[Midnightbsd-cvs] src [6439] U trunk/contrib/perl: perl 5.18.1 merge
laffer1 at midnightbsd.org
laffer1 at midnightbsd.org
Mon Dec 2 16:26:16 EST 2013
Revision: 6439
http://svnweb.midnightbsd.org/src/?rev=6439
Author: laffer1
Date: 2013-12-02 16:26:09 -0500 (Mon, 02 Dec 2013)
Log Message:
-----------
perl 5.18.1 merge
Modified Paths:
--------------
trunk/contrib/perl/haiku/Haiku/Haiku.pm
trunk/contrib/perl/haiku/Haiku/Haiku.xs
trunk/contrib/perl/hints/aix.sh
trunk/contrib/perl/hints/catamount.sh
trunk/contrib/perl/hints/cygwin.sh
trunk/contrib/perl/hints/dec_osf.sh
trunk/contrib/perl/hints/dgux.sh
trunk/contrib/perl/hints/freebsd.sh
trunk/contrib/perl/hints/gnu.sh
trunk/contrib/perl/hints/gnukfreebsd.sh
trunk/contrib/perl/hints/gnuknetbsd.sh
trunk/contrib/perl/hints/haiku.sh
trunk/contrib/perl/hints/hpux.sh
trunk/contrib/perl/hints/linux.sh
trunk/contrib/perl/hints/midnightbsd.sh
trunk/contrib/perl/hints/netbsd.sh
trunk/contrib/perl/hints/powerux.sh
trunk/contrib/perl/hints/solaris_2.sh
trunk/contrib/perl/hints/uwin.sh
trunk/contrib/perl/hints/vos.sh
trunk/contrib/perl/lib/AnyDBM_File.pm
trunk/contrib/perl/lib/AnyDBM_File.t
trunk/contrib/perl/lib/Benchmark.pm
trunk/contrib/perl/lib/Benchmark.t
trunk/contrib/perl/lib/CORE.pod
trunk/contrib/perl/lib/Class/Struct.pm
trunk/contrib/perl/lib/Class/Struct.t
trunk/contrib/perl/lib/DB.pm
trunk/contrib/perl/lib/DB.t
trunk/contrib/perl/lib/DBM_Filter/t/int32.t
trunk/contrib/perl/lib/DBM_Filter.pm
trunk/contrib/perl/lib/English.pm
trunk/contrib/perl/lib/Exporter.pm
trunk/contrib/perl/lib/Exporter.t
trunk/contrib/perl/lib/ExtUtils/t/Embed.t
trunk/contrib/perl/lib/ExtUtils/typemap
trunk/contrib/perl/lib/File/Basename.pm
trunk/contrib/perl/lib/File/Basename.t
trunk/contrib/perl/lib/File/Compare.t
trunk/contrib/perl/lib/File/Copy.pm
trunk/contrib/perl/lib/File/Copy.t
trunk/contrib/perl/lib/File/Find/t/find.t
trunk/contrib/perl/lib/File/Find/t/taint.t
trunk/contrib/perl/lib/File/Find.pm
trunk/contrib/perl/lib/File/stat.pm
trunk/contrib/perl/lib/File/stat.t
trunk/contrib/perl/lib/FileHandle.t
trunk/contrib/perl/lib/FindBin.pm
trunk/contrib/perl/lib/Getopt/Std.pm
trunk/contrib/perl/lib/Internals.t
trunk/contrib/perl/lib/PerlIO.pm
trunk/contrib/perl/lib/Tie/Array.pm
trunk/contrib/perl/lib/Tie/Handle/stdhandle.t
trunk/contrib/perl/lib/Tie/StdHandle.pm
trunk/contrib/perl/lib/UNIVERSAL.pm
trunk/contrib/perl/lib/Unicode/UCD.pm
trunk/contrib/perl/lib/Unicode/UCD.t
trunk/contrib/perl/lib/charnames.pm
trunk/contrib/perl/lib/charnames.t
trunk/contrib/perl/lib/dbm_filter_util.pl
trunk/contrib/perl/lib/diagnostics.pm
trunk/contrib/perl/lib/diagnostics.t
trunk/contrib/perl/lib/dumpvar.pl
trunk/contrib/perl/lib/dumpvar.t
trunk/contrib/perl/lib/feature/unicode_strings.t
trunk/contrib/perl/lib/feature.pm
trunk/contrib/perl/lib/filetest.pm
trunk/contrib/perl/lib/filetest.t
trunk/contrib/perl/lib/h2xs.t
trunk/contrib/perl/lib/locale.pm
trunk/contrib/perl/lib/locale.t
trunk/contrib/perl/lib/open.pm
trunk/contrib/perl/lib/open.t
trunk/contrib/perl/lib/overload/numbers.pm
trunk/contrib/perl/lib/overload.pm
trunk/contrib/perl/lib/overload.t
trunk/contrib/perl/lib/overloading.pm
trunk/contrib/perl/lib/overloading.t
trunk/contrib/perl/lib/perl5db.pl
trunk/contrib/perl/lib/perl5db.t
trunk/contrib/perl/lib/sigtrap.pm
trunk/contrib/perl/lib/sort.pm
trunk/contrib/perl/lib/strict.pm
trunk/contrib/perl/lib/subs.pm
trunk/contrib/perl/lib/unicore/ArabicShaping.txt
trunk/contrib/perl/lib/unicore/BidiMirroring.txt
trunk/contrib/perl/lib/unicore/Blocks.txt
trunk/contrib/perl/lib/unicore/CJKRadicals.txt
trunk/contrib/perl/lib/unicore/CaseFolding.txt
trunk/contrib/perl/lib/unicore/CompositionExclusions.txt
trunk/contrib/perl/lib/unicore/DAge.txt
trunk/contrib/perl/lib/unicore/DCoreProperties.txt
trunk/contrib/perl/lib/unicore/DNormalizationProps.txt
trunk/contrib/perl/lib/unicore/EastAsianWidth.txt
trunk/contrib/perl/lib/unicore/EmojiSources.txt
trunk/contrib/perl/lib/unicore/HangulSyllableType.txt
trunk/contrib/perl/lib/unicore/Index.txt
trunk/contrib/perl/lib/unicore/IndicMatraCategory.txt
trunk/contrib/perl/lib/unicore/IndicSyllabicCategory.txt
trunk/contrib/perl/lib/unicore/Jamo.txt
trunk/contrib/perl/lib/unicore/LineBreak.txt
trunk/contrib/perl/lib/unicore/Makefile
trunk/contrib/perl/lib/unicore/NameAliases.txt
trunk/contrib/perl/lib/unicore/NamedSequences.txt
trunk/contrib/perl/lib/unicore/NamedSqProv.txt
trunk/contrib/perl/lib/unicore/NamesList.txt
trunk/contrib/perl/lib/unicore/NormalizationCorrections.txt
trunk/contrib/perl/lib/unicore/PropList.txt
trunk/contrib/perl/lib/unicore/PropValueAliases.txt
trunk/contrib/perl/lib/unicore/PropertyAliases.txt
trunk/contrib/perl/lib/unicore/README.perl
trunk/contrib/perl/lib/unicore/ReadMe.txt
trunk/contrib/perl/lib/unicore/ScriptExtensions.txt
trunk/contrib/perl/lib/unicore/Scripts.txt
trunk/contrib/perl/lib/unicore/SpecialCasing.txt
trunk/contrib/perl/lib/unicore/StandardizedVariants.txt
trunk/contrib/perl/lib/unicore/UnicodeData.txt
trunk/contrib/perl/lib/unicore/auxiliary/GCBTest.txt
trunk/contrib/perl/lib/unicore/auxiliary/GraphemeBreakProperty.txt
trunk/contrib/perl/lib/unicore/auxiliary/SentenceBreakProperty.txt
trunk/contrib/perl/lib/unicore/auxiliary/WordBreakProperty.txt
trunk/contrib/perl/lib/unicore/extracted/DBidiClass.txt
trunk/contrib/perl/lib/unicore/extracted/DBinaryProperties.txt
trunk/contrib/perl/lib/unicore/extracted/DCombiningClass.txt
trunk/contrib/perl/lib/unicore/extracted/DDecompositionType.txt
trunk/contrib/perl/lib/unicore/extracted/DEastAsianWidth.txt
trunk/contrib/perl/lib/unicore/extracted/DGeneralCategory.txt
trunk/contrib/perl/lib/unicore/extracted/DJoinGroup.txt
trunk/contrib/perl/lib/unicore/extracted/DJoinType.txt
trunk/contrib/perl/lib/unicore/extracted/DLineBreak.txt
trunk/contrib/perl/lib/unicore/extracted/DNumType.txt
trunk/contrib/perl/lib/unicore/extracted/DNumValues.txt
trunk/contrib/perl/lib/unicore/mktables
trunk/contrib/perl/lib/unicore/version
trunk/contrib/perl/lib/utf8.pm
trunk/contrib/perl/lib/utf8.t
trunk/contrib/perl/lib/utf8_heavy.pl
trunk/contrib/perl/lib/vars.pm
trunk/contrib/perl/lib/version/Internals.pod
trunk/contrib/perl/lib/version.pm
trunk/contrib/perl/lib/version.pod
trunk/contrib/perl/lib/vmsish.pm
trunk/contrib/perl/lib/warnings.pm
trunk/contrib/perl/symbian/PerlBase.cpp
trunk/contrib/perl/symbian/config.sh
trunk/contrib/perl/t/TEST
trunk/contrib/perl/t/base/lex.t
trunk/contrib/perl/t/benchmark/rt26188-speed-up-keys-on-empty-hash.t
trunk/contrib/perl/t/cmd/for.t
trunk/contrib/perl/t/comp/bproto.t
trunk/contrib/perl/t/comp/fold.t
trunk/contrib/perl/t/comp/form_scope.t
trunk/contrib/perl/t/comp/hints.t
trunk/contrib/perl/t/comp/parser.t
trunk/contrib/perl/t/comp/proto.t
trunk/contrib/perl/t/comp/require.t
trunk/contrib/perl/t/comp/retainedlines.t
trunk/contrib/perl/t/comp/uproto.t
trunk/contrib/perl/t/comp/use.t
trunk/contrib/perl/t/harness
trunk/contrib/perl/t/io/crlf.t
trunk/contrib/perl/t/io/eintr.t
trunk/contrib/perl/t/io/errno.t
trunk/contrib/perl/t/io/fs.t
trunk/contrib/perl/t/io/inplace.t
trunk/contrib/perl/t/io/layers.t
trunk/contrib/perl/t/io/open.t
trunk/contrib/perl/t/io/perlio.t
trunk/contrib/perl/t/io/pipe.t
trunk/contrib/perl/t/io/print.t
trunk/contrib/perl/t/io/say.t
trunk/contrib/perl/t/io/tell.t
trunk/contrib/perl/t/io/utf8.t
trunk/contrib/perl/t/lib/1_compile.t
trunk/contrib/perl/t/lib/charnames/alias
trunk/contrib/perl/t/lib/common.pl
trunk/contrib/perl/t/lib/commonsense.t
trunk/contrib/perl/t/lib/croak.t
trunk/contrib/perl/t/lib/dbmt_common.pl
trunk/contrib/perl/t/lib/feature/bundle
trunk/contrib/perl/t/lib/feature/implicit
trunk/contrib/perl/t/lib/feature/switch
trunk/contrib/perl/t/lib/h2ph.h
trunk/contrib/perl/t/lib/proxy_constant_subs.t
trunk/contrib/perl/t/lib/strict/refs
trunk/contrib/perl/t/lib/strict/subs
trunk/contrib/perl/t/lib/strict/vars
trunk/contrib/perl/t/lib/subs/subs
trunk/contrib/perl/t/lib/universal.t
trunk/contrib/perl/t/lib/warnings/1global
trunk/contrib/perl/t/lib/warnings/2use
trunk/contrib/perl/t/lib/warnings/9enabled
trunk/contrib/perl/t/lib/warnings/9uninit
trunk/contrib/perl/t/lib/warnings/doio
trunk/contrib/perl/t/lib/warnings/gv
trunk/contrib/perl/t/lib/warnings/op
trunk/contrib/perl/t/lib/warnings/pad
trunk/contrib/perl/t/lib/warnings/perl
trunk/contrib/perl/t/lib/warnings/perly
trunk/contrib/perl/t/lib/warnings/pp
trunk/contrib/perl/t/lib/warnings/pp_hot
trunk/contrib/perl/t/lib/warnings/pp_sys
trunk/contrib/perl/t/lib/warnings/regcomp
trunk/contrib/perl/t/lib/warnings/sv
trunk/contrib/perl/t/lib/warnings/toke
trunk/contrib/perl/t/lib/warnings/universal
trunk/contrib/perl/t/lib/warnings/utf8
trunk/contrib/perl/t/lib/warnings/util
trunk/contrib/perl/t/mro/basic.t
trunk/contrib/perl/t/mro/c3_with_overload.t
trunk/contrib/perl/t/mro/inconsistent_c3.t
trunk/contrib/perl/t/mro/isa_aliases.t
trunk/contrib/perl/t/mro/isa_c3.t
trunk/contrib/perl/t/mro/isa_dfs.t
trunk/contrib/perl/t/mro/method_caching.t
trunk/contrib/perl/t/mro/next_edgecases.t
trunk/contrib/perl/t/mro/overload_c3.t
trunk/contrib/perl/t/mro/overload_dfs.t
trunk/contrib/perl/t/mro/package_aliases.t
trunk/contrib/perl/t/op/alarm.t
trunk/contrib/perl/t/op/anonsub.t
trunk/contrib/perl/t/op/append.t
trunk/contrib/perl/t/op/args.t
trunk/contrib/perl/t/op/array.t
trunk/contrib/perl/t/op/array_base.t
trunk/contrib/perl/t/op/assignwarn.t
trunk/contrib/perl/t/op/attrs.t
trunk/contrib/perl/t/op/auto.t
trunk/contrib/perl/t/op/blocks.t
trunk/contrib/perl/t/op/bop.t
trunk/contrib/perl/t/op/caller.t
trunk/contrib/perl/t/op/chars.t
trunk/contrib/perl/t/op/chop.t
trunk/contrib/perl/t/op/chr.t
trunk/contrib/perl/t/op/closure.t
trunk/contrib/perl/t/op/concat2.t
trunk/contrib/perl/t/op/cond.t
trunk/contrib/perl/t/op/cproto.t
trunk/contrib/perl/t/op/dbm.t
trunk/contrib/perl/t/op/defins.t
trunk/contrib/perl/t/op/die.t
trunk/contrib/perl/t/op/die_except.t
trunk/contrib/perl/t/op/die_exit.t
trunk/contrib/perl/t/op/die_keeperr.t
trunk/contrib/perl/t/op/die_unwind.t
trunk/contrib/perl/t/op/do.t
trunk/contrib/perl/t/op/dor.t
trunk/contrib/perl/t/op/each.t
trunk/contrib/perl/t/op/each_array.t
trunk/contrib/perl/t/op/eval.t
trunk/contrib/perl/t/op/exec.t
trunk/contrib/perl/t/op/exists_sub.t
trunk/contrib/perl/t/op/exp.t
trunk/contrib/perl/t/op/fh.t
trunk/contrib/perl/t/op/filehandle.t
trunk/contrib/perl/t/op/filetest.t
trunk/contrib/perl/t/op/filetest_stack_ok.t
trunk/contrib/perl/t/op/filetest_t.t
trunk/contrib/perl/t/op/fork.t
trunk/contrib/perl/t/op/getpid.t
trunk/contrib/perl/t/op/getppid.t
trunk/contrib/perl/t/op/glob.t
trunk/contrib/perl/t/op/gmagic.t
trunk/contrib/perl/t/op/goto.t
trunk/contrib/perl/t/op/grent.t
trunk/contrib/perl/t/op/grep.t
trunk/contrib/perl/t/op/groups.t
trunk/contrib/perl/t/op/gv.t
trunk/contrib/perl/t/op/hash.t
trunk/contrib/perl/t/op/hashassign.t
trunk/contrib/perl/t/op/inc.t
trunk/contrib/perl/t/op/inccode.t
trunk/contrib/perl/t/op/incfilter.t
trunk/contrib/perl/t/op/index.t
trunk/contrib/perl/t/op/int.t
trunk/contrib/perl/t/op/join.t
trunk/contrib/perl/t/op/lc.t
trunk/contrib/perl/t/op/leaky-magic.t
trunk/contrib/perl/t/op/length.t
trunk/contrib/perl/t/op/lex.t
trunk/contrib/perl/t/op/lex_assign.t
trunk/contrib/perl/t/op/list.t
trunk/contrib/perl/t/op/local.t
trunk/contrib/perl/t/op/loopctl.t
trunk/contrib/perl/t/op/lop.t
trunk/contrib/perl/t/op/magic.t
trunk/contrib/perl/t/op/method.t
trunk/contrib/perl/t/op/mkdir.t
trunk/contrib/perl/t/op/my.t
trunk/contrib/perl/t/op/mydef.t
trunk/contrib/perl/t/op/negate.t
trunk/contrib/perl/t/op/not.t
trunk/contrib/perl/t/op/oct.t
trunk/contrib/perl/t/op/or.t
trunk/contrib/perl/t/op/overload_integer.t
trunk/contrib/perl/t/op/override.t
trunk/contrib/perl/t/op/pack.t
trunk/contrib/perl/t/op/pos.t
trunk/contrib/perl/t/op/pow.t
trunk/contrib/perl/t/op/print.t
trunk/contrib/perl/t/op/push.t
trunk/contrib/perl/t/op/pwent.t
trunk/contrib/perl/t/op/qr.t
trunk/contrib/perl/t/op/quotemeta.t
trunk/contrib/perl/t/op/range.t
trunk/contrib/perl/t/op/readdir.t
trunk/contrib/perl/t/op/readline.t
trunk/contrib/perl/t/op/ref.t
trunk/contrib/perl/t/op/require_errors.t
trunk/contrib/perl/t/op/reset.t
trunk/contrib/perl/t/op/reverse.t
trunk/contrib/perl/t/op/setpgrpstack.t
trunk/contrib/perl/t/op/sigdispatch.t
trunk/contrib/perl/t/op/smartkve.t
trunk/contrib/perl/t/op/smartmatch.t
trunk/contrib/perl/t/op/sort.t
trunk/contrib/perl/t/op/splice.t
trunk/contrib/perl/t/op/split.t
trunk/contrib/perl/t/op/split_unicode.t
trunk/contrib/perl/t/op/sprintf.t
trunk/contrib/perl/t/op/sprintf2.t
trunk/contrib/perl/t/op/srand.t
trunk/contrib/perl/t/op/sselect.t
trunk/contrib/perl/t/op/stash.t
trunk/contrib/perl/t/op/stat.t
trunk/contrib/perl/t/op/state.t
trunk/contrib/perl/t/op/study.t
trunk/contrib/perl/t/op/sub.t
trunk/contrib/perl/t/op/sub_lval.t
trunk/contrib/perl/t/op/svleak.t
trunk/contrib/perl/t/op/switch.t
trunk/contrib/perl/t/op/sysio.t
trunk/contrib/perl/t/op/taint.t
trunk/contrib/perl/t/op/threads.t
trunk/contrib/perl/t/op/tie.t
trunk/contrib/perl/t/op/tie_fetch_count.t
trunk/contrib/perl/t/op/tr.t
trunk/contrib/perl/t/op/undef.t
trunk/contrib/perl/t/op/universal.t
trunk/contrib/perl/t/op/utf8cache.t
trunk/contrib/perl/t/op/utf8decode.t
trunk/contrib/perl/t/op/utf8magic.t
trunk/contrib/perl/t/op/ver.t
trunk/contrib/perl/t/op/warn.t
trunk/contrib/perl/t/op/write.t
trunk/contrib/perl/t/porting/args_assert.t
trunk/contrib/perl/t/porting/authors.t
trunk/contrib/perl/t/porting/checkcase.t
trunk/contrib/perl/t/porting/cmp_version.t
trunk/contrib/perl/t/porting/diag.t
trunk/contrib/perl/t/porting/dual-life.t
trunk/contrib/perl/t/porting/exec-bit.t
trunk/contrib/perl/t/porting/filenames.t
trunk/contrib/perl/t/porting/maintainers.t
trunk/contrib/perl/t/porting/manifest.t
trunk/contrib/perl/t/porting/podcheck.t
trunk/contrib/perl/t/porting/regen.t
trunk/contrib/perl/t/porting/test_bootstrap.t
trunk/contrib/perl/t/re/charset.t
trunk/contrib/perl/t/re/fold_grind.t
trunk/contrib/perl/t/re/no_utf8_pm.t
trunk/contrib/perl/t/re/overload.t
trunk/contrib/perl/t/re/pat.t
trunk/contrib/perl/t/re/pat_advanced.t
trunk/contrib/perl/t/re/pat_psycho.t
trunk/contrib/perl/t/re/pat_re_eval.t
trunk/contrib/perl/t/re/pat_rt_report.t
trunk/contrib/perl/t/re/qr.t
trunk/contrib/perl/t/re/re_tests
trunk/contrib/perl/t/re/reg_email.t
trunk/contrib/perl/t/re/reg_eval_scope.t
trunk/contrib/perl/t/re/reg_fold.t
trunk/contrib/perl/t/re/reg_mesg.t
trunk/contrib/perl/t/re/reg_pmod.t
trunk/contrib/perl/t/re/reg_posixcc.t
trunk/contrib/perl/t/re/regexp.t
trunk/contrib/perl/t/re/regexp_noamp.t
trunk/contrib/perl/t/re/regexp_unicode_prop.t
trunk/contrib/perl/t/re/rxcode.t
trunk/contrib/perl/t/re/subst.t
trunk/contrib/perl/t/run/cloexec.t
trunk/contrib/perl/t/run/fresh_perl.t
trunk/contrib/perl/t/run/locale.t
trunk/contrib/perl/t/run/noswitch.t
trunk/contrib/perl/t/run/runenv.t
trunk/contrib/perl/t/run/script.t
trunk/contrib/perl/t/run/switch0.t
trunk/contrib/perl/t/run/switchC.t
trunk/contrib/perl/t/run/switchF.t
trunk/contrib/perl/t/run/switchF1.t
trunk/contrib/perl/t/run/switchI.t
trunk/contrib/perl/t/run/switcha.t
trunk/contrib/perl/t/run/switchd.t
trunk/contrib/perl/t/run/switches.t
trunk/contrib/perl/t/run/switchn.t
trunk/contrib/perl/t/run/switchp.t
trunk/contrib/perl/t/run/switchx.aux
trunk/contrib/perl/t/run/switchx.t
trunk/contrib/perl/t/run/switchx2.aux
trunk/contrib/perl/t/test.pl
trunk/contrib/perl/t/uni/cache.t
trunk/contrib/perl/t/uni/case.pl
trunk/contrib/perl/t/uni/chr.t
trunk/contrib/perl/t/uni/class.t
trunk/contrib/perl/t/uni/fold.t
trunk/contrib/perl/t/uni/greek.t
trunk/contrib/perl/t/uni/latin2.t
trunk/contrib/perl/t/uni/lex_utf8.t
trunk/contrib/perl/t/uni/lower.t
trunk/contrib/perl/t/uni/overload.t
trunk/contrib/perl/t/uni/tie.t
trunk/contrib/perl/t/uni/title.t
trunk/contrib/perl/t/uni/tr_7jis.t
trunk/contrib/perl/t/uni/tr_eucjp.t
trunk/contrib/perl/t/uni/tr_sjis.t
trunk/contrib/perl/t/uni/tr_utf8.t
trunk/contrib/perl/t/uni/upper.t
trunk/contrib/perl/t/uni/write.t
trunk/contrib/perl/t/win32/system.t
trunk/contrib/perl/t/x2p/s2p.t
trunk/contrib/perl/vms/descrip_mms.template
trunk/contrib/perl/vms/ext/filespec.t
trunk/contrib/perl/vms/gen_shrfls.pl
trunk/contrib/perl/vms/vms.c
trunk/contrib/perl/vms/vmsish.h
trunk/contrib/perl/vos/vos.c
trunk/contrib/perl/vos/vosish.h
trunk/contrib/perl/win32/Makefile
trunk/contrib/perl/win32/Makefile.ce
trunk/contrib/perl/win32/bin/pl2bat.pl
trunk/contrib/perl/win32/bin/runperl.pl
trunk/contrib/perl/win32/bin/search.pl
trunk/contrib/perl/win32/ce-helpers/cecopy-lib.pl
trunk/contrib/perl/win32/config.ce
trunk/contrib/perl/win32/config.gc
trunk/contrib/perl/win32/config.vc
trunk/contrib/perl/win32/config_H.ce
trunk/contrib/perl/win32/config_H.gc
trunk/contrib/perl/win32/config_H.vc
trunk/contrib/perl/win32/config_h.PL
trunk/contrib/perl/win32/config_sh.PL
trunk/contrib/perl/win32/fcrypt.c
trunk/contrib/perl/win32/include/sys/socket.h
trunk/contrib/perl/win32/makefile.mk
trunk/contrib/perl/win32/perlglob.c
trunk/contrib/perl/win32/perlhost.h
trunk/contrib/perl/win32/perllib.c
trunk/contrib/perl/win32/pod.mak
trunk/contrib/perl/win32/vmem.h
trunk/contrib/perl/win32/win32.c
trunk/contrib/perl/win32/win32.h
trunk/contrib/perl/win32/win32io.c
trunk/contrib/perl/win32/win32iop-o.h
trunk/contrib/perl/win32/win32iop.h
trunk/contrib/perl/win32/win32sck.c
trunk/contrib/perl/win32/win32thread.h
trunk/contrib/perl/win32/wince.c
trunk/contrib/perl/win32/wincesck.c
trunk/contrib/perl/x2p/Makefile.SH
trunk/contrib/perl/x2p/a2p.c
trunk/contrib/perl/x2p/a2p.h
trunk/contrib/perl/x2p/a2p.pod
trunk/contrib/perl/x2p/a2p.y
trunk/contrib/perl/x2p/a2py.c
trunk/contrib/perl/x2p/cflags.SH
trunk/contrib/perl/x2p/hash.c
trunk/contrib/perl/x2p/s2p.PL
trunk/contrib/perl/x2p/str.c
trunk/contrib/perl/x2p/util.c
trunk/contrib/perl/x2p/walk.c
Added Paths:
-----------
trunk/contrib/perl/hints/machten.sh
trunk/contrib/perl/hints/machten_2.sh
trunk/contrib/perl/lib/Archive/
trunk/contrib/perl/lib/Attribute/
trunk/contrib/perl/lib/AutoLoader/
trunk/contrib/perl/lib/AutoLoader.pm
trunk/contrib/perl/lib/AutoLoader.t
trunk/contrib/perl/lib/AutoSplit.pm
trunk/contrib/perl/lib/AutoSplit.t
trunk/contrib/perl/lib/CGI/
trunk/contrib/perl/lib/CGI.pm
trunk/contrib/perl/lib/CPAN/
trunk/contrib/perl/lib/CPAN.pm
trunk/contrib/perl/lib/CPANPLUS/
trunk/contrib/perl/lib/CPANPLUS.pm
trunk/contrib/perl/lib/Class/ISA/
trunk/contrib/perl/lib/Class/ISA.pm
trunk/contrib/perl/lib/Cwd.pm
trunk/contrib/perl/lib/Devel/
trunk/contrib/perl/lib/Digest/
trunk/contrib/perl/lib/Digest.pm
trunk/contrib/perl/lib/Dumpvalue.pm
trunk/contrib/perl/lib/Dumpvalue.t
trunk/contrib/perl/lib/Env/
trunk/contrib/perl/lib/Env.pm
trunk/contrib/perl/lib/ExtUtils/CBuilder/
trunk/contrib/perl/lib/ExtUtils/CBuilder.pm
trunk/contrib/perl/lib/ExtUtils/Command/
trunk/contrib/perl/lib/ExtUtils/Command.pm
trunk/contrib/perl/lib/ExtUtils/Constant/
trunk/contrib/perl/lib/ExtUtils/Constant.pm
trunk/contrib/perl/lib/ExtUtils/Install.pm
trunk/contrib/perl/lib/ExtUtils/Installed.pm
trunk/contrib/perl/lib/ExtUtils/Liblist/
trunk/contrib/perl/lib/ExtUtils/Liblist.pm
trunk/contrib/perl/lib/ExtUtils/MANIFEST.SKIP
trunk/contrib/perl/lib/ExtUtils/MM.pm
trunk/contrib/perl/lib/ExtUtils/MM_AIX.pm
trunk/contrib/perl/lib/ExtUtils/MM_Any.pm
trunk/contrib/perl/lib/ExtUtils/MM_BeOS.pm
trunk/contrib/perl/lib/ExtUtils/MM_Cygwin.pm
trunk/contrib/perl/lib/ExtUtils/MM_DOS.pm
trunk/contrib/perl/lib/ExtUtils/MM_Darwin.pm
trunk/contrib/perl/lib/ExtUtils/MM_MacOS.pm
trunk/contrib/perl/lib/ExtUtils/MM_NW5.pm
trunk/contrib/perl/lib/ExtUtils/MM_OS2.pm
trunk/contrib/perl/lib/ExtUtils/MM_QNX.pm
trunk/contrib/perl/lib/ExtUtils/MM_UWIN.pm
trunk/contrib/perl/lib/ExtUtils/MM_Unix.pm
trunk/contrib/perl/lib/ExtUtils/MM_VMS.pm
trunk/contrib/perl/lib/ExtUtils/MM_VOS.pm
trunk/contrib/perl/lib/ExtUtils/MM_Win32.pm
trunk/contrib/perl/lib/ExtUtils/MM_Win95.pm
trunk/contrib/perl/lib/ExtUtils/MY.pm
trunk/contrib/perl/lib/ExtUtils/MakeMaker/
trunk/contrib/perl/lib/ExtUtils/MakeMaker.pm
trunk/contrib/perl/lib/ExtUtils/Manifest.pm
trunk/contrib/perl/lib/ExtUtils/Mkbootstrap.pm
trunk/contrib/perl/lib/ExtUtils/Mksymlists.pm
trunk/contrib/perl/lib/ExtUtils/NOTES
trunk/contrib/perl/lib/ExtUtils/PATCHING
trunk/contrib/perl/lib/ExtUtils/Packlist.pm
trunk/contrib/perl/lib/ExtUtils/ParseXS/
trunk/contrib/perl/lib/ExtUtils/ParseXS.pm
trunk/contrib/perl/lib/ExtUtils/README
trunk/contrib/perl/lib/ExtUtils/TODO
trunk/contrib/perl/lib/ExtUtils/instmodsh
trunk/contrib/perl/lib/ExtUtils/t/00compile.t
trunk/contrib/perl/lib/ExtUtils/t/Constant.t
trunk/contrib/perl/lib/ExtUtils/t/FIRST_MAKEFILE.t
trunk/contrib/perl/lib/ExtUtils/t/INST.t
trunk/contrib/perl/lib/ExtUtils/t/INSTALL_BASE.t
trunk/contrib/perl/lib/ExtUtils/t/INST_PREFIX.t
trunk/contrib/perl/lib/ExtUtils/t/Install.t
trunk/contrib/perl/lib/ExtUtils/t/InstallWithMM.t
trunk/contrib/perl/lib/ExtUtils/t/Installapi2.t
trunk/contrib/perl/lib/ExtUtils/t/Installed.t
trunk/contrib/perl/lib/ExtUtils/t/Liblist.t
trunk/contrib/perl/lib/ExtUtils/t/MM_Any.t
trunk/contrib/perl/lib/ExtUtils/t/MM_BeOS.t
trunk/contrib/perl/lib/ExtUtils/t/MM_Cygwin.t
trunk/contrib/perl/lib/ExtUtils/t/MM_NW5.t
trunk/contrib/perl/lib/ExtUtils/t/MM_OS2.t
trunk/contrib/perl/lib/ExtUtils/t/MM_Unix.t
trunk/contrib/perl/lib/ExtUtils/t/MM_VMS.t
trunk/contrib/perl/lib/ExtUtils/t/MM_Win32.t
trunk/contrib/perl/lib/ExtUtils/t/MakeMaker_Parameters.t
trunk/contrib/perl/lib/ExtUtils/t/Manifest.t
trunk/contrib/perl/lib/ExtUtils/t/Mkbootstrap.t
trunk/contrib/perl/lib/ExtUtils/t/PL_FILES.t
trunk/contrib/perl/lib/ExtUtils/t/Packlist.t
trunk/contrib/perl/lib/ExtUtils/t/VERSION_FROM.t
trunk/contrib/perl/lib/ExtUtils/t/WriteEmptyMakefile.t
trunk/contrib/perl/lib/ExtUtils/t/arch_check.t
trunk/contrib/perl/lib/ExtUtils/t/backwards.t
trunk/contrib/perl/lib/ExtUtils/t/basic.t
trunk/contrib/perl/lib/ExtUtils/t/build_man.t
trunk/contrib/perl/lib/ExtUtils/t/bytes.t
trunk/contrib/perl/lib/ExtUtils/t/can_write_dir.t
trunk/contrib/perl/lib/ExtUtils/t/cd.t
trunk/contrib/perl/lib/ExtUtils/t/config.t
trunk/contrib/perl/lib/ExtUtils/t/cp.t
trunk/contrib/perl/lib/ExtUtils/t/dir_target.t
trunk/contrib/perl/lib/ExtUtils/t/eu_command.t
trunk/contrib/perl/lib/ExtUtils/t/fix_libs.t
trunk/contrib/perl/lib/ExtUtils/t/fixin.t
trunk/contrib/perl/lib/ExtUtils/t/hints.t
trunk/contrib/perl/lib/ExtUtils/t/installed_file.t
trunk/contrib/perl/lib/ExtUtils/t/is_of_type.t
trunk/contrib/perl/lib/ExtUtils/t/make.t
trunk/contrib/perl/lib/ExtUtils/t/maketext_filter.t
trunk/contrib/perl/lib/ExtUtils/t/metafile_data.t
trunk/contrib/perl/lib/ExtUtils/t/metafile_file.t
trunk/contrib/perl/lib/ExtUtils/t/min_perl_version.t
trunk/contrib/perl/lib/ExtUtils/t/miniperl.t
trunk/contrib/perl/lib/ExtUtils/t/oneliner.t
trunk/contrib/perl/lib/ExtUtils/t/parse_version.t
trunk/contrib/perl/lib/ExtUtils/t/pm.t
trunk/contrib/perl/lib/ExtUtils/t/pm_to_blib.t
trunk/contrib/perl/lib/ExtUtils/t/pod2man.t
trunk/contrib/perl/lib/ExtUtils/t/postamble.t
trunk/contrib/perl/lib/ExtUtils/t/prefixify.t
trunk/contrib/perl/lib/ExtUtils/t/prereq.t
trunk/contrib/perl/lib/ExtUtils/t/prereq_print.t
trunk/contrib/perl/lib/ExtUtils/t/problems.t
trunk/contrib/perl/lib/ExtUtils/t/prompt.t
trunk/contrib/perl/lib/ExtUtils/t/recurs.t
trunk/contrib/perl/lib/ExtUtils/t/revision.t
trunk/contrib/perl/lib/ExtUtils/t/split_command.t
trunk/contrib/perl/lib/ExtUtils/t/test_boilerplate.t
trunk/contrib/perl/lib/ExtUtils/t/testdata/
trunk/contrib/perl/lib/ExtUtils/t/testlib.t
trunk/contrib/perl/lib/ExtUtils/t/writemakefile_args.t
trunk/contrib/perl/lib/ExtUtils/t/xs.t
trunk/contrib/perl/lib/ExtUtils/testlib.pm
trunk/contrib/perl/lib/ExtUtils/xsubpp
trunk/contrib/perl/lib/Fatal.pm
trunk/contrib/perl/lib/Fatal.t
trunk/contrib/perl/lib/File/CheckTree.pm
trunk/contrib/perl/lib/File/CheckTree.t
trunk/contrib/perl/lib/File/Fetch/
trunk/contrib/perl/lib/File/Fetch.pm
trunk/contrib/perl/lib/File/Path.pm
trunk/contrib/perl/lib/File/Path.t
trunk/contrib/perl/lib/File/Spec/
trunk/contrib/perl/lib/File/Spec.pm
trunk/contrib/perl/lib/File/Temp/
trunk/contrib/perl/lib/File/Temp.pm
trunk/contrib/perl/lib/File/stat-7896.t
trunk/contrib/perl/lib/FileCache/
trunk/contrib/perl/lib/FileCache.pm
trunk/contrib/perl/lib/Filter/
trunk/contrib/perl/lib/Getopt/Long/
trunk/contrib/perl/lib/Getopt/Long.pm
trunk/contrib/perl/lib/I18N/
trunk/contrib/perl/lib/IO/
trunk/contrib/perl/lib/IPC/
trunk/contrib/perl/lib/Locale/
trunk/contrib/perl/lib/Log/
trunk/contrib/perl/lib/Math/
trunk/contrib/perl/lib/Memoize/
trunk/contrib/perl/lib/Memoize.pm
trunk/contrib/perl/lib/Module/
trunk/contrib/perl/lib/NEXT/
trunk/contrib/perl/lib/NEXT.pm
trunk/contrib/perl/lib/Net/Cmd.pm
trunk/contrib/perl/lib/Net/Config.eg
trunk/contrib/perl/lib/Net/Config.pm
trunk/contrib/perl/lib/Net/Domain.pm
trunk/contrib/perl/lib/Net/FTP/
trunk/contrib/perl/lib/Net/FTP.pm
trunk/contrib/perl/lib/Net/Hostname.pm.eg
trunk/contrib/perl/lib/Net/NNTP.pm
trunk/contrib/perl/lib/Net/Netrc.pm
trunk/contrib/perl/lib/Net/POP3.pm
trunk/contrib/perl/lib/Net/Ping/
trunk/contrib/perl/lib/Net/Ping.pm
trunk/contrib/perl/lib/Net/README
trunk/contrib/perl/lib/Net/SMTP.pm
trunk/contrib/perl/lib/Net/Time.pm
trunk/contrib/perl/lib/Net/demos/
trunk/contrib/perl/lib/Net/libnetFAQ.pod
trunk/contrib/perl/lib/Net/t/
trunk/contrib/perl/lib/Object/
trunk/contrib/perl/lib/Package/
trunk/contrib/perl/lib/Params/
trunk/contrib/perl/lib/Parse/
trunk/contrib/perl/lib/PerlIO/
trunk/contrib/perl/lib/Pod/Checker.pm
trunk/contrib/perl/lib/Pod/Escapes/
trunk/contrib/perl/lib/Pod/Escapes.pm
trunk/contrib/perl/lib/Pod/Find.pm
trunk/contrib/perl/lib/Pod/Html.pm
trunk/contrib/perl/lib/Pod/InputObjects.pm
trunk/contrib/perl/lib/Pod/LaTeX.pm
trunk/contrib/perl/lib/Pod/Man.pm
trunk/contrib/perl/lib/Pod/ParseLink.pm
trunk/contrib/perl/lib/Pod/ParseUtils.pm
trunk/contrib/perl/lib/Pod/Parser.pm
trunk/contrib/perl/lib/Pod/Perldoc/
trunk/contrib/perl/lib/Pod/Perldoc.pm
trunk/contrib/perl/lib/Pod/PlainText.pm
trunk/contrib/perl/lib/Pod/Plainer.pm
trunk/contrib/perl/lib/Pod/Select.pm
trunk/contrib/perl/lib/Pod/Simple/
trunk/contrib/perl/lib/Pod/Simple.pm
trunk/contrib/perl/lib/Pod/Simple.pod
trunk/contrib/perl/lib/Pod/Text/
trunk/contrib/perl/lib/Pod/Text.pm
trunk/contrib/perl/lib/Pod/Usage.pm
trunk/contrib/perl/lib/Pod/t/basic.cap
trunk/contrib/perl/lib/Pod/t/basic.clr
trunk/contrib/perl/lib/Pod/t/basic.man
trunk/contrib/perl/lib/Pod/t/basic.ovr
trunk/contrib/perl/lib/Pod/t/basic.pod
trunk/contrib/perl/lib/Pod/t/basic.t
trunk/contrib/perl/lib/Pod/t/basic.txt
trunk/contrib/perl/lib/Pod/t/color.t
trunk/contrib/perl/lib/Pod/t/contains_pod.t
trunk/contrib/perl/lib/Pod/t/filehandle.t
trunk/contrib/perl/lib/Pod/t/htmlescp.pod
trunk/contrib/perl/lib/Pod/t/htmlescp.t
trunk/contrib/perl/lib/Pod/t/htmllink.pod
trunk/contrib/perl/lib/Pod/t/htmllink.t
trunk/contrib/perl/lib/Pod/t/htmlview.pod
trunk/contrib/perl/lib/Pod/t/htmlview.t
trunk/contrib/perl/lib/Pod/t/man-options.t
trunk/contrib/perl/lib/Pod/t/man-utf8.t
trunk/contrib/perl/lib/Pod/t/man.t
trunk/contrib/perl/lib/Pod/t/parselink.t
trunk/contrib/perl/lib/Pod/t/pod-parser.t
trunk/contrib/perl/lib/Pod/t/pod-spelling.t
trunk/contrib/perl/lib/Pod/t/pod.t
trunk/contrib/perl/lib/Pod/t/pod2html-lib.pl
trunk/contrib/perl/lib/Pod/t/pod2latex.t
trunk/contrib/perl/lib/Pod/t/termcap.t
trunk/contrib/perl/lib/Pod/t/text-encoding.t
trunk/contrib/perl/lib/Pod/t/text-options.t
trunk/contrib/perl/lib/Pod/t/text-utf8.t
trunk/contrib/perl/lib/Pod/t/text.t
trunk/contrib/perl/lib/Pod/t/user.t
trunk/contrib/perl/lib/SelfLoader/
trunk/contrib/perl/lib/SelfLoader-buggy.t
trunk/contrib/perl/lib/SelfLoader.pm
trunk/contrib/perl/lib/SelfLoader.t
trunk/contrib/perl/lib/Shell.pm
trunk/contrib/perl/lib/Shell.t
trunk/contrib/perl/lib/Switch/
trunk/contrib/perl/lib/Switch.pm
trunk/contrib/perl/lib/Term/ANSIColor/
trunk/contrib/perl/lib/Term/ANSIColor.pm
trunk/contrib/perl/lib/Term/Cap.pm
trunk/contrib/perl/lib/Term/Cap.t
trunk/contrib/perl/lib/Term/UI/
trunk/contrib/perl/lib/Term/UI.pm
trunk/contrib/perl/lib/Test/
trunk/contrib/perl/lib/Test.pm
trunk/contrib/perl/lib/Text/Balanced/
trunk/contrib/perl/lib/Text/Balanced.pm
trunk/contrib/perl/lib/Text/ParseWords/
trunk/contrib/perl/lib/Text/ParseWords.pm
trunk/contrib/perl/lib/Text/ParseWords.t
trunk/contrib/perl/lib/Text/Tabs.pm
trunk/contrib/perl/lib/Text/TabsWrap/
trunk/contrib/perl/lib/Text/Wrap.pm
trunk/contrib/perl/lib/Thread/
trunk/contrib/perl/lib/Tie/File/
trunk/contrib/perl/lib/Tie/File.pm
trunk/contrib/perl/lib/Tie/Hash/
trunk/contrib/perl/lib/Tie/Memoize.pm
trunk/contrib/perl/lib/Tie/Memoize.t
trunk/contrib/perl/lib/Tie/RefHash/
trunk/contrib/perl/lib/Tie/RefHash.pm
trunk/contrib/perl/lib/Time/Local.pm
trunk/contrib/perl/lib/Time/Local.t
trunk/contrib/perl/lib/Unicode/Collate/
trunk/contrib/perl/lib/Unicode/Collate.pm
trunk/contrib/perl/lib/_charnames.pm
trunk/contrib/perl/lib/attributes.pm
trunk/contrib/perl/lib/autodie/
trunk/contrib/perl/lib/autodie.pm
trunk/contrib/perl/lib/autouse.pm
trunk/contrib/perl/lib/autouse.t
trunk/contrib/perl/lib/base/
trunk/contrib/perl/lib/base.pm
trunk/contrib/perl/lib/bigint.pm
trunk/contrib/perl/lib/bignum/
trunk/contrib/perl/lib/bignum.pm
trunk/contrib/perl/lib/bigrat.pm
trunk/contrib/perl/lib/constant.pm
trunk/contrib/perl/lib/constant.t
trunk/contrib/perl/lib/encoding/
trunk/contrib/perl/lib/fields.pm
trunk/contrib/perl/lib/if.pm
trunk/contrib/perl/lib/if.t
trunk/contrib/perl/lib/lib.t
trunk/contrib/perl/lib/lib_pm.PL
trunk/contrib/perl/lib/mro.pm
trunk/contrib/perl/lib/parent/
trunk/contrib/perl/lib/parent.pm
trunk/contrib/perl/lib/perl5db/t/EnableModule.pm
trunk/contrib/perl/lib/perl5db/t/MyModule.pm
trunk/contrib/perl/lib/perl5db/t/break-on-dot
trunk/contrib/perl/lib/perl5db/t/breakpoint-bug
trunk/contrib/perl/lib/perl5db/t/disable-breakpoints-1
trunk/contrib/perl/lib/perl5db/t/disable-breakpoints-2
trunk/contrib/perl/lib/perl5db/t/disable-breakpoints-3
trunk/contrib/perl/lib/perl5db/t/fact
trunk/contrib/perl/lib/perl5db/t/filename-line-breakpoint
trunk/contrib/perl/lib/perl5db/t/load-modules
trunk/contrib/perl/lib/perl5db/t/rt-104168
trunk/contrib/perl/lib/perl5db/t/source-cmd-test-no-q.perldb
trunk/contrib/perl/lib/perl5db/t/source-cmd-test.perldb
trunk/contrib/perl/lib/perl5db/t/test-PrintRet-option-1
trunk/contrib/perl/lib/perl5db/t/test-a-statement-1
trunk/contrib/perl/lib/perl5db/t/test-dieLevel-option-1
trunk/contrib/perl/lib/perl5db/t/test-frame-option-1
trunk/contrib/perl/lib/perl5db/t/test-l-statement-1
trunk/contrib/perl/lib/perl5db/t/test-l-statement-2
trunk/contrib/perl/lib/perl5db/t/test-m-statement-1
trunk/contrib/perl/lib/perl5db/t/test-passing-at-underscore-to-x-etc
trunk/contrib/perl/lib/perl5db/t/test-r-statement
trunk/contrib/perl/lib/perl5db/t/test-w-statement-1
trunk/contrib/perl/lib/perl5db/t/test-warnLevel-option-1
trunk/contrib/perl/lib/perl5db/t/uncalled-subroutine
trunk/contrib/perl/lib/perl5db/t/with-subroutine
trunk/contrib/perl/lib/unicore/mktables.lst
trunk/contrib/perl/lib/version/t/
trunk/contrib/perl/t/Module_Pluggable/
trunk/contrib/perl/t/TestInit.pm
trunk/contrib/perl/t/bigmem/
trunk/contrib/perl/t/comp/cpp.aux
trunk/contrib/perl/t/comp/cpp.t
trunk/contrib/perl/t/comp/script.t
trunk/contrib/perl/t/io/shm.t
trunk/contrib/perl/t/lib/Count.pm
trunk/contrib/perl/t/lib/Dev/
trunk/contrib/perl/t/lib/Devel/nodb.pm
trunk/contrib/perl/t/lib/Dummy.pm
trunk/contrib/perl/t/lib/Filter/
trunk/contrib/perl/t/lib/HasSigDie.pm
trunk/contrib/perl/t/lib/MakeMaker/
trunk/contrib/perl/t/lib/Math/
trunk/contrib/perl/t/lib/NoExporter.pm
trunk/contrib/perl/t/lib/Parse/
trunk/contrib/perl/t/lib/Test/
trunk/contrib/perl/t/lib/TieIn.pm
trunk/contrib/perl/t/lib/TieOut.pm
trunk/contrib/perl/t/lib/compress/
trunk/contrib/perl/t/lib/contains_bad_pod.xr
trunk/contrib/perl/t/lib/contains_pod.xr
trunk/contrib/perl/t/lib/croak/
trunk/contrib/perl/t/lib/dprof/
trunk/contrib/perl/t/lib/filter-util.pl
trunk/contrib/perl/t/lib/manifest.t
trunk/contrib/perl/t/lib/overload_nomethod.t
trunk/contrib/perl/t/lib/sample-tests/
trunk/contrib/perl/t/lib/test_require.pm
trunk/contrib/perl/t/mro/basic_01_c3_utf8.t
trunk/contrib/perl/t/mro/basic_01_dfs_utf8.t
trunk/contrib/perl/t/mro/basic_02_c3_utf8.t
trunk/contrib/perl/t/mro/basic_02_dfs_utf8.t
trunk/contrib/perl/t/mro/basic_03_c3_utf8.t
trunk/contrib/perl/t/mro/basic_03_dfs_utf8.t
trunk/contrib/perl/t/mro/basic_04_c3_utf8.t
trunk/contrib/perl/t/mro/basic_04_dfs_utf8.t
trunk/contrib/perl/t/mro/basic_05_c3_utf8.t
trunk/contrib/perl/t/mro/basic_05_dfs_utf8.t
trunk/contrib/perl/t/mro/basic_utf8.t
trunk/contrib/perl/t/mro/c3_with_overload_utf8.t
trunk/contrib/perl/t/mro/complex_c3_utf8.t
trunk/contrib/perl/t/mro/complex_dfs_utf8.t
trunk/contrib/perl/t/mro/dbic_c3_utf8.t
trunk/contrib/perl/t/mro/dbic_dfs_utf8.t
trunk/contrib/perl/t/mro/inconsistent_c3_utf8.t
trunk/contrib/perl/t/mro/isa_aliases_utf8.t
trunk/contrib/perl/t/mro/isa_c3_utf8.t
trunk/contrib/perl/t/mro/isa_dfs_utf8.t
trunk/contrib/perl/t/mro/isarev_utf8.t
trunk/contrib/perl/t/mro/method_caching_utf8.t
trunk/contrib/perl/t/mro/next_NEXT_utf8.t
trunk/contrib/perl/t/mro/next_edgecases_utf8.t
trunk/contrib/perl/t/mro/next_goto_utf8.t
trunk/contrib/perl/t/mro/next_inanon_utf8.t
trunk/contrib/perl/t/mro/next_ineval_utf8.t
trunk/contrib/perl/t/mro/next_method_utf8.t
trunk/contrib/perl/t/mro/next_skip_utf8.t
trunk/contrib/perl/t/mro/overload_c3_utf8.t
trunk/contrib/perl/t/mro/package_aliases_utf8.t
trunk/contrib/perl/t/mro/pkg_gen_utf8.t
trunk/contrib/perl/t/mro/recursion_c3_utf8.t
trunk/contrib/perl/t/mro/recursion_dfs_utf8.t
trunk/contrib/perl/t/mro/vulcan_c3_utf8.t
trunk/contrib/perl/t/mro/vulcan_dfs_utf8.t
trunk/contrib/perl/t/op/closure_test.pl
trunk/contrib/perl/t/op/coreamp.t
trunk/contrib/perl/t/op/coresubs.t
trunk/contrib/perl/t/op/current_sub.t
trunk/contrib/perl/t/op/defined.t
trunk/contrib/perl/t/op/evalbytes.t
trunk/contrib/perl/t/op/for.t
trunk/contrib/perl/t/op/fresh_perl_utf8.t
trunk/contrib/perl/t/op/hash-rt85026.t
trunk/contrib/perl/t/op/heredoc.t
trunk/contrib/perl/t/op/lexsub.t
trunk/contrib/perl/t/op/lock.t
trunk/contrib/perl/t/op/pat.t
trunk/contrib/perl/t/op/pat_thr.t
trunk/contrib/perl/t/op/qr_gc.t
trunk/contrib/perl/t/op/qrstack.t
trunk/contrib/perl/t/op/re.t
trunk/contrib/perl/t/op/re_tests
trunk/contrib/perl/t/op/reg_email.t
trunk/contrib/perl/t/op/reg_email_thr.t
trunk/contrib/perl/t/op/reg_fold.t
trunk/contrib/perl/t/op/reg_mesg.t
trunk/contrib/perl/t/op/reg_namedcapture.t
trunk/contrib/perl/t/op/reg_nc_tie.t
trunk/contrib/perl/t/op/reg_pmod.t
trunk/contrib/perl/t/op/reg_posixcc.t
trunk/contrib/perl/t/op/reg_unsafe.t
trunk/contrib/perl/t/op/regexp.t
trunk/contrib/perl/t/op/regexp_noamp.t
trunk/contrib/perl/t/op/regexp_notrie.t
trunk/contrib/perl/t/op/regexp_qr.t
trunk/contrib/perl/t/op/regexp_qr_embed.t
trunk/contrib/perl/t/op/regexp_qr_embed_thr.t
trunk/contrib/perl/t/op/regexp_trielist.t
trunk/contrib/perl/t/op/regexp_unicode_prop.t
trunk/contrib/perl/t/op/regexp_unicode_prop_thr.t
trunk/contrib/perl/t/op/require_37033.t
trunk/contrib/perl/t/op/rxcode.t
trunk/contrib/perl/t/op/select.t
trunk/contrib/perl/t/op/sigsystem.t
trunk/contrib/perl/t/op/subst.t
trunk/contrib/perl/t/op/substT.t
trunk/contrib/perl/t/op/subst_amp.t
trunk/contrib/perl/t/op/subst_wamp.t
trunk/contrib/perl/t/op/substr.t
trunk/contrib/perl/t/op/substr_thr.t
trunk/contrib/perl/t/op/svleak.pl
trunk/contrib/perl/t/op/unlink.t
trunk/contrib/perl/t/op/while.t
trunk/contrib/perl/t/opbasic/
trunk/contrib/perl/t/pod/
trunk/contrib/perl/t/porting/checkcfgvar.t
trunk/contrib/perl/t/porting/customized.dat
trunk/contrib/perl/t/porting/customized.t
trunk/contrib/perl/t/porting/extrefs.t
trunk/contrib/perl/t/porting/globvar.t
trunk/contrib/perl/t/porting/known_pod_issues.dat
trunk/contrib/perl/t/porting/pending-author.t
trunk/contrib/perl/t/porting/perlfunc.t
trunk/contrib/perl/t/porting/pod_rules.t
trunk/contrib/perl/t/porting/utils.t
trunk/contrib/perl/t/re/pos.t
trunk/contrib/perl/t/re/recompile.t
trunk/contrib/perl/t/re/regex_sets.t
trunk/contrib/perl/t/re/regex_sets_compat.t
trunk/contrib/perl/t/run/dtrace.pl
trunk/contrib/perl/t/run/dtrace.t
trunk/contrib/perl/t/run/flib/
trunk/contrib/perl/t/run/mad.t
trunk/contrib/perl/t/run/switchM.t
trunk/contrib/perl/t/run/switchPx.aux
trunk/contrib/perl/t/run/switchPx.t
trunk/contrib/perl/t/run/switchx3.aux
trunk/contrib/perl/t/test_pl/
trunk/contrib/perl/t/uni/attrs.t
trunk/contrib/perl/t/uni/bless.t
trunk/contrib/perl/t/uni/caller.t
trunk/contrib/perl/t/uni/eval.t
trunk/contrib/perl/t/uni/goto.t
trunk/contrib/perl/t/uni/gv.t
trunk/contrib/perl/t/uni/labels.t
trunk/contrib/perl/t/uni/method.t
trunk/contrib/perl/t/uni/opcroak.t
trunk/contrib/perl/t/uni/package.t
trunk/contrib/perl/t/uni/parser.t
trunk/contrib/perl/t/uni/readline.t
trunk/contrib/perl/t/uni/select.t
trunk/contrib/perl/t/uni/stash.t
trunk/contrib/perl/t/uni/universal.t
trunk/contrib/perl/t/uni/variables.t
trunk/contrib/perl/t/win32/runenv.t
Property Changed:
----------------
trunk/contrib/perl/haiku/Haiku/Haiku.pm
trunk/contrib/perl/haiku/Haiku/Haiku.xs
trunk/contrib/perl/haiku/Haiku/Makefile.PL
trunk/contrib/perl/haiku/haikuish.h
trunk/contrib/perl/hints/3b1.sh
trunk/contrib/perl/hints/3b1cc
trunk/contrib/perl/hints/README.hints
trunk/contrib/perl/hints/aix.sh
trunk/contrib/perl/hints/aix_3.sh
trunk/contrib/perl/hints/aix_4.sh
trunk/contrib/perl/hints/altos486.sh
trunk/contrib/perl/hints/amigaos.sh
trunk/contrib/perl/hints/atheos.sh
trunk/contrib/perl/hints/aux_3.sh
trunk/contrib/perl/hints/beos.sh
trunk/contrib/perl/hints/broken-db.msg
trunk/contrib/perl/hints/bsdos.sh
trunk/contrib/perl/hints/catamount.sh
trunk/contrib/perl/hints/convexos.sh
trunk/contrib/perl/hints/cxux.sh
trunk/contrib/perl/hints/cygwin.sh
trunk/contrib/perl/hints/darwin.sh
trunk/contrib/perl/hints/dcosx.sh
trunk/contrib/perl/hints/dec_osf.sh
trunk/contrib/perl/hints/dgux.sh
trunk/contrib/perl/hints/dos_djgpp.sh
trunk/contrib/perl/hints/dragonfly.sh
trunk/contrib/perl/hints/dynix.sh
trunk/contrib/perl/hints/dynixptx.sh
trunk/contrib/perl/hints/epix.sh
trunk/contrib/perl/hints/esix4.sh
trunk/contrib/perl/hints/fps.sh
trunk/contrib/perl/hints/freebsd.sh
trunk/contrib/perl/hints/genix.sh
trunk/contrib/perl/hints/gnu.sh
trunk/contrib/perl/hints/gnukfreebsd.sh
trunk/contrib/perl/hints/gnuknetbsd.sh
trunk/contrib/perl/hints/greenhills.sh
trunk/contrib/perl/hints/haiku.sh
trunk/contrib/perl/hints/hpux.sh
trunk/contrib/perl/hints/i386.sh
trunk/contrib/perl/hints/interix.sh
trunk/contrib/perl/hints/irix_4.sh
trunk/contrib/perl/hints/irix_5.sh
trunk/contrib/perl/hints/irix_6.sh
trunk/contrib/perl/hints/irix_6_0.sh
trunk/contrib/perl/hints/irix_6_1.sh
trunk/contrib/perl/hints/isc.sh
trunk/contrib/perl/hints/isc_2.sh
trunk/contrib/perl/hints/linux.sh
trunk/contrib/perl/hints/lynxos.sh
trunk/contrib/perl/hints/midnightbsd.sh
trunk/contrib/perl/hints/mips.sh
trunk/contrib/perl/hints/mirbsd.sh
trunk/contrib/perl/hints/mpc.sh
trunk/contrib/perl/hints/mpeix.sh
trunk/contrib/perl/hints/ncr_tower.sh
trunk/contrib/perl/hints/netbsd.sh
trunk/contrib/perl/hints/newsos4.sh
trunk/contrib/perl/hints/next_3.sh
trunk/contrib/perl/hints/next_3_0.sh
trunk/contrib/perl/hints/next_4.sh
trunk/contrib/perl/hints/nonstopux.sh
trunk/contrib/perl/hints/openbsd.sh
trunk/contrib/perl/hints/opus.sh
trunk/contrib/perl/hints/os2.sh
trunk/contrib/perl/hints/os390.sh
trunk/contrib/perl/hints/os400.sh
trunk/contrib/perl/hints/posix-bc.sh
trunk/contrib/perl/hints/powerux.sh
trunk/contrib/perl/hints/qnx.sh
trunk/contrib/perl/hints/rhapsody.sh
trunk/contrib/perl/hints/riscos.sh
trunk/contrib/perl/hints/sco.sh
trunk/contrib/perl/hints/sco_2_3_0.sh
trunk/contrib/perl/hints/sco_2_3_1.sh
trunk/contrib/perl/hints/sco_2_3_2.sh
trunk/contrib/perl/hints/sco_2_3_3.sh
trunk/contrib/perl/hints/sco_2_3_4.sh
trunk/contrib/perl/hints/solaris_2.sh
trunk/contrib/perl/hints/stellar.sh
trunk/contrib/perl/hints/sunos_4_0.sh
trunk/contrib/perl/hints/sunos_4_1.sh
trunk/contrib/perl/hints/super-ux.sh
trunk/contrib/perl/hints/svr4.sh
trunk/contrib/perl/hints/svr5.sh
trunk/contrib/perl/hints/t001.c
trunk/contrib/perl/hints/ti1500.sh
trunk/contrib/perl/hints/titanos.sh
trunk/contrib/perl/hints/ultrix_4.sh
trunk/contrib/perl/hints/umips.sh
trunk/contrib/perl/hints/unicos.sh
trunk/contrib/perl/hints/unicosmk.sh
trunk/contrib/perl/hints/unisysdynix.sh
trunk/contrib/perl/hints/utekv.sh
trunk/contrib/perl/hints/uts.sh
trunk/contrib/perl/hints/uwin.sh
trunk/contrib/perl/hints/vmesa.sh
trunk/contrib/perl/hints/vos.sh
trunk/contrib/perl/lib/AnyDBM_File.pm
trunk/contrib/perl/lib/AnyDBM_File.t
trunk/contrib/perl/lib/Benchmark.pm
trunk/contrib/perl/lib/Benchmark.t
trunk/contrib/perl/lib/CORE.pod
trunk/contrib/perl/lib/Carp/Heavy.pm
trunk/contrib/perl/lib/Carp.pm
trunk/contrib/perl/lib/Carp.t
trunk/contrib/perl/lib/Class/Struct.pm
trunk/contrib/perl/lib/Class/Struct.t
trunk/contrib/perl/lib/Config/Extensions.pm
trunk/contrib/perl/lib/Config/Extensions.t
trunk/contrib/perl/lib/Config.t
trunk/contrib/perl/lib/DB.pm
trunk/contrib/perl/lib/DB.t
trunk/contrib/perl/lib/DBM_Filter/Changes
trunk/contrib/perl/lib/DBM_Filter/compress.pm
trunk/contrib/perl/lib/DBM_Filter/encode.pm
trunk/contrib/perl/lib/DBM_Filter/int32.pm
trunk/contrib/perl/lib/DBM_Filter/null.pm
trunk/contrib/perl/lib/DBM_Filter/t/01error.t
trunk/contrib/perl/lib/DBM_Filter/t/02core.t
trunk/contrib/perl/lib/DBM_Filter/t/compress.t
trunk/contrib/perl/lib/DBM_Filter/t/encode.t
trunk/contrib/perl/lib/DBM_Filter/t/int32.t
trunk/contrib/perl/lib/DBM_Filter/t/null.t
trunk/contrib/perl/lib/DBM_Filter/t/utf8.t
trunk/contrib/perl/lib/DBM_Filter/utf8.pm
trunk/contrib/perl/lib/DBM_Filter.pm
trunk/contrib/perl/lib/DirHandle.pm
trunk/contrib/perl/lib/DirHandle.t
trunk/contrib/perl/lib/English.pm
trunk/contrib/perl/lib/English.t
trunk/contrib/perl/lib/Exporter/Heavy.pm
trunk/contrib/perl/lib/Exporter.pm
trunk/contrib/perl/lib/Exporter.t
trunk/contrib/perl/lib/ExtUtils/Embed.pm
trunk/contrib/perl/lib/ExtUtils/XSSymSet.pm
trunk/contrib/perl/lib/ExtUtils/t/Embed.t
trunk/contrib/perl/lib/ExtUtils/typemap
trunk/contrib/perl/lib/File/Basename.pm
trunk/contrib/perl/lib/File/Basename.t
trunk/contrib/perl/lib/File/Compare.pm
trunk/contrib/perl/lib/File/Compare.t
trunk/contrib/perl/lib/File/Copy.pm
trunk/contrib/perl/lib/File/Copy.t
trunk/contrib/perl/lib/File/DosGlob.pm
trunk/contrib/perl/lib/File/DosGlob.t
trunk/contrib/perl/lib/File/Find/t/find.t
trunk/contrib/perl/lib/File/Find/t/taint.t
trunk/contrib/perl/lib/File/Find.pm
trunk/contrib/perl/lib/File/stat.pm
trunk/contrib/perl/lib/File/stat.t
trunk/contrib/perl/lib/FileHandle.pm
trunk/contrib/perl/lib/FileHandle.t
trunk/contrib/perl/lib/FindBin.pm
trunk/contrib/perl/lib/FindBin.t
trunk/contrib/perl/lib/Getopt/Std.pm
trunk/contrib/perl/lib/Getopt/Std.t
trunk/contrib/perl/lib/Internals.t
trunk/contrib/perl/lib/Net/hostent.pm
trunk/contrib/perl/lib/Net/hostent.t
trunk/contrib/perl/lib/Net/netent.pm
trunk/contrib/perl/lib/Net/netent.t
trunk/contrib/perl/lib/Net/protoent.pm
trunk/contrib/perl/lib/Net/protoent.t
trunk/contrib/perl/lib/Net/servent.pm
trunk/contrib/perl/lib/Net/servent.t
trunk/contrib/perl/lib/PerlIO.pm
trunk/contrib/perl/lib/Pod/Functions.pm
trunk/contrib/perl/lib/Pod/t/Functions.t
trunk/contrib/perl/lib/Pod/t/InputObjects.t
trunk/contrib/perl/lib/Pod/t/Select.t
trunk/contrib/perl/lib/Pod/t/Usage.t
trunk/contrib/perl/lib/Pod/t/eol.t
trunk/contrib/perl/lib/Pod/t/utils.t
trunk/contrib/perl/lib/Search/Dict.pm
trunk/contrib/perl/lib/Search/Dict.t
trunk/contrib/perl/lib/SelectSaver.pm
trunk/contrib/perl/lib/SelectSaver.t
trunk/contrib/perl/lib/Symbol.pm
trunk/contrib/perl/lib/Symbol.t
trunk/contrib/perl/lib/Term/Complete.pm
trunk/contrib/perl/lib/Term/Complete.t
trunk/contrib/perl/lib/Term/ReadLine.pm
trunk/contrib/perl/lib/Term/ReadLine.t
trunk/contrib/perl/lib/Text/Abbrev.pm
trunk/contrib/perl/lib/Text/Abbrev.t
trunk/contrib/perl/lib/Thread.pm
trunk/contrib/perl/lib/Thread.t
trunk/contrib/perl/lib/Tie/Array/push.t
trunk/contrib/perl/lib/Tie/Array/splice.t
trunk/contrib/perl/lib/Tie/Array/std.t
trunk/contrib/perl/lib/Tie/Array/stdpush.t
trunk/contrib/perl/lib/Tie/Array.pm
trunk/contrib/perl/lib/Tie/ExtraHash.t
trunk/contrib/perl/lib/Tie/Handle/stdhandle.t
trunk/contrib/perl/lib/Tie/Handle/stdhandle_from_handle.t
trunk/contrib/perl/lib/Tie/Handle.pm
trunk/contrib/perl/lib/Tie/Hash.pm
trunk/contrib/perl/lib/Tie/Hash.t
trunk/contrib/perl/lib/Tie/Scalar.pm
trunk/contrib/perl/lib/Tie/Scalar.t
trunk/contrib/perl/lib/Tie/StdHandle.pm
trunk/contrib/perl/lib/Tie/SubstrHash.pm
trunk/contrib/perl/lib/Tie/SubstrHash.t
trunk/contrib/perl/lib/Time/gmtime.pm
trunk/contrib/perl/lib/Time/gmtime.t
trunk/contrib/perl/lib/Time/localtime.pm
trunk/contrib/perl/lib/Time/localtime.t
trunk/contrib/perl/lib/Time/tm.pm
trunk/contrib/perl/lib/UNIVERSAL.pm
trunk/contrib/perl/lib/Unicode/README
trunk/contrib/perl/lib/Unicode/UCD.pm
trunk/contrib/perl/lib/Unicode/UCD.t
trunk/contrib/perl/lib/User/grent.pm
trunk/contrib/perl/lib/User/grent.t
trunk/contrib/perl/lib/User/pwent.pm
trunk/contrib/perl/lib/User/pwent.t
trunk/contrib/perl/lib/abbrev.pl
trunk/contrib/perl/lib/assert.pl
trunk/contrib/perl/lib/bigfloat.pl
trunk/contrib/perl/lib/bigfloatpl.t
trunk/contrib/perl/lib/bigint.pl
trunk/contrib/perl/lib/bigintpl.t
trunk/contrib/perl/lib/bigrat.pl
trunk/contrib/perl/lib/blib.pm
trunk/contrib/perl/lib/blib.t
trunk/contrib/perl/lib/bytes.pm
trunk/contrib/perl/lib/bytes.t
trunk/contrib/perl/lib/bytes_heavy.pl
trunk/contrib/perl/lib/cacheout.pl
trunk/contrib/perl/lib/charnames.pm
trunk/contrib/perl/lib/charnames.t
trunk/contrib/perl/lib/complete.pl
trunk/contrib/perl/lib/ctime.pl
trunk/contrib/perl/lib/dbm_filter_util.pl
trunk/contrib/perl/lib/deprecate.pm
trunk/contrib/perl/lib/diagnostics.pm
trunk/contrib/perl/lib/diagnostics.t
trunk/contrib/perl/lib/dotsh.pl
trunk/contrib/perl/lib/dumpvar.pl
trunk/contrib/perl/lib/dumpvar.t
trunk/contrib/perl/lib/exceptions.pl
trunk/contrib/perl/lib/fastcwd.pl
trunk/contrib/perl/lib/feature/unicode_strings.t
trunk/contrib/perl/lib/feature.pm
trunk/contrib/perl/lib/feature.t
trunk/contrib/perl/lib/filetest.pm
trunk/contrib/perl/lib/filetest.t
trunk/contrib/perl/lib/find.pl
trunk/contrib/perl/lib/finddepth.pl
trunk/contrib/perl/lib/flush.pl
trunk/contrib/perl/lib/getcwd.pl
trunk/contrib/perl/lib/getopt.pl
trunk/contrib/perl/lib/getopts.pl
trunk/contrib/perl/lib/h2ph.t
trunk/contrib/perl/lib/h2xs.t
trunk/contrib/perl/lib/hostname.pl
trunk/contrib/perl/lib/importenv.pl
trunk/contrib/perl/lib/integer.pm
trunk/contrib/perl/lib/integer.t
trunk/contrib/perl/lib/less.pm
trunk/contrib/perl/lib/less.t
trunk/contrib/perl/lib/locale.pm
trunk/contrib/perl/lib/locale.t
trunk/contrib/perl/lib/look.pl
trunk/contrib/perl/lib/newgetopt.pl
trunk/contrib/perl/lib/open.pm
trunk/contrib/perl/lib/open.t
trunk/contrib/perl/lib/open2.pl
trunk/contrib/perl/lib/open3.pl
trunk/contrib/perl/lib/overload/numbers.pm
trunk/contrib/perl/lib/overload.pm
trunk/contrib/perl/lib/overload.t
trunk/contrib/perl/lib/overload64.t
trunk/contrib/perl/lib/overloading.pm
trunk/contrib/perl/lib/overloading.t
trunk/contrib/perl/lib/perl5db/t/eval-line-bug
trunk/contrib/perl/lib/perl5db/t/lvalue-bug
trunk/contrib/perl/lib/perl5db/t/proxy-constants
trunk/contrib/perl/lib/perl5db/t/rt-61222
trunk/contrib/perl/lib/perl5db/t/rt-66110
trunk/contrib/perl/lib/perl5db/t/symbol-table-bug
trunk/contrib/perl/lib/perl5db/t/taint
trunk/contrib/perl/lib/perl5db.pl
trunk/contrib/perl/lib/perl5db.t
trunk/contrib/perl/lib/pwd.pl
trunk/contrib/perl/lib/shellwords.pl
trunk/contrib/perl/lib/sigtrap.pm
trunk/contrib/perl/lib/sigtrap.t
trunk/contrib/perl/lib/sort.pm
trunk/contrib/perl/lib/sort.t
trunk/contrib/perl/lib/stat.pl
trunk/contrib/perl/lib/strict.pm
trunk/contrib/perl/lib/strict.t
trunk/contrib/perl/lib/subs.pm
trunk/contrib/perl/lib/subs.t
trunk/contrib/perl/lib/syslog.pl
trunk/contrib/perl/lib/tainted.pl
trunk/contrib/perl/lib/termcap.pl
trunk/contrib/perl/lib/timelocal.pl
trunk/contrib/perl/lib/unicore/ArabicShaping.txt
trunk/contrib/perl/lib/unicore/BidiMirroring.txt
trunk/contrib/perl/lib/unicore/Blocks.txt
trunk/contrib/perl/lib/unicore/CJKRadicals.txt
trunk/contrib/perl/lib/unicore/CaseFolding.txt
trunk/contrib/perl/lib/unicore/CompositionExclusions.txt
trunk/contrib/perl/lib/unicore/DAge.txt
trunk/contrib/perl/lib/unicore/DCoreProperties.txt
trunk/contrib/perl/lib/unicore/DNormalizationProps.txt
trunk/contrib/perl/lib/unicore/EastAsianWidth.txt
trunk/contrib/perl/lib/unicore/EmojiSources.txt
trunk/contrib/perl/lib/unicore/HangulSyllableType.txt
trunk/contrib/perl/lib/unicore/Index.txt
trunk/contrib/perl/lib/unicore/IndicMatraCategory.txt
trunk/contrib/perl/lib/unicore/IndicSyllabicCategory.txt
trunk/contrib/perl/lib/unicore/Jamo.txt
trunk/contrib/perl/lib/unicore/LineBreak.txt
trunk/contrib/perl/lib/unicore/Makefile
trunk/contrib/perl/lib/unicore/NameAliases.txt
trunk/contrib/perl/lib/unicore/NamedSequences.txt
trunk/contrib/perl/lib/unicore/NamedSqProv.txt
trunk/contrib/perl/lib/unicore/NamesList.txt
trunk/contrib/perl/lib/unicore/NormalizationCorrections.txt
trunk/contrib/perl/lib/unicore/PropList.txt
trunk/contrib/perl/lib/unicore/PropValueAliases.txt
trunk/contrib/perl/lib/unicore/PropertyAliases.txt
trunk/contrib/perl/lib/unicore/README.perl
trunk/contrib/perl/lib/unicore/ReadMe.txt
trunk/contrib/perl/lib/unicore/ScriptExtensions.txt
trunk/contrib/perl/lib/unicore/Scripts.txt
trunk/contrib/perl/lib/unicore/SpecialCasing.txt
trunk/contrib/perl/lib/unicore/StandardizedVariants.txt
trunk/contrib/perl/lib/unicore/UnicodeData.txt
trunk/contrib/perl/lib/unicore/auxiliary/GCBTest.txt
trunk/contrib/perl/lib/unicore/auxiliary/GraphemeBreakProperty.txt
trunk/contrib/perl/lib/unicore/auxiliary/SentenceBreakProperty.txt
trunk/contrib/perl/lib/unicore/auxiliary/WordBreakProperty.txt
trunk/contrib/perl/lib/unicore/extracted/DBidiClass.txt
trunk/contrib/perl/lib/unicore/extracted/DBinaryProperties.txt
trunk/contrib/perl/lib/unicore/extracted/DCombiningClass.txt
trunk/contrib/perl/lib/unicore/extracted/DDecompositionType.txt
trunk/contrib/perl/lib/unicore/extracted/DEastAsianWidth.txt
trunk/contrib/perl/lib/unicore/extracted/DGeneralCategory.txt
trunk/contrib/perl/lib/unicore/extracted/DJoinGroup.txt
trunk/contrib/perl/lib/unicore/extracted/DJoinType.txt
trunk/contrib/perl/lib/unicore/extracted/DLineBreak.txt
trunk/contrib/perl/lib/unicore/extracted/DNumType.txt
trunk/contrib/perl/lib/unicore/extracted/DNumValues.txt
trunk/contrib/perl/lib/unicore/mktables
trunk/contrib/perl/lib/unicore/version
trunk/contrib/perl/lib/utf8.pm
trunk/contrib/perl/lib/utf8.t
trunk/contrib/perl/lib/utf8_heavy.pl
trunk/contrib/perl/lib/validate.pl
trunk/contrib/perl/lib/vars.pm
trunk/contrib/perl/lib/vars.t
trunk/contrib/perl/lib/vars_carp.t
trunk/contrib/perl/lib/version/Internals.pod
trunk/contrib/perl/lib/version.pm
trunk/contrib/perl/lib/version.pod
trunk/contrib/perl/lib/version.t
trunk/contrib/perl/lib/vmsish.pm
trunk/contrib/perl/lib/vmsish.t
trunk/contrib/perl/lib/warnings/register.pm
trunk/contrib/perl/lib/warnings.pm
trunk/contrib/perl/lib/warnings.t
trunk/contrib/perl/mad/Nomad.pm
trunk/contrib/perl/mad/P5AST.pm
trunk/contrib/perl/mad/P5re.pm
trunk/contrib/perl/mad/PLXML.pm
trunk/contrib/perl/mad/p55
trunk/contrib/perl/mad/t/p55.t
trunk/contrib/perl/qnx/ar
trunk/contrib/perl/qnx/cpp
trunk/contrib/perl/qnx/qnx.c
trunk/contrib/perl/symbian/PerlApp.cpp
trunk/contrib/perl/symbian/PerlApp.h
trunk/contrib/perl/symbian/PerlApp.hrh
trunk/contrib/perl/symbian/PerlAppAif.rss
trunk/contrib/perl/symbian/PerlBase.cpp
trunk/contrib/perl/symbian/PerlBase.h
trunk/contrib/perl/symbian/PerlBase.pod
trunk/contrib/perl/symbian/PerlRecog.cpp
trunk/contrib/perl/symbian/PerlRecog.mmp
trunk/contrib/perl/symbian/PerlUi.cpp
trunk/contrib/perl/symbian/PerlUi.h
trunk/contrib/perl/symbian/PerlUi.hrh
trunk/contrib/perl/symbian/PerlUiS60.rss
trunk/contrib/perl/symbian/PerlUiS80.rss
trunk/contrib/perl/symbian/PerlUiS90.rss
trunk/contrib/perl/symbian/PerlUiUIQ.rss
trunk/contrib/perl/symbian/PerlUtil.cpp
trunk/contrib/perl/symbian/PerlUtil.h
trunk/contrib/perl/symbian/PerlUtil.pod
trunk/contrib/perl/symbian/README
trunk/contrib/perl/symbian/TODO
trunk/contrib/perl/symbian/bld.inf
trunk/contrib/perl/symbian/config.pl
trunk/contrib/perl/symbian/config.sh
trunk/contrib/perl/symbian/cwd.pl
trunk/contrib/perl/symbian/demo_pl
trunk/contrib/perl/symbian/ext/Moped/Msg/Msg.mmp
trunk/contrib/perl/symbian/ext/Moped/Msg/Msg.pkg
trunk/contrib/perl/symbian/ext/Moped/Msg/Msg.pm
trunk/contrib/perl/symbian/ext/Moped/Msg/Msg.xs
trunk/contrib/perl/symbian/ext/Moped/Msg/README
trunk/contrib/perl/symbian/ext/Moped/Msg/bld.inf
trunk/contrib/perl/symbian/ext/Moped/Msg/location.pl
trunk/contrib/perl/symbian/find_writeable_data.pl
trunk/contrib/perl/symbian/hexdump.pl
trunk/contrib/perl/symbian/install.cfg
trunk/contrib/perl/symbian/makesis.pl
trunk/contrib/perl/symbian/port.pl
trunk/contrib/perl/symbian/sanity.pl
trunk/contrib/perl/symbian/sdk.pl
trunk/contrib/perl/symbian/sisify.pl
trunk/contrib/perl/symbian/symbian_dll.cpp
trunk/contrib/perl/symbian/symbian_proto.h
trunk/contrib/perl/symbian/symbian_stubs.c
trunk/contrib/perl/symbian/symbian_stubs.h
trunk/contrib/perl/symbian/symbian_utils.cpp
trunk/contrib/perl/symbian/symbianish.h
trunk/contrib/perl/symbian/uid.pl
trunk/contrib/perl/symbian/version.pl
trunk/contrib/perl/symbian/xsbuild.pl
trunk/contrib/perl/t/README
trunk/contrib/perl/t/TEST
trunk/contrib/perl/t/base/cond.t
trunk/contrib/perl/t/base/if.t
trunk/contrib/perl/t/base/lex.t
trunk/contrib/perl/t/base/num.t
trunk/contrib/perl/t/base/pat.t
trunk/contrib/perl/t/base/rs.t
trunk/contrib/perl/t/base/term.t
trunk/contrib/perl/t/base/while.t
trunk/contrib/perl/t/benchmark/rt26188-speed-up-keys-on-empty-hash.t
trunk/contrib/perl/t/cmd/elsif.t
trunk/contrib/perl/t/cmd/for.t
trunk/contrib/perl/t/cmd/mod.t
trunk/contrib/perl/t/cmd/subval.t
trunk/contrib/perl/t/cmd/switch.t
trunk/contrib/perl/t/cmd/while.t
trunk/contrib/perl/t/comp/bproto.t
trunk/contrib/perl/t/comp/cmdopt.t
trunk/contrib/perl/t/comp/colon.t
trunk/contrib/perl/t/comp/decl.t
trunk/contrib/perl/t/comp/final_line_num.t
trunk/contrib/perl/t/comp/fold.t
trunk/contrib/perl/t/comp/form_scope.t
trunk/contrib/perl/t/comp/hints.aux
trunk/contrib/perl/t/comp/hints.t
trunk/contrib/perl/t/comp/line_debug.t
trunk/contrib/perl/t/comp/line_debug_0.aux
trunk/contrib/perl/t/comp/multiline.t
trunk/contrib/perl/t/comp/opsubs.t
trunk/contrib/perl/t/comp/our.t
trunk/contrib/perl/t/comp/package.t
trunk/contrib/perl/t/comp/package_block.t
trunk/contrib/perl/t/comp/parser.t
trunk/contrib/perl/t/comp/proto.t
trunk/contrib/perl/t/comp/redef.t
trunk/contrib/perl/t/comp/require.t
trunk/contrib/perl/t/comp/retainedlines.t
trunk/contrib/perl/t/comp/term.t
trunk/contrib/perl/t/comp/uproto.t
trunk/contrib/perl/t/comp/use.t
trunk/contrib/perl/t/comp/utf.t
trunk/contrib/perl/t/harness
trunk/contrib/perl/t/io/argv.t
trunk/contrib/perl/t/io/binmode.t
trunk/contrib/perl/t/io/bom.t
trunk/contrib/perl/t/io/crlf.t
trunk/contrib/perl/t/io/crlf_through.t
trunk/contrib/perl/t/io/data.t
trunk/contrib/perl/t/io/defout.t
trunk/contrib/perl/t/io/dup.t
trunk/contrib/perl/t/io/eintr.t
trunk/contrib/perl/t/io/errno.t
trunk/contrib/perl/t/io/errnosig.t
trunk/contrib/perl/t/io/fflush.t
trunk/contrib/perl/t/io/fs.t
trunk/contrib/perl/t/io/inplace.t
trunk/contrib/perl/t/io/iofile.t
trunk/contrib/perl/t/io/iprefix.t
trunk/contrib/perl/t/io/layers.t
trunk/contrib/perl/t/io/nargv.t
trunk/contrib/perl/t/io/open.t
trunk/contrib/perl/t/io/openpid.t
trunk/contrib/perl/t/io/perlio.t
trunk/contrib/perl/t/io/perlio_fail.t
trunk/contrib/perl/t/io/perlio_leaks.t
trunk/contrib/perl/t/io/perlio_open.t
trunk/contrib/perl/t/io/pipe.t
trunk/contrib/perl/t/io/print.t
trunk/contrib/perl/t/io/pvbm.t
trunk/contrib/perl/t/io/read.t
trunk/contrib/perl/t/io/say.t
trunk/contrib/perl/t/io/tell.t
trunk/contrib/perl/t/io/through.t
trunk/contrib/perl/t/io/utf8.t
trunk/contrib/perl/t/japh/abigail.t
trunk/contrib/perl/t/lib/1_compile.t
trunk/contrib/perl/t/lib/Cname.pm
trunk/contrib/perl/t/lib/Devel/switchd.pm
trunk/contrib/perl/t/lib/Devel/switchd_empty.pm
trunk/contrib/perl/t/lib/Sans_mypragma.pm
trunk/contrib/perl/t/lib/charnames/alias
trunk/contrib/perl/t/lib/common.pl
trunk/contrib/perl/t/lib/commonsense.t
trunk/contrib/perl/t/lib/compmod.pl
trunk/contrib/perl/t/lib/croak.t
trunk/contrib/perl/t/lib/cygwin.t
trunk/contrib/perl/t/lib/dbmt_common.pl
trunk/contrib/perl/t/lib/deprecate/Deprecated.pm
trunk/contrib/perl/t/lib/deprecate/Optionally.pm
trunk/contrib/perl/t/lib/deprecate.t
trunk/contrib/perl/t/lib/feature/bundle
trunk/contrib/perl/t/lib/feature/implicit
trunk/contrib/perl/t/lib/feature/nonesuch
trunk/contrib/perl/t/lib/feature/say
trunk/contrib/perl/t/lib/feature/switch
trunk/contrib/perl/t/lib/h2ph.h
trunk/contrib/perl/t/lib/h2ph.pht
trunk/contrib/perl/t/lib/locale/latin1
trunk/contrib/perl/t/lib/locale/utf8
trunk/contrib/perl/t/lib/mypragma.pm
trunk/contrib/perl/t/lib/mypragma.t
trunk/contrib/perl/t/lib/no_load.t
trunk/contrib/perl/t/lib/overload_fallback.t
trunk/contrib/perl/t/lib/proxy_constant_subs.t
trunk/contrib/perl/t/lib/strict/refs
trunk/contrib/perl/t/lib/strict/subs
trunk/contrib/perl/t/lib/strict/vars
trunk/contrib/perl/t/lib/subs/subs
trunk/contrib/perl/t/lib/test_use.pm
trunk/contrib/perl/t/lib/test_use_14937.pm
trunk/contrib/perl/t/lib/universal.t
trunk/contrib/perl/t/lib/warnings/1global
trunk/contrib/perl/t/lib/warnings/2use
trunk/contrib/perl/t/lib/warnings/3both
trunk/contrib/perl/t/lib/warnings/4lint
trunk/contrib/perl/t/lib/warnings/5nolint
trunk/contrib/perl/t/lib/warnings/6default
trunk/contrib/perl/t/lib/warnings/7fatal
trunk/contrib/perl/t/lib/warnings/8signal
trunk/contrib/perl/t/lib/warnings/9enabled
trunk/contrib/perl/t/lib/warnings/9uninit
trunk/contrib/perl/t/lib/warnings/av
trunk/contrib/perl/t/lib/warnings/doio
trunk/contrib/perl/t/lib/warnings/doop
trunk/contrib/perl/t/lib/warnings/gv
trunk/contrib/perl/t/lib/warnings/hv
trunk/contrib/perl/t/lib/warnings/malloc
trunk/contrib/perl/t/lib/warnings/mg
trunk/contrib/perl/t/lib/warnings/op
trunk/contrib/perl/t/lib/warnings/pad
trunk/contrib/perl/t/lib/warnings/perl
trunk/contrib/perl/t/lib/warnings/perlio
trunk/contrib/perl/t/lib/warnings/perly
trunk/contrib/perl/t/lib/warnings/pp
trunk/contrib/perl/t/lib/warnings/pp_ctl
trunk/contrib/perl/t/lib/warnings/pp_hot
trunk/contrib/perl/t/lib/warnings/pp_pack
trunk/contrib/perl/t/lib/warnings/pp_sys
trunk/contrib/perl/t/lib/warnings/regcomp
trunk/contrib/perl/t/lib/warnings/regexec
trunk/contrib/perl/t/lib/warnings/run
trunk/contrib/perl/t/lib/warnings/sv
trunk/contrib/perl/t/lib/warnings/taint
trunk/contrib/perl/t/lib/warnings/toke
trunk/contrib/perl/t/lib/warnings/universal
trunk/contrib/perl/t/lib/warnings/utf8
trunk/contrib/perl/t/lib/warnings/util
trunk/contrib/perl/t/mro/basic.t
trunk/contrib/perl/t/mro/basic_01_c3.t
trunk/contrib/perl/t/mro/basic_01_dfs.t
trunk/contrib/perl/t/mro/basic_02_c3.t
trunk/contrib/perl/t/mro/basic_02_dfs.t
trunk/contrib/perl/t/mro/basic_03_c3.t
trunk/contrib/perl/t/mro/basic_03_dfs.t
trunk/contrib/perl/t/mro/basic_04_c3.t
trunk/contrib/perl/t/mro/basic_04_dfs.t
trunk/contrib/perl/t/mro/basic_05_c3.t
trunk/contrib/perl/t/mro/basic_05_dfs.t
trunk/contrib/perl/t/mro/c3_with_overload.t
trunk/contrib/perl/t/mro/complex_c3.t
trunk/contrib/perl/t/mro/complex_dfs.t
trunk/contrib/perl/t/mro/dbic_c3.t
trunk/contrib/perl/t/mro/dbic_dfs.t
trunk/contrib/perl/t/mro/inconsistent_c3.t
trunk/contrib/perl/t/mro/isa_aliases.t
trunk/contrib/perl/t/mro/isa_c3.t
trunk/contrib/perl/t/mro/isa_dfs.t
trunk/contrib/perl/t/mro/isarev.t
trunk/contrib/perl/t/mro/method_caching.t
trunk/contrib/perl/t/mro/next_NEXT.t
trunk/contrib/perl/t/mro/next_edgecases.t
trunk/contrib/perl/t/mro/next_goto.t
trunk/contrib/perl/t/mro/next_inanon.t
trunk/contrib/perl/t/mro/next_ineval.t
trunk/contrib/perl/t/mro/next_method.t
trunk/contrib/perl/t/mro/next_skip.t
trunk/contrib/perl/t/mro/overload_c3.t
trunk/contrib/perl/t/mro/overload_dfs.t
trunk/contrib/perl/t/mro/package_aliases.t
trunk/contrib/perl/t/mro/pkg_gen.t
trunk/contrib/perl/t/mro/recursion_c3.t
trunk/contrib/perl/t/mro/recursion_dfs.t
trunk/contrib/perl/t/mro/vulcan_c3.t
trunk/contrib/perl/t/mro/vulcan_dfs.t
trunk/contrib/perl/t/op/64bitint.t
trunk/contrib/perl/t/op/alarm.t
trunk/contrib/perl/t/op/anonsub.t
trunk/contrib/perl/t/op/append.t
trunk/contrib/perl/t/op/args.t
trunk/contrib/perl/t/op/arith.t
trunk/contrib/perl/t/op/array.t
trunk/contrib/perl/t/op/array_base.aux
trunk/contrib/perl/t/op/array_base.t
trunk/contrib/perl/t/op/assignwarn.t
trunk/contrib/perl/t/op/attrhand.t
trunk/contrib/perl/t/op/attrs.t
trunk/contrib/perl/t/op/auto.t
trunk/contrib/perl/t/op/avhv.t
trunk/contrib/perl/t/op/bless.t
trunk/contrib/perl/t/op/blocks.t
trunk/contrib/perl/t/op/bop.t
trunk/contrib/perl/t/op/caller.pl
trunk/contrib/perl/t/op/caller.t
trunk/contrib/perl/t/op/chars.t
trunk/contrib/perl/t/op/chdir.t
trunk/contrib/perl/t/op/chop.t
trunk/contrib/perl/t/op/chr.t
trunk/contrib/perl/t/op/closure.t
trunk/contrib/perl/t/op/cmp.t
trunk/contrib/perl/t/op/concat.t
trunk/contrib/perl/t/op/concat2.t
trunk/contrib/perl/t/op/cond.t
trunk/contrib/perl/t/op/context.t
trunk/contrib/perl/t/op/cproto.t
trunk/contrib/perl/t/op/crypt.t
trunk/contrib/perl/t/op/dbm.t
trunk/contrib/perl/t/op/defins.t
trunk/contrib/perl/t/op/delete.t
trunk/contrib/perl/t/op/die.t
trunk/contrib/perl/t/op/die_except.t
trunk/contrib/perl/t/op/die_exit.t
trunk/contrib/perl/t/op/die_keeperr.t
trunk/contrib/perl/t/op/die_unwind.t
trunk/contrib/perl/t/op/do.t
trunk/contrib/perl/t/op/dor.t
trunk/contrib/perl/t/op/each.t
trunk/contrib/perl/t/op/each_array.t
trunk/contrib/perl/t/op/eval.t
trunk/contrib/perl/t/op/exec.t
trunk/contrib/perl/t/op/exists_sub.t
trunk/contrib/perl/t/op/exp.t
trunk/contrib/perl/t/op/fh.t
trunk/contrib/perl/t/op/filehandle.t
trunk/contrib/perl/t/op/filetest.t
trunk/contrib/perl/t/op/filetest_stack_ok.t
trunk/contrib/perl/t/op/filetest_t.t
trunk/contrib/perl/t/op/flip.t
trunk/contrib/perl/t/op/fork.t
trunk/contrib/perl/t/op/getpid.t
trunk/contrib/perl/t/op/getppid.t
trunk/contrib/perl/t/op/glob.t
trunk/contrib/perl/t/op/gmagic.t
trunk/contrib/perl/t/op/goto.t
trunk/contrib/perl/t/op/goto_xs.t
trunk/contrib/perl/t/op/grent.t
trunk/contrib/perl/t/op/grep.t
trunk/contrib/perl/t/op/groups.t
trunk/contrib/perl/t/op/gv.t
trunk/contrib/perl/t/op/hash.t
trunk/contrib/perl/t/op/hashassign.t
trunk/contrib/perl/t/op/hashwarn.t
trunk/contrib/perl/t/op/inc.t
trunk/contrib/perl/t/op/inccode-tie.t
trunk/contrib/perl/t/op/inccode.t
trunk/contrib/perl/t/op/incfilter.t
trunk/contrib/perl/t/op/index.t
trunk/contrib/perl/t/op/index_thr.t
trunk/contrib/perl/t/op/int.t
trunk/contrib/perl/t/op/join.t
trunk/contrib/perl/t/op/kill0.t
trunk/contrib/perl/t/op/lc.t
trunk/contrib/perl/t/op/lc_user.t
trunk/contrib/perl/t/op/leaky-magic.t
trunk/contrib/perl/t/op/length.t
trunk/contrib/perl/t/op/lex.t
trunk/contrib/perl/t/op/lex_assign.t
trunk/contrib/perl/t/op/lfs.t
trunk/contrib/perl/t/op/list.t
trunk/contrib/perl/t/op/local.t
trunk/contrib/perl/t/op/localref.t
trunk/contrib/perl/t/op/loopctl.t
trunk/contrib/perl/t/op/lop.t
trunk/contrib/perl/t/op/magic-27839.t
trunk/contrib/perl/t/op/magic.t
trunk/contrib/perl/t/op/magic_phase.t
trunk/contrib/perl/t/op/method.t
trunk/contrib/perl/t/op/mkdir.t
trunk/contrib/perl/t/op/my.t
trunk/contrib/perl/t/op/my_stash.t
trunk/contrib/perl/t/op/mydef.t
trunk/contrib/perl/t/op/negate.t
trunk/contrib/perl/t/op/not.t
trunk/contrib/perl/t/op/numconvert.t
trunk/contrib/perl/t/op/oct.t
trunk/contrib/perl/t/op/or.t
trunk/contrib/perl/t/op/ord.t
trunk/contrib/perl/t/op/overload_integer.t
trunk/contrib/perl/t/op/override.t
trunk/contrib/perl/t/op/pack.t
trunk/contrib/perl/t/op/packagev.t
trunk/contrib/perl/t/op/pos.t
trunk/contrib/perl/t/op/pow.t
trunk/contrib/perl/t/op/print.t
trunk/contrib/perl/t/op/protowarn.t
trunk/contrib/perl/t/op/push.t
trunk/contrib/perl/t/op/pwent.t
trunk/contrib/perl/t/op/qq.t
trunk/contrib/perl/t/op/qr.t
trunk/contrib/perl/t/op/quotemeta.t
trunk/contrib/perl/t/op/rand.t
trunk/contrib/perl/t/op/range.t
trunk/contrib/perl/t/op/read.t
trunk/contrib/perl/t/op/readdir.t
trunk/contrib/perl/t/op/readline.t
trunk/contrib/perl/t/op/recurse.t
trunk/contrib/perl/t/op/ref.t
trunk/contrib/perl/t/op/repeat.t
trunk/contrib/perl/t/op/require_errors.t
trunk/contrib/perl/t/op/reset.t
trunk/contrib/perl/t/op/reverse.t
trunk/contrib/perl/t/op/runlevel.t
trunk/contrib/perl/t/op/setpgrpstack.t
trunk/contrib/perl/t/op/sigdispatch.t
trunk/contrib/perl/t/op/sleep.t
trunk/contrib/perl/t/op/smartkve.t
trunk/contrib/perl/t/op/smartmatch.t
trunk/contrib/perl/t/op/sort.t
trunk/contrib/perl/t/op/splice.t
trunk/contrib/perl/t/op/split.t
trunk/contrib/perl/t/op/split_unicode.t
trunk/contrib/perl/t/op/sprintf.t
trunk/contrib/perl/t/op/sprintf2.t
trunk/contrib/perl/t/op/srand.t
trunk/contrib/perl/t/op/sselect.t
trunk/contrib/perl/t/op/stash.t
trunk/contrib/perl/t/op/stat.t
trunk/contrib/perl/t/op/state.t
trunk/contrib/perl/t/op/study.t
trunk/contrib/perl/t/op/studytied.t
trunk/contrib/perl/t/op/sub.t
trunk/contrib/perl/t/op/sub_lval.t
trunk/contrib/perl/t/op/svleak.t
trunk/contrib/perl/t/op/switch.t
trunk/contrib/perl/t/op/symbolcache.t
trunk/contrib/perl/t/op/sysio.t
trunk/contrib/perl/t/op/taint.t
trunk/contrib/perl/t/op/threads-dirh.t
trunk/contrib/perl/t/op/threads.t
trunk/contrib/perl/t/op/threads_create.pl
trunk/contrib/perl/t/op/tie.t
trunk/contrib/perl/t/op/tie_fetch_count.t
trunk/contrib/perl/t/op/tiearray.t
trunk/contrib/perl/t/op/tiehandle.t
trunk/contrib/perl/t/op/time.t
trunk/contrib/perl/t/op/time_loop.t
trunk/contrib/perl/t/op/tr.t
trunk/contrib/perl/t/op/turkish.t
trunk/contrib/perl/t/op/undef.t
trunk/contrib/perl/t/op/universal.t
trunk/contrib/perl/t/op/unshift.t
trunk/contrib/perl/t/op/upgrade.t
trunk/contrib/perl/t/op/utf8cache.t
trunk/contrib/perl/t/op/utf8decode.t
trunk/contrib/perl/t/op/utf8magic.t
trunk/contrib/perl/t/op/utfhash.t
trunk/contrib/perl/t/op/utftaint.t
trunk/contrib/perl/t/op/vec.t
trunk/contrib/perl/t/op/ver.t
trunk/contrib/perl/t/op/wantarray.t
trunk/contrib/perl/t/op/warn.t
trunk/contrib/perl/t/op/while_readdir.t
trunk/contrib/perl/t/op/write.t
trunk/contrib/perl/t/op/yadayada.t
trunk/contrib/perl/t/perl.supp
trunk/contrib/perl/t/porting/FindExt.t
trunk/contrib/perl/t/porting/args_assert.t
trunk/contrib/perl/t/porting/authors.t
trunk/contrib/perl/t/porting/bincompat.t
trunk/contrib/perl/t/porting/buildtoc.t
trunk/contrib/perl/t/porting/checkcase.t
trunk/contrib/perl/t/porting/cmp_version.t
trunk/contrib/perl/t/porting/diag.t
trunk/contrib/perl/t/porting/dual-life.t
trunk/contrib/perl/t/porting/exec-bit.t
trunk/contrib/perl/t/porting/filenames.t
trunk/contrib/perl/t/porting/maintainers.t
trunk/contrib/perl/t/porting/manifest.t
trunk/contrib/perl/t/porting/podcheck.t
trunk/contrib/perl/t/porting/regen.t
trunk/contrib/perl/t/porting/test_bootstrap.t
trunk/contrib/perl/t/re/charset.t
trunk/contrib/perl/t/re/fold_grind.t
trunk/contrib/perl/t/re/no_utf8_pm.t
trunk/contrib/perl/t/re/overload.t
trunk/contrib/perl/t/re/pat.t
trunk/contrib/perl/t/re/pat_advanced.t
trunk/contrib/perl/t/re/pat_advanced_thr.t
trunk/contrib/perl/t/re/pat_psycho.t
trunk/contrib/perl/t/re/pat_psycho_thr.t
trunk/contrib/perl/t/re/pat_re_eval.t
trunk/contrib/perl/t/re/pat_re_eval_thr.t
trunk/contrib/perl/t/re/pat_rt_report.t
trunk/contrib/perl/t/re/pat_rt_report_thr.t
trunk/contrib/perl/t/re/pat_special_cc.t
trunk/contrib/perl/t/re/pat_special_cc_thr.t
trunk/contrib/perl/t/re/pat_thr.t
trunk/contrib/perl/t/re/qr-72922.t
trunk/contrib/perl/t/re/qr.t
trunk/contrib/perl/t/re/qr_gc.t
trunk/contrib/perl/t/re/qrstack.t
trunk/contrib/perl/t/re/re_tests
trunk/contrib/perl/t/re/reg_60508.t
trunk/contrib/perl/t/re/reg_email.t
trunk/contrib/perl/t/re/reg_email_thr.t
trunk/contrib/perl/t/re/reg_eval.t
trunk/contrib/perl/t/re/reg_eval_scope.t
trunk/contrib/perl/t/re/reg_fold.t
trunk/contrib/perl/t/re/reg_mesg.t
trunk/contrib/perl/t/re/reg_namedcapture.t
trunk/contrib/perl/t/re/reg_nc_tie.t
trunk/contrib/perl/t/re/reg_pmod.t
trunk/contrib/perl/t/re/reg_posixcc.t
trunk/contrib/perl/t/re/regexp.t
trunk/contrib/perl/t/re/regexp_noamp.t
trunk/contrib/perl/t/re/regexp_notrie.t
trunk/contrib/perl/t/re/regexp_qr.t
trunk/contrib/perl/t/re/regexp_qr_embed.t
trunk/contrib/perl/t/re/regexp_qr_embed_thr.t
trunk/contrib/perl/t/re/regexp_trielist.t
trunk/contrib/perl/t/re/regexp_unicode_prop.t
trunk/contrib/perl/t/re/regexp_unicode_prop_thr.t
trunk/contrib/perl/t/re/rxcode.t
trunk/contrib/perl/t/re/subst.t
trunk/contrib/perl/t/re/substT.t
trunk/contrib/perl/t/re/subst_amp.t
trunk/contrib/perl/t/re/subst_wamp.t
trunk/contrib/perl/t/re/substr.t
trunk/contrib/perl/t/re/substr_thr.t
trunk/contrib/perl/t/re/uniprops.t
trunk/contrib/perl/t/run/cloexec.t
trunk/contrib/perl/t/run/exit.t
trunk/contrib/perl/t/run/fresh_perl.t
trunk/contrib/perl/t/run/locale.t
trunk/contrib/perl/t/run/noswitch.t
trunk/contrib/perl/t/run/runenv.t
trunk/contrib/perl/t/run/script.t
trunk/contrib/perl/t/run/switch0.t
trunk/contrib/perl/t/run/switchC.t
trunk/contrib/perl/t/run/switchF.t
trunk/contrib/perl/t/run/switchF1.t
trunk/contrib/perl/t/run/switchI.t
trunk/contrib/perl/t/run/switcha.t
trunk/contrib/perl/t/run/switchd-78586.t
trunk/contrib/perl/t/run/switchd.t
trunk/contrib/perl/t/run/switches.t
trunk/contrib/perl/t/run/switchn.t
trunk/contrib/perl/t/run/switchp.t
trunk/contrib/perl/t/run/switcht.t
trunk/contrib/perl/t/run/switchx.aux
trunk/contrib/perl/t/run/switchx.t
trunk/contrib/perl/t/run/switchx2.aux
trunk/contrib/perl/t/test.pl
trunk/contrib/perl/t/thread_it.pl
trunk/contrib/perl/t/uni/cache.t
trunk/contrib/perl/t/uni/case.pl
trunk/contrib/perl/t/uni/chomp.t
trunk/contrib/perl/t/uni/chr.t
trunk/contrib/perl/t/uni/class.t
trunk/contrib/perl/t/uni/fold.t
trunk/contrib/perl/t/uni/greek.t
trunk/contrib/perl/t/uni/latin2.t
trunk/contrib/perl/t/uni/lex_utf8.t
trunk/contrib/perl/t/uni/lower.t
trunk/contrib/perl/t/uni/overload.t
trunk/contrib/perl/t/uni/sprintf.t
trunk/contrib/perl/t/uni/tie.t
trunk/contrib/perl/t/uni/title.t
trunk/contrib/perl/t/uni/tr_7jis.t
trunk/contrib/perl/t/uni/tr_eucjp.t
trunk/contrib/perl/t/uni/tr_sjis.t
trunk/contrib/perl/t/uni/tr_utf8.t
trunk/contrib/perl/t/uni/upper.t
trunk/contrib/perl/t/uni/write.t
trunk/contrib/perl/t/win32/system.t
trunk/contrib/perl/t/win32/system_tests
trunk/contrib/perl/t/x2p/s2p.t
trunk/contrib/perl/vms/descrip_mms.template
trunk/contrib/perl/vms/ext/Filespec.pm
trunk/contrib/perl/vms/ext/filespec.t
trunk/contrib/perl/vms/gen_shrfls.pl
trunk/contrib/perl/vms/genopt.com
trunk/contrib/perl/vms/make_command.com
trunk/contrib/perl/vms/mms2make.pl
trunk/contrib/perl/vms/munchconfig.c
trunk/contrib/perl/vms/myconfig.com
trunk/contrib/perl/vms/sockadapt.c
trunk/contrib/perl/vms/sockadapt.h
trunk/contrib/perl/vms/test.com
trunk/contrib/perl/vms/vms.c
trunk/contrib/perl/vms/vmsish.h
trunk/contrib/perl/vms/vmspipe.com
trunk/contrib/perl/vos/Changes
trunk/contrib/perl/vos/compile_full_perl.cm
trunk/contrib/perl/vos/configure_full_perl.sh
trunk/contrib/perl/vos/make_full_perl.sh
trunk/contrib/perl/vos/syslog.h
trunk/contrib/perl/vos/vos.c
trunk/contrib/perl/vos/vosish.h
trunk/contrib/perl/win32/FindExt.pm
trunk/contrib/perl/win32/Makefile
trunk/contrib/perl/win32/Makefile.ce
trunk/contrib/perl/win32/bin/exetype.pl
trunk/contrib/perl/win32/bin/perlglob.pl
trunk/contrib/perl/win32/bin/pl2bat.pl
trunk/contrib/perl/win32/bin/runperl.pl
trunk/contrib/perl/win32/bin/search.pl
trunk/contrib/perl/win32/ce-helpers/cecopy-lib.pl
trunk/contrib/perl/win32/ce-helpers/comp.pl
trunk/contrib/perl/win32/ce-helpers/compile-all.bat
trunk/contrib/perl/win32/ce-helpers/compile.bat
trunk/contrib/perl/win32/ce-helpers/makedist.pl
trunk/contrib/perl/win32/ce-helpers/registry.bat
trunk/contrib/perl/win32/config.bc
trunk/contrib/perl/win32/config.ce
trunk/contrib/perl/win32/config.gc
trunk/contrib/perl/win32/config.gc64
trunk/contrib/perl/win32/config.gc64nox
trunk/contrib/perl/win32/config.vc
trunk/contrib/perl/win32/config.vc64
trunk/contrib/perl/win32/config_H.bc
trunk/contrib/perl/win32/config_H.ce
trunk/contrib/perl/win32/config_H.gc
trunk/contrib/perl/win32/config_H.gc64
trunk/contrib/perl/win32/config_H.gc64nox
trunk/contrib/perl/win32/config_H.vc
trunk/contrib/perl/win32/config_H.vc64
trunk/contrib/perl/win32/config_h.PL
trunk/contrib/perl/win32/config_sh.PL
trunk/contrib/perl/win32/create_perllibst_h.pl
trunk/contrib/perl/win32/distclean.bat
trunk/contrib/perl/win32/fcrypt.c
trunk/contrib/perl/win32/genmk95.pl
trunk/contrib/perl/win32/include/arpa/inet.h
trunk/contrib/perl/win32/include/dirent.h
trunk/contrib/perl/win32/include/netdb.h
trunk/contrib/perl/win32/include/sys/socket.h
trunk/contrib/perl/win32/list_static_libs.pl
trunk/contrib/perl/win32/makefile.mk
trunk/contrib/perl/win32/mdelete.bat
trunk/contrib/perl/win32/perl.rc
trunk/contrib/perl/win32/perlexe.ico
trunk/contrib/perl/win32/perlexe.manifest
trunk/contrib/perl/win32/perlexe.rc
trunk/contrib/perl/win32/perlglob.c
trunk/contrib/perl/win32/perlhost.h
trunk/contrib/perl/win32/perllib.c
trunk/contrib/perl/win32/perlmaince.c
trunk/contrib/perl/win32/pod.mak
trunk/contrib/perl/win32/runperl.c
trunk/contrib/perl/win32/sync_ext.pl
trunk/contrib/perl/win32/vdir.h
trunk/contrib/perl/win32/vmem.h
trunk/contrib/perl/win32/win32.c
trunk/contrib/perl/win32/win32.h
trunk/contrib/perl/win32/win32ceio.c
trunk/contrib/perl/win32/win32io.c
trunk/contrib/perl/win32/win32iop-o.h
trunk/contrib/perl/win32/win32iop.h
trunk/contrib/perl/win32/win32sck.c
trunk/contrib/perl/win32/win32thread.c
trunk/contrib/perl/win32/win32thread.h
trunk/contrib/perl/win32/wince.c
trunk/contrib/perl/win32/wince.h
trunk/contrib/perl/win32/wincesck.c
trunk/contrib/perl/x2p/EXTERN.h
trunk/contrib/perl/x2p/INTERN.h
trunk/contrib/perl/x2p/Makefile.SH
trunk/contrib/perl/x2p/a2p.c
trunk/contrib/perl/x2p/a2p.h
trunk/contrib/perl/x2p/a2p.pod
trunk/contrib/perl/x2p/a2p.y
trunk/contrib/perl/x2p/a2py.c
trunk/contrib/perl/x2p/cflags.SH
trunk/contrib/perl/x2p/find2perl.PL
trunk/contrib/perl/x2p/hash.c
trunk/contrib/perl/x2p/hash.h
trunk/contrib/perl/x2p/s2p.PL
trunk/contrib/perl/x2p/str.c
trunk/contrib/perl/x2p/str.h
trunk/contrib/perl/x2p/util.c
trunk/contrib/perl/x2p/util.h
trunk/contrib/perl/x2p/walk.c
Modified: trunk/contrib/perl/haiku/Haiku/Haiku.pm
===================================================================
--- trunk/contrib/perl/haiku/Haiku/Haiku.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/haiku/Haiku/Haiku.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -8,7 +8,7 @@
require DynaLoader;
@ISA = qw|Exporter DynaLoader|;
- $VERSION = '0.34';
+ $VERSION = '0.35';
$XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
Property changes on: trunk/contrib/perl/haiku/Haiku/Haiku.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/haiku/Haiku/Haiku.xs
===================================================================
--- trunk/contrib/perl/haiku/Haiku/Haiku.xs 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/haiku/Haiku/Haiku.xs 2013-12-02 21:26:09 UTC (rev 6439)
@@ -20,7 +20,7 @@
}
static void
-haiku_do_debug_printf(pTHX_ register SV *sv,
+haiku_do_debug_printf(pTHX_ SV *sv,
void (*printfFunc)(const char*,...))
{
dVAR;
Property changes on: trunk/contrib/perl/haiku/Haiku/Haiku.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/haiku/Haiku/Makefile.PL
===================================================================
--- trunk/contrib/perl/haiku/Haiku/Makefile.PL 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/haiku/Haiku/Makefile.PL 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/haiku/Haiku/Makefile.PL
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/haiku/haikuish.h
===================================================================
--- trunk/contrib/perl/haiku/haikuish.h 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/haiku/haikuish.h 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/haiku/haikuish.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/3b1.sh
===================================================================
--- trunk/contrib/perl/hints/3b1.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/3b1.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/3b1.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/3b1cc
===================================================================
--- trunk/contrib/perl/hints/3b1cc 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/3b1cc 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/3b1cc
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/README.hints
===================================================================
--- trunk/contrib/perl/hints/README.hints 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/README.hints 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/README.hints
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/hints/aix.sh
===================================================================
--- trunk/contrib/perl/hints/aix.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/aix.sh 2013-12-02 21:26:09 UTC (rev 6439)
@@ -96,7 +96,7 @@
ccflags="$ccflags -D_ALL_SOURCE -D_ANSI_C_SOURCE -D_POSIX_SOURCE"
case "$cc" in
*gcc*) ;;
- *) ccflags="$ccflags -qmaxmem=-1 -qnoansialias" ;;
+ *) ccflags="$ccflags -qmaxmem=-1 -qnoansialias -qlanglvl=extc99" ;;
esac
nm_opt='-B'
@@ -245,13 +245,9 @@
cc_r)
;;
xlc_r)
- # for -qlonglong
- ccflags="$ccflags -qlanglvl=extended"
;;
# we do not need the C++ compiler
xlC_r)
- # for -qlonglong
- ccflags="$ccflags -qlanglvl=extended"
cc=xlc_r
;;
'')
@@ -272,13 +268,9 @@
*)
case "$cc" in
xlc)
- # for -qlonglong
- ccflags="$ccflags -qlanglvl=extended"
;;
# we do not need the C++ compiler
xlC)
- # for -qlonglong
- ccflags="$ccflags -qlanglvl=extended"
cc=xlc
;;
*)
@@ -348,6 +340,9 @@
$define|true|[yY]*) cc="$cc -q64" ;;
*) cc="$cc -q32" ;;
esac
+ # Some 32-bit getconfs will set ccflags to include -qlonglong
+ # but that's no longer needed with an explicit -qextc99.
+ ccflags="`echo $ccflags | sed -e 's@ -qlonglong@@'`"
;;
*) # Remove xlc-specific -qflags.
ccflags="`echo $ccflags | sed -e 's@ -q[^ ]*@ @g' -e 's@^-q[^ ]* @@g'`"
Property changes on: trunk/contrib/perl/hints/aix.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/hints/aix_3.sh
===================================================================
--- trunk/contrib/perl/hints/aix_3.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/aix_3.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/aix_3.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/hints/aix_4.sh
===================================================================
--- trunk/contrib/perl/hints/aix_4.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/aix_4.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/aix_4.sh
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/hints/altos486.sh
===================================================================
--- trunk/contrib/perl/hints/altos486.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/altos486.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/altos486.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/amigaos.sh
===================================================================
--- trunk/contrib/perl/hints/amigaos.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/amigaos.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/amigaos.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/atheos.sh
===================================================================
--- trunk/contrib/perl/hints/atheos.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/atheos.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/atheos.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/aux_3.sh
===================================================================
--- trunk/contrib/perl/hints/aux_3.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/aux_3.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/aux_3.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/beos.sh
===================================================================
--- trunk/contrib/perl/hints/beos.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/beos.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/beos.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/broken-db.msg
===================================================================
--- trunk/contrib/perl/hints/broken-db.msg 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/broken-db.msg 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/broken-db.msg
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/bsdos.sh
===================================================================
--- trunk/contrib/perl/hints/bsdos.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/bsdos.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/bsdos.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/hints/catamount.sh
===================================================================
--- trunk/contrib/perl/hints/catamount.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/catamount.sh 2013-12-02 21:26:09 UTC (rev 6439)
@@ -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.14.2
+# mkdir -p /opt/perl-catamount/lib/perl5/5.18.1
# 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.14.2
+# cp -pr lib/* /opt/perl-catamount/lib/perl5/5.18.1
# 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
Property changes on: trunk/contrib/perl/hints/catamount.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.4
\ No newline at end of property
Index: trunk/contrib/perl/hints/convexos.sh
===================================================================
--- trunk/contrib/perl/hints/convexos.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/convexos.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/convexos.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/cxux.sh
===================================================================
--- trunk/contrib/perl/hints/cxux.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/cxux.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/cxux.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/hints/cygwin.sh
===================================================================
--- trunk/contrib/perl/hints/cygwin.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/cygwin.sh 2013-12-02 21:26:09 UTC (rev 6439)
@@ -30,7 +30,7 @@
test -z "$optimize" && optimize='-O3'
man3ext='3pm'
test -z "$use64bitint" && use64bitint='define'
-test -z "$usethreads" && usethreads='define'
+test -z "$useithreads" && useithreads='define'
ccflags="$ccflags -DPERL_USE_SAFE_PUTENV -U__STRICT_ANSI__"
# - otherwise i686-cygwin
archname='cygwin'
Property changes on: trunk/contrib/perl/hints/cygwin.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/darwin.sh
===================================================================
--- trunk/contrib/perl/hints/darwin.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/darwin.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/darwin.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.4
\ No newline at end of property
Index: trunk/contrib/perl/hints/dcosx.sh
===================================================================
--- trunk/contrib/perl/hints/dcosx.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/dcosx.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/dcosx.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/hints/dec_osf.sh
===================================================================
--- trunk/contrib/perl/hints/dec_osf.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/dec_osf.sh 2013-12-02 21:26:09 UTC (rev 6439)
@@ -278,7 +278,7 @@
esac
# The patch 23787
-# http://public.activestate.com/cgi-bin/perlbrowse?patch=23787
+# http://perl5.git.perl.org/perl.git/commit/73cb726371990cd489597c4fee405a9815abf4da
# broke things for gcc (at least gcc 3.3) so that many of the pack()
# checksum tests for formats L, j, J, especially when combined
# with the < and > specifiers, started to fail if compiled with plain -O3.
Property changes on: trunk/contrib/perl/hints/dec_osf.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/hints/dgux.sh
===================================================================
--- trunk/contrib/perl/hints/dgux.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/dgux.sh 2013-12-02 21:26:09 UTC (rev 6439)
@@ -52,14 +52,14 @@
#####################################
prefix=/usr/local
-perlpath="$prefix/bin/perl514"
-startperl="#! $prefix/bin/perl514"
-privlib="$prefix/lib/perl514"
+perlpath="$prefix/bin/perl518"
+startperl="#! $prefix/bin/perl518"
+privlib="$prefix/lib/perl518"
man1dir="$prefix/man/man1"
man3dir="$prefix/man/man3"
-sitearch="$prefix/lib/perl514/$archname"
-sitelib="$prefix/lib/perl514"
+sitearch="$prefix/lib/perl518/$archname"
+sitelib="$prefix/lib/perl518"
#Do not overwrite by default /usr/bin/perl of DG/UX
installusrbinperl="$undef"
@@ -138,7 +138,7 @@
# <takis at XFree86.Org>
#####################################
-libperl="libperl514.so"
+libperl="libperl518.so"
# Many functions (eg, gethostent(), killpg(), getpriority(), setruid()
# dbm_*(), and plenty more) are defined in -ldgc. Usually you don't
@@ -205,8 +205,8 @@
# DG/UX library!
libswanted="dbm posix resolv socket nsl dl m rte"
archname="ix86-dgux-thread"
- sitearch="$prefix/lib/perl514/$archname"
- sitelib="$prefix/lib/perl514"
+ sitearch="$prefix/lib/perl518/$archname"
+ sitelib="$prefix/lib/perl518"
case "$cc" in
*gcc*)
#### Use GCC -2.95.2/3 rev (DG/UX) and -pthread
Property changes on: trunk/contrib/perl/hints/dgux.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/hints/dos_djgpp.sh
===================================================================
--- trunk/contrib/perl/hints/dos_djgpp.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/dos_djgpp.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/dos_djgpp.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/dragonfly.sh
===================================================================
--- trunk/contrib/perl/hints/dragonfly.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/dragonfly.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/dragonfly.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/hints/dynix.sh
===================================================================
--- trunk/contrib/perl/hints/dynix.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/dynix.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/dynix.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/dynixptx.sh
===================================================================
--- trunk/contrib/perl/hints/dynixptx.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/dynixptx.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/dynixptx.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/epix.sh
===================================================================
--- trunk/contrib/perl/hints/epix.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/epix.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/epix.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/hints/esix4.sh
===================================================================
--- trunk/contrib/perl/hints/esix4.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/esix4.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/esix4.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/fps.sh
===================================================================
--- trunk/contrib/perl/hints/fps.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/fps.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/fps.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/hints/freebsd.sh
===================================================================
--- trunk/contrib/perl/hints/freebsd.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/freebsd.sh 2013-12-02 21:26:09 UTC (rev 6439)
@@ -110,7 +110,8 @@
case "$osvers" in
0.*|1.0*) ;;
-1*|2*) cccdlflags='-DPIC -fpic'
+1.*|2.*)
+ cccdlflags='-DPIC -fpic'
lddlflags="-Bshareable $lddlflags"
;;
@@ -140,7 +141,7 @@
esac
case "$osvers" in
-0*|1*|2*|3*) ;;
+0.*|1.*|2.*|3.*) ;;
*)
ccflags="${ccflags} -DHAS_FPSETMASK -DHAS_FLOATINGPOINT_H"
@@ -195,7 +196,7 @@
$define|true|[yY]*)
lc_r=`/sbin/ldconfig -r|grep ':-lc_r'|awk '{print $NF}'|sed -n '$p'`
case "$osvers" in
- 0*|1*|2.0*|2.1*) cat <<EOM >&4
+ 0.*|1.*|2.0*|2.1*) cat <<EOM >&4
I did not know that FreeBSD $osvers supports POSIX threads.
Feel free to tell perlbug at perl.org otherwise.
Property changes on: trunk/contrib/perl/hints/freebsd.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/hints/genix.sh
===================================================================
--- trunk/contrib/perl/hints/genix.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/genix.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/genix.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/hints/gnu.sh
===================================================================
--- trunk/contrib/perl/hints/gnu.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/gnu.sh 2013-12-02 21:26:09 UTC (rev 6439)
@@ -8,10 +8,22 @@
shift
libswanted="$*"
+# Debian 4.0 puts ndbm in the -lgdbm_compat library.
+libswanted="$libswanted gdbm_compat"
+
case "$optimize" in
'') optimize='-O2' ;;
esac
+case "$plibpth" in
+'') plibpth=`gcc -print-search-dirs | grep libraries |
+ cut -f2- -d= | tr ':' $trnl | grep -v 'gcc' | sed -e 's:/$::'`
+ set X $plibpth # Collapse all entries on one line
+ shift
+ plibpth="$*"
+ ;;
+esac
+
# Flags needed to produce shared libraries.
lddlflags='-shared'
@@ -19,8 +31,21 @@
ccdlflags='-Wl,-E'
# Debian bug #258618
-ccflags='-D_GNU_SOURCE'
+ccflags="-D_GNU_SOURCE $ccflags"
+cat > UU/uselargefiles.cbu <<'EOCBU'
+# This script UU/uselargefiles.cbu will get 'called-back' by Configure
+# after it has prompted the user for whether to use large files.
+case "$uselargefiles" in
+''|$define|true|[yY]*)
+# Keep this in the left margin.
+ccflags_uselargefiles="-D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64"
+
+ ccflags="$ccflags $ccflags_uselargefiles"
+ ;;
+esac
+EOCBU
+
# The following routines are only available as stubs in GNU libc.
# XXX remove this once metaconf detects the GNU libc stubs.
d_msgctl='undef'
Property changes on: trunk/contrib/perl/hints/gnu.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/hints/gnukfreebsd.sh
===================================================================
--- trunk/contrib/perl/hints/gnukfreebsd.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/gnukfreebsd.sh 2013-12-02 21:26:09 UTC (rev 6439)
@@ -5,6 +5,3 @@
. ./hints/linux.sh
-# Configure sets these where $osname = linux
-ccdlflags='-Wl,-E'
-lddlflags='-shared'
Property changes on: trunk/contrib/perl/hints/gnukfreebsd.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/hints/gnuknetbsd.sh
===================================================================
--- trunk/contrib/perl/hints/gnuknetbsd.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/gnuknetbsd.sh 2013-12-02 21:26:09 UTC (rev 6439)
@@ -5,6 +5,3 @@
. ./hints/linux.sh
-# Configure sets these where $osname = linux
-ccdlflags='-Wl,-E'
-lddlflags='-shared'
Property changes on: trunk/contrib/perl/hints/gnuknetbsd.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/greenhills.sh
===================================================================
--- trunk/contrib/perl/hints/greenhills.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/greenhills.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/greenhills.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/hints/haiku.sh
===================================================================
--- trunk/contrib/perl/hints/haiku.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/haiku.sh 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,7 +1,10 @@
# Haiku hints file
-# $Id: haiku.sh,v 1.1.1.1 2011-02-17 12:49:38 laffer1 Exp $
+# $Id$
-prefix="/boot/common"
+case "$prefix" in
+'') prefix="/boot/common" ;;
+*) ;; # pass the user supplied value through
+esac
libpth='/boot/home/config/lib /boot/common/lib /system/lib'
usrinc='/boot/develop/headers/posix'
@@ -32,3 +35,10 @@
case "$ldlibpthname" in
'') ldlibpthname=LIBRARY_PATH ;;
esac
+
+# as of alpha 4.1 (at the latest) some symbols are versioned,
+# confusing the nm lookup
+case "$usenm" in
+'') usenm='undef' ;;
+esac
+
Property changes on: trunk/contrib/perl/hints/haiku.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/hints/hpux.sh
===================================================================
--- trunk/contrib/perl/hints/hpux.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/hpux.sh 2013-12-02 21:26:09 UTC (rev 6439)
@@ -157,7 +157,7 @@
done
[ -z "$cc_found" ] && cc_found=`which cc`
what $cc_found >&4
- ccversion=`what $cc_found | awk '/Compiler/{print $2}/Itanium/{print $6,$7}/for Integrity/{print $6}'`
+ ccversion=`what $cc_found | awk '/Compiler/{print $2}/Itanium/{print $6,$7}/for Integrity/{print $6,$7}'`
case "$ccflags" in
"-Ae "*) ;;
*) ccflags="-Ae $cc_cppflags"
@@ -414,7 +414,7 @@
fi
;;
- *) # HP's compiler cannot combine -g and -O
+ *)
case "$optimize" in
"") optimize="+O2 +Onolimit" ;;
*O[3456789]*) optimize=`echo "$optimize" | sed -e 's/O[3-9]/O2/'` ;;
@@ -436,6 +436,19 @@
# maint (5.8.8+) and blead (5.9.3+)
# -O1/+O1 passed all tests (m)'05 [ 10 Jan 2005 ]
optimize="$opt" ;;
+ B3910B*A.06.15)
+ # > cc --version
+ # cc: HP C/aC++ B3910B A.06.15 [May 16 2007]
+ # Has optimizing problems with +O2 for blead (5.17.4),
+ # see https://rt.perl.org:443/rt3/Ticket/Display.html?id=103668.
+ #
+ # +O2 +Onolimit +Onoprocelim +Ostore_ordering \
+ # +Onolibcalls=strcmp
+ # passes all tests (with/without -DDEBUGGING) [Nov 17 2011]
+ case "$optimize" in
+ *O2*) optimize="$optimize +Onoprocelim +Ostore_ordering +Onolibcalls=strcmp" ;;
+ esac
+ ;;
*) doop_cflags="optimize=\"$opt\""
op_cflags="optimize=\"$opt\"" ;;
esac
@@ -520,6 +533,27 @@
fi
EOCBU
+cat >config.arch <<'EOCBU'
+# This script UU/config.arch will get 'called-back' by Configure after
+# all other configurations are done just before config.h is generated
+case "$archname:$optimize" in
+ PA*:*-g*[-+]O*|PA*:*[-+]O*-g*)
+ case "$ccflags" in
+ *DD64*) ;;
+ *) case "$ccversion" in
+ # Only on PA-RISC. B3910B (aCC) is not faulty
+ # B.11.* and A.10.* are
+ [AB].1*)
+ # cc: error 1414: Can't handle preprocessed file foo.i if -g and -O specified.
+ echo "HP-UX C-ANSI-C on PA-RISC does not accept both -g and -O on preprocessed files" >&4
+ echo "when compiling in 32bit mode. The optimizer will be disabled." >&4
+ optimize=`echo "$optimize" | sed -e 's/[-+]O[0-9]*//' -e 's/+Onolimit//' -e 's/^ *//'`
+ ;;
+ esac
+ esac
+ esac
+EOCBU
+
cat >UU/uselargefiles.cbu <<'EOCBU'
# This script UU/uselargefiles.cbu will get 'called-back' by Configure
# after it has prompted the user for whether to use large files.
@@ -644,7 +678,7 @@
or
- PTH package from e.g. http://hpux.tn.tudelft.nl/hppd/hpux/alpha.html
+ PTH package from e.g. http://hpux.connect.org.uk/hppd/hpux/Gnu/pth-2.0.7/
Cannot continue, aborting.
EOM
Property changes on: trunk/contrib/perl/hints/hpux.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.4
\ No newline at end of property
Index: trunk/contrib/perl/hints/i386.sh
===================================================================
--- trunk/contrib/perl/hints/i386.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/i386.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/i386.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/interix.sh
===================================================================
--- trunk/contrib/perl/hints/interix.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/interix.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/interix.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/irix_4.sh
===================================================================
--- trunk/contrib/perl/hints/irix_4.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/irix_4.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/irix_4.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/irix_5.sh
===================================================================
--- trunk/contrib/perl/hints/irix_5.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/irix_5.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/irix_5.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/irix_6.sh
===================================================================
--- trunk/contrib/perl/hints/irix_6.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/irix_6.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/irix_6.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/hints/irix_6_0.sh
===================================================================
--- trunk/contrib/perl/hints/irix_6_0.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/irix_6_0.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/irix_6_0.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/irix_6_1.sh
===================================================================
--- trunk/contrib/perl/hints/irix_6_1.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/irix_6_1.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/irix_6_1.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/isc.sh
===================================================================
--- trunk/contrib/perl/hints/isc.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/isc.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/isc.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/hints/isc_2.sh
===================================================================
--- trunk/contrib/perl/hints/isc_2.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/isc_2.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/isc_2.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/hints/linux.sh
===================================================================
--- trunk/contrib/perl/hints/linux.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/linux.sh 2013-12-02 21:26:09 UTC (rev 6439)
@@ -18,6 +18,9 @@
# No version of Linux supports setuid scripts.
d_suidsafe='undef'
+# No version of Linux needs libutil for perl.
+i_libutil='undef'
+
# Debian and Red Hat, and perhaps other vendors, provide both runtime and
# development packages for some libraries. The runtime packages contain shared
# libraries with version information in their names (e.g., libgdbm.so.1.7.3);
@@ -160,10 +163,18 @@
# This unconditionally uses gcc because even if the user is using another
# compiler, we still need to find the math library and friends, and I don't
# know how other compilers will cope with that situation.
+# Morever, if the user has their own gcc earlier in $PATH than the system gcc,
+# we don't want its libraries. So we try to prefer the system gcc
# Still, as an escape hatch, allow Configure command line overrides to
# plibpth to bypass this check.
+if [ -x /usr/bin/gcc ] ; then
+ gcc=/usr/bin/gcc
+else
+ gcc=gcc
+fi
+
case "$plibpth" in
-'') plibpth=`gcc -print-search-dirs | grep libraries |
+'') plibpth=`LANG=C LC_ALL=C $gcc -print-search-dirs | grep libraries |
cut -f2- -d= | tr ':' $trnl | grep -v 'gcc' | sed -e 's:/$::'`
set X $plibpth # Collapse all entries on one line
shift
@@ -354,15 +365,9 @@
# This script UU/usethreads.cbu will get 'called-back' by Configure
# after it has prompted the user for whether to use threads.
cat > UU/usethreads.cbu <<'EOCBU'
-if getconf GNU_LIBPTHREAD_VERSION | grep NPTL >/dev/null 2>/dev/null
-then
- threadshavepids=""
-else
- threadshavepids="-DTHREADS_HAVE_PIDS"
-fi
case "$usethreads" in
$define|true|[yY]*)
- ccflags="-D_REENTRANT -D_GNU_SOURCE $threadshavepids $ccflags"
+ ccflags="-D_REENTRANT -D_GNU_SOURCE $ccflags"
if echo $libswanted | grep -v pthread >/dev/null
then
set `echo X "$libswanted "| sed -e 's/ c / pthread c /'`
@@ -409,16 +414,6 @@
;;
esac
-# If we are using g++ we must use nm and force ourselves to use
-# the /usr/lib/libc.a (resetting the libc below to an empty string
-# makes Configure to look for the right one) because the symbol
-# scanning tricks of Configure will crash and burn horribly.
-case "$cc" in
-*g++*) usenm=true
- libc=''
- ;;
-esac
-
# If using g++, the Configure scan for dlopen() and (especially)
# dlerror() might fail, easier just to forcibly hint them in.
case "$cc" in
Property changes on: trunk/contrib/perl/hints/linux.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/hints/lynxos.sh
===================================================================
--- trunk/contrib/perl/hints/lynxos.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/lynxos.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/lynxos.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/hints/machten.sh (from rev 6437, vendor/perl/5.18.1/hints/machten.sh)
===================================================================
--- trunk/contrib/perl/hints/machten.sh (rev 0)
+++ trunk/contrib/perl/hints/machten.sh 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,276 @@
+#! /bin/bash
+# machten.sh
+# This is for MachTen 4.1.4. It might work on other versions and variants
+# too. MachTen is now obsolete, lacks many features expected in modern UNIX
+# implementations, and suffers from a number of bugs which are likely never
+# to be fixed. This means that, in the absence of extensive work on
+# this file and on the perl source code, versions of perl later than 5.6.x
+# cannot successfully be built on MachTen. This file enforces this
+# restriction. Should you wish to port a later version of perl to MachTen,
+# feel free to contact me for pointers.
+# -- Dominic Dunlop <domo at computer.org> 040213
+#
+# Users of earlier MachTen versions might need a fixed tr from ftp.tenon.com.
+# This should be described in the MachTen release notes.
+#
+# MachTen 2.x has its own hint file.
+#
+# The original version of this file was put together by Andy Dougherty
+# <doughera at lafayette.edu> based on comments from lots of
+# folks, especially
+# Mark Pease <peasem at primenet.com>
+# Martijn Koster <m.koster at webcrawler.com>
+# Richard Yeh <rcyeh at cco.caltech.edu>
+#
+# Prevent building of perls later than 5.6.x, stating why -- see above.
+# -- Dominic Dunlop <domo at computer.org> 040213
+# Deny system's false claims to support mmap() and munmap(); note
+# also that Sys V IPC (re)disabled by jhi due to continuing inadequacy
+# -- Dominic Dunlop <domo at computer.org> 001111
+# Remove dynamic loading libraries from search; enable SysV IPC with
+# MachTen 4.1.4 and above; define SYSTEM_ALIGN_BYTES for old MT versions
+# -- Dominic Dunlop <domo at computer.org> 000224
+# Disable shadow password file access: MT 4.1.1 has necessary library
+# functions, but not header file (or documentation)
+# -- Dominic Dunlop <domo at computer.org> 990804
+# For now, explicitly disable dynamic loading -- MT 4.1.1 has it,
+# but these hints do not yet support it.
+# Define NOTEDEF_MACHTEN to undo gratuitous Tenon hack to signal.h.
+# -- Dominic Dunlop <domo at computer.org> 9800802
+# Completely disable SysV IPC pending more complete support from Tenon
+# -- Dominic Dunlop <domo at computer.org> 980712
+# Use vfork and perl's malloc by default
+# -- Dominic Dunlop <domo at computer.org> 980630
+# Raise perl's stack size again; cut down reg_infty; document
+# -- Dominic Dunlop <domo at computer.org> 980619
+# Use of semctl() can crash system: disable -- Dominic Dunlop 980506
+# Raise stack size further; slight tweaks to accomodate MT 4.1
+# -- Dominic Dunlop <domo at computer.org> 980211
+# Raise perl's stack size -- Dominic Dunlop <domo at tcp.ip.lu> 970922
+# Reinstate sigsetjmp iff version is 4.0.3 or greater; use nm
+# (assumes Configure change); prune libswanted -- Dominic Dunlop 970113
+# Warn about test failure due to old Berkeley db -- Dominic Dunlop 970105
+# Do not use perl's malloc; SysV IPC OK -- Neil Cutcliffe, Tenon 961030
+# File::Find's use of link count disabled by Dominic Dunlop 960528
+# Perl's use of sigsetjmp etc. disabled by Dominic Dunlop 960521
+
+# Assume that PERL_REVISON in patchlevel.h is 5.
+# If you want to try building perl-5.8.x or later, set PERL_VERSION_SAFE_MAX
+# appropriately in your environment before running Configure.
+if [ `awk '$1=="#define" && $2=="PERL_VERSION"{print $3}' patchlevel.h` \
+ -gt ${PERL_VERSION_SAFE_MAX:-6} ]
+then
+ cat <<EOF >&4
+
+Perl versions greater than 5.6.x have not been ported to MachTen. If you
+wish to build a version from the 5.6 track, please see the notes in
+README.machten
+EOF
+ exit 1
+fi
+#
+# MachTen 4.1.1's support for shadow password file access is incomplete:
+# disable its use completely.
+d_getspnam=${d_getspnam:-undef}
+
+# MachTen 4.1.1 does support dynamic loading, but perl doesn't
+# know how to use it yet.
+usedl=${usedl:-undef}
+
+# MachTen 4.1.1 may have an unhelpful hack in /usr/include/signal.h.
+# Undo it if so.
+if grep NOTDEF_MACHTEN /usr/include/signal.h > /dev/null
+then
+ ccflags="$ccflags -DNOTDEF_MACHTEN"
+fi
+
+# Power MachTen is a real memory system and its standard malloc
+# has been optimized for this. Using this malloc instead of Perl's
+# malloc may result in significant memory savings. In particular,
+# unlike most UNIX memory allocation subsystems, MachTen's free()
+# really does return unneeded process data memory to the system.
+# However, MachTen's malloc() is woefully slow -- maybe 100 times
+# slower than perl's own, so perl's own is usually the better
+# choice. In order to use perl's malloc(), the sbrk() system call
+# must be simulated using MachTen's malloc(). See malloc.c for
+# precise details of how this is achieved. Recent improvements
+# to perl's malloc() currently crash MachTen, and so are disabled
+# by -DPLAIN_MALLOC and -DNO_FANCY_MALLOC.
+usemymalloc=${usemymalloc:-y}
+
+# Older versions of MachTen malloc() data on a two-byte boundary, which
+# works, but slows down operations on long, float and double data.
+# Perl's malloc() can compensate if SYSTEM_ALLOC_ALIGNMENT is suitably
+# defined.
+if expr "$osvers" \< "4.1" >/dev/null
+then
+system_alloc_alignment=" -DSYSTEM_ALLOC_ALIGNMENT=2"
+fi
+# Do not wrap the following long line
+malloc_cflags='ccflags="$ccflags -DPLAIN_MALLOC -DNO_FANCY_MALLOC -DUSE_PERL_SBRK$system_alloc_alignment"'
+
+# When MachTen does a fork(), it immediately copies the whole of
+# the parent process' data space for the child. This can be
+# expensive. Using vfork() where appropriate avoids this cost.
+d_vfork=${d_vfork:-define}
+
+# Specify a high level of optimization (-O3 wouldn't do much more)
+optimize=${optimize:--O2 -fomit-frame-pointer}
+
+# Make symbol table listings less voluminous
+nmopts=-gp
+
+# Set reg_infty -- the maximum allowable number of repeats in regular
+# expressions such as /a{1,$max_repeats}/, and the maximum number of
+# times /a*/ will match. Setting this too high without having a stack
+# large enough to accommodate deep recursion in the regular expression
+# engine allows perl to crash your Mac due to stack overrun if it
+# encounters a pathological regular expression. The default is a
+# compromise between capability and required stack size (see below).
+# You may override the default value from the Configure command-line
+# like this:
+#
+# Configure -Dreg_infty=16368 ...
+
+reg_infty=${reg_infty:-2047}
+
+# If you want to have many perl processes active simultaneously --
+# processing CGI forms -- for example, you should opt for a small stack.
+# For safety, you should set reg_infty no larger than the corresponding
+# value given in this table:
+#
+# Stack size reg_infty value supported
+# ---------- -------------------------
+# 128k 2**8-1 (256)
+# 256k 2**9-1 (511)
+# 512k 2**10-1 (1023)
+# 1M 2**11-1 (2047)
+# ...
+# 16M 2**15-1 (32767) (perl's default value)
+
+# This script selects a safe stack size based on the value of reg_infty
+# specified above. However, you may choose to take a risk and set
+# stack size lower: pathological regular expressions are rare in real-world
+# programs. But be aware that, if perl does encounter one, it WILL
+# crash your system. Do not set stack size lower than 96k unless
+# you want perl's installation tests ( make test ) to crash your system.
+#
+# You may override the default value from the Configure command-line
+# by specifying the required size in kilobytes like this:
+#
+# Configure -Dstack_size=96
+
+if [ "X$stack_size" = 'X' ]
+then
+ stack_size=128
+ X=`expr $reg_infty / 256`
+
+ while [ $X -gt 0 ]
+ do
+ X=`expr $X / 2`
+ stack_size=`expr $stack_size \* 2`
+ done
+ X=`expr $stack_size \* 1024`
+fi
+
+ldflags="$ldflags -Xlstack=$X"
+ccflags="$ccflags -DREG_INFTY=$reg_infty"
+
+# Install in /usr/local by default
+prefix='/usr/local'
+
+# At least on PowerMac, doubles must be aligned on 8 byte boundaries.
+# I don't know if this is true for all MachTen systems, or how to
+# determine this automatically.
+alignbytes=8
+
+# 4.0.2 and earlier had a problem with perl's use of sigsetjmp and
+# friends. Use setjmp and friends instead.
+expr "$osvers" \< "4.0.3" > /dev/null && d_sigsetjmp='undef'
+
+# System V IPC before MachTen 4.1.4 is incomplete (missing msg function
+# prototypes, no ftok()), buggy (semctl(.., .., IPC_STATUS, ..) hangs
+# system), and undocumented. Claim it's not there at all before 4.1.4.
+if expr "$osvers" \< "4.1.4" >/dev/null
+then
+d_msg=${d_msg:-undef}
+d_sem=${d_sem:-undef}
+d_shm=${d_shm:-undef}
+fi
+
+
+# As of MachTen 4.1.4 the msg* and shm* are in libc but unimplemented
+# (an attempt to use them causes a runtime error)
+# XXX Configure probe for really functional msg*() is needed XXX
+# XXX Configure probe for really functional shm*() is needed XXX
+if test "$d_msg" = ""; then
+ d_msgget=${d_msgget:-undef}
+ d_msgctl=${d_msgctl:-undef}
+ d_msgsnd=${d_msgsnd:-undef}
+ d_msgrcv=${d_msgrcv:-undef}
+ case "$d_msgget$d_msgsnd$d_msgctl$d_msgrcv" in
+ *"undef"*) d_msg="$undef" ;;
+ esac
+fi
+if test "$d_shm" = ""; then
+ d_shmat=${d_shmat:-undef}
+ d_shmdt=${d_shmdt:-undef}
+ d_shmget=${d_shmget:-undef}
+ d_shmctl=${d_shmctl:-undef}
+ case "$d_shmat$d_shmctl$d_shmdt$d_shmget" in
+ *"undef"*) d_shm="$undef" ;;
+ esac
+fi
+
+# MachTen has stubs for mmap and munmap(), but they just result in the
+# caller being killed on the grounds of "Bad system call"
+d_mmap=${d_mmap:-undef}
+d_munmap=${d_munmap:-undef}
+
+# Get rid of some extra libs which it takes Configure a tediously
+# long time never to find on MachTen, or which break perl
+set `echo X "$libswanted "|sed -e 's/ net / /' -e 's/ socket / /' \
+ -e 's/ inet / /' -e 's/ nsl / /' -e 's/ nm / /' -e 's/ malloc / /' \
+ -e 's/ ld / /' -e 's/ sun / /' -e 's/ posix / /' \
+ -e 's/ cposix / /' -e 's/ crypt / /' -e 's/ dl / /' -e 's/ dld / /' \
+ -e 's/ ucb / /' -e 's/ bsd / /' -e 's/ BSD / /' -e 's/ PW / /'`
+shift
+libswanted="$*"
+
+# While link counts on MachTen 4.1's fast file systems work correctly,
+# on Macintosh Heirarchical File Systems, (and on HFS+)
+# MachTen always reports ony two links to directories, even if they
+# contain subdirectories. Consequently, we use this variable to stop
+# File::Find using the link count to determine whether there are
+# subdirectories to be searched. This will generate a harmless message:
+# Hmm...You had some extra variables I don't know about...I'll try to keep 'em.
+# Propagating recommended variable dont_use_nlink
+dont_use_nlink=define
+
+cat <<EOM >&4
+
+At the end of Configure, you will see a harmless message
+
+Hmm...You had some extra variables I don't know about...I'll try to keep 'em.
+ Propagating recommended variable dont_use_nlink
+ Propagating recommended variable nmopts
+ Propagating recommended variable malloc_cflags...
+ Propagating recommended variable reg_infty
+ Propagating recommended variable system_alloc_alignment
+Read the File::Find documentation for more information about dont_use_nlink
+
+Your perl will be built with a stack size of ${stack_size}k and a regular
+expression repeat count limit of $reg_infty. If you want alternative
+values, see the file hints/machten.sh for advice on how to change them.
+
+Tests
+ io/fs test 4 and
+ op/stat test 3
+may fail since MachTen may not return a useful nlinks field to stat
+on directories.
+
+EOM
+expr "$osvers" \< "4.1" >/dev/null && test -r ./broken-db.msg && \
+ . ./broken-db.msg
+
+unset stack_size X
Copied: trunk/contrib/perl/hints/machten_2.sh (from rev 6437, vendor/perl/5.18.1/hints/machten_2.sh)
===================================================================
--- trunk/contrib/perl/hints/machten_2.sh (rev 0)
+++ trunk/contrib/perl/hints/machten_2.sh 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,91 @@
+# machten.sh
+# This file has been put together by Mark Pease <peasem at primenet.com>
+# Comments, questions, and improvements welcome!
+#
+# MachTen does not support dynamic loading. If you wish to, you
+# can fetch, compile, and install the dld package.
+# This ought to work with the ext/DynaLoader/dl_dld.xs in the
+# perl5 package. Have fun!
+# Some possible locations for dld:
+# ftp-swiss.ai.mit.edu:pub/scm/dld-3.2.7.tar.gz
+# prep.ai.mit.edu:/pub/gnu/jacal/dld-3.2.7.tar.gz
+# ftp.cs.indiana.edu:/pub/scheme-repository/imp/SCM-support/dld-3.2.7.tar.gz
+# tsx-11.mit.edu:/pub/linux/sources/libs/dld-3.2.7.tar.gz
+#
+# Original version was for MachTen 2.1.1.
+# Last modified by Andy Dougherty <doughera at lafayette.edu>
+# Tue Aug 13 12:31:01 EDT 1996
+#
+# Warning about tests which no longer fail
+# fixed by Tom Phoenix <rootbeer at teleport.com>
+# March 5, 1997
+#
+# Locale, optimization, and malloc changes by Tom Phoenix Mar 15, 1997
+#
+# groupstype change and note about t/lib/findbin.t by Tom, Mar 24, 1997
+
+# MachTen's ability to have valid filepaths beginning with "//" may
+# be causing lib/FindBin.pm to fail. I don't know how to fix it, but
+# the reader is encouraged to do so! :-) -- Tom
+
+# There seem to be some hard-to-diagnose problems under MachTen's
+# malloc, so we'll use Perl's. If you have problems which Perl's
+# malloc's diagnostics can't help you with, you may wish to use
+# MachTen's malloc after all.
+case "$usemymalloc" in
+'') usemymalloc='y' ;;
+esac
+
+# I (Tom Phoenix) don't know how to test for locales on MachTen. (If
+# you do, please fix this hints file!) But since mine didn't come
+# with locales working out of the box, I'll assume that's the case
+# for most folks.
+case "$d_setlocale" in
+'') d_setlocale=undef
+esac
+
+# MachTen doesn't have secure setid scripts
+d_suidsafe='undef'
+
+# groupstype should be gid_t, as near as I can tell, but it only
+# seems to work right when it's int.
+groupstype='int'
+
+case "$optimize" in
+'') optimize='-O2' ;;
+esac
+
+so='none'
+# These are useful only if you have DLD, but harmless otherwise.
+# Make sure gcc doesn't use -fpic.
+cccdlflags=' ' # That's an empty space.
+lddlflags='-r'
+dlext='o'
+
+# MachTen does not support POSIX enough to compile the POSIX module.
+useposix=false
+
+#MachTen might have an incomplete Berkeley DB implementation.
+i_db=$undef
+
+#MachTen versions 2.X have no hard links. This variable is used
+# by File::Find.
+# This will generate a harmless message:
+# Hmm...You had some extra variables I don't know about...I'll try to keep 'em.
+# Propagating recommended variable dont_use_nlink
+# Without this, tests io/fs #4 and op/stat #3 will fail.
+dont_use_nlink=define
+
+cat <<'EOM' >&4
+
+At the end of Configure, you will see a harmless message
+
+Hmm...You had some extra variables I don't know about...I'll try to keep 'em.
+ Propagating recommended variable dont_use_nlink
+
+Read the File::Find documentation for more information.
+
+It's possible that test t/lib/findbin.t will fail on some configurations
+of MachTen.
+
+EOM
Modified: trunk/contrib/perl/hints/midnightbsd.sh
===================================================================
--- trunk/contrib/perl/hints/midnightbsd.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/midnightbsd.sh 2013-12-02 21:26:09 UTC (rev 6439)
@@ -5,10 +5,19 @@
esac
libswanted=`echo $libswanted | sed 's/ malloc / /'`
-libpth="/usr/lib /usr/local/lib"
-glibpth="/usr/lib /usr/local/lib"
-ldflags="-Wl,-E "
-lddlflags="-shared "
+objformat=`/usr/bin/objformat`
+if [ x$objformat = xaout ]; then
+ if [ -e /usr/lib/aout ]; then
+ libpth="/usr/lib/aout /usr/local/lib /usr/lib"
+ glibpth="/usr/lib/aout /usr/local/lib /usr/lib"
+ fi
+ lddlflags='-Bshareable'
+else
+ libpth="/usr/lib /usr/local/lib"
+ glibpth="/usr/lib /usr/local/lib"
+ ldflags="-Wl,-E "
+ lddlflags="-shared "
+fi
cccdlflags='-DPIC -fPIC'
ccflags="${ccflags} -DHAS_FPSETMASK -DHAS_FLOATINGPOINT_H"
Property changes on: trunk/contrib/perl/hints/midnightbsd.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.3
\ No newline at end of property
Index: trunk/contrib/perl/hints/mips.sh
===================================================================
--- trunk/contrib/perl/hints/mips.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/mips.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/mips.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/mirbsd.sh
===================================================================
--- trunk/contrib/perl/hints/mirbsd.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/mirbsd.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/mirbsd.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/mpc.sh
===================================================================
--- trunk/contrib/perl/hints/mpc.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/mpc.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/mpc.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/mpeix.sh
===================================================================
--- trunk/contrib/perl/hints/mpeix.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/mpeix.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/mpeix.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/ncr_tower.sh
===================================================================
--- trunk/contrib/perl/hints/ncr_tower.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/ncr_tower.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/ncr_tower.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/hints/netbsd.sh
===================================================================
--- trunk/contrib/perl/hints/netbsd.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/netbsd.sh 2013-12-02 21:26:09 UTC (rev 6439)
@@ -89,7 +89,7 @@
;;
esac
case "$osvers" in
-0.9*|1.*|2.*|3.*|4.*|5.*)
+0.9*|1.*|2.*|3.*|4.*|5.*|6.*)
d_getprotoent_r="$undef"
d_getprotobyname_r="$undef"
d_getprotobynumber_r="$undef"
Property changes on: trunk/contrib/perl/hints/netbsd.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/hints/newsos4.sh
===================================================================
--- trunk/contrib/perl/hints/newsos4.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/newsos4.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/newsos4.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/next_3.sh
===================================================================
--- trunk/contrib/perl/hints/next_3.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/next_3.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/next_3.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/hints/next_3_0.sh
===================================================================
--- trunk/contrib/perl/hints/next_3_0.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/next_3_0.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/next_3_0.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/next_4.sh
===================================================================
--- trunk/contrib/perl/hints/next_4.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/next_4.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/next_4.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/nonstopux.sh
===================================================================
--- trunk/contrib/perl/hints/nonstopux.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/nonstopux.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/nonstopux.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/openbsd.sh
===================================================================
--- trunk/contrib/perl/hints/openbsd.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/openbsd.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/openbsd.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/hints/opus.sh
===================================================================
--- trunk/contrib/perl/hints/opus.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/opus.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/opus.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/os2.sh
===================================================================
--- trunk/contrib/perl/hints/os2.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/os2.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/os2.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/os390.sh
===================================================================
--- trunk/contrib/perl/hints/os390.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/os390.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/os390.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/hints/os400.sh
===================================================================
--- trunk/contrib/perl/hints/os400.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/os400.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/os400.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/posix-bc.sh
===================================================================
--- trunk/contrib/perl/hints/posix-bc.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/posix-bc.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/posix-bc.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/hints/powerux.sh
===================================================================
--- trunk/contrib/perl/hints/powerux.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/powerux.sh 2013-12-02 21:26:09 UTC (rev 6439)
@@ -176,7 +176,7 @@
# There was a bug in memcmp (which was fixed a while ago) which sometimes
# fails to provide the correct compare status (it is data dependant). I
-# don't wnat to figure out if you are building with the correct version or
+# don't want to figure out if you are building with the correct version or
# not, so just pretend there is no memcmp (since perl has its own handy
# substitute).
#
Property changes on: trunk/contrib/perl/hints/powerux.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/hints/qnx.sh
===================================================================
--- trunk/contrib/perl/hints/qnx.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/qnx.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/qnx.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/rhapsody.sh
===================================================================
--- trunk/contrib/perl/hints/rhapsody.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/rhapsody.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/rhapsody.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/riscos.sh
===================================================================
--- trunk/contrib/perl/hints/riscos.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/riscos.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/riscos.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/sco.sh
===================================================================
--- trunk/contrib/perl/hints/sco.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/sco.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/sco.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/hints/sco_2_3_0.sh
===================================================================
--- trunk/contrib/perl/hints/sco_2_3_0.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/sco_2_3_0.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/sco_2_3_0.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/sco_2_3_1.sh
===================================================================
--- trunk/contrib/perl/hints/sco_2_3_1.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/sco_2_3_1.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/sco_2_3_1.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/sco_2_3_2.sh
===================================================================
--- trunk/contrib/perl/hints/sco_2_3_2.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/sco_2_3_2.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/sco_2_3_2.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/sco_2_3_3.sh
===================================================================
--- trunk/contrib/perl/hints/sco_2_3_3.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/sco_2_3_3.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/sco_2_3_3.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/sco_2_3_4.sh
===================================================================
--- trunk/contrib/perl/hints/sco_2_3_4.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/sco_2_3_4.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/sco_2_3_4.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/hints/solaris_2.sh
===================================================================
--- trunk/contrib/perl/hints/solaris_2.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/solaris_2.sh 2013-12-02 21:26:09 UTC (rev 6439)
@@ -300,7 +300,7 @@
END
ccdlflags="$ccdlflags -Wl,-E"
- lddlflags="$lddlflags -Wl,-E -G"
+ lddlflags="$lddlflags -Wl,-E -shared"
fi
fi
@@ -311,11 +311,15 @@
cat > try.c << 'EOM'
#include <stdio.h>
int main() {
-#ifdef __SUNPRO_C
+#if defined(__SUNPRO_C)
printf("workshop\n");
#else
+#if defined(__SUNPRO_CC)
+ printf("workshop CC\n");
+#else
printf("\n");
#endif
+#endif
return(0);
}
EOM
@@ -323,11 +327,27 @@
if $tryworkshopcc >/dev/null 2>&1; then
cc_name=`./try`
if test "$cc_name" = "workshop"; then
- ccversion="`${cc:-cc} -V 2>&1|sed -n -e '1s/^cc: //p'`"
+ ccversion="`${cc:-cc} -V 2>&1|sed -n -e '1s/^[Cc][Cc]: //p'`"
+ fi
+ if test "$cc_name" = "workshop CC"; then
+ ccversion="`${cc:-CC} -V 2>&1|sed -n -e '1s/^[Cc][C]: //p'`"
+ fi
+ case "$cc_name" in
+ workshop*)
+ # Settings for either cc or CC
if test ! "$use64bitall_done"; then
loclibpth="/usr/lib /usr/ccs/lib `$getworkshoplibs` $loclibpth"
fi
- fi
+ # Sun CC/cc don't support gcc attributes
+ d_attribute_format='undef'
+ d_attribute_malloc='undef'
+ d_attribute_nonnull='undef'
+ d_attribute_noreturn='undef'
+ d_attribute_pure='undef'
+ d_attribute_unused='undef'
+ d_attribute_warn_unused_result='undef'
+ ;;
+ esac
fi
# See if as(1) is GNU as(1). GNU might not work for this job.
@@ -568,7 +588,17 @@
# ccflags="$ccflags -Wa,`getconf XBS5_LP64_OFF64_CFLAGS 2>/dev/null`"
# fi
ldflags="$ldflags -m64"
- lddlflags="$lddlflags -G -m64"
+
+ # See [perl #66604]: On Solaris 11, gcc -m64 on amd64
+ # appears not to understand -G. (gcc -G has not caused
+ # problems on other platforms in the past.) gcc versions
+ # at least as old as 3.4.3 support -shared, so just
+ # use that with Solaris 11 and later, but keep
+ # the old behavior for older Solaris versions.
+ case "$osvers" in
+ 2.?|2.10) lddlflags="$lddlflags -G -m64" ;;
+ *) lddlflags="$lddlflags -shared -m64" ;;
+ esac
;;
*)
getconfccflags="`getconf XBS5_LP64_OFF64_CFLAGS 2>/dev/null`"
Property changes on: trunk/contrib/perl/hints/solaris_2.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/hints/stellar.sh
===================================================================
--- trunk/contrib/perl/hints/stellar.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/stellar.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/stellar.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/sunos_4_0.sh
===================================================================
--- trunk/contrib/perl/hints/sunos_4_0.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/sunos_4_0.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/sunos_4_0.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/sunos_4_1.sh
===================================================================
--- trunk/contrib/perl/hints/sunos_4_1.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/sunos_4_1.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/sunos_4_1.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/super-ux.sh
===================================================================
--- trunk/contrib/perl/hints/super-ux.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/super-ux.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/super-ux.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/svr4.sh
===================================================================
--- trunk/contrib/perl/hints/svr4.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/svr4.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/svr4.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/hints/svr5.sh
===================================================================
--- trunk/contrib/perl/hints/svr5.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/svr5.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/svr5.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/hints/t001.c
===================================================================
--- trunk/contrib/perl/hints/t001.c 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/t001.c 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/t001.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/hints/ti1500.sh
===================================================================
--- trunk/contrib/perl/hints/ti1500.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/ti1500.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/ti1500.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/titanos.sh
===================================================================
--- trunk/contrib/perl/hints/titanos.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/titanos.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/titanos.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/ultrix_4.sh
===================================================================
--- trunk/contrib/perl/hints/ultrix_4.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/ultrix_4.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/ultrix_4.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/umips.sh
===================================================================
--- trunk/contrib/perl/hints/umips.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/umips.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/umips.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/unicos.sh
===================================================================
--- trunk/contrib/perl/hints/unicos.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/unicos.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/unicos.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/unicosmk.sh
===================================================================
--- trunk/contrib/perl/hints/unicosmk.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/unicosmk.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/unicosmk.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/unisysdynix.sh
===================================================================
--- trunk/contrib/perl/hints/unisysdynix.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/unisysdynix.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/unisysdynix.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/utekv.sh
===================================================================
--- trunk/contrib/perl/hints/utekv.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/utekv.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/utekv.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/hints/uts.sh
===================================================================
--- trunk/contrib/perl/hints/uts.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/uts.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/uts.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/hints/uwin.sh
===================================================================
--- trunk/contrib/perl/hints/uwin.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/uwin.sh 2013-12-02 21:26:09 UTC (rev 6439)
@@ -46,8 +46,7 @@
# __UWIN__ added so it could be used in ext/POSIX/POSIX.xs
# to protect against either tzname definition. According to Dave Korn
-#dgk gcc on uwin also predefined _UWIN as does the borland and digital
-#dgk mars compiler.
+#dgk gcc on uwin also predefined _UWIN as does the digital mars compiler.
#dgk
#dgk Only ncc does not define _UWIN and this is intentional. ncc is used
#dgk to build binaries that do not require the uwin runtime.
Property changes on: trunk/contrib/perl/hints/uwin.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/hints/vmesa.sh
===================================================================
--- trunk/contrib/perl/hints/vmesa.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/vmesa.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/hints/vmesa.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/hints/vos.sh
===================================================================
--- trunk/contrib/perl/hints/vos.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/hints/vos.sh 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,29 +1,33 @@
-# $Id: vos.sh,v 1.1.1.1 2011-05-19 23:03:36 laffer1 Exp $
-
-# This is a hints file for Stratus VOS, using the POSIX environment
-# in VOS 14.4.0 and higher.
+# This is a hints file for Stratus OpenVOS, using the POSIX environment
+# found in VOS 17.1.0 and higher.
#
-# VOS POSIX is based on POSIX.1-1996 and contains elements of
+# OpenVOS POSIX is based on POSIX.1-1996 and contains elements of
# POSIX.1-2001. It ships with gcc as the standard compiler.
#
# Paul Green (Paul.Green at stratus.com)
# C compiler and default options.
-cc=gcc
-ccflags="-D_SVID_SOURCE -D_POSIX_C_SOURCE=200112L -D_VOS_EXTENDED_NAMES"
+cc=${CC-gcc}
+ccflags=${CFLAGS-"-D_XOPEN_SOURCE=700 -D_SYSV -D_VOS_EXTENDED_NAMES -D_FILE_OFFSET_BITS=64"}
# Make command.
-make="/system/gnu_library/bin/gmake"
+make=${MAKE-"/system/gnu_library/bin/gmake"}
# indented to not put it into config.sh
- _make="/system/gnu_library/bin/gmake"
+ _make=${MAKE-"/system/gnu_library/bin/gmake"}
-# Architecture name
-if test `uname -m` = i786; then
- archname="i786"
-else
- archname="hppa1.1"
+# Check for the minimum acceptable release of OpenVOS (17.1.0).
+if test `uname -r | sed -e 's/OpenVOS Release //' -e 's/VOS Release //'` \< "17.1.0"; then
+cat >&4 <<EOF
+***
+*** This version of Perl 5 must be built on OpenVOS Release 17.1.0 or later.
+***
+EOF
+exit 1
fi
+# Architecture name always X86
+archname=`uname -m`
+
# Executable suffix.
# No, this is not a typo. The ".pm" really is the native
# executable suffix in VOS. Talk about cosmic resonance.
@@ -30,11 +34,6 @@
_exe=".pm"
# Object library paths.
-loclibpth="/system/stcp/object_library"
-loclibpth="$loclibpth /system/stcp/object_library/common"
-loclibpth="$loclibpth /system/stcp/object_library/net"
-loclibpth="$loclibpth /system/stcp/object_library/socket"
-loclibpth="$loclibpth /system/posix_object_library/sysv"
loclibpth="$loclibpth /system/posix_object_library"
loclibpth="$loclibpth /system/c_object_library"
loclibpth="$loclibpth /system/object_library"
@@ -41,31 +40,18 @@
glibpth="$loclibpth"
# Include library paths
-# Pick up vos/syslog.h on Continuum Platform.
-if test "$archname" = "i786"; then
- locincpth=""
-else
- locincpth=`pwd`/vos
-fi
-locincpth="$locincpth /system/stcp/include_library"
-locincpth="$locincpth /system/include_library/sysv"
-usrinc="/system/include_library"
+locincpth=""
+usrinc=${USRINC-"/system/include_library"}
# Where to install perl5.
-prefix=/system/ported/perl5
+prefix=/system/ported
# Linker is gcc.
-ld="gcc"
+ld=${CC-"gcc"}
-# No shared libraries.
-so="none"
-
-# Don't use nm.
+# Don't use nm. The VOS copy of libc.a is empty.
usenm="n"
-# Make the default be no large file support.
-uselargefiles="n"
-
# Don't use malloc that comes with perl.
usemymalloc="n"
@@ -72,8 +58,8 @@
# Make bison the default compiler-compiler.
yacc="/system/gnu_library/bin/bison"
-# VOS doesn't have (or need) a pager, but perl needs one.
-pager="/system/gnu_library/bin/cat.pm"
+# VOS doesn't need a pager, but perl does.
+pager="/system/gnu_library/bin/less.pm"
# VOS has a bug that causes _exit() to flush all files.
# This confuses the tests. Make 'em happy here.
@@ -89,71 +75,29 @@
# Help gmake find vos.c
test -h vos.c || ln -s vos/vos.c vos.c
-# VOS returns a constant 1 for st_nlink when stat'ing a
-# directory. Therefore, we must set this variable to stop
-# File::Find using the link count to determine whether there are
-# subdirectories to be searched.
-dont_use_nlink=define
-
# Tell Configure where to find the hosts file.
hostcat="cat /system/stcp/hosts"
-# VOS does not have socketpair() but we supply one in vos.c
-d_sockpair="define"
+# VOS 17.1 has support for dynamic linking.
+usedl="define"
-# Once we have the compiler flags defined, Configure will
-# execute the following call-back script. See hints/README.hints
-# for details.
-cat > UU/cc.cbu <<'EOCBU'
-# This script UU/cc.cbu will get 'called-back' by Configure after it
-# has prompted the user for the C compiler to use.
+# Filename suffix for shared libraries.
+so="so"
-# Compile and run the a test case to see if bug gnu_g++-220 is
-# present. If so, lower the optimization level when compiling
-# pp_pack.c. This works around a bug in unpack.
+# Flags used when compiling a module for a shared library.
+cccdlflags="-fPIC"
-echo " "
-echo "Testing whether bug gnu_g++-220 is fixed in your compiler..."
+# Flags passed to $ld to produce shared libraries.
+lddlflags="-shared"
-# Try compiling the test case.
-if $cc -o t001 -O $ccflags $ldflags ../hints/t001.c; then
- gccbug=`$run ./t001`
- if [ "X$gccversion" = "X" ]; then
- # Done too late in Configure if hinted
- gccversion=`$cc -dumpversion`
- fi
- case "$gccbug" in
- *fails*) cat >&4 <<EOF
-This C compiler ($gccversion) is known to have optimizer
-problems when compiling pp_pack.c. The Stratus bug number
-for this problem is gnu_g++-220.
+# Flags passed to $cc when linking a program that uses shared libraries.
+ccdlflags="-Wl,-export-dynamic"
-Disabling optimization for pp_pack.c.
-EOF
- case "$pp_pack_cflags" in
- '') pp_pack_cflags='optimize='
- echo "pp_pack_cflags='optimize=\"\"'" >> config.sh ;;
- *) echo "You specified pp_pack_cflags yourself, so we'll go with your value." >&4 ;;
- esac
- ;;
- *) echo "Your compiler is ok." >&4
- ;;
- esac
-else
- echo " "
- echo "*** WHOA THERE!!! ***" >&4
- echo " Your C compiler \"$cc\" doesn't seem to be working!" >&4
- case "$knowitall" in
- '')
- echo " You'd better start hunting for one and let me know about it." >&4
- exit 1
- ;;
- esac
-fi
+# Filename suffix for dynamically-loaded perl modules.
+dlext="so"
-$rm -f t001$_o t001$_exe t001.kp
-EOCBU
+# Use dlopen() to open shared libraries.
+dlsrc="dl_dlopen.xs"
-
-# VOS 14.7 has minimal support for dynamic linking. Too minimal for perl.
-usedl="undef"
+# Build a shared libperl? (Define on Configure cmd line.)
+# useshrplib="true"
Property changes on: trunk/contrib/perl/hints/vos.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/lib/AnyDBM_File.pm
===================================================================
--- trunk/contrib/perl/lib/AnyDBM_File.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/AnyDBM_File.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,7 +1,9 @@
package AnyDBM_File;
+use warnings;
+use strict;
use 5.006_001;
-our $VERSION = '1.00';
+our $VERSION = '1.01';
our @ISA = qw(NDBM_File DB_File GDBM_File SDBM_File ODBM_File) unless @ISA;
my $mod;
@@ -13,8 +15,9 @@
}
die "No DBM package was successfully found or installed";
-#return 0;
+__END__
+
=head1 NAME
AnyDBM_File - provide framework for multiple DBMs
@@ -39,7 +42,7 @@
Having multiple DBM implementations makes it trivial to copy database formats:
- use POSIX; use NDBM_File; use DB_File;
+ use Fcntl; use NDBM_File; use DB_File;
tie %newhash, 'DB_File', $new_filename, O_CREAT|O_RDWR;
tie %oldhash, 'NDBM_File', $old_filename, 1, 0;
%newhash = %oldhash;
Property changes on: trunk/contrib/perl/lib/AnyDBM_File.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/lib/AnyDBM_File.t
===================================================================
--- trunk/contrib/perl/lib/AnyDBM_File.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/AnyDBM_File.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -14,7 +14,7 @@
$Is_Dosish = ($^O eq 'amigaos' || $^O eq 'MSWin32' ||
$^O eq 'NetWare' || $^O eq 'dos' ||
- $^O eq 'os2' || $^O eq 'mint' ||
+ $^O eq 'os2' ||
$^O eq 'cygwin');
my $filename = "Any_dbmx$$";
Property changes on: trunk/contrib/perl/lib/AnyDBM_File.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/lib/AutoLoader.pm (from rev 6437, vendor/perl/5.18.1/lib/AutoLoader.pm)
===================================================================
--- trunk/contrib/perl/lib/AutoLoader.pm (rev 0)
+++ trunk/contrib/perl/lib/AutoLoader.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,429 @@
+package AutoLoader;
+
+use strict;
+use 5.006_001;
+
+our($VERSION, $AUTOLOAD);
+
+my $is_dosish;
+my $is_epoc;
+my $is_vms;
+my $is_macos;
+
+BEGIN {
+ $is_dosish = $^O eq 'dos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare';
+ $is_epoc = $^O eq 'epoc';
+ $is_vms = $^O eq 'VMS';
+ $is_macos = $^O eq 'MacOS';
+ $VERSION = '5.68';
+}
+
+AUTOLOAD {
+ my $sub = $AUTOLOAD;
+ my $filename = AutoLoader::find_filename( $sub );
+
+ my $save = $@;
+ local $!; # Do not munge the value.
+ eval { local $SIG{__DIE__}; require $filename };
+ if ($@) {
+ if (substr($sub,-9) eq '::DESTROY') {
+ no strict 'refs';
+ *$sub = sub {};
+ $@ = undef;
+ } elsif ($@ =~ /^Can't locate/) {
+ # The load might just have failed because the filename was too
+ # long for some old SVR3 systems which treat long names as errors.
+ # If we can successfully truncate a long name then it's worth a go.
+ # There is a slight risk that we could pick up the wrong file here
+ # but autosplit should have warned about that when splitting.
+ if ($filename =~ s/(\w{12,})\.al$/substr($1,0,11).".al"/e){
+ eval { local $SIG{__DIE__}; require $filename };
+ }
+ }
+ if ($@){
+ $@ =~ s/ at .*\n//;
+ my $error = $@;
+ require Carp;
+ Carp::croak($error);
+ }
+ }
+ $@ = $save;
+ goto &$sub;
+}
+
+sub find_filename {
+ my $sub = shift;
+ my $filename;
+ # Braces used to preserve $1 et al.
+ {
+ # Try to find the autoloaded file from the package-qualified
+ # name of the sub. e.g., if the sub needed is
+ # Getopt::Long::GetOptions(), then $INC{Getopt/Long.pm} is
+ # something like '/usr/lib/perl5/Getopt/Long.pm', and the
+ # autoload file is '/usr/lib/perl5/auto/Getopt/Long/GetOptions.al'.
+ #
+ # However, if @INC is a relative path, this might not work. If,
+ # for example, @INC = ('lib'), then $INC{Getopt/Long.pm} is
+ # 'lib/Getopt/Long.pm', and we want to require
+ # 'auto/Getopt/Long/GetOptions.al' (without the leading 'lib').
+ # In this case, we simple prepend the 'auto/' and let the
+ # C<require> take care of the searching for us.
+
+ my ($pkg,$func) = ($sub =~ /(.*)::([^:]+)$/);
+ $pkg =~ s#::#/#g;
+ if (defined($filename = $INC{"$pkg.pm"})) {
+ if ($is_macos) {
+ $pkg =~ tr#/#:#;
+ $filename = undef
+ unless $filename =~ s#^(.*)$pkg\.pm\z#$1auto:$pkg:$func.al#s;
+ } else {
+ $filename = undef
+ unless $filename =~ s#^(.*)$pkg\.pm\z#$1auto/$pkg/$func.al#s;
+ }
+
+ # if the file exists, then make sure that it is a
+ # a fully anchored path (i.e either '/usr/lib/auto/foo/bar.al',
+ # or './lib/auto/foo/bar.al'. This avoids C<require> searching
+ # (and failing) to find the 'lib/auto/foo/bar.al' because it
+ # looked for 'lib/lib/auto/foo/bar.al', given @INC = ('lib').
+
+ if (defined $filename and -r $filename) {
+ unless ($filename =~ m|^/|s) {
+ if ($is_dosish) {
+ unless ($filename =~ m{^([a-z]:)?[\\/]}is) {
+ if ($^O ne 'NetWare') {
+ $filename = "./$filename";
+ } else {
+ $filename = "$filename";
+ }
+ }
+ }
+ elsif ($is_epoc) {
+ unless ($filename =~ m{^([a-z?]:)?[\\/]}is) {
+ $filename = "./$filename";
+ }
+ }
+ elsif ($is_vms) {
+ # XXX todo by VMSmiths
+ $filename = "./$filename";
+ }
+ elsif (!$is_macos) {
+ $filename = "./$filename";
+ }
+ }
+ }
+ else {
+ $filename = undef;
+ }
+ }
+ unless (defined $filename) {
+ # let C<require> do the searching
+ $filename = "auto/$sub.al";
+ $filename =~ s#::#/#g;
+ }
+ }
+ return $filename;
+}
+
+sub import {
+ my $pkg = shift;
+ my $callpkg = caller;
+
+ #
+ # Export symbols, but not by accident of inheritance.
+ #
+
+ if ($pkg eq 'AutoLoader') {
+ if ( @_ and $_[0] =~ /^&?AUTOLOAD$/ ) {
+ no strict 'refs';
+ *{ $callpkg . '::AUTOLOAD' } = \&AUTOLOAD;
+ }
+ }
+
+ #
+ # Try to find the autosplit index file. Eg., if the call package
+ # is POSIX, then $INC{POSIX.pm} is something like
+ # '/usr/local/lib/perl5/POSIX.pm', and the autosplit index file is in
+ # '/usr/local/lib/perl5/auto/POSIX/autosplit.ix', so we require that.
+ #
+ # However, if @INC is a relative path, this might not work. If,
+ # for example, @INC = ('lib'), then
+ # $INC{POSIX.pm} is 'lib/POSIX.pm', and we want to require
+ # 'auto/POSIX/autosplit.ix' (without the leading 'lib').
+ #
+
+ (my $calldir = $callpkg) =~ s#::#/#g;
+ my $path = $INC{$calldir . '.pm'};
+ if (defined($path)) {
+ # Try absolute path name, but only eval it if the
+ # transformation from module path to autosplit.ix path
+ # succeeded!
+ my $replaced_okay;
+ if ($is_macos) {
+ (my $malldir = $calldir) =~ tr#/#:#;
+ $replaced_okay = ($path =~ s#^(.*)$malldir\.pm\z#$1auto:$malldir:autosplit.ix#s);
+ } else {
+ $replaced_okay = ($path =~ s#^(.*)$calldir\.pm\z#$1auto/$calldir/autosplit.ix#);
+ }
+
+ eval { require $path; } if $replaced_okay;
+ # If that failed, try relative path with normal @INC searching.
+ if (!$replaced_okay or $@) {
+ $path ="auto/$calldir/autosplit.ix";
+ eval { require $path; };
+ }
+ if ($@) {
+ my $error = $@;
+ require Carp;
+ Carp::carp($error);
+ }
+ }
+}
+
+sub unimport {
+ my $callpkg = caller;
+
+ no strict 'refs';
+
+ for my $exported (qw( AUTOLOAD )) {
+ my $symname = $callpkg . '::' . $exported;
+ undef *{ $symname } if \&{ $symname } == \&{ $exported };
+ *{ $symname } = \&{ $symname };
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+AutoLoader - load subroutines only on demand
+
+=head1 SYNOPSIS
+
+ package Foo;
+ use AutoLoader 'AUTOLOAD'; # import the default AUTOLOAD subroutine
+
+ package Bar;
+ use AutoLoader; # don't import AUTOLOAD, define our own
+ sub AUTOLOAD {
+ ...
+ $AutoLoader::AUTOLOAD = "...";
+ goto &AutoLoader::AUTOLOAD;
+ }
+
+=head1 DESCRIPTION
+
+The B<AutoLoader> module works with the B<AutoSplit> module and the
+C<__END__> token to defer the loading of some subroutines until they are
+used rather than loading them all at once.
+
+To use B<AutoLoader>, the author of a module has to place the
+definitions of subroutines to be autoloaded after an C<__END__> token.
+(See L<perldata>.) The B<AutoSplit> module can then be run manually to
+extract the definitions into individual files F<auto/funcname.al>.
+
+B<AutoLoader> implements an AUTOLOAD subroutine. When an undefined
+subroutine in is called in a client module of B<AutoLoader>,
+B<AutoLoader>'s AUTOLOAD subroutine attempts to locate the subroutine in a
+file with a name related to the location of the file from which the
+client module was read. As an example, if F<POSIX.pm> is located in
+F</usr/local/lib/perl5/POSIX.pm>, B<AutoLoader> will look for perl
+subroutines B<POSIX> in F</usr/local/lib/perl5/auto/POSIX/*.al>, where
+the C<.al> file has the same name as the subroutine, sans package. If
+such a file exists, AUTOLOAD will read and evaluate it,
+thus (presumably) defining the needed subroutine. AUTOLOAD will then
+C<goto> the newly defined subroutine.
+
+Once this process completes for a given function, it is defined, so
+future calls to the subroutine will bypass the AUTOLOAD mechanism.
+
+=head2 Subroutine Stubs
+
+In order for object method lookup and/or prototype checking to operate
+correctly even when methods have not yet been defined it is necessary to
+"forward declare" each subroutine (as in C<sub NAME;>). See
+L<perlsub/"SYNOPSIS">. Such forward declaration creates "subroutine
+stubs", which are place holders with no code.
+
+The AutoSplit and B<AutoLoader> modules automate the creation of forward
+declarations. The AutoSplit module creates an 'index' file containing
+forward declarations of all the AutoSplit subroutines. When the
+AutoLoader module is 'use'd it loads these declarations into its callers
+package.
+
+Because of this mechanism it is important that B<AutoLoader> is always
+C<use>d and not C<require>d.
+
+=head2 Using B<AutoLoader>'s AUTOLOAD Subroutine
+
+In order to use B<AutoLoader>'s AUTOLOAD subroutine you I<must>
+explicitly import it:
+
+ use AutoLoader 'AUTOLOAD';
+
+=head2 Overriding B<AutoLoader>'s AUTOLOAD Subroutine
+
+Some modules, mainly extensions, provide their own AUTOLOAD subroutines.
+They typically need to check for some special cases (such as constants)
+and then fallback to B<AutoLoader>'s AUTOLOAD for the rest.
+
+Such modules should I<not> import B<AutoLoader>'s AUTOLOAD subroutine.
+Instead, they should define their own AUTOLOAD subroutines along these
+lines:
+
+ use AutoLoader;
+ use Carp;
+
+ sub AUTOLOAD {
+ my $sub = $AUTOLOAD;
+ (my $constname = $sub) =~ s/.*:://;
+ my $val = constant($constname, @_ ? $_[0] : 0);
+ if ($! != 0) {
+ if ($! =~ /Invalid/ || $!{EINVAL}) {
+ $AutoLoader::AUTOLOAD = $sub;
+ goto &AutoLoader::AUTOLOAD;
+ }
+ else {
+ croak "Your vendor has not defined constant $constname";
+ }
+ }
+ *$sub = sub { $val }; # same as: eval "sub $sub { $val }";
+ goto &$sub;
+ }
+
+If any module's own AUTOLOAD subroutine has no need to fallback to the
+AutoLoader's AUTOLOAD subroutine (because it doesn't have any AutoSplit
+subroutines), then that module should not use B<AutoLoader> at all.
+
+=head2 Package Lexicals
+
+Package lexicals declared with C<my> in the main block of a package
+using B<AutoLoader> will not be visible to auto-loaded subroutines, due to
+the fact that the given scope ends at the C<__END__> marker. A module
+using such variables as package globals will not work properly under the
+B<AutoLoader>.
+
+The C<vars> pragma (see L<perlmod/"vars">) may be used in such
+situations as an alternative to explicitly qualifying all globals with
+the package namespace. Variables pre-declared with this pragma will be
+visible to any autoloaded routines (but will not be invisible outside
+the package, unfortunately).
+
+=head2 Not Using AutoLoader
+
+You can stop using AutoLoader by simply
+
+ no AutoLoader;
+
+=head2 B<AutoLoader> vs. B<SelfLoader>
+
+The B<AutoLoader> is similar in purpose to B<SelfLoader>: both delay the
+loading of subroutines.
+
+B<SelfLoader> uses the C<__DATA__> marker rather than C<__END__>.
+While this avoids the use of a hierarchy of disk files and the
+associated open/close for each routine loaded, B<SelfLoader> suffers a
+startup speed disadvantage in the one-time parsing of the lines after
+C<__DATA__>, after which routines are cached. B<SelfLoader> can also
+handle multiple packages in a file.
+
+B<AutoLoader> only reads code as it is requested, and in many cases
+should be faster, but requires a mechanism like B<AutoSplit> be used to
+create the individual files. L<ExtUtils::MakeMaker> will invoke
+B<AutoSplit> automatically if B<AutoLoader> is used in a module source
+file.
+
+=head1 CAVEATS
+
+AutoLoaders prior to Perl 5.002 had a slightly different interface. Any
+old modules which use B<AutoLoader> should be changed to the new calling
+style. Typically this just means changing a require to a use, adding
+the explicit C<'AUTOLOAD'> import if needed, and removing B<AutoLoader>
+from C<@ISA>.
+
+On systems with restrictions on file name length, the file corresponding
+to a subroutine may have a shorter name that the routine itself. This
+can lead to conflicting file names. The I<AutoSplit> package warns of
+these potential conflicts when used to split a module.
+
+AutoLoader may fail to find the autosplit files (or even find the wrong
+ones) in cases where C<@INC> contains relative paths, B<and> the program
+does C<chdir>.
+
+=head1 SEE ALSO
+
+L<SelfLoader> - an autoloader that doesn't use external files.
+
+=head1 AUTHOR
+
+C<AutoLoader> is maintained by the perl5-porters. Please direct
+any questions to the canonical mailing list. Anything that
+is applicable to the CPAN release can be sent to its maintainer,
+though.
+
+Author and Maintainer: The Perl5-Porters <perl5-porters at perl.org>
+
+Maintainer of the CPAN release: Steffen Mueller <smueller at cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This package has been part of the perl core since the first release
+of perl5. It has been released separately to CPAN so older installations
+can benefit from bug fixes.
+
+This package has the same copyright and license as the perl core:
+
+ Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
+ by Larry Wall and others
+
+ All rights reserved.
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of either:
+
+ a) the GNU General Public License as published by the Free
+ Software Foundation; either version 1, or (at your option) any
+ later version, or
+
+ b) the "Artistic License" which comes with this Kit.
+
+ 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 either
+ the GNU General Public License or the Artistic License for more details.
+
+ You should have received a copy of the Artistic License with this
+ Kit, in the file named "Artistic". If not, I'll be glad to provide one.
+
+ You should also have received a copy of the GNU General Public License
+ along with this program in the file named "Copying". If not, write to the
+ Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+ 02111-1307, USA or visit their web page on the internet at
+ http://www.gnu.org/copyleft/gpl.html.
+
+ For those of you that choose to use the GNU General Public License,
+ my interpretation of the GNU General Public License is that no Perl
+ script falls under the terms of the GPL unless you explicitly put
+ said script under the terms of the GPL yourself. Furthermore, any
+ object code linked with perl does not automatically fall under the
+ terms of the GPL, provided such object code only adds definitions
+ of subroutines and variables, and does not otherwise impair the
+ resulting interpreter from executing any standard Perl script. I
+ consider linking in C subroutines in this manner to be the moral
+ equivalent of defining subroutines in the Perl language itself. You
+ may sell such an object file as proprietary provided that you provide
+ or offer to provide the Perl source, as specified by the GNU General
+ Public License. (This is merely an alternate way of specifying input
+ to the program.) You may also sell a binary produced by the dumping of
+ a running Perl script that belongs to you, provided that you provide or
+ offer to provide the Perl source as specified by the GPL. (The
+ fact that a Perl interpreter and your code are in the same binary file
+ is, in this case, a form of mere aggregation.) This is my interpretation
+ of the GPL. If you still have concerns or difficulties understanding
+ my intent, feel free to contact me. Of course, the Artistic License
+ spells all this out for your protection, so you may prefer to use that.
+
+=cut
Copied: trunk/contrib/perl/lib/AutoLoader.t (from rev 6437, vendor/perl/5.18.1/lib/AutoLoader.t)
===================================================================
--- trunk/contrib/perl/lib/AutoLoader.t (rev 0)
+++ trunk/contrib/perl/lib/AutoLoader.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,186 @@
+#!./perl -w
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use strict;
+use File::Spec;
+use File::Path;
+
+my $dir;
+BEGIN
+{
+ $dir = File::Spec->catdir( "auto-$$" );
+ unshift @INC, $dir;
+}
+
+use Test::More tests => 22;
+
+# First we must set up some autoloader files
+my $fulldir = File::Spec->catdir( $dir, 'auto', 'Foo' );
+mkpath( $fulldir ) or die "Can't mkdir '$fulldir': $!";
+
+open(FOO, '>', File::Spec->catfile( $fulldir, 'foo.al' ))
+ or die "Can't open foo file: $!";
+print FOO <<'EOT';
+package Foo;
+sub foo { shift; shift || "foo" }
+1;
+EOT
+close(FOO);
+
+open(BAR, '>', File::Spec->catfile( $fulldir, 'bar.al' ))
+ or die "Can't open bar file: $!";
+print BAR <<'EOT';
+package Foo;
+sub bar { shift; shift || "bar" }
+1;
+EOT
+close(BAR);
+
+open(BAZ, '>', File::Spec->catfile( $fulldir, 'bazmarkhian.al' ))
+ or die "Can't open bazmarkhian file: $!";
+print BAZ <<'EOT';
+package Foo;
+sub bazmarkhianish { shift; shift || "baz" }
+1;
+EOT
+close(BAZ);
+
+open(BLECH, '>', File::Spec->catfile( $fulldir, 'blechanawilla.al' ))
+ or die "Can't open blech file: $!";
+print BLECH <<'EOT';
+package Foo;
+sub blechanawilla { compilation error (
+EOT
+close(BLECH);
+
+# This is just to keep the old SVR3 systems happy; they may fail
+# to find the above file so we duplicate it where they should find it.
+open(BLECH, '>', File::Spec->catfile( $fulldir, 'blechanawil.al' ))
+ or die "Can't open blech file: $!";
+print BLECH <<'EOT';
+package Foo;
+sub blechanawilla { compilation error (
+EOT
+close(BLECH);
+
+# Let's define the package
+package Foo;
+require AutoLoader;
+AutoLoader->import( 'AUTOLOAD' );
+
+sub new { bless {}, shift };
+sub foo;
+sub bazmarkhianish;
+
+package main;
+
+my $foo = Foo->new();
+
+my $result = $foo->can( 'foo' );
+ok( $result, 'can() first time' );
+is( $foo->foo, 'foo', 'autoloaded first time' );
+is( $foo->foo, 'foo', 'regular call' );
+is( $result, \&Foo::foo, 'can() returns ref to regular installed sub' );
+$result = $foo->can( 'bar' );
+ok( $result, 'can() should work when importing AUTOLOAD too' );
+is( $foo->bar, 'bar', 'regular call' );
+is( $result, \&Foo::bar, '... returning ref to regular installed sub' );
+
+eval {
+ $foo->will_fail;
+};
+like( $@, qr/^Can't locate/, 'undefined method' );
+
+$result = $foo->can( 'will_fail' );
+ok( ! $result, 'can() should fail on undefined methods' );
+
+# Used to be trouble with this
+eval {
+ my $foo = Foo->new();
+ die "oops";
+};
+like( $@, qr/oops/, 'indirect method call' );
+
+# Pass regular expression variable to autoloaded function. This used
+# to go wrong because AutoLoader used regular expressions to generate
+# autoloaded filename.
+'foo' =~ /(\w+)/;
+
+is( $foo->bar($1), 'foo', 'autoloaded method should not stomp match vars' );
+is( $foo->bar($1), 'foo', '(again)' );
+is( $foo->bazmarkhianish($1), 'foo', 'for any method call' );
+is( $foo->bazmarkhianish($1), 'foo', '(again)' );
+
+# Used to retry long subnames with shorter filenames on any old
+# exception, including compilation error. Now AutoLoader only
+# tries shorter filenames if it can't find the long one.
+eval {
+ $foo->blechanawilla;
+};
+like( $@, qr/syntax error/i, 'require error propagates' );
+
+# test recursive autoloads
+open(F, '>', File::Spec->catfile( $fulldir, 'a.al'))
+ or die "Cannot make 'a' file: $!";
+print F <<'EOT';
+package Foo;
+BEGIN { b() }
+sub a { ::ok( 1, 'adding a new autoloaded method' ); }
+1;
+EOT
+close(F);
+
+open(F, '>', File::Spec->catfile( $fulldir, 'b.al'))
+ or die "Cannot make 'b' file: $!";
+print F <<'EOT';
+package Foo;
+sub b { ::ok( 1, 'adding a new autoloaded method' ) }
+1;
+EOT
+close(F);
+Foo::a();
+
+package Bar;
+AutoLoader->import();
+::ok( ! defined &AUTOLOAD, 'AutoLoader should not export AUTOLOAD by default' );
+::ok( ! defined &can, '... nor can()' );
+
+package Foo;
+AutoLoader->unimport();
+eval { Foo->baz() };
+::like( $@, qr/locate object method "baz"/,
+ 'unimport() should remove imported AUTOLOAD()' );
+
+package Baz;
+
+sub AUTOLOAD { 'i am here' }
+
+AutoLoader->import();
+AutoLoader->unimport();
+
+::is( Baz->AUTOLOAD(), 'i am here', '... but not non-imported AUTOLOAD()' );
+
+
+package SomeClass;
+use AutoLoader 'AUTOLOAD';
+sub new {
+ bless {} => shift;
+}
+
+package main;
+
+$INC{"SomeClass.pm"} = $0; # Prepare possible recursion
+{
+ my $p = SomeClass->new();
+} # <-- deep recursion in AUTOLOAD looking for SomeClass::DESTROY?
+::ok(1, "AutoLoader shouldn't loop forever if \%INC is modified");
+
+# cleanup
+END {
+ return unless $dir && -d $dir;
+ rmtree $dir;
+}
Copied: trunk/contrib/perl/lib/AutoSplit.pm (from rev 6437, vendor/perl/5.18.1/lib/AutoSplit.pm)
===================================================================
--- trunk/contrib/perl/lib/AutoSplit.pm (rev 0)
+++ trunk/contrib/perl/lib/AutoSplit.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,592 @@
+package AutoSplit;
+
+use Exporter ();
+use Config qw(%Config);
+use File::Basename ();
+use File::Path qw(mkpath);
+use File::Spec::Functions qw(curdir catfile catdir);
+use strict;
+our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $Verbose, $Keep, $Maxlen,
+ $CheckForAutoloader, $CheckModTime);
+
+$VERSION = "1.06";
+ at ISA = qw(Exporter);
+ at EXPORT = qw(&autosplit &autosplit_lib_modules);
+ at EXPORT_OK = qw($Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime);
+
+=head1 NAME
+
+AutoSplit - split a package for autoloading
+
+=head1 SYNOPSIS
+
+ autosplit($file, $dir, $keep, $check, $modtime);
+
+ autosplit_lib_modules(@modules);
+
+=head1 DESCRIPTION
+
+This function will split up your program into files that the AutoLoader
+module can handle. It is used by both the standard perl libraries and by
+the MakeMaker utility, to automatically configure libraries for autoloading.
+
+The C<autosplit> interface splits the specified file into a hierarchy
+rooted at the directory C<$dir>. It creates directories as needed to reflect
+class hierarchy, and creates the file F<autosplit.ix>. This file acts as
+both forward declaration of all package routines, and as timestamp for the
+last update of the hierarchy.
+
+The remaining three arguments to C<autosplit> govern other options to
+the autosplitter.
+
+=over 2
+
+=item $keep
+
+If the third argument, I<$keep>, is false, then any
+pre-existing C<*.al> files in the autoload directory are removed if
+they are no longer part of the module (obsoleted functions).
+$keep defaults to 0.
+
+=item $check
+
+The
+fourth argument, I<$check>, instructs C<autosplit> to check the module
+currently being split to ensure that it includes a C<use>
+specification for the AutoLoader module, and skips the module if
+AutoLoader is not detected.
+$check defaults to 1.
+
+=item $modtime
+
+Lastly, the I<$modtime> argument specifies
+that C<autosplit> is to check the modification time of the module
+against that of the C<autosplit.ix> file, and only split the module if
+it is newer.
+$modtime defaults to 1.
+
+=back
+
+Typical use of AutoSplit in the perl MakeMaker utility is via the command-line
+with:
+
+ perl -e 'use AutoSplit; autosplit($ARGV[0], $ARGV[1], 0, 1, 1)'
+
+Defined as a Make macro, it is invoked with file and directory arguments;
+C<autosplit> will split the specified file into the specified directory and
+delete obsolete C<.al> files, after checking first that the module does use
+the AutoLoader, and ensuring that the module is not already currently split
+in its current form (the modtime test).
+
+The C<autosplit_lib_modules> form is used in the building of perl. It takes
+as input a list of files (modules) that are assumed to reside in a directory
+B<lib> relative to the current directory. Each file is sent to the
+autosplitter one at a time, to be split into the directory B<lib/auto>.
+
+In both usages of the autosplitter, only subroutines defined following the
+perl I<__END__> token are split out into separate files. Some
+routines may be placed prior to this marker to force their immediate loading
+and parsing.
+
+=head2 Multiple packages
+
+As of version 1.01 of the AutoSplit module it is possible to have
+multiple packages within a single file. Both of the following cases
+are supported:
+
+ package NAME;
+ __END__
+ sub AAA { ... }
+ package NAME::option1;
+ sub BBB { ... }
+ package NAME::option2;
+ sub BBB { ... }
+
+ package NAME;
+ __END__
+ sub AAA { ... }
+ sub NAME::option1::BBB { ... }
+ sub NAME::option2::BBB { ... }
+
+=head1 DIAGNOSTICS
+
+C<AutoSplit> will inform the user if it is necessary to create the
+top-level directory specified in the invocation. It is preferred that
+the script or installation process that invokes C<AutoSplit> have
+created the full directory path ahead of time. This warning may
+indicate that the module is being split into an incorrect path.
+
+C<AutoSplit> will warn the user of all subroutines whose name causes
+potential file naming conflicts on machines with drastically limited
+(8 characters or less) file name length. Since the subroutine name is
+used as the file name, these warnings can aid in portability to such
+systems.
+
+Warnings are issued and the file skipped if C<AutoSplit> cannot locate
+either the I<__END__> marker or a "package Name;"-style specification.
+
+C<AutoSplit> will also emit general diagnostics for inability to
+create directories or files.
+
+=head1 AUTHOR
+
+C<AutoSplit> is maintained by the perl5-porters. Please direct
+any questions to the canonical mailing list. Anything that
+is applicable to the CPAN release can be sent to its maintainer,
+though.
+
+Author and Maintainer: The Perl5-Porters <perl5-porters at perl.org>
+
+Maintainer of the CPAN release: Steffen Mueller <smueller at cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This package has been part of the perl core since the first release
+of perl5. It has been released separately to CPAN so older installations
+can benefit from bug fixes.
+
+This package has the same copyright and license as the perl core:
+
+ Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
+ by Larry Wall and others
+
+ All rights reserved.
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of either:
+
+ a) the GNU General Public License as published by the Free
+ Software Foundation; either version 1, or (at your option) any
+ later version, or
+
+ b) the "Artistic License" which comes with this Kit.
+
+ 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 either
+ the GNU General Public License or the Artistic License for more details.
+
+ You should have received a copy of the Artistic License with this
+ Kit, in the file named "Artistic". If not, I'll be glad to provide one.
+
+ You should also have received a copy of the GNU General Public License
+ along with this program in the file named "Copying". If not, write to the
+ Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+ 02111-1307, USA or visit their web page on the internet at
+ http://www.gnu.org/copyleft/gpl.html.
+
+ For those of you that choose to use the GNU General Public License,
+ my interpretation of the GNU General Public License is that no Perl
+ script falls under the terms of the GPL unless you explicitly put
+ said script under the terms of the GPL yourself. Furthermore, any
+ object code linked with perl does not automatically fall under the
+ terms of the GPL, provided such object code only adds definitions
+ of subroutines and variables, and does not otherwise impair the
+ resulting interpreter from executing any standard Perl script. I
+ consider linking in C subroutines in this manner to be the moral
+ equivalent of defining subroutines in the Perl language itself. You
+ may sell such an object file as proprietary provided that you provide
+ or offer to provide the Perl source, as specified by the GNU General
+ Public License. (This is merely an alternate way of specifying input
+ to the program.) You may also sell a binary produced by the dumping of
+ a running Perl script that belongs to you, provided that you provide or
+ offer to provide the Perl source as specified by the GPL. (The
+ fact that a Perl interpreter and your code are in the same binary file
+ is, in this case, a form of mere aggregation.) This is my interpretation
+ of the GPL. If you still have concerns or difficulties understanding
+ my intent, feel free to contact me. Of course, the Artistic License
+ spells all this out for your protection, so you may prefer to use that.
+
+=cut
+
+# for portability warn about names longer than $maxlen
+$Maxlen = 8; # 8 for dos, 11 (14-".al") for SYSVR3
+$Verbose = 1; # 0=none, 1=minimal, 2=list .al files
+$Keep = 0;
+$CheckForAutoloader = 1;
+$CheckModTime = 1;
+
+my $IndexFile = "autosplit.ix"; # file also serves as timestamp
+my $maxflen = 255;
+$maxflen = 14 if $Config{'d_flexfnam'} ne 'define';
+if (defined (&Dos::UseLFN)) {
+ $maxflen = Dos::UseLFN() ? 255 : 11;
+}
+my $Is_VMS = ($^O eq 'VMS');
+
+# allow checking for valid ': attrlist' attachments.
+# extra jugglery required to support both 5.8 and 5.9/5.10 features
+# (support for 5.8 required for cross-compiling environments)
+
+my $attr_list =
+ $] >= 5.009005 ?
+ eval <<'__QR__'
+ qr{
+ \s* : \s*
+ (?:
+ # one attribute
+ (?> # no backtrack
+ (?! \d) \w+
+ (?<nested> \( (?: [^()]++ | (?&nested)++ )*+ \) ) ?
+ )
+ (?: \s* : \s* | \s+ (?! :) )
+ )*
+ }x
+__QR__
+ :
+ do {
+ # In pre-5.9.5 world we have to do dirty tricks.
+ # (we use 'our' rather than 'my' here, due to the rather complex and buggy
+ # behaviour of lexicals with qr// and (??{$lex}) )
+ our $trick1; # yes, cannot our and assign at the same time.
+ $trick1 = qr{ \( (?: (?> [^()]+ ) | (??{ $trick1 }) )* \) }x;
+ our $trick2 = qr{ (?> (?! \d) \w+ (?:$trick1)? ) (?:\s*\:\s*|\s+(?!\:)) }x;
+ qr{ \s* : \s* (?: $trick2 )* }x;
+ };
+
+sub autosplit{
+ my($file, $autodir, $keep, $ckal, $ckmt) = @_;
+ # $file - the perl source file to be split (after __END__)
+ # $autodir - the ".../auto" dir below which to write split subs
+ # Handle optional flags:
+ $keep = $Keep unless defined $keep;
+ $ckal = $CheckForAutoloader unless defined $ckal;
+ $ckmt = $CheckModTime unless defined $ckmt;
+ autosplit_file($file, $autodir, $keep, $ckal, $ckmt);
+}
+
+sub carp{
+ require Carp;
+ goto &Carp::carp;
+}
+
+# This function is used during perl building/installation
+# ./miniperl -e 'use AutoSplit; autosplit_lib_modules(@ARGV)' ...
+
+sub autosplit_lib_modules {
+ my(@modules) = @_; # list of Module names
+ local $_; # Avoid clobber.
+ while (defined($_ = shift @modules)) {
+ while (m#([^:]+)::([^:].*)#) { # in case specified as ABC::XYZ
+ $_ = catfile($1, $2);
+ }
+ s|\\|/|g; # bug in ksh OS/2
+ s#^lib/##s; # incase specified as lib/*.pm
+ my($lib) = catfile(curdir(), "lib");
+ if ($Is_VMS) { # may need to convert VMS-style filespecs
+ $lib =~ s#^\[\]#.\/#;
+ }
+ s#^$lib\W+##s; # incase specified as ./lib/*.pm
+ if ($Is_VMS && /[:>\]]/) { # may need to convert VMS-style filespecs
+ my ($dir,$name) = (/(.*])(.*)/s);
+ $dir =~ s/.*lib[\.\]]//s;
+ $dir =~ s#[\.\]]#/#g;
+ $_ = $dir . $name;
+ }
+ autosplit_file(catfile($lib, $_), catfile($lib, "auto"),
+ $Keep, $CheckForAutoloader, $CheckModTime);
+ }
+ 0;
+}
+
+
+# private functions
+
+my $self_mod_time = (stat __FILE__)[9];
+
+sub autosplit_file {
+ my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time)
+ = @_;
+ my(@outfiles);
+ local($_);
+ local($/) = "\n";
+
+ # where to write output files
+ $autodir ||= catfile(curdir(), "lib", "auto");
+ if ($Is_VMS) {
+ ($autodir = VMS::Filespec::unixpath($autodir)) =~ s|/\z||;
+ $filename = VMS::Filespec::unixify($filename); # may have dirs
+ }
+ unless (-d $autodir){
+ mkpath($autodir,0,0755);
+ # We should never need to create the auto dir
+ # here. installperl (or similar) should have done
+ # it. Expecting it to exist is a valuable sanity check against
+ # autosplitting into some random directory by mistake.
+ print "Warning: AutoSplit had to create top-level " .
+ "$autodir unexpectedly.\n";
+ }
+
+ # allow just a package name to be used
+ $filename .= ".pm" unless ($filename =~ m/\.pm\z/);
+
+ open(my $in, "<$filename") or die "AutoSplit: Can't open $filename: $!\n";
+ my($pm_mod_time) = (stat($filename))[9];
+ my($autoloader_seen) = 0;
+ my($in_pod) = 0;
+ my($def_package,$last_package,$this_package,$fnr);
+ while (<$in>) {
+ # Skip pod text.
+ $fnr++;
+ $in_pod = 1 if /^=\w/;
+ $in_pod = 0 if /^=cut/;
+ next if ($in_pod || /^=cut/);
+ next if /^\s*#/;
+
+ # record last package name seen
+ $def_package = $1 if (m/^\s*package\s+([\w:]+)\s*;/);
+ ++$autoloader_seen if m/^\s*(use|require)\s+AutoLoader\b/;
+ ++$autoloader_seen if m/\bISA\s*=.*\bAutoLoader\b/;
+ last if /^__END__/;
+ }
+ if ($check_for_autoloader && !$autoloader_seen){
+ print "AutoSplit skipped $filename: no AutoLoader used\n"
+ if ($Verbose>=2);
+ return 0;
+ }
+ $_ or die "Can't find __END__ in $filename\n";
+
+ $def_package or die "Can't find 'package Name;' in $filename\n";
+
+ my($modpname) = _modpname($def_package);
+
+ # this _has_ to match so we have a reasonable timestamp file
+ die "Package $def_package ($modpname.pm) does not ".
+ "match filename $filename"
+ unless ($filename =~ m/\Q$modpname.pm\E$/ or
+ ($^O eq 'dos') or ($^O eq 'MSWin32') or ($^O eq 'NetWare') or
+ $Is_VMS && $filename =~ m/$modpname.pm/i);
+
+ my($al_idx_file) = catfile($autodir, $modpname, $IndexFile);
+
+ if ($check_mod_time){
+ my($al_ts_time) = (stat("$al_idx_file"))[9] || 1;
+ if ($al_ts_time >= $pm_mod_time and
+ $al_ts_time >= $self_mod_time){
+ print "AutoSplit skipped ($al_idx_file newer than $filename)\n"
+ if ($Verbose >= 2);
+ return undef; # one undef, not a list
+ }
+ }
+
+ my($modnamedir) = catdir($autodir, $modpname);
+ print "AutoSplitting $filename ($modnamedir)\n"
+ if $Verbose;
+
+ unless (-d $modnamedir){
+ mkpath($modnamedir,0,0777);
+ }
+
+ # We must try to deal with some SVR3 systems with a limit of 14
+ # characters for file names. Sadly we *cannot* simply truncate all
+ # file names to 14 characters on these systems because we *must*
+ # create filenames which exactly match the names used by AutoLoader.pm.
+ # This is a problem because some systems silently truncate the file
+ # names while others treat long file names as an error.
+
+ my $Is83 = $maxflen==11; # plain, case INSENSITIVE dos filenames
+
+ my(@subnames, $subname, %proto, %package);
+ my @cache = ();
+ my $caching = 1;
+ $last_package = '';
+ my $out;
+ while (<$in>) {
+ $fnr++;
+ $in_pod = 1 if /^=\w/;
+ $in_pod = 0 if /^=cut/;
+ next if ($in_pod || /^=cut/);
+ # the following (tempting) old coding gives big troubles if a
+ # cut is forgotten at EOF:
+ # next if /^=\w/ .. /^=cut/;
+ if (/^package\s+([\w:]+)\s*;/) {
+ $this_package = $def_package = $1;
+ }
+
+ if (/^sub\s+([\w:]+)(\s*(?:\(.*?\))?(?:$attr_list)?)/) {
+ print $out "# end of $last_package\::$subname\n1;\n"
+ if $last_package;
+ $subname = $1;
+ my $proto = $2 || '';
+ if ($subname =~ s/(.*):://){
+ $this_package = $1;
+ } else {
+ $this_package = $def_package;
+ }
+ my $fq_subname = "$this_package\::$subname";
+ $package{$fq_subname} = $this_package;
+ $proto{$fq_subname} = $proto;
+ push(@subnames, $fq_subname);
+ my($lname, $sname) = ($subname, substr($subname,0,$maxflen-3));
+ $modpname = _modpname($this_package);
+ my($modnamedir) = catdir($autodir, $modpname);
+ mkpath($modnamedir,0,0777);
+ my($lpath) = catfile($modnamedir, "$lname.al");
+ my($spath) = catfile($modnamedir, "$sname.al");
+ my $path;
+
+ if (!$Is83 and open($out, ">$lpath")){
+ $path=$lpath;
+ print " writing $lpath\n" if ($Verbose>=2);
+ } else {
+ open($out, ">$spath") or die "Can't create $spath: $!\n";
+ $path=$spath;
+ print " writing $spath (with truncated name)\n"
+ if ($Verbose>=1);
+ }
+ push(@outfiles, $path);
+ my $lineno = $fnr - @cache;
+ print $out <<EOT;
+# NOTE: Derived from $filename.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package $this_package;
+
+#line $lineno "$filename (autosplit into $path)"
+EOT
+ print $out @cache;
+ @cache = ();
+ $caching = 0;
+ }
+ if($caching) {
+ push(@cache, $_) if @cache || /\S/;
+ } else {
+ print $out $_;
+ }
+ if(/^\}/) {
+ if($caching) {
+ print $out @cache;
+ @cache = ();
+ }
+ print $out "\n";
+ $caching = 1;
+ }
+ $last_package = $this_package if defined $this_package;
+ }
+ if ($subname) {
+ print $out @cache,"1;\n# end of $last_package\::$subname\n";
+ close($out);
+ }
+ close($in);
+
+ if (!$keep){ # don't keep any obsolete *.al files in the directory
+ my(%outfiles);
+ # @outfiles{@outfiles} = @outfiles;
+ # perl downcases all filenames on VMS (which upcases all filenames) so
+ # we'd better downcase the sub name list too, or subs with upper case
+ # letters in them will get their .al files deleted right after they're
+ # created. (The mixed case sub name won't match the all-lowercase
+ # filename, and so be cleaned up as a scrap file)
+ if ($Is_VMS or $Is83) {
+ %outfiles = map {lc($_) => lc($_) } @outfiles;
+ } else {
+ @outfiles{@outfiles} = @outfiles;
+ }
+ my(%outdirs, at outdirs);
+ for (@outfiles) {
+ $outdirs{File::Basename::dirname($_)}||=1;
+ }
+ for my $dir (keys %outdirs) {
+ opendir(my $outdir,$dir);
+ foreach (sort readdir($outdir)){
+ next unless /\.al\z/;
+ my($file) = catfile($dir, $_);
+ $file = lc $file if $Is83 or $Is_VMS;
+ next if $outfiles{$file};
+ print " deleting $file\n" if ($Verbose>=2);
+ my($deleted,$thistime); # catch all versions on VMS
+ do { $deleted += ($thistime = unlink $file) } while ($thistime);
+ carp ("Unable to delete $file: $!") unless $deleted;
+ }
+ closedir($outdir);
+ }
+ }
+
+ open(my $ts,">$al_idx_file") or
+ carp ("AutoSplit: unable to create timestamp file ($al_idx_file): $!");
+ print $ts "# Index created by AutoSplit for $filename\n";
+ print $ts "# (file acts as timestamp)\n";
+ $last_package = '';
+ for my $fqs (@subnames) {
+ my($subname) = $fqs;
+ $subname =~ s/.*:://;
+ print $ts "package $package{$fqs};\n"
+ unless $last_package eq $package{$fqs};
+ print $ts "sub $subname $proto{$fqs};\n";
+ $last_package = $package{$fqs};
+ }
+ print $ts "1;\n";
+ close($ts);
+
+ _check_unique($filename, $Maxlen, 1, @outfiles);
+
+ @outfiles;
+}
+
+sub _modpname ($) {
+ my($package) = @_;
+ my $modpname = $package;
+ if ($^O eq 'MSWin32') {
+ $modpname =~ s#::#\\#g;
+ } else {
+ my @modpnames = ();
+ while ($modpname =~ m#(.*?[^:])::([^:].*)#) {
+ push @modpnames, $1;
+ $modpname = $2;
+ }
+ $modpname = catfile(@modpnames, $modpname);
+ }
+ if ($Is_VMS) {
+ $modpname = VMS::Filespec::unixify($modpname); # may have dirs
+ }
+ $modpname;
+}
+
+sub _check_unique {
+ my($filename, $maxlen, $warn, @outfiles) = @_;
+ my(%notuniq) = ();
+ my(%shorts) = ();
+ my(@toolong) = grep(
+ length(File::Basename::basename($_))
+ > $maxlen,
+ @outfiles
+ );
+
+ foreach (@toolong){
+ my($dir) = File::Basename::dirname($_);
+ my($file) = File::Basename::basename($_);
+ my($trunc) = substr($file,0,$maxlen);
+ $notuniq{$dir}{$trunc} = 1 if $shorts{$dir}{$trunc};
+ $shorts{$dir}{$trunc} = $shorts{$dir}{$trunc} ?
+ "$shorts{$dir}{$trunc}, $file" : $file;
+ }
+ if (%notuniq && $warn){
+ print "$filename: some names are not unique when " .
+ "truncated to $maxlen characters:\n";
+ foreach my $dir (sort keys %notuniq){
+ print " directory $dir:\n";
+ foreach my $trunc (sort keys %{$notuniq{$dir}}) {
+ print " $shorts{$dir}{$trunc} truncate to $trunc\n";
+ }
+ }
+ }
+}
+
+1;
+__END__
+
+# test functions so AutoSplit.pm can be applied to itself:
+sub test1 ($) { "test 1\n"; }
+sub test2 ($$) { "test 2\n"; }
+sub test3 ($$$) { "test 3\n"; }
+sub testtesttesttest4_1 { "test 4\n"; }
+sub testtesttesttest4_2 { "duplicate test 4\n"; }
+sub Just::Another::test5 { "another test 5\n"; }
+sub test6 { return join ":", __FILE__,__LINE__; }
+package Yet::Another::AutoSplit;
+sub testtesttesttest4_1 ($) { "another test 4\n"; }
+sub testtesttesttest4_2 ($$) { "another duplicate test 4\n"; }
+package Yet::More::Attributes;
+sub test_a1 ($) : locked :locked { 1; }
+sub test_a2 : locked { 1; }
Copied: trunk/contrib/perl/lib/AutoSplit.t (from rev 6437, vendor/perl/5.18.1/lib/AutoSplit.t)
===================================================================
--- trunk/contrib/perl/lib/AutoSplit.t (rev 0)
+++ trunk/contrib/perl/lib/AutoSplit.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,419 @@
+#!./perl -w
+
+# AutoLoader.t runs before this test, so it seems safe to assume that it will
+# work.
+
+my($incdir, $lib);
+BEGIN {
+ chdir 't' if -d 't';
+ if ($^O eq 'dos') {
+ print "1..0 # This test is not 8.3-aware.\n";
+ exit 0;
+ }
+ if ($^O eq 'MacOS') {
+ $incdir = ":auto-$$";
+ $lib = '-I::lib:';
+ } else {
+ $incdir = "auto-$$";
+ $lib = '"-I../lib"'; # ok on unix, nt, The extra \" are for VMS
+ }
+ @INC = $incdir;
+ push @INC, '../lib';
+}
+my $runperl = "$^X $lib";
+
+use warnings;
+use strict;
+use Test::More tests => 58;
+use File::Spec;
+use File::Find;
+
+require AutoSplit; # Run time. Check it compiles.
+ok (1, "AutoSplit loaded");
+
+END {
+ use File::Path;
+ print "# $incdir being removed...\n";
+ rmtree($incdir);
+}
+
+mkdir $incdir,0755;
+
+my @tests;
+{
+ # local this else it buggers up the chomp() below.
+ # Hmm. Would be nice to have this as a regexp.
+ local $/
+ = "################################################################\n";
+ @tests = <DATA>;
+ close DATA;
+}
+
+my $pathsep = $^O eq 'MSWin32' ? '\\' : $^O eq 'MacOS' ? ':' : '/';
+my $endpathsep = $^O eq 'MacOS' ? ':' : '';
+
+sub split_a_file {
+ my $contents = shift;
+ my $file = $_[0];
+ if (defined $contents) {
+ open FILE, ">$file" or die "Can't open $file: $!";
+ print FILE $contents;
+ close FILE or die "Can't close $file: $!";
+ }
+
+ # Assumption: no characters in arguments need escaping from the shell or perl
+ my $com = qq($runperl -e "use AutoSplit; autosplit (qw(@_))");
+ print "# command: $com\n";
+ # There may be a way to capture STDOUT without spawning a child process, but
+ # it's probably worthwhile spawning, as it ensures that nothing in AutoSplit
+ # can load functions from split modules into this perl.
+ my $output = `$com`;
+ warn "Exit status $? from running: >>$com<<" if $?;
+ return $output;
+}
+
+my $i = 0;
+my $dir = File::Spec->catdir($incdir, 'auto');
+if ($^O eq 'VMS') {
+ $dir = VMS::Filespec::unixify($dir);
+ $dir =~ s/\/$//;
+} elsif ($^O eq 'MacOS') {
+ $dir =~ s/:$//;
+}
+
+foreach (@tests) {
+ my $module = 'A' . $i . '_' . $$ . 'splittest';
+ my $file = File::Spec->catfile($incdir,"$module.pm");
+ s/\*INC\*/$incdir/gm;
+ s/\*DIR\*/$dir/gm;
+ s/\*MOD\*/$module/gm;
+ s/\*PATHSEP\*/$pathsep/gm;
+ s/\*ENDPATHSEP\*/$endpathsep/gm;
+ s#//#/#gm;
+ # Build a hash for this test.
+ my %args = /^\#\#\ ([^\n]*)\n # Key is on a line starting ##
+ ((?:[^\#]+ # Any number of characters not #
+ | \#(?!\#) # or a # character not followed by #
+ | (?<!\n)\# # or a # character not preceded by \n
+ )*)/sgmx;
+ foreach ($args{Name}, $args{Require}, $args{Extra}) {
+ chomp $_ if defined $_;
+ }
+ $args{Get} ||= '';
+
+ my @extra_args = !defined $args{Extra} ? () : split /,/, $args{Extra};
+ my ($output, $body);
+ if ($args{File}) {
+ $body ="package $module;\n" . $args{File};
+ $output = split_a_file ($body, $file, $dir, @extra_args);
+ } else {
+ # Repeat tests
+ $output = split_a_file (undef, $file, $dir, @extra_args);
+ }
+
+ if ($^O eq 'VMS') {
+ my ($filespec, $replacement);
+ while ($output =~ m/(\[.+\])/) {
+ $filespec = $1;
+ $replacement = VMS::Filespec::unixify($filespec);
+ $replacement =~ s/\/$//;
+ $output =~ s/\Q$filespec\E/$replacement/;
+ }
+ }
+
+ # test n+1
+ is($output, $args{Get}, "Output from autosplit()ing $args{Name}");
+
+ if ($args{Files}) {
+ $args{Files} =~ s!/!:!gs if $^O eq 'MacOS';
+ my (%missing, %got);
+ find (sub {$got{$File::Find::name}++ unless -d $_}, $dir);
+ foreach (split /\n/, $args{Files}) {
+ next if /^#/;
+ $_ = lc($_) if $^O eq 'VMS';
+ unless (delete $got{$_}) {
+ $missing{$_}++;
+ }
+ }
+ my @missing = keys %missing;
+ # test n+2
+ unless (ok (!@missing, "Are any expected files missing?")) {
+ print "# These files are missing\n";
+ print "# $_\n" foreach sort @missing;
+ }
+ my @extra = keys %got;
+ # test n+3
+ unless (ok (!@extra, "Are any extra files present?")) {
+ print "# These files are unexpectedly present:\n";
+ print "# $_\n" foreach sort @extra;
+ }
+ }
+ if ($args{Require}) {
+ $args{Require} =~ s|/|:|gm if $^O eq 'MacOS';
+ my $com = 'require "' . File::Spec->catfile ('auto', $args{Require}) . '"';
+ $com =~ s{\\}{/}gm if ($^O eq 'MSWin32');
+ eval $com;
+ # test n+3
+ ok ($@ eq '', $com) or print "# \$\@ = '$@'\n";
+ if (defined $body) {
+ eval $body or die $@;
+ }
+ }
+ # match tests to check for prototypes
+ if ($args{Match}) {
+ local $/;
+ my $file = File::Spec->catfile($dir, $args{Require});
+ open IX, $file or die "Can't open '$file': $!";
+ my $ix = <IX>;
+ close IX or die "Can't close '$file': $!";
+ foreach my $pat (split /\n/, $args{Match}) {
+ next if $pat =~ /^\#/;
+ like ($ix, qr/^\s*$pat\s*$/m, "match $pat");
+ }
+ }
+ # code tests contain eval{}ed ok()s etc
+ if ($args{Tests}) {
+ foreach my $code (split /\n/, $args{Tests}) {
+ next if $code =~ /^\#/;
+ defined eval $code or fail(), print "# Code: $code\n# Error: $@";
+ }
+ }
+ if (my $sleepfor = $args{Sleep}) {
+ # We need to sleep for a while
+ # Need the sleep hack else the next test is so fast that the timestamp
+ # compare routine in AutoSplit thinks that it shouldn't split the files.
+ my $time = time;
+ my $until = $time + $sleepfor;
+ my $attempts = 3;
+ do {
+ sleep ($sleepfor)
+ } while (time < $until && --$attempts > 0);
+ if ($attempts == 0) {
+ printf << "EOM", time;
+# Attempted to sleep for $sleepfor second(s), started at $time, now %d.
+# sleep attempt ppears to have failed; some tests may fail as a result.
+EOM
+ }
+ }
+ unless ($args{SameAgain}) {
+ $i++;
+ rmtree($dir);
+ mkdir $dir, 0775;
+ }
+}
+
+__DATA__
+## Name
+tests from the end of the AutoSplit module.
+## File
+use AutoLoader 'AUTOLOAD';
+{package Just::Another;
+ use AutoLoader 'AUTOLOAD';
+}
+ at Yet::Another::AutoSplit::ISA = 'AutoLoader';
+1;
+__END__
+sub test1 ($) { "test 1"; }
+sub test2 ($$) { "test 2"; }
+sub test3 ($$$) { "test 3"; }
+sub testtesttesttest4_1 { "test 4"; }
+sub testtesttesttest4_2 { "duplicate test 4"; }
+sub Just::Another::test5 { "another test 5"; }
+sub test6 { return join ":", __FILE__,__LINE__; }
+package Yet::Another::AutoSplit;
+sub testtesttesttest4_1 ($) { "another test 4"; }
+sub testtesttesttest4_2 ($$) { "another duplicate test 4"; }
+package Yet::More::Attributes;
+sub test_a1 ($) : locked :locked { 1; }
+sub test_a2 : locked { 1; }
+# And that was all it has. You were expected to manually inspect the output
+## Get
+Warning: AutoSplit had to create top-level *DIR* unexpectedly.
+AutoSplitting *INC**PATHSEP**MOD*.pm (*DIR**PATHSEP**MOD**ENDPATHSEP*)
+*INC**PATHSEP**MOD*.pm: some names are not unique when truncated to 8 characters:
+ directory *DIR**PATHSEP**MOD**ENDPATHSEP*:
+ testtesttesttest4_1.al, testtesttesttest4_2.al truncate to testtest
+ directory *DIR**PATHSEP*Yet*PATHSEP*Another*PATHSEP*AutoSplit*ENDPATHSEP*:
+ testtesttesttest4_1.al, testtesttesttest4_2.al truncate to testtest
+## Files
+*DIR*/*MOD*/autosplit.ix
+*DIR*/*MOD*/test1.al
+*DIR*/*MOD*/test2.al
+*DIR*/*MOD*/test3.al
+*DIR*/*MOD*/testtesttesttest4_1.al
+*DIR*/*MOD*/testtesttesttest4_2.al
+*DIR*/Just/Another/test5.al
+*DIR*/*MOD*/test6.al
+*DIR*/Yet/Another/AutoSplit/testtesttesttest4_1.al
+*DIR*/Yet/Another/AutoSplit/testtesttesttest4_2.al
+*DIR*/Yet/More/Attributes/test_a1.al
+*DIR*/Yet/More/Attributes/test_a2.al
+## Require
+*MOD*/autosplit.ix
+## Match
+# Need to find these lines somewhere in the required file
+sub test1\s*\(\$\);
+sub test2\s*\(\$\$\);
+sub test3\s*\(\$\$\$\);
+sub testtesttesttest4_1\s*\(\$\);
+sub testtesttesttest4_2\s*\(\$\$\);
+sub test_a1\s*\(\$\)\s*:\s*locked\s*:\s*locked\s*;
+sub test_a2\s*:\s*locked\s*;
+## Tests
+is (*MOD*::test1 (1), 'test 1');
+is (*MOD*::test2 (1,2), 'test 2');
+is (*MOD*::test3 (1,2,3), 'test 3');
+ok (!defined eval "*MOD*::test1 () eq 'test 1'" and $@ =~ /^Not enough arguments for *MOD*::test1/, "Check prototypes mismatch fails") or print "# \$\@='$@'";
+is (&*MOD*::testtesttesttest4_1, "test 4");
+is (&*MOD*::testtesttesttest4_2, "duplicate test 4");
+is (&Just::Another::test5, "another test 5");
+# very messy way to interpolate function into regexp, but it's going to be
+# needed to get : for Mac filespecs
+like (&*MOD*::test6, qr!^\Q*INC**PATHSEP**MOD*\E\.pm \(autosplit into \Q@{[File::Spec->catfile('*DIR*','*MOD*', 'test6.al')]}\E\):\d+$!);
+ok (Yet::Another::AutoSplit->testtesttesttest4_1 eq "another test 4");
+################################################################
+## Name
+missing use AutoLoader;
+## File
+1;
+__END__
+## Get
+## Files
+# There should be no files.
+################################################################
+## Name
+missing use AutoLoader; (but don't skip)
+## Extra
+0, 0
+## File
+1;
+__END__
+## Get
+AutoSplitting *INC**PATHSEP**MOD*.pm (*DIR**PATHSEP**MOD**ENDPATHSEP*)
+## Require
+*MOD*/autosplit.ix
+## Files
+*DIR*/*MOD*/autosplit.ix
+################################################################
+## Name
+Split prior to checking whether obsolete files get deleted
+## File
+use AutoLoader 'AUTOLOAD';
+1;
+__END__
+sub obsolete {our $hidden_a; return $hidden_a++;}
+sub gonner {warn "This gonner function should never get called"}
+## Get
+AutoSplitting *INC**PATHSEP**MOD*.pm (*DIR**PATHSEP**MOD**ENDPATHSEP*)
+## Require
+*MOD*/autosplit.ix
+## Files
+*DIR*/*MOD*/autosplit.ix
+*DIR*/*MOD*/gonner.al
+*DIR*/*MOD*/obsolete.al
+## Tests
+is (&*MOD*::obsolete, 0);
+is (&*MOD*::obsolete, 1);
+## Sleep
+4
+## SameAgain
+True, so don't scrub this directory.
+IIRC DOS FAT filesystems have only 2 second granularity.
+################################################################
+## Name
+Check whether obsolete files get deleted
+## File
+use AutoLoader 'AUTOLOAD';
+1;
+__END__
+sub skeleton {"bones"};
+sub ghost {"scream"}; # This definition gets overwritten with the one below
+sub ghoul {"wail"};
+sub zombie {"You didn't use fire."};
+sub flying_pig {"Oink oink flap flap"};
+## Get
+AutoSplitting *INC**PATHSEP**MOD*.pm (*DIR**PATHSEP**MOD**ENDPATHSEP*)
+## Require
+*MOD*/autosplit.ix
+## Files
+*DIR*/*MOD*/autosplit.ix
+*DIR*/*MOD*/skeleton.al
+*DIR*/*MOD*/zombie.al
+*DIR*/*MOD*/ghost.al
+*DIR*/*MOD*/ghoul.al
+*DIR*/*MOD*/flying_pig.al
+## Tests
+is (&*MOD*::skeleton, "bones", "skeleton");
+eval {&*MOD*::gonner}; ok ($@ =~ m!^Can't locate auto/*MOD*/gonner.al in \@INC!, "Check &*MOD*::gonner is now a gonner") or print "# \$\@='$@'\n";
+## Sleep
+4
+## SameAgain
+True, so don't scrub this directory.
+################################################################
+## Name
+Check whether obsolete files remain when keep is 1
+## Extra
+1, 1
+## File
+use AutoLoader 'AUTOLOAD';
+1;
+__END__
+sub ghost {"bump"};
+sub wraith {9};
+## Get
+AutoSplitting *INC**PATHSEP**MOD*.pm (*DIR**PATHSEP**MOD**ENDPATHSEP*)
+## Require
+*MOD*/autosplit.ix
+## Files
+*DIR*/*MOD*/autosplit.ix
+*DIR*/*MOD*/skeleton.al
+*DIR*/*MOD*/zombie.al
+*DIR*/*MOD*/ghost.al
+*DIR*/*MOD*/ghoul.al
+*DIR*/*MOD*/wraith.al
+*DIR*/*MOD*/flying_pig.al
+## Tests
+is (&*MOD*::ghost, "bump");
+is (&*MOD*::zombie, "You didn't use fire.", "Are our zombies undead?");
+## Sleep
+4
+## SameAgain
+True, so don't scrub this directory.
+################################################################
+## Name
+Without the timestamp check make sure that nothing happens
+## Extra
+0, 1, 1
+## Require
+*MOD*/autosplit.ix
+## Files
+*DIR*/*MOD*/autosplit.ix
+*DIR*/*MOD*/skeleton.al
+*DIR*/*MOD*/zombie.al
+*DIR*/*MOD*/ghost.al
+*DIR*/*MOD*/ghoul.al
+*DIR*/*MOD*/wraith.al
+*DIR*/*MOD*/flying_pig.al
+## Tests
+is (&*MOD*::ghoul, "wail", "still haunted");
+is (&*MOD*::zombie, "You didn't use fire.", "Are our zombies still undead?");
+## Sleep
+4
+## SameAgain
+True, so don't scrub this directory.
+################################################################
+## Name
+With the timestamp check make sure that things happen (stuff gets deleted)
+## Extra
+0, 1, 0
+## Get
+AutoSplitting *INC**PATHSEP**MOD*.pm (*DIR**PATHSEP**MOD**ENDPATHSEP*)
+## Require
+*MOD*/autosplit.ix
+## Files
+*DIR*/*MOD*/autosplit.ix
+*DIR*/*MOD*/ghost.al
+*DIR*/*MOD*/wraith.al
+## Tests
+is (&*MOD*::wraith, 9);
+eval {&*MOD*::flying_pig}; ok ($@ =~ m!^Can't locate auto/*MOD*/flying_pig.al in \@INC!, "There are no flying pigs") or print "# \$\@='$@'\n";
Modified: trunk/contrib/perl/lib/Benchmark.pm
===================================================================
--- trunk/contrib/perl/lib/Benchmark.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Benchmark.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -385,7 +385,7 @@
=head1 SEE ALSO
-L<Devel::DProf> - a Perl code profiler
+L<Devel::NYTProf> - a Perl code profiler
=head1 AUTHORS
@@ -440,7 +440,7 @@
clearcache clearallcache disablecache enablecache);
%EXPORT_TAGS=( all => [ @EXPORT, @EXPORT_OK ] ) ;
-$VERSION = 1.12;
+$VERSION = 1.15;
# --- ':hireswallclock' special handling
Property changes on: trunk/contrib/perl/lib/Benchmark.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/Benchmark.t
===================================================================
--- trunk/contrib/perl/lib/Benchmark.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Benchmark.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -63,12 +63,14 @@
my $in_threesecs = $threesecs->iters;
print "# in_threesecs=$in_threesecs iterations\n";
ok ($in_threesecs > 0, "iters returned positive iterations");
-my $cpu = $threesecs->[1] + $threesecs->[2]; # user + sys
-cmp_ok($cpu, '>=', 3.0, "3s cpu is at least 3s");
-$in_threesecs *= (3/$cpu); # adjust because may not have run for exactly 3s
-print "# in_threesecs=$in_threesecs adjusted iterations\n";
+my $cpu3 = $threesecs->[1]; # user
+my $sys3 = $threesecs->[2]; # sys
+cmp_ok($cpu3+$sys3, '>=', 3.0, "3s cpu3 is at least 3s");
+my $in_threesecs_adj = $in_threesecs;
+$in_threesecs_adj *= (3/$cpu3); # adjust because may not have run for exactly 3s
+print "# in_threesecs_adj=$in_threesecs_adj adjusted iterations\n";
-my $estimate = int (100 * $in_threesecs / 3) / 100;
+my $estimate = int (100 * $in_threesecs_adj / 3) / 100;
print "# from the 3 second run estimate $estimate iterations in 1 second...\n";
$baz = 0;
my $onesec = countit(1, $coderef);
@@ -77,16 +79,28 @@
my $in_onesec = $onesec->iters;
print "# in_onesec=$in_onesec iterations\n";
ok ($in_onesec > 0, "iters returned positive iterations");
-$cpu = $onesec->[1] + $onesec->[2]; # user + sys
-cmp_ok($cpu, '>=', 1.0, "1s cpu is at least 1s");
-$in_onesec *= (1/$cpu); # adjust because may not have run for exactly 1s
-print "# in_onesec=$in_onesec adjusted iterations\n";
+my $cpu1 = $onesec->[1]; # user
+my $sys1 = $onesec->[2]; # sys
+cmp_ok($cpu1+$sys1, '>=', 1.0, "is cpu1 is at least 1s");
+my $in_onesec_adj = $in_onesec;
+$in_onesec_adj *= (1/$cpu1); # adjust because may not have run for exactly 1s
+print "# in_onesec_adj=$in_onesec_adj adjusted iterations\n";
{
- my $difference = $in_onesec - $estimate;
- my $actual = abs ($difference / $in_onesec);
- cmp_ok($actual, '<=', $delta, "is $in_onesec within $delta of estimate ($estimate)")
- or diag("# $in_onesec is between " . ($delta / 2) . " and $delta of estimate. Not that safe.");
+ my $difference = $in_onesec_adj - $estimate;
+ my $actual = abs ($difference / $in_onesec_adj);
+ cmp_ok($actual, '<=', $delta, "is $in_onesec_adj within $delta of estimate ($estimate)")
+ or do {
+ diag(" in_threesecs = $in_threesecs");
+ diag(" in_threesecs_adj = $in_threesecs_adj");
+ diag(" cpu3 = $cpu3");
+ diag(" sys3 = $sys3");
+ diag(" estimate = $estimate");
+ diag(" in_onesec = $in_onesec");
+ diag(" in_onesec_adj = $in_onesec_adj");
+ diag(" cpu1 = $cpu1");
+ diag(" sys1 = $sys1");
+ };
}
# I found that the eval'ed version was 3 times faster than the coderef.
@@ -122,7 +136,7 @@
is (timestr ($diff, 'none'), '', "none suppresses output");
my $noc = timestr ($diff, 'noc');
- like ($noc, qr/$wallclock +wallclock secs? +\( *$usr +usr +\+ +$sys +sys += +$cpu +CPU\)/, 'timestr ($diff, "noc")');
+ like ($noc, qr/$wallclock +wallclock secs? +\( *$usr +usr +\+ +$sys +sys += +\d+\.\d\d +CPU\)/, 'timestr ($diff, "noc")');
my $nop = timestr ($diff, 'nop');
like ($nop, qr/$wallclock +wallclock secs? +\( *$cusr +cusr +\+ +$csys +csys += +\d+\.\d\d +CPU\)/, 'timestr ($diff, "nop")');
Property changes on: trunk/contrib/perl/lib/Benchmark.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/lib/CGI.pm (from rev 6437, vendor/perl/5.18.1/lib/CGI.pm)
===================================================================
--- trunk/contrib/perl/lib/CGI.pm (rev 0)
+++ trunk/contrib/perl/lib/CGI.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,7885 @@
+package CGI;
+require 5.004;
+use Carp 'croak';
+
+# See the bottom of this file for the POD documentation. Search for the
+# string '=head'.
+
+# You can run this file through either pod2man or pod2html to produce pretty
+# documentation in manual or html file format (these utilities are part of the
+# Perl 5 distribution).
+
+# Copyright 1995-1998 Lincoln D. Stein. All rights reserved.
+# It may be used and modified freely, but I do request that this copyright
+# notice remain attached to the file. You may modify this module as you
+# wish, but if you redistribute a modified version, please attach a note
+# listing the modifications you have made.
+
+# The most recent version and complete docs are available at:
+# http://stein.cshl.org/WWW/software/CGI/
+
+$CGI::revision = '$Id: CGI.pm,v 1.1.1.2 2011-02-17 12:49:38 laffer1 Exp $';
+$CGI::VERSION='3.43';
+
+# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
+# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
+# $CGITempFile::TMPDIRECTORY = '/usr/tmp';
+use CGI::Util qw(rearrange rearrange_header make_attributes unescape escape expires ebcdic2ascii ascii2ebcdic);
+
+#use constant XHTML_DTD => ['-//W3C//DTD XHTML Basic 1.0//EN',
+# 'http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd'];
+
+use constant XHTML_DTD => ['-//W3C//DTD XHTML 1.0 Transitional//EN',
+ 'http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd'];
+
+{
+ local $^W = 0;
+ $TAINTED = substr("$0$^X",0,0);
+}
+
+$MOD_PERL = 0; # no mod_perl by default
+
+#global settings
+$POST_MAX = -1; # no limit to uploaded files
+$DISABLE_UPLOADS = 0;
+
+ at SAVED_SYMBOLS = ();
+
+
+# >>>>> Here are some globals that you might want to adjust <<<<<<
+sub initialize_globals {
+ # Set this to 1 to enable copious autoloader debugging messages
+ $AUTOLOAD_DEBUG = 0;
+
+ # Set this to 1 to generate XTML-compatible output
+ $XHTML = 1;
+
+ # Change this to the preferred DTD to print in start_html()
+ # or use default_dtd('text of DTD to use');
+ $DEFAULT_DTD = [ '-//W3C//DTD HTML 4.01 Transitional//EN',
+ 'http://www.w3.org/TR/html4/loose.dtd' ] ;
+
+ # Set this to 1 to enable NOSTICKY scripts
+ # or:
+ # 1) use CGI qw(-nosticky)
+ # 2) $CGI::nosticky(1)
+ $NOSTICKY = 0;
+
+ # Set this to 1 to enable NPH scripts
+ # or:
+ # 1) use CGI qw(-nph)
+ # 2) CGI::nph(1)
+ # 3) print header(-nph=>1)
+ $NPH = 0;
+
+ # Set this to 1 to enable debugging from @ARGV
+ # Set to 2 to enable debugging from STDIN
+ $DEBUG = 1;
+
+ # Set this to 1 to make the temporary files created
+ # during file uploads safe from prying eyes
+ # or do...
+ # 1) use CGI qw(:private_tempfiles)
+ # 2) CGI::private_tempfiles(1);
+ $PRIVATE_TEMPFILES = 0;
+
+ # Set this to 1 to generate automatic tab indexes
+ $TABINDEX = 0;
+
+ # Set this to 1 to cause files uploaded in multipart documents
+ # to be closed, instead of caching the file handle
+ # or:
+ # 1) use CGI qw(:close_upload_files)
+ # 2) $CGI::close_upload_files(1);
+ # Uploads with many files run out of file handles.
+ # Also, for performance, since the file is already on disk,
+ # it can just be renamed, instead of read and written.
+ $CLOSE_UPLOAD_FILES = 0;
+
+ # Automatically determined -- don't change
+ $EBCDIC = 0;
+
+ # Change this to 1 to suppress redundant HTTP headers
+ $HEADERS_ONCE = 0;
+
+ # separate the name=value pairs by semicolons rather than ampersands
+ $USE_PARAM_SEMICOLONS = 1;
+
+ # Do not include undefined params parsed from query string
+ # use CGI qw(-no_undef_params);
+ $NO_UNDEF_PARAMS = 0;
+
+ # return everything as utf-8
+ $PARAM_UTF8 = 0;
+
+ # Other globals that you shouldn't worry about.
+ undef $Q;
+ $BEEN_THERE = 0;
+ $DTD_PUBLIC_IDENTIFIER = "";
+ undef @QUERY_PARAM;
+ undef %EXPORT;
+ undef $QUERY_CHARSET;
+ undef %QUERY_FIELDNAMES;
+ undef %QUERY_TMPFILES;
+
+ # prevent complaints by mod_perl
+ 1;
+}
+
+# ------------------ START OF THE LIBRARY ------------
+
+*end_form = \&endform;
+
+# make mod_perlhappy
+initialize_globals();
+
+# FIGURE OUT THE OS WE'RE RUNNING UNDER
+# Some systems support the $^O variable. If not
+# available then require() the Config library
+unless ($OS) {
+ unless ($OS = $^O) {
+ require Config;
+ $OS = $Config::Config{'osname'};
+ }
+}
+if ($OS =~ /^MSWin/i) {
+ $OS = 'WINDOWS';
+} elsif ($OS =~ /^VMS/i) {
+ $OS = 'VMS';
+} elsif ($OS =~ /^dos/i) {
+ $OS = 'DOS';
+} elsif ($OS =~ /^MacOS/i) {
+ $OS = 'MACINTOSH';
+} elsif ($OS =~ /^os2/i) {
+ $OS = 'OS2';
+} elsif ($OS =~ /^epoc/i) {
+ $OS = 'EPOC';
+} elsif ($OS =~ /^cygwin/i) {
+ $OS = 'CYGWIN';
+} else {
+ $OS = 'UNIX';
+}
+
+# Some OS logic. Binary mode enabled on DOS, NT and VMS
+$needs_binmode = $OS=~/^(WINDOWS|DOS|OS2|MSWin|CYGWIN)/;
+
+# This is the default class for the CGI object to use when all else fails.
+$DefaultClass = 'CGI' unless defined $CGI::DefaultClass;
+
+# This is where to look for autoloaded routines.
+$AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass;
+
+# The path separator is a slash, backslash or semicolon, depending
+# on the paltform.
+$SL = {
+ UNIX => '/', OS2 => '\\', EPOC => '/', CYGWIN => '/',
+ WINDOWS => '\\', DOS => '\\', MACINTOSH => ':', VMS => '/'
+ }->{$OS};
+
+# This no longer seems to be necessary
+# Turn on NPH scripts by default when running under IIS server!
+# $NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
+$IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
+
+# Turn on special checking for Doug MacEachern's modperl
+if (exists $ENV{MOD_PERL}) {
+ # mod_perl handlers may run system() on scripts using CGI.pm;
+ # Make sure so we don't get fooled by inherited $ENV{MOD_PERL}
+ if (exists $ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) {
+ $MOD_PERL = 2;
+ require Apache2::Response;
+ require Apache2::RequestRec;
+ require Apache2::RequestUtil;
+ require Apache2::RequestIO;
+ require APR::Pool;
+ } else {
+ $MOD_PERL = 1;
+ require Apache;
+ }
+}
+
+# Turn on special checking for ActiveState's PerlEx
+$PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/;
+
+# Define the CRLF sequence. I can't use a simple "\r\n" because the meaning
+# of "\n" is different on different OS's (sometimes it generates CRLF, sometimes LF
+# and sometimes CR). The most popular VMS web server
+# doesn't accept CRLF -- instead it wants a LR. EBCDIC machines don't
+# use ASCII, so \015\012 means something different. I find this all
+# really annoying.
+$EBCDIC = "\t" ne "\011";
+if ($OS eq 'VMS') {
+ $CRLF = "\n";
+} elsif ($EBCDIC) {
+ $CRLF= "\r\n";
+} else {
+ $CRLF = "\015\012";
+}
+
+if ($needs_binmode) {
+ $CGI::DefaultClass->binmode(\*main::STDOUT);
+ $CGI::DefaultClass->binmode(\*main::STDIN);
+ $CGI::DefaultClass->binmode(\*main::STDERR);
+}
+
+%EXPORT_TAGS = (
+ ':html2'=>['h1'..'h6',qw/p br hr ol ul li dl dt dd menu code var strong em
+ tt u i b blockquote pre img a address cite samp dfn html head
+ base body Link nextid title meta kbd start_html end_html
+ input Select option comment charset escapeHTML/],
+ ':html3'=>[qw/div table caption th td TR Tr sup Sub strike applet Param nobr
+ embed basefont style span layer ilayer font frameset frame script small big Area Map/],
+ ':html4'=>[qw/abbr acronym bdo col colgroup del fieldset iframe
+ ins label legend noframes noscript object optgroup Q
+ thead tbody tfoot/],
+ ':netscape'=>[qw/blink fontsize center/],
+ ':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group
+ submit reset defaults radio_group popup_menu button autoEscape
+ scrolling_list image_button start_form end_form startform endform
+ start_multipart_form end_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/],
+ ':cgi'=>[qw/param upload path_info path_translated request_uri url self_url script_name
+ cookie Dump
+ raw_cookie request_method query_string Accept user_agent remote_host content_type
+ remote_addr referer server_name server_software server_port server_protocol virtual_port
+ virtual_host remote_ident auth_type http append
+ save_parameters restore_parameters param_fetch
+ remote_user user_name header redirect import_names put
+ Delete Delete_all url_param cgi_error/],
+ ':ssl' => [qw/https/],
+ ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam Vars/],
+ ':html' => [qw/:html2 :html3 :html4 :netscape/],
+ ':standard' => [qw/:html2 :html3 :html4 :form :cgi/],
+ ':push' => [qw/multipart_init multipart_start multipart_end multipart_final/],
+ ':all' => [qw/:html2 :html3 :netscape :form :cgi :internal :html4/]
+ );
+
+# Custom 'can' method for both autoloaded and non-autoloaded subroutines.
+# Author: Cees Hek <cees at sitesuite.com.au>
+
+sub can {
+ my($class, $method) = @_;
+
+ # See if UNIVERSAL::can finds it.
+
+ if (my $func = $class -> SUPER::can($method) ){
+ return $func;
+ }
+
+ # Try to compile the function.
+
+ eval {
+ # _compile looks at $AUTOLOAD for the function name.
+
+ local $AUTOLOAD = join "::", $class, $method;
+ &_compile;
+ };
+
+ # Now that the function is loaded (if it exists)
+ # just use UNIVERSAL::can again to do the work.
+
+ return $class -> SUPER::can($method);
+}
+
+# to import symbols into caller
+sub import {
+ my $self = shift;
+
+ # This causes modules to clash.
+ undef %EXPORT_OK;
+ undef %EXPORT;
+
+ $self->_setup_symbols(@_);
+ my ($callpack, $callfile, $callline) = caller;
+
+ # To allow overriding, search through the packages
+ # Till we find one in which the correct subroutine is defined.
+ my @packages = ($self,@{"$self\:\:ISA"});
+ for $sym (keys %EXPORT) {
+ my $pck;
+ my $def = ${"$self\:\:AutoloadClass"} || $DefaultClass;
+ for $pck (@packages) {
+ if (defined(&{"$pck\:\:$sym"})) {
+ $def = $pck;
+ last;
+ }
+ }
+ *{"${callpack}::$sym"} = \&{"$def\:\:$sym"};
+ }
+}
+
+sub compile {
+ my $pack = shift;
+ $pack->_setup_symbols('-compile', at _);
+}
+
+sub expand_tags {
+ my($tag) = @_;
+ return ("start_$1","end_$1") if $tag=~/^(?:\*|start_|end_)(.+)/;
+ my(@r);
+ return ($tag) unless $EXPORT_TAGS{$tag};
+ for (@{$EXPORT_TAGS{$tag}}) {
+ push(@r,&expand_tags($_));
+ }
+ return @r;
+}
+
+#### Method: new
+# The new routine. This will check the current environment
+# for an existing query string, and initialize itself, if so.
+####
+sub new {
+ my($class, at initializer) = @_;
+ my $self = {};
+
+ bless $self,ref $class || $class || $DefaultClass;
+
+ # always use a tempfile
+ $self->{'use_tempfile'} = 1;
+
+ if (ref($initializer[0])
+ && (UNIVERSAL::isa($initializer[0],'Apache')
+ ||
+ UNIVERSAL::isa($initializer[0],'Apache2::RequestRec')
+ )) {
+ $self->r(shift @initializer);
+ }
+ if (ref($initializer[0])
+ && (UNIVERSAL::isa($initializer[0],'CODE'))) {
+ $self->upload_hook(shift @initializer, shift @initializer);
+ $self->{'use_tempfile'} = shift @initializer if (@initializer > 0);
+ }
+ if ($MOD_PERL) {
+ if ($MOD_PERL == 1) {
+ $self->r(Apache->request) unless $self->r;
+ my $r = $self->r;
+ $r->register_cleanup(\&CGI::_reset_globals);
+ $self->_setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS;
+ }
+ else {
+ # XXX: once we have the new API
+ # will do a real PerlOptions -SetupEnv check
+ $self->r(Apache2::RequestUtil->request) unless $self->r;
+ my $r = $self->r;
+ $r->subprocess_env unless exists $ENV{REQUEST_METHOD};
+ $r->pool->cleanup_register(\&CGI::_reset_globals);
+ $self->_setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS;
+ }
+ undef $NPH;
+ }
+ $self->_reset_globals if $PERLEX;
+ $self->init(@initializer);
+ return $self;
+}
+
+# We provide a DESTROY method so that we can ensure that
+# temporary files are closed (via Fh->DESTROY) before they
+# are unlinked (via CGITempFile->DESTROY) because it is not
+# possible to unlink an open file on Win32. We explicitly
+# call DESTROY on each, rather than just undefing them and
+# letting Perl DESTROY them by garbage collection, in case the
+# user is still holding any reference to them as well.
+sub DESTROY {
+ my $self = shift;
+ if ($OS eq 'WINDOWS') {
+ for my $href (values %{$self->{'.tmpfiles'}}) {
+ $href->{hndl}->DESTROY if defined $href->{hndl};
+ $href->{name}->DESTROY if defined $href->{name};
+ }
+ }
+}
+
+sub r {
+ my $self = shift;
+ my $r = $self->{'.r'};
+ $self->{'.r'} = shift if @_;
+ $r;
+}
+
+sub upload_hook {
+ my $self;
+ if (ref $_[0] eq 'CODE') {
+ $CGI::Q = $self = $CGI::DefaultClass->new(@_);
+ } else {
+ $self = shift;
+ }
+ my ($hook,$data,$use_tempfile) = @_;
+ $self->{'.upload_hook'} = $hook;
+ $self->{'.upload_data'} = $data;
+ $self->{'use_tempfile'} = $use_tempfile if defined $use_tempfile;
+}
+
+#### Method: param
+# Returns the value(s)of a named parameter.
+# If invoked in a list context, returns the
+# entire list. Otherwise returns the first
+# member of the list.
+# If name is not provided, return a list of all
+# the known parameters names available.
+# If more than one argument is provided, the
+# second and subsequent arguments are used to
+# set the value of the parameter.
+####
+sub param {
+ my($self, at p) = self_or_default(@_);
+ return $self->all_parameters unless @p;
+ my($name,$value, at other);
+
+ # For compatibility between old calling style and use_named_parameters() style,
+ # we have to special case for a single parameter present.
+ if (@p > 1) {
+ ($name,$value, at other) = rearrange([NAME,[DEFAULT,VALUE,VALUES]], at p);
+ my(@values);
+
+ if (substr($p[0],0,1) eq '-') {
+ @values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : ();
+ } else {
+ for ($value, at other) {
+ push(@values,$_) if defined($_);
+ }
+ }
+ # If values is provided, then we set it.
+ if (@values or defined $value) {
+ $self->add_parameter($name);
+ $self->{param}{$name}=[@values];
+ }
+ } else {
+ $name = $p[0];
+ }
+
+ return unless defined($name) && $self->{param}{$name};
+
+ my @result = @{$self->{param}{$name}};
+
+ if ($PARAM_UTF8) {
+ eval "require Encode; 1;" unless Encode->can('decode'); # bring in these functions
+ @result = map {ref $_ ? $_ : Encode::decode(utf8=>$_) } @result;
+ }
+
+ return wantarray ? @result : $result[0];
+}
+
+sub self_or_default {
+ return @_ if defined($_[0]) && (!ref($_[0])) &&($_[0] eq 'CGI');
+ unless (defined($_[0]) &&
+ (ref($_[0]) eq 'CGI' || UNIVERSAL::isa($_[0],'CGI')) # slightly optimized for common case
+ ) {
+ $Q = $CGI::DefaultClass->new unless defined($Q);
+ unshift(@_,$Q);
+ }
+ return wantarray ? @_ : $Q;
+}
+
+sub self_or_CGI {
+ local $^W=0; # prevent a warning
+ if (defined($_[0]) &&
+ (substr(ref($_[0]),0,3) eq 'CGI'
+ || UNIVERSAL::isa($_[0],'CGI'))) {
+ return @_;
+ } else {
+ return ($DefaultClass, at _);
+ }
+}
+
+########################################
+# THESE METHODS ARE MORE OR LESS PRIVATE
+# GO TO THE __DATA__ SECTION TO SEE MORE
+# PUBLIC METHODS
+########################################
+
+# Initialize the query object from the environment.
+# If a parameter list is found, this object will be set
+# to a hash in which parameter names are keys
+# and the values are stored as lists
+# If a keyword list is found, this method creates a bogus
+# parameter list with the single parameter 'keywords'.
+
+sub init {
+ my $self = shift;
+ my($query_string,$meth,$content_length,$fh, at lines) = ('','','','');
+
+ my $is_xforms;
+
+ my $initializer = shift; # for backward compatibility
+ local($/) = "\n";
+
+ # set autoescaping on by default
+ $self->{'escape'} = 1;
+
+ # if we get called more than once, we want to initialize
+ # ourselves from the original query (which may be gone
+ # if it was read from STDIN originally.)
+ if (defined(@QUERY_PARAM) && !defined($initializer)) {
+ for my $name (@QUERY_PARAM) {
+ my $val = $QUERY_PARAM{$name}; # always an arrayref;
+ $self->param('-name'=>$name,'-value'=> $val);
+ if (defined $val and ref $val eq 'ARRAY') {
+ for my $fh (grep {defined(fileno($_))} @$val) {
+ seek($fh,0,0); # reset the filehandle.
+ }
+
+ }
+ }
+ $self->charset($QUERY_CHARSET);
+ $self->{'.fieldnames'} = {%QUERY_FIELDNAMES};
+ $self->{'.tmpfiles'} = {%QUERY_TMPFILES};
+ return;
+ }
+
+ $meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'});
+ $content_length = defined($ENV{'CONTENT_LENGTH'}) ? $ENV{'CONTENT_LENGTH'} : 0;
+
+ $fh = to_filehandle($initializer) if $initializer;
+
+ # set charset to the safe ISO-8859-1
+ $self->charset('ISO-8859-1');
+
+ METHOD: {
+
+ # avoid unreasonably large postings
+ if (($POST_MAX > 0) && ($content_length > $POST_MAX)) {
+ #discard the post, unread
+ $self->cgi_error("413 Request entity too large");
+ last METHOD;
+ }
+
+ # Process multipart postings, but only if the initializer is
+ # not defined.
+ if ($meth eq 'POST'
+ && defined($ENV{'CONTENT_TYPE'})
+ && $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data|
+ && !defined($initializer)
+ ) {
+ my($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";,]+)\"?/;
+ $self->read_multipart($boundary,$content_length);
+ last METHOD;
+ }
+
+ # Process XForms postings. We know that we have XForms in the
+ # following cases:
+ # method eq 'POST' && content-type eq 'application/xml'
+ # method eq 'POST' && content-type =~ /multipart\/related.+start=/
+ # There are more cases, actually, but for now, we don't support other
+ # methods for XForm posts.
+ # In a XForm POST, the QUERY_STRING is parsed normally.
+ # If the content-type is 'application/xml', we just set the param
+ # XForms:Model (referring to the xml syntax) param containing the
+ # unparsed XML data.
+ # In the case of multipart/related we set XForms:Model as above, but
+ # the other parts are available as uploads with the Content-ID as the
+ # the key.
+ # See the URL below for XForms specs on this issue.
+ # http://www.w3.org/TR/2006/REC-xforms-20060314/slice11.html#submit-options
+ if ($meth eq 'POST' && defined($ENV{'CONTENT_TYPE'})) {
+ if ($ENV{'CONTENT_TYPE'} eq 'application/xml') {
+ my($param) = 'XForms:Model';
+ my($value) = '';
+ $self->add_parameter($param);
+ $self->read_from_client(\$value,$content_length,0)
+ if $content_length > 0;
+ push (@{$self->{param}{$param}},$value);
+ $is_xforms = 1;
+ } elsif ($ENV{'CONTENT_TYPE'} =~ /multipart\/related.+boundary=\"?([^\";,]+)\"?.+start=\"?\<?([^\"\>]+)\>?\"?/) {
+ my($boundary,$start) = ($1,$2);
+ my($param) = 'XForms:Model';
+ $self->add_parameter($param);
+ my($value) = $self->read_multipart_related($start,$boundary,$content_length,0);
+ push (@{$self->{param}{$param}},$value);
+ if ($MOD_PERL) {
+ $query_string = $self->r->args;
+ } else {
+ $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
+ $query_string ||= $ENV{'REDIRECT_QUERY_STRING'} if defined $ENV{'REDIRECT_QUERY_STRING'};
+ }
+ $is_xforms = 1;
+ }
+ }
+
+
+ # If initializer is defined, then read parameters
+ # from it.
+ if (!$is_xforms && defined($initializer)) {
+ if (UNIVERSAL::isa($initializer,'CGI')) {
+ $query_string = $initializer->query_string;
+ last METHOD;
+ }
+ if (ref($initializer) && ref($initializer) eq 'HASH') {
+ for (keys %$initializer) {
+ $self->param('-name'=>$_,'-value'=>$initializer->{$_});
+ }
+ last METHOD;
+ }
+
+ if (defined($fh) && ($fh ne '')) {
+ while (<$fh>) {
+ chomp;
+ last if /^=/;
+ push(@lines,$_);
+ }
+ # massage back into standard format
+ if ("@lines" =~ /=/) {
+ $query_string=join("&", at lines);
+ } else {
+ $query_string=join("+", at lines);
+ }
+ last METHOD;
+ }
+
+ # last chance -- treat it as a string
+ $initializer = $$initializer if ref($initializer) eq 'SCALAR';
+ $query_string = $initializer;
+
+ last METHOD;
+ }
+
+ # If method is GET or HEAD, fetch the query from
+ # the environment.
+ if ($is_xforms || $meth=~/^(GET|HEAD)$/) {
+ if ($MOD_PERL) {
+ $query_string = $self->r->args;
+ } else {
+ $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
+ $query_string ||= $ENV{'REDIRECT_QUERY_STRING'} if defined $ENV{'REDIRECT_QUERY_STRING'};
+ }
+ last METHOD;
+ }
+
+ if ($meth eq 'POST' || $meth eq 'PUT') {
+ $self->read_from_client(\$query_string,$content_length,0)
+ if $content_length > 0;
+ # Some people want to have their cake and eat it too!
+ # Uncomment this line to have the contents of the query string
+ # APPENDED to the POST data.
+ # $query_string .= (length($query_string) ? '&' : '') . $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
+ last METHOD;
+ }
+
+ # If $meth is not of GET, POST or HEAD, assume we're being debugged offline.
+ # Check the command line and then the standard input for data.
+ # We use the shellwords package in order to behave the way that
+ # UN*X programmers expect.
+ if ($DEBUG)
+ {
+ my $cmdline_ret = read_from_cmdline();
+ $query_string = $cmdline_ret->{'query_string'};
+ if (defined($cmdline_ret->{'subpath'}))
+ {
+ $self->path_info($cmdline_ret->{'subpath'});
+ }
+ }
+ }
+
+# YL: Begin Change for XML handler 10/19/2001
+ if (!$is_xforms && ($meth eq 'POST' || $meth eq 'PUT')
+ && defined($ENV{'CONTENT_TYPE'})
+ && $ENV{'CONTENT_TYPE'} !~ m|^application/x-www-form-urlencoded|
+ && $ENV{'CONTENT_TYPE'} !~ m|^multipart/form-data| ) {
+ my($param) = $meth . 'DATA' ;
+ $self->add_parameter($param) ;
+ push (@{$self->{param}{$param}},$query_string);
+ undef $query_string ;
+ }
+# YL: End Change for XML handler 10/19/2001
+
+ # We now have the query string in hand. We do slightly
+ # different things for keyword lists and parameter lists.
+ if (defined $query_string && length $query_string) {
+ if ($query_string =~ /[&=;]/) {
+ $self->parse_params($query_string);
+ } else {
+ $self->add_parameter('keywords');
+ $self->{param}{'keywords'} = [$self->parse_keywordlist($query_string)];
+ }
+ }
+
+ # Special case. Erase everything if there is a field named
+ # .defaults.
+ if ($self->param('.defaults')) {
+ $self->delete_all();
+ }
+
+ # hash containing our defined fieldnames
+ $self->{'.fieldnames'} = {};
+ for ($self->param('.cgifields')) {
+ $self->{'.fieldnames'}->{$_}++;
+ }
+
+ # Clear out our default submission button flag if present
+ $self->delete('.submit');
+ $self->delete('.cgifields');
+
+ $self->save_request unless defined $initializer;
+}
+
+# FUNCTIONS TO OVERRIDE:
+# Turn a string into a filehandle
+sub to_filehandle {
+ my $thingy = shift;
+ return undef unless $thingy;
+ return $thingy if UNIVERSAL::isa($thingy,'GLOB');
+ return $thingy if UNIVERSAL::isa($thingy,'FileHandle');
+ if (!ref($thingy)) {
+ my $caller = 1;
+ while (my $package = caller($caller++)) {
+ my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy";
+ return $tmp if defined(fileno($tmp));
+ }
+ }
+ return undef;
+}
+
+# send output to the browser
+sub put {
+ my($self, at p) = self_or_default(@_);
+ $self->print(@p);
+}
+
+# print to standard output (for overriding in mod_perl)
+sub print {
+ shift;
+ CORE::print(@_);
+}
+
+# get/set last cgi_error
+sub cgi_error {
+ my ($self,$err) = self_or_default(@_);
+ $self->{'.cgi_error'} = $err if defined $err;
+ return $self->{'.cgi_error'};
+}
+
+sub save_request {
+ my($self) = @_;
+ # We're going to play with the package globals now so that if we get called
+ # again, we initialize ourselves in exactly the same way. This allows
+ # us to have several of these objects.
+ @QUERY_PARAM = $self->param; # save list of parameters
+ for (@QUERY_PARAM) {
+ next unless defined $_;
+ $QUERY_PARAM{$_}=$self->{param}{$_};
+ }
+ $QUERY_CHARSET = $self->charset;
+ %QUERY_FIELDNAMES = %{$self->{'.fieldnames'}};
+ %QUERY_TMPFILES = %{ $self->{'.tmpfiles'} || {} };
+}
+
+sub parse_params {
+ my($self,$tosplit) = @_;
+ my(@pairs) = split(/[&;]/,$tosplit);
+ my($param,$value);
+ for (@pairs) {
+ ($param,$value) = split('=',$_,2);
+ next unless defined $param;
+ next if $NO_UNDEF_PARAMS and not defined $value;
+ $value = '' unless defined $value;
+ $param = unescape($param);
+ $value = unescape($value);
+ $self->add_parameter($param);
+ push (@{$self->{param}{$param}},$value);
+ }
+}
+
+sub add_parameter {
+ my($self,$param)=@_;
+ return unless defined $param;
+ push (@{$self->{'.parameters'}},$param)
+ unless defined($self->{param}{$param});
+}
+
+sub all_parameters {
+ my $self = shift;
+ return () unless defined($self) && $self->{'.parameters'};
+ return () unless @{$self->{'.parameters'}};
+ return @{$self->{'.parameters'}};
+}
+
+# put a filehandle into binary mode (DOS)
+sub binmode {
+ return unless defined($_[1]) && defined fileno($_[1]);
+ CORE::binmode($_[1]);
+}
+
+sub _make_tag_func {
+ my ($self,$tagname) = @_;
+ my $func = qq(
+ sub $tagname {
+ my (\$q,\$a,\@rest) = self_or_default(\@_);
+ my(\$attr) = '';
+ if (ref(\$a) && ref(\$a) eq 'HASH') {
+ my(\@attr) = make_attributes(\$a,\$q->{'escape'});
+ \$attr = " \@attr" if \@attr;
+ } else {
+ unshift \@rest,\$a if defined \$a;
+ }
+ );
+ if ($tagname=~/start_(\w+)/i) {
+ $func .= qq! return "<\L$1\E\$attr>";} !;
+ } elsif ($tagname=~/end_(\w+)/i) {
+ $func .= qq! return "<\L/$1\E>"; } !;
+ } else {
+ $func .= qq#
+ return \$XHTML ? "\L<$tagname\E\$attr />" : "\L<$tagname\E\$attr>" unless \@rest;
+ my(\$tag,\$untag) = ("\L<$tagname\E\$attr>","\L</$tagname>\E");
+ my \@result = map { "\$tag\$_\$untag" }
+ (ref(\$rest[0]) eq 'ARRAY') ? \@{\$rest[0]} : "\@rest";
+ return "\@result";
+ }#;
+ }
+return $func;
+}
+
+sub AUTOLOAD {
+ print STDERR "CGI::AUTOLOAD for $AUTOLOAD\n" if $CGI::AUTOLOAD_DEBUG;
+ my $func = &_compile;
+ goto &$func;
+}
+
+sub _compile {
+ my($func) = $AUTOLOAD;
+ my($pack,$func_name);
+ {
+ local($1,$2); # this fixes an obscure variable suicide problem.
+ $func=~/(.+)::([^:]+)$/;
+ ($pack,$func_name) = ($1,$2);
+ $pack=~s/::SUPER$//; # fix another obscure problem
+ $pack = ${"$pack\:\:AutoloadClass"} || $CGI::DefaultClass
+ unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"});
+
+ my($sub) = \%{"$pack\:\:SUBS"};
+ unless (%$sub) {
+ my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"};
+ local ($@,$!);
+ eval "package $pack; $$auto";
+ croak("$AUTOLOAD: $@") if $@;
+ $$auto = ''; # Free the unneeded storage (but don't undef it!!!)
+ }
+ my($code) = $sub->{$func_name};
+
+ $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY');
+ if (!$code) {
+ (my $base = $func_name) =~ s/^(start_|end_)//i;
+ if ($EXPORT{':any'} ||
+ $EXPORT{'-any'} ||
+ $EXPORT{$base} ||
+ (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html')))
+ && $EXPORT_OK{$base}) {
+ $code = $CGI::DefaultClass->_make_tag_func($func_name);
+ }
+ }
+ croak("Undefined subroutine $AUTOLOAD\n") unless $code;
+ local ($@,$!);
+ eval "package $pack; $code";
+ if ($@) {
+ $@ =~ s/ at .*\n//;
+ croak("$AUTOLOAD: $@");
+ }
+ }
+ CORE::delete($sub->{$func_name}); #free storage
+ return "$pack\:\:$func_name";
+}
+
+sub _selected {
+ my $self = shift;
+ my $value = shift;
+ return '' unless $value;
+ return $XHTML ? qq(selected="selected" ) : qq(selected );
+}
+
+sub _checked {
+ my $self = shift;
+ my $value = shift;
+ return '' unless $value;
+ return $XHTML ? qq(checked="checked" ) : qq(checked );
+}
+
+sub _reset_globals { initialize_globals(); }
+
+sub _setup_symbols {
+ my $self = shift;
+ my $compile = 0;
+
+ # to avoid reexporting unwanted variables
+ undef %EXPORT;
+
+ for (@_) {
+ $HEADERS_ONCE++, next if /^[:-]unique_headers$/;
+ $NPH++, next if /^[:-]nph$/;
+ $NOSTICKY++, next if /^[:-]nosticky$/;
+ $DEBUG=0, next if /^[:-]no_?[Dd]ebug$/;
+ $DEBUG=2, next if /^[:-][Dd]ebug$/;
+ $USE_PARAM_SEMICOLONS++, next if /^[:-]newstyle_urls$/;
+ $PARAM_UTF8++, next if /^[:-]utf8$/;
+ $XHTML++, next if /^[:-]xhtml$/;
+ $XHTML=0, next if /^[:-]no_?xhtml$/;
+ $USE_PARAM_SEMICOLONS=0, next if /^[:-]oldstyle_urls$/;
+ $PRIVATE_TEMPFILES++, next if /^[:-]private_tempfiles$/;
+ $TABINDEX++, next if /^[:-]tabindex$/;
+ $CLOSE_UPLOAD_FILES++, next if /^[:-]close_upload_files$/;
+ $EXPORT{$_}++, next if /^[:-]any$/;
+ $compile++, next if /^[:-]compile$/;
+ $NO_UNDEF_PARAMS++, next if /^[:-]no_undef_params$/;
+
+ # This is probably extremely evil code -- to be deleted some day.
+ if (/^[-]autoload$/) {
+ my($pkg) = caller(1);
+ *{"${pkg}::AUTOLOAD"} = sub {
+ my($routine) = $AUTOLOAD;
+ $routine =~ s/^.*::/CGI::/;
+ &$routine;
+ };
+ next;
+ }
+
+ for (&expand_tags($_)) {
+ tr/a-zA-Z0-9_//cd; # don't allow weird function names
+ $EXPORT{$_}++;
+ }
+ }
+ _compile_all(keys %EXPORT) if $compile;
+ @SAVED_SYMBOLS = @_;
+}
+
+sub charset {
+ my ($self,$charset) = self_or_default(@_);
+ $self->{'.charset'} = $charset if defined $charset;
+ $self->{'.charset'};
+}
+
+sub element_id {
+ my ($self,$new_value) = self_or_default(@_);
+ $self->{'.elid'} = $new_value if defined $new_value;
+ sprintf('%010d',$self->{'.elid'}++);
+}
+
+sub element_tab {
+ my ($self,$new_value) = self_or_default(@_);
+ $self->{'.etab'} ||= 1;
+ $self->{'.etab'} = $new_value if defined $new_value;
+ my $tab = $self->{'.etab'}++;
+ return '' unless $TABINDEX or defined $new_value;
+ return qq(tabindex="$tab" );
+}
+
+###############################################################################
+################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
+###############################################################################
+$AUTOLOADED_ROUTINES = ''; # get rid of -w warning
+$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
+
+%SUBS = (
+
+'URL_ENCODED'=> <<'END_OF_FUNC',
+sub URL_ENCODED { 'application/x-www-form-urlencoded'; }
+END_OF_FUNC
+
+'MULTIPART' => <<'END_OF_FUNC',
+sub MULTIPART { 'multipart/form-data'; }
+END_OF_FUNC
+
+'SERVER_PUSH' => <<'END_OF_FUNC',
+sub SERVER_PUSH { 'multipart/x-mixed-replace;boundary="' . shift() . '"'; }
+END_OF_FUNC
+
+'new_MultipartBuffer' => <<'END_OF_FUNC',
+# Create a new multipart buffer
+sub new_MultipartBuffer {
+ my($self,$boundary,$length) = @_;
+ return MultipartBuffer->new($self,$boundary,$length);
+}
+END_OF_FUNC
+
+'read_from_client' => <<'END_OF_FUNC',
+# Read data from a file handle
+sub read_from_client {
+ my($self, $buff, $len, $offset) = @_;
+ local $^W=0; # prevent a warning
+ return $MOD_PERL
+ ? $self->r->read($$buff, $len, $offset)
+ : read(\*STDIN, $$buff, $len, $offset);
+}
+END_OF_FUNC
+
+'delete' => <<'END_OF_FUNC',
+#### Method: delete
+# Deletes the named parameter entirely.
+####
+sub delete {
+ my($self, at p) = self_or_default(@_);
+ my(@names) = rearrange([NAME], at p);
+ my @to_delete = ref($names[0]) eq 'ARRAY' ? @$names[0] : @names;
+ my %to_delete;
+ for my $name (@to_delete)
+ {
+ CORE::delete $self->{param}{$name};
+ CORE::delete $self->{'.fieldnames'}->{$name};
+ $to_delete{$name}++;
+ }
+ @{$self->{'.parameters'}}=grep { !exists($to_delete{$_}) } $self->param();
+ return;
+}
+END_OF_FUNC
+
+#### Method: import_names
+# Import all parameters into the given namespace.
+# Assumes namespace 'Q' if not specified
+####
+'import_names' => <<'END_OF_FUNC',
+sub import_names {
+ my($self,$namespace,$delete) = self_or_default(@_);
+ $namespace = 'Q' unless defined($namespace);
+ die "Can't import names into \"main\"\n" if \%{"${namespace}::"} == \%::;
+ if ($delete || $MOD_PERL || exists $ENV{'FCGI_ROLE'}) {
+ # can anyone find an easier way to do this?
+ for (keys %{"${namespace}::"}) {
+ local *symbol = "${namespace}::${_}";
+ undef $symbol;
+ undef @symbol;
+ undef %symbol;
+ }
+ }
+ my($param, at value,$var);
+ for $param ($self->param) {
+ # protect against silly names
+ ($var = $param)=~tr/a-zA-Z0-9_/_/c;
+ $var =~ s/^(?=\d)/_/;
+ local *symbol = "${namespace}::$var";
+ @value = $self->param($param);
+ @symbol = @value;
+ $symbol = $value[0];
+ }
+}
+END_OF_FUNC
+
+#### Method: keywords
+# Keywords acts a bit differently. Calling it in a list context
+# returns the list of keywords.
+# Calling it in a scalar context gives you the size of the list.
+####
+'keywords' => <<'END_OF_FUNC',
+sub keywords {
+ my($self, at values) = self_or_default(@_);
+ # If values is provided, then we set it.
+ $self->{param}{'keywords'}=[@values] if @values;
+ my(@result) = defined($self->{param}{'keywords'}) ? @{$self->{param}{'keywords'}} : ();
+ @result;
+}
+END_OF_FUNC
+
+# These are some tie() interfaces for compatibility
+# with Steve Brenner's cgi-lib.pl routines
+'Vars' => <<'END_OF_FUNC',
+sub Vars {
+ my $q = shift;
+ my %in;
+ tie(%in,CGI,$q);
+ return %in if wantarray;
+ return \%in;
+}
+END_OF_FUNC
+
+# These are some tie() interfaces for compatibility
+# with Steve Brenner's cgi-lib.pl routines
+'ReadParse' => <<'END_OF_FUNC',
+sub ReadParse {
+ local(*in);
+ if (@_) {
+ *in = $_[0];
+ } else {
+ my $pkg = caller();
+ *in=*{"${pkg}::in"};
+ }
+ tie(%in,CGI);
+ return scalar(keys %in);
+}
+END_OF_FUNC
+
+'PrintHeader' => <<'END_OF_FUNC',
+sub PrintHeader {
+ my($self) = self_or_default(@_);
+ return $self->header();
+}
+END_OF_FUNC
+
+'HtmlTop' => <<'END_OF_FUNC',
+sub HtmlTop {
+ my($self, at p) = self_or_default(@_);
+ return $self->start_html(@p);
+}
+END_OF_FUNC
+
+'HtmlBot' => <<'END_OF_FUNC',
+sub HtmlBot {
+ my($self, at p) = self_or_default(@_);
+ return $self->end_html(@p);
+}
+END_OF_FUNC
+
+'SplitParam' => <<'END_OF_FUNC',
+sub SplitParam {
+ my ($param) = @_;
+ my (@params) = split ("\0", $param);
+ return (wantarray ? @params : $params[0]);
+}
+END_OF_FUNC
+
+'MethGet' => <<'END_OF_FUNC',
+sub MethGet {
+ return request_method() eq 'GET';
+}
+END_OF_FUNC
+
+'MethPost' => <<'END_OF_FUNC',
+sub MethPost {
+ return request_method() eq 'POST';
+}
+END_OF_FUNC
+
+'TIEHASH' => <<'END_OF_FUNC',
+sub TIEHASH {
+ my $class = shift;
+ my $arg = $_[0];
+ if (ref($arg) && UNIVERSAL::isa($arg,'CGI')) {
+ return $arg;
+ }
+ return $Q ||= $class->new(@_);
+}
+END_OF_FUNC
+
+'STORE' => <<'END_OF_FUNC',
+sub STORE {
+ my $self = shift;
+ my $tag = shift;
+ my $vals = shift;
+ my @vals = index($vals,"\0")!=-1 ? split("\0",$vals) : $vals;
+ $self->param(-name=>$tag,-value=>\@vals);
+}
+END_OF_FUNC
+
+'FETCH' => <<'END_OF_FUNC',
+sub FETCH {
+ return $_[0] if $_[1] eq 'CGI';
+ return undef unless defined $_[0]->param($_[1]);
+ return join("\0",$_[0]->param($_[1]));
+}
+END_OF_FUNC
+
+'FIRSTKEY' => <<'END_OF_FUNC',
+sub FIRSTKEY {
+ $_[0]->{'.iterator'}=0;
+ $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
+}
+END_OF_FUNC
+
+'NEXTKEY' => <<'END_OF_FUNC',
+sub NEXTKEY {
+ $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
+}
+END_OF_FUNC
+
+'EXISTS' => <<'END_OF_FUNC',
+sub EXISTS {
+ exists $_[0]->{param}{$_[1]};
+}
+END_OF_FUNC
+
+'DELETE' => <<'END_OF_FUNC',
+sub DELETE {
+ $_[0]->delete($_[1]);
+}
+END_OF_FUNC
+
+'CLEAR' => <<'END_OF_FUNC',
+sub CLEAR {
+ %{$_[0]}=();
+}
+####
+END_OF_FUNC
+
+####
+# Append a new value to an existing query
+####
+'append' => <<'EOF',
+sub append {
+ my($self, at p) = self_or_default(@_);
+ my($name,$value) = rearrange([NAME,[VALUE,VALUES]], at p);
+ my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : ();
+ if (@values) {
+ $self->add_parameter($name);
+ push(@{$self->{param}{$name}}, at values);
+ }
+ return $self->param($name);
+}
+EOF
+
+#### Method: delete_all
+# Delete all parameters
+####
+'delete_all' => <<'EOF',
+sub delete_all {
+ my($self) = self_or_default(@_);
+ my @param = $self->param();
+ $self->delete(@param);
+}
+EOF
+
+'Delete' => <<'EOF',
+sub Delete {
+ my($self, at p) = self_or_default(@_);
+ $self->delete(@p);
+}
+EOF
+
+'Delete_all' => <<'EOF',
+sub Delete_all {
+ my($self, at p) = self_or_default(@_);
+ $self->delete_all(@p);
+}
+EOF
+
+#### Method: autoescape
+# If you want to turn off the autoescaping features,
+# call this method with undef as the argument
+'autoEscape' => <<'END_OF_FUNC',
+sub autoEscape {
+ my($self,$escape) = self_or_default(@_);
+ my $d = $self->{'escape'};
+ $self->{'escape'} = $escape;
+ $d;
+}
+END_OF_FUNC
+
+
+#### Method: version
+# Return the current version
+####
+'version' => <<'END_OF_FUNC',
+sub version {
+ return $VERSION;
+}
+END_OF_FUNC
+
+#### Method: url_param
+# Return a parameter in the QUERY_STRING, regardless of
+# whether this was a POST or a GET
+####
+'url_param' => <<'END_OF_FUNC',
+sub url_param {
+ my ($self, at p) = self_or_default(@_);
+ my $name = shift(@p);
+ return undef unless exists($ENV{QUERY_STRING});
+ unless (exists($self->{'.url_param'})) {
+ $self->{'.url_param'}={}; # empty hash
+ if ($ENV{QUERY_STRING} =~ /=/) {
+ my(@pairs) = split(/[&;]/,$ENV{QUERY_STRING});
+ my($param,$value);
+ for (@pairs) {
+ ($param,$value) = split('=',$_,2);
+ $param = unescape($param);
+ $value = unescape($value);
+ push(@{$self->{'.url_param'}->{$param}},$value);
+ }
+ } else {
+ $self->{'.url_param'}->{'keywords'} = [$self->parse_keywordlist($ENV{QUERY_STRING})];
+ }
+ }
+ return keys %{$self->{'.url_param'}} unless defined($name);
+ return () unless $self->{'.url_param'}->{$name};
+ return wantarray ? @{$self->{'.url_param'}->{$name}}
+ : $self->{'.url_param'}->{$name}->[0];
+}
+END_OF_FUNC
+
+#### Method: Dump
+# Returns a string in which all the known parameter/value
+# pairs are represented as nested lists, mainly for the purposes
+# of debugging.
+####
+'Dump' => <<'END_OF_FUNC',
+sub Dump {
+ my($self) = self_or_default(@_);
+ my($param,$value, at result);
+ return '<ul></ul>' unless $self->param;
+ push(@result,"<ul>");
+ for $param ($self->param) {
+ my($name)=$self->escapeHTML($param);
+ push(@result,"<li><strong>$param</strong></li>");
+ push(@result,"<ul>");
+ for $value ($self->param($param)) {
+ $value = $self->escapeHTML($value);
+ $value =~ s/\n/<br \/>\n/g;
+ push(@result,"<li>$value</li>");
+ }
+ push(@result,"</ul>");
+ }
+ push(@result,"</ul>");
+ return join("\n", at result);
+}
+END_OF_FUNC
+
+#### Method as_string
+#
+# synonym for "dump"
+####
+'as_string' => <<'END_OF_FUNC',
+sub as_string {
+ &Dump(@_);
+}
+END_OF_FUNC
+
+#### Method: save
+# Write values out to a filehandle in such a way that they can
+# be reinitialized by the filehandle form of the new() method
+####
+'save' => <<'END_OF_FUNC',
+sub save {
+ my($self,$filehandle) = self_or_default(@_);
+ $filehandle = to_filehandle($filehandle);
+ my($param);
+ local($,) = ''; # set print field separator back to a sane value
+ local($\) = ''; # set output line separator to a sane value
+ for $param ($self->param) {
+ my($escaped_param) = escape($param);
+ my($value);
+ for $value ($self->param($param)) {
+ print $filehandle "$escaped_param=",escape("$value"),"\n";
+ }
+ }
+ for (keys %{$self->{'.fieldnames'}}) {
+ print $filehandle ".cgifields=",escape("$_"),"\n";
+ }
+ print $filehandle "=\n"; # end of record
+}
+END_OF_FUNC
+
+
+#### Method: save_parameters
+# An alias for save() that is a better name for exportation.
+# Only intended to be used with the function (non-OO) interface.
+####
+'save_parameters' => <<'END_OF_FUNC',
+sub save_parameters {
+ my $fh = shift;
+ return save(to_filehandle($fh));
+}
+END_OF_FUNC
+
+#### Method: restore_parameters
+# A way to restore CGI parameters from an initializer.
+# Only intended to be used with the function (non-OO) interface.
+####
+'restore_parameters' => <<'END_OF_FUNC',
+sub restore_parameters {
+ $Q = $CGI::DefaultClass->new(@_);
+}
+END_OF_FUNC
+
+#### Method: multipart_init
+# Return a Content-Type: style header for server-push
+# This has to be NPH on most web servers, and it is advisable to set $| = 1
+#
+# Many thanks to Ed Jordan <ed at fidalgo.net> for this
+# contribution, updated by Andrew Benham (adsb at bigfoot.com)
+####
+'multipart_init' => <<'END_OF_FUNC',
+sub multipart_init {
+ my($self, at p) = self_or_default(@_);
+ my($boundary, at other) = rearrange_header([BOUNDARY], at p);
+ $boundary = $boundary || '------- =_aaaaaaaaaa0';
+ $self->{'separator'} = "$CRLF--$boundary$CRLF";
+ $self->{'final_separator'} = "$CRLF--$boundary--$CRLF";
+ $type = SERVER_PUSH($boundary);
+ return $self->header(
+ -nph => 0,
+ -type => $type,
+ (map { split "=", $_, 2 } @other),
+ ) . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $self->multipart_end;
+}
+END_OF_FUNC
+
+
+#### Method: multipart_start
+# Return a Content-Type: style header for server-push, start of section
+#
+# Many thanks to Ed Jordan <ed at fidalgo.net> for this
+# contribution, updated by Andrew Benham (adsb at bigfoot.com)
+####
+'multipart_start' => <<'END_OF_FUNC',
+sub multipart_start {
+ my(@header);
+ my($self, at p) = self_or_default(@_);
+ my($type, at other) = rearrange([TYPE], at p);
+ $type = $type || 'text/html';
+ push(@header,"Content-Type: $type");
+
+ # rearrange() was designed for the HTML portion, so we
+ # need to fix it up a little.
+ for (@other) {
+ # Don't use \s because of perl bug 21951
+ next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/;
+ ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ': '.$self->unescapeHTML($value)/e;
+ }
+ push(@header, at other);
+ my $header = join($CRLF, at header)."${CRLF}${CRLF}";
+ return $header;
+}
+END_OF_FUNC
+
+
+#### Method: multipart_end
+# Return a MIME boundary separator for server-push, end of section
+#
+# Many thanks to Ed Jordan <ed at fidalgo.net> for this
+# contribution
+####
+'multipart_end' => <<'END_OF_FUNC',
+sub multipart_end {
+ my($self, at p) = self_or_default(@_);
+ return $self->{'separator'};
+}
+END_OF_FUNC
+
+
+#### Method: multipart_final
+# Return a MIME boundary separator for server-push, end of all sections
+#
+# Contributed by Andrew Benham (adsb at bigfoot.com)
+####
+'multipart_final' => <<'END_OF_FUNC',
+sub multipart_final {
+ my($self, at p) = self_or_default(@_);
+ return $self->{'final_separator'} . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $CRLF;
+}
+END_OF_FUNC
+
+
+#### Method: header
+# Return a Content-Type: style header
+#
+####
+'header' => <<'END_OF_FUNC',
+sub header {
+ my($self, at p) = self_or_default(@_);
+ my(@header);
+
+ return "" if $self->{'.header_printed'}++ and $HEADERS_ONCE;
+
+ my($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,$p3p, at other) =
+ rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'],
+ 'STATUS',['COOKIE','COOKIES'],'TARGET',
+ 'EXPIRES','NPH','CHARSET',
+ 'ATTACHMENT','P3P'], at p);
+
+ $nph ||= $NPH;
+
+ $type ||= 'text/html' unless defined($type);
+
+ if (defined $charset) {
+ $self->charset($charset);
+ } else {
+ $charset = $self->charset if $type =~ /^text\//;
+ }
+ $charset ||= '';
+
+ # rearrange() was designed for the HTML portion, so we
+ # need to fix it up a little.
+ for (@other) {
+ # Don't use \s because of perl bug 21951
+ next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/;
+ ($_ = $header) =~ s/^(\w)(.*)/"\u$1\L$2" . ': '.$self->unescapeHTML($value)/e;
+ }
+
+ $type .= "; charset=$charset"
+ if $type ne ''
+ and $type !~ /\bcharset\b/
+ and defined $charset
+ and $charset ne '';
+
+ # Maybe future compatibility. Maybe not.
+ my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
+ push(@header,$protocol . ' ' . ($status || '200 OK')) if $nph;
+ push(@header,"Server: " . &server_software()) if $nph;
+
+ push(@header,"Status: $status") if $status;
+ push(@header,"Window-Target: $target") if $target;
+ if ($p3p) {
+ $p3p = join ' ',@$p3p if ref($p3p) eq 'ARRAY';
+ push(@header,qq(P3P: policyref="/w3c/p3p.xml", CP="$p3p"));
+ }
+ # push all the cookies -- there may be several
+ if ($cookie) {
+ my(@cookie) = ref($cookie) && ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie;
+ for (@cookie) {
+ my $cs = UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_;
+ push(@header,"Set-Cookie: $cs") if $cs ne '';
+ }
+ }
+ # if the user indicates an expiration time, then we need
+ # both an Expires and a Date header (so that the browser is
+ # uses OUR clock)
+ push(@header,"Expires: " . expires($expires,'http'))
+ if $expires;
+ push(@header,"Date: " . expires(0,'http')) if $expires || $cookie || $nph;
+ push(@header,"Pragma: no-cache") if $self->cache();
+ push(@header,"Content-Disposition: attachment; filename=\"$attachment\"") if $attachment;
+ push(@header,map {ucfirst $_} @other);
+ push(@header,"Content-Type: $type") if $type ne '';
+ my $header = join($CRLF, at header)."${CRLF}${CRLF}";
+ if (($MOD_PERL >= 1) && !$nph) {
+ $self->r->send_cgi_header($header);
+ return '';
+ }
+ return $header;
+}
+END_OF_FUNC
+
+
+#### Method: cache
+# Control whether header() will produce the no-cache
+# Pragma directive.
+####
+'cache' => <<'END_OF_FUNC',
+sub cache {
+ my($self,$new_value) = self_or_default(@_);
+ $new_value = '' unless $new_value;
+ if ($new_value ne '') {
+ $self->{'cache'} = $new_value;
+ }
+ return $self->{'cache'};
+}
+END_OF_FUNC
+
+
+#### Method: redirect
+# Return a Location: style header
+#
+####
+'redirect' => <<'END_OF_FUNC',
+sub redirect {
+ my($self, at p) = self_or_default(@_);
+ my($url,$target,$status,$cookie,$nph, at other) =
+ rearrange([[LOCATION,URI,URL],TARGET,STATUS,['COOKIE','COOKIES'],NPH], at p);
+ $status = '302 Found' unless defined $status;
+ $url ||= $self->self_url;
+ my(@o);
+ for (@other) { tr/\"//d; push(@o,split("=",$_,2)); }
+ unshift(@o,
+ '-Status' => $status,
+ '-Location'=> $url,
+ '-nph' => $nph);
+ unshift(@o,'-Target'=>$target) if $target;
+ unshift(@o,'-Type'=>'');
+ my @unescaped;
+ unshift(@unescaped,'-Cookie'=>$cookie) if $cookie;
+ return $self->header((map {$self->unescapeHTML($_)} @o), at unescaped);
+}
+END_OF_FUNC
+
+
+#### Method: start_html
+# Canned HTML header
+#
+# Parameters:
+# $title -> (optional) The title for this HTML document (-title)
+# $author -> (optional) e-mail address of the author (-author)
+# $base -> (optional) if set to true, will enter the BASE address of this document
+# for resolving relative references (-base)
+# $xbase -> (optional) alternative base at some remote location (-xbase)
+# $target -> (optional) target window to load all links into (-target)
+# $script -> (option) Javascript code (-script)
+# $no_script -> (option) Javascript <noscript> tag (-noscript)
+# $meta -> (optional) Meta information tags
+# $head -> (optional) any other elements you'd like to incorporate into the <head> tag
+# (a scalar or array ref)
+# $style -> (optional) reference to an external style sheet
+# @other -> (optional) any other named parameters you'd like to incorporate into
+# the <body> tag.
+####
+'start_html' => <<'END_OF_FUNC',
+sub start_html {
+ my($self, at p) = &self_or_default(@_);
+ my($title,$author,$base,$xbase,$script,$noscript,
+ $target,$meta,$head,$style,$dtd,$lang,$encoding,$declare_xml, at other) =
+ rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,
+ META,HEAD,STYLE,DTD,LANG,ENCODING,DECLARE_XML], at p);
+
+ $self->element_id(0);
+ $self->element_tab(0);
+
+ $encoding = lc($self->charset) unless defined $encoding;
+
+ # Need to sort out the DTD before it's okay to call escapeHTML().
+ my(@result,$xml_dtd);
+ if ($dtd) {
+ if (defined(ref($dtd)) and (ref($dtd) eq 'ARRAY')) {
+ $dtd = $DEFAULT_DTD unless $dtd->[0] =~ m|^-//|;
+ } else {
+ $dtd = $DEFAULT_DTD unless $dtd =~ m|^-//|;
+ }
+ } else {
+ $dtd = $XHTML ? XHTML_DTD : $DEFAULT_DTD;
+ }
+
+ $xml_dtd++ if ref($dtd) eq 'ARRAY' && $dtd->[0] =~ /\bXHTML\b/i;
+ $xml_dtd++ if ref($dtd) eq '' && $dtd =~ /\bXHTML\b/i;
+ push @result,qq(<?xml version="1.0" encoding="$encoding"?>) if $xml_dtd && $declare_xml;
+
+ if (ref($dtd) && ref($dtd) eq 'ARRAY') {
+ push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd->[0]"\n\t "$dtd->[1]">));
+ $DTD_PUBLIC_IDENTIFIER = $dtd->[0];
+ } else {
+ push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd">));
+ $DTD_PUBLIC_IDENTIFIER = $dtd;
+ }
+
+ # Now that we know whether we're using the HTML 3.2 DTD or not, it's okay to
+ # call escapeHTML(). Strangely enough, the title needs to be escaped as
+ # HTML while the author needs to be escaped as a URL.
+ $title = $self->escapeHTML($title || 'Untitled Document');
+ $author = $self->escape($author);
+
+ if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML (2\.0|3\.2)/i) {
+ $lang = "" unless defined $lang;
+ $XHTML = 0;
+ }
+ else {
+ $lang = 'en-US' unless defined $lang;
+ }
+
+ my $lang_bits = $lang ne '' ? qq( lang="$lang" xml:lang="$lang") : '';
+ my $meta_bits = qq(<meta http-equiv="Content-Type" content="text/html; charset=$encoding" />)
+ if $XHTML && $encoding && !$declare_xml;
+
+ push(@result,$XHTML ? qq(<html xmlns="http://www.w3.org/1999/xhtml"$lang_bits>\n<head>\n<title>$title</title>)
+ : ($lang ? qq(<html lang="$lang">) : "<html>")
+ . "<head><title>$title</title>");
+ if (defined $author) {
+ push(@result,$XHTML ? "<link rev=\"made\" href=\"mailto:$author\" />"
+ : "<link rev=\"made\" href=\"mailto:$author\">");
+ }
+
+ if ($base || $xbase || $target) {
+ my $href = $xbase || $self->url('-path'=>1);
+ my $t = $target ? qq/ target="$target"/ : '';
+ push(@result,$XHTML ? qq(<base href="$href"$t />) : qq(<base href="$href"$t>));
+ }
+
+ if ($meta && ref($meta) && (ref($meta) eq 'HASH')) {
+ for (keys %$meta) { push(@result,$XHTML ? qq(<meta name="$_" content="$meta->{$_}" />)
+ : qq(<meta name="$_" content="$meta->{$_}">)); }
+ }
+
+ my $meta_bits_set = 0;
+ if( $head ) {
+ if( ref $head ) {
+ push @result, @$head;
+ $meta_bits_set = 1 if grep { /http-equiv=["']Content-Type/i }@$head;
+ }
+ else {
+ push @result, $head;
+ $meta_bits_set = 1 if $head =~ /http-equiv=["']Content-Type/i;
+ }
+ }
+
+ # handle the infrequently-used -style and -script parameters
+ push(@result,$self->_style($style)) if defined $style;
+ push(@result,$self->_script($script)) if defined $script;
+ push(@result,$meta_bits) if defined $meta_bits and !$meta_bits_set;
+
+ # handle -noscript parameter
+ push(@result,<<END) if $noscript;
+<noscript>
+$noscript
+</noscript>
+END
+ ;
+ my($other) = @other ? " @other" : '';
+ push(@result,"</head>\n<body$other>\n");
+ return join("\n", at result);
+}
+END_OF_FUNC
+
+### Method: _style
+# internal method for generating a CSS style section
+####
+'_style' => <<'END_OF_FUNC',
+sub _style {
+ my ($self,$style) = @_;
+ my (@result);
+
+ my $type = 'text/css';
+ my $rel = 'stylesheet';
+
+
+ my $cdata_start = $XHTML ? "\n<!--/* <![CDATA[ */" : "\n<!-- ";
+ my $cdata_end = $XHTML ? "\n/* ]]> */-->\n" : " -->\n";
+
+ my @s = ref($style) eq 'ARRAY' ? @$style : $style;
+ my $other = '';
+
+ for my $s (@s) {
+ if (ref($s)) {
+ my($src,$code,$verbatim,$stype,$alternate,$foo, at other) =
+ rearrange([qw(SRC CODE VERBATIM TYPE ALTERNATE FOO)],
+ ('-foo'=>'bar',
+ ref($s) eq 'ARRAY' ? @$s : %$s));
+ my $type = defined $stype ? $stype : 'text/css';
+ my $rel = $alternate ? 'alternate stylesheet' : 'stylesheet';
+ $other = "@other" if @other;
+
+ if (ref($src) eq "ARRAY") # Check to see if the $src variable is an array reference
+ { # If it is, push a LINK tag for each one
+ for $src (@$src)
+ {
+ push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>)
+ : qq(<link rel="$rel" type="$type" href="$src"$other>)) if $src;
+ }
+ }
+ else
+ { # Otherwise, push the single -src, if it exists.
+ push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>)
+ : qq(<link rel="$rel" type="$type" href="$src"$other>)
+ ) if $src;
+ }
+ if ($verbatim) {
+ my @v = ref($verbatim) eq 'ARRAY' ? @$verbatim : $verbatim;
+ push(@result, "<style type=\"text/css\">\n$_\n</style>") for @v;
+ }
+ my @c = ref($code) eq 'ARRAY' ? @$code : $code if $code;
+ push(@result,style({'type'=>$type},"$cdata_start\n$_\n$cdata_end")) for @c;
+
+ } else {
+ my $src = $s;
+ push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>)
+ : qq(<link rel="$rel" type="$type" href="$src"$other>));
+ }
+ }
+ @result;
+}
+END_OF_FUNC
+
+'_script' => <<'END_OF_FUNC',
+sub _script {
+ my ($self,$script) = @_;
+ my (@result);
+
+ my (@scripts) = ref($script) eq 'ARRAY' ? @$script : ($script);
+ for $script (@scripts) {
+ my($src,$code,$language);
+ if (ref($script)) { # script is a hash
+ ($src,$code,$type) =
+ rearrange(['SRC','CODE',['LANGUAGE','TYPE']],
+ '-foo'=>'bar', # a trick to allow the '-' to be omitted
+ ref($script) eq 'ARRAY' ? @$script : %$script);
+ $type ||= 'text/javascript';
+ unless ($type =~ m!\w+/\w+!) {
+ $type =~ s/[\d.]+$//;
+ $type = "text/$type";
+ }
+ } else {
+ ($src,$code,$type) = ('',$script, 'text/javascript');
+ }
+
+ my $comment = '//'; # javascript by default
+ $comment = '#' if $type=~/perl|tcl/i;
+ $comment = "'" if $type=~/vbscript/i;
+
+ my ($cdata_start,$cdata_end);
+ if ($XHTML) {
+ $cdata_start = "$comment<![CDATA[\n";
+ $cdata_end .= "\n$comment]]>";
+ } else {
+ $cdata_start = "\n<!-- Hide script\n";
+ $cdata_end = $comment;
+ $cdata_end .= " End script hiding -->\n";
+ }
+ my(@satts);
+ push(@satts,'src'=>$src) if $src;
+ push(@satts,'type'=>$type);
+ $code = $cdata_start . $code . $cdata_end if defined $code;
+ push(@result,$self->script({@satts},$code || ''));
+ }
+ @result;
+}
+END_OF_FUNC
+
+#### Method: end_html
+# End an HTML document.
+# Trivial method for completeness. Just returns "</body>"
+####
+'end_html' => <<'END_OF_FUNC',
+sub end_html {
+ return "\n</body>\n</html>";
+}
+END_OF_FUNC
+
+
+################################
+# METHODS USED IN BUILDING FORMS
+################################
+
+#### Method: isindex
+# Just prints out the isindex tag.
+# Parameters:
+# $action -> optional URL of script to run
+# Returns:
+# A string containing a <isindex> tag
+'isindex' => <<'END_OF_FUNC',
+sub isindex {
+ my($self, at p) = self_or_default(@_);
+ my($action, at other) = rearrange([ACTION], at p);
+ $action = qq/ action="$action"/ if $action;
+ my($other) = @other ? " @other" : '';
+ return $XHTML ? "<isindex$action$other />" : "<isindex$action$other>";
+}
+END_OF_FUNC
+
+
+#### Method: startform
+# Start a form
+# Parameters:
+# $method -> optional submission method to use (GET or POST)
+# $action -> optional URL of script to run
+# $enctype ->encoding to use (URL_ENCODED or MULTIPART)
+'startform' => <<'END_OF_FUNC',
+sub startform {
+ my($self, at p) = self_or_default(@_);
+
+ my($method,$action,$enctype, at other) =
+ rearrange([METHOD,ACTION,ENCTYPE], at p);
+
+ $method = $self->escapeHTML(lc($method || 'post'));
+ $enctype = $self->escapeHTML($enctype || &URL_ENCODED);
+ if (defined $action) {
+ $action = $self->escapeHTML($action);
+ }
+ else {
+ $action = $self->escapeHTML($self->request_uri || $self->self_url);
+ }
+ $action = qq(action="$action");
+ my($other) = @other ? " @other" : '';
+ $self->{'.parametersToAdd'}={};
+ return qq/<form method="$method" $action enctype="$enctype"$other>\n/;
+}
+END_OF_FUNC
+
+
+#### Method: start_form
+# synonym for startform
+'start_form' => <<'END_OF_FUNC',
+sub start_form {
+ $XHTML ? &start_multipart_form : &startform;
+}
+END_OF_FUNC
+
+'end_multipart_form' => <<'END_OF_FUNC',
+sub end_multipart_form {
+ &endform;
+}
+END_OF_FUNC
+
+#### Method: start_multipart_form
+# synonym for startform
+'start_multipart_form' => <<'END_OF_FUNC',
+sub start_multipart_form {
+ my($self, at p) = self_or_default(@_);
+ if (defined($p[0]) && substr($p[0],0,1) eq '-') {
+ return $self->startform(-enctype=>&MULTIPART, at p);
+ } else {
+ my($method,$action, at other) =
+ rearrange([METHOD,ACTION], at p);
+ return $self->startform($method,$action,&MULTIPART, at other);
+ }
+}
+END_OF_FUNC
+
+
+#### Method: endform
+# End a form
+'endform' => <<'END_OF_FUNC',
+sub endform {
+ my($self, at p) = self_or_default(@_);
+ if ( $NOSTICKY ) {
+ return wantarray ? ("</form>") : "\n</form>";
+ } else {
+ if (my @fields = $self->get_fields) {
+ return wantarray ? ("<div>", at fields,"</div>","</form>")
+ : "<div>".(join '', at fields)."</div>\n</form>";
+ } else {
+ return "</form>";
+ }
+ }
+}
+END_OF_FUNC
+
+
+'_textfield' => <<'END_OF_FUNC',
+sub _textfield {
+ my($self,$tag, at p) = self_or_default(@_);
+ my($name,$default,$size,$maxlength,$override,$tabindex, at other) =
+ rearrange([NAME,[DEFAULT,VALUE,VALUES],SIZE,MAXLENGTH,[OVERRIDE,FORCE],TABINDEX], at p);
+
+ my $current = $override ? $default :
+ (defined($self->param($name)) ? $self->param($name) : $default);
+
+ $current = defined($current) ? $self->escapeHTML($current,1) : '';
+ $name = defined($name) ? $self->escapeHTML($name) : '';
+ my($s) = defined($size) ? qq/ size="$size"/ : '';
+ my($m) = defined($maxlength) ? qq/ maxlength="$maxlength"/ : '';
+ my($other) = @other ? " @other" : '';
+ # this entered at cristy's request to fix problems with file upload fields
+ # and WebTV -- not sure it won't break stuff
+ my($value) = $current ne '' ? qq(value="$current") : '';
+ $tabindex = $self->element_tab($tabindex);
+ return $XHTML ? qq(<input type="$tag" name="$name" $tabindex$value$s$m$other />)
+ : qq(<input type="$tag" name="$name" $value$s$m$other>);
+}
+END_OF_FUNC
+
+#### Method: textfield
+# Parameters:
+# $name -> Name of the text field
+# $default -> Optional default value of the field if not
+# already defined.
+# $size -> Optional width of field in characaters.
+# $maxlength -> Optional maximum number of characters.
+# Returns:
+# A string containing a <input type="text"> field
+#
+'textfield' => <<'END_OF_FUNC',
+sub textfield {
+ my($self, at p) = self_or_default(@_);
+ $self->_textfield('text', at p);
+}
+END_OF_FUNC
+
+
+#### Method: filefield
+# Parameters:
+# $name -> Name of the file upload field
+# $size -> Optional width of field in characaters.
+# $maxlength -> Optional maximum number of characters.
+# Returns:
+# A string containing a <input type="file"> field
+#
+'filefield' => <<'END_OF_FUNC',
+sub filefield {
+ my($self, at p) = self_or_default(@_);
+ $self->_textfield('file', at p);
+}
+END_OF_FUNC
+
+
+#### Method: password
+# Create a "secret password" entry field
+# Parameters:
+# $name -> Name of the field
+# $default -> Optional default value of the field if not
+# already defined.
+# $size -> Optional width of field in characters.
+# $maxlength -> Optional maximum characters that can be entered.
+# Returns:
+# A string containing a <input type="password"> field
+#
+'password_field' => <<'END_OF_FUNC',
+sub password_field {
+ my ($self, at p) = self_or_default(@_);
+ $self->_textfield('password', at p);
+}
+END_OF_FUNC
+
+#### Method: textarea
+# Parameters:
+# $name -> Name of the text field
+# $default -> Optional default value of the field if not
+# already defined.
+# $rows -> Optional number of rows in text area
+# $columns -> Optional number of columns in text area
+# Returns:
+# A string containing a <textarea></textarea> tag
+#
+'textarea' => <<'END_OF_FUNC',
+sub textarea {
+ my($self, at p) = self_or_default(@_);
+ my($name,$default,$rows,$cols,$override,$tabindex, at other) =
+ rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE],TABINDEX], at p);
+
+ my($current)= $override ? $default :
+ (defined($self->param($name)) ? $self->param($name) : $default);
+
+ $name = defined($name) ? $self->escapeHTML($name) : '';
+ $current = defined($current) ? $self->escapeHTML($current) : '';
+ my($r) = $rows ? qq/ rows="$rows"/ : '';
+ my($c) = $cols ? qq/ cols="$cols"/ : '';
+ my($other) = @other ? " @other" : '';
+ $tabindex = $self->element_tab($tabindex);
+ return qq{<textarea name="$name" $tabindex$r$c$other>$current</textarea>};
+}
+END_OF_FUNC
+
+
+#### Method: button
+# Create a javascript button.
+# Parameters:
+# $name -> (optional) Name for the button. (-name)
+# $value -> (optional) Value of the button when selected (and visible name) (-value)
+# $onclick -> (optional) Text of the JavaScript to run when the button is
+# clicked.
+# Returns:
+# A string containing a <input type="button"> tag
+####
+'button' => <<'END_OF_FUNC',
+sub button {
+ my($self, at p) = self_or_default(@_);
+
+ my($label,$value,$script,$tabindex, at other) = rearrange([NAME,[VALUE,LABEL],
+ [ONCLICK,SCRIPT],TABINDEX], at p);
+
+ $label=$self->escapeHTML($label);
+ $value=$self->escapeHTML($value,1);
+ $script=$self->escapeHTML($script);
+
+ my($name) = '';
+ $name = qq/ name="$label"/ if $label;
+ $value = $value || $label;
+ my($val) = '';
+ $val = qq/ value="$value"/ if $value;
+ $script = qq/ onclick="$script"/ if $script;
+ my($other) = @other ? " @other" : '';
+ $tabindex = $self->element_tab($tabindex);
+ return $XHTML ? qq(<input type="button" $tabindex$name$val$script$other />)
+ : qq(<input type="button"$name$val$script$other>);
+}
+END_OF_FUNC
+
+
+#### Method: submit
+# Create a "submit query" button.
+# Parameters:
+# $name -> (optional) Name for the button.
+# $value -> (optional) Value of the button when selected (also doubles as label).
+# $label -> (optional) Label printed on the button(also doubles as the value).
+# Returns:
+# A string containing a <input type="submit"> tag
+####
+'submit' => <<'END_OF_FUNC',
+sub submit {
+ my($self, at p) = self_or_default(@_);
+
+ my($label,$value,$tabindex, at other) = rearrange([NAME,[VALUE,LABEL],TABINDEX], at p);
+
+ $label=$self->escapeHTML($label);
+ $value=$self->escapeHTML($value,1);
+
+ my $name = $NOSTICKY ? '' : 'name=".submit" ';
+ $name = qq/name="$label" / if defined($label);
+ $value = defined($value) ? $value : $label;
+ my $val = '';
+ $val = qq/value="$value" / if defined($value);
+ $tabindex = $self->element_tab($tabindex);
+ my($other) = @other ? "@other " : '';
+ return $XHTML ? qq(<input type="submit" $tabindex$name$val$other/>)
+ : qq(<input type="submit" $name$val$other>);
+}
+END_OF_FUNC
+
+
+#### Method: reset
+# Create a "reset" button.
+# Parameters:
+# $name -> (optional) Name for the button.
+# Returns:
+# A string containing a <input type="reset"> tag
+####
+'reset' => <<'END_OF_FUNC',
+sub reset {
+ my($self, at p) = self_or_default(@_);
+ my($label,$value,$tabindex, at other) = rearrange(['NAME',['VALUE','LABEL'],TABINDEX], at p);
+ $label=$self->escapeHTML($label);
+ $value=$self->escapeHTML($value,1);
+ my ($name) = ' name=".reset"';
+ $name = qq/ name="$label"/ if defined($label);
+ $value = defined($value) ? $value : $label;
+ my($val) = '';
+ $val = qq/ value="$value"/ if defined($value);
+ my($other) = @other ? " @other" : '';
+ $tabindex = $self->element_tab($tabindex);
+ return $XHTML ? qq(<input type="reset" $tabindex$name$val$other />)
+ : qq(<input type="reset"$name$val$other>);
+}
+END_OF_FUNC
+
+
+#### Method: defaults
+# Create a "defaults" button.
+# Parameters:
+# $name -> (optional) Name for the button.
+# Returns:
+# A string containing a <input type="submit" name=".defaults"> tag
+#
+# Note: this button has a special meaning to the initialization script,
+# and tells it to ERASE the current query string so that your defaults
+# are used again!
+####
+'defaults' => <<'END_OF_FUNC',
+sub defaults {
+ my($self, at p) = self_or_default(@_);
+
+ my($label,$tabindex, at other) = rearrange([[NAME,VALUE],TABINDEX], at p);
+
+ $label=$self->escapeHTML($label,1);
+ $label = $label || "Defaults";
+ my($value) = qq/ value="$label"/;
+ my($other) = @other ? " @other" : '';
+ $tabindex = $self->element_tab($tabindex);
+ return $XHTML ? qq(<input type="submit" name=".defaults" $tabindex$value$other />)
+ : qq/<input type="submit" NAME=".defaults"$value$other>/;
+}
+END_OF_FUNC
+
+
+#### Method: comment
+# Create an HTML <!-- comment -->
+# Parameters: a string
+'comment' => <<'END_OF_FUNC',
+sub comment {
+ my($self, at p) = self_or_CGI(@_);
+ return "<!-- @p -->";
+}
+END_OF_FUNC
+
+#### Method: checkbox
+# Create a checkbox that is not logically linked to any others.
+# The field value is "on" when the button is checked.
+# Parameters:
+# $name -> Name of the checkbox
+# $checked -> (optional) turned on by default if true
+# $value -> (optional) value of the checkbox, 'on' by default
+# $label -> (optional) a user-readable label printed next to the box.
+# Otherwise the checkbox name is used.
+# Returns:
+# A string containing a <input type="checkbox"> field
+####
+'checkbox' => <<'END_OF_FUNC',
+sub checkbox {
+ my($self, at p) = self_or_default(@_);
+
+ my($name,$checked,$value,$label,$labelattributes,$override,$tabindex, at other) =
+ rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,LABELATTRIBUTES,
+ [OVERRIDE,FORCE],TABINDEX], at p);
+
+ $value = defined $value ? $value : 'on';
+
+ if (!$override && ($self->{'.fieldnames'}->{$name} ||
+ defined $self->param($name))) {
+ $checked = grep($_ eq $value,$self->param($name)) ? $self->_checked(1) : '';
+ } else {
+ $checked = $self->_checked($checked);
+ }
+ my($the_label) = defined $label ? $label : $name;
+ $name = $self->escapeHTML($name);
+ $value = $self->escapeHTML($value,1);
+ $the_label = $self->escapeHTML($the_label);
+ my($other) = @other ? "@other " : '';
+ $tabindex = $self->element_tab($tabindex);
+ $self->register_parameter($name);
+ return $XHTML ? CGI::label($labelattributes,
+ qq{<input type="checkbox" name="$name" value="$value" $tabindex$checked$other/>$the_label})
+ : qq{<input type="checkbox" name="$name" value="$value"$checked$other>$the_label};
+}
+END_OF_FUNC
+
+
+
+# Escape HTML -- used internally
+'escapeHTML' => <<'END_OF_FUNC',
+sub escapeHTML {
+ # hack to work around earlier hacks
+ push @_,$_[0] if @_==1 && $_[0] eq 'CGI';
+ my ($self,$toencode,$newlinestoo) = CGI::self_or_default(@_);
+ return undef unless defined($toencode);
+ return $toencode if ref($self) && !$self->{'escape'};
+ $toencode =~ s{&}{&}gso;
+ $toencode =~ s{<}{<}gso;
+ $toencode =~ s{>}{>}gso;
+ if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML 3\.2/i) {
+ # $quot; was accidentally omitted from the HTML 3.2 DTD -- see
+ # <http://validator.w3.org/docs/errors.html#bad-entity> /
+ # <http://lists.w3.org/Archives/Public/www-html/1997Mar/0003.html>.
+ $toencode =~ s{"}{"}gso;
+ }
+ else {
+ $toencode =~ s{"}{"}gso;
+ }
+ # Handle bug in some browsers with Latin charsets
+ if ($self->{'.charset'} &&
+ (uc($self->{'.charset'}) eq 'ISO-8859-1' ||
+ uc($self->{'.charset'}) eq 'WINDOWS-1252'))
+ {
+ $toencode =~ s{'}{'}gso;
+ $toencode =~ s{\x8b}{‹}gso;
+ $toencode =~ s{\x9b}{›}gso;
+ if (defined $newlinestoo && $newlinestoo) {
+ $toencode =~ s{\012}{
}gso;
+ $toencode =~ s{\015}{
}gso;
+ }
+ }
+ return $toencode;
+}
+END_OF_FUNC
+
+# unescape HTML -- used internally
+'unescapeHTML' => <<'END_OF_FUNC',
+sub unescapeHTML {
+ # hack to work around earlier hacks
+ push @_,$_[0] if @_==1 && $_[0] eq 'CGI';
+ my ($self,$string) = CGI::self_or_default(@_);
+ return undef unless defined($string);
+ my $latin = defined $self->{'.charset'} ? $self->{'.charset'} =~ /^(ISO-8859-1|WINDOWS-1252)$/i
+ : 1;
+ # thanks to Randal Schwartz for the correct solution to this one
+ $string=~ s[&(.*?);]{
+ local $_ = $1;
+ /^amp$/i ? "&" :
+ /^quot$/i ? '"' :
+ /^gt$/i ? ">" :
+ /^lt$/i ? "<" :
+ /^#(\d+)$/ && $latin ? chr($1) :
+ /^#x([0-9a-f]+)$/i && $latin ? chr(hex($1)) :
+ $_
+ }gex;
+ return $string;
+}
+END_OF_FUNC
+
+# Internal procedure - don't use
+'_tableize' => <<'END_OF_FUNC',
+sub _tableize {
+ my($rows,$columns,$rowheaders,$colheaders, at elements) = @_;
+ my @rowheaders = $rowheaders ? @$rowheaders : ();
+ my @colheaders = $colheaders ? @$colheaders : ();
+ my($result);
+
+ if (defined($columns)) {
+ $rows = int(0.99 + @elements/$columns) unless defined($rows);
+ }
+ if (defined($rows)) {
+ $columns = int(0.99 + @elements/$rows) unless defined($columns);
+ }
+
+ # rearrange into a pretty table
+ $result = "<table>";
+ my($row,$column);
+ unshift(@colheaders,'') if @colheaders && @rowheaders;
+ $result .= "<tr>" if @colheaders;
+ for (@colheaders) {
+ $result .= "<th>$_</th>";
+ }
+ for ($row=0;$row<$rows;$row++) {
+ $result .= "<tr>";
+ $result .= "<th>$rowheaders[$row]</th>" if @rowheaders;
+ for ($column=0;$column<$columns;$column++) {
+ $result .= "<td>" . $elements[$column*$rows + $row] . "</td>"
+ if defined($elements[$column*$rows + $row]);
+ }
+ $result .= "</tr>";
+ }
+ $result .= "</table>";
+ return $result;
+}
+END_OF_FUNC
+
+
+#### Method: radio_group
+# Create a list of logically-linked radio buttons.
+# Parameters:
+# $name -> Common name for all the buttons.
+# $values -> A pointer to a regular array containing the
+# values for each button in the group.
+# $default -> (optional) Value of the button to turn on by default. Pass '-'
+# to turn _nothing_ on.
+# $linebreak -> (optional) Set to true to place linebreaks
+# between the buttons.
+# $labels -> (optional)
+# A pointer to a hash of labels to print next to each checkbox
+# in the form $label{'value'}="Long explanatory label".
+# Otherwise the provided values are used as the labels.
+# Returns:
+# An ARRAY containing a series of <input type="radio"> fields
+####
+'radio_group' => <<'END_OF_FUNC',
+sub radio_group {
+ my($self, at p) = self_or_default(@_);
+ $self->_box_group('radio', at p);
+}
+END_OF_FUNC
+
+#### Method: checkbox_group
+# Create a list of logically-linked checkboxes.
+# Parameters:
+# $name -> Common name for all the check boxes
+# $values -> A pointer to a regular array containing the
+# values for each checkbox in the group.
+# $defaults -> (optional)
+# 1. If a pointer to a regular array of checkbox values,
+# then this will be used to decide which
+# checkboxes to turn on by default.
+# 2. If a scalar, will be assumed to hold the
+# value of a single checkbox in the group to turn on.
+# $linebreak -> (optional) Set to true to place linebreaks
+# between the buttons.
+# $labels -> (optional)
+# A pointer to a hash of labels to print next to each checkbox
+# in the form $label{'value'}="Long explanatory label".
+# Otherwise the provided values are used as the labels.
+# Returns:
+# An ARRAY containing a series of <input type="checkbox"> fields
+####
+
+'checkbox_group' => <<'END_OF_FUNC',
+sub checkbox_group {
+ my($self, at p) = self_or_default(@_);
+ $self->_box_group('checkbox', at p);
+}
+END_OF_FUNC
+
+'_box_group' => <<'END_OF_FUNC',
+sub _box_group {
+ my $self = shift;
+ my $box_type = shift;
+
+ my($name,$values,$defaults,$linebreak,$labels,$labelattributes,
+ $attributes,$rows,$columns,$rowheaders,$colheaders,
+ $override,$nolabels,$tabindex,$disabled, at other) =
+ rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LINEBREAK,LABELS,LABELATTRIBUTES,
+ ATTRIBUTES,ROWS,[COLUMNS,COLS],[ROWHEADERS,ROWHEADER],[COLHEADERS,COLHEADER],
+ [OVERRIDE,FORCE],NOLABELS,TABINDEX,DISABLED
+ ], at _);
+
+
+ my($result,$checked, at elements, at values);
+
+ @values = $self->_set_values_and_labels($values,\$labels,$name);
+ my %checked = $self->previous_or_default($name,$defaults,$override);
+
+ # If no check array is specified, check the first by default
+ $checked{$values[0]}++ if $box_type eq 'radio' && !%checked;
+
+ $name=$self->escapeHTML($name);
+
+ my %tabs = ();
+ if ($TABINDEX && $tabindex) {
+ if (!ref $tabindex) {
+ $self->element_tab($tabindex);
+ } elsif (ref $tabindex eq 'ARRAY') {
+ %tabs = map {$_=>$self->element_tab} @$tabindex;
+ } elsif (ref $tabindex eq 'HASH') {
+ %tabs = %$tabindex;
+ }
+ }
+ %tabs = map {$_=>$self->element_tab} @values unless %tabs;
+ my $other = @other ? "@other " : '';
+ my $radio_checked;
+
+ # for disabling groups of radio/checkbox buttons
+ my %disabled;
+ for (@{$disabled}) {
+ $disabled{$_}=1;
+ }
+
+ for (@values) {
+ my $disable="";
+ if ($disabled{$_}) {
+ $disable="disabled='1'";
+ }
+
+ my $checkit = $self->_checked($box_type eq 'radio' ? ($checked{$_} && !$radio_checked++)
+ : $checked{$_});
+ my($break);
+ if ($linebreak) {
+ $break = $XHTML ? "<br />" : "<br>";
+ }
+ else {
+ $break = '';
+ }
+ my($label)='';
+ unless (defined($nolabels) && $nolabels) {
+ $label = $_;
+ $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
+ $label = $self->escapeHTML($label,1);
+ $label = "<span style=\"color:gray\">$label</span>" if $disabled{$_};
+ }
+ my $attribs = $self->_set_attributes($_, $attributes);
+ my $tab = $tabs{$_};
+ $_=$self->escapeHTML($_);
+
+ if ($XHTML) {
+ push @elements,
+ CGI::label($labelattributes,
+ qq(<input type="$box_type" name="$name" value="$_" $checkit$other$tab$attribs$disable/>$label)).${break};
+ } else {
+ push(@elements,qq/<input type="$box_type" name="$name" value="$_"$checkit$other$tab$attribs$disable>${label}${break}/);
+ }
+ }
+ $self->register_parameter($name);
+ return wantarray ? @elements : "@elements"
+ unless defined($columns) || defined($rows);
+ return _tableize($rows,$columns,$rowheaders,$colheaders, at elements);
+}
+END_OF_FUNC
+
+
+#### Method: popup_menu
+# Create a popup menu.
+# Parameters:
+# $name -> Name for all the menu
+# $values -> A pointer to a regular array containing the
+# text of each menu item.
+# $default -> (optional) Default item to display
+# $labels -> (optional)
+# A pointer to a hash of labels to print next to each checkbox
+# in the form $label{'value'}="Long explanatory label".
+# Otherwise the provided values are used as the labels.
+# Returns:
+# A string containing the definition of a popup menu.
+####
+'popup_menu' => <<'END_OF_FUNC',
+sub popup_menu {
+ my($self, at p) = self_or_default(@_);
+
+ my($name,$values,$default,$labels,$attributes,$override,$tabindex, at other) =
+ rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,
+ ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX], at p);
+ my($result,%selected);
+
+ if (!$override && defined($self->param($name))) {
+ $selected{$self->param($name)}++;
+ } elsif (defined $default) {
+ %selected = map {$_=>1} ref($default) eq 'ARRAY'
+ ? @$default
+ : $default;
+ }
+ $name=$self->escapeHTML($name);
+ my($other) = @other ? " @other" : '';
+
+ my(@values);
+ @values = $self->_set_values_and_labels($values,\$labels,$name);
+ $tabindex = $self->element_tab($tabindex);
+ $result = qq/<select name="$name" $tabindex$other>\n/;
+ for (@values) {
+ if (/<optgroup/) {
+ for my $v (split(/\n/)) {
+ my $selectit = $XHTML ? 'selected="selected"' : 'selected';
+ for my $selected (keys %selected) {
+ $v =~ s/(value="$selected")/$selectit $1/;
+ }
+ $result .= "$v\n";
+ }
+ }
+ else {
+ my $attribs = $self->_set_attributes($_, $attributes);
+ my($selectit) = $self->_selected($selected{$_});
+ my($label) = $_;
+ $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
+ my($value) = $self->escapeHTML($_);
+ $label = $self->escapeHTML($label,1);
+ $result .= "<option${attribs} ${selectit}value=\"$value\">$label</option>\n";
+ }
+ }
+
+ $result .= "</select>";
+ return $result;
+}
+END_OF_FUNC
+
+
+#### Method: optgroup
+# Create a optgroup.
+# Parameters:
+# $name -> Label for the group
+# $values -> A pointer to a regular array containing the
+# values for each option line in the group.
+# $labels -> (optional)
+# A pointer to a hash of labels to print next to each item
+# in the form $label{'value'}="Long explanatory label".
+# Otherwise the provided values are used as the labels.
+# $labeled -> (optional)
+# A true value indicates the value should be used as the label attribute
+# in the option elements.
+# The label attribute specifies the option label presented to the user.
+# This defaults to the content of the <option> element, but the label
+# attribute allows authors to more easily use optgroup without sacrificing
+# compatibility with browsers that do not support option groups.
+# $novals -> (optional)
+# A true value indicates to suppress the val attribute in the option elements
+# Returns:
+# A string containing the definition of an option group.
+####
+'optgroup' => <<'END_OF_FUNC',
+sub optgroup {
+ my($self, at p) = self_or_default(@_);
+ my($name,$values,$attributes,$labeled,$noval,$labels, at other)
+ = rearrange([NAME,[VALUES,VALUE],ATTRIBUTES,LABELED,NOVALS,LABELS], at p);
+
+ my($result, at values);
+ @values = $self->_set_values_and_labels($values,\$labels,$name,$labeled,$novals);
+ my($other) = @other ? " @other" : '';
+
+ $name=$self->escapeHTML($name);
+ $result = qq/<optgroup label="$name"$other>\n/;
+ for (@values) {
+ if (/<optgroup/) {
+ for (split(/\n/)) {
+ my $selectit = $XHTML ? 'selected="selected"' : 'selected';
+ s/(value="$selected")/$selectit $1/ if defined $selected;
+ $result .= "$_\n";
+ }
+ }
+ else {
+ my $attribs = $self->_set_attributes($_, $attributes);
+ my($label) = $_;
+ $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
+ $label=$self->escapeHTML($label);
+ my($value)=$self->escapeHTML($_,1);
+ $result .= $labeled ? $novals ? "<option$attribs label=\"$value\">$label</option>\n"
+ : "<option$attribs label=\"$value\" value=\"$value\">$label</option>\n"
+ : $novals ? "<option$attribs>$label</option>\n"
+ : "<option$attribs value=\"$value\">$label</option>\n";
+ }
+ }
+ $result .= "</optgroup>";
+ return $result;
+}
+END_OF_FUNC
+
+
+#### Method: scrolling_list
+# Create a scrolling list.
+# Parameters:
+# $name -> name for the list
+# $values -> A pointer to a regular array containing the
+# values for each option line in the list.
+# $defaults -> (optional)
+# 1. If a pointer to a regular array of options,
+# then this will be used to decide which
+# lines to turn on by default.
+# 2. Otherwise holds the value of the single line to turn on.
+# $size -> (optional) Size of the list.
+# $multiple -> (optional) If set, allow multiple selections.
+# $labels -> (optional)
+# A pointer to a hash of labels to print next to each checkbox
+# in the form $label{'value'}="Long explanatory label".
+# Otherwise the provided values are used as the labels.
+# Returns:
+# A string containing the definition of a scrolling list.
+####
+'scrolling_list' => <<'END_OF_FUNC',
+sub scrolling_list {
+ my($self, at p) = self_or_default(@_);
+ my($name,$values,$defaults,$size,$multiple,$labels,$attributes,$override,$tabindex, at other)
+ = rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
+ SIZE,MULTIPLE,LABELS,ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX], at p);
+
+ my($result, at values);
+ @values = $self->_set_values_and_labels($values,\$labels,$name);
+
+ $size = $size || scalar(@values);
+
+ my(%selected) = $self->previous_or_default($name,$defaults,$override);
+
+ my($is_multiple) = $multiple ? qq/ multiple="multiple"/ : '';
+ my($has_size) = $size ? qq/ size="$size"/: '';
+ my($other) = @other ? " @other" : '';
+
+ $name=$self->escapeHTML($name);
+ $tabindex = $self->element_tab($tabindex);
+ $result = qq/<select name="$name" $tabindex$has_size$is_multiple$other>\n/;
+ for (@values) {
+ my($selectit) = $self->_selected($selected{$_});
+ my($label) = $_;
+ $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
+ $label=$self->escapeHTML($label);
+ my($value)=$self->escapeHTML($_,1);
+ my $attribs = $self->_set_attributes($_, $attributes);
+ $result .= "<option ${selectit}${attribs}value=\"$value\">$label</option>\n";
+ }
+ $result .= "</select>";
+ $self->register_parameter($name);
+ return $result;
+}
+END_OF_FUNC
+
+
+#### Method: hidden
+# Parameters:
+# $name -> Name of the hidden field
+# @default -> (optional) Initial values of field (may be an array)
+# or
+# $default->[initial values of field]
+# Returns:
+# A string containing a <input type="hidden" name="name" value="value">
+####
+'hidden' => <<'END_OF_FUNC',
+sub hidden {
+ my($self, at p) = self_or_default(@_);
+
+ # this is the one place where we departed from our standard
+ # calling scheme, so we have to special-case (darn)
+ my(@result, at value);
+ my($name,$default,$override, at other) =
+ rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]], at p);
+
+ my $do_override = 0;
+ if ( ref($p[0]) || substr($p[0],0,1) eq '-') {
+ @value = ref($default) ? @{$default} : $default;
+ $do_override = $override;
+ } else {
+ for ($default,$override, at other) {
+ push(@value,$_) if defined($_);
+ }
+ }
+
+ # use previous values if override is not set
+ my @prev = $self->param($name);
+ @value = @prev if !$do_override && @prev;
+
+ $name=$self->escapeHTML($name);
+ for (@value) {
+ $_ = defined($_) ? $self->escapeHTML($_,1) : '';
+ push @result,$XHTML ? qq(<input type="hidden" name="$name" value="$_" @other />)
+ : qq(<input type="hidden" name="$name" value="$_" @other>);
+ }
+ return wantarray ? @result : join('', at result);
+}
+END_OF_FUNC
+
+
+#### Method: image_button
+# Parameters:
+# $name -> Name of the button
+# $src -> URL of the image source
+# $align -> Alignment style (TOP, BOTTOM or MIDDLE)
+# Returns:
+# A string containing a <input type="image" name="name" src="url" align="alignment">
+####
+'image_button' => <<'END_OF_FUNC',
+sub image_button {
+ my($self, at p) = self_or_default(@_);
+
+ my($name,$src,$alignment, at other) =
+ rearrange([NAME,SRC,ALIGN], at p);
+
+ my($align) = $alignment ? " align=\L\"$alignment\"" : '';
+ my($other) = @other ? " @other" : '';
+ $name=$self->escapeHTML($name);
+ return $XHTML ? qq(<input type="image" name="$name" src="$src"$align$other />)
+ : qq/<input type="image" name="$name" src="$src"$align$other>/;
+}
+END_OF_FUNC
+
+
+#### Method: self_url
+# Returns a URL containing the current script and all its
+# param/value pairs arranged as a query. You can use this
+# to create a link that, when selected, will reinvoke the
+# script with all its state information preserved.
+####
+'self_url' => <<'END_OF_FUNC',
+sub self_url {
+ my($self, at p) = self_or_default(@_);
+ return $self->url('-path_info'=>1,'-query'=>1,'-full'=>1, at p);
+}
+END_OF_FUNC
+
+
+# This is provided as a synonym to self_url() for people unfortunate
+# enough to have incorporated it into their programs already!
+'state' => <<'END_OF_FUNC',
+sub state {
+ &self_url;
+}
+END_OF_FUNC
+
+
+#### Method: url
+# Like self_url, but doesn't return the query string part of
+# the URL.
+####
+'url' => <<'END_OF_FUNC',
+sub url {
+ my($self, at p) = self_or_default(@_);
+ my ($relative,$absolute,$full,$path_info,$query,$base,$rewrite) =
+ rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING'],'BASE','REWRITE'], at p);
+ my $url = '';
+ $full++ if $base || !($relative || $absolute);
+ $rewrite++ unless defined $rewrite;
+
+ my $path = $self->path_info;
+ my $script_name = $self->script_name;
+ my $request_uri = unescape($self->request_uri) || '';
+ my $query_str = $self->query_string;
+
+ my $rewrite_in_use = $request_uri && $request_uri !~ /^\Q$script_name/;
+ undef $path if $rewrite_in_use && $rewrite; # path not valid when rewriting active
+
+ my $uri = $rewrite && $request_uri ? $request_uri : $script_name;
+ $uri =~ s/\?.*$//s; # remove query string
+ $uri =~ s/\Q$ENV{PATH_INFO}\E$// if defined $ENV{PATH_INFO};
+# $uri =~ s/\Q$path\E$// if defined $path; # remove path
+
+ if ($full) {
+ my $protocol = $self->protocol();
+ $url = "$protocol://";
+ my $vh = http('x_forwarded_host') || http('host') || '';
+ $vh =~ s/\:\d+$//; # some clients add the port number (incorrectly). Get rid of it.
+ if ($vh) {
+ $url .= $vh;
+ } else {
+ $url .= server_name();
+ }
+ my $port = $self->server_port;
+ $url .= ":" . $port
+ unless (lc($protocol) eq 'http' && $port == 80)
+ || (lc($protocol) eq 'https' && $port == 443);
+ return $url if $base;
+ $url .= $uri;
+ } elsif ($relative) {
+ ($url) = $uri =~ m!([^/]+)$!;
+ } elsif ($absolute) {
+ $url = $uri;
+ }
+
+ $url .= $path if $path_info and defined $path;
+ $url .= "?$query_str" if $query and $query_str ne '';
+ $url ||= '';
+ $url =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/sprintf("%%%02X",ord($1))/eg;
+ return $url;
+}
+
+END_OF_FUNC
+
+#### Method: cookie
+# Set or read a cookie from the specified name.
+# Cookie can then be passed to header().
+# Usual rules apply to the stickiness of -value.
+# Parameters:
+# -name -> name for this cookie (optional)
+# -value -> value of this cookie (scalar, array or hash)
+# -path -> paths for which this cookie is valid (optional)
+# -domain -> internet domain in which this cookie is valid (optional)
+# -secure -> if true, cookie only passed through secure channel (optional)
+# -expires -> expiry date in format Wdy, DD-Mon-YYYY HH:MM:SS GMT (optional)
+####
+'cookie' => <<'END_OF_FUNC',
+sub cookie {
+ my($self, at p) = self_or_default(@_);
+ my($name,$value,$path,$domain,$secure,$expires,$httponly) =
+ rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES,HTTPONLY], at p);
+
+ require CGI::Cookie;
+
+ # if no value is supplied, then we retrieve the
+ # value of the cookie, if any. For efficiency, we cache the parsed
+ # cookies in our state variables.
+ unless ( defined($value) ) {
+ $self->{'.cookies'} = CGI::Cookie->fetch
+ unless $self->{'.cookies'};
+
+ # If no name is supplied, then retrieve the names of all our cookies.
+ return () unless $self->{'.cookies'};
+ return keys %{$self->{'.cookies'}} unless $name;
+ return () unless $self->{'.cookies'}->{$name};
+ return $self->{'.cookies'}->{$name}->value if defined($name) && $name ne '';
+ }
+
+ # If we get here, we're creating a new cookie
+ return undef unless defined($name) && $name ne ''; # this is an error
+
+ my @param;
+ push(@param,'-name'=>$name);
+ push(@param,'-value'=>$value);
+ push(@param,'-domain'=>$domain) if $domain;
+ push(@param,'-path'=>$path) if $path;
+ push(@param,'-expires'=>$expires) if $expires;
+ push(@param,'-secure'=>$secure) if $secure;
+ push(@param,'-httponly'=>$httponly) if $httponly;
+
+ return new CGI::Cookie(@param);
+}
+END_OF_FUNC
+
+'parse_keywordlist' => <<'END_OF_FUNC',
+sub parse_keywordlist {
+ my($self,$tosplit) = @_;
+ $tosplit = unescape($tosplit); # unescape the keywords
+ $tosplit=~tr/+/ /; # pluses to spaces
+ my(@keywords) = split(/\s+/,$tosplit);
+ return @keywords;
+}
+END_OF_FUNC
+
+'param_fetch' => <<'END_OF_FUNC',
+sub param_fetch {
+ my($self, at p) = self_or_default(@_);
+ my($name) = rearrange([NAME], at p);
+ unless (exists($self->{param}{$name})) {
+ $self->add_parameter($name);
+ $self->{param}{$name} = [];
+ }
+
+ return $self->{param}{$name};
+}
+END_OF_FUNC
+
+###############################################
+# OTHER INFORMATION PROVIDED BY THE ENVIRONMENT
+###############################################
+
+#### Method: path_info
+# Return the extra virtual path information provided
+# after the URL (if any)
+####
+'path_info' => <<'END_OF_FUNC',
+sub path_info {
+ my ($self,$info) = self_or_default(@_);
+ if (defined($info)) {
+ $info = "/$info" if $info ne '' && substr($info,0,1) ne '/';
+ $self->{'.path_info'} = $info;
+ } elsif (! defined($self->{'.path_info'}) ) {
+ my (undef,$path_info) = $self->_name_and_path_from_env;
+ $self->{'.path_info'} = $path_info || '';
+ }
+ return $self->{'.path_info'};
+}
+END_OF_FUNC
+
+# This function returns a potentially modified version of SCRIPT_NAME
+# and PATH_INFO. Some HTTP servers do sanitise the paths in those
+# variables. It is the case of at least Apache 2. If for instance the
+# user requests: /path/./to/script.cgi/x//y/z/../x?y, Apache will set:
+# REQUEST_URI=/path/./to/script.cgi/x//y/z/../x?y
+# SCRIPT_NAME=/path/to/env.cgi
+# PATH_INFO=/x/y/x
+#
+# This is all fine except that some bogus CGI scripts expect
+# PATH_INFO=/http://foo when the user requests
+# http://xxx/script.cgi/http://foo
+#
+# Old versions of this module used to accomodate with those scripts, so
+# this is why we do this here to keep those scripts backward compatible.
+# Basically, we accomodate with those scripts but within limits, that is
+# we only try to preserve the number of / that were provided by the user
+# if $REQUEST_URI and "$SCRIPT_NAME$PATH_INFO" only differ by the number
+# of consecutive /.
+#
+# So for instance, in: http://foo/x//y/script.cgi/a//b, we'll return a
+# script_name of /x//y/script.cgi and a path_info of /a//b, but in:
+# http://foo/./x//z/script.cgi/a/../b//c, we'll return the versions
+# possibly sanitised by the HTTP server, so in the case of Apache 2:
+# script_name == /foo/x/z/script.cgi and path_info == /b/c.
+#
+# Future versions of this module may no longer do that, so one should
+# avoid relying on the browser, proxy, server, and CGI.pm preserving the
+# number of consecutive slashes as no guarantee can be made there.
+'_name_and_path_from_env' => <<'END_OF_FUNC',
+sub _name_and_path_from_env {
+ my $self = shift;
+ my $script_name = $ENV{SCRIPT_NAME} || '';
+ my $path_info = $ENV{PATH_INFO} || '';
+ my $uri = $self->request_uri || '';
+
+ $uri =~ s/\?.*//s;
+ $uri = unescape($uri);
+
+ if ($uri ne "$script_name$path_info") {
+ my $script_name_pattern = quotemeta($script_name);
+ my $path_info_pattern = quotemeta($path_info);
+ $script_name_pattern =~ s{(?:\\/)+}{/+}g;
+ $path_info_pattern =~ s{(?:\\/)+}{/+}g;
+
+ if ($uri =~ /^($script_name_pattern)($path_info_pattern)$/s) {
+ # REQUEST_URI and SCRIPT_NAME . PATH_INFO only differ by the
+ # numer of consecutive slashes, so we can extract the info from
+ # REQUEST_URI:
+ ($script_name, $path_info) = ($1, $2);
+ }
+ }
+ return ($script_name,$path_info);
+}
+END_OF_FUNC
+
+
+#### Method: request_method
+# Returns 'POST', 'GET', 'PUT' or 'HEAD'
+####
+'request_method' => <<'END_OF_FUNC',
+sub request_method {
+ return $ENV{'REQUEST_METHOD'};
+}
+END_OF_FUNC
+
+#### Method: content_type
+# Returns the content_type string
+####
+'content_type' => <<'END_OF_FUNC',
+sub content_type {
+ return $ENV{'CONTENT_TYPE'};
+}
+END_OF_FUNC
+
+#### Method: path_translated
+# Return the physical path information provided
+# by the URL (if any)
+####
+'path_translated' => <<'END_OF_FUNC',
+sub path_translated {
+ return $ENV{'PATH_TRANSLATED'};
+}
+END_OF_FUNC
+
+
+#### Method: request_uri
+# Return the literal request URI
+####
+'request_uri' => <<'END_OF_FUNC',
+sub request_uri {
+ return $ENV{'REQUEST_URI'};
+}
+END_OF_FUNC
+
+
+#### Method: query_string
+# Synthesize a query string from our current
+# parameters
+####
+'query_string' => <<'END_OF_FUNC',
+sub query_string {
+ my($self) = self_or_default(@_);
+ my($param,$value, at pairs);
+ for $param ($self->param) {
+ my($eparam) = escape($param);
+ for $value ($self->param($param)) {
+ $value = escape($value);
+ next unless defined $value;
+ push(@pairs,"$eparam=$value");
+ }
+ }
+ for (keys %{$self->{'.fieldnames'}}) {
+ push(@pairs,".cgifields=".escape("$_"));
+ }
+ return join($USE_PARAM_SEMICOLONS ? ';' : '&', at pairs);
+}
+END_OF_FUNC
+
+
+#### Method: accept
+# Without parameters, returns an array of the
+# MIME types the browser accepts.
+# With a single parameter equal to a MIME
+# type, will return undef if the browser won't
+# accept it, 1 if the browser accepts it but
+# doesn't give a preference, or a floating point
+# value between 0.0 and 1.0 if the browser
+# declares a quantitative score for it.
+# This handles MIME type globs correctly.
+####
+'Accept' => <<'END_OF_FUNC',
+sub Accept {
+ my($self,$search) = self_or_CGI(@_);
+ my(%prefs,$type,$pref,$pat);
+
+ my(@accept) = defined $self->http('accept')
+ ? split(',',$self->http('accept'))
+ : ();
+
+ for (@accept) {
+ ($pref) = /q=(\d\.\d+|\d+)/;
+ ($type) = m#(\S+/[^;]+)#;
+ next unless $type;
+ $prefs{$type}=$pref || 1;
+ }
+
+ return keys %prefs unless $search;
+
+ # if a search type is provided, we may need to
+ # perform a pattern matching operation.
+ # The MIME types use a glob mechanism, which
+ # is easily translated into a perl pattern match
+
+ # First return the preference for directly supported
+ # types:
+ return $prefs{$search} if $prefs{$search};
+
+ # Didn't get it, so try pattern matching.
+ for (keys %prefs) {
+ next unless /\*/; # not a pattern match
+ ($pat = $_) =~ s/([^\w*])/\\$1/g; # escape meta characters
+ $pat =~ s/\*/.*/g; # turn it into a pattern
+ return $prefs{$_} if $search=~/$pat/;
+ }
+}
+END_OF_FUNC
+
+
+#### Method: user_agent
+# If called with no parameters, returns the user agent.
+# If called with one parameter, does a pattern match (case
+# insensitive) on the user agent.
+####
+'user_agent' => <<'END_OF_FUNC',
+sub user_agent {
+ my($self,$match)=self_or_CGI(@_);
+ return $self->http('user_agent') unless $match;
+ return $self->http('user_agent') =~ /$match/i;
+}
+END_OF_FUNC
+
+
+#### Method: raw_cookie
+# Returns the magic cookies for the session.
+# The cookies are not parsed or altered in any way, i.e.
+# cookies are returned exactly as given in the HTTP
+# headers. If a cookie name is given, only that cookie's
+# value is returned, otherwise the entire raw cookie
+# is returned.
+####
+'raw_cookie' => <<'END_OF_FUNC',
+sub raw_cookie {
+ my($self,$key) = self_or_CGI(@_);
+
+ require CGI::Cookie;
+
+ if (defined($key)) {
+ $self->{'.raw_cookies'} = CGI::Cookie->raw_fetch
+ unless $self->{'.raw_cookies'};
+
+ return () unless $self->{'.raw_cookies'};
+ return () unless $self->{'.raw_cookies'}->{$key};
+ return $self->{'.raw_cookies'}->{$key};
+ }
+ return $self->http('cookie') || $ENV{'COOKIE'} || '';
+}
+END_OF_FUNC
+
+#### Method: virtual_host
+# Return the name of the virtual_host, which
+# is not always the same as the server
+######
+'virtual_host' => <<'END_OF_FUNC',
+sub virtual_host {
+ my $vh = http('x_forwarded_host') || http('host') || server_name();
+ $vh =~ s/:\d+$//; # get rid of port number
+ return $vh;
+}
+END_OF_FUNC
+
+#### Method: remote_host
+# Return the name of the remote host, or its IP
+# address if unavailable. If this variable isn't
+# defined, it returns "localhost" for debugging
+# purposes.
+####
+'remote_host' => <<'END_OF_FUNC',
+sub remote_host {
+ return $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'}
+ || 'localhost';
+}
+END_OF_FUNC
+
+
+#### Method: remote_addr
+# Return the IP addr of the remote host.
+####
+'remote_addr' => <<'END_OF_FUNC',
+sub remote_addr {
+ return $ENV{'REMOTE_ADDR'} || '127.0.0.1';
+}
+END_OF_FUNC
+
+
+#### Method: script_name
+# Return the partial URL to this script for
+# self-referencing scripts. Also see
+# self_url(), which returns a URL with all state information
+# preserved.
+####
+'script_name' => <<'END_OF_FUNC',
+sub script_name {
+ my ($self, at p) = self_or_default(@_);
+ if (@p) {
+ $self->{'.script_name'} = shift @p;
+ } elsif (!exists $self->{'.script_name'}) {
+ my ($script_name,$path_info) = $self->_name_and_path_from_env();
+ $self->{'.script_name'} = $script_name;
+ }
+ return $self->{'.script_name'};
+}
+END_OF_FUNC
+
+
+#### Method: referer
+# Return the HTTP_REFERER: useful for generating
+# a GO BACK button.
+####
+'referer' => <<'END_OF_FUNC',
+sub referer {
+ my($self) = self_or_CGI(@_);
+ return $self->http('referer');
+}
+END_OF_FUNC
+
+
+#### Method: server_name
+# Return the name of the server
+####
+'server_name' => <<'END_OF_FUNC',
+sub server_name {
+ return $ENV{'SERVER_NAME'} || 'localhost';
+}
+END_OF_FUNC
+
+#### Method: server_software
+# Return the name of the server software
+####
+'server_software' => <<'END_OF_FUNC',
+sub server_software {
+ return $ENV{'SERVER_SOFTWARE'} || 'cmdline';
+}
+END_OF_FUNC
+
+#### Method: virtual_port
+# Return the server port, taking virtual hosts into account
+####
+'virtual_port' => <<'END_OF_FUNC',
+sub virtual_port {
+ my($self) = self_or_default(@_);
+ my $vh = $self->http('x_forwarded_host') || $self->http('host');
+ my $protocol = $self->protocol;
+ if ($vh) {
+ return ($vh =~ /:(\d+)$/)[0] || ($protocol eq 'https' ? 443 : 80);
+ } else {
+ return $self->server_port();
+ }
+}
+END_OF_FUNC
+
+#### Method: server_port
+# Return the tcp/ip port the server is running on
+####
+'server_port' => <<'END_OF_FUNC',
+sub server_port {
+ return $ENV{'SERVER_PORT'} || 80; # for debugging
+}
+END_OF_FUNC
+
+#### Method: server_protocol
+# Return the protocol (usually HTTP/1.0)
+####
+'server_protocol' => <<'END_OF_FUNC',
+sub server_protocol {
+ return $ENV{'SERVER_PROTOCOL'} || 'HTTP/1.0'; # for debugging
+}
+END_OF_FUNC
+
+#### Method: http
+# Return the value of an HTTP variable, or
+# the list of variables if none provided
+####
+'http' => <<'END_OF_FUNC',
+sub http {
+ my ($self,$parameter) = self_or_CGI(@_);
+ return $ENV{$parameter} if $parameter=~/^HTTP/;
+ $parameter =~ tr/-/_/;
+ return $ENV{"HTTP_\U$parameter\E"} if $parameter;
+ my(@p);
+ for (keys %ENV) {
+ push(@p,$_) if /^HTTP/;
+ }
+ return @p;
+}
+END_OF_FUNC
+
+#### Method: https
+# Return the value of HTTPS
+####
+'https' => <<'END_OF_FUNC',
+sub https {
+ local($^W)=0;
+ my ($self,$parameter) = self_or_CGI(@_);
+ return $ENV{HTTPS} unless $parameter;
+ return $ENV{$parameter} if $parameter=~/^HTTPS/;
+ $parameter =~ tr/-/_/;
+ return $ENV{"HTTPS_\U$parameter\E"} if $parameter;
+ my(@p);
+ for (keys %ENV) {
+ push(@p,$_) if /^HTTPS/;
+ }
+ return @p;
+}
+END_OF_FUNC
+
+#### Method: protocol
+# Return the protocol (http or https currently)
+####
+'protocol' => <<'END_OF_FUNC',
+sub protocol {
+ local($^W)=0;
+ my $self = shift;
+ return 'https' if uc($self->https()) eq 'ON';
+ return 'https' if $self->server_port == 443;
+ my $prot = $self->server_protocol;
+ my($protocol,$version) = split('/',$prot);
+ return "\L$protocol\E";
+}
+END_OF_FUNC
+
+#### Method: remote_ident
+# Return the identity of the remote user
+# (but only if his host is running identd)
+####
+'remote_ident' => <<'END_OF_FUNC',
+sub remote_ident {
+ return $ENV{'REMOTE_IDENT'};
+}
+END_OF_FUNC
+
+
+#### Method: auth_type
+# Return the type of use verification/authorization in use, if any.
+####
+'auth_type' => <<'END_OF_FUNC',
+sub auth_type {
+ return $ENV{'AUTH_TYPE'};
+}
+END_OF_FUNC
+
+
+#### Method: remote_user
+# Return the authorization name used for user
+# verification.
+####
+'remote_user' => <<'END_OF_FUNC',
+sub remote_user {
+ return $ENV{'REMOTE_USER'};
+}
+END_OF_FUNC
+
+
+#### Method: user_name
+# Try to return the remote user's name by hook or by
+# crook
+####
+'user_name' => <<'END_OF_FUNC',
+sub user_name {
+ my ($self) = self_or_CGI(@_);
+ return $self->http('from') || $ENV{'REMOTE_IDENT'} || $ENV{'REMOTE_USER'};
+}
+END_OF_FUNC
+
+#### Method: nosticky
+# Set or return the NOSTICKY global flag
+####
+'nosticky' => <<'END_OF_FUNC',
+sub nosticky {
+ my ($self,$param) = self_or_CGI(@_);
+ $CGI::NOSTICKY = $param if defined($param);
+ return $CGI::NOSTICKY;
+}
+END_OF_FUNC
+
+#### Method: nph
+# Set or return the NPH global flag
+####
+'nph' => <<'END_OF_FUNC',
+sub nph {
+ my ($self,$param) = self_or_CGI(@_);
+ $CGI::NPH = $param if defined($param);
+ return $CGI::NPH;
+}
+END_OF_FUNC
+
+#### Method: private_tempfiles
+# Set or return the private_tempfiles global flag
+####
+'private_tempfiles' => <<'END_OF_FUNC',
+sub private_tempfiles {
+ my ($self,$param) = self_or_CGI(@_);
+ $CGI::PRIVATE_TEMPFILES = $param if defined($param);
+ return $CGI::PRIVATE_TEMPFILES;
+}
+END_OF_FUNC
+#### Method: close_upload_files
+# Set or return the close_upload_files global flag
+####
+'close_upload_files' => <<'END_OF_FUNC',
+sub close_upload_files {
+ my ($self,$param) = self_or_CGI(@_);
+ $CGI::CLOSE_UPLOAD_FILES = $param if defined($param);
+ return $CGI::CLOSE_UPLOAD_FILES;
+}
+END_OF_FUNC
+
+
+#### Method: default_dtd
+# Set or return the default_dtd global
+####
+'default_dtd' => <<'END_OF_FUNC',
+sub default_dtd {
+ my ($self,$param,$param2) = self_or_CGI(@_);
+ if (defined $param2 && defined $param) {
+ $CGI::DEFAULT_DTD = [ $param, $param2 ];
+ } elsif (defined $param) {
+ $CGI::DEFAULT_DTD = $param;
+ }
+ return $CGI::DEFAULT_DTD;
+}
+END_OF_FUNC
+
+# -------------- really private subroutines -----------------
+'previous_or_default' => <<'END_OF_FUNC',
+sub previous_or_default {
+ my($self,$name,$defaults,$override) = @_;
+ my(%selected);
+
+ if (!$override && ($self->{'.fieldnames'}->{$name} ||
+ defined($self->param($name)) ) ) {
+ $selected{$_}++ for $self->param($name);
+ } elsif (defined($defaults) && ref($defaults) &&
+ (ref($defaults) eq 'ARRAY')) {
+ $selected{$_}++ for @{$defaults};
+ } else {
+ $selected{$defaults}++ if defined($defaults);
+ }
+
+ return %selected;
+}
+END_OF_FUNC
+
+'register_parameter' => <<'END_OF_FUNC',
+sub register_parameter {
+ my($self,$param) = @_;
+ $self->{'.parametersToAdd'}->{$param}++;
+}
+END_OF_FUNC
+
+'get_fields' => <<'END_OF_FUNC',
+sub get_fields {
+ my($self) = @_;
+ return $self->CGI::hidden('-name'=>'.cgifields',
+ '-values'=>[keys %{$self->{'.parametersToAdd'}}],
+ '-override'=>1);
+}
+END_OF_FUNC
+
+'read_from_cmdline' => <<'END_OF_FUNC',
+sub read_from_cmdline {
+ my($input, at words);
+ my($query_string);
+ my($subpath);
+ if ($DEBUG && @ARGV) {
+ @words = @ARGV;
+ } elsif ($DEBUG > 1) {
+ require "shellwords.pl";
+ print STDERR "(offline mode: enter name=value pairs on standard input; press ^D or ^Z when done)\n";
+ chomp(@lines = <STDIN>); # remove newlines
+ $input = join(" ", at lines);
+ @words = &shellwords($input);
+ }
+ for (@words) {
+ s/\\=/%3D/g;
+ s/\\&/%26/g;
+ }
+
+ if ("@words"=~/=/) {
+ $query_string = join('&', at words);
+ } else {
+ $query_string = join('+', at words);
+ }
+ if ($query_string =~ /^(.*?)\?(.*)$/)
+ {
+ $query_string = $2;
+ $subpath = $1;
+ }
+ return { 'query_string' => $query_string, 'subpath' => $subpath };
+}
+END_OF_FUNC
+
+#####
+# subroutine: read_multipart
+#
+# Read multipart data and store it into our parameters.
+# An interesting feature is that if any of the parts is a file, we
+# create a temporary file and open up a filehandle on it so that the
+# caller can read from it if necessary.
+#####
+'read_multipart' => <<'END_OF_FUNC',
+sub read_multipart {
+ my($self,$boundary,$length) = @_;
+ my($buffer) = $self->new_MultipartBuffer($boundary,$length);
+ return unless $buffer;
+ my(%header,$body);
+ my $filenumber = 0;
+ while (!$buffer->eof) {
+ %header = $buffer->readHeader;
+
+ unless (%header) {
+ $self->cgi_error("400 Bad request (malformed multipart POST)");
+ return;
+ }
+
+ $header{'Content-Disposition'} ||= ''; # quench uninit variable warning
+
+ my($param)= $header{'Content-Disposition'}=~/ name="([^"]*)"/;
+ $param .= $TAINTED;
+
+ # See RFC 1867, 2183, 2045
+ # NB: File content will be loaded into memory should
+ # content-disposition parsing fail.
+ my ($filename) = $header{'Content-Disposition'}
+ =~/ filename=(("[^"]*")|([a-z\d!\#'\*\+,\.^_\`\{\}\|\~]*))/i;
+
+ $filename ||= ''; # quench uninit variable warning
+
+ $filename =~ s/^"([^"]*)"$/$1/;
+ # Test for Opera's multiple upload feature
+ my($multipart) = ( defined( $header{'Content-Type'} ) &&
+ $header{'Content-Type'} =~ /multipart\/mixed/ ) ?
+ 1 : 0;
+
+ # add this parameter to our list
+ $self->add_parameter($param);
+
+ # If no filename specified, then just read the data and assign it
+ # to our parameter list.
+ if ( ( !defined($filename) || $filename eq '' ) && !$multipart ) {
+ my($value) = $buffer->readBody;
+ $value .= $TAINTED;
+ push(@{$self->{param}{$param}},$value);
+ next;
+ }
+
+ my ($tmpfile,$tmp,$filehandle);
+ UPLOADS: {
+ # If we get here, then we are dealing with a potentially large
+ # uploaded form. Save the data to a temporary file, then open
+ # the file for reading.
+
+ # skip the file if uploads disabled
+ if ($DISABLE_UPLOADS) {
+ while (defined($data = $buffer->read)) { }
+ last UPLOADS;
+ }
+
+ # set the filename to some recognizable value
+ if ( ( !defined($filename) || $filename eq '' ) && $multipart ) {
+ $filename = "multipart/mixed";
+ }
+
+ # choose a relatively unpredictable tmpfile sequence number
+ my $seqno = unpack("%16C*",join('',localtime,grep {defined $_} values %ENV));
+ for (my $cnt=10;$cnt>0;$cnt--) {
+ next unless $tmpfile = new CGITempFile($seqno);
+ $tmp = $tmpfile->as_string;
+ last if defined($filehandle = Fh->new($filename,$tmp,$PRIVATE_TEMPFILES));
+ $seqno += int rand(100);
+ }
+ die "CGI open of tmpfile: $!\n" unless defined $filehandle;
+ $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode
+ && defined fileno($filehandle);
+
+ # if this is an multipart/mixed attachment, save the header
+ # together with the body for later parsing with an external
+ # MIME parser module
+ if ( $multipart ) {
+ for ( keys %header ) {
+ print $filehandle "$_: $header{$_}${CRLF}";
+ }
+ print $filehandle "${CRLF}";
+ }
+
+ my ($data);
+ local($\) = '';
+ my $totalbytes = 0;
+ while (defined($data = $buffer->read)) {
+ if (defined $self->{'.upload_hook'})
+ {
+ $totalbytes += length($data);
+ &{$self->{'.upload_hook'}}($filename ,$data, $totalbytes, $self->{'.upload_data'});
+ }
+ print $filehandle $data if ($self->{'use_tempfile'});
+ }
+
+ # back up to beginning of file
+ seek($filehandle,0,0);
+
+ ## Close the filehandle if requested this allows a multipart MIME
+ ## upload to contain many files, and we won't die due to too many
+ ## open file handles. The user can access the files using the hash
+ ## below.
+ close $filehandle if $CLOSE_UPLOAD_FILES;
+ $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
+
+ # Save some information about the uploaded file where we can get
+ # at it later.
+ # Use the typeglob as the key, as this is guaranteed to be
+ # unique for each filehandle. Don't use the file descriptor as
+ # this will be re-used for each filehandle if the
+ # close_upload_files feature is used.
+ $self->{'.tmpfiles'}->{$$filehandle}= {
+ hndl => $filehandle,
+ name => $tmpfile,
+ info => {%header},
+ };
+ push(@{$self->{param}{$param}},$filehandle);
+ }
+ }
+}
+END_OF_FUNC
+
+#####
+# subroutine: read_multipart_related
+#
+# Read multipart/related data and store it into our parameters. The
+# first parameter sets the start of the data. The part identified by
+# this Content-ID will not be stored as a file upload, but will be
+# returned by this method. All other parts will be available as file
+# uploads accessible by their Content-ID
+#####
+'read_multipart_related' => <<'END_OF_FUNC',
+sub read_multipart_related {
+ my($self,$start,$boundary,$length) = @_;
+ my($buffer) = $self->new_MultipartBuffer($boundary,$length);
+ return unless $buffer;
+ my(%header,$body);
+ my $filenumber = 0;
+ my $returnvalue;
+ while (!$buffer->eof) {
+ %header = $buffer->readHeader;
+
+ unless (%header) {
+ $self->cgi_error("400 Bad request (malformed multipart POST)");
+ return;
+ }
+
+ my($param) = $header{'Content-ID'}=~/\<([^\>]*)\>/;
+ $param .= $TAINTED;
+
+ # If this is the start part, then just read the data and assign it
+ # to our return variable.
+ if ( $param eq $start ) {
+ $returnvalue = $buffer->readBody;
+ $returnvalue .= $TAINTED;
+ next;
+ }
+
+ # add this parameter to our list
+ $self->add_parameter($param);
+
+ my ($tmpfile,$tmp,$filehandle);
+ UPLOADS: {
+ # If we get here, then we are dealing with a potentially large
+ # uploaded form. Save the data to a temporary file, then open
+ # the file for reading.
+
+ # skip the file if uploads disabled
+ if ($DISABLE_UPLOADS) {
+ while (defined($data = $buffer->read)) { }
+ last UPLOADS;
+ }
+
+ # choose a relatively unpredictable tmpfile sequence number
+ my $seqno = unpack("%16C*",join('',localtime,grep {defined $_} values %ENV));
+ for (my $cnt=10;$cnt>0;$cnt--) {
+ next unless $tmpfile = new CGITempFile($seqno);
+ $tmp = $tmpfile->as_string;
+ last if defined($filehandle = Fh->new($param,$tmp,$PRIVATE_TEMPFILES));
+ $seqno += int rand(100);
+ }
+ die "CGI open of tmpfile: $!\n" unless defined $filehandle;
+ $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode
+ && defined fileno($filehandle);
+
+ my ($data);
+ local($\) = '';
+ my $totalbytes;
+ while (defined($data = $buffer->read)) {
+ if (defined $self->{'.upload_hook'})
+ {
+ $totalbytes += length($data);
+ &{$self->{'.upload_hook'}}($param ,$data, $totalbytes, $self->{'.upload_data'});
+ }
+ print $filehandle $data if ($self->{'use_tempfile'});
+ }
+
+ # back up to beginning of file
+ seek($filehandle,0,0);
+
+ ## Close the filehandle if requested this allows a multipart MIME
+ ## upload to contain many files, and we won't die due to too many
+ ## open file handles. The user can access the files using the hash
+ ## below.
+ close $filehandle if $CLOSE_UPLOAD_FILES;
+ $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
+
+ # Save some information about the uploaded file where we can get
+ # at it later.
+ # Use the typeglob as the key, as this is guaranteed to be
+ # unique for each filehandle. Don't use the file descriptor as
+ # this will be re-used for each filehandle if the
+ # close_upload_files feature is used.
+ $self->{'.tmpfiles'}->{$$filehandle}= {
+ hndl => $filehandle,
+ name => $tmpfile,
+ info => {%header},
+ };
+ push(@{$self->{param}{$param}},$filehandle);
+ }
+ }
+ return $returnvalue;
+}
+END_OF_FUNC
+
+
+'upload' =><<'END_OF_FUNC',
+sub upload {
+ my($self,$param_name) = self_or_default(@_);
+ my @param = grep {ref($_) && defined(fileno($_))} $self->param($param_name);
+ return unless @param;
+ return wantarray ? @param : $param[0];
+}
+END_OF_FUNC
+
+'tmpFileName' => <<'END_OF_FUNC',
+sub tmpFileName {
+ my($self,$filename) = self_or_default(@_);
+ return $self->{'.tmpfiles'}->{$$filename}->{name} ?
+ $self->{'.tmpfiles'}->{$$filename}->{name}->as_string
+ : '';
+}
+END_OF_FUNC
+
+'uploadInfo' => <<'END_OF_FUNC',
+sub uploadInfo {
+ my($self,$filename) = self_or_default(@_);
+ return $self->{'.tmpfiles'}->{$$filename}->{info};
+}
+END_OF_FUNC
+
+# internal routine, don't use
+'_set_values_and_labels' => <<'END_OF_FUNC',
+sub _set_values_and_labels {
+ my $self = shift;
+ my ($v,$l,$n) = @_;
+ $$l = $v if ref($v) eq 'HASH' && !ref($$l);
+ return $self->param($n) if !defined($v);
+ return $v if !ref($v);
+ return ref($v) eq 'HASH' ? keys %$v : @$v;
+}
+END_OF_FUNC
+
+# internal routine, don't use
+'_set_attributes' => <<'END_OF_FUNC',
+sub _set_attributes {
+ my $self = shift;
+ my($element, $attributes) = @_;
+ return '' unless defined($attributes->{$element});
+ $attribs = ' ';
+ for my $attrib (keys %{$attributes->{$element}}) {
+ (my $clean_attrib = $attrib) =~ s/^-//;
+ $attribs .= "@{[lc($clean_attrib)]}=\"$attributes->{$element}{$attrib}\" ";
+ }
+ $attribs =~ s/ $//;
+ return $attribs;
+}
+END_OF_FUNC
+
+'_compile_all' => <<'END_OF_FUNC',
+sub _compile_all {
+ for (@_) {
+ next if defined(&$_);
+ $AUTOLOAD = "CGI::$_";
+ _compile();
+ }
+}
+END_OF_FUNC
+
+);
+END_OF_AUTOLOAD
+;
+
+#########################################################
+# Globals and stubs for other packages that we use.
+#########################################################
+
+################### Fh -- lightweight filehandle ###############
+package Fh;
+
+use overload
+ '""' => \&asString,
+ 'cmp' => \&compare,
+ 'fallback'=>1;
+
+$FH='fh00000';
+
+*Fh::AUTOLOAD = \&CGI::AUTOLOAD;
+
+sub DESTROY {
+ my $self = shift;
+ close $self;
+}
+
+$AUTOLOADED_ROUTINES = ''; # prevent -w error
+$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
+%SUBS = (
+'asString' => <<'END_OF_FUNC',
+sub asString {
+ my $self = shift;
+ # get rid of package name
+ (my $i = $$self) =~ s/^\*(\w+::fh\d{5})+//;
+ $i =~ s/%(..)/ chr(hex($1)) /eg;
+ return $i.$CGI::TAINTED;
+# BEGIN DEAD CODE
+# This was an extremely clever patch that allowed "use strict refs".
+# Unfortunately it relied on another bug that caused leaky file descriptors.
+# The underlying bug has been fixed, so this no longer works. However
+# "strict refs" still works for some reason.
+# my $self = shift;
+# return ${*{$self}{SCALAR}};
+# END DEAD CODE
+}
+END_OF_FUNC
+
+'compare' => <<'END_OF_FUNC',
+sub compare {
+ my $self = shift;
+ my $value = shift;
+ return "$self" cmp $value;
+}
+END_OF_FUNC
+
+'new' => <<'END_OF_FUNC',
+sub new {
+ my($pack,$name,$file,$delete) = @_;
+ _setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS;
+ require Fcntl unless defined &Fcntl::O_RDWR;
+ (my $safename = $name) =~ s/([':%])/ sprintf '%%%02X', ord $1 /eg;
+ my $fv = ++$FH . $safename;
+ my $ref = \*{"Fh::$fv"};
+ $file =~ m!^([a-zA-Z0-9_\+ \'\":/.\$\\~-]+)$! || return;
+ my $safe = $1;
+ sysopen($ref,$safe,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL(),0600) || return;
+ unlink($safe) if $delete;
+ CORE::delete $Fh::{$fv};
+ return bless $ref,$pack;
+}
+END_OF_FUNC
+
+'handle' => <<'END_OF_FUNC',
+sub handle {
+ my $self = shift;
+ eval "require IO::Handle" unless IO::Handle->can('new_from_fd');
+ return IO::Handle->new_from_fd(fileno $self,"<");
+}
+END_OF_FUNC
+
+);
+END_OF_AUTOLOAD
+
+######################## MultipartBuffer ####################
+package MultipartBuffer;
+
+use constant DEBUG => 0;
+
+# how many bytes to read at a time. We use
+# a 4K buffer by default.
+$INITIAL_FILLUNIT = 1024 * 4;
+$TIMEOUT = 240*60; # 4 hour timeout for big files
+$SPIN_LOOP_MAX = 2000; # bug fix for some Netscape servers
+$CRLF=$CGI::CRLF;
+
+#reuse the autoload function
+*MultipartBuffer::AUTOLOAD = \&CGI::AUTOLOAD;
+
+# avoid autoloader warnings
+sub DESTROY {}
+
+###############################################################################
+################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
+###############################################################################
+$AUTOLOADED_ROUTINES = ''; # prevent -w error
+$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
+%SUBS = (
+
+'new' => <<'END_OF_FUNC',
+sub new {
+ my($package,$interface,$boundary,$length) = @_;
+ $FILLUNIT = $INITIAL_FILLUNIT;
+ $CGI::DefaultClass->binmode($IN); # if $CGI::needs_binmode; # just do it always
+
+ # If the user types garbage into the file upload field,
+ # then Netscape passes NOTHING to the server (not good).
+ # We may hang on this read in that case. So we implement
+ # a read timeout. If nothing is ready to read
+ # by then, we return.
+
+ # Netscape seems to be a little bit unreliable
+ # about providing boundary strings.
+ my $boundary_read = 0;
+ if ($boundary) {
+
+ # Under the MIME spec, the boundary consists of the
+ # characters "--" PLUS the Boundary string
+
+ # BUG: IE 3.01 on the Macintosh uses just the boundary -- not
+ # the two extra hyphens. We do a special case here on the user-agent!!!!
+ $boundary = "--$boundary" unless CGI::user_agent('MSIE\s+3\.0[12];\s*Mac|DreamPassport');
+
+ } else { # otherwise we find it ourselves
+ my($old);
+ ($old,$/) = ($/,$CRLF); # read a CRLF-delimited line
+ $boundary = <STDIN>; # BUG: This won't work correctly under mod_perl
+ $length -= length($boundary);
+ chomp($boundary); # remove the CRLF
+ $/ = $old; # restore old line separator
+ $boundary_read++;
+ }
+
+ my $self = {LENGTH=>$length,
+ CHUNKED=>!$length,
+ BOUNDARY=>$boundary,
+ INTERFACE=>$interface,
+ BUFFER=>'',
+ };
+
+ $FILLUNIT = length($boundary)
+ if length($boundary) > $FILLUNIT;
+
+ my $retval = bless $self,ref $package || $package;
+
+ # Read the preamble and the topmost (boundary) line plus the CRLF.
+ unless ($boundary_read) {
+ while ($self->read(0)) { }
+ }
+ die "Malformed multipart POST: data truncated\n" if $self->eof;
+
+ return $retval;
+}
+END_OF_FUNC
+
+'readHeader' => <<'END_OF_FUNC',
+sub readHeader {
+ my($self) = @_;
+ my($end);
+ my($ok) = 0;
+ my($bad) = 0;
+
+ local($CRLF) = "\015\012" if $CGI::OS eq 'VMS' || $CGI::EBCDIC;
+
+ do {
+ $self->fillBuffer($FILLUNIT);
+ $ok++ if ($end = index($self->{BUFFER},"${CRLF}${CRLF}")) >= 0;
+ $ok++ if $self->{BUFFER} eq '';
+ $bad++ if !$ok && $self->{LENGTH} <= 0;
+ # this was a bad idea
+ # $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT;
+ } until $ok || $bad;
+ return () if $bad;
+
+ #EBCDIC NOTE: translate header into EBCDIC, but watch out for continuation lines!
+
+ my($header) = substr($self->{BUFFER},0,$end+2);
+ substr($self->{BUFFER},0,$end+4) = '';
+ my %return;
+
+ if ($CGI::EBCDIC) {
+ warn "untranslated header=$header\n" if DEBUG;
+ $header = CGI::Util::ascii2ebcdic($header);
+ warn "translated header=$header\n" if DEBUG;
+ }
+
+ # See RFC 2045 Appendix A and RFC 822 sections 3.4.8
+ # (Folding Long Header Fields), 3.4.3 (Comments)
+ # and 3.4.5 (Quoted-Strings).
+
+ my $token = '[-\w!\#$%&\'*+.^_\`|{}~]';
+ $header=~s/$CRLF\s+/ /og; # merge continuation lines
+
+ while ($header=~/($token+):\s+([^$CRLF]*)/mgox) {
+ my ($field_name,$field_value) = ($1,$2);
+ $field_name =~ s/\b(\w)/uc($1)/eg; #canonicalize
+ $return{$field_name}=$field_value;
+ }
+ return %return;
+}
+END_OF_FUNC
+
+# This reads and returns the body as a single scalar value.
+'readBody' => <<'END_OF_FUNC',
+sub readBody {
+ my($self) = @_;
+ my($data);
+ my($returnval)='';
+
+ #EBCDIC NOTE: want to translate returnval into EBCDIC HERE
+
+ while (defined($data = $self->read)) {
+ $returnval .= $data;
+ }
+
+ if ($CGI::EBCDIC) {
+ warn "untranslated body=$returnval\n" if DEBUG;
+ $returnval = CGI::Util::ascii2ebcdic($returnval);
+ warn "translated body=$returnval\n" if DEBUG;
+ }
+ return $returnval;
+}
+END_OF_FUNC
+
+# This will read $bytes or until the boundary is hit, whichever happens
+# first. After the boundary is hit, we return undef. The next read will
+# skip over the boundary and begin reading again;
+'read' => <<'END_OF_FUNC',
+sub read {
+ my($self,$bytes) = @_;
+
+ # default number of bytes to read
+ $bytes = $bytes || $FILLUNIT;
+
+ # Fill up our internal buffer in such a way that the boundary
+ # is never split between reads.
+ $self->fillBuffer($bytes);
+
+ my $boundary_start = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}) : $self->{BOUNDARY};
+ my $boundary_end = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}.'--') : $self->{BOUNDARY}.'--';
+
+ # Find the boundary in the buffer (it may not be there).
+ my $start = index($self->{BUFFER},$boundary_start);
+
+ warn "boundary=$self->{BOUNDARY} length=$self->{LENGTH} start=$start\n" if DEBUG;
+
+ # protect against malformed multipart POST operations
+ die "Malformed multipart POST\n" unless $self->{CHUNKED} || ($start >= 0 || $self->{LENGTH} > 0);
+
+ #EBCDIC NOTE: want to translate boundary search into ASCII here.
+
+ # If the boundary begins the data, then skip past it
+ # and return undef.
+ if ($start == 0) {
+
+ # clear us out completely if we've hit the last boundary.
+ if (index($self->{BUFFER},$boundary_end)==0) {
+ $self->{BUFFER}='';
+ $self->{LENGTH}=0;
+ return undef;
+ }
+
+ # just remove the boundary.
+ substr($self->{BUFFER},0,length($boundary_start))='';
+ $self->{BUFFER} =~ s/^\012\015?//;
+ return undef;
+ }
+
+ my $bytesToReturn;
+ if ($start > 0) { # read up to the boundary
+ $bytesToReturn = $start-2 > $bytes ? $bytes : $start;
+ } else { # read the requested number of bytes
+ # leave enough bytes in the buffer to allow us to read
+ # the boundary. Thanks to Kevin Hendrick for finding
+ # this one.
+ $bytesToReturn = $bytes - (length($boundary_start)+1);
+ }
+
+ my $returnval=substr($self->{BUFFER},0,$bytesToReturn);
+ substr($self->{BUFFER},0,$bytesToReturn)='';
+
+ # If we hit the boundary, remove the CRLF from the end.
+ return ($bytesToReturn==$start)
+ ? substr($returnval,0,-2) : $returnval;
+}
+END_OF_FUNC
+
+
+# This fills up our internal buffer in such a way that the
+# boundary is never split between reads
+'fillBuffer' => <<'END_OF_FUNC',
+sub fillBuffer {
+ my($self,$bytes) = @_;
+ return unless $self->{CHUNKED} || $self->{LENGTH};
+
+ my($boundaryLength) = length($self->{BOUNDARY});
+ my($bufferLength) = length($self->{BUFFER});
+ my($bytesToRead) = $bytes - $bufferLength + $boundaryLength + 2;
+ $bytesToRead = $self->{LENGTH} if !$self->{CHUNKED} && $self->{LENGTH} < $bytesToRead;
+
+ # Try to read some data. We may hang here if the browser is screwed up.
+ my $bytesRead = $self->{INTERFACE}->read_from_client(\$self->{BUFFER},
+ $bytesToRead,
+ $bufferLength);
+ warn "bytesToRead=$bytesToRead, bufferLength=$bufferLength, buffer=$self->{BUFFER}\n" if DEBUG;
+ $self->{BUFFER} = '' unless defined $self->{BUFFER};
+
+ # An apparent bug in the Apache server causes the read()
+ # to return zero bytes repeatedly without blocking if the
+ # remote user aborts during a file transfer. I don't know how
+ # they manage this, but the workaround is to abort if we get
+ # more than SPIN_LOOP_MAX consecutive zero reads.
+ if ($bytesRead <= 0) {
+ die "CGI.pm: Server closed socket during multipart read (client aborted?).\n"
+ if ($self->{ZERO_LOOP_COUNTER}++ >= $SPIN_LOOP_MAX);
+ } else {
+ $self->{ZERO_LOOP_COUNTER}=0;
+ }
+
+ $self->{LENGTH} -= $bytesRead if !$self->{CHUNKED} && $bytesRead;
+}
+END_OF_FUNC
+
+
+# Return true when we've finished reading
+'eof' => <<'END_OF_FUNC'
+sub eof {
+ my($self) = @_;
+ return 1 if (length($self->{BUFFER}) == 0)
+ && ($self->{LENGTH} <= 0);
+ undef;
+}
+END_OF_FUNC
+
+);
+END_OF_AUTOLOAD
+
+####################################################################################
+################################## TEMPORARY FILES #################################
+####################################################################################
+package CGITempFile;
+
+sub find_tempdir {
+ $SL = $CGI::SL;
+ $MAC = $CGI::OS eq 'MACINTOSH';
+ my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : "";
+ unless (defined $TMPDIRECTORY) {
+ @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp",
+ "C:${SL}temp","${SL}tmp","${SL}temp",
+ "${vol}${SL}Temporary Items",
+ "${SL}WWW_ROOT", "${SL}SYS\$SCRATCH",
+ "C:${SL}system${SL}temp");
+
+ if( $CGI::OS eq 'WINDOWS' ){
+ unshift @TEMP,
+ $ENV{TEMP},
+ $ENV{TMP},
+ $ENV{WINDIR} . $SL . 'TEMP';
+ }
+
+ unshift(@TEMP,$ENV{'TMPDIR'}) if defined $ENV{'TMPDIR'};
+
+ # this feature was supposed to provide per-user tmpfiles, but
+ # it is problematic.
+ # unshift(@TEMP,(getpwuid($<))[7].'/tmp') if $CGI::OS eq 'UNIX';
+ # Rob: getpwuid() is unfortunately UNIX specific. On brain dead OS'es this
+ # : can generate a 'getpwuid() not implemented' exception, even though
+ # : it's never called. Found under DOS/Win with the DJGPP perl port.
+ # : Refer to getpwuid() only at run-time if we're fortunate and have UNIX.
+ # unshift(@TEMP,(eval {(getpwuid($>))[7]}).'/tmp') if $CGI::OS eq 'UNIX' and $> != 0;
+
+ for (@TEMP) {
+ do {$TMPDIRECTORY = $_; last} if -d $_ && -w _;
+ }
+ }
+ $TMPDIRECTORY = $MAC ? "" : "." unless $TMPDIRECTORY;
+}
+
+find_tempdir();
+
+$MAXTRIES = 5000;
+
+# cute feature, but overload implementation broke it
+# %OVERLOAD = ('""'=>'as_string');
+*CGITempFile::AUTOLOAD = \&CGI::AUTOLOAD;
+
+sub DESTROY {
+ my($self) = @_;
+ $$self =~ m!^([a-zA-Z0-9_ \'\":/.\$\\~-]+)$! || return;
+ my $safe = $1; # untaint operation
+ unlink $safe; # get rid of the file
+}
+
+###############################################################################
+################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
+###############################################################################
+$AUTOLOADED_ROUTINES = ''; # prevent -w error
+$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
+%SUBS = (
+
+'new' => <<'END_OF_FUNC',
+sub new {
+ my($package,$sequence) = @_;
+ my $filename;
+ find_tempdir() unless -w $TMPDIRECTORY;
+ for (my $i = 0; $i < $MAXTRIES; $i++) {
+ last if ! -f ($filename = sprintf("\%s${SL}CGItemp%d", $TMPDIRECTORY, $sequence++));
+ }
+ # check that it is a more-or-less valid filename
+ return unless $filename =~ m!^([a-zA-Z0-9_\+ \'\":/.\$\\~-]+)$!;
+ # this used to untaint, now it doesn't
+ # $filename = $1;
+ return bless \$filename;
+}
+END_OF_FUNC
+
+'as_string' => <<'END_OF_FUNC'
+sub as_string {
+ my($self) = @_;
+ return $$self;
+}
+END_OF_FUNC
+
+);
+END_OF_AUTOLOAD
+
+package CGI;
+
+# We get a whole bunch of warnings about "possibly uninitialized variables"
+# when running with the -w switch. Touch them all once to get rid of the
+# warnings. This is ugly and I hate it.
+if ($^W) {
+ $CGI::CGI = '';
+ $CGI::CGI=<<EOF;
+ $CGI::VERSION;
+ $MultipartBuffer::SPIN_LOOP_MAX;
+ $MultipartBuffer::CRLF;
+ $MultipartBuffer::TIMEOUT;
+ $MultipartBuffer::INITIAL_FILLUNIT;
+EOF
+ ;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+CGI - Handle Common Gateway Interface requests and responses
+
+=head1 SYNOPSIS
+
+ use CGI;
+
+ my $q = CGI->new;
+
+ # Process an HTTP request
+ @values = $q->param('form_field');
+
+ $fh = $q->upload('file_field');
+
+ $riddle = $query->cookie('riddle_name');
+ %answers = $query->cookie('answers');
+
+ # Prepare various HTTP responses
+ print $q->header();
+ print $q->header('application/json');
+
+ $cookie1 = $q->cookie(-name=>'riddle_name', -value=>"The Sphynx's Question");
+ $cookie2 = $q->cookie(-name=>'answers', -value=>\%answers);
+ print $q->header(
+ -type => 'image/gif',
+ -expires => '+3d',
+ -cookie => [$cookie1,$cookie2]
+ );
+
+ print $q->redirect('http://somewhere.else/in/movie/land');
+
+=head1 DESCRIPTION
+
+CGI.pm is a stable, complete and mature solution for processing and preparing
+HTTP requests and responses. Major features including processing form
+submissions, file uploads, reading and writing cookies, query string generation
+and manipulation, and processing and preparing HTTP headers. Some HTML
+generation utilities are included as well.
+
+CGI.pm performs very well in in a vanilla CGI.pm environment and also comes
+with built-in support for mod_perl and mod_perl2 as well as FastCGI.
+
+It has the benefit of having developed and refined over 10 years with input
+from dozens of contributors and being deployed on thousands of websites.
+CGI.pm has been included in the Perl distribution since Perl 5.4, and has
+become a de-facto standard.
+
+=head2 PROGRAMMING STYLE
+
+There are two styles of programming with CGI.pm, an object-oriented
+style and a function-oriented style. In the object-oriented style you
+create one or more CGI objects and then use object methods to create
+the various elements of the page. Each CGI object starts out with the
+list of named parameters that were passed to your CGI script by the
+server. You can modify the objects, save them to a file or database
+and recreate them. Because each object corresponds to the "state" of
+the CGI script, and because each object's parameter list is
+independent of the others, this allows you to save the state of the
+script and restore it later.
+
+For example, using the object oriented style, here is how you create
+a simple "Hello World" HTML page:
+
+ #!/usr/local/bin/perl -w
+ use CGI; # load CGI routines
+ $q = new CGI; # create new CGI object
+ print $q->header, # create the HTTP header
+ $q->start_html('hello world'), # start the HTML
+ $q->h1('hello world'), # level 1 header
+ $q->end_html; # end the HTML
+
+In the function-oriented style, there is one default CGI object that
+you rarely deal with directly. Instead you just call functions to
+retrieve CGI parameters, create HTML tags, manage cookies, and so
+on. This provides you with a cleaner programming interface, but
+limits you to using one CGI object at a time. The following example
+prints the same page, but uses the function-oriented interface.
+The main differences are that we now need to import a set of functions
+into our name space (usually the "standard" functions), and we don't
+need to create the CGI object.
+
+ #!/usr/local/bin/perl
+ use CGI qw/:standard/; # load standard CGI routines
+ print header, # create the HTTP header
+ start_html('hello world'), # start the HTML
+ h1('hello world'), # level 1 header
+ end_html; # end the HTML
+
+The examples in this document mainly use the object-oriented style.
+See HOW TO IMPORT FUNCTIONS for important information on
+function-oriented programming in CGI.pm
+
+=head2 CALLING CGI.PM ROUTINES
+
+Most CGI.pm routines accept several arguments, sometimes as many as 20
+optional ones! To simplify this interface, all routines use a named
+argument calling style that looks like this:
+
+ print $q->header(-type=>'image/gif',-expires=>'+3d');
+
+Each argument name is preceded by a dash. Neither case nor order
+matters in the argument list. -type, -Type, and -TYPE are all
+acceptable. In fact, only the first argument needs to begin with a
+dash. If a dash is present in the first argument, CGI.pm assumes
+dashes for the subsequent ones.
+
+Several routines are commonly called with just one argument. In the
+case of these routines you can provide the single argument without an
+argument name. header() happens to be one of these routines. In this
+case, the single argument is the document type.
+
+ print $q->header('text/html');
+
+Other such routines are documented below.
+
+Sometimes named arguments expect a scalar, sometimes a reference to an
+array, and sometimes a reference to a hash. Often, you can pass any
+type of argument and the routine will do whatever is most appropriate.
+For example, the param() routine is used to set a CGI parameter to a
+single or a multi-valued value. The two cases are shown below:
+
+ $q->param(-name=>'veggie',-value=>'tomato');
+ $q->param(-name=>'veggie',-value=>['tomato','tomahto','potato','potahto']);
+
+A large number of routines in CGI.pm actually aren't specifically
+defined in the module, but are generated automatically as needed.
+These are the "HTML shortcuts," routines that generate HTML tags for
+use in dynamically-generated pages. HTML tags have both attributes
+(the attribute="value" pairs within the tag itself) and contents (the
+part between the opening and closing pairs.) To distinguish between
+attributes and contents, CGI.pm uses the convention of passing HTML
+attributes as a hash reference as the first argument, and the
+contents, if any, as any subsequent arguments. It works out like
+this:
+
+ Code Generated HTML
+ ---- --------------
+ h1() <h1>
+ h1('some','contents'); <h1>some contents</h1>
+ h1({-align=>left}); <h1 align="LEFT">
+ h1({-align=>left},'contents'); <h1 align="LEFT">contents</h1>
+
+HTML tags are described in more detail later.
+
+Many newcomers to CGI.pm are puzzled by the difference between the
+calling conventions for the HTML shortcuts, which require curly braces
+around the HTML tag attributes, and the calling conventions for other
+routines, which manage to generate attributes without the curly
+brackets. Don't be confused. As a convenience the curly braces are
+optional in all but the HTML shortcuts. If you like, you can use
+curly braces when calling any routine that takes named arguments. For
+example:
+
+ print $q->header( {-type=>'image/gif',-expires=>'+3d'} );
+
+If you use the B<-w> switch, you will be warned that some CGI.pm argument
+names conflict with built-in Perl functions. The most frequent of
+these is the -values argument, used to create multi-valued menus,
+radio button clusters and the like. To get around this warning, you
+have several choices:
+
+=over 4
+
+=item 1.
+
+Use another name for the argument, if one is available.
+For example, -value is an alias for -values.
+
+=item 2.
+
+Change the capitalization, e.g. -Values
+
+=item 3.
+
+Put quotes around the argument name, e.g. '-values'
+
+=back
+
+Many routines will do something useful with a named argument that it
+doesn't recognize. For example, you can produce non-standard HTTP
+header fields by providing them as named arguments:
+
+ print $q->header(-type => 'text/html',
+ -cost => 'Three smackers',
+ -annoyance_level => 'high',
+ -complaints_to => 'bit bucket');
+
+This will produce the following nonstandard HTTP header:
+
+ HTTP/1.0 200 OK
+ Cost: Three smackers
+ Annoyance-level: high
+ Complaints-to: bit bucket
+ Content-type: text/html
+
+Notice the way that underscores are translated automatically into
+hyphens. HTML-generating routines perform a different type of
+translation.
+
+This feature allows you to keep up with the rapidly changing HTTP and
+HTML "standards".
+
+=head2 CREATING A NEW QUERY OBJECT (OBJECT-ORIENTED STYLE):
+
+ $query = new CGI;
+
+This will parse the input (from both POST and GET methods) and store
+it into a perl5 object called $query.
+
+Any filehandles from file uploads will have their position reset to
+the beginning of the file.
+
+=head2 CREATING A NEW QUERY OBJECT FROM AN INPUT FILE
+
+ $query = new CGI(INPUTFILE);
+
+If you provide a file handle to the new() method, it will read
+parameters from the file (or STDIN, or whatever). The file can be in
+any of the forms describing below under debugging (i.e. a series of
+newline delimited TAG=VALUE pairs will work). Conveniently, this type
+of file is created by the save() method (see below). Multiple records
+can be saved and restored.
+
+Perl purists will be pleased to know that this syntax accepts
+references to file handles, or even references to filehandle globs,
+which is the "official" way to pass a filehandle:
+
+ $query = new CGI(\*STDIN);
+
+You can also initialize the CGI object with a FileHandle or IO::File
+object.
+
+If you are using the function-oriented interface and want to
+initialize CGI state from a file handle, the way to do this is with
+B<restore_parameters()>. This will (re)initialize the
+default CGI object from the indicated file handle.
+
+ open (IN,"test.in") || die;
+ restore_parameters(IN);
+ close IN;
+
+You can also initialize the query object from a hash
+reference:
+
+ $query = new CGI( {'dinosaur'=>'barney',
+ 'song'=>'I love you',
+ 'friends'=>[qw/Jessica George Nancy/]}
+ );
+
+or from a properly formatted, URL-escaped query string:
+
+ $query = new CGI('dinosaur=barney&color=purple');
+
+or from a previously existing CGI object (currently this clones the
+parameter list, but none of the other object-specific fields, such as
+autoescaping):
+
+ $old_query = new CGI;
+ $new_query = new CGI($old_query);
+
+To create an empty query, initialize it from an empty string or hash:
+
+ $empty_query = new CGI("");
+
+ -or-
+
+ $empty_query = new CGI({});
+
+=head2 FETCHING A LIST OF KEYWORDS FROM THE QUERY:
+
+ @keywords = $query->keywords
+
+If the script was invoked as the result of an <ISINDEX> search, the
+parsed keywords can be obtained as an array using the keywords() method.
+
+=head2 FETCHING THE NAMES OF ALL THE PARAMETERS PASSED TO YOUR SCRIPT:
+
+ @names = $query->param
+
+If the script was invoked with a parameter list
+(e.g. "name1=value1&name2=value2&name3=value3"), the param() method
+will return the parameter names as a list. If the script was invoked
+as an <ISINDEX> script and contains a string without ampersands
+(e.g. "value1+value2+value3") , there will be a single parameter named
+"keywords" containing the "+"-delimited keywords.
+
+NOTE: As of version 1.5, the array of parameter names returned will
+be in the same order as they were submitted by the browser.
+Usually this order is the same as the order in which the
+parameters are defined in the form (however, this isn't part
+of the spec, and so isn't guaranteed).
+
+=head2 FETCHING THE VALUE OR VALUES OF A SINGLE NAMED PARAMETER:
+
+ @values = $query->param('foo');
+
+ -or-
+
+ $value = $query->param('foo');
+
+Pass the param() method a single argument to fetch the value of the
+named parameter. If the parameter is multivalued (e.g. from multiple
+selections in a scrolling list), you can ask to receive an array. Otherwise
+the method will return a single value.
+
+If a value is not given in the query string, as in the queries
+"name1=&name2=", it will be returned as an empty string.
+
+
+If the parameter does not exist at all, then param() will return undef
+in a scalar context, and the empty list in a list context.
+
+
+=head2 SETTING THE VALUE(S) OF A NAMED PARAMETER:
+
+ $query->param('foo','an','array','of','values');
+
+This sets the value for the named parameter 'foo' to an array of
+values. This is one way to change the value of a field AFTER
+the script has been invoked once before. (Another way is with
+the -override parameter accepted by all methods that generate
+form elements.)
+
+param() also recognizes a named parameter style of calling described
+in more detail later:
+
+ $query->param(-name=>'foo',-values=>['an','array','of','values']);
+
+ -or-
+
+ $query->param(-name=>'foo',-value=>'the value');
+
+=head2 APPENDING ADDITIONAL VALUES TO A NAMED PARAMETER:
+
+ $query->append(-name=>'foo',-values=>['yet','more','values']);
+
+This adds a value or list of values to the named parameter. The
+values are appended to the end of the parameter if it already exists.
+Otherwise the parameter is created. Note that this method only
+recognizes the named argument calling syntax.
+
+=head2 IMPORTING ALL PARAMETERS INTO A NAMESPACE:
+
+ $query->import_names('R');
+
+This creates a series of variables in the 'R' namespace. For example,
+$R::foo, @R:foo. For keyword lists, a variable @R::keywords will appear.
+If no namespace is given, this method will assume 'Q'.
+WARNING: don't import anything into 'main'; this is a major security
+risk!!!!
+
+NOTE 1: Variable names are transformed as necessary into legal Perl
+variable names. All non-legal characters are transformed into
+underscores. If you need to keep the original names, you should use
+the param() method instead to access CGI variables by name.
+
+NOTE 2: In older versions, this method was called B<import()>. As of version 2.20,
+this name has been removed completely to avoid conflict with the built-in
+Perl module B<import> operator.
+
+=head2 DELETING A PARAMETER COMPLETELY:
+
+ $query->delete('foo','bar','baz');
+
+This completely clears a list of parameters. It sometimes useful for
+resetting parameters that you don't want passed down between script
+invocations.
+
+If you are using the function call interface, use "Delete()" instead
+to avoid conflicts with Perl's built-in delete operator.
+
+=head2 DELETING ALL PARAMETERS:
+
+ $query->delete_all();
+
+This clears the CGI object completely. It might be useful to ensure
+that all the defaults are taken when you create a fill-out form.
+
+Use Delete_all() instead if you are using the function call interface.
+
+=head2 HANDLING NON-URLENCODED ARGUMENTS
+
+
+If POSTed data is not of type application/x-www-form-urlencoded or
+multipart/form-data, then the POSTed data will not be processed, but
+instead be returned as-is in a parameter named POSTDATA. To retrieve
+it, use code like this:
+
+ my $data = $query->param('POSTDATA');
+
+Likewise if PUTed data can be retrieved with code like this:
+
+ my $data = $query->param('PUTDATA');
+
+(If you don't know what the preceding means, don't worry about it. It
+only affects people trying to use CGI for XML processing and other
+specialized tasks.)
+
+
+=head2 DIRECT ACCESS TO THE PARAMETER LIST:
+
+ $q->param_fetch('address')->[1] = '1313 Mockingbird Lane';
+ unshift @{$q->param_fetch(-name=>'address')},'George Munster';
+
+If you need access to the parameter list in a way that isn't covered
+by the methods above, you can obtain a direct reference to it by
+calling the B<param_fetch()> method with the name of the . This
+will return an array reference to the named parameters, which you then
+can manipulate in any way you like.
+
+You can also use a named argument style using the B<-name> argument.
+
+=head2 FETCHING THE PARAMETER LIST AS A HASH:
+
+ $params = $q->Vars;
+ print $params->{'address'};
+ @foo = split("\0",$params->{'foo'});
+ %params = $q->Vars;
+
+ use CGI ':cgi-lib';
+ $params = Vars;
+
+Many people want to fetch the entire parameter list as a hash in which
+the keys are the names of the CGI parameters, and the values are the
+parameters' values. The Vars() method does this. Called in a scalar
+context, it returns the parameter list as a tied hash reference.
+Changing a key changes the value of the parameter in the underlying
+CGI parameter list. Called in a list context, it returns the
+parameter list as an ordinary hash. This allows you to read the
+contents of the parameter list, but not to change it.
+
+When using this, the thing you must watch out for are multivalued CGI
+parameters. Because a hash cannot distinguish between scalar and
+list context, multivalued parameters will be returned as a packed
+string, separated by the "\0" (null) character. You must split this
+packed string in order to get at the individual values. This is the
+convention introduced long ago by Steve Brenner in his cgi-lib.pl
+module for Perl version 4.
+
+If you wish to use Vars() as a function, import the I<:cgi-lib> set of
+function calls (also see the section on CGI-LIB compatibility).
+
+=head2 SAVING THE STATE OF THE SCRIPT TO A FILE:
+
+ $query->save(\*FILEHANDLE)
+
+This will write the current state of the form to the provided
+filehandle. You can read it back in by providing a filehandle
+to the new() method. Note that the filehandle can be a file, a pipe,
+or whatever!
+
+The format of the saved file is:
+
+ NAME1=VALUE1
+ NAME1=VALUE1'
+ NAME2=VALUE2
+ NAME3=VALUE3
+ =
+
+Both name and value are URL escaped. Multi-valued CGI parameters are
+represented as repeated names. A session record is delimited by a
+single = symbol. You can write out multiple records and read them
+back in with several calls to B<new>. You can do this across several
+sessions by opening the file in append mode, allowing you to create
+primitive guest books, or to keep a history of users' queries. Here's
+a short example of creating multiple session records:
+
+ use CGI;
+
+ open (OUT,">>test.out") || die;
+ $records = 5;
+ for (0..$records) {
+ my $q = new CGI;
+ $q->param(-name=>'counter',-value=>$_);
+ $q->save(\*OUT);
+ }
+ close OUT;
+
+ # reopen for reading
+ open (IN,"test.out") || die;
+ while (!eof(IN)) {
+ my $q = new CGI(\*IN);
+ print $q->param('counter'),"\n";
+ }
+
+The file format used for save/restore is identical to that used by the
+Whitehead Genome Center's data exchange format "Boulderio", and can be
+manipulated and even databased using Boulderio utilities. See
+
+ http://stein.cshl.org/boulder/
+
+for further details.
+
+If you wish to use this method from the function-oriented (non-OO)
+interface, the exported name for this method is B<save_parameters()>.
+
+=head2 RETRIEVING CGI ERRORS
+
+Errors can occur while processing user input, particularly when
+processing uploaded files. When these errors occur, CGI will stop
+processing and return an empty parameter list. You can test for
+the existence and nature of errors using the I<cgi_error()> function.
+The error messages are formatted as HTTP status codes. You can either
+incorporate the error text into an HTML page, or use it as the value
+of the HTTP status:
+
+ my $error = $q->cgi_error;
+ if ($error) {
+ print $q->header(-status=>$error),
+ $q->start_html('Problems'),
+ $q->h2('Request not processed'),
+ $q->strong($error);
+ exit 0;
+ }
+
+When using the function-oriented interface (see the next section),
+errors may only occur the first time you call I<param()>. Be ready
+for this!
+
+=head2 USING THE FUNCTION-ORIENTED INTERFACE
+
+To use the function-oriented interface, you must specify which CGI.pm
+routines or sets of routines to import into your script's namespace.
+There is a small overhead associated with this importation, but it
+isn't much.
+
+ use CGI <list of methods>;
+
+The listed methods will be imported into the current package; you can
+call them directly without creating a CGI object first. This example
+shows how to import the B<param()> and B<header()>
+methods, and then use them directly:
+
+ use CGI 'param','header';
+ print header('text/plain');
+ $zipcode = param('zipcode');
+
+More frequently, you'll import common sets of functions by referring
+to the groups by name. All function sets are preceded with a ":"
+character as in ":html3" (for tags defined in the HTML 3 standard).
+
+Here is a list of the function sets you can import:
+
+=over 4
+
+=item B<:cgi>
+
+Import all CGI-handling methods, such as B<param()>, B<path_info()>
+and the like.
+
+=item B<:form>
+
+Import all fill-out form generating methods, such as B<textfield()>.
+
+=item B<:html2>
+
+Import all methods that generate HTML 2.0 standard elements.
+
+=item B<:html3>
+
+Import all methods that generate HTML 3.0 elements (such as
+<table>, <super> and <sub>).
+
+=item B<:html4>
+
+Import all methods that generate HTML 4 elements (such as
+<abbrev>, <acronym> and <thead>).
+
+=item B<:netscape>
+
+Import all methods that generate Netscape-specific HTML extensions.
+
+=item B<:html>
+
+Import all HTML-generating shortcuts (i.e. 'html2' + 'html3' +
+'netscape')...
+
+=item B<:standard>
+
+Import "standard" features, 'html2', 'html3', 'html4', 'form' and 'cgi'.
+
+=item B<:all>
+
+Import all the available methods. For the full list, see the CGI.pm
+code, where the variable %EXPORT_TAGS is defined.
+
+=back
+
+If you import a function name that is not part of CGI.pm, the module
+will treat it as a new HTML tag and generate the appropriate
+subroutine. You can then use it like any other HTML tag. This is to
+provide for the rapidly-evolving HTML "standard." For example, say
+Microsoft comes out with a new tag called <gradient> (which causes the
+user's desktop to be flooded with a rotating gradient fill until his
+machine reboots). You don't need to wait for a new version of CGI.pm
+to start using it immediately:
+
+ use CGI qw/:standard :html3 gradient/;
+ print gradient({-start=>'red',-end=>'blue'});
+
+Note that in the interests of execution speed CGI.pm does B<not> use
+the standard L<Exporter> syntax for specifying load symbols. This may
+change in the future.
+
+If you import any of the state-maintaining CGI or form-generating
+methods, a default CGI object will be created and initialized
+automatically the first time you use any of the methods that require
+one to be present. This includes B<param()>, B<textfield()>,
+B<submit()> and the like. (If you need direct access to the CGI
+object, you can find it in the global variable B<$CGI::Q>). By
+importing CGI.pm methods, you can create visually elegant scripts:
+
+ use CGI qw/:standard/;
+ print
+ header,
+ start_html('Simple Script'),
+ h1('Simple Script'),
+ start_form,
+ "What's your name? ",textfield('name'),p,
+ "What's the combination?",
+ checkbox_group(-name=>'words',
+ -values=>['eenie','meenie','minie','moe'],
+ -defaults=>['eenie','moe']),p,
+ "What's your favorite color?",
+ popup_menu(-name=>'color',
+ -values=>['red','green','blue','chartreuse']),p,
+ submit,
+ end_form,
+ hr,"\n";
+
+ if (param) {
+ print
+ "Your name is ",em(param('name')),p,
+ "The keywords are: ",em(join(", ",param('words'))),p,
+ "Your favorite color is ",em(param('color')),".\n";
+ }
+ print end_html;
+
+=head2 PRAGMAS
+
+In addition to the function sets, there are a number of pragmas that
+you can import. Pragmas, which are always preceded by a hyphen,
+change the way that CGI.pm functions in various ways. Pragmas,
+function sets, and individual functions can all be imported in the
+same use() line. For example, the following use statement imports the
+standard set of functions and enables debugging mode (pragma
+-debug):
+
+ use CGI qw/:standard -debug/;
+
+The current list of pragmas is as follows:
+
+=over 4
+
+=item -any
+
+When you I<use CGI -any>, then any method that the query object
+doesn't recognize will be interpreted as a new HTML tag. This allows
+you to support the next I<ad hoc> Netscape or Microsoft HTML
+extension. This lets you go wild with new and unsupported tags:
+
+ use CGI qw(-any);
+ $q=new CGI;
+ print $q->gradient({speed=>'fast',start=>'red',end=>'blue'});
+
+Since using <cite>any</cite> causes any mistyped method name
+to be interpreted as an HTML tag, use it with care or not at
+all.
+
+=item -compile
+
+This causes the indicated autoloaded methods to be compiled up front,
+rather than deferred to later. This is useful for scripts that run
+for an extended period of time under FastCGI or mod_perl, and for
+those destined to be crunched by Malcolm Beattie's Perl compiler. Use
+it in conjunction with the methods or method families you plan to use.
+
+ use CGI qw(-compile :standard :html3);
+
+or even
+
+ use CGI qw(-compile :all);
+
+Note that using the -compile pragma in this way will always have
+the effect of importing the compiled functions into the current
+namespace. If you want to compile without importing use the
+compile() method instead:
+
+ use CGI();
+ CGI->compile();
+
+This is particularly useful in a mod_perl environment, in which you
+might want to precompile all CGI routines in a startup script, and
+then import the functions individually in each mod_perl script.
+
+=item -nosticky
+
+By default the CGI module implements a state-preserving behavior
+called "sticky" fields. The way this works is that if you are
+regenerating a form, the methods that generate the form field values
+will interrogate param() to see if similarly-named parameters are
+present in the query string. If they find a like-named parameter, they
+will use it to set their default values.
+
+Sometimes this isn't what you want. The B<-nosticky> pragma prevents
+this behavior. You can also selectively change the sticky behavior in
+each element that you generate.
+
+=item -tabindex
+
+Automatically add tab index attributes to each form field. With this
+option turned off, you can still add tab indexes manually by passing a
+-tabindex option to each field-generating method.
+
+=item -no_undef_params
+
+This keeps CGI.pm from including undef params in the parameter list.
+
+=item -no_xhtml
+
+By default, CGI.pm versions 2.69 and higher emit XHTML
+(http://www.w3.org/TR/xhtml1/). The -no_xhtml pragma disables this
+feature. Thanks to Michalis Kabrianis <kabrianis at hellug.gr> for this
+feature.
+
+If start_html()'s -dtd parameter specifies an HTML 2.0 or 3.2 DTD,
+XHTML will automatically be disabled without needing to use this
+pragma.
+
+=item -utf8
+
+This makes CGI.pm treat all parameters as UTF-8 strings. Use this with
+care, as it will interfere with the processing of binary uploads. It
+is better to manually select which fields are expected to return utf-8
+strings and convert them using code like this:
+
+ use Encode;
+ my $arg = decode utf8=>param('foo');
+
+=item -nph
+
+This makes CGI.pm produce a header appropriate for an NPH (no
+parsed header) script. You may need to do other things as well
+to tell the server that the script is NPH. See the discussion
+of NPH scripts below.
+
+=item -newstyle_urls
+
+Separate the name=value pairs in CGI parameter query strings with
+semicolons rather than ampersands. For example:
+
+ ?name=fred;age=24;favorite_color=3
+
+Semicolon-delimited query strings are always accepted, but will not be
+emitted by self_url() and query_string() unless the -newstyle_urls
+pragma is specified.
+
+This became the default in version 2.64.
+
+=item -oldstyle_urls
+
+Separate the name=value pairs in CGI parameter query strings with
+ampersands rather than semicolons. This is no longer the default.
+
+=item -autoload
+
+This overrides the autoloader so that any function in your program
+that is not recognized is referred to CGI.pm for possible evaluation.
+This allows you to use all the CGI.pm functions without adding them to
+your symbol table, which is of concern for mod_perl users who are
+worried about memory consumption. I<Warning:> when
+I<-autoload> is in effect, you cannot use "poetry mode"
+(functions without the parenthesis). Use I<hr()> rather
+than I<hr>, or add something like I<use subs qw/hr p header/>
+to the top of your script.
+
+=item -no_debug
+
+This turns off the command-line processing features. If you want to
+run a CGI.pm script from the command line to produce HTML, and you
+don't want it to read CGI parameters from the command line or STDIN,
+then use this pragma:
+
+ use CGI qw(-no_debug :standard);
+
+=item -debug
+
+This turns on full debugging. In addition to reading CGI arguments
+from the command-line processing, CGI.pm will pause and try to read
+arguments from STDIN, producing the message "(offline mode: enter
+name=value pairs on standard input)" features.
+
+See the section on debugging for more details.
+
+=item -private_tempfiles
+
+CGI.pm can process uploaded file. Ordinarily it spools the uploaded
+file to a temporary directory, then deletes the file when done.
+However, this opens the risk of eavesdropping as described in the file
+upload section. Another CGI script author could peek at this data
+during the upload, even if it is confidential information. On Unix
+systems, the -private_tempfiles pragma will cause the temporary file
+to be unlinked as soon as it is opened and before any data is written
+into it, reducing, but not eliminating the risk of eavesdropping
+(there is still a potential race condition). To make life harder for
+the attacker, the program chooses tempfile names by calculating a 32
+bit checksum of the incoming HTTP headers.
+
+To ensure that the temporary file cannot be read by other CGI scripts,
+use suEXEC or a CGI wrapper program to run your script. The temporary
+file is created with mode 0600 (neither world nor group readable).
+
+The temporary directory is selected using the following algorithm:
+
+ 1. if the current user (e.g. "nobody") has a directory named
+ "tmp" in its home directory, use that (Unix systems only).
+
+ 2. if the environment variable TMPDIR exists, use the location
+ indicated.
+
+ 3. Otherwise try the locations /usr/tmp, /var/tmp, C:\temp,
+ /tmp, /temp, ::Temporary Items, and \WWW_ROOT.
+
+Each of these locations is checked that it is a directory and is
+writable. If not, the algorithm tries the next choice.
+
+=back
+
+=head2 SPECIAL FORMS FOR IMPORTING HTML-TAG FUNCTIONS
+
+Many of the methods generate HTML tags. As described below, tag
+functions automatically generate both the opening and closing tags.
+For example:
+
+ print h1('Level 1 Header');
+
+produces
+
+ <h1>Level 1 Header</h1>
+
+There will be some times when you want to produce the start and end
+tags yourself. In this case, you can use the form start_I<tag_name>
+and end_I<tag_name>, as in:
+
+ print start_h1,'Level 1 Header',end_h1;
+
+With a few exceptions (described below), start_I<tag_name> and
+end_I<tag_name> functions are not generated automatically when you
+I<use CGI>. However, you can specify the tags you want to generate
+I<start/end> functions for by putting an asterisk in front of their
+name, or, alternatively, requesting either "start_I<tag_name>" or
+"end_I<tag_name>" in the import list.
+
+Example:
+
+ use CGI qw/:standard *table start_ul/;
+
+In this example, the following functions are generated in addition to
+the standard ones:
+
+=over 4
+
+=item 1. start_table() (generates a <table> tag)
+
+=item 2. end_table() (generates a </table> tag)
+
+=item 3. start_ul() (generates a <ul> tag)
+
+=item 4. end_ul() (generates a </ul> tag)
+
+=back
+
+=head1 GENERATING DYNAMIC DOCUMENTS
+
+Most of CGI.pm's functions deal with creating documents on the fly.
+Generally you will produce the HTTP header first, followed by the
+document itself. CGI.pm provides functions for generating HTTP
+headers of various types as well as for generating HTML. For creating
+GIF images, see the GD.pm module.
+
+Each of these functions produces a fragment of HTML or HTTP which you
+can print out directly so that it displays in the browser window,
+append to a string, or save to a file for later use.
+
+=head2 CREATING A STANDARD HTTP HEADER:
+
+Normally the first thing you will do in any CGI script is print out an
+HTTP header. This tells the browser what type of document to expect,
+and gives other optional information, such as the language, expiration
+date, and whether to cache the document. The header can also be
+manipulated for special purposes, such as server push and pay per view
+pages.
+
+ print header;
+
+ -or-
+
+ print header('image/gif');
+
+ -or-
+
+ print header('text/html','204 No response');
+
+ -or-
+
+ print header(-type=>'image/gif',
+ -nph=>1,
+ -status=>'402 Payment required',
+ -expires=>'+3d',
+ -cookie=>$cookie,
+ -charset=>'utf-7',
+ -attachment=>'foo.gif',
+ -Cost=>'$2.00');
+
+header() returns the Content-type: header. You can provide your own
+MIME type if you choose, otherwise it defaults to text/html. An
+optional second parameter specifies the status code and a human-readable
+message. For example, you can specify 204, "No response" to create a
+script that tells the browser to do nothing at all.
+
+The last example shows the named argument style for passing arguments
+to the CGI methods using named parameters. Recognized parameters are
+B<-type>, B<-status>, B<-expires>, and B<-cookie>. Any other named
+parameters will be stripped of their initial hyphens and turned into
+header fields, allowing you to specify any HTTP header you desire.
+Internal underscores will be turned into hyphens:
+
+ print header(-Content_length=>3002);
+
+Most browsers will not cache the output from CGI scripts. Every time
+the browser reloads the page, the script is invoked anew. You can
+change this behavior with the B<-expires> parameter. When you specify
+an absolute or relative expiration interval with this parameter, some
+browsers and proxy servers will cache the script's output until the
+indicated expiration date. The following forms are all valid for the
+-expires field:
+
+ +30s 30 seconds from now
+ +10m ten minutes from now
+ +1h one hour from now
+ -1d yesterday (i.e. "ASAP!")
+ now immediately
+ +3M in three months
+ +10y in ten years time
+ Thursday, 25-Apr-1999 00:40:33 GMT at the indicated time & date
+
+The B<-cookie> parameter generates a header that tells the browser to provide
+a "magic cookie" during all subsequent transactions with your script.
+Netscape cookies have a special format that includes interesting attributes
+such as expiration time. Use the cookie() method to create and retrieve
+session cookies.
+
+The B<-nph> parameter, if set to a true value, will issue the correct
+headers to work with a NPH (no-parse-header) script. This is important
+to use with certain servers that expect all their scripts to be NPH.
+
+The B<-charset> parameter can be used to control the character set
+sent to the browser. If not provided, defaults to ISO-8859-1. As a
+side effect, this sets the charset() method as well.
+
+The B<-attachment> parameter can be used to turn the page into an
+attachment. Instead of displaying the page, some browsers will prompt
+the user to save it to disk. The value of the argument is the
+suggested name for the saved file. In order for this to work, you may
+have to set the B<-type> to "application/octet-stream".
+
+The B<-p3p> parameter will add a P3P tag to the outgoing header. The
+parameter can be an arrayref or a space-delimited string of P3P tags.
+For example:
+
+ print header(-p3p=>[qw(CAO DSP LAW CURa)]);
+ print header(-p3p=>'CAO DSP LAW CURa');
+
+In either case, the outgoing header will be formatted as:
+
+ P3P: policyref="/w3c/p3p.xml" cp="CAO DSP LAW CURa"
+
+=head2 GENERATING A REDIRECTION HEADER
+
+ print redirect('http://somewhere.else/in/movie/land');
+
+Sometimes you don't want to produce a document yourself, but simply
+redirect the browser elsewhere, perhaps choosing a URL based on the
+time of day or the identity of the user.
+
+The redirect() function redirects the browser to a different URL. If
+you use redirection like this, you should B<not> print out a header as
+well.
+
+You should always use full URLs (including the http: or ftp: part) in
+redirection requests. Relative URLs will not work correctly.
+
+You can also use named arguments:
+
+ print redirect(-uri=>'http://somewhere.else/in/movie/land',
+ -nph=>1,
+ -status=>301);
+
+The B<-nph> parameter, if set to a true value, will issue the correct
+headers to work with a NPH (no-parse-header) script. This is important
+to use with certain servers, such as Microsoft IIS, which
+expect all their scripts to be NPH.
+
+The B<-status> parameter will set the status of the redirect. HTTP
+defines three different possible redirection status codes:
+
+ 301 Moved Permanently
+ 302 Found
+ 303 See Other
+
+The default if not specified is 302, which means "moved temporarily."
+You may change the status to another status code if you wish. Be
+advised that changing the status to anything other than 301, 302 or
+303 will probably break redirection.
+
+=head2 CREATING THE HTML DOCUMENT HEADER
+
+ print start_html(-title=>'Secrets of the Pyramids',
+ -author=>'fred at capricorn.org',
+ -base=>'true',
+ -target=>'_blank',
+ -meta=>{'keywords'=>'pharaoh secret mummy',
+ 'copyright'=>'copyright 1996 King Tut'},
+ -style=>{'src'=>'/styles/style1.css'},
+ -BGCOLOR=>'blue');
+
+After creating the HTTP header, most CGI scripts will start writing
+out an HTML document. The start_html() routine creates the top of the
+page, along with a lot of optional information that controls the
+page's appearance and behavior.
+
+This method returns a canned HTML header and the opening <body> tag.
+All parameters are optional. In the named parameter form, recognized
+parameters are -title, -author, -base, -xbase, -dtd, -lang and -target
+(see below for the explanation). Any additional parameters you
+provide, such as the Netscape unofficial BGCOLOR attribute, are added
+to the <body> tag. Additional parameters must be proceeded by a
+hyphen.
+
+The argument B<-xbase> allows you to provide an HREF for the <base> tag
+different from the current location, as in
+
+ -xbase=>"http://home.mcom.com/"
+
+All relative links will be interpreted relative to this tag.
+
+The argument B<-target> allows you to provide a default target frame
+for all the links and fill-out forms on the page. B<This is a
+non-standard HTTP feature which only works with Netscape browsers!>
+See the Netscape documentation on frames for details of how to
+manipulate this.
+
+ -target=>"answer_window"
+
+All relative links will be interpreted relative to this tag.
+You add arbitrary meta information to the header with the B<-meta>
+argument. This argument expects a reference to a hash
+containing name/value pairs of meta information. These will be turned
+into a series of header <meta> tags that look something like this:
+
+ <meta name="keywords" content="pharaoh secret mummy">
+ <meta name="description" content="copyright 1996 King Tut">
+
+To create an HTTP-EQUIV type of <meta> tag, use B<-head>, described
+below.
+
+The B<-style> argument is used to incorporate cascading stylesheets
+into your code. See the section on CASCADING STYLESHEETS for more
+information.
+
+The B<-lang> argument is used to incorporate a language attribute into
+the <html> tag. For example:
+
+ print $q->start_html(-lang=>'fr-CA');
+
+The default if not specified is "en-US" for US English, unless the
+-dtd parameter specifies an HTML 2.0 or 3.2 DTD, in which case the
+lang attribute is left off. You can force the lang attribute to left
+off in other cases by passing an empty string (-lang=>'').
+
+The B<-encoding> argument can be used to specify the character set for
+XHTML. It defaults to iso-8859-1 if not specified.
+
+The B<-declare_xml> argument, when used in conjunction with XHTML,
+will put a <?xml> declaration at the top of the HTML header. The sole
+purpose of this declaration is to declare the character set
+encoding. In the absence of -declare_xml, the output HTML will contain
+a <meta> tag that specifies the encoding, allowing the HTML to pass
+most validators. The default for -declare_xml is false.
+
+You can place other arbitrary HTML elements to the <head> section with the
+B<-head> tag. For example, to place the rarely-used <link> element in the
+head section, use this:
+
+ print start_html(-head=>Link({-rel=>'next',
+ -href=>'http://www.capricorn.com/s2.html'}));
+
+To incorporate multiple HTML elements into the <head> section, just pass an
+array reference:
+
+ print start_html(-head=>[
+ Link({-rel=>'next',
+ -href=>'http://www.capricorn.com/s2.html'}),
+ Link({-rel=>'previous',
+ -href=>'http://www.capricorn.com/s1.html'})
+ ]
+ );
+
+And here's how to create an HTTP-EQUIV <meta> tag:
+
+ print start_html(-head=>meta({-http_equiv => 'Content-Type',
+ -content => 'text/html'}))
+
+
+JAVASCRIPTING: The B<-script>, B<-noScript>, B<-onLoad>,
+B<-onMouseOver>, B<-onMouseOut> and B<-onUnload> parameters are used
+to add Netscape JavaScript calls to your pages. B<-script> should
+point to a block of text containing JavaScript function definitions.
+This block will be placed within a <script> block inside the HTML (not
+HTTP) header. The block is placed in the header in order to give your
+page a fighting chance of having all its JavaScript functions in place
+even if the user presses the stop button before the page has loaded
+completely. CGI.pm attempts to format the script in such a way that
+JavaScript-naive browsers will not choke on the code: unfortunately
+there are some browsers, such as Chimera for Unix, that get confused
+by it nevertheless.
+
+The B<-onLoad> and B<-onUnload> parameters point to fragments of JavaScript
+code to execute when the page is respectively opened and closed by the
+browser. Usually these parameters are calls to functions defined in the
+B<-script> field:
+
+ $query = new CGI;
+ print header;
+ $JSCRIPT=<<END;
+ // Ask a silly question
+ function riddle_me_this() {
+ var r = prompt("What walks on four legs in the morning, " +
+ "two legs in the afternoon, " +
+ "and three legs in the evening?");
+ response(r);
+ }
+ // Get a silly answer
+ function response(answer) {
+ if (answer == "man")
+ alert("Right you are!");
+ else
+ alert("Wrong! Guess again.");
+ }
+ END
+ print start_html(-title=>'The Riddle of the Sphinx',
+ -script=>$JSCRIPT);
+
+Use the B<-noScript> parameter to pass some HTML text that will be displayed on
+browsers that do not have JavaScript (or browsers where JavaScript is turned
+off).
+
+The <script> tag, has several attributes including "type" and src.
+The latter is particularly interesting, as it allows you to keep the
+JavaScript code in a file or CGI script rather than cluttering up each
+page with the source. To use these attributes pass a HASH reference
+in the B<-script> parameter containing one or more of -type, -src, or
+-code:
+
+ print $q->start_html(-title=>'The Riddle of the Sphinx',
+ -script=>{-type=>'JAVASCRIPT',
+ -src=>'/javascript/sphinx.js'}
+ );
+
+ print $q->(-title=>'The Riddle of the Sphinx',
+ -script=>{-type=>'PERLSCRIPT',
+ -code=>'print "hello world!\n;"'}
+ );
+
+
+A final feature allows you to incorporate multiple <script> sections into the
+header. Just pass the list of script sections as an array reference.
+this allows you to specify different source files for different dialects
+of JavaScript. Example:
+
+ print $q->start_html(-title=>'The Riddle of the Sphinx',
+ -script=>[
+ { -type => 'text/javascript',
+ -src => '/javascript/utilities10.js'
+ },
+ { -type => 'text/javascript',
+ -src => '/javascript/utilities11.js'
+ },
+ { -type => 'text/jscript',
+ -src => '/javascript/utilities12.js'
+ },
+ { -type => 'text/ecmascript',
+ -src => '/javascript/utilities219.js'
+ }
+ ]
+ );
+
+The option "-language" is a synonym for -type, and is supported for
+backwad compatibility.
+
+The old-style positional parameters are as follows:
+
+=over 4
+
+=item B<Parameters:>
+
+=item 1.
+
+The title
+
+=item 2.
+
+The author's e-mail address (will create a <link rev="MADE"> tag if present
+
+=item 3.
+
+A 'true' flag if you want to include a <base> tag in the header. This
+helps resolve relative addresses to absolute ones when the document is moved,
+but makes the document hierarchy non-portable. Use with care!
+
+=item 4, 5, 6...
+
+Any other parameters you want to include in the <body> tag. This is a good
+place to put Netscape extensions, such as colors and wallpaper patterns.
+
+=back
+
+=head2 ENDING THE HTML DOCUMENT:
+
+ print end_html
+
+This ends an HTML document by printing the </body></html> tags.
+
+=head2 CREATING A SELF-REFERENCING URL THAT PRESERVES STATE INFORMATION:
+
+ $myself = self_url;
+ print q(<a href="$myself">I'm talking to myself.</a>);
+
+self_url() will return a URL, that, when selected, will reinvoke
+this script with all its state information intact. This is most
+useful when you want to jump around within the document using
+internal anchors but you don't want to disrupt the current contents
+of the form(s). Something like this will do the trick.
+
+ $myself = self_url;
+ print "<a href=\"$myself#table1\">See table 1</a>";
+ print "<a href=\"$myself#table2\">See table 2</a>";
+ print "<a href=\"$myself#yourself\">See for yourself</a>";
+
+If you want more control over what's returned, using the B<url()>
+method instead.
+
+You can also retrieve the unprocessed query string with query_string():
+
+ $the_string = query_string;
+
+=head2 OBTAINING THE SCRIPT'S URL
+
+ $full_url = url();
+ $full_url = url(-full=>1); #alternative syntax
+ $relative_url = url(-relative=>1);
+ $absolute_url = url(-absolute=>1);
+ $url_with_path = url(-path_info=>1);
+ $url_with_path_and_query = url(-path_info=>1,-query=>1);
+ $netloc = url(-base => 1);
+
+B<url()> returns the script's URL in a variety of formats. Called
+without any arguments, it returns the full form of the URL, including
+host name and port number
+
+ http://your.host.com/path/to/script.cgi
+
+You can modify this format with the following named arguments:
+
+=over 4
+
+=item B<-absolute>
+
+If true, produce an absolute URL, e.g.
+
+ /path/to/script.cgi
+
+=item B<-relative>
+
+Produce a relative URL. This is useful if you want to reinvoke your
+script with different parameters. For example:
+
+ script.cgi
+
+=item B<-full>
+
+Produce the full URL, exactly as if called without any arguments.
+This overrides the -relative and -absolute arguments.
+
+=item B<-path> (B<-path_info>)
+
+Append the additional path information to the URL. This can be
+combined with B<-full>, B<-absolute> or B<-relative>. B<-path_info>
+is provided as a synonym.
+
+=item B<-query> (B<-query_string>)
+
+Append the query string to the URL. This can be combined with
+B<-full>, B<-absolute> or B<-relative>. B<-query_string> is provided
+as a synonym.
+
+=item B<-base>
+
+Generate just the protocol and net location, as in http://www.foo.com:8000
+
+=item B<-rewrite>
+
+If Apache's mod_rewrite is turned on, then the script name and path
+info probably won't match the request that the user sent. Set
+-rewrite=>1 (default) to return URLs that match what the user sent
+(the original request URI). Set -rewrite=>0 to return URLs that match
+the URL after mod_rewrite's rules have run. Because the additional
+path information only makes sense in the context of the rewritten URL,
+-rewrite is set to false when you request path info in the URL.
+
+=back
+
+=head2 MIXING POST AND URL PARAMETERS
+
+ $color = url_param('color');
+
+It is possible for a script to receive CGI parameters in the URL as
+well as in the fill-out form by creating a form that POSTs to a URL
+containing a query string (a "?" mark followed by arguments). The
+B<param()> method will always return the contents of the POSTed
+fill-out form, ignoring the URL's query string. To retrieve URL
+parameters, call the B<url_param()> method. Use it in the same way as
+B<param()>. The main difference is that it allows you to read the
+parameters, but not set them.
+
+
+Under no circumstances will the contents of the URL query string
+interfere with similarly-named CGI parameters in POSTed forms. If you
+try to mix a URL query string with a form submitted with the GET
+method, the results will not be what you expect.
+
+=head1 CREATING STANDARD HTML ELEMENTS:
+
+CGI.pm defines general HTML shortcut methods for most, if not all of
+the HTML 3 and HTML 4 tags. HTML shortcuts are named after a single
+HTML element and return a fragment of HTML text that you can then
+print or manipulate as you like. Each shortcut returns a fragment of
+HTML code that you can append to a string, save to a file, or, most
+commonly, print out so that it displays in the browser window.
+
+This example shows how to use the HTML methods:
+
+ print $q->blockquote(
+ "Many years ago on the island of",
+ $q->a({href=>"http://crete.org/"},"Crete"),
+ "there lived a Minotaur named",
+ $q->strong("Fred."),
+ ),
+ $q->hr;
+
+This results in the following HTML code (extra newlines have been
+added for readability):
+
+ <blockquote>
+ Many years ago on the island of
+ <a href="http://crete.org/">Crete</a> there lived
+ a minotaur named <strong>Fred.</strong>
+ </blockquote>
+ <hr>
+
+If you find the syntax for calling the HTML shortcuts awkward, you can
+import them into your namespace and dispense with the object syntax
+completely (see the next section for more details):
+
+ use CGI ':standard';
+ print blockquote(
+ "Many years ago on the island of",
+ a({href=>"http://crete.org/"},"Crete"),
+ "there lived a minotaur named",
+ strong("Fred."),
+ ),
+ hr;
+
+=head2 PROVIDING ARGUMENTS TO HTML SHORTCUTS
+
+The HTML methods will accept zero, one or multiple arguments. If you
+provide no arguments, you get a single tag:
+
+ print hr; # <hr>
+
+If you provide one or more string arguments, they are concatenated
+together with spaces and placed between opening and closing tags:
+
+ print h1("Chapter","1"); # <h1>Chapter 1</h1>"
+
+If the first argument is a hash reference, then the keys
+and values of the hash become the HTML tag's attributes:
+
+ print a({-href=>'fred.html',-target=>'_new'},
+ "Open a new frame");
+
+ <a href="fred.html",target="_new">Open a new frame</a>
+
+You may dispense with the dashes in front of the attribute names if
+you prefer:
+
+ print img {src=>'fred.gif',align=>'LEFT'};
+
+ <img align="LEFT" src="fred.gif">
+
+Sometimes an HTML tag attribute has no argument. For example, ordered
+lists can be marked as COMPACT. The syntax for this is an argument that
+that points to an undef string:
+
+ print ol({compact=>undef},li('one'),li('two'),li('three'));
+
+Prior to CGI.pm version 2.41, providing an empty ('') string as an
+attribute argument was the same as providing undef. However, this has
+changed in order to accommodate those who want to create tags of the form
+<img alt="">. The difference is shown in these two pieces of code:
+
+ CODE RESULT
+ img({alt=>undef}) <img alt>
+ img({alt=>''}) <img alt="">
+
+=head2 THE DISTRIBUTIVE PROPERTY OF HTML SHORTCUTS
+
+One of the cool features of the HTML shortcuts is that they are
+distributive. If you give them an argument consisting of a
+B<reference> to a list, the tag will be distributed across each
+element of the list. For example, here's one way to make an ordered
+list:
+
+ print ul(
+ li({-type=>'disc'},['Sneezy','Doc','Sleepy','Happy'])
+ );
+
+This example will result in HTML output that looks like this:
+
+ <ul>
+ <li type="disc">Sneezy</li>
+ <li type="disc">Doc</li>
+ <li type="disc">Sleepy</li>
+ <li type="disc">Happy</li>
+ </ul>
+
+This is extremely useful for creating tables. For example:
+
+ print table({-border=>undef},
+ caption('When Should You Eat Your Vegetables?'),
+ Tr({-align=>CENTER,-valign=>TOP},
+ [
+ th(['Vegetable', 'Breakfast','Lunch','Dinner']),
+ td(['Tomatoes' , 'no', 'yes', 'yes']),
+ td(['Broccoli' , 'no', 'no', 'yes']),
+ td(['Onions' , 'yes','yes', 'yes'])
+ ]
+ )
+ );
+
+=head2 HTML SHORTCUTS AND LIST INTERPOLATION
+
+Consider this bit of code:
+
+ print blockquote(em('Hi'),'mom!'));
+
+It will ordinarily return the string that you probably expect, namely:
+
+ <blockquote><em>Hi</em> mom!</blockquote>
+
+Note the space between the element "Hi" and the element "mom!".
+CGI.pm puts the extra space there using array interpolation, which is
+controlled by the magic $" variable. Sometimes this extra space is
+not what you want, for example, when you are trying to align a series
+of images. In this case, you can simply change the value of $" to an
+empty string.
+
+ {
+ local($") = '';
+ print blockquote(em('Hi'),'mom!'));
+ }
+
+I suggest you put the code in a block as shown here. Otherwise the
+change to $" will affect all subsequent code until you explicitly
+reset it.
+
+=head2 NON-STANDARD HTML SHORTCUTS
+
+A few HTML tags don't follow the standard pattern for various
+reasons.
+
+B<comment()> generates an HTML comment (<!-- comment -->). Call it
+like
+
+ print comment('here is my comment');
+
+Because of conflicts with built-in Perl functions, the following functions
+begin with initial caps:
+
+ Select
+ Tr
+ Link
+ Delete
+ Accept
+ Sub
+
+In addition, start_html(), end_html(), start_form(), end_form(),
+start_multipart_form() and all the fill-out form tags are special.
+See their respective sections.
+
+=head2 AUTOESCAPING HTML
+
+By default, all HTML that is emitted by the form-generating functions
+is passed through a function called escapeHTML():
+
+=over 4
+
+=item $escaped_string = escapeHTML("unescaped string");
+
+Escape HTML formatting characters in a string.
+
+=back
+
+Provided that you have specified a character set of ISO-8859-1 (the
+default), the standard HTML escaping rules will be used. The "<"
+character becomes "<", ">" becomes ">", "&" becomes "&", and
+the quote character becomes """. In addition, the hexadecimal
+0x8b and 0x9b characters, which some browsers incorrectly interpret
+as the left and right angle-bracket characters, are replaced by their
+numeric character entities ("‹" and "›"). If you manually change
+the charset, either by calling the charset() method explicitly or by
+passing a -charset argument to header(), then B<all> characters will
+be replaced by their numeric entities, since CGI.pm has no lookup
+table for all the possible encodings.
+
+The automatic escaping does not apply to other shortcuts, such as
+h1(). You should call escapeHTML() yourself on untrusted data in
+order to protect your pages against nasty tricks that people may enter
+into guestbooks, etc.. To change the character set, use charset().
+To turn autoescaping off completely, use autoEscape(0):
+
+=over 4
+
+=item $charset = charset([$charset]);
+
+Get or set the current character set.
+
+=item $flag = autoEscape([$flag]);
+
+Get or set the value of the autoescape flag.
+
+=back
+
+=head2 PRETTY-PRINTING HTML
+
+By default, all the HTML produced by these functions comes out as one
+long line without carriage returns or indentation. This is yuck, but
+it does reduce the size of the documents by 10-20%. To get
+pretty-printed output, please use L<CGI::Pretty>, a subclass
+contributed by Brian Paulsen.
+
+=head1 CREATING FILL-OUT FORMS:
+
+I<General note> The various form-creating methods all return strings
+to the caller, containing the tag or tags that will create the requested
+form element. You are responsible for actually printing out these strings.
+It's set up this way so that you can place formatting tags
+around the form elements.
+
+I<Another note> The default values that you specify for the forms are only
+used the B<first> time the script is invoked (when there is no query
+string). On subsequent invocations of the script (when there is a query
+string), the former values are used even if they are blank.
+
+If you want to change the value of a field from its previous value, you have two
+choices:
+
+(1) call the param() method to set it.
+
+(2) use the -override (alias -force) parameter (a new feature in version 2.15).
+This forces the default value to be used, regardless of the previous value:
+
+ print textfield(-name=>'field_name',
+ -default=>'starting value',
+ -override=>1,
+ -size=>50,
+ -maxlength=>80);
+
+I<Yet another note> By default, the text and labels of form elements are
+escaped according to HTML rules. This means that you can safely use
+"<CLICK ME>" as the label for a button. However, it also interferes with
+your ability to incorporate special HTML character sequences, such as Á,
+into your fields. If you wish to turn off automatic escaping, call the
+autoEscape() method with a false value immediately after creating the CGI object:
+
+ $query = new CGI;
+ autoEscape(undef);
+
+I<A Lurking Trap!> Some of the form-element generating methods return
+multiple tags. In a scalar context, the tags will be concatenated
+together with spaces, or whatever is the current value of the $"
+global. In a list context, the methods will return a list of
+elements, allowing you to modify them if you wish. Usually you will
+not notice this behavior, but beware of this:
+
+ printf("%s\n",end_form())
+
+end_form() produces several tags, and only the first of them will be
+printed because the format only expects one value.
+
+<p>
+
+
+=head2 CREATING AN ISINDEX TAG
+
+ print isindex(-action=>$action);
+
+ -or-
+
+ print isindex($action);
+
+Prints out an <isindex> tag. Not very exciting. The parameter
+-action specifies the URL of the script to process the query. The
+default is to process the query with the current script.
+
+=head2 STARTING AND ENDING A FORM
+
+ print start_form(-method=>$method,
+ -action=>$action,
+ -enctype=>$encoding);
+ <... various form stuff ...>
+ print endform;
+
+ -or-
+
+ print start_form($method,$action,$encoding);
+ <... various form stuff ...>
+ print endform;
+
+start_form() will return a <form> tag with the optional method,
+action and form encoding that you specify. The defaults are:
+
+ method: POST
+ action: this script
+ enctype: application/x-www-form-urlencoded
+
+endform() returns the closing </form> tag.
+
+Start_form()'s enctype argument tells the browser how to package the various
+fields of the form before sending the form to the server. Two
+values are possible:
+
+B<Note:> This method was previously named startform(), and startform()
+is still recognized as an alias.
+
+=over 4
+
+=item B<application/x-www-form-urlencoded>
+
+This is the older type of encoding used by all browsers prior to
+Netscape 2.0. It is compatible with many CGI scripts and is
+suitable for short fields containing text data. For your
+convenience, CGI.pm stores the name of this encoding
+type in B<&CGI::URL_ENCODED>.
+
+=item B<multipart/form-data>
+
+This is the newer type of encoding introduced by Netscape 2.0.
+It is suitable for forms that contain very large fields or that
+are intended for transferring binary data. Most importantly,
+it enables the "file upload" feature of Netscape 2.0 forms. For
+your convenience, CGI.pm stores the name of this encoding type
+in B<&CGI::MULTIPART>
+
+Forms that use this type of encoding are not easily interpreted
+by CGI scripts unless they use CGI.pm or another library designed
+to handle them.
+
+If XHTML is activated (the default), then forms will be automatically
+created using this type of encoding.
+
+=back
+
+For compatibility, the start_form() method uses the older form of
+encoding by default. If you want to use the newer form of encoding
+by default, you can call B<start_multipart_form()> instead of
+B<start_form()>.
+
+JAVASCRIPTING: The B<-name> and B<-onSubmit> parameters are provided
+for use with JavaScript. The -name parameter gives the
+form a name so that it can be identified and manipulated by
+JavaScript functions. -onSubmit should point to a JavaScript
+function that will be executed just before the form is submitted to your
+server. You can use this opportunity to check the contents of the form
+for consistency and completeness. If you find something wrong, you
+can put up an alert box or maybe fix things up yourself. You can
+abort the submission by returning false from this function.
+
+Usually the bulk of JavaScript functions are defined in a <script>
+block in the HTML header and -onSubmit points to one of these function
+call. See start_html() for details.
+
+=head2 FORM ELEMENTS
+
+After starting a form, you will typically create one or more
+textfields, popup menus, radio groups and other form elements. Each
+of these elements takes a standard set of named arguments. Some
+elements also have optional arguments. The standard arguments are as
+follows:
+
+=over 4
+
+=item B<-name>
+
+The name of the field. After submission this name can be used to
+retrieve the field's value using the param() method.
+
+=item B<-value>, B<-values>
+
+The initial value of the field which will be returned to the script
+after form submission. Some form elements, such as text fields, take
+a single scalar -value argument. Others, such as popup menus, take a
+reference to an array of values. The two arguments are synonyms.
+
+=item B<-tabindex>
+
+A numeric value that sets the order in which the form element receives
+focus when the user presses the tab key. Elements with lower values
+receive focus first.
+
+=item B<-id>
+
+A string identifier that can be used to identify this element to
+JavaScript and DHTML.
+
+=item B<-override>
+
+A boolean, which, if true, forces the element to take on the value
+specified by B<-value>, overriding the sticky behavior described
+earlier for the B<-no_sticky> pragma.
+
+=item B<-onChange>, B<-onFocus>, B<-onBlur>, B<-onMouseOver>, B<-onMouseOut>, B<-onSelect>
+
+These are used to assign JavaScript event handlers. See the
+JavaScripting section for more details.
+
+=back
+
+Other common arguments are described in the next section. In addition
+to these, all attributes described in the HTML specifications are
+supported.
+
+=head2 CREATING A TEXT FIELD
+
+ print textfield(-name=>'field_name',
+ -value=>'starting value',
+ -size=>50,
+ -maxlength=>80);
+ -or-
+
+ print textfield('field_name','starting value',50,80);
+
+textfield() will return a text input field.
+
+=over 4
+
+=item B<Parameters>
+
+=item 1.
+
+The first parameter is the required name for the field (-name).
+
+=item 2.
+
+The optional second parameter is the default starting value for the field
+contents (-value, formerly known as -default).
+
+=item 3.
+
+The optional third parameter is the size of the field in
+ characters (-size).
+
+=item 4.
+
+The optional fourth parameter is the maximum number of characters the
+ field will accept (-maxlength).
+
+=back
+
+As with all these methods, the field will be initialized with its
+previous contents from earlier invocations of the script.
+When the form is processed, the value of the text field can be
+retrieved with:
+
+ $value = param('foo');
+
+If you want to reset it from its initial value after the script has been
+called once, you can do so like this:
+
+ param('foo',"I'm taking over this value!");
+
+=head2 CREATING A BIG TEXT FIELD
+
+ print textarea(-name=>'foo',
+ -default=>'starting value',
+ -rows=>10,
+ -columns=>50);
+
+ -or
+
+ print textarea('foo','starting value',10,50);
+
+textarea() is just like textfield, but it allows you to specify
+rows and columns for a multiline text entry box. You can provide
+a starting value for the field, which can be long and contain
+multiple lines.
+
+=head2 CREATING A PASSWORD FIELD
+
+ print password_field(-name=>'secret',
+ -value=>'starting value',
+ -size=>50,
+ -maxlength=>80);
+ -or-
+
+ print password_field('secret','starting value',50,80);
+
+password_field() is identical to textfield(), except that its contents
+will be starred out on the web page.
+
+=head2 CREATING A FILE UPLOAD FIELD
+
+ print filefield(-name=>'uploaded_file',
+ -default=>'starting value',
+ -size=>50,
+ -maxlength=>80);
+ -or-
+
+ print filefield('uploaded_file','starting value',50,80);
+
+filefield() will return a file upload field for Netscape 2.0 browsers.
+In order to take full advantage of this I<you must use the new
+multipart encoding scheme> for the form. You can do this either
+by calling B<start_form()> with an encoding type of B<&CGI::MULTIPART>,
+or by calling the new method B<start_multipart_form()> instead of
+vanilla B<start_form()>.
+
+=over 4
+
+=item B<Parameters>
+
+=item 1.
+
+The first parameter is the required name for the field (-name).
+
+=item 2.
+
+The optional second parameter is the starting value for the field contents
+to be used as the default file name (-default).
+
+For security reasons, browsers don't pay any attention to this field,
+and so the starting value will always be blank. Worse, the field
+loses its "sticky" behavior and forgets its previous contents. The
+starting value field is called for in the HTML specification, however,
+and possibly some browser will eventually provide support for it.
+
+=item 3.
+
+The optional third parameter is the size of the field in
+characters (-size).
+
+=item 4.
+
+The optional fourth parameter is the maximum number of characters the
+field will accept (-maxlength).
+
+=back
+
+When the form is processed, you can retrieve the entered filename
+by calling param():
+
+ $filename = param('uploaded_file');
+
+Different browsers will return slightly different things for the
+name. Some browsers return the filename only. Others return the full
+path to the file, using the path conventions of the user's machine.
+Regardless, the name returned is always the name of the file on the
+I<user's> machine, and is unrelated to the name of the temporary file
+that CGI.pm creates during upload spooling (see below).
+
+The filename returned is also a file handle. You can read the contents
+of the file using standard Perl file reading calls:
+
+ # Read a text file and print it out
+ while (<$filename>) {
+ print;
+ }
+
+ # Copy a binary file to somewhere safe
+ open (OUTFILE,">>/usr/local/web/users/feedback");
+ while ($bytesread=read($filename,$buffer,1024)) {
+ print OUTFILE $buffer;
+ }
+
+However, there are problems with the dual nature of the upload fields.
+If you C<use strict>, then Perl will complain when you try to use a
+string as a filehandle. You can get around this by placing the file
+reading code in a block containing the C<no strict> pragma. More
+seriously, it is possible for the remote user to type garbage into the
+upload field, in which case what you get from param() is not a
+filehandle at all, but a string.
+
+To be safe, use the I<upload()> function (new in version 2.47). When
+called with the name of an upload field, I<upload()> returns a
+filehandle-like object, or undef if the parameter is not a valid
+filehandle.
+
+ $fh = upload('uploaded_file');
+ while (<$fh>) {
+ print;
+ }
+
+In a list context, upload() will return an array of filehandles.
+This makes it possible to create forms that use the same name for
+multiple upload fields.
+
+This is the recommended idiom.
+
+The lightweight filehandle returned by CGI.pm is not compatible with
+IO::Handle; for example, it does not have read() or getline()
+functions, but instead must be manipulated using read($fh) or
+<$fh>. To get a compatible IO::Handle object, call the handle's
+handle() method:
+
+ my $real_io_handle = upload('uploaded_file')->handle;
+
+When a file is uploaded the browser usually sends along some
+information along with it in the format of headers. The information
+usually includes the MIME content type. Future browsers may send
+other information as well (such as modification date and size). To
+retrieve this information, call uploadInfo(). It returns a reference to
+a hash containing all the document headers.
+
+ $filename = param('uploaded_file');
+ $type = uploadInfo($filename)->{'Content-Type'};
+ unless ($type eq 'text/html') {
+ die "HTML FILES ONLY!";
+ }
+
+If you are using a machine that recognizes "text" and "binary" data
+modes, be sure to understand when and how to use them (see the Camel book).
+Otherwise you may find that binary files are corrupted during file
+uploads.
+
+There are occasionally problems involving parsing the uploaded file.
+This usually happens when the user presses "Stop" before the upload is
+finished. In this case, CGI.pm will return undef for the name of the
+uploaded file and set I<cgi_error()> to the string "400 Bad request
+(malformed multipart POST)". This error message is designed so that
+you can incorporate it into a status code to be sent to the browser.
+Example:
+
+ $file = upload('uploaded_file');
+ if (!$file && cgi_error) {
+ print header(-status=>cgi_error);
+ exit 0;
+ }
+
+You are free to create a custom HTML page to complain about the error,
+if you wish.
+
+You can set up a callback that will be called whenever a file upload
+is being read during the form processing. This is much like the
+UPLOAD_HOOK facility available in Apache::Request, with the exception
+that the first argument to the callback is an Apache::Upload object,
+here it's the remote filename.
+
+ $q = CGI->new(\&hook [,$data [,$use_tempfile]]);
+
+ sub hook
+ {
+ my ($filename, $buffer, $bytes_read, $data) = @_;
+ print "Read $bytes_read bytes of $filename\n";
+ }
+
+The $data field is optional; it lets you pass configuration
+information (e.g. a database handle) to your hook callback.
+
+The $use_tempfile field is a flag that lets you turn on and off
+CGI.pm's use of a temporary disk-based file during file upload. If you
+set this to a FALSE value (default true) then param('uploaded_file')
+will no longer work, and the only way to get at the uploaded data is
+via the hook you provide.
+
+If using the function-oriented interface, call the CGI::upload_hook()
+method before calling param() or any other CGI functions:
+
+ CGI::upload_hook(\&hook [,$data [,$use_tempfile]]);
+
+This method is not exported by default. You will have to import it
+explicitly if you wish to use it without the CGI:: prefix.
+
+If you are using CGI.pm on a Windows platform and find that binary
+files get slightly larger when uploaded but that text files remain the
+same, then you have forgotten to activate binary mode on the output
+filehandle. Be sure to call binmode() on any handle that you create
+to write the uploaded file to disk.
+
+JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>,
+B<-onMouseOver>, B<-onMouseOut> and B<-onSelect> parameters are
+recognized. See textfield() for details.
+
+=head2 CREATING A POPUP MENU
+
+ print popup_menu('menu_name',
+ ['eenie','meenie','minie'],
+ 'meenie');
+
+ -or-
+
+ %labels = ('eenie'=>'your first choice',
+ 'meenie'=>'your second choice',
+ 'minie'=>'your third choice');
+ %attributes = ('eenie'=>{'class'=>'class of first choice'});
+ print popup_menu('menu_name',
+ ['eenie','meenie','minie'],
+ 'meenie',\%labels,\%attributes);
+
+ -or (named parameter style)-
+
+ print popup_menu(-name=>'menu_name',
+ -values=>['eenie','meenie','minie'],
+ -default=>['meenie','minie'],
+ -labels=>\%labels,
+ -attributes=>\%attributes);
+
+popup_menu() creates a menu.
+
+=over 4
+
+=item 1.
+
+The required first argument is the menu's name (-name).
+
+=item 2.
+
+The required second argument (-values) is an array B<reference>
+containing the list of menu items in the menu. You can pass the
+method an anonymous array, as shown in the example, or a reference to
+a named array, such as "\@foo".
+
+=item 3.
+
+The optional third parameter (-default) is the name of the default
+menu choice. If not specified, the first item will be the default.
+The values of the previous choice will be maintained across
+queries. Pass an array reference to select multiple defaults.
+
+=item 4.
+
+The optional fourth parameter (-labels) is provided for people who
+want to use different values for the user-visible label inside the
+popup menu and the value returned to your script. It's a pointer to an
+hash relating menu values to user-visible labels. If you
+leave this parameter blank, the menu values will be displayed by
+default. (You can also leave a label undefined if you want to).
+
+=item 5.
+
+The optional fifth parameter (-attributes) is provided to assign
+any of the common HTML attributes to an individual menu item. It's
+a pointer to a hash relating menu values to another
+hash with the attribute's name as the key and the
+attribute's value as the value.
+
+=back
+
+When the form is processed, the selected value of the popup menu can
+be retrieved using:
+
+ $popup_menu_value = param('menu_name');
+
+=head2 CREATING AN OPTION GROUP
+
+Named parameter style
+
+ print popup_menu(-name=>'menu_name',
+ -values=>[qw/eenie meenie minie/,
+ optgroup(-name=>'optgroup_name',
+ -values => ['moe','catch'],
+ -attributes=>{'catch'=>{'class'=>'red'}})],
+ -labels=>{'eenie'=>'one',
+ 'meenie'=>'two',
+ 'minie'=>'three'},
+ -default=>'meenie');
+
+ Old style
+ print popup_menu('menu_name',
+ ['eenie','meenie','minie',
+ optgroup('optgroup_name', ['moe', 'catch'],
+ {'catch'=>{'class'=>'red'}})],'meenie',
+ {'eenie'=>'one','meenie'=>'two','minie'=>'three'});
+
+optgroup() creates an option group within a popup menu.
+
+=over 4
+
+=item 1.
+
+The required first argument (B<-name>) is the label attribute of the
+optgroup and is B<not> inserted in the parameter list of the query.
+
+=item 2.
+
+The required second argument (B<-values>) is an array reference
+containing the list of menu items in the menu. You can pass the
+method an anonymous array, as shown in the example, or a reference
+to a named array, such as \@foo. If you pass a HASH reference,
+the keys will be used for the menu values, and the values will be
+used for the menu labels (see -labels below).
+
+=item 3.
+
+The optional third parameter (B<-labels>) allows you to pass a reference
+to a hash containing user-visible labels for one or more
+of the menu items. You can use this when you want the user to see one
+menu string, but have the browser return your program a different one.
+If you don't specify this, the value string will be used instead
+("eenie", "meenie" and "minie" in this example). This is equivalent
+to using a hash reference for the -values parameter.
+
+=item 4.
+
+An optional fourth parameter (B<-labeled>) can be set to a true value
+and indicates that the values should be used as the label attribute
+for each option element within the optgroup.
+
+=item 5.
+
+An optional fifth parameter (-novals) can be set to a true value and
+indicates to suppress the val attribute in each option element within
+the optgroup.
+
+See the discussion on optgroup at W3C
+(http://www.w3.org/TR/REC-html40/interact/forms.html#edef-OPTGROUP)
+for details.
+
+=item 6.
+
+An optional sixth parameter (-attributes) is provided to assign
+any of the common HTML attributes to an individual menu item. It's
+a pointer to a hash relating menu values to another
+hash with the attribute's name as the key and the
+attribute's value as the value.
+
+=back
+
+=head2 CREATING A SCROLLING LIST
+
+ print scrolling_list('list_name',
+ ['eenie','meenie','minie','moe'],
+ ['eenie','moe'],5,'true',{'moe'=>{'class'=>'red'}});
+ -or-
+
+ print scrolling_list('list_name',
+ ['eenie','meenie','minie','moe'],
+ ['eenie','moe'],5,'true',
+ \%labels,%attributes);
+
+ -or-
+
+ print scrolling_list(-name=>'list_name',
+ -values=>['eenie','meenie','minie','moe'],
+ -default=>['eenie','moe'],
+ -size=>5,
+ -multiple=>'true',
+ -labels=>\%labels,
+ -attributes=>\%attributes);
+
+scrolling_list() creates a scrolling list.
+
+=over 4
+
+=item B<Parameters:>
+
+=item 1.
+
+The first and second arguments are the list name (-name) and values
+(-values). As in the popup menu, the second argument should be an
+array reference.
+
+=item 2.
+
+The optional third argument (-default) can be either a reference to a
+list containing the values to be selected by default, or can be a
+single value to select. If this argument is missing or undefined,
+then nothing is selected when the list first appears. In the named
+parameter version, you can use the synonym "-defaults" for this
+parameter.
+
+=item 3.
+
+The optional fourth argument is the size of the list (-size).
+
+=item 4.
+
+The optional fifth argument can be set to true to allow multiple
+simultaneous selections (-multiple). Otherwise only one selection
+will be allowed at a time.
+
+=item 5.
+
+The optional sixth argument is a pointer to a hash
+containing long user-visible labels for the list items (-labels).
+If not provided, the values will be displayed.
+
+=item 6.
+
+The optional sixth parameter (-attributes) is provided to assign
+any of the common HTML attributes to an individual menu item. It's
+a pointer to a hash relating menu values to another
+hash with the attribute's name as the key and the
+attribute's value as the value.
+
+When this form is processed, all selected list items will be returned as
+a list under the parameter name 'list_name'. The values of the
+selected items can be retrieved with:
+
+ @selected = param('list_name');
+
+=back
+
+=head2 CREATING A GROUP OF RELATED CHECKBOXES
+
+ print checkbox_group(-name=>'group_name',
+ -values=>['eenie','meenie','minie','moe'],
+ -default=>['eenie','moe'],
+ -linebreak=>'true',
+ -disabled => ['moe'],
+ -labels=>\%labels,
+ -attributes=>\%attributes);
+
+ print checkbox_group('group_name',
+ ['eenie','meenie','minie','moe'],
+ ['eenie','moe'],'true',\%labels,
+ {'moe'=>{'class'=>'red'}});
+
+ HTML3-COMPATIBLE BROWSERS ONLY:
+
+ print checkbox_group(-name=>'group_name',
+ -values=>['eenie','meenie','minie','moe'],
+ -rows=2,-columns=>2);
+
+
+checkbox_group() creates a list of checkboxes that are related
+by the same name.
+
+=over 4
+
+=item B<Parameters:>
+
+=item 1.
+
+The first and second arguments are the checkbox name and values,
+respectively (-name and -values). As in the popup menu, the second
+argument should be an array reference. These values are used for the
+user-readable labels printed next to the checkboxes as well as for the
+values passed to your script in the query string.
+
+=item 2.
+
+The optional third argument (-default) can be either a reference to a
+list containing the values to be checked by default, or can be a
+single value to checked. If this argument is missing or undefined,
+then nothing is selected when the list first appears.
+
+=item 3.
+
+The optional fourth argument (-linebreak) can be set to true to place
+line breaks between the checkboxes so that they appear as a vertical
+list. Otherwise, they will be strung together on a horizontal line.
+
+=back
+
+
+The optional B<-labels> argument is a pointer to a hash
+relating the checkbox values to the user-visible labels that will be
+printed next to them. If not provided, the values will be used as the
+default.
+
+
+The optional parameters B<-rows>, and B<-columns> cause
+checkbox_group() to return an HTML3 compatible table containing the
+checkbox group formatted with the specified number of rows and
+columns. You can provide just the -columns parameter if you wish;
+checkbox_group will calculate the correct number of rows for you.
+
+The option B<-disabled> takes an array of checkbox values and disables
+them by greying them out (this may not be supported by all browsers).
+
+The optional B<-attributes> argument is provided to assign any of the
+common HTML attributes to an individual menu item. It's a pointer to
+a hash relating menu values to another hash
+with the attribute's name as the key and the attribute's value as the
+value.
+
+The optional B<-tabindex> argument can be used to control the order in which
+radio buttons receive focus when the user presses the tab button. If
+passed a scalar numeric value, the first element in the group will
+receive this tab index and subsequent elements will be incremented by
+one. If given a reference to an array of radio button values, then
+the indexes will be jiggered so that the order specified in the array
+will correspond to the tab order. You can also pass a reference to a
+hash in which the hash keys are the radio button values and the values
+are the tab indexes of each button. Examples:
+
+ -tabindex => 100 # this group starts at index 100 and counts up
+ -tabindex => ['moe','minie','eenie','meenie'] # tab in this order
+ -tabindex => {meenie=>100,moe=>101,minie=>102,eenie=>200} # tab in this order
+
+The optional B<-labelattributes> argument will contain attributes
+attached to the <label> element that surrounds each button.
+
+When the form is processed, all checked boxes will be returned as
+a list under the parameter name 'group_name'. The values of the
+"on" checkboxes can be retrieved with:
+
+ @turned_on = param('group_name');
+
+The value returned by checkbox_group() is actually an array of button
+elements. You can capture them and use them within tables, lists,
+or in other creative ways:
+
+ @h = checkbox_group(-name=>'group_name',-values=>\@values);
+ &use_in_creative_way(@h);
+
+=head2 CREATING A STANDALONE CHECKBOX
+
+ print checkbox(-name=>'checkbox_name',
+ -checked=>1,
+ -value=>'ON',
+ -label=>'CLICK ME');
+
+ -or-
+
+ print checkbox('checkbox_name','checked','ON','CLICK ME');
+
+checkbox() is used to create an isolated checkbox that isn't logically
+related to any others.
+
+=over 4
+
+=item B<Parameters:>
+
+=item 1.
+
+The first parameter is the required name for the checkbox (-name). It
+will also be used for the user-readable label printed next to the
+checkbox.
+
+=item 2.
+
+The optional second parameter (-checked) specifies that the checkbox
+is turned on by default. Synonyms are -selected and -on.
+
+=item 3.
+
+The optional third parameter (-value) specifies the value of the
+checkbox when it is checked. If not provided, the word "on" is
+assumed.
+
+=item 4.
+
+The optional fourth parameter (-label) is the user-readable label to
+be attached to the checkbox. If not provided, the checkbox name is
+used.
+
+=back
+
+The value of the checkbox can be retrieved using:
+
+ $turned_on = param('checkbox_name');
+
+=head2 CREATING A RADIO BUTTON GROUP
+
+ print radio_group(-name=>'group_name',
+ -values=>['eenie','meenie','minie'],
+ -default=>'meenie',
+ -linebreak=>'true',
+ -labels=>\%labels,
+ -attributes=>\%attributes);
+
+ -or-
+
+ print radio_group('group_name',['eenie','meenie','minie'],
+ 'meenie','true',\%labels,\%attributes);
+
+
+ HTML3-COMPATIBLE BROWSERS ONLY:
+
+ print radio_group(-name=>'group_name',
+ -values=>['eenie','meenie','minie','moe'],
+ -rows=2,-columns=>2);
+
+radio_group() creates a set of logically-related radio buttons
+(turning one member of the group on turns the others off)
+
+=over 4
+
+=item B<Parameters:>
+
+=item 1.
+
+The first argument is the name of the group and is required (-name).
+
+=item 2.
+
+The second argument (-values) is the list of values for the radio
+buttons. The values and the labels that appear on the page are
+identical. Pass an array I<reference> in the second argument, either
+using an anonymous array, as shown, or by referencing a named array as
+in "\@foo".
+
+=item 3.
+
+The optional third parameter (-default) is the name of the default
+button to turn on. If not specified, the first item will be the
+default. You can provide a nonexistent button name, such as "-" to
+start up with no buttons selected.
+
+=item 4.
+
+The optional fourth parameter (-linebreak) can be set to 'true' to put
+line breaks between the buttons, creating a vertical list.
+
+=item 5.
+
+The optional fifth parameter (-labels) is a pointer to an associative
+array relating the radio button values to user-visible labels to be
+used in the display. If not provided, the values themselves are
+displayed.
+
+=back
+
+
+All modern browsers can take advantage of the optional parameters
+B<-rows>, and B<-columns>. These parameters cause radio_group() to
+return an HTML3 compatible table containing the radio group formatted
+with the specified number of rows and columns. You can provide just
+the -columns parameter if you wish; radio_group will calculate the
+correct number of rows for you.
+
+To include row and column headings in the returned table, you
+can use the B<-rowheaders> and B<-colheaders> parameters. Both
+of these accept a pointer to an array of headings to use.
+The headings are just decorative. They don't reorganize the
+interpretation of the radio buttons -- they're still a single named
+unit.
+
+The optional B<-tabindex> argument can be used to control the order in which
+radio buttons receive focus when the user presses the tab button. If
+passed a scalar numeric value, the first element in the group will
+receive this tab index and subsequent elements will be incremented by
+one. If given a reference to an array of radio button values, then
+the indexes will be jiggered so that the order specified in the array
+will correspond to the tab order. You can also pass a reference to a
+hash in which the hash keys are the radio button values and the values
+are the tab indexes of each button. Examples:
+
+ -tabindex => 100 # this group starts at index 100 and counts up
+ -tabindex => ['moe','minie','eenie','meenie'] # tab in this order
+ -tabindex => {meenie=>100,moe=>101,minie=>102,eenie=>200} # tab in this order
+
+
+The optional B<-attributes> argument is provided to assign any of the
+common HTML attributes to an individual menu item. It's a pointer to
+a hash relating menu values to another hash
+with the attribute's name as the key and the attribute's value as the
+value.
+
+The optional B<-labelattributes> argument will contain attributes
+attached to the <label> element that surrounds each button.
+
+When the form is processed, the selected radio button can
+be retrieved using:
+
+ $which_radio_button = param('group_name');
+
+The value returned by radio_group() is actually an array of button
+elements. You can capture them and use them within tables, lists,
+or in other creative ways:
+
+ @h = radio_group(-name=>'group_name',-values=>\@values);
+ &use_in_creative_way(@h);
+
+=head2 CREATING A SUBMIT BUTTON
+
+ print submit(-name=>'button_name',
+ -value=>'value');
+
+ -or-
+
+ print submit('button_name','value');
+
+submit() will create the query submission button. Every form
+should have one of these.
+
+=over 4
+
+=item B<Parameters:>
+
+=item 1.
+
+The first argument (-name) is optional. You can give the button a
+name if you have several submission buttons in your form and you want
+to distinguish between them.
+
+=item 2.
+
+The second argument (-value) is also optional. This gives the button
+a value that will be passed to your script in the query string. The
+name will also be used as the user-visible label.
+
+=item 3.
+
+You can use -label as an alias for -value. I always get confused
+about which of -name and -value changes the user-visible label on the
+button.
+
+=back
+
+You can figure out which button was pressed by using different
+values for each one:
+
+ $which_one = param('button_name');
+
+=head2 CREATING A RESET BUTTON
+
+ print reset
+
+reset() creates the "reset" button. Note that it restores the
+form to its value from the last time the script was called,
+NOT necessarily to the defaults.
+
+Note that this conflicts with the Perl reset() built-in. Use
+CORE::reset() to get the original reset function.
+
+=head2 CREATING A DEFAULT BUTTON
+
+ print defaults('button_label')
+
+defaults() creates a button that, when invoked, will cause the
+form to be completely reset to its defaults, wiping out all the
+changes the user ever made.
+
+=head2 CREATING A HIDDEN FIELD
+
+ print hidden(-name=>'hidden_name',
+ -default=>['value1','value2'...]);
+
+ -or-
+
+ print hidden('hidden_name','value1','value2'...);
+
+hidden() produces a text field that can't be seen by the user. It
+is useful for passing state variable information from one invocation
+of the script to the next.
+
+=over 4
+
+=item B<Parameters:>
+
+=item 1.
+
+The first argument is required and specifies the name of this
+field (-name).
+
+=item 2.
+
+The second argument is also required and specifies its value
+(-default). In the named parameter style of calling, you can provide
+a single value here or a reference to a whole list
+
+=back
+
+Fetch the value of a hidden field this way:
+
+ $hidden_value = param('hidden_name');
+
+Note, that just like all the other form elements, the value of a
+hidden field is "sticky". If you want to replace a hidden field with
+some other values after the script has been called once you'll have to
+do it manually:
+
+ param('hidden_name','new','values','here');
+
+=head2 CREATING A CLICKABLE IMAGE BUTTON
+
+ print image_button(-name=>'button_name',
+ -src=>'/source/URL',
+ -align=>'MIDDLE');
+
+ -or-
+
+ print image_button('button_name','/source/URL','MIDDLE');
+
+image_button() produces a clickable image. When it's clicked on the
+position of the click is returned to your script as "button_name.x"
+and "button_name.y", where "button_name" is the name you've assigned
+to it.
+
+=over 4
+
+=item B<Parameters:>
+
+=item 1.
+
+The first argument (-name) is required and specifies the name of this
+field.
+
+=item 2.
+
+The second argument (-src) is also required and specifies the URL
+
+=item 3.
+The third option (-align, optional) is an alignment type, and may be
+TOP, BOTTOM or MIDDLE
+
+=back
+
+Fetch the value of the button this way:
+ $x = param('button_name.x');
+ $y = param('button_name.y');
+
+=head2 CREATING A JAVASCRIPT ACTION BUTTON
+
+ print button(-name=>'button_name',
+ -value=>'user visible label',
+ -onClick=>"do_something()");
+
+ -or-
+
+ print button('button_name',"do_something()");
+
+button() produces a button that is compatible with Netscape 2.0's
+JavaScript. When it's pressed the fragment of JavaScript code
+pointed to by the B<-onClick> parameter will be executed.
+
+=head1 HTTP COOKIES
+
+Browsers support a so-called "cookie" designed to help maintain state
+within a browser session. CGI.pm has several methods that support
+cookies.
+
+A cookie is a name=value pair much like the named parameters in a CGI
+query string. CGI scripts create one or more cookies and send
+them to the browser in the HTTP header. The browser maintains a list
+of cookies that belong to a particular Web server, and returns them
+to the CGI script during subsequent interactions.
+
+In addition to the required name=value pair, each cookie has several
+optional attributes:
+
+=over 4
+
+=item 1. an expiration time
+
+This is a time/date string (in a special GMT format) that indicates
+when a cookie expires. The cookie will be saved and returned to your
+script until this expiration date is reached if the user exits
+the browser and restarts it. If an expiration date isn't specified, the cookie
+will remain active until the user quits the browser.
+
+=item 2. a domain
+
+This is a partial or complete domain name for which the cookie is
+valid. The browser will return the cookie to any host that matches
+the partial domain name. For example, if you specify a domain name
+of ".capricorn.com", then the browser will return the cookie to
+Web servers running on any of the machines "www.capricorn.com",
+"www2.capricorn.com", "feckless.capricorn.com", etc. Domain names
+must contain at least two periods to prevent attempts to match
+on top level domains like ".edu". If no domain is specified, then
+the browser will only return the cookie to servers on the host the
+cookie originated from.
+
+=item 3. a path
+
+If you provide a cookie path attribute, the browser will check it
+against your script's URL before returning the cookie. For example,
+if you specify the path "/cgi-bin", then the cookie will be returned
+to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl",
+and "/cgi-bin/customer_service/complain.pl", but not to the script
+"/cgi-private/site_admin.pl". By default, path is set to "/", which
+causes the cookie to be sent to any CGI script on your site.
+
+=item 4. a "secure" flag
+
+If the "secure" attribute is set, the cookie will only be sent to your
+script if the CGI request is occurring on a secure channel, such as SSL.
+
+=back
+
+The interface to HTTP cookies is the B<cookie()> method:
+
+ $cookie = cookie(-name=>'sessionID',
+ -value=>'xyzzy',
+ -expires=>'+1h',
+ -path=>'/cgi-bin/database',
+ -domain=>'.capricorn.org',
+ -secure=>1);
+ print header(-cookie=>$cookie);
+
+B<cookie()> creates a new cookie. Its parameters include:
+
+=over 4
+
+=item B<-name>
+
+The name of the cookie (required). This can be any string at all.
+Although browsers limit their cookie names to non-whitespace
+alphanumeric characters, CGI.pm removes this restriction by escaping
+and unescaping cookies behind the scenes.
+
+=item B<-value>
+
+The value of the cookie. This can be any scalar value,
+array reference, or even hash reference. For example,
+you can store an entire hash into a cookie this way:
+
+ $cookie=cookie(-name=>'family information',
+ -value=>\%childrens_ages);
+
+=item B<-path>
+
+The optional partial path for which this cookie will be valid, as described
+above.
+
+=item B<-domain>
+
+The optional partial domain for which this cookie will be valid, as described
+above.
+
+=item B<-expires>
+
+The optional expiration date for this cookie. The format is as described
+in the section on the B<header()> method:
+
+ "+1h" one hour from now
+
+=item B<-secure>
+
+If set to true, this cookie will only be used within a secure
+SSL session.
+
+=back
+
+The cookie created by cookie() must be incorporated into the HTTP
+header within the string returned by the header() method:
+
+ use CGI ':standard';
+ print header(-cookie=>$my_cookie);
+
+To create multiple cookies, give header() an array reference:
+
+ $cookie1 = cookie(-name=>'riddle_name',
+ -value=>"The Sphynx's Question");
+ $cookie2 = cookie(-name=>'answers',
+ -value=>\%answers);
+ print header(-cookie=>[$cookie1,$cookie2]);
+
+To retrieve a cookie, request it by name by calling cookie() method
+without the B<-value> parameter. This example uses the object-oriented
+form:
+
+ use CGI;
+ $query = new CGI;
+ $riddle = $query->cookie('riddle_name');
+ %answers = $query->cookie('answers');
+
+Cookies created with a single scalar value, such as the "riddle_name"
+cookie, will be returned in that form. Cookies with array and hash
+values can also be retrieved.
+
+The cookie and CGI namespaces are separate. If you have a parameter
+named 'answers' and a cookie named 'answers', the values retrieved by
+param() and cookie() are independent of each other. However, it's
+simple to turn a CGI parameter into a cookie, and vice-versa:
+
+ # turn a CGI parameter into a cookie
+ $c=cookie(-name=>'answers',-value=>[param('answers')]);
+ # vice-versa
+ param(-name=>'answers',-value=>[cookie('answers')]);
+
+If you call cookie() without any parameters, it will return a list of
+the names of all cookies passed to your script:
+
+ @cookies = cookie();
+
+See the B<cookie.cgi> example script for some ideas on how to use
+cookies effectively.
+
+=head1 WORKING WITH FRAMES
+
+It's possible for CGI.pm scripts to write into several browser panels
+and windows using the HTML 4 frame mechanism. There are three
+techniques for defining new frames programmatically:
+
+=over 4
+
+=item 1. Create a <Frameset> document
+
+After writing out the HTTP header, instead of creating a standard
+HTML document using the start_html() call, create a <frameset>
+document that defines the frames on the page. Specify your script(s)
+(with appropriate parameters) as the SRC for each of the frames.
+
+There is no specific support for creating <frameset> sections
+in CGI.pm, but the HTML is very simple to write. See the frame
+documentation in Netscape's home pages for details
+
+ http://wp.netscape.com/assist/net_sites/frames.html
+
+=item 2. Specify the destination for the document in the HTTP header
+
+You may provide a B<-target> parameter to the header() method:
+
+ print header(-target=>'ResultsWindow');
+
+This will tell the browser to load the output of your script into the
+frame named "ResultsWindow". If a frame of that name doesn't already
+exist, the browser will pop up a new window and load your script's
+document into that. There are a number of magic names that you can
+use for targets. See the frame documents on Netscape's home pages for
+details.
+
+=item 3. Specify the destination for the document in the <form> tag
+
+You can specify the frame to load in the FORM tag itself. With
+CGI.pm it looks like this:
+
+ print start_form(-target=>'ResultsWindow');
+
+When your script is reinvoked by the form, its output will be loaded
+into the frame named "ResultsWindow". If one doesn't already exist
+a new window will be created.
+
+=back
+
+The script "frameset.cgi" in the examples directory shows one way to
+create pages in which the fill-out form and the response live in
+side-by-side frames.
+
+=head1 SUPPORT FOR JAVASCRIPT
+
+The usual way to use JavaScript is to define a set of functions in a
+<SCRIPT> block inside the HTML header and then to register event
+handlers in the various elements of the page. Events include such
+things as the mouse passing over a form element, a button being
+clicked, the contents of a text field changing, or a form being
+submitted. When an event occurs that involves an element that has
+registered an event handler, its associated JavaScript code gets
+called.
+
+The elements that can register event handlers include the <BODY> of an
+HTML document, hypertext links, all the various elements of a fill-out
+form, and the form itself. There are a large number of events, and
+each applies only to the elements for which it is relevant. Here is a
+partial list:
+
+=over 4
+
+=item B<onLoad>
+
+The browser is loading the current document. Valid in:
+
+ + The HTML <BODY> section only.
+
+=item B<onUnload>
+
+The browser is closing the current page or frame. Valid for:
+
+ + The HTML <BODY> section only.
+
+=item B<onSubmit>
+
+The user has pressed the submit button of a form. This event happens
+just before the form is submitted, and your function can return a
+value of false in order to abort the submission. Valid for:
+
+ + Forms only.
+
+=item B<onClick>
+
+The mouse has clicked on an item in a fill-out form. Valid for:
+
+ + Buttons (including submit, reset, and image buttons)
+ + Checkboxes
+ + Radio buttons
+
+=item B<onChange>
+
+The user has changed the contents of a field. Valid for:
+
+ + Text fields
+ + Text areas
+ + Password fields
+ + File fields
+ + Popup Menus
+ + Scrolling lists
+
+=item B<onFocus>
+
+The user has selected a field to work with. Valid for:
+
+ + Text fields
+ + Text areas
+ + Password fields
+ + File fields
+ + Popup Menus
+ + Scrolling lists
+
+=item B<onBlur>
+
+The user has deselected a field (gone to work somewhere else). Valid
+for:
+
+ + Text fields
+ + Text areas
+ + Password fields
+ + File fields
+ + Popup Menus
+ + Scrolling lists
+
+=item B<onSelect>
+
+The user has changed the part of a text field that is selected. Valid
+for:
+
+ + Text fields
+ + Text areas
+ + Password fields
+ + File fields
+
+=item B<onMouseOver>
+
+The mouse has moved over an element.
+
+ + Text fields
+ + Text areas
+ + Password fields
+ + File fields
+ + Popup Menus
+ + Scrolling lists
+
+=item B<onMouseOut>
+
+The mouse has moved off an element.
+
+ + Text fields
+ + Text areas
+ + Password fields
+ + File fields
+ + Popup Menus
+ + Scrolling lists
+
+=back
+
+In order to register a JavaScript event handler with an HTML element,
+just use the event name as a parameter when you call the corresponding
+CGI method. For example, to have your validateAge() JavaScript code
+executed every time the textfield named "age" changes, generate the
+field like this:
+
+ print textfield(-name=>'age',-onChange=>"validateAge(this)");
+
+This example assumes that you've already declared the validateAge()
+function by incorporating it into a <SCRIPT> block. The CGI.pm
+start_html() method provides a convenient way to create this section.
+
+Similarly, you can create a form that checks itself over for
+consistency and alerts the user if some essential value is missing by
+creating it this way:
+ print startform(-onSubmit=>"validateMe(this)");
+
+See the javascript.cgi script for a demonstration of how this all
+works.
+
+
+=head1 LIMITED SUPPORT FOR CASCADING STYLE SHEETS
+
+CGI.pm has limited support for HTML3's cascading style sheets (css).
+To incorporate a stylesheet into your document, pass the
+start_html() method a B<-style> parameter. The value of this
+parameter may be a scalar, in which case it is treated as the source
+URL for the stylesheet, or it may be a hash reference. In the latter
+case you should provide the hash with one or more of B<-src> or
+B<-code>. B<-src> points to a URL where an externally-defined
+stylesheet can be found. B<-code> points to a scalar value to be
+incorporated into a <style> section. Style definitions in B<-code>
+override similarly-named ones in B<-src>, hence the name "cascading."
+
+You may also specify the type of the stylesheet by adding the optional
+B<-type> parameter to the hash pointed to by B<-style>. If not
+specified, the style defaults to 'text/css'.
+
+To refer to a style within the body of your document, add the
+B<-class> parameter to any HTML element:
+
+ print h1({-class=>'Fancy'},'Welcome to the Party');
+
+Or define styles on the fly with the B<-style> parameter:
+
+ print h1({-style=>'Color: red;'},'Welcome to Hell');
+
+You may also use the new B<span()> element to apply a style to a
+section of text:
+
+ print span({-style=>'Color: red;'},
+ h1('Welcome to Hell'),
+ "Where did that handbasket get to?"
+ );
+
+Note that you must import the ":html3" definitions to have the
+B<span()> method available. Here's a quick and dirty example of using
+CSS's. See the CSS specification at
+http://www.w3.org/pub/WWW/TR/Wd-css-1.html for more information.
+
+ use CGI qw/:standard :html3/;
+
+ #here's a stylesheet incorporated directly into the page
+ $newStyle=<<END;
+ <!--
+ P.Tip {
+ margin-right: 50pt;
+ margin-left: 50pt;
+ color: red;
+ }
+ P.Alert {
+ font-size: 30pt;
+ font-family: sans-serif;
+ color: red;
+ }
+ -->
+ END
+ print header();
+ print start_html( -title=>'CGI with Style',
+ -style=>{-src=>'http://www.capricorn.com/style/st1.css',
+ -code=>$newStyle}
+ );
+ print h1('CGI with Style'),
+ p({-class=>'Tip'},
+ "Better read the cascading style sheet spec before playing with this!"),
+ span({-style=>'color: magenta'},
+ "Look Mom, no hands!",
+ p(),
+ "Whooo wee!"
+ );
+ print end_html;
+
+Pass an array reference to B<-code> or B<-src> in order to incorporate
+multiple stylesheets into your document.
+
+Should you wish to incorporate a verbatim stylesheet that includes
+arbitrary formatting in the header, you may pass a -verbatim tag to
+the -style hash, as follows:
+
+print start_html (-style => {-verbatim => '@import url("/server-common/css/'.$cssFile.'");',
+ -src => '/server-common/css/core.css'});
+
+
+This will generate an HTML header that contains this:
+
+ <link rel="stylesheet" type="text/css" href="/server-common/css/core.css">
+ <style type="text/css">
+ @import url("/server-common/css/main.css");
+ </style>
+
+Any additional arguments passed in the -style value will be
+incorporated into the <link> tag. For example:
+
+ start_html(-style=>{-src=>['/styles/print.css','/styles/layout.css'],
+ -media => 'all'});
+
+This will give:
+
+ <link rel="stylesheet" type="text/css" href="/styles/print.css" media="all"/>
+ <link rel="stylesheet" type="text/css" href="/styles/layout.css" media="all"/>
+
+<p>
+
+To make more complicated <link> tags, use the Link() function
+and pass it to start_html() in the -head argument, as in:
+
+ @h = (Link({-rel=>'stylesheet',-type=>'text/css',-src=>'/ss/ss.css',-media=>'all'}),
+ Link({-rel=>'stylesheet',-type=>'text/css',-src=>'/ss/fred.css',-media=>'paper'}));
+ print start_html({-head=>\@h})
+
+To create primary and "alternate" stylesheet, use the B<-alternate> option:
+
+ start_html(-style=>{-src=>[
+ {-src=>'/styles/print.css'},
+ {-src=>'/styles/alt.css',-alternate=>1}
+ ]
+ });
+
+=head1 DEBUGGING
+
+If you are running the script from the command line or in the perl
+debugger, you can pass the script a list of keywords or
+parameter=value pairs on the command line or from standard input (you
+don't have to worry about tricking your script into reading from
+environment variables). You can pass keywords like this:
+
+ your_script.pl keyword1 keyword2 keyword3
+
+or this:
+
+ your_script.pl keyword1+keyword2+keyword3
+
+or this:
+
+ your_script.pl name1=value1 name2=value2
+
+or this:
+
+ your_script.pl name1=value1&name2=value2
+
+To turn off this feature, use the -no_debug pragma.
+
+To test the POST method, you may enable full debugging with the -debug
+pragma. This will allow you to feed newline-delimited name=value
+pairs to the script on standard input.
+
+When debugging, you can use quotes and backslashes to escape
+characters in the familiar shell manner, letting you place
+spaces and other funny characters in your parameter=value
+pairs:
+
+ your_script.pl "name1='I am a long value'" "name2=two\ words"
+
+Finally, you can set the path info for the script by prefixing the first
+name/value parameter with the path followed by a question mark (?):
+
+ your_script.pl /your/path/here?name1=value1&name2=value2
+
+=head2 DUMPING OUT ALL THE NAME/VALUE PAIRS
+
+The Dump() method produces a string consisting of all the query's
+name/value pairs formatted nicely as a nested list. This is useful
+for debugging purposes:
+
+ print Dump
+
+
+Produces something that looks like:
+
+ <ul>
+ <li>name1
+ <ul>
+ <li>value1
+ <li>value2
+ </ul>
+ <li>name2
+ <ul>
+ <li>value1
+ </ul>
+ </ul>
+
+As a shortcut, you can interpolate the entire CGI object into a string
+and it will be replaced with the a nice HTML dump shown above:
+
+ $query=new CGI;
+ print "<h2>Current Values</h2> $query\n";
+
+=head1 FETCHING ENVIRONMENT VARIABLES
+
+Some of the more useful environment variables can be fetched
+through this interface. The methods are as follows:
+
+=over 4
+
+=item B<Accept()>
+
+Return a list of MIME types that the remote browser accepts. If you
+give this method a single argument corresponding to a MIME type, as in
+Accept('text/html'), it will return a floating point value
+corresponding to the browser's preference for this type from 0.0
+(don't want) to 1.0. Glob types (e.g. text/*) in the browser's accept
+list are handled correctly.
+
+Note that the capitalization changed between version 2.43 and 2.44 in
+order to avoid conflict with Perl's accept() function.
+
+=item B<raw_cookie()>
+
+Returns the HTTP_COOKIE variable. Cookies have a special format, and
+this method call just returns the raw form (?cookie dough). See
+cookie() for ways of setting and retrieving cooked cookies.
+
+Called with no parameters, raw_cookie() returns the packed cookie
+structure. You can separate it into individual cookies by splitting
+on the character sequence "; ". Called with the name of a cookie,
+retrieves the B<unescaped> form of the cookie. You can use the
+regular cookie() method to get the names, or use the raw_fetch()
+method from the CGI::Cookie module.
+
+=item B<user_agent()>
+
+Returns the HTTP_USER_AGENT variable. If you give
+this method a single argument, it will attempt to
+pattern match on it, allowing you to do something
+like user_agent(Mozilla);
+
+=item B<path_info()>
+
+Returns additional path information from the script URL.
+E.G. fetching /cgi-bin/your_script/additional/stuff will result in
+path_info() returning "/additional/stuff".
+
+NOTE: The Microsoft Internet Information Server
+is broken with respect to additional path information. If
+you use the Perl DLL library, the IIS server will attempt to
+execute the additional path information as a Perl script.
+If you use the ordinary file associations mapping, the
+path information will be present in the environment,
+but incorrect. The best thing to do is to avoid using additional
+path information in CGI scripts destined for use with IIS.
+
+=item B<path_translated()>
+
+As per path_info() but returns the additional
+path information translated into a physical path, e.g.
+"/usr/local/etc/httpd/htdocs/additional/stuff".
+
+The Microsoft IIS is broken with respect to the translated
+path as well.
+
+=item B<remote_host()>
+
+Returns either the remote host name or IP address.
+if the former is unavailable.
+
+=item B<script_name()>
+Return the script name as a partial URL, for self-refering
+scripts.
+
+=item B<referer()>
+
+Return the URL of the page the browser was viewing
+prior to fetching your script. Not available for all
+browsers.
+
+=item B<auth_type ()>
+
+Return the authorization/verification method in use for this
+script, if any.
+
+=item B<server_name ()>
+
+Returns the name of the server, usually the machine's host
+name.
+
+=item B<virtual_host ()>
+
+When using virtual hosts, returns the name of the host that
+the browser attempted to contact
+
+=item B<server_port ()>
+
+Return the port that the server is listening on.
+
+=item B<virtual_port ()>
+
+Like server_port() except that it takes virtual hosts into account.
+Use this when running with virtual hosts.
+
+=item B<server_software ()>
+
+Returns the server software and version number.
+
+=item B<remote_user ()>
+
+Return the authorization/verification name used for user
+verification, if this script is protected.
+
+=item B<user_name ()>
+
+Attempt to obtain the remote user's name, using a variety of different
+techniques. This only works with older browsers such as Mosaic.
+Newer browsers do not report the user name for privacy reasons!
+
+=item B<request_method()>
+
+Returns the method used to access your script, usually
+one of 'POST', 'GET' or 'HEAD'.
+
+=item B<content_type()>
+
+Returns the content_type of data submitted in a POST, generally
+multipart/form-data or application/x-www-form-urlencoded
+
+=item B<http()>
+
+Called with no arguments returns the list of HTTP environment
+variables, including such things as HTTP_USER_AGENT,
+HTTP_ACCEPT_LANGUAGE, and HTTP_ACCEPT_CHARSET, corresponding to the
+like-named HTTP header fields in the request. Called with the name of
+an HTTP header field, returns its value. Capitalization and the use
+of hyphens versus underscores are not significant.
+
+For example, all three of these examples are equivalent:
+
+ $requested_language = http('Accept-language');
+ $requested_language = http('Accept_language');
+ $requested_language = http('HTTP_ACCEPT_LANGUAGE');
+
+=item B<https()>
+
+The same as I<http()>, but operates on the HTTPS environment variables
+present when the SSL protocol is in effect. Can be used to determine
+whether SSL is turned on.
+
+=back
+
+=head1 USING NPH SCRIPTS
+
+NPH, or "no-parsed-header", scripts bypass the server completely by
+sending the complete HTTP header directly to the browser. This has
+slight performance benefits, but is of most use for taking advantage
+of HTTP extensions that are not directly supported by your server,
+such as server push and PICS headers.
+
+Servers use a variety of conventions for designating CGI scripts as
+NPH. Many Unix servers look at the beginning of the script's name for
+the prefix "nph-". The Macintosh WebSTAR server and Microsoft's
+Internet Information Server, in contrast, try to decide whether a
+program is an NPH script by examining the first line of script output.
+
+
+CGI.pm supports NPH scripts with a special NPH mode. When in this
+mode, CGI.pm will output the necessary extra header information when
+the header() and redirect() methods are
+called.
+
+The Microsoft Internet Information Server requires NPH mode. As of
+version 2.30, CGI.pm will automatically detect when the script is
+running under IIS and put itself into this mode. You do not need to
+do this manually, although it won't hurt anything if you do. However,
+note that if you have applied Service Pack 6, much of the
+functionality of NPH scripts, including the ability to redirect while
+setting a cookie, B<do not work at all> on IIS without a special patch
+from Microsoft. See
+http://support.microsoft.com/support/kb/articles/Q280/3/41.ASP:
+Non-Parsed Headers Stripped From CGI Applications That Have nph-
+Prefix in Name.
+
+=over 4
+
+=item In the B<use> statement
+
+Simply add the "-nph" pragmato the list of symbols to be imported into
+your script:
+
+ use CGI qw(:standard -nph)
+
+=item By calling the B<nph()> method:
+
+Call B<nph()> with a non-zero parameter at any point after using CGI.pm in your program.
+
+ CGI->nph(1)
+
+=item By using B<-nph> parameters
+
+in the B<header()> and B<redirect()> statements:
+
+ print header(-nph=>1);
+
+=back
+
+=head1 Server Push
+
+CGI.pm provides four simple functions for producing multipart
+documents of the type needed to implement server push. These
+functions were graciously provided by Ed Jordan <ed at fidalgo.net>. To
+import these into your namespace, you must import the ":push" set.
+You are also advised to put the script into NPH mode and to set $| to
+1 to avoid buffering problems.
+
+Here is a simple script that demonstrates server push:
+
+ #!/usr/local/bin/perl
+ use CGI qw/:push -nph/;
+ $| = 1;
+ print multipart_init(-boundary=>'----here we go!');
+ for (0 .. 4) {
+ print multipart_start(-type=>'text/plain'),
+ "The current time is ",scalar(localtime),"\n";
+ if ($_ < 4) {
+ print multipart_end;
+ } else {
+ print multipart_final;
+ }
+ sleep 1;
+ }
+
+This script initializes server push by calling B<multipart_init()>.
+It then enters a loop in which it begins a new multipart section by
+calling B<multipart_start()>, prints the current local time,
+and ends a multipart section with B<multipart_end()>. It then sleeps
+a second, and begins again. On the final iteration, it ends the
+multipart section with B<multipart_final()> rather than with
+B<multipart_end()>.
+
+=over 4
+
+=item multipart_init()
+
+ multipart_init(-boundary=>$boundary);
+
+Initialize the multipart system. The -boundary argument specifies
+what MIME boundary string to use to separate parts of the document.
+If not provided, CGI.pm chooses a reasonable boundary for you.
+
+=item multipart_start()
+
+ multipart_start(-type=>$type)
+
+Start a new part of the multipart document using the specified MIME
+type. If not specified, text/html is assumed.
+
+=item multipart_end()
+
+ multipart_end()
+
+End a part. You must remember to call multipart_end() once for each
+multipart_start(), except at the end of the last part of the multipart
+document when multipart_final() should be called instead of multipart_end().
+
+=item multipart_final()
+
+ multipart_final()
+
+End all parts. You should call multipart_final() rather than
+multipart_end() at the end of the last part of the multipart document.
+
+=back
+
+Users interested in server push applications should also have a look
+at the CGI::Push module.
+
+=head1 Avoiding Denial of Service Attacks
+
+A potential problem with CGI.pm is that, by default, it attempts to
+process form POSTings no matter how large they are. A wily hacker
+could attack your site by sending a CGI script a huge POST of many
+megabytes. CGI.pm will attempt to read the entire POST into a
+variable, growing hugely in size until it runs out of memory. While
+the script attempts to allocate the memory the system may slow down
+dramatically. This is a form of denial of service attack.
+
+Another possible attack is for the remote user to force CGI.pm to
+accept a huge file upload. CGI.pm will accept the upload and store it
+in a temporary directory even if your script doesn't expect to receive
+an uploaded file. CGI.pm will delete the file automatically when it
+terminates, but in the meantime the remote user may have filled up the
+server's disk space, causing problems for other programs.
+
+The best way to avoid denial of service attacks is to limit the amount
+of memory, CPU time and disk space that CGI scripts can use. Some Web
+servers come with built-in facilities to accomplish this. In other
+cases, you can use the shell I<limit> or I<ulimit>
+commands to put ceilings on CGI resource usage.
+
+
+CGI.pm also has some simple built-in protections against denial of
+service attacks, but you must activate them before you can use them.
+These take the form of two global variables in the CGI name space:
+
+=over 4
+
+=item B<$CGI::POST_MAX>
+
+If set to a non-negative integer, this variable puts a ceiling
+on the size of POSTings, in bytes. If CGI.pm detects a POST
+that is greater than the ceiling, it will immediately exit with an error
+message. This value will affect both ordinary POSTs and
+multipart POSTs, meaning that it limits the maximum size of file
+uploads as well. You should set this to a reasonably high
+value, such as 1 megabyte.
+
+=item B<$CGI::DISABLE_UPLOADS>
+
+If set to a non-zero value, this will disable file uploads
+completely. Other fill-out form values will work as usual.
+
+=back
+
+You can use these variables in either of two ways.
+
+=over 4
+
+=item B<1. On a script-by-script basis>
+
+Set the variable at the top of the script, right after the "use" statement:
+
+ use CGI qw/:standard/;
+ use CGI::Carp 'fatalsToBrowser';
+ $CGI::POST_MAX=1024 * 100; # max 100K posts
+ $CGI::DISABLE_UPLOADS = 1; # no uploads
+
+=item B<2. Globally for all scripts>
+
+Open up CGI.pm, find the definitions for $POST_MAX and
+$DISABLE_UPLOADS, and set them to the desired values. You'll
+find them towards the top of the file in a subroutine named
+initialize_globals().
+
+=back
+
+An attempt to send a POST larger than $POST_MAX bytes will cause
+I<param()> to return an empty CGI parameter list. You can test for
+this event by checking I<cgi_error()>, either after you create the CGI
+object or, if you are using the function-oriented interface, call
+<param()> for the first time. If the POST was intercepted, then
+cgi_error() will return the message "413 POST too large".
+
+This error message is actually defined by the HTTP protocol, and is
+designed to be returned to the browser as the CGI script's status
+ code. For example:
+
+ $uploaded_file = param('upload');
+ if (!$uploaded_file && cgi_error()) {
+ print header(-status=>cgi_error());
+ exit 0;
+ }
+
+However it isn't clear that any browser currently knows what to do
+with this status code. It might be better just to create an
+HTML page that warns the user of the problem.
+
+=head1 COMPATIBILITY WITH CGI-LIB.PL
+
+To make it easier to port existing programs that use cgi-lib.pl the
+compatibility routine "ReadParse" is provided. Porting is simple:
+
+OLD VERSION
+ require "cgi-lib.pl";
+ &ReadParse;
+ print "The value of the antique is $in{antique}.\n";
+
+NEW VERSION
+ use CGI;
+ CGI::ReadParse();
+ print "The value of the antique is $in{antique}.\n";
+
+CGI.pm's ReadParse() routine creates a tied variable named %in,
+which can be accessed to obtain the query variables. Like
+ReadParse, you can also provide your own variable. Infrequently
+used features of ReadParse, such as the creation of @in and $in
+variables, are not supported.
+
+Once you use ReadParse, you can retrieve the query object itself
+this way:
+
+ $q = $in{CGI};
+ print textfield(-name=>'wow',
+ -value=>'does this really work?');
+
+This allows you to start using the more interesting features
+of CGI.pm without rewriting your old scripts from scratch.
+
+=head1 AUTHOR INFORMATION
+
+The GD.pm interface is copyright 1995-2007, Lincoln D. Stein. It is
+distributed under GPL and the Artistic License 2.0.
+
+Address bug reports and comments to: lstein at cshl.org. When sending
+bug reports, please provide the version of CGI.pm, the version of
+Perl, the name and version of your Web server, and the name and
+version of the operating system you are using. If the problem is even
+remotely browser dependent, please provide information about the
+affected browers as well.
+
+=head1 CREDITS
+
+Thanks very much to:
+
+=over 4
+
+=item Matt Heffron (heffron at falstaff.css.beckman.com)
+
+=item James Taylor (james.taylor at srs.gov)
+
+=item Scott Anguish <sanguish at digifix.com>
+
+=item Mike Jewell (mlj3u at virginia.edu)
+
+=item Timothy Shimmin (tes at kbs.citri.edu.au)
+
+=item Joergen Haegg (jh at axis.se)
+
+=item Laurent Delfosse (delfosse at delfosse.com)
+
+=item Richard Resnick (applepi1 at aol.com)
+
+=item Craig Bishop (csb at barwonwater.vic.gov.au)
+
+=item Tony Curtis (tc at vcpc.univie.ac.at)
+
+=item Tim Bunce (Tim.Bunce at ig.co.uk)
+
+=item Tom Christiansen (tchrist at convex.com)
+
+=item Andreas Koenig (k at franz.ww.TU-Berlin.DE)
+
+=item Tim MacKenzie (Tim.MacKenzie at fulcrum.com.au)
+
+=item Kevin B. Hendricks (kbhend at dogwood.tyler.wm.edu)
+
+=item Stephen Dahmen (joyfire at inxpress.net)
+
+=item Ed Jordan (ed at fidalgo.net)
+
+=item David Alan Pisoni (david at cnation.com)
+
+=item Doug MacEachern (dougm at opengroup.org)
+
+=item Robin Houston (robin at oneworld.org)
+
+=item ...and many many more...
+
+for suggestions and bug fixes.
+
+=back
+
+=head1 A COMPLETE EXAMPLE OF A SIMPLE FORM-BASED SCRIPT
+
+
+ #!/usr/local/bin/perl
+
+ use CGI ':standard';
+
+ print header;
+ print start_html("Example CGI.pm Form");
+ print "<h1> Example CGI.pm Form</h1>\n";
+ print_prompt();
+ do_work();
+ print_tail();
+ print end_html;
+
+ sub print_prompt {
+ print start_form;
+ print "<em>What's your name?</em><br>";
+ print textfield('name');
+ print checkbox('Not my real name');
+
+ print "<p><em>Where can you find English Sparrows?</em><br>";
+ print checkbox_group(
+ -name=>'Sparrow locations',
+ -values=>[England,France,Spain,Asia,Hoboken],
+ -linebreak=>'yes',
+ -defaults=>[England,Asia]);
+
+ print "<p><em>How far can they fly?</em><br>",
+ radio_group(
+ -name=>'how far',
+ -values=>['10 ft','1 mile','10 miles','real far'],
+ -default=>'1 mile');
+
+ print "<p><em>What's your favorite color?</em> ";
+ print popup_menu(-name=>'Color',
+ -values=>['black','brown','red','yellow'],
+ -default=>'red');
+
+ print hidden('Reference','Monty Python and the Holy Grail');
+
+ print "<p><em>What have you got there?</em><br>";
+ print scrolling_list(
+ -name=>'possessions',
+ -values=>['A Coconut','A Grail','An Icon',
+ 'A Sword','A Ticket'],
+ -size=>5,
+ -multiple=>'true');
+
+ print "<p><em>Any parting comments?</em><br>";
+ print textarea(-name=>'Comments',
+ -rows=>10,
+ -columns=>50);
+
+ print "<p>",reset;
+ print submit('Action','Shout');
+ print submit('Action','Scream');
+ print endform;
+ print "<hr>\n";
+ }
+
+ sub do_work {
+ my(@values,$key);
+
+ print "<h2>Here are the current settings in this form</h2>";
+
+ for $key (param) {
+ print "<strong>$key</strong> -> ";
+ @values = param($key);
+ print join(", ", at values),"<br>\n";
+ }
+ }
+
+ sub print_tail {
+ print <<END;
+ <hr>
+ <address>Lincoln D. Stein</address><br>
+ <a href="/">Home Page</a>
+ END
+ }
+
+=head1 BUGS
+
+Please report them.
+
+=head1 SEE ALSO
+
+L<CGI::Carp>, L<CGI::Fast>, L<CGI::Pretty>
+
+=cut
+
Modified: trunk/contrib/perl/lib/CORE.pod
===================================================================
--- trunk/contrib/perl/lib/CORE.pod 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/CORE.pod 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,6 +1,6 @@
=head1 NAME
-CORE - Pseudo-namespace for Perl's core routines
+CORE - Namespace for Perl's core routines
=head1 SYNOPSIS
@@ -10,21 +10,55 @@
print hex("0x50"),"\n"; # prints 1
print CORE::hex("0x50"),"\n"; # prints 80
+ CORE::say "yes"; # prints yes
+ BEGIN { *shove = \&CORE::push; }
+ shove @array, 1,2,3; # pushes on to @array
+
=head1 DESCRIPTION
The C<CORE> namespace gives access to the original built-in functions of
-Perl. There is no C<CORE> package, and therefore you do not need to use or
-require an hypothetical "CORE" module prior to accessing routines in this
+Perl. The C<CORE> package is built into
+Perl, and therefore you do not need to use or
+require a hypothetical "CORE" module prior to accessing routines in this
namespace.
A list of the built-in functions in Perl can be found in L<perlfunc>.
+For all Perl keywords, a C<CORE::> prefix will force the built-in function
+to be used, even if it has been overridden or would normally require the
+L<feature> pragma. Despite appearances, this has nothing to do with the
+CORE package, but is part of Perl's syntax.
+
+For many Perl functions, the CORE package contains real subroutines. This
+feature is new in Perl 5.16. You can take references to these and make
+aliases. However, some can only be called as barewords; i.e., you cannot
+use ampersand syntax (C<&foo>) or call them through references. See the
+C<shove> example above. These subroutines exist for all keywords except the following:
+
+C<__DATA__>, C<__END__>, C<and>, C<cmp>, C<default>, C<do>, C<dump>,
+C<else>, C<elsif>, C<eq>, C<eval>, C<for>, C<foreach>, C<format>, C<ge>,
+C<given>, C<goto>, C<grep>, C<gt>, C<if>, C<last>, C<le>, C<local>, C<lt>,
+C<m>, C<map>, C<my>, C<ne>, C<next>, C<no>, C<or>, C<our>, C<package>,
+C<print>, C<printf>, C<q>, C<qq>, C<qr>, C<qw>, C<qx>, C<redo>, C<require>,
+C<return>, C<s>, C<say>, C<sort>, C<state>, C<sub>, C<tr>, C<unless>,
+C<until>, C<use>, C<when>, C<while>, C<x>, C<xor>, C<y>
+
+Calling with
+ampersand syntax and through references does not work for the following
+functions, as they have special syntax that cannot always be translated
+into a simple list (e.g., C<eof> vs C<eof()>):
+
+C<chdir>, C<chomp>, C<chop>, C<defined>, C<delete>, C<each>,
+C<eof>, C<exec>, C<exists>, C<keys>, C<lstat>, C<pop>, C<push>,
+C<shift>, C<splice>, C<split>, C<stat>, C<system>, C<truncate>,
+C<unlink>, C<unshift>, C<values>
+
=head1 OVERRIDING CORE FUNCTIONS
To override a Perl built-in routine with your own version, you need to
-import it at compile-time. This can be conveniently achieved with the
-C<subs> pragma. This will affect only the package in which you've imported
+import it at compile-time. This can be conveniently achieved with the
+C<subs> pragma. This will affect only the package in which you've imported
the said subroutine:
use subs 'chdir';
Property changes on: trunk/contrib/perl/lib/CORE.pod
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/lib/CPAN.pm (from rev 6437, vendor/perl/5.18.1/lib/CPAN.pm)
===================================================================
--- trunk/contrib/perl/lib/CPAN.pm (rev 0)
+++ trunk/contrib/perl/lib/CPAN.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,3717 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+use strict;
+package CPAN;
+$CPAN::VERSION = '1.9402';
+$CPAN::VERSION =~ s/_//;
+
+# we need to run chdir all over and we would get at wrong libraries
+# there
+use File::Spec ();
+BEGIN {
+ if (File::Spec->can("rel2abs")) {
+ for my $inc (@INC) {
+ $inc = File::Spec->rel2abs($inc) unless ref $inc;
+ }
+ }
+}
+use CPAN::Author;
+use CPAN::HandleConfig;
+use CPAN::Version;
+use CPAN::Bundle;
+use CPAN::CacheMgr;
+use CPAN::Complete;
+use CPAN::Debug;
+use CPAN::Distribution;
+use CPAN::Distrostatus;
+use CPAN::FTP;
+use CPAN::Index 1.93; # https://rt.cpan.org/Ticket/Display.html?id=43349
+use CPAN::InfoObj;
+use CPAN::Module;
+use CPAN::Prompt;
+use CPAN::URL;
+use CPAN::Queue;
+use CPAN::Tarzip;
+use CPAN::DeferredCode;
+use CPAN::Shell;
+use CPAN::LWP::UserAgent;
+use CPAN::Exception::RecursiveDependency;
+use CPAN::Exception::yaml_not_installed;
+
+use Carp ();
+use Config ();
+use Cwd qw(chdir);
+use DirHandle ();
+use Exporter ();
+use ExtUtils::MakeMaker qw(prompt); # for some unknown reason,
+ # 5.005_04 does not work without
+ # this
+use File::Basename ();
+use File::Copy ();
+use File::Find;
+use File::Path ();
+use FileHandle ();
+use Fcntl qw(:flock);
+use Safe ();
+use Sys::Hostname qw(hostname);
+use Text::ParseWords ();
+use Text::Wrap ();
+
+# protect against "called too early"
+sub find_perl ();
+sub anycwd ();
+sub _uniq;
+
+no lib ".";
+
+require Mac::BuildTools if $^O eq 'MacOS';
+if ($ENV{PERL5_CPAN_IS_RUNNING} && $$ != $ENV{PERL5_CPAN_IS_RUNNING}) {
+ $ENV{PERL5_CPAN_IS_RUNNING_IN_RECURSION} ||= $ENV{PERL5_CPAN_IS_RUNNING};
+ my @rec = _uniq split(/,/, $ENV{PERL5_CPAN_IS_RUNNING_IN_RECURSION}), $$;
+ $ENV{PERL5_CPAN_IS_RUNNING_IN_RECURSION} = join ",", @rec;
+ # warn "# Note: Recursive call of CPAN.pm detected\n";
+ my $w = sprintf "# Note: CPAN.pm is running in process %d now", pop @rec;
+ my %sleep = (
+ 5 => 30,
+ 6 => 60,
+ 7 => 120,
+ );
+ my $sleep = @rec > 7 ? 300 : ($sleep{scalar @rec}||0);
+ my $verbose = @rec >= 4;
+ while (@rec) {
+ $w .= sprintf " which has been called by process %d", pop @rec;
+ }
+ if ($sleep) {
+ $w .= ".\n\n# Sleeping $sleep seconds to protect other processes\n";
+ }
+ if ($verbose) {
+ warn $w;
+ }
+ local $| = 1;
+ while ($sleep > 0) {
+ printf "\r#%5d", --$sleep;
+ sleep 1;
+ }
+ print "\n";
+}
+$ENV{PERL5_CPAN_IS_RUNNING}=$$;
+$ENV{PERL5_CPANPLUS_IS_RUNNING}=$$; # https://rt.cpan.org/Ticket/Display.html?id=23735
+
+END { $CPAN::End++; &cleanup; }
+
+$CPAN::Signal ||= 0;
+$CPAN::Frontend ||= "CPAN::Shell";
+unless (@CPAN::Defaultsites) {
+ @CPAN::Defaultsites = map {
+ CPAN::URL->new(TEXT => $_, FROM => "DEF")
+ }
+ "http://www.perl.org/CPAN/",
+ "ftp://ftp.perl.org/pub/CPAN/";
+}
+# $CPAN::iCwd (i for initial)
+$CPAN::iCwd ||= CPAN::anycwd();
+$CPAN::Perl ||= CPAN::find_perl();
+$CPAN::Defaultdocs ||= "http://search.cpan.org/perldoc?";
+$CPAN::Defaultrecent ||= "http://search.cpan.org/uploads.rdf";
+$CPAN::Defaultrecent ||= "http://cpan.uwinnipeg.ca/htdocs/cpan.xml";
+
+# our globals are getting a mess
+use vars qw(
+ $AUTOLOAD
+ $Be_Silent
+ $CONFIG_DIRTY
+ $Defaultdocs
+ $Echo_readline
+ $Frontend
+ $GOTOSHELL
+ $HAS_USABLE
+ $Have_warned
+ $MAX_RECURSION
+ $META
+ $RUN_DEGRADED
+ $Signal
+ $SQLite
+ $Suppress_readline
+ $VERSION
+ $autoload_recursion
+ $term
+ @Defaultsites
+ @EXPORT
+ );
+
+$MAX_RECURSION = 32;
+
+ at CPAN::ISA = qw(CPAN::Debug Exporter);
+
+# note that these functions live in CPAN::Shell and get executed via
+# AUTOLOAD when called directly
+ at EXPORT = qw(
+ autobundle
+ bundle
+ clean
+ cvs_import
+ expand
+ force
+ fforce
+ get
+ install
+ install_tested
+ is_tested
+ make
+ mkmyconfig
+ notest
+ perldoc
+ readme
+ recent
+ recompile
+ report
+ shell
+ smoke
+ test
+ upgrade
+ );
+
+sub soft_chdir_with_alternatives ($);
+
+{
+ $autoload_recursion ||= 0;
+
+ #-> sub CPAN::AUTOLOAD ;
+ sub AUTOLOAD { ## no critic
+ $autoload_recursion++;
+ my($l) = $AUTOLOAD;
+ $l =~ s/.*:://;
+ if ($CPAN::Signal) {
+ warn "Refusing to autoload '$l' while signal pending";
+ $autoload_recursion--;
+ return;
+ }
+ if ($autoload_recursion > 1) {
+ my $fullcommand = join " ", map { "'$_'" } $l, @_;
+ warn "Refusing to autoload $fullcommand in recursion\n";
+ $autoload_recursion--;
+ return;
+ }
+ my(%export);
+ @export{@EXPORT} = '';
+ CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
+ if (exists $export{$l}) {
+ CPAN::Shell->$l(@_);
+ } else {
+ die(qq{Unknown CPAN command "$AUTOLOAD". }.
+ qq{Type ? for help.\n});
+ }
+ $autoload_recursion--;
+ }
+}
+
+{
+ my $x = *SAVEOUT; # avoid warning
+ open($x,">&STDOUT") or die "dup failed";
+ my $redir = 0;
+ sub _redirect(@) {
+ #die if $redir;
+ local $_;
+ push(@_,undef);
+ while(defined($_=shift)) {
+ if (s/^\s*>//){
+ my ($m) = s/^>// ? ">" : "";
+ s/\s+//;
+ $_=shift unless length;
+ die "no dest" unless defined;
+ open(STDOUT,">$m$_") or die "open:$_:$!\n";
+ $redir=1;
+ } elsif ( s/^\s*\|\s*// ) {
+ my $pipe="| $_";
+ while(defined($_[0])){
+ $pipe .= ' ' . shift;
+ }
+ open(STDOUT,$pipe) or die "open:$pipe:$!\n";
+ $redir=1;
+ } else {
+ push(@_,$_);
+ }
+ }
+ return @_;
+ }
+ sub _unredirect {
+ return unless $redir;
+ $redir = 0;
+ ## redirect: unredirect and propagate errors. explicit close to wait for pipe.
+ close(STDOUT);
+ open(STDOUT,">&SAVEOUT");
+ die "$@" if "$@";
+ ## redirect: done
+ }
+}
+
+sub _uniq {
+ my(@list) = @_;
+ my %seen;
+ return grep { !$seen{$_}++ } @list;
+}
+
+#-> sub CPAN::shell ;
+sub shell {
+ my($self) = @_;
+ $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
+ CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
+
+ my $oprompt = shift || CPAN::Prompt->new;
+ my $prompt = $oprompt;
+ my $commandline = shift || "";
+ $CPAN::CurrentCommandId ||= 1;
+
+ local($^W) = 1;
+ unless ($Suppress_readline) {
+ require Term::ReadLine;
+ if (! $term
+ or
+ $term->ReadLine eq "Term::ReadLine::Stub"
+ ) {
+ $term = Term::ReadLine->new('CPAN Monitor');
+ }
+ if ($term->ReadLine eq "Term::ReadLine::Gnu") {
+ my $attribs = $term->Attribs;
+ $attribs->{attempted_completion_function} = sub {
+ &CPAN::Complete::gnu_cpl;
+ }
+ } else {
+ $readline::rl_completion_function =
+ $readline::rl_completion_function = 'CPAN::Complete::cpl';
+ }
+ if (my $histfile = $CPAN::Config->{'histfile'}) {{
+ unless ($term->can("AddHistory")) {
+ $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n");
+ last;
+ }
+ $META->readhist($term,$histfile);
+ }}
+ for ($CPAN::Config->{term_ornaments}) { # alias
+ local $Term::ReadLine::termcap_nowarn = 1;
+ $term->ornaments($_) if defined;
+ }
+ # $term->OUT is autoflushed anyway
+ my $odef = select STDERR;
+ $| = 1;
+ select STDOUT;
+ $| = 1;
+ select $odef;
+ }
+
+ $META->checklock();
+ my @cwd = grep { defined $_ and length $_ }
+ CPAN::anycwd(),
+ File::Spec->can("tmpdir") ? File::Spec->tmpdir() : (),
+ File::Spec->rootdir();
+ my $try_detect_readline;
+ $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
+ unless ($CPAN::Config->{inhibit_startup_message}) {
+ my $rl_avail = $Suppress_readline ? "suppressed" :
+ ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
+ "available (maybe install Bundle::CPAN or Bundle::CPANxxl?)";
+ $CPAN::Frontend->myprint(
+ sprintf qq{
+cpan shell -- CPAN exploration and modules installation (v%s)
+Enter 'h' for help.
+
+},
+ $CPAN::VERSION,
+ $rl_avail
+ )
+ }
+ my($continuation) = "";
+ my $last_term_ornaments;
+ SHELLCOMMAND: while () {
+ if ($Suppress_readline) {
+ if ($Echo_readline) {
+ $|=1;
+ }
+ print $prompt;
+ last SHELLCOMMAND unless defined ($_ = <> );
+ if ($Echo_readline) {
+ # backdoor: I could not find a way to record sessions
+ print $_;
+ }
+ chomp;
+ } else {
+ last SHELLCOMMAND unless
+ defined ($_ = $term->readline($prompt, $commandline));
+ }
+ $_ = "$continuation$_" if $continuation;
+ s/^\s+//;
+ next SHELLCOMMAND if /^$/;
+ s/^\s*\?\s*/help /;
+ if (/^(?:q(?:uit)?|bye|exit)$/i) {
+ last SHELLCOMMAND;
+ } elsif (s/\\$//s) {
+ chomp;
+ $continuation = $_;
+ $prompt = " > ";
+ } elsif (/^\!/) {
+ s/^\!//;
+ my($eval) = $_;
+ package
+ CPAN::Eval; # hide from the indexer
+ use strict;
+ use vars qw($import_done);
+ CPAN->import(':DEFAULT') unless $import_done++;
+ CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
+ eval($eval);
+ warn $@ if $@;
+ $continuation = "";
+ $prompt = $oprompt;
+ } elsif (/./) {
+ my(@line);
+ eval { @line = Text::ParseWords::shellwords($_) };
+ warn($@), next SHELLCOMMAND if $@;
+ warn("Text::Parsewords could not parse the line [$_]"),
+ next SHELLCOMMAND unless @line;
+ $CPAN::META->debug("line[".join("|", at line)."]") if $CPAN::DEBUG;
+ my $command = shift @line;
+ eval {
+ local (*STDOUT)=*STDOUT;
+ @line = _redirect(@line);
+ CPAN::Shell->$command(@line)
+ };
+ my $command_error = $@;
+ _unredirect;
+ my $reported_error;
+ if ($command_error) {
+ my $err = $command_error;
+ if (ref $err and $err->isa('CPAN::Exception::blocked_urllist')) {
+ $CPAN::Frontend->mywarn("Client not fully configured, please proceed with configuring.$err");
+ $reported_error = ref $err;
+ } else {
+ # I'd prefer never to arrive here and make all errors exception objects
+ if ($err =~ /\S/) {
+ require Carp;
+ require Dumpvalue;
+ my $dv = Dumpvalue->new(tick => '"');
+ Carp::cluck(sprintf "Catching error: %s", $dv->stringify($err));
+ }
+ }
+ }
+ if ($command =~ /^(
+ # classic commands
+ make
+ |test
+ |install
+ |clean
+
+ # pragmas for classic commands
+ |ff?orce
+ |notest
+
+ # compounds
+ |report
+ |smoke
+ |upgrade
+ )$/x) {
+ # only commands that tell us something about failed distros
+ # eval necessary for people without an urllist
+ eval {CPAN::Shell->failed($CPAN::CurrentCommandId,1);};
+ if (my $err = $@) {
+ unless (ref $err and $reported_error eq ref $err) {
+ die $@;
+ }
+ }
+ }
+ soft_chdir_with_alternatives(\@cwd);
+ $CPAN::Frontend->myprint("\n");
+ $continuation = "";
+ $CPAN::CurrentCommandId++;
+ $prompt = $oprompt;
+ }
+ } continue {
+ $commandline = ""; # I do want to be able to pass a default to
+ # shell, but on the second command I see no
+ # use in that
+ $Signal=0;
+ CPAN::Queue->nullify_queue;
+ if ($try_detect_readline) {
+ if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
+ ||
+ $CPAN::META->has_inst("Term::ReadLine::Perl")
+ ) {
+ delete $INC{"Term/ReadLine.pm"};
+ my $redef = 0;
+ local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
+ require Term::ReadLine;
+ $CPAN::Frontend->myprint("\n$redef subroutines in ".
+ "Term::ReadLine redefined\n");
+ $GOTOSHELL = 1;
+ }
+ }
+ if ($term and $term->can("ornaments")) {
+ for ($CPAN::Config->{term_ornaments}) { # alias
+ if (defined $_) {
+ if (not defined $last_term_ornaments
+ or $_ != $last_term_ornaments
+ ) {
+ local $Term::ReadLine::termcap_nowarn = 1;
+ $term->ornaments($_);
+ $last_term_ornaments = $_;
+ }
+ } else {
+ undef $last_term_ornaments;
+ }
+ }
+ }
+ for my $class (qw(Module Distribution)) {
+ # again unsafe meta access?
+ for my $dm (keys %{$CPAN::META->{readwrite}{"CPAN::$class"}}) {
+ next unless $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
+ CPAN->debug("BUG: $class '$dm' was in command state, resetting");
+ delete $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
+ }
+ }
+ if ($GOTOSHELL) {
+ $GOTOSHELL = 0; # not too often
+ $META->savehist if $CPAN::term && $CPAN::term->can("GetHistory");
+ @_ = ($oprompt,"");
+ goto &shell;
+ }
+ }
+ soft_chdir_with_alternatives(\@cwd);
+}
+
+#-> CPAN::soft_chdir_with_alternatives ;
+sub soft_chdir_with_alternatives ($) {
+ my($cwd) = @_;
+ unless (@$cwd) {
+ my $root = File::Spec->rootdir();
+ $CPAN::Frontend->mywarn(qq{Warning: no good directory to chdir to!
+Trying '$root' as temporary haven.
+});
+ push @$cwd, $root;
+ }
+ while () {
+ if (chdir $cwd->[0]) {
+ return;
+ } else {
+ if (@$cwd>1) {
+ $CPAN::Frontend->mywarn(qq{Could not chdir to "$cwd->[0]": $!
+Trying to chdir to "$cwd->[1]" instead.
+});
+ shift @$cwd;
+ } else {
+ $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd->[0]": $!});
+ }
+ }
+ }
+}
+
+sub _flock {
+ my($fh,$mode) = @_;
+ if ( $Config::Config{d_flock} || $Config::Config{d_fcntl_can_lock} ) {
+ return flock $fh, $mode;
+ } elsif (!$Have_warned->{"d_flock"}++) {
+ $CPAN::Frontend->mywarn("Your OS does not seem to support locking; continuing and ignoring all locking issues\n");
+ $CPAN::Frontend->mysleep(5);
+ return 1;
+ } else {
+ return 1;
+ }
+}
+
+sub _yaml_module () {
+ my $yaml_module = $CPAN::Config->{yaml_module} || "YAML";
+ if (
+ $yaml_module ne "YAML"
+ &&
+ !$CPAN::META->has_inst($yaml_module)
+ ) {
+ # $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back to 'YAML'\n");
+ $yaml_module = "YAML";
+ }
+ if ($yaml_module eq "YAML"
+ &&
+ $CPAN::META->has_inst($yaml_module)
+ &&
+ $YAML::VERSION < 0.60
+ &&
+ !$Have_warned->{"YAML"}++
+ ) {
+ $CPAN::Frontend->mywarn("Warning: YAML version '$YAML::VERSION' is too low, please upgrade!\n".
+ "I'll continue but problems are *very* likely to happen.\n"
+ );
+ $CPAN::Frontend->mysleep(5);
+ }
+ return $yaml_module;
+}
+
+# CPAN::_yaml_loadfile
+sub _yaml_loadfile {
+ my($self,$local_file) = @_;
+ return +[] unless -s $local_file;
+ my $yaml_module = _yaml_module;
+ if ($CPAN::META->has_inst($yaml_module)) {
+ # temporarly enable yaml code deserialisation
+ no strict 'refs';
+ # 5.6.2 could not do the local() with the reference
+ # so we do it manually instead
+ my $old_loadcode = ${"$yaml_module\::LoadCode"};
+ ${ "$yaml_module\::LoadCode" } = $CPAN::Config->{yaml_load_code} || 0;
+
+ my ($code, @yaml);
+ if ($code = UNIVERSAL::can($yaml_module, "LoadFile")) {
+ eval { @yaml = $code->($local_file); };
+ if ($@) {
+ # this shall not be done by the frontend
+ die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@);
+ }
+ } elsif ($code = UNIVERSAL::can($yaml_module, "Load")) {
+ local *FH;
+ open FH, $local_file or die "Could not open '$local_file': $!";
+ local $/;
+ my $ystream = <FH>;
+ eval { @yaml = $code->($ystream); };
+ if ($@) {
+ # this shall not be done by the frontend
+ die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@);
+ }
+ }
+ ${"$yaml_module\::LoadCode"} = $old_loadcode;
+ return \@yaml;
+ } else {
+ # this shall not be done by the frontend
+ die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "parse");
+ }
+ return +[];
+}
+
+# CPAN::_yaml_dumpfile
+sub _yaml_dumpfile {
+ my($self,$local_file, at what) = @_;
+ my $yaml_module = _yaml_module;
+ if ($CPAN::META->has_inst($yaml_module)) {
+ my $code;
+ if (UNIVERSAL::isa($local_file, "FileHandle")) {
+ $code = UNIVERSAL::can($yaml_module, "Dump");
+ eval { print $local_file $code->(@what) };
+ } elsif ($code = UNIVERSAL::can($yaml_module, "DumpFile")) {
+ eval { $code->($local_file, at what); };
+ } elsif ($code = UNIVERSAL::can($yaml_module, "Dump")) {
+ local *FH;
+ open FH, ">$local_file" or die "Could not open '$local_file': $!";
+ print FH $code->(@what);
+ }
+ if ($@) {
+ die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"dump",$@);
+ }
+ } else {
+ if (UNIVERSAL::isa($local_file, "FileHandle")) {
+ # I think this case does not justify a warning at all
+ } else {
+ die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "dump");
+ }
+ }
+}
+
+sub _init_sqlite () {
+ unless ($CPAN::META->has_inst("CPAN::SQLite")) {
+ $CPAN::Frontend->mywarn(qq{CPAN::SQLite not installed, trying to work without\n})
+ unless $Have_warned->{"CPAN::SQLite"}++;
+ return;
+ }
+ require CPAN::SQLite::META; # not needed since CVS version of 2006-12-17
+ $CPAN::SQLite ||= CPAN::SQLite::META->new($CPAN::META);
+}
+
+{
+ my $negative_cache = {};
+ sub _sqlite_running {
+ if ($negative_cache->{time} && time < $negative_cache->{time} + 60) {
+ # need to cache the result, otherwise too slow
+ return $negative_cache->{fact};
+ } else {
+ $negative_cache = {}; # reset
+ }
+ my $ret = $CPAN::Config->{use_sqlite} && ($CPAN::SQLite || _init_sqlite());
+ return $ret if $ret; # fast anyway
+ $negative_cache->{time} = time;
+ return $negative_cache->{fact} = $ret;
+ }
+}
+
+$META ||= CPAN->new; # In case we re-eval ourselves we need the ||
+
+# from here on only subs.
+################################################################################
+
+sub _perl_fingerprint {
+ my($self,$other_fingerprint) = @_;
+ my $dll = eval {OS2::DLLname()};
+ my $mtime_dll = 0;
+ if (defined $dll) {
+ $mtime_dll = (-f $dll ? (stat(_))[9] : '-1');
+ }
+ my $mtime_perl = (-f CPAN::find_perl ? (stat(_))[9] : '-1');
+ my $this_fingerprint = {
+ '$^X' => CPAN::find_perl,
+ sitearchexp => $Config::Config{sitearchexp},
+ 'mtime_$^X' => $mtime_perl,
+ 'mtime_dll' => $mtime_dll,
+ };
+ if ($other_fingerprint) {
+ if (exists $other_fingerprint->{'stat($^X)'}) { # repair fp from rev. 1.88_57
+ $other_fingerprint->{'mtime_$^X'} = $other_fingerprint->{'stat($^X)'}[9];
+ }
+ # mandatory keys since 1.88_57
+ for my $key (qw($^X sitearchexp mtime_dll mtime_$^X)) {
+ return unless $other_fingerprint->{$key} eq $this_fingerprint->{$key};
+ }
+ return 1;
+ } else {
+ return $this_fingerprint;
+ }
+}
+
+sub suggest_myconfig () {
+ SUGGEST_MYCONFIG: if(!$INC{'CPAN/MyConfig.pm'}) {
+ $CPAN::Frontend->myprint("You don't seem to have a user ".
+ "configuration (MyConfig.pm) yet.\n");
+ my $new = CPAN::Shell::colorable_makemaker_prompt("Do you want to create a ".
+ "user configuration now? (Y/n)",
+ "yes");
+ if($new =~ m{^y}i) {
+ CPAN::Shell->mkmyconfig();
+ return &checklock;
+ } else {
+ $CPAN::Frontend->mydie("OK, giving up.");
+ }
+ }
+}
+
+#-> sub CPAN::all_objects ;
+sub all_objects {
+ my($mgr,$class) = @_;
+ CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
+ CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
+ CPAN::Index->reload;
+ values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
+}
+
+# Called by shell, not in batch mode. In batch mode I see no risk in
+# having many processes updating something as installations are
+# continually checked at runtime. In shell mode I suspect it is
+# unintentional to open more than one shell at a time
+
+#-> sub CPAN::checklock ;
+sub checklock {
+ my($self) = @_;
+ my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
+ if (-f $lockfile && -M _ > 0) {
+ my $fh = FileHandle->new($lockfile) or
+ $CPAN::Frontend->mydie("Could not open lockfile '$lockfile': $!");
+ my $otherpid = <$fh>;
+ my $otherhost = <$fh>;
+ $fh->close;
+ if (defined $otherpid && $otherpid) {
+ chomp $otherpid;
+ }
+ if (defined $otherhost && $otherhost) {
+ chomp $otherhost;
+ }
+ my $thishost = hostname();
+ if (defined $otherhost && defined $thishost &&
+ $otherhost ne '' && $thishost ne '' &&
+ $otherhost ne $thishost) {
+ $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
+ "reports other host $otherhost and other ".
+ "process $otherpid.\n".
+ "Cannot proceed.\n"));
+ } elsif ($RUN_DEGRADED) {
+ $CPAN::Frontend->mywarn("Running in downgraded mode (experimental)\n");
+ } elsif (defined $otherpid && $otherpid) {
+ return if $$ == $otherpid; # should never happen
+ $CPAN::Frontend->mywarn(
+ qq{
+There seems to be running another CPAN process (pid $otherpid). Contacting...
+});
+ if (kill 0, $otherpid or $!{EPERM}) {
+ $CPAN::Frontend->mywarn(qq{Other job is running.\n});
+ my($ans) =
+ CPAN::Shell::colorable_makemaker_prompt
+ (qq{Shall I try to run in downgraded }.
+ qq{mode? (Y/n)},"y");
+ if ($ans =~ /^y/i) {
+ $CPAN::Frontend->mywarn("Running in downgraded mode (experimental).
+Please report if something unexpected happens\n");
+ $RUN_DEGRADED = 1;
+ for ($CPAN::Config) {
+ # XXX
+ # $_->{build_dir_reuse} = 0; # 2006-11-17 akoenig Why was that?
+ $_->{commandnumber_in_prompt} = 0; # visibility
+ $_->{histfile} = ""; # who should win otherwise?
+ $_->{cache_metadata} = 0; # better would be a lock?
+ $_->{use_sqlite} = 0; # better would be a write lock!
+ $_->{auto_commit} = 0; # we are violent, do not persist
+ $_->{test_report} = 0; # Oliver Paukstadt had sent wrong reports in degraded mode
+ }
+ } else {
+ $CPAN::Frontend->mydie("
+You may want to kill the other job and delete the lockfile. On UNIX try:
+ kill $otherpid
+ rm $lockfile
+");
+ }
+ } elsif (-w $lockfile) {
+ my($ans) =
+ CPAN::Shell::colorable_makemaker_prompt
+ (qq{Other job not responding. Shall I overwrite }.
+ qq{the lockfile '$lockfile'? (Y/n)},"y");
+ $CPAN::Frontend->myexit("Ok, bye\n")
+ unless $ans =~ /^y/i;
+ } else {
+ Carp::croak(
+ qq{Lockfile '$lockfile' not writable by you. }.
+ qq{Cannot proceed.\n}.
+ qq{ On UNIX try:\n}.
+ qq{ rm '$lockfile'\n}.
+ qq{ and then rerun us.\n}
+ );
+ }
+ } else {
+ $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Found invalid lockfile ".
+ "'$lockfile', please remove. Cannot proceed.\n"));
+ }
+ }
+ my $dotcpan = $CPAN::Config->{cpan_home};
+ eval { File::Path::mkpath($dotcpan);};
+ if ($@) {
+ # A special case at least for Jarkko.
+ my $firsterror = $@;
+ my $seconderror;
+ my $symlinkcpan;
+ if (-l $dotcpan) {
+ $symlinkcpan = readlink $dotcpan;
+ die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
+ eval { File::Path::mkpath($symlinkcpan); };
+ if ($@) {
+ $seconderror = $@;
+ } else {
+ $CPAN::Frontend->mywarn(qq{
+Working directory $symlinkcpan created.
+});
+ }
+ }
+ unless (-d $dotcpan) {
+ my $mess = qq{
+Your configuration suggests "$dotcpan" as your
+CPAN.pm working directory. I could not create this directory due
+to this error: $firsterror\n};
+ $mess .= qq{
+As "$dotcpan" is a symlink to "$symlinkcpan",
+I tried to create that, but I failed with this error: $seconderror
+} if $seconderror;
+ $mess .= qq{
+Please make sure the directory exists and is writable.
+};
+ $CPAN::Frontend->mywarn($mess);
+ return suggest_myconfig;
+ }
+ } # $@ after eval mkpath $dotcpan
+ if (0) { # to test what happens when a race condition occurs
+ for (reverse 1..10) {
+ print $_, "\n";
+ sleep 1;
+ }
+ }
+ # locking
+ if (!$RUN_DEGRADED && !$self->{LOCKFH}) {
+ my $fh;
+ unless ($fh = FileHandle->new("+>>$lockfile")) {
+ if ($! =~ /Permission/) {
+ $CPAN::Frontend->mywarn(qq{
+
+Your configuration suggests that CPAN.pm should use a working
+directory of
+ $CPAN::Config->{cpan_home}
+Unfortunately we could not create the lock file
+ $lockfile
+due to permission problems.
+
+Please make sure that the configuration variable
+ \$CPAN::Config->{cpan_home}
+points to a directory where you can write a .lock file. You can set
+this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your
+\@INC path;
+});
+ return suggest_myconfig;
+ }
+ }
+ my $sleep = 1;
+ while (!CPAN::_flock($fh, LOCK_EX|LOCK_NB)) {
+ if ($sleep>10) {
+ $CPAN::Frontend->mydie("Giving up\n");
+ }
+ $CPAN::Frontend->mysleep($sleep++);
+ $CPAN::Frontend->mywarn("Could not lock lockfile with flock: $!; retrying\n");
+ }
+
+ seek $fh, 0, 0;
+ truncate $fh, 0;
+ $fh->autoflush(1);
+ $fh->print($$, "\n");
+ $fh->print(hostname(), "\n");
+ $self->{LOCK} = $lockfile;
+ $self->{LOCKFH} = $fh;
+ }
+ $SIG{TERM} = sub {
+ my $sig = shift;
+ &cleanup;
+ $CPAN::Frontend->mydie("Got SIG$sig, leaving");
+ };
+ $SIG{INT} = sub {
+ # no blocks!!!
+ my $sig = shift;
+ &cleanup if $Signal;
+ die "Got yet another signal" if $Signal > 1;
+ $CPAN::Frontend->mydie("Got another SIG$sig") if $Signal;
+ $CPAN::Frontend->mywarn("Caught SIG$sig, trying to continue\n");
+ $Signal++;
+ };
+
+# From: Larry Wall <larry at wall.org>
+# Subject: Re: deprecating SIGDIE
+# To: perl5-porters at perl.org
+# Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
+#
+# The original intent of __DIE__ was only to allow you to substitute one
+# kind of death for another on an application-wide basis without respect
+# to whether you were in an eval or not. As a global backstop, it should
+# not be used any more lightly (or any more heavily :-) than class
+# UNIVERSAL. Any attempt to build a general exception model on it should
+# be politely squashed. Any bug that causes every eval {} to have to be
+# modified should be not so politely squashed.
+#
+# Those are my current opinions. It is also my optinion that polite
+# arguments degenerate to personal arguments far too frequently, and that
+# when they do, it's because both people wanted it to, or at least didn't
+# sufficiently want it not to.
+#
+# Larry
+
+ # global backstop to cleanup if we should really die
+ $SIG{__DIE__} = \&cleanup;
+ $self->debug("Signal handler set.") if $CPAN::DEBUG;
+}
+
+#-> sub CPAN::DESTROY ;
+sub DESTROY {
+ &cleanup; # need an eval?
+}
+
+#-> sub CPAN::anycwd ;
+sub anycwd () {
+ my $getcwd;
+ $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
+ CPAN->$getcwd();
+}
+
+#-> sub CPAN::cwd ;
+sub cwd {Cwd::cwd();}
+
+#-> sub CPAN::getcwd ;
+sub getcwd {Cwd::getcwd();}
+
+#-> sub CPAN::fastcwd ;
+sub fastcwd {Cwd::fastcwd();}
+
+#-> sub CPAN::backtickcwd ;
+sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd}
+
+#-> sub CPAN::find_perl ;
+sub find_perl () {
+ my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
+ unless ($perl) {
+ my $candidate = File::Spec->catfile($CPAN::iCwd,$^X);
+ $^X = $perl = $candidate if MM->maybe_command($candidate);
+ }
+ unless ($perl) {
+ my ($component,$perl_name);
+ DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
+ PATH_COMPONENT: foreach $component (File::Spec->path(),
+ $Config::Config{'binexp'}) {
+ next unless defined($component) && $component;
+ my($abs) = File::Spec->catfile($component,$perl_name);
+ if (MM->maybe_command($abs)) {
+ $^X = $perl = $abs;
+ last DIST_PERLNAME;
+ }
+ }
+ }
+ }
+ return $perl;
+}
+
+
+#-> sub CPAN::exists ;
+sub exists {
+ my($mgr,$class,$id) = @_;
+ CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
+ CPAN::Index->reload;
+ ### Carp::croak "exists called without class argument" unless $class;
+ $id ||= "";
+ $id =~ s/:+/::/g if $class eq "CPAN::Module";
+ my $exists;
+ if (CPAN::_sqlite_running) {
+ $exists = (exists $META->{readonly}{$class}{$id} or
+ $CPAN::SQLite->set($class, $id));
+ } else {
+ $exists = exists $META->{readonly}{$class}{$id};
+ }
+ $exists ||= exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
+}
+
+#-> sub CPAN::delete ;
+sub delete {
+ my($mgr,$class,$id) = @_;
+ delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
+ delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
+}
+
+#-> sub CPAN::has_usable
+# has_inst is sometimes too optimistic, we should replace it with this
+# has_usable whenever a case is given
+sub has_usable {
+ my($self,$mod,$message) = @_;
+ return 1 if $HAS_USABLE->{$mod};
+ my $has_inst = $self->has_inst($mod,$message);
+ return unless $has_inst;
+ my $usable;
+ $usable = {
+ LWP => [ # we frequently had "Can't locate object
+ # method "new" via package "LWP::UserAgent" at
+ # (eval 69) line 2006
+ sub {require LWP},
+ sub {require LWP::UserAgent},
+ sub {require HTTP::Request},
+ sub {require URI::URL},
+ ],
+ 'Net::FTP' => [
+ sub {require Net::FTP},
+ sub {require Net::Config},
+ ],
+ 'File::HomeDir' => [
+ sub {require File::HomeDir;
+ unless (CPAN::Version->vge(File::HomeDir::->VERSION, 0.52)) {
+ for ("Will not use File::HomeDir, need 0.52\n") {
+ $CPAN::Frontend->mywarn($_);
+ die $_;
+ }
+ }
+ },
+ ],
+ 'Archive::Tar' => [
+ sub {require Archive::Tar;
+ unless (CPAN::Version->vge(Archive::Tar::->VERSION, 1.50)) {
+ for ("Will not use Archive::Tar, need 1.00\n") {
+ $CPAN::Frontend->mywarn($_);
+ die $_;
+ }
+ }
+ unless (CPAN::Version->vge(Archive::Tar::->VERSION, 1.50)) {
+ my $atv = Archive::Tar->VERSION;
+ $CPAN::Frontend->mywarn("You have Archive::Tar $atv, but 1.50 or later is recommended. Please upgrade.\n");
+ }
+ },
+ ],
+ 'File::Temp' => [
+ # XXX we should probably delete from
+ # %INC too so we can load after we
+ # installed a new enough version --
+ # I'm not sure.
+ sub {require File::Temp;
+ unless (CPAN::Version->vge(File::Temp::->VERSION,0.16)) {
+ for ("Will not use File::Temp, need 0.16\n") {
+ $CPAN::Frontend->mywarn($_);
+ die $_;
+ }
+ }
+ },
+ ]
+ };
+ if ($usable->{$mod}) {
+ for my $c (0..$#{$usable->{$mod}}) {
+ my $code = $usable->{$mod}[$c];
+ my $ret = eval { &$code() };
+ $ret = "" unless defined $ret;
+ if ($@) {
+ # warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
+ return;
+ }
+ }
+ }
+ return $HAS_USABLE->{$mod} = 1;
+}
+
+#-> sub CPAN::has_inst
+sub has_inst {
+ my($self,$mod,$message) = @_;
+ Carp::croak("CPAN->has_inst() called without an argument")
+ unless defined $mod;
+ my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}},
+ keys %{$CPAN::Config->{dontload_hash}||{}},
+ @{$CPAN::Config->{dontload_list}||[]};
+ if (defined $message && $message eq "no" # afair only used by Nox
+ ||
+ $dont{$mod}
+ ) {
+ $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
+ return 0;
+ }
+ my $file = $mod;
+ my $obj;
+ $file =~ s|::|/|g;
+ $file .= ".pm";
+ if ($INC{$file}) {
+ # checking %INC is wrong, because $INC{LWP} may be true
+ # although $INC{"URI/URL.pm"} may have failed. But as
+ # I really want to say "bla loaded OK", I have to somehow
+ # cache results.
+ ### warn "$file in %INC"; #debug
+ return 1;
+ } elsif (eval { require $file }) {
+ # eval is good: if we haven't yet read the database it's
+ # perfect and if we have installed the module in the meantime,
+ # it tries again. The second require is only a NOOP returning
+ # 1 if we had success, otherwise it's retrying
+
+ my $mtime = (stat $INC{$file})[9];
+ # privileged files loaded by has_inst; Note: we use $mtime
+ # as a proxy for a checksum.
+ $CPAN::Shell::reload->{$file} = $mtime;
+ my $v = eval "\$$mod\::VERSION";
+ $v = $v ? " (v$v)" : "";
+ CPAN::Shell->optprint("load_module","CPAN: $mod loaded ok$v\n");
+ if ($mod eq "CPAN::WAIT") {
+ push @CPAN::Shell::ISA, 'CPAN::WAIT';
+ }
+ return 1;
+ } elsif ($mod eq "Net::FTP") {
+ $CPAN::Frontend->mywarn(qq{
+ Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
+ if you just type
+ install Bundle::libnet
+
+}) unless $Have_warned->{"Net::FTP"}++;
+ $CPAN::Frontend->mysleep(3);
+ } elsif ($mod eq "Digest::SHA") {
+ if ($Have_warned->{"Digest::SHA"}++) {
+ $CPAN::Frontend->mywarn(qq{CPAN: checksum security checks disabled }.
+ qq{because Digest::SHA not installed.\n});
+ } else {
+ $CPAN::Frontend->mywarn(qq{
+ CPAN: checksum security checks disabled because Digest::SHA not installed.
+ Please consider installing the Digest::SHA module.
+
+});
+ $CPAN::Frontend->mysleep(2);
+ }
+ } elsif ($mod eq "Module::Signature") {
+ # NOT prefs_lookup, we are not a distro
+ my $check_sigs = $CPAN::Config->{check_sigs};
+ if (not $check_sigs) {
+ # they do not want us:-(
+ } elsif (not $Have_warned->{"Module::Signature"}++) {
+ # No point in complaining unless the user can
+ # reasonably install and use it.
+ if (eval { require Crypt::OpenPGP; 1 } ||
+ (
+ defined $CPAN::Config->{'gpg'}
+ &&
+ $CPAN::Config->{'gpg'} =~ /\S/
+ )
+ ) {
+ $CPAN::Frontend->mywarn(qq{
+ CPAN: Module::Signature security checks disabled because Module::Signature
+ not installed. Please consider installing the Module::Signature module.
+ You may also need to be able to connect over the Internet to the public
+ keyservers like pgp.mit.edu (port 11371).
+
+});
+ $CPAN::Frontend->mysleep(2);
+ }
+ }
+ } else {
+ delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
+ }
+ return 0;
+}
+
+#-> sub CPAN::instance ;
+sub instance {
+ my($mgr,$class,$id) = @_;
+ CPAN::Index->reload;
+ $id ||= "";
+ # unsafe meta access, ok?
+ return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
+ $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
+}
+
+#-> sub CPAN::new ;
+sub new {
+ bless {}, shift;
+}
+
+#-> sub CPAN::cleanup ;
+sub cleanup {
+ # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]";
+ local $SIG{__DIE__} = '';
+ my($message) = @_;
+ my $i = 0;
+ my $ineval = 0;
+ my($subroutine);
+ while ((undef,undef,undef,$subroutine) = caller(++$i)) {
+ $ineval = 1, last if
+ $subroutine eq '(eval)';
+ }
+ return if $ineval && !$CPAN::End;
+ return unless defined $META->{LOCK};
+ return unless -f $META->{LOCK};
+ $META->savehist;
+ close $META->{LOCKFH};
+ unlink $META->{LOCK};
+ # require Carp;
+ # Carp::cluck("DEBUGGING");
+ if ( $CPAN::CONFIG_DIRTY ) {
+ $CPAN::Frontend->mywarn("Warning: Configuration not saved.\n");
+ }
+ $CPAN::Frontend->myprint("Lockfile removed.\n");
+}
+
+#-> sub CPAN::readhist
+sub readhist {
+ my($self,$term,$histfile) = @_;
+ my $histsize = $CPAN::Config->{'histsize'} || 100;
+ $term->Attribs->{'MaxHistorySize'} = $histsize if (defined($term->Attribs->{'MaxHistorySize'}));
+ my($fh) = FileHandle->new;
+ open $fh, "<$histfile" or return;
+ local $/ = "\n";
+ while (<$fh>) {
+ chomp;
+ $term->AddHistory($_);
+ }
+ close $fh;
+}
+
+#-> sub CPAN::savehist
+sub savehist {
+ my($self) = @_;
+ my($histfile,$histsize);
+ unless ($histfile = $CPAN::Config->{'histfile'}) {
+ $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
+ return;
+ }
+ $histsize = $CPAN::Config->{'histsize'} || 100;
+ if ($CPAN::term) {
+ unless ($CPAN::term->can("GetHistory")) {
+ $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
+ return;
+ }
+ } else {
+ return;
+ }
+ my @h = $CPAN::term->GetHistory;
+ splice @h, 0, @h-$histsize if @h>$histsize;
+ my($fh) = FileHandle->new;
+ open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
+ local $\ = local $, = "\n";
+ print $fh @h;
+ close $fh;
+}
+
+#-> sub CPAN::is_tested
+sub is_tested {
+ my($self,$what,$when) = @_;
+ unless ($what) {
+ Carp::cluck("DEBUG: empty what");
+ return;
+ }
+ $self->{is_tested}{$what} = $when;
+}
+
+#-> sub CPAN::reset_tested
+# forget all distributions tested -- resets what gets included in PERL5LIB
+sub reset_tested {
+ my ($self) = @_;
+ $self->{is_tested} = {};
+}
+
+#-> sub CPAN::is_installed
+# unsets the is_tested flag: as soon as the thing is installed, it is
+# not needed in set_perl5lib anymore
+sub is_installed {
+ my($self,$what) = @_;
+ delete $self->{is_tested}{$what};
+}
+
+sub _list_sorted_descending_is_tested {
+ my($self) = @_;
+ sort
+ { ($self->{is_tested}{$b}||0) <=> ($self->{is_tested}{$a}||0) }
+ keys %{$self->{is_tested}}
+}
+
+#-> sub CPAN::set_perl5lib
+# Notes on max environment variable length:
+# - Win32 : XP or later, 8191; Win2000 or NT4, 2047
+{
+my $fh;
+sub set_perl5lib {
+ my($self,$for) = @_;
+ unless ($for) {
+ (undef,undef,undef,$for) = caller(1);
+ $for =~ s/.*://;
+ }
+ $self->{is_tested} ||= {};
+ return unless %{$self->{is_tested}};
+ my $env = $ENV{PERL5LIB};
+ $env = $ENV{PERLLIB} unless defined $env;
+ my @env;
+ push @env, split /\Q$Config::Config{path_sep}\E/, $env if defined $env and length $env;
+ #my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
+ #$CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
+
+ my @dirs = map {("$_/blib/arch", "$_/blib/lib")} $self->_list_sorted_descending_is_tested;
+ return if !@dirs;
+
+ if (@dirs < 12) {
+ $CPAN::Frontend->optprint('perl5lib', "Prepending @dirs to PERL5LIB for '$for'\n");
+ $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
+ } elsif (@dirs < 24 ) {
+ my @d = map {my $cp = $_;
+ $cp =~ s/^\Q$CPAN::Config->{build_dir}\E/%BUILDDIR%/;
+ $cp
+ } @dirs;
+ $CPAN::Frontend->optprint('perl5lib', "Prepending @d to PERL5LIB; ".
+ "%BUILDDIR%=$CPAN::Config->{build_dir} ".
+ "for '$for'\n"
+ );
+ $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
+ } else {
+ my $cnt = keys %{$self->{is_tested}};
+ $CPAN::Frontend->optprint('perl5lib', "Prepending blib/arch and blib/lib of ".
+ "$cnt build dirs to PERL5LIB; ".
+ "for '$for'\n"
+ );
+ $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
+ }
+}}
+
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+CPAN - query, download and build perl modules from CPAN sites
+
+=head1 SYNOPSIS
+
+Interactive mode:
+
+ perl -MCPAN -e shell
+
+--or--
+
+ cpan
+
+Basic commands:
+
+ # Modules:
+
+ cpan> install Acme::Meta # in the shell
+
+ CPAN::Shell->install("Acme::Meta"); # in perl
+
+ # Distributions:
+
+ cpan> install NWCLARK/Acme-Meta-0.02.tar.gz # in the shell
+
+ CPAN::Shell->
+ install("NWCLARK/Acme-Meta-0.02.tar.gz"); # in perl
+
+ # module objects:
+
+ $mo = CPAN::Shell->expandany($mod);
+ $mo = CPAN::Shell->expand("Module",$mod); # same thing
+
+ # distribution objects:
+
+ $do = CPAN::Shell->expand("Module",$mod)->distribution;
+ $do = CPAN::Shell->expandany($distro); # same thing
+ $do = CPAN::Shell->expand("Distribution",
+ $distro); # same thing
+
+=head1 DESCRIPTION
+
+The CPAN module automates or at least simplifies the make and install
+of perl modules and extensions. It includes some primitive searching
+capabilities and knows how to use Net::FTP, LWP, and certain external
+download clients to fetch distributions from the net.
+
+These are fetched from one or more mirrored CPAN (Comprehensive
+Perl Archive Network) sites and unpacked in a dedicated directory.
+
+The CPAN module also supports named and versioned
+I<bundles> of modules. Bundles simplify handling of sets of
+related modules. See Bundles below.
+
+The package contains a session manager and a cache manager. The
+session manager keeps track of what has been fetched, built, and
+installed in the current session. The cache manager keeps track of the
+disk space occupied by the make processes and deletes excess space
+using a simple FIFO mechanism.
+
+All methods provided are accessible in a programmer style and in an
+interactive shell style.
+
+=head2 CPAN::shell([$prompt, $command]) Starting Interactive Mode
+
+Enter interactive mode by running
+
+ perl -MCPAN -e shell
+
+or
+
+ cpan
+
+which puts you into a readline interface. If C<Term::ReadKey> and
+either of C<Term::ReadLine::Perl> or C<Term::ReadLine::Gnu> are installed,
+history and command completion are supported.
+
+Once at the command line, type C<h> for one-page help
+screen; the rest should be self-explanatory.
+
+The function call C<shell> takes two optional arguments: one the
+prompt, the second the default initial command line (the latter
+only works if a real ReadLine interface module is installed).
+
+The most common uses of the interactive modes are
+
+=over 2
+
+=item Searching for authors, bundles, distribution files and modules
+
+There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
+for each of the four categories and another, C<i> for any of the
+mentioned four. Each of the four entities is implemented as a class
+with slightly differing methods for displaying an object.
+
+Arguments to these commands are either strings exactly matching
+the identification string of an object, or regular expressions
+matched case-insensitively against various attributes of the
+objects. The parser only recognizes a regular expression when you
+enclose it with slashes.
+
+The principle is that the number of objects found influences how an
+item is displayed. If the search finds one item, the result is
+displayed with the rather verbose method C<as_string>, but if
+more than one is found, each object is displayed with the terse method
+C<as_glimpse>.
+
+Examples:
+
+ cpan> m Acme::MetaSyntactic
+ Module id = Acme::MetaSyntactic
+ CPAN_USERID BOOK (Philippe Bruhat (BooK) <[...]>)
+ CPAN_VERSION 0.99
+ CPAN_FILE B/BO/BOOK/Acme-MetaSyntactic-0.99.tar.gz
+ UPLOAD_DATE 2006-11-06
+ MANPAGE Acme::MetaSyntactic - Themed metasyntactic variables names
+ INST_FILE /usr/local/lib/perl/5.10.0/Acme/MetaSyntactic.pm
+ INST_VERSION 0.99
+ cpan> a BOOK
+ Author id = BOOK
+ EMAIL [...]
+ FULLNAME Philippe Bruhat (BooK)
+ cpan> d BOOK/Acme-MetaSyntactic-0.99.tar.gz
+ Distribution id = B/BO/BOOK/Acme-MetaSyntactic-0.99.tar.gz
+ CPAN_USERID BOOK (Philippe Bruhat (BooK) <[...]>)
+ CONTAINSMODS Acme::MetaSyntactic Acme::MetaSyntactic::Alias [...]
+ UPLOAD_DATE 2006-11-06
+ cpan> m /lorem/
+ Module = Acme::MetaSyntactic::loremipsum (BOOK/Acme-MetaSyntactic-0.99.tar.gz)
+ Module Text::Lorem (ADEOLA/Text-Lorem-0.3.tar.gz)
+ Module Text::Lorem::More (RKRIMEN/Text-Lorem-More-0.12.tar.gz)
+ Module Text::Lorem::More::Source (RKRIMEN/Text-Lorem-More-0.12.tar.gz)
+ cpan> i /berlin/
+ Distribution BEATNIK/Filter-NumberLines-0.02.tar.gz
+ Module = DateTime::TimeZone::Europe::Berlin (DROLSKY/DateTime-TimeZone-0.7904.tar.gz)
+ Module Filter::NumberLines (BEATNIK/Filter-NumberLines-0.02.tar.gz)
+ Author [...]
+
+The examples illustrate several aspects: the first three queries
+target modules, authors, or distros directly and yield exactly one
+result. The last two use regular expressions and yield several
+results. The last one targets all of bundles, modules, authors, and
+distros simultaneously. When more than one result is available, they
+are printed in one-line format.
+
+=item C<get>, C<make>, C<test>, C<install>, C<clean> modules or distributions
+
+These commands take any number of arguments and investigate what is
+necessary to perform the action. If the argument is a distribution
+file name (recognized by embedded slashes), it is processed. If it is
+a module, CPAN determines the distribution file in which this module
+is included and processes that, following any dependencies named in
+the module's META.yml or Makefile.PL (this behavior is controlled by
+the configuration parameter C<prerequisites_policy>.)
+
+C<get> downloads a distribution file and untars or unzips it, C<make>
+builds it, C<test> runs the test suite, and C<install> installs it.
+
+Any C<make> or C<test> is run unconditionally. An
+
+ install <distribution_file>
+
+is also run unconditionally. But for
+
+ install <module>
+
+CPAN checks whether an install is needed and prints
+I<module up to date> if the distribution file containing
+the module doesn't need updating.
+
+CPAN also keeps track of what it has done within the current session
+and doesn't try to build a package a second time regardless of whether it
+succeeded or not. It does not repeat a test run if the test
+has been run successfully before. Same for install runs.
+
+The C<force> pragma may precede another command (currently: C<get>,
+C<make>, C<test>, or C<install>) to execute the command from scratch
+and attempt to continue past certain errors. See the section below on
+the C<force> and the C<fforce> pragma.
+
+The C<notest> pragma skips the test part in the build
+process.
+
+Example:
+
+ cpan> notest install Tk
+
+A C<clean> command results in a
+
+ make clean
+
+being executed within the distribution file's working directory.
+
+=item C<readme>, C<perldoc>, C<look> module or distribution
+
+C<readme> displays the README file of the associated distribution.
+C<Look> gets and untars (if not yet done) the distribution file,
+changes to the appropriate directory and opens a subshell process in
+that directory. C<perldoc> displays the module's pod documentation
+in html or plain text format.
+
+=item C<ls> author
+
+=item C<ls> globbing_expression
+
+The first form lists all distribution files in and below an author's
+CPAN directory as stored in the CHECKUMS files distributed on
+CPAN. The listing recurses into subdirectories.
+
+The second form limits or expands the output with shell
+globbing as in the following examples:
+
+ ls JV/make*
+ ls GSAR/*make*
+ ls */*make*
+
+The last example is very slow and outputs extra progress indicators
+that break the alignment of the result.
+
+Note that globbing only lists directories explicitly asked for, for
+example FOO/* will not list FOO/bar/Acme-Sthg-n.nn.tar.gz. This may be
+regarded as a bug that may be changed in some future version.
+
+=item C<failed>
+
+The C<failed> command reports all distributions that failed on one of
+C<make>, C<test> or C<install> for some reason in the currently
+running shell session.
+
+=item Persistence between sessions
+
+If the C<YAML> or the C<YAML::Syck> module is installed a record of
+the internal state of all modules is written to disk after each step.
+The files contain a signature of the currently running perl version
+for later perusal.
+
+If the configurations variable C<build_dir_reuse> is set to a true
+value, then CPAN.pm reads the collected YAML files. If the stored
+signature matches the currently running perl, the stored state is
+loaded into memory such that persistence between sessions
+is effectively established.
+
+=item The C<force> and the C<fforce> pragma
+
+To speed things up in complex installation scenarios, CPAN.pm keeps
+track of what it has already done and refuses to do some things a
+second time. A C<get>, a C<make>, and an C<install> are not repeated.
+A C<test> is repeated only if the previous test was unsuccessful. The
+diagnostic message when CPAN.pm refuses to do something a second time
+is one of I<Has already been >C<unwrapped|made|tested successfully> or
+something similar. Another situation where CPAN refuses to act is an
+C<install> if the corresponding C<test> was not successful.
+
+In all these cases, the user can override this stubborn behaviour by
+prepending the command with the word force, for example:
+
+ cpan> force get Foo
+ cpan> force make AUTHOR/Bar-3.14.tar.gz
+ cpan> force test Baz
+ cpan> force install Acme::Meta
+
+Each I<forced> command is executed with the corresponding part of its
+memory erased.
+
+The C<fforce> pragma is a variant that emulates a C<force get> which
+erases the entire memory followed by the action specified, effectively
+restarting the whole get/make/test/install procedure from scratch.
+
+=item Lockfile
+
+Interactive sessions maintain a lockfile, by default C<~/.cpan/.lock>.
+Batch jobs can run without a lockfile and not disturb each other.
+
+The shell offers to run in I<downgraded mode> when another process is
+holding the lockfile. This is an experimental feature that is not yet
+tested very well. This second shell then does not write the history
+file, does not use the metadata file, and has a different prompt.
+
+=item Signals
+
+CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
+in the cpan-shell, it is intended that you can press C<^C> anytime and
+return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
+to clean up and leave the shell loop. You can emulate the effect of a
+SIGTERM by sending two consecutive SIGINTs, which usually means by
+pressing C<^C> twice.
+
+CPAN.pm ignores SIGPIPE. If the user sets C<inactivity_timeout>, a
+SIGALRM is used during the run of the C<perl Makefile.PL> or C<perl
+Build.PL> subprocess.
+
+=back
+
+=head2 CPAN::Shell
+
+The commands available in the shell interface are methods in
+the package CPAN::Shell. If you enter the shell command, your
+input is split by the Text::ParseWords::shellwords() routine, which
+acts like most shells do. The first word is interpreted as the
+method to be invoked, and the rest of the words are treated as the method's arguments.
+Continuation lines are supported by ending a line with a
+literal backslash.
+
+=head2 autobundle
+
+C<autobundle> writes a bundle file into the
+C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
+a list of all modules that are both available from CPAN and currently
+installed within @INC. The name of the bundle file is based on the
+current date and a counter.
+
+=head2 hosts
+
+Note: this feature is still in alpha state and may change in future
+versions of CPAN.pm
+
+This commands provides a statistical overview over recent download
+activities. The data for this is collected in the YAML file
+C<FTPstats.yml> in your C<cpan_home> directory. If no YAML module is
+configured or YAML not installed, no stats are provided.
+
+=head2 mkmyconfig
+
+mkmyconfig() writes your own CPAN::MyConfig file into your C<~/.cpan/>
+directory so that you can save your own preferences instead of the
+system-wide ones.
+
+=head2 recent ***EXPERIMENTAL COMMAND***
+
+The C<recent> command downloads a list of recent uploads to CPAN and
+displays them I<slowly>. While the command is running, a $SIG{INT}
+exits the loop after displaying the current item.
+
+B<Note>: This command requires XML::LibXML installed.
+
+B<Note>: This whole command currently is just a hack and will
+probably change in future versions of CPAN.pm, but the general
+approach will likely remain.
+
+B<Note>: See also L<smoke>
+
+=head2 recompile
+
+recompile() is a special command that takes no argument and
+runs the make/test/install cycle with brute force over all installed
+dynamically loadable extensions (aka XS modules) with 'force' in
+effect. The primary purpose of this command is to finish a network
+installation. Imagine you have a common source tree for two different
+architectures. You decide to do a completely independent fresh
+installation. You start on one architecture with the help of a Bundle
+file produced earlier. CPAN installs the whole Bundle for you, but
+when you try to repeat the job on the second architecture, CPAN
+responds with a C<"Foo up to date"> message for all modules. So you
+invoke CPAN's recompile on the second architecture and you're done.
+
+Another popular use for C<recompile> is to act as a rescue in case your
+perl breaks binary compatibility. If one of the modules that CPAN uses
+is in turn depending on binary compatibility (so you cannot run CPAN
+commands), then you should try the CPAN::Nox module for recovery.
+
+=head2 report Bundle|Distribution|Module
+
+The C<report> command temporarily turns on the C<test_report> config
+variable, then runs the C<force test> command with the given
+arguments. The C<force> pragma reruns the tests and repeats
+every step that might have failed before.
+
+=head2 smoke ***EXPERIMENTAL COMMAND***
+
+B<*** WARNING: this command downloads and executes software from CPAN to
+your computer of completely unknown status. You should never do
+this with your normal account and better have a dedicated well
+separated and secured machine to do this. ***>
+
+The C<smoke> command takes the list of recent uploads to CPAN as
+provided by the C<recent> command and tests them all. While the
+command is running $SIG{INT} is defined to mean that the current item
+shall be skipped.
+
+B<Note>: This whole command currently is just a hack and will
+probably change in future versions of CPAN.pm, but the general
+approach will likely remain.
+
+B<Note>: See also L<recent>
+
+=head2 upgrade [Module|/Regex/]...
+
+The C<upgrade> command first runs an C<r> command with the given
+arguments and then installs the newest versions of all modules that
+were listed by that.
+
+=head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
+
+Although it may be considered internal, the class hierarchy does matter
+for both users and programmer. CPAN.pm deals with the four
+classes mentioned above, and those classes all share a set of methods. Classical
+single polymorphism is in effect. A metaclass object registers all
+objects of all kinds and indexes them with a string. The strings
+referencing objects have a separated namespace (well, not completely
+separated):
+
+ Namespace Class
+
+ words containing a "/" (slash) Distribution
+ words starting with Bundle:: Bundle
+ everything else Module or Author
+
+Modules know their associated Distribution objects. They always refer
+to the most recent official release. Developers may mark their releases
+as unstable development versions (by inserting an underbar into the
+module version number which will also be reflected in the distribution
+name when you run 'make dist'), so the really hottest and newest
+distribution is not always the default. If a module Foo circulates
+on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
+way to install version 1.23 by saying
+
+ install Foo
+
+This would install the complete distribution file (say
+BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
+like to install version 1.23_90, you need to know where the
+distribution file resides on CPAN relative to the authors/id/
+directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
+so you would have to say
+
+ install BAR/Foo-1.23_90.tar.gz
+
+The first example will be driven by an object of the class
+CPAN::Module, the second by an object of class CPAN::Distribution.
+
+=head2 Integrating local directories
+
+Note: this feature is still in alpha state and may change in future
+versions of CPAN.pm
+
+Distribution objects are normally distributions from the CPAN, but
+there is a slightly degenerate case for Distribution objects, too, of
+projects held on the local disk. These distribution objects have the
+same name as the local directory and end with a dot. A dot by itself
+is also allowed for the current directory at the time CPAN.pm was
+used. All actions such as C<make>, C<test>, and C<install> are applied
+directly to that directory. This gives the command C<cpan .> an
+interesting touch: while the normal mantra of installing a CPAN module
+without CPAN.pm is one of
+
+ perl Makefile.PL perl Build.PL
+ ( go and get prerequisites )
+ make ./Build
+ make test ./Build test
+ make install ./Build install
+
+the command C<cpan .> does all of this at once. It figures out which
+of the two mantras is appropriate, fetches and installs all
+prerequisites, takes care of them recursively, and finally finishes the
+installation of the module in the current directory, be it a CPAN
+module or not.
+
+The typical usage case is for private modules or working copies of
+projects from remote repositories on the local disk.
+
+=head2 Redirection
+
+The usual shell redirection symbols C< | > and C<< > >> are recognized
+by the cpan shell B<only when surrounded by whitespace>. So piping to
+pager or redirecting output into a file works somewhat as in a normal
+shell, with the stipulation that you must type extra spaces.
+
+=head1 CONFIGURATION
+
+When the CPAN module is used for the first time, a configuration
+dialogue tries to determine a couple of site specific options. The
+result of the dialog is stored in a hash reference C< $CPAN::Config >
+in a file CPAN/Config.pm.
+
+Default values defined in the CPAN/Config.pm file can be
+overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
+best placed in C<$HOME/.cpan/CPAN/MyConfig.pm>, because C<$HOME/.cpan> is
+added to the search path of the CPAN module before the use() or
+require() statements. The mkmyconfig command writes this file for you.
+
+The C<o conf> command has various bells and whistles:
+
+=over
+
+=item completion support
+
+If you have a ReadLine module installed, you can hit TAB at any point
+of the commandline and C<o conf> will offer you completion for the
+built-in subcommands and/or config variable names.
+
+=item displaying some help: o conf help
+
+Displays a short help
+
+=item displaying current values: o conf [KEY]
+
+Displays the current value(s) for this config variable. Without KEY,
+displays all subcommands and config variables.
+
+Example:
+
+ o conf shell
+
+If KEY starts and ends with a slash, the string in between is
+treated as a regular expression and only keys matching this regex
+are displayed
+
+Example:
+
+ o conf /color/
+
+=item changing of scalar values: o conf KEY VALUE
+
+Sets the config variable KEY to VALUE. The empty string can be
+specified as usual in shells, with C<''> or C<"">
+
+Example:
+
+ o conf wget /usr/bin/wget
+
+=item changing of list values: o conf KEY SHIFT|UNSHIFT|PUSH|POP|SPLICE|LIST
+
+If a config variable name ends with C<list>, it is a list. C<o conf
+KEY shift> removes the first element of the list, C<o conf KEY pop>
+removes the last element of the list. C<o conf KEYS unshift LIST>
+prepends a list of values to the list, C<o conf KEYS push LIST>
+appends a list of valued to the list.
+
+Likewise, C<o conf KEY splice LIST> passes the LIST to the corresponding
+splice command.
+
+Finally, any other list of arguments is taken as a new list value for
+the KEY variable discarding the previous value.
+
+Examples:
+
+ o conf urllist unshift http://cpan.dev.local/CPAN
+ o conf urllist splice 3 1
+ o conf urllist http://cpan1.local http://cpan2.local ftp://ftp.perl.org
+
+=item reverting to saved: o conf defaults
+
+Reverts all config variables to the state in the saved config file.
+
+=item saving the config: o conf commit
+
+Saves all config variables to the current config file (CPAN/Config.pm
+or CPAN/MyConfig.pm that was loaded at start).
+
+=back
+
+The configuration dialog can be started any time later again by
+issuing the command C< o conf init > in the CPAN shell. A subset of
+the configuration dialog can be run by issuing C<o conf init WORD>
+where WORD is any valid config variable or a regular expression.
+
+=head2 Config Variables
+
+The following keys in the hash reference $CPAN::Config are
+currently defined:
+
+ applypatch path to external prg
+ auto_commit commit all changes to config variables to disk
+ build_cache size of cache for directories to build modules
+ build_dir locally accessible directory to build modules
+ build_dir_reuse boolean if distros in build_dir are persistent
+ build_requires_install_policy
+ to install or not to install when a module is
+ only needed for building. yes|no|ask/yes|ask/no
+ bzip2 path to external prg
+ cache_metadata use serializer to cache metadata
+ check_sigs if signatures should be verified
+ colorize_debug Term::ANSIColor attributes for debugging output
+ colorize_output boolean if Term::ANSIColor should colorize output
+ colorize_print Term::ANSIColor attributes for normal output
+ colorize_warn Term::ANSIColor attributes for warnings
+ commandnumber_in_prompt
+ boolean if you want to see current command number
+ commands_quote preferred character to use for quoting external
+ commands when running them. Defaults to double
+ quote on Windows, single tick everywhere else;
+ can be set to space to disable quoting
+ connect_to_internet_ok
+ whether to ask if opening a connection is ok before
+ urllist is specified
+ cpan_home local directory reserved for this package
+ curl path to external prg
+ dontload_hash DEPRECATED
+ dontload_list arrayref: modules in the list will not be
+ loaded by the CPAN::has_inst() routine
+ ftp path to external prg
+ ftp_passive if set, the envariable FTP_PASSIVE is set for downloads
+ ftp_proxy proxy host for ftp requests
+ ftpstats_period max number of days to keep download statistics
+ ftpstats_size max number of items to keep in the download statistics
+ getcwd see below
+ gpg path to external prg
+ gzip location of external program gzip
+ halt_on_failure stop processing after the first failure of queued
+ items or dependencies
+ histfile file to maintain history between sessions
+ histsize maximum number of lines to keep in histfile
+ http_proxy proxy host for http requests
+ inactivity_timeout breaks interactive Makefile.PLs or Build.PLs
+ after this many seconds inactivity. Set to 0 to
+ disable timeouts.
+ index_expire refetch index files after this many days
+ inhibit_startup_message
+ if true, suppress the startup message
+ keep_source_where directory in which to keep the source (if we do)
+ load_module_verbosity
+ report loading of optional modules used by CPAN.pm
+ lynx path to external prg
+ make location of external make program
+ make_arg arguments that should always be passed to 'make'
+ make_install_make_command
+ the make command for running 'make install', for
+ example 'sudo make'
+ make_install_arg same as make_arg for 'make install'
+ makepl_arg arguments passed to 'perl Makefile.PL'
+ mbuild_arg arguments passed to './Build'
+ mbuild_install_arg arguments passed to './Build install'
+ mbuild_install_build_command
+ command to use instead of './Build' when we are
+ in the install stage, for example 'sudo ./Build'
+ mbuildpl_arg arguments passed to 'perl Build.PL'
+ ncftp path to external prg
+ ncftpget path to external prg
+ no_proxy don't proxy to these hosts/domains (comma separated list)
+ pager location of external program more (or any pager)
+ password your password if you CPAN server wants one
+ patch path to external prg
+ patches_dir local directory containing patch files
+ perl5lib_verbosity verbosity level for PERL5LIB additions
+ prefer_installer legal values are MB and EUMM: if a module comes
+ with both a Makefile.PL and a Build.PL, use the
+ former (EUMM) or the latter (MB); if the module
+ comes with only one of the two, that one will be
+ used no matter the setting
+ prerequisites_policy
+ what to do if you are missing module prerequisites
+ ('follow' automatically, 'ask' me, or 'ignore')
+ prefs_dir local directory to store per-distro build options
+ proxy_user username for accessing an authenticating proxy
+ proxy_pass password for accessing an authenticating proxy
+ randomize_urllist add some randomness to the sequence of the urllist
+ scan_cache controls scanning of cache ('atstart' or 'never')
+ shell your favorite shell
+ show_unparsable_versions
+ boolean if r command tells which modules are versionless
+ show_upload_date boolean if commands should try to determine upload date
+ show_zero_versions boolean if r command tells for which modules $version==0
+ tar location of external program tar
+ tar_verbosity verbosity level for the tar command
+ term_is_latin deprecated: if true Unicode is translated to ISO-8859-1
+ (and nonsense for characters outside latin range)
+ term_ornaments boolean to turn ReadLine ornamenting on/off
+ test_report email test reports (if CPAN::Reporter is installed)
+ trust_test_report_history
+ skip testing when previously tested ok (according to
+ CPAN::Reporter history)
+ unzip location of external program unzip
+ urllist arrayref to nearby CPAN sites (or equivalent locations)
+ use_sqlite use CPAN::SQLite for metadata storage (fast and lean)
+ username your username if you CPAN server wants one
+ wait_list arrayref to a wait server to try (See CPAN::WAIT)
+ wget path to external prg
+ yaml_load_code enable YAML code deserialisation via CPAN::DeferredCode
+ yaml_module which module to use to read/write YAML files
+
+You can set and query each of these options interactively in the cpan
+shell with the C<o conf> or the C<o conf init> command as specified below.
+
+=over 2
+
+=item C<o conf E<lt>scalar optionE<gt>>
+
+prints the current value of the I<scalar option>
+
+=item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
+
+Sets the value of the I<scalar option> to I<value>
+
+=item C<o conf E<lt>list optionE<gt>>
+
+prints the current value of the I<list option> in MakeMaker's
+neatvalue format.
+
+=item C<o conf E<lt>list optionE<gt> [shift|pop]>
+
+shifts or pops the array in the I<list option> variable
+
+=item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
+
+works like the corresponding perl commands.
+
+=item interactive editing: o conf init [MATCH|LIST]
+
+Runs an interactive configuration dialog for matching variables.
+Without argument runs the dialog over all supported config variables.
+To specify a MATCH the argument must be enclosed by slashes.
+
+Examples:
+
+ o conf init ftp_passive ftp_proxy
+ o conf init /color/
+
+Note: this method of setting config variables often provides more
+explanation about the functioning of a variable than the manpage.
+
+=back
+
+=head2 CPAN::anycwd($path): Note on config variable getcwd
+
+CPAN.pm changes the current working directory often and needs to
+determine its own current working directory. By default it uses
+Cwd::cwd, but if for some reason this doesn't work on your system,
+configure alternatives according to the following table:
+
+=over 4
+
+=item cwd
+
+Calls Cwd::cwd
+
+=item getcwd
+
+Calls Cwd::getcwd
+
+=item fastcwd
+
+Calls Cwd::fastcwd
+
+=item backtickcwd
+
+Calls the external command cwd.
+
+=back
+
+=head2 Note on the format of the urllist parameter
+
+urllist parameters are URLs according to RFC 1738. We do a little
+guessing if your URL is not compliant, but if you have problems with
+C<file> URLs, please try the correct format. Either:
+
+ file://localhost/whatever/ftp/pub/CPAN/
+
+or
+
+ file:///home/ftp/pub/CPAN/
+
+=head2 The urllist parameter has CD-ROM support
+
+The C<urllist> parameter of the configuration table contains a list of
+URLs used for downloading. If the list contains any
+C<file> URLs, CPAN always tries there first. This
+feature is disabled for index files. So the recommendation for the
+owner of a CD-ROM with CPAN contents is: include your local, possibly
+outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
+
+ o conf urllist push file://localhost/CDROM/CPAN
+
+CPAN.pm will then fetch the index files from one of the CPAN sites
+that come at the beginning of urllist. It will later check for each
+module to see whether there is a local copy of the most recent version.
+
+Another peculiarity of urllist is that the site that we could
+successfully fetch the last file from automatically gets a preference
+token and is tried as the first site for the next request. So if you
+add a new site at runtime it may happen that the previously preferred
+site will be tried another time. This means that if you want to disallow
+a site for the next transfer, it must be explicitly removed from
+urllist.
+
+=head2 Maintaining the urllist parameter
+
+If you have YAML.pm (or some other YAML module configured in
+C<yaml_module>) installed, CPAN.pm collects a few statistical data
+about recent downloads. You can view the statistics with the C<hosts>
+command or inspect them directly by looking into the C<FTPstats.yml>
+file in your C<cpan_home> directory.
+
+To get some interesting statistics, it is recommended that
+C<randomize_urllist> be set; this introduces some amount of
+randomness into the URL selection.
+
+=head2 The C<requires> and C<build_requires> dependency declarations
+
+Since CPAN.pm version 1.88_51 modules declared as C<build_requires> by
+a distribution are treated differently depending on the config
+variable C<build_requires_install_policy>. By setting
+C<build_requires_install_policy> to C<no>, such a module is not
+installed. It is only built and tested, and then kept in the list of
+tested but uninstalled modules. As such, it is available during the
+build of the dependent module by integrating the path to the
+C<blib/arch> and C<blib/lib> directories in the environment variable
+PERL5LIB. If C<build_requires_install_policy> is set ti C<yes>, then
+both modules declared as C<requires> and those declared as
+C<build_requires> are treated alike. By setting to C<ask/yes> or
+C<ask/no>, CPAN.pm asks the user and sets the default accordingly.
+
+=head2 Configuration for individual distributions (I<Distroprefs>)
+
+(B<Note:> This feature has been introduced in CPAN.pm 1.8854 and is
+still considered beta quality)
+
+Distributions on CPAN usually behave according to what we call the
+CPAN mantra. Or since the advent of Module::Build we should talk about
+two mantras:
+
+ perl Makefile.PL perl Build.PL
+ make ./Build
+ make test ./Build test
+ make install ./Build install
+
+But some modules cannot be built with this mantra. They try to get
+some extra data from the user via the environment, extra arguments, or
+interactively--thus disturbing the installation of large bundles like
+Phalanx100 or modules with many dependencies like Plagger.
+
+The distroprefs system of C<CPAN.pm> addresses this problem by
+allowing the user to specify extra informations and recipes in YAML
+files to either
+
+=over
+
+=item
+
+pass additional arguments to one of the four commands,
+
+=item
+
+set environment variables
+
+=item
+
+instantiate an Expect object that reads from the console, waits for
+some regular expressions and enters some answers
+
+=item
+
+temporarily override assorted C<CPAN.pm> configuration variables
+
+=item
+
+specify dependencies the original maintainer forgot
+
+=item
+
+disable the installation of an object altogether
+
+=back
+
+See the YAML and Data::Dumper files that come with the C<CPAN.pm>
+distribution in the C<distroprefs/> directory for examples.
+
+=head2 Filenames
+
+The YAML files themselves must have the C<.yml> extension; all other
+files are ignored (for two exceptions see I<Fallback Data::Dumper and
+Storable> below). The containing directory can be specified in
+C<CPAN.pm> in the C<prefs_dir> config variable. Try C<o conf init
+prefs_dir> in the CPAN shell to set and activate the distroprefs
+system.
+
+Every YAML file may contain arbitrary documents according to the YAML
+specification, and every document is treated as an entity that
+can specify the treatment of a single distribution.
+
+Filenames can be picked arbitrarily; C<CPAN.pm> always reads
+all files (in alphabetical order) and takes the key C<match> (see
+below in I<Language Specs>) as a hashref containing match criteria
+that determine if the current distribution matches the YAML document
+or not.
+
+=head2 Fallback Data::Dumper and Storable
+
+If neither your configured C<yaml_module> nor YAML.pm is installed,
+CPAN.pm falls back to using Data::Dumper and Storable and looks for
+files with the extensions C<.dd> or C<.st> in the C<prefs_dir>
+directory. These files are expected to contain one or more hashrefs.
+For Data::Dumper generated files, this is expected to be done with by
+defining C<$VAR1>, C<$VAR2>, etc. The YAML shell would produce these
+with the command
+
+ ysh < somefile.yml > somefile.dd
+
+For Storable files the rule is that they must be constructed such that
+C<Storable::retrieve(file)> returns an array reference and the array
+elements represent one distropref object each. The conversion from
+YAML would look like so:
+
+ perl -MYAML=LoadFile -MStorable=nstore -e '
+ @y=LoadFile(shift);
+ nstore(\@y, shift)' somefile.yml somefile.st
+
+In bootstrapping situations it is usually sufficient to translate only
+a few YAML files to Data::Dumper for crucial modules like
+C<YAML::Syck>, C<YAML.pm> and C<Expect.pm>. If you prefer Storable
+over Data::Dumper, remember to pull out a Storable version that writes
+an older format than all the other Storable versions that will need to
+read them.
+
+=head2 Blueprint
+
+The following example contains all supported keywords and structures
+with the exception of C<eexpect> which can be used instead of
+C<expect>.
+
+ ---
+ comment: "Demo"
+ match:
+ module: "Dancing::Queen"
+ distribution: "^CHACHACHA/Dancing-"
+ not_distribution: "\.zip$"
+ perl: "/usr/local/cariba-perl/bin/perl"
+ perlconfig:
+ archname: "freebsd"
+ not_cc: "gcc"
+ env:
+ DANCING_FLOOR: "Shubiduh"
+ disabled: 1
+ cpanconfig:
+ make: gmake
+ pl:
+ args:
+ - "--somearg=specialcase"
+
+ env: {}
+
+ expect:
+ - "Which is your favorite fruit"
+ - "apple\n"
+
+ make:
+ args:
+ - all
+ - extra-all
+
+ env: {}
+
+ expect: []
+
+ commendline: "echo SKIPPING make"
+
+ test:
+ args: []
+
+ env: {}
+
+ expect: []
+
+ install:
+ args: []
+
+ env:
+ WANT_TO_INSTALL: YES
+
+ expect:
+ - "Do you really want to install"
+ - "y\n"
+
+ patches:
+ - "ABCDE/Fedcba-3.14-ABCDE-01.patch"
+
+ depends:
+ configure_requires:
+ LWP: 5.8
+ build_requires:
+ Test::Exception: 0.25
+ requires:
+ Spiffy: 0.30
+
+
+=head2 Language Specs
+
+Every YAML document represents a single hash reference. The valid keys
+in this hash are as follows:
+
+=over
+
+=item comment [scalar]
+
+A comment
+
+=item cpanconfig [hash]
+
+Temporarily override assorted C<CPAN.pm> configuration variables.
+
+Supported are: C<build_requires_install_policy>, C<check_sigs>,
+C<make>, C<make_install_make_command>, C<prefer_installer>,
+C<test_report>. Please report as a bug when you need another one
+supported.
+
+=item depends [hash] *** EXPERIMENTAL FEATURE ***
+
+All three types, namely C<configure_requires>, C<build_requires>, and
+C<requires> are supported in the way specified in the META.yml
+specification. The current implementation I<merges> the specified
+dependencies with those declared by the package maintainer. In a
+future implementation this may be changed to override the original
+declaration.
+
+=item disabled [boolean]
+
+Specifies that this distribution shall not be processed at all.
+
+=item features [array] *** EXPERIMENTAL FEATURE ***
+
+Experimental implementation to deal with optional_features from
+META.yml. Still needs coordination with installer software and
+currently works only for META.yml declaring C<dynamic_config=0>. Use
+with caution.
+
+=item goto [string]
+
+The canonical name of a delegate distribution to install
+instead. Useful when a new version, although it tests OK itself,
+breaks something else or a developer release or a fork is already
+uploaded that is better than the last released version.
+
+=item install [hash]
+
+Processing instructions for the C<make install> or C<./Build install>
+phase of the CPAN mantra. See below under I<Processing Instructions>.
+
+=item make [hash]
+
+Processing instructions for the C<make> or C<./Build> phase of the
+CPAN mantra. See below under I<Processing Instructions>.
+
+=item match [hash]
+
+A hashref with one or more of the keys C<distribution>, C<modules>,
+C<perl>, C<perlconfig>, and C<env> that specify whether a document is
+targeted at a specific CPAN distribution or installation.
+Keys prefixed with C<not_> negates the corresponding match.
+
+The corresponding values are interpreted as regular expressions. The
+C<distribution> related one will be matched against the canonical
+distribution name, e.g. "AUTHOR/Foo-Bar-3.14.tar.gz".
+
+The C<module> related one will be matched against I<all> modules
+contained in the distribution until one module matches.
+
+The C<perl> related one will be matched against C<$^X> (but with the
+absolute path).
+
+The value associated with C<perlconfig> is itself a hashref that is
+matched against corresponding values in the C<%Config::Config> hash
+living in the C<Config.pm> module.
+Keys prefixed with C<not_> negates the corresponding match.
+
+The value associated with C<env> is itself a hashref that is
+matched against corresponding values in the C<%ENV> hash.
+Keys prefixed with C<not_> negates the corresponding match.
+
+If more than one restriction of C<module>, C<distribution>, etc. is
+specified, the results of the separately computed match values must
+all match. If so, the hashref represented by the
+YAML document is returned as the preference structure for the current
+distribution.
+
+=item patches [array]
+
+An array of patches on CPAN or on the local disk to be applied in
+order via an external patch program. If the value for the C<-p>
+parameter is C<0> or C<1> is determined by reading the patch
+beforehand. The path to each patch is either an absolute path on the
+local filesystem or relative to a patch directory specified in the
+C<patches_dir> configuration variable or in the format of a canonical
+distroname. For examples please consult the distroprefs/ directory in
+the CPAN.pm distribution (these examples are not installed by
+default).
+
+Note: if the C<applypatch> program is installed and C<CPAN::Config>
+knows about it B<and> a patch is written by the C<makepatch> program,
+then C<CPAN.pm> lets C<applypatch> apply the patch. Both C<makepatch>
+and C<applypatch> are available from CPAN in the C<JV/makepatch-*>
+distribution.
+
+=item pl [hash]
+
+Processing instructions for the C<perl Makefile.PL> or C<perl
+Build.PL> phase of the CPAN mantra. See below under I<Processing
+Instructions>.
+
+=item test [hash]
+
+Processing instructions for the C<make test> or C<./Build test> phase
+of the CPAN mantra. See below under I<Processing Instructions>.
+
+=back
+
+=head2 Processing Instructions
+
+=over
+
+=item args [array]
+
+Arguments to be added to the command line
+
+=item commandline
+
+A full commandline to run via C<system()>.
+During execution, the environment variable PERL is set
+to $^X (but with an absolute path). If C<commandline> is specified,
+C<args> is not used.
+
+=item eexpect [hash]
+
+Extended C<expect>. This is a hash reference with four allowed keys,
+C<mode>, C<timeout>, C<reuse>, and C<talk>.
+
+C<mode> may have the values C<deterministic> for the case where all
+questions come in the order written down and C<anyorder> for the case
+where the questions may come in any order. The default mode is
+C<deterministic>.
+
+C<timeout> denotes a timeout in seconds. Floating-point timeouts are
+OK. With C<mode=deterministic>, the timeout denotes the
+timeout per question; with C<mode=anyorder> it denotes the
+timeout per byte received from the stream or questions.
+
+C<talk> is a reference to an array that contains alternating questions
+and answers. Questions are regular expressions and answers are literal
+strings. The Expect module watches the stream from the
+execution of the external program (C<perl Makefile.PL>, C<perl
+Build.PL>, C<make>, etc.).
+
+For C<mode=deterministic>, the CPAN.pm injects the
+corresponding answer as soon as the stream matches the regular expression.
+
+For C<mode=anyorder> CPAN.pm answers a question as soon
+as the timeout is reached for the next byte in the input stream. In
+this mode you can use the C<reuse> parameter to decide what will
+happen with a question-answer pair after it has been used. In the
+default case (reuse=0) it is removed from the array, avoiding being
+used again accidentally. If you want to answer the
+question C<Do you really want to do that> several times, then it must
+be included in the array at least as often as you want this answer to
+be given. Setting the parameter C<reuse> to 1 makes this repetition
+unnecessary.
+
+=item env [hash]
+
+Environment variables to be set during the command
+
+=item expect [array]
+
+C<< expect: <array> >> is a short notation for
+
+eexpect:
+ mode: deterministic
+ timeout: 15
+ talk: <array>
+
+=back
+
+=head2 Schema verification with C<Kwalify>
+
+If you have the C<Kwalify> module installed (which is part of the
+Bundle::CPANxxl), then all your distroprefs files are checked for
+syntactic correctness.
+
+=head2 Example Distroprefs Files
+
+C<CPAN.pm> comes with a collection of example YAML files. Note that these
+are really just examples and should not be used without care because
+they cannot fit everybody's purpose. After all, the authors of the
+packages that ask questions had a need to ask, so you should watch
+their questions and adjust the examples to your environment and your
+needs. You have been warned:-)
+
+=head1 PROGRAMMER'S INTERFACE
+
+If you do not enter the shell, shell commands are
+available both as methods (C<CPAN::Shell-E<gt>install(...)>) and as
+functions in the calling package (C<install(...)>). Before calling low-level
+commands, it makes sense to initialize components of CPAN you need, e.g.:
+
+ CPAN::HandleConfig->load;
+ CPAN::Shell::setup_output;
+ CPAN::Index->reload;
+
+High-level commands do such initializations automatically.
+
+There's currently only one class that has a stable interface -
+CPAN::Shell. All commands that are available in the CPAN shell are
+methods of the class CPAN::Shell. Each of the commands that produce
+listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
+the IDs of all modules within the list.
+
+=over 2
+
+=item expand($type, at things)
+
+The IDs of all objects available within a program are strings that can
+be expanded to the corresponding real objects with the
+C<CPAN::Shell-E<gt>expand("Module", at things)> method. Expand returns a
+list of CPAN::Module objects according to the C<@things> arguments
+given. In scalar context, it returns only the first element of the
+list.
+
+=item expandany(@things)
+
+Like expand, but returns objects of the appropriate type, i.e.
+CPAN::Bundle objects for bundles, CPAN::Module objects for modules, and
+CPAN::Distribution objects for distributions. Note: it does not expand
+to CPAN::Author objects.
+
+=item Programming Examples
+
+This enables the programmer to do operations that combine
+functionalities that are available in the shell.
+
+ # install everything that is outdated on my disk:
+ perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
+
+ # install my favorite programs if necessary:
+ for $mod (qw(Net::FTP Digest::SHA Data::Dumper)) {
+ CPAN::Shell->install($mod);
+ }
+
+ # list all modules on my disk that have no VERSION number
+ for $mod (CPAN::Shell->expand("Module","/./")) {
+ next unless $mod->inst_file;
+ # MakeMaker convention for undefined $VERSION:
+ next unless $mod->inst_version eq "undef";
+ print "No VERSION in ", $mod->id, "\n";
+ }
+
+ # find out which distribution on CPAN contains a module:
+ print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
+
+Or if you want to schedule a I<cron> job to watch CPAN, you could list
+all modules that need updating. First a quick and dirty way:
+
+ perl -e 'use CPAN; CPAN::Shell->r;'
+
+If you don't want any output should all modules be
+up to date, parse the output of above command for the regular
+expression C</modules are up to date/> and decide to mail the output
+only if it doesn't match.
+
+If you prefer to do it more in a programmerish style in one single
+process, something like this may better suit you:
+
+ # list all modules on my disk that have newer versions on CPAN
+ for $mod (CPAN::Shell->expand("Module","/./")) {
+ next unless $mod->inst_file;
+ next if $mod->uptodate;
+ printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
+ $mod->id, $mod->inst_version, $mod->cpan_version;
+ }
+
+If that gives too much output every day, you may want to
+watch only for three modules. You can write
+
+ for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")) {
+
+as the first line instead. Or you can combine some of the above
+tricks:
+
+ # watch only for a new mod_perl module
+ $mod = CPAN::Shell->expand("Module","mod_perl");
+ exit if $mod->uptodate;
+ # new mod_perl arrived, let me know all update recommendations
+ CPAN::Shell->r;
+
+=back
+
+=head2 Methods in the other Classes
+
+=over 4
+
+=item CPAN::Author::as_glimpse()
+
+Returns a one-line description of the author
+
+=item CPAN::Author::as_string()
+
+Returns a multi-line description of the author
+
+=item CPAN::Author::email()
+
+Returns the author's email address
+
+=item CPAN::Author::fullname()
+
+Returns the author's name
+
+=item CPAN::Author::name()
+
+An alias for fullname
+
+=item CPAN::Bundle::as_glimpse()
+
+Returns a one-line description of the bundle
+
+=item CPAN::Bundle::as_string()
+
+Returns a multi-line description of the bundle
+
+=item CPAN::Bundle::clean()
+
+Recursively runs the C<clean> method on all items contained in the bundle.
+
+=item CPAN::Bundle::contains()
+
+Returns a list of objects' IDs contained in a bundle. The associated
+objects may be bundles, modules or distributions.
+
+=item CPAN::Bundle::force($method, at args)
+
+Forces CPAN to perform a task that it normally would have refused to
+do. Force takes as arguments a method name to be called and any number
+of additional arguments that should be passed to the called method.
+The internals of the object get the needed changes so that CPAN.pm
+does not refuse to take the action. The C<force> is passed recursively
+to all contained objects. See also the section above on the C<force>
+and the C<fforce> pragma.
+
+=item CPAN::Bundle::get()
+
+Recursively runs the C<get> method on all items contained in the bundle
+
+=item CPAN::Bundle::inst_file()
+
+Returns the highest installed version of the bundle in either @INC or
+C<$CPAN::Config->{cpan_home}>. Note that this is different from
+CPAN::Module::inst_file.
+
+=item CPAN::Bundle::inst_version()
+
+Like CPAN::Bundle::inst_file, but returns the $VERSION
+
+=item CPAN::Bundle::uptodate()
+
+Returns 1 if the bundle itself and all its members are uptodate.
+
+=item CPAN::Bundle::install()
+
+Recursively runs the C<install> method on all items contained in the bundle
+
+=item CPAN::Bundle::make()
+
+Recursively runs the C<make> method on all items contained in the bundle
+
+=item CPAN::Bundle::readme()
+
+Recursively runs the C<readme> method on all items contained in the bundle
+
+=item CPAN::Bundle::test()
+
+Recursively runs the C<test> method on all items contained in the bundle
+
+=item CPAN::Distribution::as_glimpse()
+
+Returns a one-line description of the distribution
+
+=item CPAN::Distribution::as_string()
+
+Returns a multi-line description of the distribution
+
+=item CPAN::Distribution::author
+
+Returns the CPAN::Author object of the maintainer who uploaded this
+distribution
+
+=item CPAN::Distribution::pretty_id()
+
+Returns a string of the form "AUTHORID/TARBALL", where AUTHORID is the
+author's PAUSE ID and TARBALL is the distribution filename.
+
+=item CPAN::Distribution::base_id()
+
+Returns the distribution filename without any archive suffix. E.g
+"Foo-Bar-0.01"
+
+=item CPAN::Distribution::clean()
+
+Changes to the directory where the distribution has been unpacked and
+runs C<make clean> there.
+
+=item CPAN::Distribution::containsmods()
+
+Returns a list of IDs of modules contained in a distribution file.
+Works only for distributions listed in the 02packages.details.txt.gz
+file. This typically means that just most recent version of a
+distribution is covered.
+
+=item CPAN::Distribution::cvs_import()
+
+Changes to the directory where the distribution has been unpacked and
+runs something like
+
+ cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
+
+there.
+
+=item CPAN::Distribution::dir()
+
+Returns the directory into which this distribution has been unpacked.
+
+=item CPAN::Distribution::force($method, at args)
+
+Forces CPAN to perform a task that it normally would have refused to
+do. Force takes as arguments a method name to be called and any number
+of additional arguments that should be passed to the called method.
+The internals of the object get the needed changes so that CPAN.pm
+does not refuse to take the action. See also the section above on the
+C<force> and the C<fforce> pragma.
+
+=item CPAN::Distribution::get()
+
+Downloads the distribution from CPAN and unpacks it. Does nothing if
+the distribution has already been downloaded and unpacked within the
+current session.
+
+=item CPAN::Distribution::install()
+
+Changes to the directory where the distribution has been unpacked and
+runs the external command C<make install> there. If C<make> has not
+yet been run, it will be run first. A C<make test> is issued in
+any case and if this fails, the install is cancelled. The
+cancellation can be avoided by letting C<force> run the C<install> for
+you.
+
+This install method only has the power to install the distribution if
+there are no dependencies in the way. To install an object along with all
+its dependencies, use CPAN::Shell->install.
+
+Note that install() gives no meaningful return value. See uptodate().
+
+=item CPAN::Distribution::install_tested()
+
+Install all distributions that have tested sucessfully but
+not yet installed. See also C<is_tested>.
+
+=item CPAN::Distribution::isa_perl()
+
+Returns 1 if this distribution file seems to be a perl distribution.
+Normally this is derived from the file name only, but the index from
+CPAN can contain a hint to achieve a return value of true for other
+filenames too.
+
+=item CPAN::Distribution::look()
+
+Changes to the directory where the distribution has been unpacked and
+opens a subshell there. Exiting the subshell returns.
+
+=item CPAN::Distribution::make()
+
+First runs the C<get> method to make sure the distribution is
+downloaded and unpacked. Changes to the directory where the
+distribution has been unpacked and runs the external commands C<perl
+Makefile.PL> or C<perl Build.PL> and C<make> there.
+
+=item CPAN::Distribution::perldoc()
+
+Downloads the pod documentation of the file associated with a
+distribution (in HTML format) and runs it through the external
+command I<lynx> specified in C<$CPAN::Config->{lynx}>. If I<lynx>
+isn't available, it converts it to plain text with the external
+command I<html2text> and runs it through the pager specified
+in C<$CPAN::Config->{pager}>
+
+=item CPAN::Distribution::prefs()
+
+Returns the hash reference from the first matching YAML file that the
+user has deposited in the C<prefs_dir/> directory. The first
+succeeding match wins. The files in the C<prefs_dir/> are processed
+alphabetically, and the canonical distroname (e.g.
+AUTHOR/Foo-Bar-3.14.tar.gz) is matched against the regular expressions
+stored in the $root->{match}{distribution} attribute value.
+Additionally all module names contained in a distribution are matched
+against the regular expressions in the $root->{match}{module} attribute
+value. The two match values are ANDed together. Each of the two
+attributes are optional.
+
+=item CPAN::Distribution::prereq_pm()
+
+Returns the hash reference that has been announced by a distribution
+as the C<requires> and C<build_requires> elements. These can be
+declared either by the C<META.yml> (if authoritative) or can be
+deposited after the run of C<Build.PL> in the file C<./_build/prereqs>
+or after the run of C<Makfile.PL> written as the C<PREREQ_PM> hash in
+a comment in the produced C<Makefile>. I<Note>: this method only works
+after an attempt has been made to C<make> the distribution. Returns
+undef otherwise.
+
+=item CPAN::Distribution::readme()
+
+Downloads the README file associated with a distribution and runs it
+through the pager specified in C<$CPAN::Config->{pager}>.
+
+=item CPAN::Distribution::reports()
+
+Downloads report data for this distribution from www.cpantesters.org
+and displays a subset of them.
+
+=item CPAN::Distribution::read_yaml()
+
+Returns the content of the META.yml of this distro as a hashref. Note:
+works only after an attempt has been made to C<make> the distribution.
+Returns undef otherwise. Also returns undef if the content of META.yml
+is not authoritative. (The rules about what exactly makes the content
+authoritative are still in flux.)
+
+=item CPAN::Distribution::test()
+
+Changes to the directory where the distribution has been unpacked and
+runs C<make test> there.
+
+=item CPAN::Distribution::uptodate()
+
+Returns 1 if all the modules contained in the distribution are
+uptodate. Relies on containsmods.
+
+=item CPAN::Index::force_reload()
+
+Forces a reload of all indices.
+
+=item CPAN::Index::reload()
+
+Reloads all indices if they have not been read for more than
+C<$CPAN::Config->{index_expire}> days.
+
+=item CPAN::InfoObj::dump()
+
+CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
+inherit this method. It prints the data structure associated with an
+object. Useful for debugging. Note: the data structure is considered
+internal and thus subject to change without notice.
+
+=item CPAN::Module::as_glimpse()
+
+Returns a one-line description of the module in four columns: The
+first column contains the word C<Module>, the second column consists
+of one character: an equals sign if this module is already installed
+and uptodate, a less-than sign if this module is installed but can be
+upgraded, and a space if the module is not installed. The third column
+is the name of the module and the fourth column gives maintainer or
+distribution information.
+
+=item CPAN::Module::as_string()
+
+Returns a multi-line description of the module
+
+=item CPAN::Module::clean()
+
+Runs a clean on the distribution associated with this module.
+
+=item CPAN::Module::cpan_file()
+
+Returns the filename on CPAN that is associated with the module.
+
+=item CPAN::Module::cpan_version()
+
+Returns the latest version of this module available on CPAN.
+
+=item CPAN::Module::cvs_import()
+
+Runs a cvs_import on the distribution associated with this module.
+
+=item CPAN::Module::description()
+
+Returns a 44 character description of this module. Only available for
+modules listed in The Module List (CPAN/modules/00modlist.long.html
+or 00modlist.long.txt.gz)
+
+=item CPAN::Module::distribution()
+
+Returns the CPAN::Distribution object that contains the current
+version of this module.
+
+=item CPAN::Module::dslip_status()
+
+Returns a hash reference. The keys of the hash are the letters C<D>,
+C<S>, C<L>, C<I>, and <P>, for development status, support level,
+language, interface and public licence respectively. The data for the
+DSLIP status are collected by pause.perl.org when authors register
+their namespaces. The values of the 5 hash elements are one-character
+words whose meaning is described in the table below. There are also 5
+hash elements C<DV>, C<SV>, C<LV>, C<IV>, and <PV> that carry a more
+verbose value of the 5 status variables.
+
+Where the 'DSLIP' characters have the following meanings:
+
+ D - Development Stage (Note: *NO IMPLIED TIMESCALES*):
+ i - Idea, listed to gain consensus or as a placeholder
+ c - under construction but pre-alpha (not yet released)
+ a/b - Alpha/Beta testing
+ R - Released
+ M - Mature (no rigorous definition)
+ S - Standard, supplied with Perl 5
+
+ S - Support Level:
+ m - Mailing-list
+ d - Developer
+ u - Usenet newsgroup comp.lang.perl.modules
+ n - None known, try comp.lang.perl.modules
+ a - abandoned; volunteers welcome to take over maintainance
+
+ L - Language Used:
+ p - Perl-only, no compiler needed, should be platform independent
+ c - C and perl, a C compiler will be needed
+ h - Hybrid, written in perl with optional C code, no compiler needed
+ + - C++ and perl, a C++ compiler will be needed
+ o - perl and another language other than C or C++
+
+ I - Interface Style
+ f - plain Functions, no references used
+ h - hybrid, object and function interfaces available
+ n - no interface at all (huh?)
+ r - some use of unblessed References or ties
+ O - Object oriented using blessed references and/or inheritance
+
+ P - Public License
+ p - Standard-Perl: user may choose between GPL and Artistic
+ g - GPL: GNU General Public License
+ l - LGPL: "GNU Lesser General Public License" (previously known as
+ "GNU Library General Public License")
+ b - BSD: The BSD License
+ a - Artistic license alone
+ 2 - Artistic license 2.0 or later
+ o - open source: appoved by www.opensource.org
+ d - allows distribution without restrictions
+ r - restricted distribtion
+ n - no license at all
+
+=item CPAN::Module::force($method, at args)
+
+Forces CPAN to perform a task it would normally refuse to
+do. Force takes as arguments a method name to be invoked and any number
+of additional arguments to pass that method.
+The internals of the object get the needed changes so that CPAN.pm
+does not refuse to take the action. See also the section above on the
+C<force> and the C<fforce> pragma.
+
+=item CPAN::Module::get()
+
+Runs a get on the distribution associated with this module.
+
+=item CPAN::Module::inst_file()
+
+Returns the filename of the module found in @INC. The first file found
+is reported, just as perl itself stops searching @INC once it finds a
+module.
+
+=item CPAN::Module::available_file()
+
+Returns the filename of the module found in PERL5LIB or @INC. The
+first file found is reported. The advantage of this method over
+C<inst_file> is that modules that have been tested but not yet
+installed are included because PERL5LIB keeps track of tested modules.
+
+=item CPAN::Module::inst_version()
+
+Returns the version number of the installed module in readable format.
+
+=item CPAN::Module::available_version()
+
+Returns the version number of the available module in readable format.
+
+=item CPAN::Module::install()
+
+Runs an C<install> on the distribution associated with this module.
+
+=item CPAN::Module::look()
+
+Changes to the directory where the distribution associated with this
+module has been unpacked and opens a subshell there. Exiting the
+subshell returns.
+
+=item CPAN::Module::make()
+
+Runs a C<make> on the distribution associated with this module.
+
+=item CPAN::Module::manpage_headline()
+
+If module is installed, peeks into the module's manpage, reads the
+headline, and returns it. Moreover, if the module has been downloaded
+within this session, does the equivalent on the downloaded module even
+if it hasn't been installed yet.
+
+=item CPAN::Module::perldoc()
+
+Runs a C<perldoc> on this module.
+
+=item CPAN::Module::readme()
+
+Runs a C<readme> on the distribution associated with this module.
+
+=item CPAN::Module::reports()
+
+Calls the reports() method on the associated distribution object.
+
+=item CPAN::Module::test()
+
+Runs a C<test> on the distribution associated with this module.
+
+=item CPAN::Module::uptodate()
+
+Returns 1 if the module is installed and up-to-date.
+
+=item CPAN::Module::userid()
+
+Returns the author's ID of the module.
+
+=back
+
+=head2 Cache Manager
+
+Currently the cache manager only keeps track of the build directory
+($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
+deletes complete directories below C<build_dir> as soon as the size of
+all directories there gets bigger than $CPAN::Config->{build_cache}
+(in MB). The contents of this cache may be used for later
+re-installations that you intend to do manually, but will never be
+trusted by CPAN itself. This is due to the fact that the user might
+use these directories for building modules on different architectures.
+
+There is another directory ($CPAN::Config->{keep_source_where}) where
+the original distribution files are kept. This directory is not
+covered by the cache manager and must be controlled by the user. If
+you choose to have the same directory as build_dir and as
+keep_source_where directory, then your sources will be deleted with
+the same fifo mechanism.
+
+=head2 Bundles
+
+A bundle is just a perl module in the namespace Bundle:: that does not
+define any functions or methods. It usually only contains documentation.
+
+It starts like a perl module with a package declaration and a $VERSION
+variable. After that the pod section looks like any other pod with the
+only difference being that I<one special pod section> exists starting with
+(verbatim):
+
+ =head1 CONTENTS
+
+In this pod section each line obeys the format
+
+ Module_Name [Version_String] [- optional text]
+
+The only required part is the first field, the name of a module
+(e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
+of the line is optional. The comment part is delimited by a dash just
+as in the man page header.
+
+The distribution of a bundle should follow the same convention as
+other distributions.
+
+Bundles are treated specially in the CPAN package. If you say 'install
+Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
+the modules in the CONTENTS section of the pod. You can install your
+own Bundles locally by placing a conformant Bundle file somewhere into
+your @INC path. The autobundle() command which is available in the
+shell interface does that for you by including all currently installed
+modules in a snapshot bundle file.
+
+=head1 PREREQUISITES
+
+If you have a local mirror of CPAN and can access all files with
+"file:" URLs, then you only need a perl later than perl5.003 to run
+this module. Otherwise Net::FTP is strongly recommended. LWP may be
+required for non-UNIX systems, or if your nearest CPAN site is
+associated with a URL that is not C<ftp:>.
+
+If you have neither Net::FTP nor LWP, there is a fallback mechanism
+implemented for an external ftp command or for an external lynx
+command.
+
+=head1 UTILITIES
+
+=head2 Finding packages and VERSION
+
+This module presumes that all packages on CPAN
+
+=over 2
+
+=item *
+
+declare their $VERSION variable in an easy to parse manner. This
+prerequisite can hardly be relaxed because it consumes far too much
+memory to load all packages into the running program just to determine
+the $VERSION variable. Currently all programs that are dealing with
+version use something like this
+
+ perl -MExtUtils::MakeMaker -le \
+ 'print MM->parse_version(shift)' filename
+
+If you are author of a package and wonder if your $VERSION can be
+parsed, please try the above method.
+
+=item *
+
+come as compressed or gzipped tarfiles or as zip files and contain a
+C<Makefile.PL> or C<Build.PL> (well, we try to handle a bit more, but
+with little enthusiasm).
+
+=back
+
+=head2 Debugging
+
+Debugging this module is more than a bit complex due to interference from
+the software producing the indices on CPAN, the mirroring process on CPAN,
+packaging, configuration, synchronicity, and even (gasp!) due to bugs
+within the CPAN.pm module itself.
+
+For debugging the code of CPAN.pm itself in interactive mode, some
+debugging aid can be turned on for most packages within
+CPAN.pm with one of
+
+=over 2
+
+=item o debug package...
+
+sets debug mode for packages.
+
+=item o debug -package...
+
+unsets debug mode for packages.
+
+=item o debug all
+
+turns debugging on for all packages.
+
+=item o debug number
+
+=back
+
+which sets the debugging packages directly. Note that C<o debug 0>
+turns debugging off.
+
+What seems a successful strategy is the combination of C<reload
+cpan> and the debugging switches. Add a new debug statement while
+running in the shell and then issue a C<reload cpan> and see the new
+debugging messages immediately without losing the current context.
+
+C<o debug> without an argument lists the valid package names and the
+current set of packages in debugging mode. C<o debug> has built-in
+completion support.
+
+For debugging of CPAN data there is the C<dump> command which takes
+the same arguments as make/test/install and outputs each object's
+Data::Dumper dump. If an argument looks like a perl variable and
+contains one of C<$>, C<@> or C<%>, it is eval()ed and fed to
+Data::Dumper directly.
+
+=head2 Floppy, Zip, Offline Mode
+
+CPAN.pm works nicely without network access, too. If you maintain machines
+that are not networked at all, you should consider working with C<file:>
+URLs. You'll have to collect your modules somewhere first. So
+you might use CPAN.pm to put together all you need on a networked
+machine. Then copy the $CPAN::Config->{keep_source_where} (but not
+$CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
+of a personal CPAN. CPAN.pm on the non-networked machines works nicely
+with this floppy. See also below the paragraph about CD-ROM support.
+
+=head2 Basic Utilities for Programmers
+
+=over 2
+
+=item has_inst($module)
+
+Returns true if the module is installed. Used to load all modules into
+the running CPAN.pm that are considered optional. The config variable
+C<dontload_list> intercepts the C<has_inst()> call such
+that an optional module is not loaded despite being available. For
+example, the following command will prevent C<YAML.pm> from being
+loaded:
+
+ cpan> o conf dontload_list push YAML
+
+See the source for details.
+
+=item has_usable($module)
+
+Returns true if the module is installed and in a usable state. Only
+useful for a handful of modules that are used internally. See the
+source for details.
+
+=item instance($module)
+
+The constructor for all the singletons used to represent modules,
+distributions, authors, and bundles. If the object already exists, this
+method returns the object; otherwise, it calls the constructor.
+
+=back
+
+=head1 SECURITY
+
+There's no strong security layer in CPAN.pm. CPAN.pm helps you to
+install foreign, unmasked, unsigned code on your machine. We compare
+to a checksum that comes from the net just as the distribution file
+itself. But we try to make it easy to add security on demand:
+
+=head2 Cryptographically signed modules
+
+Since release 1.77, CPAN.pm has been able to verify cryptographically
+signed module distributions using Module::Signature. The CPAN modules
+can be signed by their authors, thus giving more security. The simple
+unsigned MD5 checksums that were used before by CPAN protect mainly
+against accidental file corruption.
+
+You will need to have Module::Signature installed, which in turn
+requires that you have at least one of Crypt::OpenPGP module or the
+command-line F<gpg> tool installed.
+
+You will also need to be able to connect over the Internet to the public
+keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
+
+The configuration parameter check_sigs is there to turn signature
+checking on or off.
+
+=head1 EXPORT
+
+Most functions in package CPAN are exported by default. The reason
+for this is that the primary use is intended for the cpan shell or for
+one-liners.
+
+=head1 ENVIRONMENT
+
+When the CPAN shell enters a subshell via the look command, it sets
+the environment CPAN_SHELL_LEVEL to 1, or increments that variable if it is
+already set.
+
+When CPAN runs, it sets the environment variable PERL5_CPAN_IS_RUNNING
+to the ID of the running process. It also sets
+PERL5_CPANPLUS_IS_RUNNING to prevent runaway processes which could
+happen with older versions of Module::Install.
+
+When running C<perl Makefile.PL>, the environment variable
+C<PERL5_CPAN_IS_EXECUTING> is set to the full path of the
+C<Makefile.PL> that is being executed. This prevents runaway processes
+with newer versions of Module::Install.
+
+When the config variable ftp_passive is set, all downloads will be run
+with the environment variable FTP_PASSIVE set to this value. This is
+in general a good idea as it influences both Net::FTP and LWP based
+connections. The same effect can be achieved by starting the cpan
+shell with this environment variable set. For Net::FTP alone, one can
+also always set passive mode by running libnetcfg.
+
+=head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
+
+Populating a freshly installed perl with one's favorite modules is pretty
+easy if you maintain a private bundle definition file. To get a useful
+blueprint of a bundle definition file, the command autobundle can be used
+on the CPAN shell command line. This command writes a bundle definition
+file for all modules installed for the current perl
+interpreter. It's recommended to run this command once only, and from then
+on maintain the file manually under a private name, say
+Bundle/my_bundle.pm. With a clever bundle file you can then simply say
+
+ cpan> install Bundle::my_bundle
+
+then answer a few questions and go out for coffee (possibly
+even in a different city).
+
+Maintaining a bundle definition file means keeping track of two
+things: dependencies and interactivity. CPAN.pm sometimes fails on
+calculating dependencies because not all modules define all MakeMaker
+attributes correctly, so a bundle definition file should specify
+prerequisites as early as possible. On the other hand, it's
+annoying that so many distributions need some interactive configuring. So
+what you can try to accomplish in your private bundle file is to have the
+packages that need to be configured early in the file and the gentle
+ones later, so you can go out for cofeee after a few minutes and leave CPAN.pm
+to churn away untended.
+
+=head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
+
+Thanks to Graham Barr for contributing the following paragraphs about
+the interaction between perl, and various firewall configurations. For
+further information on firewalls, it is recommended to consult the
+documentation that comes with the I<ncftp> program. If you are unable to
+go through the firewall with a simple Perl setup, it is likely
+that you can configure I<ncftp> so that it works through your firewall.
+
+=head2 Three basic types of firewalls
+
+Firewalls can be categorized into three basic types.
+
+=over 4
+
+=item http firewall
+
+This is when the firewall machine runs a web server, and to access the
+outside world, you must do so via that web server. If you set environment
+variables like http_proxy or ftp_proxy to values beginning with http://,
+or in your web browser you've proxy information set, then you know
+you are running behind an http firewall.
+
+To access servers outside these types of firewalls with perl (even for
+ftp), you need LWP.
+
+=item ftp firewall
+
+This where the firewall machine runs an ftp server. This kind of
+firewall will only let you access ftp servers outside the firewall.
+This is usually done by connecting to the firewall with ftp, then
+entering a username like "user at outside.host.com".
+
+To access servers outside these type of firewalls with perl, you
+need Net::FTP.
+
+=item One-way visibility
+
+One-way visibility means these firewalls try to make themselves
+invisible to users inside the firewall. An FTP data connection is
+normally created by sending your IP address to the remote server and then
+listening for the return connection. But the remote server will not be able to
+connect to you because of the firewall. For these types of firewall,
+FTP connections need to be done in a passive mode.
+
+There are two that I can think off.
+
+=over 4
+
+=item SOCKS
+
+If you are using a SOCKS firewall, you will need to compile perl and link
+it with the SOCKS library. This is what is normally called a 'socksified'
+perl. With this executable you will be able to connect to servers outside
+the firewall as if it were not there.
+
+=item IP Masquerade
+
+This is when the firewall implemented in the kernel (via NAT, or networking
+address translation), it allows you to hide a complete network behind one
+IP address. With this firewall no special compiling is needed as you can
+access hosts directly.
+
+For accessing ftp servers behind such firewalls you usually need to
+set the environment variable C<FTP_PASSIVE> or the config variable
+ftp_passive to a true value.
+
+=back
+
+=back
+
+=head2 Configuring lynx or ncftp for going through a firewall
+
+If you can go through your firewall with e.g. lynx, presumably with a
+command such as
+
+ /usr/local/bin/lynx -pscott:tiger
+
+then you would configure CPAN.pm with the command
+
+ o conf lynx "/usr/local/bin/lynx -pscott:tiger"
+
+That's all. Similarly for ncftp or ftp, you would configure something
+like
+
+ o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
+
+Your mileage may vary...
+
+=head1 FAQ
+
+=over 4
+
+=item 1)
+
+I installed a new version of module X but CPAN keeps saying,
+I have the old version installed
+
+Probably you B<do> have the old version installed. This can
+happen if a module installs itself into a different directory in the
+ at INC path than it was previously installed. This is not really a
+CPAN.pm problem, you would have the same problem when installing the
+module manually. The easiest way to prevent this behaviour is to add
+the argument C<UNINST=1> to the C<make install> call, and that is why
+many people add this argument permanently by configuring
+
+ o conf make_install_arg UNINST=1
+
+=item 2)
+
+So why is UNINST=1 not the default?
+
+Because there are people who have their precise expectations about who
+may install where in the @INC path and who uses which @INC array. In
+fine tuned environments C<UNINST=1> can cause damage.
+
+=item 3)
+
+I want to clean up my mess, and install a new perl along with
+all modules I have. How do I go about it?
+
+Run the autobundle command for your old perl and optionally rename the
+resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
+with the Configure option prefix, e.g.
+
+ ./Configure -Dprefix=/usr/local/perl-5.6.78.9
+
+Install the bundle file you produced in the first step with something like
+
+ cpan> install Bundle::mybundle
+
+and you're done.
+
+=item 4)
+
+When I install bundles or multiple modules with one command
+there is too much output to keep track of.
+
+You may want to configure something like
+
+ o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
+ o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
+
+so that STDOUT is captured in a file for later inspection.
+
+
+=item 5)
+
+I am not root, how can I install a module in a personal directory?
+
+First of all, you will want to use your own configuration, not the one
+that your root user installed. If you do not have permission to write
+in the cpan directory that root has configured, you will be asked if
+you want to create your own config. Answering "yes" will bring you into
+CPAN's configuration stage, using the system config for all defaults except
+things that have to do with CPAN's work directory, saving your choices to
+your MyConfig.pm file.
+
+You can also manually initiate this process with the following command:
+
+ % perl -MCPAN -e 'mkmyconfig'
+
+or by running
+
+ mkmyconfig
+
+from the CPAN shell.
+
+You will most probably also want to configure something like this:
+
+ o conf makepl_arg "LIB=~/myperl/lib \
+ INSTALLMAN1DIR=~/myperl/man/man1 \
+ INSTALLMAN3DIR=~/myperl/man/man3 \
+ INSTALLSCRIPT=~/myperl/bin \
+ INSTALLBIN=~/myperl/bin"
+
+and then the equivalent command for Module::Build, which is
+
+ o conf mbuildpl_arg "--lib=~/myperl/lib \
+ --installman1dir=~/myperl/man/man1 \
+ --installman3dir=~/myperl/man/man3 \
+ --installscript=~/myperl/bin \
+ --installbin=~/myperl/bin"
+
+You can make this setting permanent like all C<o conf> settings with
+C<o conf commit> or by setting C<auto_commit> beforehand.
+
+You will have to add ~/myperl/man to the MANPATH environment variable
+and also tell your perl programs to look into ~/myperl/lib, e.g. by
+including
+
+ use lib "$ENV{HOME}/myperl/lib";
+
+or setting the PERL5LIB environment variable.
+
+While we're speaking about $ENV{HOME}, it might be worth mentioning,
+that for Windows we use the File::HomeDir module that provides an
+equivalent to the concept of the home directory on Unix.
+
+Another thing you should bear in mind is that the UNINST parameter can
+be dangerous when you are installing into a private area because you
+might accidentally remove modules that other people depend on that are
+not using the private area.
+
+=item 6)
+
+How to get a package, unwrap it, and make a change before building it?
+
+Have a look at the C<look> (!) command.
+
+=item 7)
+
+I installed a Bundle and had a couple of fails. When I
+retried, everything resolved nicely. Can this be fixed to work
+on first try?
+
+The reason for this is that CPAN does not know the dependencies of all
+modules when it starts out. To decide about the additional items to
+install, it just uses data found in the META.yml file or the generated
+Makefile. An undetected missing piece breaks the process. But it may
+well be that your Bundle installs some prerequisite later than some
+depending item and thus your second try is able to resolve everything.
+Please note, CPAN.pm does not know the dependency tree in advance and
+cannot sort the queue of things to install in a topologically correct
+order. It resolves perfectly well B<if> all modules declare the
+prerequisites correctly with the PREREQ_PM attribute to MakeMaker or
+the C<requires> stanza of Module::Build. For bundles which fail and
+you need to install often, it is recommended to sort the Bundle
+definition file manually.
+
+=item 8)
+
+In our intranet, we have many modules for internal use. How
+can I integrate these modules with CPAN.pm but without uploading
+the modules to CPAN?
+
+Have a look at the CPAN::Site module.
+
+=item 9)
+
+When I run CPAN's shell, I get an error message about things in my
+C</etc/inputrc> (or C<~/.inputrc>) file.
+
+These are readline issues and can only be fixed by studying readline
+configuration on your architecture and adjusting the referenced file
+accordingly. Please make a backup of the C</etc/inputrc> or C<~/.inputrc>
+and edit them. Quite often harmless changes like uppercasing or
+lowercasing some arguments solves the problem.
+
+=item 10)
+
+Some authors have strange characters in their names.
+
+Internally CPAN.pm uses the UTF-8 charset. If your terminal is
+expecting ISO-8859-1 charset, a converter can be activated by setting
+term_is_latin to a true value in your config file. One way of doing so
+would be
+
+ cpan> o conf term_is_latin 1
+
+If other charset support is needed, please file a bugreport against
+CPAN.pm at rt.cpan.org and describe your needs. Maybe we can extend
+the support or maybe UTF-8 terminals become widely available.
+
+Note: this config variable is deprecated and will be removed in a
+future version of CPAN.pm. It will be replaced with the conventions
+around the family of $LANG and $LC_* environment variables.
+
+=item 11)
+
+When an install fails for some reason and then I correct the error
+condition and retry, CPAN.pm refuses to install the module, saying
+C<Already tried without success>.
+
+Use the force pragma like so
+
+ force install Foo::Bar
+
+Or you can use
+
+ look Foo::Bar
+
+and then C<make install> directly in the subshell.
+
+=item 12)
+
+How do I install a "DEVELOPER RELEASE" of a module?
+
+By default, CPAN will install the latest non-developer release of a
+module. If you want to install a dev release, you have to specify the
+partial path starting with the author id to the tarball you wish to
+install, like so:
+
+ cpan> install KWILLIAMS/Module-Build-0.27_07.tar.gz
+
+Note that you can use the C<ls> command to get this path listed.
+
+=item 13)
+
+How do I install a module and all its dependencies from the commandline,
+without being prompted for anything, despite my CPAN configuration
+(or lack thereof)?
+
+CPAN uses ExtUtils::MakeMaker's prompt() function to ask its questions, so
+if you set the PERL_MM_USE_DEFAULT environment variable, you shouldn't be
+asked any questions at all (assuming the modules you are installing are
+nice about obeying that variable as well):
+
+ % PERL_MM_USE_DEFAULT=1 perl -MCPAN -e 'install My::Module'
+
+=item 14)
+
+How do I create a Module::Build based Build.PL derived from an
+ExtUtils::MakeMaker focused Makefile.PL?
+
+http://search.cpan.org/search?query=Module::Build::Convert
+
+http://www.refcnt.org/papers/module-build-convert
+
+=item 15)
+
+I'm frequently irritated with the CPAN shell's inability to help me
+select a good mirror.
+
+The urllist config parameter is yours. You can add and remove sites at
+will. You should find out which sites have the best uptodateness,
+bandwidth, reliability, etc. and are topologically close to you. Some
+people prefer fast downloads, others uptodateness, others reliability.
+You decide which to try in which order.
+
+Henk P. Penning maintains a site that collects data about CPAN sites:
+
+ http://www.cs.uu.nl/people/henkp/mirmon/cpan.html
+
+Also, feel free to play with experimental features. Run
+
+ o conf init randomize_urllist ftpstats_period ftpstats_size
+
+and choose your favorite parameters. After a few downloads running the
+C<hosts> command will probably assist you in choosing the best mirror
+sites.
+
+=item 16)
+
+Why do I get asked the same questions every time I start the shell?
+
+You can make your configuration changes permanent by calling the
+command C<o conf commit>. Alternatively set the C<auto_commit>
+variable to true by running C<o conf init auto_commit> and answering
+the following question with yes.
+
+=item 17)
+
+Older versions of CPAN.pm had the original root directory of all
+tarballs in the build directory. Now there are always random
+characters appended to these directory names. Why was this done?
+
+The random characters are provided by File::Temp and ensure that each
+module's individual build directory is unique. This makes running
+CPAN.pm in concurrent processes simultaneously safe.
+
+=item 18)
+
+Speaking of the build directory. Do I have to clean it up myself?
+
+You have the choice to set the config variable C<scan_cache> to
+C<never>. Then you must clean it up yourself. The other possible
+value, C<atstart> only cleans up the build directory when you start
+the CPAN shell. If you never start up the CPAN shell, you probably
+also have to clean up the build directory yourself.
+
+=back
+
+=head1 COMPATIBILITY
+
+=head2 OLD PERL VERSIONS
+
+CPAN.pm is regularly tested to run under 5.004, 5.005, and assorted
+newer versions. It is getting more and more difficult to get the
+minimal prerequisites working on older perls. It is close to
+impossible to get the whole Bundle::CPAN working there. If you're in
+the position to have only these old versions, be advised that CPAN is
+designed to work fine without the Bundle::CPAN installed.
+
+To get things going, note that GBARR/Scalar-List-Utils-1.18.tar.gz is
+compatible with ancient perls and that File::Temp is listed as a
+prerequisite but CPAN has reasonable workarounds if it is missing.
+
+=head2 CPANPLUS
+
+This module and its competitor, the CPANPLUS module, are both much
+cooler than the other. CPAN.pm is older. CPANPLUS was designed to be
+more modular, but it was never intended to be compatible with CPAN.pm.
+
+=head1 SECURITY ADVICE
+
+This software enables you to upgrade software on your computer and so
+is inherently dangerous because the newly installed software may
+contain bugs and may alter the way your computer works or even make it
+unusable. Please consider backing up your data before every upgrade.
+
+=head1 BUGS
+
+Please report bugs via L<http://rt.cpan.org/>
+
+Before submitting a bug, please make sure that the traditional method
+of building a Perl module package from a shell by following the
+installation instructions of that package still works in your
+environment.
+
+=head1 AUTHOR
+
+Andreas Koenig C<< <andk at cpan.org> >>
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
+=head1 TRANSLATIONS
+
+Kawai,Takanori provides a Japanese translation of this manpage at
+L<http://homepage3.nifty.com/hippo2000/perltips/CPAN.htm>
+
+=head1 SEE ALSO
+
+L<cpan>, L<CPAN::Nox>, L<CPAN::Version>
+
+=cut
Copied: trunk/contrib/perl/lib/CPANPLUS.pm (from rev 6437, vendor/perl/5.18.1/lib/CPANPLUS.pm)
===================================================================
--- trunk/contrib/perl/lib/CPANPLUS.pm (rev 0)
+++ trunk/contrib/perl/lib/CPANPLUS.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,271 @@
+package CPANPLUS;
+
+use strict;
+use Carp;
+
+use CPANPLUS::Error;
+use CPANPLUS::Backend;
+
+use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
+
+BEGIN {
+ use Exporter ();
+ use vars qw( @EXPORT @ISA $VERSION );
+ @EXPORT = qw( shell fetch get install );
+ @ISA = qw( Exporter );
+ $VERSION = "0.88"; #have to hardcode or cpan.org gets unhappy
+}
+
+### purely for backward compatibility, so we can call it from the commandline:
+### perl -MCPANPLUS -e 'install Net::SMTP'
+sub install {
+ my $cpan = CPANPLUS::Backend->new;
+ my $mod = shift or (
+ error(loc("No module specified!")), return
+ );
+
+ if ( ref $mod ) {
+ error( loc( "You passed an object. Use %1 for OO style interaction",
+ 'CPANPLUS::Backend' ));
+ return;
+
+ } else {
+ my $obj = $cpan->module_tree($mod) or (
+ error(loc("No such module '%1'", $mod)),
+ return
+ );
+
+ my $ok = $obj->install;
+
+ $ok
+ ? msg(loc("Installing of %1 successful", $mod),1)
+ : msg(loc("Installing of %1 failed", $mod),1);
+
+ return $ok;
+ }
+}
+
+### simply downloads a module and stores it
+sub fetch {
+ my $cpan = CPANPLUS::Backend->new;
+
+ my $mod = shift or (
+ error(loc("No module specified!")), return
+ );
+
+ if ( ref $mod ) {
+ error( loc( "You passed an object. Use %1 for OO style interaction",
+ 'CPANPLUS::Backend' ));
+ return;
+
+ } else {
+ my $obj = $cpan->module_tree($mod) or (
+ error(loc("No such module '%1'", $mod)),
+ return
+ );
+
+ my $ok = $obj->fetch( fetchdir => '.' );
+
+ $ok
+ ? msg(loc("Fetching of %1 successful", $mod),1)
+ : msg(loc("Fetching of %1 failed", $mod),1);
+
+ return $ok;
+ }
+}
+
+### alias to fetch() due to compatibility with cpan.pm ###
+sub get { fetch(@_) }
+
+
+### purely for backwards compatibility, so we can call it from the commandline:
+### perl -MCPANPLUS -e 'shell'
+sub shell {
+ my $option = shift;
+
+ ### since the user can specify the type of shell they wish to start
+ ### when they call the shell() function, we have to eval the usage
+ ### of CPANPLUS::Shell so we can set up all the checks properly
+ eval { require CPANPLUS::Shell; CPANPLUS::Shell->import($option) };
+ die $@ if $@;
+
+ my $cpan = CPANPLUS::Shell->new();
+
+ $cpan->shell();
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+CPANPLUS - API & CLI access to the CPAN mirrors
+
+=head1 SYNOPSIS
+
+ ### standard invocation from the command line
+ $ cpanp
+ $ cpanp -i Some::Module
+
+ $ perl -MCPANPLUS -eshell
+ $ perl -MCPANPLUS -e'fetch Some::Module'
+
+
+=head1 DESCRIPTION
+
+The C<CPANPLUS> library is an API to the C<CPAN> mirrors and a
+collection of interactive shells, commandline programs, etc,
+that use this API.
+
+=head1 GUIDE TO DOCUMENTATION
+
+=head2 GENERAL USAGE
+
+This is the document you are currently reading. It describes
+basic usage and background information. Its main purpose is to
+assist the user who wants to learn how to invoke CPANPLUS
+and install modules from the commandline and to point you
+to more indepth reading if required.
+
+=head2 API REFERENCE
+
+The C<CPANPLUS> API is meant to let you programmatically
+interact with the C<CPAN> mirrors. The documentation in
+L<CPANPLUS::Backend> shows you how to create an object
+capable of interacting with those mirrors, letting you
+create & retrieve module objects.
+L<CPANPLUS::Module> shows you how you can use these module
+objects to perform actions like installing and testing.
+
+The default shell, documented in L<CPANPLUS::Shell::Default>
+is also scriptable. You can use its API to dispatch calls
+from your script to the CPANPLUS Shell.
+
+=cut
+
+=head1 COMMANDLINE TOOLS
+
+=head2 STARTING AN INTERACTIVE SHELL
+
+You can start an interactive shell by running either of
+the two following commands:
+
+ $ cpanp
+
+ $ perl -MCPANPLUS -eshell
+
+All commans available are listed in the interactive shells
+help menu. See C<cpanp -h> or L<CPANPLUS::Shell::Default>
+for instructions on using the default shell.
+
+=head2 CHOOSE A SHELL
+
+By running C<cpanp> without arguments, you will start up
+the shell specified in your config, which defaults to
+L<CPANPLUS::Shell::Default>. There are more shells available.
+C<CPANPLUS> itself ships with an emulation shell called
+L<CPANPLUS::Shell::Classic> that looks and feels just like
+the old C<CPAN.pm> shell.
+
+You can start this shell by typing:
+
+ $ perl -MCPANPLUS -e'shell Classic'
+
+Even more shells may be available from C<CPAN>.
+
+Note that if you have changed your default shell in your
+configuration, that shell will be used instead. If for
+some reason there was an error with your specified shell,
+you will be given the default shell.
+
+=head2 BUILDING PACKAGES
+
+C<cpan2dist> is a commandline tool to convert any distribution
+from C<CPAN> into a package in the format of your choice, like
+for example C<.deb> or C<FreeBSD ports>.
+
+See C<cpan2dist -h> for details.
+
+
+=head1 FUNCTIONS
+
+For quick access to common commands, you may use this module,
+C<CPANPLUS> rather than the full programmatic API situated in
+C<CPANPLUS::Backend>. This module offers the following functions:
+
+=head2 $bool = install( Module::Name | /A/AU/AUTHOR/Module-Name-1.tgz )
+
+This function requires the full name of the module, which is case
+sensitive. The module name can also be provided as a fully
+qualified file name, beginning with a I</>, relative to
+the /authors/id directory on a CPAN mirror.
+
+It will download, extract and install the module.
+
+=head2 $where = fetch( Module::Name | /A/AU/AUTHOR/Module-Name-1.tgz )
+
+Like install, fetch needs the full name of a module or the fully
+qualified file name, and is case sensitive.
+
+It will download the specified module to the current directory.
+
+=head2 $where = get( Module::Name | /A/AU/AUTHOR/Module-Name-1.tgz )
+
+Get is provided as an alias for fetch for compatibility with
+CPAN.pm.
+
+=head2 shell()
+
+Shell starts the default CPAN shell. You can also start the shell
+by using the C<cpanp> command, which will be installed in your
+perl bin.
+
+=head1 FAQ
+
+For frequently asked questions and answers, please consult the
+C<CPANPLUS::FAQ> manual.
+
+=head1 BUG REPORTS
+
+Please report bugs or other issues to E<lt>bug-cpanplus at rt.cpan.org<gt>.
+
+=head1 AUTHOR
+
+This module by Jos Boumans E<lt>kane at cpan.orgE<gt>.
+
+=head1 COPYRIGHT
+
+The CPAN++ interface (of which this module is a part of) is copyright (c)
+2001 - 2007, Jos Boumans E<lt>kane at cpan.orgE<gt>. All rights reserved.
+
+This library is free software; you may redistribute and/or modify it
+under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<CPANPLUS::Shell::Default>, L<CPANPLUS::FAQ>, L<CPANPLUS::Backend>, L<CPANPLUS::Module>, L<cpanp>, L<cpan2dist>
+
+=head1 CONTACT INFORMATION
+
+=over 4
+
+=item * Bug reporting:
+I<bug-cpanplus at rt.cpan.org>
+
+=item * Questions & suggestions:
+I<cpanplus-devel at lists.sourceforge.net>
+
+=back
+
+
+=cut
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
Index: trunk/contrib/perl/lib/Carp/Heavy.pm
===================================================================
--- trunk/contrib/perl/lib/Carp/Heavy.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Carp/Heavy.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Carp/Heavy.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/Carp.pm
===================================================================
--- trunk/contrib/perl/lib/Carp.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Carp.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Carp.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/lib/Carp.t
===================================================================
--- trunk/contrib/perl/lib/Carp.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Carp.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Carp.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/lib/Class/ISA.pm (from rev 6437, vendor/perl/5.18.1/lib/Class/ISA.pm)
===================================================================
--- trunk/contrib/perl/lib/Class/ISA.pm (rev 0)
+++ trunk/contrib/perl/lib/Class/ISA.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,214 @@
+#!/usr/local/bin/perl
+# Time-stamp: "2004-12-29 20:01:02 AST" -*-Perl-*-
+
+package Class::ISA;
+require 5;
+use strict;
+use vars qw($Debug $VERSION);
+$VERSION = '0.33';
+$Debug = 0 unless defined $Debug;
+
+=head1 NAME
+
+Class::ISA -- report the search path for a class's ISA tree
+
+=head1 SYNOPSIS
+
+ # Suppose you go: use Food::Fishstick, and that uses and
+ # inherits from other things, which in turn use and inherit
+ # from other things. And suppose, for sake of brevity of
+ # example, that their ISA tree is the same as:
+
+ @Food::Fishstick::ISA = qw(Food::Fish Life::Fungus Chemicals);
+ @Food::Fish::ISA = qw(Food);
+ @Food::ISA = qw(Matter);
+ @Life::Fungus::ISA = qw(Life);
+ @Chemicals::ISA = qw(Matter);
+ @Life::ISA = qw(Matter);
+ @Matter::ISA = qw();
+
+ use Class::ISA;
+ print "Food::Fishstick path is:\n ",
+ join(", ", Class::ISA::super_path('Food::Fishstick')),
+ "\n";
+
+That prints:
+
+ Food::Fishstick path is:
+ Food::Fish, Food, Matter, Life::Fungus, Life, Chemicals
+
+=head1 DESCRIPTION
+
+Suppose you have a class (like Food::Fish::Fishstick) that is derived,
+via its @ISA, from one or more superclasses (as Food::Fish::Fishstick
+is from Food::Fish, Life::Fungus, and Chemicals), and some of those
+superclasses may themselves each be derived, via its @ISA, from one or
+more superclasses (as above).
+
+When, then, you call a method in that class ($fishstick->calories),
+Perl first searches there for that method, but if it's not there, it
+goes searching in its superclasses, and so on, in a depth-first (or
+maybe "height-first" is the word) search. In the above example, it'd
+first look in Food::Fish, then Food, then Matter, then Life::Fungus,
+then Life, then Chemicals.
+
+This library, Class::ISA, provides functions that return that list --
+the list (in order) of names of classes Perl would search to find a
+method, with no duplicates.
+
+=head1 FUNCTIONS
+
+=over
+
+=item the function Class::ISA::super_path($CLASS)
+
+This returns the ordered list of names of classes that Perl would
+search thru in order to find a method, with no duplicates in the list.
+$CLASS is not included in the list. UNIVERSAL is not included -- if
+you need to consider it, add it to the end.
+
+
+=item the function Class::ISA::self_and_super_path($CLASS)
+
+Just like C<super_path>, except that $CLASS is included as the first
+element.
+
+=item the function Class::ISA::self_and_super_versions($CLASS)
+
+This returns a hash whose keys are $CLASS and its
+(super-)superclasses, and whose values are the contents of each
+class's $VERSION (or undef, for classes with no $VERSION).
+
+The code for self_and_super_versions is meant to serve as an example
+for precisely the kind of tasks I anticipate that self_and_super_path
+and super_path will be used for. You are strongly advised to read the
+source for self_and_super_versions, and the comments there.
+
+=back
+
+=head1 CAUTIONARY NOTES
+
+* Class::ISA doesn't export anything. You have to address the
+functions with a "Class::ISA::" on the front.
+
+* Contrary to its name, Class::ISA isn't a class; it's just a package.
+Strange, isn't it?
+
+* Say you have a loop in the ISA tree of the class you're calling one
+of the Class::ISA functions on: say that Food inherits from Matter,
+but Matter inherits from Food (for sake of argument). If Perl, while
+searching for a method, actually discovers this cyclicity, it will
+throw a fatal error. The functions in Class::ISA effectively ignore
+this cyclicity; the Class::ISA algorithm is "never go down the same
+path twice", and cyclicities are just a special case of that.
+
+* The Class::ISA functions just look at @ISAs. But theoretically, I
+suppose, AUTOLOADs could bypass Perl's ISA-based search mechanism and
+do whatever they please. That would be bad behavior, tho; and I try
+not to think about that.
+
+* If Perl can't find a method anywhere in the ISA tree, it then looks
+in the magical class UNIVERSAL. This is rarely relevant to the tasks
+that I expect Class::ISA functions to be put to, but if it matters to
+you, then instead of this:
+
+ @supers = Class::Tree::super_path($class);
+
+do this:
+
+ @supers = (Class::Tree::super_path($class), 'UNIVERSAL');
+
+And don't say no-one ever told ya!
+
+* When you call them, the Class::ISA functions look at @ISAs anew --
+that is, there is no memoization, and so if ISAs change during
+runtime, you get the current ISA tree's path, not anything memoized.
+However, changing ISAs at runtime is probably a sign that you're out
+of your mind!
+
+=head1 COPYRIGHT
+
+Copyright (c) 1999, 2000 Sean M. Burke. All rights reserved.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=head1 AUTHOR
+
+Sean M. Burke C<sburke at cpan.org>
+
+=cut
+
+###########################################################################
+
+sub self_and_super_versions {
+ no strict 'refs';
+ map {
+ $_ => (defined(${"$_\::VERSION"}) ? ${"$_\::VERSION"} : undef)
+ } self_and_super_path($_[0])
+}
+
+# Also consider magic like:
+# no strict 'refs';
+# my %class2SomeHashr =
+# map { defined(%{"$_\::SomeHash"}) ? ($_ => \%{"$_\::SomeHash"}) : () }
+# Class::ISA::self_and_super_path($class);
+# to get a hash of refs to all the defined (and non-empty) hashes in
+# $class and its superclasses.
+#
+# Or even consider this incantation for doing something like hash-data
+# inheritance:
+# no strict 'refs';
+# %union_hash =
+# map { defined(%{"$_\::SomeHash"}) ? %{"$_\::SomeHash"}) : () }
+# reverse(Class::ISA::self_and_super_path($class));
+# Consider that reverse() is necessary because with
+# %foo = ('a', 'wun', 'b', 'tiw', 'a', 'foist');
+# $foo{'a'} is 'foist', not 'wun'.
+
+###########################################################################
+sub super_path {
+ my @ret = &self_and_super_path(@_);
+ shift @ret if @ret;
+ return @ret;
+}
+
+#--------------------------------------------------------------------------
+sub self_and_super_path {
+ # Assumption: searching is depth-first.
+ # Assumption: '' (empty string) can't be a class package name.
+ # Note: 'UNIVERSAL' is not given any special treatment.
+ return () unless @_;
+
+ my @out = ();
+
+ my @in_stack = ($_[0]);
+ my %seen = ($_[0] => 1);
+
+ my $current;
+ while(@in_stack) {
+ next unless defined($current = shift @in_stack) && length($current);
+ print "At $current\n" if $Debug;
+ push @out, $current;
+ no strict 'refs';
+ unshift @in_stack,
+ map
+ { my $c = $_; # copy, to avoid being destructive
+ substr($c,0,2) = "main::" if substr($c,0,2) eq '::';
+ # Canonize the :: -> main::, ::foo -> main::foo thing.
+ # Should I ever canonize the Foo'Bar = Foo::Bar thing?
+ $seen{$c}++ ? () : $c;
+ }
+ @{"$current\::ISA"}
+ ;
+ # I.e., if this class has any parents (at least, ones I've never seen
+ # before), push them, in order, onto the stack of classes I need to
+ # explore.
+ }
+
+ return @out;
+}
+#--------------------------------------------------------------------------
+1;
+
+__END__
Modified: trunk/contrib/perl/lib/Class/Struct.pm
===================================================================
--- trunk/contrib/perl/lib/Class/Struct.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Class/Struct.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -14,11 +14,8 @@
@ISA = qw(Exporter);
@EXPORT = qw(struct);
-$VERSION = '0.63';
+$VERSION = '0.64';
-## Tested on 5.002 and 5.003 without class membership tests:
-my $CHECK_CLASS_MEMBERSHIP = ($] >= 5.003_95);
-
my $print = 0;
sub printem {
if (@_) { $print = shift }
@@ -130,6 +127,9 @@
elsif( $base_type eq 'ARRAY' ){
$out .= " my(\$r) = [];\n";
}
+
+ $out .= " bless \$r, \$class;\n\n";
+
while( $idx < @decls ){
$name = $decls[$idx];
$type = $decls[$idx+1];
@@ -150,24 +150,24 @@
if( $type eq '@' ){
$out .= " croak 'Initializer for $name must be array reference'\n";
$out .= " if defined(\$init{'$name'}) && ref(\$init{'$name'}) ne 'ARRAY';\n";
- $out .= " \$r->$elem = $init [];$cmt\n";
+ $out .= " \$r->$name( $init [] );$cmt\n";
$arrays{$name}++;
}
elsif( $type eq '%' ){
$out .= " croak 'Initializer for $name must be hash reference'\n";
$out .= " if defined(\$init{'$name'}) && ref(\$init{'$name'}) ne 'HASH';\n";
- $out .= " \$r->$elem = $init {};$cmt\n";
+ $out .= " \$r->$name( $init {} );$cmt\n";
$hashes{$name}++;
}
elsif ( $type eq '$') {
- $out .= " \$r->$elem = $init undef;$cmt\n";
+ $out .= " \$r->$name( $init undef );$cmt\n";
}
elsif( $type =~ /^\w+(?:::\w+)*$/ ){
$out .= " if (defined(\$init{'$name'})) {\n";
$out .= " if (ref \$init{'$name'} eq 'HASH')\n";
- $out .= " { \$r->$elem = $type->new(\%{\$init{'$name'}}) } $cmt\n";
+ $out .= " { \$r->$name( $type->new(\%{\$init{'$name'}}) ) } $cmt\n";
$out .= " elsif (UNIVERSAL::isa(\$init{'$name'}, '$type'))\n";
- $out .= " { \$r->$elem = \$init{'$name'} } $cmt\n";
+ $out .= " { \$r->$name( \$init{'$name'} ) } $cmt\n";
$out .= " else { croak 'Initializer for $name must be hash or $type reference' }\n";
$out .= " }\n";
$classes{$name} = $type;
@@ -178,8 +178,9 @@
}
$idx += 2;
}
- $out .= " bless \$r, \$class;\n }\n";
+ $out .= "\n \$r;\n}\n";
+
# Create accessor methods.
my( $pre, $pst, $sel );
@@ -216,9 +217,7 @@
$sel = "->{\$i}";
}
elsif( defined $classes{$name} ){
- if ( $CHECK_CLASS_MEMBERSHIP ) {
- $out .= " croak '$name argument is wrong class' if \@_ && ! UNIVERSAL::isa(\$_[0], '$classes{$name}');\n";
- }
+ $out .= " croak '$name argument is wrong class' if \@_ && ! UNIVERSAL::isa(\$_[0], '$classes{$name}');\n";
}
$out .= " croak 'Too many args to $name' if \@_ > 1;\n";
$out .= " \@_ ? ($pre\$r->$elem$sel = shift$pst) : $pre\$r->$elem$sel$pst;\n";
Property changes on: trunk/contrib/perl/lib/Class/Struct.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/lib/Class/Struct.t
===================================================================
--- trunk/contrib/perl/lib/Class/Struct.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Class/Struct.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -33,11 +33,32 @@
use Class::Struct s => '$', a => '@', h => '%', c => 'aClass';
#
+# test overriden accessors
+#
+package OverrideAccessor;
+use Class::Struct;
+
+{
+ no warnings qw(Class::Struct);
+ struct( 'OverrideAccessor', { count => '$' } );
+}
+
+sub count {
+ my ($self,$count) = @_;
+
+ if ( @_ >= 2 ) {
+ $self->{'OverrideAccessor::count'} = $count + 9;
+ }
+
+ return $self->{'OverrideAccessor::count'};
+}
+
+#
# back to main...
#
package main;
-use Test::More tests => 24;
+use Test::More;
my $obj = MyObj->new;
isa_ok $obj, 'MyObj';
@@ -101,3 +122,133 @@
my $recobj = RecClass->new();
isa_ok $recobj, 'RecClass';
+my $override_obj = OverrideAccessor->new( count => 3 );
+is $override_obj->count, 12;
+
+$override_obj->count( 1 );
+is $override_obj->count, 10;
+
+
+use Class::Struct Kapow => { z_zwap => 'Regexp', sploosh => 'MyObj' };
+
+is eval { main->new(); }, undef,
+ 'No new method injected into current package';
+
+my $obj3 = Kapow->new();
+
+isa_ok $obj3, 'Kapow';
+is $obj3->z_zwap, undef, 'No z_zwap member by default';
+is $obj3->sploosh, undef, 'No sploosh member by default';
+$obj3->z_zwap(qr//);
+isa_ok $obj3->z_zwap, 'Regexp', 'Can set z_zwap member';
+$obj3->sploosh(MyObj->new(s => 'pie'));
+isa_ok $obj3->sploosh, 'MyObj',
+ 'Can set sploosh member to object of correct class';
+is $obj3->sploosh->s, 'pie', 'Can set sploosh member to correct object';
+
+my $obj4 = Kapow->new( z_zwap => qr//, sploosh => MyObj->new(a => ['Good']) );
+
+isa_ok $obj4, 'Kapow';
+isa_ok $obj4->z_zwap, 'Regexp', 'Initialised z_zwap member';
+isa_ok $obj4->sploosh, 'MyObj', 'Initialised sploosh member';
+is_deeply $obj4->sploosh->a, ['Good'], 'with correct object';
+
+my $obj5 = Kapow->new( sploosh => { h => {perl => 'rules'} } );
+
+isa_ok $obj5, 'Kapow';
+is $obj5->z_zwap, undef, 'No z_zwap member by default';
+isa_ok $obj5->sploosh, 'MyObj', 'Initialised sploosh member from hash';
+is_deeply $obj5->sploosh->h, { perl => 'rules'} , 'with correct object';
+
+is eval {
+ package MyObj;
+ struct( s => '$', a => '@', h => '%', c => 'aClass' );
+}, undef, 'Calling struct a second time fails';
+
+like $@, qr/^function 'new' already defined in package MyObj/,
+ 'fails with the expected error';
+
+is eval { MyObj->new( a => {} ) }, undef,
+ 'Using a hash where an array reference is expected';
+like $@, qr/^Initializer for a must be array reference/,
+ 'fails with the expected error';
+
+is eval { MyObj->new( h => [] ) }, undef,
+ 'Using an array where a hash reference is expected';
+like $@, qr/^Initializer for h must be hash reference/,
+ 'fails with the expected error';
+
+is eval { Kapow->new( sploosh => { h => [perl => 'rules'] } ); }, undef,
+ 'Using an array where a hash reference is expected in an initialiser list';
+like $@, qr/^Initializer for h must be hash reference/,
+ 'fails with the expected error';
+
+is eval { Kapow->new( sploosh => [ h => {perl => 'rules'} ] ); }, undef,
+ "Using an array for a member object's initialiser list";
+like $@, qr/^Initializer for sploosh must be hash or MyObj reference/,
+ 'fails with the expected error';
+
+is eval {
+ package Crraack;
+ use Class::Struct 'struct';
+ struct( 'pow' => '@$%!' );
+}, undef, 'Bad type fails';
+like $@, qr/^'\@\$\%\!' is not a valid struct element type/,
+ 'with the expected error';
+
+is eval {
+ $obj3->sploosh(MyOther->new(s => 3.14));
+}, undef, 'Setting member to the wrong class of object fails';
+like $@, qr/^sploosh argument is wrong class/,
+ 'with the expected error';
+is $obj3->sploosh->s, 'pie', 'Object is unchanged';
+
+is eval {
+ $obj3->sploosh(MyObj->new(s => 3.14), 'plop');
+}, undef, 'Too many arguments to setter fails';
+like $@, qr/^Too many args to sploosh/,
+ 'with the expected error';
+is $obj3->sploosh->s, 'pie', 'Object is unchanged';
+
+is eval {
+ package Blurp;
+ use Class::Struct 'struct';
+ struct( Blurp => {}, 'Bonus!' );
+}, undef, 'hash based class with extra argument fails';
+like $@, qr/\Astruct usage error.*\n.*\n/,
+ 'with the expected confession';
+
+is eval {
+ package Zamm;
+ use Class::Struct 'struct';
+ struct( Zamm => [], 'Bonus!' );
+}, undef, 'array based class with extra argument fails';
+like $@, qr/\Astruct usage error.*\n.*\n/,
+ 'with the expected confession';
+
+is eval {
+ package Thwapp;
+ use Class::Struct 'struct';
+ struct( Thwapp => ['Bonus!'] );
+}, undef, 'array based class with extra constructor argument fails';
+like $@, qr/\Astruct usage error.*\n.*\n/,
+ 'with the expected confession';
+
+is eval {
+ package Rakkk;
+ use Class::Struct 'struct';
+ struct( z_zwap => 'Regexp', sploosh => 'MyObj', 'Bonus' );
+}, undef, 'default array based class with extra constructor argument fails';
+like $@, qr/\Astruct usage error.*\n.*\n/,
+ 'with the expected confession';
+
+is eval {
+ package Awk;
+ use parent -norequire, 'Urkkk';
+ use Class::Struct 'struct';
+ struct( beer => 'foamy' );
+}, undef, '@ISA is not allowed';
+like $@, qr/^struct class cannot be a subclass \(\@ISA not allowed\)/,
+ 'with the expected error';
+
+done_testing;
Property changes on: trunk/contrib/perl/lib/Class/Struct.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/Config/Extensions.pm
===================================================================
--- trunk/contrib/perl/lib/Config/Extensions.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Config/Extensions.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Config/Extensions.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/Config/Extensions.t
===================================================================
--- trunk/contrib/perl/lib/Config/Extensions.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Config/Extensions.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Config/Extensions.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/Config.t
===================================================================
--- trunk/contrib/perl/lib/Config.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Config.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Config.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/lib/Cwd.pm (from rev 6437, vendor/perl/5.18.1/lib/Cwd.pm)
===================================================================
--- trunk/contrib/perl/lib/Cwd.pm (rev 0)
+++ trunk/contrib/perl/lib/Cwd.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,824 @@
+package Cwd;
+
+=head1 NAME
+
+Cwd - get pathname of current working directory
+
+=head1 SYNOPSIS
+
+ use Cwd;
+ my $dir = getcwd;
+
+ use Cwd 'abs_path';
+ my $abs_path = abs_path($file);
+
+=head1 DESCRIPTION
+
+This module provides functions for determining the pathname of the
+current working directory. It is recommended that getcwd (or another
+*cwd() function) be used in I<all> code to ensure portability.
+
+By default, it exports the functions cwd(), getcwd(), fastcwd(), and
+fastgetcwd() (and, on Win32, getdcwd()) into the caller's namespace.
+
+
+=head2 getcwd and friends
+
+Each of these functions are called without arguments and return the
+absolute path of the current working directory.
+
+=over 4
+
+=item getcwd
+
+ my $cwd = getcwd();
+
+Returns the current working directory.
+
+Exposes the POSIX function getcwd(3) or re-implements it if it's not
+available.
+
+=item cwd
+
+ my $cwd = cwd();
+
+The cwd() is the most natural form for the current architecture. For
+most systems it is identical to `pwd` (but without the trailing line
+terminator).
+
+=item fastcwd
+
+ my $cwd = fastcwd();
+
+A more dangerous version of getcwd(), but potentially faster.
+
+It might conceivably chdir() you out of a directory that it can't
+chdir() you back into. If fastcwd encounters a problem it will return
+undef but will probably leave you in a different directory. For a
+measure of extra security, if everything appears to have worked, the
+fastcwd() function will check that it leaves you in the same directory
+that it started in. If it has changed it will C<die> with the message
+"Unstable directory path, current directory changed
+unexpectedly". That should never happen.
+
+=item fastgetcwd
+
+ my $cwd = fastgetcwd();
+
+The fastgetcwd() function is provided as a synonym for cwd().
+
+=item getdcwd
+
+ my $cwd = getdcwd();
+ my $cwd = getdcwd('C:');
+
+The getdcwd() function is also provided on Win32 to get the current working
+directory on the specified drive, since Windows maintains a separate current
+working directory for each drive. If no drive is specified then the current
+drive is assumed.
+
+This function simply calls the Microsoft C library _getdcwd() function.
+
+=back
+
+
+=head2 abs_path and friends
+
+These functions are exported only on request. They each take a single
+argument and return the absolute pathname for it. If no argument is
+given they'll use the current working directory.
+
+=over 4
+
+=item abs_path
+
+ my $abs_path = abs_path($file);
+
+Uses the same algorithm as getcwd(). Symbolic links and relative-path
+components ("." and "..") are resolved to return the canonical
+pathname, just like realpath(3).
+
+=item realpath
+
+ my $abs_path = realpath($file);
+
+A synonym for abs_path().
+
+=item fast_abs_path
+
+ my $abs_path = fast_abs_path($file);
+
+A more dangerous, but potentially faster version of abs_path.
+
+=back
+
+=head2 $ENV{PWD}
+
+If you ask to override your chdir() built-in function,
+
+ use Cwd qw(chdir);
+
+then your PWD environment variable will be kept up to date. Note that
+it will only be kept up to date if all packages which use chdir import
+it from Cwd.
+
+
+=head1 NOTES
+
+=over 4
+
+=item *
+
+Since the path seperators are different on some operating systems ('/'
+on Unix, ':' on MacPerl, etc...) we recommend you use the File::Spec
+modules wherever portability is a concern.
+
+=item *
+
+Actually, on Mac OS, the C<getcwd()>, C<fastgetcwd()> and C<fastcwd()>
+functions are all aliases for the C<cwd()> function, which, on Mac OS,
+calls `pwd`. Likewise, the C<abs_path()> function is an alias for
+C<fast_abs_path()>.
+
+=back
+
+=head1 AUTHOR
+
+Originally by the perl5-porters.
+
+Maintained by Ken Williams <KWILLIAMS at cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+Portions of the C code in this library are copyright (c) 1994 by the
+Regents of the University of California. All rights reserved. The
+license on this code is compatible with the licensing of the rest of
+the distribution - please see the source code in F<Cwd.xs> for the
+details.
+
+=head1 SEE ALSO
+
+L<File::chdir>
+
+=cut
+
+use strict;
+use Exporter;
+use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
+
+$VERSION = '3.30';
+my $xs_version = $VERSION;
+$VERSION = eval $VERSION;
+
+ at ISA = qw/ Exporter /;
+ at EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
+push @EXPORT, qw(getdcwd) if $^O eq 'MSWin32';
+ at EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath);
+
+# sys_cwd may keep the builtin command
+
+# All the functionality of this module may provided by builtins,
+# there is no sense to process the rest of the file.
+# The best choice may be to have this in BEGIN, but how to return from BEGIN?
+
+if ($^O eq 'os2') {
+ local $^W = 0;
+
+ *cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
+ *getcwd = \&cwd;
+ *fastgetcwd = \&cwd;
+ *fastcwd = \&cwd;
+
+ *fast_abs_path = \&sys_abspath if defined &sys_abspath;
+ *abs_path = \&fast_abs_path;
+ *realpath = \&fast_abs_path;
+ *fast_realpath = \&fast_abs_path;
+
+ return 1;
+}
+
+# Need to look up the feature settings on VMS. The preferred way is to use the
+# VMS::Feature module, but that may not be available to dual life modules.
+
+my $use_vms_feature;
+BEGIN {
+ if ($^O eq 'VMS') {
+ if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
+ $use_vms_feature = 1;
+ }
+ }
+}
+
+# Need to look up the UNIX report mode. This may become a dynamic mode
+# in the future.
+sub _vms_unix_rpt {
+ my $unix_rpt;
+ if ($use_vms_feature) {
+ $unix_rpt = VMS::Feature::current("filename_unix_report");
+ } else {
+ my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
+ $unix_rpt = $env_unix_rpt =~ /^[ET1]/i;
+ }
+ return $unix_rpt;
+}
+
+# Need to look up the EFS character set mode. This may become a dynamic
+# mode in the future.
+sub _vms_efs {
+ my $efs;
+ if ($use_vms_feature) {
+ $efs = VMS::Feature::current("efs_charset");
+ } else {
+ my $env_efs = $ENV{'DECC$EFS_CHARSET'} || '';
+ $efs = $env_efs =~ /^[ET1]/i;
+ }
+ return $efs;
+}
+
+
+# If loading the XS stuff doesn't work, we can fall back to pure perl
+eval {
+ if ( $] >= 5.006 ) {
+ require XSLoader;
+ XSLoader::load( __PACKAGE__, $xs_version);
+ } else {
+ require DynaLoader;
+ push @ISA, 'DynaLoader';
+ __PACKAGE__->bootstrap( $xs_version );
+ }
+};
+
+# Must be after the DynaLoader stuff:
+$VERSION = eval $VERSION;
+
+# Big nasty table of function aliases
+my %METHOD_MAP =
+ (
+ VMS =>
+ {
+ cwd => '_vms_cwd',
+ getcwd => '_vms_cwd',
+ fastcwd => '_vms_cwd',
+ fastgetcwd => '_vms_cwd',
+ abs_path => '_vms_abs_path',
+ fast_abs_path => '_vms_abs_path',
+ },
+
+ MSWin32 =>
+ {
+ # We assume that &_NT_cwd is defined as an XSUB or in the core.
+ cwd => '_NT_cwd',
+ getcwd => '_NT_cwd',
+ fastcwd => '_NT_cwd',
+ fastgetcwd => '_NT_cwd',
+ abs_path => 'fast_abs_path',
+ realpath => 'fast_abs_path',
+ },
+
+ dos =>
+ {
+ cwd => '_dos_cwd',
+ getcwd => '_dos_cwd',
+ fastgetcwd => '_dos_cwd',
+ fastcwd => '_dos_cwd',
+ abs_path => 'fast_abs_path',
+ },
+
+ # QNX4. QNX6 has a $os of 'nto'.
+ qnx =>
+ {
+ cwd => '_qnx_cwd',
+ getcwd => '_qnx_cwd',
+ fastgetcwd => '_qnx_cwd',
+ fastcwd => '_qnx_cwd',
+ abs_path => '_qnx_abs_path',
+ fast_abs_path => '_qnx_abs_path',
+ },
+
+ cygwin =>
+ {
+ getcwd => 'cwd',
+ fastgetcwd => 'cwd',
+ fastcwd => 'cwd',
+ abs_path => 'fast_abs_path',
+ realpath => 'fast_abs_path',
+ },
+
+ epoc =>
+ {
+ cwd => '_epoc_cwd',
+ getcwd => '_epoc_cwd',
+ fastgetcwd => '_epoc_cwd',
+ fastcwd => '_epoc_cwd',
+ abs_path => 'fast_abs_path',
+ },
+
+ MacOS =>
+ {
+ getcwd => 'cwd',
+ fastgetcwd => 'cwd',
+ fastcwd => 'cwd',
+ abs_path => 'fast_abs_path',
+ },
+ );
+
+$METHOD_MAP{NT} = $METHOD_MAP{MSWin32};
+
+
+# Find the pwd command in the expected locations. We assume these
+# are safe. This prevents _backtick_pwd() consulting $ENV{PATH}
+# so everything works under taint mode.
+my $pwd_cmd;
+foreach my $try ('/bin/pwd',
+ '/usr/bin/pwd',
+ '/QOpenSys/bin/pwd', # OS/400 PASE.
+ ) {
+
+ if( -x $try ) {
+ $pwd_cmd = $try;
+ last;
+ }
+}
+my $found_pwd_cmd = defined($pwd_cmd);
+unless ($pwd_cmd) {
+ # Isn't this wrong? _backtick_pwd() will fail if somenone has
+ # pwd in their path but it is not /bin/pwd or /usr/bin/pwd?
+ # See [perl #16774]. --jhi
+ $pwd_cmd = 'pwd';
+}
+
+# Lazy-load Carp
+sub _carp { require Carp; Carp::carp(@_) }
+sub _croak { require Carp; Carp::croak(@_) }
+
+# The 'natural and safe form' for UNIX (pwd may be setuid root)
+sub _backtick_pwd {
+ # Localize %ENV entries in a way that won't create new hash keys
+ my @localize = grep exists $ENV{$_}, qw(PATH IFS CDPATH ENV BASH_ENV);
+ local @ENV{@localize};
+
+ my $cwd = `$pwd_cmd`;
+ # Belt-and-suspenders in case someone said "undef $/".
+ local $/ = "\n";
+ # `pwd` may fail e.g. if the disk is full
+ chomp($cwd) if defined $cwd;
+ $cwd;
+}
+
+# Since some ports may predefine cwd internally (e.g., NT)
+# we take care not to override an existing definition for cwd().
+
+unless ($METHOD_MAP{$^O}{cwd} or defined &cwd) {
+ # The pwd command is not available in some chroot(2)'ed environments
+ my $sep = $Config::Config{path_sep} || ':';
+ my $os = $^O; # Protect $^O from tainting
+
+
+ # Try again to find a pwd, this time searching the whole PATH.
+ if (defined $ENV{PATH} and $os ne 'MSWin32') { # no pwd on Windows
+ my @candidates = split($sep, $ENV{PATH});
+ while (!$found_pwd_cmd and @candidates) {
+ my $candidate = shift @candidates;
+ $found_pwd_cmd = 1 if -x "$candidate/pwd";
+ }
+ }
+
+ # MacOS has some special magic to make `pwd` work.
+ if( $os eq 'MacOS' || $found_pwd_cmd )
+ {
+ *cwd = \&_backtick_pwd;
+ }
+ else {
+ *cwd = \&getcwd;
+ }
+}
+
+if ($^O eq 'cygwin') {
+ # We need to make sure cwd() is called with no args, because it's
+ # got an arg-less prototype and will die if args are present.
+ local $^W = 0;
+ my $orig_cwd = \&cwd;
+ *cwd = sub { &$orig_cwd() }
+}
+
+
+# set a reasonable (and very safe) default for fastgetcwd, in case it
+# isn't redefined later (20001212 rspier)
+*fastgetcwd = \&cwd;
+
+# A non-XS version of getcwd() - also used to bootstrap the perl build
+# process, when miniperl is running and no XS loading happens.
+sub _perl_getcwd
+{
+ abs_path('.');
+}
+
+# By John Bazik
+#
+# Usage: $cwd = &fastcwd;
+#
+# This is a faster version of getcwd. It's also more dangerous because
+# you might chdir out of a directory that you can't chdir back into.
+
+sub fastcwd_ {
+ my($odev, $oino, $cdev, $cino, $tdev, $tino);
+ my(@path, $path);
+ local(*DIR);
+
+ my($orig_cdev, $orig_cino) = stat('.');
+ ($cdev, $cino) = ($orig_cdev, $orig_cino);
+ for (;;) {
+ my $direntry;
+ ($odev, $oino) = ($cdev, $cino);
+ CORE::chdir('..') || return undef;
+ ($cdev, $cino) = stat('.');
+ last if $odev == $cdev && $oino == $cino;
+ opendir(DIR, '.') || return undef;
+ for (;;) {
+ $direntry = readdir(DIR);
+ last unless defined $direntry;
+ next if $direntry eq '.';
+ next if $direntry eq '..';
+
+ ($tdev, $tino) = lstat($direntry);
+ last unless $tdev != $odev || $tino != $oino;
+ }
+ closedir(DIR);
+ return undef unless defined $direntry; # should never happen
+ unshift(@path, $direntry);
+ }
+ $path = '/' . join('/', @path);
+ if ($^O eq 'apollo') { $path = "/".$path; }
+ # At this point $path may be tainted (if tainting) and chdir would fail.
+ # Untaint it then check that we landed where we started.
+ $path =~ /^(.*)\z/s # untaint
+ && CORE::chdir($1) or return undef;
+ ($cdev, $cino) = stat('.');
+ die "Unstable directory path, current directory changed unexpectedly"
+ if $cdev != $orig_cdev || $cino != $orig_cino;
+ $path;
+}
+if (not defined &fastcwd) { *fastcwd = \&fastcwd_ }
+
+
+# Keeps track of current working directory in PWD environment var
+# Usage:
+# use Cwd 'chdir';
+# chdir $newdir;
+
+my $chdir_init = 0;
+
+sub chdir_init {
+ if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') {
+ my($dd,$di) = stat('.');
+ my($pd,$pi) = stat($ENV{'PWD'});
+ if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
+ $ENV{'PWD'} = cwd();
+ }
+ }
+ else {
+ my $wd = cwd();
+ $wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32';
+ $ENV{'PWD'} = $wd;
+ }
+ # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar)
+ if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) {
+ my($pd,$pi) = stat($2);
+ my($dd,$di) = stat($1);
+ if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
+ $ENV{'PWD'}="$2$3";
+ }
+ }
+ $chdir_init = 1;
+}
+
+sub chdir {
+ my $newdir = @_ ? shift : ''; # allow for no arg (chdir to HOME dir)
+ $newdir =~ s|///*|/|g unless $^O eq 'MSWin32';
+ chdir_init() unless $chdir_init;
+ my $newpwd;
+ if ($^O eq 'MSWin32') {
+ # get the full path name *before* the chdir()
+ $newpwd = Win32::GetFullPathName($newdir);
+ }
+
+ return 0 unless CORE::chdir $newdir;
+
+ if ($^O eq 'VMS') {
+ return $ENV{'PWD'} = $ENV{'DEFAULT'}
+ }
+ elsif ($^O eq 'MacOS') {
+ return $ENV{'PWD'} = cwd();
+ }
+ elsif ($^O eq 'MSWin32') {
+ $ENV{'PWD'} = $newpwd;
+ return 1;
+ }
+
+ if (ref $newdir eq 'GLOB') { # in case a file/dir handle is passed in
+ $ENV{'PWD'} = cwd();
+ } elsif ($newdir =~ m#^/#s) {
+ $ENV{'PWD'} = $newdir;
+ } else {
+ my @curdir = split(m#/#,$ENV{'PWD'});
+ @curdir = ('') unless @curdir;
+ my $component;
+ foreach $component (split(m#/#, $newdir)) {
+ next if $component eq '.';
+ pop(@curdir),next if $component eq '..';
+ push(@curdir,$component);
+ }
+ $ENV{'PWD'} = join('/', at curdir) || '/';
+ }
+ 1;
+}
+
+
+sub _perl_abs_path
+{
+ my $start = @_ ? shift : '.';
+ my($dotdots, $cwd, @pst, @cst, $dir, @tst);
+
+ unless (@cst = stat( $start ))
+ {
+ _carp("stat($start): $!");
+ return '';
+ }
+
+ unless (-d _) {
+ # Make sure we can be invoked on plain files, not just directories.
+ # NOTE that this routine assumes that '/' is the only directory separator.
+
+ my ($dir, $file) = $start =~ m{^(.*)/(.+)$}
+ or return cwd() . '/' . $start;
+
+ # Can't use "-l _" here, because the previous stat was a stat(), not an lstat().
+ if (-l $start) {
+ my $link_target = readlink($start);
+ die "Can't resolve link $start: $!" unless defined $link_target;
+
+ require File::Spec;
+ $link_target = $dir . '/' . $link_target
+ unless File::Spec->file_name_is_absolute($link_target);
+
+ return abs_path($link_target);
+ }
+
+ return $dir ? abs_path($dir) . "/$file" : "/$file";
+ }
+
+ $cwd = '';
+ $dotdots = $start;
+ do
+ {
+ $dotdots .= '/..';
+ @pst = @cst;
+ local *PARENT;
+ unless (opendir(PARENT, $dotdots))
+ {
+ # probably a permissions issue. Try the native command.
+ return File::Spec->rel2abs( $start, _backtick_pwd() );
+ }
+ unless (@cst = stat($dotdots))
+ {
+ _carp("stat($dotdots): $!");
+ closedir(PARENT);
+ return '';
+ }
+ if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
+ {
+ $dir = undef;
+ }
+ else
+ {
+ do
+ {
+ unless (defined ($dir = readdir(PARENT)))
+ {
+ _carp("readdir($dotdots): $!");
+ closedir(PARENT);
+ return '';
+ }
+ $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir"))
+ }
+ while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
+ $tst[1] != $pst[1]);
+ }
+ $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ;
+ closedir(PARENT);
+ } while (defined $dir);
+ chop($cwd) unless $cwd eq '/'; # drop the trailing /
+ $cwd;
+}
+
+
+my $Curdir;
+sub fast_abs_path {
+ local $ENV{PWD} = $ENV{PWD} || ''; # Guard against clobberage
+ my $cwd = getcwd();
+ require File::Spec;
+ my $path = @_ ? shift : ($Curdir ||= File::Spec->curdir);
+
+ # Detaint else we'll explode in taint mode. This is safe because
+ # we're not doing anything dangerous with it.
+ ($path) = $path =~ /(.*)/;
+ ($cwd) = $cwd =~ /(.*)/;
+
+ unless (-e $path) {
+ _croak("$path: No such file or directory");
+ }
+
+ unless (-d _) {
+ # Make sure we can be invoked on plain files, not just directories.
+
+ my ($vol, $dir, $file) = File::Spec->splitpath($path);
+ return File::Spec->catfile($cwd, $path) unless length $dir;
+
+ if (-l $path) {
+ my $link_target = readlink($path);
+ die "Can't resolve link $path: $!" unless defined $link_target;
+
+ $link_target = File::Spec->catpath($vol, $dir, $link_target)
+ unless File::Spec->file_name_is_absolute($link_target);
+
+ return fast_abs_path($link_target);
+ }
+
+ return $dir eq File::Spec->rootdir
+ ? File::Spec->catpath($vol, $dir, $file)
+ : fast_abs_path(File::Spec->catpath($vol, $dir, '')) . '/' . $file;
+ }
+
+ if (!CORE::chdir($path)) {
+ _croak("Cannot chdir to $path: $!");
+ }
+ my $realpath = getcwd();
+ if (! ((-d $cwd) && (CORE::chdir($cwd)))) {
+ _croak("Cannot chdir back to $cwd: $!");
+ }
+ $realpath;
+}
+
+# added function alias to follow principle of least surprise
+# based on previous aliasing. --tchrist 27-Jan-00
+*fast_realpath = \&fast_abs_path;
+
+
+# --- PORTING SECTION ---
+
+# VMS: $ENV{'DEFAULT'} points to default directory at all times
+# 06-Mar-1996 Charles Bailey bailey at newman.upenn.edu
+# Note: Use of Cwd::chdir() causes the logical name PWD to be defined
+# in the process logical name table as the default device and directory
+# seen by Perl. This may not be the same as the default device
+# and directory seen by DCL after Perl exits, since the effects
+# the CRTL chdir() function persist only until Perl exits.
+
+sub _vms_cwd {
+ return $ENV{'DEFAULT'};
+}
+
+sub _vms_abs_path {
+ return $ENV{'DEFAULT'} unless @_;
+ my $path = shift;
+
+ my $efs = _vms_efs;
+ my $unix_rpt = _vms_unix_rpt;
+
+ if (defined &VMS::Filespec::vmsrealpath) {
+ my $path_unix = 0;
+ my $path_vms = 0;
+
+ $path_unix = 1 if ($path =~ m#(?<=\^)/#);
+ $path_unix = 1 if ($path =~ /^\.\.?$/);
+ $path_vms = 1 if ($path =~ m#[\[<\]]#);
+ $path_vms = 1 if ($path =~ /^--?$/);
+
+ my $unix_mode = $path_unix;
+ if ($efs) {
+ # In case of a tie, the Unix report mode decides.
+ if ($path_vms == $path_unix) {
+ $unix_mode = $unix_rpt;
+ } else {
+ $unix_mode = 0 if $path_vms;
+ }
+ }
+
+ if ($unix_mode) {
+ # Unix format
+ return VMS::Filespec::unixrealpath($path);
+ }
+
+ # VMS format
+
+ my $new_path = VMS::Filespec::vmsrealpath($path);
+
+ # Perl expects directories to be in directory format
+ $new_path = VMS::Filespec::pathify($new_path) if -d $path;
+ return $new_path;
+ }
+
+ # Fallback to older algorithm if correct ones are not
+ # available.
+
+ if (-l $path) {
+ my $link_target = readlink($path);
+ die "Can't resolve link $path: $!" unless defined $link_target;
+
+ return _vms_abs_path($link_target);
+ }
+
+ # may need to turn foo.dir into [.foo]
+ my $pathified = VMS::Filespec::pathify($path);
+ $path = $pathified if defined $pathified;
+
+ return VMS::Filespec::rmsexpand($path);
+}
+
+sub _os2_cwd {
+ $ENV{'PWD'} = `cmd /c cd`;
+ chomp $ENV{'PWD'};
+ $ENV{'PWD'} =~ s:\\:/:g ;
+ return $ENV{'PWD'};
+}
+
+sub _win32_cwd {
+ if (defined &DynaLoader::boot_DynaLoader) {
+ $ENV{'PWD'} = Win32::GetCwd();
+ }
+ else { # miniperl
+ chomp($ENV{'PWD'} = `cd`);
+ }
+ $ENV{'PWD'} =~ s:\\:/:g ;
+ return $ENV{'PWD'};
+}
+
+*_NT_cwd = defined &Win32::GetCwd ? \&_win32_cwd : \&_os2_cwd;
+
+sub _dos_cwd {
+ if (!defined &Dos::GetCwd) {
+ $ENV{'PWD'} = `command /c cd`;
+ chomp $ENV{'PWD'};
+ $ENV{'PWD'} =~ s:\\:/:g ;
+ } else {
+ $ENV{'PWD'} = Dos::GetCwd();
+ }
+ return $ENV{'PWD'};
+}
+
+sub _qnx_cwd {
+ local $ENV{PATH} = '';
+ local $ENV{CDPATH} = '';
+ local $ENV{ENV} = '';
+ $ENV{'PWD'} = `/usr/bin/fullpath -t`;
+ chomp $ENV{'PWD'};
+ return $ENV{'PWD'};
+}
+
+sub _qnx_abs_path {
+ local $ENV{PATH} = '';
+ local $ENV{CDPATH} = '';
+ local $ENV{ENV} = '';
+ my $path = @_ ? shift : '.';
+ local *REALPATH;
+
+ defined( open(REALPATH, '-|') || exec '/usr/bin/fullpath', '-t', $path ) or
+ die "Can't open /usr/bin/fullpath: $!";
+ my $realpath = <REALPATH>;
+ close REALPATH;
+ chomp $realpath;
+ return $realpath;
+}
+
+sub _epoc_cwd {
+ $ENV{'PWD'} = EPOC::getcwd();
+ return $ENV{'PWD'};
+}
+
+
+# Now that all the base-level functions are set up, alias the
+# user-level functions to the right places
+
+if (exists $METHOD_MAP{$^O}) {
+ my $map = $METHOD_MAP{$^O};
+ foreach my $name (keys %$map) {
+ local $^W = 0; # assignments trigger 'subroutine redefined' warning
+ no strict 'refs';
+ *{$name} = \&{$map->{$name}};
+ }
+}
+
+# In case the XS version doesn't load.
+*abs_path = \&_perl_abs_path unless defined &abs_path;
+*getcwd = \&_perl_getcwd unless defined &getcwd;
+
+# added function alias for those of us more
+# used to the libc function. --tchrist 27-Jan-00
+*realpath = \&abs_path;
+
+1;
Modified: trunk/contrib/perl/lib/DB.pm
===================================================================
--- trunk/contrib/perl/lib/DB.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/DB.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -41,7 +41,7 @@
$DB::subname = ''; # currently executing sub (fullly qualified name)
$DB::lineno = ''; # current line number
- $DB::VERSION = $DB::VERSION = '1.03';
+ $DB::VERSION = $DB::VERSION = '1.04';
# initialize private globals to avoid warnings
@@ -258,7 +258,7 @@
} elsif ($s eq '(eval)') {
$s = "eval {...}";
}
- $f = "file `$f'" unless $f eq '-e';
+ $f = "file '$f'" unless $f eq '-e';
push @ret, "$w&$s$a from $f line $l";
last if $DB::signal;
}
Property changes on: trunk/contrib/perl/lib/DB.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/DB.t
===================================================================
--- trunk/contrib/perl/lib/DB.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/DB.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -126,7 +126,7 @@
my @ret = eval { DB->backtrace() };
like( $ret[0], qr/file.+\Q$0\E/, 'DB::backtrace() should report current file');
like( $ret[0], qr/line $line/, '... should report calling line number' );
- like( $ret[0], qr/eval {...}/, '... should catch eval BLOCK' );
+ like( $ret[0], qr/eval\Q {...}/, '... should catch eval BLOCK' );
@ret = eval "one(2)";
is( scalar @ret, 1, '... should report from provided stack frame number' );
Property changes on: trunk/contrib/perl/lib/DB.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/DBM_Filter/Changes
===================================================================
--- trunk/contrib/perl/lib/DBM_Filter/Changes 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/DBM_Filter/Changes 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/DBM_Filter/Changes
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/DBM_Filter/compress.pm
===================================================================
--- trunk/contrib/perl/lib/DBM_Filter/compress.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/DBM_Filter/compress.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/DBM_Filter/compress.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/DBM_Filter/encode.pm
===================================================================
--- trunk/contrib/perl/lib/DBM_Filter/encode.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/DBM_Filter/encode.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/DBM_Filter/encode.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/DBM_Filter/int32.pm
===================================================================
--- trunk/contrib/perl/lib/DBM_Filter/int32.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/DBM_Filter/int32.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/DBM_Filter/int32.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/DBM_Filter/null.pm
===================================================================
--- trunk/contrib/perl/lib/DBM_Filter/null.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/DBM_Filter/null.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/DBM_Filter/null.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/DBM_Filter/t/01error.t
===================================================================
--- trunk/contrib/perl/lib/DBM_Filter/t/01error.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/DBM_Filter/t/01error.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/DBM_Filter/t/01error.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/DBM_Filter/t/02core.t
===================================================================
--- trunk/contrib/perl/lib/DBM_Filter/t/02core.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/DBM_Filter/t/02core.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/DBM_Filter/t/02core.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/DBM_Filter/t/compress.t
===================================================================
--- trunk/contrib/perl/lib/DBM_Filter/t/compress.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/DBM_Filter/t/compress.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/DBM_Filter/t/compress.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/DBM_Filter/t/encode.t
===================================================================
--- trunk/contrib/perl/lib/DBM_Filter/t/encode.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/DBM_Filter/t/encode.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/DBM_Filter/t/encode.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/lib/DBM_Filter/t/int32.t
===================================================================
--- trunk/contrib/perl/lib/DBM_Filter/t/int32.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/DBM_Filter/t/int32.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -55,9 +55,8 @@
no warnings 'uninitialized';
StoreData(\%h1,
{
- undef() => undef(),
"400" => "500",
- 0 => 1,
+ undef() => 1,
1 => 0,
-47 => -6,
});
Property changes on: trunk/contrib/perl/lib/DBM_Filter/t/int32.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/DBM_Filter/t/null.t
===================================================================
--- trunk/contrib/perl/lib/DBM_Filter/t/null.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/DBM_Filter/t/null.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/DBM_Filter/t/null.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/DBM_Filter/t/utf8.t
===================================================================
--- trunk/contrib/perl/lib/DBM_Filter/t/utf8.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/DBM_Filter/t/utf8.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/DBM_Filter/t/utf8.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/DBM_Filter/utf8.pm
===================================================================
--- trunk/contrib/perl/lib/DBM_Filter/utf8.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/DBM_Filter/utf8.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/DBM_Filter/utf8.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/lib/DBM_Filter.pm
===================================================================
--- trunk/contrib/perl/lib/DBM_Filter.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/DBM_Filter.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -2,7 +2,7 @@
use strict;
use warnings;
-our $VERSION = '0.04';
+our $VERSION = '0.05';
package Tie::Hash ;
@@ -247,7 +247,7 @@
$db->Filtered();
package DBM_Filter::my_filter1;
-
+
sub Store { ... }
sub Fetch { ... }
Property changes on: trunk/contrib/perl/lib/DBM_Filter.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/lib/Digest.pm (from rev 6437, vendor/perl/5.18.1/lib/Digest.pm)
===================================================================
--- trunk/contrib/perl/lib/Digest.pm (rev 0)
+++ trunk/contrib/perl/lib/Digest.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,316 @@
+package Digest;
+
+use strict;
+use vars qw($VERSION %MMAP $AUTOLOAD);
+
+$VERSION = "1.16";
+
+%MMAP = (
+ "SHA-1" => [["Digest::SHA", 1], "Digest::SHA1", ["Digest::SHA2", 1]],
+ "SHA-224" => [["Digest::SHA", 224]],
+ "SHA-256" => [["Digest::SHA", 256], ["Digest::SHA2", 256]],
+ "SHA-384" => [["Digest::SHA", 384], ["Digest::SHA2", 384]],
+ "SHA-512" => [["Digest::SHA", 512], ["Digest::SHA2", 512]],
+ "HMAC-MD5" => "Digest::HMAC_MD5",
+ "HMAC-SHA-1" => "Digest::HMAC_SHA1",
+ "CRC-16" => [["Digest::CRC", type => "crc16"]],
+ "CRC-32" => [["Digest::CRC", type => "crc32"]],
+ "CRC-CCITT" => [["Digest::CRC", type => "crcccitt"]],
+ "RIPEMD-160" => "Crypt::PIPEMD160",
+);
+
+sub new
+{
+ shift; # class ignored
+ my $algorithm = shift;
+ my $impl = $MMAP{$algorithm} || do {
+ $algorithm =~ s/\W+//;
+ "Digest::$algorithm";
+ };
+ $impl = [$impl] unless ref($impl);
+ my $err;
+ for (@$impl) {
+ my $class = $_;
+ my @args;
+ ($class, @args) = @$class if ref($class);
+ no strict 'refs';
+ unless (exists ${"$class\::"}{"VERSION"}) {
+ eval "require $class";
+ if ($@) {
+ $err ||= $@;
+ next;
+ }
+ }
+ return $class->new(@args, @_);
+ }
+ die $err;
+}
+
+sub AUTOLOAD
+{
+ my $class = shift;
+ my $algorithm = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
+ $class->new($algorithm, @_);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Digest - Modules that calculate message digests
+
+=head1 SYNOPSIS
+
+ $md5 = Digest->new("MD5");
+ $sha1 = Digest->new("SHA-1");
+ $sha256 = Digest->new("SHA-256");
+ $sha384 = Digest->new("SHA-384");
+ $sha512 = Digest->new("SHA-512");
+
+ $hmac = Digest->HMAC_MD5($key);
+
+=head1 DESCRIPTION
+
+The C<Digest::> modules calculate digests, also called "fingerprints"
+or "hashes", of some data, called a message. The digest is (usually)
+some small/fixed size string. The actual size of the digest depend of
+the algorithm used. The message is simply a sequence of arbitrary
+bytes or bits.
+
+An important property of the digest algorithms is that the digest is
+I<likely> to change if the message change in some way. Another
+property is that digest functions are one-way functions, that is it
+should be I<hard> to find a message that correspond to some given
+digest. Algorithms differ in how "likely" and how "hard", as well as
+how efficient they are to compute.
+
+Note that the properties of the algorithms change over time, as the
+algorithms are analyzed and machines grow faster. If your application
+for instance depends on it being "impossible" to generate the same
+digest for a different message it is wise to make it easy to plug in
+stronger algorithms as the one used grow weaker. Using the interface
+documented here should make it easy to change algorithms later.
+
+All C<Digest::> modules provide the same programming interface. A
+functional interface for simple use, as well as an object oriented
+interface that can handle messages of arbitrary length and which can
+read files directly.
+
+The digest can be delivered in three formats:
+
+=over 8
+
+=item I<binary>
+
+This is the most compact form, but it is not well suited for printing
+or embedding in places that can't handle arbitrary data.
+
+=item I<hex>
+
+A twice as long string of lowercase hexadecimal digits.
+
+=item I<base64>
+
+A string of portable printable characters. This is the base64 encoded
+representation of the digest with any trailing padding removed. The
+string will be about 30% longer than the binary version.
+L<MIME::Base64> tells you more about this encoding.
+
+=back
+
+
+The functional interface is simply importable functions with the same
+name as the algorithm. The functions take the message as argument and
+return the digest. Example:
+
+ use Digest::MD5 qw(md5);
+ $digest = md5($message);
+
+There are also versions of the functions with "_hex" or "_base64"
+appended to the name, which returns the digest in the indicated form.
+
+=head1 OO INTERFACE
+
+The following methods are available for all C<Digest::> modules:
+
+=over 4
+
+=item $ctx = Digest->XXX($arg,...)
+
+=item $ctx = Digest->new(XXX => $arg,...)
+
+=item $ctx = Digest::XXX->new($arg,...)
+
+The constructor returns some object that encapsulate the state of the
+message-digest algorithm. You can add data to the object and finally
+ask for the digest. The "XXX" should of course be replaced by the proper
+name of the digest algorithm you want to use.
+
+The two first forms are simply syntactic sugar which automatically
+load the right module on first use. The second form allow you to use
+algorithm names which contains letters which are not legal perl
+identifiers, e.g. "SHA-1". If no implementation for the given algorithm
+can be found, then an exception is raised.
+
+If new() is called as an instance method (i.e. $ctx->new) it will just
+reset the state the object to the state of a newly created object. No
+new object is created in this case, and the return value is the
+reference to the object (i.e. $ctx).
+
+=item $other_ctx = $ctx->clone
+
+The clone method creates a copy of the digest state object and returns
+a reference to the copy.
+
+=item $ctx->reset
+
+This is just an alias for $ctx->new.
+
+=item $ctx->add( $data )
+
+=item $ctx->add( $chunk1, $chunk2, ... )
+
+The string value of the $data provided as argument is appended to the
+message we calculate the digest for. The return value is the $ctx
+object itself.
+
+If more arguments are provided then they are all appended to the
+message, thus all these lines will have the same effect on the state
+of the $ctx object:
+
+ $ctx->add("a"); $ctx->add("b"); $ctx->add("c");
+ $ctx->add("a")->add("b")->add("c");
+ $ctx->add("a", "b", "c");
+ $ctx->add("abc");
+
+Most algorithms are only defined for strings of bytes and this method
+might therefore croak if the provided arguments contain chars with
+ordinal number above 255.
+
+=item $ctx->addfile( $io_handle )
+
+The $io_handle is read until EOF and the content is appended to the
+message we calculate the digest for. The return value is the $ctx
+object itself.
+
+The addfile() method will croak() if it fails reading data for some
+reason. If it croaks it is unpredictable what the state of the $ctx
+object will be in. The addfile() method might have been able to read
+the file partially before it failed. It is probably wise to discard
+or reset the $ctx object if this occurs.
+
+In most cases you want to make sure that the $io_handle is in
+"binmode" before you pass it as argument to the addfile() method.
+
+=item $ctx->add_bits( $data, $nbits )
+
+=item $ctx->add_bits( $bitstring )
+
+The add_bits() method is an alternative to add() that allow partial
+bytes to be appended to the message. Most users should just ignore
+this method as partial bytes is very unlikely to be of any practical
+use.
+
+The two argument form of add_bits() will add the first $nbits bits
+from $data. For the last potentially partial byte only the high order
+C<< $nbits % 8 >> bits are used. If $nbits is greater than C<<
+length($data) * 8 >>, then this method would do the same as C<<
+$ctx->add($data) >>.
+
+The one argument form of add_bits() takes a $bitstring of "1" and "0"
+chars as argument. It's a shorthand for C<< $ctx->add_bits(pack("B*",
+$bitstring), length($bitstring)) >>.
+
+The return value is the $ctx object itself.
+
+This example shows two calls that should have the same effect:
+
+ $ctx->add_bits("111100001010");
+ $ctx->add_bits("\xF0\xA0", 12);
+
+Most digest algorithms are byte based and for these it is not possible
+to add bits that are not a multiple of 8, and the add_bits() method
+will croak if you try.
+
+=item $ctx->digest
+
+Return the binary digest for the message.
+
+Note that the C<digest> operation is effectively a destructive,
+read-once operation. Once it has been performed, the $ctx object is
+automatically C<reset> and can be used to calculate another digest
+value. Call $ctx->clone->digest if you want to calculate the digest
+without resetting the digest state.
+
+=item $ctx->hexdigest
+
+Same as $ctx->digest, but will return the digest in hexadecimal form.
+
+=item $ctx->b64digest
+
+Same as $ctx->digest, but will return the digest as a base64 encoded
+string.
+
+=back
+
+=head1 Digest speed
+
+This table should give some indication on the relative speed of
+different algorithms. It is sorted by throughput based on a benchmark
+done with of some implementations of this API:
+
+ Algorithm Size Implementation MB/s
+
+ MD4 128 Digest::MD4 v1.3 165.0
+ MD5 128 Digest::MD5 v2.33 98.8
+ SHA-256 256 Digest::SHA2 v1.1.0 66.7
+ SHA-1 160 Digest::SHA v4.3.1 58.9
+ SHA-1 160 Digest::SHA1 v2.10 48.8
+ SHA-256 256 Digest::SHA v4.3.1 41.3
+ Haval-256 256 Digest::Haval256 v1.0.4 39.8
+ SHA-384 384 Digest::SHA2 v1.1.0 19.6
+ SHA-512 512 Digest::SHA2 v1.1.0 19.3
+ SHA-384 384 Digest::SHA v4.3.1 19.2
+ SHA-512 512 Digest::SHA v4.3.1 19.2
+ Whirlpool 512 Digest::Whirlpool v1.0.2 13.0
+ MD2 128 Digest::MD2 v2.03 9.5
+
+ Adler-32 32 Digest::Adler32 v0.03 1.3
+ CRC-16 16 Digest::CRC v0.05 1.1
+ CRC-32 32 Digest::CRC v0.05 1.1
+ MD5 128 Digest::Perl::MD5 v1.5 1.0
+ CRC-CCITT 16 Digest::CRC v0.05 0.8
+
+These numbers was achieved Apr 2004 with ActivePerl-5.8.3 running
+under Linux on a P4 2.8 GHz CPU. The last 5 entries differ by being
+pure perl implementations of the algorithms, which explains why they
+are so slow.
+
+=head1 SEE ALSO
+
+L<Digest::Adler32>, L<Digest::CRC>, L<Digest::Haval256>,
+L<Digest::HMAC>, L<Digest::MD2>, L<Digest::MD4>, L<Digest::MD5>,
+L<Digest::SHA>, L<Digest::SHA1>, L<Digest::SHA2>, L<Digest::Whirlpool>
+
+New digest implementations should consider subclassing from L<Digest::base>.
+
+L<MIME::Base64>
+
+http://en.wikipedia.org/wiki/Cryptographic_hash_function
+
+=head1 AUTHOR
+
+Gisle Aas <gisle at aas.no>
+
+The C<Digest::> interface is based on the interface originally
+developed by Neil Winton for his C<MD5> module.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+ Copyright 1998-2006 Gisle Aas.
+ Copyright 1995,1996 Neil Winton.
+
+=cut
Index: trunk/contrib/perl/lib/DirHandle.pm
===================================================================
--- trunk/contrib/perl/lib/DirHandle.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/DirHandle.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/DirHandle.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/lib/DirHandle.t
===================================================================
--- trunk/contrib/perl/lib/DirHandle.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/DirHandle.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/DirHandle.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Copied: trunk/contrib/perl/lib/Dumpvalue.pm (from rev 6437, vendor/perl/5.18.1/lib/Dumpvalue.pm)
===================================================================
--- trunk/contrib/perl/lib/Dumpvalue.pm (rev 0)
+++ trunk/contrib/perl/lib/Dumpvalue.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,648 @@
+use 5.006_001; # for (defined ref) and $#$v and our
+package Dumpvalue;
+use strict;
+our $VERSION = '1.13';
+our(%address, $stab, @stab, %stab, %subs);
+
+# documentation nits, handle complex data structures better by chromatic
+# translate control chars to ^X - Randal Schwartz
+# Modifications to print types by Peter Gordon v1.0
+
+# Ilya Zakharevich -- patches after 5.001 (and some before ;-)
+
+# Won't dump symbol tables and contents of debugged files by default
+
+# (IZ) changes for objectification:
+# c) quote() renamed to method set_quote();
+# d) unctrlSet() renamed to method set_unctrl();
+# f) Compiles with `use strict', but in two places no strict refs is needed:
+# maybe more problems are waiting...
+
+my %defaults = (
+ globPrint => 0,
+ printUndef => 1,
+ tick => "auto",
+ unctrl => 'quote',
+ subdump => 1,
+ dumpReused => 0,
+ bareStringify => 1,
+ hashDepth => '',
+ arrayDepth => '',
+ dumpDBFiles => '',
+ dumpPackages => '',
+ quoteHighBit => '',
+ usageOnly => '',
+ compactDump => '',
+ veryCompact => '',
+ stopDbSignal => '',
+ );
+
+sub new {
+ my $class = shift;
+ my %opt = (%defaults, @_);
+ bless \%opt, $class;
+}
+
+sub set {
+ my $self = shift;
+ my %opt = @_;
+ @$self{keys %opt} = values %opt;
+}
+
+sub get {
+ my $self = shift;
+ wantarray ? @$self{@_} : $$self{pop @_};
+}
+
+sub dumpValue {
+ my $self = shift;
+ die "usage: \$dumper->dumpValue(value)" unless @_ == 1;
+ local %address;
+ local $^W=0;
+ (print "undef\n"), return unless defined $_[0];
+ (print $self->stringify($_[0]), "\n"), return unless ref $_[0];
+ $self->unwrap($_[0],0);
+}
+
+sub dumpValues {
+ my $self = shift;
+ local %address;
+ local $^W=0;
+ (print "undef\n"), return unless defined $_[0];
+ $self->unwrap(\@_,0);
+}
+
+# This one is good for variable names:
+
+sub unctrl {
+ local($_) = @_;
+
+ return \$_ if ref \$_ eq "GLOB";
+ s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;
+ $_;
+}
+
+sub stringify {
+ my $self = shift;
+ local $_ = shift;
+ my $noticks = shift;
+ my $tick = $self->{tick};
+
+ return 'undef' unless defined $_ or not $self->{printUndef};
+ return $_ . "" if ref \$_ eq 'GLOB';
+ { no strict 'refs';
+ $_ = &{'overload::StrVal'}($_)
+ if $self->{bareStringify} and ref $_
+ and %overload:: and defined &{'overload::StrVal'};
+ }
+
+ if ($tick eq 'auto') {
+ if (/[\000-\011\013-\037\177]/) {
+ $tick = '"';
+ } else {
+ $tick = "'";
+ }
+ }
+ if ($tick eq "'") {
+ s/([\'\\])/\\$1/g;
+ } elsif ($self->{unctrl} eq 'unctrl') {
+ s/([\"\\])/\\$1/g ;
+ s/([\000-\037\177])/'^'.pack('c',ord($1)^64)/eg;
+ s/([\200-\377])/'\\0x'.sprintf('%2X',ord($1))/eg
+ if $self->{quoteHighBit};
+ } elsif ($self->{unctrl} eq 'quote') {
+ s/([\"\\\$\@])/\\$1/g if $tick eq '"';
+ s/\033/\\e/g;
+ s/([\000-\037\177])/'\\c'.chr(ord($1)^64)/eg;
+ }
+ s/([\200-\377])/'\\'.sprintf('%3o',ord($1))/eg if $self->{quoteHighBit};
+ ($noticks || /^\d+(\.\d*)?\Z/)
+ ? $_
+ : $tick . $_ . $tick;
+}
+
+sub DumpElem {
+ my ($self, $v) = (shift, shift);
+ my $short = $self->stringify($v, ref $v);
+ my $shortmore = '';
+ if ($self->{veryCompact} && ref $v
+ && (ref $v eq 'ARRAY' and !grep(ref $_, @$v) )) {
+ my $depth = $#$v;
+ ($shortmore, $depth) = (' ...', $self->{arrayDepth} - 1)
+ if $self->{arrayDepth} and $depth >= $self->{arrayDepth};
+ my @a = map $self->stringify($_), @$v[0..$depth];
+ print "0..$#{$v} @a$shortmore\n";
+ } elsif ($self->{veryCompact} && ref $v
+ && (ref $v eq 'HASH') and !grep(ref $_, values %$v)) {
+ my @a = sort keys %$v;
+ my $depth = $#a;
+ ($shortmore, $depth) = (' ...', $self->{hashDepth} - 1)
+ if $self->{hashDepth} and $depth >= $self->{hashDepth};
+ my @b = map {$self->stringify($_) . " => " . $self->stringify($$v{$_})}
+ @a[0..$depth];
+ local $" = ', ';
+ print "@b$shortmore\n";
+ } else {
+ print "$short\n";
+ $self->unwrap($v,shift);
+ }
+}
+
+sub unwrap {
+ my $self = shift;
+ return if $DB::signal and $self->{stopDbSignal};
+ my ($v) = shift ;
+ my ($s) = shift ; # extra no of spaces
+ my $sp;
+ my (%v, at v,$address,$short,$fileno);
+
+ $sp = " " x $s ;
+ $s += 3 ;
+
+ # Check for reused addresses
+ if (ref $v) {
+ my $val = $v;
+ { no strict 'refs';
+ $val = &{'overload::StrVal'}($v)
+ if %overload:: and defined &{'overload::StrVal'};
+ }
+ ($address) = $val =~ /(0x[0-9a-f]+)\)$/ ;
+ if (!$self->{dumpReused} && defined $address) {
+ $address{$address}++ ;
+ if ( $address{$address} > 1 ) {
+ print "${sp}-> REUSED_ADDRESS\n" ;
+ return ;
+ }
+ }
+ } elsif (ref \$v eq 'GLOB') {
+ $address = "$v" . ""; # To avoid a bug with globs
+ $address{$address}++ ;
+ if ( $address{$address} > 1 ) {
+ print "${sp}*DUMPED_GLOB*\n" ;
+ return ;
+ }
+ }
+
+ if (ref $v eq 'Regexp') {
+ my $re = "$v";
+ $re =~ s,/,\\/,g;
+ print "$sp-> qr/$re/\n";
+ return;
+ }
+
+ if ( UNIVERSAL::isa($v, 'HASH') ) {
+ my @sortKeys = sort keys(%$v) ;
+ my $more;
+ my $tHashDepth = $#sortKeys ;
+ $tHashDepth = $#sortKeys < $self->{hashDepth}-1 ? $#sortKeys : $self->{hashDepth}-1
+ unless $self->{hashDepth} eq '' ;
+ $more = "....\n" if $tHashDepth < $#sortKeys ;
+ my $shortmore = "";
+ $shortmore = ", ..." if $tHashDepth < $#sortKeys ;
+ $#sortKeys = $tHashDepth ;
+ if ($self->{compactDump} && !grep(ref $_, values %{$v})) {
+ $short = $sp;
+ my @keys;
+ for (@sortKeys) {
+ push @keys, $self->stringify($_) . " => " . $self->stringify($v->{$_});
+ }
+ $short .= join ', ', @keys;
+ $short .= $shortmore;
+ (print "$short\n"), return if length $short <= $self->{compactDump};
+ }
+ for my $key (@sortKeys) {
+ return if $DB::signal and $self->{stopDbSignal};
+ my $value = $ {$v}{$key} ;
+ print $sp, $self->stringify($key), " => ";
+ $self->DumpElem($value, $s);
+ }
+ print "$sp empty hash\n" unless @sortKeys;
+ print "$sp$more" if defined $more ;
+ } elsif ( UNIVERSAL::isa($v, 'ARRAY') ) {
+ my $tArrayDepth = $#{$v} ;
+ my $more ;
+ $tArrayDepth = $#$v < $self->{arrayDepth}-1 ? $#$v : $self->{arrayDepth}-1
+ unless $self->{arrayDepth} eq '' ;
+ $more = "....\n" if $tArrayDepth < $#{$v} ;
+ my $shortmore = "";
+ $shortmore = " ..." if $tArrayDepth < $#{$v} ;
+ if ($self->{compactDump} && !grep(ref $_, @{$v})) {
+ if ($#$v >= 0) {
+ $short = $sp . "0..$#{$v} " .
+ join(" ",
+ map {exists $v->[$_] ? $self->stringify($v->[$_]) : "empty"} ($[..$tArrayDepth)
+ ) . "$shortmore";
+ } else {
+ $short = $sp . "empty array";
+ }
+ (print "$short\n"), return if length $short <= $self->{compactDump};
+ }
+ for my $num ($[ .. $tArrayDepth) {
+ return if $DB::signal and $self->{stopDbSignal};
+ print "$sp$num ";
+ if (exists $v->[$num]) {
+ $self->DumpElem($v->[$num], $s);
+ } else {
+ print "empty slot\n";
+ }
+ }
+ print "$sp empty array\n" unless @$v;
+ print "$sp$more" if defined $more ;
+ } elsif ( UNIVERSAL::isa($v, 'SCALAR') or ref $v eq 'REF' ) {
+ print "$sp-> ";
+ $self->DumpElem($$v, $s);
+ } elsif ( UNIVERSAL::isa($v, 'CODE') ) {
+ print "$sp-> ";
+ $self->dumpsub(0, $v);
+ } elsif ( UNIVERSAL::isa($v, 'GLOB') ) {
+ print "$sp-> ",$self->stringify($$v,1),"\n";
+ if ($self->{globPrint}) {
+ $s += 3;
+ $self->dumpglob('', $s, "{$$v}", $$v, 1);
+ } elsif (defined ($fileno = fileno($v))) {
+ print( (' ' x ($s+3)) . "FileHandle({$$v}) => fileno($fileno)\n" );
+ }
+ } elsif (ref \$v eq 'GLOB') {
+ if ($self->{globPrint}) {
+ $self->dumpglob('', $s, "{$v}", $v, 1);
+ } elsif (defined ($fileno = fileno(\$v))) {
+ print( (' ' x $s) . "FileHandle({$v}) => fileno($fileno)\n" );
+ }
+ }
+}
+
+sub matchvar {
+ $_[0] eq $_[1] or
+ ($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and
+ ($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$3/});
+}
+
+sub compactDump {
+ my $self = shift;
+ $self->{compactDump} = shift if @_;
+ $self->{compactDump} = 6*80-1
+ if $self->{compactDump} and $self->{compactDump} < 2;
+ $self->{compactDump};
+}
+
+sub veryCompact {
+ my $self = shift;
+ $self->{veryCompact} = shift if @_;
+ $self->compactDump(1) if !$self->{compactDump} and $self->{veryCompact};
+ $self->{veryCompact};
+}
+
+sub set_unctrl {
+ my $self = shift;
+ if (@_) {
+ my $in = shift;
+ if ($in eq 'unctrl' or $in eq 'quote') {
+ $self->{unctrl} = $in;
+ } else {
+ print "Unknown value for `unctrl'.\n";
+ }
+ }
+ $self->{unctrl};
+}
+
+sub set_quote {
+ my $self = shift;
+ if (@_ and $_[0] eq '"') {
+ $self->{tick} = '"';
+ $self->{unctrl} = 'quote';
+ } elsif (@_ and $_[0] eq 'auto') {
+ $self->{tick} = 'auto';
+ $self->{unctrl} = 'quote';
+ } elsif (@_) { # Need to set
+ $self->{tick} = "'";
+ $self->{unctrl} = 'unctrl';
+ }
+ $self->{tick};
+}
+
+sub dumpglob {
+ my $self = shift;
+ return if $DB::signal and $self->{stopDbSignal};
+ my ($package, $off, $key, $val, $all) = @_;
+ local(*stab) = $val;
+ my $fileno;
+ if (($key !~ /^_</ or $self->{dumpDBFiles}) and defined $stab) {
+ print( (' ' x $off) . "\$", &unctrl($key), " = " );
+ $self->DumpElem($stab, 3+$off);
+ }
+ if (($key !~ /^_</ or $self->{dumpDBFiles}) and @stab) {
+ print( (' ' x $off) . "\@$key = (\n" );
+ $self->unwrap(\@stab,3+$off) ;
+ print( (' ' x $off) . ")\n" );
+ }
+ if ($key ne "main::" && $key ne "DB::" && %stab
+ && ($self->{dumpPackages} or $key !~ /::$/)
+ && ($key !~ /^_</ or $self->{dumpDBFiles})
+ && !($package eq "Dumpvalue" and $key eq "stab")) {
+ print( (' ' x $off) . "\%$key = (\n" );
+ $self->unwrap(\%stab,3+$off) ;
+ print( (' ' x $off) . ")\n" );
+ }
+ if (defined ($fileno = fileno(*stab))) {
+ print( (' ' x $off) . "FileHandle($key) => fileno($fileno)\n" );
+ }
+ if ($all) {
+ if (defined &stab) {
+ $self->dumpsub($off, $key);
+ }
+ }
+}
+
+sub CvGV_name {
+ my $self = shift;
+ my $in = shift;
+ return if $self->{skipCvGV}; # Backdoor to avoid problems if XS broken...
+ $in = \&$in; # Hard reference...
+ eval {require Devel::Peek; 1} or return;
+ my $gv = Devel::Peek::CvGV($in) or return;
+ *$gv{PACKAGE} . '::' . *$gv{NAME};
+}
+
+sub dumpsub {
+ my $self = shift;
+ my ($off,$sub) = @_;
+ my $ini = $sub;
+ my $s;
+ $sub = $1 if $sub =~ /^\{\*(.*)\}$/;
+ my $subref = defined $1 ? \&$sub : \&$ini;
+ my $place = $DB::sub{$sub} || (($s = $subs{"$subref"}) && $DB::sub{$s})
+ || (($s = $self->CvGV_name($subref)) && $DB::sub{$s})
+ || ($self->{subdump} && ($s = $self->findsubs("$subref"))
+ && $DB::sub{$s});
+ $s = $sub unless defined $s;
+ $place = '???' unless defined $place;
+ print( (' ' x $off) . "&$s in $place\n" );
+}
+
+sub findsubs {
+ my $self = shift;
+ return undef unless %DB::sub;
+ my ($addr, $name, $loc);
+ while (($name, $loc) = each %DB::sub) {
+ $addr = \&$name;
+ $subs{"$addr"} = $name;
+ }
+ $self->{subdump} = 0;
+ $subs{ shift() };
+}
+
+sub dumpvars {
+ my $self = shift;
+ my ($package, at vars) = @_;
+ local(%address,$^W);
+ my ($key,$val);
+ $package .= "::" unless $package =~ /::$/;
+ *stab = *main::;
+
+ while ($package =~ /(\w+?::)/g) {
+ *stab = $ {stab}{$1};
+ }
+ $self->{TotalStrings} = 0;
+ $self->{Strings} = 0;
+ $self->{CompleteTotal} = 0;
+ while (($key,$val) = each(%stab)) {
+ return if $DB::signal and $self->{stopDbSignal};
+ next if @vars && !grep( matchvar($key, $_), @vars );
+ if ($self->{usageOnly}) {
+ $self->globUsage(\$val, $key)
+ if ($package ne 'Dumpvalue' or $key ne 'stab')
+ and ref(\$val) eq 'GLOB';
+ } else {
+ $self->dumpglob($package, 0,$key, $val);
+ }
+ }
+ if ($self->{usageOnly}) {
+ print <<EOP;
+String space: $self->{TotalStrings} bytes in $self->{Strings} strings.
+EOP
+ $self->{CompleteTotal} += $self->{TotalStrings};
+ print <<EOP;
+Grand total = $self->{CompleteTotal} bytes (1 level deep) + overhead.
+EOP
+ }
+}
+
+sub scalarUsage {
+ my $self = shift;
+ my $size;
+ if (UNIVERSAL::isa($_[0], 'ARRAY')) {
+ $size = $self->arrayUsage($_[0]);
+ } elsif (UNIVERSAL::isa($_[0], 'HASH')) {
+ $size = $self->hashUsage($_[0]);
+ } elsif (!ref($_[0])) {
+ $size = length($_[0]);
+ }
+ $self->{TotalStrings} += $size;
+ $self->{Strings}++;
+ $size;
+}
+
+sub arrayUsage { # array ref, name
+ my $self = shift;
+ my $size = 0;
+ map {$size += $self->scalarUsage($_)} @{$_[0]};
+ my $len = @{$_[0]};
+ print "\@$_[1] = $len item", ($len > 1 ? "s" : ""), " (data: $size bytes)\n"
+ if defined $_[1];
+ $self->{CompleteTotal} += $size;
+ $size;
+}
+
+sub hashUsage { # hash ref, name
+ my $self = shift;
+ my @keys = keys %{$_[0]};
+ my @values = values %{$_[0]};
+ my $keys = $self->arrayUsage(\@keys);
+ my $values = $self->arrayUsage(\@values);
+ my $len = @keys;
+ my $total = $keys + $values;
+ print "\%$_[1] = $len item", ($len > 1 ? "s" : ""),
+ " (keys: $keys; values: $values; total: $total bytes)\n"
+ if defined $_[1];
+ $total;
+}
+
+sub globUsage { # glob ref, name
+ my $self = shift;
+ local *stab = *{$_[0]};
+ my $total = 0;
+ $total += $self->scalarUsage($stab) if defined $stab;
+ $total += $self->arrayUsage(\@stab, $_[1]) if @stab;
+ $total += $self->hashUsage(\%stab, $_[1])
+ if %stab and $_[1] ne "main::" and $_[1] ne "DB::";
+ #and !($package eq "Dumpvalue" and $key eq "stab"));
+ $total;
+}
+
+1;
+
+=head1 NAME
+
+Dumpvalue - provides screen dump of Perl data.
+
+=head1 SYNOPSIS
+
+ use Dumpvalue;
+ my $dumper = Dumpvalue->new;
+ $dumper->set(globPrint => 1);
+ $dumper->dumpValue(\*::);
+ $dumper->dumpvars('main');
+ my $dump = $dumper->stringify($some_value);
+
+=head1 DESCRIPTION
+
+=head2 Creation
+
+A new dumper is created by a call
+
+ $d = Dumpvalue->new(option1 => value1, option2 => value2)
+
+Recognized options:
+
+=over 4
+
+=item C<arrayDepth>, C<hashDepth>
+
+Print only first N elements of arrays and hashes. If false, prints all the
+elements.
+
+=item C<compactDump>, C<veryCompact>
+
+Change style of array and hash dump. If true, short array
+may be printed on one line.
+
+=item C<globPrint>
+
+Whether to print contents of globs.
+
+=item C<dumpDBFiles>
+
+Dump arrays holding contents of debugged files.
+
+=item C<dumpPackages>
+
+Dump symbol tables of packages.
+
+=item C<dumpReused>
+
+Dump contents of "reused" addresses.
+
+=item C<tick>, C<quoteHighBit>, C<printUndef>
+
+Change style of string dump. Default value of C<tick> is C<auto>, one
+can enable either double-quotish dump, or single-quotish by setting it
+to C<"> or C<'>. By default, characters with high bit set are printed
+I<as is>. If C<quoteHighBit> is set, they will be quoted.
+
+=item C<usageOnly>
+
+rudimentally per-package memory usage dump. If set,
+C<dumpvars> calculates total size of strings in variables in the package.
+
+=item unctrl
+
+Changes the style of printout of strings. Possible values are
+C<unctrl> and C<quote>.
+
+=item subdump
+
+Whether to try to find the subroutine name given the reference.
+
+=item bareStringify
+
+Whether to write the non-overloaded form of the stringify-overloaded objects.
+
+=item quoteHighBit
+
+Whether to print chars with high bit set in binary or "as is".
+
+=item stopDbSignal
+
+Whether to abort printing if debugger signal flag is raised.
+
+=back
+
+Later in the life of the object the methods may be queries with get()
+method and set() method (which accept multiple arguments).
+
+=head2 Methods
+
+=over 4
+
+=item dumpValue
+
+ $dumper->dumpValue($value);
+ $dumper->dumpValue([$value1, $value2]);
+
+Prints a dump to the currently selected filehandle.
+
+=item dumpValues
+
+ $dumper->dumpValues($value1, $value2);
+
+Same as C< $dumper->dumpValue([$value1, $value2]); >.
+
+=item stringify
+
+ my $dump = $dumper->stringify($value [,$noticks] );
+
+Returns the dump of a single scalar without printing. If the second
+argument is true, the return value does not contain enclosing ticks.
+Does not handle data structures.
+
+=item dumpvars
+
+ $dumper->dumpvars('my_package');
+ $dumper->dumpvars('my_package', 'foo', '~bar$', '!......');
+
+The optional arguments are considered as literal strings unless they
+start with C<~> or C<!>, in which case they are interpreted as regular
+expressions (possibly negated).
+
+The second example prints entries with names C<foo>, and also entries
+with names which ends on C<bar>, or are shorter than 5 chars.
+
+=item set_quote
+
+ $d->set_quote('"');
+
+Sets C<tick> and C<unctrl> options to suitable values for printout with the
+given quote char. Possible values are C<auto>, C<'> and C<">.
+
+=item set_unctrl
+
+ $d->set_unctrl('unctrl');
+
+Sets C<unctrl> option with checking for an invalid argument.
+Possible values are C<unctrl> and C<quote>.
+
+=item compactDump
+
+ $d->compactDump(1);
+
+Sets C<compactDump> option. If the value is 1, sets to a reasonable
+big number.
+
+=item veryCompact
+
+ $d->veryCompact(1);
+
+Sets C<compactDump> and C<veryCompact> options simultaneously.
+
+=item set
+
+ $d->set(option1 => value1, option2 => value2);
+
+=item get
+
+ @values = $d->get('option1', 'option2');
+
+=back
+
+=cut
+
Copied: trunk/contrib/perl/lib/Dumpvalue.t (from rev 6437, vendor/perl/5.18.1/lib/Dumpvalue.t)
===================================================================
--- trunk/contrib/perl/lib/Dumpvalue.t (rev 0)
+++ trunk/contrib/perl/lib/Dumpvalue.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,295 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ if (ord('A') == 193) {
+ print "1..0 # skip: EBCDIC\n";
+ exit 0;
+ }
+ require Config;
+ if (($Config::Config{'extensions'} !~ m!\bList/Util\b!) ){
+ print "1..0 # Skip -- Perl configured without List::Util module\n";
+ exit 0;
+ }
+}
+
+use vars qw( $foo @bar %baz );
+
+use Test::More tests => 88;
+
+use_ok( 'Dumpvalue' );
+
+my $d;
+ok( $d = Dumpvalue->new(), 'create a new Dumpvalue object' );
+
+$d->set( globPrint => 1, dumpReused => 1 );
+is( $d->{globPrint}, 1, 'set an option correctly' );
+is( $d->get('globPrint'), 1, 'get an option correctly' );
+is( $d->get('globPrint', 'dumpReused'), qw( 1 1 ), 'get multiple options' );
+
+# check to see if unctrl works
+is( ref( Dumpvalue::unctrl(*FOO) ), 'GLOB', 'unctrl should not modify GLOB' );
+is( Dumpvalue::unctrl('donotchange'), 'donotchange', "unctrl shouldn't modify");
+like( Dumpvalue::unctrl("bo\007nd"), qr/bo\^.nd/, 'unctrl should escape' );
+
+# check to see if stringify works
+is( $d->stringify(), 'undef', 'stringify handles undef okay' );
+
+# the default is 1, but we want two single quotes
+$d->{printUndef} = 0;
+is( $d->stringify(), "''", 'stringify skips undef when asked nicely' );
+
+is( $d->stringify(*FOO), *FOO . "", 'stringify stringifies globs alright' );
+
+# check for double-quotes if there's an unprintable character
+$d->{tick} = 'auto';
+like( $d->stringify("hi\005"), qr/^"hi/, 'added double-quotes when necessary' );
+
+# if no unprintable character, escape ticks or backslashes
+is( $d->stringify('hi'), "'hi'", 'used single-quotes when appropriate' );
+
+# if 'unctrl' is set
+$d->{unctrl} = 'unctrl';
+like( $d->stringify('double and whack:\ "'), qr!\\ \"!, 'escaped with unctrl' );
+like( $d->stringify("a\005"), qr/^"a\^/, 'escaped ASCII value in unctrl' );
+like( $d->stringify("b\205"), qr!^'b.'$!, 'no high-bit escape value in unctrl');
+
+$d->{quoteHighBit} = 1;
+like( $d->stringify("b\205"), qr!^'b\\205!, 'high-bit now escaped in unctrl');
+
+# if 'quote' is set
+$d->{unctrl} = 'quote';
+is( $d->stringify('5@ $1'), "'5\@ \$1'", 'quoted $ and @ fine' );
+is( $d->stringify("5@\033\$1"), '"5\@\e\$1"', 'quoted $ and @ and \033 fine' );
+like( $d->stringify("\037"), qr/^"\\c/, 'escaped ASCII value okay' );
+
+# add ticks, if necessary
+is( $d->stringify("no ticks", 1), 'no ticks', 'avoid ticks if asked' );
+
+my $out = tie *OUT, 'TieOut';
+select(OUT);
+
+# test DumpElem, it does its magic with veryCompact set
+$d->{veryCompact} = 1;
+$d->DumpElem([1, 2, 3]);
+is( $out->read, "0..2 1 2 3\n", 'DumpElem worked on array ref');
+$d->DumpElem({ one => 1, two => 2 });
+is( $out->read, "'one' => 1, 'two' => 2\n", 'DumpElem worked on hash ref' );
+$d->DumpElem('hi');
+is( $out->read, "'hi'\n", 'DumpElem worked on simple scalar' );
+$d->{veryCompact} = 0;
+$d->DumpElem([]);
+like( $out->read, qr/ARRAY/, 'DumpElem okay with reference and no veryCompact');
+
+# should compact simple arrays just fine
+$d->{veryCompact} = 1;
+$d->DumpElem([1, 2, 3]);
+is( $out->read, "0..2 1 2 3\n", 'dumped array fine' );
+$d->{arrayDepth} = 2;
+$d->DumpElem([1, 2, 3]);
+is( $out->read, "0..2 1 2 ...\n", 'dumped limited array fine' );
+
+# should compact simple hashes just fine
+$d->DumpElem({ a => 1, b => 2, c => 3 });
+is( $out->read, "'a' => 1, 'b' => 2, 'c' => 3\n", 'dumped hash fine' );
+$d->{hashDepth} = 2;
+$d->DumpElem({ a => 1, b => 2, c => 3 });
+is( $out->read, "'a' => 1, 'b' => 2 ...\n", 'dumped limited hash fine' );
+
+# should just stringify what it is
+$d->{veryCompact} = 0;
+$d->DumpElem([]);
+like( $out->read, qr/ARRAY.+empty array/s, 'stringified empty array ref' );
+$d->DumpElem({});
+like( $out->read, qr/HASH.+empty hash/s, 'stringified empty hash ref' );
+$d->DumpElem(1);
+is( $out->read, "1\n", 'stringified simple scalar' );
+
+# test unwrap
+$DB::signal = $d->{stopDbSignal} = 1;
+is( $d->unwrap(), undef, 'unwrap returns if DB signal is set' );
+undef $DB::signal;
+
+my $foo = 7;
+$d->{dumpReused} = 0;
+$d->unwrap(\$foo);
+is( $out->read, "-> 7\n", 'unwrap worked on scalar' );
+$d->unwrap(\$foo);
+is( $out->read, "-> REUSED_ADDRESS\n", 'unwrap worked on scalar' );
+$d->unwrap({ one => 1 });
+
+# leaving this at zero may cause some subsequent tests to fail
+# if they reuse an address creating an anonymous variable
+$d->{dumpReused} = 1;
+is( $out->read, "'one' => 1\n", 'unwrap worked on hash' );
+$d->unwrap([ 2, 3 ]);
+is( $out->read, "0 2\n1 3\n", 'unwrap worked on array' );
+$d->unwrap(*FOO);
+is( $out->read, '', 'unwrap ignored glob on first try');
+$d->unwrap(*FOO);
+is( $out->read, "*DUMPED_GLOB*\n", 'unwrap worked on glob');
+$d->unwrap(qr/foo(.+)/);
+is( $out->read, "-> qr/(?-xism:foo(.+))/\n", 'unwrap worked on Regexp' );
+$d->unwrap( sub {} );
+like( $out->read, qr/^-> &CODE/, 'unwrap worked on sub ref' );
+
+# test matchvar
+# test to see if first arg 'eq' second
+ok( Dumpvalue::matchvar(1, 1), 'matchvar matched numbers fine' );
+ok( Dumpvalue::matchvar('hi', 'hi'), 'matchvar matched strings fine' );
+ok( !Dumpvalue::matchvar('hello', 1), 'matchvar caught failed match fine' );
+
+# test compactDump, which doesn't do much
+is( $d->compactDump(3), 3, 'set compactDump to 3' );
+is( $d->compactDump(1), 479, 'compactDump reset to 6*80-1 when less than 2' );
+
+# test veryCompact, which does slightly more, setting compactDump sometimes
+$d->{compactDump} = 0;
+is( $d->veryCompact(1), 1, 'set veryCompact successfully' );
+ok( $d->compactDump(), 'and it set compactDump as well' );
+
+# test set_unctrl
+$d->set_unctrl('impossible value');
+like( $out->read, qr/^Unknown value/, 'set_unctrl caught bad value' );
+is( $d->set_unctrl('quote'), 'quote', 'set quote fine' );
+is( $d->set_unctrl(), 'quote', 'retrieved quote fine' );
+
+# test set_quote
+$d->set_quote('"');
+is( $d->{tick}, '"', 'set_quote set tick right' );
+is( $d->{unctrl}, 'quote', 'set unctrl right too' );
+$d->set_quote('auto');
+is( $d->{tick}, 'auto', 'set_quote set auto right' );
+$d->set_quote('foo');
+is( $d->{tick}, "'", 'default value set to " correctly' );
+
+# test dumpglob
+# should do nothing if debugger signal flag is raised
+$d->{stopDbSignal} = $DB::signal = 1;
+is( $d->dumpglob(*DB::signal), undef, 'returned early with DB signal set' );
+undef $DB::signal;
+
+# test dumping "normal" variables, this is a nasty glob trick
+$foo = 1;
+$d->dumpglob( '', 2, 'foo', local *foo = \$foo );
+is( $out->read, " \$foo = 1\n", 'dumped glob for $foo correctly' );
+ at bar = (1, 2);
+
+# the key name is a little different here
+$d->dumpglob( '', 0, 'boo', *bar );
+is( $out->read, "\@boo = (\n 0..1 1 2\n)\n", 'dumped glob for @bar fine' );
+
+%baz = ( one => 1, two => 2 );
+$d->dumpglob( '', 0, 'baz', *baz );
+is( $out->read, "\%baz = (\n 'one' => 1, 'two' => 2\n)\n",
+ 'dumped glob for %baz fine' );
+
+SKIP: {
+ skip( "Couldn't open $0 for reading", 1 ) unless open(FILE, $0);
+ my $fileno = fileno(FILE);
+ $d->dumpglob( '', 0, 'FILE', *FILE );
+ is( $out->read, "FileHandle(FILE) => fileno($fileno)\n",
+ 'dumped filehandle from glob fine' );
+}
+
+$d->dumpglob( '', 0, 'read', *TieOut::read );
+is( $out->read, '', 'no sub dumped without $all set' );
+$d->dumpglob( '', 0, 'read', \&TieOut::read, 1 );
+is( $out->read, "&read in ???\n", 'sub dumped when requested' );
+
+# see if it dumps DB-like values correctly
+$d->{dumpDBFiles} = 1;
+$d->dumpglob( '', 0, '_<foo', *foo );
+is( $out->read, "\$_<foo = 1\n", 'dumped glob for $_<foo correctly (DB)' );
+
+# test CvGV name
+SKIP: {
+ if (" $Config::Config{'extensions'} " !~ m[ Devel/Peek ]) {
+ skip( 'no Devel::Peek', 2 );
+ }
+ use_ok( 'Devel::Peek' );
+ is( $d->CvGV_name(\&TieOut::read), 'TieOut::read', 'CvGV_name found sub' );
+}
+
+# test dumpsub
+$d->dumpsub( '', 'TieOut::read' );
+like( $out->read, qr/&TieOut::read in/, 'dumpsub found sub fine' );
+
+# test findsubs
+is( $d->findsubs(), undef, 'findsubs returns nothing without %DB::sub' );
+$DB::sub{'TieOut::read'} = 'TieOut';
+is( $d->findsubs( \&TieOut::read ), 'TieOut::read', 'findsubs reported sub' );
+
+# now that it's capable of finding the package...
+$d->dumpsub( '', 'TieOut::read' );
+is( $out->read, "&TieOut::read in TieOut\n", 'dumpsub found sub fine again' );
+
+# this should print just a usage message
+$d->{usageOnly} = 1;
+$d->dumpvars( 'Fake', 'veryfake' );
+like( $out->read, qr/^String space:/, 'printed usage message fine' );
+delete $d->{usageOnly};
+
+# this should report @INC and %INC
+$d->dumpvars( 'main', 'INC' );
+like( $out->read, qr/\@INC =/, 'dumped variables from a package' );
+
+# this should report nothing
+$DB::signal = 1;
+$d->dumpvars( 'main', 'INC' );
+is( $out->read, '', 'no dump when $DB::signal is set' );
+undef $DB::signal;
+
+is( $d->scalarUsage('12345'), 5, 'scalarUsage reports length correctly' );
+is( $d->arrayUsage( [1, 2, 3], 'a' ), 3, 'arrayUsage reports correct lengths' );
+is( $out->read, "\@a = 3 items (data: 3 bytes)\n", 'arrayUsage message okay' );
+is( $d->hashUsage({ one => 1 }, 'b'), 4, 'hashUsage reports correct lengths' );
+is( $out->read, "\%b = 1 item (keys: 3; values: 1; total: 4 bytes)\n",
+ 'hashUsage message okay' );
+is( $d->hashUsage({ one => [ 1, 2, 3 ]}, 'c'), 6, 'complex hash okay' );
+is( $out->read, "\%c = 1 item (keys: 3; values: 3; total: 6 bytes)\n",
+ 'hashUsage complex message okay' );
+
+$foo = 'one';
+ at foo = ('two');
+%foo = ( three => '123' );
+is( $d->globUsage(\*foo, 'foo'), 14, 'globUsage reports length correctly' );
+like( $out->read, qr/\@foo =.+\%foo =/s, 'globValue message okay' );
+
+# and now, the real show
+$d->dumpValue(undef);
+is( $out->read, "undef\n", 'dumpValue caught undef value okay' );
+$d->dumpValue($foo);
+is( $out->read, "'one'\n", 'dumpValue worked' );
+$d->dumpValue(@foo);
+is( $out->read, "'two'\n", 'dumpValue worked on array' );
+$d->dumpValue(\$foo);
+is( $out->read, "-> 'one'\n", 'dumpValue worked on scalar ref' );
+
+# dumpValues (the rest of these should be caught by unwrap)
+$d->dumpValues(undef);
+is( $out->read, "undef\n", 'dumpValues caught undef value fine' );
+$d->dumpValues(\@foo);
+is( $out->read, "0 0..0 'two'\n", 'dumpValues worked on array ref' );
+$d->dumpValues('one', 'two');
+is( $out->read, "0..1 'one' 'two'\n", 'dumpValues worked on multiple values' );
+
+
+package TieOut;
+use overload '"' => sub { "overloaded!" };
+
+sub TIEHANDLE {
+ my $class = shift;
+ bless(\( my $ref), $class);
+}
+
+sub PRINT {
+ my $self = shift;
+ $$self .= join('', @_);
+}
+
+sub read {
+ my $self = shift;
+ return substr($$self, 0, length($$self), '');
+}
Modified: trunk/contrib/perl/lib/English.pm
===================================================================
--- trunk/contrib/perl/lib/English.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/English.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,6 +1,6 @@
package English;
-our $VERSION = '1.04';
+our $VERSION = '1.06';
require Exporter;
@ISA = qw(Exporter);
@@ -11,8 +11,9 @@
=head1 SYNOPSIS
+ use English;
use English qw( -no_match_vars ) ; # Avoids regex performance penalty
- use English;
+ # in perl 5.16 and earlier
...
if ($ERRNO =~ /denied/) { ... }
@@ -32,6 +33,10 @@
=head1 PERFORMANCE
+NOTE: This was fixed in perl 5.18. Mentioning these three variables no
+longer makes a speed difference. This section still applies if your code
+is to run on perl 5.16 or earlier.
+
This module can provoke sizeable inefficiencies for regular expressions,
due to unfortunate implementation details. If performance matters in
your application and you don't need $PREMATCH, $MATCH, or $POSTMATCH,
@@ -139,7 +144,7 @@
@COMPLETE_EXPORT = ( @MINIMAL_EXPORT, @MATCH_EXPORT ) ;
-# The ground of all being. @ARG is deprecated (5.005 makes @_ lexical)
+# The ground of all being.
*ARG = *_ ;
Property changes on: trunk/contrib/perl/lib/English.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/English.t
===================================================================
--- trunk/contrib/perl/lib/English.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/English.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/English.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Copied: trunk/contrib/perl/lib/Env.pm (from rev 6437, vendor/perl/5.18.1/lib/Env.pm)
===================================================================
--- trunk/contrib/perl/lib/Env.pm (rev 0)
+++ trunk/contrib/perl/lib/Env.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,235 @@
+package Env;
+
+our $VERSION = '1.00';
+
+=head1 NAME
+
+Env - perl module that imports environment variables as scalars or arrays
+
+=head1 SYNOPSIS
+
+ use Env;
+ use Env qw(PATH HOME TERM);
+ use Env qw($SHELL @LD_LIBRARY_PATH);
+
+=head1 DESCRIPTION
+
+Perl maintains environment variables in a special hash named C<%ENV>. For
+when this access method is inconvenient, the Perl module C<Env> allows
+environment variables to be treated as scalar or array variables.
+
+The C<Env::import()> function ties environment variables with suitable
+names to global Perl variables with the same names. By default it
+ties all existing environment variables (C<keys %ENV>) to scalars. If
+the C<import> function receives arguments, it takes them to be a list of
+variables to tie; it's okay if they don't yet exist. The scalar type
+prefix '$' is inferred for any element of this list not prefixed by '$'
+or '@'. Arrays are implemented in terms of C<split> and C<join>, using
+C<$Config::Config{path_sep}> as the delimiter.
+
+After an environment variable is tied, merely use it like a normal variable.
+You may access its value
+
+ @path = split(/:/, $PATH);
+ print join("\n", @LD_LIBRARY_PATH), "\n";
+
+or modify it
+
+ $PATH .= ":.";
+ push @LD_LIBRARY_PATH, $dir;
+
+however you'd like. Bear in mind, however, that each access to a tied array
+variable requires splitting the environment variable's string anew.
+
+The code:
+
+ use Env qw(@PATH);
+ push @PATH, '.';
+
+is equivalent to:
+
+ use Env qw(PATH);
+ $PATH .= ":.";
+
+except that if C<$ENV{PATH}> started out empty, the second approach leaves
+it with the (odd) value "C<:.>", but the first approach leaves it with "C<.>".
+
+To remove a tied environment variable from
+the environment, assign it the undefined value
+
+ undef $PATH;
+ undef @LD_LIBRARY_PATH;
+
+=head1 LIMITATIONS
+
+On VMS systems, arrays tied to environment variables are read-only. Attempting
+to change anything will cause a warning.
+
+=head1 AUTHOR
+
+Chip Salzenberg E<lt>F<chip at fin.uucp>E<gt>
+and
+Gregor N. Purdy E<lt>F<gregor at focusresearch.com>E<gt>
+
+=cut
+
+sub import {
+ my ($callpack) = caller(0);
+ my $pack = shift;
+ my @vars = grep /^[\$\@]?[A-Za-z_]\w*$/, (@_ ? @_ : keys(%ENV));
+ return unless @vars;
+
+ @vars = map { m/^[\$\@]/ ? $_ : '$'.$_ } @vars;
+
+ eval "package $callpack; use vars qw(" . join(' ', @vars) . ")";
+ die $@ if $@;
+ foreach (@vars) {
+ my ($type, $name) = m/^([\$\@])(.*)$/;
+ if ($type eq '$') {
+ tie ${"${callpack}::$name"}, Env, $name;
+ } else {
+ if ($^O eq 'VMS') {
+ tie @{"${callpack}::$name"}, Env::Array::VMS, $name;
+ } else {
+ tie @{"${callpack}::$name"}, Env::Array, $name;
+ }
+ }
+ }
+}
+
+sub TIESCALAR {
+ bless \($_[1]);
+}
+
+sub FETCH {
+ my ($self) = @_;
+ $ENV{$$self};
+}
+
+sub STORE {
+ my ($self, $value) = @_;
+ if (defined($value)) {
+ $ENV{$$self} = $value;
+ } else {
+ delete $ENV{$$self};
+ }
+}
+
+######################################################################
+
+package Env::Array;
+
+use Config;
+use Tie::Array;
+
+ at ISA = qw(Tie::Array);
+
+my $sep = $Config::Config{path_sep};
+
+sub TIEARRAY {
+ bless \($_[1]);
+}
+
+sub FETCHSIZE {
+ my ($self) = @_;
+ my @temp = split($sep, $ENV{$$self});
+ return scalar(@temp);
+}
+
+sub STORESIZE {
+ my ($self, $size) = @_;
+ my @temp = split($sep, $ENV{$$self});
+ $#temp = $size - 1;
+ $ENV{$$self} = join($sep, @temp);
+}
+
+sub CLEAR {
+ my ($self) = @_;
+ $ENV{$$self} = '';
+}
+
+sub FETCH {
+ my ($self, $index) = @_;
+ return (split($sep, $ENV{$$self}))[$index];
+}
+
+sub STORE {
+ my ($self, $index, $value) = @_;
+ my @temp = split($sep, $ENV{$$self});
+ $temp[$index] = $value;
+ $ENV{$$self} = join($sep, @temp);
+ return $value;
+}
+
+sub PUSH {
+ my $self = shift;
+ my @temp = split($sep, $ENV{$$self});
+ push @temp, @_;
+ $ENV{$$self} = join($sep, @temp);
+ return scalar(@temp);
+}
+
+sub POP {
+ my ($self) = @_;
+ my @temp = split($sep, $ENV{$$self});
+ my $result = pop @temp;
+ $ENV{$$self} = join($sep, @temp);
+ return $result;
+}
+
+sub UNSHIFT {
+ my $self = shift;
+ my @temp = split($sep, $ENV{$$self});
+ my $result = unshift @temp, @_;
+ $ENV{$$self} = join($sep, @temp);
+ return $result;
+}
+
+sub SHIFT {
+ my ($self) = @_;
+ my @temp = split($sep, $ENV{$$self});
+ my $result = shift @temp;
+ $ENV{$$self} = join($sep, @temp);
+ return $result;
+}
+
+sub SPLICE {
+ my $self = shift;
+ my $offset = shift;
+ my $length = shift;
+ my @temp = split($sep, $ENV{$$self});
+ if (wantarray) {
+ my @result = splice @temp, $self, $offset, $length, @_;
+ $ENV{$$self} = join($sep, @temp);
+ return @result;
+ } else {
+ my $result = scalar splice @temp, $offset, $length, @_;
+ $ENV{$$self} = join($sep, @temp);
+ return $result;
+ }
+}
+
+######################################################################
+
+package Env::Array::VMS;
+use Tie::Array;
+
+ at ISA = qw(Tie::Array);
+
+sub TIEARRAY {
+ bless \($_[1]);
+}
+
+sub FETCHSIZE {
+ my ($self) = @_;
+ my $i = 0;
+ while ($i < 127 and defined $ENV{$$self . ';' . $i}) { $i++; };
+ return $i;
+}
+
+sub FETCH {
+ my ($self, $index) = @_;
+ return $ENV{$$self . ';' . $index};
+}
+
+1;
Index: trunk/contrib/perl/lib/Exporter/Heavy.pm
===================================================================
--- trunk/contrib/perl/lib/Exporter/Heavy.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Exporter/Heavy.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Exporter/Heavy.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/Exporter.pm
===================================================================
--- trunk/contrib/perl/lib/Exporter.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Exporter.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -9,7 +9,7 @@
our $Debug = 0;
our $ExportLevel = 0;
our $Verbose ||= 0;
-our $VERSION = '5.64_03';
+our $VERSION = '5.68';
our (%Cache);
sub as_heavy {
@@ -44,7 +44,6 @@
my $export_cache = ($Cache{$pkg} ||= {});
my $args = @_ or @_ = @$exports;
- local $_;
if ($args and not %$export_cache) {
s/^&//, $export_cache->{$_} = 1
foreach (@$exports, @{"$pkg\::EXPORT_OK"});
@@ -127,14 +126,14 @@
=head1 DESCRIPTION
The Exporter module implements an C<import> method which allows a module
-to export functions and variables to its users' namespaces. Many modules
+to export functions and variables to its users' namespaces. Many modules
use Exporter rather than implementing their own C<import> method because
Exporter provides a highly flexible interface, with an implementation optimised
for the common case.
Perl automatically calls the C<import> method when processing a
-C<use> statement for a module. Modules and C<use> are documented
-in L<perlfunc> and L<perlmod>. Understanding the concept of
+C<use> statement for a module. Modules and C<use> are documented
+in L<perlfunc> and L<perlmod>. Understanding the concept of
modules and how the C<use> statement operates is important to
understanding the Exporter.
@@ -153,7 +152,7 @@
If you are only exporting function names it is recommended to omit the
ampersand, as the implementation is faster this way.
-=head2 Selecting What To Export
+=head2 Selecting What to Export
Do B<not> export method names!
@@ -178,8 +177,8 @@
how to make inheritance work.)
As a general rule, if the module is trying to be object oriented
-then export nothing. If it's just a collection of functions then
-C<@EXPORT_OK> anything but use C<@EXPORT> with caution. For function and
+then export nothing. If it's just a collection of functions then
+C<@EXPORT_OK> anything but use C<@EXPORT> with caution. For function and
method names use barewords in preference to names prefixed with
ampersands for the export lists.
@@ -205,7 +204,7 @@
This imports only the symbols listed by the caller into their namespace.
All listed symbols must be in your C<@EXPORT> or C<@EXPORT_OK>, else an error
-occurs. The advanced export features of Exporter are accessed like this,
+occurs. The advanced export features of Exporter are accessed like this,
but with list entries that are syntactically distinct from symbol names.
=back
@@ -213,13 +212,13 @@
Unless you want to use its advanced features, this is probably all you
need to know to use Exporter.
-=head1 Advanced features
+=head1 Advanced Features
=head2 Specialised Import Lists
If any of the entries in an import list begins with !, : or / then
the list is treated as a series of specifications which either add to
-or delete from the list of names to import. They are processed left to
+or delete from the list of names to import. They are processed left to
right. Specifications are in the form:
[!]name This name only
@@ -229,7 +228,7 @@
A leading ! indicates that matching names should be deleted from the
list of names to import. If the first specification is a deletion it
-is treated as though preceded by :DEFAULT. If you just want to import
+is treated as though preceded by :DEFAULT. If you just want to import
extra names in addition to the default set you will still need to
include :DEFAULT explicitly.
@@ -239,9 +238,10 @@
@EXPORT_OK = qw(B1 B2 B3 B4 B5);
%EXPORT_TAGS = (T1 => [qw(A1 A2 B1 B2)], T2 => [qw(A1 A2 B3 B4)]);
- Note that you cannot use tags in @EXPORT or @EXPORT_OK.
- Names in EXPORT_TAGS must also appear in @EXPORT or @EXPORT_OK.
+Note that you cannot use tags in @EXPORT or @EXPORT_OK.
+Names in EXPORT_TAGS must also appear in @EXPORT or @EXPORT_OK.
+
An application using Module can say something like:
use Module qw(:DEFAULT :T2 !B3 A3);
@@ -258,13 +258,16 @@
specifications are being processed and what is actually being imported
into modules.
-=head2 Exporting without using Exporter's import method
+=head2 Exporting Without Using Exporter's import Method
Exporter has a special method, 'export_to_level' which is used in situations
-where you can't directly call Exporter's import method. The export_to_level
+where you can't directly call Exporter's
+import method. The export_to_level
method looks like:
- MyPackage->export_to_level($where_to_export, $package, @what_to_export);
+ MyPackage->export_to_level(
+ $where_to_export, $package, @what_to_export
+ );
where C<$where_to_export> is an integer telling how far up the calling stack
to export your symbols, and C<@what_to_export> is an array telling what
@@ -285,7 +288,7 @@
}
and you want to Export symbol C<$A::b> back to the module that called
-package A. Since Exporter relies on the import method to work, via
+package A. Since Exporter relies on the import method to work, via
inheritance, as it stands Exporter::import() will never get called.
Instead, say the following:
@@ -305,11 +308,11 @@
Note: Be careful not to modify C<@_> at all before you call export_to_level
- or people using your package will get very unexplained results!
-=head2 Exporting without inheriting from Exporter
+=head2 Exporting Without Inheriting from Exporter
By including Exporter in your C<@ISA> you inherit an Exporter's import() method
but you also inherit several other helper methods which you probably don't
-want. To avoid this you can do
+want. To avoid this you can do
package YourModule;
use Exporter qw( import );
@@ -324,22 +327,23 @@
=head2 Module Version Checking
The Exporter module will convert an attempt to import a number from a
-module into a call to C<< $module_name->require_version($value) >>. This can
+module into a call to C<< $module_name->VERSION($value) >>. This can
be used to validate that the version of the module being used is
greater than or equal to the required version.
-The Exporter module supplies a default C<require_version> method which
-checks the value of C<$VERSION> in the exporting module.
+For historical reasons, Exporter supplies a C<require_version> method that
+simply delegates to C<VERSION>. Originally, before C<UNIVERSAL::VERSION>
+existed, Exporter would call C<require_version>.
-Since the default C<require_version> method treats the C<$VERSION> number as
+Since the C<UNIVERSAL::VERSION> method treats the C<$VERSION> number as
a simple numeric value it will regard version 1.10 as lower than
-1.9. For this reason it is strongly recommended that you use numbers
+1.9. For this reason it is strongly recommended that you use numbers
with at least two decimal places, e.g., 1.09.
=head2 Managing Unknown Symbols
In some situations you may want to prevent certain symbols from being
-exported. Typically this applies to extensions which have functions
+exported. Typically this applies to extensions which have functions
or constants that may not exist on some systems.
The names of any symbols that cannot be exported should be listed
@@ -347,15 +351,15 @@
If a module attempts to import any of these symbols the Exporter
will give the module an opportunity to handle the situation before
-generating an error. The Exporter will call an export_fail method
+generating an error. The Exporter will call an export_fail method
with a list of the failed symbols:
@failed_symbols = $module_name->export_fail(@failed_symbols);
If the C<export_fail> method returns an empty list then no error is
-recorded and all the requested symbols are exported. If the returned
+recorded and all the requested symbols are exported. If the returned
list is not empty then an error is generated for each symbol and the
-export fails. The Exporter provides a default C<export_fail> method which
+export fails. The Exporter provides a default C<export_fail> method which
simply returns the list unchanged.
Uses for the C<export_fail> method include giving better error messages
@@ -377,10 +381,10 @@
Any names which are not tags are added to C<@EXPORT> or C<@EXPORT_OK>
unchanged but will trigger a warning (with C<-w>) to avoid misspelt tags
-names being silently added to C<@EXPORT> or C<@EXPORT_OK>. Future versions
+names being silently added to C<@EXPORT> or C<@EXPORT_OK>. Future versions
may make this a fatal error.
-=head2 Generating combined tags
+=head2 Generating Combined Tags
If several symbol categories exist in C<%EXPORT_TAGS>, it's usually
useful to create the utility ":all" to simplify "use" statements.
@@ -423,7 +427,7 @@
they can't be checked at compile time for constancy.
Even if a prototype is available at compile time, the body of the
-subroutine is not (it hasn't been C<AUTOLOAD>ed yet). perl needs to
+subroutine is not (it hasn't been C<AUTOLOAD>ed yet). perl needs to
examine both the C<()> prototype and the body of a subroutine at
compile time to detect that it can safely replace calls to that
subroutine with the constant value.
@@ -434,9 +438,9 @@
use Socket ;
- foo( SO_LINGER ); ## SO_LINGER NOT optimized away; called at runtime
+ foo( SO_LINGER ); ## SO_LINGER NOT optimized away; called at runtime
BEGIN { SO_LINGER }
- foo( SO_LINGER ); ## SO_LINGER optimized away at compile time.
+ foo( SO_LINGER ); ## SO_LINGER optimized away at compile time.
This forces the C<AUTOLOAD> for C<SO_LINGER> to take place before
SO_LINGER is encountered later in C<My> package.
@@ -473,7 +477,7 @@
constructions are executed.
The ideal (but a bit ugly) way to never have to think
-about that is to use C<BEGIN> blocks. So the first part
+about that is to use C<BEGIN> blocks. So the first part
of the L</SYNOPSIS> code could be rewritten as:
package YourModule;
@@ -502,7 +506,7 @@
Any of these statements are nice replacements for
C<BEGIN { require Exporter; @ISA = qw(Exporter); }>
-with the same compile-time effect. The basic difference
+with the same compile-time effect. The basic difference
is that C<base> code interacts with declared C<fields>
while C<parent> is a streamlined version of the older
C<base> code to just establish the IS-A relationship.
@@ -510,8 +514,8 @@
For more details, see the documentation and code of
L<base> and L<parent>.
-Another thorough remedy to that runtime vs.
-compile-time trap is to use L<Exporter::Easy>,
+Another thorough remedy to that runtime
+vs. compile-time trap is to use L<Exporter::Easy>,
which is a wrapper of Exporter that allows all
boilerplate code at a single gulp in the
use statement.
@@ -522,9 +526,9 @@
# @ISA setup is automatic
# all assignments happen at compile time
-=head2 What not to Export
+=head2 What Not to Export
-You have been warned already in L</Selecting What To Export>
+You have been warned already in L</Selecting What to Export>
to not export:
=over 4
@@ -545,16 +549,16 @@
=back
-There's one more item to add to this list. Do B<not>
-export variable names. Just because C<Exporter> lets you
+There's one more item to add to this list. Do B<not>
+export variable names. Just because C<Exporter> lets you
do that, it does not mean you should.
@EXPORT_OK = qw( $svar @avar %hvar ); # DON'T!
-Exporting variables is not a good idea. They can
+Exporting variables is not a good idea. They can
change under the hood, provoking horrible
effects at-a-distance, that are too hard to track
-and to fix. Trust me: they are not worth it.
+and to fix. Trust me: they are not worth it.
To provide the capability to set/get class-wide
settings, it is best instead to provide accessors
@@ -563,10 +567,10 @@
=head1 SEE ALSO
C<Exporter> is definitely not the only module with
-symbol exporter capabilities. At CPAN, you may find
-a bunch of them. Some are lighter. Some
-provide improved APIs and features. Peek the one
-that fits your needs. The following is
+symbol exporter capabilities. At CPAN, you may find
+a bunch of them. Some are lighter. Some
+provide improved APIs and features. Peek the one
+that fits your needs. The following is
a sample list of such modules.
Exporter::Easy
@@ -578,7 +582,7 @@
=head1 LICENSE
-This library is free software. You can redistribute it
+This library is free software. You can redistribute it
and/or modify it under the same terms as Perl itself.
=cut
Property changes on: trunk/contrib/perl/lib/Exporter.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/Exporter.t
===================================================================
--- trunk/contrib/perl/lib/Exporter.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Exporter.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -25,7 +25,7 @@
BEGIN {
$test = 1;
- print "1..30\n";
+ print "1..31\n";
require Exporter;
ok( 1, 'Exporter compiled' );
}
@@ -233,3 +233,20 @@
::ok($Carp::Internal{Exporter}, "Carp recognizes Exporter");
::ok($Carp::Internal{'Exporter::Heavy'}, "Carp recognizes Exporter::Heavy");
+package Exporter::for::Tied::_;
+
+ at ISA = 'Exporter';
+ at EXPORT = 'foo';
+
+package Tied::_;
+
+sub TIESCALAR{bless[]}
+# no tie methods!
+
+{
+ tie my $t, __PACKAGE__;
+ for($t) { # $_ is now tied
+ import Exporter::for::Tied::_;
+ }
+}
+::ok(1, 'import with tied $_');
Property changes on: trunk/contrib/perl/lib/Exporter.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Copied: trunk/contrib/perl/lib/ExtUtils/CBuilder.pm (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/CBuilder.pm)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/CBuilder.pm (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/CBuilder.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,322 @@
+package ExtUtils::CBuilder;
+
+use File::Spec ();
+use File::Path ();
+use File::Basename ();
+
+use vars qw($VERSION @ISA);
+$VERSION = '0.2602';
+$VERSION = eval $VERSION;
+
+# Okay, this is the brute-force method of finding out what kind of
+# platform we're on. I don't know of a systematic way. These values
+# came from the latest (bleadperl) perlport.pod.
+
+my %OSTYPES = qw(
+ aix Unix
+ bsdos Unix
+ dgux Unix
+ dynixptx Unix
+ freebsd Unix
+ linux Unix
+ hpux Unix
+ irix Unix
+ darwin Unix
+ machten Unix
+ next Unix
+ openbsd Unix
+ netbsd Unix
+ dec_osf Unix
+ svr4 Unix
+ svr5 Unix
+ sco_sv Unix
+ unicos Unix
+ unicosmk Unix
+ solaris Unix
+ sunos Unix
+ cygwin Unix
+ os2 Unix
+ gnu Unix
+ gnukfreebsd Unix
+ haiku Unix
+
+ dos Windows
+ MSWin32 Windows
+
+ os390 EBCDIC
+ os400 EBCDIC
+ posix-bc EBCDIC
+ vmesa EBCDIC
+
+ MacOS MacOS
+ VMS VMS
+ VOS VOS
+ riscos RiscOS
+ amigaos Amiga
+ mpeix MPEiX
+ );
+
+# We only use this once - don't waste a symbol table entry on it.
+# More importantly, don't make it an inheritable method.
+my $load = sub {
+ my $mod = shift;
+ eval "use $mod";
+ die $@ if $@;
+ @ISA = ($mod);
+};
+
+{
+ my @package = split /::/, __PACKAGE__;
+
+ if (grep {-e File::Spec->catfile($_, @package, 'Platform', $^O) . '.pm'} @INC) {
+ $load->(__PACKAGE__ . "::Platform::$^O");
+
+ } elsif (exists $OSTYPES{$^O} and
+ grep {-e File::Spec->catfile($_, @package, 'Platform', $OSTYPES{$^O}) . '.pm'} @INC) {
+ $load->(__PACKAGE__ . "::Platform::$OSTYPES{$^O}");
+
+ } else {
+ $load->(__PACKAGE__ . "::Base");
+ }
+}
+
+sub os_type { $OSTYPES{$^O} }
+
+1;
+__END__
+
+=head1 NAME
+
+ExtUtils::CBuilder - Compile and link C code for Perl modules
+
+=head1 SYNOPSIS
+
+ use ExtUtils::CBuilder;
+
+ my $b = ExtUtils::CBuilder->new(%options);
+ $obj_file = $b->compile(source => 'MyModule.c');
+ $lib_file = $b->link(objects => $obj_file);
+
+=head1 DESCRIPTION
+
+This module can build the C portions of Perl modules by invoking the
+appropriate compilers and linkers in a cross-platform manner. It was
+motivated by the C<Module::Build> project, but may be useful for other
+purposes as well. However, it is I<not> intended as a general
+cross-platform interface to all your C building needs. That would
+have been a much more ambitious goal!
+
+=head1 METHODS
+
+=over 4
+
+=item new
+
+Returns a new C<ExtUtils::CBuilder> object. A C<config> parameter
+lets you override C<Config.pm> settings for all operations performed
+by the object, as in the following example:
+
+ # Use a different compiler than Config.pm says
+ my $b = ExtUtils::CBuilder->new( config =>
+ { ld => 'gcc' } );
+
+A C<quiet> parameter tells C<CBuilder> to not print its C<system()>
+commands before executing them:
+
+ # Be quieter than normal
+ my $b = ExtUtils::CBuilder->new( quiet => 1 );
+
+=item have_compiler
+
+Returns true if the current system has a working C compiler and
+linker, false otherwise. To determine this, we actually compile and
+link a sample C library. The sample will be compiled in the system
+tempdir or, if that fails for some reason, in the current directory.
+
+=item compile
+
+Compiles a C source file and produces an object file. The name of the
+object file is returned. The source file is specified in a C<source>
+parameter, which is required; the other parameters listed below are
+optional.
+
+=over 4
+
+=item C<object_file>
+
+Specifies the name of the output file to create. Otherwise the
+C<object_file()> method will be consulted, passing it the name of the
+C<source> file.
+
+=item C<include_dirs>
+
+Specifies any additional directories in which to search for header
+files. May be given as a string indicating a single directory, or as
+a list reference indicating multiple directories.
+
+=item C<extra_compiler_flags>
+
+Specifies any additional arguments to pass to the compiler. Should be
+given as a list reference containing the arguments individually, or if
+this is not possible, as a string containing all the arguments
+together.
+
+=back
+
+The operation of this method is also affected by the
+C<archlibexp>, C<cccdlflags>, C<ccflags>, C<optimize>, and C<cc>
+entries in C<Config.pm>.
+
+=item link
+
+Invokes the linker to produce a library file from object files. In
+scalar context, the name of the library file is returned. In list
+context, the library file and any temporary files created are
+returned. A required C<objects> parameter contains the name of the
+object files to process, either in a string (for one object file) or
+list reference (for one or more files). The following parameters are
+optional:
+
+
+=over 4
+
+=item lib_file
+
+Specifies the name of the output library file to create. Otherwise
+the C<lib_file()> method will be consulted, passing it the name of
+the first entry in C<objects>.
+
+=item module_name
+
+Specifies the name of the Perl module that will be created by linking.
+On platforms that need to do prelinking (Win32, OS/2, etc.) this is a
+required parameter.
+
+=item extra_linker_flags
+
+Any additional flags you wish to pass to the linker.
+
+=back
+
+On platforms where C<need_prelink()> returns true, C<prelink()>
+will be called automatically.
+
+The operation of this method is also affected by the C<lddlflags>,
+C<shrpenv>, and C<ld> entries in C<Config.pm>.
+
+=item link_executable
+
+Invokes the linker to produce an executable file from object files. In
+scalar context, the name of the executable file is returned. In list
+context, the executable file and any temporary files created are
+returned. A required C<objects> parameter contains the name of the
+object files to process, either in a string (for one object file) or
+list reference (for one or more files). The optional parameters are
+the same as C<link> with exception for
+
+
+=over 4
+
+=item exe_file
+
+Specifies the name of the output executable file to create. Otherwise
+the C<exe_file()> method will be consulted, passing it the name of the
+first entry in C<objects>.
+
+=back
+
+=item object_file
+
+ my $object_file = $b->object_file($source_file);
+
+Converts the name of a C source file to the most natural name of an
+output object file to create from it. For instance, on Unix the
+source file F<foo.c> would result in the object file F<foo.o>.
+
+=item lib_file
+
+ my $lib_file = $b->lib_file($object_file);
+
+Converts the name of an object file to the most natural name of a
+output library file to create from it. For instance, on Mac OS X the
+object file F<foo.o> would result in the library file F<foo.bundle>.
+
+=item exe_file
+
+ my $exe_file = $b->exe_file($object_file);
+
+Converts the name of an object file to the most natural name of an
+executable file to create from it. For instance, on Mac OS X the
+object file F<foo.o> would result in the executable file F<foo>, and
+on Windows it would result in F<foo.exe>.
+
+
+=item prelink
+
+On certain platforms like Win32, OS/2, VMS, and AIX, it is necessary
+to perform some actions before invoking the linker. The
+C<ExtUtils::Mksymlists> module does this, writing files used by the
+linker during the creation of shared libraries for dynamic extensions.
+The names of any files written will be returned as a list.
+
+Several parameters correspond to C<ExtUtils::Mksymlists::Mksymlists()>
+options, as follows:
+
+ Mksymlists() prelink() type
+ -------------|-------------------|-------------------
+ NAME | dl_name | string (required)
+ DLBASE | dl_base | string
+ FILE | dl_file | string
+ DL_VARS | dl_vars | array reference
+ DL_FUNCS | dl_funcs | hash reference
+ FUNCLIST | dl_func_list | array reference
+ IMPORTS | dl_imports | hash reference
+ VERSION | dl_version | string
+
+Please see the documentation for C<ExtUtils::Mksymlists> for the
+details of what these parameters do.
+
+=item need_prelink
+
+Returns true on platforms where C<prelink()> should be called
+during linking, and false otherwise.
+
+=item extra_link_args_after_prelink
+
+Returns list of extra arguments to give to the link command; the arguments
+are the same as for prelink(), with addition of array reference to the
+results of prelink(); this reference is indexed by key C<prelink_res>.
+
+=back
+
+=head1 TO DO
+
+Currently this has only been tested on Unix and doesn't contain any of
+the Windows-specific code from the C<Module::Build> project. I'll do
+that next.
+
+=head1 HISTORY
+
+This module is an outgrowth of the C<Module::Build> project, to which
+there have been many contributors. Notably, Randy W. Sims submitted
+lots of code to support 3 compilers on Windows and helped with various
+other platform-specific issues. Ilya Zakharevich has contributed
+fixes for OS/2; John E. Malmberg and Peter Prymmer have done likewise
+for VMS.
+
+=head1 AUTHOR
+
+Ken Williams, kwilliams at cpan.org
+
+=head1 COPYRIGHT
+
+Copyright (c) 2003-2005 Ken Williams. All rights reserved.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+perl(1), Module::Build(3)
+
+=cut
Copied: trunk/contrib/perl/lib/ExtUtils/Command.pm (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/Command.pm)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/Command.pm (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/Command.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,369 @@
+package ExtUtils::Command;
+
+use 5.00503;
+use strict;
+use Carp;
+use File::Copy;
+use File::Compare;
+use File::Basename;
+use File::Path qw(rmtree);
+require Exporter;
+use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
+ at ISA = qw(Exporter);
+ at EXPORT = qw(cp rm_f rm_rf mv cat eqtime mkpath touch test_f test_d chmod
+ dos2unix);
+$VERSION = '1.16';
+
+my $Is_VMS = $^O eq 'VMS';
+my $Is_VMS_mode = $Is_VMS;
+my $Is_VMS_noefs = $Is_VMS;
+my $Is_Win32 = $^O eq 'MSWin32';
+
+if( $Is_VMS ) {
+ my $vms_unix_rpt;
+ my $vms_efs;
+ my $vms_case;
+
+ if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
+ $vms_unix_rpt = VMS::Feature::current("filename_unix_report");
+ $vms_efs = VMS::Feature::current("efs_charset");
+ $vms_case = VMS::Feature::current("efs_case_preserve");
+ } else {
+ my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
+ my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || '';
+ my $efs_case = $ENV{'DECC$EFS_CASE_PRESERVE'} || '';
+ $vms_unix_rpt = $unix_rpt =~ /^[ET1]/i;
+ $vms_efs = $efs_charset =~ /^[ET1]/i;
+ $vms_case = $efs_case =~ /^[ET1]/i;
+ }
+ $Is_VMS_mode = 0 if $vms_unix_rpt;
+ $Is_VMS_noefs = 0 if ($vms_efs);
+}
+
+
+=head1 NAME
+
+ExtUtils::Command - utilities to replace common UNIX commands in Makefiles etc.
+
+=head1 SYNOPSIS
+
+ perl -MExtUtils::Command -e cat files... > destination
+ perl -MExtUtils::Command -e mv source... destination
+ perl -MExtUtils::Command -e cp source... destination
+ perl -MExtUtils::Command -e touch files...
+ perl -MExtUtils::Command -e rm_f files...
+ perl -MExtUtils::Command -e rm_rf directories...
+ perl -MExtUtils::Command -e mkpath directories...
+ perl -MExtUtils::Command -e eqtime source destination
+ perl -MExtUtils::Command -e test_f file
+ perl -MExtUtils::Command -e test_d directory
+ perl -MExtUtils::Command -e chmod mode files...
+ ...
+
+=head1 DESCRIPTION
+
+The module is used to replace common UNIX commands. In all cases the
+functions work from @ARGV rather than taking arguments. This makes
+them easier to deal with in Makefiles. Call them like this:
+
+ perl -MExtUtils::Command -e some_command some files to work on
+
+and I<NOT> like this:
+
+ perl -MExtUtils::Command -e 'some_command qw(some files to work on)'
+
+For that use L<Shell::Command>.
+
+Filenames with * and ? will be glob expanded.
+
+
+=head2 FUNCTIONS
+
+=over 4
+
+=cut
+
+# VMS uses % instead of ? to mean "one character"
+my $wild_regex = $Is_VMS ? '*%' : '*?';
+sub expand_wildcards
+{
+ @ARGV = map(/[$wild_regex]/o ? glob($_) : $_, at ARGV);
+}
+
+
+=item cat
+
+ cat file ...
+
+Concatenates all files mentioned on command line to STDOUT.
+
+=cut
+
+sub cat ()
+{
+ expand_wildcards();
+ print while (<>);
+}
+
+=item eqtime
+
+ eqtime source destination
+
+Sets modified time of destination to that of source.
+
+=cut
+
+sub eqtime
+{
+ my ($src,$dst) = @ARGV;
+ local @ARGV = ($dst); touch(); # in case $dst doesn't exist
+ utime((stat($src))[8,9],$dst);
+}
+
+=item rm_rf
+
+ rm_rf files or directories ...
+
+Removes files and directories - recursively (even if readonly)
+
+=cut
+
+sub rm_rf
+{
+ expand_wildcards();
+ rmtree([grep -e $_, at ARGV],0,0);
+}
+
+=item rm_f
+
+ rm_f file ...
+
+Removes files (even if readonly)
+
+=cut
+
+sub rm_f {
+ expand_wildcards();
+
+ foreach my $file (@ARGV) {
+ next unless -f $file;
+
+ next if _unlink($file);
+
+ chmod(0777, $file);
+
+ next if _unlink($file);
+
+ carp "Cannot delete $file: $!";
+ }
+}
+
+sub _unlink {
+ my $files_unlinked = 0;
+ foreach my $file (@_) {
+ my $delete_count = 0;
+ $delete_count++ while unlink $file;
+ $files_unlinked++ if $delete_count;
+ }
+ return $files_unlinked;
+}
+
+
+=item touch
+
+ touch file ...
+
+Makes files exist, with current timestamp
+
+=cut
+
+sub touch {
+ my $t = time;
+ expand_wildcards();
+ foreach my $file (@ARGV) {
+ open(FILE,">>$file") || die "Cannot write $file:$!";
+ close(FILE);
+ utime($t,$t,$file);
+ }
+}
+
+=item mv
+
+ mv source_file destination_file
+ mv source_file source_file destination_dir
+
+Moves source to destination. Multiple sources are allowed if
+destination is an existing directory.
+
+Returns true if all moves succeeded, false otherwise.
+
+=cut
+
+sub mv {
+ expand_wildcards();
+ my @src = @ARGV;
+ my $dst = pop @src;
+
+ croak("Too many arguments") if (@src > 1 && ! -d $dst);
+
+ my $nok = 0;
+ foreach my $src (@src) {
+ $nok ||= !move($src,$dst);
+ }
+ return !$nok;
+}
+
+=item cp
+
+ cp source_file destination_file
+ cp source_file source_file destination_dir
+
+Copies sources to the destination. Multiple sources are allowed if
+destination is an existing directory.
+
+Returns true if all copies succeeded, false otherwise.
+
+=cut
+
+sub cp {
+ expand_wildcards();
+ my @src = @ARGV;
+ my $dst = pop @src;
+
+ croak("Too many arguments") if (@src > 1 && ! -d $dst);
+
+ my $nok = 0;
+ foreach my $src (@src) {
+ $nok ||= !copy($src,$dst);
+
+ # Win32 does not update the mod time of a copied file, just the
+ # created time which make does not look at.
+ utime(time, time, $dst) if $Is_Win32;
+ }
+ return $nok;
+}
+
+=item chmod
+
+ chmod mode files ...
+
+Sets UNIX like permissions 'mode' on all the files. e.g. 0666
+
+=cut
+
+sub chmod {
+ local @ARGV = @ARGV;
+ my $mode = shift(@ARGV);
+ expand_wildcards();
+
+ if( $Is_VMS_mode && $Is_VMS_noefs) {
+ foreach my $idx (0..$#ARGV) {
+ my $path = $ARGV[$idx];
+ next unless -d $path;
+
+ # chmod 0777, [.foo.bar] doesn't work on VMS, you have to do
+ # chmod 0777, [.foo]bar.dir
+ my @dirs = File::Spec->splitdir( $path );
+ $dirs[-1] .= '.dir';
+ $path = File::Spec->catfile(@dirs);
+
+ $ARGV[$idx] = $path;
+ }
+ }
+
+ chmod(oct $mode, at ARGV) || die "Cannot chmod ".join(' ',$mode, at ARGV).":$!";
+}
+
+=item mkpath
+
+ mkpath directory ...
+
+Creates directories, including any parent directories.
+
+=cut
+
+sub mkpath
+{
+ expand_wildcards();
+ File::Path::mkpath([@ARGV],0,0777);
+}
+
+=item test_f
+
+ test_f file
+
+Tests if a file exists. I<Exits> with 0 if it does, 1 if it does not (ie.
+shell's idea of true and false).
+
+=cut
+
+sub test_f
+{
+ exit(-f $ARGV[0] ? 0 : 1);
+}
+
+=item test_d
+
+ test_d directory
+
+Tests if a directory exists. I<Exits> with 0 if it does, 1 if it does
+not (ie. shell's idea of true and false).
+
+=cut
+
+sub test_d
+{
+ exit(-d $ARGV[0] ? 0 : 1);
+}
+
+=item dos2unix
+
+ dos2unix files or dirs ...
+
+Converts DOS and OS/2 linefeeds to Unix style recursively.
+
+=cut
+
+sub dos2unix {
+ require File::Find;
+ File::Find::find(sub {
+ return if -d;
+ return unless -w _;
+ return unless -r _;
+ return if -B _;
+
+ local $\;
+
+ my $orig = $_;
+ my $temp = '.dos2unix_tmp';
+ open ORIG, $_ or do { warn "dos2unix can't open $_: $!"; return };
+ open TEMP, ">$temp" or
+ do { warn "dos2unix can't create .dos2unix_tmp: $!"; return };
+ while (my $line = <ORIG>) {
+ $line =~ s/\015\012/\012/g;
+ print TEMP $line;
+ }
+ close ORIG;
+ close TEMP;
+ rename $temp, $orig;
+
+ }, @ARGV);
+}
+
+=back
+
+=head1 SEE ALSO
+
+Shell::Command which is these same functions but take arguments normally.
+
+
+=head1 AUTHOR
+
+Nick Ing-Simmons C<ni-s at cpan.org>
+
+Maintained by Michael G Schwern C<schwern at pobox.com> within the
+ExtUtils-MakeMaker package and, as a separate CPAN package, by
+Randy Kobes C<r.kobes at uwinnipeg.ca>.
+
+=cut
+
Copied: trunk/contrib/perl/lib/ExtUtils/Constant.pm (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/Constant.pm)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/Constant.pm (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/Constant.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,565 @@
+package ExtUtils::Constant;
+use vars qw (@ISA $VERSION @EXPORT_OK %EXPORT_TAGS);
+$VERSION = 0.22;
+
+=head1 NAME
+
+ExtUtils::Constant - generate XS code to import C header constants
+
+=head1 SYNOPSIS
+
+ use ExtUtils::Constant qw (WriteConstants);
+ WriteConstants(
+ NAME => 'Foo',
+ NAMES => [qw(FOO BAR BAZ)],
+ );
+ # Generates wrapper code to make the values of the constants FOO BAR BAZ
+ # available to perl
+
+=head1 DESCRIPTION
+
+ExtUtils::Constant facilitates generating C and XS wrapper code to allow
+perl modules to AUTOLOAD constants defined in C library header files.
+It is principally used by the C<h2xs> utility, on which this code is based.
+It doesn't contain the routines to scan header files to extract these
+constants.
+
+=head1 USAGE
+
+Generally one only needs to call the C<WriteConstants> function, and then
+
+ #include "const-c.inc"
+
+in the C section of C<Foo.xs>
+
+ INCLUDE: const-xs.inc
+
+in the XS section of C<Foo.xs>.
+
+For greater flexibility use C<constant_types()>, C<C_constant> and
+C<XS_constant>, with which C<WriteConstants> is implemented.
+
+Currently this module understands the following types. h2xs may only know
+a subset. The sizes of the numeric types are chosen by the C<Configure>
+script at compile time.
+
+=over 4
+
+=item IV
+
+signed integer, at least 32 bits.
+
+=item UV
+
+unsigned integer, the same size as I<IV>
+
+=item NV
+
+floating point type, probably C<double>, possibly C<long double>
+
+=item PV
+
+NUL terminated string, length will be determined with C<strlen>
+
+=item PVN
+
+A fixed length thing, given as a [pointer, length] pair. If you know the
+length of a string at compile time you may use this instead of I<PV>
+
+=item SV
+
+A B<mortal> SV.
+
+=item YES
+
+Truth. (C<PL_sv_yes>) The value is not needed (and ignored).
+
+=item NO
+
+Defined Falsehood. (C<PL_sv_no>) The value is not needed (and ignored).
+
+=item UNDEF
+
+C<undef>. The value of the macro is not needed.
+
+=back
+
+=head1 FUNCTIONS
+
+=over 4
+
+=cut
+
+if ($] >= 5.006) {
+ eval "use warnings; 1" or die $@;
+}
+use strict;
+use Carp qw(croak cluck);
+
+use Exporter;
+use ExtUtils::Constant::Utils qw(C_stringify);
+use ExtUtils::Constant::XS qw(%XS_Constant %XS_TypeSet);
+
+ at ISA = 'Exporter';
+
+%EXPORT_TAGS = ( 'all' => [ qw(
+ XS_constant constant_types return_clause memEQ_clause C_stringify
+ C_constant autoload WriteConstants WriteMakefileSnippet
+) ] );
+
+ at EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
+
+=item constant_types
+
+A function returning a single scalar with C<#define> definitions for the
+constants used internally between the generated C and XS functions.
+
+=cut
+
+sub constant_types {
+ ExtUtils::Constant::XS->header();
+}
+
+sub memEQ_clause {
+ cluck "ExtUtils::Constant::memEQ_clause is deprecated";
+ ExtUtils::Constant::XS->memEQ_clause({name=>$_[0], checked_at=>$_[1],
+ indent=>$_[2]});
+}
+
+sub return_clause ($$) {
+ cluck "ExtUtils::Constant::return_clause is deprecated";
+ my $indent = shift;
+ ExtUtils::Constant::XS->return_clause({indent=>$indent}, @_);
+}
+
+sub switch_clause {
+ cluck "ExtUtils::Constant::switch_clause is deprecated";
+ my $indent = shift;
+ my $comment = shift;
+ ExtUtils::Constant::XS->switch_clause({indent=>$indent, comment=>$comment},
+ @_);
+}
+
+sub C_constant {
+ my ($package, $subname, $default_type, $what, $indent, $breakout, @items)
+ = @_;
+ ExtUtils::Constant::XS->C_constant({package => $package, subname => $subname,
+ default_type => $default_type,
+ types => $what, indent => $indent,
+ breakout => $breakout}, @items);
+}
+
+=item XS_constant PACKAGE, TYPES, XS_SUBNAME, C_SUBNAME
+
+A function to generate the XS code to implement the perl subroutine
+I<PACKAGE>::constant used by I<PACKAGE>::AUTOLOAD to load constants.
+This XS code is a wrapper around a C subroutine usually generated by
+C<C_constant>, and usually named C<constant>.
+
+I<TYPES> should be given either as a comma separated list of types that the
+C subroutine C<constant> will generate or as a reference to a hash. It should
+be the same list of types as C<C_constant> was given.
+[Otherwise C<XS_constant> and C<C_constant> may have different ideas about
+the number of parameters passed to the C function C<constant>]
+
+You can call the perl visible subroutine something other than C<constant> if
+you give the parameter I<XS_SUBNAME>. The C subroutine it calls defaults to
+the name of the perl visible subroutine, unless you give the parameter
+I<C_SUBNAME>.
+
+=cut
+
+sub XS_constant {
+ my $package = shift;
+ my $what = shift;
+ my $XS_subname = shift;
+ my $C_subname = shift;
+ $XS_subname ||= 'constant';
+ $C_subname ||= $XS_subname;
+
+ if (!ref $what) {
+ # Convert line of the form IV,UV,NV to hash
+ $what = {map {$_ => 1} split /,\s*/, ($what)};
+ }
+ my $params = ExtUtils::Constant::XS->params ($what);
+ my $type;
+
+ my $xs = <<"EOT";
+void
+$XS_subname(sv)
+ PREINIT:
+#ifdef dXSTARG
+ dXSTARG; /* Faster if we have it. */
+#else
+ dTARGET;
+#endif
+ STRLEN len;
+ int type;
+EOT
+
+ if ($params->{IV}) {
+ $xs .= " IV iv;\n";
+ } else {
+ $xs .= " /* IV\t\tiv;\tUncomment this if you need to return IVs */\n";
+ }
+ if ($params->{NV}) {
+ $xs .= " NV nv;\n";
+ } else {
+ $xs .= " /* NV\t\tnv;\tUncomment this if you need to return NVs */\n";
+ }
+ if ($params->{PV}) {
+ $xs .= " const char *pv;\n";
+ } else {
+ $xs .=
+ " /* const char\t*pv;\tUncomment this if you need to return PVs */\n";
+ }
+
+ $xs .= << 'EOT';
+ INPUT:
+ SV * sv;
+ const char * s = SvPV(sv, len);
+EOT
+ if ($params->{''}) {
+ $xs .= << 'EOT';
+ INPUT:
+ int utf8 = SvUTF8(sv);
+EOT
+ }
+ $xs .= << 'EOT';
+ PPCODE:
+EOT
+
+ if ($params->{IV} xor $params->{NV}) {
+ $xs .= << "EOT";
+ /* Change this to $C_subname(aTHX_ s, len, &iv, &nv);
+ if you need to return both NVs and IVs */
+EOT
+ }
+ $xs .= " type = $C_subname(aTHX_ s, len";
+ $xs .= ', utf8' if $params->{''};
+ $xs .= ', &iv' if $params->{IV};
+ $xs .= ', &nv' if $params->{NV};
+ $xs .= ', &pv' if $params->{PV};
+ $xs .= ', &sv' if $params->{SV};
+ $xs .= ");\n";
+
+ # If anyone is insane enough to suggest a package name containing %
+ my $package_sprintf_safe = $package;
+ $package_sprintf_safe =~ s/%/%%/g;
+
+ $xs .= << "EOT";
+ /* Return 1 or 2 items. First is error message, or undef if no error.
+ Second, if present, is found value */
+ switch (type) {
+ case PERL_constant_NOTFOUND:
+ sv =
+ sv_2mortal(newSVpvf("%s is not a valid $package_sprintf_safe macro", s));
+ PUSHs(sv);
+ break;
+ case PERL_constant_NOTDEF:
+ sv = sv_2mortal(newSVpvf(
+ "Your vendor has not defined $package_sprintf_safe macro %s, used",
+ s));
+ PUSHs(sv);
+ break;
+EOT
+
+ foreach $type (sort keys %XS_Constant) {
+ # '' marks utf8 flag needed.
+ next if $type eq '';
+ $xs .= "\t/* Uncomment this if you need to return ${type}s\n"
+ unless $what->{$type};
+ $xs .= " case PERL_constant_IS$type:\n";
+ if (length $XS_Constant{$type}) {
+ $xs .= << "EOT";
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ $XS_Constant{$type};
+EOT
+ } else {
+ # Do nothing. return (), which will be correctly interpreted as
+ # (undef, undef)
+ }
+ $xs .= " break;\n";
+ unless ($what->{$type}) {
+ chop $xs; # Yes, another need for chop not chomp.
+ $xs .= " */\n";
+ }
+ }
+ $xs .= << "EOT";
+ default:
+ sv = sv_2mortal(newSVpvf(
+ "Unexpected return type %d while processing $package_sprintf_safe macro %s, used",
+ type, s));
+ PUSHs(sv);
+ }
+EOT
+
+ return $xs;
+}
+
+
+=item autoload PACKAGE, VERSION, AUTOLOADER
+
+A function to generate the AUTOLOAD subroutine for the module I<PACKAGE>
+I<VERSION> is the perl version the code should be backwards compatible with.
+It defaults to the version of perl running the subroutine. If I<AUTOLOADER>
+is true, the AUTOLOAD subroutine falls back on AutoLoader::AUTOLOAD for all
+names that the constant() routine doesn't recognise.
+
+=cut
+
+# ' # Grr. syntax highlighters that don't grok pod.
+
+sub autoload {
+ my ($module, $compat_version, $autoloader) = @_;
+ $compat_version ||= $];
+ croak "Can't maintain compatibility back as far as version $compat_version"
+ if $compat_version < 5;
+ my $func = "sub AUTOLOAD {\n"
+ . " # This AUTOLOAD is used to 'autoload' constants from the constant()\n"
+ . " # XS function.";
+ $func .= " If a constant is not found then control is passed\n"
+ . " # to the AUTOLOAD in AutoLoader." if $autoloader;
+
+
+ $func .= "\n\n"
+ . " my \$constname;\n";
+ $func .=
+ " our \$AUTOLOAD;\n" if ($compat_version >= 5.006);
+
+ $func .= <<"EOT";
+ (\$constname = \$AUTOLOAD) =~ s/.*:://;
+ croak "&${module}::constant not defined" if \$constname eq 'constant';
+ my (\$error, \$val) = constant(\$constname);
+EOT
+
+ if ($autoloader) {
+ $func .= <<'EOT';
+ if ($error) {
+ if ($error =~ /is not a valid/) {
+ $AutoLoader::AUTOLOAD = $AUTOLOAD;
+ goto &AutoLoader::AUTOLOAD;
+ } else {
+ croak $error;
+ }
+ }
+EOT
+ } else {
+ $func .=
+ " if (\$error) { croak \$error; }\n";
+ }
+
+ $func .= <<'END';
+ {
+ no strict 'refs';
+ # Fixed between 5.005_53 and 5.005_61
+#XXX if ($] >= 5.00561) {
+#XXX *$AUTOLOAD = sub () { $val };
+#XXX }
+#XXX else {
+ *$AUTOLOAD = sub { $val };
+#XXX }
+ }
+ goto &$AUTOLOAD;
+}
+
+END
+
+ return $func;
+}
+
+
+=item WriteMakefileSnippet
+
+WriteMakefileSnippet ATTRIBUTE =E<gt> VALUE [, ...]
+
+A function to generate perl code for Makefile.PL that will regenerate
+the constant subroutines. Parameters are named as passed to C<WriteConstants>,
+with the addition of C<INDENT> to specify the number of leading spaces
+(default 2).
+
+Currently only C<INDENT>, C<NAME>, C<DEFAULT_TYPE>, C<NAMES>, C<C_FILE> and
+C<XS_FILE> are recognised.
+
+=cut
+
+sub WriteMakefileSnippet {
+ my %args = @_;
+ my $indent = $args{INDENT} || 2;
+
+ my $result = <<"EOT";
+ExtUtils::Constant::WriteConstants(
+ NAME => '$args{NAME}',
+ NAMES => \\\@names,
+ DEFAULT_TYPE => '$args{DEFAULT_TYPE}',
+EOT
+ foreach (qw (C_FILE XS_FILE)) {
+ next unless exists $args{$_};
+ $result .= sprintf " %-12s => '%s',\n",
+ $_, $args{$_};
+ }
+ $result .= <<'EOT';
+ );
+EOT
+
+ $result =~ s/^/' 'x$indent/gem;
+ return ExtUtils::Constant::XS->dump_names({default_type=>$args{DEFAULT_TYPE},
+ indent=>$indent,},
+ @{$args{NAMES}})
+ . $result;
+}
+
+=item WriteConstants ATTRIBUTE =E<gt> VALUE [, ...]
+
+Writes a file of C code and a file of XS code which you should C<#include>
+and C<INCLUDE> in the C and XS sections respectively of your module's XS
+code. You probably want to do this in your C<Makefile.PL>, so that you can
+easily edit the list of constants without touching the rest of your module.
+The attributes supported are
+
+=over 4
+
+=item NAME
+
+Name of the module. This must be specified
+
+=item DEFAULT_TYPE
+
+The default type for the constants. If not specified C<IV> is assumed.
+
+=item BREAKOUT_AT
+
+The names of the constants are grouped by length. Generate child subroutines
+for each group with this number or more names in.
+
+=item NAMES
+
+An array of constants' names, either scalars containing names, or hashrefs
+as detailed in L<"C_constant">.
+
+=item PROXYSUBS
+
+If true, uses proxy subs. See L<ExtUtils::Constant::ProxySubs>.
+
+=item C_FH
+
+A filehandle to write the C code to. If not given, then I<C_FILE> is opened
+for writing.
+
+=item C_FILE
+
+The name of the file to write containing the C code. The default is
+C<const-c.inc>. The C<-> in the name ensures that the file can't be
+mistaken for anything related to a legitimate perl package name, and
+not naming the file C<.c> avoids having to override Makefile.PL's
+C<.xs> to C<.c> rules.
+
+=item XS_FH
+
+A filehandle to write the XS code to. If not given, then I<XS_FILE> is opened
+for writing.
+
+=item XS_FILE
+
+The name of the file to write containing the XS code. The default is
+C<const-xs.inc>.
+
+=item XS_SUBNAME
+
+The perl visible name of the XS subroutine generated which will return the
+constants. The default is C<constant>.
+
+=item C_SUBNAME
+
+The name of the C subroutine generated which will return the constants.
+The default is I<XS_SUBNAME>. Child subroutines have C<_> and the name
+length appended, so constants with 10 character names would be in
+C<constant_10> with the default I<XS_SUBNAME>.
+
+=back
+
+=cut
+
+sub WriteConstants {
+ my %ARGS =
+ ( # defaults
+ C_FILE => 'const-c.inc',
+ XS_FILE => 'const-xs.inc',
+ XS_SUBNAME => 'constant',
+ DEFAULT_TYPE => 'IV',
+ @_);
+
+ $ARGS{C_SUBNAME} ||= $ARGS{XS_SUBNAME}; # No-one sane will have C_SUBNAME eq '0'
+
+ croak "Module name not specified" unless length $ARGS{NAME};
+
+ my $c_fh = $ARGS{C_FH};
+ if (!$c_fh) {
+ if ($] <= 5.008) {
+ # We need these little games, rather than doing things
+ # unconditionally, because we're used in core Makefile.PLs before
+ # IO is available (needed by filehandle), but also we want to work on
+ # older perls where undefined scalars do not automatically turn into
+ # anonymous file handles.
+ require FileHandle;
+ $c_fh = FileHandle->new();
+ }
+ open $c_fh, ">$ARGS{C_FILE}" or die "Can't open $ARGS{C_FILE}: $!";
+ }
+
+ my $xs_fh = $ARGS{XS_FH};
+ if (!$xs_fh) {
+ if ($] <= 5.008) {
+ require FileHandle;
+ $xs_fh = FileHandle->new();
+ }
+ open $xs_fh, ">$ARGS{XS_FILE}" or die "Can't open $ARGS{XS_FILE}: $!";
+ }
+
+ # As this subroutine is intended to make code that isn't edited, there's no
+ # need for the user to specify any types that aren't found in the list of
+ # names.
+
+ if ($ARGS{PROXYSUBS}) {
+ require ExtUtils::Constant::ProxySubs;
+ $ARGS{C_FH} = $c_fh;
+ $ARGS{XS_FH} = $xs_fh;
+ ExtUtils::Constant::ProxySubs->WriteConstants(%ARGS);
+ } else {
+ my $types = {};
+
+ print $c_fh constant_types(); # macro defs
+ print $c_fh "\n";
+
+ # indent is still undef. Until anyone implements indent style rules with
+ # it.
+ foreach (ExtUtils::Constant::XS->C_constant({package => $ARGS{NAME},
+ subname => $ARGS{C_SUBNAME},
+ default_type =>
+ $ARGS{DEFAULT_TYPE},
+ types => $types,
+ breakout =>
+ $ARGS{BREAKOUT_AT}},
+ @{$ARGS{NAMES}})) {
+ print $c_fh $_, "\n"; # C constant subs
+ }
+ print $xs_fh XS_constant ($ARGS{NAME}, $types, $ARGS{XS_SUBNAME},
+ $ARGS{C_SUBNAME});
+ }
+
+ close $c_fh or warn "Error closing $ARGS{C_FILE}: $!" unless $ARGS{C_FH};
+ close $xs_fh or warn "Error closing $ARGS{XS_FILE}: $!" unless $ARGS{XS_FH};
+}
+
+1;
+__END__
+
+=back
+
+=head1 AUTHOR
+
+Nicholas Clark <nick at ccl4.org> based on the code in C<h2xs> by Larry Wall and
+others
+
+=cut
Index: trunk/contrib/perl/lib/ExtUtils/Embed.pm
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/Embed.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/ExtUtils/Embed.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/ExtUtils/Embed.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Copied: trunk/contrib/perl/lib/ExtUtils/Install.pm (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/Install.pm)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/Install.pm (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/Install.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,1356 @@
+package ExtUtils::Install;
+use strict;
+
+use vars qw(@ISA @EXPORT $VERSION $MUST_REBOOT %Config);
+
+use AutoSplit;
+use Carp ();
+use Config qw(%Config);
+use Cwd qw(cwd);
+use Exporter;
+use ExtUtils::Packlist;
+use File::Basename qw(dirname);
+use File::Compare qw(compare);
+use File::Copy;
+use File::Find qw(find);
+use File::Path;
+use File::Spec;
+
+
+ at ISA = ('Exporter');
+ at EXPORT = ('install','uninstall','pm_to_blib', 'install_default');
+
+=pod
+
+=head1 NAME
+
+ExtUtils::Install - install files from here to there
+
+=head1 SYNOPSIS
+
+ use ExtUtils::Install;
+
+ install({ 'blib/lib' => 'some/install/dir' } );
+
+ uninstall($packlist);
+
+ pm_to_blib({ 'lib/Foo/Bar.pm' => 'blib/lib/Foo/Bar.pm' });
+
+=head1 VERSION
+
+1.54
+
+=cut
+
+$VERSION = '1.54'; # <---- dont forget to update the POD section just above this line!
+$VERSION = eval $VERSION;
+
+=pod
+
+=head1 DESCRIPTION
+
+Handles the installing and uninstalling of perl modules, scripts, man
+pages, etc...
+
+Both install() and uninstall() are specific to the way
+ExtUtils::MakeMaker handles the installation and deinstallation of
+perl modules. They are not designed as general purpose tools.
+
+On some operating systems such as Win32 installation may not be possible
+until after a reboot has occured. This can have varying consequences:
+removing an old DLL does not impact programs using the new one, but if
+a new DLL cannot be installed properly until reboot then anything
+depending on it must wait. The package variable
+
+ $ExtUtils::Install::MUST_REBOOT
+
+is used to store this status.
+
+If this variable is true then such an operation has occured and
+anything depending on this module cannot proceed until a reboot
+has occured.
+
+If this value is defined but false then such an operation has
+ocurred, but should not impact later operations.
+
+=begin _private
+
+=item _chmod($$;$)
+
+Wrapper to chmod() for debugging and error trapping.
+
+=item _warnonce(@)
+
+Warns about something only once.
+
+=item _choke(@)
+
+Dies with a special message.
+
+=end _private
+
+=cut
+
+my $Is_VMS = $^O eq 'VMS';
+my $Is_VMS_noefs = $Is_VMS;
+my $Is_MacPerl = $^O eq 'MacOS';
+my $Is_Win32 = $^O eq 'MSWin32';
+my $Is_cygwin = $^O eq 'cygwin';
+my $CanMoveAtBoot = ($Is_Win32 || $Is_cygwin);
+
+ if( $Is_VMS ) {
+ my $vms_unix_rpt;
+ my $vms_efs;
+ my $vms_case;
+
+ if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
+ $vms_unix_rpt = VMS::Feature::current("filename_unix_report");
+ $vms_efs = VMS::Feature::current("efs_charset");
+ $vms_case = VMS::Feature::current("efs_case_preserve");
+ } else {
+ my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
+ my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || '';
+ my $efs_case = $ENV{'DECC$EFS_CASE_PRESERVE'} || '';
+ $vms_unix_rpt = $unix_rpt =~ /^[ET1]/i;
+ $vms_efs = $efs_charset =~ /^[ET1]/i;
+ $vms_case = $efs_case =~ /^[ET1]/i;
+ }
+ $Is_VMS_noefs = 0 if ($vms_efs);
+ }
+
+
+
+# *note* CanMoveAtBoot is only incidentally the same condition as below
+# this needs not hold true in the future.
+my $Has_Win32API_File = ($Is_Win32 || $Is_cygwin)
+ ? (eval {require Win32API::File; 1} || 0)
+ : 0;
+
+
+my $Inc_uninstall_warn_handler;
+
+# install relative to here
+
+my $INSTALL_ROOT = $ENV{PERL_INSTALL_ROOT};
+
+my $Curdir = File::Spec->curdir;
+my $Updir = File::Spec->updir;
+
+sub _estr(@) {
+ return join "\n",'!' x 72, at _,'!' x 72,'';
+}
+
+{my %warned;
+sub _warnonce(@) {
+ my $first=shift;
+ my $msg=_estr "WARNING: $first", at _;
+ warn $msg unless $warned{$msg}++;
+}}
+
+sub _choke(@) {
+ my $first=shift;
+ my $msg=_estr "ERROR: $first", at _;
+ Carp::croak($msg);
+}
+
+
+sub _chmod($$;$) {
+ my ( $mode, $item, $verbose )=@_;
+ $verbose ||= 0;
+ if (chmod $mode, $item) {
+ printf "chmod(0%o, %s)\n",$mode, $item if $verbose > 1;
+ } else {
+ my $err="$!";
+ _warnonce sprintf "WARNING: Failed chmod(0%o, %s): %s\n",
+ $mode, $item, $err
+ if -e $item;
+ }
+}
+
+=begin _private
+
+=item _move_file_at_boot( $file, $target, $moan )
+
+OS-Specific, Win32/Cygwin
+
+Schedules a file to be moved/renamed/deleted at next boot.
+$file should be a filespec of an existing file
+$target should be a ref to an array if the file is to be deleted
+otherwise it should be a filespec for a rename. If the file is existing
+it will be replaced.
+
+Sets $MUST_REBOOT to 0 to indicate a deletion operation has occured
+and sets it to 1 to indicate that a move operation has been requested.
+
+returns 1 on success, on failure if $moan is false errors are fatal.
+If $moan is true then returns 0 on error and warns instead of dies.
+
+=end _private
+
+=cut
+
+
+
+sub _move_file_at_boot { #XXX OS-SPECIFIC
+ my ( $file, $target, $moan )= @_;
+ Carp::confess("Panic: Can't _move_file_at_boot on this platform!")
+ unless $CanMoveAtBoot;
+
+ my $descr= ref $target
+ ? "'$file' for deletion"
+ : "'$file' for installation as '$target'";
+
+ if ( ! $Has_Win32API_File ) {
+
+ my @msg=(
+ "Cannot schedule $descr at reboot.",
+ "Try installing Win32API::File to allow operations on locked files",
+ "to be scheduled during reboot. Or try to perform the operation by",
+ "hand yourself. (You may need to close other perl processes first)"
+ );
+ if ( $moan ) { _warnonce(@msg) } else { _choke(@msg) }
+ return 0;
+ }
+ my $opts= Win32API::File::MOVEFILE_DELAY_UNTIL_REBOOT();
+ $opts= $opts | Win32API::File::MOVEFILE_REPLACE_EXISTING()
+ unless ref $target;
+
+ _chmod( 0666, $file );
+ _chmod( 0666, $target ) unless ref $target;
+
+ if (Win32API::File::MoveFileEx( $file, $target, $opts )) {
+ $MUST_REBOOT ||= ref $target ? 0 : 1;
+ return 1;
+ } else {
+ my @msg=(
+ "MoveFileEx $descr at reboot failed: $^E",
+ "You may try to perform the operation by hand yourself. ",
+ "(You may need to close other perl processes first).",
+ );
+ if ( $moan ) { _warnonce(@msg) } else { _choke(@msg) }
+ }
+ return 0;
+}
+
+
+=begin _private
+
+=item _unlink_or_rename( $file, $tryhard, $installing )
+
+OS-Specific, Win32/Cygwin
+
+Tries to get a file out of the way by unlinking it or renaming it. On
+some OS'es (Win32 based) DLL files can end up locked such that they can
+be renamed but not deleted. Likewise sometimes a file can be locked such
+that it cant even be renamed or changed except at reboot. To handle
+these cases this routine finds a tempfile name that it can either rename
+the file out of the way or use as a proxy for the install so that the
+rename can happen later (at reboot).
+
+ $file : the file to remove.
+ $tryhard : should advanced tricks be used for deletion
+ $installing : we are not merely deleting but we want to overwrite
+
+When $tryhard is not true if the unlink fails its fatal. When $tryhard
+is true then the file is attempted to be renamed. The renamed file is
+then scheduled for deletion. If the rename fails then $installing
+governs what happens. If it is false the failure is fatal. If it is true
+then an attempt is made to schedule installation at boot using a
+temporary file to hold the new file. If this fails then a fatal error is
+thrown, if it succeeds it returns the temporary file name (which will be
+a derivative of the original in the same directory) so that the caller can
+use it to install under. In all other cases of success returns $file.
+On failure throws a fatal error.
+
+=end _private
+
+=cut
+
+
+
+sub _unlink_or_rename { #XXX OS-SPECIFIC
+ my ( $file, $tryhard, $installing )= @_;
+
+ _chmod( 0666, $file );
+ my $unlink_count = 0;
+ while (unlink $file) { $unlink_count++; }
+ return $file if $unlink_count > 0;
+ my $error="$!";
+
+ _choke("Cannot unlink '$file': $!")
+ unless $CanMoveAtBoot && $tryhard;
+
+ my $tmp= "AAA";
+ ++$tmp while -e "$file.$tmp";
+ $tmp= "$file.$tmp";
+
+ warn "WARNING: Unable to unlink '$file': $error\n",
+ "Going to try to rename it to '$tmp'.\n";
+
+ if ( rename $file, $tmp ) {
+ warn "Rename succesful. Scheduling '$tmp'\nfor deletion at reboot.\n";
+ # when $installing we can set $moan to true.
+ # IOW, if we cant delete the renamed file at reboot its
+ # not the end of the world. The other cases are more serious
+ # and need to be fatal.
+ _move_file_at_boot( $tmp, [], $installing );
+ return $file;
+ } elsif ( $installing ) {
+ _warnonce("Rename failed: $!. Scheduling '$tmp'\nfor".
+ " installation as '$file' at reboot.\n");
+ _move_file_at_boot( $tmp, $file );
+ return $tmp;
+ } else {
+ _choke("Rename failed:$!", "Cannot procede.");
+ }
+
+}
+
+
+=pod
+
+=head2 Functions
+
+=begin _private
+
+=item _get_install_skip
+
+Handles loading the INSTALL.SKIP file. Returns an array of patterns to use.
+
+=cut
+
+
+
+sub _get_install_skip {
+ my ( $skip, $verbose )= @_;
+ if ($ENV{EU_INSTALL_IGNORE_SKIP}) {
+ print "EU_INSTALL_IGNORE_SKIP is set, ignore skipfile settings\n"
+ if $verbose>2;
+ return [];
+ }
+ if ( ! defined $skip ) {
+ print "Looking for install skip list\n"
+ if $verbose>2;
+ for my $file ( 'INSTALL.SKIP', $ENV{EU_INSTALL_SITE_SKIPFILE} ) {
+ next unless $file;
+ print "\tChecking for $file\n"
+ if $verbose>2;
+ if (-e $file) {
+ $skip= $file;
+ last;
+ }
+ }
+ }
+ if ($skip && !ref $skip) {
+ print "Reading skip patterns from '$skip'.\n"
+ if $verbose;
+ if (open my $fh,$skip ) {
+ my @patterns;
+ while (<$fh>) {
+ chomp;
+ next if /^\s*(?:#|$)/;
+ print "\tSkip pattern: $_\n" if $verbose>3;
+ push @patterns, $_;
+ }
+ $skip= \@patterns;
+ } else {
+ warn "Can't read skip file:'$skip':$!\n";
+ $skip=[];
+ }
+ } elsif ( UNIVERSAL::isa($skip,'ARRAY') ) {
+ print "Using array for skip list\n"
+ if $verbose>2;
+ } elsif ($verbose) {
+ print "No skip list found.\n"
+ if $verbose>1;
+ $skip= [];
+ }
+ warn "Got @{[0+@$skip]} skip patterns.\n"
+ if $verbose>3;
+ return $skip
+}
+
+=pod
+
+=item _have_write_access
+
+Abstract a -w check that tries to use POSIX::access() if possible.
+
+=cut
+
+{
+ my $has_posix;
+ sub _have_write_access {
+ my $dir=shift;
+ unless (defined $has_posix) {
+ $has_posix= (!$Is_cygwin && !$Is_Win32
+ && eval 'local $^W; require POSIX; 1') || 0;
+ }
+ if ($has_posix) {
+ return POSIX::access($dir, POSIX::W_OK());
+ } else {
+ return -w $dir;
+ }
+ }
+}
+
+=pod
+
+=item _can_write_dir(C<$dir>)
+
+Checks whether a given directory is writable, taking account
+the possibility that the directory might not exist and would have to
+be created first.
+
+Returns a list, containing: C<($writable, $determined_by, @create)>
+
+C<$writable> says whether whether the directory is (hypothetically) writable
+
+C<$determined_by> is the directory the status was determined from. It will be
+either the C<$dir>, or one of its parents.
+
+C<@create> is a list of directories that would probably have to be created
+to make the requested directory. It may not actually be correct on
+relative paths with C<..> in them. But for our purposes it should work ok
+
+=cut
+
+
+sub _can_write_dir {
+ my $dir=shift;
+ return
+ unless defined $dir and length $dir;
+
+ my ($vol, $dirs, $file) = File::Spec->splitpath($dir,1);
+ my @dirs = File::Spec->splitdir($dirs);
+ unshift @dirs, File::Spec->curdir
+ unless File::Spec->file_name_is_absolute($dir);
+
+ my $path='';
+ my @make;
+ while (@dirs) {
+ if ($Is_VMS_noefs) {
+ # There is a bug in catdir that is fixed when the EFS character
+ # set is enabled, which requires this VMS specific code.
+ $dir = File::Spec->catdir($vol, at dirs);
+ }
+ else {
+ $dir = File::Spec->catdir(@dirs);
+ $dir = File::Spec->catpath($vol,$dir,'')
+ if defined $vol and length $vol;
+ }
+ next if ( $dir eq $path );
+ if ( ! -e $dir ) {
+ unshift @make,$dir;
+ next;
+ }
+ if ( _have_write_access($dir) ) {
+ return 1,$dir, at make
+ } else {
+ return 0,$dir, at make
+ }
+ } continue {
+ pop @dirs;
+ }
+ return 0;
+}
+
+=pod
+
+=item _mkpath($dir,$show,$mode,$verbose,$dry_run)
+
+Wrapper around File::Path::mkpath() to handle errors.
+
+If $verbose is true and >1 then additional diagnostics will be produced, also
+this will force $show to true.
+
+If $dry_run is true then the directory will not be created but a check will be
+made to see whether it would be possible to write to the directory, or that
+it would be possible to create the directory.
+
+If $dry_run is not true dies if the directory can not be created or is not
+writable.
+
+=cut
+
+sub _mkpath {
+ my ($dir,$show,$mode,$verbose,$dry_run)=@_;
+ if ( $verbose && $verbose > 1 && ! -d $dir) {
+ $show= 1;
+ printf "mkpath(%s,%d,%#o)\n", $dir, $show, $mode;
+ }
+ if (!$dry_run) {
+ if ( ! eval { File::Path::mkpath($dir,$show,$mode); 1 } ) {
+ _choke("Can't create '$dir'","$@");
+ }
+
+ }
+ my ($can,$root, at make)=_can_write_dir($dir);
+ if (!$can) {
+ my @msg=(
+ "Can't create '$dir'",
+ $root ? "Do not have write permissions on '$root'"
+ : "Unknown Error"
+ );
+ if ($dry_run) {
+ _warnonce @msg;
+ } else {
+ _choke @msg;
+ }
+ } elsif ($show and $dry_run) {
+ print "$_\n" for @make;
+ }
+
+}
+
+=pod
+
+=item _copy($from,$to,$verbose,$dry_run)
+
+Wrapper around File::Copy::copy to handle errors.
+
+If $verbose is true and >1 then additional dignostics will be emitted.
+
+If $dry_run is true then the copy will not actually occur.
+
+Dies if the copy fails.
+
+=cut
+
+
+sub _copy {
+ my ( $from, $to, $verbose, $dry_run)=@_;
+ if ($verbose && $verbose>1) {
+ printf "copy(%s,%s)\n", $from, $to;
+ }
+ if (!$dry_run) {
+ File::Copy::copy($from,$to)
+ or Carp::croak( _estr "ERROR: Cannot copy '$from' to '$to': $!" );
+ }
+}
+
+=pod
+
+=item _chdir($from)
+
+Wrapper around chdir to catch errors.
+
+If not called in void context returns the cwd from before the chdir.
+
+dies on error.
+
+=cut
+
+sub _chdir {
+ my ($dir)= @_;
+ my $ret;
+ if (defined wantarray) {
+ $ret= cwd;
+ }
+ chdir $dir
+ or _choke("Couldn't chdir to '$dir': $!");
+ return $ret;
+}
+
+=pod
+
+=end _private
+
+=over 4
+
+=item B<install>
+
+ # deprecated forms
+ install(\%from_to);
+ install(\%from_to, $verbose, $dry_run, $uninstall_shadows,
+ $skip, $always_copy, \%result);
+
+ # recommended form as of 1.47
+ install([
+ from_to => \%from_to,
+ verbose => 1,
+ dry_run => 0,
+ uninstall_shadows => 1,
+ skip => undef,
+ always_copy => 1,
+ result => \%install_results,
+ ]);
+
+
+Copies each directory tree of %from_to to its corresponding value
+preserving timestamps and permissions.
+
+There are two keys with a special meaning in the hash: "read" and
+"write". These contain packlist files. After the copying is done,
+install() will write the list of target files to $from_to{write}. If
+$from_to{read} is given the contents of this file will be merged into
+the written file. The read and the written file may be identical, but
+on AFS it is quite likely that people are installing to a different
+directory than the one where the files later appear.
+
+If $verbose is true, will print out each file removed. Default is
+false. This is "make install VERBINST=1". $verbose values going
+up to 5 show increasingly more diagnostics output.
+
+If $dry_run is true it will only print what it was going to do
+without actually doing it. Default is false.
+
+If $uninstall_shadows is true any differing versions throughout @INC
+will be uninstalled. This is "make install UNINST=1"
+
+As of 1.37_02 install() supports the use of a list of patterns to filter out
+files that shouldn't be installed. If $skip is omitted or undefined then
+install will try to read the list from INSTALL.SKIP in the CWD. This file is
+a list of regular expressions and is just like the MANIFEST.SKIP file used
+by L<ExtUtils::Manifest>.
+
+A default site INSTALL.SKIP may be provided by setting then environment
+variable EU_INSTALL_SITE_SKIPFILE, this will only be used when there isn't a
+distribution specific INSTALL.SKIP. If the environment variable
+EU_INSTALL_IGNORE_SKIP is true then no install file filtering will be
+performed.
+
+If $skip is undefined then the skip file will be autodetected and used if it
+is found. If $skip is a reference to an array then it is assumed the array
+contains the list of patterns, if $skip is a true non reference it is
+assumed to be the filename holding the list of patterns, any other value of
+$skip is taken to mean that no install filtering should occur.
+
+B<Changes As of Version 1.47>
+
+As of version 1.47 the following additions were made to the install interface.
+Note that the new argument style and use of the %result hash is recommended.
+
+The $always_copy parameter which when true causes files to be updated
+regardles as to whether they have changed, if it is defined but false then
+copies are made only if the files have changed, if it is undefined then the
+value of the environment variable EU_INSTALL_ALWAYS_COPY is used as default.
+
+The %result hash will be populated with the various keys/subhashes reflecting
+the install. Currently these keys and their structure are:
+
+ install => { $target => $source },
+ install_fail => { $target => $source },
+ install_unchanged => { $target => $source },
+
+ install_filtered => { $source => $pattern },
+
+ uninstall => { $uninstalled => $source },
+ uninstall_fail => { $uninstalled => $source },
+
+where C<$source> is the filespec of the file being installed. C<$target> is where
+it is being installed to, and C<$uninstalled> is any shadow file that is in C<@INC>
+or C<$ENV{PERL5LIB}> or other standard locations, and C<$pattern> is the pattern that
+caused a source file to be skipped. In future more keys will be added, such as to
+show created directories, however this requires changes in other modules and must
+therefore wait.
+
+These keys will be populated before any exceptions are thrown should there be an
+error.
+
+Note that all updates of the %result are additive, the hash will not be
+cleared before use, thus allowing status results of many installs to be easily
+aggregated.
+
+B<NEW ARGUMENT STYLE>
+
+If there is only one argument and it is a reference to an array then
+the array is assumed to contain a list of key-value pairs specifying
+the options. In this case the option "from_to" is mandatory. This style
+means that you dont have to supply a cryptic list of arguments and can
+use a self documenting argument list that is easier to understand.
+
+This is now the recommended interface to install().
+
+B<RETURN>
+
+If all actions were successful install will return a hashref of the results
+as described above for the $result parameter. If any action is a failure
+then install will die, therefore it is recommended to pass in the $result
+parameter instead of using the return value. If the result parameter is
+provided then the returned hashref will be the passed in hashref.
+
+=cut
+
+sub install { #XXX OS-SPECIFIC
+ my($from_to,$verbose,$dry_run,$uninstall_shadows,$skip,$always_copy,$result) = @_;
+ if (@_==1 and eval { 1+@$from_to }) {
+ my %opts = @$from_to;
+ $from_to = $opts{from_to}
+ or Carp::confess("from_to is a mandatory parameter");
+ $verbose = $opts{verbose};
+ $dry_run = $opts{dry_run};
+ $uninstall_shadows = $opts{uninstall_shadows};
+ $skip = $opts{skip};
+ $always_copy = $opts{always_copy};
+ $result = $opts{result};
+ }
+
+ $result ||= {};
+ $verbose ||= 0;
+ $dry_run ||= 0;
+
+ $skip= _get_install_skip($skip,$verbose);
+ $always_copy = $ENV{EU_INSTALL_ALWAYS_COPY}
+ || $ENV{EU_ALWAYS_COPY}
+ || 0
+ unless defined $always_copy;
+
+ my(%from_to) = %$from_to;
+ my(%pack, $dir, %warned);
+ my($packlist) = ExtUtils::Packlist->new();
+
+ local(*DIR);
+ for (qw/read write/) {
+ $pack{$_}=$from_to{$_};
+ delete $from_to{$_};
+ }
+ my $tmpfile = install_rooted_file($pack{"read"});
+ $packlist->read($tmpfile) if (-f $tmpfile);
+ my $cwd = cwd();
+ my @found_files;
+ my %check_dirs;
+
+ MOD_INSTALL: foreach my $source (sort keys %from_to) {
+ #copy the tree to the target directory without altering
+ #timestamp and permission and remember for the .packlist
+ #file. The packlist file contains the absolute paths of the
+ #install locations. AFS users may call this a bug. We'll have
+ #to reconsider how to add the means to satisfy AFS users also.
+
+ #October 1997: we want to install .pm files into archlib if
+ #there are any files in arch. So we depend on having ./blib/arch
+ #hardcoded here.
+
+ my $targetroot = install_rooted_dir($from_to{$source});
+
+ my $blib_lib = File::Spec->catdir('blib', 'lib');
+ my $blib_arch = File::Spec->catdir('blib', 'arch');
+ if ($source eq $blib_lib and
+ exists $from_to{$blib_arch} and
+ directory_not_empty($blib_arch)
+ ){
+ $targetroot = install_rooted_dir($from_to{$blib_arch});
+ print "Files found in $blib_arch: installing files in $blib_lib into architecture dependent library tree\n";
+ }
+
+ next unless -d $source;
+ _chdir($source);
+ # 5.5.3's File::Find missing no_chdir option
+ # XXX OS-SPECIFIC
+ # File::Find seems to always be Unixy except on MacPerl :(
+ my $current_directory= $Is_MacPerl ? $Curdir : '.';
+ find(sub {
+ my ($mode,$size,$atime,$mtime) = (stat)[2,7,8,9];
+
+ return if !-f _;
+ my $origfile = $_;
+
+ return if $origfile eq ".exists";
+ my $targetdir = File::Spec->catdir($targetroot, $File::Find::dir);
+ my $targetfile = File::Spec->catfile($targetdir, $origfile);
+ my $sourcedir = File::Spec->catdir($source, $File::Find::dir);
+ my $sourcefile = File::Spec->catfile($sourcedir, $origfile);
+
+ for my $pat (@$skip) {
+ if ( $sourcefile=~/$pat/ ) {
+ print "Skipping $targetfile (filtered)\n"
+ if $verbose>1;
+ $result->{install_filtered}{$sourcefile} = $pat;
+ return;
+ }
+ }
+ # we have to do this for back compat with old File::Finds
+ # and because the target is relative
+ my $save_cwd = _chdir($cwd);
+ my $diff = 0;
+ # XXX: I wonder how useful this logic is actually -- demerphq
+ if ( $always_copy or !-f $targetfile or -s $targetfile != $size) {
+ $diff++;
+ } else {
+ # we might not need to copy this file
+ $diff = compare($sourcefile, $targetfile);
+ }
+ $check_dirs{$targetdir}++
+ unless -w $targetfile;
+
+ push @found_files,
+ [ $diff, $File::Find::dir, $origfile,
+ $mode, $size, $atime, $mtime,
+ $targetdir, $targetfile, $sourcedir, $sourcefile,
+
+ ];
+ #restore the original directory we were in when File::Find
+ #called us so that it doesnt get horribly confused.
+ _chdir($save_cwd);
+ }, $current_directory );
+ _chdir($cwd);
+ }
+ foreach my $targetdir (sort keys %check_dirs) {
+ _mkpath( $targetdir, 0, 0755, $verbose, $dry_run );
+ }
+ foreach my $found (@found_files) {
+ my ($diff, $ffd, $origfile, $mode, $size, $atime, $mtime,
+ $targetdir, $targetfile, $sourcedir, $sourcefile)= @$found;
+
+ my $realtarget= $targetfile;
+ if ($diff) {
+ eval {
+ if (-f $targetfile) {
+ print "_unlink_or_rename($targetfile)\n" if $verbose>1;
+ $targetfile= _unlink_or_rename( $targetfile, 'tryhard', 'install' )
+ unless $dry_run;
+ } elsif ( ! -d $targetdir ) {
+ _mkpath( $targetdir, 0, 0755, $verbose, $dry_run );
+ }
+ print "Installing $targetfile\n";
+
+ _copy( $sourcefile, $targetfile, $verbose, $dry_run, );
+
+
+ #XXX OS-SPECIFIC
+ print "utime($atime,$mtime,$targetfile)\n" if $verbose>1;
+ utime($atime,$mtime + $Is_VMS,$targetfile) unless $dry_run>1;
+
+
+ $mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
+ $mode = $mode | 0222
+ if $realtarget ne $targetfile;
+ _chmod( $mode, $targetfile, $verbose );
+ $result->{install}{$targetfile} = $sourcefile;
+ 1
+ } or do {
+ $result->{install_fail}{$targetfile} = $sourcefile;
+ die $@;
+ };
+ } else {
+ $result->{install_unchanged}{$targetfile} = $sourcefile;
+ print "Skipping $targetfile (unchanged)\n" if $verbose;
+ }
+
+ if ( $uninstall_shadows ) {
+ inc_uninstall($sourcefile,$ffd, $verbose,
+ $dry_run,
+ $realtarget ne $targetfile ? $realtarget : "",
+ $result);
+ }
+
+ # Record the full pathname.
+ $packlist->{$targetfile}++;
+ }
+
+ if ($pack{'write'}) {
+ $dir = install_rooted_dir(dirname($pack{'write'}));
+ _mkpath( $dir, 0, 0755, $verbose, $dry_run );
+ print "Writing $pack{'write'}\n" if $verbose;
+ $packlist->write(install_rooted_file($pack{'write'})) unless $dry_run;
+ }
+
+ _do_cleanup($verbose);
+ return $result;
+}
+
+=begin _private
+
+=item _do_cleanup
+
+Standardize finish event for after another instruction has occured.
+Handles converting $MUST_REBOOT to a die for instance.
+
+=end _private
+
+=cut
+
+sub _do_cleanup {
+ my ($verbose) = @_;
+ if ($MUST_REBOOT) {
+ die _estr "Operation not completed! ",
+ "You must reboot to complete the installation.",
+ "Sorry.";
+ } elsif (defined $MUST_REBOOT & $verbose) {
+ warn _estr "Installation will be completed at the next reboot.\n",
+ "However it is not necessary to reboot immediately.\n";
+ }
+}
+
+=begin _undocumented
+
+=item install_rooted_file( $file )
+
+Returns $file, or catfile($INSTALL_ROOT,$file) if $INSTALL_ROOT
+is defined.
+
+=item install_rooted_dir( $dir )
+
+Returns $dir, or catdir($INSTALL_ROOT,$dir) if $INSTALL_ROOT
+is defined.
+
+=end _undocumented
+
+=cut
+
+
+sub install_rooted_file {
+ if (defined $INSTALL_ROOT) {
+ File::Spec->catfile($INSTALL_ROOT, $_[0]);
+ } else {
+ $_[0];
+ }
+}
+
+
+sub install_rooted_dir {
+ if (defined $INSTALL_ROOT) {
+ File::Spec->catdir($INSTALL_ROOT, $_[0]);
+ } else {
+ $_[0];
+ }
+}
+
+=begin _undocumented
+
+=item forceunlink( $file, $tryhard )
+
+Tries to delete a file. If $tryhard is true then we will use whatever
+devious tricks we can to delete the file. Currently this only applies to
+Win32 in that it will try to use Win32API::File to schedule a delete at
+reboot. A wrapper for _unlink_or_rename().
+
+=end _undocumented
+
+=cut
+
+
+sub forceunlink {
+ my ( $file, $tryhard )= @_; #XXX OS-SPECIFIC
+ _unlink_or_rename( $file, $tryhard, not("installing") );
+}
+
+=begin _undocumented
+
+=item directory_not_empty( $dir )
+
+Returns 1 if there is an .exists file somewhere in a directory tree.
+Returns 0 if there is not.
+
+=end _undocumented
+
+=cut
+
+sub directory_not_empty ($) {
+ my($dir) = @_;
+ my $files = 0;
+ find(sub {
+ return if $_ eq ".exists";
+ if (-f) {
+ $File::Find::prune++;
+ $files = 1;
+ }
+ }, $dir);
+ return $files;
+}
+
+=pod
+
+=item B<install_default> I<DISCOURAGED>
+
+ install_default();
+ install_default($fullext);
+
+Calls install() with arguments to copy a module from blib/ to the
+default site installation location.
+
+$fullext is the name of the module converted to a directory
+(ie. Foo::Bar would be Foo/Bar). If $fullext is not specified, it
+will attempt to read it from @ARGV.
+
+This is primarily useful for install scripts.
+
+B<NOTE> This function is not really useful because of the hard-coded
+install location with no way to control site vs core vs vendor
+directories and the strange way in which the module name is given.
+Consider its use discouraged.
+
+=cut
+
+sub install_default {
+ @_ < 2 or Carp::croak("install_default should be called with 0 or 1 argument");
+ my $FULLEXT = @_ ? shift : $ARGV[0];
+ defined $FULLEXT or die "Do not know to where to write install log";
+ my $INST_LIB = File::Spec->catdir($Curdir,"blib","lib");
+ my $INST_ARCHLIB = File::Spec->catdir($Curdir,"blib","arch");
+ my $INST_BIN = File::Spec->catdir($Curdir,'blib','bin');
+ my $INST_SCRIPT = File::Spec->catdir($Curdir,'blib','script');
+ my $INST_MAN1DIR = File::Spec->catdir($Curdir,'blib','man1');
+ my $INST_MAN3DIR = File::Spec->catdir($Curdir,'blib','man3');
+
+ my @INST_HTML;
+ if($Config{installhtmldir}) {
+ my $INST_HTMLDIR = File::Spec->catdir($Curdir,'blib','html');
+ @INST_HTML = ($INST_HTMLDIR => $Config{installhtmldir});
+ }
+
+ install({
+ read => "$Config{sitearchexp}/auto/$FULLEXT/.packlist",
+ write => "$Config{installsitearch}/auto/$FULLEXT/.packlist",
+ $INST_LIB => (directory_not_empty($INST_ARCHLIB)) ?
+ $Config{installsitearch} :
+ $Config{installsitelib},
+ $INST_ARCHLIB => $Config{installsitearch},
+ $INST_BIN => $Config{installbin} ,
+ $INST_SCRIPT => $Config{installscript},
+ $INST_MAN1DIR => $Config{installman1dir},
+ $INST_MAN3DIR => $Config{installman3dir},
+ @INST_HTML,
+ },1,0,0);
+}
+
+
+=item B<uninstall>
+
+ uninstall($packlist_file);
+ uninstall($packlist_file, $verbose, $dont_execute);
+
+Removes the files listed in a $packlist_file.
+
+If $verbose is true, will print out each file removed. Default is
+false.
+
+If $dont_execute is true it will only print what it was going to do
+without actually doing it. Default is false.
+
+=cut
+
+sub uninstall {
+ my($fil,$verbose,$dry_run) = @_;
+ $verbose ||= 0;
+ $dry_run ||= 0;
+
+ die _estr "ERROR: no packlist file found: '$fil'"
+ unless -f $fil;
+ # my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al));
+ # require $my_req; # Hairy, but for the first
+ my ($packlist) = ExtUtils::Packlist->new($fil);
+ foreach (sort(keys(%$packlist))) {
+ chomp;
+ print "unlink $_\n" if $verbose;
+ forceunlink($_,'tryhard') unless $dry_run;
+ }
+ print "unlink $fil\n" if $verbose;
+ forceunlink($fil, 'tryhard') unless $dry_run;
+ _do_cleanup($verbose);
+}
+
+=begin _undocumented
+
+=item inc_uninstall($filepath,$libdir,$verbose,$dry_run,$ignore,$results)
+
+Remove shadowed files. If $ignore is true then it is assumed to hold
+a filename to ignore. This is used to prevent spurious warnings from
+occuring when doing an install at reboot.
+
+We now only die when failing to remove a file that has precedence over
+our own, when our install has precedence we only warn.
+
+$results is assumed to contain a hashref which will have the keys
+'uninstall' and 'uninstall_fail' populated with keys for the files
+removed and values of the source files they would shadow.
+
+=end _undocumented
+
+=cut
+
+sub inc_uninstall {
+ my($filepath,$libdir,$verbose,$dry_run,$ignore,$results) = @_;
+ my($dir);
+ $ignore||="";
+ my $file = (File::Spec->splitpath($filepath))[2];
+ my %seen_dir = ();
+
+ my @PERL_ENV_LIB = split $Config{path_sep}, defined $ENV{'PERL5LIB'}
+ ? $ENV{'PERL5LIB'} : $ENV{'PERLLIB'} || '';
+
+ my @dirs=( @PERL_ENV_LIB,
+ @INC,
+ @Config{qw(archlibexp
+ privlibexp
+ sitearchexp
+ sitelibexp)});
+
+ #warn join "\n","---", at dirs,"---";
+ my $seen_ours;
+ foreach $dir ( @dirs ) {
+ my $canonpath = $Is_VMS ? $dir : File::Spec->canonpath($dir);
+ next if $canonpath eq $Curdir;
+ next if $seen_dir{$canonpath}++;
+ my $targetfile = File::Spec->catfile($canonpath,$libdir,$file);
+ next unless -f $targetfile;
+
+ # The reason why we compare file's contents is, that we cannot
+ # know, which is the file we just installed (AFS). So we leave
+ # an identical file in place
+ my $diff = 0;
+ if ( -f $targetfile && -s _ == -s $filepath) {
+ # We have a good chance, we can skip this one
+ $diff = compare($filepath,$targetfile);
+ } else {
+ $diff++;
+ }
+ print "#$file and $targetfile differ\n" if $diff && $verbose > 1;
+
+ if (!$diff or $targetfile eq $ignore) {
+ $seen_ours = 1;
+ next;
+ }
+ if ($dry_run) {
+ $results->{uninstall}{$targetfile} = $filepath;
+ if ($verbose) {
+ $Inc_uninstall_warn_handler ||= ExtUtils::Install::Warn->new();
+ $libdir =~ s|^\./||s ; # That's just cosmetics, no need to port. It looks prettier.
+ $Inc_uninstall_warn_handler->add(
+ File::Spec->catfile($libdir, $file),
+ $targetfile
+ );
+ }
+ # if not verbose, we just say nothing
+ } else {
+ print "Unlinking $targetfile (shadowing?)\n" if $verbose;
+ eval {
+ die "Fake die for testing"
+ if $ExtUtils::Install::Testing and
+ ucase(File::Spec->canonpath($ExtUtils::Install::Testing)) eq ucase($targetfile);
+ forceunlink($targetfile,'tryhard');
+ $results->{uninstall}{$targetfile} = $filepath;
+ 1;
+ } or do {
+ $results->{fail_uninstall}{$targetfile} = $filepath;
+ if ($seen_ours) {
+ warn "Failed to remove probably harmless shadow file '$targetfile'\n";
+ } else {
+ die "$@\n";
+ }
+ };
+ }
+ }
+}
+
+=begin _undocumented
+
+=item run_filter($cmd,$src,$dest)
+
+Filter $src using $cmd into $dest.
+
+=end _undocumented
+
+=cut
+
+sub run_filter {
+ my ($cmd, $src, $dest) = @_;
+ local(*CMD, *SRC);
+ open(CMD, "|$cmd >$dest") || die "Cannot fork: $!";
+ open(SRC, $src) || die "Cannot open $src: $!";
+ my $buf;
+ my $sz = 1024;
+ while (my $len = sysread(SRC, $buf, $sz)) {
+ syswrite(CMD, $buf, $len);
+ }
+ close SRC;
+ close CMD or die "Filter command '$cmd' failed for $src";
+}
+
+=pod
+
+=item B<pm_to_blib>
+
+ pm_to_blib(\%from_to, $autosplit_dir);
+ pm_to_blib(\%from_to, $autosplit_dir, $filter_cmd);
+
+Copies each key of %from_to to its corresponding value efficiently.
+Filenames with the extension .pm are autosplit into the $autosplit_dir.
+Any destination directories are created.
+
+$filter_cmd is an optional shell command to run each .pm file through
+prior to splitting and copying. Input is the contents of the module,
+output the new module contents.
+
+You can have an environment variable PERL_INSTALL_ROOT set which will
+be prepended as a directory to each installed file (and directory).
+
+=cut
+
+sub pm_to_blib {
+ my($fromto,$autodir,$pm_filter) = @_;
+
+ _mkpath($autodir,0,0755);
+ while(my($from, $to) = each %$fromto) {
+ if( -f $to && -s $from == -s $to && -M $to < -M $from ) {
+ print "Skip $to (unchanged)\n";
+ next;
+ }
+
+ # When a pm_filter is defined, we need to pre-process the source first
+ # to determine whether it has changed or not. Therefore, only perform
+ # the comparison check when there's no filter to be ran.
+ # -- RAM, 03/01/2001
+
+ my $need_filtering = defined $pm_filter && length $pm_filter &&
+ $from =~ /\.pm$/;
+
+ if (!$need_filtering && 0 == compare($from,$to)) {
+ print "Skip $to (unchanged)\n";
+ next;
+ }
+ if (-f $to){
+ # we wont try hard here. its too likely to mess things up.
+ forceunlink($to);
+ } else {
+ _mkpath(dirname($to),0,0755);
+ }
+ if ($need_filtering) {
+ run_filter($pm_filter, $from, $to);
+ print "$pm_filter <$from >$to\n";
+ } else {
+ _copy( $from, $to );
+ print "cp $from $to\n";
+ }
+ my($mode,$atime,$mtime) = (stat $from)[2,8,9];
+ utime($atime,$mtime+$Is_VMS,$to);
+ _chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$to);
+ next unless $from =~ /\.pm$/;
+ _autosplit($to,$autodir);
+ }
+}
+
+
+=begin _private
+
+=item _autosplit
+
+From 1.0307 back, AutoSplit will sometimes leave an open filehandle to
+the file being split. This causes problems on systems with mandatory
+locking (ie. Windows). So we wrap it and close the filehandle.
+
+=end _private
+
+=cut
+
+sub _autosplit { #XXX OS-SPECIFIC
+ my $retval = autosplit(@_);
+ close *AutoSplit::IN if defined *AutoSplit::IN{IO};
+
+ return $retval;
+}
+
+
+package ExtUtils::Install::Warn;
+
+sub new { bless {}, shift }
+
+sub add {
+ my($self,$file,$targetfile) = @_;
+ push @{$self->{$file}}, $targetfile;
+}
+
+sub DESTROY {
+ unless(defined $INSTALL_ROOT) {
+ my $self = shift;
+ my($file,$i,$plural);
+ foreach $file (sort keys %$self) {
+ $plural = @{$self->{$file}} > 1 ? "s" : "";
+ print "## Differing version$plural of $file found. You might like to\n";
+ for (0..$#{$self->{$file}}) {
+ print "rm ", $self->{$file}[$_], "\n";
+ $i++;
+ }
+ }
+ $plural = $i>1 ? "all those files" : "this file";
+ my $inst = (_invokant() eq 'ExtUtils::MakeMaker')
+ ? ( $Config::Config{make} || 'make' ).' install'
+ . ( $Is_VMS ? '/MACRO="UNINST"=1' : ' UNINST=1' )
+ : './Build install uninst=1';
+ print "## Running '$inst' will unlink $plural for you.\n";
+ }
+}
+
+=begin _private
+
+=item _invokant
+
+Does a heuristic on the stack to see who called us for more intelligent
+error messages. Currently assumes we will be called only by Module::Build
+or by ExtUtils::MakeMaker.
+
+=end _private
+
+=cut
+
+sub _invokant {
+ my @stack;
+ my $frame = 0;
+ while (my $file = (caller($frame++))[1]) {
+ push @stack, (File::Spec->splitpath($file))[2];
+ }
+
+ my $builder;
+ my $top = pop @stack;
+ if ($top =~ /^Build/i || exists($INC{'Module/Build.pm'})) {
+ $builder = 'Module::Build';
+ } else {
+ $builder = 'ExtUtils::MakeMaker';
+ }
+ return $builder;
+}
+
+=pod
+
+=back
+
+=head1 ENVIRONMENT
+
+=over 4
+
+=item B<PERL_INSTALL_ROOT>
+
+Will be prepended to each install path.
+
+=item B<EU_INSTALL_IGNORE_SKIP>
+
+Will prevent the automatic use of INSTALL.SKIP as the install skip file.
+
+=item B<EU_INSTALL_SITE_SKIPFILE>
+
+If there is no INSTALL.SKIP file in the make directory then this value
+can be used to provide a default.
+
+=item B<EU_INSTALL_ALWAYS_COPY>
+
+If this environment variable is true then normal install processes will
+always overwrite older identical files during the install process.
+
+Note that the alias EU_ALWAYS_COPY will be supported if EU_INSTALL_ALWAYS_COPY
+is not defined until at least the 1.50 release. Please ensure you use the
+correct EU_INSTALL_ALWAYS_COPY.
+
+=back
+
+=head1 AUTHOR
+
+Original author lost in the mists of time. Probably the same as Makemaker.
+
+Production release currently maintained by demerphq C<yves at cpan.org>,
+extensive changes by Michael G. Schwern.
+
+Send bug reports via http://rt.cpan.org/. Please send your
+generated Makefile along with your report.
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
+
+=cut
+
+1;
Copied: trunk/contrib/perl/lib/ExtUtils/Installed.pm (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/Installed.pm)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/Installed.pm (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/Installed.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,462 @@
+package ExtUtils::Installed;
+
+use 5.00503;
+use strict;
+#use warnings; # XXX requires 5.6
+use Carp qw();
+use ExtUtils::Packlist;
+use ExtUtils::MakeMaker;
+use Config;
+use File::Find;
+use File::Basename;
+use File::Spec;
+
+my $Is_VMS = $^O eq 'VMS';
+my $DOSISH = ($^O =~ /^(MSWin\d\d|os2|dos|mint)$/);
+
+require VMS::Filespec if $Is_VMS;
+
+use vars qw($VERSION);
+$VERSION = '1.999_001';
+$VERSION = eval $VERSION;
+
+sub _is_prefix {
+ my ($self, $path, $prefix) = @_;
+ return unless defined $prefix && defined $path;
+
+ if( $Is_VMS ) {
+ $prefix = VMS::Filespec::unixify($prefix);
+ $path = VMS::Filespec::unixify($path);
+ }
+
+ # Unix path normalization.
+ $prefix = File::Spec->canonpath($prefix);
+
+ return 1 if substr($path, 0, length($prefix)) eq $prefix;
+
+ if ($DOSISH) {
+ $path =~ s|\\|/|g;
+ $prefix =~ s|\\|/|g;
+ return 1 if $path =~ m{^\Q$prefix\E}i;
+ }
+ return(0);
+}
+
+sub _is_doc {
+ my ($self, $path) = @_;
+
+ my $man1dir = $self->{':private:'}{Config}{man1direxp};
+ my $man3dir = $self->{':private:'}{Config}{man3direxp};
+ return(($man1dir && $self->_is_prefix($path, $man1dir))
+ ||
+ ($man3dir && $self->_is_prefix($path, $man3dir))
+ ? 1 : 0)
+}
+
+sub _is_type {
+ my ($self, $path, $type) = @_;
+ return 1 if $type eq "all";
+
+ return($self->_is_doc($path)) if $type eq "doc";
+ my $conf= $self->{':private:'}{Config};
+ if ($type eq "prog") {
+ return($self->_is_prefix($path, $conf->{prefix} || $conf->{prefixexp})
+ && !($self->_is_doc($path)) ? 1 : 0);
+ }
+ return(0);
+}
+
+sub _is_under {
+ my ($self, $path, @under) = @_;
+ $under[0] = "" if (! @under);
+ foreach my $dir (@under) {
+ return(1) if ($self->_is_prefix($path, $dir));
+ }
+
+ return(0);
+}
+
+sub _fix_dirs {
+ my ($self, @dirs)= @_;
+ # File::Find does not know how to deal with VMS filepaths.
+ if( $Is_VMS ) {
+ $_ = VMS::Filespec::unixify($_)
+ for @dirs;
+ }
+
+ if ($DOSISH) {
+ s|\\|/|g for @dirs;
+ }
+ return wantarray ? @dirs : $dirs[0];
+}
+
+sub _make_entry {
+ my ($self, $module, $packlist_file, $modfile)= @_;
+
+ my $data= {
+ module => $module,
+ packlist => scalar(ExtUtils::Packlist->new($packlist_file)),
+ packlist_file => $packlist_file,
+ };
+
+ if (!$modfile) {
+ $data->{version} = $self->{':private:'}{Config}{version};
+ } else {
+ $data->{modfile} = $modfile;
+ # Find the top-level module file in @INC
+ $data->{version} = '';
+ foreach my $dir (@{$self->{':private:'}{INC}}) {
+ my $p = File::Spec->catfile($dir, $modfile);
+ if (-r $p) {
+ $module = _module_name($p, $module) if $Is_VMS;
+
+ $data->{version} = MM->parse_version($p);
+ $data->{version_from} = $p;
+ $data->{packlist_valid} = exists $data->{packlist}{$p};
+ last;
+ }
+ }
+ }
+ $self->{$module}= $data;
+}
+
+our $INSTALLED;
+sub new {
+ my ($class) = shift(@_);
+ $class = ref($class) || $class;
+
+ my %args = @_;
+
+ return $INSTALLED if $INSTALLED and ($args{default_get} || $args{default});
+
+ my $self = bless {}, $class;
+
+ $INSTALLED= $self if $args{default_set} || $args{default};
+
+
+ if ($args{config_override}) {
+ eval {
+ $self->{':private:'}{Config} = { %{$args{config_override}} };
+ } or Carp::croak(
+ "The 'config_override' parameter must be a hash reference."
+ );
+ }
+ else {
+ $self->{':private:'}{Config} = \%Config;
+ }
+
+ for my $tuple ([inc_override => INC => [ @INC ] ],
+ [ extra_libs => EXTRA => [] ])
+ {
+ my ($arg,$key,$val)=@$tuple;
+ if ( $args{$arg} ) {
+ eval {
+ $self->{':private:'}{$key} = [ @{$args{$arg}} ];
+ } or Carp::croak(
+ "The '$arg' parameter must be an array reference."
+ );
+ }
+ elsif ($val) {
+ $self->{':private:'}{$key} = $val;
+ }
+ }
+ {
+ my %dupe;
+ @{$self->{':private:'}{LIBDIRS}} = grep { -e $_ && !$dupe{$_}++ }
+ @{$self->{':private:'}{EXTRA}}, @{$self->{':private:'}{INC}};
+ }
+
+ my @dirs= $self->_fix_dirs(@{$self->{':private:'}{LIBDIRS}});
+
+ # Read the core packlist
+ my $archlib = $self->_fix_dirs($self->{':private:'}{Config}{archlibexp});
+ $self->_make_entry("Perl",File::Spec->catfile($archlib, '.packlist'));
+
+ my $root;
+ # Read the module packlists
+ my $sub = sub {
+ # Only process module .packlists
+ return if $_ ne ".packlist" || $File::Find::dir eq $archlib;
+
+ # Hack of the leading bits of the paths & convert to a module name
+ my $module = $File::Find::name;
+ my $found = $module =~ s!^.*?/auto/(.*)/.packlist!$1!s
+ or do {
+ # warn "Woah! \$_=$_\n\$module=$module\n\$File::Find::dir=$File::Find::dir\n",
+ # join ("\n", at dirs);
+ return;
+ };
+
+ my $modfile = "$module.pm";
+ $module =~ s!/!::!g;
+
+ return if $self->{$module}; #shadowing?
+ $self->_make_entry($module,$File::Find::name,$modfile);
+ };
+ while (@dirs) {
+ $root= shift @dirs;
+ next if !-d $root;
+ find($sub,$root);
+ }
+
+ return $self;
+}
+
+# VMS's non-case preserving file-system means the package name can't
+# be reconstructed from the filename.
+sub _module_name {
+ my($file, $orig_module) = @_;
+
+ my $module = '';
+ if (open PACKFH, $file) {
+ while (<PACKFH>) {
+ if (/package\s+(\S+)\s*;/) {
+ my $pack = $1;
+ # Make a sanity check, that lower case $module
+ # is identical to lowercase $pack before
+ # accepting it
+ if (lc($pack) eq lc($orig_module)) {
+ $module = $pack;
+ last;
+ }
+ }
+ }
+ close PACKFH;
+ }
+
+ print STDERR "Couldn't figure out the package name for $file\n"
+ unless $module;
+
+ return $module;
+}
+
+sub modules {
+ my ($self) = @_;
+ $self= $self->new(default=>1) if !ref $self;
+
+ # Bug/feature of sort in scalar context requires this.
+ return wantarray
+ ? sort grep { not /^:private:$/ } keys %$self
+ : grep { not /^:private:$/ } keys %$self;
+}
+
+sub files {
+ my ($self, $module, $type, @under) = @_;
+ $self= $self->new(default=>1) if !ref $self;
+
+ # Validate arguments
+ Carp::croak("$module is not installed") if (! exists($self->{$module}));
+ $type = "all" if (! defined($type));
+ Carp::croak('type must be "all", "prog" or "doc"')
+ if ($type ne "all" && $type ne "prog" && $type ne "doc");
+
+ my (@files);
+ foreach my $file (keys(%{$self->{$module}{packlist}})) {
+ push(@files, $file)
+ if ($self->_is_type($file, $type) &&
+ $self->_is_under($file, @under));
+ }
+ return(@files);
+}
+
+sub directories {
+ my ($self, $module, $type, @under) = @_;
+ $self= $self->new(default=>1) if !ref $self;
+ my (%dirs);
+ foreach my $file ($self->files($module, $type, @under)) {
+ $dirs{dirname($file)}++;
+ }
+ return sort keys %dirs;
+}
+
+sub directory_tree {
+ my ($self, $module, $type, @under) = @_;
+ $self= $self->new(default=>1) if !ref $self;
+ my (%dirs);
+ foreach my $dir ($self->directories($module, $type, @under)) {
+ $dirs{$dir}++;
+ my ($last) = ("");
+ while ($last ne $dir) {
+ $last = $dir;
+ $dir = dirname($dir);
+ last if !$self->_is_under($dir, @under);
+ $dirs{$dir}++;
+ }
+ }
+ return(sort(keys(%dirs)));
+}
+
+sub validate {
+ my ($self, $module, $remove) = @_;
+ $self= $self->new(default=>1) if !ref $self;
+ Carp::croak("$module is not installed") if (! exists($self->{$module}));
+ return($self->{$module}{packlist}->validate($remove));
+}
+
+sub packlist {
+ my ($self, $module) = @_;
+ $self= $self->new(default=>1) if !ref $self;
+ Carp::croak("$module is not installed") if (! exists($self->{$module}));
+ return($self->{$module}{packlist});
+}
+
+sub version {
+ my ($self, $module) = @_;
+ $self= $self->new(default=>1) if !ref $self;
+ Carp::croak("$module is not installed") if (! exists($self->{$module}));
+ return($self->{$module}{version});
+}
+
+sub debug_dump {
+ my ($self, $module) = @_;
+ $self= $self->new(default=>1) if !ref $self;
+ local $self->{":private:"}{Config};
+ require Data::Dumper;
+ print Data::Dumper->new([$self])->Sortkeys(1)->Indent(1)->Dump();
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+ExtUtils::Installed - Inventory management of installed modules
+
+=head1 SYNOPSIS
+
+ use ExtUtils::Installed;
+ my ($inst) = ExtUtils::Installed->new();
+ my (@modules) = $inst->modules();
+ my (@missing) = $inst->validate("DBI");
+ my $all_files = $inst->files("DBI");
+ my $files_below_usr_local = $inst->files("DBI", "all", "/usr/local");
+ my $all_dirs = $inst->directories("DBI");
+ my $dirs_below_usr_local = $inst->directory_tree("DBI", "prog");
+ my $packlist = $inst->packlist("DBI");
+
+=head1 DESCRIPTION
+
+ExtUtils::Installed provides a standard way to find out what core and module
+files have been installed. It uses the information stored in .packlist files
+created during installation to provide this information. In addition it
+provides facilities to classify the installed files and to extract directory
+information from the .packlist files.
+
+=head1 USAGE
+
+The new() function searches for all the installed .packlists on the system, and
+stores their contents. The .packlists can be queried with the functions
+described below. Where it searches by default is determined by the settings found
+in C<%Config::Config>, and what the value is of the PERL5LIB environment variable.
+
+=head1 METHODS
+
+Unless specified otherwise all method can be called as class methods, or as object
+methods. If called as class methods then the "default" object will be used, and if
+necessary created using the current processes %Config and @INC. See the
+'default' option to new() for details.
+
+
+=over 4
+
+=item new()
+
+This takes optional named parameters. Without parameters, this
+searches for all the installed .packlists on the system using
+information from C<%Config::Config> and the default module search
+paths C<@INC>. The packlists are read using the
+L<ExtUtils::Packlist> module.
+
+If the named parameter C<config_override> is specified,
+it should be a reference to a hash which contains all information
+usually found in C<%Config::Config>. For example, you can obtain
+the configuration information for a separate perl installation and
+pass that in.
+
+ my $yoda_cfg = get_fake_config('yoda');
+ my $yoda_inst = ExtUtils::Installed->new(config_override=>$yoda_cfg);
+
+Similarly, the parameter C<inc_override> may be a reference to an
+array which is used in place of the default module search paths
+from C<@INC>.
+
+ use Config;
+ my @dirs = split(/\Q$Config{path_sep}\E/, $ENV{PERL5LIB});
+ my $p5libs = ExtUtils::Installed->new(inc_override=>\@dirs);
+
+B<Note>: You probably do not want to use these options alone, almost always
+you will want to set both together.
+
+The parameter c<extra_libs> can be used to specify B<additional> paths to
+search for installed modules. For instance
+
+ my $installed = ExtUtils::Installed->new(extra_libs=>["/my/lib/path"]);
+
+This should only be necessary if C</my/lib/path> is not in PERL5LIB.
+
+Finally there is the 'default', and the related 'default_get' and 'default_set'
+options. These options control the "default" object which is provided by the
+class interface to the methods. Setting C<default_get> to true tells the constructor
+to return the default object if it is defined. Setting C<default_set> to true tells
+the constructor to make the default object the constructed object. Setting the
+C<default> option is like setting both to true. This is used primarily internally
+and probably isn't interesting to any real user.
+
+=item modules()
+
+This returns a list of the names of all the installed modules. The perl 'core'
+is given the special name 'Perl'.
+
+=item files()
+
+This takes one mandatory parameter, the name of a module. It returns a list of
+all the filenames from the package. To obtain a list of core perl files, use
+the module name 'Perl'. Additional parameters are allowed. The first is one
+of the strings "prog", "doc" or "all", to select either just program files,
+just manual files or all files. The remaining parameters are a list of
+directories. The filenames returned will be restricted to those under the
+specified directories.
+
+=item directories()
+
+This takes one mandatory parameter, the name of a module. It returns a list of
+all the directories from the package. Additional parameters are allowed. The
+first is one of the strings "prog", "doc" or "all", to select either just
+program directories, just manual directories or all directories. The remaining
+parameters are a list of directories. The directories returned will be
+restricted to those under the specified directories. This method returns only
+the leaf directories that contain files from the specified module.
+
+=item directory_tree()
+
+This is identical in operation to directories(), except that it includes all the
+intermediate directories back up to the specified directories.
+
+=item validate()
+
+This takes one mandatory parameter, the name of a module. It checks that all
+the files listed in the modules .packlist actually exist, and returns a list of
+any missing files. If an optional second argument which evaluates to true is
+given any missing files will be removed from the .packlist
+
+=item packlist()
+
+This returns the ExtUtils::Packlist object for the specified module.
+
+=item version()
+
+This returns the version number for the specified module.
+
+=back
+
+=head1 EXAMPLE
+
+See the example in L<ExtUtils::Packlist>.
+
+=head1 AUTHOR
+
+Alan Burlison <Alan.Burlison at uk.sun.com>
+
+=cut
Copied: trunk/contrib/perl/lib/ExtUtils/Liblist.pm (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/Liblist.pm)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/Liblist.pm (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/Liblist.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,286 @@
+package ExtUtils::Liblist;
+
+use strict;
+
+our $VERSION = '6.55_02';
+
+use File::Spec;
+require ExtUtils::Liblist::Kid;
+our @ISA = qw(ExtUtils::Liblist::Kid File::Spec);
+
+# Backwards compatibility with old interface.
+sub ext {
+ goto &ExtUtils::Liblist::Kid::ext;
+}
+
+sub lsdir {
+ shift;
+ my $rex = qr/$_[1]/;
+ opendir DIR, $_[0];
+ my @out = grep /$rex/, readdir DIR;
+ closedir DIR;
+ return @out;
+}
+
+__END__
+
+=head1 NAME
+
+ExtUtils::Liblist - determine libraries to use and how to use them
+
+=head1 SYNOPSIS
+
+ require ExtUtils::Liblist;
+
+ $MM->ext($potential_libs, $verbose, $need_names);
+
+ # Usually you can get away with:
+ ExtUtils::Liblist->ext($potential_libs, $verbose, $need_names)
+
+=head1 DESCRIPTION
+
+This utility takes a list of libraries in the form C<-llib1 -llib2
+-llib3> and returns lines suitable for inclusion in an extension
+Makefile. Extra library paths may be included with the form
+C<-L/another/path> this will affect the searches for all subsequent
+libraries.
+
+It returns an array of four or five scalar values: EXTRALIBS,
+BSLOADLIBS, LDLOADLIBS, LD_RUN_PATH, and, optionally, a reference to
+the array of the filenames of actual libraries. Some of these don't
+mean anything unless on Unix. See the details about those platform
+specifics below. The list of the filenames is returned only if
+$need_names argument is true.
+
+Dependent libraries can be linked in one of three ways:
+
+=over 2
+
+=item * For static extensions
+
+by the ld command when the perl binary is linked with the extension
+library. See EXTRALIBS below.
+
+=item * For dynamic extensions at build/link time
+
+by the ld command when the shared object is built/linked. See
+LDLOADLIBS below.
+
+=item * For dynamic extensions at load time
+
+by the DynaLoader when the shared object is loaded. See BSLOADLIBS
+below.
+
+=back
+
+=head2 EXTRALIBS
+
+List of libraries that need to be linked with when linking a perl
+binary which includes this extension. Only those libraries that
+actually exist are included. These are written to a file and used
+when linking perl.
+
+=head2 LDLOADLIBS and LD_RUN_PATH
+
+List of those libraries which can or must be linked into the shared
+library when created using ld. These may be static or dynamic
+libraries. LD_RUN_PATH is a colon separated list of the directories
+in LDLOADLIBS. It is passed as an environment variable to the process
+that links the shared library.
+
+=head2 BSLOADLIBS
+
+List of those libraries that are needed but can be linked in
+dynamically at run time on this platform. SunOS/Solaris does not need
+this because ld records the information (from LDLOADLIBS) into the
+object file. This list is used to create a .bs (bootstrap) file.
+
+=head1 PORTABILITY
+
+This module deals with a lot of system dependencies and has quite a
+few architecture specific C<if>s in the code.
+
+=head2 VMS implementation
+
+The version of ext() which is executed under VMS differs from the
+Unix-OS/2 version in several respects:
+
+=over 2
+
+=item *
+
+Input library and path specifications are accepted with or without the
+C<-l> and C<-L> prefixes used by Unix linkers. If neither prefix is
+present, a token is considered a directory to search if it is in fact
+a directory, and a library to search for otherwise. Authors who wish
+their extensions to be portable to Unix or OS/2 should use the Unix
+prefixes, since the Unix-OS/2 version of ext() requires them.
+
+=item *
+
+Wherever possible, shareable images are preferred to object libraries,
+and object libraries to plain object files. In accordance with VMS
+naming conventions, ext() looks for files named I<lib>shr and I<lib>rtl;
+it also looks for I<lib>lib and libI<lib> to accommodate Unix conventions
+used in some ported software.
+
+=item *
+
+For each library that is found, an appropriate directive for a linker options
+file is generated. The return values are space-separated strings of
+these directives, rather than elements used on the linker command line.
+
+=item *
+
+LDLOADLIBS contains both the libraries found based on C<$potential_libs> and
+the CRTLs, if any, specified in Config.pm. EXTRALIBS contains just those
+libraries found based on C<$potential_libs>. BSLOADLIBS and LD_RUN_PATH
+are always empty.
+
+=back
+
+In addition, an attempt is made to recognize several common Unix library
+names, and filter them out or convert them to their VMS equivalents, as
+appropriate.
+
+In general, the VMS version of ext() should properly handle input from
+extensions originally designed for a Unix or VMS environment. If you
+encounter problems, or discover cases where the search could be improved,
+please let us know.
+
+=head2 Win32 implementation
+
+The version of ext() which is executed under Win32 differs from the
+Unix-OS/2 version in several respects:
+
+=over 2
+
+=item *
+
+If C<$potential_libs> is empty, the return value will be empty.
+Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm)
+will be appended to the list of C<$potential_libs>. The libraries
+will be searched for in the directories specified in C<$potential_libs>,
+C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>.
+For each library that is found, a space-separated list of fully qualified
+library pathnames is generated.
+
+=item *
+
+Input library and path specifications are accepted with or without the
+C<-l> and C<-L> prefixes used by Unix linkers.
+
+An entry of the form C<-La:\foo> specifies the C<a:\foo> directory to look
+for the libraries that follow.
+
+An entry of the form C<-lfoo> specifies the library C<foo>, which may be
+spelled differently depending on what kind of compiler you are using. If
+you are using GCC, it gets translated to C<libfoo.a>, but for other win32
+compilers, it becomes C<foo.lib>. If no files are found by those translated
+names, one more attempt is made to find them using either C<foo.a> or
+C<libfoo.lib>, depending on whether GCC or some other win32 compiler is
+being used, respectively.
+
+If neither the C<-L> or C<-l> prefix is present in an entry, the entry is
+considered a directory to search if it is in fact a directory, and a
+library to search for otherwise. The C<$Config{lib_ext}> suffix will
+be appended to any entries that are not directories and don't already have
+the suffix.
+
+Note that the C<-L> and C<-l> prefixes are B<not required>, but authors
+who wish their extensions to be portable to Unix or OS/2 should use the
+prefixes, since the Unix-OS/2 version of ext() requires them.
+
+=item *
+
+Entries cannot be plain object files, as many Win32 compilers will
+not handle object files in the place of libraries.
+
+=item *
+
+Entries in C<$potential_libs> beginning with a colon and followed by
+alphanumeric characters are treated as flags. Unknown flags will be ignored.
+
+An entry that matches C</:nodefault/i> disables the appending of default
+libraries found in C<$Config{perllibs}> (this should be only needed very rarely).
+
+An entry that matches C</:nosearch/i> disables all searching for
+the libraries specified after it. Translation of C<-Lfoo> and
+C<-lfoo> still happens as appropriate (depending on compiler being used,
+as reflected by C<$Config{cc}>), but the entries are not verified to be
+valid files or directories.
+
+An entry that matches C</:search/i> reenables searching for
+the libraries specified after it. You can put it at the end to
+enable searching for default libraries specified by C<$Config{perllibs}>.
+
+=item *
+
+The libraries specified may be a mixture of static libraries and
+import libraries (to link with DLLs). Since both kinds are used
+pretty transparently on the Win32 platform, we do not attempt to
+distinguish between them.
+
+=item *
+
+LDLOADLIBS and EXTRALIBS are always identical under Win32, and BSLOADLIBS
+and LD_RUN_PATH are always empty (this may change in future).
+
+=item *
+
+You must make sure that any paths and path components are properly
+surrounded with double-quotes if they contain spaces. For example,
+C<$potential_libs> could be (literally):
+
+ "-Lc:\Program Files\vc\lib" msvcrt.lib "la test\foo bar.lib"
+
+Note how the first and last entries are protected by quotes in order
+to protect the spaces.
+
+=item *
+
+Since this module is most often used only indirectly from extension
+C<Makefile.PL> files, here is an example C<Makefile.PL> entry to add
+a library to the build process for an extension:
+
+ LIBS => ['-lgl']
+
+When using GCC, that entry specifies that MakeMaker should first look
+for C<libgl.a> (followed by C<gl.a>) in all the locations specified by
+C<$Config{libpth}>.
+
+When using a compiler other than GCC, the above entry will search for
+C<gl.lib> (followed by C<libgl.lib>).
+
+If the library happens to be in a location not in C<$Config{libpth}>,
+you need:
+
+ LIBS => ['-Lc:\gllibs -lgl']
+
+Here is a less often used example:
+
+ LIBS => ['-lgl', ':nosearch -Ld:\mesalibs -lmesa -luser32']
+
+This specifies a search for library C<gl> as before. If that search
+fails to find the library, it looks at the next item in the list. The
+C<:nosearch> flag will prevent searching for the libraries that follow,
+so it simply returns the value as C<-Ld:\mesalibs -lmesa -luser32>,
+since GCC can use that value as is with its linker.
+
+When using the Visual C compiler, the second item is returned as
+C<-libpath:d:\mesalibs mesa.lib user32.lib>.
+
+When using the Borland compiler, the second item is returned as
+C<-Ld:\mesalibs mesa.lib user32.lib>, and MakeMaker takes care of
+moving the C<-Ld:\mesalibs> to the correct place in the linker
+command line.
+
+=back
+
+
+=head1 SEE ALSO
+
+L<ExtUtils::MakeMaker>
+
+=cut
+
Copied: trunk/contrib/perl/lib/ExtUtils/MANIFEST.SKIP (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/MANIFEST.SKIP)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/MANIFEST.SKIP (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/MANIFEST.SKIP 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,32 @@
+# Avoid version control files.
+\bRCS\b
+\bCVS\b
+\bSCCS\b
+,v$
+\B\.svn\b
+\B\.git\b
+\B\.gitignore\b
+\b_darcs\b
+
+# Avoid Makemaker generated and utility files.
+\bMANIFEST\.bak
+\bMakefile$
+\bblib/
+\bMakeMaker-\d
+\bpm_to_blib\.ts$
+\bpm_to_blib$
+\bblibdirs\.ts$ # 6.18 through 6.25 generated this
+
+# Avoid Module::Build generated and utility files.
+\bBuild$
+\b_build/
+
+# Avoid temp and backup files.
+~$
+\.old$
+\#$
+\b\.#
+\.bak$
+
+# Avoid Devel::Cover files.
+\bcover_db\b
Copied: trunk/contrib/perl/lib/ExtUtils/MM.pm (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/MM.pm)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/MM.pm (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/MM.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,90 @@
+package ExtUtils::MM;
+
+use strict;
+use ExtUtils::MakeMaker::Config;
+
+our $VERSION = '6.55_02';
+
+require ExtUtils::Liblist;
+require ExtUtils::MakeMaker;
+our @ISA = qw(ExtUtils::Liblist ExtUtils::MakeMaker);
+
+=head1 NAME
+
+ExtUtils::MM - OS adjusted ExtUtils::MakeMaker subclass
+
+=head1 SYNOPSIS
+
+ require ExtUtils::MM;
+ my $mm = MM->new(...);
+
+=head1 DESCRIPTION
+
+B<FOR INTERNAL USE ONLY>
+
+ExtUtils::MM is a subclass of ExtUtils::MakeMaker which automatically
+chooses the appropriate OS specific subclass for you
+(ie. ExtUils::MM_Unix, etc...).
+
+It also provides a convenient alias via the MM class (I didn't want
+MakeMaker modules outside of ExtUtils/).
+
+This class might turn out to be a temporary solution, but MM won't go
+away.
+
+=cut
+
+{
+ # Convenient alias.
+ package MM;
+ our @ISA = qw(ExtUtils::MM);
+ sub DESTROY {}
+}
+
+sub _is_win95 {
+ # miniperl might not have the Win32 functions available and we need
+ # to run in miniperl.
+ my $have_win32 = eval { require Win32 };
+ return $have_win32 && defined &Win32::IsWin95 ? Win32::IsWin95()
+ : ! defined $ENV{SYSTEMROOT};
+}
+
+my %Is = ();
+$Is{VMS} = $^O eq 'VMS';
+$Is{OS2} = $^O eq 'os2';
+$Is{MacOS} = $^O eq 'MacOS';
+if( $^O eq 'MSWin32' ) {
+ _is_win95() ? $Is{Win95} = 1 : $Is{Win32} = 1;
+}
+$Is{UWIN} = $^O =~ /^uwin(-nt)?$/;
+$Is{Cygwin} = $^O eq 'cygwin';
+$Is{NW5} = $Config{osname} eq 'NetWare'; # intentional
+$Is{BeOS} = ($^O =~ /beos/i or $^O eq 'haiku');
+$Is{DOS} = $^O eq 'dos';
+if( $Is{NW5} ) {
+ $^O = 'NetWare';
+ delete $Is{Win32};
+}
+$Is{VOS} = $^O eq 'vos';
+$Is{QNX} = $^O eq 'qnx';
+$Is{AIX} = $^O eq 'aix';
+$Is{Darwin} = $^O eq 'darwin';
+
+$Is{Unix} = !grep { $_ } values %Is;
+
+map { delete $Is{$_} unless $Is{$_} } keys %Is;
+_assert( keys %Is == 1 );
+my($OS) = keys %Is;
+
+
+my $class = "ExtUtils::MM_$OS";
+eval "require $class" unless $INC{"ExtUtils/MM_$OS.pm"}; ## no critic
+die $@ if $@;
+unshift @ISA, $class;
+
+
+sub _assert {
+ my $sanity = shift;
+ die sprintf "Assert failed at %s line %d\n", (caller)[1,2] unless $sanity;
+ return;
+}
Copied: trunk/contrib/perl/lib/ExtUtils/MM_AIX.pm (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/MM_AIX.pm)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/MM_AIX.pm (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/MM_AIX.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,79 @@
+package ExtUtils::MM_AIX;
+
+use strict;
+our $VERSION = '6.55_02';
+
+require ExtUtils::MM_Unix;
+our @ISA = qw(ExtUtils::MM_Unix);
+
+use ExtUtils::MakeMaker qw(neatvalue);
+
+
+=head1 NAME
+
+ExtUtils::MM_AIX - AIX specific subclass of ExtUtils::MM_Unix
+
+=head1 SYNOPSIS
+
+ Don't use this module directly.
+ Use ExtUtils::MM and let it choose.
+
+=head1 DESCRIPTION
+
+This is a subclass of ExtUtils::MM_Unix which contains functionality for
+AIX.
+
+Unless otherwise stated it works just like ExtUtils::MM_Unix
+
+=head2 Overridden methods
+
+=head3 dlsyms
+
+Define DL_FUNCS and DL_VARS and write the *.exp files.
+
+=cut
+
+sub dlsyms {
+ my($self,%attribs) = @_;
+
+ return '' unless $self->needs_linking();
+
+ my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {};
+ my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || [];
+ my($funclist) = $attribs{FUNCLIST} || $self->{FUNCLIST} || [];
+ my(@m);
+
+ push(@m,"
+dynamic :: $self->{BASEEXT}.exp
+
+") unless $self->{SKIPHASH}{'dynamic'}; # dynamic and static are subs, so...
+
+ push(@m,"
+static :: $self->{BASEEXT}.exp
+
+") unless $self->{SKIPHASH}{'static'}; # we avoid a warning if we tick them
+
+ push(@m,"
+$self->{BASEEXT}.exp: Makefile.PL
+",' $(PERLRUN) -e \'use ExtUtils::Mksymlists; \\
+ Mksymlists("NAME" => "',$self->{NAME},'", "DL_FUNCS" => ',
+ neatvalue($funcs), ', "FUNCLIST" => ', neatvalue($funclist),
+ ', "DL_VARS" => ', neatvalue($vars), ');\'
+');
+
+ join('', at m);
+}
+
+
+=head1 AUTHOR
+
+Michael G Schwern <schwern at pobox.com> with code from ExtUtils::MM_Unix
+
+=head1 SEE ALSO
+
+L<ExtUtils::MakeMaker>
+
+=cut
+
+
+1;
Copied: trunk/contrib/perl/lib/ExtUtils/MM_Any.pm (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/MM_Any.pm)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/MM_Any.pm (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/MM_Any.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,2332 @@
+package ExtUtils::MM_Any;
+
+use strict;
+our $VERSION = '6.55_02';
+
+use Carp;
+use File::Spec;
+use File::Basename;
+BEGIN { our @ISA = qw(File::Spec); }
+
+# We need $Verbose
+use ExtUtils::MakeMaker qw($Verbose);
+
+use ExtUtils::MakeMaker::Config;
+
+
+# So we don't have to keep calling the methods over and over again,
+# we have these globals to cache the values. Faster and shrtr.
+my $Curdir = __PACKAGE__->curdir;
+my $Rootdir = __PACKAGE__->rootdir;
+my $Updir = __PACKAGE__->updir;
+
+
+=head1 NAME
+
+ExtUtils::MM_Any - Platform-agnostic MM methods
+
+=head1 SYNOPSIS
+
+ FOR INTERNAL USE ONLY!
+
+ package ExtUtils::MM_SomeOS;
+
+ # Temporarily, you have to subclass both. Put MM_Any first.
+ require ExtUtils::MM_Any;
+ require ExtUtils::MM_Unix;
+ @ISA = qw(ExtUtils::MM_Any ExtUtils::Unix);
+
+=head1 DESCRIPTION
+
+B<FOR INTERNAL USE ONLY!>
+
+ExtUtils::MM_Any is a superclass for the ExtUtils::MM_* set of
+modules. It contains methods which are either inherently
+cross-platform or are written in a cross-platform manner.
+
+Subclass off of ExtUtils::MM_Any I<and> ExtUtils::MM_Unix. This is a
+temporary solution.
+
+B<THIS MAY BE TEMPORARY!>
+
+
+=head1 METHODS
+
+Any methods marked I<Abstract> must be implemented by subclasses.
+
+
+=head2 Cross-platform helper methods
+
+These are methods which help writing cross-platform code.
+
+
+
+=head3 os_flavor I<Abstract>
+
+ my @os_flavor = $mm->os_flavor;
+
+ at os_flavor is the style of operating system this is, usually
+corresponding to the MM_*.pm file we're using.
+
+The first element of @os_flavor is the major family (ie. Unix,
+Windows, VMS, OS/2, etc...) and the rest are sub families.
+
+Some examples:
+
+ Cygwin98 ('Unix', 'Cygwin', 'Cygwin9x')
+ Windows ('Win32')
+ Win98 ('Win32', 'Win9x')
+ Linux ('Unix', 'Linux')
+ MacOS X ('Unix', 'Darwin', 'MacOS', 'MacOS X')
+ OS/2 ('OS/2')
+
+This is used to write code for styles of operating system.
+See os_flavor_is() for use.
+
+
+=head3 os_flavor_is
+
+ my $is_this_flavor = $mm->os_flavor_is($this_flavor);
+ my $is_this_flavor = $mm->os_flavor_is(@one_of_these_flavors);
+
+Checks to see if the current operating system is one of the given flavors.
+
+This is useful for code like:
+
+ if( $mm->os_flavor_is('Unix') ) {
+ $out = `foo 2>&1`;
+ }
+ else {
+ $out = `foo`;
+ }
+
+=cut
+
+sub os_flavor_is {
+ my $self = shift;
+ my %flavors = map { ($_ => 1) } $self->os_flavor;
+ return (grep { $flavors{$_} } @_) ? 1 : 0;
+}
+
+
+=head3 can_load_xs
+
+ my $can_load_xs = $self->can_load_xs;
+
+Returns true if we have the ability to load XS.
+
+This is important because miniperl, used to build XS modules in the
+core, can not load XS.
+
+=cut
+
+sub can_load_xs {
+ return defined &DynaLoader::boot_DynaLoader ? 1 : 0;
+}
+
+
+=head3 split_command
+
+ my @cmds = $MM->split_command($cmd, @args);
+
+Most OS have a maximum command length they can execute at once. Large
+modules can easily generate commands well past that limit. Its
+necessary to split long commands up into a series of shorter commands.
+
+C<split_command> will return a series of @cmds each processing part of
+the args. Collectively they will process all the arguments. Each
+individual line in @cmds will not be longer than the
+$self->max_exec_len being careful to take into account macro expansion.
+
+$cmd should include any switches and repeated initial arguments.
+
+If no @args are given, no @cmds will be returned.
+
+Pairs of arguments will always be preserved in a single command, this
+is a heuristic for things like pm_to_blib and pod2man which work on
+pairs of arguments. This makes things like this safe:
+
+ $self->split_command($cmd, %pod2man);
+
+
+=cut
+
+sub split_command {
+ my($self, $cmd, @args) = @_;
+
+ my @cmds = ();
+ return(@cmds) unless @args;
+
+ # If the command was given as a here-doc, there's probably a trailing
+ # newline.
+ chomp $cmd;
+
+ # set aside 30% for macro expansion.
+ my $len_left = int($self->max_exec_len * 0.70);
+ $len_left -= length $self->_expand_macros($cmd);
+
+ do {
+ my $arg_str = '';
+ my @next_args;
+ while( @next_args = splice(@args, 0, 2) ) {
+ # Two at a time to preserve pairs.
+ my $next_arg_str = "\t ". join ' ', @next_args, "\n";
+
+ if( !length $arg_str ) {
+ $arg_str .= $next_arg_str
+ }
+ elsif( length($arg_str) + length($next_arg_str) > $len_left ) {
+ unshift @args, @next_args;
+ last;
+ }
+ else {
+ $arg_str .= $next_arg_str;
+ }
+ }
+ chop $arg_str;
+
+ push @cmds, $self->escape_newlines("$cmd \n$arg_str");
+ } while @args;
+
+ return @cmds;
+}
+
+
+sub _expand_macros {
+ my($self, $cmd) = @_;
+
+ $cmd =~ s{\$\((\w+)\)}{
+ defined $self->{$1} ? $self->{$1} : "\$($1)"
+ }e;
+ return $cmd;
+}
+
+
+=head3 echo
+
+ my @commands = $MM->echo($text);
+ my @commands = $MM->echo($text, $file);
+ my @commands = $MM->echo($text, $file, $appending);
+
+Generates a set of @commands which print the $text to a $file.
+
+If $file is not given, output goes to STDOUT.
+
+If $appending is true the $file will be appended to rather than
+overwritten.
+
+=cut
+
+sub echo {
+ my($self, $text, $file, $appending) = @_;
+ $appending ||= 0;
+
+ my @cmds = map { '$(NOECHO) $(ECHO) '.$self->quote_literal($_) }
+ split /\n/, $text;
+ if( $file ) {
+ my $redirect = $appending ? '>>' : '>';
+ $cmds[0] .= " $redirect $file";
+ $_ .= " >> $file" foreach @cmds[1..$#cmds];
+ }
+
+ return @cmds;
+}
+
+
+=head3 wraplist
+
+ my $args = $mm->wraplist(@list);
+
+Takes an array of items and turns them into a well-formatted list of
+arguments. In most cases this is simply something like:
+
+ FOO \
+ BAR \
+ BAZ
+
+=cut
+
+sub wraplist {
+ my $self = shift;
+ return join " \\\n\t", @_;
+}
+
+
+=head3 maketext_filter
+
+ my $filter_make_text = $mm->maketext_filter($make_text);
+
+The text of the Makefile is run through this method before writing to
+disk. It allows systems a chance to make portability fixes to the
+Makefile.
+
+By default it does nothing.
+
+This method is protected and not intended to be called outside of
+MakeMaker.
+
+=cut
+
+sub maketext_filter { return $_[1] }
+
+
+=head3 cd I<Abstract>
+
+ my $subdir_cmd = $MM->cd($subdir, @cmds);
+
+This will generate a make fragment which runs the @cmds in the given
+$dir. The rough equivalent to this, except cross platform.
+
+ cd $subdir && $cmd
+
+Currently $dir can only go down one level. "foo" is fine. "foo/bar" is
+not. "../foo" is right out.
+
+The resulting $subdir_cmd has no leading tab nor trailing newline. This
+makes it easier to embed in a make string. For example.
+
+ my $make = sprintf <<'CODE', $subdir_cmd;
+ foo :
+ $(ECHO) what
+ %s
+ $(ECHO) mouche
+ CODE
+
+
+=head3 oneliner I<Abstract>
+
+ my $oneliner = $MM->oneliner($perl_code);
+ my $oneliner = $MM->oneliner($perl_code, \@switches);
+
+This will generate a perl one-liner safe for the particular platform
+you're on based on the given $perl_code and @switches (a -e is
+assumed) suitable for using in a make target. It will use the proper
+shell quoting and escapes.
+
+$(PERLRUN) will be used as perl.
+
+Any newlines in $perl_code will be escaped. Leading and trailing
+newlines will be stripped. Makes this idiom much easier:
+
+ my $code = $MM->oneliner(<<'CODE', [...switches...]);
+some code here
+another line here
+CODE
+
+Usage might be something like:
+
+ # an echo emulation
+ $oneliner = $MM->oneliner('print "Foo\n"');
+ $make = '$oneliner > somefile';
+
+All dollar signs must be doubled in the $perl_code if you expect them
+to be interpreted normally, otherwise it will be considered a make
+macro. Also remember to quote make macros else it might be used as a
+bareword. For example:
+
+ # Assign the value of the $(VERSION_FROM) make macro to $vf.
+ $oneliner = $MM->oneliner('$$vf = "$(VERSION_FROM)"');
+
+Its currently very simple and may be expanded sometime in the figure
+to include more flexible code and switches.
+
+
+=head3 quote_literal I<Abstract>
+
+ my $safe_text = $MM->quote_literal($text);
+
+This will quote $text so it is interpreted literally in the shell.
+
+For example, on Unix this would escape any single-quotes in $text and
+put single-quotes around the whole thing.
+
+
+=head3 escape_newlines I<Abstract>
+
+ my $escaped_text = $MM->escape_newlines($text);
+
+Shell escapes newlines in $text.
+
+
+=head3 max_exec_len I<Abstract>
+
+ my $max_exec_len = $MM->max_exec_len;
+
+Calculates the maximum command size the OS can exec. Effectively,
+this is the max size of a shell command line.
+
+=for _private
+$self->{_MAX_EXEC_LEN} is set by this method, but only for testing purposes.
+
+
+=head3 make
+
+ my $make = $MM->make;
+
+Returns the make variant we're generating the Makefile for. This attempts
+to do some normalization on the information from %Config or the user.
+
+=cut
+
+sub make {
+ my $self = shift;
+
+ my $make = lc $self->{MAKE};
+
+ # Truncate anything like foomake6 to just foomake.
+ $make =~ s/^(\w+make).*/$1/;
+
+ # Turn gnumake into gmake.
+ $make =~ s/^gnu/g/;
+
+ return $make;
+}
+
+
+=head2 Targets
+
+These are methods which produce make targets.
+
+
+=head3 all_target
+
+Generate the default target 'all'.
+
+=cut
+
+sub all_target {
+ my $self = shift;
+
+ return <<'MAKE_EXT';
+all :: pure_all
+ $(NOECHO) $(NOOP)
+MAKE_EXT
+
+}
+
+
+=head3 blibdirs_target
+
+ my $make_frag = $mm->blibdirs_target;
+
+Creates the blibdirs target which creates all the directories we use
+in blib/.
+
+The blibdirs.ts target is deprecated. Depend on blibdirs instead.
+
+
+=cut
+
+sub blibdirs_target {
+ my $self = shift;
+
+ my @dirs = map { uc "\$(INST_$_)" } qw(libdir archlib
+ autodir archautodir
+ bin script
+ man1dir man3dir
+ );
+
+ my @exists = map { $_.'$(DFSEP).exists' } @dirs;
+
+ my $make = sprintf <<'MAKE', join(' ', @exists);
+blibdirs : %s
+ $(NOECHO) $(NOOP)
+
+# Backwards compat with 6.18 through 6.25
+blibdirs.ts : blibdirs
+ $(NOECHO) $(NOOP)
+
+MAKE
+
+ $make .= $self->dir_target(@dirs);
+
+ return $make;
+}
+
+
+=head3 clean (o)
+
+Defines the clean target.
+
+=cut
+
+sub clean {
+# --- Cleanup and Distribution Sections ---
+
+ my($self, %attribs) = @_;
+ my @m;
+ push(@m, '
+# Delete temporary files but do not touch installed files. We don\'t delete
+# the Makefile here so a later make realclean still has a makefile to use.
+
+clean :: clean_subdirs
+');
+
+ my @files = values %{$self->{XS}}; # .c files from *.xs files
+ my @dirs = qw(blib);
+
+ # Normally these are all under blib but they might have been
+ # redefined.
+ # XXX normally this would be a good idea, but the Perl core sets
+ # INST_LIB = ../../lib rather than actually installing the files.
+ # So a "make clean" in an ext/ directory would blow away lib.
+ # Until the core is adjusted let's leave this out.
+# push @dirs, qw($(INST_ARCHLIB) $(INST_LIB)
+# $(INST_BIN) $(INST_SCRIPT)
+# $(INST_MAN1DIR) $(INST_MAN3DIR)
+# $(INST_LIBDIR) $(INST_ARCHLIBDIR) $(INST_AUTODIR)
+# $(INST_STATIC) $(INST_DYNAMIC) $(INST_BOOT)
+# );
+
+
+ if( $attribs{FILES} ) {
+ # Use @dirs because we don't know what's in here.
+ push @dirs, ref $attribs{FILES} ?
+ @{$attribs{FILES}} :
+ split /\s+/, $attribs{FILES} ;
+ }
+
+ push(@files, qw[$(MAKE_APERL_FILE)
+ perlmain.c tmon.out mon.out so_locations
+ blibdirs.ts pm_to_blib pm_to_blib.ts
+ *$(OBJ_EXT) *$(LIB_EXT) perl.exe perl perl$(EXE_EXT)
+ $(BOOTSTRAP) $(BASEEXT).bso
+ $(BASEEXT).def lib$(BASEEXT).def
+ $(BASEEXT).exp $(BASEEXT).x
+ ]);
+
+ push(@files, $self->catfile('$(INST_ARCHAUTODIR)','extralibs.all'));
+ push(@files, $self->catfile('$(INST_ARCHAUTODIR)','extralibs.ld'));
+
+ # core files
+ push(@files, qw[core core.*perl.*.? *perl.core]);
+ push(@files, map { "core." . "[0-9]"x$_ } (1..5));
+
+ # OS specific things to clean up. Use @dirs since we don't know
+ # what might be in here.
+ push @dirs, $self->extra_clean_files;
+
+ # Occasionally files are repeated several times from different sources
+ { my(%f) = map { ($_ => 1) } @files; @files = keys %f; }
+ { my(%d) = map { ($_ => 1) } @dirs; @dirs = keys %d; }
+
+ push @m, map "\t$_\n", $self->split_command('- $(RM_F)', @files);
+ push @m, map "\t$_\n", $self->split_command('- $(RM_RF)', @dirs);
+
+ # Leave Makefile.old around for realclean
+ push @m, <<'MAKE';
+ - $(MV) $(FIRST_MAKEFILE) $(MAKEFILE_OLD) $(DEV_NULL)
+MAKE
+
+ push(@m, "\t$attribs{POSTOP}\n") if $attribs{POSTOP};
+
+ join("", @m);
+}
+
+
+=head3 clean_subdirs_target
+
+ my $make_frag = $MM->clean_subdirs_target;
+
+Returns the clean_subdirs target. This is used by the clean target to
+call clean on any subdirectories which contain Makefiles.
+
+=cut
+
+sub clean_subdirs_target {
+ my($self) = shift;
+
+ # No subdirectories, no cleaning.
+ return <<'NOOP_FRAG' unless @{$self->{DIR}};
+clean_subdirs :
+ $(NOECHO) $(NOOP)
+NOOP_FRAG
+
+
+ my $clean = "clean_subdirs :\n";
+
+ for my $dir (@{$self->{DIR}}) {
+ my $subclean = $self->oneliner(sprintf <<'CODE', $dir);
+chdir '%s'; system '$(MAKE) clean' if -f '$(FIRST_MAKEFILE)';
+CODE
+
+ $clean .= "\t$subclean\n";
+ }
+
+ return $clean;
+}
+
+
+=head3 dir_target
+
+ my $make_frag = $mm->dir_target(@directories);
+
+Generates targets to create the specified directories and set its
+permission to PERM_DIR.
+
+Because depending on a directory to just ensure it exists doesn't work
+too well (the modified time changes too often) dir_target() creates a
+.exists file in the created directory. It is this you should depend on.
+For portability purposes you should use the $(DIRFILESEP) macro rather
+than a '/' to seperate the directory from the file.
+
+ yourdirectory$(DIRFILESEP).exists
+
+=cut
+
+sub dir_target {
+ my($self, @dirs) = @_;
+
+ my $make = '';
+ foreach my $dir (@dirs) {
+ $make .= sprintf <<'MAKE', ($dir) x 7;
+%s$(DFSEP).exists :: Makefile.PL
+ $(NOECHO) $(MKPATH) %s
+ $(NOECHO) $(CHMOD) $(PERM_DIR) %s
+ $(NOECHO) $(TOUCH) %s$(DFSEP).exists
+
+MAKE
+
+ }
+
+ return $make;
+}
+
+
+=head3 distdir
+
+Defines the scratch directory target that will hold the distribution
+before tar-ing (or shar-ing).
+
+=cut
+
+# For backwards compatibility.
+*dist_dir = *distdir;
+
+sub distdir {
+ my($self) = shift;
+
+ my $meta_target = $self->{NO_META} ? '' : 'distmeta';
+ my $sign_target = !$self->{SIGN} ? '' : 'distsignature';
+
+ return sprintf <<'MAKE_FRAG', $meta_target, $sign_target;
+create_distdir :
+ $(RM_RF) $(DISTVNAME)
+ $(PERLRUN) "-MExtUtils::Manifest=manicopy,maniread" \
+ -e "manicopy(maniread(),'$(DISTVNAME)', '$(DIST_CP)');"
+
+distdir : create_distdir %s %s
+ $(NOECHO) $(NOOP)
+
+MAKE_FRAG
+
+}
+
+
+=head3 dist_test
+
+Defines a target that produces the distribution in the
+scratchdirectory, and runs 'perl Makefile.PL; make ;make test' in that
+subdirectory.
+
+=cut
+
+sub dist_test {
+ my($self) = shift;
+
+ my $mpl_args = join " ", map qq["$_"], @ARGV;
+
+ my $test = $self->cd('$(DISTVNAME)',
+ '$(ABSPERLRUN) Makefile.PL '.$mpl_args,
+ '$(MAKE) $(PASTHRU)',
+ '$(MAKE) test $(PASTHRU)'
+ );
+
+ return sprintf <<'MAKE_FRAG', $test;
+disttest : distdir
+ %s
+
+MAKE_FRAG
+
+
+}
+
+
+=head3 dynamic (o)
+
+Defines the dynamic target.
+
+=cut
+
+sub dynamic {
+# --- Dynamic Loading Sections ---
+
+ my($self) = shift;
+ '
+dynamic :: $(FIRST_MAKEFILE) $(INST_DYNAMIC) $(INST_BOOT)
+ $(NOECHO) $(NOOP)
+';
+}
+
+
+=head3 makemakerdflt_target
+
+ my $make_frag = $mm->makemakerdflt_target
+
+Returns a make fragment with the makemakerdeflt_target specified.
+This target is the first target in the Makefile, is the default target
+and simply points off to 'all' just in case any make variant gets
+confused or something gets snuck in before the real 'all' target.
+
+=cut
+
+sub makemakerdflt_target {
+ return <<'MAKE_FRAG';
+makemakerdflt : all
+ $(NOECHO) $(NOOP)
+MAKE_FRAG
+
+}
+
+
+=head3 manifypods_target
+
+ my $manifypods_target = $self->manifypods_target;
+
+Generates the manifypods target. This target generates man pages from
+all POD files in MAN1PODS and MAN3PODS.
+
+=cut
+
+sub manifypods_target {
+ my($self) = shift;
+
+ my $man1pods = '';
+ my $man3pods = '';
+ my $dependencies = '';
+
+ # populate manXpods & dependencies:
+ foreach my $name (keys %{$self->{MAN1PODS}}, keys %{$self->{MAN3PODS}}) {
+ $dependencies .= " \\\n\t$name";
+ }
+
+ my $manify = <<END;
+manifypods : pure_all $dependencies
+END
+
+ my @man_cmds;
+ foreach my $section (qw(1 3)) {
+ my $pods = $self->{"MAN${section}PODS"};
+ push @man_cmds, $self->split_command(<<CMD, %$pods);
+ \$(NOECHO) \$(POD2MAN) --section=$section --perm_rw=\$(PERM_RW)
+CMD
+ }
+
+ $manify .= "\t\$(NOECHO) \$(NOOP)\n" unless @man_cmds;
+ $manify .= join '', map { "$_\n" } @man_cmds;
+
+ return $manify;
+}
+
+
+=head3 metafile_target
+
+ my $target = $mm->metafile_target;
+
+Generate the metafile target.
+
+Writes the file META.yml YAML encoded meta-data about the module in
+the distdir. The format follows Module::Build's as closely as
+possible.
+
+=cut
+
+sub metafile_target {
+ my $self = shift;
+
+ return <<'MAKE_FRAG' if $self->{NO_META};
+metafile :
+ $(NOECHO) $(NOOP)
+MAKE_FRAG
+
+ my @metadata = $self->metafile_data(
+ $self->{META_ADD} || {},
+ $self->{META_MERGE} || {},
+ );
+ my $meta = $self->metafile_file(@metadata);
+ my @write_meta = $self->echo($meta, 'META_new.yml');
+
+ return sprintf <<'MAKE_FRAG', join("\n\t", @write_meta);
+metafile : create_distdir
+ $(NOECHO) $(ECHO) Generating META.yml
+ %s
+ -$(NOECHO) $(MV) META_new.yml $(DISTVNAME)/META.yml
+MAKE_FRAG
+
+}
+
+
+=begin private
+
+=head3 _sort_pairs
+
+ my @pairs = _sort_pairs($sort_sub, \%hash);
+
+Sorts the pairs of a hash based on keys ordered according
+to C<$sort_sub>.
+
+=end private
+
+=cut
+
+sub _sort_pairs {
+ my $sort = shift;
+ my $pairs = shift;
+ return map { $_ => $pairs->{$_} }
+ sort $sort
+ keys %$pairs;
+}
+
+
+# Taken from Module::Build::Base
+sub _hash_merge {
+ my ($self, $h, $k, $v) = @_;
+ if (ref $h->{$k} eq 'ARRAY') {
+ push @{$h->{$k}}, ref $v ? @$v : $v;
+ } elsif (ref $h->{$k} eq 'HASH') {
+ $self->_hash_merge($h->{$k}, $_, $v->{$_}) foreach keys %$v;
+ } else {
+ $h->{$k} = $v;
+ }
+}
+
+
+=head3 metafile_data
+
+ my @metadata_pairs = $mm->metafile_data(\%meta_add, \%meta_merge);
+
+Returns the data which MakeMaker turns into the META.yml file.
+
+Values of %meta_add will overwrite any existing metadata in those
+keys. %meta_merge will be merged with them.
+
+=cut
+
+sub metafile_data {
+ my $self = shift;
+ my($meta_add, $meta_merge) = @_;
+
+ # The order in which standard meta keys should be written.
+ my @meta_order = qw(
+ name
+ version
+ abstract
+ author
+ license
+ distribution_type
+
+ configure_requires
+ build_requires
+ requires
+
+ resources
+
+ provides
+ no_index
+
+ generated_by
+ meta-spec
+ );
+
+ # Check the original args so we can tell between the user setting it
+ # to an empty hash and it just being initialized.
+ my $configure_requires;
+ if( $self->{ARGS}{CONFIGURE_REQUIRES} ) {
+ $configure_requires = $self->{CONFIGURE_REQUIRES};
+ } else {
+ $configure_requires = {
+ 'ExtUtils::MakeMaker' => 0,
+ };
+ }
+ my $build_requires;
+ if( $self->{ARGS}{BUILD_REQUIRES} ) {
+ $build_requires = $self->{BUILD_REQUIRES};
+ } else {
+ $build_requires = {
+ 'ExtUtils::MakeMaker' => 0,
+ };
+ }
+
+ my %meta = (
+ name => $self->{DISTNAME},
+ version => $self->{VERSION},
+ abstract => $self->{ABSTRACT},
+ license => $self->{LICENSE} || 'unknown',
+ distribution_type => $self->{PM} ? 'module' : 'script',
+
+ configure_requires => $configure_requires,
+
+ build_requires => $build_requires,
+
+ no_index => {
+ directory => [qw(t inc)]
+ },
+
+ generated_by => "ExtUtils::MakeMaker version $ExtUtils::MakeMaker::VERSION",
+ 'meta-spec' => {
+ url => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
+ version => 1.4
+ },
+ );
+
+ # The author key is required and it takes a list.
+ $meta{author} = defined $self->{AUTHOR} ? [$self->{AUTHOR}] : [];
+
+ $meta{requires} = $self->{PREREQ_PM} if defined $self->{PREREQ_PM};
+ $meta{requires}{perl} = $self->{MIN_PERL_VERSION} if $self->{MIN_PERL_VERSION};
+
+ while( my($key, $val) = each %$meta_add ) {
+ $meta{$key} = $val;
+ }
+
+ while( my($key, $val) = each %$meta_merge ) {
+ $self->_hash_merge(\%meta, $key, $val);
+ }
+
+ my @meta_pairs;
+
+ # Put the standard keys first in the proper order.
+ for my $key (@meta_order) {
+ next unless exists $meta{$key};
+
+ push @meta_pairs, $key, delete $meta{$key};
+ }
+
+ # Then tack everything else onto the end, alpha sorted.
+ for my $key (sort {lc $a cmp lc $b} keys %meta) {
+ push @meta_pairs, $key, $meta{$key};
+ }
+
+ return @meta_pairs
+}
+
+=begin private
+
+=head3 _dump_hash
+
+ $yaml = _dump_hash(\%options, %hash);
+
+Implements a fake YAML dumper for a hash given
+as a list of pairs. No quoting/escaping is done. Keys
+are supposed to be strings. Values are undef, strings,
+hash refs or array refs of strings.
+
+Supported options are:
+
+ delta => STR - indentation delta
+ use_header => BOOL - whether to include a YAML header
+ indent => STR - a string of spaces
+ default: ''
+
+ max_key_length => INT - maximum key length used to align
+ keys and values of the same hash
+ default: 20
+ key_sort => CODE - a sort sub
+ It may be undef, which means no sorting by keys
+ default: sub { lc $a cmp lc $b }
+
+ customs => HASH - special options for certain keys
+ (whose values are hashes themselves)
+ may contain: max_key_length, key_sort, customs
+
+=end private
+
+=cut
+
+sub _dump_hash {
+ croak "first argument should be a hash ref" unless ref $_[0] eq 'HASH';
+ my $options = shift;
+ my %hash = @_;
+
+ # Use a list to preserve order.
+ my @pairs;
+
+ my $k_sort
+ = exists $options->{key_sort} ? $options->{key_sort}
+ : sub { lc $a cmp lc $b };
+ if ($k_sort) {
+ croak "'key_sort' should be a coderef" unless ref $k_sort eq 'CODE';
+ @pairs = _sort_pairs($k_sort, \%hash);
+ } else { # list of pairs, no sorting
+ @pairs = @_;
+ }
+
+ my $yaml = $options->{use_header} ? "--- #YAML:1.0\n" : '';
+ my $indent = $options->{indent} || '';
+ my $k_length = min(
+ ($options->{max_key_length} || 20),
+ max(map { length($_) + 1 } grep { !ref $hash{$_} } keys %hash)
+ );
+ my $customs = $options->{customs} || {};
+
+ # printf format for key
+ my $k_format = "%-${k_length}s";
+
+ while( @pairs ) {
+ my($key, $val) = splice @pairs, 0, 2;
+ $val = '~' unless defined $val;
+ if(ref $val eq 'HASH') {
+ if ( keys %$val ) {
+ my %k_options = ( # options for recursive call
+ delta => $options->{delta},
+ use_header => 0,
+ indent => $indent . $options->{delta},
+ );
+ if (exists $customs->{$key}) {
+ my %k_custom = %{$customs->{$key}};
+ foreach my $k qw(key_sort max_key_length customs) {
+ $k_options{$k} = $k_custom{$k} if exists $k_custom{$k};
+ }
+ }
+ $yaml .= $indent . "$key:\n"
+ . _dump_hash(\%k_options, %$val);
+ }
+ else {
+ $yaml .= $indent . "$key: {}\n";
+ }
+ }
+ elsif (ref $val eq 'ARRAY') {
+ if( @$val ) {
+ $yaml .= $indent . "$key:\n";
+
+ for (@$val) {
+ croak "only nested arrays of non-refs are supported" if ref $_;
+ $yaml .= $indent . $options->{delta} . "- $_\n";
+ }
+ }
+ else {
+ $yaml .= $indent . "$key: []\n";
+ }
+ }
+ elsif( ref $val and !blessed($val) ) {
+ croak "only nested hashes, arrays and objects are supported";
+ }
+ else { # if it's an object, just stringify it
+ $yaml .= $indent . sprintf "$k_format %s\n", "$key:", $val;
+ }
+ };
+
+ return $yaml;
+
+}
+
+sub blessed {
+ return eval { $_[0]->isa("UNIVERSAL"); };
+}
+
+sub max {
+ return (sort { $b <=> $a } @_)[0];
+}
+
+sub min {
+ return (sort { $a <=> $b } @_)[0];
+}
+
+=head3 metafile_file
+
+ my $meta_yml = $mm->metafile_file(@metadata_pairs);
+
+Turns the @metadata_pairs into YAML.
+
+This method does not implement a complete YAML dumper, being limited
+to dump a hash with values which are strings, undef's or nested hashes
+and arrays of strings. No quoting/escaping is done.
+
+=cut
+
+sub metafile_file {
+ my $self = shift;
+
+ my %dump_options = (
+ use_header => 1,
+ delta => ' ' x 4,
+ key_sort => undef,
+ );
+ return _dump_hash(\%dump_options, @_);
+
+}
+
+
+=head3 distmeta_target
+
+ my $make_frag = $mm->distmeta_target;
+
+Generates the distmeta target to add META.yml to the MANIFEST in the
+distdir.
+
+=cut
+
+sub distmeta_target {
+ my $self = shift;
+
+ my $add_meta = $self->oneliner(<<'CODE', ['-MExtUtils::Manifest=maniadd']);
+eval { maniadd({q{META.yml} => q{Module meta-data (added by MakeMaker)}}) }
+ or print "Could not add META.yml to MANIFEST: $${'@'}\n"
+CODE
+
+ my $add_meta_to_distdir = $self->cd('$(DISTVNAME)', $add_meta);
+
+ return sprintf <<'MAKE', $add_meta_to_distdir;
+distmeta : create_distdir metafile
+ $(NOECHO) %s
+
+MAKE
+
+}
+
+
+=head3 realclean (o)
+
+Defines the realclean target.
+
+=cut
+
+sub realclean {
+ my($self, %attribs) = @_;
+
+ my @dirs = qw($(DISTVNAME));
+ my @files = qw($(FIRST_MAKEFILE) $(MAKEFILE_OLD));
+
+ # Special exception for the perl core where INST_* is not in blib.
+ # This cleans up the files built from the ext/ directory (all XS).
+ if( $self->{PERL_CORE} ) {
+ push @dirs, qw($(INST_AUTODIR) $(INST_ARCHAUTODIR));
+ push @files, values %{$self->{PM}};
+ }
+
+ if( $self->has_link_code ){
+ push @files, qw($(OBJECT));
+ }
+
+ if( $attribs{FILES} ) {
+ if( ref $attribs{FILES} ) {
+ push @dirs, @{ $attribs{FILES} };
+ }
+ else {
+ push @dirs, split /\s+/, $attribs{FILES};
+ }
+ }
+
+ # Occasionally files are repeated several times from different sources
+ { my(%f) = map { ($_ => 1) } @files; @files = keys %f; }
+ { my(%d) = map { ($_ => 1) } @dirs; @dirs = keys %d; }
+
+ my $rm_cmd = join "\n\t", map { "$_" }
+ $self->split_command('- $(RM_F)', @files);
+ my $rmf_cmd = join "\n\t", map { "$_" }
+ $self->split_command('- $(RM_RF)', @dirs);
+
+ my $m = sprintf <<'MAKE', $rm_cmd, $rmf_cmd;
+# Delete temporary files (via clean) and also delete dist files
+realclean purge :: clean realclean_subdirs
+ %s
+ %s
+MAKE
+
+ $m .= "\t$attribs{POSTOP}\n" if $attribs{POSTOP};
+
+ return $m;
+}
+
+
+=head3 realclean_subdirs_target
+
+ my $make_frag = $MM->realclean_subdirs_target;
+
+Returns the realclean_subdirs target. This is used by the realclean
+target to call realclean on any subdirectories which contain Makefiles.
+
+=cut
+
+sub realclean_subdirs_target {
+ my $self = shift;
+
+ return <<'NOOP_FRAG' unless @{$self->{DIR}};
+realclean_subdirs :
+ $(NOECHO) $(NOOP)
+NOOP_FRAG
+
+ my $rclean = "realclean_subdirs :\n";
+
+ foreach my $dir (@{$self->{DIR}}) {
+ foreach my $makefile ('$(MAKEFILE_OLD)', '$(FIRST_MAKEFILE)' ) {
+ my $subrclean .= $self->oneliner(sprintf <<'CODE', $dir, ($makefile) x 2);
+chdir '%s'; system '$(MAKE) $(USEMAKEFILE) %s realclean' if -f '%s';
+CODE
+
+ $rclean .= sprintf <<'RCLEAN', $subrclean;
+ - %s
+RCLEAN
+
+ }
+ }
+
+ return $rclean;
+}
+
+
+=head3 signature_target
+
+ my $target = $mm->signature_target;
+
+Generate the signature target.
+
+Writes the file SIGNATURE with "cpansign -s".
+
+=cut
+
+sub signature_target {
+ my $self = shift;
+
+ return <<'MAKE_FRAG';
+signature :
+ cpansign -s
+MAKE_FRAG
+
+}
+
+
+=head3 distsignature_target
+
+ my $make_frag = $mm->distsignature_target;
+
+Generates the distsignature target to add SIGNATURE to the MANIFEST in the
+distdir.
+
+=cut
+
+sub distsignature_target {
+ my $self = shift;
+
+ my $add_sign = $self->oneliner(<<'CODE', ['-MExtUtils::Manifest=maniadd']);
+eval { maniadd({q{SIGNATURE} => q{Public-key signature (added by MakeMaker)}}) }
+ or print "Could not add SIGNATURE to MANIFEST: $${'@'}\n"
+CODE
+
+ my $sign_dist = $self->cd('$(DISTVNAME)' => 'cpansign -s');
+
+ # cpansign -s complains if SIGNATURE is in the MANIFEST yet does not
+ # exist
+ my $touch_sig = $self->cd('$(DISTVNAME)' => '$(TOUCH) SIGNATURE');
+ my $add_sign_to_dist = $self->cd('$(DISTVNAME)' => $add_sign );
+
+ return sprintf <<'MAKE', $add_sign_to_dist, $touch_sig, $sign_dist
+distsignature : create_distdir
+ $(NOECHO) %s
+ $(NOECHO) %s
+ %s
+
+MAKE
+
+}
+
+
+=head3 special_targets
+
+ my $make_frag = $mm->special_targets
+
+Returns a make fragment containing any targets which have special
+meaning to make. For example, .SUFFIXES and .PHONY.
+
+=cut
+
+sub special_targets {
+ my $make_frag = <<'MAKE_FRAG';
+.SUFFIXES : .xs .c .C .cpp .i .s .cxx .cc $(OBJ_EXT)
+
+.PHONY: all config static dynamic test linkext manifest blibdirs clean realclean disttest distdir
+
+MAKE_FRAG
+
+ $make_frag .= <<'MAKE_FRAG' if $ENV{CLEARCASE_ROOT};
+.NO_CONFIG_REC: Makefile
+
+MAKE_FRAG
+
+ return $make_frag;
+}
+
+
+
+
+=head2 Init methods
+
+Methods which help initialize the MakeMaker object and macros.
+
+
+=head3 init_ABSTRACT
+
+ $mm->init_ABSTRACT
+
+=cut
+
+sub init_ABSTRACT {
+ my $self = shift;
+
+ if( $self->{ABSTRACT_FROM} and $self->{ABSTRACT} ) {
+ warn "Both ABSTRACT_FROM and ABSTRACT are set. ".
+ "Ignoring ABSTRACT_FROM.\n";
+ return;
+ }
+
+ if ($self->{ABSTRACT_FROM}){
+ $self->{ABSTRACT} = $self->parse_abstract($self->{ABSTRACT_FROM}) or
+ carp "WARNING: Setting ABSTRACT via file ".
+ "'$self->{ABSTRACT_FROM}' failed\n";
+ }
+}
+
+=head3 init_INST
+
+ $mm->init_INST;
+
+Called by init_main. Sets up all INST_* variables except those related
+to XS code. Those are handled in init_xs.
+
+=cut
+
+sub init_INST {
+ my($self) = shift;
+
+ $self->{INST_ARCHLIB} ||= $self->catdir($Curdir,"blib","arch");
+ $self->{INST_BIN} ||= $self->catdir($Curdir,'blib','bin');
+
+ # INST_LIB typically pre-set if building an extension after
+ # perl has been built and installed. Setting INST_LIB allows
+ # you to build directly into, say $Config{privlibexp}.
+ unless ($self->{INST_LIB}){
+ if ($self->{PERL_CORE}) {
+ if (defined $Cross::platform) {
+ $self->{INST_LIB} = $self->{INST_ARCHLIB} =
+ $self->catdir($self->{PERL_LIB},"..","xlib",
+ $Cross::platform);
+ }
+ else {
+ $self->{INST_LIB} = $self->{INST_ARCHLIB} = $self->{PERL_LIB};
+ }
+ } else {
+ $self->{INST_LIB} = $self->catdir($Curdir,"blib","lib");
+ }
+ }
+
+ my @parentdir = split(/::/, $self->{PARENT_NAME});
+ $self->{INST_LIBDIR} = $self->catdir('$(INST_LIB)', @parentdir);
+ $self->{INST_ARCHLIBDIR} = $self->catdir('$(INST_ARCHLIB)', @parentdir);
+ $self->{INST_AUTODIR} = $self->catdir('$(INST_LIB)', 'auto',
+ '$(FULLEXT)');
+ $self->{INST_ARCHAUTODIR} = $self->catdir('$(INST_ARCHLIB)', 'auto',
+ '$(FULLEXT)');
+
+ $self->{INST_SCRIPT} ||= $self->catdir($Curdir,'blib','script');
+
+ $self->{INST_MAN1DIR} ||= $self->catdir($Curdir,'blib','man1');
+ $self->{INST_MAN3DIR} ||= $self->catdir($Curdir,'blib','man3');
+
+ return 1;
+}
+
+
+=head3 init_INSTALL
+
+ $mm->init_INSTALL;
+
+Called by init_main. Sets up all INSTALL_* variables (except
+INSTALLDIRS) and *PREFIX.
+
+=cut
+
+sub init_INSTALL {
+ my($self) = shift;
+
+ if( $self->{ARGS}{INSTALL_BASE} and $self->{ARGS}{PREFIX} ) {
+ die "Only one of PREFIX or INSTALL_BASE can be given. Not both.\n";
+ }
+
+ if( $self->{ARGS}{INSTALL_BASE} ) {
+ $self->init_INSTALL_from_INSTALL_BASE;
+ }
+ else {
+ $self->init_INSTALL_from_PREFIX;
+ }
+}
+
+
+=head3 init_INSTALL_from_PREFIX
+
+ $mm->init_INSTALL_from_PREFIX;
+
+=cut
+
+sub init_INSTALL_from_PREFIX {
+ my $self = shift;
+
+ $self->init_lib2arch;
+
+ # There are often no Config.pm defaults for these new man variables so
+ # we fall back to the old behavior which is to use installman*dir
+ foreach my $num (1, 3) {
+ my $k = 'installsiteman'.$num.'dir';
+
+ $self->{uc $k} ||= uc "\$(installman${num}dir)"
+ unless $Config{$k};
+ }
+
+ foreach my $num (1, 3) {
+ my $k = 'installvendorman'.$num.'dir';
+
+ unless( $Config{$k} ) {
+ $self->{uc $k} ||= $Config{usevendorprefix}
+ ? uc "\$(installman${num}dir)"
+ : '';
+ }
+ }
+
+ $self->{INSTALLSITEBIN} ||= '$(INSTALLBIN)'
+ unless $Config{installsitebin};
+ $self->{INSTALLSITESCRIPT} ||= '$(INSTALLSCRIPT)'
+ unless $Config{installsitescript};
+
+ unless( $Config{installvendorbin} ) {
+ $self->{INSTALLVENDORBIN} ||= $Config{usevendorprefix}
+ ? $Config{installbin}
+ : '';
+ }
+ unless( $Config{installvendorscript} ) {
+ $self->{INSTALLVENDORSCRIPT} ||= $Config{usevendorprefix}
+ ? $Config{installscript}
+ : '';
+ }
+
+
+ my $iprefix = $Config{installprefixexp} || $Config{installprefix} ||
+ $Config{prefixexp} || $Config{prefix} || '';
+ my $vprefix = $Config{usevendorprefix} ? $Config{vendorprefixexp} : '';
+ my $sprefix = $Config{siteprefixexp} || '';
+
+ # 5.005_03 doesn't have a siteprefix.
+ $sprefix = $iprefix unless $sprefix;
+
+
+ $self->{PREFIX} ||= '';
+
+ if( $self->{PREFIX} ) {
+ @{$self}{qw(PERLPREFIX SITEPREFIX VENDORPREFIX)} =
+ ('$(PREFIX)') x 3;
+ }
+ else {
+ $self->{PERLPREFIX} ||= $iprefix;
+ $self->{SITEPREFIX} ||= $sprefix;
+ $self->{VENDORPREFIX} ||= $vprefix;
+
+ # Lots of MM extension authors like to use $(PREFIX) so we
+ # put something sensible in there no matter what.
+ $self->{PREFIX} = '$('.uc $self->{INSTALLDIRS}.'PREFIX)';
+ }
+
+ my $arch = $Config{archname};
+ my $version = $Config{version};
+
+ # default style
+ my $libstyle = $Config{installstyle} || 'lib/perl5';
+ my $manstyle = '';
+
+ if( $self->{LIBSTYLE} ) {
+ $libstyle = $self->{LIBSTYLE};
+ $manstyle = $self->{LIBSTYLE} eq 'lib/perl5' ? 'lib/perl5' : '';
+ }
+
+ # Some systems, like VOS, set installman*dir to '' if they can't
+ # read man pages.
+ for my $num (1, 3) {
+ $self->{'INSTALLMAN'.$num.'DIR'} ||= 'none'
+ unless $Config{'installman'.$num.'dir'};
+ }
+
+ my %bin_layouts =
+ (
+ bin => { s => $iprefix,
+ t => 'perl',
+ d => 'bin' },
+ vendorbin => { s => $vprefix,
+ t => 'vendor',
+ d => 'bin' },
+ sitebin => { s => $sprefix,
+ t => 'site',
+ d => 'bin' },
+ script => { s => $iprefix,
+ t => 'perl',
+ d => 'bin' },
+ vendorscript=> { s => $vprefix,
+ t => 'vendor',
+ d => 'bin' },
+ sitescript => { s => $sprefix,
+ t => 'site',
+ d => 'bin' },
+ );
+
+ my %man_layouts =
+ (
+ man1dir => { s => $iprefix,
+ t => 'perl',
+ d => 'man/man1',
+ style => $manstyle, },
+ siteman1dir => { s => $sprefix,
+ t => 'site',
+ d => 'man/man1',
+ style => $manstyle, },
+ vendorman1dir => { s => $vprefix,
+ t => 'vendor',
+ d => 'man/man1',
+ style => $manstyle, },
+
+ man3dir => { s => $iprefix,
+ t => 'perl',
+ d => 'man/man3',
+ style => $manstyle, },
+ siteman3dir => { s => $sprefix,
+ t => 'site',
+ d => 'man/man3',
+ style => $manstyle, },
+ vendorman3dir => { s => $vprefix,
+ t => 'vendor',
+ d => 'man/man3',
+ style => $manstyle, },
+ );
+
+ my %lib_layouts =
+ (
+ privlib => { s => $iprefix,
+ t => 'perl',
+ d => '',
+ style => $libstyle, },
+ vendorlib => { s => $vprefix,
+ t => 'vendor',
+ d => '',
+ style => $libstyle, },
+ sitelib => { s => $sprefix,
+ t => 'site',
+ d => 'site_perl',
+ style => $libstyle, },
+
+ archlib => { s => $iprefix,
+ t => 'perl',
+ d => "$version/$arch",
+ style => $libstyle },
+ vendorarch => { s => $vprefix,
+ t => 'vendor',
+ d => "$version/$arch",
+ style => $libstyle },
+ sitearch => { s => $sprefix,
+ t => 'site',
+ d => "site_perl/$version/$arch",
+ style => $libstyle },
+ );
+
+
+ # Special case for LIB.
+ if( $self->{LIB} ) {
+ foreach my $var (keys %lib_layouts) {
+ my $Installvar = uc "install$var";
+
+ if( $var =~ /arch/ ) {
+ $self->{$Installvar} ||=
+ $self->catdir($self->{LIB}, $Config{archname});
+ }
+ else {
+ $self->{$Installvar} ||= $self->{LIB};
+ }
+ }
+ }
+
+ my %type2prefix = ( perl => 'PERLPREFIX',
+ site => 'SITEPREFIX',
+ vendor => 'VENDORPREFIX'
+ );
+
+ my %layouts = (%bin_layouts, %man_layouts, %lib_layouts);
+ while( my($var, $layout) = each(%layouts) ) {
+ my($s, $t, $d, $style) = @{$layout}{qw(s t d style)};
+ my $r = '$('.$type2prefix{$t}.')';
+
+ print STDERR "Prefixing $var\n" if $Verbose >= 2;
+
+ my $installvar = "install$var";
+ my $Installvar = uc $installvar;
+ next if $self->{$Installvar};
+
+ $d = "$style/$d" if $style;
+ $self->prefixify($installvar, $s, $r, $d);
+
+ print STDERR " $Installvar == $self->{$Installvar}\n"
+ if $Verbose >= 2;
+ }
+
+ # Generate these if they weren't figured out.
+ $self->{VENDORARCHEXP} ||= $self->{INSTALLVENDORARCH};
+ $self->{VENDORLIBEXP} ||= $self->{INSTALLVENDORLIB};
+
+ return 1;
+}
+
+
+=head3 init_from_INSTALL_BASE
+
+ $mm->init_from_INSTALL_BASE
+
+=cut
+
+my %map = (
+ lib => [qw(lib perl5)],
+ arch => [('lib', 'perl5', $Config{archname})],
+ bin => [qw(bin)],
+ man1dir => [qw(man man1)],
+ man3dir => [qw(man man3)]
+ );
+$map{script} = $map{bin};
+
+sub init_INSTALL_from_INSTALL_BASE {
+ my $self = shift;
+
+ @{$self}{qw(PREFIX VENDORPREFIX SITEPREFIX PERLPREFIX)} =
+ '$(INSTALL_BASE)';
+
+ my %install;
+ foreach my $thing (keys %map) {
+ foreach my $dir (('', 'SITE', 'VENDOR')) {
+ my $uc_thing = uc $thing;
+ my $key = "INSTALL".$dir.$uc_thing;
+
+ $install{$key} ||=
+ $self->catdir('$(INSTALL_BASE)', @{$map{$thing}});
+ }
+ }
+
+ # Adjust for variable quirks.
+ $install{INSTALLARCHLIB} ||= delete $install{INSTALLARCH};
+ $install{INSTALLPRIVLIB} ||= delete $install{INSTALLLIB};
+
+ foreach my $key (keys %install) {
+ $self->{$key} ||= $install{$key};
+ }
+
+ return 1;
+}
+
+
+=head3 init_VERSION I<Abstract>
+
+ $mm->init_VERSION
+
+Initialize macros representing versions of MakeMaker and other tools
+
+MAKEMAKER: path to the MakeMaker module.
+
+MM_VERSION: ExtUtils::MakeMaker Version
+
+MM_REVISION: ExtUtils::MakeMaker version control revision (for backwards
+ compat)
+
+VERSION: version of your module
+
+VERSION_MACRO: which macro represents the version (usually 'VERSION')
+
+VERSION_SYM: like version but safe for use as an RCS revision number
+
+DEFINE_VERSION: -D line to set the module version when compiling
+
+XS_VERSION: version in your .xs file. Defaults to $(VERSION)
+
+XS_VERSION_MACRO: which macro represents the XS version.
+
+XS_DEFINE_VERSION: -D line to set the xs version when compiling.
+
+Called by init_main.
+
+=cut
+
+sub init_VERSION {
+ my($self) = shift;
+
+ $self->{MAKEMAKER} = $ExtUtils::MakeMaker::Filename;
+ $self->{MM_VERSION} = $ExtUtils::MakeMaker::VERSION;
+ $self->{MM_REVISION}= $ExtUtils::MakeMaker::Revision;
+ $self->{VERSION_FROM} ||= '';
+
+ if ($self->{VERSION_FROM}){
+ $self->{VERSION} = $self->parse_version($self->{VERSION_FROM});
+ if( $self->{VERSION} eq 'undef' ) {
+ carp("WARNING: Setting VERSION via file ".
+ "'$self->{VERSION_FROM}' failed\n");
+ }
+ }
+
+ # strip blanks
+ if (defined $self->{VERSION}) {
+ $self->{VERSION} =~ s/^\s+//;
+ $self->{VERSION} =~ s/\s+$//;
+ }
+ else {
+ $self->{VERSION} = '';
+ }
+
+
+ $self->{VERSION_MACRO} = 'VERSION';
+ ($self->{VERSION_SYM} = $self->{VERSION}) =~ s/\W/_/g;
+ $self->{DEFINE_VERSION} = '-D$(VERSION_MACRO)=\"$(VERSION)\"';
+
+
+ # Graham Barr and Paul Marquess had some ideas how to ensure
+ # version compatibility between the *.pm file and the
+ # corresponding *.xs file. The bottomline was, that we need an
+ # XS_VERSION macro that defaults to VERSION:
+ $self->{XS_VERSION} ||= $self->{VERSION};
+
+ $self->{XS_VERSION_MACRO} = 'XS_VERSION';
+ $self->{XS_DEFINE_VERSION} = '-D$(XS_VERSION_MACRO)=\"$(XS_VERSION)\"';
+
+}
+
+
+=head3 init_others
+
+ $MM->init_others();
+
+Initializes the macro definitions used by tools_other() and places them
+in the $MM object.
+
+If there is no description, its the same as the parameter to
+WriteMakefile() documented in ExtUtils::MakeMaker.
+
+Defines at least these macros.
+
+ Macro Description
+
+ NOOP Do nothing
+ NOECHO Tell make not to display the command itself
+
+ MAKEFILE
+ FIRST_MAKEFILE
+ MAKEFILE_OLD
+ MAKE_APERL_FILE File used by MAKE_APERL
+
+ SHELL Program used to run shell commands
+
+ ECHO Print text adding a newline on the end
+ RM_F Remove a file
+ RM_RF Remove a directory
+ TOUCH Update a file's timestamp
+ TEST_F Test for a file's existence
+ CP Copy a file
+ MV Move a file
+ CHMOD Change permissions on a file
+ FALSE Exit with non-zero
+ TRUE Exit with zero
+
+ UMASK_NULL Nullify umask
+ DEV_NULL Suppress all command output
+
+=cut
+
+sub init_others {
+ my $self = shift;
+
+ $self->{ECHO} ||= $self->oneliner('print qq{@ARGV}', ['-l']);
+ $self->{ECHO_N} ||= $self->oneliner('print qq{@ARGV}');
+
+ $self->{TOUCH} ||= $self->oneliner('touch', ["-MExtUtils::Command"]);
+ $self->{CHMOD} ||= $self->oneliner('chmod', ["-MExtUtils::Command"]);
+ $self->{RM_F} ||= $self->oneliner('rm_f', ["-MExtUtils::Command"]);
+ $self->{RM_RF} ||= $self->oneliner('rm_rf', ["-MExtUtils::Command"]);
+ $self->{TEST_F} ||= $self->oneliner('test_f', ["-MExtUtils::Command"]);
+ $self->{FALSE} ||= $self->oneliner('exit 1');
+ $self->{TRUE} ||= $self->oneliner('exit 0');
+
+ $self->{MKPATH} ||= $self->oneliner('mkpath', ["-MExtUtils::Command"]);
+
+ $self->{CP} ||= $self->oneliner('cp', ["-MExtUtils::Command"]);
+ $self->{MV} ||= $self->oneliner('mv', ["-MExtUtils::Command"]);
+
+ $self->{MOD_INSTALL} ||=
+ $self->oneliner(<<'CODE', ['-MExtUtils::Install']);
+install([ from_to => {@ARGV}, verbose => '$(VERBINST)', uninstall_shadows => '$(UNINST)', dir_mode => '$(PERM_DIR)' ]);
+CODE
+ $self->{DOC_INSTALL} ||= $self->oneliner('perllocal_install', ["-MExtUtils::Command::MM"]);
+ $self->{UNINSTALL} ||= $self->oneliner('uninstall', ["-MExtUtils::Command::MM"]);
+ $self->{WARN_IF_OLD_PACKLIST} ||=
+ $self->oneliner('warn_if_old_packlist', ["-MExtUtils::Command::MM"]);
+ $self->{FIXIN} ||= $self->oneliner('MY->fixin(shift)', ["-MExtUtils::MY"]);
+ $self->{EQUALIZE_TIMESTAMP} ||= $self->oneliner('eqtime', ["-MExtUtils::Command"]);
+
+ $self->{UNINST} ||= 0;
+ $self->{VERBINST} ||= 0;
+
+ $self->{FIRST_MAKEFILE} ||= $self->{MAKEFILE} || 'Makefile';
+ $self->{MAKEFILE} ||= $self->{FIRST_MAKEFILE};
+ $self->{MAKEFILE_OLD} ||= $self->{MAKEFILE}.'.old';
+ $self->{MAKE_APERL_FILE} ||= $self->{MAKEFILE}.'.aperl';
+
+ # Not everybody uses -f to indicate "use this Makefile instead"
+ $self->{USEMAKEFILE} ||= '-f';
+
+ # Some makes require a wrapper around macros passed in on the command
+ # line.
+ $self->{MACROSTART} ||= '';
+ $self->{MACROEND} ||= '';
+
+ $self->{SHELL} ||= $Config{sh};
+
+ # UMASK_NULL is not used by MakeMaker but some CPAN modules
+ # make use of it.
+ $self->{UMASK_NULL} ||= "umask 0";
+
+ # Not the greatest default, but its something.
+ $self->{DEV_NULL} ||= "> /dev/null 2>&1";
+
+ $self->{NOOP} ||= '$(TRUE)';
+ $self->{NOECHO} = '@' unless defined $self->{NOECHO};
+
+ $self->{LD_RUN_PATH} = "";
+
+ $self->{LIBS} = $self->_fix_libs($self->{LIBS});
+
+ # Compute EXTRALIBS, BSLOADLIBS and LDLOADLIBS from $self->{LIBS}
+ foreach my $libs ( @{$self->{LIBS}} ){
+ $libs =~ s/^\s*(.*\S)\s*$/$1/; # remove leading and trailing whitespace
+ my(@libs) = $self->extliblist($libs);
+ if ($libs[0] or $libs[1] or $libs[2]){
+ # LD_RUN_PATH now computed by ExtUtils::Liblist
+ ($self->{EXTRALIBS}, $self->{BSLOADLIBS},
+ $self->{LDLOADLIBS}, $self->{LD_RUN_PATH}) = @libs;
+ last;
+ }
+ }
+
+ if ( $self->{OBJECT} ) {
+ $self->{OBJECT} =~ s!\.o(bj)?\b!\$(OBJ_EXT)!g;
+ } else {
+ # init_dirscan should have found out, if we have C files
+ $self->{OBJECT} = "";
+ $self->{OBJECT} = '$(BASEEXT)$(OBJ_EXT)' if @{$self->{C}||[]};
+ }
+ $self->{OBJECT} =~ s/\n+/ \\\n\t/g;
+
+ $self->{BOOTDEP} = (-f "$self->{BASEEXT}_BS") ? "$self->{BASEEXT}_BS" : "";
+ $self->{PERLMAINCC} ||= '$(CC)';
+ $self->{LDFROM} = '$(OBJECT)' unless $self->{LDFROM};
+
+ # Sanity check: don't define LINKTYPE = dynamic if we're skipping
+ # the 'dynamic' section of MM. We don't have this problem with
+ # 'static', since we either must use it (%Config says we can't
+ # use dynamic loading) or the caller asked for it explicitly.
+ if (!$self->{LINKTYPE}) {
+ $self->{LINKTYPE} = $self->{SKIPHASH}{'dynamic'}
+ ? 'static'
+ : ($Config{usedl} ? 'dynamic' : 'static');
+ }
+
+ return 1;
+}
+
+
+# Lets look at $self->{LIBS} carefully: It may be an anon array, a string or
+# undefined. In any case we turn it into an anon array
+sub _fix_libs {
+ my($self, $libs) = @_;
+
+ return !defined $libs ? [''] :
+ !ref $libs ? [$libs] :
+ !defined $libs->[0] ? [''] :
+ $libs ;
+}
+
+
+=head3 tools_other
+
+ my $make_frag = $MM->tools_other;
+
+Returns a make fragment containing definitions for the macros init_others()
+initializes.
+
+=cut
+
+sub tools_other {
+ my($self) = shift;
+ my @m;
+
+ # We set PM_FILTER as late as possible so it can see all the earlier
+ # on macro-order sensitive makes such as nmake.
+ for my $tool (qw{ SHELL CHMOD CP MV NOOP NOECHO RM_F RM_RF TEST_F TOUCH
+ UMASK_NULL DEV_NULL MKPATH EQUALIZE_TIMESTAMP
+ FALSE TRUE
+ ECHO ECHO_N
+ UNINST VERBINST
+ MOD_INSTALL DOC_INSTALL UNINSTALL
+ WARN_IF_OLD_PACKLIST
+ MACROSTART MACROEND
+ USEMAKEFILE
+ PM_FILTER
+ FIXIN
+ } )
+ {
+ next unless defined $self->{$tool};
+ push @m, "$tool = $self->{$tool}\n";
+ }
+
+ return join "", @m;
+}
+
+
+=head3 init_DIRFILESEP I<Abstract>
+
+ $MM->init_DIRFILESEP;
+ my $dirfilesep = $MM->{DIRFILESEP};
+
+Initializes the DIRFILESEP macro which is the seperator between the
+directory and filename in a filepath. ie. / on Unix, \ on Win32 and
+nothing on VMS.
+
+For example:
+
+ # instead of $(INST_ARCHAUTODIR)/extralibs.ld
+ $(INST_ARCHAUTODIR)$(DIRFILESEP)extralibs.ld
+
+Something of a hack but it prevents a lot of code duplication between
+MM_* variants.
+
+Do not use this as a seperator between directories. Some operating
+systems use different seperators between subdirectories as between
+directories and filenames (for example: VOLUME:[dir1.dir2]file on VMS).
+
+=head3 init_linker I<Abstract>
+
+ $mm->init_linker;
+
+Initialize macros which have to do with linking.
+
+PERL_ARCHIVE: path to libperl.a equivalent to be linked to dynamic
+extensions.
+
+PERL_ARCHIVE_AFTER: path to a library which should be put on the
+linker command line I<after> the external libraries to be linked to
+dynamic extensions. This may be needed if the linker is one-pass, and
+Perl includes some overrides for C RTL functions, such as malloc().
+
+EXPORT_LIST: name of a file that is passed to linker to define symbols
+to be exported.
+
+Some OSes do not need these in which case leave it blank.
+
+
+=head3 init_platform
+
+ $mm->init_platform
+
+Initialize any macros which are for platform specific use only.
+
+A typical one is the version number of your OS specific mocule.
+(ie. MM_Unix_VERSION or MM_VMS_VERSION).
+
+=cut
+
+sub init_platform {
+ return '';
+}
+
+
+=head3 init_MAKE
+
+ $mm->init_MAKE
+
+Initialize MAKE from either a MAKE environment variable or $Config{make}.
+
+=cut
+
+sub init_MAKE {
+ my $self = shift;
+
+ $self->{MAKE} ||= $ENV{MAKE} || $Config{make};
+}
+
+
+=head2 Tools
+
+A grab bag of methods to generate specific macros and commands.
+
+
+
+=head3 manifypods
+
+Defines targets and routines to translate the pods into manpages and
+put them into the INST_* directories.
+
+=cut
+
+sub manifypods {
+ my $self = shift;
+
+ my $POD2MAN_macro = $self->POD2MAN_macro();
+ my $manifypods_target = $self->manifypods_target();
+
+ return <<END_OF_TARGET;
+
+$POD2MAN_macro
+
+$manifypods_target
+
+END_OF_TARGET
+
+}
+
+
+=head3 POD2MAN_macro
+
+ my $pod2man_macro = $self->POD2MAN_macro
+
+Returns a definition for the POD2MAN macro. This is a program
+which emulates the pod2man utility. You can add more switches to the
+command by simply appending them on the macro.
+
+Typical usage:
+
+ $(POD2MAN) --section=3 --perm_rw=$(PERM_RW) podfile1 man_page1 ...
+
+=cut
+
+sub POD2MAN_macro {
+ my $self = shift;
+
+# Need the trailing '--' so perl stops gobbling arguments and - happens
+# to be an alternative end of line seperator on VMS so we quote it
+ return <<'END_OF_DEF';
+POD2MAN_EXE = $(PERLRUN) "-MExtUtils::Command::MM" -e pod2man "--"
+POD2MAN = $(POD2MAN_EXE)
+END_OF_DEF
+}
+
+
+=head3 test_via_harness
+
+ my $command = $mm->test_via_harness($perl, $tests);
+
+Returns a $command line which runs the given set of $tests with
+Test::Harness and the given $perl.
+
+Used on the t/*.t files.
+
+=cut
+
+sub test_via_harness {
+ my($self, $perl, $tests) = @_;
+
+ return qq{\t$perl "-MExtUtils::Command::MM" }.
+ qq{"-e" "test_harness(\$(TEST_VERBOSE), '\$(INST_LIB)', '\$(INST_ARCHLIB)')" $tests\n};
+}
+
+=head3 test_via_script
+
+ my $command = $mm->test_via_script($perl, $script);
+
+Returns a $command line which just runs a single test without
+Test::Harness. No checks are done on the results, they're just
+printed.
+
+Used for test.pl, since they don't always follow Test::Harness
+formatting.
+
+=cut
+
+sub test_via_script {
+ my($self, $perl, $script) = @_;
+ return qq{\t$perl "-I\$(INST_LIB)" "-I\$(INST_ARCHLIB)" $script\n};
+}
+
+
+=head3 tool_autosplit
+
+Defines a simple perl call that runs autosplit. May be deprecated by
+pm_to_blib soon.
+
+=cut
+
+sub tool_autosplit {
+ my($self, %attribs) = @_;
+
+ my $maxlen = $attribs{MAXLEN} ? '$$AutoSplit::Maxlen=$attribs{MAXLEN};'
+ : '';
+
+ my $asplit = $self->oneliner(sprintf <<'PERL_CODE', $maxlen);
+use AutoSplit; %s autosplit($$ARGV[0], $$ARGV[1], 0, 1, 1)
+PERL_CODE
+
+ return sprintf <<'MAKE_FRAG', $asplit;
+# Usage: $(AUTOSPLITFILE) FileToSplit AutoDirToSplitInto
+AUTOSPLITFILE = %s
+
+MAKE_FRAG
+
+}
+
+
+=head3 arch_check
+
+ my $arch_ok = $mm->arch_check(
+ $INC{"Config.pm"},
+ File::Spec->catfile($Config{archlibexp}, "Config.pm")
+ );
+
+A sanity check that what Perl thinks the architecture is and what
+Config thinks the architecture is are the same. If they're not it
+will return false and show a diagnostic message.
+
+When building Perl it will always return true, as nothing is installed
+yet.
+
+The interface is a bit odd because this is the result of a
+quick refactoring. Don't rely on it.
+
+=cut
+
+sub arch_check {
+ my $self = shift;
+ my($pconfig, $cconfig) = @_;
+
+ return 1 if $self->{PERL_SRC};
+
+ my($pvol, $pthinks) = $self->splitpath($pconfig);
+ my($cvol, $cthinks) = $self->splitpath($cconfig);
+
+ $pthinks = $self->canonpath($pthinks);
+ $cthinks = $self->canonpath($cthinks);
+
+ my $ret = 1;
+ if ($pthinks ne $cthinks) {
+ print "Have $pthinks\n";
+ print "Want $cthinks\n";
+
+ $ret = 0;
+
+ my $arch = (grep length, $self->splitdir($pthinks))[-1];
+
+ print STDOUT <<END unless $self->{UNINSTALLED_PERL};
+Your perl and your Config.pm seem to have different ideas about the
+architecture they are running on.
+Perl thinks: [$arch]
+Config says: [$Config{archname}]
+This may or may not cause problems. Please check your installation of perl
+if you have problems building this extension.
+END
+ }
+
+ return $ret;
+}
+
+
+
+=head2 File::Spec wrappers
+
+ExtUtils::MM_Any is a subclass of File::Spec. The methods noted here
+override File::Spec.
+
+
+
+=head3 catfile
+
+File::Spec <= 0.83 has a bug where the file part of catfile is not
+canonicalized. This override fixes that bug.
+
+=cut
+
+sub catfile {
+ my $self = shift;
+ return $self->canonpath($self->SUPER::catfile(@_));
+}
+
+
+
+=head2 Misc
+
+Methods I can't really figure out where they should go yet.
+
+
+=head3 find_tests
+
+ my $test = $mm->find_tests;
+
+Returns a string suitable for feeding to the shell to return all
+tests in t/*.t.
+
+=cut
+
+sub find_tests {
+ my($self) = shift;
+ return -d 't' ? 't/*.t' : '';
+}
+
+
+=head3 extra_clean_files
+
+ my @files_to_clean = $MM->extra_clean_files;
+
+Returns a list of OS specific files to be removed in the clean target in
+addition to the usual set.
+
+=cut
+
+# An empty method here tickled a perl 5.8.1 bug and would return its object.
+sub extra_clean_files {
+ return;
+}
+
+
+=head3 installvars
+
+ my @installvars = $mm->installvars;
+
+A list of all the INSTALL* variables without the INSTALL prefix. Useful
+for iteration or building related variable sets.
+
+=cut
+
+sub installvars {
+ return qw(PRIVLIB SITELIB VENDORLIB
+ ARCHLIB SITEARCH VENDORARCH
+ BIN SITEBIN VENDORBIN
+ SCRIPT SITESCRIPT VENDORSCRIPT
+ MAN1DIR SITEMAN1DIR VENDORMAN1DIR
+ MAN3DIR SITEMAN3DIR VENDORMAN3DIR
+ );
+}
+
+
+=head3 libscan
+
+ my $wanted = $self->libscan($path);
+
+Takes a path to a file or dir and returns an empty string if we don't
+want to include this file in the library. Otherwise it returns the
+the $path unchanged.
+
+Mainly used to exclude version control administrative directories from
+installation.
+
+=cut
+
+sub libscan {
+ my($self,$path) = @_;
+ my($dirs,$file) = ($self->splitpath($path))[1,2];
+ return '' if grep /^(?:RCS|CVS|SCCS|\.svn|_darcs)$/,
+ $self->splitdir($dirs), $file;
+
+ return $path;
+}
+
+
+=head3 platform_constants
+
+ my $make_frag = $mm->platform_constants
+
+Returns a make fragment defining all the macros initialized in
+init_platform() rather than put them in constants().
+
+=cut
+
+sub platform_constants {
+ return '';
+}
+
+=begin private
+
+=head3 _PREREQ_PRINT
+
+ $self->_PREREQ_PRINT;
+
+Implements PREREQ_PRINT.
+
+Refactored out of MakeMaker->new().
+
+=end private
+
+=cut
+
+sub _PREREQ_PRINT {
+ my $self = shift;
+
+ require Data::Dumper;
+ my @what = ('PREREQ_PM');
+ push @what, 'MIN_PERL_VERSION' if $self->{MIN_PERL_VERSION};
+ push @what, 'BUILD_REQUIRES' if $self->{BUILD_REQUIRES};
+ print Data::Dumper->Dump([@{$self}{@what}], \@what);
+ exit 0;
+}
+
+
+=begin private
+
+=head3 _PRINT_PREREQ
+
+ $mm->_PRINT_PREREQ;
+
+Implements PRINT_PREREQ, a slightly different version of PREREQ_PRINT
+added by Redhat to, I think, support generating RPMs from Perl modules.
+
+Refactored out of MakeMaker->new().
+
+=end private
+
+=cut
+
+sub _PRINT_PREREQ {
+ my $self = shift;
+
+ my $prereqs= $self->_all_prereqs;
+ my @prereq = map { [$_, $prereqs->{$_}] } keys %$prereqs;
+
+ if ( $self->{MIN_PERL_VERSION} ) {
+ push @prereq, ['perl' => $self->{MIN_PERL_VERSION}];
+ }
+
+ print join(" ", map { "perl($_->[0])>=$_->[1] " }
+ sort { $a->[0] cmp $b->[0] } @prereq), "\n";
+ exit 0;
+}
+
+
+=begin private
+
+=head3 _all_prereqs
+
+ my $prereqs = $self->_all_prereqs;
+
+Returns a hash ref of both PREREQ_PM and BUILD_REQUIRES.
+
+=end private
+
+=cut
+
+sub _all_prereqs {
+ my $self = shift;
+
+ return { %{$self->{PREREQ_PM}}, %{$self->{BUILD_REQUIRES}} };
+}
+
+
+=head1 AUTHOR
+
+Michael G Schwern <schwern at pobox.com> and the denizens of
+makemaker at perl.org with code from ExtUtils::MM_Unix and
+ExtUtils::MM_Win32.
+
+
+=cut
+
+1;
Copied: trunk/contrib/perl/lib/ExtUtils/MM_BeOS.pm (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/MM_BeOS.pm)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/MM_BeOS.pm (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/MM_BeOS.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,61 @@
+package ExtUtils::MM_BeOS;
+
+use strict;
+
+=head1 NAME
+
+ExtUtils::MM_BeOS - methods to override UN*X behaviour in ExtUtils::MakeMaker
+
+=head1 SYNOPSIS
+
+ use ExtUtils::MM_BeOS; # Done internally by ExtUtils::MakeMaker if needed
+
+=head1 DESCRIPTION
+
+See ExtUtils::MM_Unix for a documentation of the methods provided
+there. This package overrides the implementation of these methods, not
+the semantics.
+
+=over 4
+
+=cut
+
+use ExtUtils::MakeMaker::Config;
+use File::Spec;
+require ExtUtils::MM_Any;
+require ExtUtils::MM_Unix;
+
+our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix );
+our $VERSION = '6.55_02';
+
+
+=item os_flavor
+
+BeOS is BeOS.
+
+=cut
+
+sub os_flavor {
+ return('BeOS');
+}
+
+=item init_linker
+
+libperl.a equivalent to be linked to dynamic extensions.
+
+=cut
+
+sub init_linker {
+ my($self) = shift;
+
+ $self->{PERL_ARCHIVE} ||=
+ File::Spec->catdir('$(PERL_INC)',$Config{libperl});
+ $self->{PERL_ARCHIVE_AFTER} ||= '';
+ $self->{EXPORT_LIST} ||= '';
+}
+
+=back
+
+1;
+__END__
+
Copied: trunk/contrib/perl/lib/ExtUtils/MM_Cygwin.pm (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/MM_Cygwin.pm)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/MM_Cygwin.pm (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/MM_Cygwin.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,123 @@
+package ExtUtils::MM_Cygwin;
+
+use strict;
+
+use ExtUtils::MakeMaker::Config;
+use File::Spec;
+
+require ExtUtils::MM_Unix;
+require ExtUtils::MM_Win32;
+our @ISA = qw( ExtUtils::MM_Unix );
+
+our $VERSION = '6.55_02';
+
+
+=head1 NAME
+
+ExtUtils::MM_Cygwin - methods to override UN*X behaviour in ExtUtils::MakeMaker
+
+=head1 SYNOPSIS
+
+ use ExtUtils::MM_Cygwin; # Done internally by ExtUtils::MakeMaker if needed
+
+=head1 DESCRIPTION
+
+See ExtUtils::MM_Unix for a documentation of the methods provided there.
+
+=over 4
+
+=item os_flavor
+
+We're Unix and Cygwin.
+
+=cut
+
+sub os_flavor {
+ return('Unix', 'Cygwin');
+}
+
+=item cflags
+
+if configured for dynamic loading, triggers #define EXT in EXTERN.h
+
+=cut
+
+sub cflags {
+ my($self,$libperl)=@_;
+ return $self->{CFLAGS} if $self->{CFLAGS};
+ return '' unless $self->needs_linking();
+
+ my $base = $self->SUPER::cflags($libperl);
+ foreach (split /\n/, $base) {
+ /^(\S*)\s*=\s*(\S*)$/ and $self->{$1} = $2;
+ };
+ $self->{CCFLAGS} .= " -DUSEIMPORTLIB" if ($Config{useshrplib} eq 'true');
+
+ return $self->{CFLAGS} = qq{
+CCFLAGS = $self->{CCFLAGS}
+OPTIMIZE = $self->{OPTIMIZE}
+PERLTYPE = $self->{PERLTYPE}
+};
+
+}
+
+
+=item replace_manpage_separator
+
+replaces strings '::' with '.' in MAN*POD man page names
+
+=cut
+
+sub replace_manpage_separator {
+ my($self, $man) = @_;
+ $man =~ s{/+}{.}g;
+ return $man;
+}
+
+=item init_linker
+
+points to libperl.a
+
+=cut
+
+sub init_linker {
+ my $self = shift;
+
+ if ($Config{useshrplib} eq 'true') {
+ my $libperl = '$(PERL_INC)' .'/'. "$Config{libperl}";
+ if( $] >= 5.006002 ) {
+ $libperl =~ s/a$/dll.a/;
+ }
+ $self->{PERL_ARCHIVE} = $libperl;
+ } else {
+ $self->{PERL_ARCHIVE} =
+ '$(PERL_INC)' .'/'. ("$Config{libperl}" or "libperl.a");
+ }
+
+ $self->{PERL_ARCHIVE_AFTER} ||= '';
+ $self->{EXPORT_LIST} ||= '';
+}
+
+=item maybe_command
+
+If our path begins with F</cygdrive/> then we use C<ExtUtils::MM_Win32>
+to determine if it may be a command. Otherwise we use the tests
+from C<ExtUtils::MM_Unix>.
+
+=cut
+
+sub maybe_command {
+ my ($self, $file) = @_;
+
+ if ($file =~ m{^/cygdrive/}i) {
+ return ExtUtils::MM_Win32->maybe_command($file);
+ }
+
+ return $self->SUPER::maybe_command($file);
+}
+
+=back
+
+=cut
+
+1;
Copied: trunk/contrib/perl/lib/ExtUtils/MM_DOS.pm (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/MM_DOS.pm)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/MM_DOS.pm (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/MM_DOS.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,65 @@
+package ExtUtils::MM_DOS;
+
+use strict;
+
+our $VERSION = 6.55_02;
+
+require ExtUtils::MM_Any;
+require ExtUtils::MM_Unix;
+our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix );
+
+
+=head1 NAME
+
+ExtUtils::MM_DOS - DOS specific subclass of ExtUtils::MM_Unix
+
+=head1 SYNOPSIS
+
+ Don't use this module directly.
+ Use ExtUtils::MM and let it choose.
+
+=head1 DESCRIPTION
+
+This is a subclass of ExtUtils::MM_Unix which contains functionality
+for DOS.
+
+Unless otherwise stated, it works just like ExtUtils::MM_Unix
+
+=head2 Overridden methods
+
+=over 4
+
+=item os_flavor
+
+=cut
+
+sub os_flavor {
+ return('DOS');
+}
+
+=item B<replace_manpage_separator>
+
+Generates Foo__Bar.3 style man page names
+
+=cut
+
+sub replace_manpage_separator {
+ my($self, $man) = @_;
+
+ $man =~ s,/+,__,g;
+ return $man;
+}
+
+=back
+
+=head1 AUTHOR
+
+Michael G Schwern <schwern at pobox.com> with code from ExtUtils::MM_Unix
+
+=head1 SEE ALSO
+
+L<ExtUtils::MM_Unix>, L<ExtUtils::MakeMaker>
+
+=cut
+
+1;
Copied: trunk/contrib/perl/lib/ExtUtils/MM_Darwin.pm (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/MM_Darwin.pm)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/MM_Darwin.pm (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/MM_Darwin.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,47 @@
+package ExtUtils::MM_Darwin;
+
+use strict;
+
+BEGIN {
+ require ExtUtils::MM_Unix;
+ our @ISA = qw( ExtUtils::MM_Unix );
+}
+
+our $VERSION = '6.55_02';
+
+
+=head1 NAME
+
+ExtUtils::MM_Darwin - special behaviors for OS X
+
+=head1 SYNOPSIS
+
+ For internal MakeMaker use only
+
+=head1 DESCRIPTION
+
+See L<ExtUtils::MM_Unix> for L<ExtUtils::MM_Any> for documention on the
+methods overridden here.
+
+=head2 Overriden Methods
+
+=head3 init_dist
+
+Turn off Apple tar's tendency to copy resource forks as "._foo" files.
+
+=cut
+
+sub init_dist {
+ my $self = shift;
+
+ # Thank you, Apple, for breaking tar and then breaking the work around.
+ # 10.4 wants COPY_EXTENDED_ATTRIBUTES_DISABLE while 10.5 wants
+ # COPYFILE_DISABLE. I'm not going to push my luck and instead just
+ # set both.
+ $self->{TAR} ||=
+ 'COPY_EXTENDED_ATTRIBUTES_DISABLE=1 COPYFILE_DISABLE=1 tar';
+
+ $self->SUPER::init_dist(@_);
+}
+
+1;
Copied: trunk/contrib/perl/lib/ExtUtils/MM_MacOS.pm (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/MM_MacOS.pm)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/MM_MacOS.pm (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/MM_MacOS.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,40 @@
+package ExtUtils::MM_MacOS;
+
+use strict;
+
+our $VERSION = 6.55_02;
+
+sub new {
+ die <<'UNSUPPORTED';
+MacOS Classic (MacPerl) is no longer supported by MakeMaker.
+Please use Module::Build instead.
+UNSUPPORTED
+}
+
+=head1 NAME
+
+ExtUtils::MM_MacOS - once produced Makefiles for MacOS Classic
+
+=head1 SYNOPSIS
+
+ # MM_MacOS no longer contains any code. This is just a stub.
+
+=head1 DESCRIPTION
+
+Once upon a time, MakeMaker could produce an approximation of a correct
+Makefile on MacOS Classic (MacPerl). Due to a lack of maintainers, this
+fell out of sync with the rest of MakeMaker and hadn't worked in years.
+Since there's little chance of it being repaired, MacOS Classic is fading
+away, and the code was icky to begin with, the code has been deleted to
+make maintenance easier.
+
+Those interested in writing modules for MacPerl should use Module::Build
+which works better than MakeMaker ever did.
+
+Anyone interested in resurrecting this file should pull the old version
+from the MakeMaker CVS repository and contact makemaker at perl.org, but we
+really encourage you to work on Module::Build instead.
+
+=cut
+
+1;
Copied: trunk/contrib/perl/lib/ExtUtils/MM_NW5.pm (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/MM_NW5.pm)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/MM_NW5.pm (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/MM_NW5.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,269 @@
+package ExtUtils::MM_NW5;
+
+=head1 NAME
+
+ExtUtils::MM_NW5 - methods to override UN*X behaviour in ExtUtils::MakeMaker
+
+=head1 SYNOPSIS
+
+ use ExtUtils::MM_NW5; # Done internally by ExtUtils::MakeMaker if needed
+
+=head1 DESCRIPTION
+
+See ExtUtils::MM_Unix for a documentation of the methods provided
+there. This package overrides the implementation of these methods, not
+the semantics.
+
+=over
+
+=cut
+
+use strict;
+use ExtUtils::MakeMaker::Config;
+use File::Basename;
+
+our $VERSION = '6.55_02';
+
+require ExtUtils::MM_Win32;
+our @ISA = qw(ExtUtils::MM_Win32);
+
+use ExtUtils::MakeMaker qw( &neatvalue );
+
+$ENV{EMXSHELL} = 'sh'; # to run `commands`
+
+my $BORLAND = $Config{'cc'} =~ /^bcc/i;
+my $GCC = $Config{'cc'} =~ /^gcc/i;
+
+
+=item os_flavor
+
+We're Netware in addition to being Windows.
+
+=cut
+
+sub os_flavor {
+ my $self = shift;
+ return ($self->SUPER::os_flavor, 'Netware');
+}
+
+=item init_platform
+
+Add Netware macros.
+
+LIBPTH, BASE_IMPORT, NLM_VERSION, MPKTOOL, TOOLPATH, BOOT_SYMBOL,
+NLM_SHORT_NAME, INCLUDE, PATH, MM_NW5_REVISION
+
+
+=item platform_constants
+
+Add Netware macros initialized above to the Makefile.
+
+=cut
+
+sub init_platform {
+ my($self) = shift;
+
+ # To get Win32's setup.
+ $self->SUPER::init_platform;
+
+ # incpath is copied to makefile var INCLUDE in constants sub, here just
+ # make it empty
+ my $libpth = $Config{'libpth'};
+ $libpth =~ s( )(;);
+ $self->{'LIBPTH'} = $libpth;
+
+ $self->{'BASE_IMPORT'} = $Config{'base_import'};
+
+ # Additional import file specified from Makefile.pl
+ if($self->{'base_import'}) {
+ $self->{'BASE_IMPORT'} .= ', ' . $self->{'base_import'};
+ }
+
+ $self->{'NLM_VERSION'} = $Config{'nlm_version'};
+ $self->{'MPKTOOL'} = $Config{'mpktool'};
+ $self->{'TOOLPATH'} = $Config{'toolpath'};
+
+ (my $boot = $self->{'NAME'}) =~ s/:/_/g;
+ $self->{'BOOT_SYMBOL'}=$boot;
+
+ # If the final binary name is greater than 8 chars,
+ # truncate it here.
+ if(length($self->{'BASEEXT'}) > 8) {
+ $self->{'NLM_SHORT_NAME'} = substr($self->{'BASEEXT'},0,8);
+ }
+
+ # Get the include path and replace the spaces with ;
+ # Copy this to makefile as INCLUDE = d:\...;d:\;
+ ($self->{INCLUDE} = $Config{'incpath'}) =~ s/([ ]*)-I/;/g;
+
+ # Set the path to CodeWarrior binaries which might not have been set in
+ # any other place
+ $self->{PATH} = '$(PATH);$(TOOLPATH)';
+
+ $self->{MM_NW5_VERSION} = $VERSION;
+}
+
+sub platform_constants {
+ my($self) = shift;
+ my $make_frag = '';
+
+ # Setup Win32's constants.
+ $make_frag .= $self->SUPER::platform_constants;
+
+ foreach my $macro (qw(LIBPTH BASE_IMPORT NLM_VERSION MPKTOOL
+ TOOLPATH BOOT_SYMBOL NLM_SHORT_NAME INCLUDE PATH
+ MM_NW5_VERSION
+ ))
+ {
+ next unless defined $self->{$macro};
+ $make_frag .= "$macro = $self->{$macro}\n";
+ }
+
+ return $make_frag;
+}
+
+
+=item const_cccmd
+
+=cut
+
+sub const_cccmd {
+ my($self,$libperl)=@_;
+ return $self->{CONST_CCCMD} if $self->{CONST_CCCMD};
+ return '' unless $self->needs_linking();
+ return $self->{CONST_CCCMD} = <<'MAKE_FRAG';
+CCCMD = $(CC) $(CCFLAGS) $(INC) $(OPTIMIZE) \
+ $(PERLTYPE) $(MPOLLUTE) -o $@ \
+ -DVERSION=\"$(VERSION)\" -DXS_VERSION=\"$(XS_VERSION)\"
+MAKE_FRAG
+
+}
+
+
+=item static_lib
+
+=cut
+
+sub static_lib {
+ my($self) = @_;
+
+ return '' unless $self->has_link_code;
+
+ my $m = <<'END';
+$(INST_STATIC): $(OBJECT) $(MYEXTLIB) $(INST_ARCHAUTODIR)$(DFSEP).exists
+ $(RM_RF) $@
+END
+
+ # If this extension has it's own library (eg SDBM_File)
+ # then copy that to $(INST_STATIC) and add $(OBJECT) into it.
+ $m .= <<'END' if $self->{MYEXTLIB};
+ $self->{CP} $(MYEXTLIB) $@
+END
+
+ my $ar_arg;
+ if( $BORLAND ) {
+ $ar_arg = '$@ $(OBJECT:^"+")';
+ }
+ elsif( $GCC ) {
+ $ar_arg = '-ru $@ $(OBJECT)';
+ }
+ else {
+ $ar_arg = '-type library -o $@ $(OBJECT)';
+ }
+
+ $m .= sprintf <<'END', $ar_arg;
+ $(AR) %s
+ $(NOECHO) $(ECHO) "$(EXTRALIBS)" > $(INST_ARCHAUTODIR)\extralibs.ld
+ $(CHMOD) 755 $@
+END
+
+ $m .= <<'END' if $self->{PERL_SRC};
+ $(NOECHO) $(ECHO) "$(EXTRALIBS)" >> $(PERL_SRC)\ext.libs
+
+
+END
+ return $m;
+}
+
+=item dynamic_lib
+
+Defines how to produce the *.so (or equivalent) files.
+
+=cut
+
+sub dynamic_lib {
+ my($self, %attribs) = @_;
+ return '' unless $self->needs_linking(); #might be because of a subdir
+
+ return '' unless $self->has_link_code;
+
+ my($otherldflags) = $attribs{OTHERLDFLAGS} || ($BORLAND ? 'c0d32.obj': '');
+ my($inst_dynamic_dep) = $attribs{INST_DYNAMIC_DEP} || "";
+ my($ldfrom) = '$(LDFROM)';
+
+ (my $boot = $self->{NAME}) =~ s/:/_/g;
+
+ my $m = <<'MAKE_FRAG';
+# This section creates the dynamically loadable $(INST_DYNAMIC)
+# from $(OBJECT) and possibly $(MYEXTLIB).
+OTHERLDFLAGS = '.$otherldflags.'
+INST_DYNAMIC_DEP = '.$inst_dynamic_dep.'
+
+# Create xdc data for an MT safe NLM in case of mpk build
+$(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DFSEP).exists
+ $(NOECHO) $(ECHO) Export boot_$(BOOT_SYMBOL) > $(BASEEXT).def
+ $(NOECHO) $(ECHO) $(BASE_IMPORT) >> $(BASEEXT).def
+ $(NOECHO) $(ECHO) Import @$(PERL_INC)\perl.imp >> $(BASEEXT).def
+MAKE_FRAG
+
+
+ if ( $self->{CCFLAGS} =~ m/ -DMPK_ON /) {
+ $m .= <<'MAKE_FRAG';
+ $(MPKTOOL) $(XDCFLAGS) $(BASEEXT).xdc
+ $(NOECHO) $(ECHO) xdcdata $(BASEEXT).xdc >> $(BASEEXT).def
+MAKE_FRAG
+ }
+
+ # Reconstruct the X.Y.Z version.
+ my $version = join '.', map { sprintf "%d", $_ }
+ $] =~ /(\d)\.(\d{3})(\d{2})/;
+ $m .= sprintf ' $(LD) $(LDFLAGS) $(OBJECT:.obj=.obj) -desc "Perl %s Extension ($(BASEEXT)) XS_VERSION: $(XS_VERSION)" -nlmversion $(NLM_VERSION)', $version;
+
+ # Taking care of long names like FileHandle, ByteLoader, SDBM_File etc
+ if($self->{NLM_SHORT_NAME}) {
+ # In case of nlms with names exceeding 8 chars, build nlm in the
+ # current dir, rename and move to auto\lib.
+ $m .= q{ -o $(NLM_SHORT_NAME).$(DLEXT)}
+ } else {
+ $m .= q{ -o $(INST_AUTODIR)\\$(BASEEXT).$(DLEXT)}
+ }
+
+ # Add additional lib files if any (SDBM_File)
+ $m .= q{ $(MYEXTLIB) } if $self->{MYEXTLIB};
+
+ $m .= q{ $(PERL_INC)\Main.lib -commandfile $(BASEEXT).def}."\n";
+
+ if($self->{NLM_SHORT_NAME}) {
+ $m .= <<'MAKE_FRAG';
+ if exist $(INST_AUTODIR)\$(NLM_SHORT_NAME).$(DLEXT) del $(INST_AUTODIR)\$(NLM_SHORT_NAME).$(DLEXT)
+ move $(NLM_SHORT_NAME).$(DLEXT) $(INST_AUTODIR)
+MAKE_FRAG
+ }
+
+ $m .= <<'MAKE_FRAG';
+
+ $(CHMOD) 755 $@
+MAKE_FRAG
+
+ return $m;
+}
+
+
+1;
+__END__
+
+=back
+
+=cut
+
+
Copied: trunk/contrib/perl/lib/ExtUtils/MM_OS2.pm (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/MM_OS2.pm)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/MM_OS2.pm (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/MM_OS2.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,151 @@
+package ExtUtils::MM_OS2;
+
+use strict;
+
+use ExtUtils::MakeMaker qw(neatvalue);
+use File::Spec;
+
+our $VERSION = '6.55_02';
+
+require ExtUtils::MM_Any;
+require ExtUtils::MM_Unix;
+our @ISA = qw(ExtUtils::MM_Any ExtUtils::MM_Unix);
+
+=pod
+
+=head1 NAME
+
+ExtUtils::MM_OS2 - methods to override UN*X behaviour in ExtUtils::MakeMaker
+
+=head1 SYNOPSIS
+
+ use ExtUtils::MM_OS2; # Done internally by ExtUtils::MakeMaker if needed
+
+=head1 DESCRIPTION
+
+See ExtUtils::MM_Unix for a documentation of the methods provided
+there. This package overrides the implementation of these methods, not
+the semantics.
+
+=head1 METHODS
+
+=over 4
+
+=item init_dist
+
+Define TO_UNIX to convert OS2 linefeeds to Unix style.
+
+=cut
+
+sub init_dist {
+ my($self) = @_;
+
+ $self->{TO_UNIX} ||= <<'MAKE_TEXT';
+$(NOECHO) $(TEST_F) tmp.zip && $(RM_F) tmp.zip; $(ZIP) -ll -mr tmp.zip $(DISTVNAME) && unzip -o tmp.zip && $(RM_F) tmp.zip
+MAKE_TEXT
+
+ $self->SUPER::init_dist;
+}
+
+sub dlsyms {
+ my($self,%attribs) = @_;
+
+ my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {};
+ my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || [];
+ my($funclist) = $attribs{FUNCLIST} || $self->{FUNCLIST} || [];
+ my($imports) = $attribs{IMPORTS} || $self->{IMPORTS} || {};
+ my(@m);
+ (my $boot = $self->{NAME}) =~ s/:/_/g;
+
+ if (not $self->{SKIPHASH}{'dynamic'}) {
+ push(@m,"
+$self->{BASEEXT}.def: Makefile.PL
+",
+ ' $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e \'use ExtUtils::Mksymlists; \\
+ Mksymlists("NAME" => "$(NAME)", "DLBASE" => "$(DLBASE)", ',
+ '"VERSION" => "$(VERSION)", "DISTNAME" => "$(DISTNAME)", ',
+ '"INSTALLDIRS" => "$(INSTALLDIRS)", ',
+ '"DL_FUNCS" => ',neatvalue($funcs),
+ ', "FUNCLIST" => ',neatvalue($funclist),
+ ', "IMPORTS" => ',neatvalue($imports),
+ ', "DL_VARS" => ', neatvalue($vars), ');\'
+');
+ }
+ if ($self->{IMPORTS} && %{$self->{IMPORTS}}) {
+ # Make import files (needed for static build)
+ -d 'tmp_imp' or mkdir 'tmp_imp', 0777 or die "Can't mkdir tmp_imp";
+ open my $imp, '>', 'tmpimp.imp' or die "Can't open tmpimp.imp";
+ while (my($name, $exp) = each %{$self->{IMPORTS}}) {
+ my ($lib, $id) = ($exp =~ /(.*)\.(.*)/) or die "Malformed IMPORT `$exp'";
+ print $imp "$name $lib $id ?\n";
+ }
+ close $imp or die "Can't close tmpimp.imp";
+ # print "emximp -o tmpimp$Config::Config{lib_ext} tmpimp.imp\n";
+ system "emximp -o tmpimp$Config::Config{lib_ext} tmpimp.imp"
+ and die "Cannot make import library: $!, \$?=$?";
+ unlink <tmp_imp/*>;
+ system "cd tmp_imp; $Config::Config{ar} x ../tmpimp$Config::Config{lib_ext}"
+ and die "Cannot extract import objects: $!, \$?=$?";
+ }
+ join('', at m);
+}
+
+sub static_lib {
+ my($self) = @_;
+ my $old = $self->ExtUtils::MM_Unix::static_lib();
+ return $old unless $self->{IMPORTS} && %{$self->{IMPORTS}};
+
+ my @chunks = split /\n{2,}/, $old;
+ shift @chunks unless length $chunks[0]; # Empty lines at the start
+ $chunks[0] .= <<'EOC';
+
+ $(AR) $(AR_STATIC_ARGS) $@ tmp_imp/* && $(RANLIB) $@
+EOC
+ return join "\n\n". '', @chunks;
+}
+
+sub replace_manpage_separator {
+ my($self,$man) = @_;
+ $man =~ s,/+,.,g;
+ $man;
+}
+
+sub maybe_command {
+ my($self,$file) = @_;
+ $file =~ s,[/\\]+,/,g;
+ return $file if -x $file && ! -d _;
+ return "$file.exe" if -x "$file.exe" && ! -d _;
+ return "$file.cmd" if -x "$file.cmd" && ! -d _;
+ return;
+}
+
+=item init_linker
+
+=cut
+
+sub init_linker {
+ my $self = shift;
+
+ $self->{PERL_ARCHIVE} = "\$(PERL_INC)/libperl\$(LIB_EXT)";
+
+ $self->{PERL_ARCHIVE_AFTER} = $OS2::is_aout
+ ? ''
+ : '$(PERL_INC)/libperl_override$(LIB_EXT)';
+ $self->{EXPORT_LIST} = '$(BASEEXT).def';
+}
+
+=item os_flavor
+
+OS/2 is OS/2
+
+=cut
+
+sub os_flavor {
+ return('OS/2');
+}
+
+=back
+
+=cut
+
+1;
Copied: trunk/contrib/perl/lib/ExtUtils/MM_QNX.pm (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/MM_QNX.pm)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/MM_QNX.pm (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/MM_QNX.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,57 @@
+package ExtUtils::MM_QNX;
+
+use strict;
+our $VERSION = '6.55_02';
+
+require ExtUtils::MM_Unix;
+our @ISA = qw(ExtUtils::MM_Unix);
+
+
+=head1 NAME
+
+ExtUtils::MM_QNX - QNX specific subclass of ExtUtils::MM_Unix
+
+=head1 SYNOPSIS
+
+ Don't use this module directly.
+ Use ExtUtils::MM and let it choose.
+
+=head1 DESCRIPTION
+
+This is a subclass of ExtUtils::MM_Unix which contains functionality for
+QNX.
+
+Unless otherwise stated it works just like ExtUtils::MM_Unix
+
+=head2 Overridden methods
+
+=head3 extra_clean_files
+
+Add .err files corresponding to each .c file.
+
+=cut
+
+sub extra_clean_files {
+ my $self = shift;
+
+ my @errfiles = @{$self->{C}};
+ for ( @errfiles ) {
+ s/.c$/.err/;
+ }
+
+ return( @errfiles, 'perlmain.err' );
+}
+
+
+=head1 AUTHOR
+
+Michael G Schwern <schwern at pobox.com> with code from ExtUtils::MM_Unix
+
+=head1 SEE ALSO
+
+L<ExtUtils::MakeMaker>
+
+=cut
+
+
+1;
Copied: trunk/contrib/perl/lib/ExtUtils/MM_UWIN.pm (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/MM_UWIN.pm)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/MM_UWIN.pm (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/MM_UWIN.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,64 @@
+package ExtUtils::MM_UWIN;
+
+use strict;
+our $VERSION = 6.55_02;
+
+require ExtUtils::MM_Unix;
+our @ISA = qw(ExtUtils::MM_Unix);
+
+
+=head1 NAME
+
+ExtUtils::MM_UWIN - U/WIN specific subclass of ExtUtils::MM_Unix
+
+=head1 SYNOPSIS
+
+ Don't use this module directly.
+ Use ExtUtils::MM and let it choose.
+
+=head1 DESCRIPTION
+
+This is a subclass of ExtUtils::MM_Unix which contains functionality for
+the AT&T U/WIN UNIX on Windows environment.
+
+Unless otherwise stated it works just like ExtUtils::MM_Unix
+
+=head2 Overridden methods
+
+=over 4
+
+=item os_flavor
+
+In addition to being Unix, we're U/WIN.
+
+=cut
+
+sub os_flavor {
+ return('Unix', 'U/WIN');
+}
+
+
+=item B<replace_manpage_separator>
+
+=cut
+
+sub replace_manpage_separator {
+ my($self, $man) = @_;
+
+ $man =~ s,/+,.,g;
+ return $man;
+}
+
+=back
+
+=head1 AUTHOR
+
+Michael G Schwern <schwern at pobox.com> with code from ExtUtils::MM_Unix
+
+=head1 SEE ALSO
+
+L<ExtUtils::MM_Win32>, L<ExtUtils::MakeMaker>
+
+=cut
+
+1;
Copied: trunk/contrib/perl/lib/ExtUtils/MM_Unix.pm (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/MM_Unix.pm)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/MM_Unix.pm (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/MM_Unix.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,3622 @@
+package ExtUtils::MM_Unix;
+
+require 5.006;
+
+use strict;
+
+use Carp;
+use ExtUtils::MakeMaker::Config;
+use File::Basename qw(basename dirname);
+use DirHandle;
+
+our %Config_Override;
+
+use ExtUtils::MakeMaker qw($Verbose neatvalue);
+
+# If we make $VERSION an our variable parse_version() breaks
+use vars qw($VERSION);
+$VERSION = '6.55_02';
+
+require ExtUtils::MM_Any;
+our @ISA = qw(ExtUtils::MM_Any);
+
+my %Is;
+BEGIN {
+ $Is{OS2} = $^O eq 'os2';
+ $Is{Win32} = $^O eq 'MSWin32' || $Config{osname} eq 'NetWare';
+ $Is{Dos} = $^O eq 'dos';
+ $Is{VMS} = $^O eq 'VMS';
+ $Is{OSF} = $^O eq 'dec_osf';
+ $Is{IRIX} = $^O eq 'irix';
+ $Is{NetBSD} = $^O eq 'netbsd';
+ $Is{Interix} = $^O eq 'interix';
+ $Is{SunOS4} = $^O eq 'sunos';
+ $Is{Solaris} = $^O eq 'solaris';
+ $Is{SunOS} = $Is{SunOS4} || $Is{Solaris};
+ $Is{BSD} = ($^O =~ /^(?:free|net|open)bsd$/ or
+ grep( $^O eq $_, qw(bsdos interix dragonfly) )
+ );
+}
+
+BEGIN {
+ if( $Is{VMS} ) {
+ # For things like vmsify()
+ require VMS::Filespec;
+ VMS::Filespec->import;
+ }
+}
+
+
+=head1 NAME
+
+ExtUtils::MM_Unix - methods used by ExtUtils::MakeMaker
+
+=head1 SYNOPSIS
+
+C<require ExtUtils::MM_Unix;>
+
+=head1 DESCRIPTION
+
+The methods provided by this package are designed to be used in
+conjunction with ExtUtils::MakeMaker. When MakeMaker writes a
+Makefile, it creates one or more objects that inherit their methods
+from a package C<MM>. MM itself doesn't provide any methods, but it
+ISA ExtUtils::MM_Unix class. The inheritance tree of MM lets operating
+specific packages take the responsibility for all the methods provided
+by MM_Unix. We are trying to reduce the number of the necessary
+overrides by defining rather primitive operations within
+ExtUtils::MM_Unix.
+
+If you are going to write a platform specific MM package, please try
+to limit the necessary overrides to primitive methods, and if it is not
+possible to do so, let's work out how to achieve that gain.
+
+If you are overriding any of these methods in your Makefile.PL (in the
+MY class), please report that to the makemaker mailing list. We are
+trying to minimize the necessary method overrides and switch to data
+driven Makefile.PLs wherever possible. In the long run less methods
+will be overridable via the MY class.
+
+=head1 METHODS
+
+The following description of methods is still under
+development. Please refer to the code for not suitably documented
+sections and complain loudly to the makemaker at perl.org mailing list.
+Better yet, provide a patch.
+
+Not all of the methods below are overridable in a
+Makefile.PL. Overridable methods are marked as (o). All methods are
+overridable by a platform specific MM_*.pm file.
+
+Cross-platform methods are being moved into MM_Any. If you can't find
+something that used to be in here, look in MM_Any.
+
+=cut
+
+# So we don't have to keep calling the methods over and over again,
+# we have these globals to cache the values. Faster and shrtr.
+my $Curdir = __PACKAGE__->curdir;
+my $Rootdir = __PACKAGE__->rootdir;
+my $Updir = __PACKAGE__->updir;
+
+
+=head2 Methods
+
+=over 4
+
+=item os_flavor
+
+Simply says that we're Unix.
+
+=cut
+
+sub os_flavor {
+ return('Unix');
+}
+
+
+=item c_o (o)
+
+Defines the suffix rules to compile different flavors of C files to
+object files.
+
+=cut
+
+sub c_o {
+# --- Translation Sections ---
+
+ my($self) = shift;
+ return '' unless $self->needs_linking();
+ my(@m);
+
+ my $command = '$(CCCMD)';
+ my $flags = '$(CCCDLFLAGS) "-I$(PERL_INC)" $(PASTHRU_DEFINE) $(DEFINE)';
+
+ if (my $cpp = $Config{cpprun}) {
+ my $cpp_cmd = $self->const_cccmd;
+ $cpp_cmd =~ s/^CCCMD\s*=\s*\$\(CC\)/$cpp/;
+ push @m, qq{
+.c.i:
+ $cpp_cmd $flags \$*.c > \$*.i
+};
+ }
+
+ push @m, qq{
+.c.s:
+ $command -S $flags \$*.c
+
+.c\$(OBJ_EXT):
+ $command $flags \$*.c
+
+.cpp\$(OBJ_EXT):
+ $command $flags \$*.cpp
+
+.cxx\$(OBJ_EXT):
+ $command $flags \$*.cxx
+
+.cc\$(OBJ_EXT):
+ $command $flags \$*.cc
+};
+
+ push @m, qq{
+.C\$(OBJ_EXT):
+ $command $flags \$*.C
+} if !$Is{OS2} and !$Is{Win32} and !$Is{Dos}; #Case-specific
+
+ return join "", @m;
+}
+
+=item cflags (o)
+
+Does very much the same as the cflags script in the perl
+distribution. It doesn't return the whole compiler command line, but
+initializes all of its parts. The const_cccmd method then actually
+returns the definition of the CCCMD macro which uses these parts.
+
+=cut
+
+#'
+
+sub cflags {
+ my($self,$libperl)=@_;
+ return $self->{CFLAGS} if $self->{CFLAGS};
+ return '' unless $self->needs_linking();
+
+ my($prog, $uc, $perltype, %cflags);
+ $libperl ||= $self->{LIBPERL_A} || "libperl$self->{LIB_EXT}" ;
+ $libperl =~ s/\.\$\(A\)$/$self->{LIB_EXT}/;
+
+ @cflags{qw(cc ccflags optimize shellflags)}
+ = @Config{qw(cc ccflags optimize shellflags)};
+ my($optdebug) = "";
+
+ $cflags{shellflags} ||= '';
+
+ my(%map) = (
+ D => '-DDEBUGGING',
+ E => '-DEMBED',
+ DE => '-DDEBUGGING -DEMBED',
+ M => '-DEMBED -DMULTIPLICITY',
+ DM => '-DDEBUGGING -DEMBED -DMULTIPLICITY',
+ );
+
+ if ($libperl =~ /libperl(\w*)\Q$self->{LIB_EXT}/){
+ $uc = uc($1);
+ } else {
+ $uc = ""; # avoid warning
+ }
+ $perltype = $map{$uc} ? $map{$uc} : "";
+
+ if ($uc =~ /^D/) {
+ $optdebug = "-g";
+ }
+
+
+ my($name);
+ ( $name = $self->{NAME} . "_cflags" ) =~ s/:/_/g ;
+ if ($prog = $Config{$name}) {
+ # Expand hints for this extension via the shell
+ print STDOUT "Processing $name hint:\n" if $Verbose;
+ my(@o)=`cc=\"$cflags{cc}\"
+ ccflags=\"$cflags{ccflags}\"
+ optimize=\"$cflags{optimize}\"
+ perltype=\"$cflags{perltype}\"
+ optdebug=\"$cflags{optdebug}\"
+ eval '$prog'
+ echo cc=\$cc
+ echo ccflags=\$ccflags
+ echo optimize=\$optimize
+ echo perltype=\$perltype
+ echo optdebug=\$optdebug
+ `;
+ foreach my $line (@o){
+ chomp $line;
+ if ($line =~ /(.*?)=\s*(.*)\s*$/){
+ $cflags{$1} = $2;
+ print STDOUT " $1 = $2\n" if $Verbose;
+ } else {
+ print STDOUT "Unrecognised result from hint: '$line'\n";
+ }
+ }
+ }
+
+ if ($optdebug) {
+ $cflags{optimize} = $optdebug;
+ }
+
+ for (qw(ccflags optimize perltype)) {
+ $cflags{$_} ||= '';
+ $cflags{$_} =~ s/^\s+//;
+ $cflags{$_} =~ s/\s+/ /g;
+ $cflags{$_} =~ s/\s+$//;
+ $self->{uc $_} ||= $cflags{$_};
+ }
+
+ if ($self->{POLLUTE}) {
+ $self->{CCFLAGS} .= ' -DPERL_POLLUTE ';
+ }
+
+ my $pollute = '';
+ if ($Config{usemymalloc} and not $Config{bincompat5005}
+ and not $Config{ccflags} =~ /-DPERL_POLLUTE_MALLOC\b/
+ and $self->{PERL_MALLOC_OK}) {
+ $pollute = '$(PERL_MALLOC_DEF)';
+ }
+
+ $self->{CCFLAGS} = quote_paren($self->{CCFLAGS});
+ $self->{OPTIMIZE} = quote_paren($self->{OPTIMIZE});
+
+ return $self->{CFLAGS} = qq{
+CCFLAGS = $self->{CCFLAGS}
+OPTIMIZE = $self->{OPTIMIZE}
+PERLTYPE = $self->{PERLTYPE}
+MPOLLUTE = $pollute
+};
+
+}
+
+
+=item const_cccmd (o)
+
+Returns the full compiler call for C programs and stores the
+definition in CONST_CCCMD.
+
+=cut
+
+sub const_cccmd {
+ my($self,$libperl)=@_;
+ return $self->{CONST_CCCMD} if $self->{CONST_CCCMD};
+ return '' unless $self->needs_linking();
+ return $self->{CONST_CCCMD} =
+ q{CCCMD = $(CC) -c $(PASTHRU_INC) $(INC) \\
+ $(CCFLAGS) $(OPTIMIZE) \\
+ $(PERLTYPE) $(MPOLLUTE) $(DEFINE_VERSION) \\
+ $(XS_DEFINE_VERSION)};
+}
+
+=item const_config (o)
+
+Defines a couple of constants in the Makefile that are imported from
+%Config.
+
+=cut
+
+sub const_config {
+# --- Constants Sections ---
+
+ my($self) = shift;
+ my @m = <<"END";
+
+# These definitions are from config.sh (via $INC{'Config.pm'}).
+# They may have been overridden via Makefile.PL or on the command line.
+END
+
+ my(%once_only);
+ foreach my $key (@{$self->{CONFIG}}){
+ # SITE*EXP macros are defined in &constants; avoid duplicates here
+ next if $once_only{$key};
+ $self->{uc $key} = quote_paren($self->{uc $key});
+ push @m, uc($key) , ' = ' , $self->{uc $key}, "\n";
+ $once_only{$key} = 1;
+ }
+ join('', @m);
+}
+
+=item const_loadlibs (o)
+
+Defines EXTRALIBS, LDLOADLIBS, BSLOADLIBS, LD_RUN_PATH. See
+L<ExtUtils::Liblist> for details.
+
+=cut
+
+sub const_loadlibs {
+ my($self) = shift;
+ return "" unless $self->needs_linking;
+ my @m;
+ push @m, qq{
+# $self->{NAME} might depend on some other libraries:
+# See ExtUtils::Liblist for details
+#
+};
+ for my $tmp (qw/
+ EXTRALIBS LDLOADLIBS BSLOADLIBS
+ /) {
+ next unless defined $self->{$tmp};
+ push @m, "$tmp = $self->{$tmp}\n";
+ }
+ # don't set LD_RUN_PATH if empty
+ for my $tmp (qw/
+ LD_RUN_PATH
+ /) {
+ next unless $self->{$tmp};
+ push @m, "$tmp = $self->{$tmp}\n";
+ }
+ return join "", @m;
+}
+
+=item constants (o)
+
+ my $make_frag = $mm->constants;
+
+Prints out macros for lots of constants.
+
+=cut
+
+sub constants {
+ my($self) = @_;
+ my @m = ();
+
+ $self->{DFSEP} = '$(DIRFILESEP)'; # alias for internal use
+
+ for my $macro (qw(
+
+ AR_STATIC_ARGS DIRFILESEP DFSEP
+ NAME NAME_SYM
+ VERSION VERSION_MACRO VERSION_SYM DEFINE_VERSION
+ XS_VERSION XS_VERSION_MACRO XS_DEFINE_VERSION
+ INST_ARCHLIB INST_SCRIPT INST_BIN INST_LIB
+ INST_MAN1DIR INST_MAN3DIR
+ MAN1EXT MAN3EXT
+ INSTALLDIRS INSTALL_BASE DESTDIR PREFIX
+ PERLPREFIX SITEPREFIX VENDORPREFIX
+ ),
+ (map { ("INSTALL".$_,
+ "DESTINSTALL".$_)
+ } $self->installvars),
+ qw(
+ PERL_LIB
+ PERL_ARCHLIB
+ LIBPERL_A MYEXTLIB
+ FIRST_MAKEFILE MAKEFILE_OLD MAKE_APERL_FILE
+ PERLMAINCC PERL_SRC PERL_INC
+ PERL FULLPERL ABSPERL
+ PERLRUN FULLPERLRUN ABSPERLRUN
+ PERLRUNINST FULLPERLRUNINST ABSPERLRUNINST
+ PERL_CORE
+ PERM_DIR PERM_RW PERM_RWX
+
+ ) )
+ {
+ next unless defined $self->{$macro};
+
+ # pathnames can have sharp signs in them; escape them so
+ # make doesn't think it is a comment-start character.
+ $self->{$macro} =~ s/#/\\#/g;
+ push @m, "$macro = $self->{$macro}\n";
+ }
+
+ push @m, qq{
+MAKEMAKER = $self->{MAKEMAKER}
+MM_VERSION = $self->{MM_VERSION}
+MM_REVISION = $self->{MM_REVISION}
+};
+
+ push @m, q{
+# FULLEXT = Pathname for extension directory (eg Foo/Bar/Oracle).
+# BASEEXT = Basename part of FULLEXT. May be just equal FULLEXT. (eg Oracle)
+# PARENT_NAME = NAME without BASEEXT and no trailing :: (eg Foo::Bar)
+# DLBASE = Basename part of dynamic library. May be just equal BASEEXT.
+};
+
+ for my $macro (qw/
+ MAKE
+ FULLEXT BASEEXT PARENT_NAME DLBASE VERSION_FROM INC DEFINE OBJECT
+ LDFROM LINKTYPE BOOTDEP
+ / )
+ {
+ next unless defined $self->{$macro};
+ push @m, "$macro = $self->{$macro}\n";
+ }
+
+ push @m, "
+# Handy lists of source code files:
+XS_FILES = ".$self->wraplist(sort keys %{$self->{XS}})."
+C_FILES = ".$self->wraplist(@{$self->{C}})."
+O_FILES = ".$self->wraplist(@{$self->{O_FILES}})."
+H_FILES = ".$self->wraplist(@{$self->{H}})."
+MAN1PODS = ".$self->wraplist(sort keys %{$self->{MAN1PODS}})."
+MAN3PODS = ".$self->wraplist(sort keys %{$self->{MAN3PODS}})."
+";
+
+
+ push @m, q{
+# Where is the Config information that we are using/depend on
+CONFIGDEP = $(PERL_ARCHLIB)$(DFSEP)Config.pm $(PERL_INC)$(DFSEP)config.h
+};
+
+
+ push @m, qq{
+# Where to build things
+INST_LIBDIR = $self->{INST_LIBDIR}
+INST_ARCHLIBDIR = $self->{INST_ARCHLIBDIR}
+
+INST_AUTODIR = $self->{INST_AUTODIR}
+INST_ARCHAUTODIR = $self->{INST_ARCHAUTODIR}
+
+INST_STATIC = $self->{INST_STATIC}
+INST_DYNAMIC = $self->{INST_DYNAMIC}
+INST_BOOT = $self->{INST_BOOT}
+};
+
+
+ push @m, qq{
+# Extra linker info
+EXPORT_LIST = $self->{EXPORT_LIST}
+PERL_ARCHIVE = $self->{PERL_ARCHIVE}
+PERL_ARCHIVE_AFTER = $self->{PERL_ARCHIVE_AFTER}
+};
+
+ push @m, "
+
+TO_INST_PM = ".$self->wraplist(sort keys %{$self->{PM}})."
+
+PM_TO_BLIB = ".$self->wraplist(%{$self->{PM}})."
+";
+
+ join('', at m);
+}
+
+
+=item depend (o)
+
+Same as macro for the depend attribute.
+
+=cut
+
+sub depend {
+ my($self,%attribs) = @_;
+ my(@m,$key,$val);
+ while (($key,$val) = each %attribs){
+ last unless defined $key;
+ push @m, "$key : $val\n";
+ }
+ join "", @m;
+}
+
+
+=item init_DEST
+
+ $mm->init_DEST
+
+Defines the DESTDIR and DEST* variables paralleling the INSTALL*.
+
+=cut
+
+sub init_DEST {
+ my $self = shift;
+
+ # Initialize DESTDIR
+ $self->{DESTDIR} ||= '';
+
+ # Make DEST variables.
+ foreach my $var ($self->installvars) {
+ my $destvar = 'DESTINSTALL'.$var;
+ $self->{$destvar} ||= '$(DESTDIR)$(INSTALL'.$var.')';
+ }
+}
+
+
+=item init_dist
+
+ $mm->init_dist;
+
+Defines a lot of macros for distribution support.
+
+ macro description default
+
+ TAR tar command to use tar
+ TARFLAGS flags to pass to TAR cvf
+
+ ZIP zip command to use zip
+ ZIPFLAGS flags to pass to ZIP -r
+
+ COMPRESS compression command to gzip --best
+ use for tarfiles
+ SUFFIX suffix to put on .gz
+ compressed files
+
+ SHAR shar command to use shar
+
+ PREOP extra commands to run before
+ making the archive
+ POSTOP extra commands to run after
+ making the archive
+
+ TO_UNIX a command to convert linefeeds
+ to Unix style in your archive
+
+ CI command to checkin your ci -u
+ sources to version control
+ RCS_LABEL command to label your sources rcs -Nv$(VERSION_SYM): -q
+ just after CI is run
+
+ DIST_CP $how argument to manicopy() best
+ when the distdir is created
+
+ DIST_DEFAULT default target to use to tardist
+ create a distribution
+
+ DISTVNAME name of the resulting archive $(DISTNAME)-$(VERSION)
+ (minus suffixes)
+
+=cut
+
+sub init_dist {
+ my $self = shift;
+
+ $self->{TAR} ||= 'tar';
+ $self->{TARFLAGS} ||= 'cvf';
+ $self->{ZIP} ||= 'zip';
+ $self->{ZIPFLAGS} ||= '-r';
+ $self->{COMPRESS} ||= 'gzip --best';
+ $self->{SUFFIX} ||= '.gz';
+ $self->{SHAR} ||= 'shar';
+ $self->{PREOP} ||= '$(NOECHO) $(NOOP)'; # eg update MANIFEST
+ $self->{POSTOP} ||= '$(NOECHO) $(NOOP)'; # eg remove the distdir
+ $self->{TO_UNIX} ||= '$(NOECHO) $(NOOP)';
+
+ $self->{CI} ||= 'ci -u';
+ $self->{RCS_LABEL}||= 'rcs -Nv$(VERSION_SYM): -q';
+ $self->{DIST_CP} ||= 'best';
+ $self->{DIST_DEFAULT} ||= 'tardist';
+
+ ($self->{DISTNAME} = $self->{NAME}) =~ s{::}{-}g unless $self->{DISTNAME};
+ $self->{DISTVNAME} ||= $self->{DISTNAME}.'-'.$self->{VERSION};
+
+}
+
+=item dist (o)
+
+ my $dist_macros = $mm->dist(%overrides);
+
+Generates a make fragment defining all the macros initialized in
+init_dist.
+
+%overrides can be used to override any of the above.
+
+=cut
+
+sub dist {
+ my($self, %attribs) = @_;
+
+ my $make = '';
+ foreach my $key (qw(
+ TAR TARFLAGS ZIP ZIPFLAGS COMPRESS SUFFIX SHAR
+ PREOP POSTOP TO_UNIX
+ CI RCS_LABEL DIST_CP DIST_DEFAULT
+ DISTNAME DISTVNAME
+ ))
+ {
+ my $value = $attribs{$key} || $self->{$key};
+ $make .= "$key = $value\n";
+ }
+
+ return $make;
+}
+
+=item dist_basics (o)
+
+Defines the targets distclean, distcheck, skipcheck, manifest, veryclean.
+
+=cut
+
+sub dist_basics {
+ my($self) = shift;
+
+ return <<'MAKE_FRAG';
+distclean :: realclean distcheck
+ $(NOECHO) $(NOOP)
+
+distcheck :
+ $(PERLRUN) "-MExtUtils::Manifest=fullcheck" -e fullcheck
+
+skipcheck :
+ $(PERLRUN) "-MExtUtils::Manifest=skipcheck" -e skipcheck
+
+manifest :
+ $(PERLRUN) "-MExtUtils::Manifest=mkmanifest" -e mkmanifest
+
+veryclean : realclean
+ $(RM_F) *~ */*~ *.orig */*.orig *.bak */*.bak *.old */*.old
+
+MAKE_FRAG
+
+}
+
+=item dist_ci (o)
+
+Defines a check in target for RCS.
+
+=cut
+
+sub dist_ci {
+ my($self) = shift;
+ return q{
+ci :
+ $(PERLRUN) "-MExtUtils::Manifest=maniread" \\
+ -e "@all = keys %{ maniread() };" \\
+ -e "print(qq{Executing $(CI) @all\n}); system(qq{$(CI) @all});" \\
+ -e "print(qq{Executing $(RCS_LABEL) ...\n}); system(qq{$(RCS_LABEL) @all});"
+};
+}
+
+=item dist_core (o)
+
+ my $dist_make_fragment = $MM->dist_core;
+
+Puts the targets necessary for 'make dist' together into one make
+fragment.
+
+=cut
+
+sub dist_core {
+ my($self) = shift;
+
+ my $make_frag = '';
+ foreach my $target (qw(dist tardist uutardist tarfile zipdist zipfile
+ shdist))
+ {
+ my $method = $target.'_target';
+ $make_frag .= "\n";
+ $make_frag .= $self->$method();
+ }
+
+ return $make_frag;
+}
+
+
+=item B<dist_target>
+
+ my $make_frag = $MM->dist_target;
+
+Returns the 'dist' target to make an archive for distribution. This
+target simply checks to make sure the Makefile is up-to-date and
+depends on $(DIST_DEFAULT).
+
+=cut
+
+sub dist_target {
+ my($self) = shift;
+
+ my $date_check = $self->oneliner(<<'CODE', ['-l']);
+print 'Warning: Makefile possibly out of date with $(VERSION_FROM)'
+ if -e '$(VERSION_FROM)' and -M '$(VERSION_FROM)' < -M '$(FIRST_MAKEFILE)';
+CODE
+
+ return sprintf <<'MAKE_FRAG', $date_check;
+dist : $(DIST_DEFAULT) $(FIRST_MAKEFILE)
+ $(NOECHO) %s
+MAKE_FRAG
+}
+
+=item B<tardist_target>
+
+ my $make_frag = $MM->tardist_target;
+
+Returns the 'tardist' target which is simply so 'make tardist' works.
+The real work is done by the dynamically named tardistfile_target()
+method, tardist should have that as a dependency.
+
+=cut
+
+sub tardist_target {
+ my($self) = shift;
+
+ return <<'MAKE_FRAG';
+tardist : $(DISTVNAME).tar$(SUFFIX)
+ $(NOECHO) $(NOOP)
+MAKE_FRAG
+}
+
+=item B<zipdist_target>
+
+ my $make_frag = $MM->zipdist_target;
+
+Returns the 'zipdist' target which is simply so 'make zipdist' works.
+The real work is done by the dynamically named zipdistfile_target()
+method, zipdist should have that as a dependency.
+
+=cut
+
+sub zipdist_target {
+ my($self) = shift;
+
+ return <<'MAKE_FRAG';
+zipdist : $(DISTVNAME).zip
+ $(NOECHO) $(NOOP)
+MAKE_FRAG
+}
+
+=item B<tarfile_target>
+
+ my $make_frag = $MM->tarfile_target;
+
+The name of this target is the name of the tarball generated by
+tardist. This target does the actual work of turning the distdir into
+a tarball.
+
+=cut
+
+sub tarfile_target {
+ my($self) = shift;
+
+ return <<'MAKE_FRAG';
+$(DISTVNAME).tar$(SUFFIX) : distdir
+ $(PREOP)
+ $(TO_UNIX)
+ $(TAR) $(TARFLAGS) $(DISTVNAME).tar $(DISTVNAME)
+ $(RM_RF) $(DISTVNAME)
+ $(COMPRESS) $(DISTVNAME).tar
+ $(POSTOP)
+MAKE_FRAG
+}
+
+=item zipfile_target
+
+ my $make_frag = $MM->zipfile_target;
+
+The name of this target is the name of the zip file generated by
+zipdist. This target does the actual work of turning the distdir into
+a zip file.
+
+=cut
+
+sub zipfile_target {
+ my($self) = shift;
+
+ return <<'MAKE_FRAG';
+$(DISTVNAME).zip : distdir
+ $(PREOP)
+ $(ZIP) $(ZIPFLAGS) $(DISTVNAME).zip $(DISTVNAME)
+ $(RM_RF) $(DISTVNAME)
+ $(POSTOP)
+MAKE_FRAG
+}
+
+=item uutardist_target
+
+ my $make_frag = $MM->uutardist_target;
+
+Converts the tarfile into a uuencoded file
+
+=cut
+
+sub uutardist_target {
+ my($self) = shift;
+
+ return <<'MAKE_FRAG';
+uutardist : $(DISTVNAME).tar$(SUFFIX)
+ uuencode $(DISTVNAME).tar$(SUFFIX) $(DISTVNAME).tar$(SUFFIX) > $(DISTVNAME).tar$(SUFFIX)_uu
+MAKE_FRAG
+}
+
+
+=item shdist_target
+
+ my $make_frag = $MM->shdist_target;
+
+Converts the distdir into a shell archive.
+
+=cut
+
+sub shdist_target {
+ my($self) = shift;
+
+ return <<'MAKE_FRAG';
+shdist : distdir
+ $(PREOP)
+ $(SHAR) $(DISTVNAME) > $(DISTVNAME).shar
+ $(RM_RF) $(DISTVNAME)
+ $(POSTOP)
+MAKE_FRAG
+}
+
+
+=item dlsyms (o)
+
+Used by some OS' to define DL_FUNCS and DL_VARS and write the *.exp files.
+
+Normally just returns an empty string.
+
+=cut
+
+sub dlsyms {
+ return '';
+}
+
+
+=item dynamic_bs (o)
+
+Defines targets for bootstrap files.
+
+=cut
+
+sub dynamic_bs {
+ my($self, %attribs) = @_;
+ return '
+BOOTSTRAP =
+' unless $self->has_link_code();
+
+ my $target = $Is{VMS} ? '$(MMS$TARGET)' : '$@';
+
+ return sprintf <<'MAKE_FRAG', ($target) x 5;
+BOOTSTRAP = $(BASEEXT).bs
+
+# As Mkbootstrap might not write a file (if none is required)
+# we use touch to prevent make continually trying to remake it.
+# The DynaLoader only reads a non-empty file.
+$(BOOTSTRAP) : $(FIRST_MAKEFILE) $(BOOTDEP) $(INST_ARCHAUTODIR)$(DFSEP).exists
+ $(NOECHO) $(ECHO) "Running Mkbootstrap for $(NAME) ($(BSLOADLIBS))"
+ $(NOECHO) $(PERLRUN) \
+ "-MExtUtils::Mkbootstrap" \
+ -e "Mkbootstrap('$(BASEEXT)','$(BSLOADLIBS)');"
+ $(NOECHO) $(TOUCH) %s
+ $(CHMOD) $(PERM_RW) %s
+
+$(INST_BOOT) : $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DFSEP).exists
+ $(NOECHO) $(RM_RF) %s
+ - $(CP) $(BOOTSTRAP) %s
+ $(CHMOD) $(PERM_RW) %s
+MAKE_FRAG
+}
+
+=item dynamic_lib (o)
+
+Defines how to produce the *.so (or equivalent) files.
+
+=cut
+
+sub dynamic_lib {
+ my($self, %attribs) = @_;
+ return '' unless $self->needs_linking(); #might be because of a subdir
+
+ return '' unless $self->has_link_code;
+
+ my($otherldflags) = $attribs{OTHERLDFLAGS} || "";
+ my($inst_dynamic_dep) = $attribs{INST_DYNAMIC_DEP} || "";
+ my($armaybe) = $attribs{ARMAYBE} || $self->{ARMAYBE} || ":";
+ my($ldfrom) = '$(LDFROM)';
+ $armaybe = 'ar' if ($Is{OSF} and $armaybe eq ':');
+ my(@m);
+ my $ld_opt = $Is{OS2} ? '$(OPTIMIZE) ' : ''; # Useful on other systems too?
+ my $ld_fix = $Is{OS2} ? '|| ( $(RM_F) $@ && sh -c false )' : '';
+ push(@m,'
+# This section creates the dynamically loadable $(INST_DYNAMIC)
+# from $(OBJECT) and possibly $(MYEXTLIB).
+ARMAYBE = '.$armaybe.'
+OTHERLDFLAGS = '.$ld_opt.$otherldflags.'
+INST_DYNAMIC_DEP = '.$inst_dynamic_dep.'
+INST_DYNAMIC_FIX = '.$ld_fix.'
+
+$(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DFSEP).exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(PERL_ARCHIVE_AFTER) $(INST_DYNAMIC_DEP)
+');
+ if ($armaybe ne ':'){
+ $ldfrom = 'tmp$(LIB_EXT)';
+ push(@m,' $(ARMAYBE) cr '.$ldfrom.' $(OBJECT)'."\n");
+ push(@m,' $(RANLIB) '."$ldfrom\n");
+ }
+ $ldfrom = "-all $ldfrom -none" if $Is{OSF};
+
+ # The IRIX linker doesn't use LD_RUN_PATH
+ my $ldrun = $Is{IRIX} && $self->{LD_RUN_PATH} ?
+ qq{-rpath "$self->{LD_RUN_PATH}"} : '';
+
+ # For example in AIX the shared objects/libraries from previous builds
+ # linger quite a while in the shared dynalinker cache even when nobody
+ # is using them. This is painful if one for instance tries to restart
+ # a failed build because the link command will fail unnecessarily 'cos
+ # the shared object/library is 'busy'.
+ push(@m,' $(RM_F) $@
+');
+
+ my $libs = '$(LDLOADLIBS)';
+
+ if (($Is{NetBSD} || $Is{Interix}) && $Config{'useshrplib'} eq 'true') {
+ # Use nothing on static perl platforms, and to the flags needed
+ # to link against the shared libperl library on shared perl
+ # platforms. We peek at lddlflags to see if we need -Wl,-R
+ # or -R to add paths to the run-time library search path.
+ if ($Config{'lddlflags'} =~ /-Wl,-R/) {
+ $libs .= ' -L$(PERL_INC) -Wl,-R$(INSTALLARCHLIB)/CORE -Wl,-R$(PERL_ARCHLIB)/CORE -lperl';
+ } elsif ($Config{'lddlflags'} =~ /-R/) {
+ $libs .= ' -L$(PERL_INC) -R$(INSTALLARCHLIB)/CORE -R$(PERL_ARCHLIB)/CORE -lperl';
+ }
+ }
+
+ my $ld_run_path_shell = "";
+ if ($self->{LD_RUN_PATH} ne "") {
+ $ld_run_path_shell = 'LD_RUN_PATH="$(LD_RUN_PATH)" ';
+ }
+
+ push @m, sprintf <<'MAKE', $ld_run_path_shell, $ldrun, $ldfrom, $libs;
+ %s$(LD) %s $(LDDLFLAGS) %s $(OTHERLDFLAGS) -o $@ $(MYEXTLIB) \
+ $(PERL_ARCHIVE) %s $(PERL_ARCHIVE_AFTER) $(EXPORT_LIST) \
+ $(INST_DYNAMIC_FIX)
+MAKE
+
+ push @m, <<'MAKE';
+ $(CHMOD) $(PERM_RWX) $@
+MAKE
+
+ return join('', at m);
+}
+
+=item exescan
+
+Deprecated method. Use libscan instead.
+
+=cut
+
+sub exescan {
+ my($self,$path) = @_;
+ $path;
+}
+
+=item extliblist
+
+Called by init_others, and calls ext ExtUtils::Liblist. See
+L<ExtUtils::Liblist> for details.
+
+=cut
+
+sub extliblist {
+ my($self,$libs) = @_;
+ require ExtUtils::Liblist;
+ $self->ext($libs, $Verbose);
+}
+
+=item find_perl
+
+Finds the executables PERL and FULLPERL
+
+=cut
+
+sub find_perl {
+ my($self, $ver, $names, $dirs, $trace) = @_;
+
+ if ($trace >= 2){
+ print "Looking for perl $ver by these names:
+@$names
+in these dirs:
+@$dirs
+";
+ }
+
+ my $stderr_duped = 0;
+ local *STDERR_COPY;
+
+ unless ($Is{BSD}) {
+ # >& and lexical filehandles together give 5.6.2 indigestion
+ if( open(STDERR_COPY, '>&STDERR') ) { ## no critic
+ $stderr_duped = 1;
+ }
+ else {
+ warn <<WARNING;
+find_perl() can't dup STDERR: $!
+You might see some garbage while we search for Perl
+WARNING
+ }
+ }
+
+ foreach my $name (@$names){
+ foreach my $dir (@$dirs){
+ next unless defined $dir; # $self->{PERL_SRC} may be undefined
+ my ($abs, $val);
+ if ($self->file_name_is_absolute($name)) { # /foo/bar
+ $abs = $name;
+ } elsif ($self->canonpath($name) eq
+ $self->canonpath(basename($name))) { # foo
+ $abs = $self->catfile($dir, $name);
+ } else { # foo/bar
+ $abs = $self->catfile($Curdir, $name);
+ }
+ print "Checking $abs\n" if ($trace >= 2);
+ next unless $self->maybe_command($abs);
+ print "Executing $abs\n" if ($trace >= 2);
+
+ my $version_check = qq{$abs -le "require $ver; print qq{VER_OK}"};
+ $version_check = "$Config{run} $version_check"
+ if defined $Config{run} and length $Config{run};
+
+ # To avoid using the unportable 2>&1 to suppress STDERR,
+ # we close it before running the command.
+ # However, thanks to a thread library bug in many BSDs
+ # ( http://www.freebsd.org/cgi/query-pr.cgi?pr=51535 )
+ # we cannot use the fancier more portable way in here
+ # but instead need to use the traditional 2>&1 construct.
+ if ($Is{BSD}) {
+ $val = `$version_check 2>&1`;
+ } else {
+ close STDERR if $stderr_duped;
+ $val = `$version_check`;
+
+ # 5.6.2's 3-arg open doesn't work with >&
+ open STDERR, ">&STDERR_COPY" ## no critic
+ if $stderr_duped;
+ }
+
+ if ($val =~ /^VER_OK/m) {
+ print "Using PERL=$abs\n" if $trace;
+ return $abs;
+ } elsif ($trace >= 2) {
+ print "Result: '$val' ".($? >> 8)."\n";
+ }
+ }
+ }
+ print STDOUT "Unable to find a perl $ver (by these names: @$names, in these dirs: @$dirs)\n";
+ 0; # false and not empty
+}
+
+
+=item fixin
+
+ $mm->fixin(@files);
+
+Inserts the sharpbang or equivalent magic number to a set of @files.
+
+=cut
+
+sub fixin { # stolen from the pink Camel book, more or less
+ my ( $self, @files ) = @_;
+
+ my ($does_shbang) = $Config{'sharpbang'} =~ /^\s*\#\!/;
+ for my $file (@files) {
+ my $file_new = "$file.new";
+ my $file_bak = "$file.bak";
+
+ open( my $fixin, '<', $file ) or croak "Can't process '$file': $!";
+ local $/ = "\n";
+ chomp( my $line = <$fixin> );
+ next unless $line =~ s/^\s*\#!\s*//; # Not a shbang file.
+ # Now figure out the interpreter name.
+ my ( $cmd, $arg ) = split ' ', $line, 2;
+ $cmd =~ s!^.*/!!;
+
+ # Now look (in reverse) for interpreter in absolute PATH (unless perl).
+ my $interpreter;
+ if ( $cmd =~ m{^perl(?:\z|[^a-z])} ) {
+ if ( $Config{startperl} =~ m,^\#!.*/perl, ) {
+ $interpreter = $Config{startperl};
+ $interpreter =~ s,^\#!,,;
+ }
+ else {
+ $interpreter = $Config{perlpath};
+ }
+ }
+ else {
+ my (@absdirs)
+ = reverse grep { $self->file_name_is_absolute($_) } $self->path;
+ $interpreter = '';
+
+ foreach my $dir (@absdirs) {
+ if ( $self->maybe_command($cmd) ) {
+ warn "Ignoring $interpreter in $file\n"
+ if $Verbose && $interpreter;
+ $interpreter = $self->catfile( $dir, $cmd );
+ }
+ }
+ }
+
+ # Figure out how to invoke interpreter on this machine.
+
+ my ($shb) = "";
+ if ($interpreter) {
+ print STDOUT "Changing sharpbang in $file to $interpreter"
+ if $Verbose;
+
+ # this is probably value-free on DOSISH platforms
+ if ($does_shbang) {
+ $shb .= "$Config{'sharpbang'}$interpreter";
+ $shb .= ' ' . $arg if defined $arg;
+ $shb .= "\n";
+ }
+ $shb .= qq{
+eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}'
+ if 0; # not running under some shell
+} unless $Is{Win32}; # this won't work on win32, so don't
+ }
+ else {
+ warn "Can't find $cmd in PATH, $file unchanged"
+ if $Verbose;
+ next;
+ }
+
+ open( my $fixout, ">", "$file_new" ) or do {
+ warn "Can't create new $file: $!\n";
+ next;
+ };
+
+ # Print out the new #! line (or equivalent).
+ local $\;
+ local $/;
+ print $fixout $shb, <$fixin>;
+ close $fixin;
+ close $fixout;
+
+ chmod 0666, $file_bak;
+ unlink $file_bak;
+ unless ( _rename( $file, $file_bak ) ) {
+ warn "Can't rename $file to $file_bak: $!";
+ next;
+ }
+ unless ( _rename( $file_new, $file ) ) {
+ warn "Can't rename $file_new to $file: $!";
+ unless ( _rename( $file_bak, $file ) ) {
+ warn "Can't rename $file_bak back to $file either: $!";
+ warn "Leaving $file renamed as $file_bak\n";
+ }
+ next;
+ }
+ unlink $file_bak;
+ }
+ continue {
+ system("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
+ }
+}
+
+
+sub _rename {
+ my($old, $new) = @_;
+
+ foreach my $file ($old, $new) {
+ if( $Is{VMS} and basename($file) !~ /\./ ) {
+ # rename() in 5.8.0 on VMS will not rename a file if it
+ # does not contain a dot yet it returns success.
+ $file = "$file.";
+ }
+ }
+
+ return rename($old, $new);
+}
+
+
+=item force (o)
+
+Writes an empty FORCE: target.
+
+=cut
+
+sub force {
+ my($self) = shift;
+ '# Phony target to force checking subdirectories.
+FORCE :
+ $(NOECHO) $(NOOP)
+';
+}
+
+=item guess_name
+
+Guess the name of this package by examining the working directory's
+name. MakeMaker calls this only if the developer has not supplied a
+NAME attribute.
+
+=cut
+
+# ';
+
+sub guess_name {
+ my($self) = @_;
+ use Cwd 'cwd';
+ my $name = basename(cwd());
+ $name =~ s|[\-_][\d\.\-]+\z||; # this is new with MM 5.00, we
+ # strip minus or underline
+ # followed by a float or some such
+ print "Warning: Guessing NAME [$name] from current directory name.\n";
+ $name;
+}
+
+=item has_link_code
+
+Returns true if C, XS, MYEXTLIB or similar objects exist within this
+object that need a compiler. Does not descend into subdirectories as
+needs_linking() does.
+
+=cut
+
+sub has_link_code {
+ my($self) = shift;
+ return $self->{HAS_LINK_CODE} if defined $self->{HAS_LINK_CODE};
+ if ($self->{OBJECT} or @{$self->{C} || []} or $self->{MYEXTLIB}){
+ $self->{HAS_LINK_CODE} = 1;
+ return 1;
+ }
+ return $self->{HAS_LINK_CODE} = 0;
+}
+
+
+=item init_dirscan
+
+Scans the directory structure and initializes DIR, XS, XS_FILES,
+C, C_FILES, O_FILES, H, H_FILES, PL_FILES, EXE_FILES.
+
+Called by init_main.
+
+=cut
+
+sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc)
+ my($self) = @_;
+ my(%dir, %xs, %c, %h, %pl_files, %pm);
+
+ my %ignore = map {( $_ => 1 )} qw(Makefile.PL Build.PL test.pl t);
+
+ # ignore the distdir
+ $Is{VMS} ? $ignore{"$self->{DISTVNAME}.dir"} = 1
+ : $ignore{$self->{DISTVNAME}} = 1;
+
+ @ignore{map lc, keys %ignore} = values %ignore if $Is{VMS};
+
+ foreach my $name ($self->lsdir($Curdir)){
+ next if $name =~ /\#/;
+ next if $name eq $Curdir or $name eq $Updir or $ignore{$name};
+ next unless $self->libscan($name);
+ if (-d $name){
+ next if -l $name; # We do not support symlinks at all
+ next if $self->{NORECURS};
+ $dir{$name} = $name if (-f $self->catfile($name,"Makefile.PL"));
+ } elsif ($name =~ /\.xs\z/){
+ my($c); ($c = $name) =~ s/\.xs\z/.c/;
+ $xs{$name} = $c;
+ $c{$c} = 1;
+ } elsif ($name =~ /\.c(pp|xx|c)?\z/i){ # .c .C .cpp .cxx .cc
+ $c{$name} = 1
+ unless $name =~ m/perlmain\.c/; # See MAP_TARGET
+ } elsif ($name =~ /\.h\z/i){
+ $h{$name} = 1;
+ } elsif ($name =~ /\.PL\z/) {
+ ($pl_files{$name} = $name) =~ s/\.PL\z// ;
+ } elsif (($Is{VMS} || $Is{Dos}) && $name =~ /[._]pl$/i) {
+ # case-insensitive filesystem, one dot per name, so foo.h.PL
+ # under Unix appears as foo.h_pl under VMS or fooh.pl on Dos
+ local($/); open(my $pl, '<', $name); my $txt = <$pl>; close $pl;
+ if ($txt =~ /Extracting \S+ \(with variable substitutions/) {
+ ($pl_files{$name} = $name) =~ s/[._]pl\z//i ;
+ }
+ else {
+ $pm{$name} = $self->catfile($self->{INST_LIBDIR},$name);
+ }
+ } elsif ($name =~ /\.(p[ml]|pod)\z/){
+ $pm{$name} = $self->catfile($self->{INST_LIBDIR},$name);
+ }
+ }
+
+ $self->{PL_FILES} ||= \%pl_files;
+ $self->{DIR} ||= [sort keys %dir];
+ $self->{XS} ||= \%xs;
+ $self->{C} ||= [sort keys %c];
+ $self->{H} ||= [sort keys %h];
+ $self->{PM} ||= \%pm;
+
+ my @o_files = @{$self->{C}};
+ $self->{O_FILES} = [grep s/\.c(pp|xx|c)?\z/$self->{OBJ_EXT}/i, @o_files];
+}
+
+
+=item init_MANPODS
+
+Determines if man pages should be generated and initializes MAN1PODS
+and MAN3PODS as appropriate.
+
+=cut
+
+sub init_MANPODS {
+ my $self = shift;
+
+ # Set up names of manual pages to generate from pods
+ foreach my $man (qw(MAN1 MAN3)) {
+ if ( $self->{"${man}PODS"}
+ or $self->{"INSTALL${man}DIR"} =~ /^(none|\s*)$/
+ ) {
+ $self->{"${man}PODS"} ||= {};
+ }
+ else {
+ my $init_method = "init_${man}PODS";
+ $self->$init_method();
+ }
+ }
+}
+
+
+sub _has_pod {
+ my($self, $file) = @_;
+
+ my($ispod)=0;
+ if (open( my $fh, '<', $file )) {
+ while (<$fh>) {
+ if (/^=(?:head\d+|item|pod)\b/) {
+ $ispod=1;
+ last;
+ }
+ }
+ close $fh;
+ } else {
+ # If it doesn't exist yet, we assume, it has pods in it
+ $ispod = 1;
+ }
+
+ return $ispod;
+}
+
+
+=item init_MAN1PODS
+
+Initializes MAN1PODS from the list of EXE_FILES.
+
+=cut
+
+sub init_MAN1PODS {
+ my($self) = @_;
+
+ if ( exists $self->{EXE_FILES} ) {
+ foreach my $name (@{$self->{EXE_FILES}}) {
+ next unless $self->_has_pod($name);
+
+ $self->{MAN1PODS}->{$name} =
+ $self->catfile("\$(INST_MAN1DIR)",
+ basename($name).".\$(MAN1EXT)");
+ }
+ }
+}
+
+
+=item init_MAN3PODS
+
+Initializes MAN3PODS from the list of PM files.
+
+=cut
+
+sub init_MAN3PODS {
+ my $self = shift;
+
+ my %manifypods = (); # we collect the keys first, i.e. the files
+ # we have to convert to pod
+
+ foreach my $name (keys %{$self->{PM}}) {
+ if ($name =~ /\.pod\z/ ) {
+ $manifypods{$name} = $self->{PM}{$name};
+ } elsif ($name =~ /\.p[ml]\z/ ) {
+ if( $self->_has_pod($name) ) {
+ $manifypods{$name} = $self->{PM}{$name};
+ }
+ }
+ }
+
+ my $parentlibs_re = join '|', @{$self->{PMLIBPARENTDIRS}};
+
+ # Remove "Configure.pm" and similar, if it's not the only pod listed
+ # To force inclusion, just name it "Configure.pod", or override
+ # MAN3PODS
+ foreach my $name (keys %manifypods) {
+ if ($self->{PERL_CORE} and $name =~ /(config|setup).*\.pm/is) {
+ delete $manifypods{$name};
+ next;
+ }
+ my($manpagename) = $name;
+ $manpagename =~ s/\.p(od|m|l)\z//;
+ # everything below lib is ok
+ unless($manpagename =~ s!^\W*($parentlibs_re)\W+!!s) {
+ $manpagename = $self->catfile(
+ split(/::/,$self->{PARENT_NAME}),$manpagename
+ );
+ }
+ $manpagename = $self->replace_manpage_separator($manpagename);
+ $self->{MAN3PODS}->{$name} =
+ $self->catfile("\$(INST_MAN3DIR)", "$manpagename.\$(MAN3EXT)");
+ }
+}
+
+
+=item init_PM
+
+Initializes PMLIBDIRS and PM from PMLIBDIRS.
+
+=cut
+
+sub init_PM {
+ my $self = shift;
+
+ # Some larger extensions often wish to install a number of *.pm/pl
+ # files into the library in various locations.
+
+ # The attribute PMLIBDIRS holds an array reference which lists
+ # subdirectories which we should search for library files to
+ # install. PMLIBDIRS defaults to [ 'lib', $self->{BASEEXT} ]. We
+ # recursively search through the named directories (skipping any
+ # which don't exist or contain Makefile.PL files).
+
+ # For each *.pm or *.pl file found $self->libscan() is called with
+ # the default installation path in $_[1]. The return value of
+ # libscan defines the actual installation location. The default
+ # libscan function simply returns the path. The file is skipped
+ # if libscan returns false.
+
+ # The default installation location passed to libscan in $_[1] is:
+ #
+ # ./*.pm => $(INST_LIBDIR)/*.pm
+ # ./xyz/... => $(INST_LIBDIR)/xyz/...
+ # ./lib/... => $(INST_LIB)/...
+ #
+ # In this way the 'lib' directory is seen as the root of the actual
+ # perl library whereas the others are relative to INST_LIBDIR
+ # (which includes PARENT_NAME). This is a subtle distinction but one
+ # that's important for nested modules.
+
+ unless( $self->{PMLIBDIRS} ) {
+ if( $Is{VMS} ) {
+ # Avoid logical name vs directory collisions
+ $self->{PMLIBDIRS} = ['./lib', "./$self->{BASEEXT}"];
+ }
+ else {
+ $self->{PMLIBDIRS} = ['lib', $self->{BASEEXT}];
+ }
+ }
+
+ #only existing directories that aren't in $dir are allowed
+
+ # Avoid $_ wherever possible:
+ # @{$self->{PMLIBDIRS}} = grep -d && !$dir{$_}, @{$self->{PMLIBDIRS}};
+ my (@pmlibdirs) = @{$self->{PMLIBDIRS}};
+ @{$self->{PMLIBDIRS}} = ();
+ my %dir = map { ($_ => $_) } @{$self->{DIR}};
+ foreach my $pmlibdir (@pmlibdirs) {
+ -d $pmlibdir && !$dir{$pmlibdir} && push @{$self->{PMLIBDIRS}}, $pmlibdir;
+ }
+
+ unless( $self->{PMLIBPARENTDIRS} ) {
+ @{$self->{PMLIBPARENTDIRS}} = ('lib');
+ }
+
+ return if $self->{PM} and $self->{ARGS}{PM};
+
+ if (@{$self->{PMLIBDIRS}}){
+ print "Searching PMLIBDIRS: @{$self->{PMLIBDIRS}}\n"
+ if ($Verbose >= 2);
+ require File::Find;
+ File::Find::find(sub {
+ if (-d $_){
+ unless ($self->libscan($_)){
+ $File::Find::prune = 1;
+ }
+ return;
+ }
+ return if /\#/;
+ return if /~$/; # emacs temp files
+ return if /,v$/; # RCS files
+ return if m{\.swp$}; # vim swap files
+
+ my $path = $File::Find::name;
+ my $prefix = $self->{INST_LIBDIR};
+ my $striplibpath;
+
+ my $parentlibs_re = join '|', @{$self->{PMLIBPARENTDIRS}};
+ $prefix = $self->{INST_LIB}
+ if ($striplibpath = $path) =~ s{^(\W*)($parentlibs_re)\W}
+ {$1}i;
+
+ my($inst) = $self->catfile($prefix,$striplibpath);
+ local($_) = $inst; # for backwards compatibility
+ $inst = $self->libscan($inst);
+ print "libscan($path) => '$inst'\n" if ($Verbose >= 2);
+ return unless $inst;
+ $self->{PM}{$path} = $inst;
+ }, @{$self->{PMLIBDIRS}});
+ }
+}
+
+
+=item init_DIRFILESEP
+
+Using / for Unix. Called by init_main.
+
+=cut
+
+sub init_DIRFILESEP {
+ my($self) = shift;
+
+ $self->{DIRFILESEP} = '/';
+}
+
+
+=item init_main
+
+Initializes AR, AR_STATIC_ARGS, BASEEXT, CONFIG, DISTNAME, DLBASE,
+EXE_EXT, FULLEXT, FULLPERL, FULLPERLRUN, FULLPERLRUNINST, INST_*,
+INSTALL*, INSTALLDIRS, LIB_EXT, LIBPERL_A, MAP_TARGET, NAME,
+OBJ_EXT, PARENT_NAME, PERL, PERL_ARCHLIB, PERL_INC, PERL_LIB,
+PERL_SRC, PERLRUN, PERLRUNINST, PREFIX, VERSION,
+VERSION_SYM, XS_VERSION.
+
+=cut
+
+sub init_main {
+ my($self) = @_;
+
+ # --- Initialize Module Name and Paths
+
+ # NAME = Foo::Bar::Oracle
+ # FULLEXT = Foo/Bar/Oracle
+ # BASEEXT = Oracle
+ # PARENT_NAME = Foo::Bar
+### Only UNIX:
+### ($self->{FULLEXT} =
+### $self->{NAME}) =~ s!::!/!g ; #eg. BSD/Foo/Socket
+ $self->{FULLEXT} = $self->catdir(split /::/, $self->{NAME});
+
+
+ # Copied from DynaLoader:
+
+ my(@modparts) = split(/::/,$self->{NAME});
+ my($modfname) = $modparts[-1];
+
+ # Some systems have restrictions on files names for DLL's etc.
+ # mod2fname returns appropriate file base name (typically truncated)
+ # It may also edit @modparts if required.
+ if (defined &DynaLoader::mod2fname) {
+ $modfname = &DynaLoader::mod2fname(\@modparts);
+ }
+
+ ($self->{PARENT_NAME}, $self->{BASEEXT}) = $self->{NAME} =~ m!(?:([\w:]+)::)?(\w+)\z! ;
+ $self->{PARENT_NAME} ||= '';
+
+ if (defined &DynaLoader::mod2fname) {
+ # As of 5.001m, dl_os2 appends '_'
+ $self->{DLBASE} = $modfname;
+ } else {
+ $self->{DLBASE} = '$(BASEEXT)';
+ }
+
+
+ # --- Initialize PERL_LIB, PERL_SRC
+
+ # *Real* information: where did we get these two from? ...
+ my $inc_config_dir = dirname($INC{'Config.pm'});
+ my $inc_carp_dir = dirname($INC{'Carp.pm'});
+
+ unless ($self->{PERL_SRC}){
+ foreach my $dir_count (1..8) { # 8 is the VMS limit for nesting
+ my $dir = $self->catdir(($Updir) x $dir_count);
+
+ if (-f $self->catfile($dir,"config_h.SH") &&
+ -f $self->catfile($dir,"perl.h") &&
+ -f $self->catfile($dir,"lib","strict.pm")
+ ) {
+ $self->{PERL_SRC}=$dir ;
+ last;
+ }
+ }
+ }
+
+ warn "PERL_CORE is set but I can't find your PERL_SRC!\n" if
+ $self->{PERL_CORE} and !$self->{PERL_SRC};
+
+ if ($self->{PERL_SRC}){
+ $self->{PERL_LIB} ||= $self->catdir("$self->{PERL_SRC}","lib");
+
+ if (defined $Cross::platform) {
+ $self->{PERL_ARCHLIB} =
+ $self->catdir("$self->{PERL_SRC}","xlib",$Cross::platform);
+ $self->{PERL_INC} =
+ $self->catdir("$self->{PERL_SRC}","xlib",$Cross::platform,
+ $Is{Win32}?("CORE"):());
+ }
+ else {
+ $self->{PERL_ARCHLIB} = $self->{PERL_LIB};
+ $self->{PERL_INC} = ($Is{Win32}) ?
+ $self->catdir($self->{PERL_LIB},"CORE") : $self->{PERL_SRC};
+ }
+
+ # catch a situation that has occurred a few times in the past:
+ unless (
+ -s $self->catfile($self->{PERL_SRC},'cflags')
+ or
+ $Is{VMS}
+ &&
+ -s $self->catfile($self->{PERL_SRC},'perlshr_attr.opt')
+ or
+ $Is{Win32}
+ ){
+ warn qq{
+You cannot build extensions below the perl source tree after executing
+a 'make clean' in the perl source tree.
+
+To rebuild extensions distributed with the perl source you should
+simply Configure (to include those extensions) and then build perl as
+normal. After installing perl the source tree can be deleted. It is
+not needed for building extensions by running 'perl Makefile.PL'
+usually without extra arguments.
+
+It is recommended that you unpack and build additional extensions away
+from the perl source tree.
+};
+ }
+ } else {
+ # we should also consider $ENV{PERL5LIB} here
+ my $old = $self->{PERL_LIB} || $self->{PERL_ARCHLIB} || $self->{PERL_INC};
+ $self->{PERL_LIB} ||= $Config{privlibexp};
+ $self->{PERL_ARCHLIB} ||= $Config{archlibexp};
+ $self->{PERL_INC} = $self->catdir("$self->{PERL_ARCHLIB}","CORE"); # wild guess for now
+ my $perl_h;
+
+ if (not -f ($perl_h = $self->catfile($self->{PERL_INC},"perl.h"))
+ and not $old){
+ # Maybe somebody tries to build an extension with an
+ # uninstalled Perl outside of Perl build tree
+ my $lib;
+ for my $dir (@INC) {
+ $lib = $dir, last if -e $self->catfile($dir, "Config.pm");
+ }
+ if ($lib) {
+ # Win32 puts its header files in /perl/src/lib/CORE.
+ # Unix leaves them in /perl/src.
+ my $inc = $Is{Win32} ? $self->catdir($lib, "CORE" )
+ : dirname $lib;
+ if (-e $self->catfile($inc, "perl.h")) {
+ $self->{PERL_LIB} = $lib;
+ $self->{PERL_ARCHLIB} = $lib;
+ $self->{PERL_INC} = $inc;
+ $self->{UNINSTALLED_PERL} = 1;
+ print STDOUT <<EOP;
+... Detected uninstalled Perl. Trying to continue.
+EOP
+ }
+ }
+ }
+ }
+
+ # We get SITELIBEXP and SITEARCHEXP directly via
+ # Get_from_Config. When we are running standard modules, these
+ # won't matter, we will set INSTALLDIRS to "perl". Otherwise we
+ # set it to "site". I prefer that INSTALLDIRS be set from outside
+ # MakeMaker.
+ $self->{INSTALLDIRS} ||= "site";
+
+ $self->{MAN1EXT} ||= $Config{man1ext};
+ $self->{MAN3EXT} ||= $Config{man3ext};
+
+ # Get some stuff out of %Config if we haven't yet done so
+ print STDOUT "CONFIG must be an array ref\n"
+ if ($self->{CONFIG} and ref $self->{CONFIG} ne 'ARRAY');
+ $self->{CONFIG} = [] unless (ref $self->{CONFIG});
+ push(@{$self->{CONFIG}}, @ExtUtils::MakeMaker::Get_from_Config);
+ push(@{$self->{CONFIG}}, 'shellflags') if $Config{shellflags};
+ my(%once_only);
+ foreach my $m (@{$self->{CONFIG}}){
+ next if $once_only{$m};
+ print STDOUT "CONFIG key '$m' does not exist in Config.pm\n"
+ unless exists $Config{$m};
+ $self->{uc $m} ||= $Config{$m};
+ $once_only{$m} = 1;
+ }
+
+# This is too dangerous:
+# if ($^O eq "next") {
+# $self->{AR} = "libtool";
+# $self->{AR_STATIC_ARGS} = "-o";
+# }
+# But I leave it as a placeholder
+
+ $self->{AR_STATIC_ARGS} ||= "cr";
+
+ # These should never be needed
+ $self->{OBJ_EXT} ||= '.o';
+ $self->{LIB_EXT} ||= '.a';
+
+ $self->{MAP_TARGET} ||= "perl";
+
+ $self->{LIBPERL_A} ||= "libperl$self->{LIB_EXT}";
+
+ # make a simple check if we find strict
+ warn "Warning: PERL_LIB ($self->{PERL_LIB}) seems not to be a perl library directory
+ (strict.pm not found)"
+ unless -f $self->catfile("$self->{PERL_LIB}","strict.pm") ||
+ $self->{NAME} eq "ExtUtils::MakeMaker";
+}
+
+=item init_others
+
+Initializes EXTRALIBS, BSLOADLIBS, LDLOADLIBS, LIBS, LD_RUN_PATH, LD,
+OBJECT, BOOTDEP, PERLMAINCC, LDFROM, LINKTYPE, SHELL, NOOP,
+FIRST_MAKEFILE, MAKEFILE_OLD, NOECHO, RM_F, RM_RF, TEST_F,
+TOUCH, CP, MV, CHMOD, UMASK_NULL, ECHO, ECHO_N
+
+=cut
+
+sub init_others { # --- Initialize Other Attributes
+ my($self) = shift;
+
+ $self->{ECHO} ||= 'echo';
+ $self->{ECHO_N} ||= 'echo -n';
+ $self->{RM_F} ||= "rm -f";
+ $self->{RM_RF} ||= "rm -rf";
+ $self->{TOUCH} ||= "touch";
+ $self->{TEST_F} ||= "test -f";
+ $self->{CP} ||= "cp";
+ $self->{MV} ||= "mv";
+ $self->{CHMOD} ||= "chmod";
+ $self->{FALSE} ||= 'false';
+ $self->{TRUE} ||= 'true';
+
+ $self->{LD} ||= 'ld';
+
+ $self->SUPER::init_others(@_);
+
+ # After SUPER::init_others so $Config{shell} has a
+ # chance to get set.
+ $self->{SHELL} ||= '/bin/sh';
+
+ return 1;
+}
+
+
+=item init_linker
+
+Unix has no need of special linker flags.
+
+=cut
+
+sub init_linker {
+ my($self) = shift;
+ $self->{PERL_ARCHIVE} ||= '';
+ $self->{PERL_ARCHIVE_AFTER} ||= '';
+ $self->{EXPORT_LIST} ||= '';
+}
+
+
+=begin _protected
+
+=item init_lib2arch
+
+ $mm->init_lib2arch
+
+=end _protected
+
+=cut
+
+sub init_lib2arch {
+ my($self) = shift;
+
+ # The user who requests an installation directory explicitly
+ # should not have to tell us an architecture installation directory
+ # as well. We look if a directory exists that is named after the
+ # architecture. If not we take it as a sign that it should be the
+ # same as the requested installation directory. Otherwise we take
+ # the found one.
+ for my $libpair ({l=>"privlib", a=>"archlib"},
+ {l=>"sitelib", a=>"sitearch"},
+ {l=>"vendorlib", a=>"vendorarch"},
+ )
+ {
+ my $lib = "install$libpair->{l}";
+ my $Lib = uc $lib;
+ my $Arch = uc "install$libpair->{a}";
+ if( $self->{$Lib} && ! $self->{$Arch} ){
+ my($ilib) = $Config{$lib};
+
+ $self->prefixify($Arch,$ilib,$self->{$Lib});
+
+ unless (-d $self->{$Arch}) {
+ print STDOUT "Directory $self->{$Arch} not found\n"
+ if $Verbose;
+ $self->{$Arch} = $self->{$Lib};
+ }
+ print STDOUT "Defaulting $Arch to $self->{$Arch}\n" if $Verbose;
+ }
+ }
+}
+
+
+=item init_PERL
+
+ $mm->init_PERL;
+
+Called by init_main. Sets up ABSPERL, PERL, FULLPERL and all the
+*PERLRUN* permutations.
+
+ PERL is allowed to be miniperl
+ FULLPERL must be a complete perl
+
+ ABSPERL is PERL converted to an absolute path
+
+ *PERLRUN contains everything necessary to run perl, find it's
+ libraries, etc...
+
+ *PERLRUNINST is *PERLRUN + everything necessary to find the
+ modules being built.
+
+=cut
+
+sub init_PERL {
+ my($self) = shift;
+
+ my @defpath = ();
+ foreach my $component ($self->{PERL_SRC}, $self->path(),
+ $Config{binexp})
+ {
+ push @defpath, $component if defined $component;
+ }
+
+ # Build up a set of file names (not command names).
+ my $thisperl = $self->canonpath($^X);
+ $thisperl .= $Config{exe_ext} unless
+ # VMS might have a file version # at the end
+ $Is{VMS} ? $thisperl =~ m/$Config{exe_ext}(;\d+)?$/i
+ : $thisperl =~ m/$Config{exe_ext}$/i;
+
+ # We need a relative path to perl when in the core.
+ $thisperl = $self->abs2rel($thisperl) if $self->{PERL_CORE};
+
+ my @perls = ($thisperl);
+ push @perls, map { "$_$Config{exe_ext}" }
+ ('perl', 'perl5', "perl$Config{version}");
+
+ # miniperl has priority over all but the cannonical perl when in the
+ # core. Otherwise its a last resort.
+ my $miniperl = "miniperl$Config{exe_ext}";
+ if( $self->{PERL_CORE} ) {
+ splice @perls, 1, 0, $miniperl;
+ }
+ else {
+ push @perls, $miniperl;
+ }
+
+ $self->{PERL} ||=
+ $self->find_perl(5.0, \@perls, \@defpath, $Verbose );
+ # don't check if perl is executable, maybe they have decided to
+ # supply switches with perl
+
+ # When built for debugging, VMS doesn't create perl.exe but ndbgperl.exe.
+ my $perl_name = 'perl';
+ $perl_name = 'ndbgperl' if $Is{VMS} &&
+ defined $Config{usevmsdebug} && $Config{usevmsdebug} eq 'define';
+
+ # XXX This logic is flawed. If "miniperl" is anywhere in the path
+ # it will get confused. It should be fixed to work only on the filename.
+ # Define 'FULLPERL' to be a non-miniperl (used in test: target)
+ ($self->{FULLPERL} = $self->{PERL}) =~ s/miniperl/$perl_name/i
+ unless $self->{FULLPERL};
+
+ # Little hack to get around VMS's find_perl putting "MCR" in front
+ # sometimes.
+ $self->{ABSPERL} = $self->{PERL};
+ my $has_mcr = $self->{ABSPERL} =~ s/^MCR\s*//;
+ if( $self->file_name_is_absolute($self->{ABSPERL}) ) {
+ $self->{ABSPERL} = '$(PERL)';
+ }
+ else {
+ $self->{ABSPERL} = $self->rel2abs($self->{ABSPERL});
+
+ # Quote the perl command if it contains whitespace
+ $self->{ABSPERL} = $self->quote_literal($self->{ABSPERL})
+ if $self->{ABSPERL} =~ /\s/;
+
+ $self->{ABSPERL} = 'MCR '.$self->{ABSPERL} if $has_mcr;
+ }
+
+ # Are we building the core?
+ $self->{PERL_CORE} = $ENV{PERL_CORE} unless exists $self->{PERL_CORE};
+ $self->{PERL_CORE} = 0 unless defined $self->{PERL_CORE};
+
+ # How do we run perl?
+ foreach my $perl (qw(PERL FULLPERL ABSPERL)) {
+ my $run = $perl.'RUN';
+
+ $self->{$run} = "\$($perl)";
+
+ # Make sure perl can find itself before it's installed.
+ $self->{$run} .= q{ "-I$(PERL_LIB)" "-I$(PERL_ARCHLIB)"}
+ if $self->{UNINSTALLED_PERL} || $self->{PERL_CORE};
+
+ $self->{$perl.'RUNINST'} =
+ sprintf q{$(%sRUN) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)"}, $perl;
+ }
+
+ return 1;
+}
+
+
+=item init_platform
+
+=item platform_constants
+
+Add MM_Unix_VERSION.
+
+=cut
+
+sub init_platform {
+ my($self) = shift;
+
+ $self->{MM_Unix_VERSION} = $VERSION;
+ $self->{PERL_MALLOC_DEF} = '-DPERL_EXTMALLOC_DEF -Dmalloc=Perl_malloc '.
+ '-Dfree=Perl_mfree -Drealloc=Perl_realloc '.
+ '-Dcalloc=Perl_calloc';
+
+}
+
+sub platform_constants {
+ my($self) = shift;
+ my $make_frag = '';
+
+ foreach my $macro (qw(MM_Unix_VERSION PERL_MALLOC_DEF))
+ {
+ next unless defined $self->{$macro};
+ $make_frag .= "$macro = $self->{$macro}\n";
+ }
+
+ return $make_frag;
+}
+
+
+=item init_PERM
+
+ $mm->init_PERM
+
+Called by init_main. Initializes PERL_*
+
+=cut
+
+sub init_PERM {
+ my($self) = shift;
+
+ $self->{PERM_DIR} = 755 unless defined $self->{PERM_DIR};
+ $self->{PERM_RW} = 644 unless defined $self->{PERM_RW};
+ $self->{PERM_RWX} = 755 unless defined $self->{PERM_RWX};
+
+ return 1;
+}
+
+
+=item init_xs
+
+ $mm->init_xs
+
+Sets up macros having to do with XS code. Currently just INST_STATIC,
+INST_DYNAMIC and INST_BOOT.
+
+=cut
+
+sub init_xs {
+ my $self = shift;
+
+ if ($self->has_link_code()) {
+ $self->{INST_STATIC} =
+ $self->catfile('$(INST_ARCHAUTODIR)', '$(BASEEXT)$(LIB_EXT)');
+ $self->{INST_DYNAMIC} =
+ $self->catfile('$(INST_ARCHAUTODIR)', '$(DLBASE).$(DLEXT)');
+ $self->{INST_BOOT} =
+ $self->catfile('$(INST_ARCHAUTODIR)', '$(BASEEXT).bs');
+ } else {
+ $self->{INST_STATIC} = '';
+ $self->{INST_DYNAMIC} = '';
+ $self->{INST_BOOT} = '';
+ }
+}
+
+=item install (o)
+
+Defines the install target.
+
+=cut
+
+sub install {
+ my($self, %attribs) = @_;
+ my(@m);
+
+ push @m, q{
+install :: pure_install doc_install
+ $(NOECHO) $(NOOP)
+
+install_perl :: pure_perl_install doc_perl_install
+ $(NOECHO) $(NOOP)
+
+install_site :: pure_site_install doc_site_install
+ $(NOECHO) $(NOOP)
+
+install_vendor :: pure_vendor_install doc_vendor_install
+ $(NOECHO) $(NOOP)
+
+pure_install :: pure_$(INSTALLDIRS)_install
+ $(NOECHO) $(NOOP)
+
+doc_install :: doc_$(INSTALLDIRS)_install
+ $(NOECHO) $(NOOP)
+
+pure__install : pure_site_install
+ $(NOECHO) $(ECHO) INSTALLDIRS not defined, defaulting to INSTALLDIRS=site
+
+doc__install : doc_site_install
+ $(NOECHO) $(ECHO) INSTALLDIRS not defined, defaulting to INSTALLDIRS=site
+
+pure_perl_install :: all
+ $(NOECHO) $(MOD_INSTALL) \
+ read }.$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q{ \
+ write }.$self->catfile('$(DESTINSTALLARCHLIB)','auto','$(FULLEXT)','.packlist').q{ \
+ $(INST_LIB) $(DESTINSTALLPRIVLIB) \
+ $(INST_ARCHLIB) $(DESTINSTALLARCHLIB) \
+ $(INST_BIN) $(DESTINSTALLBIN) \
+ $(INST_SCRIPT) $(DESTINSTALLSCRIPT) \
+ $(INST_MAN1DIR) $(DESTINSTALLMAN1DIR) \
+ $(INST_MAN3DIR) $(DESTINSTALLMAN3DIR)
+ $(NOECHO) $(WARN_IF_OLD_PACKLIST) \
+ }.$self->catdir('$(SITEARCHEXP)','auto','$(FULLEXT)').q{
+
+
+pure_site_install :: all
+ $(NOECHO) $(MOD_INSTALL) \
+ read }.$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q{ \
+ write }.$self->catfile('$(DESTINSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').q{ \
+ $(INST_LIB) $(DESTINSTALLSITELIB) \
+ $(INST_ARCHLIB) $(DESTINSTALLSITEARCH) \
+ $(INST_BIN) $(DESTINSTALLSITEBIN) \
+ $(INST_SCRIPT) $(DESTINSTALLSITESCRIPT) \
+ $(INST_MAN1DIR) $(DESTINSTALLSITEMAN1DIR) \
+ $(INST_MAN3DIR) $(DESTINSTALLSITEMAN3DIR)
+ $(NOECHO) $(WARN_IF_OLD_PACKLIST) \
+ }.$self->catdir('$(PERL_ARCHLIB)','auto','$(FULLEXT)').q{
+
+pure_vendor_install :: all
+ $(NOECHO) $(MOD_INSTALL) \
+ read }.$self->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').q{ \
+ write }.$self->catfile('$(DESTINSTALLVENDORARCH)','auto','$(FULLEXT)','.packlist').q{ \
+ $(INST_LIB) $(DESTINSTALLVENDORLIB) \
+ $(INST_ARCHLIB) $(DESTINSTALLVENDORARCH) \
+ $(INST_BIN) $(DESTINSTALLVENDORBIN) \
+ $(INST_SCRIPT) $(DESTINSTALLVENDORSCRIPT) \
+ $(INST_MAN1DIR) $(DESTINSTALLVENDORMAN1DIR) \
+ $(INST_MAN3DIR) $(DESTINSTALLVENDORMAN3DIR)
+
+doc_perl_install :: all
+ $(NOECHO) $(ECHO) Appending installation info to $(DESTINSTALLARCHLIB)/perllocal.pod
+ -$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
+ -$(NOECHO) $(DOC_INSTALL) \
+ "Module" "$(NAME)" \
+ "installed into" "$(INSTALLPRIVLIB)" \
+ LINKTYPE "$(LINKTYPE)" \
+ VERSION "$(VERSION)" \
+ EXE_FILES "$(EXE_FILES)" \
+ >> }.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{
+
+doc_site_install :: all
+ $(NOECHO) $(ECHO) Appending installation info to $(DESTINSTALLARCHLIB)/perllocal.pod
+ -$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
+ -$(NOECHO) $(DOC_INSTALL) \
+ "Module" "$(NAME)" \
+ "installed into" "$(INSTALLSITELIB)" \
+ LINKTYPE "$(LINKTYPE)" \
+ VERSION "$(VERSION)" \
+ EXE_FILES "$(EXE_FILES)" \
+ >> }.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{
+
+doc_vendor_install :: all
+ $(NOECHO) $(ECHO) Appending installation info to $(DESTINSTALLARCHLIB)/perllocal.pod
+ -$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
+ -$(NOECHO) $(DOC_INSTALL) \
+ "Module" "$(NAME)" \
+ "installed into" "$(INSTALLVENDORLIB)" \
+ LINKTYPE "$(LINKTYPE)" \
+ VERSION "$(VERSION)" \
+ EXE_FILES "$(EXE_FILES)" \
+ >> }.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{
+
+};
+
+ push @m, q{
+uninstall :: uninstall_from_$(INSTALLDIRS)dirs
+ $(NOECHO) $(NOOP)
+
+uninstall_from_perldirs ::
+ $(NOECHO) $(UNINSTALL) }.$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q{
+
+uninstall_from_sitedirs ::
+ $(NOECHO) $(UNINSTALL) }.$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q{
+
+uninstall_from_vendordirs ::
+ $(NOECHO) $(UNINSTALL) }.$self->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').q{
+};
+
+ join("", at m);
+}
+
+=item installbin (o)
+
+Defines targets to make and to install EXE_FILES.
+
+=cut
+
+sub installbin {
+ my($self) = shift;
+
+ return "" unless $self->{EXE_FILES} && ref $self->{EXE_FILES} eq "ARRAY";
+ my @exefiles = @{$self->{EXE_FILES}};
+ return "" unless @exefiles;
+
+ @exefiles = map vmsify($_), @exefiles if $Is{VMS};
+
+ my %fromto;
+ for my $from (@exefiles) {
+ my($path)= $self->catfile('$(INST_SCRIPT)', basename($from));
+
+ local($_) = $path; # for backwards compatibility
+ my $to = $self->libscan($path);
+ print "libscan($from) => '$to'\n" if ($Verbose >=2);
+
+ $to = vmsify($to) if $Is{VMS};
+ $fromto{$from} = $to;
+ }
+ my @to = values %fromto;
+
+ my @m;
+ push(@m, qq{
+EXE_FILES = @exefiles
+
+pure_all :: @to
+ \$(NOECHO) \$(NOOP)
+
+realclean ::
+});
+
+ # realclean can get rather large.
+ push @m, map "\t$_\n", $self->split_command('$(RM_F)', @to);
+ push @m, "\n";
+
+
+ # A target for each exe file.
+ while (my($from,$to) = each %fromto) {
+ last unless defined $from;
+
+ push @m, sprintf <<'MAKE', $to, $from, $to, $from, $to, $to, $to;
+%s : %s $(FIRST_MAKEFILE) $(INST_SCRIPT)$(DFSEP).exists $(INST_BIN)$(DFSEP).exists
+ $(NOECHO) $(RM_F) %s
+ $(CP) %s %s
+ $(FIXIN) %s
+ -$(NOECHO) $(CHMOD) $(PERM_RWX) %s
+
+MAKE
+
+ }
+
+ join "", @m;
+}
+
+
+=item linkext (o)
+
+Defines the linkext target which in turn defines the LINKTYPE.
+
+=cut
+
+sub linkext {
+ my($self, %attribs) = @_;
+ # LINKTYPE => static or dynamic or ''
+ my($linktype) = defined $attribs{LINKTYPE} ?
+ $attribs{LINKTYPE} : '$(LINKTYPE)';
+ "
+linkext :: $linktype
+ \$(NOECHO) \$(NOOP)
+";
+}
+
+=item lsdir
+
+Takes as arguments a directory name and a regular expression. Returns
+all entries in the directory that match the regular expression.
+
+=cut
+
+sub lsdir {
+ my($self) = shift;
+ my($dir, $regex) = @_;
+ my(@ls);
+ my $dh = new DirHandle;
+ $dh->open($dir || ".") or return ();
+ @ls = $dh->read;
+ $dh->close;
+ @ls = grep(/$regex/, @ls) if $regex;
+ @ls;
+}
+
+=item macro (o)
+
+Simple subroutine to insert the macros defined by the macro attribute
+into the Makefile.
+
+=cut
+
+sub macro {
+ my($self,%attribs) = @_;
+ my(@m,$key,$val);
+ while (($key,$val) = each %attribs){
+ last unless defined $key;
+ push @m, "$key = $val\n";
+ }
+ join "", @m;
+}
+
+=item makeaperl (o)
+
+Called by staticmake. Defines how to write the Makefile to produce a
+static new perl.
+
+By default the Makefile produced includes all the static extensions in
+the perl library. (Purified versions of library files, e.g.,
+DynaLoader_pure_p1_c0_032.a are automatically ignored to avoid link errors.)
+
+=cut
+
+sub makeaperl {
+ my($self, %attribs) = @_;
+ my($makefilename, $searchdirs, $static, $extra, $perlinc, $target, $tmp, $libperl) =
+ @attribs{qw(MAKE DIRS STAT EXTRA INCL TARGET TMP LIBPERL)};
+ my(@m);
+ push @m, "
+# --- MakeMaker makeaperl section ---
+MAP_TARGET = $target
+FULLPERL = $self->{FULLPERL}
+";
+ return join '', @m if $self->{PARENT};
+
+ my($dir) = join ":", @{$self->{DIR}};
+
+ unless ($self->{MAKEAPERL}) {
+ push @m, q{
+$(MAP_TARGET) :: static $(MAKE_APERL_FILE)
+ $(MAKE) $(USEMAKEFILE) $(MAKE_APERL_FILE) $@
+
+$(MAKE_APERL_FILE) : $(FIRST_MAKEFILE) pm_to_blib
+ $(NOECHO) $(ECHO) Writing \"$(MAKE_APERL_FILE)\" for this $(MAP_TARGET)
+ $(NOECHO) $(PERLRUNINST) \
+ Makefile.PL DIR=}, $dir, q{ \
+ MAKEFILE=$(MAKE_APERL_FILE) LINKTYPE=static \
+ MAKEAPERL=1 NORECURS=1 CCCDLFLAGS=};
+
+ foreach (@ARGV){
+ if( /\s/ ){
+ s/=(.*)/='$1'/;
+ }
+ push @m, " \\\n\t\t$_";
+ }
+# push @m, map( " \\\n\t\t$_", @ARGV );
+ push @m, "\n";
+
+ return join '', @m;
+ }
+
+
+
+ my($cccmd, $linkcmd, $lperl);
+
+
+ $cccmd = $self->const_cccmd($libperl);
+ $cccmd =~ s/^CCCMD\s*=\s*//;
+ $cccmd =~ s/\$\(INC\)/ "-I$self->{PERL_INC}" /;
+ $cccmd .= " $Config{cccdlflags}"
+ if ($Config{useshrplib} eq 'true');
+ $cccmd =~ s/\(CC\)/\(PERLMAINCC\)/;
+
+ # The front matter of the linkcommand...
+ $linkcmd = join ' ', "\$(CC)",
+ grep($_, @Config{qw(ldflags ccdlflags)});
+ $linkcmd =~ s/\s+/ /g;
+ $linkcmd =~ s,(perl\.exp),\$(PERL_INC)/$1,;
+
+ # Which *.a files could we make use of...
+ my %static;
+ require File::Find;
+ File::Find::find(sub {
+ return unless m/\Q$self->{LIB_EXT}\E$/;
+
+ # Skip perl's libraries.
+ return if m/^libperl/ or m/^perl\Q$self->{LIB_EXT}\E$/;
+
+ # Skip purified versions of libraries
+ # (e.g., DynaLoader_pure_p1_c0_032.a)
+ return if m/_pure_\w+_\w+_\w+\.\w+$/ and -f "$File::Find::dir/.pure";
+
+ if( exists $self->{INCLUDE_EXT} ){
+ my $found = 0;
+
+ (my $xx = $File::Find::name) =~ s,.*?/auto/,,s;
+ $xx =~ s,/?$_,,;
+ $xx =~ s,/,::,g;
+
+ # Throw away anything not explicitly marked for inclusion.
+ # DynaLoader is implied.
+ foreach my $incl ((@{$self->{INCLUDE_EXT}},'DynaLoader')){
+ if( $xx eq $incl ){
+ $found++;
+ last;
+ }
+ }
+ return unless $found;
+ }
+ elsif( exists $self->{EXCLUDE_EXT} ){
+ (my $xx = $File::Find::name) =~ s,.*?/auto/,,s;
+ $xx =~ s,/?$_,,;
+ $xx =~ s,/,::,g;
+
+ # Throw away anything explicitly marked for exclusion
+ foreach my $excl (@{$self->{EXCLUDE_EXT}}){
+ return if( $xx eq $excl );
+ }
+ }
+
+ # don't include the installed version of this extension. I
+ # leave this line here, although it is not necessary anymore:
+ # I patched minimod.PL instead, so that Miniperl.pm won't
+ # enclude duplicates
+
+ # Once the patch to minimod.PL is in the distribution, I can
+ # drop it
+ return if $File::Find::name =~ m:auto/$self->{FULLEXT}/$self->{BASEEXT}$self->{LIB_EXT}\z:;
+ use Cwd 'cwd';
+ $static{cwd() . "/" . $_}++;
+ }, grep( -d $_, @{$searchdirs || []}) );
+
+ # We trust that what has been handed in as argument, will be buildable
+ $static = [] unless $static;
+ @static{@{$static}} = (1) x @{$static};
+
+ $extra = [] unless $extra && ref $extra eq 'ARRAY';
+ for (sort keys %static) {
+ next unless /\Q$self->{LIB_EXT}\E\z/;
+ $_ = dirname($_) . "/extralibs.ld";
+ push @$extra, $_;
+ }
+
+ s/^(.*)/"-I$1"/ for @{$perlinc || []};
+
+ $target ||= "perl";
+ $tmp ||= ".";
+
+# MAP_STATIC doesn't look into subdirs yet. Once "all" is made and we
+# regenerate the Makefiles, MAP_STATIC and the dependencies for
+# extralibs.all are computed correctly
+ push @m, "
+MAP_LINKCMD = $linkcmd
+MAP_PERLINC = @{$perlinc || []}
+MAP_STATIC = ",
+join(" \\\n\t", reverse sort keys %static), "
+
+MAP_PRELIBS = $Config{perllibs} $Config{cryptlib}
+";
+
+ if (defined $libperl) {
+ ($lperl = $libperl) =~ s/\$\(A\)/$self->{LIB_EXT}/;
+ }
+ unless ($libperl && -f $lperl) { # Ilya's code...
+ my $dir = $self->{PERL_SRC} || "$self->{PERL_ARCHLIB}/CORE";
+ $dir = "$self->{PERL_ARCHLIB}/.." if $self->{UNINSTALLED_PERL};
+ $libperl ||= "libperl$self->{LIB_EXT}";
+ $libperl = "$dir/$libperl";
+ $lperl ||= "libperl$self->{LIB_EXT}";
+ $lperl = "$dir/$lperl";
+
+ if (! -f $libperl and ! -f $lperl) {
+ # We did not find a static libperl. Maybe there is a shared one?
+ if ($Is{SunOS}) {
+ $lperl = $libperl = "$dir/$Config{libperl}";
+ # SUNOS ld does not take the full path to a shared library
+ $libperl = '' if $Is{SunOS4};
+ }
+ }
+
+ print STDOUT "Warning: $libperl not found
+ If you're going to build a static perl binary, make sure perl is installed
+ otherwise ignore this warning\n"
+ unless (-f $lperl || defined($self->{PERL_SRC}));
+ }
+
+ # SUNOS ld does not take the full path to a shared library
+ my $llibperl = $libperl ? '$(MAP_LIBPERL)' : '-lperl';
+
+ push @m, "
+MAP_LIBPERL = $libperl
+LLIBPERL = $llibperl
+";
+
+ push @m, '
+$(INST_ARCHAUTODIR)/extralibs.all : $(INST_ARCHAUTODIR)$(DFSEP).exists '.join(" \\\n\t", @$extra).'
+ $(NOECHO) $(RM_F) $@
+ $(NOECHO) $(TOUCH) $@
+';
+
+ foreach my $catfile (@$extra){
+ push @m, "\tcat $catfile >> \$\@\n";
+ }
+
+push @m, "
+\$(MAP_TARGET) :: $tmp/perlmain\$(OBJ_EXT) \$(MAP_LIBPERL) \$(MAP_STATIC) \$(INST_ARCHAUTODIR)/extralibs.all
+ \$(MAP_LINKCMD) -o \$\@ \$(OPTIMIZE) $tmp/perlmain\$(OBJ_EXT) \$(LDFROM) \$(MAP_STATIC) \$(LLIBPERL) `cat \$(INST_ARCHAUTODIR)/extralibs.all` \$(MAP_PRELIBS)
+ \$(NOECHO) \$(ECHO) 'To install the new \"\$(MAP_TARGET)\" binary, call'
+ \$(NOECHO) \$(ECHO) ' \$(MAKE) \$(USEMAKEFILE) $makefilename inst_perl MAP_TARGET=\$(MAP_TARGET)'
+ \$(NOECHO) \$(ECHO) 'To remove the intermediate files say'
+ \$(NOECHO) \$(ECHO) ' \$(MAKE) \$(USEMAKEFILE) $makefilename map_clean'
+
+$tmp/perlmain\$(OBJ_EXT): $tmp/perlmain.c
+";
+ push @m, "\t".$self->cd($tmp, qq[$cccmd "-I\$(PERL_INC)" perlmain.c])."\n";
+
+ push @m, qq{
+$tmp/perlmain.c: $makefilename}, q{
+ $(NOECHO) $(ECHO) Writing $@
+ $(NOECHO) $(PERL) $(MAP_PERLINC) "-MExtUtils::Miniperl" \\
+ -e "writemain(grep s#.*/auto/##s, split(q| |, q|$(MAP_STATIC)|))" > $@t && $(MV) $@t $@
+
+};
+ push @m, "\t", q{$(NOECHO) $(PERL) $(INSTALLSCRIPT)/fixpmain
+} if (defined (&Dos::UseLFN) && Dos::UseLFN()==0);
+
+
+ push @m, q{
+doc_inst_perl :
+ $(NOECHO) $(ECHO) Appending installation info to $(DESTINSTALLARCHLIB)/perllocal.pod
+ -$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
+ -$(NOECHO) $(DOC_INSTALL) \
+ "Perl binary" "$(MAP_TARGET)" \
+ MAP_STATIC "$(MAP_STATIC)" \
+ MAP_EXTRA "`cat $(INST_ARCHAUTODIR)/extralibs.all`" \
+ MAP_LIBPERL "$(MAP_LIBPERL)" \
+ >> }.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{
+
+};
+
+ push @m, q{
+inst_perl : pure_inst_perl doc_inst_perl
+
+pure_inst_perl : $(MAP_TARGET)
+ }.$self->{CP}.q{ $(MAP_TARGET) }.$self->catfile('$(DESTINSTALLBIN)','$(MAP_TARGET)').q{
+
+clean :: map_clean
+
+map_clean :
+ }.$self->{RM_F}.qq{ $tmp/perlmain\$(OBJ_EXT) $tmp/perlmain.c \$(MAP_TARGET) $makefilename \$(INST_ARCHAUTODIR)/extralibs.all
+};
+
+ join '', @m;
+}
+
+=item makefile (o)
+
+Defines how to rewrite the Makefile.
+
+=cut
+
+sub makefile {
+ my($self) = shift;
+ my $m;
+ # We do not know what target was originally specified so we
+ # must force a manual rerun to be sure. But as it should only
+ # happen very rarely it is not a significant problem.
+ $m = '
+$(OBJECT) : $(FIRST_MAKEFILE)
+
+' if $self->{OBJECT};
+
+ my $newer_than_target = $Is{VMS} ? '$(MMS$SOURCE_LIST)' : '$?';
+ my $mpl_args = join " ", map qq["$_"], @ARGV;
+
+ $m .= sprintf <<'MAKE_FRAG', $newer_than_target, $mpl_args;
+# We take a very conservative approach here, but it's worth it.
+# We move Makefile to Makefile.old here to avoid gnu make looping.
+$(FIRST_MAKEFILE) : Makefile.PL $(CONFIGDEP)
+ $(NOECHO) $(ECHO) "Makefile out-of-date with respect to %s"
+ $(NOECHO) $(ECHO) "Cleaning current config before rebuilding Makefile..."
+ -$(NOECHO) $(RM_F) $(MAKEFILE_OLD)
+ -$(NOECHO) $(MV) $(FIRST_MAKEFILE) $(MAKEFILE_OLD)
+ - $(MAKE) $(USEMAKEFILE) $(MAKEFILE_OLD) clean $(DEV_NULL)
+ $(PERLRUN) Makefile.PL %s
+ $(NOECHO) $(ECHO) "==> Your Makefile has been rebuilt. <=="
+ $(NOECHO) $(ECHO) "==> Please rerun the $(MAKE) command. <=="
+ $(FALSE)
+
+MAKE_FRAG
+
+ return $m;
+}
+
+
+=item maybe_command
+
+Returns true, if the argument is likely to be a command.
+
+=cut
+
+sub maybe_command {
+ my($self,$file) = @_;
+ return $file if -x $file && ! -d $file;
+ return;
+}
+
+
+=item needs_linking (o)
+
+Does this module need linking? Looks into subdirectory objects (see
+also has_link_code())
+
+=cut
+
+sub needs_linking {
+ my($self) = shift;
+
+ my $caller = (caller(0))[3];
+ confess("needs_linking called too early") if
+ $caller =~ /^ExtUtils::MakeMaker::/;
+ return $self->{NEEDS_LINKING} if defined $self->{NEEDS_LINKING};
+ if ($self->has_link_code or $self->{MAKEAPERL}){
+ $self->{NEEDS_LINKING} = 1;
+ return 1;
+ }
+ foreach my $child (keys %{$self->{CHILDREN}}) {
+ if ($self->{CHILDREN}->{$child}->needs_linking) {
+ $self->{NEEDS_LINKING} = 1;
+ return 1;
+ }
+ }
+ return $self->{NEEDS_LINKING} = 0;
+}
+
+
+=item parse_abstract
+
+parse a file and return what you think is the ABSTRACT
+
+=cut
+
+sub parse_abstract {
+ my($self,$parsefile) = @_;
+ my $result;
+
+ local $/ = "\n";
+ open(my $fh, '<', $parsefile) or die "Could not open '$parsefile': $!";
+ my $inpod = 0;
+ my $package = $self->{DISTNAME};
+ $package =~ s/-/::/g;
+ while (<$fh>) {
+ $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod;
+ next if !$inpod;
+ chop;
+ next unless /^($package\s-\s)(.*)/;
+ $result = $2;
+ last;
+ }
+ close $fh;
+
+ return $result;
+}
+
+=item parse_version
+
+ my $version = MM->parse_version($file);
+
+Parse a $file and return what $VERSION is set to by the first assignment.
+It will return the string "undef" if it can't figure out what $VERSION
+is. $VERSION should be for all to see, so C<our $VERSION> or plain $VERSION
+are okay, but C<my $VERSION> is not.
+
+parse_version() will try to C<use version> before checking for
+C<$VERSION> so the following will work.
+
+ $VERSION = qv(1.2.3);
+
+=cut
+
+sub parse_version {
+ my($self,$parsefile) = @_;
+ my $result;
+
+ local $/ = "\n";
+ local $_;
+ open(my $fh, '<', $parsefile) or die "Could not open '$parsefile': $!";
+ my $inpod = 0;
+ while (<$fh>) {
+ $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod;
+ next if $inpod || /^\s*#/;
+ chop;
+ next if /^\s*(if|unless)/;
+ next unless m{(?<!\\) ([\$*]) (([\w\:\']*) \bVERSION)\b .* =}x;
+ my $eval = qq{
+ package ExtUtils::MakeMaker::_version;
+ no strict;
+ BEGIN { eval {
+ # Ensure any version() routine which might have leaked
+ # into this package has been deleted. Interferes with
+ # version->import()
+ undef *version;
+ require version;
+ "version"->import;
+ } }
+
+ local $1$2;
+ \$$2=undef;
+ do {
+ $_
+ };
+ \$$2;
+ };
+ local $^W = 0;
+ $result = eval($eval); ## no critic
+ warn "Could not eval '$eval' in $parsefile: $@" if $@;
+ last if defined $result;
+ }
+ close $fh;
+
+ $result = "undef" unless defined $result;
+ return $result;
+}
+
+
+=item pasthru (o)
+
+Defines the string that is passed to recursive make calls in
+subdirectories.
+
+=cut
+
+sub pasthru {
+ my($self) = shift;
+ my(@m);
+
+ my(@pasthru);
+ my($sep) = $Is{VMS} ? ',' : '';
+ $sep .= "\\\n\t";
+
+ foreach my $key (qw(LIB LIBPERL_A LINKTYPE OPTIMIZE
+ PREFIX INSTALL_BASE)
+ )
+ {
+ next unless defined $self->{$key};
+ push @pasthru, "$key=\"\$($key)\"";
+ }
+
+ foreach my $key (qw(DEFINE INC)) {
+ next unless defined $self->{$key};
+ push @pasthru, "PASTHRU_$key=\"\$(PASTHRU_$key)\"";
+ }
+
+ push @m, "\nPASTHRU = ", join ($sep, @pasthru), "\n";
+ join "", @m;
+}
+
+=item perl_script
+
+Takes one argument, a file name, and returns the file name, if the
+argument is likely to be a perl script. On MM_Unix this is true for
+any ordinary, readable file.
+
+=cut
+
+sub perl_script {
+ my($self,$file) = @_;
+ return $file if -r $file && -f _;
+ return;
+}
+
+=item perldepend (o)
+
+Defines the dependency from all *.h files that come with the perl
+distribution.
+
+=cut
+
+sub perldepend {
+ my($self) = shift;
+ my(@m);
+
+ my $make_config = $self->cd('$(PERL_SRC)', '$(MAKE) lib/Config.pm');
+
+ push @m, sprintf <<'MAKE_FRAG', $make_config if $self->{PERL_SRC};
+# Check for unpropogated config.sh changes. Should never happen.
+# We do NOT just update config.h because that is not sufficient.
+# An out of date config.h is not fatal but complains loudly!
+$(PERL_INC)/config.h: $(PERL_SRC)/config.sh
+ -$(NOECHO) $(ECHO) "Warning: $(PERL_INC)/config.h out of date with $(PERL_SRC)/config.sh"; $(FALSE)
+
+$(PERL_ARCHLIB)/Config.pm: $(PERL_SRC)/config.sh
+ $(NOECHO) $(ECHO) "Warning: $(PERL_ARCHLIB)/Config.pm may be out of date with $(PERL_SRC)/config.sh"
+ %s
+MAKE_FRAG
+
+ return join "", @m unless $self->needs_linking;
+
+ push @m, q{
+PERL_HDRS = \
+ $(PERL_INC)/EXTERN.h \
+ $(PERL_INC)/INTERN.h \
+ $(PERL_INC)/XSUB.h \
+ $(PERL_INC)/av.h \
+ $(PERL_INC)/cc_runtime.h \
+ $(PERL_INC)/config.h \
+ $(PERL_INC)/cop.h \
+ $(PERL_INC)/cv.h \
+ $(PERL_INC)/dosish.h \
+ $(PERL_INC)/embed.h \
+ $(PERL_INC)/embedvar.h \
+ $(PERL_INC)/fakethr.h \
+ $(PERL_INC)/form.h \
+ $(PERL_INC)/gv.h \
+ $(PERL_INC)/handy.h \
+ $(PERL_INC)/hv.h \
+ $(PERL_INC)/intrpvar.h \
+ $(PERL_INC)/iperlsys.h \
+ $(PERL_INC)/keywords.h \
+ $(PERL_INC)/mg.h \
+ $(PERL_INC)/nostdio.h \
+ $(PERL_INC)/op.h \
+ $(PERL_INC)/opcode.h \
+ $(PERL_INC)/patchlevel.h \
+ $(PERL_INC)/perl.h \
+ $(PERL_INC)/perlio.h \
+ $(PERL_INC)/perlsdio.h \
+ $(PERL_INC)/perlsfio.h \
+ $(PERL_INC)/perlvars.h \
+ $(PERL_INC)/perly.h \
+ $(PERL_INC)/pp.h \
+ $(PERL_INC)/pp_proto.h \
+ $(PERL_INC)/proto.h \
+ $(PERL_INC)/regcomp.h \
+ $(PERL_INC)/regexp.h \
+ $(PERL_INC)/regnodes.h \
+ $(PERL_INC)/scope.h \
+ $(PERL_INC)/sv.h \
+ $(PERL_INC)/thread.h \
+ $(PERL_INC)/unixish.h \
+ $(PERL_INC)/util.h
+
+$(OBJECT) : $(PERL_HDRS)
+} if $self->{OBJECT};
+
+ push @m, join(" ", values %{$self->{XS}})." : \$(XSUBPPDEPS)\n" if %{$self->{XS}};
+
+ join "\n", @m;
+}
+
+
+=item pm_to_blib
+
+Defines target that copies all files in the hash PM to their
+destination and autosplits them. See L<ExtUtils::Install/DESCRIPTION>
+
+=cut
+
+sub pm_to_blib {
+ my $self = shift;
+ my($autodir) = $self->catdir('$(INST_LIB)','auto');
+ my $r = q{
+pm_to_blib : $(FIRST_MAKEFILE) $(TO_INST_PM)
+};
+
+ # VMS will swallow '' and PM_FILTER is often empty. So use q[]
+ my $pm_to_blib = $self->oneliner(<<CODE, ['-MExtUtils::Install']);
+pm_to_blib({\@ARGV}, '$autodir', q[\$(PM_FILTER)], '\$(PERM_DIR)')
+CODE
+
+ my @cmds = $self->split_command($pm_to_blib, %{$self->{PM}});
+
+ $r .= join '', map { "\t\$(NOECHO) $_\n" } @cmds;
+ $r .= qq{\t\$(NOECHO) \$(TOUCH) pm_to_blib\n};
+
+ return $r;
+}
+
+=item post_constants (o)
+
+Returns an empty string per default. Dedicated to overrides from
+within Makefile.PL after all constants have been defined.
+
+=cut
+
+sub post_constants{
+ "";
+}
+
+=item post_initialize (o)
+
+Returns an empty string per default. Used in Makefile.PLs to add some
+chunk of text to the Makefile after the object is initialized.
+
+=cut
+
+sub post_initialize {
+ "";
+}
+
+=item postamble (o)
+
+Returns an empty string. Can be used in Makefile.PLs to write some
+text to the Makefile at the end.
+
+=cut
+
+sub postamble {
+ "";
+}
+
+# transform dot-separated version string into comma-separated quadruple
+# examples: '1.2.3.4.5' => '1,2,3,4'
+# '1.2.3' => '1,2,3,0'
+sub _ppd_version {
+ my ($self, $string) = @_;
+ return join ',', ((split /\./, $string), (0) x 4)[0..3];
+}
+
+=item ppd
+
+Defines target that creates a PPD (Perl Package Description) file
+for a binary distribution.
+
+=cut
+
+sub ppd {
+ my($self) = @_;
+
+ my $abstract = $self->{ABSTRACT} || '';
+ $abstract =~ s/\n/\\n/sg;
+ $abstract =~ s/</</g;
+ $abstract =~ s/>/>/g;
+
+ my $author = $self->{AUTHOR} || '';
+ $author =~ s/</</g;
+ $author =~ s/>/>/g;
+
+ my $ppd_xml = sprintf <<'PPD_HTML', $self->{VERSION}, $abstract, $author;
+<SOFTPKG NAME="$(DISTNAME)" VERSION="%s">
+ <ABSTRACT>%s</ABSTRACT>
+ <AUTHOR>%s</AUTHOR>
+PPD_HTML
+
+ $ppd_xml .= " <IMPLEMENTATION>\n";
+ if ( $self->{MIN_PERL_VERSION} ) {
+ my $min_perl_version = $self->_ppd_version($self->{MIN_PERL_VERSION});
+ $ppd_xml .= sprintf <<'PPD_PERLVERS', $min_perl_version;
+ <PERLCORE VERSION="%s" />
+PPD_PERLVERS
+
+ }
+
+ # Don't add "perl" to requires. perl dependencies are
+ # handles by ARCHITECTURE.
+ my %prereqs = %{$self->{PREREQ_PM}};
+ delete $prereqs{perl};
+
+ # Build up REQUIRE
+ foreach my $prereq (sort keys %prereqs) {
+ my $name = $prereq;
+ $name .= '::' unless $name =~ /::/;
+ my $version = $prereqs{$prereq}+0; # force numification
+
+ my %attrs = ( NAME => $name );
+ $attrs{VERSION} = $version if $version;
+ my $attrs = join " ", map { qq[$_="$attrs{$_}"] } keys %attrs;
+ $ppd_xml .= qq( <REQUIRE $attrs />\n);
+ }
+
+ my $archname = $Config{archname};
+ if ($] >= 5.008) {
+ # archname did not change from 5.6 to 5.8, but those versions may
+ # not be not binary compatible so now we append the part of the
+ # version that changes when binary compatibility may change
+ $archname .= "-$Config{PERL_REVISION}.$Config{PERL_VERSION}";
+ }
+ $ppd_xml .= sprintf <<'PPD_OUT', $archname;
+ <ARCHITECTURE NAME="%s" />
+PPD_OUT
+
+ if ($self->{PPM_INSTALL_SCRIPT}) {
+ if ($self->{PPM_INSTALL_EXEC}) {
+ $ppd_xml .= sprintf qq{ <INSTALL EXEC="%s">%s</INSTALL>\n},
+ $self->{PPM_INSTALL_EXEC}, $self->{PPM_INSTALL_SCRIPT};
+ }
+ else {
+ $ppd_xml .= sprintf qq{ <INSTALL>%s</INSTALL>\n},
+ $self->{PPM_INSTALL_SCRIPT};
+ }
+ }
+
+ my ($bin_location) = $self->{BINARY_LOCATION} || '';
+ $bin_location =~ s/\\/\\\\/g;
+
+ $ppd_xml .= sprintf <<'PPD_XML', $bin_location;
+ <CODEBASE HREF="%s" />
+ </IMPLEMENTATION>
+</SOFTPKG>
+PPD_XML
+
+ my @ppd_cmds = $self->echo($ppd_xml, '$(DISTNAME).ppd');
+
+ return sprintf <<'PPD_OUT', join "\n\t", @ppd_cmds;
+# Creates a PPD (Perl Package Description) for a binary distribution.
+ppd :
+ %s
+PPD_OUT
+
+}
+
+=item prefixify
+
+ $MM->prefixify($var, $prefix, $new_prefix, $default);
+
+Using either $MM->{uc $var} || $Config{lc $var}, it will attempt to
+replace it's $prefix with a $new_prefix.
+
+Should the $prefix fail to match I<AND> a PREFIX was given as an
+argument to WriteMakefile() it will set it to the $new_prefix +
+$default. This is for systems whose file layouts don't neatly fit into
+our ideas of prefixes.
+
+This is for heuristics which attempt to create directory structures
+that mirror those of the installed perl.
+
+For example:
+
+ $MM->prefixify('installman1dir', '/usr', '/home/foo', 'man/man1');
+
+this will attempt to remove '/usr' from the front of the
+$MM->{INSTALLMAN1DIR} path (initializing it to $Config{installman1dir}
+if necessary) and replace it with '/home/foo'. If this fails it will
+simply use '/home/foo/man/man1'.
+
+=cut
+
+sub prefixify {
+ my($self,$var,$sprefix,$rprefix,$default) = @_;
+
+ my $path = $self->{uc $var} ||
+ $Config_Override{lc $var} || $Config{lc $var} || '';
+
+ $rprefix .= '/' if $sprefix =~ m|/$|;
+
+ print STDERR " prefixify $var => $path\n" if $Verbose >= 2;
+ print STDERR " from $sprefix to $rprefix\n" if $Verbose >= 2;
+
+ if( $self->{ARGS}{PREFIX} &&
+ $path !~ s{^\Q$sprefix\E\b}{$rprefix}s )
+ {
+
+ print STDERR " cannot prefix, using default.\n" if $Verbose >= 2;
+ print STDERR " no default!\n" if !$default && $Verbose >= 2;
+
+ $path = $self->catdir($rprefix, $default) if $default;
+ }
+
+ print " now $path\n" if $Verbose >= 2;
+ return $self->{uc $var} = $path;
+}
+
+
+=item processPL (o)
+
+Defines targets to run *.PL files.
+
+=cut
+
+sub processPL {
+ my $self = shift;
+ my $pl_files = $self->{PL_FILES};
+
+ return "" unless $pl_files;
+
+ my $m = '';
+ foreach my $plfile (sort keys %$pl_files) {
+ my $list = ref($pl_files->{$plfile})
+ ? $pl_files->{$plfile}
+ : [$pl_files->{$plfile}];
+
+ foreach my $target (@$list) {
+ if( $Is{VMS} ) {
+ $plfile = vmsify($self->eliminate_macros($plfile));
+ $target = vmsify($self->eliminate_macros($target));
+ }
+
+ # Normally a .PL file runs AFTER pm_to_blib so it can have
+ # blib in its @INC and load the just built modules. BUT if
+ # the generated module is something in $(TO_INST_PM) which
+ # pm_to_blib depends on then it can't depend on pm_to_blib
+ # else we have a dependency loop.
+ my $pm_dep;
+ my $perlrun;
+ if( defined $self->{PM}{$target} ) {
+ $pm_dep = '';
+ $perlrun = 'PERLRUN';
+ }
+ else {
+ $pm_dep = 'pm_to_blib';
+ $perlrun = 'PERLRUNINST';
+ }
+
+ $m .= <<MAKE_FRAG;
+
+all :: $target
+ \$(NOECHO) \$(NOOP)
+
+$target :: $plfile $pm_dep
+ \$($perlrun) $plfile $target
+MAKE_FRAG
+
+ }
+ }
+
+ return $m;
+}
+
+=item quote_paren
+
+Backslashes parentheses C<()> in command line arguments.
+Doesn't handle recursive Makefile C<$(...)> constructs,
+but handles simple ones.
+
+=cut
+
+sub quote_paren {
+ my $arg = shift;
+ $arg =~ s{\$\((.+?)\)}{\$\\\\($1\\\\)}g; # protect $(...)
+ $arg =~ s{(?<!\\)([()])}{\\$1}g; # quote unprotected
+ $arg =~ s{\$\\\\\((.+?)\\\\\)}{\$($1)}g; # unprotect $(...)
+ return $arg;
+}
+
+=item replace_manpage_separator
+
+ my $man_name = $MM->replace_manpage_separator($file_path);
+
+Takes the name of a package, which may be a nested package, in the
+form 'Foo/Bar.pm' and replaces the slash with C<::> or something else
+safe for a man page file name. Returns the replacement.
+
+=cut
+
+sub replace_manpage_separator {
+ my($self,$man) = @_;
+
+ $man =~ s,/+,::,g;
+ return $man;
+}
+
+
+=item cd
+
+=cut
+
+sub cd {
+ my($self, $dir, @cmds) = @_;
+
+ # No leading tab and no trailing newline makes for easier embedding
+ my $make_frag = join "\n\t", map { "cd $dir && $_" } @cmds;
+
+ return $make_frag;
+}
+
+=item oneliner
+
+=cut
+
+sub oneliner {
+ my($self, $cmd, $switches) = @_;
+ $switches = [] unless defined $switches;
+
+ # Strip leading and trailing newlines
+ $cmd =~ s{^\n+}{};
+ $cmd =~ s{\n+$}{};
+
+ my @cmds = split /\n/, $cmd;
+ $cmd = join " \n\t -e ", map $self->quote_literal($_), @cmds;
+ $cmd = $self->escape_newlines($cmd);
+
+ $switches = join ' ', @$switches;
+
+ return qq{\$(ABSPERLRUN) $switches -e $cmd --};
+}
+
+
+=item quote_literal
+
+=cut
+
+sub quote_literal {
+ my($self, $text) = @_;
+
+ # I think all we have to quote is single quotes and I think
+ # this is a safe way to do it.
+ $text =~ s{'}{'\\''}g;
+
+ return "'$text'";
+}
+
+
+=item escape_newlines
+
+=cut
+
+sub escape_newlines {
+ my($self, $text) = @_;
+
+ $text =~ s{\n}{\\\n}g;
+
+ return $text;
+}
+
+
+=item max_exec_len
+
+Using POSIX::ARG_MAX. Otherwise falling back to 4096.
+
+=cut
+
+sub max_exec_len {
+ my $self = shift;
+
+ if (!defined $self->{_MAX_EXEC_LEN}) {
+ if (my $arg_max = eval { require POSIX; &POSIX::ARG_MAX }) {
+ $self->{_MAX_EXEC_LEN} = $arg_max;
+ }
+ else { # POSIX minimum exec size
+ $self->{_MAX_EXEC_LEN} = 4096;
+ }
+ }
+
+ return $self->{_MAX_EXEC_LEN};
+}
+
+
+=item static (o)
+
+Defines the static target.
+
+=cut
+
+sub static {
+# --- Static Loading Sections ---
+
+ my($self) = shift;
+ '
+## $(INST_PM) has been moved to the all: target.
+## It remains here for awhile to allow for old usage: "make static"
+static :: $(FIRST_MAKEFILE) $(INST_STATIC)
+ $(NOECHO) $(NOOP)
+';
+}
+
+=item static_lib (o)
+
+Defines how to produce the *.a (or equivalent) files.
+
+=cut
+
+sub static_lib {
+ my($self) = @_;
+ return '' unless $self->has_link_code;
+
+ my(@m);
+ push(@m, <<'END');
+
+$(INST_STATIC) : $(OBJECT) $(MYEXTLIB) $(INST_ARCHAUTODIR)$(DFSEP).exists
+ $(RM_RF) $@
+END
+
+ # If this extension has its own library (eg SDBM_File)
+ # then copy that to $(INST_STATIC) and add $(OBJECT) into it.
+ push(@m, <<'MAKE_FRAG') if $self->{MYEXTLIB};
+ $(CP) $(MYEXTLIB) $@
+MAKE_FRAG
+
+ my $ar;
+ if (exists $self->{FULL_AR} && -x $self->{FULL_AR}) {
+ # Prefer the absolute pathed ar if available so that PATH
+ # doesn't confuse us. Perl itself is built with the full_ar.
+ $ar = 'FULL_AR';
+ } else {
+ $ar = 'AR';
+ }
+ push @m, sprintf <<'MAKE_FRAG', $ar;
+ $(%s) $(AR_STATIC_ARGS) $@ $(OBJECT) && $(RANLIB) $@
+ $(CHMOD) $(PERM_RWX) $@
+ $(NOECHO) $(ECHO) "$(EXTRALIBS)" > $(INST_ARCHAUTODIR)/extralibs.ld
+MAKE_FRAG
+
+ # Old mechanism - still available:
+ push @m, <<'MAKE_FRAG' if $self->{PERL_SRC} && $self->{EXTRALIBS};
+ $(NOECHO) $(ECHO) "$(EXTRALIBS)" >> $(PERL_SRC)/ext.libs
+MAKE_FRAG
+
+ join('', @m);
+}
+
+=item staticmake (o)
+
+Calls makeaperl.
+
+=cut
+
+sub staticmake {
+ my($self, %attribs) = @_;
+ my(@static);
+
+ my(@searchdirs)=($self->{PERL_ARCHLIB}, $self->{SITEARCHEXP}, $self->{INST_ARCHLIB});
+
+ # And as it's not yet built, we add the current extension
+ # but only if it has some C code (or XS code, which implies C code)
+ if (@{$self->{C}}) {
+ @static = $self->catfile($self->{INST_ARCHLIB},
+ "auto",
+ $self->{FULLEXT},
+ "$self->{BASEEXT}$self->{LIB_EXT}"
+ );
+ }
+
+ # Either we determine now, which libraries we will produce in the
+ # subdirectories or we do it at runtime of the make.
+
+ # We could ask all subdir objects, but I cannot imagine, why it
+ # would be necessary.
+
+ # Instead we determine all libraries for the new perl at
+ # runtime.
+ my(@perlinc) = ($self->{INST_ARCHLIB}, $self->{INST_LIB}, $self->{PERL_ARCHLIB}, $self->{PERL_LIB});
+
+ $self->makeaperl(MAKE => $self->{MAKEFILE},
+ DIRS => \@searchdirs,
+ STAT => \@static,
+ INCL => \@perlinc,
+ TARGET => $self->{MAP_TARGET},
+ TMP => "",
+ LIBPERL => $self->{LIBPERL_A}
+ );
+}
+
+=item subdir_x (o)
+
+Helper subroutine for subdirs
+
+=cut
+
+sub subdir_x {
+ my($self, $subdir) = @_;
+
+ my $subdir_cmd = $self->cd($subdir,
+ '$(MAKE) $(USEMAKEFILE) $(FIRST_MAKEFILE) all $(PASTHRU)'
+ );
+ return sprintf <<'EOT', $subdir_cmd;
+
+subdirs ::
+ $(NOECHO) %s
+EOT
+
+}
+
+=item subdirs (o)
+
+Defines targets to process subdirectories.
+
+=cut
+
+sub subdirs {
+# --- Sub-directory Sections ---
+ my($self) = shift;
+ my(@m);
+ # This method provides a mechanism to automatically deal with
+ # subdirectories containing further Makefile.PL scripts.
+ # It calls the subdir_x() method for each subdirectory.
+ foreach my $dir (@{$self->{DIR}}){
+ push(@m, $self->subdir_x($dir));
+#### print "Including $dir subdirectory\n";
+ }
+ if (@m){
+ unshift(@m, "
+# The default clean, realclean and test targets in this Makefile
+# have automatically been given entries for each subdir.
+
+");
+ } else {
+ push(@m, "\n# none")
+ }
+ join('', at m);
+}
+
+=item test (o)
+
+Defines the test targets.
+
+=cut
+
+sub test {
+# --- Test and Installation Sections ---
+
+ my($self, %attribs) = @_;
+ my $tests = $attribs{TESTS} || '';
+ if (!$tests && -d 't') {
+ $tests = $self->find_tests;
+ }
+ # note: 'test.pl' name is also hardcoded in init_dirscan()
+ my(@m);
+ push(@m,"
+TEST_VERBOSE=0
+TEST_TYPE=test_\$(LINKTYPE)
+TEST_FILE = test.pl
+TEST_FILES = $tests
+TESTDB_SW = -d
+
+testdb :: testdb_\$(LINKTYPE)
+
+test :: \$(TEST_TYPE) subdirs-test
+
+subdirs-test ::
+ \$(NOECHO) \$(NOOP)
+
+");
+
+ foreach my $dir (@{ $self->{DIR} }) {
+ my $test = $self->cd($dir, '$(MAKE) test $(PASTHRU)');
+
+ push @m, <<END
+subdirs-test ::
+ \$(NOECHO) $test
+
+END
+ }
+
+ push(@m, "\t\$(NOECHO) \$(ECHO) 'No tests defined for \$(NAME) extension.'\n")
+ unless $tests or -f "test.pl" or @{$self->{DIR}};
+ push(@m, "\n");
+
+ push(@m, "test_dynamic :: pure_all\n");
+ push(@m, $self->test_via_harness('$(FULLPERLRUN)', '$(TEST_FILES)'))
+ if $tests;
+ push(@m, $self->test_via_script('$(FULLPERLRUN)', '$(TEST_FILE)'))
+ if -f "test.pl";
+ push(@m, "\n");
+
+ push(@m, "testdb_dynamic :: pure_all\n");
+ push(@m, $self->test_via_script('$(FULLPERLRUN) $(TESTDB_SW)',
+ '$(TEST_FILE)'));
+ push(@m, "\n");
+
+ # Occasionally we may face this degenerate target:
+ push @m, "test_ : test_dynamic\n\n";
+
+ if ($self->needs_linking()) {
+ push(@m, "test_static :: pure_all \$(MAP_TARGET)\n");
+ push(@m, $self->test_via_harness('./$(MAP_TARGET)', '$(TEST_FILES)')) if $tests;
+ push(@m, $self->test_via_script('./$(MAP_TARGET)', '$(TEST_FILE)')) if -f "test.pl";
+ push(@m, "\n");
+ push(@m, "testdb_static :: pure_all \$(MAP_TARGET)\n");
+ push(@m, $self->test_via_script('./$(MAP_TARGET) $(TESTDB_SW)', '$(TEST_FILE)'));
+ push(@m, "\n");
+ } else {
+ push @m, "test_static :: test_dynamic\n";
+ push @m, "testdb_static :: testdb_dynamic\n";
+ }
+ join("", @m);
+}
+
+=item test_via_harness (override)
+
+For some reason which I forget, Unix machines like to have
+PERL_DL_NONLAZY set for tests.
+
+=cut
+
+sub test_via_harness {
+ my($self, $perl, $tests) = @_;
+ return $self->SUPER::test_via_harness("PERL_DL_NONLAZY=1 $perl", $tests);
+}
+
+=item test_via_script (override)
+
+Again, the PERL_DL_NONLAZY thing.
+
+=cut
+
+sub test_via_script {
+ my($self, $perl, $script) = @_;
+ return $self->SUPER::test_via_script("PERL_DL_NONLAZY=1 $perl", $script);
+}
+
+
+=item tool_xsubpp (o)
+
+Determines typemaps, xsubpp version, prototype behaviour.
+
+=cut
+
+sub tool_xsubpp {
+ my($self) = shift;
+ return "" unless $self->needs_linking;
+
+ my $xsdir;
+ my @xsubpp_dirs = @INC;
+
+ # Make sure we pick up the new xsubpp if we're building perl.
+ unshift @xsubpp_dirs, $self->{PERL_LIB} if $self->{PERL_CORE};
+
+ foreach my $dir (@xsubpp_dirs) {
+ $xsdir = $self->catdir($dir, 'ExtUtils');
+ if( -r $self->catfile($xsdir, "xsubpp") ) {
+ last;
+ }
+ }
+
+ my $tmdir = File::Spec->catdir($self->{PERL_LIB},"ExtUtils");
+ my(@tmdeps) = $self->catfile($tmdir,'typemap');
+ if( $self->{TYPEMAPS} ){
+ foreach my $typemap (@{$self->{TYPEMAPS}}){
+ if( ! -f $typemap ) {
+ warn "Typemap $typemap not found.\n";
+ }
+ else {
+ push(@tmdeps, $typemap);
+ }
+ }
+ }
+ push(@tmdeps, "typemap") if -f "typemap";
+ my(@tmargs) = map("-typemap $_", @tmdeps);
+ if( exists $self->{XSOPT} ){
+ unshift( @tmargs, $self->{XSOPT} );
+ }
+
+ if ($Is{VMS} &&
+ $Config{'ldflags'} &&
+ $Config{'ldflags'} =~ m!/Debug!i &&
+ (!exists($self->{XSOPT}) || $self->{XSOPT} !~ /linenumbers/)
+ )
+ {
+ unshift(@tmargs,'-nolinenumbers');
+ }
+
+
+ $self->{XSPROTOARG} = "" unless defined $self->{XSPROTOARG};
+
+ return qq{
+XSUBPPDIR = $xsdir
+XSUBPP = \$(XSUBPPDIR)\$(DFSEP)xsubpp
+XSUBPPRUN = \$(PERLRUN) \$(XSUBPP)
+XSPROTOARG = $self->{XSPROTOARG}
+XSUBPPDEPS = @tmdeps \$(XSUBPP)
+XSUBPPARGS = @tmargs
+XSUBPP_EXTRA_ARGS =
+};
+};
+
+
+=item all_target
+
+Build man pages, too
+
+=cut
+
+sub all_target {
+ my $self = shift;
+
+ return <<'MAKE_EXT';
+all :: pure_all manifypods
+ $(NOECHO) $(NOOP)
+MAKE_EXT
+}
+
+=item top_targets (o)
+
+Defines the targets all, subdirs, config, and O_FILES
+
+=cut
+
+sub top_targets {
+# --- Target Sections ---
+
+ my($self) = shift;
+ my(@m);
+
+ push @m, $self->all_target, "\n" unless $self->{SKIPHASH}{'all'};
+
+ push @m, '
+pure_all :: config pm_to_blib subdirs linkext
+ $(NOECHO) $(NOOP)
+
+subdirs :: $(MYEXTLIB)
+ $(NOECHO) $(NOOP)
+
+config :: $(FIRST_MAKEFILE) blibdirs
+ $(NOECHO) $(NOOP)
+';
+
+ push @m, '
+$(O_FILES): $(H_FILES)
+' if @{$self->{O_FILES} || []} && @{$self->{H} || []};
+
+ push @m, q{
+help :
+ perldoc ExtUtils::MakeMaker
+};
+
+ join('', at m);
+}
+
+=item writedoc
+
+Obsolete, deprecated method. Not used since Version 5.21.
+
+=cut
+
+sub writedoc {
+# --- perllocal.pod section ---
+ my($self,$what,$name, at attribs)=@_;
+ my $time = localtime;
+ print "=head2 $time: $what C<$name>\n\n=over 4\n\n=item *\n\n";
+ print join "\n\n=item *\n\n", map("C<$_>", at attribs);
+ print "\n\n=back\n\n";
+}
+
+=item xs_c (o)
+
+Defines the suffix rules to compile XS files to C.
+
+=cut
+
+sub xs_c {
+ my($self) = shift;
+ return '' unless $self->needs_linking();
+ '
+.xs.c:
+ $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(XSUBPP_EXTRA_ARGS) $*.xs > $*.xsc && $(MV) $*.xsc $*.c
+';
+}
+
+=item xs_cpp (o)
+
+Defines the suffix rules to compile XS files to C++.
+
+=cut
+
+sub xs_cpp {
+ my($self) = shift;
+ return '' unless $self->needs_linking();
+ '
+.xs.cpp:
+ $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc && $(MV) $*.xsc $*.cpp
+';
+}
+
+=item xs_o (o)
+
+Defines suffix rules to go from XS to object files directly. This is
+only intended for broken make implementations.
+
+=cut
+
+sub xs_o { # many makes are too dumb to use xs_c then c_o
+ my($self) = shift;
+ return '' unless $self->needs_linking();
+ '
+.xs$(OBJ_EXT):
+ $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc && $(MV) $*.xsc $*.c
+ $(CCCMD) $(CCCDLFLAGS) "-I$(PERL_INC)" $(PASTHRU_DEFINE) $(DEFINE) $*.c
+';
+}
+
+
+1;
+
+=back
+
+=head1 SEE ALSO
+
+L<ExtUtils::MakeMaker>
+
+=cut
+
+__END__
Copied: trunk/contrib/perl/lib/ExtUtils/MM_VMS.pm (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/MM_VMS.pm)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/MM_VMS.pm (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/MM_VMS.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,1994 @@
+package ExtUtils::MM_VMS;
+
+use strict;
+
+use ExtUtils::MakeMaker::Config;
+require Exporter;
+
+BEGIN {
+ # so we can compile the thing on non-VMS platforms.
+ if( $^O eq 'VMS' ) {
+ require VMS::Filespec;
+ VMS::Filespec->import;
+ }
+}
+
+use File::Basename;
+
+our $VERSION = '6.55_02';
+
+require ExtUtils::MM_Any;
+require ExtUtils::MM_Unix;
+our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix );
+
+use ExtUtils::MakeMaker qw($Verbose neatvalue);
+our $Revision = $ExtUtils::MakeMaker::Revision;
+
+
+=head1 NAME
+
+ExtUtils::MM_VMS - methods to override UN*X behaviour in ExtUtils::MakeMaker
+
+=head1 SYNOPSIS
+
+ Do not use this directly.
+ Instead, use ExtUtils::MM and it will figure out which MM_*
+ class to use for you.
+
+=head1 DESCRIPTION
+
+See ExtUtils::MM_Unix for a documentation of the methods provided
+there. This package overrides the implementation of these methods, not
+the semantics.
+
+=head2 Methods always loaded
+
+=over 4
+
+=item wraplist
+
+Converts a list into a string wrapped at approximately 80 columns.
+
+=cut
+
+sub wraplist {
+ my($self) = shift;
+ my($line,$hlen) = ('',0);
+
+ foreach my $word (@_) {
+ # Perl bug -- seems to occasionally insert extra elements when
+ # traversing array (scalar(@array) doesn't show them, but
+ # foreach(@array) does) (5.00307)
+ next unless $word =~ /\w/;
+ $line .= ' ' if length($line);
+ if ($hlen > 80) { $line .= "\\\n\t"; $hlen = 0; }
+ $line .= $word;
+ $hlen += length($word) + 2;
+ }
+ $line;
+}
+
+
+# This isn't really an override. It's just here because ExtUtils::MM_VMS
+# appears in @MM::ISA before ExtUtils::Liblist::Kid, so if there isn't an ext()
+# in MM_VMS, then AUTOLOAD is called, and bad things happen. So, we just
+# mimic inheritance here and hand off to ExtUtils::Liblist::Kid.
+# XXX This hackery will die soon. --Schwern
+sub ext {
+ require ExtUtils::Liblist::Kid;
+ goto &ExtUtils::Liblist::Kid::ext;
+}
+
+=back
+
+=head2 Methods
+
+Those methods which override default MM_Unix methods are marked
+"(override)", while methods unique to MM_VMS are marked "(specific)".
+For overridden methods, documentation is limited to an explanation
+of why this method overrides the MM_Unix method; see the ExtUtils::MM_Unix
+documentation for more details.
+
+=over 4
+
+=item guess_name (override)
+
+Try to determine name of extension being built. We begin with the name
+of the current directory. Since VMS filenames are case-insensitive,
+however, we look for a F<.pm> file whose name matches that of the current
+directory (presumably the 'main' F<.pm> file for this extension), and try
+to find a C<package> statement from which to obtain the Mixed::Case
+package name.
+
+=cut
+
+sub guess_name {
+ my($self) = @_;
+ my($defname,$defpm, at pm,%xs);
+ local *PM;
+
+ $defname = basename(fileify($ENV{'DEFAULT'}));
+ $defname =~ s![\d\-_]*\.dir.*$!!; # Clip off .dir;1 suffix, and package version
+ $defpm = $defname;
+ # Fallback in case for some reason a user has copied the files for an
+ # extension into a working directory whose name doesn't reflect the
+ # extension's name. We'll use the name of a unique .pm file, or the
+ # first .pm file with a matching .xs file.
+ if (not -e "${defpm}.pm") {
+ @pm = glob('*.pm');
+ s/.pm$// for @pm;
+ if (@pm == 1) { ($defpm = $pm[0]) =~ s/.pm$//; }
+ elsif (@pm) {
+ %xs = map { s/.xs$//; ($_,1) } glob('*.xs'); ## no critic
+ if (keys %xs) {
+ foreach my $pm (@pm) {
+ $defpm = $pm, last if exists $xs{$pm};
+ }
+ }
+ }
+ }
+ if (open(my $pm, '<', "${defpm}.pm")){
+ while (<$pm>) {
+ if (/^\s*package\s+([^;]+)/i) {
+ $defname = $1;
+ last;
+ }
+ }
+ print STDOUT "Warning (non-fatal): Couldn't find package name in ${defpm}.pm;\n\t",
+ "defaulting package name to $defname\n"
+ if eof($pm);
+ close $pm;
+ }
+ else {
+ print STDOUT "Warning (non-fatal): Couldn't find ${defpm}.pm;\n\t",
+ "defaulting package name to $defname\n";
+ }
+ $defname =~ s#[\d.\-_]+$##;
+ $defname;
+}
+
+=item find_perl (override)
+
+Use VMS file specification syntax and CLI commands to find and
+invoke Perl images.
+
+=cut
+
+sub find_perl {
+ my($self, $ver, $names, $dirs, $trace) = @_;
+ my($vmsfile, at sdirs, at snames, at cand);
+ my($rslt);
+ my($inabs) = 0;
+ local *TCF;
+
+ if( $self->{PERL_CORE} ) {
+ # Check in relative directories first, so we pick up the current
+ # version of Perl if we're running MakeMaker as part of the main build.
+ @sdirs = sort { my($absa) = $self->file_name_is_absolute($a);
+ my($absb) = $self->file_name_is_absolute($b);
+ if ($absa && $absb) { return $a cmp $b }
+ else { return $absa ? 1 : ($absb ? -1 : ($a cmp $b)); }
+ } @$dirs;
+ # Check miniperl before perl, and check names likely to contain
+ # version numbers before "generic" names, so we pick up an
+ # executable that's less likely to be from an old installation.
+ @snames = sort { my($ba) = $a =~ m!([^:>\]/]+)$!; # basename
+ my($bb) = $b =~ m!([^:>\]/]+)$!;
+ my($ahasdir) = (length($a) - length($ba) > 0);
+ my($bhasdir) = (length($b) - length($bb) > 0);
+ if ($ahasdir and not $bhasdir) { return 1; }
+ elsif ($bhasdir and not $ahasdir) { return -1; }
+ else { $bb =~ /\d/ <=> $ba =~ /\d/
+ or substr($ba,0,1) cmp substr($bb,0,1)
+ or length($bb) <=> length($ba) } } @$names;
+ }
+ else {
+ @sdirs = @$dirs;
+ @snames = @$names;
+ }
+
+ # Image names containing Perl version use '_' instead of '.' under VMS
+ s/\.(\d+)$/_$1/ for @snames;
+ if ($trace >= 2){
+ print "Looking for perl $ver by these names:\n";
+ print "\t at snames,\n";
+ print "in these dirs:\n";
+ print "\t at sdirs\n";
+ }
+ foreach my $dir (@sdirs){
+ next unless defined $dir; # $self->{PERL_SRC} may be undefined
+ $inabs++ if $self->file_name_is_absolute($dir);
+ if ($inabs == 1) {
+ # We've covered relative dirs; everything else is an absolute
+ # dir (probably an installed location). First, we'll try
+ # potential command names, to see whether we can avoid a long
+ # MCR expression.
+ foreach my $name (@snames) {
+ push(@cand,$name) if $name =~ /^[\w\-\$]+$/;
+ }
+ $inabs++; # Should happen above in next $dir, but just in case...
+ }
+ foreach my $name (@snames){
+ push @cand, ($name !~ m![/:>\]]!) ? $self->catfile($dir,$name)
+ : $self->fixpath($name,0);
+ }
+ }
+ foreach my $name (@cand) {
+ print "Checking $name\n" if $trace >= 2;
+ # If it looks like a potential command, try it without the MCR
+ if ($name =~ /^[\w\-\$]+$/) {
+ open(my $tcf, ">", "temp_mmvms.com")
+ or die('unable to open temp file');
+ print $tcf "\$ set message/nofacil/nosever/noident/notext\n";
+ print $tcf "\$ $name -e \"require $ver; print \"\"VER_OK\\n\"\"\"\n";
+ close $tcf;
+ $rslt = `\@temp_mmvms.com` ;
+ unlink('temp_mmvms.com');
+ if ($rslt =~ /VER_OK/) {
+ print "Using PERL=$name\n" if $trace;
+ return $name;
+ }
+ }
+ next unless $vmsfile = $self->maybe_command($name);
+ $vmsfile =~ s/;[\d\-]*$//; # Clip off version number; we can use a newer version as well
+ print "Executing $vmsfile\n" if ($trace >= 2);
+ open(my $tcf, '>', "temp_mmvms.com")
+ or die('unable to open temp file');
+ print $tcf "\$ set message/nofacil/nosever/noident/notext\n";
+ print $tcf "\$ mcr $vmsfile -e \"require $ver; print \"\"VER_OK\\n\"\"\" \n";
+ close $tcf;
+ $rslt = `\@temp_mmvms.com`;
+ unlink('temp_mmvms.com');
+ if ($rslt =~ /VER_OK/) {
+ print "Using PERL=MCR $vmsfile\n" if $trace;
+ return "MCR $vmsfile";
+ }
+ }
+ print STDOUT "Unable to find a perl $ver (by these names: @$names, in these dirs: @$dirs)\n";
+ 0; # false and not empty
+}
+
+=item maybe_command (override)
+
+Follows VMS naming conventions for executable files.
+If the name passed in doesn't exactly match an executable file,
+appends F<.Exe> (or equivalent) to check for executable image, and F<.Com>
+to check for DCL procedure. If this fails, checks directories in DCL$PATH
+and finally F<Sys$System:> for an executable file having the name specified,
+with or without the F<.Exe>-equivalent suffix.
+
+=cut
+
+sub maybe_command {
+ my($self,$file) = @_;
+ return $file if -x $file && ! -d _;
+ my(@dirs) = ('');
+ my(@exts) = ('',$Config{'exe_ext'},'.exe','.com');
+
+ if ($file !~ m![/:>\]]!) {
+ for (my $i = 0; defined $ENV{"DCL\$PATH;$i"}; $i++) {
+ my $dir = $ENV{"DCL\$PATH;$i"};
+ $dir .= ':' unless $dir =~ m%[\]:]$%;
+ push(@dirs,$dir);
+ }
+ push(@dirs,'Sys$System:');
+ foreach my $dir (@dirs) {
+ my $sysfile = "$dir$file";
+ foreach my $ext (@exts) {
+ return $file if -x "$sysfile$ext" && ! -d _;
+ }
+ }
+ }
+ return 0;
+}
+
+
+=item pasthru (override)
+
+VMS has $(MMSQUALIFIERS) which is a listing of all the original command line
+options. This is used in every invocation of make in the VMS Makefile so
+PASTHRU should not be necessary. Using PASTHRU tends to blow commands past
+the 256 character limit.
+
+=cut
+
+sub pasthru {
+ return "PASTHRU=\n";
+}
+
+
+=item pm_to_blib (override)
+
+VMS wants a dot in every file so we can't have one called 'pm_to_blib',
+it becomes 'pm_to_blib.' and MMS/K isn't smart enough to know that when
+you have a target called 'pm_to_blib' it should look for 'pm_to_blib.'.
+
+So in VMS its pm_to_blib.ts.
+
+=cut
+
+sub pm_to_blib {
+ my $self = shift;
+
+ my $make = $self->SUPER::pm_to_blib;
+
+ $make =~ s{^pm_to_blib :}{pm_to_blib.ts :}m;
+ $make =~ s{\$\(TOUCH\) pm_to_blib}{\$(TOUCH) pm_to_blib.ts};
+
+ $make = <<'MAKE' . $make;
+# Dummy target to match Unix target name; we use pm_to_blib.ts as
+# timestamp file to avoid repeated invocations under VMS
+pm_to_blib : pm_to_blib.ts
+ $(NOECHO) $(NOOP)
+
+MAKE
+
+ return $make;
+}
+
+
+=item perl_script (override)
+
+If name passed in doesn't specify a readable file, appends F<.com> or
+F<.pl> and tries again, since it's customary to have file types on all files
+under VMS.
+
+=cut
+
+sub perl_script {
+ my($self,$file) = @_;
+ return $file if -r $file && ! -d _;
+ return "$file.com" if -r "$file.com";
+ return "$file.pl" if -r "$file.pl";
+ return '';
+}
+
+
+=item replace_manpage_separator
+
+Use as separator a character which is legal in a VMS-syntax file name.
+
+=cut
+
+sub replace_manpage_separator {
+ my($self,$man) = @_;
+ $man = unixify($man);
+ $man =~ s#/+#__#g;
+ $man;
+}
+
+=item init_DEST
+
+(override) Because of the difficulty concatenating VMS filepaths we
+must pre-expand the DEST* variables.
+
+=cut
+
+sub init_DEST {
+ my $self = shift;
+
+ $self->SUPER::init_DEST;
+
+ # Expand DEST variables.
+ foreach my $var ($self->installvars) {
+ my $destvar = 'DESTINSTALL'.$var;
+ $self->{$destvar} = $self->eliminate_macros($self->{$destvar});
+ }
+}
+
+
+=item init_DIRFILESEP
+
+No seperator between a directory path and a filename on VMS.
+
+=cut
+
+sub init_DIRFILESEP {
+ my($self) = shift;
+
+ $self->{DIRFILESEP} = '';
+ return 1;
+}
+
+
+=item init_main (override)
+
+
+=cut
+
+sub init_main {
+ my($self) = shift;
+
+ $self->SUPER::init_main;
+
+ $self->{DEFINE} ||= '';
+ if ($self->{DEFINE} ne '') {
+ my(@terms) = split(/\s+/,$self->{DEFINE});
+ my(@defs, at udefs);
+ foreach my $def (@terms) {
+ next unless $def;
+ my $targ = \@defs;
+ if ($def =~ s/^-([DU])//) { # If it was a Unix-style definition
+ $targ = \@udefs if $1 eq 'U';
+ $def =~ s/='(.*)'$/=$1/; # then remove shell-protection ''
+ $def =~ s/^'(.*)'$/$1/; # from entire term or argument
+ }
+ if ($def =~ /=/) {
+ $def =~ s/"/""/g; # Protect existing " from DCL
+ $def = qq["$def"]; # and quote to prevent parsing of =
+ }
+ push @$targ, $def;
+ }
+
+ $self->{DEFINE} = '';
+ if (@defs) {
+ $self->{DEFINE} = '/Define=(' . join(',', at defs) . ')';
+ }
+ if (@udefs) {
+ $self->{DEFINE} .= '/Undef=(' . join(',', at udefs) . ')';
+ }
+ }
+}
+
+=item init_others (override)
+
+Provide VMS-specific forms of various utility commands, then hand
+off to the default MM_Unix method.
+
+DEV_NULL should probably be overriden with something.
+
+Also changes EQUALIZE_TIMESTAMP to set revision date of target file to
+one second later than source file, since MMK interprets precisely
+equal revision dates for a source and target file as a sign that the
+target needs to be updated.
+
+=cut
+
+sub init_others {
+ my($self) = @_;
+
+ $self->{NOOP} = 'Continue';
+ $self->{NOECHO} ||= '@ ';
+
+ $self->{MAKEFILE} ||= $self->{FIRST_MAKEFILE} || 'Descrip.MMS';
+ $self->{FIRST_MAKEFILE} ||= $self->{MAKEFILE};
+ $self->{MAKE_APERL_FILE} ||= 'Makeaperl.MMS';
+ $self->{MAKEFILE_OLD} ||= $self->eliminate_macros('$(FIRST_MAKEFILE)_old');
+#
+# If an extension is not specified, then MMS/MMK assumes an
+# an extension of .MMS. If there really is no extension,
+# then a trailing "." needs to be appended to specify a
+# a null extension.
+#
+ $self->{MAKEFILE} .= '.' unless $self->{MAKEFILE} =~ m/\./;
+ $self->{FIRST_MAKEFILE} .= '.' unless $self->{FIRST_MAKEFILE} =~ m/\./;
+ $self->{MAKE_APERL_FILE} .= '.' unless $self->{MAKE_APERL_FILE} =~ m/\./;
+ $self->{MAKEFILE_OLD} .= '.' unless $self->{MAKEFILE_OLD} =~ m/\./;
+
+ $self->{MACROSTART} ||= '/Macro=(';
+ $self->{MACROEND} ||= ')';
+ $self->{USEMAKEFILE} ||= '/Descrip=';
+
+ $self->{EQUALIZE_TIMESTAMP} ||= '$(ABSPERLRUN) -we "open F,qq{>>$ARGV[1]};close F;utime(0,(stat($ARGV[0]))[9]+1,$ARGV[1])"';
+
+ $self->{MOD_INSTALL} ||=
+ $self->oneliner(<<'CODE', ['-MExtUtils::Install']);
+install([ from_to => {split(' ', <STDIN>)}, verbose => '$(VERBINST)', uninstall_shadows => '$(UNINST)', dir_mode => '$(PERM_DIR)' ]);
+CODE
+
+ $self->SUPER::init_others;
+
+ $self->{SHELL} ||= 'Posix';
+
+ $self->{UMASK_NULL} = '! ';
+
+ # Redirection on VMS goes before the command, not after as on Unix.
+ # $(DEV_NULL) is used once and its not worth going nuts over making
+ # it work. However, Unix's DEV_NULL is quite wrong for VMS.
+ $self->{DEV_NULL} = '';
+
+ if ($self->{OBJECT} =~ /\s/) {
+ $self->{OBJECT} =~ s/(\\)?\n+\s+/ /g;
+ $self->{OBJECT} = $self->wraplist(
+ map $self->fixpath($_,0), split /,?\s+/, $self->{OBJECT}
+ );
+ }
+
+ $self->{LDFROM} = $self->wraplist(
+ map $self->fixpath($_,0), split /,?\s+/, $self->{LDFROM}
+ );
+}
+
+
+=item init_platform (override)
+
+Add PERL_VMS, MM_VMS_REVISION and MM_VMS_VERSION.
+
+MM_VMS_REVISION is for backwards compatibility before MM_VMS had a
+$VERSION.
+
+=cut
+
+sub init_platform {
+ my($self) = shift;
+
+ $self->{MM_VMS_REVISION} = $Revision;
+ $self->{MM_VMS_VERSION} = $VERSION;
+ $self->{PERL_VMS} = $self->catdir($self->{PERL_SRC}, 'VMS')
+ if $self->{PERL_SRC};
+}
+
+
+=item platform_constants
+
+=cut
+
+sub platform_constants {
+ my($self) = shift;
+ my $make_frag = '';
+
+ foreach my $macro (qw(PERL_VMS MM_VMS_REVISION MM_VMS_VERSION))
+ {
+ next unless defined $self->{$macro};
+ $make_frag .= "$macro = $self->{$macro}\n";
+ }
+
+ return $make_frag;
+}
+
+
+=item init_VERSION (override)
+
+Override the *DEFINE_VERSION macros with VMS semantics. Translate the
+MAKEMAKER filepath to VMS style.
+
+=cut
+
+sub init_VERSION {
+ my $self = shift;
+
+ $self->SUPER::init_VERSION;
+
+ $self->{DEFINE_VERSION} = '"$(VERSION_MACRO)=""$(VERSION)"""';
+ $self->{XS_DEFINE_VERSION} = '"$(XS_VERSION_MACRO)=""$(XS_VERSION)"""';
+ $self->{MAKEMAKER} = vmsify($INC{'ExtUtils/MakeMaker.pm'});
+}
+
+
+=item constants (override)
+
+Fixes up numerous file and directory macros to insure VMS syntax
+regardless of input syntax. Also makes lists of files
+comma-separated.
+
+=cut
+
+sub constants {
+ my($self) = @_;
+
+ # Be kind about case for pollution
+ for (@ARGV) { $_ = uc($_) if /POLLUTE/i; }
+
+ # Cleanup paths for directories in MMS macros.
+ foreach my $macro ( qw [
+ INST_BIN INST_SCRIPT INST_LIB INST_ARCHLIB
+ PERL_LIB PERL_ARCHLIB
+ PERL_INC PERL_SRC ],
+ (map { 'INSTALL'.$_ } $self->installvars)
+ )
+ {
+ next unless defined $self->{$macro};
+ next if $macro =~ /MAN/ && $self->{$macro} eq 'none';
+ $self->{$macro} = $self->fixpath($self->{$macro},1);
+ }
+
+ # Cleanup paths for files in MMS macros.
+ foreach my $macro ( qw[LIBPERL_A FIRST_MAKEFILE MAKEFILE_OLD
+ MAKE_APERL_FILE MYEXTLIB] )
+ {
+ next unless defined $self->{$macro};
+ $self->{$macro} = $self->fixpath($self->{$macro},0);
+ }
+
+ # Fixup files for MMS macros
+ # XXX is this list complete?
+ for my $macro (qw/
+ FULLEXT VERSION_FROM OBJECT LDFROM
+ / ) {
+ next unless defined $self->{$macro};
+ $self->{$macro} = $self->fixpath($self->{$macro},0);
+ }
+
+
+ for my $macro (qw/ XS MAN1PODS MAN3PODS PM /) {
+ # Where is the space coming from? --jhi
+ next unless $self ne " " && defined $self->{$macro};
+ my %tmp = ();
+ for my $key (keys %{$self->{$macro}}) {
+ $tmp{$self->fixpath($key,0)} =
+ $self->fixpath($self->{$macro}{$key},0);
+ }
+ $self->{$macro} = \%tmp;
+ }
+
+ for my $macro (qw/ C O_FILES H /) {
+ next unless defined $self->{$macro};
+ my @tmp = ();
+ for my $val (@{$self->{$macro}}) {
+ push(@tmp,$self->fixpath($val,0));
+ }
+ $self->{$macro} = \@tmp;
+ }
+
+ # mms/k does not define a $(MAKE) macro.
+ $self->{MAKE} = '$(MMS)$(MMSQUALIFIERS)';
+
+ return $self->SUPER::constants;
+}
+
+
+=item special_targets
+
+Clear the default .SUFFIXES and put in our own list.
+
+=cut
+
+sub special_targets {
+ my $self = shift;
+
+ my $make_frag .= <<'MAKE_FRAG';
+.SUFFIXES :
+.SUFFIXES : $(OBJ_EXT) .c .cpp .cxx .xs
+
+MAKE_FRAG
+
+ return $make_frag;
+}
+
+=item cflags (override)
+
+Bypass shell script and produce qualifiers for CC directly (but warn
+user if a shell script for this extension exists). Fold multiple
+/Defines into one, since some C compilers pay attention to only one
+instance of this qualifier on the command line.
+
+=cut
+
+sub cflags {
+ my($self,$libperl) = @_;
+ my($quals) = $self->{CCFLAGS} || $Config{'ccflags'};
+ my($definestr,$undefstr,$flagoptstr) = ('','','');
+ my($incstr) = '/Include=($(PERL_INC)';
+ my($name,$sys, at m);
+
+ ( $name = $self->{NAME} . "_cflags" ) =~ s/:/_/g ;
+ print STDOUT "Unix shell script ".$Config{"$self->{'BASEEXT'}_cflags"}.
+ " required to modify CC command for $self->{'BASEEXT'}\n"
+ if ($Config{$name});
+
+ if ($quals =~ / -[DIUOg]/) {
+ while ($quals =~ / -([Og])(\d*)\b/) {
+ my($type,$lvl) = ($1,$2);
+ $quals =~ s/ -$type$lvl\b\s*//;
+ if ($type eq 'g') { $flagoptstr = '/NoOptimize'; }
+ else { $flagoptstr = '/Optimize' . (defined($lvl) ? "=$lvl" : ''); }
+ }
+ while ($quals =~ / -([DIU])(\S+)/) {
+ my($type,$def) = ($1,$2);
+ $quals =~ s/ -$type$def\s*//;
+ $def =~ s/"/""/g;
+ if ($type eq 'D') { $definestr .= qq["$def",]; }
+ elsif ($type eq 'I') { $incstr .= ',' . $self->fixpath($def,1); }
+ else { $undefstr .= qq["$def",]; }
+ }
+ }
+ if (length $quals and $quals !~ m!/!) {
+ warn "MM_VMS: Ignoring unrecognized CCFLAGS elements \"$quals\"\n";
+ $quals = '';
+ }
+ $definestr .= q["PERL_POLLUTE",] if $self->{POLLUTE};
+ if (length $definestr) { chop($definestr); $quals .= "/Define=($definestr)"; }
+ if (length $undefstr) { chop($undefstr); $quals .= "/Undef=($undefstr)"; }
+ # Deal with $self->{DEFINE} here since some C compilers pay attention
+ # to only one /Define clause on command line, so we have to
+ # conflate the ones from $Config{'ccflags'} and $self->{DEFINE}
+ # ($self->{DEFINE} has already been VMSified in constants() above)
+ if ($self->{DEFINE}) { $quals .= $self->{DEFINE}; }
+ for my $type (qw(Def Undef)) {
+ my(@terms);
+ while ($quals =~ m:/${type}i?n?e?=([^/]+):ig) {
+ my $term = $1;
+ $term =~ s:^\((.+)\)$:$1:;
+ push @terms, $term;
+ }
+ if ($type eq 'Def') {
+ push @terms, qw[ $(DEFINE_VERSION) $(XS_DEFINE_VERSION) ];
+ }
+ if (@terms) {
+ $quals =~ s:/${type}i?n?e?=[^/]+::ig;
+ $quals .= "/${type}ine=(" . join(',', at terms) . ')';
+ }
+ }
+
+ $libperl or $libperl = $self->{LIBPERL_A} || "libperl.olb";
+
+ # Likewise with $self->{INC} and /Include
+ if ($self->{'INC'}) {
+ my(@includes) = split(/\s+/,$self->{INC});
+ foreach (@includes) {
+ s/^-I//;
+ $incstr .= ','.$self->fixpath($_,1);
+ }
+ }
+ $quals .= "$incstr)";
+# $quals =~ s/,,/,/g; $quals =~ s/\(,/(/g;
+ $self->{CCFLAGS} = $quals;
+
+ $self->{PERLTYPE} ||= '';
+
+ $self->{OPTIMIZE} ||= $flagoptstr || $Config{'optimize'};
+ if ($self->{OPTIMIZE} !~ m!/!) {
+ if ($self->{OPTIMIZE} =~ m!-g!) { $self->{OPTIMIZE} = '/Debug/NoOptimize' }
+ elsif ($self->{OPTIMIZE} =~ /-O(\d*)/) {
+ $self->{OPTIMIZE} = '/Optimize' . (defined($1) ? "=$1" : '');
+ }
+ else {
+ warn "MM_VMS: Can't parse OPTIMIZE \"$self->{OPTIMIZE}\"; using default\n" if length $self->{OPTIMIZE};
+ $self->{OPTIMIZE} = '/Optimize';
+ }
+ }
+
+ return $self->{CFLAGS} = qq{
+CCFLAGS = $self->{CCFLAGS}
+OPTIMIZE = $self->{OPTIMIZE}
+PERLTYPE = $self->{PERLTYPE}
+};
+}
+
+=item const_cccmd (override)
+
+Adds directives to point C preprocessor to the right place when
+handling #include E<lt>sys/foo.hE<gt> directives. Also constructs CC
+command line a bit differently than MM_Unix method.
+
+=cut
+
+sub const_cccmd {
+ my($self,$libperl) = @_;
+ my(@m);
+
+ return $self->{CONST_CCCMD} if $self->{CONST_CCCMD};
+ return '' unless $self->needs_linking();
+ if ($Config{'vms_cc_type'} eq 'gcc') {
+ push @m,'
+.FIRST
+ ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" Then Define/NoLog SYS GNU_CC_Include:[VMS]';
+ }
+ elsif ($Config{'vms_cc_type'} eq 'vaxc') {
+ push @m,'
+.FIRST
+ ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("VAXC$Include").eqs."" Then Define/NoLog SYS Sys$Library
+ ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("VAXC$Include").nes."" Then Define/NoLog SYS VAXC$Include';
+ }
+ else {
+ push @m,'
+.FIRST
+ ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("DECC$System_Include").eqs."" Then Define/NoLog SYS ',
+ ($Config{'archname'} eq 'VMS_AXP' ? 'Sys$Library' : 'DECC$Library_Include'),'
+ ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("DECC$System_Include").nes."" Then Define/NoLog SYS DECC$System_Include';
+ }
+
+ push(@m, "\n\nCCCMD = $Config{'cc'} \$(CCFLAGS)\$(OPTIMIZE)\n");
+
+ $self->{CONST_CCCMD} = join('', at m);
+}
+
+
+=item tools_other (override)
+
+Throw in some dubious extra macros for Makefile args.
+
+Also keep around the old $(SAY) macro in case somebody's using it.
+
+=cut
+
+sub tools_other {
+ my($self) = @_;
+
+ # XXX Are these necessary? Does anyone override them? They're longer
+ # than just typing the literal string.
+ my $extra_tools = <<'EXTRA_TOOLS';
+
+# Just in case anyone is using the old macro.
+USEMACROS = $(MACROSTART)
+SAY = $(ECHO)
+
+EXTRA_TOOLS
+
+ return $self->SUPER::tools_other . $extra_tools;
+}
+
+=item init_dist (override)
+
+VMSish defaults for some values.
+
+ macro description default
+
+ ZIPFLAGS flags to pass to ZIP -Vu
+
+ COMPRESS compression command to gzip
+ use for tarfiles
+ SUFFIX suffix to put on -gz
+ compressed files
+
+ SHAR shar command to use vms_share
+
+ DIST_DEFAULT default target to use to tardist
+ create a distribution
+
+ DISTVNAME Use VERSION_SYM instead of $(DISTNAME)-$(VERSION_SYM)
+ VERSION for the name
+
+=cut
+
+sub init_dist {
+ my($self) = @_;
+ $self->{ZIPFLAGS} ||= '-Vu';
+ $self->{COMPRESS} ||= 'gzip';
+ $self->{SUFFIX} ||= '-gz';
+ $self->{SHAR} ||= 'vms_share';
+ $self->{DIST_DEFAULT} ||= 'zipdist';
+
+ $self->SUPER::init_dist;
+
+ $self->{DISTVNAME} = "$self->{DISTNAME}-$self->{VERSION_SYM}"
+ unless $self->{ARGS}{DISTVNAME};
+
+ return;
+}
+
+=item c_o (override)
+
+Use VMS syntax on command line. In particular, $(DEFINE) and
+$(PERL_INC) have been pulled into $(CCCMD). Also use MM[SK] macros.
+
+=cut
+
+sub c_o {
+ my($self) = @_;
+ return '' unless $self->needs_linking();
+ '
+.c$(OBJ_EXT) :
+ $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).c
+
+.cpp$(OBJ_EXT) :
+ $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).cpp
+
+.cxx$(OBJ_EXT) :
+ $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).cxx
+
+';
+}
+
+=item xs_c (override)
+
+Use MM[SK] macros.
+
+=cut
+
+sub xs_c {
+ my($self) = @_;
+ return '' unless $self->needs_linking();
+ '
+.xs.c :
+ $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs >$(MMS$TARGET)
+';
+}
+
+=item xs_o (override)
+
+Use MM[SK] macros, and VMS command line for C compiler.
+
+=cut
+
+sub xs_o { # many makes are too dumb to use xs_c then c_o
+ my($self) = @_;
+ return '' unless $self->needs_linking();
+ '
+.xs$(OBJ_EXT) :
+ $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs >$(MMS$TARGET_NAME).c
+ $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).c
+';
+}
+
+
+=item dlsyms (override)
+
+Create VMS linker options files specifying universal symbols for this
+extension's shareable image, and listing other shareable images or
+libraries to which it should be linked.
+
+=cut
+
+sub dlsyms {
+ my($self,%attribs) = @_;
+
+ return '' unless $self->needs_linking();
+
+ my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {};
+ my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || [];
+ my($funclist) = $attribs{FUNCLIST} || $self->{FUNCLIST} || [];
+ my(@m);
+
+ unless ($self->{SKIPHASH}{'dynamic'}) {
+ push(@m,'
+dynamic :: $(INST_ARCHAUTODIR)$(BASEEXT).opt
+ $(NOECHO) $(NOOP)
+');
+ }
+
+ push(@m,'
+static :: $(INST_ARCHAUTODIR)$(BASEEXT).opt
+ $(NOECHO) $(NOOP)
+') unless $self->{SKIPHASH}{'static'};
+
+ push @m,'
+$(INST_ARCHAUTODIR)$(BASEEXT).opt : $(BASEEXT).opt
+ $(CP) $(MMS$SOURCE) $(MMS$TARGET)
+
+$(BASEEXT).opt : Makefile.PL
+ $(PERLRUN) -e "use ExtUtils::Mksymlists;" -
+ ',qq[-e "Mksymlists('NAME' => '$self->{NAME}', 'DL_FUNCS' => ],
+ neatvalue($funcs),q[, 'DL_VARS' => ],neatvalue($vars),
+ q[, 'FUNCLIST' => ],neatvalue($funclist),qq[)"\n];
+
+ push @m, ' $(PERL) -e "print ""$(INST_STATIC)/Include=';
+ if ($self->{OBJECT} =~ /\bBASEEXT\b/ or
+ $self->{OBJECT} =~ /\b$self->{BASEEXT}\b/i) {
+ push @m, ($Config{d_vms_case_sensitive_symbols}
+ ? uc($self->{BASEEXT}) :'$(BASEEXT)');
+ }
+ else { # We don't have a "main" object file, so pull 'em all in
+ # Upcase module names if linker is being case-sensitive
+ my($upcase) = $Config{d_vms_case_sensitive_symbols};
+ my(@omods) = split ' ', $self->eliminate_macros($self->{OBJECT});
+ for (@omods) {
+ s/\.[^.]*$//; # Trim off file type
+ s[\$\(\w+_EXT\)][]; # even as a macro
+ s/.*[:>\/\]]//; # Trim off dir spec
+ $_ = uc if $upcase;
+ };
+
+ my(@lines);
+ my $tmp = shift @omods;
+ foreach my $elt (@omods) {
+ $tmp .= ",$elt";
+ if (length($tmp) > 80) { push @lines, $tmp; $tmp = ''; }
+ }
+ push @lines, $tmp;
+ push @m, '(', join( qq[, -\\n\\t"";" >>\$(MMS\$TARGET)\n\t\$(PERL) -e "print ""], @lines),')';
+ }
+ push @m, '\n$(INST_STATIC)/Library\n"";" >>$(MMS$TARGET)',"\n";
+
+ if (length $self->{LDLOADLIBS}) {
+ my($line) = '';
+ foreach my $lib (split ' ', $self->{LDLOADLIBS}) {
+ $lib =~ s%\$%\\\$%g; # Escape '$' in VMS filespecs
+ if (length($line) + length($lib) > 160) {
+ push @m, "\t\$(PERL) -e \"print qq{$line}\" >>\$(MMS\$TARGET)\n";
+ $line = $lib . '\n';
+ }
+ else { $line .= $lib . '\n'; }
+ }
+ push @m, "\t\$(PERL) -e \"print qq{$line}\" >>\$(MMS\$TARGET)\n" if $line;
+ }
+
+ join('', at m);
+
+}
+
+=item dynamic_lib (override)
+
+Use VMS Link command.
+
+=cut
+
+sub dynamic_lib {
+ my($self, %attribs) = @_;
+ return '' unless $self->needs_linking(); #might be because of a subdir
+
+ return '' unless $self->has_link_code();
+
+ my($otherldflags) = $attribs{OTHERLDFLAGS} || "";
+ my($inst_dynamic_dep) = $attribs{INST_DYNAMIC_DEP} || "";
+ my $shr = $Config{'dbgprefix'} . 'PerlShr';
+ my(@m);
+ push @m,"
+
+OTHERLDFLAGS = $otherldflags
+INST_DYNAMIC_DEP = $inst_dynamic_dep
+
+";
+ push @m, '
+$(INST_DYNAMIC) : $(INST_STATIC) $(PERL_INC)perlshr_attr.opt $(INST_ARCHAUTODIR)$(DFSEP).exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP)
+ If F$TrnLNm("',$shr,'").eqs."" Then Define/NoLog/User ',"$shr Sys\$Share:$shr.$Config{'dlext'}",'
+ Link $(LDFLAGS) /Shareable=$(MMS$TARGET)$(OTHERLDFLAGS) $(BASEEXT).opt/Option,$(PERL_INC)perlshr_attr.opt/Option
+';
+
+ join('', at m);
+}
+
+
+=item static_lib (override)
+
+Use VMS commands to manipulate object library.
+
+=cut
+
+sub static_lib {
+ my($self) = @_;
+ return '' unless $self->needs_linking();
+
+ return '
+$(INST_STATIC) :
+ $(NOECHO) $(NOOP)
+' unless ($self->{OBJECT} or @{$self->{C} || []} or $self->{MYEXTLIB});
+
+ my(@m);
+ push @m,'
+# Rely on suffix rule for update action
+$(OBJECT) : $(INST_ARCHAUTODIR)$(DFSEP).exists
+
+$(INST_STATIC) : $(OBJECT) $(MYEXTLIB)
+';
+ # If this extension has its own library (eg SDBM_File)
+ # then copy that to $(INST_STATIC) and add $(OBJECT) into it.
+ push(@m, "\t",'$(CP) $(MYEXTLIB) $(MMS$TARGET)',"\n") if $self->{MYEXTLIB};
+
+ push(@m,"\t",'If F$Search("$(MMS$TARGET)").eqs."" Then Library/Object/Create $(MMS$TARGET)',"\n");
+
+ # if there was a library to copy, then we can't use MMS$SOURCE_LIST,
+ # 'cause it's a library and you can't stick them in other libraries.
+ # In that case, we use $OBJECT instead and hope for the best
+ if ($self->{MYEXTLIB}) {
+ push(@m,"\t",'Library/Object/Replace $(MMS$TARGET) $(OBJECT)',"\n");
+ } else {
+ push(@m,"\t",'Library/Object/Replace $(MMS$TARGET) $(MMS$SOURCE_LIST)',"\n");
+ }
+
+ push @m, "\t\$(NOECHO) \$(PERL) -e 1 >\$(INST_ARCHAUTODIR)extralibs.ld\n";
+ foreach my $lib (split ' ', $self->{EXTRALIBS}) {
+ push(@m,"\t",'$(NOECHO) $(PERL) -e "print qq{',$lib,'\n}" >>$(INST_ARCHAUTODIR)extralibs.ld',"\n");
+ }
+ join('', at m);
+}
+
+
+=item extra_clean_files
+
+Clean up some OS specific files. Plus the temp file used to shorten
+a lot of commands.
+
+=cut
+
+sub extra_clean_files {
+ return qw(
+ *.Map *.Dmp *.Lis *.cpp *.$(DLEXT) *.Opt $(BASEEXT).bso
+ .MM_Tmp
+ );
+}
+
+
+=item zipfile_target
+
+=item tarfile_target
+
+=item shdist_target
+
+Syntax for invoking shar, tar and zip differs from that for Unix.
+
+=cut
+
+sub zipfile_target {
+ my($self) = shift;
+
+ return <<'MAKE_FRAG';
+$(DISTVNAME).zip : distdir
+ $(PREOP)
+ $(ZIP) "$(ZIPFLAGS)" $(MMS$TARGET) [.$(DISTVNAME)...]*.*;
+ $(RM_RF) $(DISTVNAME)
+ $(POSTOP)
+MAKE_FRAG
+}
+
+sub tarfile_target {
+ my($self) = shift;
+
+ return <<'MAKE_FRAG';
+$(DISTVNAME).tar$(SUFFIX) : distdir
+ $(PREOP)
+ $(TO_UNIX)
+ $(TAR) "$(TARFLAGS)" $(DISTVNAME).tar [.$(DISTVNAME)...]
+ $(RM_RF) $(DISTVNAME)
+ $(COMPRESS) $(DISTVNAME).tar
+ $(POSTOP)
+MAKE_FRAG
+}
+
+sub shdist_target {
+ my($self) = shift;
+
+ return <<'MAKE_FRAG';
+shdist : distdir
+ $(PREOP)
+ $(SHAR) [.$(DISTVNAME)...]*.*; $(DISTVNAME).share
+ $(RM_RF) $(DISTVNAME)
+ $(POSTOP)
+MAKE_FRAG
+}
+
+
+# --- Test and Installation Sections ---
+
+=item install (override)
+
+Work around DCL's 255 character limit several times,and use
+VMS-style command line quoting in a few cases.
+
+=cut
+
+sub install {
+ my($self, %attribs) = @_;
+ my(@m);
+
+ push @m, q[
+install :: all pure_install doc_install
+ $(NOECHO) $(NOOP)
+
+install_perl :: all pure_perl_install doc_perl_install
+ $(NOECHO) $(NOOP)
+
+install_site :: all pure_site_install doc_site_install
+ $(NOECHO) $(NOOP)
+
+pure_install :: pure_$(INSTALLDIRS)_install
+ $(NOECHO) $(NOOP)
+
+doc_install :: doc_$(INSTALLDIRS)_install
+ $(NOECHO) $(NOOP)
+
+pure__install : pure_site_install
+ $(NOECHO) $(ECHO) "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site"
+
+doc__install : doc_site_install
+ $(NOECHO) $(ECHO) "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site"
+
+# This hack brought to you by DCL's 255-character command line limit
+pure_perl_install ::
+ $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read '.File::Spec->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').' '" >.MM_tmp
+ $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write '.File::Spec->catfile('$(DESTINSTALLARCHLIB)','auto','$(FULLEXT)','.packlist').' '" >>.MM_tmp
+ $(NOECHO) $(ECHO_N) "$(INST_LIB) $(DESTINSTALLPRIVLIB) " >>.MM_tmp
+ $(NOECHO) $(ECHO_N) "$(INST_ARCHLIB) $(DESTINSTALLARCHLIB) " >>.MM_tmp
+ $(NOECHO) $(ECHO_N) "$(INST_BIN) $(DESTINSTALLBIN) " >>.MM_tmp
+ $(NOECHO) $(ECHO_N) "$(INST_SCRIPT) $(DESTINSTALLSCRIPT) " >>.MM_tmp
+ $(NOECHO) $(ECHO_N) "$(INST_MAN1DIR) $(DESTINSTALLMAN1DIR) " >>.MM_tmp
+ $(NOECHO) $(ECHO_N) "$(INST_MAN3DIR) $(DESTINSTALLMAN3DIR) " >>.MM_tmp
+ $(NOECHO) $(MOD_INSTALL) <.MM_tmp
+ $(NOECHO) $(RM_F) .MM_tmp
+ $(NOECHO) $(WARN_IF_OLD_PACKLIST) ].$self->catfile($self->{SITEARCHEXP},'auto',$self->{FULLEXT},'.packlist').q[
+
+# Likewise
+pure_site_install ::
+ $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read '.File::Spec->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').' '" >.MM_tmp
+ $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write '.File::Spec->catfile('$(DESTINSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').' '" >>.MM_tmp
+ $(NOECHO) $(ECHO_N) "$(INST_LIB) $(DESTINSTALLSITELIB) " >>.MM_tmp
+ $(NOECHO) $(ECHO_N) "$(INST_ARCHLIB) $(DESTINSTALLSITEARCH) " >>.MM_tmp
+ $(NOECHO) $(ECHO_N) "$(INST_BIN) $(DESTINSTALLSITEBIN) " >>.MM_tmp
+ $(NOECHO) $(ECHO_N) "$(INST_SCRIPT) $(DESTINSTALLSCRIPT) " >>.MM_tmp
+ $(NOECHO) $(ECHO_N) "$(INST_MAN1DIR) $(DESTINSTALLSITEMAN1DIR) " >>.MM_tmp
+ $(NOECHO) $(ECHO_N) "$(INST_MAN3DIR) $(DESTINSTALLSITEMAN3DIR) " >>.MM_tmp
+ $(NOECHO) $(MOD_INSTALL) <.MM_tmp
+ $(NOECHO) $(RM_F) .MM_tmp
+ $(NOECHO) $(WARN_IF_OLD_PACKLIST) ].$self->catfile($self->{PERL_ARCHLIB},'auto',$self->{FULLEXT},'.packlist').q[
+
+pure_vendor_install ::
+ $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read '.File::Spec->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').' '" >.MM_tmp
+ $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write '.File::Spec->catfile('$(DESTINSTALLVENDORARCH)','auto','$(FULLEXT)','.packlist').' '" >>.MM_tmp
+ $(NOECHO) $(ECHO_N) "$(INST_LIB) $(DESTINSTALLVENDORLIB) " >>.MM_tmp
+ $(NOECHO) $(ECHO_N) "$(INST_ARCHLIB) $(DESTINSTALLVENDORARCH) " >>.MM_tmp
+ $(NOECHO) $(ECHO_N) "$(INST_BIN) $(DESTINSTALLVENDORBIN) " >>.MM_tmp
+ $(NOECHO) $(ECHO_N) "$(INST_SCRIPT) $(DESTINSTALLSCRIPT) " >>.MM_tmp
+ $(NOECHO) $(ECHO_N) "$(INST_MAN1DIR) $(DESTINSTALLVENDORMAN1DIR) " >>.MM_tmp
+ $(NOECHO) $(ECHO_N) "$(INST_MAN3DIR) $(DESTINSTALLVENDORMAN3DIR) " >>.MM_tmp
+ $(NOECHO) $(MOD_INSTALL) <.MM_tmp
+ $(NOECHO) $(RM_F) .MM_tmp
+
+# Ditto
+doc_perl_install ::
+ $(NOECHO) $(ECHO) "Appending installation info to ].$self->catfile($self->{DESTINSTALLARCHLIB}, 'perllocal.pod').q["
+ $(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
+ $(NOECHO) $(ECHO_N) "installed into|$(INSTALLPRIVLIB)|" >.MM_tmp
+ $(NOECHO) $(ECHO_N) "LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES) " >>.MM_tmp
+ $(NOECHO) $(DOC_INSTALL) "Module" "$(NAME)" <.MM_tmp >>].$self->catfile($self->{DESTINSTALLARCHLIB},'perllocal.pod').q[
+ $(NOECHO) $(RM_F) .MM_tmp
+
+# And again
+doc_site_install ::
+ $(NOECHO) $(ECHO) "Appending installation info to ].$self->catfile($self->{DESTINSTALLARCHLIB}, 'perllocal.pod').q["
+ $(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
+ $(NOECHO) $(ECHO_N) "installed into|$(INSTALLSITELIB)|" >.MM_tmp
+ $(NOECHO) $(ECHO_N) "LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES) " >>.MM_tmp
+ $(NOECHO) $(DOC_INSTALL) "Module" "$(NAME)" <.MM_tmp >>].$self->catfile($self->{DESTINSTALLARCHLIB},'perllocal.pod').q[
+ $(NOECHO) $(RM_F) .MM_tmp
+
+doc_vendor_install ::
+ $(NOECHO) $(ECHO) "Appending installation info to ].$self->catfile($self->{DESTINSTALLARCHLIB}, 'perllocal.pod').q["
+ $(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
+ $(NOECHO) $(ECHO_N) "installed into|$(INSTALLVENDORLIB)|" >.MM_tmp
+ $(NOECHO) $(ECHO_N) "LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES) " >>.MM_tmp
+ $(NOECHO) $(DOC_INSTALL) "Module" "$(NAME)" <.MM_tmp >>].$self->catfile($self->{DESTINSTALLARCHLIB},'perllocal.pod').q[
+ $(NOECHO) $(RM_F) .MM_tmp
+
+];
+
+ push @m, q[
+uninstall :: uninstall_from_$(INSTALLDIRS)dirs
+ $(NOECHO) $(NOOP)
+
+uninstall_from_perldirs ::
+ $(NOECHO) $(UNINSTALL) ].$self->catfile($self->{PERL_ARCHLIB},'auto',$self->{FULLEXT},'.packlist').q[
+ $(NOECHO) $(ECHO) "Uninstall is now deprecated and makes no actual changes."
+ $(NOECHO) $(ECHO) "Please check the list above carefully for errors, and manually remove"
+ $(NOECHO) $(ECHO) "the appropriate files. Sorry for the inconvenience."
+
+uninstall_from_sitedirs ::
+ $(NOECHO) $(UNINSTALL) ].$self->catfile($self->{SITEARCHEXP},'auto',$self->{FULLEXT},'.packlist').q[
+ $(NOECHO) $(ECHO) "Uninstall is now deprecated and makes no actual changes."
+ $(NOECHO) $(ECHO) "Please check the list above carefully for errors, and manually remove"
+ $(NOECHO) $(ECHO) "the appropriate files. Sorry for the inconvenience."
+];
+
+ join('', at m);
+}
+
+=item perldepend (override)
+
+Use VMS-style syntax for files; it's cheaper to just do it directly here
+than to have the MM_Unix method call C<catfile> repeatedly. Also, if
+we have to rebuild Config.pm, use MM[SK] to do it.
+
+=cut
+
+sub perldepend {
+ my($self) = @_;
+ my(@m);
+
+ push @m, '
+$(OBJECT) : $(PERL_INC)EXTERN.h, $(PERL_INC)INTERN.h, $(PERL_INC)XSUB.h
+$(OBJECT) : $(PERL_INC)av.h, $(PERL_INC)cc_runtime.h, $(PERL_INC)config.h
+$(OBJECT) : $(PERL_INC)cop.h, $(PERL_INC)cv.h, $(PERL_INC)embed.h
+$(OBJECT) : $(PERL_INC)embedvar.h, $(PERL_INC)form.h
+$(OBJECT) : $(PERL_INC)gv.h, $(PERL_INC)handy.h, $(PERL_INC)hv.h
+$(OBJECT) : $(PERL_INC)intrpvar.h, $(PERL_INC)iperlsys.h, $(PERL_INC)keywords.h
+$(OBJECT) : $(PERL_INC)mg.h, $(PERL_INC)nostdio.h, $(PERL_INC)op.h
+$(OBJECT) : $(PERL_INC)opcode.h, $(PERL_INC)patchlevel.h
+$(OBJECT) : $(PERL_INC)perl.h, $(PERL_INC)perlio.h
+$(OBJECT) : $(PERL_INC)perlsdio.h, $(PERL_INC)perlvars.h
+$(OBJECT) : $(PERL_INC)perly.h, $(PERL_INC)pp.h, $(PERL_INC)pp_proto.h
+$(OBJECT) : $(PERL_INC)proto.h, $(PERL_INC)regcomp.h, $(PERL_INC)regexp.h
+$(OBJECT) : $(PERL_INC)regnodes.h, $(PERL_INC)scope.h, $(PERL_INC)sv.h
+$(OBJECT) : $(PERL_INC)thread.h, $(PERL_INC)util.h, $(PERL_INC)vmsish.h
+
+' if $self->{OBJECT};
+
+ if ($self->{PERL_SRC}) {
+ my(@macros);
+ my($mmsquals) = '$(USEMAKEFILE)[.vms]$(FIRST_MAKEFILE)';
+ push(@macros,'__AXP__=1') if $Config{'archname'} eq 'VMS_AXP';
+ push(@macros,'DECC=1') if $Config{'vms_cc_type'} eq 'decc';
+ push(@macros,'GNUC=1') if $Config{'vms_cc_type'} eq 'gcc';
+ push(@macros,'SOCKET=1') if $Config{'d_has_sockets'};
+ push(@macros,qq["CC=$Config{'cc'}"]) if $Config{'cc'} =~ m!/!;
+ $mmsquals .= '$(USEMACROS)' . join(',', at macros) . '$(MACROEND)' if @macros;
+ push(@m,q[
+# Check for unpropagated config.sh changes. Should never happen.
+# We do NOT just update config.h because that is not sufficient.
+# An out of date config.h is not fatal but complains loudly!
+$(PERL_INC)config.h : $(PERL_SRC)config.sh
+ $(NOOP)
+
+$(PERL_ARCHLIB)Config.pm : $(PERL_SRC)config.sh
+ $(NOECHO) Write Sys$Error "$(PERL_ARCHLIB)Config.pm may be out of date with config.h or genconfig.pl"
+ olddef = F$Environment("Default")
+ Set Default $(PERL_SRC)
+ $(MMS)],$mmsquals,);
+ if ($self->{PERL_ARCHLIB} =~ m|\[-| && $self->{PERL_SRC} =~ m|(\[-+)|) {
+ my($prefix,$target) = ($1,$self->fixpath('$(PERL_ARCHLIB)Config.pm',0));
+ $target =~ s/\Q$prefix/[/;
+ push(@m," $target");
+ }
+ else { push(@m,' $(MMS$TARGET)'); }
+ push(@m,q[
+ Set Default 'olddef'
+]);
+ }
+
+ push(@m, join(" ", map($self->fixpath($_,0),values %{$self->{XS}}))." : \$(XSUBPPDEPS)\n")
+ if %{$self->{XS}};
+
+ join('', at m);
+}
+
+
+=item makeaperl (override)
+
+Undertake to build a new set of Perl images using VMS commands. Since
+VMS does dynamic loading, it's not necessary to statically link each
+extension into the Perl image, so this isn't the normal build path.
+Consequently, it hasn't really been tested, and may well be incomplete.
+
+=cut
+
+our %olbs; # needs to be localized
+
+sub makeaperl {
+ my($self, %attribs) = @_;
+ my($makefilename, $searchdirs, $static, $extra, $perlinc, $target, $tmpdir, $libperl) =
+ @attribs{qw(MAKE DIRS STAT EXTRA INCL TARGET TMP LIBPERL)};
+ my(@m);
+ push @m, "
+# --- MakeMaker makeaperl section ---
+MAP_TARGET = $target
+";
+ return join '', @m if $self->{PARENT};
+
+ my($dir) = join ":", @{$self->{DIR}};
+
+ unless ($self->{MAKEAPERL}) {
+ push @m, q{
+$(MAKE_APERL_FILE) : $(FIRST_MAKEFILE)
+ $(NOECHO) $(ECHO) "Writing ""$(MMS$TARGET)"" for this $(MAP_TARGET)"
+ $(NOECHO) $(PERLRUNINST) \
+ Makefile.PL DIR=}, $dir, q{ \
+ FIRST_MAKEFILE=$(MAKE_APERL_FILE) LINKTYPE=static \
+ MAKEAPERL=1 NORECURS=1 };
+
+ push @m, map(q[ \\\n\t\t"$_"], @ARGV),q{
+
+$(MAP_TARGET) :: $(MAKE_APERL_FILE)
+ $(MAKE)$(USEMAKEFILE)$(MAKE_APERL_FILE) static $(MMS$TARGET)
+};
+ push @m, "\n";
+
+ return join '', @m;
+ }
+
+
+ my($linkcmd, at optlibs, at staticpkgs,$extralist,$targdir,$libperldir,%libseen);
+ local($_);
+
+ # The front matter of the linkcommand...
+ $linkcmd = join ' ', $Config{'ld'},
+ grep($_, @Config{qw(large split ldflags ccdlflags)});
+ $linkcmd =~ s/\s+/ /g;
+
+ # Which *.olb files could we make use of...
+ local(%olbs); # XXX can this be lexical?
+ $olbs{$self->{INST_ARCHAUTODIR}} = "$self->{BASEEXT}\$(LIB_EXT)";
+ require File::Find;
+ File::Find::find(sub {
+ return unless m/\Q$self->{LIB_EXT}\E$/;
+ return if m/^libperl/;
+
+ if( exists $self->{INCLUDE_EXT} ){
+ my $found = 0;
+
+ (my $xx = $File::Find::name) =~ s,.*?/auto/,,;
+ $xx =~ s,/?$_,,;
+ $xx =~ s,/,::,g;
+
+ # Throw away anything not explicitly marked for inclusion.
+ # DynaLoader is implied.
+ foreach my $incl ((@{$self->{INCLUDE_EXT}},'DynaLoader')){
+ if( $xx eq $incl ){
+ $found++;
+ last;
+ }
+ }
+ return unless $found;
+ }
+ elsif( exists $self->{EXCLUDE_EXT} ){
+ (my $xx = $File::Find::name) =~ s,.*?/auto/,,;
+ $xx =~ s,/?$_,,;
+ $xx =~ s,/,::,g;
+
+ # Throw away anything explicitly marked for exclusion
+ foreach my $excl (@{$self->{EXCLUDE_EXT}}){
+ return if( $xx eq $excl );
+ }
+ }
+
+ $olbs{$ENV{DEFAULT}} = $_;
+ }, grep( -d $_, @{$searchdirs || []}));
+
+ # We trust that what has been handed in as argument will be buildable
+ $static = [] unless $static;
+ @olbs{@{$static}} = (1) x @{$static};
+
+ $extra = [] unless $extra && ref $extra eq 'ARRAY';
+ # Sort the object libraries in inverse order of
+ # filespec length to try to insure that dependent extensions
+ # will appear before their parents, so the linker will
+ # search the parent library to resolve references.
+ # (e.g. Intuit::DWIM will precede Intuit, so unresolved
+ # references from [.intuit.dwim]dwim.obj can be found
+ # in [.intuit]intuit.olb).
+ for (sort { length($a) <=> length($b) } keys %olbs) {
+ next unless $olbs{$_} =~ /\Q$self->{LIB_EXT}\E$/;
+ my($dir) = $self->fixpath($_,1);
+ my($extralibs) = $dir . "extralibs.ld";
+ my($extopt) = $dir . $olbs{$_};
+ $extopt =~ s/$self->{LIB_EXT}$/.opt/;
+ push @optlibs, "$dir$olbs{$_}";
+ # Get external libraries this extension will need
+ if (-f $extralibs ) {
+ my %seenthis;
+ open my $list, "<", $extralibs or warn $!,next;
+ while (<$list>) {
+ chomp;
+ # Include a library in the link only once, unless it's mentioned
+ # multiple times within a single extension's options file, in which
+ # case we assume the builder needed to search it again later in the
+ # link.
+ my $skip = exists($libseen{$_}) && !exists($seenthis{$_});
+ $libseen{$_}++; $seenthis{$_}++;
+ next if $skip;
+ push @$extra,$_;
+ }
+ }
+ # Get full name of extension for ExtUtils::Miniperl
+ if (-f $extopt) {
+ open my $opt, '<', $extopt or die $!;
+ while (<$opt>) {
+ next unless /(?:UNIVERSAL|VECTOR)=boot_([\w_]+)/;
+ my $pkg = $1;
+ $pkg =~ s#__*#::#g;
+ push @staticpkgs,$pkg;
+ }
+ }
+ }
+ # Place all of the external libraries after all of the Perl extension
+ # libraries in the final link, in order to maximize the opportunity
+ # for XS code from multiple extensions to resolve symbols against the
+ # same external library while only including that library once.
+ push @optlibs, @$extra;
+
+ $target = "Perl$Config{'exe_ext'}" unless $target;
+ my $shrtarget;
+ ($shrtarget,$targdir) = fileparse($target);
+ $shrtarget =~ s/^([^.]*)/$1Shr/;
+ $shrtarget = $targdir . $shrtarget;
+ $target = "Perlshr.$Config{'dlext'}" unless $target;
+ $tmpdir = "[]" unless $tmpdir;
+ $tmpdir = $self->fixpath($tmpdir,1);
+ if (@optlibs) { $extralist = join(' ', at optlibs); }
+ else { $extralist = ''; }
+ # Let ExtUtils::Liblist find the necessary libs for us (but skip PerlShr)
+ # that's what we're building here).
+ push @optlibs, grep { !/PerlShr/i } split ' ', +($self->ext())[2];
+ if ($libperl) {
+ unless (-f $libperl || -f ($libperl = $self->catfile($Config{'installarchlib'},'CORE',$libperl))) {
+ print STDOUT "Warning: $libperl not found\n";
+ undef $libperl;
+ }
+ }
+ unless ($libperl) {
+ if (defined $self->{PERL_SRC}) {
+ $libperl = $self->catfile($self->{PERL_SRC},"libperl$self->{LIB_EXT}");
+ } elsif (-f ($libperl = $self->catfile($Config{'installarchlib'},'CORE',"libperl$self->{LIB_EXT}")) ) {
+ } else {
+ print STDOUT "Warning: $libperl not found
+ If you're going to build a static perl binary, make sure perl is installed
+ otherwise ignore this warning\n";
+ }
+ }
+ $libperldir = $self->fixpath((fileparse($libperl))[1],1);
+
+ push @m, '
+# Fill in the target you want to produce if it\'s not perl
+MAP_TARGET = ',$self->fixpath($target,0),'
+MAP_SHRTARGET = ',$self->fixpath($shrtarget,0),"
+MAP_LINKCMD = $linkcmd
+MAP_PERLINC = ", $perlinc ? map('"$_" ',@{$perlinc}) : '',"
+MAP_EXTRA = $extralist
+MAP_LIBPERL = ",$self->fixpath($libperl,0),'
+';
+
+
+ push @m,"\n${tmpdir}Makeaperl.Opt : \$(MAP_EXTRA)\n";
+ foreach (@optlibs) {
+ push @m,' $(NOECHO) $(PERL) -e "print q{',$_,'}" >>$(MMS$TARGET)',"\n";
+ }
+ push @m,"\n${tmpdir}PerlShr.Opt :\n\t";
+ push @m,'$(NOECHO) $(PERL) -e "print q{$(MAP_SHRTARGET)}" >$(MMS$TARGET)',"\n";
+
+ push @m,'
+$(MAP_SHRTARGET) : $(MAP_LIBPERL) Makeaperl.Opt ',"${libperldir}Perlshr_Attr.Opt",'
+ $(MAP_LINKCMD)/Shareable=$(MMS$TARGET) $(MAP_LIBPERL), Makeaperl.Opt/Option ',"${libperldir}Perlshr_Attr.Opt/Option",'
+$(MAP_TARGET) : $(MAP_SHRTARGET) ',"${tmpdir}perlmain\$(OBJ_EXT) ${tmpdir}PerlShr.Opt",'
+ $(MAP_LINKCMD) ',"${tmpdir}perlmain\$(OBJ_EXT)",', PerlShr.Opt/Option
+ $(NOECHO) $(ECHO) "To install the new ""$(MAP_TARGET)"" binary, say"
+ $(NOECHO) $(ECHO) " $(MAKE)$(USEMAKEFILE)$(FIRST_MAKEFILE) inst_perl $(USEMACROS)MAP_TARGET=$(MAP_TARGET)$(ENDMACRO)"
+ $(NOECHO) $(ECHO) "To remove the intermediate files, say
+ $(NOECHO) $(ECHO) " $(MAKE)$(USEMAKEFILE)$(FIRST_MAKEFILE) map_clean"
+';
+ push @m,"\n${tmpdir}perlmain.c : \$(FIRST_MAKEFILE)\n\t\$(NOECHO) \$(PERL) -e 1 >${tmpdir}Writemain.tmp\n";
+ push @m, "# More from the 255-char line length limit\n";
+ foreach (@staticpkgs) {
+ push @m,' $(NOECHO) $(PERL) -e "print q{',$_,qq[}" >>${tmpdir}Writemain.tmp\n];
+ }
+
+ push @m, sprintf <<'MAKE_FRAG', $tmpdir, $tmpdir;
+ $(NOECHO) $(PERL) $(MAP_PERLINC) -ane "use ExtUtils::Miniperl; writemain(@F)" %sWritemain.tmp >$(MMS$TARGET)
+ $(NOECHO) $(RM_F) %sWritemain.tmp
+MAKE_FRAG
+
+ push @m, q[
+# Still more from the 255-char line length limit
+doc_inst_perl :
+ $(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
+ $(NOECHO) $(ECHO) "Perl binary $(MAP_TARGET)|" >.MM_tmp
+ $(NOECHO) $(ECHO) "MAP_STATIC|$(MAP_STATIC)|" >>.MM_tmp
+ $(NOECHO) $(PERL) -pl040 -e " " ].$self->catfile('$(INST_ARCHAUTODIR)','extralibs.all'),q[ >>.MM_tmp
+ $(NOECHO) $(ECHO) -e "MAP_LIBPERL|$(MAP_LIBPERL)|" >>.MM_tmp
+ $(NOECHO) $(DOC_INSTALL) <.MM_tmp >>].$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q[
+ $(NOECHO) $(RM_F) .MM_tmp
+];
+
+ push @m, "
+inst_perl : pure_inst_perl doc_inst_perl
+ \$(NOECHO) \$(NOOP)
+
+pure_inst_perl : \$(MAP_TARGET)
+ $self->{CP} \$(MAP_SHRTARGET) ",$self->fixpath($Config{'installbin'},1),"
+ $self->{CP} \$(MAP_TARGET) ",$self->fixpath($Config{'installbin'},1),"
+
+clean :: map_clean
+ \$(NOECHO) \$(NOOP)
+
+map_clean :
+ \$(RM_F) ${tmpdir}perlmain\$(OBJ_EXT) ${tmpdir}perlmain.c \$(FIRST_MAKEFILE)
+ \$(RM_F) ${tmpdir}Makeaperl.Opt ${tmpdir}PerlShr.Opt \$(MAP_TARGET)
+";
+
+ join '', @m;
+}
+
+
+# --- Output postprocessing section ---
+
+=item maketext_filter (override)
+
+Insure that colons marking targets are preceded by space, in order
+to distinguish the target delimiter from a colon appearing as
+part of a filespec.
+
+=cut
+
+sub maketext_filter {
+ my($self, $text) = @_;
+
+ $text =~ s/^([^\s:=]+)(:+\s)/$1 $2/mg;
+ return $text;
+}
+
+=item prefixify (override)
+
+prefixifying on VMS is simple. Each should simply be:
+
+ perl_root:[some.dir]
+
+which can just be converted to:
+
+ volume:[your.prefix.some.dir]
+
+otherwise you get the default layout.
+
+In effect, your search prefix is ignored and $Config{vms_prefix} is
+used instead.
+
+=cut
+
+sub prefixify {
+ my($self, $var, $sprefix, $rprefix, $default) = @_;
+
+ # Translate $(PERLPREFIX) to a real path.
+ $rprefix = $self->eliminate_macros($rprefix);
+ $rprefix = vmspath($rprefix) if $rprefix;
+ $sprefix = vmspath($sprefix) if $sprefix;
+
+ $default = vmsify($default)
+ unless $default =~ /\[.*\]/;
+
+ (my $var_no_install = $var) =~ s/^install//;
+ my $path = $self->{uc $var} ||
+ $ExtUtils::MM_Unix::Config_Override{lc $var} ||
+ $Config{lc $var} || $Config{lc $var_no_install};
+
+ if( !$path ) {
+ print STDERR " no Config found for $var.\n" if $Verbose >= 2;
+ $path = $self->_prefixify_default($rprefix, $default);
+ }
+ elsif( !$self->{ARGS}{PREFIX} || !$self->file_name_is_absolute($path) ) {
+ # do nothing if there's no prefix or if its relative
+ }
+ elsif( $sprefix eq $rprefix ) {
+ print STDERR " no new prefix.\n" if $Verbose >= 2;
+ }
+ else {
+
+ print STDERR " prefixify $var => $path\n" if $Verbose >= 2;
+ print STDERR " from $sprefix to $rprefix\n" if $Verbose >= 2;
+
+ my($path_vol, $path_dirs) = $self->splitpath( $path );
+ if( $path_vol eq $Config{vms_prefix}.':' ) {
+ print STDERR " $Config{vms_prefix}: seen\n" if $Verbose >= 2;
+
+ $path_dirs =~ s{^\[}{\[.} unless $path_dirs =~ m{^\[\.};
+ $path = $self->_catprefix($rprefix, $path_dirs);
+ }
+ else {
+ $path = $self->_prefixify_default($rprefix, $default);
+ }
+ }
+
+ print " now $path\n" if $Verbose >= 2;
+ return $self->{uc $var} = $path;
+}
+
+
+sub _prefixify_default {
+ my($self, $rprefix, $default) = @_;
+
+ print STDERR " cannot prefix, using default.\n" if $Verbose >= 2;
+
+ if( !$default ) {
+ print STDERR "No default!\n" if $Verbose >= 1;
+ return;
+ }
+ if( !$rprefix ) {
+ print STDERR "No replacement prefix!\n" if $Verbose >= 1;
+ return '';
+ }
+
+ return $self->_catprefix($rprefix, $default);
+}
+
+sub _catprefix {
+ my($self, $rprefix, $default) = @_;
+
+ my($rvol, $rdirs) = $self->splitpath($rprefix);
+ if( $rvol ) {
+ return $self->catpath($rvol,
+ $self->catdir($rdirs, $default),
+ ''
+ )
+ }
+ else {
+ return $self->catdir($rdirs, $default);
+ }
+}
+
+
+=item cd
+
+=cut
+
+sub cd {
+ my($self, $dir, @cmds) = @_;
+
+ $dir = vmspath($dir);
+
+ my $cmd = join "\n\t", map "$_", @cmds;
+
+ # No leading tab makes it look right when embedded
+ my $make_frag = sprintf <<'MAKE_FRAG', $dir, $cmd;
+startdir = F$Environment("Default")
+ Set Default %s
+ %s
+ Set Default 'startdir'
+MAKE_FRAG
+
+ # No trailing newline makes this easier to embed
+ chomp $make_frag;
+
+ return $make_frag;
+}
+
+
+=item oneliner
+
+=cut
+
+sub oneliner {
+ my($self, $cmd, $switches) = @_;
+ $switches = [] unless defined $switches;
+
+ # Strip leading and trailing newlines
+ $cmd =~ s{^\n+}{};
+ $cmd =~ s{\n+$}{};
+
+ $cmd = $self->quote_literal($cmd);
+ $cmd = $self->escape_newlines($cmd);
+
+ # Switches must be quoted else they will be lowercased.
+ $switches = join ' ', map { qq{"$_"} } @$switches;
+
+ return qq{\$(ABSPERLRUN) $switches -e $cmd "--"};
+}
+
+
+=item B<echo>
+
+perl trips up on "<foo>" thinking it's an input redirect. So we use the
+native Write command instead. Besides, its faster.
+
+=cut
+
+sub echo {
+ my($self, $text, $file, $appending) = @_;
+ $appending ||= 0;
+
+ my $opencmd = $appending ? 'Open/Append' : 'Open/Write';
+
+ my @cmds = ("\$(NOECHO) $opencmd MMECHOFILE $file ");
+ push @cmds, map { '$(NOECHO) Write MMECHOFILE '.$self->quote_literal($_) }
+ split /\n/, $text;
+ push @cmds, '$(NOECHO) Close MMECHOFILE';
+ return @cmds;
+}
+
+
+=item quote_literal
+
+=cut
+
+sub quote_literal {
+ my($self, $text) = @_;
+
+ # I believe this is all we should need.
+ $text =~ s{"}{""}g;
+
+ return qq{"$text"};
+}
+
+=item escape_newlines
+
+=cut
+
+sub escape_newlines {
+ my($self, $text) = @_;
+
+ $text =~ s{\n}{-\n}g;
+
+ return $text;
+}
+
+=item max_exec_len
+
+256 characters.
+
+=cut
+
+sub max_exec_len {
+ my $self = shift;
+
+ return $self->{_MAX_EXEC_LEN} ||= 256;
+}
+
+=item init_linker
+
+=cut
+
+sub init_linker {
+ my $self = shift;
+ $self->{EXPORT_LIST} ||= '$(BASEEXT).opt';
+
+ my $shr = $Config{dbgprefix} . 'PERLSHR';
+ if ($self->{PERL_SRC}) {
+ $self->{PERL_ARCHIVE} ||=
+ $self->catfile($self->{PERL_SRC}, "$shr.$Config{'dlext'}");
+ }
+ else {
+ $self->{PERL_ARCHIVE} ||=
+ $ENV{$shr} ? $ENV{$shr} : "Sys\$Share:$shr.$Config{'dlext'}";
+ }
+
+ $self->{PERL_ARCHIVE_AFTER} ||= '';
+}
+
+
+=item catdir (override)
+
+=item catfile (override)
+
+Eliminate the macros in the output to the MMS/MMK file.
+
+(File::Spec::VMS used to do this for us, but it's being removed)
+
+=cut
+
+sub catdir {
+ my $self = shift;
+
+ # Process the macros on VMS MMS/MMK
+ my @args = map { m{\$\(} ? $self->eliminate_macros($_) : $_ } @_;
+
+ my $dir = $self->SUPER::catdir(@args);
+
+ # Fix up the directory and force it to VMS format.
+ $dir = $self->fixpath($dir, 1);
+
+ return $dir;
+}
+
+sub catfile {
+ my $self = shift;
+
+ # Process the macros on VMS MMS/MMK
+ my @args = map { m{\$\(} ? $self->eliminate_macros($_) : $_ } @_;
+
+ my $file = $self->SUPER::catfile(@args);
+
+ $file = vmsify($file);
+
+ return $file
+}
+
+
+=item eliminate_macros
+
+Expands MM[KS]/Make macros in a text string, using the contents of
+identically named elements of C<%$self>, and returns the result
+as a file specification in Unix syntax.
+
+NOTE: This is the canonical version of the method. The version in
+File::Spec::VMS is deprecated.
+
+=cut
+
+sub eliminate_macros {
+ my($self,$path) = @_;
+ return '' unless $path;
+ $self = {} unless ref $self;
+
+ if ($path =~ /\s/) {
+ return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path;
+ }
+
+ my($npath) = unixify($path);
+ # sometimes unixify will return a string with an off-by-one trailing null
+ $npath =~ s{\0$}{};
+
+ my($complex) = 0;
+ my($head,$macro,$tail);
+
+ # perform m##g in scalar context so it acts as an iterator
+ while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) {
+ if (defined $self->{$2}) {
+ ($head,$macro,$tail) = ($1,$2,$3);
+ if (ref $self->{$macro}) {
+ if (ref $self->{$macro} eq 'ARRAY') {
+ $macro = join ' ', @{$self->{$macro}};
+ }
+ else {
+ print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}),
+ "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n";
+ $macro = "\cB$macro\cB";
+ $complex = 1;
+ }
+ }
+ else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; }
+ $npath = "$head$macro$tail";
+ }
+ }
+ if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; }
+ $npath;
+}
+
+=item fixpath
+
+ my $path = $mm->fixpath($path);
+ my $path = $mm->fixpath($path, $is_dir);
+
+Catchall routine to clean up problem MM[SK]/Make macros. Expands macros
+in any directory specification, in order to avoid juxtaposing two
+VMS-syntax directories when MM[SK] is run. Also expands expressions which
+are all macro, so that we can tell how long the expansion is, and avoid
+overrunning DCL's command buffer when MM[KS] is running.
+
+fixpath() checks to see whether the result matches the name of a
+directory in the current default directory and returns a directory or
+file specification accordingly. C<$is_dir> can be set to true to
+force fixpath() to consider the path to be a directory or false to force
+it to be a file.
+
+NOTE: This is the canonical version of the method. The version in
+File::Spec::VMS is deprecated.
+
+=cut
+
+sub fixpath {
+ my($self,$path,$force_path) = @_;
+ return '' unless $path;
+ $self = bless {}, $self unless ref $self;
+ my($fixedpath,$prefix,$name);
+
+ if ($path =~ /[ \t]/) {
+ return join ' ',
+ map { $self->fixpath($_,$force_path) }
+ split /[ \t]+/, $path;
+ }
+
+ if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) {
+ if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) {
+ $fixedpath = vmspath($self->eliminate_macros($path));
+ }
+ else {
+ $fixedpath = vmsify($self->eliminate_macros($path));
+ }
+ }
+ elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) {
+ my($vmspre) = $self->eliminate_macros("\$($prefix)");
+ # is it a dir or just a name?
+ $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : '';
+ $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
+ $fixedpath = vmspath($fixedpath) if $force_path;
+ }
+ else {
+ $fixedpath = $path;
+ $fixedpath = vmspath($fixedpath) if $force_path;
+ }
+ # No hints, so we try to guess
+ if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {
+ $fixedpath = vmspath($fixedpath) if -d $fixedpath;
+ }
+
+ # Trim off root dirname if it's had other dirs inserted in front of it.
+ $fixedpath =~ s/\.000000([\]>])/$1/;
+ # Special case for VMS absolute directory specs: these will have had device
+ # prepended during trip through Unix syntax in eliminate_macros(), since
+ # Unix syntax has no way to express "absolute from the top of this device's
+ # directory tree".
+ if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; }
+
+ return $fixedpath;
+}
+
+
+=item os_flavor
+
+VMS is VMS.
+
+=cut
+
+sub os_flavor {
+ return('VMS');
+}
+
+=back
+
+
+=head1 AUTHOR
+
+Original author Charles Bailey F<bailey at newman.upenn.edu>
+
+Maintained by Michael G Schwern F<schwern at pobox.com>
+
+See L<ExtUtils::MakeMaker> for patching and contact information.
+
+
+=cut
+
+1;
+
Copied: trunk/contrib/perl/lib/ExtUtils/MM_VOS.pm (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/MM_VOS.pm)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/MM_VOS.pm (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/MM_VOS.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,50 @@
+package ExtUtils::MM_VOS;
+
+use strict;
+our $VERSION = '6.55_02';
+
+require ExtUtils::MM_Unix;
+our @ISA = qw(ExtUtils::MM_Unix);
+
+
+=head1 NAME
+
+ExtUtils::MM_VOS - VOS specific subclass of ExtUtils::MM_Unix
+
+=head1 SYNOPSIS
+
+ Don't use this module directly.
+ Use ExtUtils::MM and let it choose.
+
+=head1 DESCRIPTION
+
+This is a subclass of ExtUtils::MM_Unix which contains functionality for
+VOS.
+
+Unless otherwise stated it works just like ExtUtils::MM_Unix
+
+=head2 Overridden methods
+
+=head3 extra_clean_files
+
+Cleanup VOS core files
+
+=cut
+
+sub extra_clean_files {
+ return qw(*.kp);
+}
+
+
+=head1 AUTHOR
+
+Michael G Schwern <schwern at pobox.com> with code from ExtUtils::MM_Unix
+
+=head1 SEE ALSO
+
+L<ExtUtils::MakeMaker>
+
+=cut
+
+
+1;
Copied: trunk/contrib/perl/lib/ExtUtils/MM_Win32.pm (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/MM_Win32.pm)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/MM_Win32.pm (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/MM_Win32.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,584 @@
+package ExtUtils::MM_Win32;
+
+use strict;
+
+
+=head1 NAME
+
+ExtUtils::MM_Win32 - methods to override UN*X behaviour in ExtUtils::MakeMaker
+
+=head1 SYNOPSIS
+
+ use ExtUtils::MM_Win32; # Done internally by ExtUtils::MakeMaker if needed
+
+=head1 DESCRIPTION
+
+See ExtUtils::MM_Unix for a documentation of the methods provided
+there. This package overrides the implementation of these methods, not
+the semantics.
+
+=cut
+
+use ExtUtils::MakeMaker::Config;
+use File::Basename;
+use File::Spec;
+use ExtUtils::MakeMaker qw( neatvalue );
+
+require ExtUtils::MM_Any;
+require ExtUtils::MM_Unix;
+our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix );
+our $VERSION = '6.55_02';
+
+$ENV{EMXSHELL} = 'sh'; # to run `commands`
+
+my $BORLAND = $Config{'cc'} =~ /^bcc/i ? 1 : 0;
+my $GCC = $Config{'cc'} =~ /^gcc/i ? 1 : 0;
+
+
+=head2 Overridden methods
+
+=over 4
+
+=item B<dlsyms>
+
+=cut
+
+sub dlsyms {
+ my($self,%attribs) = @_;
+
+ my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {};
+ my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || [];
+ my($funclist) = $attribs{FUNCLIST} || $self->{FUNCLIST} || [];
+ my($imports) = $attribs{IMPORTS} || $self->{IMPORTS} || {};
+ my(@m);
+
+ if (not $self->{SKIPHASH}{'dynamic'}) {
+ push(@m,"
+$self->{BASEEXT}.def: Makefile.PL
+",
+ q! $(PERLRUN) -MExtUtils::Mksymlists \\
+ -e "Mksymlists('NAME'=>\"!, $self->{NAME},
+ q!\", 'DLBASE' => '!,$self->{DLBASE},
+ # The above two lines quoted differently to work around
+ # a bug in the 4DOS/4NT command line interpreter. The visible
+ # result of the bug was files named q('extension_name',) *with the
+ # single quotes and the comma* in the extension build directories.
+ q!', 'DL_FUNCS' => !,neatvalue($funcs),
+ q!, 'FUNCLIST' => !,neatvalue($funclist),
+ q!, 'IMPORTS' => !,neatvalue($imports),
+ q!, 'DL_VARS' => !, neatvalue($vars), q!);"
+!);
+ }
+ join('', at m);
+}
+
+=item replace_manpage_separator
+
+Changes the path separator with .
+
+=cut
+
+sub replace_manpage_separator {
+ my($self,$man) = @_;
+ $man =~ s,/+,.,g;
+ $man;
+}
+
+
+=item B<maybe_command>
+
+Since Windows has nothing as simple as an executable bit, we check the
+file extension.
+
+The PATHEXT env variable will be used to get a list of extensions that
+might indicate a command, otherwise .com, .exe, .bat and .cmd will be
+used by default.
+
+=cut
+
+sub maybe_command {
+ my($self,$file) = @_;
+ my @e = exists($ENV{'PATHEXT'})
+ ? split(/;/, $ENV{PATHEXT})
+ : qw(.com .exe .bat .cmd);
+ my $e = '';
+ for (@e) { $e .= "\Q$_\E|" }
+ chop $e;
+ # see if file ends in one of the known extensions
+ if ($file =~ /($e)$/i) {
+ return $file if -e $file;
+ }
+ else {
+ for (@e) {
+ return "$file$_" if -e "$file$_";
+ }
+ }
+ return;
+}
+
+
+=item B<init_DIRFILESEP>
+
+Using \ for Windows.
+
+=cut
+
+sub init_DIRFILESEP {
+ my($self) = shift;
+
+ # The ^ makes sure its not interpreted as an escape in nmake
+ $self->{DIRFILESEP} = $self->is_make_type('nmake') ? '^\\' :
+ $self->is_make_type('dmake') ? '\\\\'
+ : '\\';
+}
+
+=item B<init_others>
+
+Override some of the Unix specific commands with portable
+ExtUtils::Command ones.
+
+Also provide defaults for LD and AR in case the %Config values aren't
+set.
+
+LDLOADLIBS's default is changed to $Config{libs}.
+
+Adjustments are made for Borland's quirks needing -L to come first.
+
+=cut
+
+sub init_others {
+ my ($self) = @_;
+
+ $self->{NOOP} ||= 'rem';
+ $self->{DEV_NULL} ||= '> NUL';
+
+ $self->{FIXIN} ||= $self->{PERL_CORE} ?
+ "\$(PERLRUN) $self->{PERL_SRC}/win32/bin/pl2bat.pl" :
+ 'pl2bat.bat';
+
+ $self->{LD} ||= 'link';
+ $self->{AR} ||= 'lib';
+
+ $self->SUPER::init_others;
+
+ # Setting SHELL from $Config{sh} can break dmake. Its ok without it.
+ delete $self->{SHELL};
+
+ $self->{LDLOADLIBS} ||= $Config{libs};
+ # -Lfoo must come first for Borland, so we put it in LDDLFLAGS
+ if ($BORLAND) {
+ my $libs = $self->{LDLOADLIBS};
+ my $libpath = '';
+ while ($libs =~ s/(?:^|\s)(("?)-L.+?\2)(?:\s|$)/ /) {
+ $libpath .= ' ' if length $libpath;
+ $libpath .= $1;
+ }
+ $self->{LDLOADLIBS} = $libs;
+ $self->{LDDLFLAGS} ||= $Config{lddlflags};
+ $self->{LDDLFLAGS} .= " $libpath";
+ }
+
+ return 1;
+}
+
+
+=item init_platform
+
+Add MM_Win32_VERSION.
+
+=item platform_constants
+
+=cut
+
+sub init_platform {
+ my($self) = shift;
+
+ $self->{MM_Win32_VERSION} = $VERSION;
+}
+
+sub platform_constants {
+ my($self) = shift;
+ my $make_frag = '';
+
+ foreach my $macro (qw(MM_Win32_VERSION))
+ {
+ next unless defined $self->{$macro};
+ $make_frag .= "$macro = $self->{$macro}\n";
+ }
+
+ return $make_frag;
+}
+
+
+=item special_targets
+
+Add .USESHELL target for dmake.
+
+=cut
+
+sub special_targets {
+ my($self) = @_;
+
+ my $make_frag = $self->SUPER::special_targets;
+
+ $make_frag .= <<'MAKE_FRAG' if $self->is_make_type('dmake');
+.USESHELL :
+MAKE_FRAG
+
+ return $make_frag;
+}
+
+
+=item static_lib
+
+Changes how to run the linker.
+
+The rest is duplicate code from MM_Unix. Should move the linker code
+to its own method.
+
+=cut
+
+sub static_lib {
+ my($self) = @_;
+ return '' unless $self->has_link_code;
+
+ my(@m);
+ push(@m, <<'END');
+$(INST_STATIC): $(OBJECT) $(MYEXTLIB) $(INST_ARCHAUTODIR)$(DFSEP).exists
+ $(RM_RF) $@
+END
+
+ # If this extension has its own library (eg SDBM_File)
+ # then copy that to $(INST_STATIC) and add $(OBJECT) into it.
+ push @m, <<'MAKE_FRAG' if $self->{MYEXTLIB};
+ $(CP) $(MYEXTLIB) $@
+MAKE_FRAG
+
+ push @m,
+q{ $(AR) }.($BORLAND ? '$@ $(OBJECT:^"+")'
+ : ($GCC ? '-ru $@ $(OBJECT)'
+ : '-out:$@ $(OBJECT)')).q{
+ $(CHMOD) $(PERM_RWX) $@
+ $(NOECHO) $(ECHO) "$(EXTRALIBS)" > $(INST_ARCHAUTODIR)\extralibs.ld
+};
+
+ # Old mechanism - still available:
+ push @m, <<'MAKE_FRAG' if $self->{PERL_SRC} && $self->{EXTRALIBS};
+ $(NOECHO) $(ECHO) "$(EXTRALIBS)" >> $(PERL_SRC)\ext.libs
+MAKE_FRAG
+
+ join('', @m);
+}
+
+
+=item dynamic_lib
+
+Complicated stuff for Win32 that I don't understand. :(
+
+=cut
+
+sub dynamic_lib {
+ my($self, %attribs) = @_;
+ return '' unless $self->needs_linking(); #might be because of a subdir
+
+ return '' unless $self->has_link_code;
+
+ my($otherldflags) = $attribs{OTHERLDFLAGS} || ($BORLAND ? 'c0d32.obj': '');
+ my($inst_dynamic_dep) = $attribs{INST_DYNAMIC_DEP} || "";
+ my($ldfrom) = '$(LDFROM)';
+ my(@m);
+
+# one thing for GCC/Mingw32:
+# we try to overcome non-relocateable-DLL problems by generating
+# a (hopefully unique) image-base from the dll's name
+# -- BKS, 10-19-1999
+ if ($GCC) {
+ my $dllname = $self->{BASEEXT} . "." . $self->{DLEXT};
+ $dllname =~ /(....)(.{0,4})/;
+ my $baseaddr = unpack("n", $1 ^ $2);
+ $otherldflags .= sprintf("-Wl,--image-base,0x%x0000 ", $baseaddr);
+ }
+
+ push(@m,'
+# This section creates the dynamically loadable $(INST_DYNAMIC)
+# from $(OBJECT) and possibly $(MYEXTLIB).
+OTHERLDFLAGS = '.$otherldflags.'
+INST_DYNAMIC_DEP = '.$inst_dynamic_dep.'
+
+$(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DFSEP).exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP)
+');
+ if ($GCC) {
+ push(@m,
+ q{ dlltool --def $(EXPORT_LIST) --output-exp dll.exp
+ $(LD) -o $@ -Wl,--base-file -Wl,dll.base $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) dll.exp
+ dlltool --def $(EXPORT_LIST) --base-file dll.base --output-exp dll.exp
+ $(LD) -o $@ $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) dll.exp });
+ } elsif ($BORLAND) {
+ push(@m,
+ q{ $(LD) $(LDDLFLAGS) $(OTHERLDFLAGS) }.$ldfrom.q{,$@,,}
+ .($self->is_make_type('dmake')
+ ? q{$(PERL_ARCHIVE:s,/,\,) $(LDLOADLIBS:s,/,\,) }
+ .q{$(MYEXTLIB:s,/,\,),$(EXPORT_LIST:s,/,\,)}
+ : q{$(subst /,\,$(PERL_ARCHIVE)) $(subst /,\,$(LDLOADLIBS)) }
+ .q{$(subst /,\,$(MYEXTLIB)),$(subst /,\,$(EXPORT_LIST))})
+ .q{,$(RESFILES)});
+ } else { # VC
+ push(@m,
+ q{ $(LD) -out:$@ $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) }
+ .q{$(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) -def:$(EXPORT_LIST)});
+
+ # Embed the manifest file if it exists
+ push(@m, q{
+ if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;2
+ if exist $@.manifest del $@.manifest});
+ }
+ push @m, '
+ $(CHMOD) $(PERM_RWX) $@
+';
+
+ join('', at m);
+}
+
+=item extra_clean_files
+
+Clean out some extra dll.{base,exp} files which might be generated by
+gcc. Otherwise, take out all *.pdb files.
+
+=cut
+
+sub extra_clean_files {
+ my $self = shift;
+
+ return $GCC ? (qw(dll.base dll.exp)) : ('*.pdb');
+}
+
+=item init_linker
+
+=cut
+
+sub init_linker {
+ my $self = shift;
+
+ $self->{PERL_ARCHIVE} = "\$(PERL_INC)\\$Config{libperl}";
+ $self->{PERL_ARCHIVE_AFTER} = '';
+ $self->{EXPORT_LIST} = '$(BASEEXT).def';
+}
+
+
+=item perl_script
+
+Checks for the perl program under several common perl extensions.
+
+=cut
+
+sub perl_script {
+ my($self,$file) = @_;
+ return $file if -r $file && -f _;
+ return "$file.pl" if -r "$file.pl" && -f _;
+ return "$file.plx" if -r "$file.plx" && -f _;
+ return "$file.bat" if -r "$file.bat" && -f _;
+ return;
+}
+
+
+=item xs_o
+
+This target is stubbed out. Not sure why.
+
+=cut
+
+sub xs_o {
+ return ''
+}
+
+
+=item pasthru
+
+All we send is -nologo to nmake to prevent it from printing its damned
+banner.
+
+=cut
+
+sub pasthru {
+ my($self) = shift;
+ return "PASTHRU = " . ($self->is_make_type('nmake') ? "-nologo" : "");
+}
+
+
+=item arch_check (override)
+
+Normalize all arguments for consistency of comparison.
+
+=cut
+
+sub arch_check {
+ my $self = shift;
+
+ # Win32 is an XS module, minperl won't have it.
+ # arch_check() is not critical, so just fake it.
+ return 1 unless $self->can_load_xs;
+ return $self->SUPER::arch_check( map { $self->_normalize_path_name($_) } @_);
+}
+
+sub _normalize_path_name {
+ my $self = shift;
+ my $file = shift;
+
+ require Win32;
+ my $short = Win32::GetShortPathName($file);
+ return defined $short ? lc $short : lc $file;
+}
+
+
+=item oneliner
+
+These are based on what command.com does on Win98. They may be wrong
+for other Windows shells, I don't know.
+
+=cut
+
+sub oneliner {
+ my($self, $cmd, $switches) = @_;
+ $switches = [] unless defined $switches;
+
+ # Strip leading and trailing newlines
+ $cmd =~ s{^\n+}{};
+ $cmd =~ s{\n+$}{};
+
+ $cmd = $self->quote_literal($cmd);
+ $cmd = $self->escape_newlines($cmd);
+
+ $switches = join ' ', @$switches;
+
+ return qq{\$(ABSPERLRUN) $switches -e $cmd --};
+}
+
+
+sub quote_literal {
+ my($self, $text) = @_;
+
+ # I don't know if this is correct, but it seems to work on
+ # Win98's command.com
+ $text =~ s{"}{\\"}g;
+
+ # dmake eats '{' inside double quotes and leaves alone { outside double
+ # quotes; however it transforms {{ into { either inside and outside double
+ # quotes. It also translates }} into }. The escaping below is not
+ # 100% correct.
+ if( $self->is_make_type('dmake') ) {
+ $text =~ s/{/{{/g;
+ $text =~ s/}}/}}}/g;
+ }
+
+ return qq{"$text"};
+}
+
+
+sub escape_newlines {
+ my($self, $text) = @_;
+
+ # Escape newlines
+ $text =~ s{\n}{\\\n}g;
+
+ return $text;
+}
+
+
+=item cd
+
+dmake can handle Unix style cd'ing but nmake (at least 1.5) cannot. It
+wants:
+
+ cd dir1\dir2
+ command
+ another_command
+ cd ..\..
+
+=cut
+
+sub cd {
+ my($self, $dir, @cmds) = @_;
+
+ return $self->SUPER::cd($dir, @cmds) unless $self->is_make_type('nmake');
+
+ my $cmd = join "\n\t", map "$_", @cmds;
+
+ my $updirs = $self->catdir(map { $self->updir } $self->splitdir($dir));
+
+ # No leading tab and no trailing newline makes for easier embedding.
+ my $make_frag = sprintf <<'MAKE_FRAG', $dir, $cmd, $updirs;
+cd %s
+ %s
+ cd %s
+MAKE_FRAG
+
+ chomp $make_frag;
+
+ return $make_frag;
+}
+
+
+=item max_exec_len
+
+nmake 1.50 limits command length to 2048 characters.
+
+=cut
+
+sub max_exec_len {
+ my $self = shift;
+
+ return $self->{_MAX_EXEC_LEN} ||= 2 * 1024;
+}
+
+
+=item os_flavor
+
+Windows is Win32.
+
+=cut
+
+sub os_flavor {
+ return('Win32');
+}
+
+
+=item cflags
+
+Defines the PERLDLL symbol if we are configured for static building since all
+code destined for the perl5xx.dll must be compiled with the PERLDLL symbol
+defined.
+
+=cut
+
+sub cflags {
+ my($self,$libperl)=@_;
+ return $self->{CFLAGS} if $self->{CFLAGS};
+ return '' unless $self->needs_linking();
+
+ my $base = $self->SUPER::cflags($libperl);
+ foreach (split /\n/, $base) {
+ /^(\S*)\s*=\s*(\S*)$/ and $self->{$1} = $2;
+ };
+ $self->{CCFLAGS} .= " -DPERLDLL" if ($self->{LINKTYPE} eq 'static');
+
+ return $self->{CFLAGS} = qq{
+CCFLAGS = $self->{CCFLAGS}
+OPTIMIZE = $self->{OPTIMIZE}
+PERLTYPE = $self->{PERLTYPE}
+};
+
+}
+
+sub is_make_type {
+ my($self, $type) = @_;
+ return !! ($self->make =~ /\b$type(?:\.exe)?$/);
+}
+
+1;
+__END__
+
+=back
+
+=cut
+
+
Copied: trunk/contrib/perl/lib/ExtUtils/MM_Win95.pm (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/MM_Win95.pm)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/MM_Win95.pm (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/MM_Win95.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,124 @@
+package ExtUtils::MM_Win95;
+
+use strict;
+
+our $VERSION = '6.55_02';
+
+require ExtUtils::MM_Win32;
+our @ISA = qw(ExtUtils::MM_Win32);
+
+use ExtUtils::MakeMaker::Config;
+
+
+=head1 NAME
+
+ExtUtils::MM_Win95 - method to customize MakeMaker for Win9X
+
+=head1 SYNOPSIS
+
+ You should not be using this module directly.
+
+=head1 DESCRIPTION
+
+This is a subclass of ExtUtils::MM_Win32 containing changes necessary
+to get MakeMaker playing nice with command.com and other Win9Xisms.
+
+=head2 Overridden methods
+
+Most of these make up for limitations in the Win9x/nmake command shell.
+Mostly its lack of &&.
+
+=over 4
+
+
+=item xs_c
+
+The && problem.
+
+=cut
+
+sub xs_c {
+ my($self) = shift;
+ return '' unless $self->needs_linking();
+ '
+.xs.c:
+ $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.c
+ '
+}
+
+
+=item xs_cpp
+
+The && problem
+
+=cut
+
+sub xs_cpp {
+ my($self) = shift;
+ return '' unless $self->needs_linking();
+ '
+.xs.cpp:
+ $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.cpp
+ ';
+}
+
+=item xs_o
+
+The && problem.
+
+=cut
+
+sub xs_o {
+ my($self) = shift;
+ return '' unless $self->needs_linking();
+ '
+.xs$(OBJ_EXT):
+ $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.c
+ $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.c
+ ';
+}
+
+
+=item max_exec_len
+
+Win98 chokes on things like Encode if we set the max length to nmake's max
+of 2K. So we go for a more conservative value of 1K.
+
+=cut
+
+sub max_exec_len {
+ my $self = shift;
+
+ return $self->{_MAX_EXEC_LEN} ||= 1024;
+}
+
+
+=item os_flavor
+
+Win95 and Win98 and WinME are collectively Win9x and Win32
+
+=cut
+
+sub os_flavor {
+ my $self = shift;
+ return ($self->SUPER::os_flavor, 'Win9x');
+}
+
+
+=back
+
+
+=head1 AUTHOR
+
+Code originally inside MM_Win32. Original author unknown.
+
+Currently maintained by Michael G Schwern C<schwern at pobox.com>.
+
+Send patches and ideas to C<makemaker at perl.org>.
+
+See http://www.makemaker.org.
+
+=cut
+
+
+1;
Copied: trunk/contrib/perl/lib/ExtUtils/MY.pm (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/MY.pm)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/MY.pm (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/MY.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,40 @@
+package ExtUtils::MY;
+
+use strict;
+require ExtUtils::MM;
+
+our $VERSION = 6.55_02;
+our @ISA = qw(ExtUtils::MM);
+
+{
+ package MY;
+ our @ISA = qw(ExtUtils::MY);
+}
+
+sub DESTROY {}
+
+
+=head1 NAME
+
+ExtUtils::MY - ExtUtils::MakeMaker subclass for customization
+
+=head1 SYNOPSIS
+
+ # in your Makefile.PL
+ sub MY::whatever {
+ ...
+ }
+
+=head1 DESCRIPTION
+
+B<FOR INTERNAL USE ONLY>
+
+ExtUtils::MY is a subclass of ExtUtils::MM. Its provided in your
+Makefile.PL for you to add and override MakeMaker functionality.
+
+It also provides a convenient alias via the MY class.
+
+ExtUtils::MY might turn out to be a temporary solution, but MY won't
+go away.
+
+=cut
Copied: trunk/contrib/perl/lib/ExtUtils/MakeMaker.pm (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/MakeMaker.pm)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/MakeMaker.pm (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/MakeMaker.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,2809 @@
+# $Id: MakeMaker.pm,v 1.1.1.2 2011-02-17 12:49:38 laffer1 Exp $
+package ExtUtils::MakeMaker;
+
+use strict;
+
+BEGIN {require 5.006;}
+
+require Exporter;
+use ExtUtils::MakeMaker::Config;
+use Carp ();
+use File::Path;
+
+our $Verbose = 0; # exported
+our @Parent; # needs to be localized
+our @Get_from_Config; # referenced by MM_Unix
+our @MM_Sections;
+our @Overridable;
+my @Prepend_parent;
+my %Recognized_Att_Keys;
+
+our $VERSION = '6.55_02';
+
+# Emulate something resembling CVS $Revision: 1.1.1.2 $
+(our $Revision = $VERSION) =~ s{_}{};
+$Revision = int $Revision * 10000;
+
+our $Filename = __FILE__; # referenced outside MakeMaker
+
+our @ISA = qw(Exporter);
+our @EXPORT = qw(&WriteMakefile &writeMakefile $Verbose &prompt);
+our @EXPORT_OK = qw($VERSION &neatvalue &mkbootstrap &mksymlists
+ &WriteEmptyMakefile);
+
+# These will go away once the last of the Win32 & VMS specific code is
+# purged.
+my $Is_VMS = $^O eq 'VMS';
+my $Is_Win32 = $^O eq 'MSWin32';
+
+full_setup();
+
+require ExtUtils::MM; # Things like CPAN assume loading ExtUtils::MakeMaker
+ # will give them MM.
+
+require ExtUtils::MY; # XXX pre-5.8 versions of ExtUtils::Embed expect
+ # loading ExtUtils::MakeMaker will give them MY.
+ # This will go when Embed is its own CPAN module.
+
+
+sub WriteMakefile {
+ Carp::croak "WriteMakefile: Need even number of args" if @_ % 2;
+
+ require ExtUtils::MY;
+ my %att = @_;
+
+ _verify_att(\%att);
+
+ my $mm = MM->new(\%att);
+ $mm->flush;
+
+ return $mm;
+}
+
+
+# Basic signatures of the attributes WriteMakefile takes. Each is the
+# reference type. Empty value indicate it takes a non-reference
+# scalar.
+my %Att_Sigs;
+my %Special_Sigs = (
+ C => 'ARRAY',
+ CONFIG => 'ARRAY',
+ CONFIGURE => 'CODE',
+ DIR => 'ARRAY',
+ DL_FUNCS => 'HASH',
+ DL_VARS => 'ARRAY',
+ EXCLUDE_EXT => 'ARRAY',
+ EXE_FILES => 'ARRAY',
+ FUNCLIST => 'ARRAY',
+ H => 'ARRAY',
+ IMPORTS => 'HASH',
+ INCLUDE_EXT => 'ARRAY',
+ LIBS => ['ARRAY',''],
+ MAN1PODS => 'HASH',
+ MAN3PODS => 'HASH',
+ META_ADD => 'HASH',
+ META_MERGE => 'HASH',
+ PL_FILES => 'HASH',
+ PM => 'HASH',
+ PMLIBDIRS => 'ARRAY',
+ PMLIBPARENTDIRS => 'ARRAY',
+ PREREQ_PM => 'HASH',
+ BUILD_REQUIRES => 'HASH',
+ CONFIGURE_REQUIRES => 'HASH',
+ SKIP => 'ARRAY',
+ TYPEMAPS => 'ARRAY',
+ XS => 'HASH',
+ VERSION => ['version',''],
+ _KEEP_AFTER_FLUSH => '',
+
+ clean => 'HASH',
+ depend => 'HASH',
+ dist => 'HASH',
+ dynamic_lib=> 'HASH',
+ linkext => 'HASH',
+ macro => 'HASH',
+ postamble => 'HASH',
+ realclean => 'HASH',
+ test => 'HASH',
+ tool_autosplit => 'HASH',
+);
+
+ at Att_Sigs{keys %Recognized_Att_Keys} = ('') x keys %Recognized_Att_Keys;
+ at Att_Sigs{keys %Special_Sigs} = values %Special_Sigs;
+
+
+sub _verify_att {
+ my($att) = @_;
+
+ while( my($key, $val) = each %$att ) {
+ my $sig = $Att_Sigs{$key};
+ unless( defined $sig ) {
+ warn "WARNING: $key is not a known parameter.\n";
+ next;
+ }
+
+ my @sigs = ref $sig ? @$sig : $sig;
+ my $given = ref $val;
+ unless( grep { _is_of_type($val, $_) } @sigs ) {
+ my $takes = join " or ", map { _format_att($_) } @sigs;
+
+ my $has = _format_att($given);
+ warn "WARNING: $key takes a $takes not a $has.\n".
+ " Please inform the author.\n";
+ }
+ }
+}
+
+
+# Check if a given thing is a reference or instance of $type
+sub _is_of_type {
+ my($thing, $type) = @_;
+
+ return 1 if ref $thing eq $type;
+
+ local $SIG{__DIE__};
+ return 1 if eval{ $thing->isa($type) };
+
+ return 0;
+}
+
+
+sub _format_att {
+ my $given = shift;
+
+ return $given eq '' ? "string/number"
+ : uc $given eq $given ? "$given reference"
+ : "$given object"
+ ;
+}
+
+
+sub prompt ($;$) { ## no critic
+ my($mess, $def) = @_;
+ Carp::confess("prompt function called without an argument")
+ unless defined $mess;
+
+ my $isa_tty = -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT)) ;
+
+ my $dispdef = defined $def ? "[$def] " : " ";
+ $def = defined $def ? $def : "";
+
+ local $|=1;
+ local $\;
+ print "$mess $dispdef";
+
+ my $ans;
+ if ($ENV{PERL_MM_USE_DEFAULT} || (!$isa_tty && eof STDIN)) {
+ print "$def\n";
+ }
+ else {
+ $ans = <STDIN>;
+ if( defined $ans ) {
+ chomp $ans;
+ }
+ else { # user hit ctrl-D
+ print "\n";
+ }
+ }
+
+ return (!defined $ans || $ans eq '') ? $def : $ans;
+}
+
+sub eval_in_subdirs {
+ my($self) = @_;
+ use Cwd qw(cwd abs_path);
+ my $pwd = cwd() || die "Can't figure out your cwd!";
+
+ local @INC = map eval {abs_path($_) if -e} || $_, @INC;
+ push @INC, '.'; # '.' has to always be at the end of @INC
+
+ foreach my $dir (@{$self->{DIR}}){
+ my($abs) = $self->catdir($pwd,$dir);
+ eval { $self->eval_in_x($abs); };
+ last if $@;
+ }
+ chdir $pwd;
+ die $@ if $@;
+}
+
+sub eval_in_x {
+ my($self,$dir) = @_;
+ chdir $dir or Carp::carp("Couldn't change to directory $dir: $!");
+
+ {
+ package main;
+ do './Makefile.PL';
+ };
+ if ($@) {
+# if ($@ =~ /prerequisites/) {
+# die "MakeMaker WARNING: $@";
+# } else {
+# warn "WARNING from evaluation of $dir/Makefile.PL: $@";
+# }
+ die "ERROR from evaluation of $dir/Makefile.PL: $@";
+ }
+}
+
+
+# package name for the classes into which the first object will be blessed
+my $PACKNAME = 'PACK000';
+
+sub full_setup {
+ $Verbose ||= 0;
+
+ my @attrib_help = qw/
+
+ AUTHOR ABSTRACT ABSTRACT_FROM BINARY_LOCATION
+ C CAPI CCFLAGS CONFIG CONFIGURE DEFINE DIR DISTNAME DISTVNAME
+ DL_FUNCS DL_VARS
+ EXCLUDE_EXT EXE_FILES FIRST_MAKEFILE
+ FULLPERL FULLPERLRUN FULLPERLRUNINST
+ FUNCLIST H IMPORTS
+
+ INST_ARCHLIB INST_SCRIPT INST_BIN INST_LIB INST_MAN1DIR INST_MAN3DIR
+ INSTALLDIRS
+ DESTDIR PREFIX INSTALL_BASE
+ PERLPREFIX SITEPREFIX VENDORPREFIX
+ INSTALLPRIVLIB INSTALLSITELIB INSTALLVENDORLIB
+ INSTALLARCHLIB INSTALLSITEARCH INSTALLVENDORARCH
+ INSTALLBIN INSTALLSITEBIN INSTALLVENDORBIN
+ INSTALLMAN1DIR INSTALLMAN3DIR
+ INSTALLSITEMAN1DIR INSTALLSITEMAN3DIR
+ INSTALLVENDORMAN1DIR INSTALLVENDORMAN3DIR
+ INSTALLSCRIPT INSTALLSITESCRIPT INSTALLVENDORSCRIPT
+ PERL_LIB PERL_ARCHLIB
+ SITELIBEXP SITEARCHEXP
+
+ INC INCLUDE_EXT LDFROM LIB LIBPERL_A LIBS LICENSE
+ LINKTYPE MAKE MAKEAPERL MAKEFILE MAKEFILE_OLD MAN1PODS MAN3PODS MAP_TARGET
+ META_ADD META_MERGE MIN_PERL_VERSION BUILD_REQUIRES CONFIGURE_REQUIRES
+ MYEXTLIB NAME NEEDS_LINKING NOECHO NO_META NORECURS NO_VC OBJECT OPTIMIZE
+ PERL_MALLOC_OK PERL PERLMAINCC PERLRUN PERLRUNINST PERL_CORE
+ PERL_SRC PERM_DIR PERM_RW PERM_RWX
+ PL_FILES PM PM_FILTER PMLIBDIRS PMLIBPARENTDIRS POLLUTE PPM_INSTALL_EXEC
+ PPM_INSTALL_SCRIPT PREREQ_FATAL PREREQ_PM PREREQ_PRINT PRINT_PREREQ
+ SIGN SKIP TYPEMAPS VERSION VERSION_FROM XS XSOPT XSPROTOARG
+ XS_VERSION clean depend dist dynamic_lib linkext macro realclean
+ tool_autosplit
+
+ MACPERL_SRC MACPERL_LIB MACLIBS_68K MACLIBS_PPC MACLIBS_SC MACLIBS_MRC
+ MACLIBS_ALL_68K MACLIBS_ALL_PPC MACLIBS_SHARED
+ /;
+
+ # IMPORTS is used under OS/2 and Win32
+
+ # @Overridable is close to @MM_Sections but not identical. The
+ # order is important. Many subroutines declare macros. These
+ # depend on each other. Let's try to collect the macros up front,
+ # then pasthru, then the rules.
+
+ # MM_Sections are the sections we have to call explicitly
+ # in Overridable we have subroutines that are used indirectly
+
+
+ @MM_Sections =
+ qw(
+
+ post_initialize const_config constants platform_constants
+ tool_autosplit tool_xsubpp tools_other
+
+ makemakerdflt
+
+ dist macro depend cflags const_loadlibs const_cccmd
+ post_constants
+
+ pasthru
+
+ special_targets
+ c_o xs_c xs_o
+ top_targets blibdirs linkext dlsyms dynamic dynamic_bs
+ dynamic_lib static static_lib manifypods processPL
+ installbin subdirs
+ clean_subdirs clean realclean_subdirs realclean
+ metafile signature
+ dist_basics dist_core distdir dist_test dist_ci distmeta distsignature
+ install force perldepend makefile staticmake test ppd
+
+ ); # loses section ordering
+
+ @Overridable = @MM_Sections;
+ push @Overridable, qw[
+
+ libscan makeaperl needs_linking
+ subdir_x test_via_harness test_via_script
+
+ init_VERSION init_dist init_INST init_INSTALL init_DEST init_dirscan
+ init_PM init_MANPODS init_xs init_PERL init_DIRFILESEP init_linker
+ ];
+
+ push @MM_Sections, qw[
+
+ pm_to_blib selfdocument
+
+ ];
+
+ # Postamble needs to be the last that was always the case
+ push @MM_Sections, "postamble";
+ push @Overridable, "postamble";
+
+ # All sections are valid keys.
+ @Recognized_Att_Keys{@MM_Sections} = (1) x @MM_Sections;
+
+ # we will use all these variables in the Makefile
+ @Get_from_Config =
+ qw(
+ ar cc cccdlflags ccdlflags dlext dlsrc exe_ext full_ar ld
+ lddlflags ldflags libc lib_ext obj_ext osname osvers ranlib
+ sitelibexp sitearchexp so
+ );
+
+ # 5.5.3 doesn't have any concept of vendor libs
+ push @Get_from_Config, qw( vendorarchexp vendorlibexp ) if $] >= 5.006;
+
+ foreach my $item (@attrib_help){
+ $Recognized_Att_Keys{$item} = 1;
+ }
+ foreach my $item (@Get_from_Config) {
+ $Recognized_Att_Keys{uc $item} = $Config{$item};
+ print "Attribute '\U$item\E' => '$Config{$item}'\n"
+ if ($Verbose >= 2);
+ }
+
+ #
+ # When we eval a Makefile.PL in a subdirectory, that one will ask
+ # us (the parent) for the values and will prepend "..", so that
+ # all files to be installed end up below OUR ./blib
+ #
+ @Prepend_parent = qw(
+ INST_BIN INST_LIB INST_ARCHLIB INST_SCRIPT
+ MAP_TARGET INST_MAN1DIR INST_MAN3DIR PERL_SRC
+ PERL FULLPERL
+ );
+}
+
+sub writeMakefile {
+ die <<END;
+
+The extension you are trying to build apparently is rather old and
+most probably outdated. We detect that from the fact, that a
+subroutine "writeMakefile" is called, and this subroutine is not
+supported anymore since about October 1994.
+
+Please contact the author or look into CPAN (details about CPAN can be
+found in the FAQ and at http:/www.perl.com) for a more recent version
+of the extension. If you're really desperate, you can try to change
+the subroutine name from writeMakefile to WriteMakefile and rerun
+'perl Makefile.PL', but you're most probably left alone, when you do
+so.
+
+The MakeMaker team
+
+END
+}
+
+sub new {
+ my($class,$self) = @_;
+ my($key);
+
+ # Store the original args passed to WriteMakefile()
+ foreach my $k (keys %$self) {
+ $self->{ARGS}{$k} = $self->{$k};
+ }
+
+ $self = {} unless defined $self;
+
+ $self->{PREREQ_PM} ||= {};
+ $self->{BUILD_REQUIRES} ||= {};
+
+ # Temporarily bless it into MM so it can be used as an
+ # object. It will be blessed into a temp package later.
+ bless $self, "MM";
+
+ if ("@ARGV" =~ /\bPREREQ_PRINT\b/) {
+ $self->_PREREQ_PRINT;
+ }
+
+ # PRINT_PREREQ is RedHatism.
+ if ("@ARGV" =~ /\bPRINT_PREREQ\b/) {
+ $self->_PRINT_PREREQ;
+ }
+
+ print STDOUT "MakeMaker (v$VERSION)\n" if $Verbose;
+ if (-f "MANIFEST" && ! -f "Makefile"){
+ check_manifest();
+ }
+
+ check_hints($self);
+
+ # Translate X.Y.Z to X.00Y00Z
+ if( defined $self->{MIN_PERL_VERSION} ) {
+ $self->{MIN_PERL_VERSION} =~ s{ ^ (\d+) \. (\d+) \. (\d+) $ }
+ {sprintf "%d.%03d%03d", $1, $2, $3}ex;
+ }
+
+ my $perl_version_ok = eval {
+ local $SIG{__WARN__} = sub {
+ # simulate "use warnings FATAL => 'all'" for vintage perls
+ die @_;
+ };
+ !$self->{MIN_PERL_VERSION} or $self->{MIN_PERL_VERSION} <= $]
+ };
+ if (!$perl_version_ok) {
+ if (!defined $perl_version_ok) {
+ warn <<'END';
+Warning: MIN_PERL_VERSION is not in a recognized format.
+Recommended is a quoted numerical value like '5.005' or '5.008001'.
+END
+ }
+ elsif ($self->{PREREQ_FATAL}) {
+ die sprintf <<"END", $self->{MIN_PERL_VERSION}, $];
+MakeMaker FATAL: perl version too low for this distribution.
+Required is %s. We run %s.
+END
+ }
+ else {
+ warn sprintf
+ "Warning: Perl version %s or higher required. We run %s.\n",
+ $self->{MIN_PERL_VERSION}, $];
+ }
+ }
+
+ my %configure_att; # record &{$self->{CONFIGURE}} attributes
+ my(%initial_att) = %$self; # record initial attributes
+
+ my(%unsatisfied) = ();
+ my $prereqs = $self->_all_prereqs;
+ foreach my $prereq (sort keys %$prereqs) {
+ my $required_version = $prereqs->{$prereq};
+
+ my $installed_file = MM->_installed_file_for_module($prereq);
+ my $pr_version = 0;
+ $pr_version = MM->parse_version($installed_file) if $installed_file;
+ $pr_version = 0 if $pr_version eq 'undef';
+
+ # convert X.Y_Z alpha version #s to X.YZ for easier comparisons
+ $pr_version =~ s/(\d+)\.(\d+)_(\d+)/$1.$2$3/;
+
+ if (!$installed_file) {
+ warn sprintf "Warning: prerequisite %s %s not found.\n",
+ $prereq, $required_version
+ unless $self->{PREREQ_FATAL};
+
+ $unsatisfied{$prereq} = 'not installed';
+ }
+ elsif ($pr_version < $required_version ){
+ warn sprintf "Warning: prerequisite %s %s not found. We have %s.\n",
+ $prereq, $required_version, ($pr_version || 'unknown version')
+ unless $self->{PREREQ_FATAL};
+
+ $unsatisfied{$prereq} = $required_version ? $required_version : 'unknown version' ;
+ }
+ }
+
+ if (%unsatisfied && $self->{PREREQ_FATAL}){
+ my $failedprereqs = join "\n", map {" $_ $unsatisfied{$_}"}
+ sort { $a cmp $b } keys %unsatisfied;
+ die <<"END";
+MakeMaker FATAL: prerequisites not found.
+$failedprereqs
+
+Please install these modules first and rerun 'perl Makefile.PL'.
+END
+ }
+
+ if (defined $self->{CONFIGURE}) {
+ if (ref $self->{CONFIGURE} eq 'CODE') {
+ %configure_att = %{&{$self->{CONFIGURE}}};
+ $self = { %$self, %configure_att };
+ } else {
+ Carp::croak "Attribute 'CONFIGURE' to WriteMakefile() not a code reference\n";
+ }
+ }
+
+ # This is for old Makefiles written pre 5.00, will go away
+ if ( Carp::longmess("") =~ /runsubdirpl/s ){
+ Carp::carp("WARNING: Please rerun 'perl Makefile.PL' to regenerate your Makefiles\n");
+ }
+
+ my $newclass = ++$PACKNAME;
+ local @Parent = @Parent; # Protect against non-local exits
+ {
+ print "Blessing Object into class [$newclass]\n" if $Verbose>=2;
+ mv_all_methods("MY",$newclass);
+ bless $self, $newclass;
+ push @Parent, $self;
+ require ExtUtils::MY;
+
+ no strict 'refs'; ## no critic;
+ @{"$newclass\:\:ISA"} = 'MM';
+ }
+
+ if (defined $Parent[-2]){
+ $self->{PARENT} = $Parent[-2];
+ for my $key (@Prepend_parent) {
+ next unless defined $self->{PARENT}{$key};
+
+ # Don't stomp on WriteMakefile() args.
+ next if defined $self->{ARGS}{$key} and
+ $self->{ARGS}{$key} eq $self->{$key};
+
+ $self->{$key} = $self->{PARENT}{$key};
+
+ unless ($Is_VMS && $key =~ /PERL$/) {
+ $self->{$key} = $self->catdir("..",$self->{$key})
+ unless $self->file_name_is_absolute($self->{$key});
+ } else {
+ # PERL or FULLPERL will be a command verb or even a
+ # command with an argument instead of a full file
+ # specification under VMS. So, don't turn the command
+ # into a filespec, but do add a level to the path of
+ # the argument if not already absolute.
+ my @cmd = split /\s+/, $self->{$key};
+ $cmd[1] = $self->catfile('[-]',$cmd[1])
+ unless (@cmd < 2) || $self->file_name_is_absolute($cmd[1]);
+ $self->{$key} = join(' ', @cmd);
+ }
+ }
+ if ($self->{PARENT}) {
+ $self->{PARENT}->{CHILDREN}->{$newclass} = $self;
+ foreach my $opt (qw(POLLUTE PERL_CORE LINKTYPE)) {
+ if (exists $self->{PARENT}->{$opt}
+ and not exists $self->{$opt})
+ {
+ # inherit, but only if already unspecified
+ $self->{$opt} = $self->{PARENT}->{$opt};
+ }
+ }
+ }
+ my @fm = grep /^FIRST_MAKEFILE=/, @ARGV;
+ parse_args($self, at fm) if @fm;
+ } else {
+ parse_args($self,split(' ', $ENV{PERL_MM_OPT} || ''), at ARGV);
+ }
+
+
+ $self->{NAME} ||= $self->guess_name;
+
+ ($self->{NAME_SYM} = $self->{NAME}) =~ s/\W+/_/g;
+
+ $self->init_MAKE;
+ $self->init_main;
+ $self->init_VERSION;
+ $self->init_dist;
+ $self->init_INST;
+ $self->init_INSTALL;
+ $self->init_DEST;
+ $self->init_dirscan;
+ $self->init_PM;
+ $self->init_MANPODS;
+ $self->init_xs;
+ $self->init_PERL;
+ $self->init_DIRFILESEP;
+ $self->init_linker;
+ $self->init_ABSTRACT;
+
+ $self->arch_check(
+ $INC{'Config.pm'},
+ $self->catfile($Config{'archlibexp'}, "Config.pm")
+ );
+
+ $self->init_others();
+ $self->init_platform();
+ $self->init_PERM();
+ my($argv) = neatvalue(\@ARGV);
+ $argv =~ s/^\[/(/;
+ $argv =~ s/\]$/)/;
+
+ push @{$self->{RESULT}}, <<END;
+# This Makefile is for the $self->{NAME} extension to perl.
+#
+# It was generated automatically by MakeMaker version
+# $VERSION (Revision: $Revision) from the contents of
+# Makefile.PL. Don't edit this file, edit Makefile.PL instead.
+#
+# ANY CHANGES MADE HERE WILL BE LOST!
+#
+# MakeMaker ARGV: $argv
+#
+END
+
+ push @{$self->{RESULT}}, $self->_MakeMaker_Parameters_section(\%initial_att);
+
+ if (defined $self->{CONFIGURE}) {
+ push @{$self->{RESULT}}, <<END;
+
+# MakeMaker 'CONFIGURE' Parameters:
+END
+ if (scalar(keys %configure_att) > 0) {
+ foreach my $key (sort keys %configure_att){
+ next if $key eq 'ARGS';
+ my($v) = neatvalue($configure_att{$key});
+ $v =~ s/(CODE|HASH|ARRAY|SCALAR)\([\dxa-f]+\)/$1\(...\)/;
+ $v =~ tr/\n/ /s;
+ push @{$self->{RESULT}}, "# $key => $v";
+ }
+ }
+ else
+ {
+ push @{$self->{RESULT}}, "# no values returned";
+ }
+ undef %configure_att; # free memory
+ }
+
+ # turn the SKIP array into a SKIPHASH hash
+ for my $skip (@{$self->{SKIP} || []}) {
+ $self->{SKIPHASH}{$skip} = 1;
+ }
+ delete $self->{SKIP}; # free memory
+
+ if ($self->{PARENT}) {
+ for (qw/install dist dist_basics dist_core distdir dist_test dist_ci/) {
+ $self->{SKIPHASH}{$_} = 1;
+ }
+ }
+
+ # We run all the subdirectories now. They don't have much to query
+ # from the parent, but the parent has to query them: if they need linking!
+ unless ($self->{NORECURS}) {
+ $self->eval_in_subdirs if @{$self->{DIR}};
+ }
+
+ foreach my $section ( @MM_Sections ){
+ # Support for new foo_target() methods.
+ my $method = $section;
+ $method .= '_target' unless $self->can($method);
+
+ print "Processing Makefile '$section' section\n" if ($Verbose >= 2);
+ my($skipit) = $self->skipcheck($section);
+ if ($skipit){
+ push @{$self->{RESULT}}, "\n# --- MakeMaker $section section $skipit.";
+ } else {
+ my(%a) = %{$self->{$section} || {}};
+ push @{$self->{RESULT}}, "\n# --- MakeMaker $section section:";
+ push @{$self->{RESULT}}, "# " . join ", ", %a if $Verbose && %a;
+ push @{$self->{RESULT}}, $self->maketext_filter(
+ $self->$method( %a )
+ );
+ }
+ }
+
+ push @{$self->{RESULT}}, "\n# End.";
+
+ $self;
+}
+
+sub WriteEmptyMakefile {
+ Carp::croak "WriteEmptyMakefile: Need an even number of args" if @_ % 2;
+
+ my %att = @_;
+ my $self = MM->new(\%att);
+
+ my $new = $self->{MAKEFILE};
+ my $old = $self->{MAKEFILE_OLD};
+ if (-f $old) {
+ _unlink($old) or warn "unlink $old: $!";
+ }
+ if ( -f $new ) {
+ _rename($new, $old) or warn "rename $new => $old: $!"
+ }
+ open my $mfh, '>', $new or die "open $new for write: $!";
+ print $mfh <<'EOP';
+all :
+
+clean :
+
+install :
+
+makemakerdflt :
+
+test :
+
+EOP
+ close $mfh or die "close $new for write: $!";
+}
+
+
+=begin private
+
+=head3 _installed_file_for_module
+
+ my $file = MM->_installed_file_for_module($module);
+
+Return the first installed .pm $file associated with the $module. The
+one which will show up when you C<use $module>.
+
+$module is something like "strict" or "Test::More".
+
+=end private
+
+=cut
+
+sub _installed_file_for_module {
+ my $class = shift;
+ my $prereq = shift;
+
+ my $file = "$prereq.pm";
+ $file =~ s{::}{/}g;
+
+ my $path;
+ for my $dir (@INC) {
+ my $tmp = File::Spec->catfile($dir, $file);
+ if ( -r $tmp ) {
+ $path = $tmp;
+ last;
+ }
+ }
+
+ return $path;
+}
+
+
+# Extracted from MakeMaker->new so we can test it
+sub _MakeMaker_Parameters_section {
+ my $self = shift;
+ my $att = shift;
+
+ my @result = <<'END';
+# MakeMaker Parameters:
+END
+
+ # CPAN.pm takes prereqs from this field in 'Makefile'
+ # and does not know about BUILD_REQUIRES
+ if( $att->{PREREQ_PM} || $att->{BUILD_REQUIRES} ) {
+ %{$att->{'PREREQ_PM'}} = (%{$att->{'PREREQ_PM'}||{}}, %{$att->{'BUILD_REQUIRES'}||{}});
+ }
+
+ foreach my $key (sort keys %$att){
+ next if $key eq 'ARGS';
+
+ my($v) = neatvalue($att->{$key});
+ $v =~ s/(CODE|HASH|ARRAY|SCALAR)\([\dxa-f]+\)/$1\(...\)/;
+ $v =~ tr/\n/ /s;
+ push @result, "# $key => $v";
+ }
+
+ return @result;
+}
+
+
+sub check_manifest {
+ print STDOUT "Checking if your kit is complete...\n";
+ require ExtUtils::Manifest;
+ # avoid warning
+ $ExtUtils::Manifest::Quiet = $ExtUtils::Manifest::Quiet = 1;
+ my(@missed) = ExtUtils::Manifest::manicheck();
+ if (@missed) {
+ print STDOUT "Warning: the following files are missing in your kit:\n";
+ print "\t", join "\n\t", @missed;
+ print STDOUT "\n";
+ print STDOUT "Please inform the author.\n";
+ } else {
+ print STDOUT "Looks good\n";
+ }
+}
+
+sub parse_args{
+ my($self, @args) = @_;
+ foreach (@args) {
+ unless (m/(.*?)=(.*)/) {
+ ++$Verbose if m/^verb/;
+ next;
+ }
+ my($name, $value) = ($1, $2);
+ if ($value =~ m/^~(\w+)?/) { # tilde with optional username
+ $value =~ s [^~(\w*)]
+ [$1 ?
+ ((getpwnam($1))[7] || "~$1") :
+ (getpwuid($>))[7]
+ ]ex;
+ }
+
+ # Remember the original args passed it. It will be useful later.
+ $self->{ARGS}{uc $name} = $self->{uc $name} = $value;
+ }
+
+ # catch old-style 'potential_libs' and inform user how to 'upgrade'
+ if (defined $self->{potential_libs}){
+ my($msg)="'potential_libs' => '$self->{potential_libs}' should be";
+ if ($self->{potential_libs}){
+ print STDOUT "$msg changed to:\n\t'LIBS' => ['$self->{potential_libs}']\n";
+ } else {
+ print STDOUT "$msg deleted.\n";
+ }
+ $self->{LIBS} = [$self->{potential_libs}];
+ delete $self->{potential_libs};
+ }
+ # catch old-style 'ARMAYBE' and inform user how to 'upgrade'
+ if (defined $self->{ARMAYBE}){
+ my($armaybe) = $self->{ARMAYBE};
+ print STDOUT "ARMAYBE => '$armaybe' should be changed to:\n",
+ "\t'dynamic_lib' => {ARMAYBE => '$armaybe'}\n";
+ my(%dl) = %{$self->{dynamic_lib} || {}};
+ $self->{dynamic_lib} = { %dl, ARMAYBE => $armaybe};
+ delete $self->{ARMAYBE};
+ }
+ if (defined $self->{LDTARGET}){
+ print STDOUT "LDTARGET should be changed to LDFROM\n";
+ $self->{LDFROM} = $self->{LDTARGET};
+ delete $self->{LDTARGET};
+ }
+ # Turn a DIR argument on the command line into an array
+ if (defined $self->{DIR} && ref \$self->{DIR} eq 'SCALAR') {
+ # So they can choose from the command line, which extensions they want
+ # the grep enables them to have some colons too much in case they
+ # have to build a list with the shell
+ $self->{DIR} = [grep $_, split ":", $self->{DIR}];
+ }
+ # Turn a INCLUDE_EXT argument on the command line into an array
+ if (defined $self->{INCLUDE_EXT} && ref \$self->{INCLUDE_EXT} eq 'SCALAR') {
+ $self->{INCLUDE_EXT} = [grep $_, split '\s+', $self->{INCLUDE_EXT}];
+ }
+ # Turn a EXCLUDE_EXT argument on the command line into an array
+ if (defined $self->{EXCLUDE_EXT} && ref \$self->{EXCLUDE_EXT} eq 'SCALAR') {
+ $self->{EXCLUDE_EXT} = [grep $_, split '\s+', $self->{EXCLUDE_EXT}];
+ }
+
+ foreach my $mmkey (sort keys %$self){
+ next if $mmkey eq 'ARGS';
+ print STDOUT " $mmkey => ", neatvalue($self->{$mmkey}), "\n" if $Verbose;
+ print STDOUT "'$mmkey' is not a known MakeMaker parameter name.\n"
+ unless exists $Recognized_Att_Keys{$mmkey};
+ }
+ $| = 1 if $Verbose;
+}
+
+sub check_hints {
+ my($self) = @_;
+ # We allow extension-specific hints files.
+
+ require File::Spec;
+ my $curdir = File::Spec->curdir;
+
+ my $hint_dir = File::Spec->catdir($curdir, "hints");
+ return unless -d $hint_dir;
+
+ # First we look for the best hintsfile we have
+ my($hint)="${^O}_$Config{osvers}";
+ $hint =~ s/\./_/g;
+ $hint =~ s/_$//;
+ return unless $hint;
+
+ # Also try without trailing minor version numbers.
+ while (1) {
+ last if -f File::Spec->catfile($hint_dir, "$hint.pl"); # found
+ } continue {
+ last unless $hint =~ s/_[^_]*$//; # nothing to cut off
+ }
+ my $hint_file = File::Spec->catfile($hint_dir, "$hint.pl");
+
+ return unless -f $hint_file; # really there
+
+ _run_hintfile($self, $hint_file);
+}
+
+sub _run_hintfile {
+ our $self;
+ local($self) = shift; # make $self available to the hint file.
+ my($hint_file) = shift;
+
+ local($@, $!);
+ print STDERR "Processing hints file $hint_file\n";
+
+ # Just in case the ./ isn't on the hint file, which File::Spec can
+ # often strip off, we bung the curdir into @INC
+ local @INC = (File::Spec->curdir, @INC);
+ my $ret = do $hint_file;
+ if( !defined $ret ) {
+ my $error = $@ || $!;
+ print STDERR $error;
+ }
+}
+
+sub mv_all_methods {
+ my($from,$to) = @_;
+
+ # Here you see the *current* list of methods that are overridable
+ # from Makefile.PL via MY:: subroutines. As of VERSION 5.07 I'm
+ # still trying to reduce the list to some reasonable minimum --
+ # because I want to make it easier for the user. A.K.
+
+ local $SIG{__WARN__} = sub {
+ # can't use 'no warnings redefined', 5.6 only
+ warn @_ unless $_[0] =~ /^Subroutine .* redefined/
+ };
+ foreach my $method (@Overridable) {
+
+ # We cannot say "next" here. Nick might call MY->makeaperl
+ # which isn't defined right now
+
+ # Above statement was written at 4.23 time when Tk-b8 was
+ # around. As Tk-b9 only builds with 5.002something and MM 5 is
+ # standard, we try to enable the next line again. It was
+ # commented out until MM 5.23
+
+ next unless defined &{"${from}::$method"};
+
+ {
+ no strict 'refs'; ## no critic
+ *{"${to}::$method"} = \&{"${from}::$method"};
+
+ # If we delete a method, then it will be undefined and cannot
+ # be called. But as long as we have Makefile.PLs that rely on
+ # %MY:: being intact, we have to fill the hole with an
+ # inheriting method:
+
+ {
+ package MY;
+ my $super = "SUPER::".$method;
+ *{$method} = sub {
+ shift->$super(@_);
+ };
+ }
+ }
+ }
+
+ # We have to clean out %INC also, because the current directory is
+ # changed frequently and Graham Barr prefers to get his version
+ # out of a History.pl file which is "required" so woudn't get
+ # loaded again in another extension requiring a History.pl
+
+ # With perl5.002_01 the deletion of entries in %INC caused Tk-b11
+ # to core dump in the middle of a require statement. The required
+ # file was Tk/MMutil.pm. The consequence is, we have to be
+ # extremely careful when we try to give perl a reason to reload a
+ # library with same name. The workaround prefers to drop nothing
+ # from %INC and teach the writers not to use such libraries.
+
+# my $inc;
+# foreach $inc (keys %INC) {
+# #warn "***$inc*** deleted";
+# delete $INC{$inc};
+# }
+}
+
+sub skipcheck {
+ my($self) = shift;
+ my($section) = @_;
+ if ($section eq 'dynamic') {
+ print STDOUT "Warning (non-fatal): Target 'dynamic' depends on targets ",
+ "in skipped section 'dynamic_bs'\n"
+ if $self->{SKIPHASH}{dynamic_bs} && $Verbose;
+ print STDOUT "Warning (non-fatal): Target 'dynamic' depends on targets ",
+ "in skipped section 'dynamic_lib'\n"
+ if $self->{SKIPHASH}{dynamic_lib} && $Verbose;
+ }
+ if ($section eq 'dynamic_lib') {
+ print STDOUT "Warning (non-fatal): Target '\$(INST_DYNAMIC)' depends on ",
+ "targets in skipped section 'dynamic_bs'\n"
+ if $self->{SKIPHASH}{dynamic_bs} && $Verbose;
+ }
+ if ($section eq 'static') {
+ print STDOUT "Warning (non-fatal): Target 'static' depends on targets ",
+ "in skipped section 'static_lib'\n"
+ if $self->{SKIPHASH}{static_lib} && $Verbose;
+ }
+ return 'skipped' if $self->{SKIPHASH}{$section};
+ return '';
+}
+
+sub flush {
+ my $self = shift;
+
+ my $finalname = $self->{MAKEFILE};
+ print STDOUT "Writing $finalname for $self->{NAME}\n";
+
+ unlink($finalname, "MakeMaker.tmp", $Is_VMS ? 'Descrip.MMS' : ());
+ open(my $fh,">", "MakeMaker.tmp")
+ or die "Unable to open MakeMaker.tmp: $!";
+
+ for my $chunk (@{$self->{RESULT}}) {
+ print $fh "$chunk\n";
+ }
+
+ close $fh;
+ _rename("MakeMaker.tmp", $finalname) or
+ warn "rename MakeMaker.tmp => $finalname: $!";
+ chmod 0644, $finalname unless $Is_VMS;
+
+ my %keep = map { ($_ => 1) } qw(NEEDS_LINKING HAS_LINK_CODE);
+
+ if ($self->{PARENT} && !$self->{_KEEP_AFTER_FLUSH}) {
+ foreach (keys %$self) { # safe memory
+ delete $self->{$_} unless $keep{$_};
+ }
+ }
+
+ system("$Config::Config{eunicefix} $finalname") unless $Config::Config{eunicefix} eq ":";
+}
+
+
+# This is a rename for OS's where the target must be unlinked first.
+sub _rename {
+ my($src, $dest) = @_;
+ chmod 0666, $dest;
+ unlink $dest;
+ return rename $src, $dest;
+}
+
+# This is an unlink for OS's where the target must be writable first.
+sub _unlink {
+ my @files = @_;
+ chmod 0666, @files;
+ return unlink @files;
+}
+
+
+# The following mkbootstrap() is only for installations that are calling
+# the pre-4.1 mkbootstrap() from their old Makefiles. This MakeMaker
+# writes Makefiles, that use ExtUtils::Mkbootstrap directly.
+sub mkbootstrap {
+ die <<END;
+!!! Your Makefile has been built such a long time ago, !!!
+!!! that is unlikely to work with current MakeMaker. !!!
+!!! Please rebuild your Makefile !!!
+END
+}
+
+# Ditto for mksymlists() as of MakeMaker 5.17
+sub mksymlists {
+ die <<END;
+!!! Your Makefile has been built such a long time ago, !!!
+!!! that is unlikely to work with current MakeMaker. !!!
+!!! Please rebuild your Makefile !!!
+END
+}
+
+sub neatvalue {
+ my($v) = @_;
+ return "undef" unless defined $v;
+ my($t) = ref $v;
+ return "q[$v]" unless $t;
+ if ($t eq 'ARRAY') {
+ my(@m, @neat);
+ push @m, "[";
+ foreach my $elem (@$v) {
+ push @neat, "q[$elem]";
+ }
+ push @m, join ", ", @neat;
+ push @m, "]";
+ return join "", @m;
+ }
+ return "$v" unless $t eq 'HASH';
+ my(@m, $key, $val);
+ while (($key,$val) = each %$v){
+ last unless defined $key; # cautious programming in case (undef,undef) is true
+ push(@m,"$key=>".neatvalue($val)) ;
+ }
+ return "{ ".join(', ', at m)." }";
+}
+
+sub selfdocument {
+ my($self) = @_;
+ my(@m);
+ if ($Verbose){
+ push @m, "\n# Full list of MakeMaker attribute values:";
+ foreach my $key (sort keys %$self){
+ next if $key eq 'RESULT' || $key =~ /^[A-Z][a-z]/;
+ my($v) = neatvalue($self->{$key});
+ $v =~ s/(CODE|HASH|ARRAY|SCALAR)\([\dxa-f]+\)/$1\(...\)/;
+ $v =~ tr/\n/ /s;
+ push @m, "# $key => $v";
+ }
+ }
+ join "\n", @m;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+ExtUtils::MakeMaker - Create a module Makefile
+
+=head1 SYNOPSIS
+
+ use ExtUtils::MakeMaker;
+
+ WriteMakefile( ATTRIBUTE => VALUE [, ...] );
+
+=head1 DESCRIPTION
+
+This utility is designed to write a Makefile for an extension module
+from a Makefile.PL. It is based on the Makefile.SH model provided by
+Andy Dougherty and the perl5-porters.
+
+It splits the task of generating the Makefile into several subroutines
+that can be individually overridden. Each subroutine returns the text
+it wishes to have written to the Makefile.
+
+MakeMaker is object oriented. Each directory below the current
+directory that contains a Makefile.PL is treated as a separate
+object. This makes it possible to write an unlimited number of
+Makefiles with a single invocation of WriteMakefile().
+
+=head2 How To Write A Makefile.PL
+
+See ExtUtils::MakeMaker::Tutorial.
+
+The long answer is the rest of the manpage :-)
+
+=head2 Default Makefile Behaviour
+
+The generated Makefile enables the user of the extension to invoke
+
+ perl Makefile.PL # optionally "perl Makefile.PL verbose"
+ make
+ make test # optionally set TEST_VERBOSE=1
+ make install # See below
+
+The Makefile to be produced may be altered by adding arguments of the
+form C<KEY=VALUE>. E.g.
+
+ perl Makefile.PL INSTALL_BASE=~
+
+Other interesting targets in the generated Makefile are
+
+ make config # to check if the Makefile is up-to-date
+ make clean # delete local temp files (Makefile gets renamed)
+ make realclean # delete derived files (including ./blib)
+ make ci # check in all the files in the MANIFEST file
+ make dist # see below the Distribution Support section
+
+=head2 make test
+
+MakeMaker checks for the existence of a file named F<test.pl> in the
+current directory and if it exists it execute the script with the
+proper set of perl C<-I> options.
+
+MakeMaker also checks for any files matching glob("t/*.t"). It will
+execute all matching files in alphabetical order via the
+L<Test::Harness> module with the C<-I> switches set correctly.
+
+If you'd like to see the raw output of your tests, set the
+C<TEST_VERBOSE> variable to true.
+
+ make test TEST_VERBOSE=1
+
+=head2 make testdb
+
+A useful variation of the above is the target C<testdb>. It runs the
+test under the Perl debugger (see L<perldebug>). If the file
+F<test.pl> exists in the current directory, it is used for the test.
+
+If you want to debug some other testfile, set the C<TEST_FILE> variable
+thusly:
+
+ make testdb TEST_FILE=t/mytest.t
+
+By default the debugger is called using C<-d> option to perl. If you
+want to specify some other option, set the C<TESTDB_SW> variable:
+
+ make testdb TESTDB_SW=-Dx
+
+=head2 make install
+
+make alone puts all relevant files into directories that are named by
+the macros INST_LIB, INST_ARCHLIB, INST_SCRIPT, INST_MAN1DIR and
+INST_MAN3DIR. All these default to something below ./blib if you are
+I<not> building below the perl source directory. If you I<are>
+building below the perl source, INST_LIB and INST_ARCHLIB default to
+../../lib, and INST_SCRIPT is not defined.
+
+The I<install> target of the generated Makefile copies the files found
+below each of the INST_* directories to their INSTALL*
+counterparts. Which counterparts are chosen depends on the setting of
+INSTALLDIRS according to the following table:
+
+ INSTALLDIRS set to
+ perl site vendor
+
+ PERLPREFIX SITEPREFIX VENDORPREFIX
+ INST_ARCHLIB INSTALLARCHLIB INSTALLSITEARCH INSTALLVENDORARCH
+ INST_LIB INSTALLPRIVLIB INSTALLSITELIB INSTALLVENDORLIB
+ INST_BIN INSTALLBIN INSTALLSITEBIN INSTALLVENDORBIN
+ INST_SCRIPT INSTALLSCRIPT INSTALLSITESCRIPT INSTALLVENDORSCRIPT
+ INST_MAN1DIR INSTALLMAN1DIR INSTALLSITEMAN1DIR INSTALLVENDORMAN1DIR
+ INST_MAN3DIR INSTALLMAN3DIR INSTALLSITEMAN3DIR INSTALLVENDORMAN3DIR
+
+The INSTALL... macros in turn default to their %Config
+($Config{installprivlib}, $Config{installarchlib}, etc.) counterparts.
+
+You can check the values of these variables on your system with
+
+ perl '-V:install.*'
+
+And to check the sequence in which the library directories are
+searched by perl, run
+
+ perl -le 'print join $/, @INC'
+
+Sometimes older versions of the module you're installing live in other
+directories in @INC. Because Perl loads the first version of a module it
+finds, not the newest, you might accidentally get one of these older
+versions even after installing a brand new version. To delete I<all other
+versions of the module you're installing> (not simply older ones) set the
+C<UNINST> variable.
+
+ make install UNINST=1
+
+
+=head2 INSTALL_BASE
+
+INSTALL_BASE can be passed into Makefile.PL to change where your
+module will be installed. INSTALL_BASE is more like what everyone
+else calls "prefix" than PREFIX is.
+
+To have everything installed in your home directory, do the following.
+
+ # Unix users, INSTALL_BASE=~ works fine
+ perl Makefile.PL INSTALL_BASE=/path/to/your/home/dir
+
+Like PREFIX, it sets several INSTALL* attributes at once. Unlike
+PREFIX it is easy to predict where the module will end up. The
+installation pattern looks like this:
+
+ INSTALLARCHLIB INSTALL_BASE/lib/perl5/$Config{archname}
+ INSTALLPRIVLIB INSTALL_BASE/lib/perl5
+ INSTALLBIN INSTALL_BASE/bin
+ INSTALLSCRIPT INSTALL_BASE/bin
+ INSTALLMAN1DIR INSTALL_BASE/man/man1
+ INSTALLMAN3DIR INSTALL_BASE/man/man3
+
+INSTALL_BASE in MakeMaker and C<--install_base> in Module::Build (as
+of 0.28) install to the same location. If you want MakeMaker and
+Module::Build to install to the same location simply set INSTALL_BASE
+and C<--install_base> to the same location.
+
+INSTALL_BASE was added in 6.31.
+
+
+=head2 PREFIX and LIB attribute
+
+PREFIX and LIB can be used to set several INSTALL* attributes in one
+go. Here's an example for installing into your home directory.
+
+ # Unix users, PREFIX=~ works fine
+ perl Makefile.PL PREFIX=/path/to/your/home/dir
+
+This will install all files in the module under your home directory,
+with man pages and libraries going into an appropriate place (usually
+~/man and ~/lib). How the exact location is determined is complicated
+and depends on how your Perl was configured. INSTALL_BASE works more
+like what other build systems call "prefix" than PREFIX and we
+recommend you use that instead.
+
+Another way to specify many INSTALL directories with a single
+parameter is LIB.
+
+ perl Makefile.PL LIB=~/lib
+
+This will install the module's architecture-independent files into
+~/lib, the architecture-dependent files into ~/lib/$archname.
+
+Note, that in both cases the tilde expansion is done by MakeMaker, not
+by perl by default, nor by make.
+
+Conflicts between parameters LIB, PREFIX and the various INSTALL*
+arguments are resolved so that:
+
+=over 4
+
+=item *
+
+setting LIB overrides any setting of INSTALLPRIVLIB, INSTALLARCHLIB,
+INSTALLSITELIB, INSTALLSITEARCH (and they are not affected by PREFIX);
+
+=item *
+
+without LIB, setting PREFIX replaces the initial C<$Config{prefix}>
+part of those INSTALL* arguments, even if the latter are explicitly
+set (but are set to still start with C<$Config{prefix}>).
+
+=back
+
+If the user has superuser privileges, and is not working on AFS or
+relatives, then the defaults for INSTALLPRIVLIB, INSTALLARCHLIB,
+INSTALLSCRIPT, etc. will be appropriate, and this incantation will be
+the best:
+
+ perl Makefile.PL;
+ make;
+ make test
+ make install
+
+make install per default writes some documentation of what has been
+done into the file C<$(INSTALLARCHLIB)/perllocal.pod>. This feature
+can be bypassed by calling make pure_install.
+
+=head2 AFS users
+
+will have to specify the installation directories as these most
+probably have changed since perl itself has been installed. They will
+have to do this by calling
+
+ perl Makefile.PL INSTALLSITELIB=/afs/here/today \
+ INSTALLSCRIPT=/afs/there/now INSTALLMAN3DIR=/afs/for/manpages
+ make
+
+Be careful to repeat this procedure every time you recompile an
+extension, unless you are sure the AFS installation directories are
+still valid.
+
+=head2 Static Linking of a new Perl Binary
+
+An extension that is built with the above steps is ready to use on
+systems supporting dynamic loading. On systems that do not support
+dynamic loading, any newly created extension has to be linked together
+with the available resources. MakeMaker supports the linking process
+by creating appropriate targets in the Makefile whenever an extension
+is built. You can invoke the corresponding section of the makefile with
+
+ make perl
+
+That produces a new perl binary in the current directory with all
+extensions linked in that can be found in INST_ARCHLIB, SITELIBEXP,
+and PERL_ARCHLIB. To do that, MakeMaker writes a new Makefile, on
+UNIX, this is called Makefile.aperl (may be system dependent). If you
+want to force the creation of a new perl, it is recommended, that you
+delete this Makefile.aperl, so the directories are searched-through
+for linkable libraries again.
+
+The binary can be installed into the directory where perl normally
+resides on your machine with
+
+ make inst_perl
+
+To produce a perl binary with a different name than C<perl>, either say
+
+ perl Makefile.PL MAP_TARGET=myperl
+ make myperl
+ make inst_perl
+
+or say
+
+ perl Makefile.PL
+ make myperl MAP_TARGET=myperl
+ make inst_perl MAP_TARGET=myperl
+
+In any case you will be prompted with the correct invocation of the
+C<inst_perl> target that installs the new binary into INSTALLBIN.
+
+make inst_perl per default writes some documentation of what has been
+done into the file C<$(INSTALLARCHLIB)/perllocal.pod>. This
+can be bypassed by calling make pure_inst_perl.
+
+Warning: the inst_perl: target will most probably overwrite your
+existing perl binary. Use with care!
+
+Sometimes you might want to build a statically linked perl although
+your system supports dynamic loading. In this case you may explicitly
+set the linktype with the invocation of the Makefile.PL or make:
+
+ perl Makefile.PL LINKTYPE=static # recommended
+
+or
+
+ make LINKTYPE=static # works on most systems
+
+=head2 Determination of Perl Library and Installation Locations
+
+MakeMaker needs to know, or to guess, where certain things are
+located. Especially INST_LIB and INST_ARCHLIB (where to put the files
+during the make(1) run), PERL_LIB and PERL_ARCHLIB (where to read
+existing modules from), and PERL_INC (header files and C<libperl*.*>).
+
+Extensions may be built either using the contents of the perl source
+directory tree or from the installed perl library. The recommended way
+is to build extensions after you have run 'make install' on perl
+itself. You can do that in any directory on your hard disk that is not
+below the perl source tree. The support for extensions below the ext
+directory of the perl distribution is only good for the standard
+extensions that come with perl.
+
+If an extension is being built below the C<ext/> directory of the perl
+source then MakeMaker will set PERL_SRC automatically (e.g.,
+C<../..>). If PERL_SRC is defined and the extension is recognized as
+a standard extension, then other variables default to the following:
+
+ PERL_INC = PERL_SRC
+ PERL_LIB = PERL_SRC/lib
+ PERL_ARCHLIB = PERL_SRC/lib
+ INST_LIB = PERL_LIB
+ INST_ARCHLIB = PERL_ARCHLIB
+
+If an extension is being built away from the perl source then MakeMaker
+will leave PERL_SRC undefined and default to using the installed copy
+of the perl library. The other variables default to the following:
+
+ PERL_INC = $archlibexp/CORE
+ PERL_LIB = $privlibexp
+ PERL_ARCHLIB = $archlibexp
+ INST_LIB = ./blib/lib
+ INST_ARCHLIB = ./blib/arch
+
+If perl has not yet been installed then PERL_SRC can be defined on the
+command line as shown in the previous section.
+
+
+=head2 Which architecture dependent directory?
+
+If you don't want to keep the defaults for the INSTALL* macros,
+MakeMaker helps you to minimize the typing needed: the usual
+relationship between INSTALLPRIVLIB and INSTALLARCHLIB is determined
+by Configure at perl compilation time. MakeMaker supports the user who
+sets INSTALLPRIVLIB. If INSTALLPRIVLIB is set, but INSTALLARCHLIB not,
+then MakeMaker defaults the latter to be the same subdirectory of
+INSTALLPRIVLIB as Configure decided for the counterparts in %Config ,
+otherwise it defaults to INSTALLPRIVLIB. The same relationship holds
+for INSTALLSITELIB and INSTALLSITEARCH.
+
+MakeMaker gives you much more freedom than needed to configure
+internal variables and get different results. It is worth to mention,
+that make(1) also lets you configure most of the variables that are
+used in the Makefile. But in the majority of situations this will not
+be necessary, and should only be done if the author of a package
+recommends it (or you know what you're doing).
+
+=head2 Using Attributes and Parameters
+
+The following attributes may be specified as arguments to WriteMakefile()
+or as NAME=VALUE pairs on the command line.
+
+=over 2
+
+=item ABSTRACT
+
+One line description of the module. Will be included in PPD file.
+
+=item ABSTRACT_FROM
+
+Name of the file that contains the package description. MakeMaker looks
+for a line in the POD matching /^($package\s-\s)(.*)/. This is typically
+the first line in the "=head1 NAME" section. $2 becomes the abstract.
+
+=item AUTHOR
+
+String containing name (and email address) of package author(s). Is used
+in PPD (Perl Package Description) files for PPM (Perl Package Manager).
+
+=item BINARY_LOCATION
+
+Used when creating PPD files for binary packages. It can be set to a
+full or relative path or URL to the binary archive for a particular
+architecture. For example:
+
+ perl Makefile.PL BINARY_LOCATION=x86/Agent.tar.gz
+
+builds a PPD package that references a binary of the C<Agent> package,
+located in the C<x86> directory relative to the PPD itself.
+
+=item BUILD_REQUIRES
+
+A hash of modules that are needed to build your module but not run it.
+
+This will go into the C<build_requires> field of your F<META.yml>.
+
+The format is the same as PREREQ_PM.
+
+=item C
+
+Ref to array of *.c file names. Initialised from a directory scan
+and the values portion of the XS attribute hash. This is not
+currently used by MakeMaker but may be handy in Makefile.PLs.
+
+=item CCFLAGS
+
+String that will be included in the compiler call command line between
+the arguments INC and OPTIMIZE.
+
+=item CONFIG
+
+Arrayref. E.g. [qw(archname manext)] defines ARCHNAME & MANEXT from
+config.sh. MakeMaker will add to CONFIG the following values anyway:
+ar
+cc
+cccdlflags
+ccdlflags
+dlext
+dlsrc
+ld
+lddlflags
+ldflags
+libc
+lib_ext
+obj_ext
+ranlib
+sitelibexp
+sitearchexp
+so
+
+=item CONFIGURE
+
+CODE reference. The subroutine should return a hash reference. The
+hash may contain further attributes, e.g. {LIBS =E<gt> ...}, that have to
+be determined by some evaluation method.
+
+=item CONFIGURE_REQUIRES
+
+A hash of modules that are required to run Makefile.PL itself, but not
+to run your distribution.
+
+This will go into the C<configure_requires> field of your F<META.yml>.
+
+Defaults to C<{ "ExtUtils::MakeMaker" => 0 }>
+
+The format is the same as PREREQ_PM.
+
+=item DEFINE
+
+Something like C<"-DHAVE_UNISTD_H">
+
+=item DESTDIR
+
+This is the root directory into which the code will be installed. It
+I<prepends itself to the normal prefix>. For example, if your code
+would normally go into F</usr/local/lib/perl> you could set DESTDIR=~/tmp/
+and installation would go into F<~/tmp/usr/local/lib/perl>.
+
+This is primarily of use for people who repackage Perl modules.
+
+NOTE: Due to the nature of make, it is important that you put the trailing
+slash on your DESTDIR. F<~/tmp/> not F<~/tmp>.
+
+=item DIR
+
+Ref to array of subdirectories containing Makefile.PLs e.g. ['sdbm']
+in ext/SDBM_File
+
+=item DISTNAME
+
+A safe filename for the package.
+
+Defaults to NAME above but with :: replaced with -.
+
+For example, Foo::Bar becomes Foo-Bar.
+
+=item DISTVNAME
+
+Your name for distributing the package with the version number
+included. This is used by 'make dist' to name the resulting archive
+file.
+
+Defaults to DISTNAME-VERSION.
+
+For example, version 1.04 of Foo::Bar becomes Foo-Bar-1.04.
+
+On some OS's where . has special meaning VERSION_SYM may be used in
+place of VERSION.
+
+=item DL_FUNCS
+
+Hashref of symbol names for routines to be made available as universal
+symbols. Each key/value pair consists of the package name and an
+array of routine names in that package. Used only under AIX, OS/2,
+VMS and Win32 at present. The routine names supplied will be expanded
+in the same way as XSUB names are expanded by the XS() macro.
+Defaults to
+
+ {"$(NAME)" => ["boot_$(NAME)" ] }
+
+e.g.
+
+ {"RPC" => [qw( boot_rpcb rpcb_gettime getnetconfigent )],
+ "NetconfigPtr" => [ 'DESTROY'] }
+
+Please see the L<ExtUtils::Mksymlists> documentation for more information
+about the DL_FUNCS, DL_VARS and FUNCLIST attributes.
+
+=item DL_VARS
+
+Array of symbol names for variables to be made available as universal symbols.
+Used only under AIX, OS/2, VMS and Win32 at present. Defaults to [].
+(e.g. [ qw(Foo_version Foo_numstreams Foo_tree ) ])
+
+=item EXCLUDE_EXT
+
+Array of extension names to exclude when doing a static build. This
+is ignored if INCLUDE_EXT is present. Consult INCLUDE_EXT for more
+details. (e.g. [ qw( Socket POSIX ) ] )
+
+This attribute may be most useful when specified as a string on the
+command line: perl Makefile.PL EXCLUDE_EXT='Socket Safe'
+
+=item EXE_FILES
+
+Ref to array of executable files. The files will be copied to the
+INST_SCRIPT directory. Make realclean will delete them from there
+again.
+
+If your executables start with something like #!perl or
+#!/usr/bin/perl MakeMaker will change this to the path of the perl
+'Makefile.PL' was invoked with so the programs will be sure to run
+properly even if perl is not in /usr/bin/perl.
+
+=item FIRST_MAKEFILE
+
+The name of the Makefile to be produced. This is used for the second
+Makefile that will be produced for the MAP_TARGET.
+
+Defaults to 'Makefile' or 'Descrip.MMS' on VMS.
+
+(Note: we couldn't use MAKEFILE because dmake uses this for something
+else).
+
+=item FULLPERL
+
+Perl binary able to run this extension, load XS modules, etc...
+
+=item FULLPERLRUN
+
+Like PERLRUN, except it uses FULLPERL.
+
+=item FULLPERLRUNINST
+
+Like PERLRUNINST, except it uses FULLPERL.
+
+=item FUNCLIST
+
+This provides an alternate means to specify function names to be
+exported from the extension. Its value is a reference to an
+array of function names to be exported by the extension. These
+names are passed through unaltered to the linker options file.
+
+=item H
+
+Ref to array of *.h file names. Similar to C.
+
+=item IMPORTS
+
+This attribute is used to specify names to be imported into the
+extension. Takes a hash ref.
+
+It is only used on OS/2 and Win32.
+
+=item INC
+
+Include file dirs eg: C<"-I/usr/5include -I/path/to/inc">
+
+=item INCLUDE_EXT
+
+Array of extension names to be included when doing a static build.
+MakeMaker will normally build with all of the installed extensions when
+doing a static build, and that is usually the desired behavior. If
+INCLUDE_EXT is present then MakeMaker will build only with those extensions
+which are explicitly mentioned. (e.g. [ qw( Socket POSIX ) ])
+
+It is not necessary to mention DynaLoader or the current extension when
+filling in INCLUDE_EXT. If the INCLUDE_EXT is mentioned but is empty then
+only DynaLoader and the current extension will be included in the build.
+
+This attribute may be most useful when specified as a string on the
+command line: perl Makefile.PL INCLUDE_EXT='POSIX Socket Devel::Peek'
+
+=item INSTALLARCHLIB
+
+Used by 'make install', which copies files from INST_ARCHLIB to this
+directory if INSTALLDIRS is set to perl.
+
+=item INSTALLBIN
+
+Directory to install binary files (e.g. tkperl) into if
+INSTALLDIRS=perl.
+
+=item INSTALLDIRS
+
+Determines which of the sets of installation directories to choose:
+perl, site or vendor. Defaults to site.
+
+=item INSTALLMAN1DIR
+
+=item INSTALLMAN3DIR
+
+These directories get the man pages at 'make install' time if
+INSTALLDIRS=perl. Defaults to $Config{installman*dir}.
+
+If set to 'none', no man pages will be installed.
+
+=item INSTALLPRIVLIB
+
+Used by 'make install', which copies files from INST_LIB to this
+directory if INSTALLDIRS is set to perl.
+
+Defaults to $Config{installprivlib}.
+
+=item INSTALLSCRIPT
+
+Used by 'make install' which copies files from INST_SCRIPT to this
+directory if INSTALLDIRS=perl.
+
+=item INSTALLSITEARCH
+
+Used by 'make install', which copies files from INST_ARCHLIB to this
+directory if INSTALLDIRS is set to site (default).
+
+=item INSTALLSITEBIN
+
+Used by 'make install', which copies files from INST_BIN to this
+directory if INSTALLDIRS is set to site (default).
+
+=item INSTALLSITELIB
+
+Used by 'make install', which copies files from INST_LIB to this
+directory if INSTALLDIRS is set to site (default).
+
+=item INSTALLSITEMAN1DIR
+
+=item INSTALLSITEMAN3DIR
+
+These directories get the man pages at 'make install' time if
+INSTALLDIRS=site (default). Defaults to
+$(SITEPREFIX)/man/man$(MAN*EXT).
+
+If set to 'none', no man pages will be installed.
+
+=item INSTALLSITESCRIPT
+
+Used by 'make install' which copies files from INST_SCRIPT to this
+directory if INSTALLDIRS is set to site (default).
+
+=item INSTALLVENDORARCH
+
+Used by 'make install', which copies files from INST_ARCHLIB to this
+directory if INSTALLDIRS is set to vendor.
+
+=item INSTALLVENDORBIN
+
+Used by 'make install', which copies files from INST_BIN to this
+directory if INSTALLDIRS is set to vendor.
+
+=item INSTALLVENDORLIB
+
+Used by 'make install', which copies files from INST_LIB to this
+directory if INSTALLDIRS is set to vendor.
+
+=item INSTALLVENDORMAN1DIR
+
+=item INSTALLVENDORMAN3DIR
+
+These directories get the man pages at 'make install' time if
+INSTALLDIRS=vendor. Defaults to $(VENDORPREFIX)/man/man$(MAN*EXT).
+
+If set to 'none', no man pages will be installed.
+
+=item INSTALLVENDORSCRIPT
+
+Used by 'make install' which copies files from INST_SCRIPT to this
+directory if INSTALLDIRS is set to vendor.
+
+=item INST_ARCHLIB
+
+Same as INST_LIB for architecture dependent files.
+
+=item INST_BIN
+
+Directory to put real binary files during 'make'. These will be copied
+to INSTALLBIN during 'make install'
+
+=item INST_LIB
+
+Directory where we put library files of this extension while building
+it.
+
+=item INST_MAN1DIR
+
+Directory to hold the man pages at 'make' time
+
+=item INST_MAN3DIR
+
+Directory to hold the man pages at 'make' time
+
+=item INST_SCRIPT
+
+Directory, where executable files should be installed during
+'make'. Defaults to "./blib/script", just to have a dummy location during
+testing. make install will copy the files in INST_SCRIPT to
+INSTALLSCRIPT.
+
+=item LD
+
+Program to be used to link libraries for dynamic loading.
+
+Defaults to $Config{ld}.
+
+=item LDDLFLAGS
+
+Any special flags that might need to be passed to ld to create a
+shared library suitable for dynamic loading. It is up to the makefile
+to use it. (See L<Config/lddlflags>)
+
+Defaults to $Config{lddlflags}.
+
+=item LDFROM
+
+Defaults to "$(OBJECT)" and is used in the ld command to specify
+what files to link/load from (also see dynamic_lib below for how to
+specify ld flags)
+
+=item LIB
+
+LIB should only be set at C<perl Makefile.PL> time but is allowed as a
+MakeMaker argument. It has the effect of setting both INSTALLPRIVLIB
+and INSTALLSITELIB to that value regardless any explicit setting of
+those arguments (or of PREFIX). INSTALLARCHLIB and INSTALLSITEARCH
+are set to the corresponding architecture subdirectory.
+
+=item LIBPERL_A
+
+The filename of the perllibrary that will be used together with this
+extension. Defaults to libperl.a.
+
+=item LIBS
+
+An anonymous array of alternative library
+specifications to be searched for (in order) until
+at least one library is found. E.g.
+
+ 'LIBS' => ["-lgdbm", "-ldbm -lfoo", "-L/path -ldbm.nfs"]
+
+Mind, that any element of the array
+contains a complete set of arguments for the ld
+command. So do not specify
+
+ 'LIBS' => ["-ltcl", "-ltk", "-lX11"]
+
+See ODBM_File/Makefile.PL for an example, where an array is needed. If
+you specify a scalar as in
+
+ 'LIBS' => "-ltcl -ltk -lX11"
+
+MakeMaker will turn it into an array with one element.
+
+=item LICENSE
+
+The licensing terms of your distribution. Generally its "perl" for the
+same license as Perl itself.
+
+See L<Module::Build::API> for the list of options.
+
+Defaults to "unknown".
+
+=item LINKTYPE
+
+'static' or 'dynamic' (default unless usedl=undef in
+config.sh). Should only be used to force static linking (also see
+linkext below).
+
+=item MAKE
+
+Variant of make you intend to run the generated Makefile with. This
+parameter lets Makefile.PL know what make quirks to account for when
+generating the Makefile.
+
+MakeMaker also honors the MAKE environment variable. This parameter
+takes precedent.
+
+Currently the only significant values are 'dmake' and 'nmake' for Windows
+users.
+
+Defaults to $Config{make}.
+
+=item MAKEAPERL
+
+Boolean which tells MakeMaker, that it should include the rules to
+make a perl. This is handled automatically as a switch by
+MakeMaker. The user normally does not need it.
+
+=item MAKEFILE_OLD
+
+When 'make clean' or similar is run, the $(FIRST_MAKEFILE) will be
+backed up at this location.
+
+Defaults to $(FIRST_MAKEFILE).old or $(FIRST_MAKEFILE)_old on VMS.
+
+=item MAN1PODS
+
+Hashref of pod-containing files. MakeMaker will default this to all
+EXE_FILES files that include POD directives. The files listed
+here will be converted to man pages and installed as was requested
+at Configure time.
+
+This hash should map POD files (or scripts containing POD) to the
+man file names under the C<blib/man1/> directory, as in the following
+example:
+
+ MAN1PODS => {
+ 'doc/command.pod' => 'blib/man1/command.1',
+ 'scripts/script.pl' => 'blib/man1/script.1',
+ }
+
+=item MAN3PODS
+
+Hashref that assigns to *.pm and *.pod files the files into which the
+manpages are to be written. MakeMaker parses all *.pod and *.pm files
+for POD directives. Files that contain POD will be the default keys of
+the MAN3PODS hashref. These will then be converted to man pages during
+C<make> and will be installed during C<make install>.
+
+Example similar to MAN1PODS.
+
+=item MAP_TARGET
+
+If it is intended, that a new perl binary be produced, this variable
+may hold a name for that binary. Defaults to perl
+
+=item META_ADD
+
+=item META_MERGE
+
+A hashrefs of items to add to the F<META.yml>.
+
+They differ in how they behave if they have the same key as the
+default metadata. META_ADD will override the default value with it's
+own. META_MERGE will merge its value with the default.
+
+Unless you want to override the defaults, prefer META_MERGE so as to
+get the advantage of any future defaults.
+
+=item MIN_PERL_VERSION
+
+The minimum required version of Perl for this distribution.
+
+Either 5.006001 or 5.6.1 format is acceptable.
+
+=item MYEXTLIB
+
+If the extension links to a library that it builds set this to the
+name of the library (see SDBM_File)
+
+=item NAME
+
+Perl module name for this extension (DBD::Oracle). This will default
+to the directory name but should be explicitly defined in the
+Makefile.PL.
+
+=item NEEDS_LINKING
+
+MakeMaker will figure out if an extension contains linkable code
+anywhere down the directory tree, and will set this variable
+accordingly, but you can speed it up a very little bit if you define
+this boolean variable yourself.
+
+=item NOECHO
+
+Command so make does not print the literal commands its running.
+
+By setting it to an empty string you can generate a Makefile that
+prints all commands. Mainly used in debugging MakeMaker itself.
+
+Defaults to C<@>.
+
+=item NORECURS
+
+Boolean. Attribute to inhibit descending into subdirectories.
+
+=item NO_META
+
+When true, suppresses the generation and addition to the MANIFEST of
+the META.yml module meta-data file during 'make distdir'.
+
+Defaults to false.
+
+=item NO_VC
+
+In general, any generated Makefile checks for the current version of
+MakeMaker and the version the Makefile was built under. If NO_VC is
+set, the version check is neglected. Do not write this into your
+Makefile.PL, use it interactively instead.
+
+=item OBJECT
+
+List of object files, defaults to '$(BASEEXT)$(OBJ_EXT)', but can be a long
+string containing all object files, e.g. "tkpBind.o
+tkpButton.o tkpCanvas.o"
+
+(Where BASEEXT is the last component of NAME, and OBJ_EXT is $Config{obj_ext}.)
+
+=item OPTIMIZE
+
+Defaults to C<-O>. Set it to C<-g> to turn debugging on. The flag is
+passed to subdirectory makes.
+
+=item PERL
+
+Perl binary for tasks that can be done by miniperl
+
+=item PERL_CORE
+
+Set only when MakeMaker is building the extensions of the Perl core
+distribution.
+
+=item PERLMAINCC
+
+The call to the program that is able to compile perlmain.c. Defaults
+to $(CC).
+
+=item PERL_ARCHLIB
+
+Same as for PERL_LIB, but for architecture dependent files.
+
+Used only when MakeMaker is building the extensions of the Perl core
+distribution (because normally $(PERL_ARCHLIB) is automatically in @INC,
+and adding it would get in the way of PERL5LIB).
+
+=item PERL_LIB
+
+Directory containing the Perl library to use.
+
+Used only when MakeMaker is building the extensions of the Perl core
+distribution (because normally $(PERL_LIB) is automatically in @INC,
+and adding it would get in the way of PERL5LIB).
+
+=item PERL_MALLOC_OK
+
+defaults to 0. Should be set to TRUE if the extension can work with
+the memory allocation routines substituted by the Perl malloc() subsystem.
+This should be applicable to most extensions with exceptions of those
+
+=over 4
+
+=item *
+
+with bugs in memory allocations which are caught by Perl's malloc();
+
+=item *
+
+which interact with the memory allocator in other ways than via
+malloc(), realloc(), free(), calloc(), sbrk() and brk();
+
+=item *
+
+which rely on special alignment which is not provided by Perl's malloc().
+
+=back
+
+B<NOTE.> Negligence to set this flag in I<any one> of loaded extension
+nullifies many advantages of Perl's malloc(), such as better usage of
+system resources, error detection, memory usage reporting, catchable failure
+of memory allocations, etc.
+
+=item PERLPREFIX
+
+Directory under which core modules are to be installed.
+
+Defaults to $Config{installprefixexp} falling back to
+$Config{installprefix}, $Config{prefixexp} or $Config{prefix} should
+$Config{installprefixexp} not exist.
+
+Overridden by PREFIX.
+
+=item PERLRUN
+
+Use this instead of $(PERL) when you wish to run perl. It will set up
+extra necessary flags for you.
+
+=item PERLRUNINST
+
+Use this instead of $(PERL) when you wish to run perl to work with
+modules. It will add things like -I$(INST_ARCH) and other necessary
+flags so perl can see the modules you're about to install.
+
+=item PERL_SRC
+
+Directory containing the Perl source code (use of this should be
+avoided, it may be undefined)
+
+=item PERM_DIR
+
+Desired permission for directories. Defaults to C<755>.
+
+=item PERM_RW
+
+Desired permission for read/writable files. Defaults to C<644>.
+
+=item PERM_RWX
+
+Desired permission for executable files. Defaults to C<755>.
+
+=item PL_FILES
+
+MakeMaker can run programs to generate files for you at build time.
+By default any file named *.PL (except Makefile.PL and Build.PL) in
+the top level directory will be assumed to be a Perl program and run
+passing its own basename in as an argument. For example...
+
+ perl foo.PL foo
+
+This behavior can be overridden by supplying your own set of files to
+search. PL_FILES accepts a hash ref, the key being the file to run
+and the value is passed in as the first argument when the PL file is run.
+
+ PL_FILES => {'bin/foobar.PL' => 'bin/foobar'}
+
+Would run bin/foobar.PL like this:
+
+ perl bin/foobar.PL bin/foobar
+
+If multiple files from one program are desired an array ref can be used.
+
+ PL_FILES => {'bin/foobar.PL' => [qw(bin/foobar1 bin/foobar2)]}
+
+In this case the program will be run multiple times using each target file.
+
+ perl bin/foobar.PL bin/foobar1
+ perl bin/foobar.PL bin/foobar2
+
+PL files are normally run B<after> pm_to_blib and include INST_LIB and
+INST_ARCH in its C<@INC> so the just built modules can be
+accessed... unless the PL file is making a module (or anything else in
+PM) in which case it is run B<before> pm_to_blib and does not include
+INST_LIB and INST_ARCH in its C<@INC>. This apparently odd behavior
+is there for backwards compatibility (and its somewhat DWIM).
+
+
+=item PM
+
+Hashref of .pm files and *.pl files to be installed. e.g.
+
+ {'name_of_file.pm' => '$(INST_LIBDIR)/install_as.pm'}
+
+By default this will include *.pm and *.pl and the files found in
+the PMLIBDIRS directories. Defining PM in the
+Makefile.PL will override PMLIBDIRS.
+
+=item PMLIBDIRS
+
+Ref to array of subdirectories containing library files. Defaults to
+[ 'lib', $(BASEEXT) ]. The directories will be scanned and I<any> files
+they contain will be installed in the corresponding location in the
+library. A libscan() method can be used to alter the behaviour.
+Defining PM in the Makefile.PL will override PMLIBDIRS.
+
+(Where BASEEXT is the last component of NAME.)
+
+=item PM_FILTER
+
+A filter program, in the traditional Unix sense (input from stdin, output
+to stdout) that is passed on each .pm file during the build (in the
+pm_to_blib() phase). It is empty by default, meaning no filtering is done.
+
+Great care is necessary when defining the command if quoting needs to be
+done. For instance, you would need to say:
+
+ {'PM_FILTER' => 'grep -v \\"^\\#\\"'}
+
+to remove all the leading comments on the fly during the build. The
+extra \\ are necessary, unfortunately, because this variable is interpolated
+within the context of a Perl program built on the command line, and double
+quotes are what is used with the -e switch to build that command line. The
+# is escaped for the Makefile, since what is going to be generated will then
+be:
+
+ PM_FILTER = grep -v \"^\#\"
+
+Without the \\ before the #, we'd have the start of a Makefile comment,
+and the macro would be incorrectly defined.
+
+=item POLLUTE
+
+Release 5.005 grandfathered old global symbol names by providing preprocessor
+macros for extension source compatibility. As of release 5.6, these
+preprocessor definitions are not available by default. The POLLUTE flag
+specifies that the old names should still be defined:
+
+ perl Makefile.PL POLLUTE=1
+
+Please inform the module author if this is necessary to successfully install
+a module under 5.6 or later.
+
+=item PPM_INSTALL_EXEC
+
+Name of the executable used to run C<PPM_INSTALL_SCRIPT> below. (e.g. perl)
+
+=item PPM_INSTALL_SCRIPT
+
+Name of the script that gets executed by the Perl Package Manager after
+the installation of a package.
+
+=item PREFIX
+
+This overrides all the default install locations. Man pages,
+libraries, scripts, etc... MakeMaker will try to make an educated
+guess about where to place things under the new PREFIX based on your
+Config defaults. Failing that, it will fall back to a structure
+which should be sensible for your platform.
+
+If you specify LIB or any INSTALL* variables they will not be effected
+by the PREFIX.
+
+=item PREREQ_FATAL
+
+Bool. If this parameter is true, failing to have the required modules
+(or the right versions thereof) will be fatal. C<perl Makefile.PL>
+will C<die> instead of simply informing the user of the missing dependencies.
+
+It is I<extremely> rare to have to use C<PREREQ_FATAL>. Its use by module
+authors is I<strongly discouraged> and should never be used lightly.
+Module installation tools have ways of resolving umet dependencies but
+to do that they need a F<Makefile>. Using C<PREREQ_FATAL> breaks this.
+That's bad.
+
+The only situation where it is appropriate is when you have
+dependencies that are indispensible to actually I<write> a
+F<Makefile>. For example, MakeMaker's F<Makefile.PL> needs L<File::Spec>.
+If its not available it cannot write the F<Makefile>.
+
+Note: see L<Test::Harness> for a shortcut for stopping tests early
+if you are missing dependencies and are afraid that users might
+use your module with an incomplete environment.
+
+=item PREREQ_PM
+
+A hash of modules that are needed to run your module. The keys are
+the module names ie. Test::More, and the minimum version is the
+value. If the required version number is 0 any version will do.
+
+This will go into the C<requires> field of your F<META.yml>.
+
+ PREREQ_PM => {
+ # Require Test::More at least 0.47
+ "Test::More" => "0.47",
+
+ # Require any version of Acme::Buffy
+ "Acme::Buffy" => 0,
+ }
+
+=item PREREQ_PRINT
+
+Bool. If this parameter is true, the prerequisites will be printed to
+stdout and MakeMaker will exit. The output format is an evalable hash
+ref.
+
+ $PREREQ_PM = {
+ 'A::B' => Vers1,
+ 'C::D' => Vers2,
+ ...
+ };
+
+If a distribution defines a minimal required perl version, this is
+added to the output as an additional line of the form:
+
+ $MIN_PERL_VERSION = '5.008001';
+
+If BUILD_REQUIRES is not empty, it will be dumped as $BUILD_REQUIRES hasref.
+
+=item PRINT_PREREQ
+
+RedHatism for C<PREREQ_PRINT>. The output format is different, though:
+
+ perl(A::B)>=Vers1 perl(C::D)>=Vers2 ...
+
+A minimal required perl version, if present, will look like this:
+
+ perl(perl)>=5.008001
+
+=item SITEPREFIX
+
+Like PERLPREFIX, but only for the site install locations.
+
+Defaults to $Config{siteprefixexp}. Perls prior to 5.6.0 didn't have
+an explicit siteprefix in the Config. In those cases
+$Config{installprefix} will be used.
+
+Overridable by PREFIX
+
+=item SIGN
+
+When true, perform the generation and addition to the MANIFEST of the
+SIGNATURE file in the distdir during 'make distdir', via 'cpansign
+-s'.
+
+Note that you need to install the Module::Signature module to
+perform this operation.
+
+Defaults to false.
+
+=item SKIP
+
+Arrayref. E.g. [qw(name1 name2)] skip (do not write) sections of the
+Makefile. Caution! Do not use the SKIP attribute for the negligible
+speedup. It may seriously damage the resulting Makefile. Only use it
+if you really need it.
+
+=item TYPEMAPS
+
+Ref to array of typemap file names. Use this when the typemaps are
+in some directory other than the current directory or when they are
+not named B<typemap>. The last typemap in the list takes
+precedence. A typemap in the current directory has highest
+precedence, even if it isn't listed in TYPEMAPS. The default system
+typemap has lowest precedence.
+
+=item VENDORPREFIX
+
+Like PERLPREFIX, but only for the vendor install locations.
+
+Defaults to $Config{vendorprefixexp}.
+
+Overridable by PREFIX
+
+=item VERBINST
+
+If true, make install will be verbose
+
+=item VERSION
+
+Your version number for distributing the package. This defaults to
+0.1.
+
+=item VERSION_FROM
+
+Instead of specifying the VERSION in the Makefile.PL you can let
+MakeMaker parse a file to determine the version number. The parsing
+routine requires that the file named by VERSION_FROM contains one
+single line to compute the version number. The first line in the file
+that contains the regular expression
+
+ /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/
+
+will be evaluated with eval() and the value of the named variable
+B<after> the eval() will be assigned to the VERSION attribute of the
+MakeMaker object. The following lines will be parsed o.k.:
+
+ $VERSION = '1.00';
+ *VERSION = \'1.01';
+ ($VERSION) = q$Revision: 1.1.1.2 $ =~ /(\d+)/g;
+ $FOO::VERSION = '1.10';
+ *FOO::VERSION = \'1.11';
+
+but these will fail:
+
+ # Bad
+ my $VERSION = '1.01';
+ local $VERSION = '1.02';
+ local $FOO::VERSION = '1.30';
+
+"Version strings" are incompatible should not be used.
+
+ # Bad
+ $VERSION = 1.2.3;
+ $VERSION = v1.2.3;
+
+L<version> objects are fine. As of MakeMaker 6.35 version.pm will be
+automatically loaded, but you must declare the dependency on version.pm.
+For compatibility with older MakeMaker you should load on the same line
+as $VERSION is declared.
+
+ # All on one line
+ use version; our $VERSION = qv(1.2.3);
+
+(Putting C<my> or C<local> on the preceding line will work o.k.)
+
+The file named in VERSION_FROM is not added as a dependency to
+Makefile. This is not really correct, but it would be a major pain
+during development to have to rewrite the Makefile for any smallish
+change in that file. If you want to make sure that the Makefile
+contains the correct VERSION macro after any change of the file, you
+would have to do something like
+
+ depend => { Makefile => '$(VERSION_FROM)' }
+
+See attribute C<depend> below.
+
+=item VERSION_SYM
+
+A sanitized VERSION with . replaced by _. For places where . has
+special meaning (some filesystems, RCS labels, etc...)
+
+=item XS
+
+Hashref of .xs files. MakeMaker will default this. e.g.
+
+ {'name_of_file.xs' => 'name_of_file.c'}
+
+The .c files will automatically be included in the list of files
+deleted by a make clean.
+
+=item XSOPT
+
+String of options to pass to xsubpp. This might include C<-C++> or
+C<-extern>. Do not include typemaps here; the TYPEMAP parameter exists for
+that purpose.
+
+=item XSPROTOARG
+
+May be set to an empty string, which is identical to C<-prototypes>, or
+C<-noprototypes>. See the xsubpp documentation for details. MakeMaker
+defaults to the empty string.
+
+=item XS_VERSION
+
+Your version number for the .xs file of this package. This defaults
+to the value of the VERSION attribute.
+
+=back
+
+=head2 Additional lowercase attributes
+
+can be used to pass parameters to the methods which implement that
+part of the Makefile. Parameters are specified as a hash ref but are
+passed to the method as a hash.
+
+=over 2
+
+=item clean
+
+ {FILES => "*.xyz foo"}
+
+=item depend
+
+ {ANY_TARGET => ANY_DEPENDENCY, ...}
+
+(ANY_TARGET must not be given a double-colon rule by MakeMaker.)
+
+=item dist
+
+ {TARFLAGS => 'cvfF', COMPRESS => 'gzip', SUFFIX => '.gz',
+ SHAR => 'shar -m', DIST_CP => 'ln', ZIP => '/bin/zip',
+ ZIPFLAGS => '-rl', DIST_DEFAULT => 'private tardist' }
+
+If you specify COMPRESS, then SUFFIX should also be altered, as it is
+needed to tell make the target file of the compression. Setting
+DIST_CP to ln can be useful, if you need to preserve the timestamps on
+your files. DIST_CP can take the values 'cp', which copies the file,
+'ln', which links the file, and 'best' which copies symbolic links and
+links the rest. Default is 'best'.
+
+=item dynamic_lib
+
+ {ARMAYBE => 'ar', OTHERLDFLAGS => '...', INST_DYNAMIC_DEP => '...'}
+
+=item linkext
+
+ {LINKTYPE => 'static', 'dynamic' or ''}
+
+NB: Extensions that have nothing but *.pm files had to say
+
+ {LINKTYPE => ''}
+
+with Pre-5.0 MakeMakers. Since version 5.00 of MakeMaker such a line
+can be deleted safely. MakeMaker recognizes when there's nothing to
+be linked.
+
+=item macro
+
+ {ANY_MACRO => ANY_VALUE, ...}
+
+=item postamble
+
+Anything put here will be passed to MY::postamble() if you have one.
+
+=item realclean
+
+ {FILES => '$(INST_ARCHAUTODIR)/*.xyz'}
+
+=item test
+
+ {TESTS => 't/*.t'}
+
+=item tool_autosplit
+
+ {MAXLEN => 8}
+
+=back
+
+=head2 Overriding MakeMaker Methods
+
+If you cannot achieve the desired Makefile behaviour by specifying
+attributes you may define private subroutines in the Makefile.PL.
+Each subroutine returns the text it wishes to have written to
+the Makefile. To override a section of the Makefile you can
+either say:
+
+ sub MY::c_o { "new literal text" }
+
+or you can edit the default by saying something like:
+
+ package MY; # so that "SUPER" works right
+ sub c_o {
+ my $inherited = shift->SUPER::c_o(@_);
+ $inherited =~ s/old text/new text/;
+ $inherited;
+ }
+
+If you are running experiments with embedding perl as a library into
+other applications, you might find MakeMaker is not sufficient. You'd
+better have a look at ExtUtils::Embed which is a collection of utilities
+for embedding.
+
+If you still need a different solution, try to develop another
+subroutine that fits your needs and submit the diffs to
+C<makemaker at perl.org>
+
+For a complete description of all MakeMaker methods see
+L<ExtUtils::MM_Unix>.
+
+Here is a simple example of how to add a new target to the generated
+Makefile:
+
+ sub MY::postamble {
+ return <<'MAKE_FRAG';
+ $(MYEXTLIB): sdbm/Makefile
+ cd sdbm && $(MAKE) all
+
+ MAKE_FRAG
+ }
+
+=head2 The End Of Cargo Cult Programming
+
+WriteMakefile() now does some basic sanity checks on its parameters to
+protect against typos and malformatted values. This means some things
+which happened to work in the past will now throw warnings and
+possibly produce internal errors.
+
+Some of the most common mistakes:
+
+=over 2
+
+=item C<< MAN3PODS => ' ' >>
+
+This is commonly used to suppress the creation of man pages. MAN3PODS
+takes a hash ref not a string, but the above worked by accident in old
+versions of MakeMaker.
+
+The correct code is C<< MAN3PODS => { } >>.
+
+=back
+
+
+=head2 Hintsfile support
+
+MakeMaker.pm uses the architecture specific information from
+Config.pm. In addition it evaluates architecture specific hints files
+in a C<hints/> directory. The hints files are expected to be named
+like their counterparts in C<PERL_SRC/hints>, but with an C<.pl> file
+name extension (eg. C<next_3_2.pl>). They are simply C<eval>ed by
+MakeMaker within the WriteMakefile() subroutine, and can be used to
+execute commands as well as to include special variables. The rules
+which hintsfile is chosen are the same as in Configure.
+
+The hintsfile is eval()ed immediately after the arguments given to
+WriteMakefile are stuffed into a hash reference $self but before this
+reference becomes blessed. So if you want to do the equivalent to
+override or create an attribute you would say something like
+
+ $self->{LIBS} = ['-ldbm -lucb -lc'];
+
+=head2 Distribution Support
+
+For authors of extensions MakeMaker provides several Makefile
+targets. Most of the support comes from the ExtUtils::Manifest module,
+where additional documentation can be found.
+
+=over 4
+
+=item make distcheck
+
+reports which files are below the build directory but not in the
+MANIFEST file and vice versa. (See ExtUtils::Manifest::fullcheck() for
+details)
+
+=item make skipcheck
+
+reports which files are skipped due to the entries in the
+C<MANIFEST.SKIP> file (See ExtUtils::Manifest::skipcheck() for
+details)
+
+=item make distclean
+
+does a realclean first and then the distcheck. Note that this is not
+needed to build a new distribution as long as you are sure that the
+MANIFEST file is ok.
+
+=item make manifest
+
+rewrites the MANIFEST file, adding all remaining files found (See
+ExtUtils::Manifest::mkmanifest() for details)
+
+=item make distdir
+
+Copies all the files that are in the MANIFEST file to a newly created
+directory with the name C<$(DISTNAME)-$(VERSION)>. If that directory
+exists, it will be removed first.
+
+Additionally, it will create a META.yml module meta-data file in the
+distdir and add this to the distdir's MANIFEST. You can shut this
+behavior off with the NO_META flag.
+
+=item make disttest
+
+Makes a distdir first, and runs a C<perl Makefile.PL>, a make, and
+a make test in that directory.
+
+=item make tardist
+
+First does a distdir. Then a command $(PREOP) which defaults to a null
+command, followed by $(TO_UNIX), which defaults to a null command under
+UNIX, and will convert files in distribution directory to UNIX format
+otherwise. Next it runs C<tar> on that directory into a tarfile and
+deletes the directory. Finishes with a command $(POSTOP) which
+defaults to a null command.
+
+=item make dist
+
+Defaults to $(DIST_DEFAULT) which in turn defaults to tardist.
+
+=item make uutardist
+
+Runs a tardist first and uuencodes the tarfile.
+
+=item make shdist
+
+First does a distdir. Then a command $(PREOP) which defaults to a null
+command. Next it runs C<shar> on that directory into a sharfile and
+deletes the intermediate directory again. Finishes with a command
+$(POSTOP) which defaults to a null command. Note: For shdist to work
+properly a C<shar> program that can handle directories is mandatory.
+
+=item make zipdist
+
+First does a distdir. Then a command $(PREOP) which defaults to a null
+command. Runs C<$(ZIP) $(ZIPFLAGS)> on that directory into a
+zipfile. Then deletes that directory. Finishes with a command
+$(POSTOP) which defaults to a null command.
+
+=item make ci
+
+Does a $(CI) and a $(RCS_LABEL) on all files in the MANIFEST file.
+
+=back
+
+Customization of the dist targets can be done by specifying a hash
+reference to the dist attribute of the WriteMakefile call. The
+following parameters are recognized:
+
+ CI ('ci -u')
+ COMPRESS ('gzip --best')
+ POSTOP ('@ :')
+ PREOP ('@ :')
+ TO_UNIX (depends on the system)
+ RCS_LABEL ('rcs -q -Nv$(VERSION_SYM):')
+ SHAR ('shar')
+ SUFFIX ('.gz')
+ TAR ('tar')
+ TARFLAGS ('cvf')
+ ZIP ('zip')
+ ZIPFLAGS ('-r')
+
+An example:
+
+ WriteMakefile(
+ ...other options...
+ dist => {
+ COMPRESS => "bzip2",
+ SUFFIX => ".bz2"
+ }
+ );
+
+
+=head2 Module Meta-Data
+
+Long plaguing users of MakeMaker based modules has been the problem of
+getting basic information about the module out of the sources
+I<without> running the F<Makefile.PL> and doing a bunch of messy
+heuristics on the resulting F<Makefile>. To this end a simple module
+meta-data file has been introduced, F<META.yml>.
+
+F<META.yml> is a YAML document (see http://www.yaml.org) containing
+basic information about the module (name, version, prerequisites...)
+in an easy to read format. The format is developed and defined by the
+Module::Build developers (see
+http://module-build.sourceforge.net/META-spec.html)
+
+MakeMaker will automatically generate a F<META.yml> file for you and
+add it to your F<MANIFEST> as part of the 'distdir' target (and thus
+the 'dist' target). This is intended to seamlessly and rapidly
+populate CPAN with module meta-data. If you wish to shut this feature
+off, set the C<NO_META> C<WriteMakefile()> flag to true.
+
+
+=head2 Disabling an extension
+
+If some events detected in F<Makefile.PL> imply that there is no way
+to create the Module, but this is a normal state of things, then you
+can create a F<Makefile> which does nothing, but succeeds on all the
+"usual" build targets. To do so, use
+
+ use ExtUtils::MakeMaker qw(WriteEmptyMakefile);
+ WriteEmptyMakefile();
+
+instead of WriteMakefile().
+
+This may be useful if other modules expect this module to be I<built>
+OK, as opposed to I<work> OK (say, this system-dependent module builds
+in a subdirectory of some other distribution, or is listed as a
+dependency in a CPAN::Bundle, but the functionality is supported by
+different means on the current architecture).
+
+=head2 Other Handy Functions
+
+=over 4
+
+=item prompt
+
+ my $value = prompt($message);
+ my $value = prompt($message, $default);
+
+The C<prompt()> function provides an easy way to request user input
+used to write a makefile. It displays the $message as a prompt for
+input. If a $default is provided it will be used as a default. The
+function returns the $value selected by the user.
+
+If C<prompt()> detects that it is not running interactively and there
+is nothing on STDIN or if the PERL_MM_USE_DEFAULT environment variable
+is set to true, the $default will be used without prompting. This
+prevents automated processes from blocking on user input.
+
+If no $default is provided an empty string will be used instead.
+
+=back
+
+
+=head1 ENVIRONMENT
+
+=over 4
+
+=item PERL_MM_OPT
+
+Command line options used by C<MakeMaker-E<gt>new()>, and thus by
+C<WriteMakefile()>. The string is split on whitespace, and the result
+is processed before any actual command line arguments are processed.
+
+=item PERL_MM_USE_DEFAULT
+
+If set to a true value then MakeMaker's prompt function will
+always return the default without waiting for user input.
+
+=item PERL_CORE
+
+Same as the PERL_CORE parameter. The parameter overrides this.
+
+=back
+
+=head1 SEE ALSO
+
+L<Module::Build> is a pure-Perl alternative to MakeMaker which does
+not rely on make or any other external utility. It is easier to
+extend to suit your needs.
+
+L<Module::Install> is a wrapper around MakeMaker which adds features
+not normally available.
+
+L<ExtUtils::ModuleMaker> and L<Module::Starter> are both modules to
+help you setup your distribution.
+
+=head1 AUTHORS
+
+Andy Dougherty C<doughera at lafayette.edu>, Andreas KE<ouml>nig
+C<andreas.koenig at mind.de>, Tim Bunce C<timb at cpan.org>. VMS
+support by Charles Bailey C<bailey at newman.upenn.edu>. OS/2 support
+by Ilya Zakharevich C<ilya at math.ohio-state.edu>.
+
+Currently maintained by Michael G Schwern C<schwern at pobox.com>
+
+Send patches and ideas to C<makemaker at perl.org>.
+
+Send bug reports via http://rt.cpan.org/. Please send your
+generated Makefile along with your report.
+
+For more up-to-date information, see L<http://www.makemaker.org>.
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
+
+=cut
Copied: trunk/contrib/perl/lib/ExtUtils/Manifest.pm (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/Manifest.pm)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/Manifest.pm (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/Manifest.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,877 @@
+package ExtUtils::Manifest;
+
+require Exporter;
+use Config;
+use File::Basename;
+use File::Copy 'copy';
+use File::Find;
+use File::Spec;
+use Carp;
+use strict;
+
+use vars qw($VERSION @ISA @EXPORT_OK
+ $Is_MacOS $Is_VMS $Is_VMS_mode $Is_VMS_lc $Is_VMS_nodot
+ $Debug $Verbose $Quiet $MANIFEST $DEFAULT_MSKIP);
+
+$VERSION = '1.56';
+ at ISA=('Exporter');
+ at EXPORT_OK = qw(mkmanifest
+ manicheck filecheck fullcheck skipcheck
+ manifind maniread manicopy maniadd
+ maniskip
+ );
+
+$Is_MacOS = $^O eq 'MacOS';
+$Is_VMS = $^O eq 'VMS';
+$Is_VMS_mode = 0;
+$Is_VMS_lc = 0;
+$Is_VMS_nodot = 0; # No dots in dir names or double dots in files
+
+if ($Is_VMS) {
+ require VMS::Filespec if $Is_VMS;
+ my $vms_unix_rpt;
+ my $vms_efs;
+ my $vms_case;
+
+ $Is_VMS_mode = 1;
+ $Is_VMS_lc = 1;
+ $Is_VMS_nodot = 1;
+ if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
+ $vms_unix_rpt = VMS::Feature::current("filename_unix_report");
+ $vms_efs = VMS::Feature::current("efs_charset");
+ $vms_case = VMS::Feature::current("efs_case_preserve");
+ } else {
+ my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
+ my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || '';
+ my $efs_case = $ENV{'DECC$EFS_CASE_PRESERVE'} || '';
+ $vms_unix_rpt = $unix_rpt =~ /^[ET1]/i;
+ $vms_efs = $efs_charset =~ /^[ET1]/i;
+ $vms_case = $efs_case =~ /^[ET1]/i;
+ }
+ $Is_VMS_lc = 0 if ($vms_case);
+ $Is_VMS_mode = 0 if ($vms_unix_rpt);
+ $Is_VMS_nodot = 0 if ($vms_efs);
+}
+
+$Debug = $ENV{PERL_MM_MANIFEST_DEBUG} || 0;
+$Verbose = defined $ENV{PERL_MM_MANIFEST_VERBOSE} ?
+ $ENV{PERL_MM_MANIFEST_VERBOSE} : 1;
+$Quiet = 0;
+$MANIFEST = 'MANIFEST';
+
+$DEFAULT_MSKIP = File::Spec->catfile( dirname(__FILE__), "$MANIFEST.SKIP" );
+
+
+=head1 NAME
+
+ExtUtils::Manifest - utilities to write and check a MANIFEST file
+
+=head1 SYNOPSIS
+
+ use ExtUtils::Manifest qw(...funcs to import...);
+
+ mkmanifest();
+
+ my @missing_files = manicheck;
+ my @skipped = skipcheck;
+ my @extra_files = filecheck;
+ my($missing, $extra) = fullcheck;
+
+ my $found = manifind();
+
+ my $manifest = maniread();
+
+ manicopy($read,$target);
+
+ maniadd({$file => $comment, ...});
+
+
+=head1 DESCRIPTION
+
+=head2 Functions
+
+ExtUtils::Manifest exports no functions by default. The following are
+exported on request
+
+=over 4
+
+=item mkmanifest
+
+ mkmanifest();
+
+Writes all files in and below the current directory to your F<MANIFEST>.
+It works similar to the result of the Unix command
+
+ find . > MANIFEST
+
+All files that match any regular expression in a file F<MANIFEST.SKIP>
+(if it exists) are ignored.
+
+Any existing F<MANIFEST> file will be saved as F<MANIFEST.bak>.
+
+=cut
+
+sub _sort {
+ return sort { lc $a cmp lc $b } @_;
+}
+
+sub mkmanifest {
+ my $manimiss = 0;
+ my $read = (-r 'MANIFEST' && maniread()) or $manimiss++;
+ $read = {} if $manimiss;
+ local *M;
+ my $bakbase = $MANIFEST;
+ $bakbase =~ s/\./_/g if $Is_VMS_nodot; # avoid double dots
+ rename $MANIFEST, "$bakbase.bak" unless $manimiss;
+ open M, "> $MANIFEST" or die "Could not open $MANIFEST: $!";
+ my $skip = maniskip();
+ my $found = manifind();
+ my($key,$val,$file,%all);
+ %all = (%$found, %$read);
+ $all{$MANIFEST} = ($Is_VMS_mode ? "$MANIFEST\t\t" : '') .
+ 'This list of files'
+ if $manimiss; # add new MANIFEST to known file list
+ foreach $file (_sort keys %all) {
+ if ($skip->($file)) {
+ # Policy: only remove files if they're listed in MANIFEST.SKIP.
+ # Don't remove files just because they don't exist.
+ warn "Removed from $MANIFEST: $file\n" if $Verbose and exists $read->{$file};
+ next;
+ }
+ if ($Verbose){
+ warn "Added to $MANIFEST: $file\n" unless exists $read->{$file};
+ }
+ my $text = $all{$file};
+ $file = _unmacify($file);
+ my $tabs = (5 - (length($file)+1)/8);
+ $tabs = 1 if $tabs < 1;
+ $tabs = 0 unless $text;
+ if ($file =~ /\s/) {
+ $file =~ s/([\\'])/\\$1/g;
+ $file = "'$file'";
+ }
+ print M $file, "\t" x $tabs, $text, "\n";
+ }
+ close M;
+}
+
+# Geez, shouldn't this use File::Spec or File::Basename or something?
+# Why so careful about dependencies?
+sub clean_up_filename {
+ my $filename = shift;
+ $filename =~ s|^\./||;
+ $filename =~ s/^:([^:]+)$/$1/ if $Is_MacOS;
+ return $filename;
+}
+
+
+=item manifind
+
+ my $found = manifind();
+
+returns a hash reference. The keys of the hash are the files found
+below the current directory.
+
+=cut
+
+sub manifind {
+ my $p = shift || {};
+ my $found = {};
+
+ my $wanted = sub {
+ my $name = clean_up_filename($File::Find::name);
+ warn "Debug: diskfile $name\n" if $Debug;
+ return if -d $_;
+
+ if( $Is_VMS_lc ) {
+ $name =~ s#(.*)\.$#\L$1#;
+ $name = uc($name) if $name =~ /^MANIFEST(\.SKIP)?$/i;
+ }
+ $found->{$name} = "";
+ };
+
+ # We have to use "$File::Find::dir/$_" in preprocess, because
+ # $File::Find::name is unavailable.
+ # Also, it's okay to use / here, because MANIFEST files use Unix-style
+ # paths.
+ find({wanted => $wanted},
+ $Is_MacOS ? ":" : ".");
+
+ return $found;
+}
+
+
+=item manicheck
+
+ my @missing_files = manicheck();
+
+checks if all the files within a C<MANIFEST> in the current directory
+really do exist. If C<MANIFEST> and the tree below the current
+directory are in sync it silently returns an empty list.
+Otherwise it returns a list of files which are listed in the
+C<MANIFEST> but missing from the directory, and by default also
+outputs these names to STDERR.
+
+=cut
+
+sub manicheck {
+ return _check_files();
+}
+
+
+=item filecheck
+
+ my @extra_files = filecheck();
+
+finds files below the current directory that are not mentioned in the
+C<MANIFEST> file. An optional file C<MANIFEST.SKIP> will be
+consulted. Any file matching a regular expression in such a file will
+not be reported as missing in the C<MANIFEST> file. The list of any
+extraneous files found is returned, and by default also reported to
+STDERR.
+
+=cut
+
+sub filecheck {
+ return _check_manifest();
+}
+
+
+=item fullcheck
+
+ my($missing, $extra) = fullcheck();
+
+does both a manicheck() and a filecheck(), returning then as two array
+refs.
+
+=cut
+
+sub fullcheck {
+ return [_check_files()], [_check_manifest()];
+}
+
+
+=item skipcheck
+
+ my @skipped = skipcheck();
+
+lists all the files that are skipped due to your C<MANIFEST.SKIP>
+file.
+
+=cut
+
+sub skipcheck {
+ my($p) = @_;
+ my $found = manifind();
+ my $matches = maniskip();
+
+ my @skipped = ();
+ foreach my $file (_sort keys %$found){
+ if (&$matches($file)){
+ warn "Skipping $file\n";
+ push @skipped, $file;
+ next;
+ }
+ }
+
+ return @skipped;
+}
+
+
+sub _check_files {
+ my $p = shift;
+ my $dosnames=(defined(&Dos::UseLFN) && Dos::UseLFN()==0);
+ my $read = maniread() || {};
+ my $found = manifind($p);
+
+ my(@missfile) = ();
+ foreach my $file (_sort keys %$read){
+ warn "Debug: manicheck checking from $MANIFEST $file\n" if $Debug;
+ if ($dosnames){
+ $file = lc $file;
+ $file =~ s=(\.(\w|-)+)=substr ($1,0,4)=ge;
+ $file =~ s=((\w|-)+)=substr ($1,0,8)=ge;
+ }
+ unless ( exists $found->{$file} ) {
+ warn "No such file: $file\n" unless $Quiet;
+ push @missfile, $file;
+ }
+ }
+
+ return @missfile;
+}
+
+
+sub _check_manifest {
+ my($p) = @_;
+ my $read = maniread() || {};
+ my $found = manifind($p);
+ my $skip = maniskip();
+
+ my @missentry = ();
+ foreach my $file (_sort keys %$found){
+ next if $skip->($file);
+ warn "Debug: manicheck checking from disk $file\n" if $Debug;
+ unless ( exists $read->{$file} ) {
+ my $canon = $Is_MacOS ? "\t" . _unmacify($file) : '';
+ warn "Not in $MANIFEST: $file$canon\n" unless $Quiet;
+ push @missentry, $file;
+ }
+ }
+
+ return @missentry;
+}
+
+
+=item maniread
+
+ my $manifest = maniread();
+ my $manifest = maniread($manifest_file);
+
+reads a named C<MANIFEST> file (defaults to C<MANIFEST> in the current
+directory) and returns a HASH reference with files being the keys and
+comments being the values of the HASH. Blank lines and lines which
+start with C<#> in the C<MANIFEST> file are discarded.
+
+=cut
+
+sub maniread {
+ my ($mfile) = @_;
+ $mfile ||= $MANIFEST;
+ my $read = {};
+ local *M;
+ unless (open M, "< $mfile"){
+ warn "Problem opening $mfile: $!";
+ return $read;
+ }
+ local $_;
+ while (<M>){
+ chomp;
+ next if /^\s*#/;
+
+ my($file, $comment);
+
+ # filename may contain spaces if enclosed in ''
+ # (in which case, \\ and \' are escapes)
+ if (($file, $comment) = /^'(\\[\\']|.+)+'\s*(.*)/) {
+ $file =~ s/\\([\\'])/$1/g;
+ }
+ else {
+ ($file, $comment) = /^(\S+)\s*(.*)/;
+ }
+ next unless $file;
+
+ if ($Is_MacOS) {
+ $file = _macify($file);
+ $file =~ s/\\([0-3][0-7][0-7])/sprintf("%c", oct($1))/ge;
+ }
+ elsif ($Is_VMS_mode) {
+ require File::Basename;
+ my($base,$dir) = File::Basename::fileparse($file);
+ # Resolve illegal file specifications in the same way as tar
+ if ($Is_VMS_nodot) {
+ $dir =~ tr/./_/;
+ my(@pieces) = split(/\./,$base);
+ if (@pieces > 2)
+ { $base = shift(@pieces) . '.' . join('_', at pieces); }
+ my $okfile = "$dir$base";
+ warn "Debug: Illegal name $file changed to $okfile\n" if $Debug;
+ $file = $okfile;
+ }
+ $file = lc($file)
+ unless $Is_VMS_lc &&($file =~ /^MANIFEST(\.SKIP)?$/);
+ }
+
+ $read->{$file} = $comment;
+ }
+ close M;
+ $read;
+}
+
+=item maniskip
+
+ my $skipchk = maniskip();
+ my $skipchk = maniskip($manifest_skip_file);
+
+ if ($skipchk->($file)) { .. }
+
+reads a named C<MANIFEST.SKIP> file (defaults to C<MANIFEST.SKIP> in
+the current directory) and returns a CODE reference that tests whether
+a given filename should be skipped.
+
+=cut
+
+# returns an anonymous sub that decides if an argument matches
+sub maniskip {
+ my @skip ;
+ my $mfile = shift || "$MANIFEST.SKIP";
+ _check_mskip_directives($mfile) if -f $mfile;
+ local(*M, $_);
+ open M, "< $mfile" or open M, "< $DEFAULT_MSKIP" or return sub {0};
+ while (<M>){
+ chomp;
+ s/\r//;
+ next if /^#/;
+ next if /^\s*$/;
+ s/^'//;
+ s/'$//;
+ push @skip, _macify($_);
+ }
+ close M;
+ return sub {0} unless (scalar @skip > 0);
+
+ my $opts = $Is_VMS_mode ? '(?i)' : '';
+
+ # Make sure each entry is isolated in its own parentheses, in case
+ # any of them contain alternations
+ my $regex = join '|', map "(?:$_)", @skip;
+
+ return sub { $_[0] =~ qr{$opts$regex} };
+}
+
+# checks for the special directives
+# #!include_default
+# #!include /path/to/some/manifest.skip
+# in a custom MANIFEST.SKIP for, for including
+# the content of, respectively, the default MANIFEST.SKIP
+# and an external manifest.skip file
+sub _check_mskip_directives {
+ my $mfile = shift;
+ local (*M, $_);
+ my @lines = ();
+ my $flag = 0;
+ unless (open M, "< $mfile") {
+ warn "Problem opening $mfile: $!";
+ return;
+ }
+ while (<M>) {
+ if (/^#!include_default\s*$/) {
+ if (my @default = _include_mskip_file()) {
+ push @lines, @default;
+ warn "Debug: Including default MANIFEST.SKIP\n" if $Debug;
+ $flag++;
+ }
+ next;
+ }
+ if (/^#!include\s+(.*)\s*$/) {
+ my $external_file = $1;
+ if (my @external = _include_mskip_file($external_file)) {
+ push @lines, @external;
+ warn "Debug: Including external $external_file\n" if $Debug;
+ $flag++;
+ }
+ next;
+ }
+ push @lines, $_;
+ }
+ close M;
+ return unless $flag;
+ my $bakbase = $mfile;
+ $bakbase =~ s/\./_/g if $Is_VMS_nodot; # avoid double dots
+ rename $mfile, "$bakbase.bak";
+ warn "Debug: Saving original $mfile as $bakbase.bak\n" if $Debug;
+ unless (open M, "> $mfile") {
+ warn "Problem opening $mfile: $!";
+ return;
+ }
+ print M $_ for (@lines);
+ close M;
+ return;
+}
+
+# returns an array containing the lines of an external
+# manifest.skip file, if given, or $DEFAULT_MSKIP
+sub _include_mskip_file {
+ my $mskip = shift || $DEFAULT_MSKIP;
+ unless (-f $mskip) {
+ warn qq{Included file "$mskip" not found - skipping};
+ return;
+ }
+ local (*M, $_);
+ unless (open M, "< $mskip") {
+ warn "Problem opening $mskip: $!";
+ return;
+ }
+ my @lines = ();
+ push @lines, "\n#!start included $mskip\n";
+ push @lines, $_ while <M>;
+ close M;
+ push @lines, "#!end included $mskip\n\n";
+ return @lines;
+}
+
+=item manicopy
+
+ manicopy(\%src, $dest_dir);
+ manicopy(\%src, $dest_dir, $how);
+
+Copies the files that are the keys in %src to the $dest_dir. %src is
+typically returned by the maniread() function.
+
+ manicopy( maniread(), $dest_dir );
+
+This function is useful for producing a directory tree identical to the
+intended distribution tree.
+
+$how can be used to specify a different methods of "copying". Valid
+values are C<cp>, which actually copies the files, C<ln> which creates
+hard links, and C<best> which mostly links the files but copies any
+symbolic link to make a tree without any symbolic link. C<cp> is the
+default.
+
+=cut
+
+sub manicopy {
+ my($read,$target,$how)=@_;
+ croak "manicopy() called without target argument" unless defined $target;
+ $how ||= 'cp';
+ require File::Path;
+ require File::Basename;
+
+ $target = VMS::Filespec::unixify($target) if $Is_VMS_mode;
+ File::Path::mkpath([ $target ],! $Quiet,$Is_VMS ? undef : 0755);
+ foreach my $file (keys %$read){
+ if ($Is_MacOS) {
+ if ($file =~ m!:!) {
+ my $dir = _maccat($target, $file);
+ $dir =~ s/[^:]+$//;
+ File::Path::mkpath($dir,1,0755);
+ }
+ cp_if_diff($file, _maccat($target, $file), $how);
+ } else {
+ $file = VMS::Filespec::unixify($file) if $Is_VMS_mode;
+ if ($file =~ m!/!) { # Ilya, that hurts, I fear, or maybe not?
+ my $dir = File::Basename::dirname($file);
+ $dir = VMS::Filespec::unixify($dir) if $Is_VMS_mode;
+ File::Path::mkpath(["$target/$dir"],! $Quiet,$Is_VMS ? undef : 0755);
+ }
+ cp_if_diff($file, "$target/$file", $how);
+ }
+ }
+}
+
+sub cp_if_diff {
+ my($from, $to, $how)=@_;
+ if (! -f $from) {
+ carp "$from not found";
+ return;
+ }
+ my($diff) = 0;
+ local(*F,*T);
+ open(F,"< $from\0") or die "Can't read $from: $!\n";
+ if (open(T,"< $to\0")) {
+ local $_;
+ while (<F>) { $diff++,last if $_ ne <T>; }
+ $diff++ unless eof(T);
+ close T;
+ }
+ else { $diff++; }
+ close F;
+ if ($diff) {
+ if (-e $to) {
+ unlink($to) or confess "unlink $to: $!";
+ }
+ STRICT_SWITCH: {
+ best($from,$to), last STRICT_SWITCH if $how eq 'best';
+ cp($from,$to), last STRICT_SWITCH if $how eq 'cp';
+ ln($from,$to), last STRICT_SWITCH if $how eq 'ln';
+ croak("ExtUtils::Manifest::cp_if_diff " .
+ "called with illegal how argument [$how]. " .
+ "Legal values are 'best', 'cp', and 'ln'.");
+ }
+ }
+}
+
+sub cp {
+ my ($srcFile, $dstFile) = @_;
+ my ($access,$mod) = (stat $srcFile)[8,9];
+
+ copy($srcFile,$dstFile);
+ utime $access, $mod + ($Is_VMS ? 1 : 0), $dstFile;
+ _manicopy_chmod($srcFile, $dstFile);
+}
+
+
+sub ln {
+ my ($srcFile, $dstFile) = @_;
+ # Fix-me - VMS can support links.
+ return &cp if $Is_VMS or ($^O eq 'MSWin32' and Win32::IsWin95());
+ link($srcFile, $dstFile);
+
+ unless( _manicopy_chmod($srcFile, $dstFile) ) {
+ unlink $dstFile;
+ return;
+ }
+ 1;
+}
+
+# 1) Strip off all group and world permissions.
+# 2) Let everyone read it.
+# 3) If the owner can execute it, everyone can.
+sub _manicopy_chmod {
+ my($srcFile, $dstFile) = @_;
+
+ my $perm = 0444 | (stat $srcFile)[2] & 0700;
+ chmod( $perm | ( $perm & 0100 ? 0111 : 0 ), $dstFile );
+}
+
+# Files that are often modified in the distdir. Don't hard link them.
+my @Exceptions = qw(MANIFEST META.yml SIGNATURE);
+sub best {
+ my ($srcFile, $dstFile) = @_;
+
+ my $is_exception = grep $srcFile =~ /$_/, @Exceptions;
+ if ($is_exception or !$Config{d_link} or -l $srcFile) {
+ cp($srcFile, $dstFile);
+ } else {
+ ln($srcFile, $dstFile) or cp($srcFile, $dstFile);
+ }
+}
+
+sub _macify {
+ my($file) = @_;
+
+ return $file unless $Is_MacOS;
+
+ $file =~ s|^\./||;
+ if ($file =~ m|/|) {
+ $file =~ s|/+|:|g;
+ $file = ":$file";
+ }
+
+ $file;
+}
+
+sub _maccat {
+ my($f1, $f2) = @_;
+
+ return "$f1/$f2" unless $Is_MacOS;
+
+ $f1 .= ":$f2";
+ $f1 =~ s/([^:]:):/$1/g;
+ return $f1;
+}
+
+sub _unmacify {
+ my($file) = @_;
+
+ return $file unless $Is_MacOS;
+
+ $file =~ s|^:||;
+ $file =~ s|([/ \n])|sprintf("\\%03o", unpack("c", $1))|ge;
+ $file =~ y|:|/|;
+
+ $file;
+}
+
+
+=item maniadd
+
+ maniadd({ $file => $comment, ...});
+
+Adds an entry to an existing F<MANIFEST> unless its already there.
+
+$file will be normalized (ie. Unixified). B<UNIMPLEMENTED>
+
+=cut
+
+sub maniadd {
+ my($additions) = shift;
+
+ _normalize($additions);
+ _fix_manifest($MANIFEST);
+
+ my $manifest = maniread();
+ my @needed = grep { !exists $manifest->{$_} } keys %$additions;
+ return 1 unless @needed;
+
+ open(MANIFEST, ">>$MANIFEST") or
+ die "maniadd() could not open $MANIFEST: $!";
+
+ foreach my $file (_sort @needed) {
+ my $comment = $additions->{$file} || '';
+ if ($file =~ /\s/) {
+ $file =~ s/([\\'])/\\$1/g;
+ $file = "'$file'";
+ }
+ printf MANIFEST "%-40s %s\n", $file, $comment;
+ }
+ close MANIFEST or die "Error closing $MANIFEST: $!";
+
+ return 1;
+}
+
+
+# Sometimes MANIFESTs are missing a trailing newline. Fix this.
+sub _fix_manifest {
+ my $manifest_file = shift;
+
+ open MANIFEST, $MANIFEST or die "Could not open $MANIFEST: $!";
+
+ # Yes, we should be using seek(), but I'd like to avoid loading POSIX
+ # to get SEEK_*
+ my @manifest = <MANIFEST>;
+ close MANIFEST;
+
+ unless( $manifest[-1] =~ /\n\z/ ) {
+ open MANIFEST, ">>$MANIFEST" or die "Could not open $MANIFEST: $!";
+ print MANIFEST "\n";
+ close MANIFEST;
+ }
+}
+
+
+# UNIMPLEMENTED
+sub _normalize {
+ return;
+}
+
+
+=back
+
+=head2 MANIFEST
+
+A list of files in the distribution, one file per line. The MANIFEST
+always uses Unix filepath conventions even if you're not on Unix. This
+means F<foo/bar> style not F<foo\bar>.
+
+Anything between white space and an end of line within a C<MANIFEST>
+file is considered to be a comment. Any line beginning with # is also
+a comment. Beginning with ExtUtils::Manifest 1.52, a filename may
+contain whitespace characters if it is enclosed in single quotes; single
+quotes or backslashes in that filename must be backslash-escaped.
+
+ # this a comment
+ some/file
+ some/other/file comment about some/file
+ 'some/third file' comment
+
+
+=head2 MANIFEST.SKIP
+
+The file MANIFEST.SKIP may contain regular expressions of files that
+should be ignored by mkmanifest() and filecheck(). The regular
+expressions should appear one on each line. Blank lines and lines
+which start with C<#> are skipped. Use C<\#> if you need a regular
+expression to start with a C<#>.
+
+For example:
+
+ # Version control files and dirs.
+ \bRCS\b
+ \bCVS\b
+ ,v$
+ \B\.svn\b
+
+ # Makemaker generated files and dirs.
+ ^MANIFEST\.
+ ^Makefile$
+ ^blib/
+ ^MakeMaker-\d
+
+ # Temp, old and emacs backup files.
+ ~$
+ \.old$
+ ^#.*#$
+ ^\.#
+
+If no MANIFEST.SKIP file is found, a default set of skips will be
+used, similar to the example above. If you want nothing skipped,
+simply make an empty MANIFEST.SKIP file.
+
+In one's own MANIFEST.SKIP file, certain directives
+can be used to include the contents of other MANIFEST.SKIP
+files. At present two such directives are recognized.
+
+=over 4
+
+=item #!include_default
+
+This inserts the contents of the default MANIFEST.SKIP file
+
+=item #!include /Path/to/another/manifest.skip
+
+This inserts the contents of the specified external file
+
+=back
+
+The included contents will be inserted into the MANIFEST.SKIP
+file in between I<#!start included /path/to/manifest.skip>
+and I<#!end included /path/to/manifest.skip> markers.
+The original MANIFEST.SKIP is saved as MANIFEST.SKIP.bak.
+
+=head2 EXPORT_OK
+
+C<&mkmanifest>, C<&manicheck>, C<&filecheck>, C<&fullcheck>,
+C<&maniread>, and C<&manicopy> are exportable.
+
+=head2 GLOBAL VARIABLES
+
+C<$ExtUtils::Manifest::MANIFEST> defaults to C<MANIFEST>. Changing it
+results in both a different C<MANIFEST> and a different
+C<MANIFEST.SKIP> file. This is useful if you want to maintain
+different distributions for different audiences (say a user version
+and a developer version including RCS).
+
+C<$ExtUtils::Manifest::Quiet> defaults to 0. If set to a true value,
+all functions act silently.
+
+C<$ExtUtils::Manifest::Debug> defaults to 0. If set to a true value,
+or if PERL_MM_MANIFEST_DEBUG is true, debugging output will be
+produced.
+
+=head1 DIAGNOSTICS
+
+All diagnostic output is sent to C<STDERR>.
+
+=over 4
+
+=item C<Not in MANIFEST:> I<file>
+
+is reported if a file is found which is not in C<MANIFEST>.
+
+=item C<Skipping> I<file>
+
+is reported if a file is skipped due to an entry in C<MANIFEST.SKIP>.
+
+=item C<No such file:> I<file>
+
+is reported if a file mentioned in a C<MANIFEST> file does not
+exist.
+
+=item C<MANIFEST:> I<$!>
+
+is reported if C<MANIFEST> could not be opened.
+
+=item C<Added to MANIFEST:> I<file>
+
+is reported by mkmanifest() if $Verbose is set and a file is added
+to MANIFEST. $Verbose is set to 1 by default.
+
+=back
+
+=head1 ENVIRONMENT
+
+=over 4
+
+=item B<PERL_MM_MANIFEST_DEBUG>
+
+Turns on debugging
+
+=back
+
+=head1 SEE ALSO
+
+L<ExtUtils::MakeMaker> which has handy targets for most of the functionality.
+
+=head1 AUTHOR
+
+Andreas Koenig C<andreas.koenig at anima.de>
+
+Maintained by Michael G Schwern C<schwern at pobox.com> within the
+ExtUtils-MakeMaker package and, as a separate CPAN package, by
+Randy Kobes C<r.kobes at uwinnipeg.ca>.
+
+=cut
+
+1;
Copied: trunk/contrib/perl/lib/ExtUtils/Mkbootstrap.pm (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/Mkbootstrap.pm)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/Mkbootstrap.pm (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/Mkbootstrap.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,109 @@
+package ExtUtils::Mkbootstrap;
+
+# There's just too much Dynaloader incest here to turn on strict vars.
+use strict 'refs';
+
+our $VERSION = '6.55_02';
+
+require Exporter;
+our @ISA = ('Exporter');
+our @EXPORT = ('&Mkbootstrap');
+
+use Config;
+
+our $Verbose = 0;
+
+
+sub Mkbootstrap {
+ my($baseext, @bsloadlibs)=@_;
+ @bsloadlibs = grep($_, @bsloadlibs); # strip empty libs
+
+ print STDOUT " bsloadlibs=@bsloadlibs\n" if $Verbose;
+
+ # We need DynaLoader here because we and/or the *_BS file may
+ # call dl_findfile(). We don't say `use' here because when
+ # first building perl extensions the DynaLoader will not have
+ # been built when MakeMaker gets first used.
+ require DynaLoader;
+
+ rename "$baseext.bs", "$baseext.bso"
+ if -s "$baseext.bs";
+
+ if (-f "${baseext}_BS"){
+ $_ = "${baseext}_BS";
+ package DynaLoader; # execute code as if in DynaLoader
+ local($osname, $dlsrc) = (); # avoid warnings
+ ($osname, $dlsrc) = @Config::Config{qw(osname dlsrc)};
+ $bscode = "";
+ unshift @INC, ".";
+ require $_;
+ shift @INC;
+ }
+
+ if ($Config{'dlsrc'} =~ /^dl_dld/){
+ package DynaLoader;
+ push(@dl_resolve_using, dl_findfile('-lc'));
+ }
+
+ my(@all) = (@bsloadlibs, @DynaLoader::dl_resolve_using);
+ my($method) = '';
+ if (@all){
+ open my $bs, ">", "$baseext.bs"
+ or die "Unable to open $baseext.bs: $!";
+ print STDOUT "Writing $baseext.bs\n";
+ print STDOUT " containing: @all" if $Verbose;
+ print $bs "# $baseext DynaLoader bootstrap file for $^O architecture.\n";
+ print $bs "# Do not edit this file, changes will be lost.\n";
+ print $bs "# This file was automatically generated by the\n";
+ print $bs "# Mkbootstrap routine in ExtUtils::Mkbootstrap (v$VERSION).\n";
+ print $bs "\@DynaLoader::dl_resolve_using = ";
+ # If @all contains names in the form -lxxx or -Lxxx then it's asking for
+ # runtime library location so we automatically add a call to dl_findfile()
+ if (" @all" =~ m/ -[lLR]/){
+ print $bs " dl_findfile(qw(\n @all\n ));\n";
+ }else{
+ print $bs " qw(@all);\n";
+ }
+ # write extra code if *_BS says so
+ print $bs $DynaLoader::bscode if $DynaLoader::bscode;
+ print $bs "\n1;\n";
+ close $bs;
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+ExtUtils::Mkbootstrap - make a bootstrap file for use by DynaLoader
+
+=head1 SYNOPSIS
+
+C<Mkbootstrap>
+
+=head1 DESCRIPTION
+
+Mkbootstrap typically gets called from an extension Makefile.
+
+There is no C<*.bs> file supplied with the extension. Instead, there may
+be a C<*_BS> file which has code for the special cases, like posix for
+berkeley db on the NeXT.
+
+This file will get parsed, and produce a maybe empty
+C<@DynaLoader::dl_resolve_using> array for the current architecture.
+That will be extended by $BSLOADLIBS, which was computed by
+ExtUtils::Liblist::ext(). If this array still is empty, we do nothing,
+else we write a .bs file with an C<@DynaLoader::dl_resolve_using>
+array.
+
+The C<*_BS> file can put some code into the generated C<*.bs> file by
+placing it in C<$bscode>. This is a handy 'escape' mechanism that may
+prove useful in complex situations.
+
+If @DynaLoader::dl_resolve_using contains C<-L*> or C<-l*> entries then
+Mkbootstrap will automatically add a dl_findfile() call to the
+generated C<*.bs> file.
+
+=cut
Copied: trunk/contrib/perl/lib/ExtUtils/Mksymlists.pm (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/Mksymlists.pm)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/Mksymlists.pm (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/Mksymlists.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,312 @@
+package ExtUtils::Mksymlists;
+
+use 5.006;
+use strict qw[ subs refs ];
+# no strict 'vars'; # until filehandles are exempted
+
+use Carp;
+use Exporter;
+use Config;
+
+our @ISA = qw(Exporter);
+our @EXPORT = qw(&Mksymlists);
+our $VERSION = '6.55_02';
+
+sub Mksymlists {
+ my(%spec) = @_;
+ my($osname) = $^O;
+
+ croak("Insufficient information specified to Mksymlists")
+ unless ( $spec{NAME} or
+ ($spec{FILE} and ($spec{DL_FUNCS} or $spec{FUNCLIST})) );
+
+ $spec{DL_VARS} = [] unless $spec{DL_VARS};
+ ($spec{FILE} = $spec{NAME}) =~ s/.*::// unless $spec{FILE};
+ $spec{FUNCLIST} = [] unless $spec{FUNCLIST};
+ $spec{DL_FUNCS} = { $spec{NAME} => [] }
+ unless ( ($spec{DL_FUNCS} and keys %{$spec{DL_FUNCS}}) or
+ @{$spec{FUNCLIST}});
+ if (defined $spec{DL_FUNCS}) {
+ foreach my $package (keys %{$spec{DL_FUNCS}}) {
+ my($packprefix,$bootseen);
+ ($packprefix = $package) =~ s/\W/_/g;
+ foreach my $sym (@{$spec{DL_FUNCS}->{$package}}) {
+ if ($sym =~ /^boot_/) {
+ push(@{$spec{FUNCLIST}},$sym);
+ $bootseen++;
+ }
+ else {
+ push(@{$spec{FUNCLIST}},"XS_${packprefix}_$sym");
+ }
+ }
+ push(@{$spec{FUNCLIST}},"boot_$packprefix") unless $bootseen;
+ }
+ }
+
+# We'll need this if we ever add any OS which uses mod2fname
+# not as pseudo-builtin.
+# require DynaLoader;
+ if (defined &DynaLoader::mod2fname and not $spec{DLBASE}) {
+ $spec{DLBASE} = DynaLoader::mod2fname([ split(/::/,$spec{NAME}) ]);
+ }
+
+ if ($osname eq 'aix') { _write_aix(\%spec); }
+ elsif ($osname eq 'MacOS'){ _write_aix(\%spec) }
+ elsif ($osname eq 'VMS') { _write_vms(\%spec) }
+ elsif ($osname eq 'os2') { _write_os2(\%spec) }
+ elsif ($osname eq 'MSWin32') { _write_win32(\%spec) }
+ else {
+ croak("Don't know how to create linker option file for $osname\n");
+ }
+}
+
+
+sub _write_aix {
+ my($data) = @_;
+
+ rename "$data->{FILE}.exp", "$data->{FILE}.exp_old";
+
+ open( my $exp, ">", "$data->{FILE}.exp")
+ or croak("Can't create $data->{FILE}.exp: $!\n");
+ print $exp join("\n",@{$data->{DL_VARS}}, "\n") if @{$data->{DL_VARS}};
+ print $exp join("\n",@{$data->{FUNCLIST}}, "\n") if @{$data->{FUNCLIST}};
+ close $exp;
+}
+
+
+sub _write_os2 {
+ my($data) = @_;
+ require Config;
+ my $threaded = ($Config::Config{archname} =~ /-thread/ ? " threaded" : "");
+
+ if (not $data->{DLBASE}) {
+ ($data->{DLBASE} = $data->{NAME}) =~ s/.*:://;
+ $data->{DLBASE} = substr($data->{DLBASE},0,7) . '_';
+ }
+ my $distname = $data->{DISTNAME} || $data->{NAME};
+ $distname = "Distribution $distname";
+ my $patchlevel = " pl$Config{perl_patchlevel}" || '';
+ my $comment = sprintf "Perl (v%s%s%s) module %s",
+ $Config::Config{version}, $threaded, $patchlevel, $data->{NAME};
+ chomp $comment;
+ if ($data->{INSTALLDIRS} and $data->{INSTALLDIRS} eq 'perl') {
+ $distname = 'perl5-porters at perl.org';
+ $comment = "Core $comment";
+ }
+ $comment = "$comment (Perl-config: $Config{config_args})";
+ $comment = substr($comment, 0, 200) . "...)" if length $comment > 203;
+ rename "$data->{FILE}.def", "$data->{FILE}_def.old";
+
+ open(my $def, ">", "$data->{FILE}.def")
+ or croak("Can't create $data->{FILE}.def: $!\n");
+ print $def "LIBRARY '$data->{DLBASE}' INITINSTANCE TERMINSTANCE\n";
+ print $def "DESCRIPTION '\@#$distname:$data->{VERSION}#\@ $comment'\n";
+ print $def "CODE LOADONCALL\n";
+ print $def "DATA LOADONCALL NONSHARED MULTIPLE\n";
+ print $def "EXPORTS\n ";
+ print $def join("\n ",@{$data->{DL_VARS}}, "\n") if @{$data->{DL_VARS}};
+ print $def join("\n ",@{$data->{FUNCLIST}}, "\n") if @{$data->{FUNCLIST}};
+ if (%{$data->{IMPORTS}}) {
+ print $def "IMPORTS\n";
+ my ($name, $exp);
+ while (($name, $exp)= each %{$data->{IMPORTS}}) {
+ print $def " $name=$exp\n";
+ }
+ }
+ close $def;
+}
+
+sub _write_win32 {
+ my($data) = @_;
+
+ require Config;
+ if (not $data->{DLBASE}) {
+ ($data->{DLBASE} = $data->{NAME}) =~ s/.*:://;
+ $data->{DLBASE} = substr($data->{DLBASE},0,7) . '_';
+ }
+ rename "$data->{FILE}.def", "$data->{FILE}_def.old";
+
+ open( my $def, ">", "$data->{FILE}.def" )
+ or croak("Can't create $data->{FILE}.def: $!\n");
+ # put library name in quotes (it could be a keyword, like 'Alias')
+ if ($Config::Config{'cc'} !~ /^gcc/i) {
+ print $def "LIBRARY \"$data->{DLBASE}\"\n";
+ }
+ print $def "EXPORTS\n ";
+ my @syms;
+ # Export public symbols both with and without underscores to
+ # ensure compatibility between DLLs from different compilers
+ # NOTE: DynaLoader itself only uses the names without underscores,
+ # so this is only to cover the case when the extension DLL may be
+ # linked to directly from C. GSAR 97-07-10
+ if ($Config::Config{'cc'} =~ /^bcc/i) {
+ for (@{$data->{DL_VARS}}, @{$data->{FUNCLIST}}) {
+ push @syms, "_$_", "$_ = _$_";
+ }
+ }
+ else {
+ for (@{$data->{DL_VARS}}, @{$data->{FUNCLIST}}) {
+ push @syms, "$_", "_$_ = $_";
+ }
+ }
+ print $def join("\n ", at syms, "\n") if @syms;
+ if (%{$data->{IMPORTS}}) {
+ print $def "IMPORTS\n";
+ my ($name, $exp);
+ while (($name, $exp)= each %{$data->{IMPORTS}}) {
+ print $def " $name=$exp\n";
+ }
+ }
+ close $def;
+}
+
+
+sub _write_vms {
+ my($data) = @_;
+
+ require Config; # a reminder for once we do $^O
+ require ExtUtils::XSSymSet;
+
+ my($isvax) = $Config::Config{'archname'} =~ /VAX/i;
+ my($set) = new ExtUtils::XSSymSet;
+
+ rename "$data->{FILE}.opt", "$data->{FILE}.opt_old";
+
+ open(my $opt,">", "$data->{FILE}.opt")
+ or croak("Can't create $data->{FILE}.opt: $!\n");
+
+ # Options file declaring universal symbols
+ # Used when linking shareable image for dynamic extension,
+ # or when linking PerlShr into which we've added this package
+ # as a static extension
+ # We don't do anything to preserve order, so we won't relax
+ # the GSMATCH criteria for a dynamic extension
+
+ print $opt "case_sensitive=yes\n"
+ if $Config::Config{d_vms_case_sensitive_symbols};
+
+ foreach my $sym (@{$data->{FUNCLIST}}) {
+ my $safe = $set->addsym($sym);
+ if ($isvax) { print $opt "UNIVERSAL=$safe\n" }
+ else { print $opt "SYMBOL_VECTOR=($safe=PROCEDURE)\n"; }
+ }
+
+ foreach my $sym (@{$data->{DL_VARS}}) {
+ my $safe = $set->addsym($sym);
+ print $opt "PSECT_ATTR=${sym},PIC,OVR,RD,NOEXE,WRT,NOSHR\n";
+ if ($isvax) { print $opt "UNIVERSAL=$safe\n" }
+ else { print $opt "SYMBOL_VECTOR=($safe=DATA)\n"; }
+ }
+
+ close $opt;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+ExtUtils::Mksymlists - write linker options files for dynamic extension
+
+=head1 SYNOPSIS
+
+ use ExtUtils::Mksymlists;
+ Mksymlists({ NAME => $name ,
+ DL_VARS => [ $var1, $var2, $var3 ],
+ DL_FUNCS => { $pkg1 => [ $func1, $func2 ],
+ $pkg2 => [ $func3 ] });
+
+=head1 DESCRIPTION
+
+C<ExtUtils::Mksymlists> produces files used by the linker under some OSs
+during the creation of shared libraries for dynamic extensions. It is
+normally called from a MakeMaker-generated Makefile when the extension
+is built. The linker option file is generated by calling the function
+C<Mksymlists>, which is exported by default from C<ExtUtils::Mksymlists>.
+It takes one argument, a list of key-value pairs, in which the following
+keys are recognized:
+
+=over 4
+
+=item DLBASE
+
+This item specifies the name by which the linker knows the
+extension, which may be different from the name of the
+extension itself (for instance, some linkers add an '_' to the
+name of the extension). If it is not specified, it is derived
+from the NAME attribute. It is presently used only by OS2 and Win32.
+
+=item DL_FUNCS
+
+This is identical to the DL_FUNCS attribute available via MakeMaker,
+from which it is usually taken. Its value is a reference to an
+associative array, in which each key is the name of a package, and
+each value is an a reference to an array of function names which
+should be exported by the extension. For instance, one might say
+C<DL_FUNCS =E<gt> { Homer::Iliad =E<gt> [ qw(trojans greeks) ],
+Homer::Odyssey =E<gt> [ qw(travellers family suitors) ] }>. The
+function names should be identical to those in the XSUB code;
+C<Mksymlists> will alter the names written to the linker option
+file to match the changes made by F<xsubpp>. In addition, if
+none of the functions in a list begin with the string B<boot_>,
+C<Mksymlists> will add a bootstrap function for that package,
+just as xsubpp does. (If a B<boot_E<lt>pkgE<gt>> function is
+present in the list, it is passed through unchanged.) If
+DL_FUNCS is not specified, it defaults to the bootstrap
+function for the extension specified in NAME.
+
+=item DL_VARS
+
+This is identical to the DL_VARS attribute available via MakeMaker,
+and, like DL_FUNCS, it is usually specified via MakeMaker. Its
+value is a reference to an array of variable names which should
+be exported by the extension.
+
+=item FILE
+
+This key can be used to specify the name of the linker option file
+(minus the OS-specific extension), if for some reason you do not
+want to use the default value, which is the last word of the NAME
+attribute (I<e.g.> for C<Tk::Canvas>, FILE defaults to C<Canvas>).
+
+=item FUNCLIST
+
+This provides an alternate means to specify function names to be
+exported from the extension. Its value is a reference to an
+array of function names to be exported by the extension. These
+names are passed through unaltered to the linker options file.
+Specifying a value for the FUNCLIST attribute suppresses automatic
+generation of the bootstrap function for the package. To still create
+the bootstrap name you have to specify the package name in the
+DL_FUNCS hash:
+
+ Mksymlists({ NAME => $name ,
+ FUNCLIST => [ $func1, $func2 ],
+ DL_FUNCS => { $pkg => [] } });
+
+
+=item IMPORTS
+
+This attribute is used to specify names to be imported into the
+extension. It is currently only used by OS/2 and Win32.
+
+=item NAME
+
+This gives the name of the extension (I<e.g.> C<Tk::Canvas>) for which
+the linker option file will be produced.
+
+=back
+
+When calling C<Mksymlists>, one should always specify the NAME
+attribute. In most cases, this is all that's necessary. In
+the case of unusual extensions, however, the other attributes
+can be used to provide additional information to the linker.
+
+=head1 AUTHOR
+
+Charles Bailey I<E<lt>bailey at newman.upenn.eduE<gt>>
+
+=head1 REVISION
+
+Last revised 14-Feb-1996, for Perl 5.002.
Copied: trunk/contrib/perl/lib/ExtUtils/NOTES (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/NOTES)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/NOTES (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/NOTES 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,96 @@
+The Simplified MakeMaker class hierarchy
+****************************************
+
+What most people need to know.
+
+(Subclasses on top.)
+
+ MY
+ |
+ ExtUtils::MakeMaker
+ |
+ ExtUtils::MM_{Current OS}
+ |
+ ExtUtils::MM_Unix
+ |
+ ExtUtils::MM_Any
+
+The object actually used is of the class MY which allows you to
+override bits of MakeMaker inside your Makefile.PL by declaring
+MY::foo() methods.
+
+
+The Real MakeMaker class hierarchy
+**********************************
+
+You wish it was that simple.
+
+Here's how it really works.
+
+ PACK### (created each call to ExtUtils::MakeMaker->new)
+ . |
+ (mixin) |
+ . |
+ MY (created by ExtUtils::MY) |
+ | |
+ ExtUtils::MY MM (created by ExtUtils::MM)
+ | |
+ ExtUtils::MM
+ | | |-----------------------
+ | | |
+ ExtUtils::Liblist ExtUtils::MakeMaker |
+ | |
+ ExtUtils::Liblist::Kid |
+ |
+ |
+ |
+ ExtUtils::MM_{Current OS} (if necessary)
+ |
+ ExtUtils::MM_Unix
+ |
+ ExtUtils::MM_Any
+
+
+NOTE: Yes, this is a mess. See
+http://archive.develooper.com/makemaker@perl.org/msg00134.html
+for some history.
+
+NOTE: When ExtUtils::MM is loaded it chooses a superclass for MM from
+amongst the ExtUtils::MM_* modules based on the current operating
+system.
+
+NOTE: ExtUtils::MM_{Current OS} represents one of the ExtUtils::MM_*
+modules except ExtUtils::MM_Any chosen based on your operating system.
+
+NOTE: The main object used by MakeMaker is a PACK### object, *not*
+ExtUtils::MakeMaker. It is, effectively, a subclass of MY,
+ExtUtils::Makemaker, ExtUtils::Liblist and ExtUtils::MM_{Current OS}
+
+NOTE: The methods in MY are simply copied into PACK### rather than
+MY being a superclass of PACK###. I don't remember the rationale.
+
+NOTE: ExtUtils::Liblist should be removed from the inheritence hiearchy
+and simply be called as functions.
+
+NOTE: Modules like File::Spec and Exporter have been omitted for clarity.
+
+
+The MM_* hierarchy
+******************
+
+ MM_Win95 MM_NW5
+ \ /
+MM_BeOS MM_Cygwin MM_OS2 MM_VMS MM_Win32 MM_DOS MM_UWIN
+ \ | | | / / /
+ ------------------------------------------------
+ | |
+ MM_Unix |
+ | |
+ MM_Any
+
+NOTE: Each direct MM_Unix subclass is also an MM_Any subclass. This
+is a temporary hack because MM_Unix overrides some MM_Any methods with
+Unix specific code. It allows the non-Unix modules to see the
+original MM_Any implementations.
+
+NOTE: Modules like File::Spec and Exporter have been omitted for clarity.
Copied: trunk/contrib/perl/lib/ExtUtils/PATCHING (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/PATCHING)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/PATCHING (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/PATCHING 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,212 @@
+"The easy way is always mined.
+ The important things are always simple.
+ The simple things are always hard."
+ -- Some of Murphy's Laws of Combat
+
+This is a short set of guidelines for those patching
+ExtUtils::MakeMaker. Its not an iron-clad set of rules, but just
+things which make life easier when reading and integrating a patch.
+
+Lots of information can be found in makemaker.org.
+
+MakerMaker is being maintained until something else can replace it.
+Bugs will be fixed and compatibility improved, but I would like to
+avoid new features. If you want to add something to MakeMaker,
+consider instead working on Module::Build, MakeMaker's heir apparent.
+
+
+Reporting bugs
+
+- Often the only information we have for fixing a bug is contained in your
+ report. So...
+
+- Please report your bugs via http://rt.cpan.org or by mailing to
+ makemaker at perl.org. RT is preferred.
+
+- Please report your bug immediately upon encountering it. Do not wait
+ until you have a patch to fix the bug. Patches are good, but not at
+ the expense of timely bug reports.
+
+- Please be as verbose as possible. Include the complete output of
+ your 'make test' or even 'make test TEST_VERBOSE=1' and a copy of the
+ generated Makefile. Err on the side of verbosity. The more data we
+ have to work with, the faster we can diagnose the problem.
+
+- If you find an undocumented feature, or if a feature has changed/been
+ added which causes a problem, report it. Do not assume it was done
+ deliberately. Even if it was done deliberately, we still want to hear
+ if it caused problems.
+
+- If you're testing MakeMaker against a development version of Perl,
+ please also check it against the latest stable version. This makes it
+ easier to figure out if its MakeMaker or Perl at fault.
+
+
+Patching details
+
+- Please use unified diffs. (diff -u)
+
+- Patches against the latest development snapshot from makemaker.org are
+ preferred. Patches against the latest CPAN version are ok, too.
+
+- Post your patch to makemaker at perl.org.
+
+
+Code formatting
+
+- No literal tabs (except where necessary inside Makefile code, obviously).
+
+- 4 character indentation.
+
+- this_style is prefered instead of studlyCaps.
+
+- Private subroutine names (ie. those used only in the same package
+ they're declared in) should start with an underscore (_sekret_method).
+
+- Protected subroutines (ie. ones intended to be used by other modules in
+ ExtUtils::*) should be named normally (no leading underscore) but
+ documented as protected (see Documentation below).
+
+- Do not use indirect object syntax (ie. new Foo::Bar (@args))
+
+- make variables use dollar signs like Perl scalars. This causes problems
+ when you have to mix them both in a string. If you find yourself
+ backwacking lots of dollar signs because you have one interpolated
+ perl variable, like this:
+
+ return <<EOT;
+subdirs ::
+ \$(NOECHO)cd $subdir && \$(MAKE) -f \$(FIRST_MAKEFILE) all \$(PASTHRU)
+
+EOT
+
+ or are switching quoting contexts:
+
+ return q{
+subdirs ::
+ $(NOECHO)cd }.$subdir.q{ && $(MAKE) -f $(FIRST_MAKEFILE) all $(PASTHRU)
+
+};
+
+ consider using sprintf instead.
+
+ return sprintf <<'EOT', $subdir;
+subdirs ::
+ $(NOECHO)cd %s && $(MAKE) -f $(FIRST_MAKEFILE) all $(PASTHRU)
+
+EOT
+
+
+Refactoring and Cleanup
+
+- MakeMaker is a mess. We like patches which clean things up.
+
+
+Backwards Compatibility
+
+- MakeMaker must be backwards compatible to 5.5.4 (5.005_04). Avoid any
+ obvious 5.6-isms (threads, warnings.pm, Unicode, our, v1.2.3, attributes
+ open my $fh, lvalue subroutines, qr//, any new core modules, etc...).
+
+- MakeMaker should avoid having module dependencies. Avoid using modules
+ which didn't come with 5.5.4 and avoid using features from newer
+ versions. Sometimes this is unavoidable.
+
+
+Cross-Platform Compatibility
+
+- With the exception of MacOS Classic, MakeMaker must work on all
+ architectures Perl works on (see perlport.pod). This means all Unixen
+ (including Cygwin and MacOS X), Windows (including Win9x and DOS), and VMS.
+
+- Use the available macros rather than shell commands $(MV), $(CP),
+ $(TOUCH), etc...
+
+- MakeMaker must work on many makes. GNU, BSD, Solaris, nmake, dmake, MMS
+ and MMK to name the most common. Keep your make code as simple as
+ possible.
+
+- Avoid special make variables (even $@).
+
+- Format targets as "target : dependency", the spacing is important.
+
+- Use $(NOECHO) instead of @.
+
+- Use - to tell make to ignore the exit code of a command. (Unfortunately,
+ some make variants don't honor an $(IGNORE) macro).
+
+- Always put a space between $(NOECHO) and the command.
+
+- Always put a space between - (ignore) and the command.
+
+- Always put $(NOECHO) and - together, no space between them.
+
+ # Right
+ -$(NOECHO) command
+ $(NOECHO) command
+ - command
+
+- Often when you patch ExtUtils::MM_Unix, similar patches must be done
+ to the other MM_* modules. If you can, please do this extra work
+ otherwise I have to. If you can't, that's ok. We can help.
+
+- If possible, please test your patch on two Very Different architectures.
+ Unix, Windows and VMS being Very Different. Note: Cygwin and OS X are
+ Unixen for our purposes.
+
+- If nothing else, at least try it on two different Unixen or Windows
+ machines (ie. Linux and IRIX or WinNT and Win95).
+
+- HP's TestDrive (www.testdrive.compaq.com) and SourceForge's
+ compile farm (www.sourceforge.net) are good sources of testing
+ machines of many different architectures and platforms. Accounts are
+ free.
+
+- If you find yourself writing "do_this if $^O eq 'That'" (ie. checks on
+ the OS type) perhaps your code belongs in one of the non-Unix MM_*
+ modules (ie. MM_Win32, MM_VMS, etc...). If one does not exist, consider
+ creating one. Its ok to have an MM_* module with only one method.
+
+- Some shells have very small buffers. This means command lines must
+ be as small as possible. If your command is just too long, consider
+ making it an ExtUtils::Command::MM function. If your command might
+ receive many arguments (such as pod2man or pm_to_blib) consider
+ using split_command() to split it into several, shorter calls.
+
+- Most shells quote differently. If you need to put a perl one-liner
+ in the Makefile, please use oneliner() to generate it.
+
+
+Tests
+
+- Tests would be nice, but I'm not going to pretend testing MakeMaker
+ is easy. If nothing else, let us know how you tested your patch by
+ hand.
+
+
+Documentation
+
+- Documentation would be nice.
+
+- If the new feature/method is private, please document it with POD
+ wrapped in "=begin/end private" tags. That way it will be documented,
+ but won't be displayed (future versions of perldoc may have options
+ to display).
+
+ =begin private
+
+ =head3 _foo_bar
+
+ $mm->_foo_bar
+
+ Blah blah blah
+
+ =end private
+
+ =cut
+
+ sub _foo_bar {
+ ...
+
+- If you're overriding a method, document that its an override and
+ *why* its being overridden. Don't repeat the original documentation.
Copied: trunk/contrib/perl/lib/ExtUtils/Packlist.pm (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/Packlist.pm)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/Packlist.pm (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/Packlist.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,348 @@
+package ExtUtils::Packlist;
+
+use 5.00503;
+use strict;
+use Carp qw();
+use Config;
+use vars qw($VERSION $Relocations);
+$VERSION = '1.43';
+$VERSION = eval $VERSION;
+
+# Used for generating filehandle globs. IO::File might not be available!
+my $fhname = "FH1";
+
+=begin _undocumented
+
+=item mkfh()
+
+Make a filehandle. Same kind of idea as Symbol::gensym().
+
+=cut
+
+sub mkfh()
+{
+no strict;
+my $fh = \*{$fhname++};
+use strict;
+return($fh);
+}
+
+=item __find_relocations
+
+Works out what absolute paths in the configuration have been located at run
+time relative to $^X, and generates a regexp that matches them
+
+=end _undocumented
+
+=cut
+
+sub __find_relocations
+{
+ my %paths;
+ while (my ($raw_key, $raw_val) = each %Config) {
+ my $exp_key = $raw_key . "exp";
+ next unless exists $Config{$exp_key};
+ next unless $raw_val =~ m!\.\.\./!;
+ $paths{$Config{$exp_key}}++;
+ }
+ # Longest prefixes go first in the alternatives
+ my $alternations = join "|", map {quotemeta $_}
+ sort {length $b <=> length $a} keys %paths;
+ qr/^($alternations)/o;
+}
+
+sub new($$)
+{
+my ($class, $packfile) = @_;
+$class = ref($class) || $class;
+my %self;
+tie(%self, $class, $packfile);
+return(bless(\%self, $class));
+}
+
+sub TIEHASH
+{
+my ($class, $packfile) = @_;
+my $self = { packfile => $packfile };
+bless($self, $class);
+$self->read($packfile) if (defined($packfile) && -f $packfile);
+return($self);
+}
+
+sub STORE
+{
+$_[0]->{data}->{$_[1]} = $_[2];
+}
+
+sub FETCH
+{
+return($_[0]->{data}->{$_[1]});
+}
+
+sub FIRSTKEY
+{
+my $reset = scalar(keys(%{$_[0]->{data}}));
+return(each(%{$_[0]->{data}}));
+}
+
+sub NEXTKEY
+{
+return(each(%{$_[0]->{data}}));
+}
+
+sub EXISTS
+{
+return(exists($_[0]->{data}->{$_[1]}));
+}
+
+sub DELETE
+{
+return(delete($_[0]->{data}->{$_[1]}));
+}
+
+sub CLEAR
+{
+%{$_[0]->{data}} = ();
+}
+
+sub DESTROY
+{
+}
+
+sub read($;$)
+{
+my ($self, $packfile) = @_;
+$self = tied(%$self) || $self;
+
+if (defined($packfile)) { $self->{packfile} = $packfile; }
+else { $packfile = $self->{packfile}; }
+Carp::croak("No packlist filename specified") if (! defined($packfile));
+my $fh = mkfh();
+open($fh, "<$packfile") || Carp::croak("Can't open file $packfile: $!");
+$self->{data} = {};
+my ($line);
+while (defined($line = <$fh>))
+ {
+ chomp $line;
+ my ($key, $data) = $line;
+ if ($key =~ /^(.*?)( \w+=.*)$/)
+ {
+ $key = $1;
+ $data = { map { split('=', $_) } split(' ', $2)};
+
+ if ($Config{userelocatableinc} && $data->{relocate_as})
+ {
+ require File::Spec;
+ require Cwd;
+ my ($vol, $dir) = File::Spec->splitpath($packfile);
+ my $newpath = File::Spec->catpath($vol, $dir, $data->{relocate_as});
+ $key = Cwd::realpath($newpath);
+ }
+ }
+ $key =~ s!/\./!/!g; # Some .packlists have spurious '/./' bits in the paths
+ $self->{data}->{$key} = $data;
+ }
+close($fh);
+}
+
+sub write($;$)
+{
+my ($self, $packfile) = @_;
+$self = tied(%$self) || $self;
+if (defined($packfile)) { $self->{packfile} = $packfile; }
+else { $packfile = $self->{packfile}; }
+Carp::croak("No packlist filename specified") if (! defined($packfile));
+my $fh = mkfh();
+open($fh, ">$packfile") || Carp::croak("Can't open file $packfile: $!");
+foreach my $key (sort(keys(%{$self->{data}})))
+ {
+ my $data = $self->{data}->{$key};
+ if ($Config{userelocatableinc}) {
+ $Relocations ||= __find_relocations();
+ if ($packfile =~ $Relocations) {
+ # We are writing into a subdirectory of a run-time relocated
+ # path. Figure out if the this file is also within a subdir.
+ my $prefix = $1;
+ if (File::Spec->no_upwards(File::Spec->abs2rel($key, $prefix)))
+ {
+ # The relocated path is within the found prefix
+ my $packfile_prefix;
+ (undef, $packfile_prefix)
+ = File::Spec->splitpath($packfile);
+
+ my $relocate_as
+ = File::Spec->abs2rel($key, $packfile_prefix);
+
+ if (!ref $data) {
+ $data = {};
+ }
+ $data->{relocate_as} = $relocate_as;
+ }
+ }
+ }
+ print $fh ("$key");
+ if (ref($data))
+ {
+ foreach my $k (sort(keys(%$data)))
+ {
+ print $fh (" $k=$data->{$k}");
+ }
+ }
+ print $fh ("\n");
+ }
+close($fh);
+}
+
+sub validate($;$)
+{
+my ($self, $remove) = @_;
+$self = tied(%$self) || $self;
+my @missing;
+foreach my $key (sort(keys(%{$self->{data}})))
+ {
+ if (! -e $key)
+ {
+ push(@missing, $key);
+ delete($self->{data}{$key}) if ($remove);
+ }
+ }
+return(@missing);
+}
+
+sub packlist_file($)
+{
+my ($self) = @_;
+$self = tied(%$self) || $self;
+return($self->{packfile});
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+ExtUtils::Packlist - manage .packlist files
+
+=head1 SYNOPSIS
+
+ use ExtUtils::Packlist;
+ my ($pl) = ExtUtils::Packlist->new('.packlist');
+ $pl->read('/an/old/.packlist');
+ my @missing_files = $pl->validate();
+ $pl->write('/a/new/.packlist');
+
+ $pl->{'/some/file/name'}++;
+ or
+ $pl->{'/some/other/file/name'} = { type => 'file',
+ from => '/some/file' };
+
+=head1 DESCRIPTION
+
+ExtUtils::Packlist provides a standard way to manage .packlist files.
+Functions are provided to read and write .packlist files. The original
+.packlist format is a simple list of absolute pathnames, one per line. In
+addition, this package supports an extended format, where as well as a filename
+each line may contain a list of attributes in the form of a space separated
+list of key=value pairs. This is used by the installperl script to
+differentiate between files and links, for example.
+
+=head1 USAGE
+
+The hash reference returned by the new() function can be used to examine and
+modify the contents of the .packlist. Items may be added/deleted from the
+.packlist by modifying the hash. If the value associated with a hash key is a
+scalar, the entry written to the .packlist by any subsequent write() will be a
+simple filename. If the value is a hash, the entry written will be the
+filename followed by the key=value pairs from the hash. Reading back the
+.packlist will recreate the original entries.
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item new()
+
+This takes an optional parameter, the name of a .packlist. If the file exists,
+it will be opened and the contents of the file will be read. The new() method
+returns a reference to a hash. This hash holds an entry for each line in the
+.packlist. In the case of old-style .packlists, the value associated with each
+key is undef. In the case of new-style .packlists, the value associated with
+each key is a hash containing the key=value pairs following the filename in the
+.packlist.
+
+=item read()
+
+This takes an optional parameter, the name of the .packlist to be read. If
+no file is specified, the .packlist specified to new() will be read. If the
+.packlist does not exist, Carp::croak will be called.
+
+=item write()
+
+This takes an optional parameter, the name of the .packlist to be written. If
+no file is specified, the .packlist specified to new() will be overwritten.
+
+=item validate()
+
+This checks that every file listed in the .packlist actually exists. If an
+argument which evaluates to true is given, any missing files will be removed
+from the internal hash. The return value is a list of the missing files, which
+will be empty if they all exist.
+
+=item packlist_file()
+
+This returns the name of the associated .packlist file
+
+=back
+
+=head1 EXAMPLE
+
+Here's C<modrm>, a little utility to cleanly remove an installed module.
+
+ #!/usr/local/bin/perl -w
+
+ use strict;
+ use IO::Dir;
+ use ExtUtils::Packlist;
+ use ExtUtils::Installed;
+
+ sub emptydir($) {
+ my ($dir) = @_;
+ my $dh = IO::Dir->new($dir) || return(0);
+ my @count = $dh->read();
+ $dh->close();
+ return(@count == 2 ? 1 : 0);
+ }
+
+ # Find all the installed packages
+ print("Finding all installed modules...\n");
+ my $installed = ExtUtils::Installed->new();
+
+ foreach my $module (grep(!/^Perl$/, $installed->modules())) {
+ my $version = $installed->version($module) || "???";
+ print("Found module $module Version $version\n");
+ print("Do you want to delete $module? [n] ");
+ my $r = <STDIN>; chomp($r);
+ if ($r && $r =~ /^y/i) {
+ # Remove all the files
+ foreach my $file (sort($installed->files($module))) {
+ print("rm $file\n");
+ unlink($file);
+ }
+ my $pf = $installed->packlist($module)->packlist_file();
+ print("rm $pf\n");
+ unlink($pf);
+ foreach my $dir (sort($installed->directory_tree($module))) {
+ if (emptydir($dir)) {
+ print("rmdir $dir\n");
+ rmdir($dir);
+ }
+ }
+ }
+ }
+
+=head1 AUTHOR
+
+Alan Burlison <Alan.Burlison at uk.sun.com>
+
+=cut
Copied: trunk/contrib/perl/lib/ExtUtils/ParseXS.pm (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/ParseXS.pm)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/ParseXS.pm (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/ParseXS.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,2091 @@
+package ExtUtils::ParseXS;
+
+use 5.006; # We use /??{}/ in regexes
+use Cwd;
+use Config;
+use File::Basename;
+use File::Spec;
+use Symbol;
+
+require Exporter;
+
+ at ISA = qw(Exporter);
+ at EXPORT_OK = qw(process_file);
+
+# use strict; # One of these days...
+
+my(@XSStack); # Stack of conditionals and INCLUDEs
+my($XSS_work_idx, $cpp_next_tmp);
+
+use vars qw($VERSION);
+$VERSION = '2.2002';
+
+use vars qw(%input_expr %output_expr $ProtoUsed @InitFileCode $FH $proto_re $Overload $errors $Fallback
+ $cplusplus $hiertype $WantPrototypes $WantVersionChk $except $WantLineNumbers
+ $WantOptimize $process_inout $process_argtypes @tm
+ $dir $filename $filepathname %IncludedFiles
+ %type_kind %proto_letter
+ %targetable $BLOCK_re $lastline $lastline_no
+ $Package $Prefix @line @BootCode %args_match %defaults %var_types %arg_list @proto_arg
+ $processing_arg_with_types %argtype_seen @outlist %in_out %lengthof
+ $proto_in_this_xsub $scope_in_this_xsub $interface $prepush_done $interface_macro $interface_macro_set
+ $ProtoThisXSUB $ScopeThisXSUB $xsreturn
+ @line_no $ret_type $func_header $orig_args
+ ); # Add these just to get compilation to happen.
+
+
+sub process_file {
+
+ # Allow for $package->process_file(%hash) in the future
+ my ($pkg, %args) = @_ % 2 ? @_ : (__PACKAGE__, @_);
+
+ $ProtoUsed = exists $args{prototypes};
+
+ # Set defaults.
+ %args = (
+ # 'C++' => 0, # Doesn't seem to *do* anything...
+ hiertype => 0,
+ except => 0,
+ prototypes => 0,
+ versioncheck => 1,
+ linenumbers => 1,
+ optimize => 1,
+ prototypes => 0,
+ inout => 1,
+ argtypes => 1,
+ typemap => [],
+ output => \*STDOUT,
+ csuffix => '.c',
+ %args,
+ );
+
+ # Global Constants
+
+ my ($Is_VMS, $SymSet);
+ if ($^O eq 'VMS') {
+ $Is_VMS = 1;
+ # Establish set of global symbols with max length 28, since xsubpp
+ # will later add the 'XS_' prefix.
+ require ExtUtils::XSSymSet;
+ $SymSet = new ExtUtils::XSSymSet 28;
+ }
+ @XSStack = ({type => 'none'});
+ ($XSS_work_idx, $cpp_next_tmp) = (0, "XSubPPtmpAAAA");
+ @InitFileCode = ();
+ $FH = Symbol::gensym();
+ $proto_re = "[" . quotemeta('\$%&*@;[]') . "]" ;
+ $Overload = 0;
+ $errors = 0;
+ $Fallback = '&PL_sv_undef';
+
+ # Most of the 1500 lines below uses these globals. We'll have to
+ # clean this up sometime, probably. For now, we just pull them out
+ # of %args. -Ken
+
+ $cplusplus = $args{'C++'};
+ $hiertype = $args{hiertype};
+ $WantPrototypes = $args{prototypes};
+ $WantVersionChk = $args{versioncheck};
+ $except = $args{except} ? ' TRY' : '';
+ $WantLineNumbers = $args{linenumbers};
+ $WantOptimize = $args{optimize};
+ $process_inout = $args{inout};
+ $process_argtypes = $args{argtypes};
+ @tm = ref $args{typemap} ? @{$args{typemap}} : ($args{typemap});
+
+ for ($args{filename}) {
+ die "Missing required parameter 'filename'" unless $_;
+ $filepathname = $_;
+ ($dir, $filename) = (dirname($_), basename($_));
+ $filepathname =~ s/\\/\\\\/g;
+ $IncludedFiles{$_}++;
+ }
+
+ # Open the input file
+ open($FH, $args{filename}) or die "cannot open $args{filename}: $!\n";
+
+ # Open the output file if given as a string. If they provide some
+ # other kind of reference, trust them that we can print to it.
+ if (not ref $args{output}) {
+ open my($fh), "> $args{output}" or die "Can't create $args{output}: $!";
+ $args{outfile} = $args{output};
+ $args{output} = $fh;
+ }
+
+ # Really, we shouldn't have to chdir() or select() in the first
+ # place. For now, just save & restore.
+ my $orig_cwd = cwd();
+ my $orig_fh = select();
+
+ chdir($dir);
+ my $pwd = cwd();
+ my $csuffix = $args{csuffix};
+
+ if ($WantLineNumbers) {
+ my $cfile;
+ if ( $args{outfile} ) {
+ $cfile = $args{outfile};
+ } else {
+ $cfile = $args{filename};
+ $cfile =~ s/\.xs$/$csuffix/i or $cfile .= $csuffix;
+ }
+ tie(*PSEUDO_STDOUT, 'ExtUtils::ParseXS::CountLines', $cfile, $args{output});
+ select PSEUDO_STDOUT;
+ } else {
+ select $args{output};
+ }
+
+ foreach my $typemap (@tm) {
+ die "Can't find $typemap in $pwd\n" unless -r $typemap;
+ }
+
+ push @tm, standard_typemap_locations();
+
+ foreach my $typemap (@tm) {
+ next unless -f $typemap ;
+ # skip directories, binary files etc.
+ warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
+ unless -T $typemap ;
+ open(TYPEMAP, $typemap)
+ or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
+ my $mode = 'Typemap';
+ my $junk = "" ;
+ my $current = \$junk;
+ while (<TYPEMAP>) {
+ next if /^\s* #/;
+ my $line_no = $. + 1;
+ if (/^INPUT\s*$/) {
+ $mode = 'Input'; $current = \$junk; next;
+ }
+ if (/^OUTPUT\s*$/) {
+ $mode = 'Output'; $current = \$junk; next;
+ }
+ if (/^TYPEMAP\s*$/) {
+ $mode = 'Typemap'; $current = \$junk; next;
+ }
+ if ($mode eq 'Typemap') {
+ chomp;
+ my $line = $_ ;
+ TrimWhitespace($_) ;
+ # skip blank lines and comment lines
+ next if /^$/ or /^#/ ;
+ my($type,$kind, $proto) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or
+ warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next;
+ $type = TidyType($type) ;
+ $type_kind{$type} = $kind ;
+ # prototype defaults to '$'
+ $proto = "\$" unless $proto ;
+ warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n")
+ unless ValidProtoString($proto) ;
+ $proto_letter{$type} = C_string($proto) ;
+ } elsif (/^\s/) {
+ $$current .= $_;
+ } elsif ($mode eq 'Input') {
+ s/\s+$//;
+ $input_expr{$_} = '';
+ $current = \$input_expr{$_};
+ } else {
+ s/\s+$//;
+ $output_expr{$_} = '';
+ $current = \$output_expr{$_};
+ }
+ }
+ close(TYPEMAP);
+ }
+
+ foreach my $value (values %input_expr) {
+ $value =~ s/;*\s+\z//;
+ # Move C pre-processor instructions to column 1 to be strictly ANSI
+ # conformant. Some pre-processors are fussy about this.
+ $value =~ s/^\s+#/#/mg;
+ }
+ foreach my $value (values %output_expr) {
+ # And again.
+ $value =~ s/^\s+#/#/mg;
+ }
+
+ my ($cast, $size);
+ our $bal = qr[(?:(?>[^()]+)|\((??{ $bal })\))*]; # ()-balanced
+ $cast = qr[(?:\(\s*SV\s*\*\s*\)\s*)?]; # Optional (SV*) cast
+ $size = qr[,\s* (??{ $bal }) ]x; # Third arg (to setpvn)
+
+ foreach my $key (keys %output_expr) {
+ BEGIN { $^H |= 0x00200000 }; # Equivalent to: use re 'eval', but hardcoded so we can compile re.xs
+
+ my ($t, $with_size, $arg, $sarg) =
+ ($output_expr{$key} =~
+ m[^ \s+ sv_set ( [iunp] ) v (n)? # Type, is_setpvn
+ \s* \( \s* $cast \$arg \s* ,
+ \s* ( (??{ $bal }) ) # Set from
+ ( (??{ $size }) )? # Possible sizeof set-from
+ \) \s* ; \s* $
+ ]x);
+ $targetable{$key} = [$t, $with_size, $arg, $sarg] if $t;
+ }
+
+ my $END = "!End!\n\n"; # "impossible" keyword (multiple newline)
+
+ # Match an XS keyword
+ $BLOCK_re= '\s*(' . join('|', qw(
+ REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT
+ CLEANUP ALIAS ATTRS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE
+ SCOPE INTERFACE INTERFACE_MACRO C_ARGS POSTCALL OVERLOAD FALLBACK
+ )) . "|$END)\\s*:";
+
+
+ our ($C_group_rex, $C_arg);
+ # Group in C (no support for comments or literals)
+ $C_group_rex = qr/ [({\[]
+ (?: (?> [^()\[\]{}]+ ) | (??{ $C_group_rex }) )*
+ [)}\]] /x ;
+ # Chunk in C without comma at toplevel (no comments):
+ $C_arg = qr/ (?: (?> [^()\[\]{},"']+ )
+ | (??{ $C_group_rex })
+ | " (?: (?> [^\\"]+ )
+ | \\.
+ )* " # String literal
+ | ' (?: (?> [^\\']+ ) | \\. )* ' # Char literal
+ )* /xs;
+
+ # Identify the version of xsubpp used
+ print <<EOM ;
+/*
+ * This file was generated automatically by ExtUtils::ParseXS version $VERSION from the
+ * contents of $filename. Do not edit this file, edit $filename instead.
+ *
+ * ANY CHANGES MADE HERE WILL BE LOST!
+ *
+ */
+
+EOM
+
+
+ print("#line 1 \"$filepathname\"\n")
+ if $WantLineNumbers;
+
+ firstmodule:
+ while (<$FH>) {
+ if (/^=/) {
+ my $podstartline = $.;
+ do {
+ if (/^=cut\s*$/) {
+ # We can't just write out a /* */ comment, as our embedded
+ # POD might itself be in a comment. We can't put a /**/
+ # comment inside #if 0, as the C standard says that the source
+ # file is decomposed into preprocessing characters in the stage
+ # before preprocessing commands are executed.
+ # I don't want to leave the text as barewords, because the spec
+ # isn't clear whether macros are expanded before or after
+ # preprocessing commands are executed, and someone pathological
+ # may just have defined one of the 3 words as a macro that does
+ # something strange. Multiline strings are illegal in C, so
+ # the "" we write must be a string literal. And they aren't
+ # concatenated until 2 steps later, so we are safe.
+ # - Nicholas Clark
+ print("#if 0\n \"Skipped embedded POD.\"\n#endif\n");
+ printf("#line %d \"$filepathname\"\n", $. + 1)
+ if $WantLineNumbers;
+ next firstmodule
+ }
+
+ } while (<$FH>);
+ # At this point $. is at end of file so die won't state the start
+ # of the problem, and as we haven't yet read any lines &death won't
+ # show the correct line in the message either.
+ die ("Error: Unterminated pod in $filename, line $podstartline\n")
+ unless $lastline;
+ }
+ last if ($Package, $Prefix) =
+ /^MODULE\s*=\s*[\w:]+(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/;
+
+ print $_;
+ }
+ unless (defined $_) {
+ warn "Didn't find a 'MODULE ... PACKAGE ... PREFIX' line\n";
+ exit 0; # Not a fatal error for the caller process
+ }
+
+ print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
+
+ print <<"EOF";
+#ifndef PERL_UNUSED_VAR
+# define PERL_UNUSED_VAR(var) if (0) var = var
+#endif
+
+EOF
+
+ print <<"EOF";
+#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
+#define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
+
+/* prototype to pass -Wmissing-prototypes */
+STATIC void
+S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params);
+
+STATIC void
+S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
+{
+ const GV *const gv = CvGV(cv);
+
+ PERL_ARGS_ASSERT_CROAK_XS_USAGE;
+
+ if (gv) {
+ const char *const gvname = GvNAME(gv);
+ const HV *const stash = GvSTASH(gv);
+ const char *const hvname = stash ? HvNAME(stash) : NULL;
+
+ if (hvname)
+ Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
+ else
+ Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
+ } else {
+ /* Pants. I don't think that it should be possible to get here. */
+ Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
+ }
+}
+#undef PERL_ARGS_ASSERT_CROAK_XS_USAGE
+
+#ifdef PERL_IMPLICIT_CONTEXT
+#define croak_xs_usage(a,b) S_croak_xs_usage(aTHX_ a,b)
+#else
+#define croak_xs_usage S_croak_xs_usage
+#endif
+
+#endif
+
+EOF
+
+ print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
+
+ $lastline = $_;
+ $lastline_no = $.;
+
+ PARAGRAPH:
+ while (fetch_para()) {
+ # Print initial preprocessor statements and blank lines
+ while (@line && $line[0] !~ /^[^\#]/) {
+ my $line = shift(@line);
+ print $line, "\n";
+ next unless $line =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/;
+ my $statement = $+;
+ if ($statement eq 'if') {
+ $XSS_work_idx = @XSStack;
+ push(@XSStack, {type => 'if'});
+ } else {
+ death ("Error: `$statement' with no matching `if'")
+ if $XSStack[-1]{type} ne 'if';
+ if ($XSStack[-1]{varname}) {
+ push(@InitFileCode, "#endif\n");
+ push(@BootCode, "#endif");
+ }
+
+ my(@fns) = keys %{$XSStack[-1]{functions}};
+ if ($statement ne 'endif') {
+ # Hide the functions defined in other #if branches, and reset.
+ @{$XSStack[-1]{other_functions}}{@fns} = (1) x @fns;
+ @{$XSStack[-1]}{qw(varname functions)} = ('', {});
+ } else {
+ my($tmp) = pop(@XSStack);
+ 0 while (--$XSS_work_idx
+ && $XSStack[$XSS_work_idx]{type} ne 'if');
+ # Keep all new defined functions
+ push(@fns, keys %{$tmp->{other_functions}});
+ @{$XSStack[$XSS_work_idx]{functions}}{@fns} = (1) x @fns;
+ }
+ }
+ }
+
+ next PARAGRAPH unless @line;
+
+ if ($XSS_work_idx && !$XSStack[$XSS_work_idx]{varname}) {
+ # We are inside an #if, but have not yet #defined its xsubpp variable.
+ print "#define $cpp_next_tmp 1\n\n";
+ push(@InitFileCode, "#if $cpp_next_tmp\n");
+ push(@BootCode, "#if $cpp_next_tmp");
+ $XSStack[$XSS_work_idx]{varname} = $cpp_next_tmp++;
+ }
+
+ death ("Code is not inside a function"
+ ." (maybe last function was ended by a blank line "
+ ." followed by a statement on column one?)")
+ if $line[0] =~ /^\s/;
+
+ my ($class, $externC, $static, $ellipsis, $wantRETVAL, $RETVAL_no_return);
+ my (@fake_INPUT_pre); # For length(s) generated variables
+ my (@fake_INPUT);
+
+ # initialize info arrays
+ undef(%args_match);
+ undef(%var_types);
+ undef(%defaults);
+ undef(%arg_list) ;
+ undef(@proto_arg) ;
+ undef($processing_arg_with_types) ;
+ undef(%argtype_seen) ;
+ undef(@outlist) ;
+ undef(%in_out) ;
+ undef(%lengthof) ;
+ undef($proto_in_this_xsub) ;
+ undef($scope_in_this_xsub) ;
+ undef($interface);
+ undef($prepush_done);
+ $interface_macro = 'XSINTERFACE_FUNC' ;
+ $interface_macro_set = 'XSINTERFACE_FUNC_SET' ;
+ $ProtoThisXSUB = $WantPrototypes ;
+ $ScopeThisXSUB = 0;
+ $xsreturn = 0;
+
+ $_ = shift(@line);
+ while (my $kwd = check_keyword("REQUIRE|PROTOTYPES|FALLBACK|VERSIONCHECK|INCLUDE")) {
+ &{"${kwd}_handler"}() ;
+ next PARAGRAPH unless @line ;
+ $_ = shift(@line);
+ }
+
+ if (check_keyword("BOOT")) {
+ &check_cpp;
+ push (@BootCode, "#line $line_no[@line_no - @line] \"$filepathname\"")
+ if $WantLineNumbers && $line[0] !~ /^\s*#\s*line\b/;
+ push (@BootCode, @line, "") ;
+ next PARAGRAPH ;
+ }
+
+
+ # extract return type, function name and arguments
+ ($ret_type) = TidyType($_);
+ $RETVAL_no_return = 1 if $ret_type =~ s/^NO_OUTPUT\s+//;
+
+ # Allow one-line ANSI-like declaration
+ unshift @line, $2
+ if $process_argtypes
+ and $ret_type =~ s/^(.*?\w.*?)\s*\b(\w+\s*\(.*)/$1/s;
+
+ # a function definition needs at least 2 lines
+ blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH
+ unless @line ;
+
+ $externC = 1 if $ret_type =~ s/^extern "C"\s+//;
+ $static = 1 if $ret_type =~ s/^static\s+//;
+
+ $func_header = shift(@line);
+ blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
+ unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*(const)?\s*(;\s*)?$/s;
+
+ ($class, $func_name, $orig_args) = ($1, $2, $3) ;
+ $class = "$4 $class" if $4;
+ ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
+ ($clean_func_name = $func_name) =~ s/^$Prefix//;
+ $Full_func_name = "${Packid}_$clean_func_name";
+ if ($Is_VMS) {
+ $Full_func_name = $SymSet->addsym($Full_func_name);
+ }
+
+ # Check for duplicate function definition
+ for my $tmp (@XSStack) {
+ next unless defined $tmp->{functions}{$Full_func_name};
+ Warn("Warning: duplicate function definition '$clean_func_name' detected");
+ last;
+ }
+ $XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ;
+ %XsubAliases = %XsubAliasValues = %Interfaces = @Attributes = ();
+ $DoSetMagic = 1;
+
+ $orig_args =~ s/\\\s*/ /g; # process line continuations
+ my @args;
+
+ my %only_C_inlist; # Not in the signature of Perl function
+ if ($process_argtypes and $orig_args =~ /\S/) {
+ my $args = "$orig_args ,";
+ if ($args =~ /^( (??{ $C_arg }) , )* $ /x) {
+ @args = ($args =~ /\G ( (??{ $C_arg }) ) , /xg);
+ for ( @args ) {
+ s/^\s+//;
+ s/\s+$//;
+ my ($arg, $default) = / ( [^=]* ) ( (?: = .* )? ) /x;
+ my ($pre, $name) = ($arg =~ /(.*?) \s*
+ \b ( \w+ | length\( \s*\w+\s* \) )
+ \s* $ /x);
+ next unless defined($pre) && length($pre);
+ my $out_type = '';
+ my $inout_var;
+ if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//) {
+ my $type = $1;
+ $out_type = $type if $type ne 'IN';
+ $arg =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//;
+ $pre =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//;
+ }
+ my $islength;
+ if ($name =~ /^length\( \s* (\w+) \s* \)\z/x) {
+ $name = "XSauto_length_of_$1";
+ $islength = 1;
+ die "Default value on length() argument: `$_'"
+ if length $default;
+ }
+ if (length $pre or $islength) { # Has a type
+ if ($islength) {
+ push @fake_INPUT_pre, $arg;
+ } else {
+ push @fake_INPUT, $arg;
+ }
+ # warn "pushing '$arg'\n";
+ $argtype_seen{$name}++;
+ $_ = "$name$default"; # Assigns to @args
+ }
+ $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST" or $islength;
+ push @outlist, $name if $out_type =~ /OUTLIST$/;
+ $in_out{$name} = $out_type if $out_type;
+ }
+ } else {
+ @args = split(/\s*,\s*/, $orig_args);
+ Warn("Warning: cannot parse argument list '$orig_args', fallback to split");
+ }
+ } else {
+ @args = split(/\s*,\s*/, $orig_args);
+ for (@args) {
+ if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\s+//) {
+ my $out_type = $1;
+ next if $out_type eq 'IN';
+ $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST";
+ push @outlist, $name if $out_type =~ /OUTLIST$/;
+ $in_out{$_} = $out_type;
+ }
+ }
+ }
+ if (defined($class)) {
+ my $arg0 = ((defined($static) or $func_name eq 'new')
+ ? "CLASS" : "THIS");
+ unshift(@args, $arg0);
+ ($report_args = "$arg0, $report_args") =~ s/^\w+, $/$arg0/;
+ }
+ my $extra_args = 0;
+ @args_num = ();
+ $num_args = 0;
+ my $report_args = '';
+ foreach my $i (0 .. $#args) {
+ if ($args[$i] =~ s/\.\.\.//) {
+ $ellipsis = 1;
+ if ($args[$i] eq '' && $i == $#args) {
+ $report_args .= ", ...";
+ pop(@args);
+ last;
+ }
+ }
+ if ($only_C_inlist{$args[$i]}) {
+ push @args_num, undef;
+ } else {
+ push @args_num, ++$num_args;
+ $report_args .= ", $args[$i]";
+ }
+ if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) {
+ $extra_args++;
+ $args[$i] = $1;
+ $defaults{$args[$i]} = $2;
+ $defaults{$args[$i]} =~ s/"/\\"/g;
+ }
+ $proto_arg[$i+1] = '$' ;
+ }
+ $min_args = $num_args - $extra_args;
+ $report_args =~ s/"/\\"/g;
+ $report_args =~ s/^,\s+//;
+ my @func_args = @args;
+ shift @func_args if defined($class);
+
+ for (@func_args) {
+ s/^/&/ if $in_out{$_};
+ }
+ $func_args = join(", ", @func_args);
+ @args_match{@args} = @args_num;
+
+ $PPCODE = grep(/^\s*PPCODE\s*:/, @line);
+ $CODE = grep(/^\s*CODE\s*:/, @line);
+ # Detect CODE: blocks which use ST(n)= or XST_m*(n,v)
+ # to set explicit return values.
+ $EXPLICIT_RETURN = ($CODE &&
+ ("@line" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x ));
+ $ALIAS = grep(/^\s*ALIAS\s*:/, @line);
+ $INTERFACE = grep(/^\s*INTERFACE\s*:/, @line);
+
+ $xsreturn = 1 if $EXPLICIT_RETURN;
+
+ $externC = $externC ? qq[extern "C"] : "";
+
+ # print function header
+ print Q(<<"EOF");
+#$externC
+#XS(XS_${Full_func_name}); /* prototype to pass -Wmissing-prototypes */
+#XS(XS_${Full_func_name})
+#[[
+##ifdef dVAR
+# dVAR; dXSARGS;
+##else
+# dXSARGS;
+##endif
+EOF
+ print Q(<<"EOF") if $ALIAS ;
+# dXSI32;
+EOF
+ print Q(<<"EOF") if $INTERFACE ;
+# dXSFUNCTION($ret_type);
+EOF
+ if ($ellipsis) {
+ $cond = ($min_args ? qq(items < $min_args) : 0);
+ } elsif ($min_args == $num_args) {
+ $cond = qq(items != $min_args);
+ } else {
+ $cond = qq(items < $min_args || items > $num_args);
+ }
+
+ print Q(<<"EOF") if $except;
+# char errbuf[1024];
+# *errbuf = '\0';
+EOF
+
+ if($cond) {
+ print Q(<<"EOF");
+# if ($cond)
+# croak_xs_usage(cv, "$report_args");
+EOF
+ } else {
+ # cv likely to be unused
+ print Q(<<"EOF");
+# PERL_UNUSED_VAR(cv); /* -W */
+EOF
+ }
+
+ #gcc -Wall: if an xsub has PPCODE is used
+ #it is possible none of ST, XSRETURN or XSprePUSH macros are used
+ #hence `ax' (setup by dXSARGS) is unused
+ #XXX: could breakup the dXSARGS; into dSP;dMARK;dITEMS
+ #but such a move could break third-party extensions
+ print Q(<<"EOF") if $PPCODE;
+# PERL_UNUSED_VAR(ax); /* -Wall */
+EOF
+
+ print Q(<<"EOF") if $PPCODE;
+# SP -= items;
+EOF
+
+ # Now do a block of some sort.
+
+ $condnum = 0;
+ $cond = ''; # last CASE: condidional
+ push(@line, "$END:");
+ push(@line_no, $line_no[-1]);
+ $_ = '';
+ &check_cpp;
+ while (@line) {
+ &CASE_handler if check_keyword("CASE");
+ print Q(<<"EOF");
+# $except [[
+EOF
+
+ # do initialization of input variables
+ $thisdone = 0;
+ $retvaldone = 0;
+ $deferred = "";
+ %arg_list = () ;
+ $gotRETVAL = 0;
+
+ INPUT_handler() ;
+ process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD") ;
+
+ print Q(<<"EOF") if $ScopeThisXSUB;
+# ENTER;
+# [[
+EOF
+
+ if (!$thisdone && defined($class)) {
+ if (defined($static) or $func_name eq 'new') {
+ print "\tchar *";
+ $var_types{"CLASS"} = "char *";
+ &generate_init("char *", 1, "CLASS");
+ }
+ else {
+ print "\t$class *";
+ $var_types{"THIS"} = "$class *";
+ &generate_init("$class *", 1, "THIS");
+ }
+ }
+
+ # do code
+ if (/^\s*NOT_IMPLEMENTED_YET/) {
+ print "\n\tPerl_croak(aTHX_ \"$pname: not implemented yet\");\n";
+ $_ = '' ;
+ } else {
+ if ($ret_type ne "void") {
+ print "\t" . &map_type($ret_type, 'RETVAL') . ";\n"
+ if !$retvaldone;
+ $args_match{"RETVAL"} = 0;
+ $var_types{"RETVAL"} = $ret_type;
+ print "\tdXSTARG;\n"
+ if $WantOptimize and $targetable{$type_kind{$ret_type}};
+ }
+
+ if (@fake_INPUT or @fake_INPUT_pre) {
+ unshift @line, @fake_INPUT_pre, @fake_INPUT, $_;
+ $_ = "";
+ $processing_arg_with_types = 1;
+ INPUT_handler() ;
+ }
+ print $deferred;
+
+ process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD") ;
+
+ if (check_keyword("PPCODE")) {
+ print_section();
+ death ("PPCODE must be last thing") if @line;
+ print "\tLEAVE;\n" if $ScopeThisXSUB;
+ print "\tPUTBACK;\n\treturn;\n";
+ } elsif (check_keyword("CODE")) {
+ print_section() ;
+ } elsif (defined($class) and $func_name eq "DESTROY") {
+ print "\n\t";
+ print "delete THIS;\n";
+ } else {
+ print "\n\t";
+ if ($ret_type ne "void") {
+ print "RETVAL = ";
+ $wantRETVAL = 1;
+ }
+ if (defined($static)) {
+ if ($func_name eq 'new') {
+ $func_name = "$class";
+ } else {
+ print "${class}::";
+ }
+ } elsif (defined($class)) {
+ if ($func_name eq 'new') {
+ $func_name .= " $class";
+ } else {
+ print "THIS->";
+ }
+ }
+ $func_name =~ s/^\Q$args{'s'}//
+ if exists $args{'s'};
+ $func_name = 'XSFUNCTION' if $interface;
+ print "$func_name($func_args);\n";
+ }
+ }
+
+ # do output variables
+ $gotRETVAL = 0; # 1 if RETVAL seen in OUTPUT section;
+ undef $RETVAL_code ; # code to set RETVAL (from OUTPUT section);
+ # $wantRETVAL set if 'RETVAL =' autogenerated
+ ($wantRETVAL, $ret_type) = (0, 'void') if $RETVAL_no_return;
+ undef %outargs ;
+ process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD");
+
+ &generate_output($var_types{$_}, $args_match{$_}, $_, $DoSetMagic)
+ for grep $in_out{$_} =~ /OUT$/, keys %in_out;
+
+ # all OUTPUT done, so now push the return value on the stack
+ if ($gotRETVAL && $RETVAL_code) {
+ print "\t$RETVAL_code\n";
+ } elsif ($gotRETVAL || $wantRETVAL) {
+ my $t = $WantOptimize && $targetable{$type_kind{$ret_type}};
+ my $var = 'RETVAL';
+ my $type = $ret_type;
+
+ # 0: type, 1: with_size, 2: how, 3: how_size
+ if ($t and not $t->[1] and $t->[0] eq 'p') {
+ # PUSHp corresponds to setpvn. Treate setpv directly
+ my $what = eval qq("$t->[2]");
+ warn $@ if $@;
+
+ print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n";
+ $prepush_done = 1;
+ }
+ elsif ($t) {
+ my $what = eval qq("$t->[2]");
+ warn $@ if $@;
+
+ my $size = $t->[3];
+ $size = '' unless defined $size;
+ $size = eval qq("$size");
+ warn $@ if $@;
+ print "\tXSprePUSH; PUSH$t->[0]($what$size);\n";
+ $prepush_done = 1;
+ }
+ else {
+ # RETVAL almost never needs SvSETMAGIC()
+ &generate_output($ret_type, 0, 'RETVAL', 0);
+ }
+ }
+
+ $xsreturn = 1 if $ret_type ne "void";
+ my $num = $xsreturn;
+ my $c = @outlist;
+ print "\tXSprePUSH;" if $c and not $prepush_done;
+ print "\tEXTEND(SP,$c);\n" if $c;
+ $xsreturn += $c;
+ generate_output($var_types{$_}, $num++, $_, 0, 1) for @outlist;
+
+ # do cleanup
+ process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD") ;
+
+ print Q(<<"EOF") if $ScopeThisXSUB;
+# ]]
+EOF
+ print Q(<<"EOF") if $ScopeThisXSUB and not $PPCODE;
+# LEAVE;
+EOF
+
+ # print function trailer
+ print Q(<<"EOF");
+# ]]
+EOF
+ print Q(<<"EOF") if $except;
+# BEGHANDLERS
+# CATCHALL
+# sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
+# ENDHANDLERS
+EOF
+ if (check_keyword("CASE")) {
+ blurt ("Error: No `CASE:' at top of function")
+ unless $condnum;
+ $_ = "CASE: $_"; # Restore CASE: label
+ next;
+ }
+ last if $_ eq "$END:";
+ death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function");
+ }
+
+ print Q(<<"EOF") if $except;
+# if (errbuf[0])
+# Perl_croak(aTHX_ errbuf);
+EOF
+
+ if ($xsreturn) {
+ print Q(<<"EOF") unless $PPCODE;
+# XSRETURN($xsreturn);
+EOF
+ } else {
+ print Q(<<"EOF") unless $PPCODE;
+# XSRETURN_EMPTY;
+EOF
+ }
+
+ print Q(<<"EOF");
+#]]
+#
+EOF
+
+ my $newXS = "newXS" ;
+ my $proto = "" ;
+
+ # Build the prototype string for the xsub
+ if ($ProtoThisXSUB) {
+ $newXS = "newXSproto";
+
+ if ($ProtoThisXSUB eq 2) {
+ # User has specified empty prototype
+ }
+ elsif ($ProtoThisXSUB eq 1) {
+ my $s = ';';
+ if ($min_args < $num_args) {
+ $s = '';
+ $proto_arg[$min_args] .= ";" ;
+ }
+ push @proto_arg, "$s\@"
+ if $ellipsis ;
+
+ $proto = join ("", grep defined, @proto_arg);
+ }
+ else {
+ # User has specified a prototype
+ $proto = $ProtoThisXSUB;
+ }
+ $proto = qq{, "$proto"};
+ }
+
+ if (%XsubAliases) {
+ $XsubAliases{$pname} = 0
+ unless defined $XsubAliases{$pname} ;
+ while ( ($name, $value) = each %XsubAliases) {
+ push(@InitFileCode, Q(<<"EOF"));
+# cv = newXS(\"$name\", XS_$Full_func_name, file);
+# XSANY.any_i32 = $value ;
+EOF
+ push(@InitFileCode, Q(<<"EOF")) if $proto;
+# sv_setpv((SV*)cv$proto) ;
+EOF
+ }
+ }
+ elsif (@Attributes) {
+ push(@InitFileCode, Q(<<"EOF"));
+# cv = newXS(\"$pname\", XS_$Full_func_name, file);
+# apply_attrs_string("$Package", cv, "@Attributes", 0);
+EOF
+ }
+ elsif ($interface) {
+ while ( ($name, $value) = each %Interfaces) {
+ $name = "$Package\::$name" unless $name =~ /::/;
+ push(@InitFileCode, Q(<<"EOF"));
+# cv = newXS(\"$name\", XS_$Full_func_name, file);
+# $interface_macro_set(cv,$value) ;
+EOF
+ push(@InitFileCode, Q(<<"EOF")) if $proto;
+# sv_setpv((SV*)cv$proto) ;
+EOF
+ }
+ }
+ else {
+ push(@InitFileCode,
+ " ${newXS}(\"$pname\", XS_$Full_func_name, file$proto);\n");
+ }
+ }
+
+ if ($Overload) # make it findable with fetchmethod
+ {
+ print Q(<<"EOF");
+#XS(XS_${Packid}_nil); /* prototype to pass -Wmissing-prototypes */
+#XS(XS_${Packid}_nil)
+#{
+# dXSARGS;
+# XSRETURN_EMPTY;
+#}
+#
+EOF
+ unshift(@InitFileCode, <<"MAKE_FETCHMETHOD_WORK");
+ /* Making a sub named "${Package}::()" allows the package */
+ /* to be findable via fetchmethod(), and causes */
+ /* overload::Overloaded("${Package}") to return true. */
+ newXS("${Package}::()", XS_${Packid}_nil, file$proto);
+MAKE_FETCHMETHOD_WORK
+ }
+
+ # print initialization routine
+
+ print Q(<<"EOF");
+##ifdef __cplusplus
+#extern "C"
+##endif
+EOF
+
+ print Q(<<"EOF");
+#XS(boot_$Module_cname); /* prototype to pass -Wmissing-prototypes */
+#XS(boot_$Module_cname)
+EOF
+
+ print Q(<<"EOF");
+#[[
+##ifdef dVAR
+# dVAR; dXSARGS;
+##else
+# dXSARGS;
+##endif
+EOF
+
+ #-Wall: if there is no $Full_func_name there are no xsubs in this .xs
+ #so `file' is unused
+ print Q(<<"EOF") if $Full_func_name;
+# const char* file = __FILE__;
+EOF
+
+ print Q("#\n");
+
+ print Q(<<"EOF");
+# PERL_UNUSED_VAR(cv); /* -W */
+# PERL_UNUSED_VAR(items); /* -W */
+EOF
+
+ print Q(<<"EOF") if $WantVersionChk ;
+# XS_VERSION_BOOTCHECK ;
+#
+EOF
+
+ print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces ;
+# {
+# CV * cv ;
+#
+EOF
+
+ print Q(<<"EOF") if ($Overload);
+# /* register the overloading (type 'A') magic */
+# PL_amagic_generation++;
+# /* The magic for overload gets a GV* via gv_fetchmeth as */
+# /* mentioned above, and looks in the SV* slot of it for */
+# /* the "fallback" status. */
+# sv_setsv(
+# get_sv( "${Package}::()", TRUE ),
+# $Fallback
+# );
+EOF
+
+ print @InitFileCode;
+
+ print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces ;
+# }
+EOF
+
+ if (@BootCode)
+ {
+ print "\n /* Initialisation Section */\n\n" ;
+ @line = @BootCode;
+ print_section();
+ print "\n /* End of Initialisation Section */\n\n" ;
+ }
+
+ if ($] >= 5.009) {
+ print <<'EOF';
+ if (PL_unitcheckav)
+ call_list(PL_scopestack_ix, PL_unitcheckav);
+EOF
+ }
+
+ print Q(<<"EOF");
+# XSRETURN_YES;
+#]]
+#
+EOF
+
+ warn("Please specify prototyping behavior for $filename (see perlxs manual)\n")
+ unless $ProtoUsed ;
+
+ chdir($orig_cwd);
+ select($orig_fh);
+ untie *PSEUDO_STDOUT if tied *PSEUDO_STDOUT;
+ close $FH;
+
+ return 1;
+}
+
+sub errors { $errors }
+
+sub standard_typemap_locations {
+ # Add all the default typemap locations to the search path
+ my @tm = qw(typemap);
+
+ my $updir = File::Spec->updir;
+ foreach my $dir (File::Spec->catdir(($updir) x 1), File::Spec->catdir(($updir) x 2),
+ File::Spec->catdir(($updir) x 3), File::Spec->catdir(($updir) x 4)) {
+
+ unshift @tm, File::Spec->catfile($dir, 'typemap');
+ unshift @tm, File::Spec->catfile($dir, lib => ExtUtils => 'typemap');
+ }
+ foreach my $dir (@INC) {
+ my $file = File::Spec->catfile($dir, ExtUtils => 'typemap');
+ unshift @tm, $file if -e $file;
+ }
+ return @tm;
+}
+
+sub TrimWhitespace
+{
+ $_[0] =~ s/^\s+|\s+$//go ;
+}
+
+sub TidyType
+ {
+ local ($_) = @_ ;
+
+ # rationalise any '*' by joining them into bunches and removing whitespace
+ s#\s*(\*+)\s*#$1#g;
+ s#(\*+)# $1 #g ;
+
+ # change multiple whitespace into a single space
+ s/\s+/ /g ;
+
+ # trim leading & trailing whitespace
+ TrimWhitespace($_) ;
+
+ $_ ;
+}
+
+# Input: ($_, @line) == unparsed input.
+# Output: ($_, @line) == (rest of line, following lines).
+# Return: the matched keyword if found, otherwise 0
+sub check_keyword {
+ $_ = shift(@line) while !/\S/ && @line;
+ s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2;
+}
+
+sub print_section {
+ # the "do" is required for right semantics
+ do { $_ = shift(@line) } while !/\S/ && @line;
+
+ print("#line ", $line_no[@line_no - @line -1], " \"$filepathname\"\n")
+ if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/;
+ for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
+ print "$_\n";
+ }
+ print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
+}
+
+sub merge_section {
+ my $in = '';
+
+ while (!/\S/ && @line) {
+ $_ = shift(@line);
+ }
+
+ for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
+ $in .= "$_\n";
+ }
+ chomp $in;
+ return $in;
+ }
+
+sub process_keyword($)
+ {
+ my($pattern) = @_ ;
+ my $kwd ;
+
+ &{"${kwd}_handler"}()
+ while $kwd = check_keyword($pattern) ;
+ }
+
+sub CASE_handler {
+ blurt ("Error: `CASE:' after unconditional `CASE:'")
+ if $condnum && $cond eq '';
+ $cond = $_;
+ TrimWhitespace($cond);
+ print " ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n");
+ $_ = '' ;
+}
+
+sub INPUT_handler {
+ for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
+ last if /^\s*NOT_IMPLEMENTED_YET/;
+ next unless /\S/; # skip blank lines
+
+ TrimWhitespace($_) ;
+ my $line = $_ ;
+
+ # remove trailing semicolon if no initialisation
+ s/\s*;$//g unless /[=;+].*\S/ ;
+
+ # Process the length(foo) declarations
+ if (s/^([^=]*)\blength\(\s*(\w+)\s*\)\s*$/$1 XSauto_length_of_$2=NO_INIT/x) {
+ print "\tSTRLEN\tSTRLEN_length_of_$2;\n";
+ $lengthof{$2} = $name;
+ # $islengthof{$name} = $1;
+ $deferred .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;";
+ }
+
+ # check for optional initialisation code
+ my $var_init = '' ;
+ $var_init = $1 if s/\s*([=;+].*)$//s ;
+ $var_init =~ s/"/\\"/g;
+
+ s/\s+/ /g;
+ my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s
+ or blurt("Error: invalid argument declaration '$line'"), next;
+
+ # Check for duplicate definitions
+ blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
+ if $arg_list{$var_name}++
+ or defined $argtype_seen{$var_name} and not $processing_arg_with_types;
+
+ $thisdone |= $var_name eq "THIS";
+ $retvaldone |= $var_name eq "RETVAL";
+ $var_types{$var_name} = $var_type;
+ # XXXX This check is a safeguard against the unfinished conversion of
+ # generate_init(). When generate_init() is fixed,
+ # one can use 2-args map_type() unconditionally.
+ if ($var_type =~ / \( \s* \* \s* \) /x) {
+ # Function pointers are not yet supported with &output_init!
+ print "\t" . &map_type($var_type, $var_name);
+ $name_printed = 1;
+ } else {
+ print "\t" . &map_type($var_type);
+ $name_printed = 0;
+ }
+ $var_num = $args_match{$var_name};
+
+ $proto_arg[$var_num] = ProtoString($var_type)
+ if $var_num ;
+ $func_args =~ s/\b($var_name)\b/&$1/ if $var_addr;
+ if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/
+ or $in_out{$var_name} and $in_out{$var_name} =~ /^OUT/
+ and $var_init !~ /\S/) {
+ if ($name_printed) {
+ print ";\n";
+ } else {
+ print "\t$var_name;\n";
+ }
+ } elsif ($var_init =~ /\S/) {
+ &output_init($var_type, $var_num, $var_name, $var_init, $name_printed);
+ } elsif ($var_num) {
+ # generate initialization code
+ &generate_init($var_type, $var_num, $var_name, $name_printed);
+ } else {
+ print ";\n";
+ }
+ }
+}
+
+sub OUTPUT_handler {
+ for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
+ next unless /\S/;
+ if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) {
+ $DoSetMagic = ($1 eq "ENABLE" ? 1 : 0);
+ next;
+ }
+ my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s ;
+ blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
+ if $outargs{$outarg} ++ ;
+ if (!$gotRETVAL and $outarg eq 'RETVAL') {
+ # deal with RETVAL last
+ $RETVAL_code = $outcode ;
+ $gotRETVAL = 1 ;
+ next ;
+ }
+ blurt ("Error: OUTPUT $outarg not an argument"), next
+ unless defined($args_match{$outarg});
+ blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
+ unless defined $var_types{$outarg} ;
+ $var_num = $args_match{$outarg};
+ if ($outcode) {
+ print "\t$outcode\n";
+ print "\tSvSETMAGIC(ST(" , $var_num-1 , "));\n" if $DoSetMagic;
+ } else {
+ &generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic);
+ }
+ delete $in_out{$outarg} # No need to auto-OUTPUT
+ if exists $in_out{$outarg} and $in_out{$outarg} =~ /OUT$/;
+ }
+}
+
+sub C_ARGS_handler() {
+ my $in = merge_section();
+
+ TrimWhitespace($in);
+ $func_args = $in;
+}
+
+sub INTERFACE_MACRO_handler() {
+ my $in = merge_section();
+
+ TrimWhitespace($in);
+ if ($in =~ /\s/) { # two
+ ($interface_macro, $interface_macro_set) = split ' ', $in;
+ } else {
+ $interface_macro = $in;
+ $interface_macro_set = 'UNKNOWN_CVT'; # catch later
+ }
+ $interface = 1; # local
+ $Interfaces = 1; # global
+}
+
+sub INTERFACE_handler() {
+ my $in = merge_section();
+
+ TrimWhitespace($in);
+
+ foreach (split /[\s,]+/, $in) {
+ my $name = $_;
+ $name =~ s/^$Prefix//;
+ $Interfaces{$name} = $_;
+ }
+ print Q(<<"EOF");
+# XSFUNCTION = $interface_macro($ret_type,cv,XSANY.any_dptr);
+EOF
+ $interface = 1; # local
+ $Interfaces = 1; # global
+}
+
+sub CLEANUP_handler() { print_section() }
+sub PREINIT_handler() { print_section() }
+sub POSTCALL_handler() { print_section() }
+sub INIT_handler() { print_section() }
+
+sub GetAliases
+ {
+ my ($line) = @_ ;
+ my ($orig) = $line ;
+ my ($alias) ;
+ my ($value) ;
+
+ # Parse alias definitions
+ # format is
+ # alias = value alias = value ...
+
+ while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) {
+ $alias = $1 ;
+ $orig_alias = $alias ;
+ $value = $2 ;
+
+ # check for optional package definition in the alias
+ $alias = $Packprefix . $alias if $alias !~ /::/ ;
+
+ # check for duplicate alias name & duplicate value
+ Warn("Warning: Ignoring duplicate alias '$orig_alias'")
+ if defined $XsubAliases{$alias} ;
+
+ Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$value}' have identical values")
+ if $XsubAliasValues{$value} ;
+
+ $XsubAliases = 1;
+ $XsubAliases{$alias} = $value ;
+ $XsubAliasValues{$value} = $orig_alias ;
+ }
+
+ blurt("Error: Cannot parse ALIAS definitions from '$orig'")
+ if $line ;
+ }
+
+sub ATTRS_handler ()
+ {
+ for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
+ next unless /\S/;
+ TrimWhitespace($_) ;
+ push @Attributes, $_;
+ }
+ }
+
+sub ALIAS_handler ()
+ {
+ for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
+ next unless /\S/;
+ TrimWhitespace($_) ;
+ GetAliases($_) if $_ ;
+ }
+ }
+
+sub OVERLOAD_handler()
+{
+ for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
+ next unless /\S/;
+ TrimWhitespace($_) ;
+ while ( s/^\s*([\w:"\\)\+\-\*\/\%\<\>\.\&\|\^\!\~\{\}\=]+)\s*//) {
+ $Overload = 1 unless $Overload;
+ my $overload = "$Package\::(".$1 ;
+ push(@InitFileCode,
+ " newXS(\"$overload\", XS_$Full_func_name, file$proto);\n");
+ }
+ }
+}
+
+sub FALLBACK_handler()
+{
+ # the rest of the current line should contain either TRUE,
+ # FALSE or UNDEF
+
+ TrimWhitespace($_) ;
+ my %map = (
+ TRUE => "&PL_sv_yes", 1 => "&PL_sv_yes",
+ FALSE => "&PL_sv_no", 0 => "&PL_sv_no",
+ UNDEF => "&PL_sv_undef",
+ ) ;
+
+ # check for valid FALLBACK value
+ death ("Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{uc $_} ;
+
+ $Fallback = $map{uc $_} ;
+}
+
+
+sub REQUIRE_handler ()
+ {
+ # the rest of the current line should contain a version number
+ my ($Ver) = $_ ;
+
+ TrimWhitespace($Ver) ;
+
+ death ("Error: REQUIRE expects a version number")
+ unless $Ver ;
+
+ # check that the version number is of the form n.n
+ death ("Error: REQUIRE: expected a number, got '$Ver'")
+ unless $Ver =~ /^\d+(\.\d*)?/ ;
+
+ death ("Error: xsubpp $Ver (or better) required--this is only $VERSION.")
+ unless $VERSION >= $Ver ;
+ }
+
+sub VERSIONCHECK_handler ()
+ {
+ # the rest of the current line should contain either ENABLE or
+ # DISABLE
+
+ TrimWhitespace($_) ;
+
+ # check for ENABLE/DISABLE
+ death ("Error: VERSIONCHECK: ENABLE/DISABLE")
+ unless /^(ENABLE|DISABLE)/i ;
+
+ $WantVersionChk = 1 if $1 eq 'ENABLE' ;
+ $WantVersionChk = 0 if $1 eq 'DISABLE' ;
+
+ }
+
+sub PROTOTYPE_handler ()
+ {
+ my $specified ;
+
+ death("Error: Only 1 PROTOTYPE definition allowed per xsub")
+ if $proto_in_this_xsub ++ ;
+
+ for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
+ next unless /\S/;
+ $specified = 1 ;
+ TrimWhitespace($_) ;
+ if ($_ eq 'DISABLE') {
+ $ProtoThisXSUB = 0
+ } elsif ($_ eq 'ENABLE') {
+ $ProtoThisXSUB = 1
+ } else {
+ # remove any whitespace
+ s/\s+//g ;
+ death("Error: Invalid prototype '$_'")
+ unless ValidProtoString($_) ;
+ $ProtoThisXSUB = C_string($_) ;
+ }
+ }
+
+ # If no prototype specified, then assume empty prototype ""
+ $ProtoThisXSUB = 2 unless $specified ;
+
+ $ProtoUsed = 1 ;
+
+ }
+
+sub SCOPE_handler ()
+ {
+ death("Error: Only 1 SCOPE declaration allowed per xsub")
+ if $scope_in_this_xsub ++ ;
+
+ for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
+ next unless /\S/;
+ TrimWhitespace($_) ;
+ if ($_ =~ /^DISABLE/i) {
+ $ScopeThisXSUB = 0
+ } elsif ($_ =~ /^ENABLE/i) {
+ $ScopeThisXSUB = 1
+ }
+ }
+
+ }
+
+sub PROTOTYPES_handler ()
+ {
+ # the rest of the current line should contain either ENABLE or
+ # DISABLE
+
+ TrimWhitespace($_) ;
+
+ # check for ENABLE/DISABLE
+ death ("Error: PROTOTYPES: ENABLE/DISABLE")
+ unless /^(ENABLE|DISABLE)/i ;
+
+ $WantPrototypes = 1 if $1 eq 'ENABLE' ;
+ $WantPrototypes = 0 if $1 eq 'DISABLE' ;
+ $ProtoUsed = 1 ;
+
+ }
+
+sub INCLUDE_handler ()
+ {
+ # the rest of the current line should contain a valid filename
+
+ TrimWhitespace($_) ;
+
+ death("INCLUDE: filename missing")
+ unless $_ ;
+
+ death("INCLUDE: output pipe is illegal")
+ if /^\s*\|/ ;
+
+ # simple minded recursion detector
+ death("INCLUDE loop detected")
+ if $IncludedFiles{$_} ;
+
+ ++ $IncludedFiles{$_} unless /\|\s*$/ ;
+
+ # Save the current file context.
+ push(@XSStack, {
+ type => 'file',
+ LastLine => $lastline,
+ LastLineNo => $lastline_no,
+ Line => \@line,
+ LineNo => \@line_no,
+ Filename => $filename,
+ Filepathname => $filepathname,
+ Handle => $FH,
+ }) ;
+
+ $FH = Symbol::gensym();
+
+ # open the new file
+ open ($FH, "$_") or death("Cannot open '$_': $!") ;
+
+ print Q(<<"EOF");
+#
+#/* INCLUDE: Including '$_' from '$filename' */
+#
+EOF
+
+ $filepathname = $filename = $_ ;
+
+ # Prime the pump by reading the first
+ # non-blank line
+
+ # skip leading blank lines
+ while (<$FH>) {
+ last unless /^\s*$/ ;
+ }
+
+ $lastline = $_ ;
+ $lastline_no = $. ;
+
+ }
+
+sub PopFile()
+ {
+ return 0 unless $XSStack[-1]{type} eq 'file' ;
+
+ my $data = pop @XSStack ;
+ my $ThisFile = $filename ;
+ my $isPipe = ($filename =~ /\|\s*$/) ;
+
+ -- $IncludedFiles{$filename}
+ unless $isPipe ;
+
+ close $FH ;
+
+ $FH = $data->{Handle} ;
+ # $filename is the leafname, which for some reason isused for diagnostic
+ # messages, whereas $filepathname is the full pathname, and is used for
+ # #line directives.
+ $filename = $data->{Filename} ;
+ $filepathname = $data->{Filepathname} ;
+ $lastline = $data->{LastLine} ;
+ $lastline_no = $data->{LastLineNo} ;
+ @line = @{ $data->{Line} } ;
+ @line_no = @{ $data->{LineNo} } ;
+
+ if ($isPipe and $? ) {
+ -- $lastline_no ;
+ print STDERR "Error reading from pipe '$ThisFile': $! in $filename, line $lastline_no\n" ;
+ exit 1 ;
+ }
+
+ print Q(<<"EOF");
+#
+#/* INCLUDE: Returning to '$filename' from '$ThisFile' */
+#
+EOF
+
+ return 1 ;
+ }
+
+sub ValidProtoString ($)
+ {
+ my($string) = @_ ;
+
+ if ( $string =~ /^$proto_re+$/ ) {
+ return $string ;
+ }
+
+ return 0 ;
+ }
+
+sub C_string ($)
+ {
+ my($string) = @_ ;
+
+ $string =~ s[\\][\\\\]g ;
+ $string ;
+ }
+
+sub ProtoString ($)
+ {
+ my ($type) = @_ ;
+
+ $proto_letter{$type} or "\$" ;
+ }
+
+sub check_cpp {
+ my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line);
+ if (@cpp) {
+ my ($cpp, $cpplevel);
+ for $cpp (@cpp) {
+ if ($cpp =~ /^\#\s*if/) {
+ $cpplevel++;
+ } elsif (!$cpplevel) {
+ Warn("Warning: #else/elif/endif without #if in this function");
+ print STDERR " (precede it with a blank line if the matching #if is outside the function)\n"
+ if $XSStack[-1]{type} eq 'if';
+ return;
+ } elsif ($cpp =~ /^\#\s*endif/) {
+ $cpplevel--;
+ }
+ }
+ Warn("Warning: #if without #endif in this function") if $cpplevel;
+ }
+}
+
+
+sub Q {
+ my($text) = @_;
+ $text =~ s/^#//gm;
+ $text =~ s/\[\[/{/g;
+ $text =~ s/\]\]/}/g;
+ $text;
+}
+
+# Read next xsub into @line from ($lastline, <$FH>).
+sub fetch_para {
+ # parse paragraph
+ death ("Error: Unterminated `#if/#ifdef/#ifndef'")
+ if !defined $lastline && $XSStack[-1]{type} eq 'if';
+ @line = ();
+ @line_no = () ;
+ return PopFile() if !defined $lastline;
+
+ if ($lastline =~
+ /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
+ $Module = $1;
+ $Package = defined($2) ? $2 : ''; # keep -w happy
+ $Prefix = defined($3) ? $3 : ''; # keep -w happy
+ $Prefix = quotemeta $Prefix ;
+ ($Module_cname = $Module) =~ s/\W/_/g;
+ ($Packid = $Package) =~ tr/:/_/;
+ $Packprefix = $Package;
+ $Packprefix .= "::" if $Packprefix ne "";
+ $lastline = "";
+ }
+
+ for (;;) {
+ # Skip embedded PODs
+ while ($lastline =~ /^=/) {
+ while ($lastline = <$FH>) {
+ last if ($lastline =~ /^=cut\s*$/);
+ }
+ death ("Error: Unterminated pod") unless $lastline;
+ $lastline = <$FH>;
+ chomp $lastline;
+ $lastline =~ s/^\s+$//;
+ }
+ if ($lastline !~ /^\s*#/ ||
+ # CPP directives:
+ # ANSI: if ifdef ifndef elif else endif define undef
+ # line error pragma
+ # gcc: warning include_next
+ # obj-c: import
+ # others: ident (gcc notes that some cpps have this one)
+ $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) {
+ last if $lastline =~ /^\S/ && @line && $line[-1] eq "";
+ push(@line, $lastline);
+ push(@line_no, $lastline_no) ;
+ }
+
+ # Read next line and continuation lines
+ last unless defined($lastline = <$FH>);
+ $lastline_no = $.;
+ my $tmp_line;
+ $lastline .= $tmp_line
+ while ($lastline =~ /\\$/ && defined($tmp_line = <$FH>));
+
+ chomp $lastline;
+ $lastline =~ s/^\s+$//;
+ }
+ pop(@line), pop(@line_no) while @line && $line[-1] eq "";
+ 1;
+}
+
+sub output_init {
+ local($type, $num, $var, $init, $name_printed) = @_;
+ local($arg) = "ST(" . ($num - 1) . ")";
+
+ if ( $init =~ /^=/ ) {
+ if ($name_printed) {
+ eval qq/print " $init\\n"/;
+ } else {
+ eval qq/print "\\t$var $init\\n"/;
+ }
+ warn $@ if $@;
+ } else {
+ if ( $init =~ s/^\+// && $num ) {
+ &generate_init($type, $num, $var, $name_printed);
+ } elsif ($name_printed) {
+ print ";\n";
+ $init =~ s/^;//;
+ } else {
+ eval qq/print "\\t$var;\\n"/;
+ warn $@ if $@;
+ $init =~ s/^;//;
+ }
+ $deferred .= eval qq/"\\n\\t$init\\n"/;
+ warn $@ if $@;
+ }
+}
+
+sub Warn
+ {
+ # work out the line number
+ my $line_no = $line_no[@line_no - @line -1] ;
+
+ print STDERR "@_ in $filename, line $line_no\n" ;
+ }
+
+sub blurt
+ {
+ Warn @_ ;
+ $errors ++
+ }
+
+sub death
+ {
+ Warn @_ ;
+ exit 1 ;
+ }
+
+sub generate_init {
+ local($type, $num, $var) = @_;
+ local($arg) = "ST(" . ($num - 1) . ")";
+ local($argoff) = $num - 1;
+ local($ntype);
+ local($tk);
+
+ $type = TidyType($type) ;
+ blurt("Error: '$type' not in typemap"), return
+ unless defined($type_kind{$type});
+
+ ($ntype = $type) =~ s/\s*\*/Ptr/g;
+ ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
+ $tk = $type_kind{$type};
+ $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
+ if ($tk eq 'T_PV' and exists $lengthof{$var}) {
+ print "\t$var" unless $name_printed;
+ print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n";
+ die "default value not supported with length(NAME) supplied"
+ if defined $defaults{$var};
+ return;
+ }
+ $type =~ tr/:/_/ unless $hiertype;
+ blurt("Error: No INPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
+ unless defined $input_expr{$tk} ;
+ $expr = $input_expr{$tk};
+ if ($expr =~ /DO_ARRAY_ELEM/) {
+ blurt("Error: '$subtype' not in typemap"), return
+ unless defined($type_kind{$subtype});
+ blurt("Error: No INPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
+ unless defined $input_expr{$type_kind{$subtype}} ;
+ $subexpr = $input_expr{$type_kind{$subtype}};
+ $subexpr =~ s/\$type/\$subtype/g;
+ $subexpr =~ s/ntype/subtype/g;
+ $subexpr =~ s/\$arg/ST(ix_$var)/g;
+ $subexpr =~ s/\n\t/\n\t\t/g;
+ $subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g;
+ $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
+ $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
+ }
+ if ($expr =~ m#/\*.*scope.*\*/#i) { # "scope" in C comments
+ $ScopeThisXSUB = 1;
+ }
+ if (defined($defaults{$var})) {
+ $expr =~ s/(\t+)/$1 /g;
+ $expr =~ s/ /\t/g;
+ if ($name_printed) {
+ print ";\n";
+ } else {
+ eval qq/print "\\t$var;\\n"/;
+ warn $@ if $@;
+ }
+ if ($defaults{$var} eq 'NO_INIT') {
+ $deferred .= eval qq/"\\n\\tif (items >= $num) {\\n$expr;\\n\\t}\\n"/;
+ } else {
+ $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
+ }
+ warn $@ if $@;
+ } elsif ($ScopeThisXSUB or $expr !~ /^\s*\$var =/) {
+ if ($name_printed) {
+ print ";\n";
+ } else {
+ eval qq/print "\\t$var;\\n"/;
+ warn $@ if $@;
+ }
+ $deferred .= eval qq/"\\n$expr;\\n"/;
+ warn $@ if $@;
+ } else {
+ die "panic: do not know how to handle this branch for function pointers"
+ if $name_printed;
+ eval qq/print "$expr;\\n"/;
+ warn $@ if $@;
+ }
+}
+
+sub generate_output {
+ local($type, $num, $var, $do_setmagic, $do_push) = @_;
+ local($arg) = "ST(" . ($num - ($num != 0)) . ")";
+ local($argoff) = $num - 1;
+ local($ntype);
+
+ $type = TidyType($type) ;
+ if ($type =~ /^array\(([^,]*),(.*)\)/) {
+ print "\t$arg = sv_newmortal();\n";
+ print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n";
+ print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
+ } else {
+ blurt("Error: '$type' not in typemap"), return
+ unless defined($type_kind{$type});
+ blurt("Error: No OUTPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
+ unless defined $output_expr{$type_kind{$type}} ;
+ ($ntype = $type) =~ s/\s*\*/Ptr/g;
+ $ntype =~ s/\(\)//g;
+ ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
+ $expr = $output_expr{$type_kind{$type}};
+ if ($expr =~ /DO_ARRAY_ELEM/) {
+ blurt("Error: '$subtype' not in typemap"), return
+ unless defined($type_kind{$subtype});
+ blurt("Error: No OUTPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
+ unless defined $output_expr{$type_kind{$subtype}} ;
+ $subexpr = $output_expr{$type_kind{$subtype}};
+ $subexpr =~ s/ntype/subtype/g;
+ $subexpr =~ s/\$arg/ST(ix_$var)/g;
+ $subexpr =~ s/\$var/${var}[ix_$var]/g;
+ $subexpr =~ s/\n\t/\n\t\t/g;
+ $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
+ eval "print qq\a$expr\a";
+ warn $@ if $@;
+ print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic;
+ } elsif ($var eq 'RETVAL') {
+ if ($expr =~ /^\t\$arg = new/) {
+ # We expect that $arg has refcnt 1, so we need to
+ # mortalize it.
+ eval "print qq\a$expr\a";
+ warn $@ if $@;
+ print "\tsv_2mortal(ST($num));\n";
+ print "\tSvSETMAGIC(ST($num));\n" if $do_setmagic;
+ } elsif ($expr =~ /^\s*\$arg\s*=/) {
+ # We expect that $arg has refcnt >=1, so we need
+ # to mortalize it!
+ eval "print qq\a$expr\a";
+ warn $@ if $@;
+ print "\tsv_2mortal(ST(0));\n";
+ print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic;
+ } else {
+ # Just hope that the entry would safely write it
+ # over an already mortalized value. By
+ # coincidence, something like $arg = &sv_undef
+ # works too.
+ print "\tST(0) = sv_newmortal();\n";
+ eval "print qq\a$expr\a";
+ warn $@ if $@;
+ # new mortals don't have set magic
+ }
+ } elsif ($do_push) {
+ print "\tPUSHs(sv_newmortal());\n";
+ $arg = "ST($num)";
+ eval "print qq\a$expr\a";
+ warn $@ if $@;
+ print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
+ } elsif ($arg =~ /^ST\(\d+\)$/) {
+ eval "print qq\a$expr\a";
+ warn $@ if $@;
+ print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
+ }
+ }
+}
+
+sub map_type {
+ my($type, $varname) = @_;
+
+ # C++ has :: in types too so skip this
+ $type =~ tr/:/_/ unless $hiertype;
+ $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
+ if ($varname) {
+ if ($varname && $type =~ / \( \s* \* (?= \s* \) ) /xg) {
+ (substr $type, pos $type, 0) = " $varname ";
+ } else {
+ $type .= "\t$varname";
+ }
+ }
+ $type;
+}
+
+
+#########################################################
+package
+ ExtUtils::ParseXS::CountLines;
+use strict;
+use vars qw($SECTION_END_MARKER);
+
+sub TIEHANDLE {
+ my ($class, $cfile, $fh) = @_;
+ $cfile =~ s/\\/\\\\/g;
+ $SECTION_END_MARKER = qq{#line --- "$cfile"};
+
+ return bless {buffer => '',
+ fh => $fh,
+ line_no => 1,
+ }, $class;
+}
+
+sub PRINT {
+ my $self = shift;
+ for (@_) {
+ $self->{buffer} .= $_;
+ while ($self->{buffer} =~ s/^([^\n]*\n)//) {
+ my $line = $1;
+ ++ $self->{line_no};
+ $line =~ s|^\#line\s+---(?=\s)|#line $self->{line_no}|;
+ print {$self->{fh}} $line;
+ }
+ }
+}
+
+sub PRINTF {
+ my $self = shift;
+ my $fmt = shift;
+ $self->PRINT(sprintf($fmt, @_));
+}
+
+sub DESTROY {
+ # Not necessary if we're careful to end with a "\n"
+ my $self = shift;
+ print {$self->{fh}} $self->{buffer};
+}
+
+sub UNTIE {
+ # This sub does nothing, but is neccessary for references to be released.
+}
+
+sub end_marker {
+ return $SECTION_END_MARKER;
+}
+
+
+1;
+__END__
+
+=head1 NAME
+
+ExtUtils::ParseXS - converts Perl XS code into C code
+
+=head1 SYNOPSIS
+
+ use ExtUtils::ParseXS qw(process_file);
+
+ process_file( filename => 'foo.xs' );
+
+ process_file( filename => 'foo.xs',
+ output => 'bar.c',
+ 'C++' => 1,
+ typemap => 'path/to/typemap',
+ hiertype => 1,
+ except => 1,
+ prototypes => 1,
+ versioncheck => 1,
+ linenumbers => 1,
+ optimize => 1,
+ prototypes => 1,
+ );
+=head1 DESCRIPTION
+
+C<ExtUtils::ParseXS> will compile XS code into C code by embedding the constructs
+necessary to let C functions manipulate Perl values and creates the glue
+necessary to let Perl access those functions. The compiler uses typemaps to
+determine how to map C function parameters and variables to Perl values.
+
+The compiler will search for typemap files called I<typemap>. It will use
+the following search path to find default typemaps, with the rightmost
+typemap taking precedence.
+
+ ../../../typemap:../../typemap:../typemap:typemap
+
+=head1 EXPORT
+
+None by default. C<process_file()> may be exported upon request.
+
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item process_xs()
+
+This function processes an XS file and sends output to a C file.
+Named parameters control how the processing is done. The following
+parameters are accepted:
+
+=over 4
+
+=item B<C++>
+
+Adds C<extern "C"> to the C code. Default is false.
+
+=item B<hiertype>
+
+Retains C<::> in type names so that C++ hierachical types can be
+mapped. Default is false.
+
+=item B<except>
+
+Adds exception handling stubs to the C code. Default is false.
+
+=item B<typemap>
+
+Indicates that a user-supplied typemap should take precedence over the
+default typemaps. A single typemap may be specified as a string, or
+multiple typemaps can be specified in an array reference, with the
+last typemap having the highest precedence.
+
+=item B<prototypes>
+
+Generates prototype code for all xsubs. Default is false.
+
+=item B<versioncheck>
+
+Makes sure at run time that the object file (derived from the C<.xs>
+file) and the C<.pm> files have the same version number. Default is
+true.
+
+=item B<linenumbers>
+
+Adds C<#line> directives to the C output so error messages will look
+like they came from the original XS file. Default is true.
+
+=item B<optimize>
+
+Enables certain optimizations. The only optimization that is currently
+affected is the use of I<target>s by the output C code (see L<perlguts>).
+Not optimizing may significantly slow down the generated code, but this is the way
+B<xsubpp> of 5.005 and earlier operated. Default is to optimize.
+
+=item B<inout>
+
+Enable recognition of C<IN>, C<OUT_LIST> and C<INOUT_LIST>
+declarations. Default is true.
+
+=item B<argtypes>
+
+Enable recognition of ANSI-like descriptions of function signature.
+Default is true.
+
+=item B<s>
+
+I have no clue what this does. Strips function prefixes?
+
+=back
+
+=item errors()
+
+This function returns the number of [a certain kind of] errors
+encountered during processing of the XS file.
+
+=back
+
+=head1 AUTHOR
+
+Based on xsubpp code, written by Larry Wall.
+
+Maintained by Ken Williams, <ken at mathforum.org>
+
+=head1 COPYRIGHT
+
+Copyright 2002-2003 Ken Williams. All rights reserved.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+Based on the ExtUtils::xsubpp code by Larry Wall and the Perl 5
+Porters, which was released under the same license terms.
+
+=head1 SEE ALSO
+
+L<perl>, ExtUtils::xsubpp, ExtUtils::MakeMaker, L<perlxs>, L<perlxstut>.
+
+=cut
Copied: trunk/contrib/perl/lib/ExtUtils/README (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/README)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/README (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/README 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,57 @@
+This is a CPAN distribution of the venerable MakeMaker module. It has been
+backported to work with Perl 5.005_03 and up.
+
+If you do not have a make program, several can be found...
+
+Most Unixen: The make utility which comes with your operating system
+should work fine. If you don't have one, GNU make is recommended,
+most others (Sun, BSD, etc...) will work fine as well.
+http://www.gnu.org/software/make/make.html GNU make
+
+Windows: nmake or dmake will work. GNU make will *not*.
+ftp://ftp.microsoft.com/Softlib/MSLFILES/nmake15.exe nmake
+http://search.cpan.org/dist/dmake/ dmake
+
+VMS: MMS or the free MadGoat MaKe utility (MMK) will work.
+http://www.madgoat.com/mmk.html MMK
+
+If all else fails there is a pure Perl version of make available on
+CPAN which should work on most Unixen.
+http://search.cpan.org/author/NI-S/Make-1.00/ pmake
+
+
+PLEASE NOTE: This distribution does not include the xsubpp or typemap
+programs. They are extremely specific to your version or Perl, so
+MakeMaker will simply use the one which came with your copy of Perl.
+Do not delete your old ExtUtils/ directory. An upgraded version of xsubpp
+can be found in the ExtUtils::ParseXS module.
+
+Known Good Systems:
+
+Every stable MakeMaker release is tested at least on:
+
+MacOS X
+Linux/x86
+ActivePerl on Windows
+Cygwin
+OpenVMS
+
+Covering the major portability flavors MakeMaker has to cover.
+(I'm always on the lookout for DJGPP, Solaris, *BSD and OS/2 users)
+
+
+Known Problems:
+
+(See http://rt.cpan.org for a full list of open problems.)
+
+Windows will likely be broken if Perl is installed in C:\Program Files or
+other prefix with a space in the name.
+
+Using the MMS utility on VMS causes lots of extra newlines. Unknown
+why this is so, might be a bug in MMS. Problem not seen with MMK.
+
+GNU make does not work with MakeMaker on Windows.
+
+
+Please report any bugs via http://rt.cpan.org.
+Send questions and discussion to makemaker at perl.org
Copied: trunk/contrib/perl/lib/ExtUtils/TODO (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/TODO)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/TODO (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/TODO 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,78 @@
+This TODO list is out of date. See http://rt.cpan.org for the real list.
+
+
+Rethink MM_Win32 tests.
+
+Investigate one method per make target.
+
+Test MM_Any and pull some redundant tests out of MM_*.t
+
+Create a way to init MM objects. (XXX What's wrong with MakeMaker->new?)
+
+Move instmodsh to utils/ in the core.
+
+Handle config files (ie. /etc) and their special PREFIX needs
+(ie. PREFIX=/usr, INSTALLCONFIGDIR=/etc).
+
+Make sure PDL builds
+
+Fix find_perl on Amiga trg at privat.utfors.se
+
+Fix appending of .. when DIRS contains directories not immediately
+below the cwd.
+
+Fill in the IMPORTS docs.
+
+Remove tar -I Sun-ism from instmodsh.
+
+Consider adding a timeout option to prompt() and env variable.
+
+Unify VMS->find_perl
+
+Consider if VMS->find_perl needs to have pieces put into maybe_command()
+
+Add a MM_Any->init_others() using ExtUtils::Command.
+
+Figure out and document the 4th arg to ExtUtils::Install::install()
+
+Consider if adding a nativize() routine to replace macify() and
+fixpath() is useful.
+
+Eliminate eliminate_macros() from inside FS::VMS->catfile and catdir.
+Make into MM_VMS wrappers.
+
+Test ExtUtils::Command::MM
+
+Finish ExtUtils::MakeMaker::Tutorial
+
+Add 'how to install additional files' to ExtUtils::MakeMaker::FAQ.
+
+Give typemap location its own macro.
+
+Merge MM_VMS->tool_xsubpp
+
+Initialize PERL_SRC to '' instead of leaving undef when outside the source
+tree
+
+Reinstate HTMLification to use the new HTML Config info.
+
+split manifypods target into more generic docifypods target which depends on
+manifypods
+
+Add target to generate native Win32 help files (or whatever Win32 likes
+to use for help files these days)
+
+Add target to generate native VMS help files.
+
+On VMS, write PM_FILTERs to a temp file and run from there avoiding command
+line lengths. Worth the trouble given the Unixy nature of PM_FILTER?
+
+Move oneliner() and friends into a seperate module for general consumption.
+
+Make out of date check on 'make dist' more useful
+http://archive.develooper.com/makemaker@perl.org/msg01075.html
+
+Make maniadd() return a tied, case-insensitive hash on VMS.
+
+
+TER
\ No newline at end of file
Index: trunk/contrib/perl/lib/ExtUtils/XSSymSet.pm
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/XSSymSet.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/ExtUtils/XSSymSet.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/ExtUtils/XSSymSet.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/lib/ExtUtils/instmodsh (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/instmodsh)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/instmodsh (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/instmodsh 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,192 @@
+#!/usr/bin/perl -w
+
+use strict;
+use IO::File;
+use ExtUtils::Packlist;
+use ExtUtils::Installed;
+
+use vars qw($Inst @Modules);
+
+
+=head1 NAME
+
+instmodsh - A shell to examine installed modules
+
+=head1 SYNOPSIS
+
+ instmodsh
+
+=head1 DESCRIPTION
+
+A little interface to ExtUtils::Installed to examine installed modules,
+validate your packlists and even create a tarball from an installed module.
+
+=head1 SEE ALSO
+
+ExtUtils::Installed
+
+=cut
+
+
+my $Module_Help = <<EOF;
+Available commands are:
+ f [all|prog|doc] - List installed files of a given type
+ d [all|prog|doc] - List the directories used by a module
+ v - Validate the .packlist - check for missing files
+ t <tarfile> - Create a tar archive of the module
+ h - Display module help
+ q - Quit the module
+EOF
+
+my %Module_Commands = (
+ f => \&list_installed,
+ d => \&list_directories,
+ v => \&validate_packlist,
+ t => \&create_archive,
+ h => \&module_help,
+ );
+
+sub do_module($) {
+ my ($module) = @_;
+
+ print($Module_Help);
+ MODULE_CMD: while (1) {
+ print("$module cmd? ");
+
+ my $reply = <STDIN>; chomp($reply);
+ my($cmd) = $reply =~ /^(\w)\b/;
+
+ last if $cmd eq 'q';
+
+ if( $Module_Commands{$cmd} ) {
+ $Module_Commands{$cmd}->($reply, $module);
+ }
+ elsif( $cmd eq 'q' ) {
+ last MODULE_CMD;
+ }
+ else {
+ module_help();
+ }
+ }
+}
+
+
+sub list_installed {
+ my($reply, $module) = @_;
+
+ my $class = (split(' ', $reply))[1];
+ $class = 'all' unless $class;
+
+ my @files;
+ if (eval { @files = $Inst->files($module, $class); }) {
+ print("$class files in $module are:\n ",
+ join("\n ", @files), "\n");
+ }
+ else {
+ print($@);
+ }
+};
+
+
+sub list_directories {
+ my($reply, $module) = @_;
+
+ my $class = (split(' ', $reply))[1];
+ $class = 'all' unless $class;
+
+ my @dirs;
+ if (eval { @dirs = $Inst->directories($module, $class); }) {
+ print("$class directories in $module are:\n ",
+ join("\n ", @dirs), "\n");
+ }
+ else {
+ print($@);
+ }
+}
+
+
+sub create_archive {
+ my($reply, $module) = @_;
+
+ my $file = (split(' ', $reply))[1];
+
+ if( !(defined $file and length $file) ) {
+ print "No tar file specified\n";
+ }
+ elsif( eval { require Archive::Tar } ) {
+ Archive::Tar->create_archive($file, 0, $Inst->files($module));
+ }
+ else {
+ my($first, @rest) = $Inst->files($module);
+ system('tar', 'cvf', $file, $first);
+ for my $f (@rest) {
+ system('tar', 'rvf', $file, $f);
+ }
+ print "Can't use tar\n" if $?;
+ }
+}
+
+
+sub validate_packlist {
+ my($reply, $module) = @_;
+
+ if (my @missing = $Inst->validate($module)) {
+ print("Files missing from $module are:\n ",
+ join("\n ", @missing), "\n");
+ }
+ else {
+ print("$module has no missing files\n");
+ }
+}
+
+sub module_help {
+ print $Module_Help;
+}
+
+
+
+##############################################################################
+
+sub toplevel()
+{
+my $help = <<EOF;
+Available commands are:
+ l - List all installed modules
+ m <module> - Select a module
+ q - Quit the program
+EOF
+print($help);
+while (1)
+ {
+ print("cmd? ");
+ my $reply = <STDIN>; chomp($reply);
+ CASE:
+ {
+ $reply eq 'l' and do
+ {
+ print("Installed modules are:\n ", join("\n ", @Modules), "\n");
+ last CASE;
+ };
+ $reply =~ /^m\s+/ and do
+ {
+ do_module((split(' ', $reply))[1]);
+ last CASE;
+ };
+ $reply eq 'q' and do
+ {
+ exit(0);
+ };
+ # Default
+ print($help);
+ }
+ }
+}
+
+
+###############################################################################
+
+$Inst = ExtUtils::Installed->new();
+ at Modules = $Inst->modules();
+toplevel();
+
+###############################################################################
Copied: trunk/contrib/perl/lib/ExtUtils/t/00compile.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/00compile.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/00compile.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/00compile.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,42 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+chdir 't';
+
+use Test::More;
+
+my $Has_Test_Pod;
+BEGIN {
+ $Has_Test_Pod = eval 'use Test::Pod 0.95; 1';
+}
+
+chdir "..";
+my $manifest = "MANIFEST";
+open(my $manifest_fh, "<", $manifest) or die "Can't open $manifest: $!";
+my @modules = map { m{^lib/(\S+)}; $1 }
+ grep { m{^lib/ExtUtils/\S*\.pm} }
+ grep { !m{/t/} } <$manifest_fh>;
+chomp @modules;
+close $manifest_fh;
+
+chdir 'lib';
+plan tests => scalar @modules * 2;
+foreach my $file (@modules) {
+ # Make sure we look at the local files and do not reload them if
+ # they're already loaded. This avoids recompilation warnings.
+ local @INC = @INC;
+ unshift @INC, ".";
+ ok eval { require($file); 1 } or diag "require $file failed.\n$@";
+
+ SKIP: {
+ skip "Test::Pod not installed", 1 unless $Has_Test_Pod;
+ pod_file_ok($file);
+ }
+}
Copied: trunk/contrib/perl/lib/ExtUtils/t/Constant.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/Constant.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/Constant.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/Constant.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,1056 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ use Config;
+ unless ($Config{usedl}) {
+ print "1..0 # no usedl, skipping\n";
+ exit 0;
+ }
+}
+
+# use warnings;
+use strict;
+use ExtUtils::MakeMaker;
+use ExtUtils::Constant qw (C_constant autoload);
+use File::Spec;
+use Cwd;
+
+my $do_utf_tests = $] > 5.006;
+my $better_than_56 = $] > 5.007;
+# For debugging set this to 1.
+my $keep_files = 0;
+$| = 1;
+
+# Because were are going to be changing directory before running Makefile.PL
+my $perl = $^X;
+# 5.005 doesn't have new enough File::Spec to have rel2abs. But actually we
+# only need it when $^X isn't absolute, which is going to be 5.8.0 or later
+# (where ExtUtils::Constant is in the core, and tests against the uninstalled
+# perl)
+$perl = File::Spec->rel2abs ($perl) unless $] < 5.006;
+# ExtUtils::Constant::C_constant uses $^X inside a comment, and we want to
+# compare output to ensure that it is the same. We were probably run as ./perl
+# whereas we will run the child with the full path in $perl. So make $^X for
+# us the same as our child will see.
+$^X = $perl;
+my $lib = $ENV{PERL_CORE} ? '../../../lib' : '../../blib/lib';
+my $runperl = "$perl \"-I$lib\"";
+print "# perl=$perl\n";
+
+my $make = $Config{make};
+$make = $ENV{MAKE} if exists $ENV{MAKE};
+if ($^O eq 'MSWin32' && $make eq 'nmake') { $make .= " -nologo"; }
+
+# VMS may be using something other than MMS/MMK
+my $mms_or_mmk = 0;
+my $vms_lc = 0;
+my $vms_nodot = 0;
+if ($^O eq 'VMS') {
+ $mms_or_mmk = 1 if (($make eq 'MMK') || ($make eq 'MMS'));
+ $vms_lc = 1;
+ $vms_nodot = 1;
+ my $vms_unix_rpt = 0;
+ my $vms_efs = 0;
+ my $vms_efs_case = 0;
+ if (eval 'require VMS::Feature') {
+ $vms_unix_rpt = VMS::Feature::current("filename_unix_report");
+ $vms_efs = VMS::Feature::current("efs_case_preserve");
+ $vms_efs_case = VMS::Feature::current("efs_charset");
+ } else {
+ my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
+ my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || '';
+ my $efs_case = $ENV{'DECC$EFS_CASE_PRESERVE'} || '';
+ $vms_unix_rpt = $unix_rpt =~ /^[ET1]/i;
+ $vms_efs = $efs_charset =~ /^[ET1]/i;
+ $vms_efs_case = $efs_case =~ /^[ET1]/i;
+ }
+ $vms_lc = 0 if $vms_efs_case;
+ $vms_nodot = 0 if $vms_unix_rpt;
+}
+
+# Renamed by make clean
+my $makefile = ($mms_or_mmk ? 'descrip' : 'Makefile');
+my $makefile_ext = ($mms_or_mmk ? '.mms' : '');
+my $makefile_rename = $makefile . ($mms_or_mmk ? '.mms_old' : '.old');
+
+my $output = "output";
+my $package = "ExtTest";
+my $dir = "ext-$$";
+my $subdir = 0;
+# The real test counter.
+my $realtest = 1;
+
+my $orig_cwd = cwd;
+my $updir = File::Spec->updir;
+die "Can't get current directory: $!" unless defined $orig_cwd;
+
+print "# $dir being created...\n";
+mkdir $dir, 0777 or die "mkdir: $!\n";
+
+END {
+ if (defined $orig_cwd and length $orig_cwd) {
+ chdir $orig_cwd or die "Can't chdir back to '$orig_cwd': $!";
+ use File::Path;
+ print "# $dir being removed...\n";
+ rmtree($dir) unless $keep_files;
+ } else {
+ # Can't get here.
+ die "cwd at start was empty, but directory '$dir' was created" if $dir;
+ }
+}
+
+chdir $dir or die $!;
+push @INC, '../../lib', '../../../lib';
+
+package TieOut;
+
+sub TIEHANDLE {
+ my $class = shift;
+ bless(\( my $ref = ''), $class);
+}
+
+sub PRINT {
+ my $self = shift;
+ $$self .= join('', @_);
+}
+
+sub PRINTF {
+ my $self = shift;
+ $$self .= sprintf shift, @_;
+}
+
+sub read {
+ my $self = shift;
+ return substr($$self, 0, length($$self), '');
+}
+
+package main;
+
+sub check_for_bonus_files {
+ my $dir = shift;
+ my %expect = map {($vms_lc ? lc($_) : $_), 1} @_;
+
+ my $fail;
+ opendir DIR, $dir or die "opendir '$dir': $!";
+ while (defined (my $entry = readdir DIR)) {
+ $entry =~ s/\.$// if $vms_nodot; # delete trailing dot that indicates no extension
+ next if $expect{$entry};
+ print "# Extra file '$entry'\n";
+ $fail = 1;
+ }
+
+ closedir DIR or warn "closedir '.': $!";
+ if ($fail) {
+ print "not ok $realtest\n";
+ } else {
+ print "ok $realtest\n";
+ }
+ $realtest++;
+}
+
+sub build_and_run {
+ my ($tests, $expect, $files) = @_;
+ my $core = $ENV{PERL_CORE} ? ' PERL_CORE=1' : '';
+ my @perlout = `$runperl Makefile.PL $core`;
+ if ($?) {
+ print "not ok $realtest # $runperl Makefile.PL failed: $?\n";
+ print "# $_" foreach @perlout;
+ exit($?);
+ } else {
+ print "ok $realtest\n";
+ }
+ $realtest++;
+
+ if (-f "$makefile$makefile_ext") {
+ print "ok $realtest\n";
+ } else {
+ print "not ok $realtest\n";
+ }
+ $realtest++;
+
+ my @makeout;
+
+ if ($^O eq 'VMS') { $make .= ' all'; }
+
+ # Sometimes it seems that timestamps can get confused
+
+ # make failed: 256
+ # Makefile out-of-date with respect to Makefile.PL
+ # Cleaning current config before rebuilding Makefile...
+ # make -f Makefile.old clean > /dev/null 2>&1 || /bin/sh -c true
+ # ../../perl "-I../../../lib" "-I../../../lib" Makefile.PL "PERL_CORE=1"
+ # Checking if your kit is complete...
+ # Looks good
+ # Writing Makefile for ExtTest
+ # ==> Your Makefile has been rebuilt. <==
+ # ==> Please rerun the make command. <==
+ # false
+
+ my $timewarp = (-M "Makefile.PL") - (-M "$makefile$makefile_ext");
+ # Convert from days to seconds
+ $timewarp *= 86400;
+ print "# Makefile.PL is $timewarp second(s) older than $makefile$makefile_ext\n";
+ if ($timewarp < 0) {
+ # Sleep for a while to catch up.
+ $timewarp = -$timewarp;
+ $timewarp+=2;
+ $timewarp = 10 if $timewarp > 10;
+ print "# Sleeping for $timewarp second(s) to try to resolve this\n";
+ sleep $timewarp;
+ }
+
+ print "# make = '$make'\n";
+ @makeout = `$make`;
+ if ($?) {
+ print "not ok $realtest # $make failed: $?\n";
+ print "# $_" foreach @makeout;
+ exit($?);
+ } else {
+ print "ok $realtest\n";
+ }
+ $realtest++;
+
+ if ($^O eq 'VMS') { $make =~ s{ all}{}; }
+
+ if ($Config{usedl}) {
+ print "ok $realtest # This is dynamic linking, so no need to make perl\n";
+ } else {
+ my $makeperl = "$make perl";
+ print "# make = '$makeperl'\n";
+ @makeout = `$makeperl`;
+ if ($?) {
+ print "not ok $realtest # $makeperl failed: $?\n";
+ print "# $_" foreach @makeout;
+ exit($?);
+ } else {
+ print "ok $realtest\n";
+ }
+ }
+ $realtest++;
+
+ my $maketest = "$make test";
+ print "# make = '$maketest'\n";
+
+ @makeout = `$maketest`;
+
+ if (open OUTPUT, "<$output") {
+ local $/; # Slurp it - faster.
+ print <OUTPUT>;
+ close OUTPUT or print "# Close $output failed: $!\n";
+ } else {
+ # Harness will report missing test results at this point.
+ print "# Open <$output failed: $!\n";
+ }
+
+ $realtest += $tests;
+ if ($?) {
+ print "not ok $realtest # $maketest failed: $?\n";
+ print "# $_" foreach @makeout;
+ } else {
+ print "ok $realtest - maketest\n";
+ }
+ $realtest++;
+
+ if (defined $expect) {
+ # -x is busted on Win32 < 5.6.1, so we emulate it.
+ my $regen;
+ if( $^O eq 'MSWin32' && $] <= 5.006001 ) {
+ open(REGENTMP, ">regentmp") or die $!;
+ open(XS, "$package.xs") or die $!;
+ my $saw_shebang;
+ while(<XS>) {
+ $saw_shebang++ if /^#!.*/i ;
+ print REGENTMP $_ if $saw_shebang;
+ }
+ close XS; close REGENTMP;
+ $regen = `$runperl regentmp`;
+ unlink 'regentmp';
+ }
+ else {
+ $regen = `$runperl -x $package.xs`;
+ }
+ if ($?) {
+ print "not ok $realtest # $runperl -x $package.xs failed: $?\n";
+ } else {
+ print "ok $realtest - regen\n";
+ }
+ $realtest++;
+
+ if ($expect eq $regen) {
+ print "ok $realtest - regen worked\n";
+ } else {
+ print "not ok $realtest - regen worked\n";
+ # open FOO, ">expect"; print FOO $expect;
+ # open FOO, ">regen"; print FOO $regen; close FOO;
+ }
+ $realtest++;
+ } else {
+ for (0..1) {
+ print "ok $realtest # skip no regen or expect for this set of tests\n";
+ $realtest++;
+ }
+ }
+
+ my $makeclean = "$make clean";
+ print "# make = '$makeclean'\n";
+ @makeout = `$makeclean`;
+ if ($?) {
+ print "not ok $realtest # $make failed: $?\n";
+ print "# $_" foreach @makeout;
+ } else {
+ print "ok $realtest\n";
+ }
+ $realtest++;
+
+ check_for_bonus_files ('.', @$files, $output, $makefile_rename, '.', '..');
+
+ rename $makefile_rename, $makefile . $makefile_ext
+ or die "Can't rename '$makefile_rename' to '$makefile$makefile_ext': $!";
+
+ unlink $output or warn "Can't unlink '$output': $!";
+
+ # Need to make distclean to remove ../../lib/ExtTest.pm
+ my $makedistclean = "$make distclean";
+ print "# make = '$makedistclean'\n";
+ @makeout = `$makedistclean`;
+ if ($?) {
+ print "not ok $realtest # $make failed: $?\n";
+ print "# $_" foreach @makeout;
+ } else {
+ print "ok $realtest\n";
+ }
+ $realtest++;
+
+ check_for_bonus_files ('.', @$files, '.', '..');
+
+ unless ($keep_files) {
+ foreach (@$files) {
+ unlink $_ or warn "unlink $_: $!";
+ }
+ }
+
+ check_for_bonus_files ('.', '.', '..');
+}
+
+sub Makefile_PL {
+ my $package = shift;
+ ################ Makefile.PL
+ # We really need a Makefile.PL because make test for a no dynamic linking perl
+ # will run Makefile.PL again as part of the "make perl" target.
+ my $makefilePL = "Makefile.PL";
+ open FH, ">$makefilePL" or die "open >$makefilePL: $!\n";
+ print FH <<"EOT";
+#!$perl -w
+use ExtUtils::MakeMaker;
+WriteMakefile(
+ 'NAME' => "$package",
+ 'VERSION_FROM' => "$package.pm", # finds \$VERSION
+ (\$] >= 5.005 ?
+ (#ABSTRACT_FROM => "$package.pm", # XXX add this
+ AUTHOR => "$0") : ())
+ );
+EOT
+
+ close FH or die "close $makefilePL: $!\n";
+ return $makefilePL;
+}
+
+sub MANIFEST {
+ my (@files) = @_;
+ ################ MANIFEST
+ # We really need a MANIFEST because make distclean checks it.
+ my $manifest = "MANIFEST";
+ push @files, $manifest;
+ open FH, ">$manifest" or die "open >$manifest: $!\n";
+ print FH "$_\n" foreach @files;
+ close FH or die "close $manifest: $!\n";
+ return @files;
+}
+
+sub write_and_run_extension {
+ my ($name, $items, $export_names, $package, $header, $testfile, $num_tests,
+ $wc_args) = @_;
+
+ my $c = tie *C, 'TieOut';
+ my $xs = tie *XS, 'TieOut';
+
+ ExtUtils::Constant::WriteConstants(C_FH => \*C,
+ XS_FH => \*XS,
+ NAME => $package,
+ NAMES => $items,
+ @$wc_args,
+ );
+
+ my $C_code = $c->read();
+ my $XS_code = $xs->read();
+
+ undef $c;
+ undef $xs;
+
+ untie *C;
+ untie *XS;
+
+ # Don't check the regeneration code if we specify extra arguments to
+ # WriteConstants. (Fix this to give finer grained control if needed)
+ my $expect;
+ $expect = $C_code . "\n#### XS Section:\n" . $XS_code unless $wc_args;
+
+ print "# $name\n# $dir/$subdir being created...\n";
+ mkdir $subdir, 0777 or die "mkdir: $!\n";
+ chdir $subdir or die $!;
+
+ my @files;
+
+ ################ Header
+ my $header_name = "test.h";
+ push @files, $header_name;
+ open FH, ">$header_name" or die "open >$header_name: $!\n";
+ print FH $header or die $!;
+ close FH or die "close $header_name: $!\n";
+
+ ################ XS
+ my $xs_name = "$package.xs";
+ push @files, $xs_name;
+ open FH, ">$xs_name" or die "open >$xs_name: $!\n";
+
+ print FH <<"EOT";
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#include "$header_name"
+
+
+$C_code
+MODULE = $package PACKAGE = $package
+PROTOTYPES: ENABLE
+$XS_code;
+EOT
+
+ close FH or die "close $xs: $!\n";
+
+ ################ PM
+ my $pm = "$package.pm";
+ push @files, $pm;
+ open FH, ">$pm" or die "open >$pm: $!\n";
+ print FH "package $package;\n";
+ print FH "use $];\n";
+
+ print FH <<'EOT';
+
+use strict;
+EOT
+ printf FH "use warnings;\n" unless $] < 5.006;
+ print FH <<'EOT';
+use Carp;
+
+require Exporter;
+require DynaLoader;
+use vars qw ($VERSION @ISA @EXPORT_OK $AUTOLOAD);
+
+$VERSION = '0.01';
+ at ISA = qw(Exporter DynaLoader);
+EOT
+ # Having this qw( in the here doc confuses cperl mode far too much to be
+ # helpful. And I'm using cperl mode to edit this, even if you're not :-)
+ print FH "\@EXPORT_OK = qw(\n";
+
+ # Print the names of all our autoloaded constants
+ print FH "\t$_\n" foreach (@$export_names);
+ print FH ");\n";
+ # Print the AUTOLOAD subroutine ExtUtils::Constant generated for us
+ print FH autoload ($package, $]);
+ print FH "bootstrap $package \$VERSION;\n1;\n__END__\n";
+ close FH or die "close $pm: $!\n";
+
+ ################ test.pl
+ my $testpl = "test.pl";
+ push @files, $testpl;
+ open FH, ">$testpl" or die "open >$testpl: $!\n";
+ # Standard test header (need an option to suppress this?)
+ print FH <<"EOT" or die $!;
+use strict;
+use $package qw(@$export_names);
+
+print "1..2\n";
+if (open OUTPUT, ">$output") {
+ print "ok 1\n";
+ select OUTPUT;
+} else {
+ print "not ok 1 # Failed to open '$output': \$!\n";
+ exit 1;
+}
+EOT
+ print FH $testfile or die $!;
+ print FH <<"EOT" or die $!;
+select STDOUT;
+if (close OUTPUT) {
+ print "ok 2\n";
+} else {
+ print "not ok 2 # Failed to close '$output': \$!\n";
+}
+EOT
+ close FH or die "close $testpl: $!\n";
+
+ push @files, Makefile_PL($package);
+ @files = MANIFEST (@files);
+
+ build_and_run ($num_tests, $expect, \@files);
+
+ chdir $updir or die "chdir '$updir': $!";
+ ++$subdir;
+}
+
+# Tests are arrayrefs of the form
+# $name, [items], [export_names], $package, $header, $testfile, $num_tests
+my @tests;
+my $before_tests = 4; # Number of "ok"s emitted to build extension
+my $after_tests = 8; # Number of "ok"s emitted after make test run
+my $dummytest = 1;
+
+my $here;
+sub start_tests {
+ $dummytest += $before_tests;
+ $here = $dummytest;
+}
+sub end_tests {
+ my ($name, $items, $export_names, $header, $testfile, $args) = @_;
+ push @tests, [$name, $items, $export_names, $package, $header, $testfile,
+ $dummytest - $here, $args];
+ $dummytest += $after_tests;
+}
+
+my $pound;
+if (ord('A') == 193) { # EBCDIC platform
+ $pound = chr 177; # A pound sign. (Currency)
+} else { # ASCII platform
+ $pound = chr 163; # A pound sign. (Currency)
+}
+my @common_items = (
+ {name=>"perl", type=>"PV",},
+ {name=>"*/", type=>"PV", value=>'"CLOSE"', macro=>1},
+ {name=>"/*", type=>"PV", value=>'"OPEN"', macro=>1},
+ {name=>$pound, type=>"PV", value=>'"Sterling"', macro=>1},
+ );
+
+my @args = undef;
+push @args, [PROXYSUBS => 1] if $] > 5.009002;
+foreach my $args (@args)
+{
+ # Simple tests
+ start_tests();
+ my $parent_rfc1149 =
+ 'A Standard for the Transmission of IP Datagrams on Avian Carriers';
+ # Test the code that generates 1 and 2 letter name comparisons.
+ my %compass = (
+ N => 0, 'NE' => 45, E => 90, SE => 135,
+ S => 180, SW => 225, W => 270, NW => 315
+ );
+
+ my $header = << "EOT";
+#define FIVE 5
+#define OK6 "ok 6\\n"
+#define OK7 1
+#define FARTHING 0.25
+#define NOT_ZERO 1
+#define Yes 0
+#define No 1
+#define Undef 1
+#define RFC1149 "$parent_rfc1149"
+#undef NOTDEF
+#define perl "rules"
+EOT
+
+ while (my ($point, $bearing) = each %compass) {
+ $header .= "#define $point $bearing\n"
+ }
+
+ my @items = ("FIVE", {name=>"OK6", type=>"PV",},
+ {name=>"OK7", type=>"PVN",
+ value=>['"not ok 7\\n\\0ok 7\\n"', 15]},
+ {name => "FARTHING", type=>"NV"},
+ {name => "NOT_ZERO", type=>"UV", value=>"~(UV)0"},
+ {name => "OPEN", type=>"PV", value=>'"/*"', macro=>1},
+ {name => "CLOSE", type=>"PV", value=>'"*/"',
+ macro=>["#if 1\n", "#endif\n"]},
+ {name => "ANSWER", default=>["UV", 42]}, "NOTDEF",
+ {name => "Yes", type=>"YES"},
+ {name => "No", type=>"NO"},
+ {name => "Undef", type=>"UNDEF"},
+ # OK. It wasn't really designed to allow the creation of dual valued
+ # constants.
+ # It was more for INADDR_ANY INADDR_BROADCAST INADDR_LOOPBACK INADDR_NONE
+ {name=>"RFC1149", type=>"SV", value=>"sv_2mortal(temp_sv)",
+ pre=>"SV *temp_sv = newSVpv(RFC1149, 0); "
+ . "(void) SvUPGRADE(temp_sv,SVt_PVIV); SvIOK_on(temp_sv); "
+ . "SvIV_set(temp_sv, 1149);"},
+ );
+
+ push @items, $_ foreach keys %compass;
+
+ # Automatically compile the list of all the macro names, and make them
+ # exported constants.
+ my @export_names = map {(ref $_) ? $_->{name} : $_} @items;
+
+ # Exporter::Heavy (currently) isn't able to export the last 3 of these:
+ push @items, @common_items;
+
+ my $test_body = <<"EOT";
+
+my \$test = $dummytest;
+
+EOT
+
+ $test_body .= <<'EOT';
+# What follows goes to the temporary file.
+# IV
+my $five = FIVE;
+if ($five == 5) {
+ print "ok $test\n";
+} else {
+ print "not ok $test # \$five\n";
+}
+$test++;
+
+# PV
+if (OK6 eq "ok 6\n") {
+ print "ok $test\n";
+} else {
+ print "not ok $test # \$five\n";
+}
+$test++;
+
+# PVN containing embedded \0s
+$_ = OK7;
+s/.*\0//s;
+s/7/$test/;
+$test++;
+print;
+
+# NV
+my $farthing = FARTHING;
+if ($farthing == 0.25) {
+ print "ok $test\n";
+} else {
+ print "not ok $test # $farthing\n";
+}
+$test++;
+
+# UV
+my $not_zero = NOT_ZERO;
+if ($not_zero > 0 && $not_zero == ~0) {
+ print "ok $test\n";
+} else {
+ print "not ok $test # \$not_zero=$not_zero ~0=" . (~0) . "\n";
+}
+$test++;
+
+# Value includes a "*/" in an attempt to bust out of a C comment.
+# Also tests custom cpp #if clauses
+my $close = CLOSE;
+if ($close eq '*/') {
+ print "ok $test\n";
+} else {
+ print "not ok $test # \$close='$close'\n";
+}
+$test++;
+
+# Default values if macro not defined.
+my $answer = ANSWER;
+if ($answer == 42) {
+ print "ok $test\n";
+} else {
+ print "not ok $test # What do you get if you multiply six by nine? '$answer'\n";
+}
+$test++;
+
+# not defined macro
+my $notdef = eval { NOTDEF; };
+if (defined $notdef) {
+ print "not ok $test # \$notdef='$notdef'\n";
+} elsif ($@ !~ /Your vendor has not defined ExtTest macro NOTDEF/) {
+ print "not ok $test # \$@='$@'\n";
+} else {
+ print "ok $test\n";
+}
+$test++;
+
+# not a macro
+my $notthere = eval { &ExtTest::NOTTHERE; };
+if (defined $notthere) {
+ print "not ok $test # \$notthere='$notthere'\n";
+} elsif ($@ !~ /NOTTHERE is not a valid ExtTest macro/) {
+ chomp $@;
+ print "not ok $test # \$@='$@'\n";
+} else {
+ print "ok $test\n";
+}
+$test++;
+
+# Truth
+my $yes = Yes;
+if ($yes) {
+ print "ok $test\n";
+} else {
+ print "not ok $test # $yes='\$yes'\n";
+}
+$test++;
+
+# Falsehood
+my $no = No;
+if (defined $no and !$no) {
+ print "ok $test\n";
+} else {
+ print "not ok $test # \$no=" . defined ($no) ? "'$no'\n" : "undef\n";
+}
+$test++;
+
+# Undef
+my $undef = Undef;
+unless (defined $undef) {
+ print "ok $test\n";
+} else {
+ print "not ok $test # \$undef='$undef'\n";
+}
+$test++;
+
+# invalid macro (chosen to look like a mix up between No and SW)
+$notdef = eval { &ExtTest::So };
+if (defined $notdef) {
+ print "not ok $test # \$notdef='$notdef'\n";
+} elsif ($@ !~ /^So is not a valid ExtTest macro/) {
+ print "not ok $test # \$@='$@'\n";
+} else {
+ print "ok $test\n";
+}
+$test++;
+
+# invalid defined macro
+$notdef = eval { &ExtTest::EW };
+if (defined $notdef) {
+ print "not ok $test # \$notdef='$notdef'\n";
+} elsif ($@ !~ /^EW is not a valid ExtTest macro/) {
+ print "not ok $test # \$@='$@'\n";
+} else {
+ print "ok $test\n";
+}
+$test++;
+
+my %compass = (
+EOT
+
+while (my ($point, $bearing) = each %compass) {
+ $test_body .= "'$point' => $bearing, "
+}
+
+$test_body .= <<'EOT';
+
+);
+
+my $fail;
+while (my ($point, $bearing) = each %compass) {
+ my $val = eval $point;
+ if ($@) {
+ print "# $point: \$@='$@'\n";
+ $fail = 1;
+ } elsif (!defined $bearing) {
+ print "# $point: \$val=undef\n";
+ $fail = 1;
+ } elsif ($val != $bearing) {
+ print "# $point: \$val=$val, not $bearing\n";
+ $fail = 1;
+ }
+}
+if ($fail) {
+ print "not ok $test\n";
+} else {
+ print "ok $test\n";
+}
+$test++;
+
+EOT
+
+$test_body .= <<"EOT";
+my \$rfc1149 = RFC1149;
+if (\$rfc1149 ne "$parent_rfc1149") {
+ print "not ok \$test # '\$rfc1149' ne '$parent_rfc1149'\n";
+} else {
+ print "ok \$test\n";
+}
+\$test++;
+
+if (\$rfc1149 != 1149) {
+ printf "not ok \$test # %d != 1149\n", \$rfc1149;
+} else {
+ print "ok \$test\n";
+}
+\$test++;
+
+EOT
+
+$test_body .= <<'EOT';
+# test macro=>1
+my $open = OPEN;
+if ($open eq '/*') {
+ print "ok $test\n";
+} else {
+ print "not ok $test # \$open='$open'\n";
+}
+$test++;
+EOT
+$dummytest+=18;
+
+ end_tests("Simple tests", \@items, \@export_names, $header, $test_body,
+ $args);
+}
+
+if ($do_utf_tests) {
+ # utf8 tests
+ start_tests();
+ my ($inf, $pound_bytes, $pound_utf8);
+
+ $inf = chr 0x221E;
+ # Check that we can distiguish the pathological case of a string, and the
+ # utf8 representation of that string.
+ $pound_utf8 = $pound . '1';
+ if ($better_than_56) {
+ $pound_bytes = $pound_utf8;
+ utf8::encode ($pound_bytes);
+ } else {
+ # Must have that "U*" to generate a zero length UTF string that forces
+ # top bit set chars (such as the pound sign) into UTF8, so that the
+ # unpack 'C*' then gets the byte form of the UTF8.
+ $pound_bytes = pack 'C*', unpack 'C*', $pound_utf8 . pack "U*";
+ }
+
+ my @items = (@common_items,
+ {name=>$inf, type=>"PV", value=>'"Infinity"', macro=>1},
+ {name=>$pound_utf8, type=>"PV", value=>'"1 Pound"', macro=>1},
+ {name=>$pound_bytes, type=>"PV", value=>'"1 Pound (as bytes)"',
+ macro=>1},
+ );
+
+=pod
+
+The above set of names seems to produce a suitably bad set of compile
+problems on a Unicode naive version of ExtUtils::Constant (ie 0.11):
+
+nick at thinking-cap 15439-32-utf$ PERL_CORE=1 ./perl lib/ExtUtils/t/Constant.t
+1..33
+# perl=/stuff/perl5/15439-32-utf/perl
+# ext-30370 being created...
+Wide character in print at lib/ExtUtils/t/Constant.t line 140.
+ok 1
+ok 2
+# make = 'make'
+ExtTest.xs: In function `constant_1':
+ExtTest.xs:80: warning: multi-character character constant
+ExtTest.xs:80: warning: case value out of range
+ok 3
+
+=cut
+
+# Grr `
+
+ # Do this in 7 bit in case someone is testing with some settings that cause
+ # 8 bit files incapable of storing this character.
+ my @values
+ = map {"'" . join (",", unpack "U*", $_ . pack "U*") . "'"}
+ ($pound, $inf, $pound_bytes, $pound_utf8);
+ # Values is a list of strings, such as ('194,163,49', '163,49')
+
+ my $test_body .= "my \$test = $dummytest;\n";
+ $dummytest += 7 * 3; # 3 tests for each of the 7 things:
+
+ $test_body .= << 'EOT';
+
+use utf8;
+my $better_than_56 = $] > 5.007;
+
+my ($pound, $inf, $pound_bytes, $pound_utf8) = map {eval "pack 'U*', $_"}
+EOT
+
+ $test_body .= join ",", @values;
+
+ $test_body .= << 'EOT';
+;
+
+foreach (["perl", "rules", "rules"],
+ ["/*", "OPEN", "OPEN"],
+ ["*/", "CLOSE", "CLOSE"],
+ [$pound, 'Sterling', []],
+ [$inf, 'Infinity', []],
+ [$pound_utf8, '1 Pound', '1 Pound (as bytes)'],
+ [$pound_bytes, '1 Pound (as bytes)', []],
+ ) {
+ # Flag an expected error with a reference for the expect string.
+ my ($string, $expect, $expect_bytes) = @$_;
+ (my $name = $string) =~ s/([^ !"#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~])/sprintf '\x{%X}', ord $1/ges;
+ print "# \"$name\" => \'$expect\'\n";
+ # Try to force this to be bytes if possible.
+ if ($better_than_56) {
+ utf8::downgrade ($string, 1);
+ } else {
+ if ($string =~ tr/0-\377// == length $string) {
+ # No chars outside range 0-255
+ $string = pack 'C*', unpack 'U*', ($string . pack 'U*');
+ }
+ }
+EOT
+
+ $test_body .= "my (\$error, \$got) = ${package}::constant (\$string);\n";
+
+ $test_body .= <<'EOT';
+ if ($error or $got ne $expect) {
+ print "not ok $test # error '$error', got '$got'\n";
+ } else {
+ print "ok $test\n";
+ }
+ $test++;
+ print "# Now upgrade '$name' to utf8\n";
+ if ($better_than_56) {
+ utf8::upgrade ($string);
+ } else {
+ $string = pack ('U*') . $string;
+ }
+EOT
+
+ $test_body .= "my (\$error, \$got) = ${package}::constant (\$string);\n";
+
+ $test_body .= <<'EOT';
+ if ($error or $got ne $expect) {
+ print "not ok $test # error '$error', got '$got'\n";
+ } else {
+ print "ok $test\n";
+ }
+ $test++;
+ if (defined $expect_bytes) {
+ print "# And now with the utf8 byte sequence for name\n";
+ # Try the encoded bytes.
+ if ($better_than_56) {
+ utf8::encode ($string);
+ } else {
+ $string = pack 'C*', unpack 'C*', $string . pack "U*";
+ }
+EOT
+
+ $test_body .= "my (\$error, \$got) = ${package}::constant (\$string);\n";
+
+ $test_body .= <<'EOT';
+ if (ref $expect_bytes) {
+ # Error expected.
+ if ($error) {
+ print "ok $test # error='$error' (as expected)\n";
+ } else {
+ print "not ok $test # expected error, got no error and '$got'\n";
+ }
+ } elsif ($got ne $expect_bytes) {
+ print "not ok $test # error '$error', expect '$expect_bytes', got '$got'\n";
+ } else {
+ print "ok $test\n";
+ }
+ $test++;
+ }
+}
+EOT
+
+ end_tests("utf8 tests", \@items, [], "#define perl \"rules\"\n", $test_body);
+}
+
+# XXX I think that I should merge this into the utf8 test above.
+sub explict_call_constant {
+ my ($string, $expect) = @_;
+ # This does assume simple strings suitable for ''
+ my $test_body = <<"EOT";
+{
+ my (\$error, \$got) = ${package}::constant ('$string');\n;
+EOT
+
+ if (defined $expect) {
+ # No error expected
+ $test_body .= <<"EOT";
+ if (\$error or \$got ne "$expect") {
+ print "not ok $dummytest # error '\$error', expect '$expect', got '\$got'\n";
+ } else {
+ print "ok $dummytest\n";
+ }
+ }
+EOT
+ } else {
+ # Error expected.
+ $test_body .= <<"EOT";
+ if (\$error) {
+ print "ok $dummytest # error='\$error' (as expected)\n";
+ } else {
+ print "not ok $dummytest # expected error, got no error and '\$got'\n";
+ }
+EOT
+ }
+ $dummytest++;
+ return $test_body . <<'EOT';
+}
+EOT
+}
+
+# Simple tests to verify bits of the switch generation system work.
+sub simple {
+ start_tests();
+ # Deliberately leave $name in @_, so that it is indexed from 1.
+ my ($name, @items) = @_;
+ my $test_header;
+ my $test_body = "my \$value;\n";
+ foreach my $counter (1 .. $#_) {
+ my $thisname = $_[$counter];
+ $test_header .= "#define $thisname $counter\n";
+ $test_body .= <<"EOT";
+\$value = $thisname;
+if (\$value == $counter) {
+ print "ok $dummytest\n";
+} else {
+ print "not ok $dummytest # $thisname gave \$value\n";
+}
+EOT
+ ++$dummytest;
+ # Yes, the last time round the loop appends a z to the string.
+ for my $i (0 .. length $thisname) {
+ my $copyname = $thisname;
+ substr ($copyname, $i, 1) = 'z';
+ $test_body .= explict_call_constant ($copyname,
+ $copyname eq $thisname
+ ? $thisname : undef);
+ }
+ }
+ # Ho. This seems to be buggy in 5.005_03:
+ # # Now remove $name from @_:
+ # shift @_;
+ end_tests($name, \@items, \@items, $test_header, $test_body);
+}
+
+# Check that the memeq clauses work correctly when there isn't a switch
+# statement to bump off a character
+simple ("Singletons", "A", "AB", "ABC", "ABCD", "ABCDE");
+# Check the three code.
+simple ("Three start", qw(Bea kea Lea lea nea pea rea sea tea Wea yea Zea));
+# There were 162 2 letter words in /usr/share/dict/words on FreeBSD 4.6, which
+# I felt was rather too many. So I used words with 2 vowels.
+simple ("Twos and three middle", qw(aa ae ai ea eu ie io oe era eta));
+# Given the choice go for the end, else the earliest point
+simple ("Three end and four symetry", qw(ean ear eat barb marm tart));
+
+
+# Need this if the single test below is rolled into @tests :
+# --$dummytest;
+print "1..$dummytest\n";
+
+write_and_run_extension @$_ foreach @tests;
+
+# This was causing an assertion failure (a C<confess>ion)
+# Any single byte > 128 should do it.
+C_constant ($package, undef, undef, undef, undef, undef, chr 255);
+print "ok $realtest\n"; $realtest++;
+
+print STDERR "# You were running with \$keep_files set to $keep_files\n"
+ if $keep_files;
Modified: trunk/contrib/perl/lib/ExtUtils/t/Embed.t
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/Embed.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/ExtUtils/t/Embed.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -20,7 +20,6 @@
print "1..9\n";
my $cc = $Config{'cc'};
my $cl = ($^O eq 'MSWin32' && $cc eq 'cl');
-my $borl = ($^O eq 'MSWin32' && $cc eq 'bcc32');
my $skip_exe = $^O eq 'os2' && $Config{ldflags} =~ /(?<!\S)-Zexe\b/;
my $exe = 'embed_test';
$exe .= $Config{'exe_ext'} unless $skip_exe; # Linker will auto-append it
@@ -57,9 +56,6 @@
if ($cl) {
push(@cmd,$cc,"-Fe$exe");
}
- elsif ($borl) {
- push(@cmd,$cc,"-o$exe");
- }
else {
push(@cmd,$cc,'-o' => $exe);
}
@@ -94,9 +90,6 @@
if $^O eq 'os2' and $Config{ldflags} =~ /(?<!\S)-Zomf\b/;
push(@cmd,ldopts());
}
- if ($borl) {
- @cmd = ($cmd[0],(grep{/^-[LI]/}@cmd[1..$#cmd]),(grep{!/^-[LI]/}@cmd[1..$#cmd]));
- }
if ($^O eq 'aix') { # AIX needs an explicit symbol export list.
my ($perl_exp) = grep { -f } qw(perl.exp ../perl.exp);
@@ -211,13 +204,13 @@
perl_free(my_perl);
+ my_puts("ok 8");
+
+ PERL_SYS_TERM();
+
#ifdef PERL_GLOBAL_STRUCT
free_global_struct(plvarsp);
#endif /* PERL_GLOBAL_STRUCT */
- my_puts("ok 8");
-
- PERL_SYS_TERM();
-
return 0;
}
Property changes on: trunk/contrib/perl/lib/ExtUtils/t/Embed.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/lib/ExtUtils/t/FIRST_MAKEFILE.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/FIRST_MAKEFILE.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/FIRST_MAKEFILE.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/FIRST_MAKEFILE.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,40 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+chdir 't';
+
+use strict;
+use Test::More tests => 7;
+
+use MakeMaker::Test::Setup::BFD;
+use MakeMaker::Test::Utils;
+
+my $perl = which_perl();
+my $make = make_run();
+perl_lib();
+
+
+ok( setup_recurs(), 'setup' );
+END {
+ ok( chdir File::Spec->updir );
+ ok( teardown_recurs(), 'teardown' );
+}
+
+ok( chdir('Big-Dummy'), "chdir'd to Big-Dummy" ) ||
+ diag("chdir failed: $!");
+
+my @mpl_out = run(qq{$perl Makefile.PL FIRST_MAKEFILE=jakefile});
+cmp_ok( $?, '==', 0, 'Makefile.PL exited with zero' ) || diag @mpl_out;
+
+ok( -e 'jakefile', 'FIRST_MAKEFILE honored' );
+
+ok( grep(/^Writing jakefile(?:\.)? for Big::Dummy/, @mpl_out) == 1,
+ 'Makefile.PL output looks right' );
Copied: trunk/contrib/perl/lib/ExtUtils/t/INST.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/INST.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/INST.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/INST.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,148 @@
+#!/usr/bin/perl -w
+
+# Wherein we ensure the INST_* and INSTALL* variables are set correctly
+# in a default Makefile.PL run
+#
+# Essentially, this test is a Makefile.PL.
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use strict;
+use Test::More tests => 26;
+use MakeMaker::Test::Utils;
+use MakeMaker::Test::Setup::BFD;
+use ExtUtils::MakeMaker;
+use File::Spec;
+use TieOut;
+use Config;
+
+chdir 't';
+
+perl_lib;
+
+$| = 1;
+
+my $Makefile = makefile_name;
+my $Curdir = File::Spec->curdir;
+my $Updir = File::Spec->updir;
+
+ok( setup_recurs(), 'setup' );
+END {
+ ok( chdir File::Spec->updir );
+ ok( teardown_recurs(), 'teardown' );
+}
+
+ok( chdir 'Big-Dummy', "chdir'd to Big-Dummy" ) ||
+ diag("chdir failed: $!");
+
+my $stdout = tie *STDOUT, 'TieOut' or die;
+my $mm = WriteMakefile(
+ NAME => 'Big::Dummy',
+ VERSION_FROM => 'lib/Big/Dummy.pm',
+ PREREQ_PM => {},
+ PERL_CORE => $ENV{PERL_CORE},
+);
+like( $stdout->read, qr{
+ Writing\ $Makefile\ for\ Big::Liar\n
+ Big::Liar's\ vars\n
+ INST_LIB\ =\ \S+\n
+ INST_ARCHLIB\ =\ \S+\n
+ Writing\ $Makefile\ for\ Big::Dummy\n
+}x );
+undef $stdout;
+untie *STDOUT;
+
+isa_ok( $mm, 'ExtUtils::MakeMaker' );
+
+is( $mm->{NAME}, 'Big::Dummy', 'NAME' );
+is( $mm->{VERSION}, 0.01, 'VERSION' );
+
+my $config_prefix = $Config{installprefixexp} || $Config{installprefix} ||
+ $Config{prefixexp} || $Config{prefix};
+is( $mm->{PERLPREFIX}, $config_prefix, 'PERLPREFIX' );
+
+is( !!$mm->{PERL_CORE}, !!$ENV{PERL_CORE}, 'PERL_CORE' );
+
+my($perl_src, $mm_perl_src);
+if( $ENV{PERL_CORE} ) {
+ $perl_src = File::Spec->catdir($Updir, $Updir);
+ $perl_src = File::Spec->canonpath($perl_src);
+ $mm_perl_src = File::Spec->canonpath($mm->{PERL_SRC});
+}
+else {
+ $mm_perl_src = $mm->{PERL_SRC};
+}
+
+is( $mm_perl_src, $perl_src, 'PERL_SRC' );
+
+
+# PERM_*
+is( $mm->{PERM_RW}, 644, 'PERM_RW' );
+is( $mm->{PERM_RWX}, 755, 'PERM_RWX' );
+
+
+# INST_*
+is( $mm->{INST_ARCHLIB},
+ $mm->{PERL_CORE} ? $mm->{PERL_ARCHLIB}
+ : File::Spec->catdir($Curdir, 'blib', 'arch'),
+ 'INST_ARCHLIB');
+is( $mm->{INST_BIN}, File::Spec->catdir($Curdir, 'blib', 'bin'),
+ 'INST_BIN' );
+
+is( keys %{$mm->{CHILDREN}}, 1 );
+my($child_pack) = keys %{$mm->{CHILDREN}};
+my $c_mm = $mm->{CHILDREN}{$child_pack};
+is( $c_mm->{INST_ARCHLIB},
+ $c_mm->{PERL_CORE} ? $c_mm->{PERL_ARCHLIB}
+ : File::Spec->catdir($Updir, 'blib', 'arch'),
+ 'CHILD INST_ARCHLIB');
+is( $c_mm->{INST_BIN}, File::Spec->catdir($Updir, 'blib', 'bin'),
+ 'CHILD INST_BIN' );
+
+
+my $inst_lib = File::Spec->catdir($Curdir, 'blib', 'lib');
+is( $mm->{INST_LIB},
+ $mm->{PERL_CORE} ? $mm->{PERL_LIB} : $inst_lib, 'INST_LIB' );
+
+
+# INSTALL*
+is( $mm->{INSTALLDIRS}, 'site', 'INSTALLDIRS' );
+
+
+
+# Make sure the INSTALL*MAN*DIR variables work. We forgot them
+# at one point.
+$stdout = tie *STDOUT, 'TieOut' or die;
+$mm = WriteMakefile(
+ NAME => 'Big::Dummy',
+ VERSION_FROM => 'lib/Big/Dummy.pm',
+ PERL_CORE => $ENV{PERL_CORE},
+ INSTALLMAN1DIR => 'none',
+ INSTALLSITEMAN3DIR => 'none',
+ INSTALLVENDORMAN1DIR => 'none',
+ INST_MAN1DIR => 'none',
+);
+like( $stdout->read, qr{
+ Writing\ $Makefile\ for\ Big::Liar\n
+ Big::Liar's\ vars\n
+ INST_LIB\ =\ \S+\n
+ INST_ARCHLIB\ =\ \S+\n
+ Writing\ $Makefile\ for\ Big::Dummy\n
+}x );
+undef $stdout;
+untie *STDOUT;
+
+isa_ok( $mm, 'ExtUtils::MakeMaker' );
+
+is ( $mm->{INSTALLMAN1DIR}, 'none' );
+is ( $mm->{INSTALLSITEMAN3DIR}, 'none' );
+is ( $mm->{INSTALLVENDORMAN1DIR}, 'none' );
+is ( $mm->{INST_MAN1DIR}, 'none' );
Copied: trunk/contrib/perl/lib/ExtUtils/t/INSTALL_BASE.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/INSTALL_BASE.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/INSTALL_BASE.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/INSTALL_BASE.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,80 @@
+#!/usr/bin/perl -w
+
+# Tests INSTALL_BASE
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use strict;
+use File::Path;
+use Config;
+
+use Test::More tests => 20;
+use MakeMaker::Test::Utils;
+use MakeMaker::Test::Setup::BFD;
+
+my $Is_VMS = $^O eq 'VMS';
+
+my $perl = which_perl();
+
+chdir 't';
+perl_lib;
+
+ok( setup_recurs(), 'setup' );
+END {
+ ok( chdir File::Spec->updir );
+ ok( teardown_recurs(), 'teardown' );
+}
+
+ok( chdir('Big-Dummy'), "chdir'd to Big-Dummy") || diag("chdir failed; $!");
+
+my @mpl_out = run(qq{$perl Makefile.PL "INSTALL_BASE=../dummy-install"});
+END { rmtree '../dummy-install'; }
+
+cmp_ok( $?, '==', 0, 'Makefile.PL exited with zero' ) ||
+ diag(@mpl_out);
+
+my $makefile = makefile_name();
+ok( grep(/^Writing $makefile for Big::Dummy/,
+ @mpl_out) == 1,
+ 'Makefile.PL output looks right');
+
+my $make = make_run();
+run("$make"); # this is necessary due to a dmake bug.
+my $install_out = run("$make install");
+is( $?, 0, ' make install exited normally' ) || diag $install_out;
+like( $install_out, qr/^Installing /m );
+
+ok( -r '../dummy-install', ' install dir created' );
+
+my @installed_files =
+ ('../dummy-install/lib/perl5/Big/Dummy.pm',
+ '../dummy-install/lib/perl5/Big/Liar.pm',
+ '../dummy-install/bin/program',
+ "../dummy-install/lib/perl5/$Config{archname}/perllocal.pod",
+ "../dummy-install/lib/perl5/$Config{archname}/auto/Big/Dummy/.packlist"
+ );
+
+foreach my $file (@installed_files) {
+ ok( -e $file, " $file installed" );
+ ok( -r $file, " $file readable" );
+}
+
+
+# nmake outputs its damned logo
+# Send STDERR off to oblivion.
+open(SAVERR, ">&STDERR") or die $!;
+open(STDERR, ">".File::Spec->devnull) or die $!;
+
+my $realclean_out = run("$make realclean");
+is( $?, 0, 'realclean' ) || diag($realclean_out);
+
+open(STDERR, ">&SAVERR") or die $!;
+close SAVERR;
Copied: trunk/contrib/perl/lib/ExtUtils/t/INST_PREFIX.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/INST_PREFIX.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/INST_PREFIX.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/INST_PREFIX.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,270 @@
+#!/usr/bin/perl -w
+
+# Wherein we ensure the INST_* and INSTALL* variables are set correctly
+# when various PREFIX variables are set.
+#
+# Essentially, this test is a Makefile.PL.
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use strict;
+use Test::More tests => 52;
+use MakeMaker::Test::Utils;
+use MakeMaker::Test::Setup::BFD;
+use ExtUtils::MakeMaker;
+use File::Spec;
+use TieOut;
+use ExtUtils::MakeMaker::Config;
+
+my $Is_VMS = $^O eq 'VMS';
+
+chdir 't';
+
+perl_lib;
+
+$| = 1;
+
+my $Makefile = makefile_name;
+my $Curdir = File::Spec->curdir;
+my $Updir = File::Spec->updir;
+
+ok( setup_recurs(), 'setup' );
+END {
+ ok( chdir File::Spec->updir );
+ ok( teardown_recurs(), 'teardown' );
+}
+
+ok( chdir 'Big-Dummy', "chdir'd to Big-Dummy" ) ||
+ diag("chdir failed: $!");
+
+my $stdout = tie *STDOUT, 'TieOut' or die;
+
+my $mm = WriteMakefile(
+ NAME => 'Big::Dummy',
+ VERSION_FROM => 'lib/Big/Dummy.pm',
+ PREREQ_PM => {},
+ PERL_CORE => $ENV{PERL_CORE},
+);
+
+like( $stdout->read, qr{
+ Writing\ $Makefile\ for\ Big::Liar\n
+ Big::Liar's\ vars\n
+ INST_LIB\ =\ \S+\n
+ INST_ARCHLIB\ =\ \S+\n
+ Writing\ $Makefile\ for\ Big::Dummy\n
+}x );
+
+is( $mm->{PREFIX}, '$(SITEPREFIX)', 'PREFIX set based on INSTALLDIRS' );
+
+isa_ok( $mm, 'ExtUtils::MakeMaker' );
+
+is( $mm->{NAME}, 'Big::Dummy', 'NAME' );
+is( $mm->{VERSION}, 0.01, 'VERSION' );
+
+foreach my $prefix (qw(PREFIX PERLPREFIX SITEPREFIX VENDORPREFIX)) {
+ unlike( $mm->{$prefix}, qr/\$\(PREFIX\)/ );
+}
+
+
+my $PREFIX = File::Spec->catdir('foo', 'bar');
+$mm = WriteMakefile(
+ NAME => 'Big::Dummy',
+ VERSION_FROM => 'lib/Big/Dummy.pm',
+ PREREQ_PM => {},
+ PERL_CORE => $ENV{PERL_CORE},
+ PREFIX => $PREFIX,
+);
+like( $stdout->read, qr{
+ Writing\ $Makefile\ for\ Big::Liar\n
+ Big::Liar's\ vars\n
+ INST_LIB\ =\ \S+\n
+ INST_ARCHLIB\ =\ \S+\n
+ Writing\ $Makefile\ for\ Big::Dummy\n
+}x );
+undef $stdout;
+untie *STDOUT;
+
+is( $mm->{PREFIX}, $PREFIX, 'PREFIX' );
+
+foreach my $prefix (qw(PERLPREFIX SITEPREFIX VENDORPREFIX)) {
+ is( $mm->{$prefix}, '$(PREFIX)', "\$(PREFIX) overrides $prefix" );
+}
+
+is( !!$mm->{PERL_CORE}, !!$ENV{PERL_CORE}, 'PERL_CORE' );
+
+my($perl_src, $mm_perl_src);
+if( $ENV{PERL_CORE} ) {
+ $perl_src = File::Spec->catdir($Updir, $Updir);
+ $perl_src = File::Spec->canonpath($perl_src);
+ $mm_perl_src = File::Spec->canonpath($mm->{PERL_SRC});
+}
+else {
+ $mm_perl_src = $mm->{PERL_SRC};
+}
+
+is( $mm_perl_src, $perl_src, 'PERL_SRC' );
+
+
+# Every INSTALL* variable must start with some PREFIX.
+my %Install_Vars = (
+ PERL => [qw(archlib privlib bin man1dir man3dir script)],
+ SITE => [qw(sitearch sitelib sitebin siteman1dir siteman3dir)],
+ VENDOR => [qw(vendorarch vendorlib vendorbin vendorman1dir vendorman3dir)]
+);
+
+while( my($type, $vars) = each %Install_Vars) {
+ SKIP: {
+ skip "VMS must expand macros in INSTALL* vars", scalar @$vars
+ if $Is_VMS;
+ skip '$Config{usevendorprefix} not set', scalar @$vars
+ if $type eq 'VENDOR' and !$Config{usevendorprefix};
+
+ foreach my $var (@$vars) {
+ my $installvar = "install$var";
+ my $prefix = '$('.$type.'PREFIX)';
+
+ SKIP: {
+ skip uc($installvar).' set to another INSTALL variable', 1
+ if $mm->{uc $installvar} =~ /^\$\(INSTALL.*\)$/;
+
+ # support for man page skipping
+ $prefix = 'none' if $type eq 'PERL' &&
+ $var =~ /man/ &&
+ !$Config{$installvar};
+ like( $mm->{uc $installvar}, qr/^\Q$prefix\E/,
+ "$prefix + $var" );
+ }
+ }
+ }
+}
+
+# Check that when installman*dir isn't set in Config no man pages
+# are generated.
+{
+ _set_config(installman1dir => '');
+ _set_config(installman3dir => '');
+
+ my $wibble = File::Spec->catdir(qw(wibble and such));
+ my $stdout = tie *STDOUT, 'TieOut' or die;
+ my $mm = WriteMakefile(
+ NAME => 'Big::Dummy',
+ VERSION_FROM => 'lib/Big/Dummy.pm',
+ PREREQ_PM => {},
+ PERL_CORE => $ENV{PERL_CORE},
+ PREFIX => $PREFIX,
+ INSTALLMAN1DIR=> $wibble,
+ );
+
+ is( $mm->{INSTALLMAN1DIR}, $wibble );
+ is( $mm->{INSTALLMAN3DIR}, 'none' );
+}
+
+# Check that when installvendorman*dir is set in Config it is honored
+# [rt.cpan.org 2949]
+{
+ _set_config(installvendorman1dir => File::Spec->catdir('foo','bar') );
+ _set_config(installvendorman3dir => '' );
+ _set_config(usevendorprefix => 1 );
+ _set_config(vendorprefixexp => 'something' );
+
+ my $stdout = tie *STDOUT, 'TieOut' or die;
+ my $mm = WriteMakefile(
+ NAME => 'Big::Dummy',
+ VERSION_FROM => 'lib/Big/Dummy.pm',
+ PREREQ_PM => {},
+ PERL_CORE => $ENV{PERL_CORE},
+
+ # In case the local installation doesn't have man pages.
+ INSTALLMAN1DIR=> 'foo/bar/baz',
+ INSTALLMAN3DIR=> 'foo/bar/baz',
+ );
+
+ is( $mm->{INSTALLVENDORMAN1DIR}, File::Spec->catdir('foo','bar'),
+ 'installvendorman1dir (in %Config) not modified' );
+ isnt( $mm->{INSTALLVENDORMAN3DIR}, '',
+ 'installvendorman3dir (not in %Config) set' );
+}
+
+# Check that when installsiteman*dir isn't set in Config it falls back
+# to installman*dir
+{
+ _set_config(installman1dir => File::Spec->catdir('foo', 'bar') );
+ _set_config(installman3dir => File::Spec->catdir('foo', 'baz') );
+ _set_config(installsiteman1dir => '' );
+ _set_config(installsiteman3dir => '' );
+ _set_config(installvendorman1dir => '' );
+ _set_config(installvendorman3dir => '' );
+ _set_config(usevendorprefix => 'define' );
+ _set_config(vendorprefixexp => 'something' );
+
+ my $wibble = File::Spec->catdir(qw(wibble and such));
+ my $stdout = tie *STDOUT, 'TieOut' or die;
+ my $mm = WriteMakefile(
+ NAME => 'Big::Dummy',
+ VERSION_FROM => 'lib/Big/Dummy.pm',
+ PERL_CORE => $ENV{PERL_CORE},
+ );
+
+ is( $mm->{INSTALLMAN1DIR}, File::Spec->catdir('foo', 'bar') );
+ is( $mm->{INSTALLMAN3DIR}, File::Spec->catdir('foo', 'baz') );
+ SKIP: {
+ skip "VMS must expand macros in INSTALL* vars", 4 if $Is_VMS;
+
+ is( $mm->{INSTALLSITEMAN1DIR}, '$(INSTALLMAN1DIR)' );
+ is( $mm->{INSTALLSITEMAN3DIR}, '$(INSTALLMAN3DIR)' );
+ is( $mm->{INSTALLVENDORMAN1DIR}, '$(INSTALLMAN1DIR)' );
+ is( $mm->{INSTALLVENDORMAN3DIR}, '$(INSTALLMAN3DIR)' );
+ }
+}
+
+
+# Check that when usevendoprefix and installvendorman*dir aren't set in
+# Config it leaves them unset.
+{
+ _set_config(installman1dir => File::Spec->catdir('foo', 'bar') );
+ _set_config(installman3dir => File::Spec->catdir('foo', 'baz') );
+ _set_config(installsiteman1dir => '' );
+ _set_config(installsiteman3dir => '' );
+ _set_config(installvendorman1dir => '' );
+ _set_config(installvendorman3dir => '' );
+ _set_config(usevendorprefix => '' );
+ _set_config(vendorprefixexp => '' );
+
+ my $wibble = File::Spec->catdir(qw(wibble and such));
+ my $stdout = tie *STDOUT, 'TieOut' or die;
+ my $mm = WriteMakefile(
+ NAME => 'Big::Dummy',
+ VERSION_FROM => 'lib/Big/Dummy.pm',
+ PERL_CORE => $ENV{PERL_CORE},
+ );
+
+ is( $mm->{INSTALLMAN1DIR}, File::Spec->catdir('foo', 'bar') );
+ is( $mm->{INSTALLMAN3DIR}, File::Spec->catdir('foo', 'baz') );
+ SKIP: {
+ skip "VMS must expand macros in INSTALL* vars", 2 if $Is_VMS;
+ is( $mm->{INSTALLSITEMAN1DIR}, '$(INSTALLMAN1DIR)' );
+ is( $mm->{INSTALLSITEMAN3DIR}, '$(INSTALLMAN3DIR)' );
+ }
+ is( $mm->{INSTALLVENDORMAN1DIR}, '' );
+ is( $mm->{INSTALLVENDORMAN3DIR}, '' );
+}
+
+
+sub _set_config {
+ my($k,$v) = @_;
+ (my $k_no_install = $k) =~ s/^install//i;
+ $Config{$k} = $v;
+
+ # Because VMS's config has traditionally been underpopulated, it will
+ # fall back to the install-less versions in desperation.
+ $Config{$k_no_install} = $v if $Is_VMS;
+ return;
+}
Copied: trunk/contrib/perl/lib/ExtUtils/t/Install.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/Install.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/Install.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/Install.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,194 @@
+#!/usr/bin/perl -w
+
+# Test ExtUtils::Install.
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ @INC = ('../../lib', '../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+chdir 't';
+
+use strict;
+use TieOut;
+use File::Path;
+use File::Spec;
+
+use Test::More tests => 52;
+
+use MakeMaker::Test::Setup::BFD;
+
+BEGIN { use_ok('ExtUtils::Install') }
+# ensure the env doesnt pollute our tests
+local $ENV{EU_INSTALL_ALWAYS_COPY};
+local $ENV{EU_ALWAYS_COPY};
+
+# Check exports.
+foreach my $func (qw(install uninstall pm_to_blib install_default)) {
+ can_ok(__PACKAGE__, $func);
+}
+
+
+ok( setup_recurs(), 'setup' );
+END {
+ ok( chdir File::Spec->updir );
+ ok( teardown_recurs(), 'teardown' );
+}
+
+chdir 'Big-Dummy';
+
+my $stdout = tie *STDOUT, 'TieOut';
+pm_to_blib( { 'lib/Big/Dummy.pm' => 'blib/lib/Big/Dummy.pm' },
+ 'blib/lib/auto'
+ );
+END { rmtree 'blib' }
+
+ok( -d 'blib/lib', 'pm_to_blib created blib dir' );
+ok( -r 'blib/lib/Big/Dummy.pm', ' copied .pm file' );
+ok( -r 'blib/lib/auto', ' created autosplit dir' );
+is( $stdout->read, "cp lib/Big/Dummy.pm blib/lib/Big/Dummy.pm\n" );
+
+pm_to_blib( { 'lib/Big/Dummy.pm' => 'blib/lib/Big/Dummy.pm' },
+ 'blib/lib/auto'
+ );
+ok( -d 'blib/lib', 'second run, blib dir still there' );
+ok( -r 'blib/lib/Big/Dummy.pm', ' .pm file still there' );
+ok( -r 'blib/lib/auto', ' autosplit still there' );
+is( $stdout->read, "Skip blib/lib/Big/Dummy.pm (unchanged)\n" );
+
+install( { 'blib/lib' => 'install-test/lib/perl',
+ read => 'install-test/packlist',
+ write => 'install-test/packlist'
+ },
+ 0, 1);
+ok( ! -d 'install-test/lib/perl', 'install made dir (dry run)');
+ok( ! -r 'install-test/lib/perl/Big/Dummy.pm',
+ ' .pm file installed (dry run)');
+ok( ! -r 'install-test/packlist', ' packlist exists (dry run)');
+
+install( { 'blib/lib' => 'install-test/lib/perl',
+ read => 'install-test/packlist',
+ write => 'install-test/packlist'
+ } );
+ok( -d 'install-test/lib/perl', 'install made dir' );
+ok( -r 'install-test/lib/perl/Big/Dummy.pm', ' .pm file installed' );
+ok(!-r 'install-test/lib/perl/Big/Dummy.SKIP', ' ignored .SKIP file' );
+ok( -r 'install-test/packlist', ' packlist exists' );
+
+open(PACKLIST, 'install-test/packlist' );
+my %packlist = map { chomp; ($_ => 1) } <PACKLIST>;
+close PACKLIST;
+
+# On case-insensitive filesystems (ie. VMS), the keys of the packlist might
+# be lowercase. :(
+my $native_dummy = File::Spec->catfile(qw(install-test lib perl Big Dummy.pm));
+is( keys %packlist, 1 );
+is( lc((keys %packlist)[0]), lc $native_dummy, 'packlist written' );
+
+
+# Test UNINST=1 preserving same versions in other dirs.
+install( { 'blib/lib' => 'install-test/other_lib/perl',
+ read => 'install-test/packlist',
+ write => 'install-test/packlist'
+ },
+ 0, 0, 1);
+ok( -d 'install-test/other_lib/perl', 'install made other dir' );
+ok( -r 'install-test/other_lib/perl/Big/Dummy.pm', ' .pm file installed' );
+ok( -r 'install-test/packlist', ' packlist exists' );
+ok( -r 'install-test/lib/perl/Big/Dummy.pm', ' UNINST=1 preserved same' );
+
+
+chmod 0644, 'blib/lib/Big/Dummy.pm' or die $!;
+open(DUMMY, ">>blib/lib/Big/Dummy.pm") or die $!;
+print DUMMY "Extra stuff\n";
+close DUMMY;
+
+
+# Test UNINST=0 does not remove other versions in other dirs.
+{
+ ok( -r 'install-test/lib/perl/Big/Dummy.pm', 'different install exists' );
+
+ local @INC = ('install-test/lib/perl');
+ local $ENV{PERL5LIB} = '';
+ install( { 'blib/lib' => 'install-test/other_lib/perl',
+ read => 'install-test/packlist',
+ write => 'install-test/packlist'
+ },
+ 0, 0, 0);
+ ok( -d 'install-test/other_lib/perl', 'install made other dir' );
+ ok( -r 'install-test/other_lib/perl/Big/Dummy.pm', ' .pm file installed' );
+ ok( -r 'install-test/packlist', ' packlist exists' );
+ ok( -r 'install-test/lib/perl/Big/Dummy.pm',
+ ' UNINST=0 left different' );
+}
+
+# Test UNINST=1 only warning when failing to remove an irrelevent shadow file
+{
+ my $tfile='install-test/lib/perl/Big/Dummy.pm';
+ local $ExtUtils::Install::Testing = $tfile;
+ local @INC = ('install-test/other_lib/perl','install-test/lib/perl');
+ local $ENV{PERL5LIB} = '';
+ ok( -r $tfile, 'different install exists' );
+ my @warn;
+ local $SIG{__WARN__}=sub { push @warn, @_; return };
+ my $ok=eval {
+ install( { 'blib/lib' => 'install-test/other_lib/perl',
+ read => 'install-test/packlist',
+ write => 'install-test/packlist'
+ },
+ 0, 0, 1);
+ 1
+ };
+ ok($ok,' we didnt die');
+ ok(0+ at warn," we did warn");
+ ok( -d 'install-test/other_lib/perl', 'install made other dir' );
+ ok( -r 'install-test/other_lib/perl/Big/Dummy.pm', ' .pm file installed' );
+ ok( -r 'install-test/packlist', ' packlist exists' );
+ ok( -r $tfile, ' UNINST=1 failed to remove different' );
+
+}
+
+# Test UNINST=1 dieing when failing to remove an relevent shadow file
+{
+ my $tfile='install-test/lib/perl/Big/Dummy.pm';
+ local $ExtUtils::Install::Testing = $tfile;
+ local @INC = ('install-test/lib/perl','install-test/other_lib/perl');
+ local $ENV{PERL5LIB} = '';
+ ok( -r $tfile, 'different install exists' );
+ my @warn;
+ local $SIG{__WARN__}=sub { push @warn, at _; return };
+ my $ok=eval {
+ install( { 'blib/lib' => 'install-test/other_lib/perl',
+ read => 'install-test/packlist',
+ write => 'install-test/packlist'
+ },
+ 0, 0, 1);
+ 1
+ };
+ ok(!$ok,' we did die');
+ ok(!@warn," we didnt warn");
+ ok( -d 'install-test/other_lib/perl', 'install made other dir' );
+ ok( -r 'install-test/other_lib/perl/Big/Dummy.pm', ' .pm file installed' );
+ ok( -r 'install-test/packlist', ' packlist exists' );
+ ok( -r $tfile,' UNINST=1 failed to remove different' );
+}
+
+# Test UNINST=1 removing other versions in other dirs.
+{
+ local @INC = ('install-test/lib/perl');
+ local $ENV{PERL5LIB} = '';
+ install( { 'blib/lib' => 'install-test/other_lib/perl',
+ read => 'install-test/packlist',
+ write => 'install-test/packlist'
+ },
+ 0, 0, 1);
+ ok( -d 'install-test/other_lib/perl', 'install made other dir' );
+ ok( -r 'install-test/other_lib/perl/Big/Dummy.pm', ' .pm file installed' );
+ ok( -r 'install-test/packlist', ' packlist exists' );
+ ok( !-r 'install-test/lib/perl/Big/Dummy.pm',
+ ' UNINST=1 removed different' );
+}
+
Copied: trunk/contrib/perl/lib/ExtUtils/t/InstallWithMM.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/InstallWithMM.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/InstallWithMM.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/InstallWithMM.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,95 @@
+#!/usr/bin/perl -w
+
+# Make sure EUI works with MakeMaker
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use strict;
+use Config;
+use ExtUtils::MakeMaker;
+
+use Test::More tests => 15;
+use MakeMaker::Test::Utils;
+use MakeMaker::Test::Setup::BFD;
+use File::Find;
+use File::Spec;
+use File::Path;
+
+my $make = make_run();
+
+# Environment variables which interfere with our testing.
+delete @ENV{qw(PREFIX LIB MAKEFLAGS)};
+
+# Run Makefile.PL
+{
+ my $perl = which_perl();
+ my $Is_VMS = $^O eq 'VMS';
+
+ chdir 't';
+
+ perl_lib;
+
+ my $Touch_Time = calibrate_mtime();
+
+ $| = 1;
+
+ ok( setup_recurs(), 'setup' );
+ END {
+ ok( chdir File::Spec->updir );
+ ok( teardown_recurs(), 'teardown' );
+ }
+
+ ok( chdir('Big-Dummy'), "chdir'd to Big-Dummy" ) ||
+ diag("chdir failed: $!");
+
+ my @mpl_out = run(qq{$perl Makefile.PL "PREFIX=../dummy-install"});
+ END { rmtree '../dummy-install'; }
+
+ cmp_ok( $?, '==', 0, 'Makefile.PL exited with zero' ) ||
+ diag(@mpl_out);
+
+ END { unlink makefile_name(), makefile_backup() }
+}
+
+
+# make
+{
+ my $make_out = run($make);
+ is( $?, 0, 'make ran ok' ) ||
+ diag($make_out);
+}
+
+
+# Test 'make install VERBINST=1'
+{
+ my $make_install_verbinst = make_macro($make, 'install', VERBINST => 1);
+ my $install_out = run($make_install_verbinst);
+ is( $?, 0, 'install' ) || diag $install_out;
+ like( $install_out, qr/^Installing /m );
+ like( $install_out, qr/^Writing /m );
+
+ ok( -r '../dummy-install', ' install dir created' );
+ my %files = ();
+ find( sub {
+ # do it case-insensitive for non-case preserving OSs
+ my $file = lc $_;
+
+ # VMS likes to put dots on the end of things that don't have them.
+ $file =~ s/\.$// if $Is_VMS;
+
+ $files{$file} = $File::Find::name;
+ }, '../dummy-install' );
+ ok( $files{'dummy.pm'}, ' Dummy.pm installed' );
+ ok( $files{'liar.pm'}, ' Liar.pm installed' );
+ ok( $files{'program'}, ' program installed' );
+ ok( $files{'.packlist'}, ' packlist created' );
+ ok( $files{'perllocal.pod'},' perllocal.pod created' );
+}
Copied: trunk/contrib/perl/lib/ExtUtils/t/Installapi2.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/Installapi2.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/Installapi2.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/Installapi2.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,238 @@
+#!/usr/bin/perl -w
+
+# Test ExtUtils::Install.
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ @INC = ('../../lib', '../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+chdir 't';
+
+use strict;
+use TieOut;
+use File::Path;
+use File::Spec;
+
+use Test::More tests => 70;
+
+use MakeMaker::Test::Setup::BFD;
+
+BEGIN { use_ok('ExtUtils::Install') }
+
+# Check exports.
+foreach my $func (qw(install uninstall pm_to_blib install_default)) {
+ can_ok(__PACKAGE__, $func);
+}
+
+
+ok( setup_recurs(), 'setup' );
+END {
+ ok( chdir File::Spec->updir );
+ ok( teardown_recurs(), 'teardown' );
+}
+# ensure the env doesnt pollute our tests
+local $ENV{EU_INSTALL_ALWAYS_COPY};
+local $ENV{EU_ALWAYS_COPY};
+
+chdir 'Big-Dummy';
+
+my $stdout = tie *STDOUT, 'TieOut';
+pm_to_blib( { 'lib/Big/Dummy.pm' => 'blib/lib/Big/Dummy.pm' },
+ 'blib/lib/auto'
+ );
+END { rmtree 'blib' }
+
+ok( -d 'blib/lib', 'pm_to_blib created blib dir' );
+ok( -r 'blib/lib/Big/Dummy.pm', ' copied .pm file' );
+ok( -r 'blib/lib/auto', ' created autosplit dir' );
+is( $stdout->read, "cp lib/Big/Dummy.pm blib/lib/Big/Dummy.pm\n" );
+
+pm_to_blib( { 'lib/Big/Dummy.pm' => 'blib/lib/Big/Dummy.pm' },
+ 'blib/lib/auto'
+ );
+ok( -d 'blib/lib', 'second run, blib dir still there' );
+ok( -r 'blib/lib/Big/Dummy.pm', ' .pm file still there' );
+ok( -r 'blib/lib/auto', ' autosplit still there' );
+is( $stdout->read, "Skip blib/lib/Big/Dummy.pm (unchanged)\n" );
+
+install( [
+ from_to=>{ 'blib/lib' => 'install-test/lib/perl',
+ read => 'install-test/packlist',
+ write => 'install-test/packlist'
+ },
+ dry_run=>1]);
+ok( ! -d 'install-test/lib/perl', 'install made dir (dry run)');
+ok( ! -r 'install-test/lib/perl/Big/Dummy.pm',
+ ' .pm file installed (dry run)');
+ok( ! -r 'install-test/packlist', ' packlist exists (dry run)');
+
+install([ from_to=> { 'blib/lib' => 'install-test/lib/perl',
+ read => 'install-test/packlist',
+ write => 'install-test/packlist'
+ } ]);
+ok( -d 'install-test/lib/perl', 'install made dir' );
+ok( -r 'install-test/lib/perl/Big/Dummy.pm', ' .pm file installed' );
+ok(!-r 'install-test/lib/perl/Big/Dummy.SKIP', ' ignored .SKIP file' );
+ok( -r 'install-test/packlist', ' packlist exists' );
+
+open(PACKLIST, 'install-test/packlist' );
+my %packlist = map { chomp; ($_ => 1) } <PACKLIST>;
+close PACKLIST;
+
+# On case-insensitive filesystems (ie. VMS), the keys of the packlist might
+# be lowercase. :(
+my $native_dummy = File::Spec->catfile(qw(install-test lib perl Big Dummy.pm));
+is( keys %packlist, 1 );
+is( lc((keys %packlist)[0]), lc $native_dummy, 'packlist written' );
+
+
+# Test UNINST=1 preserving same versions in other dirs.
+install([from_to=> { 'blib/lib' => 'install-test/other_lib/perl',
+ read => 'install-test/packlist',
+ write => 'install-test/packlist'
+ },uninstall_shadows=>1]);
+ok( -d 'install-test/other_lib/perl', 'install made other dir' );
+ok( -r 'install-test/other_lib/perl/Big/Dummy.pm', ' .pm file installed' );
+ok( -r 'install-test/packlist', ' packlist exists' );
+ok( -r 'install-test/lib/perl/Big/Dummy.pm', ' UNINST=1 preserved same' );
+
+
+chmod 0644, 'blib/lib/Big/Dummy.pm' or die $!;
+open(DUMMY, ">>blib/lib/Big/Dummy.pm") or die $!;
+print DUMMY "Extra stuff\n";
+close DUMMY;
+
+
+# Test UNINST=0 does not remove other versions in other dirs.
+{
+ ok( -r 'install-test/lib/perl/Big/Dummy.pm', 'different install exists' );
+
+ local @INC = ('install-test/lib/perl');
+ local $ENV{PERL5LIB} = '';
+ install([from_to=> { 'blib/lib' => 'install-test/other_lib/perl',
+ read => 'install-test/packlist',
+ write => 'install-test/packlist'
+ }]);
+ ok( -d 'install-test/other_lib/perl', 'install made other dir' );
+ ok( -r 'install-test/other_lib/perl/Big/Dummy.pm', ' .pm file installed' );
+ ok( -r 'install-test/packlist', ' packlist exists' );
+ ok( -r 'install-test/lib/perl/Big/Dummy.pm',
+ ' UNINST=0 left different' );
+}
+
+# Test UNINST=1 only warning when failing to remove an irrelevent shadow file
+{
+ my $tfile='install-test/lib/perl/Big/Dummy.pm';
+ local $ExtUtils::Install::Testing = $tfile;
+ local @INC = ('install-test/other_lib/perl','install-test/lib/perl');
+ local $ENV{PERL5LIB} = '';
+ ok( -r $tfile, 'different install exists' );
+ my @warn;
+ local $SIG{__WARN__}=sub { push @warn, @_; return };
+ my $ok=eval {
+ install([from_to=> { 'blib/lib' => 'install-test/other_lib/perl',
+ read => 'install-test/packlist',
+ write => 'install-test/packlist'
+ },
+ uninstall_shadows=>1]);
+ 1
+ };
+ ok($ok,' we didnt die');
+ ok(0+ at warn," we did warn");
+ ok( -d 'install-test/other_lib/perl', 'install made other dir' );
+ ok( -r 'install-test/other_lib/perl/Big/Dummy.pm', ' .pm file installed' );
+ ok( -r 'install-test/packlist', ' packlist exists' );
+ ok( -r $tfile, ' UNINST=1 failed to remove different' );
+
+}
+
+# Test UNINST=1 dieing when failing to remove an relevent shadow file
+{
+ my $tfile='install-test/lib/perl/Big/Dummy.pm';
+ local $ExtUtils::Install::Testing = $tfile;
+ local @INC = ('install-test/lib/perl','install-test/other_lib/perl');
+ local $ENV{PERL5LIB} = '';
+ ok( -r $tfile, 'different install exists' );
+ my @warn;
+ local $SIG{__WARN__}=sub { push @warn, at _; return };
+ my $ok=eval {
+ install([from_to=> { 'blib/lib' => 'install-test/other_lib/perl',
+ read => 'install-test/packlist',
+ write => 'install-test/packlist'
+ },uninstall_shadows=>1]);
+ 1
+ };
+ ok(!$ok,' we did die');
+ ok(!@warn," we didnt warn");
+ ok( -d 'install-test/other_lib/perl', 'install made other dir' );
+ ok( -r 'install-test/other_lib/perl/Big/Dummy.pm', ' .pm file installed' );
+ ok( -r 'install-test/packlist', ' packlist exists' );
+ ok( -r $tfile,' UNINST=1 failed to remove different' );
+}
+
+# Test UNINST=1 removing other versions in other dirs.
+{
+ local @INC = ('install-test/lib/perl');
+ local $ENV{PERL5LIB} = '';
+ ok( -r 'install-test/lib/perl/Big/Dummy.pm','different install exists' );
+ install([from_to=>{ 'blib/lib' => 'install-test/other_lib/perl',
+ read => 'install-test/packlist',
+ write => 'install-test/packlist'
+ },uninstall_shadows=>1]);
+ ok( -d 'install-test/other_lib/perl', 'install made other dir' );
+ ok( -r 'install-test/other_lib/perl/Big/Dummy.pm', ' .pm file installed' );
+ ok( -r 'install-test/packlist', ' packlist exists' );
+ ok( !-r 'install-test/lib/perl/Big/Dummy.pm',
+ ' UNINST=1 removed different' );
+}
+
+# Test EU_ALWAYS_COPY triggers copy.
+{
+ local @INC = ('install-test/lib/perl');
+ local $ENV{PERL5LIB} = '';
+ local $ENV{EU_INSTALL_ALWAYS_COPY}=1;
+ my $tfile='install-test/other_lib/perl/Big/Dummy.pm';
+ my $sfile='blib/lib/Big/Dummy.pm';
+ ok(-r $tfile,"install file already exists");
+ ok(-r $sfile,"source file already exists");
+ utime time-600, time-600, $sfile or die "utime '$sfile' failed:$!";
+ ok( (stat $tfile)[9]!=(stat $sfile)[9],' Times are different');
+ install([from_to=>{ 'blib/lib' => 'install-test/other_lib/perl',
+ read => 'install-test/packlist',
+ write => 'install-test/packlist'
+ },result=>\my %result]);
+ ok( -d 'install-test/other_lib/perl', 'install made other dir' );
+ ok( -r 'install-test/other_lib/perl/Big/Dummy.pm', ' .pm file installed' );
+ ok( -r 'install-test/packlist', ' packlist exists' );
+SKIP: {
+ skip "Times not preserved during copy by default", 1 if $^O eq 'VMS';
+ ok( (stat $tfile)[9]==(stat $sfile)[9],' Times are same');
+}
+ ok( !$result{install_unchanged},' $result{install_unchanged} should be empty');
+}
+# Test nothing is copied.
+{
+ local @INC = ('install-test/lib/perl');
+ local $ENV{PERL5LIB} = '';
+ local $ENV{EU_INSTALL_ALWAYS_COPY}=0;
+ my $tfile='install-test/other_lib/perl/Big/Dummy.pm';
+ my $sfile='blib/lib/Big/Dummy.pm';
+ ok(-r $tfile,"install file already exists");
+ ok(-r $sfile,"source file already exists");
+ utime time-1200, time-1200, $sfile or die "utime '$sfile' failed:$!";
+ ok( (stat $tfile)[9]!=(stat $sfile)[9],' Times are different');
+ install([from_to=>{ 'blib/lib' => 'install-test/other_lib/perl',
+ read => 'install-test/packlist',
+ write => 'install-test/packlist'
+ },result=>\my %result]);
+ ok( -d 'install-test/other_lib/perl', 'install made other dir' );
+ ok( -r 'install-test/other_lib/perl/Big/Dummy.pm', ' .pm file installed' );
+ ok( -r 'install-test/packlist', ' packlist exists' );
+ ok( (stat $tfile)[9]!=(stat$sfile)[9],' Times are different');
+ ok( !$result{install},' nothing should have been installed');
+ ok( $result{install_unchanged},' install_unchanged should be populated');
+}
Copied: trunk/contrib/perl/lib/ExtUtils/t/Installed.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/Installed.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/Installed.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/Installed.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,313 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ else {
+ unshift @INC, 't/lib/';
+ }
+}
+chdir 't';
+
+my $Is_VMS = $^O eq 'VMS';
+
+use strict;
+
+use Config;
+use Cwd;
+use File::Path;
+use File::Basename;
+use File::Spec;
+
+use Test::More tests => 63;
+
+BEGIN { use_ok( 'ExtUtils::Installed' ) }
+
+my $mandirs = !!$Config{man1direxp} + !!$Config{man3direxp};
+
+# saves having to qualify package name for class methods
+my $ei = bless( {}, 'ExtUtils::Installed' );
+
+# Make sure meta info is available
+$ei->{':private:'}{Config} = \%Config;
+$ei->{':private:'}{INC} = \@INC;
+
+# _is_prefix
+ok( $ei->_is_prefix('foo/bar', 'foo'),
+ '_is_prefix() should match valid path prefix' );
+ok( !$ei->_is_prefix('\foo\bar', '\bar'),
+ '... should not match wrong prefix' );
+
+# _is_type
+ok( $ei->_is_type(0, 'all'), '_is_type() should be true for type of "all"' );
+
+foreach my $path (qw( man1dir man3dir )) {
+ SKIP: {
+ my $dir = File::Spec->canonpath($Config{$path.'exp'});
+ skip("no man directory $path on this system", 2 ) unless $dir;
+
+ my $file = $dir . '/foo';
+ ok( $ei->_is_type($file, 'doc'), "... should find doc file in $path" );
+ ok( !$ei->_is_type($file, 'prog'), "... but not prog file in $path" );
+ }
+}
+
+# VMS 5.6.1 doesn't seem to have $Config{prefixexp}
+my $prefix = $Config{prefix} || $Config{prefixexp};
+
+# You can concatenate /foo but not foo:, which defaults in the current
+# directory
+$prefix = VMS::Filespec::unixify($prefix) if $Is_VMS;
+
+# ActivePerl 5.6.1/631 has $Config{prefixexp} as 'p:' for some reason
+$prefix = $Config{prefix} if $prefix eq 'p:' && $^O eq 'MSWin32';
+
+ok( $ei->_is_type( File::Spec->catfile($prefix, 'bar'), 'prog'),
+ "... should find prog file under $prefix" );
+
+SKIP: {
+ skip('no man directories on this system', 1) unless $mandirs;
+ is( $ei->_is_type('bar', 'doc'), 0,
+ '... should not find doc file outside path' );
+}
+
+ok( !$ei->_is_type('bar', 'prog'),
+ '... nor prog file outside path' );
+ok( !$ei->_is_type('whocares', 'someother'), '... nor other type anywhere' );
+
+# _is_under
+ok( $ei->_is_under('foo'), '_is_under() should return true with no dirs' );
+
+my @under = qw( boo bar baz );
+ok( !$ei->_is_under('foo', @under), '... should find no file not under dirs');
+ok( $ei->_is_under('baz', @under), '... should find file under dir' );
+
+
+rmtree 'auto/FakeMod';
+ok( mkpath('auto/FakeMod') );
+END { rmtree 'auto' }
+
+ok(open(PACKLIST, '>auto/FakeMod/.packlist'));
+print PACKLIST 'list';
+close PACKLIST;
+
+ok(open(FAKEMOD, '>auto/FakeMod/FakeMod.pm'));
+
+print FAKEMOD <<'FAKE';
+package FakeMod;
+use vars qw( $VERSION );
+$VERSION = '1.1.1';
+1;
+FAKE
+
+close FAKEMOD;
+
+my $fake_mod_dir = File::Spec->catdir(cwd(), 'auto', 'FakeMod');
+{
+ # avoid warning and death by localizing glob
+ local *ExtUtils::Installed::Config;
+ %ExtUtils::Installed::Config = (
+ %Config,
+ archlibexp => cwd(),
+ sitearchexp => $fake_mod_dir,
+ );
+
+ # necessary to fool new()
+ push @INC, $fake_mod_dir;
+
+ my $realei = ExtUtils::Installed->new();
+ isa_ok( $realei, 'ExtUtils::Installed' );
+ isa_ok( $realei->{Perl}{packlist}, 'ExtUtils::Packlist' );
+ is( $realei->{Perl}{version}, $Config{version},
+ 'new() should set Perl version from %Config' );
+
+ ok( exists $realei->{FakeMod}, 'new() should find modules with .packlists');
+ isa_ok( $realei->{FakeMod}{packlist}, 'ExtUtils::Packlist' );
+ is( $realei->{FakeMod}{version}, '1.1.1',
+ '... should find version in modules' );
+}
+
+# Now try this using PERL5LIB
+{
+ local $ENV{PERL5LIB} = join $Config{path_sep}, $fake_mod_dir;
+ local *ExtUtils::Installed::Config;
+ %ExtUtils::Installed::Config = (
+ %Config,
+ archlibexp => cwd(),
+ sitearchexp => cwd(),
+ );
+
+ my $realei = ExtUtils::Installed->new();
+ isa_ok( $realei, 'ExtUtils::Installed' );
+ isa_ok( $realei->{Perl}{packlist}, 'ExtUtils::Packlist' );
+ is( $realei->{Perl}{version}, $Config{version},
+ 'new() should set Perl version from %Config' );
+
+ ok( exists $realei->{FakeMod},
+ 'new() should find modules with .packlists using PERL5LIB'
+ );
+ isa_ok( $realei->{FakeMod}{packlist}, 'ExtUtils::Packlist' );
+ is( $realei->{FakeMod}{version}, '1.1.1',
+ '... should find version in modules' );
+}
+
+# Do the same thing as the last block, but with overrides for
+# %Config and @INC.
+{
+ my $config_override = { %Config::Config };
+ $config_override->{archlibexp} = cwd();
+ $config_override->{sitearchexp} = $fake_mod_dir;
+ $config_override->{version} = 'fake_test_version';
+
+ my @inc_override = (@INC, $fake_mod_dir);
+
+ my $realei = ExtUtils::Installed->new(
+ 'config_override' => $config_override,
+ 'inc_override' => \@inc_override,
+ );
+ isa_ok( $realei, 'ExtUtils::Installed' );
+ isa_ok( $realei->{Perl}{packlist}, 'ExtUtils::Packlist' );
+ is( $realei->{Perl}{version}, 'fake_test_version',
+ 'new(config_override => HASH) overrides %Config' );
+
+ ok( exists $realei->{FakeMod}, 'new() with overrides should find modules with .packlists');
+ isa_ok( $realei->{FakeMod}{packlist}, 'ExtUtils::Packlist' );
+ is( $realei->{FakeMod}{version}, '1.1.1',
+ '... should find version in modules' );
+}
+
+# Check if extra_libs works.
+{
+ my $realei = ExtUtils::Installed->new(
+ 'extra_libs' => [ cwd() ],
+ );
+ isa_ok( $realei, 'ExtUtils::Installed' );
+ isa_ok( $realei->{Perl}{packlist}, 'ExtUtils::Packlist' );
+ ok( exists $realei->{FakeMod},
+ 'new() with extra_libs should find modules with .packlists');
+
+ #{ use Data::Dumper; local $realei->{':private:'}{Config};
+ # warn Dumper($realei); }
+
+ isa_ok( $realei->{FakeMod}{packlist}, 'ExtUtils::Packlist' );
+ is( $realei->{FakeMod}{version}, '1.1.1',
+ '... should find version in modules' );
+}
+
+# modules
+$ei->{$_} = 1 for qw( abc def ghi );
+is( join(' ', $ei->modules()), 'abc def ghi',
+ 'modules() should return sorted keys' );
+
+# This didn't work for a long time due to a sort in scalar context oddity.
+is( $ei->modules, 3, 'modules() in scalar context' );
+
+# files
+$ei->{goodmod} = {
+ packlist => {
+ ($Config{man1direxp} ?
+ (File::Spec->catdir($Config{man1direxp}, 'foo') => 1) :
+ ()),
+ ($Config{man3direxp} ?
+ (File::Spec->catdir($Config{man3direxp}, 'bar') => 1) :
+ ()),
+ File::Spec->catdir($prefix, 'foobar') => 1,
+ foobaz => 1,
+ },
+};
+
+eval { $ei->files('badmod') };
+like( $@, qr/badmod is not installed/,'files() should croak given bad modname');
+eval { $ei->files('goodmod', 'badtype' ) };
+like( $@, qr/type must be/,'files() should croak given bad type' );
+
+my @files;
+SKIP: {
+ skip('no man directory man1dir on this system', 2)
+ unless $Config{man1direxp};
+ @files = $ei->files('goodmod', 'doc', $Config{man1direxp});
+ is( scalar @files, 1, '... should find doc file under given dir' );
+ is( (grep { /foo$/ } @files), 1, '... checking file name' );
+}
+SKIP: {
+ skip('no man directories on this system', 1) unless $mandirs;
+ @files = $ei->files('goodmod', 'doc');
+ is( scalar @files, $mandirs, '... should find all doc files with no dir' );
+}
+
+ at files = $ei->files('goodmod', 'prog', 'fake', 'fake2');
+is( scalar @files, 0, '... should find no doc files given wrong dirs' );
+ at files = $ei->files('goodmod', 'prog');
+is( scalar @files, 1, '... should find doc file in correct dir' );
+like( $files[0], qr/foobar[>\]]?$/, '... checking file name' );
+ at files = $ei->files('goodmod');
+is( scalar @files, 2 + $mandirs, '... should find all files with no type specified' );
+my %dirnames = map { lc($_) => dirname($_) } @files;
+
+# directories
+my @dirs = $ei->directories('goodmod', 'prog', 'fake');
+is( scalar @dirs, 0, 'directories() should return no dirs if no files found' );
+
+SKIP: {
+ skip('no man directories on this system', 1) unless $mandirs;
+ @dirs = $ei->directories('goodmod', 'doc');
+ is( scalar @dirs, $mandirs, '... should find all files files() would' );
+}
+ at dirs = $ei->directories('goodmod');
+is( scalar @dirs, 2 + $mandirs, '... should find all files files() would, again' );
+ at files = sort map { exists $dirnames{lc($_)} ? $dirnames{lc($_)} : '' } @files;
+is( join(' ', @files), join(' ', @dirs), '... should sort output' );
+
+# directory_tree
+my $expectdirs =
+ ($mandirs == 2) &&
+ (dirname($Config{man1direxp}) eq dirname($Config{man3direxp}))
+ ? 3 : 2;
+
+SKIP: {
+ skip('no man directories on this system', 1) unless $mandirs;
+ @dirs = $ei->directory_tree('goodmod', 'doc', $Config{man1direxp} ?
+ dirname($Config{man1direxp}) : dirname($Config{man3direxp}));
+ is( scalar @dirs, $expectdirs,
+ 'directory_tree() should report intermediate dirs to those requested' );
+}
+
+my $fakepak = Fakepak->new(102);
+
+$ei->{yesmod} = {
+ version => 101,
+ packlist => $fakepak,
+};
+
+# these should all croak
+foreach my $sub (qw( validate packlist version )) {
+ eval { $ei->$sub('nomod') };
+ like( $@, qr/nomod is not installed/,
+ "$sub() should croak when asked about uninstalled module" );
+}
+
+# validate
+is( $ei->validate('yesmod'), 'validated',
+ 'validate() should return results of packlist validate() call' );
+
+# packlist
+is( ${ $ei->packlist('yesmod') }, 102,
+ 'packlist() should report installed mod packlist' );
+
+# version
+is( $ei->version('yesmod'), 101,
+ 'version() should report installed mod version' );
+
+
+package Fakepak;
+
+sub new {
+ my $class = shift;
+ bless(\(my $scalar = shift), $class);
+}
+
+sub validate {
+ return 'validated'
+}
Copied: trunk/contrib/perl/lib/ExtUtils/t/Liblist.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/Liblist.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/Liblist.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/Liblist.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,36 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ unshift @INC, '../lib';
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+chdir 't';
+
+use strict;
+use Test::More tests => 6;
+
+
+BEGIN {
+ use_ok( 'ExtUtils::Liblist' );
+}
+
+ok( defined &ExtUtils::Liblist::ext,
+ 'ExtUtils::Liblist::ext() defined for backwards compat' );
+
+{
+ my @warn;
+ local $SIG{__WARN__} = sub {push @warn, [@_]};
+
+ my $ll = bless {}, 'ExtUtils::Liblist';
+ my @out = $ll->ext('-ln0tt43r3_perl');
+ is( @out, 4, 'enough output' );
+ unlike( $out[2], qr/-ln0tt43r3_perl/, 'bogus library not added' );
+ ok( @warn, 'had warning');
+
+ is( grep(/\QNote (probably harmless): No library found for \E(-l)?n0tt43r3_perl/, map { @$_ } @warn), 1 ) || diag join "\n", @warn;
+}
Copied: trunk/contrib/perl/lib/ExtUtils/t/MM_Any.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/MM_Any.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/MM_Any.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/MM_Any.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,33 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+chdir 't';
+
+use Test::More tests => 7;
+BEGIN { use_ok('ExtUtils::MM') }
+
+
+### OS Flavor methods
+
+can_ok( 'MM', 'os_flavor', 'os_flavor_is' );
+
+# Can't really know what the flavors are going to be, so we just
+# make sure it returns something.
+my @flavors = MM->os_flavor;
+ok( @flavors, 'os_flavor() returned something' );
+
+ok( MM->os_flavor_is($flavors[rand @flavors]),
+ 'os_flavor_is() one flavor' );
+ok( MM->os_flavor_is($flavors[rand @flavors], 'BogusOS'),
+ ' many flavors' );
+ok( !MM->os_flavor_is('BogusOS'), ' wrong flavor' );
+ok( !MM->os_flavor_is(), ' no flavor' );
+
Copied: trunk/contrib/perl/lib/ExtUtils/t/MM_BeOS.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/MM_BeOS.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/MM_BeOS.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/MM_BeOS.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,56 @@
+#!/usr/bin/perl
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+chdir 't';
+
+use Test::More;
+
+BEGIN {
+ if ($^O =~ /beos/i or $^O eq 'haiku') {
+ plan tests => 4;
+ } else {
+ plan skip_all => 'This is not BeOS';
+ }
+}
+
+use Config;
+use File::Spec;
+use File::Basename;
+
+# tels - Taken from MM_Win32.t - I must not understand why this works, right?
+# Does this mimic ExtUtils::MakeMaker ok?
+{
+ @MM::ISA = qw(
+ ExtUtils::MM_Unix
+ ExtUtils::Liblist::Kid
+ ExtUtils::MakeMaker
+ );
+ # MM package faked up by messy MI entanglement
+ package MM;
+ sub DESTROY {}
+}
+
+require_ok( 'ExtUtils::MM_BeOS' );
+
+my $MM = bless { NAME => "Foo" }, 'MM';
+
+# init_linker
+{
+ my $libperl = File::Spec->catfile('$(PERL_INC)',
+ $Config{libperl} || 'libperl.a' );
+ my $export = '';
+ my $after = '';
+ $MM->init_linker;
+
+ is( $MM->{PERL_ARCHIVE}, $libperl, 'PERL_ARCHIVE' );
+ is( $MM->{PERL_ARCHIVE_AFTER}, $after, 'PERL_ARCHIVE_AFTER' );
+ is( $MM->{EXPORT_LIST}, $export, 'EXPORT_LIST' );
+}
Copied: trunk/contrib/perl/lib/ExtUtils/t/MM_Cygwin.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/MM_Cygwin.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/MM_Cygwin.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/MM_Cygwin.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,136 @@
+#!/usr/bin/perl
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+chdir 't';
+
+use strict;
+use Test::More;
+
+BEGIN {
+ if ($^O =~ /cygwin/i) {
+ plan tests => 14;
+ } else {
+ plan skip_all => "This is not cygwin";
+ }
+}
+
+use Config;
+use File::Spec;
+use ExtUtils::MM;
+use Config;
+
+use_ok( 'ExtUtils::MM_Cygwin' );
+
+# test canonpath
+my $path = File::Spec->canonpath('/a/../../c');
+is( MM->canonpath('/a/../../c'), $path,
+ 'canonpath() method should work just like the one in File::Spec' );
+
+# test cflags, with the fake package below
+my $MM = bless({
+ CFLAGS => 'fakeflags',
+ CCFLAGS => '',
+}, 'MM');
+
+# with CFLAGS set, it should be returned
+is( $MM->cflags(), 'fakeflags',
+ 'cflags() should return CFLAGS member data, if set' );
+
+delete $MM->{CFLAGS};
+
+# ExtUtils::MM_Cygwin::cflags() calls this, fake the output
+{
+ local $SIG{__WARN__} = sub {
+ warn @_ unless $_[0] =~ /^Subroutine .* redefined/;
+ };
+ *ExtUtils::MM_Unix::cflags = sub { return $_[1] };
+}
+
+# respects the config setting, should ignore whitespace around equal sign
+my $ccflags = $Config{useshrplib} eq 'true' ? ' -DUSEIMPORTLIB' : '';
+{
+ local $MM->{NEEDS_LINKING} = 1;
+ $MM->cflags(<<FLAGS);
+OPTIMIZE = opt
+PERLTYPE =pt
+FLAGS
+}
+
+like( $MM->{CFLAGS}, qr/OPTIMIZE = opt/, '... should set OPTIMIZE' );
+like( $MM->{CFLAGS}, qr/PERLTYPE = pt/, '... should set PERLTYPE' );
+like( $MM->{CFLAGS}, qr/CCFLAGS = $ccflags/, '... should set CCFLAGS' );
+
+# test manifypods
+$MM = bless({
+ NOECHO => 'noecho',
+ MAN3PODS => {},
+ MAN1PODS => {},
+ MAKEFILE => 'Makefile',
+}, 'MM');
+unlike( $MM->manifypods(), qr/foo/,
+ 'manifypods() should return without PODS values set' );
+
+$MM->{MAN3PODS} = { foo => 'foo.1' };
+my $res = $MM->manifypods();
+like( $res, qr/pure_all.*foo.*foo.1/s, '... should add MAN3PODS targets' );
+
+
+# init_linker
+{
+ my $libperl = $Config{libperl} || 'libperl.a';
+ $libperl =~ s/\.a/.dll.a/ if $] >= 5.006002;
+ $libperl = "\$(PERL_INC)/$libperl";
+
+ my $export = '';
+ my $after = '';
+ $MM->init_linker;
+
+ is( $MM->{PERL_ARCHIVE}, $libperl, 'PERL_ARCHIVE' );
+ is( $MM->{PERL_ARCHIVE_AFTER}, $after, 'PERL_ARCHIVE_AFTER' );
+ is( $MM->{EXPORT_LIST}, $export, 'EXPORT_LIST' );
+}
+
+# Tests for correct handling of maybe_command in /cygdrive/*
+# and c:/*. $ENV{COMSPEC}, if it exists, should always be executable.
+SKIP: {
+ skip "Needs Cygwin::win_to_posix_path()", 2 unless defined &Cygwin::win_to_posix_path;
+
+ SKIP: {
+ my $comspec = $ENV{COMSPEC};
+ skip(q[$ENV{COMSPEC} does not exist], 1) unless $comspec;
+
+ $comspec = Cygwin::win_to_posix_path($comspec);
+
+ ok(MM->maybe_command($comspec), qq{'$comspec' should be executable"});
+ }
+
+ # 'C:/' should *never* be executable, it's a directory.
+ {
+ my $cdrive = Cygwin::win_to_posix_path("C:/");
+
+ ok(!MM->maybe_command($cdrive), qq{'$cdrive' should never be executable});
+ }
+}
+
+# Our copy of Perl (with a unix-path) should always be executable.
+ok(MM->maybe_command($Config{perlpath}), qq{'$Config{perlpath}' should be executable});
+
+
+package FakeOut;
+
+sub TIEHANDLE {
+ bless(\(my $scalar), $_[0]);
+}
+
+sub PRINT {
+ my $self = shift;
+ $$self .= shift;
+}
Copied: trunk/contrib/perl/lib/ExtUtils/t/MM_NW5.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/MM_NW5.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/MM_NW5.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/MM_NW5.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,302 @@
+#!/usr/bin/perl
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ unshift @INC, '../lib';
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+chdir 't';
+
+
+use Test::More;
+
+BEGIN {
+ if ($^O =~ /NetWare/i) {
+ plan tests => 39;
+ } else {
+ plan skip_all => 'This is not NW5';
+ }
+}
+
+use Config;
+use File::Spec;
+use File::Basename;
+use ExtUtils::MM;
+
+require_ok( 'ExtUtils::MM_NW5' );
+
+# Dummy MM object until we have a real MM init method.
+my $MM = bless {
+ DIR => [],
+ NOECHO => '@',
+ XS => {},
+ MAKEFILE => 'Makefile',
+ RM_RF => 'rm -rf',
+ MV => 'mv',
+ }, 'MM';
+
+
+# replace_manpage_separator() => tr|/|.|s ?
+{
+ my $man = 'a/path/to//something';
+ ( my $replaced = $man ) =~ tr|/|.|s;
+ is( $MM->replace_manpage_separator( $man ),
+ $replaced, 'replace_manpage_separator()' );
+}
+
+# maybe_command()
+SKIP: {
+ skip( '$ENV{COMSPEC} not set', 2 )
+ unless $ENV{COMSPEC} =~ m!((?:[a-z]:)?[^|<>]+)!i;
+ my $comspec = $1;
+ is( $MM->maybe_command( $comspec ),
+ $comspec, 'COMSPEC is a maybe_command()' );
+ ( my $comspec2 = $comspec ) =~ s|\..{3}$||;
+ like( $MM->maybe_command( $comspec2 ),
+ qr/\Q$comspec/i,
+ 'maybe_command() without extension' );
+}
+
+my $had_pathext = exists $ENV{PATHEXT};
+{
+ local $ENV{PATHEXT} = '.exe';
+ ok( ! $MM->maybe_command( 'not_a_command.com' ),
+ 'not a maybe_command()' );
+}
+# Bug in Perl. local $ENV{FOO} won't delete the key afterward.
+delete $ENV{PATHEXT} unless $had_pathext;
+
+# file_name_is_absolute() [Does not support UNC-paths]
+{
+ ok( $MM->file_name_is_absolute( 'SYS:/' ),
+ 'file_name_is_absolute()' );
+ ok( ! $MM->file_name_is_absolute( 'some/path/' ),
+ 'not file_name_is_absolute()' );
+
+}
+
+# find_perl()
+# Should be able to find running perl... $^X is OK on NW5
+{
+ my $my_perl = $1 if $^X =~ /(.*)/; # are we in -T or -t?
+ my( $perl, $path ) = fileparse( $my_perl );
+ like( $MM->find_perl( $], [ $perl ], [ $path ] ),
+ qr/^\Q$my_perl\E$/i, 'find_perl() finds this perl' );
+}
+
+# catdir() (calls MM_NW5->canonpath)
+{
+ my @path_eg = qw( SYS trick dir/now_OK );
+
+ is( $MM->catdir( @path_eg ),
+ 'SYS\\trick\\dir\\now_OK', 'catdir()' );
+ is( $MM->catdir( @path_eg ),
+ File::Spec->catdir( @path_eg ),
+ 'catdir() eq File::Spec->catdir()' );
+
+# catfile() (calls MM_NW5->catdir)
+ push @path_eg, 'file.ext';
+
+ is( $MM->catfile( @path_eg ),
+ 'SYS\\trick\\dir\\now_OK\\file.ext', 'catfile()' );
+
+ is( $MM->catfile( @path_eg ),
+ File::Spec->catfile( @path_eg ),
+ 'catfile() eq File::Spec->catfile()' );
+}
+
+# init_others(): check if all keys are created and set?
+# qw( TOUCH CHMOD CP RM_F RM_RF MV NOOP TEST_F LD AR LDLOADLIBS DEV_NUL )
+{
+ my $mm_w32 = bless( {}, 'MM' );
+ $mm_w32->init_others();
+ my @keys = qw( TOUCH CHMOD CP RM_F RM_RF MV NOOP
+ TEST_F LD AR LDLOADLIBS DEV_NULL );
+ for my $key ( @keys ) {
+ ok( $mm_w32->{ $key }, "init_others: $key" );
+ }
+}
+
+# constants()
+{
+ my $mm_w32 = bless {
+ NAME => 'TestMM_NW5',
+ VERSION => '1.00',
+ VERSION_FROM => 'TestMM_NW5',
+ PM => { 'MM_NW5.pm' => 1 },
+ }, 'MM';
+
+ # XXX Hack until we have a proper init method.
+ # Flesh out some necessary keys in the MM object.
+ foreach my $key (qw(XS C O_FILES H HTMLLIBPODS HTMLSCRIPTPODS
+ MAN1PODS MAN3PODS PARENT_NAME)) {
+ $mm_w32->{$key} = '';
+ }
+ my $s_PM = join( " \\\n\t", sort keys %{$mm_w32->{PM}} );
+ my $k_PM = join( " \\\n\t", %{$mm_w32->{PM}} );
+
+ like( $mm_w32->constants(),
+ qr|^NAME\ =\ TestMM_NW5\s+VERSION\ =\ 1\.00.+
+ MAKEMAKER\ =\ \Q$INC{'ExtUtils/MakeMaker.pm'}\E\s+
+ MM_VERSION\ =\ \Q$ExtUtils::MakeMaker::VERSION\E.+
+ VERSION_FROM\ =\ TestMM_NW5.+
+ TO_INST_PM\ =\ \Q$s_PM\E\s+
+ PM_TO_BLIB\ =\ \Q$k_PM\E
+ |xs, 'constants()' );
+
+}
+
+# path()
+my $had_path = exists $ENV{PATH};
+{
+ my @path_eg = ( qw( . .. ), 'SYS:\\Program Files' );
+ local $ENV{PATH} = join ';', @path_eg;
+ ok( eq_array( [ $MM->path() ], [ @path_eg ] ),
+ 'path() [preset]' );
+}
+# Bug in Perl. local $ENV{FOO} will not delete key afterwards.
+delete $ENV{PATH} unless $had_path;
+
+# static_lib() should look into that
+# dynamic_bs() should look into that
+# dynamic_lib() should look into that
+
+# clean()
+{
+ my $clean = $Config{cc} =~ /^gcc/i ? 'dll.base dll.exp' : '*.pdb';
+ like( $MM->clean(), qr/^clean ::\s+\Q-$(RM_F) $clean\E\s+$/m,
+ 'clean() Makefile target' );
+}
+
+
+# init_linker
+{
+ my $libperl = $Config{libperl} || 'libperl.a';
+ my $export = '$(BASEEXT).def';
+ my $after = '';
+ $MM->init_linker;
+
+ is( $MM->{PERL_ARCHIVE}, $libperl, 'PERL_ARCHIVE' );
+ is( $MM->{PERL_ARCHIVE_AFTER}, $after, 'PERL_ARCHIVE_AFTER' );
+ is( $MM->{EXPORT_LIST}, $export, 'EXPORT_LIST' );
+}
+
+
+# canonpath()
+{
+ my $path = 'SYS:/TEMP';
+ is( $MM->canonpath( $path ), File::Spec->canonpath( $path ),
+ 'canonpath() eq File::Spec->canonpath' );
+}
+
+# perl_script()
+my $script_ext = '';
+my $script_name = 'mm_w32tmp';
+SKIP: {
+ local *SCRIPT;
+ skip( "Can't create temp file: $!", 4 )
+ unless open SCRIPT, "> $script_name";
+ print SCRIPT <<'EOSCRIPT';
+#! perl
+__END__
+EOSCRIPT
+ skip( "Can't write to temp file: $!", 4 )
+ unless close SCRIPT;
+ # now start tests:
+ is( $MM->perl_script( $script_name ),
+ "${script_name}$script_ext", "perl_script ($script_ext)" );
+
+ skip( "Can't rename temp file: $!", 3 )
+ unless rename $script_name, "${script_name}.pl";
+ $script_ext = '.pl';
+ is( $MM->perl_script( $script_name ),
+ "${script_name}$script_ext", "perl_script ($script_ext)" );
+
+ skip( "Can't rename temp file: $!", 2 )
+ unless rename "${script_name}$script_ext", "${script_name}.bat";
+ $script_ext = '.bat';
+ is( $MM->perl_script( $script_name ),
+ "${script_name}$script_ext", "perl_script ($script_ext)" );
+
+ skip( "Can't rename temp file: $!", 1 )
+ unless rename "${script_name}$script_ext", "${script_name}.noscript";
+ $script_ext = '.noscript';
+
+ isnt( $MM->perl_script( $script_name ),
+ "${script_name}$script_ext",
+ "not a perl_script anymore ($script_ext)" );
+ is( $MM->perl_script( $script_name ), undef,
+ "perl_script ($script_ext) returns empty" );
+}
+unlink "${script_name}$script_ext" if -f "${script_name}$script_ext";
+
+
+# pm_to_blib()
+{
+ like( $MM->pm_to_blib(),
+ qr/^pm_to_blib: \Q$(TO_INST_PM)\E.+\Q$(TOUCH) \E\$@\s+$/ms,
+ 'pm_to_blib' );
+}
+
+# tool_autosplit()
+{
+ my %attribs = ( MAXLEN => 255 );
+ like( $MM->tool_autosplit( %attribs ),
+ qr/^\#\ Usage:\ \$\(AUTOSPLITFILE\)
+ \ FileToSplit\ AutoDirToSplitInto.+
+ AUTOSPLITFILE\ =\ \$\(PERLRUN\)\ .+
+ \$AutoSplit::Maxlen=$attribs{MAXLEN};
+ /xms,
+ 'tool_autosplit()' );
+}
+
+
+# xs_o() should look into that
+# top_targets() should look into that
+
+# dist_ci() should look into that
+# dist_core() should look into that
+
+# pasthru()
+{
+ my $pastru = "PASTHRU = " . ($Config{make} =~ /^nmake/i ? "-nologo" : "");
+ is( $MM->pasthru(), $pastru, 'pasthru()' );
+}
+
+package FakeOut;
+
+sub TIEHANDLE {
+ bless(\(my $scalar), $_[0]);
+}
+
+sub PRINT {
+ my $self = shift;
+ $$self .= shift;
+}
+
+__END__
+
+=head1 NAME
+
+MM_NW5.t - Tests for ExtUtils::MM_NW5
+
+=head1 TODO
+
+ - Methods to still be checked:
+ # static_lib() should look into that
+ # dynamic_bs() should look into that
+ # dynamic_lib() should look into that
+ # xs_o() should look into that
+ # top_targets() should look into that
+ # dist_ci() should look into that
+ # dist_core() should look into that
+
+=head1 AUTHOR
+
+20011228 Abe Timmerman <abe at ztreet.demon.nl>
+
+=cut
Copied: trunk/contrib/perl/lib/ExtUtils/t/MM_OS2.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/MM_OS2.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/MM_OS2.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/MM_OS2.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,279 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+chdir 't';
+
+use strict;
+use Test::More;
+if ($^O =~ /os2/i) {
+ plan( tests => 32 );
+} else {
+ plan( skip_all => "This is not OS/2" );
+}
+
+# for dlsyms, overridden in tests
+BEGIN {
+ package ExtUtils::MM_OS2;
+ use subs 'system', 'unlink';
+}
+
+# for maybe_command
+use File::Spec;
+
+use_ok( 'ExtUtils::MM_OS2' );
+ok( grep( 'ExtUtils::MM_OS2', @MM::ISA),
+ 'ExtUtils::MM_OS2 should be parent of MM' );
+
+# dlsyms
+my $mm = bless({
+ SKIPHASH => {
+ dynamic => 1
+ },
+ NAME => 'foo:bar::',
+}, 'ExtUtils::MM_OS2');
+
+is( $mm->dlsyms(), '',
+ 'dlsyms() should return nothing with dynamic flag set' );
+
+$mm->{BASEEXT} = 'baseext';
+delete $mm->{SKIPHASH};
+my $res = $mm->dlsyms();
+like( $res, qr/baseext\.def: Makefile/,
+ '... without flag, should return make targets' );
+like( $res, qr/"DL_FUNCS" => { }/,
+ '... should provide empty hash refs where necessary' );
+like( $res, qr/"DL_VARS" => \[]/, '... and empty array refs too' );
+
+$mm->{FUNCLIST} = 'funclist';
+$res = $mm->dlsyms( IMPORTS => 'imports' );
+like( $res, qr/"FUNCLIST" => .+funclist/,
+ '... should pick up values from object' );
+like( $res, qr/"IMPORTS" => .+imports/, '... and allow parameter options too' );
+
+my $can_write;
+{
+ local *OUT;
+ $can_write = open(OUT, '>tmp_imp');
+}
+
+SKIP: {
+ skip("Cannot write test files: $!", 7) unless $can_write;
+
+ $mm->{IMPORTS} = { foo => 'bar' };
+
+ local $@;
+ eval { $mm->dlsyms() };
+ like( $@, qr/Can.t mkdir tmp_imp/,
+ '... should die if directory cannot be made' );
+
+ unlink('tmp_imp') or skip("Cannot remove test file: $!", 9);
+ eval { $mm->dlsyms() };
+ like( $@, qr/Malformed IMPORT/, 'should die from malformed import symbols');
+
+ $mm->{IMPORTS} = { foo => 'bar.baz' };
+
+ my @sysfail = ( 1, 0, 1 );
+ my ($sysargs, $unlinked);
+
+ *ExtUtils::MM_OS2::system = sub {
+ $sysargs = shift;
+ return shift @sysfail;
+ };
+
+ *ExtUtils::MM_OS2::unlink = sub {
+ $unlinked++;
+ };
+
+ eval { $mm->dlsyms() };
+
+ like( $sysargs, qr/^emximp/, '... should try to call system() though' );
+ like( $@, qr/Cannot make import library/,
+ '... should die if emximp syscall fails' );
+
+ # sysfail is 0 now, call emximp call should succeed
+ eval { $mm->dlsyms() };
+ is( $unlinked, 1, '... should attempt to unlink temp files' );
+ like( $@, qr/Cannot extract import/,
+ '... should die if other syscall fails' );
+
+ # make both syscalls succeed
+ @sysfail = (0, 0);
+ local $@;
+ eval { $mm->dlsyms() };
+ is( $@, '', '... should not die if both syscalls succeed' );
+}
+
+# static_lib
+{
+ my $called = 0;
+
+ # avoid "used only once"
+ local *ExtUtils::MM_Unix::static_lib;
+ *ExtUtils::MM_Unix::static_lib = sub {
+ $called++;
+ return "\n\ncalled static_lib\n\nline2\nline3\n\nline4";
+ };
+
+ my $args = bless({ IMPORTS => {}, }, 'MM');
+
+ # without IMPORTS as a populated hash, there will be no extra data
+ my $ret = ExtUtils::MM_OS2::static_lib( $args );
+ is( $called, 1, 'static_lib() should call parent method' );
+ like( $ret, qr/^called static_lib/m,
+ '... should return parent data unless IMPORTS exists' );
+
+ $args->{IMPORTS} = { foo => 1};
+ $ret = ExtUtils::MM_OS2::static_lib( $args );
+ is( $called, 2, '... should call parent method if extra imports passed' );
+ like( $ret, qr/^called static_lib\n\t\$\(AR\) \$\(AR_STATIC_ARGS\)/m,
+ '... should append make tags to first line from parent method' );
+ like( $ret, qr/\$@\n\n\nline2\nline3\n\nline4/m,
+ '... should include remaining data from parent method' );
+
+}
+
+# replace_manpage_separator
+my $sep = '//a///b//c/de';
+is( ExtUtils::MM_OS2->replace_manpage_separator($sep), '.a.b.c.de',
+ 'replace_manpage_separator() should turn multiple slashes into periods' );
+
+# maybe_command
+{
+ local *DIR;
+ my ($dir, $noext, $exe, $cmd);
+ my $found = 0;
+
+ my ($curdir, $updir) = (File::Spec->curdir, File::Spec->updir);
+
+ # we need:
+ # 1) a directory
+ # 2) an executable file with no extension
+ # 3) an executable file with the .exe extension
+ # 4) an executable file with the .cmd extension
+ # we assume there will be one somewhere in the path
+ # in addition, we need them to be unique enough they do not trip
+ # an earlier file test in maybe_command(). Portability.
+
+ foreach my $path (split(/:/, $ENV{PATH})) {
+ opendir(DIR, $path) or next;
+ while (defined(my $file = readdir(DIR))) {
+ next if $file eq $curdir or $file eq $updir;
+ $file = File::Spec->catfile($path, $file);
+ unless (defined $dir) {
+ if (-d $file) {
+ next if ( -x $file . '.exe' or -x $file . '.cmd' );
+
+ $dir = $file;
+ $found++;
+ }
+ }
+ if (-x $file) {
+ my $ext;
+ if ($file =~ s/\.(exe|cmd)\z//) {
+ $ext = $1;
+
+ # skip executable files with names too similar
+ next if -x $file;
+ $file .= '.' . $ext;
+
+ } else {
+ unless (defined $noext) {
+ $noext = $file;
+ $found++;
+ }
+ next;
+ }
+
+ unless (defined $exe) {
+ if ($ext eq 'exe') {
+ $exe = $file;
+ $found++;
+ next;
+ }
+ }
+ unless (defined $cmd) {
+ if ($ext eq 'cmd') {
+ $cmd = $file;
+ $found++;
+ next;
+ }
+ }
+ }
+ last if $found == 4;
+ }
+ last if $found == 4;
+ }
+
+ SKIP: {
+ skip('No appropriate directory found', 1) unless defined $dir;
+ is( ExtUtils::MM_OS2->maybe_command( $dir ), undef,
+ 'maybe_command() should ignore directories' );
+ }
+
+ SKIP: {
+ skip('No non-exension command found', 1) unless defined $noext;
+ is( ExtUtils::MM_OS2->maybe_command( $noext ), $noext,
+ 'maybe_command() should find executable lacking file extension' );
+ }
+
+ SKIP: {
+ skip('No .exe command found', 1) unless defined $exe;
+ (my $noexe = $exe) =~ s/\.exe\z//;
+ is( ExtUtils::MM_OS2->maybe_command( $noexe ), $exe,
+ 'maybe_command() should find .exe file lacking extension' );
+ }
+
+ SKIP: {
+ skip('No .cmd command found', 1) unless defined $cmd;
+ (my $nocmd = $cmd) =~ s/\.cmd\z//;
+ is( ExtUtils::MM_OS2->maybe_command( $nocmd ), $cmd,
+ 'maybe_command() should find .cmd file lacking extension' );
+ }
+}
+
+# file_name_is_absolute
+ok( ExtUtils::MM_OS2->file_name_is_absolute( 's:/' ),
+ 'file_name_is_absolute() should be true for paths with volume and slash' );
+ok( ExtUtils::MM_OS2->file_name_is_absolute( '\foo' ),
+ '... and for paths with leading slash but no volume' );
+ok( ! ExtUtils::MM_OS2->file_name_is_absolute( 'arduk' ),
+ '... but not for paths with no leading slash or volume' );
+
+
+$mm->init_linker;
+
+# PERL_ARCHIVE
+is( $mm->{PERL_ARCHIVE}, '$(PERL_INC)/libperl$(LIB_EXT)', 'PERL_ARCHIVE' );
+
+# PERL_ARCHIVE_AFTER
+{
+ my $aout = 0;
+ local *OS2::is_aout;
+ *OS2::is_aout = \$aout;
+
+ $mm->init_linker;
+ isnt( $mm->{PERL_ARCHIVE_AFTER}, '',
+ 'PERL_ARCHIVE_AFTER should be empty without $is_aout set' );
+ $aout = 1;
+ is( $mm->{PERL_ARCHIVE_AFTER},
+ '$(PERL_INC)/libperl_override$(LIB_EXT)',
+ '... and has libperl_override if it is set' );
+}
+
+# EXPORT_LIST
+is( $mm->{EXPORT_LIST}, '$(BASEEXT).def',
+ 'EXPORT_LIST should add .def to BASEEXT member' );
+
+END {
+ use File::Path;
+ rmtree('tmp_imp');
+ unlink 'tmpimp.imp';
+}
Copied: trunk/contrib/perl/lib/ExtUtils/t/MM_Unix.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/MM_Unix.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/MM_Unix.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/MM_Unix.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,232 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+chdir 't';
+
+BEGIN {
+ use Test::More;
+
+ if( $^O =~ /^VMS|os2|MacOS|MSWin32|cygwin|beos|netware$/i ) {
+ plan skip_all => 'Non-Unix platform';
+ }
+ else {
+ plan tests => 110;
+ }
+}
+
+BEGIN { use_ok( 'ExtUtils::MM_Unix' ); }
+
+use strict;
+use File::Spec;
+
+my $class = 'ExtUtils::MM_Unix';
+
+# only one of the following can be true
+# test should be removed if MM_Unix ever stops handling other OS than Unix
+my $os = ($ExtUtils::MM_Unix::Is{OS2} || 0)
+ + ($ExtUtils::MM_Unix::Is{Win32} || 0)
+ + ($ExtUtils::MM_Unix::Is{Dos} || 0)
+ + ($ExtUtils::MM_Unix::Is{VMS} || 0);
+cmp_ok ( $os, '<=', 1, 'There can be only one (or none)');
+
+is($ExtUtils::MM_Unix::VERSION, $ExtUtils::MakeMaker::VERSION, 'MM_Unix has a $VERSION');
+
+# when the following calls like canonpath, catdir etc are replaced by
+# File::Spec calls, the test's become a bit pointless
+
+foreach ( qw( xx/ ./xx/ xx/././xx xx///xx) ) {
+ is ($class->canonpath($_), File::Spec->canonpath($_), "canonpath $_");
+}
+
+is ($class->catdir('xx','xx'), File::Spec->catdir('xx','xx'),
+ 'catdir(xx, xx) => xx/xx');
+is ($class->catfile('xx','xx','yy'), File::Spec->catfile('xx','xx','yy'),
+ 'catfile(xx, xx) => xx/xx');
+
+is ($class->file_name_is_absolute('Bombdadil'),
+ File::Spec->file_name_is_absolute('Bombdadil'),
+ 'file_name_is_absolute()');
+
+is ($class->path(), File::Spec->path(), 'path() same as File::Spec->path()');
+
+foreach (qw/updir curdir rootdir/)
+ {
+ is ($class->$_(), File::Spec->$_(), $_ );
+ }
+
+foreach ( qw /
+ c_o
+ clean
+ const_cccmd
+ const_config
+ const_loadlibs
+ constants
+ depend
+ dist
+ dist_basics
+ dist_ci
+ dist_core
+ distdir
+ dist_test
+ dlsyms
+ dynamic
+ dynamic_bs
+ dynamic_lib
+ exescan
+ extliblist
+ find_perl
+ fixin
+ force
+ guess_name
+ init_dirscan
+ init_main
+ init_others
+ install
+ installbin
+ linkext
+ lsdir
+ macro
+ makeaperl
+ makefile
+ manifypods
+ needs_linking
+ pasthru
+ perldepend
+ pm_to_blib
+ ppd
+ prefixify
+ processPL
+ quote_paren
+ realclean
+ static
+ static_lib
+ staticmake
+ subdir_x
+ subdirs
+ test
+ test_via_harness
+ test_via_script
+ tool_autosplit
+ tool_xsubpp
+ tools_other
+ top_targets
+ writedoc
+ xs_c
+ xs_cpp
+ xs_o
+ / )
+ {
+ can_ok($class, $_);
+ }
+
+###############################################################################
+# some more detailed tests for the methods above
+
+ok ( join (' ', $class->dist_basics()), 'distclean :: realclean distcheck');
+
+###############################################################################
+# has_link_code tests
+
+my $t = bless { NAME => "Foo" }, $class;
+$t->{HAS_LINK_CODE} = 1;
+is ($t->has_link_code(),1,'has_link_code'); is ($t->{HAS_LINK_CODE},1);
+
+$t->{HAS_LINK_CODE} = 0;
+is ($t->has_link_code(),0); is ($t->{HAS_LINK_CODE},0);
+
+delete $t->{HAS_LINK_CODE}; delete $t->{OBJECT};
+is ($t->has_link_code(),0); is ($t->{HAS_LINK_CODE},0);
+
+delete $t->{HAS_LINK_CODE}; $t->{OBJECT} = 1;
+is ($t->has_link_code(),1); is ($t->{HAS_LINK_CODE},1);
+
+delete $t->{HAS_LINK_CODE}; delete $t->{OBJECT}; $t->{MYEXTLIB} = 1;
+is ($t->has_link_code(),1); is ($t->{HAS_LINK_CODE},1);
+
+delete $t->{HAS_LINK_CODE}; delete $t->{MYEXTLIB}; $t->{C} = [ 'Gloin' ];
+is ($t->has_link_code(),1); is ($t->{HAS_LINK_CODE},1);
+
+###############################################################################
+# libscan
+
+is ($t->libscan('foo/RCS/bar'), '', 'libscan on RCS');
+is ($t->libscan('CVS/bar/car'), '', 'libscan on CVS');
+is ($t->libscan('SCCS'), '', 'libscan on SCCS');
+is ($t->libscan('.svn/something'), '', 'libscan on Subversion');
+is ($t->libscan('foo/b~r'), 'foo/b~r', 'libscan on file with ~');
+is ($t->libscan('foo/RCS.pm'), 'foo/RCS.pm', 'libscan on file with RCS');
+
+is ($t->libscan('Fatty'), 'Fatty', 'libscan on something not a VC file' );
+
+###############################################################################
+# maybe_command
+
+open(FILE, ">command"); print FILE "foo"; close FILE;
+SKIP: {
+ skip("no separate execute mode on VOS", 2) if $^O eq "vos";
+
+ ok !$t->maybe_command('command') ,"non executable file isn't a command";
+
+ chmod 0755, "command";
+ ok ($t->maybe_command('command'), "executable file is a command");
+}
+unlink "command";
+
+
+###############################################################################
+# perl_script (on unix any ordinary, readable file)
+
+my $self_name = $ENV{PERL_CORE} ? '../lib/ExtUtils/t/MM_Unix.t'
+ : 'MM_Unix.t';
+is ($t->perl_script($self_name),$self_name, 'we pass as a perl_script()');
+
+###############################################################################
+# PERM_RW and PERM_RWX
+
+$t->init_PERM;
+is ($t->{PERM_RW},'644', 'PERM_RW is 644');
+is ($t->{PERM_RWX},'755', 'PERM_RWX is 755');
+is ($t->{PERM_DIR},'755', 'PERM_DIR is 755');
+
+
+###############################################################################
+# post_constants, postamble, post_initialize
+
+foreach (qw/ post_constants postamble post_initialize/) {
+ is ($t->$_(),'', "$_() is an empty string");
+}
+
+###############################################################################
+# replace_manpage_separator
+
+is ($t->replace_manpage_separator('Foo/Bar'),'Foo::Bar','manpage_separator');
+
+###############################################################################
+
+$t->init_linker;
+foreach (qw/ EXPORT_LIST PERL_ARCHIVE PERL_ARCHIVE_AFTER /)
+{
+ ok( exists $t->{$_}, "$_ was defined" );
+ is( $t->{$_}, '', "$_ is empty on Unix");
+}
+
+
+{
+ $t->{CCFLAGS} = '-DMY_THING';
+ $t->{LIBPERL_A} = 'libperl.a';
+ $t->{LIB_EXT} = '.a';
+ local $t->{NEEDS_LINKING} = 1;
+ $t->cflags();
+
+ # Brief bug where CCFLAGS was being blown away
+ is( $t->{CCFLAGS}, '-DMY_THING', 'cflags retains CCFLAGS' );
+}
+
Copied: trunk/contrib/perl/lib/ExtUtils/t/MM_VMS.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/MM_VMS.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/MM_VMS.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/MM_VMS.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,76 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+chdir 't';
+
+BEGIN {
+ @Methods = (qw(wraplist
+ rootdir
+ ext
+ guess_name
+ find_perl
+ path
+ maybe_command
+ perl_script
+ file_name_is_absolute
+ replace_manpage_separator
+ init_others
+ constants
+ cflags
+ const_cccmd
+ pm_to_blib
+ tool_autosplit
+ tool_xsubpp
+ tools_other
+ dist
+ c_o
+ xs_c
+ xs_o
+ top_targets
+ dlsyms
+ dynamic_lib
+ dynamic_bs
+ static_lib
+ manifypods
+ processPL
+ installbin
+ subdir_x
+ clean
+ realclean
+ dist_basics
+ dist_core
+ distdir
+ dist_test
+ install
+ perldepend
+ makefile
+ test
+ test_via_harness
+ test_via_script
+ makeaperl
+ ));
+}
+
+BEGIN {
+ use Test::More;
+ if ($^O eq 'VMS') {
+ plan( tests => @Methods + 1 );
+ }
+ else {
+ plan( skip_all => "This is not VMS" );
+ }
+}
+
+use_ok( 'ExtUtils::MM_VMS' );
+
+foreach my $meth (@Methods) {
+ can_ok( 'ExtUtils::MM_VMS', $meth);
+}
Copied: trunk/contrib/perl/lib/ExtUtils/t/MM_Win32.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/MM_Win32.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/MM_Win32.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/MM_Win32.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,313 @@
+#!/usr/bin/perl
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+chdir 't';
+
+use strict;
+use Test::More;
+
+BEGIN {
+ if ($^O =~ /MSWin32/i) {
+ plan tests => 49;
+ } else {
+ plan skip_all => 'This is not Win32';
+ }
+}
+
+use Config;
+use File::Spec;
+use File::Basename;
+use ExtUtils::MM;
+
+require_ok( 'ExtUtils::MM_Win32' );
+
+# Dummy MM object until we have a real MM init method.
+my $MM = bless {
+ DIR => [],
+ NOECHO => '@',
+ XS => {},
+ MAKEFILE => 'Makefile',
+ RM_RF => 'rm -rf',
+ MV => 'mv',
+ MAKE => $Config{make}
+ }, 'MM';
+
+
+# replace_manpage_separator() => tr|/|.|s ?
+{
+ my $man = 'a/path/to//something';
+ ( my $replaced = $man ) =~ tr|/|.|s;
+ is( $MM->replace_manpage_separator( $man ),
+ $replaced, 'replace_manpage_separator()' );
+}
+
+# maybe_command()
+SKIP: {
+ skip( '$ENV{COMSPEC} not set', 2 )
+ unless $ENV{COMSPEC} =~ m!((?:[a-z]:)?[^|<>]+)!i;
+ my $comspec = $1;
+ is( $MM->maybe_command( $comspec ),
+ $comspec, 'COMSPEC is a maybe_command()' );
+ ( my $comspec2 = $comspec ) =~ s|\..{3}$||;
+ like( $MM->maybe_command( $comspec2 ),
+ qr/\Q$comspec/i,
+ 'maybe_command() without extension' );
+}
+
+my $had_pathext = exists $ENV{PATHEXT};
+{
+ local $ENV{PATHEXT} = '.exe';
+ ok( ! $MM->maybe_command( 'not_a_command.com' ),
+ 'not a maybe_command()' );
+}
+# Bug in Perl. local $ENV{FOO} won't delete the key afterward.
+delete $ENV{PATHEXT} unless $had_pathext;
+
+# file_name_is_absolute() [Does not support UNC-paths]
+{
+ ok( $MM->file_name_is_absolute( 'C:/' ),
+ 'file_name_is_absolute()' );
+ ok( ! $MM->file_name_is_absolute( 'some/path/' ),
+ 'not file_name_is_absolute()' );
+
+}
+
+# find_perl()
+# Should be able to find running perl... $^X is OK on Win32
+{
+ my $my_perl = $1 if $^X =~ /(.*)/; # are we in -T or -t?
+ my( $perl, $path ) = fileparse( $my_perl );
+ like( $MM->find_perl( $], [ $perl ], [ $path ], 0 ),
+ qr/^\Q$my_perl\E$/i, 'find_perl() finds this perl' );
+}
+
+# catdir() (calls MM_Win32->canonpath)
+{
+ my @path_eg = qw( c: trick dir/now_OK );
+
+ is( $MM->catdir( @path_eg ),
+ 'C:\\trick\\dir\\now_OK', 'catdir()' );
+ is( $MM->catdir( @path_eg ),
+ File::Spec->catdir( @path_eg ),
+ 'catdir() eq File::Spec->catdir()' );
+
+# catfile() (calls MM_Win32->catdir)
+ push @path_eg, 'file.ext';
+
+ is( $MM->catfile( @path_eg ),
+ 'C:\\trick\\dir\\now_OK\\file.ext', 'catfile()' );
+
+ is( $MM->catfile( @path_eg ),
+ File::Spec->catfile( @path_eg ),
+ 'catfile() eq File::Spec->catfile()' );
+}
+
+# init_others(): check if all keys are created and set?
+# qw( TOUCH CHMOD CP RM_F RM_RF MV NOOP TEST_F LD AR LDLOADLIBS DEV_NUL )
+{
+ my $mm_w32 = bless( { BASEEXT => 'Foo' }, 'MM' );
+ $mm_w32->init_others();
+ my @keys = qw( TOUCH CHMOD CP RM_F RM_RF MV NOOP
+ TEST_F LD AR LDLOADLIBS DEV_NULL );
+ for my $key ( @keys ) {
+ ok( $mm_w32->{ $key }, "init_others: $key" );
+ }
+}
+
+# constants()
+# XXX this test is probably useless now that we can call individual
+# init_* methods and check the keys in $mm_w32 directly
+{
+ my $mm_w32 = bless {
+ NAME => 'TestMM_Win32',
+ VERSION => '1.00',
+ PM => { 'MM_Win32.pm' => 1 },
+ }, 'MM';
+
+ # XXX Hack until we have a proper init method.
+ # Flesh out some necessary keys in the MM object.
+ @{$mm_w32}{qw(XS MAN1PODS MAN3PODS)} = ({}) x 3;
+ @{$mm_w32}{qw(C O_FILES H)} = ([]) x 3;
+ @{$mm_w32}{qw(PARENT_NAME)} = ('') x 3;
+ $mm_w32->{FULLEXT} = 'TestMM_Win32';
+ $mm_w32->{BASEEXT} = 'TestMM_Win32';
+
+ $mm_w32->init_VERSION;
+ $mm_w32->init_linker;
+ $mm_w32->init_INST;
+ $mm_w32->init_xs;
+
+ my $s_PM = join( " \\\n\t", sort keys %{$mm_w32->{PM}} );
+ my $k_PM = join( " \\\n\t", %{$mm_w32->{PM}} );
+
+ my $constants = $mm_w32->constants;
+
+ foreach my $regex (
+ qr|^NAME \s* = \s* TestMM_Win32 \s* $|xms,
+ qr|^VERSION \s* = \s* 1\.00 \s* $|xms,
+ qr|^MAKEMAKER \s* = \s* \Q$INC{'ExtUtils/MakeMaker.pm'}\E \s* $|xms,
+ qr|^MM_VERSION \s* = \s* \Q$ExtUtils::MakeMaker::VERSION\E \s* $|xms,
+ qr|^TO_INST_PM \s* = \s* \Q$s_PM\E \s* $|xms,
+ qr|^PM_TO_BLIB \s* = \s* \Q$k_PM\E \s* $|xms,
+ )
+ {
+ like( $constants, $regex, 'constants() check' );
+ }
+}
+
+# path()
+{
+ ok( eq_array( [ $MM->path() ], [ File::Spec->path ] ),
+ 'path() [preset]' );
+}
+
+# static_lib() should look into that
+# dynamic_bs() should look into that
+# dynamic_lib() should look into that
+
+# init_linker
+{
+ my $libperl = File::Spec->catfile('$(PERL_INC)',
+ $Config{libperl} || 'libperl.a');
+ my $export = '$(BASEEXT).def';
+ my $after = '';
+ $MM->init_linker;
+
+ is( $MM->{PERL_ARCHIVE}, $libperl, 'PERL_ARCHIVE' );
+ is( $MM->{PERL_ARCHIVE_AFTER}, $after, 'PERL_ARCHIVE_AFTER' );
+ is( $MM->{EXPORT_LIST}, $export, 'EXPORT_LIST' );
+}
+
+# canonpath()
+{
+ my $path = 'c:\\Program Files/SomeApp\\Progje.exe';
+ is( $MM->canonpath( $path ), File::Spec->canonpath( $path ),
+ 'canonpath() eq File::Spec->canonpath' );
+}
+
+# perl_script()
+my $script_ext = '';
+my $script_name = 'mm_w32tmp';
+SKIP: {
+ local *SCRIPT;
+ skip( "Can't create temp file: $!", 4 )
+ unless open SCRIPT, "> $script_name";
+ print SCRIPT <<'EOSCRIPT';
+#! perl
+__END__
+EOSCRIPT
+ skip( "Can't write to temp file: $!", 4 )
+ unless close SCRIPT;
+ # now start tests:
+ is( $MM->perl_script( $script_name ),
+ "${script_name}$script_ext", "perl_script ($script_ext)" );
+
+ skip( "Can't rename temp file: $!", 3 )
+ unless rename $script_name, "${script_name}.pl";
+ $script_ext = '.pl';
+ is( $MM->perl_script( $script_name ),
+ "${script_name}$script_ext", "perl_script ($script_ext)" );
+
+ skip( "Can't rename temp file: $!", 2 )
+ unless rename "${script_name}$script_ext", "${script_name}.bat";
+ $script_ext = '.bat';
+ is( $MM->perl_script( $script_name ),
+ "${script_name}$script_ext", "perl_script ($script_ext)" );
+
+ skip( "Can't rename temp file: $!", 1 )
+ unless rename "${script_name}$script_ext", "${script_name}.noscript";
+ $script_ext = '.noscript';
+
+ isnt( $MM->perl_script( $script_name ),
+ "${script_name}$script_ext",
+ "not a perl_script anymore ($script_ext)" );
+ is( $MM->perl_script( $script_name ), undef,
+ "perl_script ($script_ext) returns empty" );
+}
+unlink "${script_name}$script_ext" if -f "${script_name}$script_ext";
+
+# is_make_type()
+{
+ # Check for literal nmake
+ SKIP: {
+ skip("Not using 'nmake'", 2) unless $Config{make} eq 'nmake';
+ ok( $MM->is_make_type('nmake'), '->is_make_type(nmake) true' );
+ ok( ! $MM->is_make_type('dmake'), '->is_make_type(dmake) false' );
+ }
+
+ # Check for literal nmake
+ SKIP: {
+ skip("Not using /nmake/", 2) unless $Config{make} =~ /nmake/;
+ ok( $MM->is_make_type('nmake'), '->is_make_type(nmake) true' );
+ ok( ! $MM->is_make_type('dmake'), '->is_make_type(dmake) false' );
+ }
+
+ # Check for literal dmake
+ SKIP: {
+ skip("Not using 'dmake'", 2) unless $Config{make} eq 'dmake';
+ ok( $MM->is_make_type('dmake'), '->is_make_type(dmake) true' );
+ ok( ! $MM->is_make_type('nmake'), '->is_make_type(nmake) false' );
+ }
+
+ # Check for literal dmake
+ SKIP: {
+ skip("Not using /dmake/", 2) unless $Config{make} =~ /dmake/;
+ ok( $MM->is_make_type('dmake'), '->is_make_type(dmake) true' );
+ ok( ! $MM->is_make_type('nmake'), '->is_make_type(nmake) false' );
+ }
+
+}
+
+# xs_o() should look into that
+# top_targets() should look into that
+
+# dist_ci() should look into that
+# dist_core() should look into that
+
+# pasthru()
+{
+ my $pastru = "PASTHRU = " . ($Config{make} =~ /^nmake/i ? "-nologo" : "");
+ is( $MM->pasthru(), $pastru, 'pasthru()' );
+}
+
+package FakeOut;
+
+sub TIEHANDLE {
+ bless(\(my $scalar), $_[0]);
+}
+
+sub PRINT {
+ my $self = shift;
+ $$self .= shift;
+}
+
+__END__
+
+=head1 NAME
+
+MM_Win32.t - Tests for ExtUtils::MM_Win32
+
+=head1 TODO
+
+ - Methods to still be checked:
+ # static_lib() should look into that
+ # dynamic_bs() should look into that
+ # dynamic_lib() should look into that
+ # xs_o() should look into that
+ # top_targets() should look into that
+ # dist_ci() should look into that
+ # dist_core() should look into that
+
+=head1 AUTHOR
+
+20011228 Abe Timmerman <abe at ztreet.demon.nl>
+
+=cut
Copied: trunk/contrib/perl/lib/ExtUtils/t/MakeMaker_Parameters.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/MakeMaker_Parameters.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/MakeMaker_Parameters.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/MakeMaker_Parameters.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,74 @@
+#!/usr/bin/perl -w
+
+# Things like the CPAN shell rely on the "MakeMaker Parameters" section of the
+# Makefile to learn a module's dependencies so we'd damn well better test it.
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use strict;
+use warnings;
+
+use ExtUtils::MakeMaker;
+use Test::More;
+
+my $mm = bless {}, "MM";
+
+sub extract_params {
+ my $text = join "\n", @_;
+
+ $text =~ s{^\s* \# \s+ MakeMaker\ Parameters: \s*\n}{}x;
+ $text =~ s{^#}{}gms;
+ $text =~ s{\n}{,\n}g;
+
+ no strict 'subs';
+ return { eval "$text" };
+}
+
+sub test_round_trip {
+ my $args = shift;
+ my $want = @_ ? shift : $args;
+
+ my $have = extract_params($mm->_MakeMaker_Parameters_section($args));
+
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ is_deeply $have, $want or diag explain $have, "\n", $want;
+}
+
+is join("", $mm->_MakeMaker_Parameters_section()), <<'EXPECT', "nothing";
+# MakeMaker Parameters:
+EXPECT
+
+test_round_trip({ NAME => "Foo" });
+test_round_trip({ NAME => "Foo", PREREQ_PM => { "Foo::Bar" => 0 } });
+test_round_trip({ NAME => "Foo", PREREQ_PM => { "Foo::Bar" => 1.23 } });
+
+# Test the special case for BUILD_REQUIRES
+{
+ my $have = {
+ NAME => "Foo",
+ PREREQ_PM => { "Foo::Bar" => 1.23 },
+ BUILD_REQUIRES => { "Baz" => 0.12 },
+ };
+
+ my $want = {
+ NAME => "Foo",
+ PREREQ_PM => {
+ "Foo::Bar" => 1.23,
+ "Baz" => 0.12,
+ },
+ BUILD_REQUIRES => { "Baz" => 0.12 },
+ };
+
+ test_round_trip( $have, $want );
+}
+
+done_testing();
+
Copied: trunk/contrib/perl/lib/ExtUtils/t/Manifest.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/Manifest.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/Manifest.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/Manifest.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,417 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ unshift @INC, '../lib';
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+chdir 't';
+
+use strict;
+
+use Test::More tests => 94;
+use Cwd;
+
+use File::Spec;
+use File::Path;
+use File::Find;
+use Config;
+
+my $Is_VMS = $^O eq 'VMS';
+my $Is_VMS_noefs = $Is_VMS;
+if ($Is_VMS) {
+ my $vms_efs = 0;
+ if (eval 'require VMS::Feature') {
+ $vms_efs = VMS::Feature::current("efs_charset");
+ } else {
+ my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || '';
+ $vms_efs = $efs_charset =~ /^[ET1]/i;
+ }
+ $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.
+ at INC = map { File::Spec->rel2abs($_) } @INC;
+
+# keep track of everything added so it can all be deleted
+my %Files;
+sub add_file {
+ my ($file, $data) = @_;
+ $data ||= 'foo';
+ 1 while unlink $file; # or else we'll get multiple versions on VMS
+ open( T, '> '.$file) or return;
+ print T $data;
+ close T;
+ return 0 unless -e $file; # exists under the name we gave it ?
+ ++$Files{$file};
+}
+
+sub read_manifest {
+ open( M, 'MANIFEST' ) or return;
+ chomp( my @files = <M> );
+ close M;
+ return @files;
+}
+
+sub catch_warning {
+ my $warn = '';
+ local $SIG{__WARN__} = sub { $warn .= $_[0] };
+ return join('', $_[0]->() ), $warn;
+}
+
+sub remove_dir {
+ ok( rmdir( $_ ), "remove $_ directory" ) for @_;
+}
+
+# use module, import functions
+BEGIN {
+ use_ok( 'ExtUtils::Manifest',
+ qw( mkmanifest manicheck filecheck fullcheck
+ maniread manicopy skipcheck maniadd maniskip) );
+}
+
+my $cwd = Cwd::getcwd();
+
+# Just in case any old files were lying around.
+rmtree('mantest');
+
+ok( mkdir( 'mantest', 0777 ), 'make mantest directory' );
+ok( chdir( 'mantest' ), 'chdir() to mantest' );
+ok( add_file('foo'), 'add a temporary file' );
+
+# This ensures the -x check for manicopy means something
+# Some platforms don't have chmod or an executable bit, in which case
+# this call will do nothing or fail, but on the platforms where chmod()
+# works, we test the executable bit is copied
+chmod( 0744, 'foo') if $Config{'chmod'};
+
+# there shouldn't be a MANIFEST there
+my ($res, $warn) = catch_warning( \&mkmanifest );
+# Canonize the order.
+$warn = join("", map { "$_|" }
+ sort { lc($a) cmp lc($b) } split /\r?\n/, $warn);
+is( $warn, "Added to MANIFEST: foo|Added to MANIFEST: MANIFEST|",
+ "mkmanifest() displayed its additions" );
+
+# and now you see it
+ok( -e 'MANIFEST', 'create MANIFEST file' );
+
+my @list = read_manifest();
+is( @list, 2, 'check files in MANIFEST' );
+ok( ! ExtUtils::Manifest::filecheck(), 'no additional files in directory' );
+
+# after adding bar, the MANIFEST is out of date
+ok( add_file( 'bar' ), 'add another file' );
+ok( ! manicheck(), 'MANIFEST now out of sync' );
+
+# it reports that bar has been added and throws a warning
+($res, $warn) = catch_warning( \&filecheck );
+
+like( $warn, qr/^Not in MANIFEST: bar/, 'warning that bar has been added' );
+is( $res, 'bar', 'bar reported as new' );
+
+# now quiet the warning that bar was added and test again
+($res, $warn) = do { local $ExtUtils::Manifest::Quiet = 1;
+ catch_warning( \&skipcheck )
+ };
+is( $warn, '', 'disabled warnings' );
+
+# add a skip file with a rule to skip itself (and the nonexistent glob '*baz*')
+add_file( 'MANIFEST.SKIP', "baz\n.SKIP" );
+
+# this'll skip the new file
+($res, $warn) = catch_warning( \&skipcheck );
+like( $warn, qr/^Skipping MANIFEST\.SKIP/i, 'got skipping warning' );
+
+my @skipped;
+catch_warning( sub {
+ @skipped = skipcheck()
+});
+
+is( join( ' ', @skipped ), 'MANIFEST.SKIP', 'listed skipped files' );
+
+{
+ local $ExtUtils::Manifest::Quiet = 1;
+ is( join(' ', filecheck() ), 'bar', 'listing skipped with filecheck()' );
+}
+
+# add a subdirectory and a file there that should be found
+ok( mkdir( 'moretest', 0777 ), 'created moretest directory' );
+add_file( File::Spec->catfile('moretest', 'quux'), 'quux' );
+ok( exists( ExtUtils::Manifest::manifind()->{'moretest/quux'} ),
+ "manifind found moretest/quux" );
+
+# only MANIFEST and foo are in the manifest
+$_ = 'foo';
+my $files = maniread();
+is( keys %$files, 2, 'two files found' );
+is( join(' ', sort { lc($a) cmp lc($b) } keys %$files), 'foo MANIFEST',
+ 'both files found' );
+is( $_, 'foo', q{maniread() doesn't clobber $_} );
+
+ok( mkdir( 'copy', 0777 ), 'made copy directory' );
+
+# Check that manicopy copies files.
+manicopy( $files, 'copy', 'cp' );
+my @copies = ();
+find( sub { push @copies, $_ if -f }, 'copy' );
+ at copies = map { s/\.$//; $_ } @copies if $Is_VMS; # VMS likes to put dots on
+ # the end of files.
+# Have to compare insensitively for non-case preserving VMS
+is_deeply( [sort map { lc } @copies], [sort map { lc } keys %$files] );
+
+# cp would leave files readonly, so check permissions.
+foreach my $orig (@copies) {
+ my $copy = "copy/$orig";
+ ok( -r $copy, "$copy: must be readable" );
+ is( -w $copy, -w $orig, " writable if original was" );
+ is( -x $copy, -x $orig, " executable if original was" );
+}
+rmtree('copy');
+
+
+# poison the manifest, and add a comment that should be reported
+add_file( 'MANIFEST', 'none #none' );
+is( ExtUtils::Manifest::maniread()->{none}, '#none',
+ 'maniread found comment' );
+
+ok( mkdir( 'copy', 0777 ), 'made copy directory' );
+$files = maniread();
+eval { (undef, $warn) = catch_warning( sub {
+ manicopy( $files, 'copy', 'cp' ) })
+};
+
+# a newline comes through, so get rid of it
+chomp($warn);
+# the copy should have given a warning
+like($warn, qr/^none not found/, 'carped about none' );
+($res, $warn) = catch_warning( \&skipcheck );
+like($warn, qr/^Skipping MANIFEST.SKIP/i, 'warned about MANIFEST.SKIP' );
+
+# tell ExtUtils::Manifest to use a different file
+{
+ local $ExtUtils::Manifest::MANIFEST = 'albatross';
+ ($res, $warn) = catch_warning( \&mkmanifest );
+ like( $warn, qr/Added to albatross: /, 'using a new manifest file' );
+
+ # add the new file to the list of files to be deleted
+ $Files{'albatross'}++;
+}
+
+
+# Make sure MANIFEST.SKIP is using complete relative paths
+add_file( 'MANIFEST.SKIP' => "^moretest/q\n" );
+
+# This'll skip moretest/quux
+($res, $warn) = catch_warning( \&skipcheck );
+like( $warn, qr{^Skipping moretest/quux$}i, 'got skipping warning again' );
+
+
+# There was a bug where entries in MANIFEST would be blotted out
+# by MANIFEST.SKIP rules.
+add_file( 'MANIFEST.SKIP' => 'foo' );
+add_file( 'MANIFEST' => "foobar\n" );
+add_file( 'foobar' => '123' );
+($res, $warn) = catch_warning( \&manicheck );
+is( $res, '', 'MANIFEST overrides MANIFEST.SKIP' );
+is( $warn, '', 'MANIFEST overrides MANIFEST.SKIP, no warnings' );
+
+$files = maniread;
+ok( !$files->{wibble}, 'MANIFEST in good state' );
+maniadd({ wibble => undef });
+maniadd({ yarrow => "hock" });
+$files = maniread;
+is( $files->{wibble}, '', 'maniadd() with undef comment' );
+is( $files->{yarrow}, 'hock',' with comment' );
+is( $files->{foobar}, '', ' preserved old entries' );
+
+my %funky_files;
+# test including a filename with a space
+SKIP: {
+ add_file( 'foo bar' => "space" )
+ or skip "couldn't create spaced test file", 2;
+ local $ExtUtils::Manifest::MANIFEST = "albatross";
+ maniadd({ 'foo bar' => "contains space"});
+ is( maniread()->{'foo bar'}, "contains space",
+ 'spaced manifest filename' );
+ add_file( 'albatross.bak', '' );
+ ($res, $warn) = catch_warning( \&mkmanifest );
+ like( $warn, qr/\A(Added to.*\n)+\z/m,
+ 'no warnings about funky filename' );
+ $funky_files{'space'} = 'foo bar';
+}
+
+# test including a filename with a space and a quote
+SKIP: {
+ add_file( 'foo\' baz\'quux' => "quote" )
+ or skip "couldn't create quoted test file", 1;
+ local $ExtUtils::Manifest::MANIFEST = "albatross";
+ maniadd({ 'foo\' baz\'quux' => "contains quote"});
+ is( maniread()->{'foo\' baz\'quux'}, "contains quote",
+ 'quoted manifest filename' );
+ $funky_files{'space_quote'} = 'foo\' baz\'quux';
+}
+
+# test including a filename with a space and a backslash
+SKIP: {
+ add_file( 'foo bar\\baz' => "backslash" )
+ or skip "couldn't create backslash test file", 1;
+ local $ExtUtils::Manifest::MANIFEST = "albatross";
+ maniadd({ 'foo bar\\baz' => "contains backslash"});
+ is( maniread()->{'foo bar\\baz'}, "contains backslash",
+ 'backslashed manifest filename' );
+ $funky_files{'space_backslash'} = 'foo bar\\baz';
+}
+
+# test including a filename with a space, quote, and a backslash
+SKIP: {
+ add_file( 'foo bar\\baz\'quux' => "backslash/quote" )
+ or skip "couldn't create backslash/quote test file", 1;
+ local $ExtUtils::Manifest::MANIFEST = "albatross";
+ maniadd({ 'foo bar\\baz\'quux' => "backslash and quote"});
+ is( maniread()->{'foo bar\\baz\'quux'}, "backslash and quote",
+ 'backslashed and quoted manifest filename' );
+ $funky_files{'space_quote_backslash'} = 'foo bar\\baz\'quux';
+}
+
+my @funky_keys = qw(space space_quote space_backslash space_quote_backslash);
+# test including an external manifest.skip file in MANIFEST.SKIP
+{
+ maniadd({ foo => undef , albatross => undef,
+ 'mymanifest.skip' => undef, 'mydefault.skip' => undef});
+ for (@funky_keys) {
+ maniadd( {$funky_files{$_} => $_} ) if defined $funky_files{$_};
+ }
+
+ add_file('mymanifest.skip' => "^foo\n");
+ add_file('mydefault.skip' => "^my\n");
+ local $ExtUtils::Manifest::DEFAULT_MSKIP =
+ File::Spec->catfile($cwd, qw(mantest mydefault.skip));
+ my $skip = File::Spec->catfile($cwd, qw(mantest mymanifest.skip));
+ add_file('MANIFEST.SKIP' =>
+ "albatross\n#!include $skip\n#!include_default");
+ my ($res, $warn) = catch_warning( \&skipcheck );
+ for (qw(albatross foo foobar mymanifest.skip mydefault.skip)) {
+ like( $warn, qr/Skipping \b$_\b/,
+ "Skipping $_" );
+ }
+ for my $funky_key (@funky_keys) {
+ SKIP: {
+ my $funky_file = $funky_files{$funky_key};
+ skip "'$funky_key' not created", 1 unless $funky_file;
+ like( $warn, qr/Skipping \b\Q$funky_file\E\b/,
+ "Skipping $funky_file");
+ }
+ }
+ ($res, $warn) = catch_warning( \&mkmanifest );
+ for (qw(albatross foo foobar mymanifest.skip mydefault.skip)) {
+ like( $warn, qr/Removed from MANIFEST: \b$_\b/,
+ "Removed $_ from MANIFEST" );
+ }
+ for my $funky_key (@funky_keys) {
+ SKIP: {
+ my $funky_file = $funky_files{$funky_key};
+ skip "'$funky_key' not created", 1 unless $funky_file;
+ like( $warn, qr/Removed from MANIFEST: \b\Q$funky_file\E\b/,
+ "Removed $funky_file from MANIFEST");
+ }
+ }
+ my $files = maniread;
+ ok( ! exists $files->{albatross}, 'albatross excluded via MANIFEST.SKIP' );
+ ok( exists $files->{yarrow}, 'yarrow included in MANIFEST' );
+ ok( exists $files->{bar}, 'bar included in MANIFEST' );
+ ok( ! exists $files->{foobar}, 'foobar excluded via mymanifest.skip' );
+ ok( ! exists $files->{foo}, 'foo excluded via mymanifest.skip' );
+ ok( ! exists $files->{'mymanifest.skip'},
+ 'mymanifest.skip excluded via mydefault.skip' );
+ ok( ! exists $files->{'mydefault.skip'},
+ 'mydefault.skip excluded via mydefault.skip' );
+
+ # test exclusion of funky files
+ for my $funky_key (@funky_keys) {
+ SKIP: {
+ my $funky_file = $funky_files{$funky_key};
+ skip "'$funky_key' not created", 1 unless $funky_file;
+ ok( ! exists $files->{$funky_file},
+ "'$funky_file' excluded via mymanifest.skip" );
+ }
+ }
+
+ # tests for maniskip
+ my $skipchk = maniskip();
+ is ( $skipchk->('albatross'), 1,
+ 'albatross excluded via MANIFEST.SKIP' );
+ is( $skipchk->('yarrow'), '',
+ 'yarrow included in MANIFEST' );
+ is( $skipchk->('bar'), '',
+ 'bar included in MANIFEST' );
+ $skipchk = maniskip('mymanifest.skip');
+ is( $skipchk->('foobar'), 1,
+ 'foobar excluded via mymanifest.skip' );
+ is( $skipchk->('foo'), 1,
+ 'foo excluded via mymanifest.skip' );
+ is( $skipchk->('mymanifest.skip'), '',
+ 'mymanifest.skip included via mydefault.skip' );
+ is( $skipchk->('mydefault.skip'), '',
+ 'mydefault.skip included via mydefault.skip' );
+ $skipchk = maniskip('mydefault.skip');
+ is( $skipchk->('foobar'), '',
+ 'foobar included via mydefault.skip' );
+ is( $skipchk->('foo'), '',
+ 'foo included via mydefault.skip' );
+ is( $skipchk->('mymanifest.skip'), 1,
+ 'mymanifest.skip excluded via mydefault.skip' );
+ is( $skipchk->('mydefault.skip'), 1,
+ 'mydefault.skip excluded via mydefault.skip' );
+
+ my $extsep = $Is_VMS_noefs ? '_' : '.';
+ $Files{"$_.bak"}++ for ('MANIFEST', "MANIFEST${extsep}SKIP");
+}
+
+add_file('MANIFEST' => 'Makefile.PL');
+maniadd({ foo => 'bar' });
+$files = maniread;
+# VMS downcases the MANIFEST. We normalize it here to match.
+%$files = map { (lc $_ => $files->{$_}) } keys %$files;
+my %expect = ( 'makefile.pl' => '',
+ 'foo' => 'bar'
+ );
+is_deeply( $files, \%expect, 'maniadd() vs MANIFEST without trailing newline');
+
+#add_file('MANIFEST' => 'Makefile.PL');
+#maniadd({ foo => 'bar' });
+
+SKIP: {
+ chmod( 0400, 'MANIFEST' );
+ skip "Can't make MANIFEST read-only", 2 if -w 'MANIFEST';
+
+ eval {
+ maniadd({ 'foo' => 'bar' });
+ };
+ is( $@, '', "maniadd() won't open MANIFEST if it doesn't need to" );
+
+ eval {
+ maniadd({ 'grrrwoof' => 'yippie' });
+ };
+ like( $@, qr/^\Qmaniadd() could not open MANIFEST:\E/,
+ "maniadd() dies if it can't open the MANIFEST" );
+
+ chmod( 0600, 'MANIFEST' );
+}
+
+
+END {
+ is( unlink( keys %Files ), keys %Files, 'remove all added files' );
+ remove_dir( 'moretest', 'copy' );
+
+ # now get rid of the parent directory
+ ok( chdir( $cwd ), 'return to parent directory' );
+ remove_dir( 'mantest' );
+}
+
Copied: trunk/contrib/perl/lib/ExtUtils/t/Mkbootstrap.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/Mkbootstrap.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/Mkbootstrap.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/Mkbootstrap.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,155 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ('../lib', 'lib/');
+ }
+ else {
+ unshift @INC, 't/lib/';
+ }
+}
+chdir 't';
+
+use vars qw( $required );
+use Test::More tests => 18;
+
+BEGIN { use_ok( 'ExtUtils::Mkbootstrap' ) }
+
+# Mkbootstrap makes a backup copy of "$_[0].bs" if it exists and is non-zero
+my $file_is_ready;
+local *OUT;
+if (open(OUT, '>mkboot.bs')) {
+ $file_is_ready = 1;
+ print OUT 'meaningless text';
+ close OUT;
+}
+
+SKIP: {
+ skip("could not make dummy .bs file: $!", 2) unless $file_is_ready;
+
+ Mkbootstrap('mkboot');
+ ok( -s 'mkboot.bso', 'Mkbootstrap should backup the .bs file' );
+ local *IN;
+ if (open(IN, 'mkboot.bso')) {
+ chomp ($file_is_ready = <IN>);
+ close IN;
+ }
+
+ is( $file_is_ready, 'meaningless text', 'backup should be a perfect copy' );
+}
+
+
+# if it doesn't exist or is zero bytes in size, it won't be backed up
+Mkbootstrap('fakeboot');
+ok( !( -f 'fakeboot.bso' ), 'Mkbootstrap should not backup an empty file' );
+
+use TieOut;
+my $out = tie *STDOUT, 'TieOut';
+
+# with $Verbose set, it should print status messages about libraries
+$ExtUtils::Mkbootstrap::Verbose = 1;
+Mkbootstrap('');
+is( $out->read, "\tbsloadlibs=\n", 'should report libraries in Verbose mode' );
+
+Mkbootstrap('', 'foo');
+like( $out->read, qr/bsloadlibs=foo/, 'should still report libraries' );
+
+
+# if ${_[0]}_BS exists, require it
+$file_is_ready = open(OUT, '>boot_BS');
+
+SKIP: {
+ skip("cannot open boot_BS for writing: $!", 1) unless $file_is_ready;
+
+ print OUT '$main::required = 1';
+ close OUT;
+ Mkbootstrap('boot');
+
+ ok( $required, 'baseext_BS file should be require()d' );
+}
+
+
+# if there are any arguments, open a file named baseext.bs
+$file_is_ready = open(OUT, '>dasboot.bs');
+
+SKIP: {
+ skip("cannot make dasboot.bs: $!", 5) unless $file_is_ready;
+
+ # if it can't be opened for writing, we want to prove that it'll die
+ close OUT;
+ chmod 0444, 'dasboot.bs';
+
+ SKIP: {
+ skip("cannot write readonly files", 1) if -w 'dasboot.bs';
+
+ eval{ Mkbootstrap('dasboot', 1) };
+ like( $@, qr/Unable to open dasboot\.bs/, 'should die given bad filename' );
+ }
+
+ # now put it back like it was
+ chmod 0777, 'dasboot.bs';
+ eval{ Mkbootstrap('dasboot', 'myarg') };
+ is( $@, '', 'should not die, given good filename' );
+
+ # red and reed (a visual pun makes tests worth reading)
+ my $read = $out->read();
+ like( $read, qr/Writing dasboot.bs/, 'should print status' );
+ like( $read, qr/containing: my/, 'should print verbose status on request' );
+
+ # now be tricky, and set the status for the next skip block
+ $file_is_ready = open(IN, 'dasboot.bs');
+ ok( $file_is_ready, 'should have written a new .bs file' );
+}
+
+
+SKIP: {
+ skip("cannot read .bs file: $!", 2) unless $file_is_ready;
+
+ my $file = do { local $/ = <IN> };
+
+ # filename should be in header
+ like( $file, qr/# dasboot DynaLoader/, 'file should have boilerplate' );
+
+ # should print arguments within this array
+ like( $file, qr/qw\(myarg\);/, 'should have written array to file' );
+}
+
+
+# overwrite this file (may whack portability, but the name's too good to waste)
+$file_is_ready = open(OUT, '>dasboot.bs');
+
+SKIP: {
+ skip("cannot make dasboot.bs again: $!", 1) unless $file_is_ready;
+ close OUT;
+
+ # if $DynaLoader::bscode is set, write its contents to the file
+ local $DynaLoader::bscode;
+ $DynaLoader::bscode = 'Wall';
+ $ExtUtils::Mkbootstrap::Verbose = 0;
+
+ # if arguments contain '-l' or '-L' or '-R' print dl_findfile message
+ eval{ Mkbootstrap('dasboot', '-Larry') };
+ is( $@, '', 'should be able to open a file again');
+
+ $file_is_ready = open(IN, 'dasboot.bs');
+}
+
+SKIP: {
+ skip("cannot open dasboot.bs for reading: $!", 3) unless $file_is_ready;
+
+ my $file = do { local $/ = <IN> };
+ is( $out->read, "Writing dasboot.bs\n", 'should hush without Verbose set' );
+
+ # and find our hidden tribute to a fine example
+ like( $file, qr/dl_findfile.+Larry/s, 'should load libraries if needed' );
+ like( $file, qr/Wall\n1;\n/ms, 'should write $DynaLoader::bscode if set' );
+}
+
+close IN;
+close OUT;
+
+END {
+ # clean things up, even on VMS
+ 1 while unlink(qw( mkboot.bso boot_BS dasboot.bs .bs ));
+}
Copied: trunk/contrib/perl/lib/ExtUtils/t/PL_FILES.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/PL_FILES.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/PL_FILES.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/PL_FILES.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,42 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+chdir 't';
+
+use strict;
+use Test::More tests => 9;
+
+use File::Spec;
+use MakeMaker::Test::Setup::PL_FILES;
+use MakeMaker::Test::Utils;
+
+my $perl = which_perl();
+my $make = make_run();
+perl_lib();
+
+setup;
+
+END {
+ ok( chdir File::Spec->updir );
+ ok( teardown );
+}
+
+ok chdir('PL_FILES-Module');
+
+run(qq{$perl Makefile.PL});
+cmp_ok( $?, '==', 0 );
+
+my $make_out = run("$make");
+is( $?, 0 ) || diag $make_out;
+
+foreach my $file (qw(single.out 1.out 2.out blib/lib/PL/Bar.pm)) {
+ ok( -e $file, "$file was created" );
+}
Copied: trunk/contrib/perl/lib/ExtUtils/t/Packlist.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/Packlist.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/Packlist.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/Packlist.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,174 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+chdir 't';
+
+use Test::More tests => 34;
+
+use_ok( 'ExtUtils::Packlist' );
+
+is( ref(ExtUtils::Packlist::mkfh()), 'GLOB', 'mkfh() should return a FH' );
+
+# new calls tie()
+my $pl = ExtUtils::Packlist->new();
+isa_ok( $pl, 'ExtUtils::Packlist' );
+is( ref tied %$pl, 'ExtUtils::Packlist', 'obj should be tied underneath' );
+
+
+$pl = ExtUtils::Packlist::TIEHASH( 'tieclass', 'packfile' );
+is( ref($pl), 'tieclass', 'TIEHASH() should bless into class' );
+is( $pl->{packfile}, 'packfile', 'TIEHASH() should store packfile name' );
+
+
+ExtUtils::Packlist::STORE($pl, 'key', 'value');
+is( $pl->{data}{key}, 'value', 'STORE() should stuff stuff in data member' );
+
+
+$pl->{data}{foo} = 'bar';
+is( ExtUtils::Packlist::FETCH($pl, 'foo'), 'bar', 'check FETCH()' );
+
+
+# test FIRSTKEY and NEXTKEY
+SKIP: {
+ $pl->{data}{bar} = 'baz';
+ skip('not enough keys to test FIRSTKEY', 2)
+ unless keys %{ $pl->{data} } > 2;
+
+ # get the first and second key
+ my ($first, $second) = keys %{ $pl->{data} };
+
+ # now get a couple of extra keys, to mess with the hash iterator
+ my $i = 0;
+ for (keys %{ $pl->{data} } ) {
+ last if $i++;
+ }
+
+ # finally, see if it really can get the first key again
+ is( ExtUtils::Packlist::FIRSTKEY($pl), $first,
+ 'FIRSTKEY() should be consistent' );
+
+ is( ExtUtils::Packlist::NEXTKEY($pl), $second,
+ 'and NEXTKEY() should also be consistent' );
+}
+
+
+ok( ExtUtils::Packlist::EXISTS($pl, 'bar'), 'EXISTS() should find keys' );
+
+
+ExtUtils::Packlist::DELETE($pl, 'bar');
+ok( !(exists $pl->{data}{bar}), 'DELETE() should delete cleanly' );
+
+
+ExtUtils::Packlist::CLEAR($pl);
+is( keys %{ $pl->{data} }, 0, 'CLEAR() should wipe out data' );
+
+
+# DESTROY does nothing...
+can_ok( 'ExtUtils::Packlist', 'DESTROY' );
+
+
+# write is a little more complicated
+eval { ExtUtils::Packlist::write({}) };
+like( $@, qr/No packlist filename/, 'write() should croak without packfile' );
+
+eval { ExtUtils::Packlist::write({}, 'eplist') };
+my $file_is_ready = $@ ? 0 : 1;
+ok( $file_is_ready, 'write() can write a file' );
+
+local *IN;
+
+SKIP: {
+ skip('cannot write files, some tests difficult', 3) unless $file_is_ready;
+
+ # set this file to read-only
+ chmod 0444, 'eplist';
+
+ SKIP: {
+ skip("cannot write readonly files", 1) if -w 'eplist';
+
+ eval { ExtUtils::Packlist::write({}, 'eplist') };
+ like( $@, qr/Can't open file/, 'write() should croak on open failure' );
+ }
+
+ #'now set it back (tick here fixes vim syntax highlighting ;)
+ chmod 0777, 'eplist';
+
+ # and some test data to be read
+ $pl->{data} = {
+ single => 1,
+ hash => {
+ foo => 'bar',
+ baz => 'bup',
+ },
+ '/./abc' => '',
+ };
+ eval { ExtUtils::Packlist::write($pl, 'eplist') };
+ is( $@, '', 'write() should normally succeed' );
+ is( $pl->{packfile}, 'eplist', 'write() should set packfile name' );
+
+ $file_is_ready = open(IN, 'eplist');
+}
+
+
+eval { ExtUtils::Packlist::read({}) };
+like( $@, qr/^No packlist filename/, 'read() should croak without packfile' );
+
+
+eval { ExtUtils::Packlist::read({}, 'abadfilename') };
+like( $@, qr/^Can't open file/, 'read() should croak with bad packfile name' );
+#'open packfile for reading
+
+
+# and more read() tests
+SKIP: {
+ skip("cannot open file for reading: $!", 5) unless $file_is_ready;
+ my $file = do { local $/ = <IN> };
+
+ like( $file, qr/single\n/, 'key with value should be available' );
+ like( $file, qr!/\./abc\n!, 'key with no value should also be present' );
+ like( $file, qr/hash.+baz=bup/, 'key with hash value should be present' );
+ like( $file, qr/hash.+foo=bar/, 'second embedded hash value should appear');
+ close IN;
+
+ eval{ ExtUtils::Packlist::read($pl, 'eplist') };
+ is( $@, '', 'read() should normally succeed' );
+ is( $pl->{data}{single}, undef, 'single keys should have undef value' );
+ is( ref($pl->{data}{hash}), 'HASH', 'multivalue keys should become hashes');
+
+ is( $pl->{data}{hash}{foo}, 'bar', 'hash values should be set' );
+ ok( exists $pl->{data}{'/abc'}, 'read() should resolve /./ to / in keys' );
+
+ # give validate a valid and an invalid file to find
+ $pl->{data} = {
+ eplist => 1,
+ fake => undef,
+ };
+
+ is( ExtUtils::Packlist::validate($pl), 1,
+ 'validate() should find missing files' );
+ ExtUtils::Packlist::validate($pl, 1);
+ ok( !exists $pl->{data}{fake},
+ 'validate() should remove missing files when prompted' );
+
+ # one more new() test, to see if it calls read() successfully
+ $pl = ExtUtils::Packlist->new('eplist');
+}
+
+
+# packlist_file, $pl should be set from write test
+is( ExtUtils::Packlist::packlist_file({ packfile => 'pl' }), 'pl',
+ 'packlist_file() should fetch packlist from passed hash' );
+is( ExtUtils::Packlist::packlist_file($pl), 'eplist',
+ 'packlist_file() should fetch packlist from ExtUtils::Packlist object' );
+
+END {
+ 1 while unlink qw( eplist );
+}
Copied: trunk/contrib/perl/lib/ExtUtils/t/VERSION_FROM.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/VERSION_FROM.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/VERSION_FROM.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/VERSION_FROM.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,39 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+chdir 't';
+
+use strict;
+use Test::More tests => 1;
+use MakeMaker::Test::Utils;
+use ExtUtils::MakeMaker;
+use TieOut;
+use File::Path;
+
+perl_lib();
+
+mkdir('Odd-Version', 0777);
+END { chdir File::Spec->updir; rmtree 'Odd-Version' }
+chdir 'Odd-Version';
+
+open(MPL, ">Version") || die $!;
+print MPL "\$VERSION = 0\n";
+close MPL;
+END { unlink 'Version' }
+
+my $stdout = tie *STDOUT, 'TieOut' or die;
+my $mm = WriteMakefile(
+ NAME => 'Version',
+ VERSION_FROM => 'Version'
+);
+
+is( $mm->{VERSION}, 0, 'VERSION_FROM when $VERSION = 0' );
Copied: trunk/contrib/perl/lib/ExtUtils/t/WriteEmptyMakefile.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/WriteEmptyMakefile.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/WriteEmptyMakefile.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/WriteEmptyMakefile.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,40 @@
+#!/usr/bin/perl -w
+
+# This is a test of WriteEmptyMakefile.
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+chdir 't';
+
+use strict;
+use Test::More tests => 5;
+
+use ExtUtils::MakeMaker qw(WriteEmptyMakefile);
+use TieOut;
+
+can_ok __PACKAGE__, 'WriteEmptyMakefile';
+
+eval { WriteEmptyMakefile("something"); };
+like $@, qr/Need an even number of args/;
+
+
+{
+ ok( my $stdout = tie *STDOUT, 'TieOut' );
+
+ ok !-e 'wibble';
+ END { 1 while unlink 'wibble' }
+
+ WriteEmptyMakefile(
+ NAME => "Foo",
+ FIRST_MAKEFILE => "wibble",
+ );
+ ok -e 'wibble';
+}
Copied: trunk/contrib/perl/lib/ExtUtils/t/arch_check.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/arch_check.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/arch_check.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/arch_check.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,89 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = qw(../lib lib);
+ }
+}
+
+use strict;
+use lib 't/lib';
+
+use TieOut;
+use Test::More 'no_plan';
+
+use Config;
+use ExtUtils::MakeMaker;
+
+ok( my $stdout = tie *STDOUT, 'TieOut' );
+
+# Create a normalized MM object to test with
+my $mm = bless {}, "MM";
+$mm->{PERL_SRC} = 0;
+$mm->{UNINSTALLED_PERL} = 0;
+
+my $rel2abs = sub { $mm->rel2abs($mm->catfile(@_)) };
+
+ok $mm->arch_check(
+ $rel2abs->(qw(. t testdata reallylongdirectoryname arch1 Config.pm)),
+ $rel2abs->(qw(. t testdata reallylongdirectoryname arch1 Config.pm)),
+);
+
+
+# Different architecures.
+{
+ ok !$mm->arch_check(
+ $rel2abs->(qw(. t testdata reallylongdirectoryname arch1 Config.pm)),
+ $rel2abs->(qw(. t testdata reallylongdirectoryname arch2 Config.pm)),
+ );
+
+ like $stdout->read, qr{\Q
+Your perl and your Config.pm seem to have different ideas about the
+architecture they are running on.
+Perl thinks: [arch1]
+Config says: [$Config{archname}]
+This may or may not cause problems. Please check your installation of perl
+if you have problems building this extension.
+};
+
+}
+
+
+# Different file path separators [rt.cpan.org 46416]
+SKIP: {
+ require File::Spec;
+ skip "Win32 test", 1 unless File::Spec->isa("File::Spec::Win32");
+
+ ok $mm->arch_check(
+ "/_64/perl1004/lib/Config.pm",
+ '\\_64\\perl1004\\lib\\Config.pm',
+ );
+}
+
+
+# PERL_SRC is set, no check is done
+{
+ # Clear our log
+ $stdout->read;
+
+ local $mm->{PERL_SRC} = 1;
+ ok $mm->arch_check(
+ $rel2abs->(qw(. t testdata reallylongdirectoryname arch1 Config.pm)),
+ $rel2abs->(qw(. t testdata reallylongdirectoryname arch2 Config.pm)),
+ );
+
+ is $stdout->read, '';
+}
+
+
+# UNINSTALLED_PERL is set, no message is sent
+{
+ local $mm->{UNINSTALLED_PERL} = 1;
+ ok !$mm->arch_check(
+ $rel2abs->(qw(. t testdata reallylongdirectoryname arch1 Config.pm)),
+ $rel2abs->(qw(. t testdata reallylongdirectoryname arch2 Config.pm)),
+ );
+
+ like $stdout->read, qr{^Have .*\nWant .*$};
+}
Copied: trunk/contrib/perl/lib/ExtUtils/t/backwards.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/backwards.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/backwards.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/backwards.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,25 @@
+#!/usr/bin/perl -w
+
+# This is a test for all the odd little backwards compatible things
+# MakeMaker has to support. And we do mean backwards.
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use strict;
+use Test::More tests => 2;
+
+require ExtUtils::MakeMaker;
+
+# CPAN.pm wants MM.
+can_ok('MM', 'new');
+
+# Pre 5.8 ExtUtils::Embed wants MY.
+can_ok('MY', 'catdir');
Copied: trunk/contrib/perl/lib/ExtUtils/t/basic.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/basic.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/basic.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/basic.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,325 @@
+#!/usr/bin/perl -w
+
+# This test puts MakeMaker through the paces of a basic perl module
+# build, test and installation of the Big::Fat::Dummy module.
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use strict;
+use Config;
+use ExtUtils::MakeMaker;
+
+use Test::More tests => 79;
+use MakeMaker::Test::Utils;
+use MakeMaker::Test::Setup::BFD;
+use File::Find;
+use File::Spec;
+use File::Path;
+
+my $perl = which_perl();
+my $Is_VMS = $^O eq 'VMS';
+
+chdir 't';
+
+perl_lib;
+
+my $Touch_Time = calibrate_mtime();
+
+$| = 1;
+
+ok( setup_recurs(), 'setup' );
+END {
+ ok( chdir File::Spec->updir );
+ ok( teardown_recurs(), 'teardown' );
+}
+
+ok( chdir('Big-Dummy'), "chdir'd to Big-Dummy" ) ||
+ diag("chdir failed: $!");
+
+my @mpl_out = run(qq{$perl Makefile.PL "PREFIX=../dummy-install"});
+END { rmtree '../dummy-install'; }
+
+cmp_ok( $?, '==', 0, 'Makefile.PL exited with zero' ) ||
+ diag(@mpl_out);
+
+my $makefile = makefile_name();
+ok( grep(/^Writing $makefile for Big::Dummy/,
+ @mpl_out) == 1,
+ 'Makefile.PL output looks right');
+
+ok( grep(/^Current package is: main$/,
+ @mpl_out) == 1,
+ 'Makefile.PL run in package main');
+
+ok( -e $makefile, 'Makefile exists' );
+
+# -M is flakey on VMS
+my $mtime = (stat($makefile))[9];
+cmp_ok( $Touch_Time, '<=', $mtime, ' its been touched' );
+
+END { unlink makefile_name(), makefile_backup() }
+
+my $make = make_run();
+
+{
+ # Supress 'make manifest' noise
+ local $ENV{PERL_MM_MANIFEST_VERBOSE} = 0;
+ my $manifest_out = run("$make manifest");
+ ok( -e 'MANIFEST', 'make manifest created a MANIFEST' );
+ ok( -s 'MANIFEST', ' its not empty' );
+}
+
+END { unlink 'MANIFEST'; }
+
+
+my $ppd_out = run("$make ppd");
+is( $?, 0, ' exited normally' ) || diag $ppd_out;
+ok( open(PPD, 'Big-Dummy.ppd'), ' .ppd file generated' );
+my $ppd_html;
+{ local $/; $ppd_html = <PPD> }
+close PPD;
+like( $ppd_html, qr{^<SOFTPKG NAME="Big-Dummy" VERSION="0.01">}m,
+ ' <SOFTPKG>' );
+like( $ppd_html, qr{^\s*<ABSTRACT>Try "our" hot dog's</ABSTRACT>}m,
+ ' <ABSTRACT>');
+like( $ppd_html,
+ qr{^\s*<AUTHOR>Michael G Schwern <schwern\@pobox.com></AUTHOR>}m,
+ ' <AUTHOR>' );
+like( $ppd_html, qr{^\s*<IMPLEMENTATION>}m, ' <IMPLEMENTATION>');
+like( $ppd_html, qr{^\s*<REQUIRE NAME="strict::" />}m, ' <REQUIRE>' );
+
+my $archname = $Config{archname};
+if( $] >= 5.008 ) {
+ # XXX This is a copy of the internal logic, so it's not a great test
+ $archname .= "-$Config{PERL_REVISION}.$Config{PERL_VERSION}";
+}
+like( $ppd_html, qr{^\s*<ARCHITECTURE NAME="$archname" />}m,
+ ' <ARCHITECTURE>');
+like( $ppd_html, qr{^\s*<CODEBASE HREF="" />}m, ' <CODEBASE>');
+like( $ppd_html, qr{^\s*</IMPLEMENTATION>}m, ' </IMPLEMENTATION>');
+like( $ppd_html, qr{^\s*</SOFTPKG>}m, ' </SOFTPKG>');
+END { unlink 'Big-Dummy.ppd' }
+
+
+my $test_out = run("$make test");
+like( $test_out, qr/All tests successful/, 'make test' );
+is( $?, 0, ' exited normally' ) ||
+ diag $test_out;
+
+# Test 'make test TEST_VERBOSE=1'
+my $make_test_verbose = make_macro($make, 'test', TEST_VERBOSE => 1);
+$test_out = run("$make_test_verbose");
+like( $test_out, qr/ok \d+ - TEST_VERBOSE/, 'TEST_VERBOSE' );
+like( $test_out, qr/All tests successful/, ' successful' );
+is( $?, 0, ' exited normally' ) ||
+ diag $test_out;
+
+
+my $install_out = run("$make install");
+is( $?, 0, 'install' ) || diag $install_out;
+like( $install_out, qr/^Installing /m );
+
+ok( -r '../dummy-install', ' install dir created' );
+my %files = ();
+find( sub {
+ # do it case-insensitive for non-case preserving OSs
+ my $file = lc $_;
+
+ # VMS likes to put dots on the end of things that don't have them.
+ $file =~ s/\.$// if $Is_VMS;
+
+ $files{$file} = $File::Find::name;
+}, '../dummy-install' );
+ok( $files{'dummy.pm'}, ' Dummy.pm installed' );
+ok( $files{'liar.pm'}, ' Liar.pm installed' );
+ok( $files{'program'}, ' program installed' );
+ok( $files{'.packlist'}, ' packlist created' );
+ok( $files{'perllocal.pod'},' perllocal.pod created' );
+
+
+SKIP: {
+ skip 'VMS install targets do not preserve $(PREFIX)', 8 if $Is_VMS;
+
+ $install_out = run("$make install PREFIX=elsewhere");
+ is( $?, 0, 'install with PREFIX override' ) || diag $install_out;
+ like( $install_out, qr/^Installing /m );
+
+ ok( -r 'elsewhere', ' install dir created' );
+ %files = ();
+ find( sub { $files{$_} = $File::Find::name; }, 'elsewhere' );
+ ok( $files{'Dummy.pm'}, ' Dummy.pm installed' );
+ ok( $files{'Liar.pm'}, ' Liar.pm installed' );
+ ok( $files{'program'}, ' program installed' );
+ ok( $files{'.packlist'}, ' packlist created' );
+ ok( $files{'perllocal.pod'},' perllocal.pod created' );
+ rmtree('elsewhere');
+}
+
+
+SKIP: {
+ skip 'VMS install targets do not preserve $(DESTDIR)', 10 if $Is_VMS;
+
+ $install_out = run("$make install PREFIX= DESTDIR=other");
+ is( $?, 0, 'install with DESTDIR' ) ||
+ diag $install_out;
+ like( $install_out, qr/^Installing /m );
+
+ ok( -d 'other', ' destdir created' );
+ %files = ();
+ my $perllocal;
+ find( sub {
+ $files{$_} = $File::Find::name;
+ }, 'other' );
+ ok( $files{'Dummy.pm'}, ' Dummy.pm installed' );
+ ok( $files{'Liar.pm'}, ' Liar.pm installed' );
+ ok( $files{'program'}, ' program installed' );
+ ok( $files{'.packlist'}, ' packlist created' );
+ ok( $files{'perllocal.pod'},' perllocal.pod created' );
+
+ ok( open(PERLLOCAL, $files{'perllocal.pod'} ) ) ||
+ diag("Can't open $files{'perllocal.pod'}: $!");
+ { local $/;
+ unlike(<PERLLOCAL>, qr/other/, 'DESTDIR should not appear in perllocal');
+ }
+ close PERLLOCAL;
+
+# TODO not available in the min version of Test::Harness we require
+# ok( open(PACKLIST, $files{'.packlist'} ) ) ||
+# diag("Can't open $files{'.packlist'}: $!");
+# { local $/;
+# local $TODO = 'DESTDIR still in .packlist';
+# unlike(<PACKLIST>, qr/other/, 'DESTDIR should not appear in .packlist');
+# }
+# close PACKLIST;
+
+ rmtree('other');
+}
+
+
+SKIP: {
+ skip 'VMS install targets do not preserve $(PREFIX)', 9 if $Is_VMS;
+
+ $install_out = run("$make install PREFIX=elsewhere DESTDIR=other/");
+ is( $?, 0, 'install with PREFIX override and DESTDIR' ) ||
+ diag $install_out;
+ like( $install_out, qr/^Installing /m );
+
+ ok( !-d 'elsewhere', ' install dir not created' );
+ ok( -d 'other/elsewhere', ' destdir created' );
+ %files = ();
+ find( sub { $files{$_} = $File::Find::name; }, 'other/elsewhere' );
+ ok( $files{'Dummy.pm'}, ' Dummy.pm installed' );
+ ok( $files{'Liar.pm'}, ' Liar.pm installed' );
+ ok( $files{'program'}, ' program installed' );
+ ok( $files{'.packlist'}, ' packlist created' );
+ ok( $files{'perllocal.pod'},' perllocal.pod created' );
+ rmtree('other');
+}
+
+
+my $dist_test_out = run("$make disttest");
+is( $?, 0, 'disttest' ) || diag($dist_test_out);
+
+# Test META.yml generation
+use ExtUtils::Manifest qw(maniread);
+
+my $distdir = 'Big-Dummy-0.01';
+$distdir =~ s/\./_/g if $Is_VMS;
+my $meta_yml = "$distdir/META.yml";
+
+ok( !-f 'META.yml', 'META.yml not written to source dir' );
+ok( -f $meta_yml, 'META.yml written to dist dir' );
+ok( !-e "META_new.yml", 'temp META.yml file not left around' );
+
+SKIP: {
+ # META.yml spec 1.4 was added in 0.11
+ skip "Test::YAML::Meta >= 0.11 required", 2
+ unless eval { require Test::YAML::Meta } and
+ Test::YAML::Meta->VERSION >= 0.11;
+
+ Test::YAML::Meta::meta_spec_ok($meta_yml);
+}
+
+ok open META, $meta_yml or diag $!;
+my $meta = join '', <META>;
+ok close META;
+
+is $meta, <<"END";
+--- #YAML:1.0
+name: Big-Dummy
+version: 0.01
+abstract: Try "our" hot dog's
+author:
+ - Michael G Schwern <schwern\@pobox.com>
+license: unknown
+distribution_type: module
+configure_requires:
+ ExtUtils::MakeMaker: 0
+build_requires:
+ ExtUtils::MakeMaker: 0
+requires:
+ strict: 0
+no_index:
+ directory:
+ - t
+ - inc
+generated_by: ExtUtils::MakeMaker version $ExtUtils::MakeMaker::VERSION
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
+END
+
+my $manifest = maniread("$distdir/MANIFEST");
+# VMS is non-case preserving, so we can't know what the MANIFEST will
+# look like. :(
+_normalize($manifest);
+is( $manifest->{'meta.yml'}, 'Module meta-data (added by MakeMaker)' );
+
+
+# Test NO_META META.yml suppression
+unlink $meta_yml;
+ok( !-f $meta_yml, 'META.yml deleted' );
+ at mpl_out = run(qq{$perl Makefile.PL "NO_META=1"});
+cmp_ok( $?, '==', 0, 'Makefile.PL exited with zero' ) || diag(@mpl_out);
+my $distdir_out = run("$make distdir");
+is( $?, 0, 'distdir' ) || diag($distdir_out);
+ok( !-f $meta_yml, 'META.yml generation suppressed by NO_META' );
+
+
+# Make sure init_dirscan doesn't go into the distdir
+ at mpl_out = run(qq{$perl Makefile.PL "PREFIX=../dummy-install"});
+
+cmp_ok( $?, '==', 0, 'Makefile.PL exited with zero' ) || diag(@mpl_out);
+
+ok( grep(/^Writing $makefile for Big::Dummy/, @mpl_out) == 1,
+ 'init_dirscan skipped distdir') ||
+ diag(@mpl_out);
+
+# I know we'll get ignored errors from make here, that's ok.
+# Send STDERR off to oblivion.
+open(SAVERR, ">&STDERR") or die $!;
+open(STDERR, ">",File::Spec->devnull) or die $!;
+
+my $realclean_out = run("$make realclean");
+is( $?, 0, 'realclean' ) || diag($realclean_out);
+
+open(STDERR, ">&SAVERR") or die $!;
+close SAVERR;
+
+
+sub _normalize {
+ my $hash = shift;
+
+ while(my($k,$v) = each %$hash) {
+ delete $hash->{$k};
+ $hash->{lc $k} = $v;
+ }
+}
Copied: trunk/contrib/perl/lib/ExtUtils/t/build_man.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/build_man.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/build_man.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/build_man.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,86 @@
+#!/usr/bin/perl -w
+
+# Test if MakeMaker declines to build man pages under the right conditions.
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use strict;
+use Test::More tests => 9;
+
+use File::Spec;
+use TieOut;
+use MakeMaker::Test::Utils;
+use MakeMaker::Test::Setup::BFD;
+
+use ExtUtils::MakeMaker;
+use ExtUtils::MakeMaker::Config;
+
+# Simulate an installation which has man page generation turned off to
+# ensure these tests will still work.
+$Config{installman3dir} = 'none';
+
+chdir 't';
+
+perl_lib();
+
+ok( setup_recurs(), 'setup' );
+END {
+ ok( chdir File::Spec->updir );
+ ok( teardown_recurs(), 'teardown' );
+}
+
+ok( chdir 'Big-Dummy', "chdir'd to Big-Dummy" ) ||
+ diag("chdir failed: $!");
+
+ok( my $stdout = tie *STDOUT, 'TieOut' );
+
+{
+ local $Config{installman3dir} = File::Spec->catdir(qw(t lib));
+
+ my $mm = WriteMakefile(
+ NAME => 'Big::Dummy',
+ VERSION_FROM => 'lib/Big/Dummy.pm',
+ );
+
+ ok( keys %{ $mm->{MAN3PODS} } );
+}
+
+{
+ my $mm = WriteMakefile(
+ NAME => 'Big::Dummy',
+ VERSION_FROM => 'lib/Big/Dummy.pm',
+ INSTALLMAN3DIR => 'none'
+ );
+
+ is_deeply( $mm->{MAN3PODS}, {} );
+}
+
+
+{
+ my $mm = WriteMakefile(
+ NAME => 'Big::Dummy',
+ VERSION_FROM => 'lib/Big/Dummy.pm',
+ MAN3PODS => {}
+ );
+
+ is_deeply( $mm->{MAN3PODS}, { } );
+}
+
+
+{
+ my $mm = WriteMakefile(
+ NAME => 'Big::Dummy',
+ VERSION_FROM => 'lib/Big/Dummy.pm',
+ MAN3PODS => { "Foo.pm" => "Foo.1" }
+ );
+
+ is_deeply( $mm->{MAN3PODS}, { "Foo.pm" => "Foo.1" } );
+}
Copied: trunk/contrib/perl/lib/ExtUtils/t/bytes.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/bytes.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/bytes.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/bytes.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,30 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use strict;
+use Test::More tests => 4;
+
+use_ok('ExtUtils::MakeMaker::bytes');
+
+SKIP: {
+ skip "bytes.pm appeared in 5.6", 3 if $] < 5.006;
+
+ my $chr = chr(400);
+ is( length $chr, 1 );
+
+ {
+ use ExtUtils::MakeMaker::bytes;
+ is( length $chr, 2, 'byte.pm in effect' );
+ }
+
+ is( length $chr, 1, ' score is lexical' );
+}
Copied: trunk/contrib/perl/lib/ExtUtils/t/can_write_dir.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/can_write_dir.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/can_write_dir.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/can_write_dir.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,61 @@
+#!/usr/bin/perl -w
+
+# Test the private _can_write_dir() function.
+
+use strict;
+use ExtUtils::Install;
+use File::Spec;
+{ package FS; our @ISA = qw(File::Spec); }
+
+# Alias it for easier access
+*can_write_dir = \&ExtUtils::Install::_can_write_dir;
+
+use Test::More 'no_plan';
+
+
+my $dne = FS->catdir(qw(does not exist));
+ok ! -e $dne;
+is_deeply [can_write_dir($dne)],
+ [1,
+ FS->curdir,
+ FS->catdir('does'),
+ FS->catdir('does', 'not'),
+ FS->catdir('does', 'not', 'exist')
+ ];
+
+
+my $abs_dne = FS->rel2abs($dne);
+ok ! -e $abs_dne;
+is_deeply [can_write_dir($abs_dne)],
+ [1,
+ FS->rel2abs(FS->curdir),
+ FS->rel2abs(FS->catdir('does')),
+ FS->rel2abs(FS->catdir('does', 'not')),
+ FS->rel2abs(FS->catdir('does', 'not', 'exist')),
+ ];
+
+SKIP: {
+ my $exists = FS->catdir(qw(exists));
+ my $subdir = FS->catdir(qw(exists subdir));
+
+
+ ok mkdir $exists;
+ END { rmdir $exists }
+
+ ok chmod 0555, $exists, 'make read only';
+
+ skip "Current user or OS cannot create directories that they cannot read", 6
+ if -w $exists; # these tests require a directory we cant read
+
+ is_deeply [can_write_dir($exists)], [0, $exists];
+ is_deeply [can_write_dir($subdir)], [0, $exists, $subdir];
+
+ ok chmod 0777, $exists, 'make writable';
+ ok -w $exists;
+ is_deeply [can_write_dir($exists)], [1, $exists];
+ is_deeply [can_write_dir($subdir)],
+ [1,
+ $exists,
+ $subdir
+ ];
+}
\ No newline at end of file
Copied: trunk/contrib/perl/lib/ExtUtils/t/cd.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/cd.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/cd.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/cd.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,68 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ('../lib', 'lib/');
+ }
+ else {
+ unshift @INC, 't/lib/';
+ }
+}
+chdir 't';
+
+my $Is_VMS = $^O eq 'VMS';
+
+use File::Spec;
+
+use Test::More tests => 4;
+
+my $dir = File::Spec->catdir("some", "dir");
+my @cd_args = ($dir, "command1", "command2");
+
+{
+ package Test::MM_Win32;
+ use ExtUtils::MM_Win32;
+ @ISA = qw(ExtUtils::MM_Win32);
+
+ my $mm = bless {}, 'Test::MM_Win32';
+
+ {
+ local *make = sub { "nmake" };
+
+ my @dirs = (File::Spec->updir) x 2;
+ my $expected_updir = File::Spec->catdir(@dirs);
+
+ ::is $mm->cd(@cd_args),
+qq{cd $dir
+ command1
+ command2
+ cd $expected_updir};
+ }
+
+ {
+ local *make = sub { "dmake" };
+
+ ::is $mm->cd(@cd_args),
+qq{cd $dir && command1
+ cd $dir && command2};
+ }
+}
+
+{
+ is +ExtUtils::MM_Unix->cd(@cd_args),
+qq{cd $dir && command1
+ cd $dir && command2};
+}
+
+SKIP: {
+ skip("VMS' cd requires vmspath which is only on VMS", 1) unless $Is_VMS;
+
+ use ExtUtils::MM_VMS;
+ is +ExtUtils::MM_VMS->cd(@cd_args),
+q{startdir = F$Environment("Default")
+ Set Default [.some.dir]
+ command1
+ command2
+ Set Default 'startdir'};
+}
Copied: trunk/contrib/perl/lib/ExtUtils/t/config.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/config.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/config.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/config.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,23 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ('../lib', 'lib/');
+ }
+ else {
+ unshift @INC, 't/lib/';
+ }
+}
+
+use Test::More tests => 3;
+use Config ();
+
+BEGIN { use_ok 'ExtUtils::MakeMaker::Config'; }
+
+is $Config{path_sep}, $Config::Config{path_sep};
+
+eval {
+ $Config{wibble} = 42;
+};
+is $Config{wibble}, 42;
Copied: trunk/contrib/perl/lib/ExtUtils/t/cp.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/cp.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/cp.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/cp.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,33 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ('../lib', 'lib/');
+ }
+ else {
+ unshift @INC, 't/lib/';
+ }
+}
+chdir 't';
+
+use ExtUtils::Command;
+use Test::More tests => 1;
+
+open FILE, ">source" or die $!;
+print FILE "stuff\n";
+close FILE;
+
+# Instead of sleeping to make the file time older
+utime time - 900, time - 900, "source";
+
+END { 1 while unlink "source", "dest"; }
+
+# Win32 bug, cp wouldn't update mtime.
+{
+ local @ARGV = qw(source dest);
+ cp();
+ my $mtime = (stat("dest"))[9];
+ my $now = time;
+ cmp_ok( abs($mtime - $now), '<=', 1, 'cp updated mtime' );
+}
Copied: trunk/contrib/perl/lib/ExtUtils/t/dir_target.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/dir_target.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/dir_target.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/dir_target.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,18 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ('../lib', 'lib/');
+ }
+ else {
+ unshift @INC, 't/lib/';
+ }
+}
+chdir 't';
+
+use Test::More tests => 1;
+use ExtUtils::MakeMaker;
+
+# dir_target() was typo'd as dir_targets()
+can_ok('MM', 'dir_target');
Copied: trunk/contrib/perl/lib/ExtUtils/t/eu_command.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/eu_command.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/eu_command.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/eu_command.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,290 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ('../lib', 'lib/');
+ }
+ else {
+ unshift @INC, 't/lib/';
+ }
+}
+chdir 't';
+
+BEGIN {
+ $Testfile = 'testfile.foo';
+}
+
+BEGIN {
+ 1 while unlink $Testfile, 'newfile';
+ # forcibly remove ecmddir/temp2, but don't import mkpath
+ use File::Path ();
+ File::Path::rmtree( 'ecmddir' );
+}
+
+use Test::More tests => 40;
+use File::Spec;
+
+BEGIN {
+ # bad neighbor, but test_f() uses exit()
+ *CORE::GLOBAL::exit = ''; # quiet 'only once' warning.
+ *CORE::GLOBAL::exit = sub (;$) { return $_[0] };
+ use_ok( 'ExtUtils::Command' );
+}
+
+{
+ # concatenate this file with itself
+ # be extra careful the regex doesn't match itself
+ use TieOut;
+ my $out = tie *STDOUT, 'TieOut';
+ my $self = $0;
+ unless (-f $self) {
+ my ($vol, $dirs, $file) = File::Spec->splitpath($self);
+ my @dirs = File::Spec->splitdir($dirs);
+ unshift(@dirs, File::Spec->updir);
+ $dirs = File::Spec->catdir(@dirs);
+ $self = File::Spec->catpath($vol, $dirs, $file);
+ }
+ @ARGV = ($self, $self);
+
+ cat();
+ is( scalar( $$out =~ s/use_ok\( 'ExtUtils::Command'//g), 2,
+ 'concatenation worked' );
+
+ # the truth value here is reversed -- Perl true is shell false
+ @ARGV = ( $Testfile );
+ is( test_f(), 1, 'testing non-existent file' );
+
+ # these are destructive, have to keep setting @ARGV
+ @ARGV = ( $Testfile );
+ touch();
+
+ @ARGV = ( $Testfile );
+ is( test_f(), 0, 'testing touch() and test_f()' );
+ is_deeply( \@ARGV, [$Testfile], 'test_f preserves @ARGV' );
+
+ @ARGV = ( $Testfile );
+ ok( -e $ARGV[0], 'created!' );
+
+ my ($now) = time;
+ utime ($now, $now, $ARGV[0]);
+ sleep 2;
+
+ # Just checking modify time stamp, access time stamp is set
+ # to the beginning of the day in Win95.
+ # There's a small chance of a 1 second flutter here.
+ my $stamp = (stat($ARGV[0]))[9];
+ cmp_ok( abs($now - $stamp), '<=', 1, 'checking modify time stamp' ) ||
+ diag "mtime == $stamp, should be $now";
+
+ @ARGV = qw(newfile);
+ touch();
+
+ my $new_stamp = (stat('newfile'))[9];
+ cmp_ok( abs($new_stamp - $stamp), '>=', 2, 'newer file created' );
+
+ @ARGV = ('newfile', $Testfile);
+ eqtime();
+
+ $stamp = (stat($Testfile))[9];
+ cmp_ok( abs($new_stamp - $stamp), '<=', 1, 'eqtime' );
+
+ # eqtime use to clear the contents of the file being equalized!
+ open(FILE, ">>$Testfile") || die $!;
+ print FILE "Foo";
+ close FILE;
+
+ @ARGV = ('newfile', $Testfile);
+ eqtime();
+ ok( -s $Testfile, "eqtime doesn't clear the file being equalized" );
+
+ SKIP: {
+ if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' ||
+ $^O eq 'NetWare' || $^O eq 'dos' || $^O eq 'cygwin' ||
+ $^O eq 'MacOS'
+ ) {
+ skip( "different file permission semantics on $^O", 3);
+ }
+
+ # change a file to execute-only
+ @ARGV = ( '0100', $Testfile );
+ ExtUtils::Command::chmod();
+
+ is( ((stat($Testfile))[2] & 07777) & 0700,
+ 0100, 'change a file to execute-only' );
+
+ # change a file to read-only
+ @ARGV = ( '0400', $Testfile );
+ ExtUtils::Command::chmod();
+
+ is( ((stat($Testfile))[2] & 07777) & 0700,
+ ($^O eq 'vos' ? 0500 : 0400), 'change a file to read-only' );
+
+ # change a file to write-only
+ @ARGV = ( '0200', $Testfile );
+ ExtUtils::Command::chmod();
+
+ is( ((stat($Testfile))[2] & 07777) & 0700,
+ ($^O eq 'vos' ? 0700 : 0200), 'change a file to write-only' );
+ }
+
+ # change a file to read-write
+ @ARGV = ( '0600', $Testfile );
+ my @orig_argv = @ARGV;
+ ExtUtils::Command::chmod();
+ is_deeply( \@ARGV, \@orig_argv, 'chmod preserves @ARGV' );
+
+ is( ((stat($Testfile))[2] & 07777) & 0700,
+ ($^O eq 'vos' ? 0700 : 0600), 'change a file to read-write' );
+
+
+ SKIP: {
+ if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' ||
+ $^O eq 'NetWare' || $^O eq 'dos' || $^O eq 'cygwin' ||
+ $^O eq 'MacOS'
+ ) {
+ skip( "different file permission semantics on $^O", 5);
+ }
+
+ @ARGV = ('testdir');
+ mkpath;
+ ok( -e 'testdir' );
+
+ # change a dir to execute-only
+ @ARGV = ( '0100', 'testdir' );
+ ExtUtils::Command::chmod();
+
+ is( ((stat('testdir'))[2] & 07777) & 0700,
+ 0100, 'change a dir to execute-only' );
+
+ # change a dir to read-only
+ @ARGV = ( '0400', 'testdir' );
+ ExtUtils::Command::chmod();
+
+ is( ((stat('testdir'))[2] & 07777) & 0700,
+ ($^O eq 'vos' ? 0500 : 0400), 'change a dir to read-only' );
+
+ # change a dir to write-only
+ @ARGV = ( '0200', 'testdir' );
+ ExtUtils::Command::chmod();
+
+ is( ((stat('testdir'))[2] & 07777) & 0700,
+ ($^O eq 'vos' ? 0700 : 0200), 'change a dir to write-only' );
+
+ @ARGV = ('testdir');
+ rm_rf;
+ ok( ! -e 'testdir', 'rm_rf can delete a read-only dir' );
+ }
+
+
+ # mkpath
+ my $test_dir = File::Spec->join( 'ecmddir', 'temp2' );
+ @ARGV = ( $test_dir );
+ ok( ! -e $ARGV[0], 'temp directory not there yet' );
+ is( test_d(), 1, 'testing non-existent directory' );
+
+ @ARGV = ( $test_dir );
+ mkpath();
+ ok( -e $ARGV[0], 'temp directory created' );
+ is( test_d(), 0, 'testing existing dir' );
+
+ @ARGV = ( $test_dir );
+ # copy a file to a nested subdirectory
+ unshift @ARGV, $Testfile;
+ @orig_argv = @ARGV;
+ cp();
+ is_deeply( \@ARGV, \@orig_argv, 'cp preserves @ARGV' );
+
+ ok( -e File::Spec->join( 'ecmddir', 'temp2', $Testfile ), 'copied okay' );
+
+ # cp should croak if destination isn't directory (not a great warning)
+ @ARGV = ( $Testfile ) x 3;
+ eval { cp() };
+
+ like( $@, qr/Too many arguments/, 'cp croaks on error' );
+
+ # move a file to a subdirectory
+ @ARGV = ( $Testfile, 'ecmddir' );
+ @orig_argv = @ARGV;
+ ok( mv() );
+ is_deeply( \@ARGV, \@orig_argv, 'mv preserves @ARGV' );
+
+ ok( ! -e $Testfile, 'moved file away' );
+ ok( -e File::Spec->join( 'ecmddir', $Testfile ), 'file in new location' );
+
+ # mv should also croak with the same wacky warning
+ @ARGV = ( $Testfile ) x 3;
+
+ eval { mv() };
+ like( $@, qr/Too many arguments/, 'mv croaks on error' );
+
+ # Test expand_wildcards()
+ {
+ my $file = $Testfile;
+ @ARGV = ();
+ chdir 'ecmddir';
+
+ # % means 'match one character' on VMS. Everything else is ?
+ my $match_char = $^O eq 'VMS' ? '%' : '?';
+ ($ARGV[0] = $file) =~ s/.\z/$match_char/;
+
+ # this should find the file
+ ExtUtils::Command::expand_wildcards();
+
+ is_deeply( \@ARGV, [$file], 'expanded wildcard ? successfully' );
+
+ # try it with the asterisk now
+ ($ARGV[0] = $file) =~ s/.{3}\z/\*/;
+ ExtUtils::Command::expand_wildcards();
+
+ is_deeply( \@ARGV, [$file], 'expanded wildcard * successfully' );
+
+ chdir File::Spec->updir;
+ }
+
+ # remove some files
+ my @files = @ARGV = ( File::Spec->catfile( 'ecmddir', $Testfile ),
+ File::Spec->catfile( 'ecmddir', 'temp2', $Testfile ) );
+ rm_f();
+
+ ok( ! -e $_, "removed $_ successfully" ) for (@ARGV);
+
+ # rm_f dir
+ @ARGV = my $dir = File::Spec->catfile( 'ecmddir' );
+ rm_rf();
+ ok( ! -e $dir, "removed $dir successfully" );
+}
+
+{
+ { local @ARGV = 'd2utest'; mkpath; }
+ open(FILE, '>d2utest/foo');
+ binmode(FILE);
+ print FILE "stuff\015\012and thing\015\012";
+ close FILE;
+
+ open(FILE, '>d2utest/bar');
+ binmode(FILE);
+ my $bin = "\c@\c@\c@\c@\c@\c@\cA\c@\c@\c@\015\012".
+ "\@\c@\cA\c@\c@\c at 8__LIN\015\012";
+ print FILE $bin;
+ close FILE;
+
+ local @ARGV = 'd2utest';
+ ExtUtils::Command::dos2unix();
+
+ open(FILE, 'd2utest/foo');
+ is( join('', <FILE>), "stuff\012and thing\012", 'dos2unix' );
+ close FILE;
+
+ open(FILE, 'd2utest/bar');
+ binmode(FILE);
+ ok( -B 'd2utest/bar' );
+ is( join('', <FILE>), $bin, 'dos2unix preserves binaries');
+ close FILE;
+}
+
+END {
+ 1 while unlink $Testfile, 'newfile';
+ File::Path::rmtree( 'ecmddir' );
+ File::Path::rmtree( 'd2utest' );
+}
Copied: trunk/contrib/perl/lib/ExtUtils/t/fix_libs.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/fix_libs.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/fix_libs.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/fix_libs.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,36 @@
+#!/usr/bin/perl -w
+
+# Unit test the code which fixes up $self->{LIBS}
+
+BEGIN {
+ chdir 't' if -d 't';
+
+ if( $ENV{PERL_CORE} ) {
+ @INC = '../lib';
+ }
+}
+
+use strict;
+use lib './lib';
+use Test::More 'no_plan';
+
+use ExtUtils::MakeMaker;
+
+my @tests = (
+ # arg # want
+ [ undef, [''] ],
+ [ "foo", ['foo'] ],
+ [ [], [''] ],
+ [ ["foo"], ['foo'] ],
+ [ [1, 2, 3], [1, 2, 3] ],
+ [ [0], [0] ],
+ [ [''], [''] ],
+ [ " ", [' '] ],
+);
+
+for my $test (@tests) {
+ my($arg, $want) = @$test;
+
+ my $display = defined $arg ? $arg : "undef";
+ is_deeply( MM->_fix_libs($arg), $want, "fix_libs($display)" );
+}
Copied: trunk/contrib/perl/lib/ExtUtils/t/fixin.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/fixin.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/fixin.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/fixin.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,123 @@
+#!/usr/bin/perl -w
+
+# Try to test fixin. I say "try" because what fixin will actually do
+# is highly variable from system to system.
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ('../lib', 'lib/');
+ }
+ else {
+ unshift @INC, 't/lib/';
+ }
+}
+chdir 't';
+
+use File::Spec;
+
+use Test::More tests => 22;
+
+use Config;
+use TieOut;
+use MakeMaker::Test::Utils;
+use MakeMaker::Test::Setup::BFD;
+
+use ExtUtils::MakeMaker;
+
+chdir 't';
+
+perl_lib();
+
+ok( setup_recurs(), 'setup' );
+END {
+ ok( chdir File::Spec->updir );
+ ok( teardown_recurs(), 'teardown' );
+}
+
+ok( chdir 'Big-Dummy', "chdir'd to Big-Dummy" ) ||
+ diag("chdir failed: $!");
+
+# [rt.cpan.org 26234]
+{
+ local $/ = "foo";
+ local $\ = "bar";
+ MY->fixin("bin/program");
+ is $/, "foo", '$/ not clobbered';
+ is $\, "bar", '$\ not clobbered';
+}
+
+
+sub test_fixin {
+ my($code, $test) = @_;
+
+ my $file = "fixin_test";
+ ok(open(my $fh, ">", $file), "write $file") or diag "Can't write $file: $!";
+ print $fh $code;
+ close $fh;
+
+ MY->fixin($file);
+
+ ok(open($fh, "<", $file), "read $file") or diag "Can't read $file: $!";
+ my @lines = <$fh>;
+ close $fh;
+
+ $test->(@lines);
+
+ 1 while unlink $file;
+ ok !-e $file, "cleaned up $file";
+}
+
+
+# A simple test of fixin
+test_fixin(<<END,
+#!/foo/bar/perl -w
+
+blah blah blah
+END
+ sub {
+ my @lines = @_;
+ unlike $lines[0], qr[/foo/bar/perl], "#! replaced";
+ like $lines[0], qr[ -w\b], "switch retained";
+
+ # In between might be that "not running under some shell" madness.
+
+ is $lines[-1], "blah blah blah\n", "Program text retained";
+ }
+);
+
+
+# [rt.cpan.org 29442]
+test_fixin(<<END,
+#!/foo/bar/perl5.8.8 -w
+
+blah blah blah
+END
+
+ sub {
+ my @lines = @_;
+ unlike $lines[0], qr[/foo/bar/perl5.8.8], "#! replaced";
+ like $lines[0], qr[ -w\b], "switch retained";
+
+ # In between might be that "not running under some shell" madness.
+
+ is $lines[-1], "blah blah blah\n", "Program text retained";
+ }
+);
+
+
+# fixin shouldn't pick this up.
+test_fixin(<<END,
+#!/foo/bar/perly -w
+
+blah blah blah
+END
+
+ sub {
+ is join("", @_), <<END;
+#!/foo/bar/perly -w
+
+blah blah blah
+END
+ }
+);
Copied: trunk/contrib/perl/lib/ExtUtils/t/hints.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/hints.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/hints.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/hints.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,56 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ('../lib', 'lib/');
+ }
+ else {
+ unshift @INC, 't/lib/';
+ }
+}
+chdir 't';
+
+use File::Spec;
+
+use Test::More tests => 3;
+
+# Having the CWD in @INC masked a bug in finding hint files
+my $curdir = File::Spec->curdir;
+ at INC = grep { $_ ne $curdir && $_ ne '.' } @INC;
+
+mkdir('hints', 0777);
+(my $os = $^O) =~ s/\./_/g;
+my $hint_file = File::Spec->catfile('hints', "$os.pl");
+
+open(HINT, ">$hint_file") || die "Can't write dummy hints file $hint_file: $!";
+print HINT <<'CLOO';
+$self->{CCFLAGS} = 'basset hounds got long ears';
+CLOO
+close HINT;
+
+use TieOut;
+use ExtUtils::MakeMaker;
+
+my $out = tie *STDERR, 'TieOut';
+my $mm = bless {}, 'ExtUtils::MakeMaker';
+$mm->check_hints;
+is( $mm->{CCFLAGS}, 'basset hounds got long ears' );
+is( $out->read, "Processing hints file $hint_file\n" );
+
+open(HINT, ">$hint_file") || die "Can't write dummy hints file $hint_file: $!";
+print HINT <<'CLOO';
+die "Argh!\n";
+CLOO
+close HINT;
+
+$mm->check_hints;
+is( $out->read, <<OUT, 'hint files produce errors' );
+Processing hints file $hint_file
+Argh!
+OUT
+
+END {
+ use File::Path;
+ rmtree ['hints'];
+}
Copied: trunk/contrib/perl/lib/ExtUtils/t/installed_file.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/installed_file.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/installed_file.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/installed_file.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,51 @@
+#!/usr/bin/perl -w
+
+# Test MM->_installed_file_for_module()
+
+BEGIN {
+ chdir 't' if -d 't';
+
+ if( $ENV{PERL_CORE} ) {
+ @INC = '../lib';
+ }
+}
+
+use strict;
+use warnings;
+
+use lib './lib';
+use ExtUtils::MakeMaker;
+use Test::More;
+use File::Spec;
+
+
+sub path_is {
+ my($have, $want, $name) = @_;
+
+ $have = File::Spec->canonpath($have);
+ $want = File::Spec->canonpath($want);
+
+ my $builder = Test::More->builder;
+ return $builder->is_eq( $have, $want, $name );
+}
+
+# Test when a module is not installed
+{
+ ok !MM->_installed_file_for_module("aaldkfjaldj"), "Module not installed";
+ ok !MM->_installed_file_for_module("aaldkfjaldj::dlajldkj");
+}
+
+# Try a single name module
+{
+ my $want = $INC{'strict.pm'};
+ path_is( MM->_installed_file_for_module("strict"), $want, "single name module" );
+}
+
+# And a tuple
+{
+ my $want = $INC{"Test/More.pm"};
+ path_is( MM->_installed_file_for_module("Test::More"), $want, "Foo::Bar style" );
+}
+
+
+done_testing(4);
Copied: trunk/contrib/perl/lib/ExtUtils/t/is_of_type.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/is_of_type.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/is_of_type.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/is_of_type.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,40 @@
+#!/usr/bin/perl -w
+
+# Test _is_of_type()
+
+BEGIN {
+ chdir 't' if -d 't';
+
+ if( $ENV{PERL_CORE} ) {
+ @INC = '../lib';
+ }
+}
+
+use lib './lib';
+use strict;
+use ExtUtils::MakeMaker;
+
+use Test::More "no_plan";
+
+my $is_of_type = \&ExtUtils::MakeMaker::_is_of_type;
+
+my @tests = (
+ [23, "", 1],
+ [[], "", 0],
+ [{}, "", 0],
+ [[], "HASH", 0],
+ [{}, "HASH", 1],
+ [bless({}, "Foo"), "Foo", 1],
+ [bless({}, "Bar"), "Foo", 0],
+ [bless([], "Foo"), "", 0],
+ [bless([], "Foo"), "HASH", 0],
+ [bless([], "Foo"), "ARRAY", 1],
+);
+
+for my $test (@tests) {
+ my($thing, $type, $want) = @$test;
+
+ # [rt.cpan.org 41060]
+ local $SIG{__DIE__} = sub { fail("sigdie should be ignored") };
+ is !!$is_of_type->($thing, $type), !!$want, qq[_is_of_type($thing, '$type'): $want];
+}
Copied: trunk/contrib/perl/lib/ExtUtils/t/make.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/make.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/make.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/make.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,24 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ('../lib', 'lib/');
+ }
+ else {
+ unshift @INC, 't/lib/';
+ }
+}
+
+use Test::More tests => 3;
+
+use ExtUtils::MakeMaker;
+
+my $MM = bless { MAKE => "nmake6" }, "MM";
+is $MM->make, 'nmake';
+
+$MM->{MAKE} = 'GNUmake';
+is $MM->make, 'gmake';
+
+$MM->{MAKE} = 'MMS';
+is $MM->make, 'mms';
Copied: trunk/contrib/perl/lib/ExtUtils/t/maketext_filter.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/maketext_filter.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/maketext_filter.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/maketext_filter.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,65 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+chdir 't';
+
+use Test::More tests => 6;
+
+use ExtUtils::MakeMaker;
+use ExtUtils::MM_VMS;
+
+sub test_filter {
+ my($text, $vms_text) = @_;
+
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ is( ExtUtils::MM_Any->maketext_filter($text), $text, 'default filter' );
+ is( ExtUtils::MM_VMS->maketext_filter($text), $vms_text, 'VMS filter' );
+}
+
+
+# VMS filter puts a space after the target
+test_filter(<<'END', <<'VMS');
+foo: bar
+ thing: splat
+END
+foo : bar
+ thing: splat
+VMS
+
+
+# And it does it for all targets
+test_filter(<<'END', <<'VMS');
+foo: bar
+ thing: splat
+
+up: down
+ yes
+END
+foo : bar
+ thing: splat
+
+up : down
+ yes
+VMS
+
+
+# And it doesn't mess with macros
+test_filter(<<'END', <<'VMS');
+CLASS=Foo: Bar
+
+target: stuff
+ $(PROGRAM) And::Stuff
+END
+CLASS=Foo: Bar
+
+target : stuff
+ $(PROGRAM) And::Stuff
+VMS
Copied: trunk/contrib/perl/lib/ExtUtils/t/metafile_data.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/metafile_data.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/metafile_data.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/metafile_data.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,315 @@
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use strict;
+use Test::More tests => 7;
+
+use Data::Dumper;
+
+require ExtUtils::MM_Any;
+
+my $new_mm = sub {
+ return bless { ARGS => {@_}, @_ }, 'ExtUtils::MM_Any';
+};
+
+{
+ my $mm = $new_mm->(
+ DISTNAME => 'Foo-Bar',
+ VERSION => 1.23,
+ PM => {
+ "Foo::Bar" => 'lib/Foo/Bar.pm',
+ },
+ );
+
+ is_deeply [$mm->metafile_data], [
+ name => 'Foo-Bar',
+ version => 1.23,
+ abstract => undef,
+ author => [],
+ license => 'unknown',
+ distribution_type => 'module',
+
+ configure_requires => {
+ 'ExtUtils::MakeMaker' => 0,
+ },
+ build_requires => {
+ 'ExtUtils::MakeMaker' => 0,
+ },
+
+ no_index => {
+ directory => [qw(t inc)],
+ },
+
+ generated_by => "ExtUtils::MakeMaker version $ExtUtils::MakeMaker::VERSION",
+ 'meta-spec' => {
+ url => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
+ version => 1.4
+ },
+ ];
+
+
+ is_deeply [$mm->metafile_data({}, { no_index => { directory => [qw(foo)] } })], [
+ name => 'Foo-Bar',
+ version => 1.23,
+ abstract => undef,
+ author => [],
+ license => 'unknown',
+ distribution_type => 'module',
+
+ configure_requires => {
+ 'ExtUtils::MakeMaker' => 0,
+ },
+ build_requires => {
+ 'ExtUtils::MakeMaker' => 0,
+ },
+
+ no_index => {
+ directory => [qw(t inc foo)],
+ },
+
+ generated_by => "ExtUtils::MakeMaker version $ExtUtils::MakeMaker::VERSION",
+ 'meta-spec' => {
+ url => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
+ version => 1.4
+ },
+ ], 'rt.cpan.org 39348';
+}
+
+
+{
+ my $mm = $new_mm->(
+ DISTNAME => 'Foo-Bar',
+ VERSION => 1.23,
+ AUTHOR => 'Some Guy',
+ PREREQ_PM => {
+ Foo => 2.34,
+ Bar => 4.56,
+ },
+ );
+
+ is_deeply [$mm->metafile_data(
+ {
+ configure_requires => {
+ Stuff => 2.34
+ },
+ wobble => 42
+ },
+ {
+ no_index => {
+ package => "Thing"
+ },
+ wibble => 23
+ },
+ )],
+ [
+ name => 'Foo-Bar',
+ version => 1.23,
+ abstract => undef,
+ author => ['Some Guy'],
+ license => 'unknown',
+ distribution_type => 'script',
+
+ configure_requires => {
+ Stuff => 2.34,
+ },
+ build_requires => {
+ 'ExtUtils::MakeMaker' => 0,
+ },
+
+ requires => {
+ Foo => 2.34,
+ Bar => 4.56,
+ },
+
+ no_index => {
+ directory => [qw(t inc)],
+ package => 'Thing',
+ },
+
+ generated_by => "ExtUtils::MakeMaker version $ExtUtils::MakeMaker::VERSION",
+ 'meta-spec' => {
+ url => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
+ version => 1.4
+ },
+
+ wibble => 23,
+ wobble => 42,
+ ];
+}
+
+
+# Test MIN_PERL_VERSION
+{
+ my $mm = $new_mm->(
+ DISTNAME => 'Foo-Bar',
+ VERSION => 1.23,
+ PM => {
+ "Foo::Bar" => 'lib/Foo/Bar.pm',
+ },
+ MIN_PERL_VERSION => 5.006,
+ );
+
+ is_deeply [$mm->metafile_data], [
+ name => 'Foo-Bar',
+ version => 1.23,
+ abstract => undef,
+ author => [],
+ license => 'unknown',
+ distribution_type => 'module',
+
+ configure_requires => {
+ 'ExtUtils::MakeMaker' => 0,
+ },
+ build_requires => {
+ 'ExtUtils::MakeMaker' => 0,
+ },
+
+ requires => {
+ perl => '5.006',
+ },
+
+ no_index => {
+ directory => [qw(t inc)],
+ },
+
+ generated_by => "ExtUtils::MakeMaker version $ExtUtils::MakeMaker::VERSION",
+ 'meta-spec' => {
+ url => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
+ version => 1.4
+ },
+ ];
+}
+
+
+# Test MIN_PERL_VERSION
+{
+ my $mm = $new_mm->(
+ DISTNAME => 'Foo-Bar',
+ VERSION => 1.23,
+ PM => {
+ "Foo::Bar" => 'lib/Foo/Bar.pm',
+ },
+ MIN_PERL_VERSION => 5.006,
+ PREREQ_PM => {
+ 'Foo::Bar' => 1.23,
+ },
+ );
+
+ is_deeply [$mm->metafile_data], [
+ name => 'Foo-Bar',
+ version => 1.23,
+ abstract => undef,
+ author => [],
+ license => 'unknown',
+ distribution_type => 'module',
+
+ configure_requires => {
+ 'ExtUtils::MakeMaker' => 0,
+ },
+ build_requires => {
+ 'ExtUtils::MakeMaker' => 0,
+ },
+
+ requires => {
+ perl => '5.006',
+ 'Foo::Bar' => 1.23,
+ },
+
+ no_index => {
+ directory => [qw(t inc)],
+ },
+
+ generated_by => "ExtUtils::MakeMaker version $ExtUtils::MakeMaker::VERSION",
+ 'meta-spec' => {
+ url => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
+ version => 1.4
+ },
+ ];
+}
+
+# Test CONFIGURE_REQUIRES
+{
+ my $mm = $new_mm->(
+ DISTNAME => 'Foo-Bar',
+ VERSION => 1.23,
+ CONFIGURE_REQUIRES => {
+ "Fake::Module1" => 1.01,
+ },
+ PM => {
+ "Foo::Bar" => 'lib/Foo/Bar.pm',
+ },
+ );
+
+ is_deeply [$mm->metafile_data], [
+ name => 'Foo-Bar',
+ version => 1.23,
+ abstract => undef,
+ author => [],
+ license => 'unknown',
+ distribution_type => 'module',
+
+ configure_requires => {
+ 'Fake::Module1' => 1.01,
+ },
+ build_requires => {
+ 'ExtUtils::MakeMaker' => 0,
+ },
+
+ no_index => {
+ directory => [qw(t inc)],
+ },
+
+ generated_by => "ExtUtils::MakeMaker version $ExtUtils::MakeMaker::VERSION",
+ 'meta-spec' => {
+ url => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
+ version => 1.4
+ },
+ ],'CONFIGURE_REQUIRES';
+}
+
+# Test BUILD_REQUIRES
+{
+ my $mm = $new_mm->(
+ DISTNAME => 'Foo-Bar',
+ VERSION => 1.23,
+ BUILD_REQUIRES => {
+ "Fake::Module1" => 1.01,
+ },
+ PM => {
+ "Foo::Bar" => 'lib/Foo/Bar.pm',
+ },
+ );
+
+ is_deeply [$mm->metafile_data], [
+ name => 'Foo-Bar',
+ version => 1.23,
+ abstract => undef,
+ author => [],
+ license => 'unknown',
+ distribution_type => 'module',
+
+ configure_requires => {
+ 'ExtUtils::MakeMaker' => 0,
+ },
+ build_requires => {
+ 'Fake::Module1' => 1.01,
+ },
+
+ no_index => {
+ directory => [qw(t inc)],
+ },
+
+ generated_by => "ExtUtils::MakeMaker version $ExtUtils::MakeMaker::VERSION",
+ 'meta-spec' => {
+ url => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
+ version => 1.4
+ },
+ ],'CONFIGURE_REQUIRES';
+}
Copied: trunk/contrib/perl/lib/ExtUtils/t/metafile_file.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/metafile_file.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/metafile_file.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/metafile_file.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,314 @@
+#!/usr/bin/perl -w
+
+# This is a test of the fake YAML dumper implemented by EUMM:
+# ExtUtils::MM_Any::metafile_file
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use strict;
+use Test::More tests => 16;
+
+require ExtUtils::MM_Any;
+
+my $mm = bless {}, 'ExtUtils::MM_Any';
+
+{
+ my @meta = ( a => 1, b => 2 );
+ my $expected = <<YAML;
+--- #YAML:1.0
+a: 1
+b: 2
+YAML
+
+ is($mm->metafile_file(@meta), $expected, "dump for flat hashes works ok");
+}
+
+{
+ my @meta = ( k1 => 'some key and value', k2 => undef, k3 => 1 );
+ my $expected = <<YAML;
+--- #YAML:1.0
+k1: some key and value
+k2: ~
+k3: 1
+YAML
+
+ is($mm->metafile_file(@meta), $expected, "dumping strings and undefs is ok");
+}
+
+{
+ my @meta = ( a => 1, b => 2, h => { hh => 1 } );
+ my $expected = <<YAML;
+--- #YAML:1.0
+a: 1
+b: 2
+h:
+ hh: 1
+YAML
+
+ is($mm->metafile_file(@meta), $expected, "dump for nested hashes works ok");
+}
+
+{
+ my @meta = ( a => 1, b => 2, h => { h1 => 'x', h2 => 'z' } );
+ my $expected = <<YAML;
+--- #YAML:1.0
+a: 1
+b: 2
+h:
+ h1: x
+ h2: z
+YAML
+
+ is($mm->metafile_file(@meta), $expected, "nested hashes sort ascii-betically");
+ # to tell the truth, they sort case-insensitively
+ # that's hard to test for Perl with unstable sort's
+}
+
+{
+ my @meta = ( a => 1, b => 2, h => { hh => { hhh => 1 } } );
+ my $expected = <<YAML;
+--- #YAML:1.0
+a: 1
+b: 2
+h:
+ hh:
+ hhh: 1
+YAML
+
+ is($mm->metafile_file(@meta), $expected, "dump for hashes (with more nesting) works ok");
+}
+
+{
+ my @meta = ( a => 1, k => [ qw(w y z) ] );
+ my $expected = <<YAML;
+--- #YAML:1.0
+a: 1
+k:
+ - w
+ - y
+ - z
+YAML
+
+ is($mm->metafile_file(@meta), $expected, "array of strings are handled ok");
+}
+
+is($mm->metafile_file( a => {}, b => [], c => undef ), <<'YAML', 'empty hashes and arrays');
+--- #YAML:1.0
+a: {}
+b: []
+c: ~
+YAML
+
+
+{
+ my @meta = (
+ name => 'My-Module',
+ version => '0.1',
+ version_from => 'lib/My/Module.pm',
+ installdirs => 'site',
+ abstract => 'A does-it-all module',
+ license => 'perl',
+ generated_by => 'myself',
+ author => 'John Doe <doe at doeland.org>',
+ distribution_type => 'module',
+ requires => {
+ 'My::Module::Helper' => 0,
+ 'Your::Module' => '1.5',
+ },
+ 'meta-spec' => {
+ version => '1.1',
+ url => 'http://module-build.sourceforge.net/META-spec-new.html',
+ },
+ );
+ my $expected = <<'YAML';
+--- #YAML:1.0
+name: My-Module
+version: 0.1
+version_from: lib/My/Module.pm
+installdirs: site
+abstract: A does-it-all module
+license: perl
+generated_by: myself
+author: John Doe <doe at doeland.org>
+distribution_type: module
+requires:
+ My::Module::Helper: 0
+ Your::Module: 1.5
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-new.html
+ version: 1.1
+YAML
+
+ is($mm->metafile_file(@meta), $expected, "dump for something like META.yml works");
+}
+
+{
+ my @meta = (
+ name => 'My-Module',
+ version => '0.1',
+ version_from => 'lib/My/Module.pm',
+ installdirs => 'site',
+ abstract => 'A does-it-all module',
+ license => 'perl',
+ generated_by => 'myself',
+ author => 'John Doe <doe at doeland.org>',
+ distribution_type => 'module',
+ requires => {
+ 'My::Module::Helper' => 0,
+ 'Your::Module' => '1.5',
+ },
+ recommends => {
+ 'Test::More' => 0,
+ 'Test::Pod' => 1.18,
+ 'Test::Pod::Coverage' => 1
+ },
+ 'meta-spec' => {
+ version => '1.1',
+ url => 'http://module-build.sourceforge.net/META-spec-new.html',
+ },
+ );
+ my $expected = <<'YAML';
+--- #YAML:1.0
+name: My-Module
+version: 0.1
+version_from: lib/My/Module.pm
+installdirs: site
+abstract: A does-it-all module
+license: perl
+generated_by: myself
+author: John Doe <doe at doeland.org>
+distribution_type: module
+requires:
+ My::Module::Helper: 0
+ Your::Module: 1.5
+recommends:
+ Test::More: 0
+ Test::Pod: 1.18
+ Test::Pod::Coverage: 1
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-new.html
+ version: 1.1
+YAML
+
+ is($mm->metafile_file(@meta), $expected, "META.yml with extra 'recommends' works");
+}
+
+{
+ my @meta = (
+ name => 'My-Module',
+ version => '0.1',
+ version_from => 'lib/My/Module.pm',
+ installdirs => 'site',
+ abstract => 'A does-it-all module',
+ license => 'perl',
+ generated_by => 'myself',
+ author => 'John Doe <doe at doeland.org>',
+ distribution_type => 'module',
+ requires => {
+ 'My::Module::Helper' => 0,
+ 'Your::Module' => '1.5',
+ },
+ recommends => {
+ 'Test::More' => 0,
+ 'Test::Pod' => 1.18,
+ 'Test::Pod::Coverage' => 1
+ },
+ no_index => {
+ dir => [ qw(inc) ],
+ file => [ qw(TODO NOTES) ],
+ },
+ 'meta-spec' => {
+ version => '1.1',
+ url => 'http://module-build.sourceforge.net/META-spec-new.html',
+ },
+ );
+ my $expected = <<'YAML';
+--- #YAML:1.0
+name: My-Module
+version: 0.1
+version_from: lib/My/Module.pm
+installdirs: site
+abstract: A does-it-all module
+license: perl
+generated_by: myself
+author: John Doe <doe at doeland.org>
+distribution_type: module
+requires:
+ My::Module::Helper: 0
+ Your::Module: 1.5
+recommends:
+ Test::More: 0
+ Test::Pod: 1.18
+ Test::Pod::Coverage: 1
+no_index:
+ dir:
+ - inc
+ file:
+ - TODO
+ - NOTES
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-new.html
+ version: 1.1
+YAML
+
+ is($mm->metafile_file(@meta), $expected, "META.yml with extra 'no_index' works");
+
+
+ # Make sure YAML.pm can ready our output
+ SKIP: {
+ skip "Need YAML.pm to test if it can load META.yml", 1
+ unless eval { require YAML };
+
+ my $yaml_load = YAML::Load($mm->metafile_file(@meta));
+ is_deeply( $yaml_load, {@meta}, "META.yml can be read by YAML.pm" );
+ }
+
+
+ SKIP: {
+ skip "Need YAML::Tiny to test if it can load META.yml", 2
+ unless eval { require YAML::Tiny };
+
+ my @yaml_load = YAML::Tiny::Load($mm->metafile_file(@meta));
+ is @yaml_load, 1, "YAML::Tiny saw one document in META.yml";
+ is_deeply( $yaml_load[0], {@meta}, "META.yml can be read by YAML::Tiny" );
+ }
+}
+
+
+{
+ my @meta = ( k => 'a : b', 'x : y' => 1 );
+ my $expected = <<YAML;
+--- #YAML:1.0
+k: a : b
+x : y: 1
+YAML
+ # NOTE: the output is not YAML-equivalent to the input
+
+ is($mm->metafile_file(@meta), $expected, "no quoting is done");
+}
+
+{
+ my @meta = ( k => \*STDOUT );
+ eval { $mm->metafile_file(@meta) };
+
+ like($@, qr/^only nested hashes, arrays and objects are supported/,
+ "we don't like but hash/array refs");
+}
+
+{
+ my @meta = ( k => [ [] ] );
+ eval { $mm->metafile_file(@meta) };
+
+ like($@, qr/^only nested arrays of non-refs are supported/,
+ "we also don't like but array of strings");
+}
+
+# recursive data structures: don't even think about it - endless recursion
Copied: trunk/contrib/perl/lib/ExtUtils/t/min_perl_version.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/min_perl_version.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/min_perl_version.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/min_perl_version.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,201 @@
+#!/usr/bin/perl -w
+
+# This is a test checking various aspects of the optional argument
+# MIN_PERL_VERSION to WriteMakefile.
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use strict;
+use Test::More tests => 33;
+
+use TieOut;
+use MakeMaker::Test::Utils;
+use MakeMaker::Test::Setup::MPV;
+use File::Path;
+
+use ExtUtils::MakeMaker;
+
+# avoid environment variables interfering with our make runs
+delete @ENV{qw(LIB MAKEFLAGS)};
+
+my $perl = which_perl();
+my $make = make_run();
+my $makefile = makefile_name();
+
+chdir 't';
+
+perl_lib();
+
+ok( setup_recurs(), 'setup' );
+END {
+ ok( chdir(File::Spec->updir), 'leaving dir' );
+ ok( teardown_recurs(), 'teardown' );
+}
+
+ok( chdir 'Min-PerlVers', 'entering dir Min-PerlVers' ) ||
+ diag("chdir failed: $!");
+
+{
+ # ----- argument verification -----
+
+ my $stdout = tie *STDOUT, 'TieOut';
+ ok( $stdout, 'capturing stdout' );
+ my $warnings = '';
+ local $SIG{__WARN__} = sub {
+ $warnings .= join '', @_;
+ };
+
+ eval {
+ WriteMakefile(
+ NAME => 'Min::PerlVers',
+ MIN_PERL_VERSION => '5',
+ );
+ };
+ is( $warnings, '', 'MIN_PERL_VERSION=5 does not trigger a warning' );
+ is( $@, '', ' nor a hard failure' );
+
+
+ $warnings = '';
+ eval {
+ WriteMakefile(
+ NAME => 'Min::PerlVers',
+ MIN_PERL_VERSION => '5.4.4',
+ );
+ };
+ is( $warnings, '', 'MIN_PERL_VERSION=X.Y.Z does not trigger a warning' );
+ is( $@, '', ' nor a hard failure' );
+
+
+ $warnings = '';
+ eval {
+ WriteMakefile(
+ NAME => 'Min::PerlVers',
+ MIN_PERL_VERSION => '999999',
+ );
+ };
+ ok( '' ne $warnings, 'MIN_PERL_VERSION=999999 triggers a warning' );
+ is( $warnings,
+ "Warning: Perl version 999999 or higher required. We run $].\n",
+ ' with expected message text' );
+ is( $@, '', ' and without a hard failure' );
+
+ $warnings = '';
+ eval {
+ WriteMakefile(
+ NAME => 'Min::PerlVers',
+ MIN_PERL_VERSION => '999999',
+ PREREQ_FATAL => 1,
+ );
+ };
+ is( $warnings, '', 'MIN_PERL_VERSION=999999 and PREREQ_FATAL: no warning' );
+ is( $@, <<"END", ' correct exception' );
+MakeMaker FATAL: perl version too low for this distribution.
+Required is 999999. We run $].
+END
+
+ $warnings = '';
+ eval {
+ WriteMakefile(
+ NAME => 'Min::PerlVers',
+ MIN_PERL_VERSION => 'foobar',
+ );
+ };
+ ok( '' ne $warnings, 'MIN_PERL_VERSION=foobar triggers a warning' );
+ is( $warnings, <<'END', ' with expected message text' );
+Warning: MIN_PERL_VERSION is not in a recognized format.
+Recommended is a quoted numerical value like '5.005' or '5.008001'.
+END
+
+ is( $@, '', ' and without a hard failure' );
+}
+
+
+# ----- PREREQ_PRINT output -----
+{
+ my $prereq_out = run(qq{$perl Makefile.PL "PREREQ_PRINT=1"});
+ is( $?, 0, 'PREREQ_PRINT exiting normally' );
+ my $prereq_out_sane = $prereq_out =~ /^\s*\$PREREQ_PM\s*=/;
+ ok( $prereq_out_sane, ' and talking like we expect' ) ||
+ diag($prereq_out);
+
+ SKIP: {
+ skip 'not going to evaluate rubbish', 3 if !$prereq_out_sane;
+
+ package _Prereq::Print::WithMPV; ## no critic
+ our($PREREQ_PM, $BUILD_REQUIRES, $MIN_PERL_VERSION, $ERR);
+ $ERR = '';
+ eval {
+ eval $prereq_out; ## no critic
+ $ERR = $@;
+ };
+ ::is( $@ . $ERR, '', 'prereqs evaluable' );
+ ::is_deeply( $PREREQ_PM, { strict => 0 }, ' and looking correct' );
+ ::is( $MIN_PERL_VERSION, '5.005', 'min version also correct' );
+ }
+}
+
+
+# ----- PRINT_PREREQ output -----
+{
+ my $prereq_out = run(qq{$perl Makefile.PL "PRINT_PREREQ=1"});
+ is( $?, 0, 'PRINT_PREREQ exiting normally' );
+ ok( $prereq_out !~ /^warning/i, ' and not complaining loudly' );
+ like( $prereq_out,
+ qr/^perl\(perl\) \s* >= 5\.005 \s+ perl\(strict\) \s* >= \s* 0 \s*$/x,
+ 'dump has prereqs and perl version' );
+}
+
+
+# ----- generated files verification -----
+{
+ unlink $makefile;
+ my @mpl_out = run(qq{$perl Makefile.PL});
+ END { unlink $makefile, makefile_backup() }
+
+ cmp_ok( $?, '==', 0, 'Makefile.PL exiting normally' ) || diag(@mpl_out);
+ ok( -e $makefile, 'Makefile present' );
+}
+
+
+# ----- ppd output -----
+{
+ my $ppd_file = 'Min-PerlVers.ppd';
+ my @make_out = run(qq{$make ppd});
+ END { unlink $ppd_file }
+
+ cmp_ok( $?, '==', 0, 'Make ppd exiting normally' ) || diag(@make_out);
+
+ my $ppd_html = slurp($ppd_file);
+ ok( defined($ppd_html), ' .ppd file present' );
+
+ like( $ppd_html, qr{^\s*<PERLCORE VERSION="5,005,0,0" />}m,
+ ' .ppd file content good' );
+}
+
+
+# ----- META.yml output -----
+{
+ my $distdir = 'Min-PerlVers-0.05';
+ $distdir =~ s{\.}{_}g if $Is_VMS;
+
+ my $meta_yml = "$distdir/META.yml";
+ my @make_out = run(qq{$make metafile});
+ END { rmtree $distdir }
+
+ cmp_ok( $?, '==', 0, 'Make metafile exiting normally' ) || diag(@make_out);
+ my $meta = slurp($meta_yml);
+ ok( defined($meta), ' META.yml present' );
+
+ like( $meta, qr{\nrequires:[^\S\n]*\n\s+perl:\s+5\.005\n\s+strict:\s+0\n},
+ ' META.yml content good');
+}
+
+__END__
Copied: trunk/contrib/perl/lib/ExtUtils/t/miniperl.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/miniperl.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/miniperl.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/miniperl.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,57 @@
+#!/usr/bin/perl -w
+
+# Test that we can build modules as miniperl.
+# This mostly means no XS modules.
+
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = qw(../lib lib);
+ }
+}
+
+use strict;
+use lib 't/lib';
+
+use Test::More 'no_plan';
+
+BEGIN {
+ ok !$INC{"ExtUtils/MakeMaker.pm"}, "MakeMaker is not yet loaded";
+}
+
+# Disable all XS from here on
+use MakeMaker::Test::NoXS;
+
+use ExtUtils::MakeMaker;
+
+use MakeMaker::Test::Utils;
+use MakeMaker::Test::Setup::BFD;
+
+
+my $perl = which_perl();
+my $makefile = makefile_name();
+my $make = make_run();
+
+
+# Setup our test environment
+{
+ chdir 't';
+
+ perl_lib;
+
+ ok( setup_recurs(), 'setup' );
+ END {
+ ok( chdir File::Spec->updir );
+ ok( teardown_recurs(), 'teardown' );
+ }
+
+ ok( chdir('Big-Dummy'), "chdir'd to Big-Dummy" ) ||
+ diag("chdir failed: $!");
+}
+
+
+# Run make once
+{
+ run_ok(qq{$perl Makefile.PL});
+ run_ok($make);
+}
Copied: trunk/contrib/perl/lib/ExtUtils/t/oneliner.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/oneliner.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/oneliner.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/oneliner.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,51 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+chdir 't';
+
+use MakeMaker::Test::Utils;
+use Test::More tests => 6;
+use File::Spec;
+
+my $TB = Test::More->builder;
+
+BEGIN { use_ok('ExtUtils::MM') }
+
+my $mm = bless { NAME => "Foo" }, 'MM';
+isa_ok($mm, 'ExtUtils::MakeMaker');
+isa_ok($mm, 'ExtUtils::MM_Any');
+
+
+sub try_oneliner {
+ my($code, $switches, $expect, $name) = @_;
+ my $cmd = $mm->oneliner($code, $switches);
+ $cmd =~ s{\$\(ABSPERLRUN\)}{$^X};
+
+ # VMS likes to put newlines at the end of commands if there isn't
+ # one already.
+ $expect =~ s/([^\n])\z/$1\n/ if $^O eq 'VMS';
+
+ $TB->is_eq(scalar `$cmd`, $expect, $name) || $TB->diag("oneliner:\n$cmd");
+}
+
+# Lets see how it deals with quotes.
+try_oneliner(q{print "foo'o", ' bar"ar'}, [], q{foo'o bar"ar}, 'quotes');
+
+# How about dollar signs?
+try_oneliner(q{$PATH = 'foo'; print $PATH},[], q{foo}, 'dollar signs' );
+
+# switches?
+try_oneliner(q{print 'foo'}, ['-l'], "foo\n", 'switches' );
+
+# XXX gotta rethink the newline test. The Makefile does newline
+# escaping, then the shell.
+
Copied: trunk/contrib/perl/lib/ExtUtils/t/parse_version.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/parse_version.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/parse_version.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/parse_version.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,85 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+chdir 't';
+
+use Test::More;
+use ExtUtils::MakeMaker;
+
+my $Has_Version = eval 'require version; "version"->import; 1';
+
+my %versions = (q[$VERSION = '1.00'] => '1.00',
+ q[*VERSION = \'1.01'] => '1.01',
+ q[($VERSION) = q$Revision: 1.1.1.2 $ =~ /(\d+)/g;] => 32208,
+ q[$FOO::VERSION = '1.10';] => '1.10',
+ q[*FOO::VERSION = \'1.11';] => '1.11',
+ '$VERSION = 0.02' => 0.02,
+ '$VERSION = 0.0' => 0.0,
+ '$VERSION = -1.0' => -1.0,
+ '$VERSION = undef' => 'undef',
+ '$wibble = 1.0' => 'undef',
+ q[my $VERSION = '1.01'] => 'undef',
+ q[local $VERISON = '1.02'] => 'undef',
+ q[local $FOO::VERSION = '1.30'] => 'undef',
+ q[if( $Foo::VERSION >= 3.00 ) {]=> 'undef',
+ q[our $VERSION = '1.23';] => '1.23',
+
+ '$Something::VERSION == 1.0' => 'undef',
+ '$Something::VERSION <= 1.0' => 'undef',
+ '$Something::VERSION >= 1.0' => 'undef',
+ '$Something::VERSION != 1.0' => 'undef',
+
+ qq[\$Something::VERSION == 1.0\n\$VERSION = 2.3\n] => '2.3',
+ qq[\$Something::VERSION == 1.0\n\$VERSION = 2.3\n\$VERSION = 4.5\n] => '2.3',
+
+ '$VERSION = sprintf("%d.%03d", q$Revision: 1.1.1.2 $ =~ /(\d+)\.(\d+)/);' => '3.074',
+ '$VERSION = substr(q$Revision: 1.1.1.2 $, 10) + 2 . "";' => '4.8',
+ );
+
+if( $Has_Version ) {
+ $versions{q[use version; $VERSION = qv("1.2.3");]} = qv("1.2.3");
+ $versions{q[$VERSION = qv("1.2.3")]} = qv("1.2.3");
+}
+
+plan tests => (2 * keys %versions) + 4;
+
+while( my($code, $expect) = each %versions ) {
+ is( parse_version_string($code), $expect, $code );
+}
+
+
+sub parse_version_string {
+ my $code = shift;
+
+ open(FILE, ">VERSION.tmp") || die $!;
+ print FILE "$code\n";
+ close FILE;
+
+ $_ = 'foo';
+ my $version = MM->parse_version('VERSION.tmp');
+ is( $_, 'foo', '$_ not leaked by parse_version' );
+
+ unlink "VERSION.tmp";
+
+ return $version;
+}
+
+
+# This is a specific test to see if a version subroutine in the $VERSION
+# declaration confuses later calls to the version class.
+# [rt.cpan.org 30747]
+SKIP: {
+ skip "need version.pm", 4 unless $Has_Version;
+ is parse_version_string(q[ $VERSION = '1.00'; sub version { $VERSION } ]),
+ '1.00';
+ is parse_version_string(q[ use version; $VERSION = version->new("1.2.3") ]),
+ qv("1.2.3");
+}
Copied: trunk/contrib/perl/lib/ExtUtils/t/pm.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/pm.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/pm.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/pm.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,47 @@
+#!/usr/bin/perl -w
+
+# Test that MakeMaker honors user's PM override.
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use strict;
+use Test::More tests => 6;
+
+use TieOut;
+use MakeMaker::Test::Utils;
+use MakeMaker::Test::Setup::BFD;
+
+use ExtUtils::MakeMaker;
+
+chdir 't';
+
+perl_lib();
+
+ok( setup_recurs(), 'setup' );
+END {
+ ok( chdir File::Spec->updir );
+ ok( teardown_recurs(), 'teardown' );
+}
+
+ok( chdir 'Big-Dummy', "chdir'd to Big-Dummy" ) ||
+ diag("chdir failed: $!");
+
+ok( my $stdout = tie *STDOUT, 'TieOut' );
+
+{
+ my $mm = WriteMakefile(
+ NAME => 'Big::Dummy',
+ VERSION_FROM => 'lib/Big/Dummy.pm',
+ PM => { 'wibble' => 'woof' }
+ );
+
+ is_deeply( $mm->{PM}, { wibble => 'woof' } );
+}
Copied: trunk/contrib/perl/lib/ExtUtils/t/pm_to_blib.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/pm_to_blib.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/pm_to_blib.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/pm_to_blib.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,77 @@
+#!/usr/bin/perl -w
+
+# Ensure pm_to_blib runs at the right times.
+
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = qw(../lib lib);
+ }
+}
+
+use strict;
+use lib 't/lib';
+
+use Test::More 'no_plan';
+
+use ExtUtils::MakeMaker;
+
+use MakeMaker::Test::Utils;
+use MakeMaker::Test::Setup::BFD;
+
+
+my $perl = which_perl();
+my $makefile = makefile_name();
+my $make = make_run();
+
+
+# Setup our test environment
+{
+ chdir 't';
+
+ perl_lib;
+
+ ok( setup_recurs(), 'setup' );
+ END {
+ ok( chdir File::Spec->updir );
+ ok( teardown_recurs(), 'teardown' );
+ }
+
+ ok( chdir('Big-Dummy'), "chdir'd to Big-Dummy" ) ||
+ diag("chdir failed: $!");
+}
+
+
+# Run make once
+{
+ run_ok(qq{$perl Makefile.PL});
+ run_ok($make);
+
+ ok( -e "blib/lib/Big/Dummy.pm", "blib copied pm file" );
+}
+
+
+# Change a pm file, it should be copied.
+{
+ # Wait a couple seconds else our changed file will have the same timestamp
+ # as the blib file
+ sleep 2;
+
+ ok( open my $fh, ">>", "lib/Big/Dummy.pm" ) or die $!;
+ print $fh "Something else\n";
+ close $fh;
+
+ run_ok($make);
+ like slurp("blib/lib/Big/Dummy.pm"), qr/Something else\n$/;
+}
+
+
+# Rerun the Makefile.PL, pm_to_blib should rerun
+{
+ run_ok(qq{$perl Makefile.PL});
+
+ # XXX This is a fragile way to check that it reran.
+ like run_ok($make), qr/^Skip /ms;
+
+ ok( -e "blib/lib/Big/Dummy.pm", "blib copied pm file" );
+}
Copied: trunk/contrib/perl/lib/ExtUtils/t/pod2man.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/pod2man.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/pod2man.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/pod2man.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,54 @@
+#!/usr/bin/perl -w
+
+# Test our simulation of pod2man
+
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = qw(../lib lib);
+ }
+}
+
+use strict;
+use lib 't/lib';
+
+use ExtUtils::Command::MM;
+
+use Test::More tests => 3;
+
+# The argument to perm_rw was optional.
+# [rt.cpan.org 35190]
+{
+ my $warnings;
+ local $SIG{__WARN__} = sub {
+ $warnings .= join '', @_;
+ };
+
+ pod2man("--perm_rw");
+
+ like $warnings, qr/^Option perm_rw requires an argument/;
+};
+
+
+# Simulate the failure of Pod::Man loading.
+# pod2man() should react gracefully.
+{
+ local @INC = @INC;
+ unshift @INC, sub {
+ die "Simulated Pod::Man failure\n" if $_[1] eq 'Pod/Man.pm';
+ };
+ local %INC = %INC;
+ delete $INC{"Pod/Man.pm"};
+
+ my $warnings;
+ local $SIG{__WARN__} = sub {
+ $warnings .= join '', @_;
+ };
+
+ is pod2man(), undef;
+ is $warnings, <<'END'
+Pod::Man is not available: Simulated Pod::Man failure
+Man pages will not be generated during this install.
+END
+
+}
Copied: trunk/contrib/perl/lib/ExtUtils/t/postamble.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/postamble.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/postamble.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/postamble.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,73 @@
+#!/usr/bin/perl -w
+
+# Wherein we ensure that postamble works ok.
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use strict;
+use Test::More tests => 8;
+use MakeMaker::Test::Utils;
+use MakeMaker::Test::Setup::BFD;
+use ExtUtils::MakeMaker;
+use TieOut;
+
+chdir 't';
+perl_lib;
+$| = 1;
+
+my $Makefile = makefile_name;
+
+ok( setup_recurs(), 'setup' );
+END {
+ ok( chdir File::Spec->updir );
+ ok( teardown_recurs(), 'teardown' );
+}
+
+ok( chdir 'Big-Dummy', q{chdir'd to Big-Dummy} ) ||
+ diag("chdir failed: $!");
+
+{
+ my $warnings = '';
+ local $SIG{__WARN__} = sub {
+ $warnings = join '', @_;
+ };
+
+ my $stdout = tie *STDOUT, 'TieOut' or die;
+ my $mm = WriteMakefile(
+ NAME => 'Big::Dummy',
+ VERSION_FROM => 'lib/Big/Dummy.pm',
+ postamble => {
+ FOO => 1,
+ BAR => "fugawazads"
+ }
+ );
+ is( $warnings, '', 'postamble argument not warned about' );
+}
+
+sub MY::postamble {
+ my($self, %extra) = @_;
+
+ is_deeply( \%extra, { FOO => 1, BAR => 'fugawazads' },
+ 'postamble args passed' );
+
+ return <<OUT;
+# This makes sure the postamble gets written
+OUT
+
+}
+
+
+ok( open(MAKEFILE, $Makefile) ) or diag "Can't open $Makefile: $!";
+{ local $/;
+ like( <MAKEFILE>, qr/^\# This makes sure the postamble gets written\n/m,
+ 'postamble added to the Makefile' );
+}
+close MAKEFILE;
Copied: trunk/contrib/perl/lib/ExtUtils/t/prefixify.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/prefixify.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/prefixify.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/prefixify.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,52 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use strict;
+use Test::More;
+
+if( $^O eq 'VMS' ) {
+ plan skip_all => 'prefixify works differently on VMS';
+}
+else {
+ plan tests => 4;
+}
+use ExtUtils::MakeMaker::Config;
+use File::Spec;
+use ExtUtils::MM;
+
+my $Is_Dosish = $^O =~ /^(dos|MSWin32)$/;
+
+my $mm = bless {}, 'MM';
+
+my $default = File::Spec->catdir(qw(this that));
+
+$mm->prefixify('installbin', 'wibble', 'something', $default);
+is( $mm->{INSTALLBIN}, $Config{installbin},
+ 'prefixify w/defaults');
+
+$mm->{ARGS}{PREFIX} = 'foo';
+$mm->prefixify('installbin', 'wibble', 'something', $default);
+is( $mm->{INSTALLBIN}, File::Spec->catdir('something', $default),
+ 'prefixify w/defaults and PREFIX');
+
+$mm->prefixify('installbin', '../wibble', 'something', $default);
+is( $mm->{INSTALLBIN}, File::Spec->catdir('something', $default),
+ 'relative paths + PREFIX');
+
+SKIP: {
+ skip "Test for DOSish prefixification", 1 unless $Is_Dosish;
+
+ $Config{wibble} = 'C:\opt\perl\wibble';
+ $mm->prefixify('wibble', 'C:\opt\perl', 'C:\yarrow');
+
+ is( $mm->{WIBBLE}, 'C:\yarrow\wibble', 'prefixify Win32 paths' );
+}
Copied: trunk/contrib/perl/lib/ExtUtils/t/prereq.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/prereq.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/prereq.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/prereq.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,133 @@
+#!/usr/bin/perl -w
+
+# This is a test of the verification of the arguments to
+# WriteMakefile.
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use strict;
+use Test::More tests => 13;
+
+use TieOut;
+use MakeMaker::Test::Utils;
+use MakeMaker::Test::Setup::BFD;
+
+use ExtUtils::MakeMaker;
+
+chdir 't';
+
+perl_lib();
+
+ok( setup_recurs(), 'setup' );
+END {
+ ok( chdir File::Spec->updir );
+ ok( teardown_recurs(), 'teardown' );
+}
+
+ok( chdir 'Big-Dummy', "chdir'd to Big-Dummy" ) ||
+ diag("chdir failed: $!");
+
+{
+ ok( my $stdout = tie *STDOUT, 'TieOut' );
+ my $warnings = '';
+ local $SIG{__WARN__} = sub {
+ $warnings .= join '', @_;
+ };
+
+ WriteMakefile(
+ NAME => 'Big::Dummy',
+ PREREQ_PM => {
+ strict => 0
+ }
+ );
+ is $warnings, '';
+
+ $warnings = '';
+ WriteMakefile(
+ NAME => 'Big::Dummy',
+ PREREQ_PM => {
+ strict => 99999
+ }
+ );
+ is $warnings,
+ sprintf("Warning: prerequisite strict 99999 not found. We have %s.\n",
+ $strict::VERSION);
+
+ $warnings = '';
+ WriteMakefile(
+ NAME => 'Big::Dummy',
+ PREREQ_PM => {
+ "I::Do::Not::Exist" => 0,
+ }
+ );
+ is $warnings,
+ "Warning: prerequisite I::Do::Not::Exist 0 not found.\n";
+
+ $warnings = '';
+ WriteMakefile(
+ NAME => 'Big::Dummy',
+ PREREQ_PM => {
+ "I::Do::Not::Exist" => 0,
+ "strict" => 99999,
+ }
+ );
+ is $warnings,
+ "Warning: prerequisite I::Do::Not::Exist 0 not found.\n".
+ sprintf("Warning: prerequisite strict 99999 not found. We have %s.\n",
+ $strict::VERSION);
+
+ $warnings = '';
+ eval {
+ WriteMakefile(
+ NAME => 'Big::Dummy',
+ PREREQ_PM => {
+ "I::Do::Not::Exist" => 0,
+ "Nor::Do::I" => 0,
+ "strict" => 99999,
+ },
+ PREREQ_FATAL => 1,
+ );
+ };
+
+ is $warnings, '';
+ is $@, <<'END', "PREREQ_FATAL";
+MakeMaker FATAL: prerequisites not found.
+ I::Do::Not::Exist not installed
+ Nor::Do::I not installed
+ strict 99999
+
+Please install these modules first and rerun 'perl Makefile.PL'.
+END
+
+
+ $warnings = '';
+ eval {
+ WriteMakefile(
+ NAME => 'Big::Dummy',
+ PREREQ_PM => {
+ "I::Do::Not::Exist" => 0,
+ },
+ CONFIGURE => sub {
+ require I::Do::Not::Exist;
+ },
+ PREREQ_FATAL => 1,
+ );
+ };
+
+ is $warnings, '';
+ is $@, <<'END', "PREREQ_FATAL happens before CONFIGURE";
+MakeMaker FATAL: prerequisites not found.
+ I::Do::Not::Exist not installed
+
+Please install these modules first and rerun 'perl Makefile.PL'.
+END
+
+}
Copied: trunk/contrib/perl/lib/ExtUtils/t/prereq_print.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/prereq_print.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/prereq_print.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/prereq_print.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,81 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use strict;
+use Config;
+
+use Test::More;
+
+unless( eval { require Data::Dumper } ) {
+ plan skip_all => 'Data::Dumper not available';
+}
+
+plan tests => 11;
+
+
+use MakeMaker::Test::Utils;
+use MakeMaker::Test::Setup::BFD;
+
+# 'make disttest' sets a bunch of environment variables which interfere
+# with our testing.
+delete @ENV{qw(PREFIX LIB MAKEFLAGS)};
+
+my $Perl = which_perl();
+my $Makefile = makefile_name();
+my $Is_VMS = $^O eq 'VMS';
+
+chdir 't';
+perl_lib;
+
+$| = 1;
+
+ok( setup_recurs(), 'setup' );
+END {
+ ok( chdir File::Spec->updir );
+ ok( teardown_recurs(), 'teardown' );
+}
+
+ok( chdir('Big-Dummy'), "chdir'd to Big-Dummy" ) ||
+ diag("chdir failed: $!");
+
+unlink $Makefile;
+my $prereq_out = run(qq{$Perl Makefile.PL "PREREQ_PRINT=1"});
+ok( !-r $Makefile, "PREREQ_PRINT produces no $Makefile" );
+is( $?, 0, ' exited normally' );
+{
+ package _Prereq::Print;
+ no strict;
+ $PREREQ_PM = undef; # shut up "used only once" warning.
+ eval $prereq_out;
+ ::is_deeply( $PREREQ_PM, { strict => 0 }, 'prereqs dumped' );
+ ::is( $@, '', ' without error' );
+}
+
+
+$prereq_out = run(qq{$Perl Makefile.PL "PRINT_PREREQ=1"});
+ok( !-r $Makefile, "PRINT_PREREQ produces no $Makefile" );
+is( $?, 0, ' exited normally' );
+::like( $prereq_out, qr/^perl\(strict\) \s* >= \s* 0 \s*$/x,
+ 'prereqs dumped' );
+
+
+# Currently a bug.
+#my $prereq_out = run(qq{$Perl Makefile.PL "PREREQ_PRINT=0"});
+#ok( -r $Makefile, "PREREQ_PRINT=0 produces a $Makefile" );
+#is( $?, 0, ' exited normally' );
+#unlink $Makefile;
+
+# Currently a bug.
+#my $prereq_out = run(qq{$Perl Makefile.PL "PRINT_PREREQ=1"});
+#ok( -r $Makefile, "PRINT_PREREQ=0 produces a $Makefile" );
+#is( $?, 0, ' exited normally' );
+#unlink $Makefile;
Copied: trunk/contrib/perl/lib/ExtUtils/t/problems.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/problems.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/problems.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/problems.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,47 @@
+# Test problems in Makefile.PL's and hint files.
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+chdir 't';
+
+use strict;
+use Test::More tests => 6;
+use ExtUtils::MM;
+use MakeMaker::Test::Setup::Problem;
+use TieOut;
+
+my $MM = bless { DIR => ['subdir'] }, 'MM';
+
+ok( setup_recurs(), 'setup' );
+END {
+ ok( chdir File::Spec->updir );
+ ok( teardown_recurs(), 'teardown' );
+}
+
+ok( chdir 'Problem-Module', "chdir'd to Problem-Module" ) ||
+ diag("chdir failed: $!");
+
+
+# Make sure when Makefile.PL's break, they issue a warning.
+# Also make sure Makefile.PL's in subdirs still have '.' in @INC.
+{
+ my $stdout = tie *STDOUT, 'TieOut' or die;
+
+ my $warning = '';
+ local $SIG{__WARN__} = sub { $warning = join '', @_ };
+ eval { $MM->eval_in_subdirs; };
+
+ is( $stdout->read, qq{\@INC has .\n}, 'cwd in @INC' );
+ like( $@,
+ qr{^ERROR from evaluation of .*subdir.*Makefile.PL: YYYAaaaakkk},
+ 'Makefile.PL death in subdir warns' );
+
+ untie *STDOUT;
+}
Copied: trunk/contrib/perl/lib/ExtUtils/t/prompt.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/prompt.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/prompt.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/prompt.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,56 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use strict;
+use Test::More tests => 11;
+use ExtUtils::MakeMaker;
+use TieOut;
+use TieIn;
+
+eval q{
+ prompt();
+};
+like( $@, qr/^Not enough arguments for ExtUtils::MakeMaker::prompt/,
+ 'no args' );
+
+eval {
+ prompt(undef);
+};
+like( $@, qr/^prompt function called without an argument/,
+ 'undef message' );
+
+my $stdout = tie *STDOUT, 'TieOut' or die;
+
+
+$ENV{PERL_MM_USE_DEFAULT} = 1;
+is( prompt("Foo?"), '', 'no default' );
+like( $stdout->read, qr/^Foo\?\s*\n$/, ' question' );
+
+is( prompt("Foo?", undef), '', 'undef default' );
+like( $stdout->read, qr/^Foo\?\s*\n$/, ' question' );
+
+is( prompt("Foo?", 'Bar!'), 'Bar!', 'default' );
+like( $stdout->read, qr/^Foo\? \[Bar!\]\s+Bar!\n$/, ' question' );
+
+
+SKIP: {
+ skip "eof() doesn't honor ties in 5.5.3", 3 if $] < 5.006;
+
+ $ENV{PERL_MM_USE_DEFAULT} = 0;
+ close STDIN;
+ my $stdin = tie *STDIN, 'TieIn' or die;
+ $stdin->write("From STDIN");
+ ok( !-t STDIN, 'STDIN not a tty' );
+
+ is( prompt("Foo?", 'Bar!'), 'From STDIN', 'from STDIN' );
+ like( $stdout->read, qr/^Foo\? \[Bar!\]\s*$/, ' question' );
+}
Copied: trunk/contrib/perl/lib/ExtUtils/t/recurs.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/recurs.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/recurs.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/recurs.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,122 @@
+#!/usr/bin/perl -w
+
+# This tests MakeMaker against recursive builds
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use strict;
+use Config;
+
+use Test::More tests => 26;
+use MakeMaker::Test::Utils;
+use MakeMaker::Test::Setup::Recurs;
+
+# 'make disttest' sets a bunch of environment variables which interfere
+# with our testing.
+delete @ENV{qw(PREFIX LIB MAKEFLAGS)};
+
+my $perl = which_perl();
+my $Is_VMS = $^O eq 'VMS';
+
+chdir('t');
+
+perl_lib;
+
+my $Touch_Time = calibrate_mtime();
+
+$| = 1;
+
+ok( setup_recurs(), 'setup' );
+END {
+ ok( chdir File::Spec->updir );
+ ok( teardown_recurs(), 'teardown' );
+}
+
+ok( chdir('Recurs'), q{chdir'd to Recurs} ) ||
+ diag("chdir failed: $!");
+
+
+# Check recursive Makefile building.
+my @mpl_out = run(qq{$perl Makefile.PL});
+
+cmp_ok( $?, '==', 0, 'Makefile.PL exited with zero' ) ||
+ diag(@mpl_out);
+
+my $makefile = makefile_name();
+
+ok( -e $makefile, 'Makefile written' );
+ok( -e File::Spec->catfile('prj2',$makefile), 'sub Makefile written' );
+
+my $make = make_run();
+
+my $make_out = run("$make");
+is( $?, 0, 'recursive make exited normally' ) || diag $make_out;
+
+ok( chdir File::Spec->updir );
+ok( teardown_recurs(), 'cleaning out recurs' );
+ok( setup_recurs(), ' setting up fresh copy' );
+ok( chdir('Recurs'), q{chdir'd to Recurs} ) ||
+ diag("chdir failed: $!");
+
+
+# Check NORECURS
+ at mpl_out = run(qq{$perl Makefile.PL "NORECURS=1"});
+
+cmp_ok( $?, '==', 0, 'Makefile.PL NORECURS=1 exited with zero' ) ||
+ diag(@mpl_out);
+
+$makefile = makefile_name();
+
+ok( -e $makefile, 'Makefile written' );
+ok( !-e File::Spec->catfile('prj2',$makefile), 'sub Makefile not written' );
+
+$make = make_run();
+
+run("$make");
+is( $?, 0, 'recursive make exited normally' );
+
+
+ok( chdir File::Spec->updir );
+ok( teardown_recurs(), 'cleaning out recurs' );
+ok( setup_recurs(), ' setting up fresh copy' );
+ok( chdir('Recurs'), q{chdir'd to Recurs} ) ||
+ diag("chdir failed: $!");
+
+
+# Check that arguments aren't stomped when they have .. prepended
+# [rt.perl.org 4345]
+ at mpl_out = run(qq{$perl Makefile.PL "INST_SCRIPT=cgi"});
+
+cmp_ok( $?, '==', 0, 'Makefile.PL exited with zero' ) ||
+ diag(@mpl_out);
+
+$makefile = makefile_name();
+my $submakefile = File::Spec->catfile('prj2',$makefile);
+
+ok( -e $makefile, 'Makefile written' );
+ok( -e $submakefile, 'sub Makefile written' );
+
+my $inst_script = File::Spec->catdir(File::Spec->updir, 'cgi');
+ok( open(MAKEFILE, $submakefile) ) || diag("Can't open $submakefile: $!");
+{ local $/;
+ like( <MAKEFILE>, qr/^\s*INST_SCRIPT\s*=\s*\Q$inst_script\E/m,
+ 'prepend .. not stomping WriteMakefile args' )
+}
+close MAKEFILE;
+
+
+{
+ # Quiet "make test" failure noise
+ close *STDERR;
+
+ my $test_out = run("$make test");
+ isnt $?, 0, 'test failure in a subdir causes make to fail';
+}
\ No newline at end of file
Copied: trunk/contrib/perl/lib/ExtUtils/t/revision.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/revision.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/revision.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/revision.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,23 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use Test::More tests => 4;
+
+BEGIN {
+ use_ok 'ExtUtils::MakeMaker';
+ use_ok 'ExtUtils::MM_VMS';
+}
+
+# Why 1? Because a common mistake is for the regex to run in scalar context
+# thus getting the count of captured elements (1) rather than the value of $1
+cmp_ok $ExtUtils::MakeMaker::Revision, '>', 1;
+cmp_ok $ExtUtils::MM_VMS::Revision, '>', 1;
Copied: trunk/contrib/perl/lib/ExtUtils/t/split_command.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/split_command.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/split_command.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/split_command.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,66 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+chdir 't';
+
+use ExtUtils::MM;
+use MakeMaker::Test::Utils;
+
+my $Is_VMS = $^O eq 'VMS';
+my $Is_Win32 = $^O eq 'MSWin32';
+
+use Test::More tests => 7;
+
+my $perl = which_perl;
+my $mm = bless { NAME => "Foo" }, "MM";
+
+# I don't expect anything to have a length shorter than 256 chars.
+cmp_ok( $mm->max_exec_len, '>=', 256, 'max_exec_len' );
+
+my $echo = $mm->oneliner(q{print @ARGV}, ['-l']);
+
+# Force a short command length to make testing split_command easier.
+$mm->{_MAX_EXEC_LEN} = length($echo) + 15;
+is( $mm->max_exec_len, $mm->{_MAX_EXEC_LEN}, ' forced a short max_exec_len' );
+
+my @test_args = qw(foo bar baz yar car har ackapicklerootyjamboree);
+my @cmds = $mm->split_command($echo, @test_args);
+isnt( @cmds, 0 );
+
+ at results = _run(@cmds);
+is( join('', @results), join('', @test_args));
+
+
+my %test_args = ( foo => 42, bar => 23, car => 'har' );
+$even_args = $mm->oneliner(q{print !(@ARGV % 2)});
+ at cmds = $mm->split_command($even_args, %test_args);
+isnt( @cmds, 0 );
+
+ at results = _run(@cmds);
+like( join('', @results ), qr/^1+$/, 'pairs preserved' );
+
+is( $mm->split_command($echo), 0, 'no args means no commands' );
+
+
+sub _run {
+ my @cmds = @_;
+
+ s{\$\(ABSPERLRUN\)}{$perl} foreach @cmds;
+ if( $Is_VMS ) {
+ s{-\n}{} foreach @cmds
+ }
+ elsif( $Is_Win32 ) {
+ s{\\\n}{} foreach @cmds;
+ }
+
+ return map { s/\n+$//; $_ } map { `$_` } @cmds
+}
Copied: trunk/contrib/perl/lib/ExtUtils/t/test_boilerplate.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/test_boilerplate.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/test_boilerplate.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/test_boilerplate.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,26 @@
+#!/usr/bin/perl -w
+
+# <<<Fill in with what this test does.>>>
+# Copy this when writing new tests to avoid forgetting the core boilerplate
+
+# Magic for core
+BEGIN {
+ # Always run in t to unify behavor with core
+ chdir 't' if -d 't';
+
+ # Only use the about to be installed modules
+ if( $ENV{PERL_CORE} ) {
+ @INC = '../lib';
+ }
+}
+
+# Use things from t/lib/
+use lib './lib';
+use strict;
+use ExtUtils::MakeMaker;
+
+use Test::More;
+
+pass("Your test code goes here");
+
+done_testing();
Copied: trunk/contrib/perl/lib/ExtUtils/t/testlib.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/testlib.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/testlib.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/testlib.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,37 @@
+#!/usr/bin/perl -Tw
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ else {
+ # ./lib is there so t/lib can be seen even after we chdir.
+ unshift @INC, 't/lib', './lib';
+ }
+}
+chdir 't';
+
+use Test::More tests => 5;
+
+BEGIN {
+ # non-core tests will have blib in their path. We remove it
+ # and just use the one in lib/.
+ unless( $ENV{PERL_CORE} ) {
+ @INC = grep !/blib/, @INC;
+ unshift @INC, '../lib';
+ }
+}
+
+my @blib_paths = grep /blib/, @INC;
+is( @blib_paths, 0, 'No blib dirs yet in @INC' );
+
+use_ok( 'ExtUtils::testlib' );
+
+ at blib_paths = grep { /blib/ } @INC;
+is( @blib_paths, 2, 'ExtUtils::testlib added two @INC dirs!' );
+ok( !(grep !File::Spec->file_name_is_absolute($_), @blib_paths),
+ ' and theyre absolute');
+
+eval { eval "# @INC"; };
+is( $@, '', '@INC is not tainted' );
Copied: trunk/contrib/perl/lib/ExtUtils/t/writemakefile_args.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/writemakefile_args.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/writemakefile_args.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/writemakefile_args.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,221 @@
+#!/usr/bin/perl -w
+
+# This is a test of the verification of the arguments to
+# WriteMakefile.
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use strict;
+use Test::More tests => 35;
+
+use TieOut;
+use MakeMaker::Test::Utils;
+use MakeMaker::Test::Setup::BFD;
+
+use ExtUtils::MakeMaker;
+
+chdir 't';
+
+perl_lib();
+
+ok( setup_recurs(), 'setup' );
+END {
+ ok( chdir File::Spec->updir );
+ ok( teardown_recurs(), 'teardown' );
+}
+
+ok( chdir 'Big-Dummy', "chdir'd to Big-Dummy" ) ||
+ diag("chdir failed: $!");
+
+{
+ ok( my $stdout = tie *STDOUT, 'TieOut' );
+ my $warnings = '';
+ local $SIG{__WARN__} = sub {
+ $warnings .= join '', @_;
+ };
+
+ my $mm;
+
+ eval {
+ $mm = WriteMakefile(
+ NAME => 'Big::Dummy',
+ VERSION_FROM => 'lib/Big/Dummy.pm',
+ MAN3PODS => ' ', # common mistake
+ );
+ };
+
+ is( $warnings, <<VERIFY );
+WARNING: MAN3PODS takes a HASH reference not a string/number.
+ Please inform the author.
+VERIFY
+
+ $warnings = '';
+ eval {
+ $mm = WriteMakefile(
+ NAME => 'Big::Dummy',
+ VERSION_FROM => 'lib/Big/Dummy.pm',
+ AUTHOR => sub {},
+ );
+ };
+
+ is( $warnings, <<VERIFY );
+WARNING: AUTHOR takes a string/number not a CODE reference.
+ Please inform the author.
+VERIFY
+
+ # LIBS accepts *both* a string or an array ref. The first cut of
+ # our verification did not take this into account.
+ $warnings = '';
+ $mm = WriteMakefile(
+ NAME => 'Big::Dummy',
+ VERSION_FROM => 'lib/Big/Dummy.pm',
+ LIBS => '-lwibble -lwobble',
+ );
+
+ # We'll get warnings about the bogus libs, that's ok.
+ unlike( $warnings, qr/WARNING: .* takes/ );
+ is_deeply( $mm->{LIBS}, ['-lwibble -lwobble'] );
+
+ $warnings = '';
+ $mm = WriteMakefile(
+ NAME => 'Big::Dummy',
+ VERSION_FROM => 'lib/Big/Dummy.pm',
+ LIBS => ['-lwibble', '-lwobble'],
+ );
+
+ # We'll get warnings about the bogus libs, that's ok.
+ unlike( $warnings, qr/WARNING: .* takes/ );
+ is_deeply( $mm->{LIBS}, ['-lwibble', '-lwobble'] );
+
+ $warnings = '';
+ eval {
+ $mm = WriteMakefile(
+ NAME => 'Big::Dummy',
+ VERSION_FROM => 'lib/Big/Dummy.pm',
+ LIBS => { wibble => "wobble" },
+ );
+ };
+
+ # We'll get warnings about the bogus libs, that's ok.
+ like( $warnings, qr{^WARNING: LIBS takes a ARRAY reference or string/number not a HASH reference}m );
+
+
+ $warnings = '';
+ $mm = WriteMakefile(
+ NAME => 'Big::Dummy',
+ WIBBLE => 'something',
+ wump => { foo => 42 },
+ );
+
+ like( $warnings, qr{^WARNING: WIBBLE is not a known parameter.\n}m );
+ like( $warnings, qr{^WARNING: wump is not a known parameter.\n}m );
+
+ is( $mm->{WIBBLE}, 'something' );
+ is_deeply( $mm->{wump}, { foo => 42 } );
+
+
+ # Test VERSION
+ $warnings = '';
+ eval {
+ $mm = WriteMakefile(
+ NAME => 'Big::Dummy',
+ VERSION => [1,2,3],
+ );
+ };
+ like( $warnings, qr{^WARNING: VERSION takes a version object or string/number} );
+
+ $warnings = '';
+ eval {
+ $mm = WriteMakefile(
+ NAME => 'Big::Dummy',
+ VERSION => 1.002_003,
+ );
+ };
+ is( $warnings, '' );
+ is( $mm->{VERSION}, '1.002003' );
+
+ $warnings = '';
+ eval {
+ $mm = WriteMakefile(
+ NAME => 'Big::Dummy',
+ VERSION => '1.002_003',
+ );
+ };
+ is( $warnings, '' );
+ is( $mm->{VERSION}, '1.002_003' );
+
+
+ $warnings = '';
+ eval {
+ $mm = WriteMakefile(
+ NAME => 'Big::Dummy',
+ VERSION => bless {}, "Some::Class",
+ );
+ };
+ like( $warnings, '/^WARNING: VERSION takes a version object or string/number not a Some::Class object/' );
+
+
+ SKIP: {
+ skip("Can't test version objects", 8) unless eval { require version };
+ version->import;
+
+ my $version = version->new("1.2.3");
+ $warnings = '';
+ ok eval {
+ $mm = WriteMakefile(
+ NAME => 'Big::Dummy',
+ VERSION => $version,
+ );
+ } || diag $@;
+ is( $warnings, '' );
+ isa_ok( $mm->{VERSION}, 'version' );
+ is( $mm->{VERSION}, $version );
+
+ $warnings = '';
+ $version = qv('1.2.3');
+ ok eval {
+ $mm = WriteMakefile(
+ NAME => 'Big::Dummy',
+ VERSION => $version,
+ );
+ } || diag $@;
+ is( $warnings, '' );
+ isa_ok( $mm->{VERSION}, 'version' );
+ is( $mm->{VERSION}, $version );
+ }
+
+
+ # DISTNAME
+ $warnings = '';
+ eval {
+ $mm = WriteMakefile(
+ NAME => 'Big::Dummy',
+ VERSION => '1.00',
+ DISTNAME => "Hooballa",
+ );
+ };
+ is( $warnings, '' );
+ is( $mm->{DISTNAME}, "Hooballa" );
+ is( $mm->{DISTVNAME}, $Is_VMS ? "Hooballa-1_00" : "Hooballa-1.00" );
+
+
+ # DISTVNAME (rt.cpan.org 43217)
+ $warnings = '';
+ eval {
+ $mm = WriteMakefile(
+ NAME => 'Big::Dummy',
+ VERSION => 1.00,
+ DISTVNAME => "Hooballoo",
+ );
+ };
+ is( $warnings, '' );
+ is( $mm->{DISTVNAME}, 'Hooballoo' );
+}
Copied: trunk/contrib/perl/lib/ExtUtils/t/xs.t (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/t/xs.t)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/t/xs.t (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/t/xs.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,64 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ('../lib', 'lib/');
+ }
+ else {
+ unshift @INC, 't/lib/';
+ }
+}
+chdir 't';
+
+use strict;
+
+use Test::More;
+use MakeMaker::Test::Utils;
+use MakeMaker::Test::Setup::XS;
+use File::Find;
+use File::Spec;
+use File::Path;
+
+my $Skipped = 0;
+if( have_compiler() ) {
+ plan tests => 5;
+}
+else {
+ $Skipped = 1;
+ plan skip_all => "ExtUtils::CBuilder not installed or couldn't find a compiler";
+}
+
+my $Is_VMS = $^O eq 'VMS';
+my $perl = which_perl();
+
+chdir 't';
+
+perl_lib;
+
+$| = 1;
+
+ok( setup_xs(), 'setup' );
+END {
+ unless( $Skipped ) {
+ chdir File::Spec->updir or die;
+ teardown_xs(), 'teardown' or die;
+ }
+}
+
+ok( chdir('XS-Test'), "chdir'd to XS-Test" ) ||
+ diag("chdir failed: $!");
+
+my @mpl_out = run(qq{$perl Makefile.PL});
+
+cmp_ok( $?, '==', 0, 'Makefile.PL exited with zero' ) ||
+ diag(@mpl_out);
+
+my $make = make_run();
+my $make_out = run("$make");
+is( $?, 0, ' make exited normally' ) ||
+ diag $make_out;
+
+my $test_out = run("$make");
+is( $?, 0, ' make test exited normally' ) ||
+ diag $test_out;
Copied: trunk/contrib/perl/lib/ExtUtils/testlib.pm (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/testlib.pm)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/testlib.pm (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/testlib.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,41 @@
+package ExtUtils::testlib;
+
+use strict;
+use warnings;
+
+our $VERSION = 6.55_02;
+
+use Cwd;
+use File::Spec;
+
+# So the tests can chdir around and not break @INC.
+# We use getcwd() because otherwise rel2abs will blow up under taint
+# mode pre-5.8. We detaint is so @INC won't be tainted. This is
+# no worse, and probably better, than just shoving an untainted,
+# relative "blib/lib" onto @INC.
+my $cwd;
+BEGIN {
+ ($cwd) = getcwd() =~ /(.*)/;
+}
+use lib map { File::Spec->rel2abs($_, $cwd) } qw(blib/arch blib/lib);
+1;
+__END__
+
+=head1 NAME
+
+ExtUtils::testlib - add blib/* directories to @INC
+
+=head1 SYNOPSIS
+
+ use ExtUtils::testlib;
+
+=head1 DESCRIPTION
+
+After an extension has been built and before it is installed it may be
+desirable to test it bypassing C<make test>. By adding
+
+ use ExtUtils::testlib;
+
+to a test program the intermediate directories used by C<make> are
+added to @INC.
+
Modified: trunk/contrib/perl/lib/ExtUtils/typemap
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/typemap 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/ExtUtils/typemap 2013-12-02 21:26:09 UTC (rev 6439)
@@ -24,10 +24,16 @@
void * T_PTR
Time_t * T_PV
SV * T_SV
+
+# These are the backwards-compatibility AV*/HV* typemaps that
+# do not decrement refcounts. Locally override with
+# "AV* T_AVREF_REFCOUNT_FIXED", "HV* T_HVREF_REFCOUNT_FIXED",
+# "CV* T_CVREF_REFCOUNT_FIXED", "SVREF T_SVREF_REFCOUNT_FIXED",
+# to get the fixed versions.
SVREF T_SVREF
+CV * T_CVREF
AV * T_AVREF
HV * T_HVREF
-CV * T_CVREF
IV T_IV
UV T_UV
@@ -70,6 +76,19 @@
\"$var\");
}
} STMT_END
+T_SVREF_REFCOUNT_FIXED
+ STMT_START {
+ SV* const xsub_tmp_sv = $arg;
+ SvGETMAGIC(xsub_tmp_sv);
+ if (SvROK(xsub_tmp_sv)){
+ $var = SvRV(xsub_tmp_sv);
+ }
+ else{
+ Perl_croak(aTHX_ \"%s: %s is not a reference\",
+ ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
+ \"$var\");
+ }
+ } STMT_END
T_AVREF
STMT_START {
SV* const xsub_tmp_sv = $arg;
@@ -83,6 +102,19 @@
\"$var\");
}
} STMT_END
+T_AVREF_REFCOUNT_FIXED
+ STMT_START {
+ SV* const xsub_tmp_sv = $arg;
+ SvGETMAGIC(xsub_tmp_sv);
+ if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVAV){
+ $var = (AV*)SvRV(xsub_tmp_sv);
+ }
+ else{
+ Perl_croak(aTHX_ \"%s: %s is not an ARRAY reference\",
+ ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
+ \"$var\");
+ }
+ } STMT_END
T_HVREF
STMT_START {
SV* const xsub_tmp_sv = $arg;
@@ -96,19 +128,45 @@
\"$var\");
}
} STMT_END
-T_CVREF
+T_HVREF_REFCOUNT_FIXED
STMT_START {
SV* const xsub_tmp_sv = $arg;
SvGETMAGIC(xsub_tmp_sv);
- if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVCV){
- $var = (CV*)SvRV(xsub_tmp_sv);
+ if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVHV){
+ $var = (HV*)SvRV(xsub_tmp_sv);
}
else{
+ Perl_croak(aTHX_ \"%s: %s is not a HASH reference\",
+ ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
+ \"$var\");
+ }
+ } STMT_END
+T_CVREF
+ STMT_START {
+ HV *st;
+ GV *gvp;
+ SV * const xsub_tmp_sv = $arg;
+ SvGETMAGIC(xsub_tmp_sv);
+ $var = sv_2cv(xsub_tmp_sv, &st, &gvp, 0);
+ if (!$var) {
Perl_croak(aTHX_ \"%s: %s is not a CODE reference\",
${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
\"$var\");
}
} STMT_END
+T_CVREF_REFCOUNT_FIXED
+ STMT_START {
+ HV *st;
+ GV *gvp;
+ SV * const xsub_tmp_sv = $arg;
+ SvGETMAGIC(xsub_tmp_sv);
+ $var = sv_2cv(xsub_tmp_sv, &st, &gvp, 0);
+ if (!$var) {
+ Perl_croak(aTHX_ \"%s: %s is not a CODE reference\",
+ ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
+ \"$var\");
+ }
+ } STMT_END
T_SYSRET
$var NOT IMPLEMENTED
T_UV
@@ -217,8 +275,6 @@
$var = XS_unpack_$ntype($arg)
T_PACKEDARRAY
$var = XS_unpack_$ntype($arg)
-T_CALLBACK
- $var = make_perl_cb_$type($arg)
T_ARRAY
U32 ix_$var = $argoff;
$var = $ntype(items -= $argoff);
@@ -242,12 +298,20 @@
$arg = $var;
T_SVREF
$arg = newRV((SV*)$var);
+T_SVREF_REFCOUNT_FIXED
+ $arg = newRV_noinc((SV*)$var);
T_AVREF
$arg = newRV((SV*)$var);
+T_AVREF_REFCOUNT_FIXED
+ $arg = newRV_noinc((SV*)$var);
T_HVREF
$arg = newRV((SV*)$var);
+T_HVREF_REFCOUNT_FIXED
+ $arg = newRV_noinc((SV*)$var);
T_CVREF
$arg = newRV((SV*)$var);
+T_CVREF_REFCOUNT_FIXED
+ $arg = newRV_noinc((SV*)$var);
T_IV
sv_setiv($arg, (IV)$var);
T_UV
@@ -264,7 +328,7 @@
T_ENUM
sv_setiv($arg, (IV)$var);
T_BOOL
- $arg = boolSV($var);
+ ${"$var" eq "RETVAL" ? \"$arg = boolSV($var);" : \"sv_setsv($arg, boolSV($var));"}
T_U_INT
sv_setuv($arg, (UV)$var);
T_SHORT
@@ -311,11 +375,6 @@
XS_pack_$ntype($arg, $var);
T_PACKEDARRAY
XS_pack_$ntype($arg, $var, count_$ntype);
-T_DATAUNIT
- sv_setpvn($arg, $var.chp(), $var.size());
-T_CALLBACK
- sv_setpvn($arg, $var.context.value().chp(),
- $var.context.value().size());
T_ARRAY
{
U32 ix_$var;
Property changes on: trunk/contrib/perl/lib/ExtUtils/typemap
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/lib/ExtUtils/xsubpp (from rev 6437, vendor/perl/5.18.1/lib/ExtUtils/xsubpp)
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/xsubpp (rev 0)
+++ trunk/contrib/perl/lib/ExtUtils/xsubpp 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,156 @@
+#!./miniperl
+
+require 5.002;
+use ExtUtils::ParseXS qw(process_file);
+use Getopt::Long;
+
+my %args = ();
+
+my $usage = "Usage: xsubpp [-v] [-csuffix csuffix] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-nooptimize] [-noinout] [-noargtypes] [-s pattern] [-typemap typemap]... file.xs\n";
+
+Getopt::Long::Configure qw(no_auto_abbrev no_ignore_case);
+
+ at ARGV = grep {$_ ne '-C++'} @ARGV; # Allow -C++ for backward compatibility
+GetOptions(\%args, qw(hiertype!
+ prototypes!
+ versioncheck!
+ linenumbers!
+ optimize!
+ inout!
+ argtypes!
+ object_capi!
+ except!
+ v
+ typemap=s@
+ output=s
+ s=s
+ csuffix=s
+ ))
+ or die $usage;
+
+if ($args{v}) {
+ print "xsubpp version $ExtUtils::ParseXS::VERSION\n";
+ exit;
+}
+
+ at ARGV == 1 or die $usage;
+
+$args{filename} = shift @ARGV;
+
+process_file(%args);
+exit( ExtUtils::ParseXS::errors() ? 1 : 0 );
+
+__END__
+
+=head1 NAME
+
+xsubpp - compiler to convert Perl XS code into C code
+
+=head1 SYNOPSIS
+
+B<xsubpp> [B<-v>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-nolinenumbers>] [B<-nooptimize>] [B<-typemap typemap>] [B<-output filename>]... file.xs
+
+=head1 DESCRIPTION
+
+This compiler is typically run by the makefiles created by L<ExtUtils::MakeMaker>.
+
+I<xsubpp> will compile XS code into C code by embedding the constructs
+necessary to let C functions manipulate Perl values and creates the glue
+necessary to let Perl access those functions. The compiler uses typemaps to
+determine how to map C function parameters and variables to Perl values.
+
+The compiler will search for typemap files called I<typemap>. It will use
+the following search path to find default typemaps, with the rightmost
+typemap taking precedence.
+
+ ../../../typemap:../../typemap:../typemap:typemap
+
+It will also use a default typemap installed as C<ExtUtils::typemap>.
+
+=head1 OPTIONS
+
+Note that the C<XSOPT> MakeMaker option may be used to add these options to
+any makefiles generated by MakeMaker.
+
+=over 5
+
+=item B<-hiertype>
+
+Retains '::' in type names so that C++ hierarchical types can be mapped.
+
+=item B<-except>
+
+Adds exception handling stubs to the C code.
+
+=item B<-typemap typemap>
+
+Indicates that a user-supplied typemap should take precedence over the
+default typemaps. This option may be used multiple times, with the last
+typemap having the highest precedence.
+
+=item B<-output filename>
+
+Specifies the name of the output file to generate. If no file is
+specified, output will be written to standard output.
+
+=item B<-v>
+
+Prints the I<xsubpp> version number to standard output, then exits.
+
+=item B<-prototypes>
+
+By default I<xsubpp> will not automatically generate prototype code for
+all xsubs. This flag will enable prototypes.
+
+=item B<-noversioncheck>
+
+Disables the run time test that determines if the object file (derived
+from the C<.xs> file) and the C<.pm> files have the same version
+number.
+
+=item B<-nolinenumbers>
+
+Prevents the inclusion of `#line' directives in the output.
+
+=item B<-nooptimize>
+
+Disables certain optimizations. The only optimization that is currently
+affected is the use of I<target>s by the output C code (see L<perlguts>).
+This may significantly slow down the generated code, but this is the way
+B<xsubpp> of 5.005 and earlier operated.
+
+=item B<-noinout>
+
+Disable recognition of C<IN>, C<OUT_LIST> and C<INOUT_LIST> declarations.
+
+=item B<-noargtypes>
+
+Disable recognition of ANSI-like descriptions of function signature.
+
+=item B<-C++>
+
+Currently doesn't do anything at all. This flag has been a no-op for
+many versions of perl, at least as far back as perl5.003_07. It's
+allowed here for backwards compatibility.
+
+=back
+
+=head1 ENVIRONMENT
+
+No environment variables are used.
+
+=head1 AUTHOR
+
+Originally by Larry Wall. Turned into the C<ExtUtils::ParseXS> module
+by Ken Williams.
+
+=head1 MODIFICATION HISTORY
+
+See the file F<Changes>.
+
+=head1 SEE ALSO
+
+perl(1), perlxs(1), perlxstut(1), ExtUtils::ParseXS
+
+=cut
+
Copied: trunk/contrib/perl/lib/Fatal.pm (from rev 6437, vendor/perl/5.18.1/lib/Fatal.pm)
===================================================================
--- trunk/contrib/perl/lib/Fatal.pm (rev 0)
+++ trunk/contrib/perl/lib/Fatal.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,1374 @@
+package Fatal;
+
+use 5.008; # 5.8.x needed for autodie
+use Carp;
+use strict;
+use warnings;
+use Tie::RefHash; # To cache subroutine refs
+
+use constant PERL510 => ( $] >= 5.010 );
+
+use constant LEXICAL_TAG => q{:lexical};
+use constant VOID_TAG => q{:void};
+use constant INSIST_TAG => q{!};
+
+use constant ERROR_NOARGS => 'Cannot use lexical %s with no arguments';
+use constant ERROR_VOID_LEX => VOID_TAG.' cannot be used with lexical scope';
+use constant ERROR_LEX_FIRST => LEXICAL_TAG.' must be used as first argument';
+use constant ERROR_NO_LEX => "no %s can only start with ".LEXICAL_TAG;
+use constant ERROR_BADNAME => "Bad subroutine name for %s: %s";
+use constant ERROR_NOTSUB => "%s is not a Perl subroutine";
+use constant ERROR_NOT_BUILT => "%s is neither a builtin, nor a Perl subroutine";
+use constant ERROR_NOHINTS => "No user hints defined for %s";
+
+use constant ERROR_CANT_OVERRIDE => "Cannot make the non-overridable builtin %s fatal";
+
+use constant ERROR_NO_IPC_SYS_SIMPLE => "IPC::System::Simple required for Fatalised/autodying system()";
+
+use constant ERROR_IPC_SYS_SIMPLE_OLD => "IPC::System::Simple version %f required for Fatalised/autodying system(). We only have version %f";
+
+use constant ERROR_AUTODIE_CONFLICT => q{"no autodie '%s'" is not allowed while "use Fatal '%s'" is in effect};
+
+use constant ERROR_FATAL_CONFLICT => q{"use Fatal '%s'" is not allowed while "no autodie '%s'" is in effect};
+
+use constant ERROR_58_HINTS => q{Non-subroutine %s hints for %s are not supported under Perl 5.8.x};
+
+# Older versions of IPC::System::Simple don't support all the
+# features we need.
+
+use constant MIN_IPC_SYS_SIMPLE_VER => 0.12;
+
+# All the Fatal/autodie modules share the same version number.
+our $VERSION = '2.06_01';
+
+our $Debug ||= 0;
+
+# EWOULDBLOCK values for systems that don't supply their own.
+# Even though this is defined with our, that's to help our
+# test code. Please don't rely upon this variable existing in
+# the future.
+
+our %_EWOULDBLOCK = (
+ MSWin32 => 33,
+);
+
+# We have some tags that can be passed in for use with import.
+# These are all assumed to be CORE::
+
+my %TAGS = (
+ ':io' => [qw(:dbm :file :filesys :ipc :socket
+ read seek sysread syswrite sysseek )],
+ ':dbm' => [qw(dbmopen dbmclose)],
+ ':file' => [qw(open close flock sysopen fcntl fileno binmode
+ ioctl truncate)],
+ ':filesys' => [qw(opendir closedir chdir link unlink rename mkdir
+ symlink rmdir readlink umask)],
+ ':ipc' => [qw(:msg :semaphore :shm pipe)],
+ ':msg' => [qw(msgctl msgget msgrcv msgsnd)],
+ ':threads' => [qw(fork)],
+ ':semaphore'=>[qw(semctl semget semop)],
+ ':shm' => [qw(shmctl shmget shmread)],
+ ':system' => [qw(system exec)],
+
+ # Can we use qw(getpeername getsockname)? What do they do on failure?
+ # TODO - Can socket return false?
+ ':socket' => [qw(accept bind connect getsockopt listen recv send
+ setsockopt shutdown socketpair)],
+
+ # Our defaults don't include system(), because it depends upon
+ # an optional module, and it breaks the exotic form.
+ #
+ # This *may* change in the future. I'd love IPC::System::Simple
+ # to be a dependency rather than a recommendation, and hence for
+ # system() to be autodying by default.
+
+ ':default' => [qw(:io :threads)],
+
+ # Version specific tags. These allow someone to specify
+ # use autodie qw(:1.994) and know exactly what they'll get.
+
+ ':1.994' => [qw(:default)],
+ ':1.995' => [qw(:default)],
+ ':1.996' => [qw(:default)],
+ ':1.997' => [qw(:default)],
+ ':1.998' => [qw(:default)],
+ ':1.999' => [qw(:default)],
+ ':1.999_01' => [qw(:default)],
+ ':2.00' => [qw(:default)],
+ ':2.01' => [qw(:default)],
+ ':2.02' => [qw(:default)],
+ ':2.03' => [qw(:default)],
+ ':2.04' => [qw(:default)],
+ ':2.05' => [qw(:default)],
+ ':2.06' => [qw(:default)],
+ ':2.06_01' => [qw(:default)],
+);
+
+$TAGS{':all'} = [ keys %TAGS ];
+
+# This hash contains subroutines for which we should
+# subroutine() // die() rather than subroutine() || die()
+
+my %Use_defined_or;
+
+# CORE::open returns undef on failure. It can legitimately return
+# 0 on success, eg: open(my $fh, '-|') || exec(...);
+
+ at Use_defined_or{qw(
+ CORE::fork
+ CORE::recv
+ CORE::send
+ CORE::open
+ CORE::fileno
+ CORE::read
+ CORE::readlink
+ CORE::sysread
+ CORE::syswrite
+ CORE::sysseek
+ CORE::umask
+)} = ();
+
+# Cached_fatalised_sub caches the various versions of our
+# fatalised subs as they're produced. This means we don't
+# have to build our own replacement of CORE::open and friends
+# for every single package that wants to use them.
+
+my %Cached_fatalised_sub = ();
+
+# Every time we're called with package scope, we record the subroutine
+# (including package or CORE::) in %Package_Fatal. This allows us
+# to detect illegal combinations of autodie and Fatal, and makes sure
+# we don't accidently make a Fatal function autodying (which isn't
+# very useful).
+
+my %Package_Fatal = ();
+
+# The first time we're called with a user-sub, we cache it here.
+# In the case of a "no autodie ..." we put back the cached copy.
+
+my %Original_user_sub = ();
+
+# Is_fatalised_sub simply records a big map of fatalised subroutine
+# refs. It means we can avoid repeating work, or fatalising something
+# we've already processed.
+
+my %Is_fatalised_sub = ();
+tie %Is_fatalised_sub, 'Tie::RefHash';
+
+# We use our package in a few hash-keys. Having it in a scalar is
+# convenient. The "guard $PACKAGE" string is used as a key when
+# setting up lexical guards.
+
+my $PACKAGE = __PACKAGE__;
+my $PACKAGE_GUARD = "guard $PACKAGE";
+my $NO_PACKAGE = "no $PACKAGE"; # Used to detect 'no autodie'
+
+# Here's where all the magic happens when someone write 'use Fatal'
+# or 'use autodie'.
+
+sub import {
+ my $class = shift(@_);
+ my $void = 0;
+ my $lexical = 0;
+ my $insist_hints = 0;
+
+ my ($pkg, $filename) = caller();
+
+ @_ or return; # 'use Fatal' is a no-op.
+
+ # If we see the :lexical flag, then _all_ arguments are
+ # changed lexically
+
+ if ($_[0] eq LEXICAL_TAG) {
+ $lexical = 1;
+ shift @_;
+
+ # If we see no arguments and :lexical, we assume they
+ # wanted ':default'.
+
+ if (@_ == 0) {
+ push(@_, ':default');
+ }
+
+ # Don't allow :lexical with :void, it's needlessly confusing.
+ if ( grep { $_ eq VOID_TAG } @_ ) {
+ croak(ERROR_VOID_LEX);
+ }
+ }
+
+ if ( grep { $_ eq LEXICAL_TAG } @_ ) {
+ # If we see the lexical tag as the non-first argument, complain.
+ croak(ERROR_LEX_FIRST);
+ }
+
+ my @fatalise_these = @_;
+
+ # Thiese subs will get unloaded at the end of lexical scope.
+ my %unload_later;
+
+ # This hash helps us track if we've alredy done work.
+ my %done_this;
+
+ # NB: we're using while/shift rather than foreach, since
+ # we'll be modifying the array as we walk through it.
+
+ while (my $func = shift @fatalise_these) {
+
+ if ($func eq VOID_TAG) {
+
+ # When we see :void, set the void flag.
+ $void = 1;
+
+ } elsif ($func eq INSIST_TAG) {
+
+ $insist_hints = 1;
+
+ } elsif (exists $TAGS{$func}) {
+
+ # When it's a tag, expand it.
+ push(@fatalise_these, @{ $TAGS{$func} });
+
+ } else {
+
+ # Otherwise, fatalise it.
+
+ # Check to see if there's an insist flag at the front.
+ # If so, remove it, and insist we have hints for this sub.
+ my $insist_this;
+
+ if ($func =~ s/^!//) {
+ $insist_this = 1;
+ }
+
+ # TODO: Even if we've already fatalised, we should
+ # check we've done it with hints (if $insist_hints).
+
+ # If we've already made something fatal this call,
+ # then don't do it twice.
+
+ next if $done_this{$func};
+
+ # We're going to make a subroutine fatalistic.
+ # However if we're being invoked with 'use Fatal qw(x)'
+ # and we've already been called with 'no autodie qw(x)'
+ # in the same scope, we consider this to be an error.
+ # Mixing Fatal and autodie effects was considered to be
+ # needlessly confusing on p5p.
+
+ my $sub = $func;
+ $sub = "${pkg}::$sub" unless $sub =~ /::/;
+
+ # If we're being called as Fatal, and we've previously
+ # had a 'no X' in scope for the subroutine, then complain
+ # bitterly.
+
+ if (! $lexical and $^H{$NO_PACKAGE}{$sub}) {
+ croak(sprintf(ERROR_FATAL_CONFLICT, $func, $func));
+ }
+
+ # We're not being used in a confusing way, so make
+ # the sub fatal. Note that _make_fatal returns the
+ # old (original) version of the sub, or undef for
+ # built-ins.
+
+ my $sub_ref = $class->_make_fatal(
+ $func, $pkg, $void, $lexical, $filename,
+ ( $insist_this || $insist_hints )
+ );
+
+ $done_this{$func}++;
+
+ $Original_user_sub{$sub} ||= $sub_ref;
+
+ # If we're making lexical changes, we need to arrange
+ # for them to be cleaned at the end of our scope, so
+ # record them here.
+
+ $unload_later{$func} = $sub_ref if $lexical;
+ }
+ }
+
+ if ($lexical) {
+
+ # Dark magic to have autodie work under 5.8
+ # Copied from namespace::clean, that copied it from
+ # autobox, that found it on an ancient scroll written
+ # in blood.
+
+ # This magic bit causes %^H to be lexically scoped.
+
+ $^H |= 0x020000;
+
+ # Our package guard gets invoked when we leave our lexical
+ # scope.
+
+ push(@ { $^H{$PACKAGE_GUARD} }, autodie::Scope::Guard->new(sub {
+ $class->_install_subs($pkg, \%unload_later);
+ }));
+
+ }
+
+ return;
+
+}
+
+# The code here is originally lifted from namespace::clean,
+# by Robert "phaylon" Sedlacek.
+#
+# It's been redesigned after feedback from ikegami on perlmonks.
+# See http://perlmonks.org/?node_id=693338 . Ikegami rocks.
+#
+# Given a package, and hash of (subname => subref) pairs,
+# we install the given subroutines into the package. If
+# a subref is undef, the subroutine is removed. Otherwise
+# it replaces any existing subs which were already there.
+
+sub _install_subs {
+ my ($class, $pkg, $subs_to_reinstate) = @_;
+
+ my $pkg_sym = "${pkg}::";
+
+ while(my ($sub_name, $sub_ref) = each %$subs_to_reinstate) {
+
+ my $full_path = $pkg_sym.$sub_name;
+
+ # Copy symbols across to temp area.
+
+ no strict 'refs'; ## no critic
+
+ local *__tmp = *{ $full_path };
+
+ # Nuke the old glob.
+ { no strict; delete $pkg_sym->{$sub_name}; } ## no critic
+
+ # Copy innocent bystanders back. Note that we lose
+ # formats; it seems that Perl versions up to 5.10.0
+ # have a bug which causes copying formats to end up in
+ # the scalar slot. Thanks to Ben Morrow for spotting this.
+
+ foreach my $slot (qw( SCALAR ARRAY HASH IO ) ) {
+ next unless defined *__tmp{ $slot };
+ *{ $full_path } = *__tmp{ $slot };
+ }
+
+ # Put back the old sub (if there was one).
+
+ if ($sub_ref) {
+
+ no strict; ## no critic
+ *{ $pkg_sym . $sub_name } = $sub_ref;
+ }
+ }
+
+ return;
+}
+
+sub unimport {
+ my $class = shift;
+
+ # Calling "no Fatal" must start with ":lexical"
+ if ($_[0] ne LEXICAL_TAG) {
+ croak(sprintf(ERROR_NO_LEX,$class));
+ }
+
+ shift @_; # Remove :lexical
+
+ my $pkg = (caller)[0];
+
+ # If we've been called with arguments, then the developer
+ # has explicitly stated 'no autodie qw(blah)',
+ # in which case, we disable Fatalistic behaviour for 'blah'.
+
+ my @unimport_these = @_ ? @_ : ':all';
+
+ while (my $symbol = shift @unimport_these) {
+
+ if ($symbol =~ /^:/) {
+
+ # Looks like a tag! Expand it!
+ push(@unimport_these, @{ $TAGS{$symbol} });
+
+ next;
+ }
+
+ my $sub = $symbol;
+ $sub = "${pkg}::$sub" unless $sub =~ /::/;
+
+ # If 'blah' was already enabled with Fatal (which has package
+ # scope) then, this is considered an error.
+
+ if (exists $Package_Fatal{$sub}) {
+ croak(sprintf(ERROR_AUTODIE_CONFLICT,$symbol,$symbol));
+ }
+
+ # Record 'no autodie qw($sub)' as being in effect.
+ # This is to catch conflicting semantics elsewhere
+ # (eg, mixing Fatal with no autodie)
+
+ $^H{$NO_PACKAGE}{$sub} = 1;
+
+ if (my $original_sub = $Original_user_sub{$sub}) {
+ # Hey, we've got an original one of these, put it back.
+ $class->_install_subs($pkg, { $symbol => $original_sub });
+ next;
+ }
+
+ # We don't have an original copy of the sub, on the assumption
+ # it's core (or doesn't exist), we'll just nuke it.
+
+ $class->_install_subs($pkg,{ $symbol => undef });
+
+ }
+
+ return;
+
+}
+
+# TODO - This is rather terribly inefficient right now.
+
+# NB: Perl::Critic's dump-autodie-tag-contents depends upon this
+# continuing to work.
+
+{
+ my %tag_cache;
+
+ sub _expand_tag {
+ my ($class, $tag) = @_;
+
+ if (my $cached = $tag_cache{$tag}) {
+ return $cached;
+ }
+
+ if (not exists $TAGS{$tag}) {
+ croak "Invalid exception class $tag";
+ }
+
+ my @to_process = @{$TAGS{$tag}};
+
+ my @taglist = ();
+
+ while (my $item = shift @to_process) {
+ if ($item =~ /^:/) {
+ push(@to_process, @{$TAGS{$item}} );
+ } else {
+ push(@taglist, "CORE::$item");
+ }
+ }
+
+ $tag_cache{$tag} = \@taglist;
+
+ return \@taglist;
+
+ }
+
+}
+
+# This code is from the original Fatal. It scares me.
+# It is 100% compatible with the 5.10.0 Fatal module, right down
+# to the scary 'XXXX' comment. ;)
+
+sub fill_protos {
+ my $proto = shift;
+ my ($n, $isref, @out, @out1, $seen_semi) = -1;
+ while ($proto =~ /\S/) {
+ $n++;
+ push(@out1,[$n, at out]) if $seen_semi;
+ push(@out, $1 . "{\$_[$n]}"), next if $proto =~ s/^\s*\\([\@%\$\&])//;
+ push(@out, "\$_[$n]"), next if $proto =~ s/^\s*([_*\$&])//;
+ push(@out, "\@_[$n..\$#_]"), last if $proto =~ s/^\s*(;\s*)?\@//;
+ $seen_semi = 1, $n--, next if $proto =~ s/^\s*;//; # XXXX ????
+ die "Internal error: Unknown prototype letters: \"$proto\"";
+ }
+ push(@out1,[$n+1, at out]);
+ return @out1;
+}
+
+# This is a backwards compatible version of _write_invocation. It's
+# recommended you don't use it.
+
+sub write_invocation {
+ my ($core, $call, $name, $void, @args) = @_;
+
+ return Fatal->_write_invocation(
+ $core, $call, $name, $void,
+ 0, # Lexical flag
+ undef, # Sub, unused in legacy mode
+ undef, # Subref, unused in legacy mode.
+ @args
+ );
+}
+
+# This version of _write_invocation is used internally. It's not
+# recommended you call it from external code, as the interface WILL
+# change in the future.
+
+sub _write_invocation {
+
+ my ($class, $core, $call, $name, $void, $lexical, $sub, $sref, @argvs) = @_;
+
+ if (@argvs == 1) { # No optional arguments
+
+ my @argv = @{$argvs[0]};
+ shift @argv;
+
+ return $class->_one_invocation($core,$call,$name,$void,$sub,! $lexical, $sref, @argv);
+
+ } else {
+ my $else = "\t";
+ my (@out, @argv, $n);
+ while (@argvs) {
+ @argv = @{shift @argvs};
+ $n = shift @argv;
+
+ push @out, "${else}if (\@_ == $n) {\n";
+ $else = "\t} els";
+
+ push @out, $class->_one_invocation($core,$call,$name,$void,$sub,! $lexical, $sref, @argv);
+ }
+ push @out, qq[
+ }
+ die "Internal error: $name(\@_): Do not expect to get ", scalar(\@_), " arguments";
+ ];
+
+ return join '', @out;
+ }
+}
+
+
+# This is a slim interface to ensure backward compatibility with
+# anyone doing very foolish things with old versions of Fatal.
+
+sub one_invocation {
+ my ($core, $call, $name, $void, @argv) = @_;
+
+ return Fatal->_one_invocation(
+ $core, $call, $name, $void,
+ undef, # Sub. Unused in back-compat mode.
+ 1, # Back-compat flag
+ undef, # Subref, unused in back-compat mode.
+ @argv
+ );
+
+}
+
+# This is the internal interface that generates code.
+# NOTE: This interface WILL change in the future. Please do not
+# call this subroutine directly.
+
+# TODO: Whatever's calling this code has already looked up hints. Pass
+# them in, rather than look them up a second time.
+
+sub _one_invocation {
+ my ($class, $core, $call, $name, $void, $sub, $back_compat, $sref, @argv) = @_;
+
+
+ # If someone is calling us directly (a child class perhaps?) then
+ # they could try to mix void without enabling backwards
+ # compatibility. We just don't support this at all, so we gripe
+ # about it rather than doing something unwise.
+
+ if ($void and not $back_compat) {
+ Carp::confess("Internal error: :void mode not supported with $class");
+ }
+
+ # @argv only contains the results of the in-built prototype
+ # function, and is therefore safe to interpolate in the
+ # code generators below.
+
+ # TODO - The following clobbers context, but that's what the
+ # old Fatal did. Do we care?
+
+ if ($back_compat) {
+
+ # Use Fatal qw(system) will never be supported. It generated
+ # a compile-time error with legacy Fatal, and there's no reason
+ # to support it when autodie does a better job.
+
+ if ($call eq 'CORE::system') {
+ return q{
+ croak("UNIMPLEMENTED: use Fatal qw(system) not supported.");
+ };
+ }
+
+ local $" = ', ';
+
+ if ($void) {
+ return qq/return (defined wantarray)?$call(@argv):
+ $call(@argv) || croak "Can't $name(\@_)/ .
+ ($core ? ': $!' : ', \$! is \"$!\"') . '"'
+ } else {
+ return qq{return $call(@argv) || croak "Can't $name(\@_)} .
+ ($core ? ': $!' : ', \$! is \"$!\"') . '"';
+ }
+ }
+
+ # The name of our original function is:
+ # $call if the function is CORE
+ # $sub if our function is non-CORE
+
+ # The reason for this is that $call is what we're actualling
+ # calling. For our core functions, this is always
+ # CORE::something. However for user-defined subs, we're about to
+ # replace whatever it is that we're calling; as such, we actually
+ # calling a subroutine ref.
+
+ my $human_sub_name = $core ? $call : $sub;
+
+ # Should we be testing to see if our result is defined, or
+ # just true?
+
+ my $use_defined_or;
+
+ my $hints; # All user-sub hints, including list hints.
+
+ if ( $core ) {
+
+ # Core hints are built into autodie.
+
+ $use_defined_or = exists ( $Use_defined_or{$call} );
+
+ }
+ else {
+
+ # User sub hints are looked up using autodie::hints,
+ # since users may wish to add their own hints.
+
+ require autodie::hints;
+
+ $hints = autodie::hints->get_hints_for( $sref );
+
+ # We'll look up the sub's fullname. This means we
+ # get better reports of where it came from in our
+ # error messages, rather than what imported it.
+
+ $human_sub_name = autodie::hints->sub_fullname( $sref );
+
+ }
+
+ # Checks for special core subs.
+
+ if ($call eq 'CORE::system') {
+
+ # Leverage IPC::System::Simple if we're making an autodying
+ # system.
+
+ local $" = ", ";
+
+ # We need to stash $@ into $E, rather than using
+ # local $@ for the whole sub. If we don't then
+ # any exceptions from internal errors in autodie/Fatal
+ # will mysteriously disappear before propogating
+ # upwards.
+
+ return qq{
+ my \$retval;
+ my \$E;
+
+
+ {
+ local \$@;
+
+ eval {
+ \$retval = IPC::System::Simple::system(@argv);
+ };
+
+ \$E = \$@;
+ }
+
+ if (\$E) {
+
+ # TODO - This can't be overridden in child
+ # classes!
+
+ die autodie::exception::system->new(
+ function => q{CORE::system}, args => [ @argv ],
+ message => "\$E", errno => \$!,
+ );
+ }
+
+ return \$retval;
+ };
+
+ }
+
+ local $" = ', ';
+
+ # If we're going to throw an exception, here's the code to use.
+ my $die = qq{
+ die $class->throw(
+ function => q{$human_sub_name}, args => [ @argv ],
+ pragma => q{$class}, errno => \$!,
+ context => \$context, return => \$retval,
+ eval_error => \$@
+ )
+ };
+
+ if ($call eq 'CORE::flock') {
+
+ # flock needs special treatment. When it fails with
+ # LOCK_UN and EWOULDBLOCK, then it's not really fatal, it just
+ # means we couldn't get the lock right now.
+
+ require POSIX; # For POSIX::EWOULDBLOCK
+
+ local $@; # Don't blat anyone else's $@.
+
+ # Ensure that our vendor supports EWOULDBLOCK. If they
+ # don't (eg, Windows), then we use known values for its
+ # equivalent on other systems.
+
+ my $EWOULDBLOCK = eval { POSIX::EWOULDBLOCK(); }
+ || $_EWOULDBLOCK{$^O}
+ || _autocroak("Internal error - can't overload flock - EWOULDBLOCK not defined on this system.");
+
+ require Fcntl; # For Fcntl::LOCK_NB
+
+ return qq{
+
+ my \$context = wantarray() ? "list" : "scalar";
+
+ # Try to flock. If successful, return it immediately.
+
+ my \$retval = $call(@argv);
+ return \$retval if \$retval;
+
+ # If we failed, but we're using LOCK_NB and
+ # returned EWOULDBLOCK, it's not a real error.
+
+ if (\$_[1] & Fcntl::LOCK_NB() and \$! == $EWOULDBLOCK ) {
+ return \$retval;
+ }
+
+ # Otherwise, we failed. Die noisily.
+
+ $die;
+
+ };
+ }
+
+ # AFAIK everything that can be given an unopned filehandle
+ # will fail if it tries to use it, so we don't really need
+ # the 'unopened' warning class here. Especially since they
+ # then report the wrong line number.
+
+ # Other warnings are disabled because they produce excessive
+ # complaints from smart-match hints under 5.10.1.
+
+ my $code = qq[
+ no warnings qw(unopened uninitialized numeric);
+
+ if (wantarray) {
+ my \@results = $call(@argv);
+ my \$retval = \\\@results;
+ my \$context = "list";
+
+ ];
+
+ if ( $hints and ( ref($hints->{list} ) || "" ) eq 'CODE' ) {
+
+ # NB: Subroutine hints are passed as a full list.
+ # This differs from the 5.10.0 smart-match behaviour,
+ # but means that context unaware subroutines can use
+ # the same hints in both list and scalar context.
+
+ $code .= qq{
+ if ( \$hints->{list}->(\@results) ) { $die };
+ };
+ }
+ elsif ( PERL510 and $hints ) {
+ $code .= qq{
+ if ( \@results ~~ \$hints->{list} ) { $die };
+ };
+ }
+ elsif ( $hints ) {
+ croak sprintf(ERROR_58_HINTS, 'list', $sub);
+ }
+ else {
+ $code .= qq{
+ # An empty list, or a single undef is failure
+ if (! \@results or (\@results == 1 and ! defined \$results[0])) {
+ $die;
+ }
+ }
+ }
+
+ # Tidy up the end of our wantarray call.
+
+ $code .= qq[
+ return \@results;
+ }
+ ];
+
+
+ # Otherwise, we're in scalar context.
+ # We're never in a void context, since we have to look
+ # at the result.
+
+ $code .= qq{
+ my \$retval = $call(@argv);
+ my \$context = "scalar";
+ };
+
+ if ( $hints and ( ref($hints->{scalar} ) || "" ) eq 'CODE' ) {
+
+ # We always call code refs directly, since that always
+ # works in 5.8.x, and always works in 5.10.1
+
+ return $code .= qq{
+ if ( \$hints->{scalar}->(\$retval) ) { $die };
+ return \$retval;
+ };
+
+ }
+ elsif (PERL510 and $hints) {
+ return $code . qq{
+
+ if ( \$retval ~~ \$hints->{scalar} ) { $die };
+
+ return \$retval;
+ };
+ }
+ elsif ( $hints ) {
+ croak sprintf(ERROR_58_HINTS, 'scalar', $sub);
+ }
+
+ return $code .
+ ( $use_defined_or ? qq{
+
+ $die if not defined \$retval;
+
+ return \$retval;
+
+ } : qq{
+
+ return \$retval || $die;
+
+ } ) ;
+
+}
+
+# This returns the old copy of the sub, so we can
+# put it back at end of scope.
+
+# TODO : Check to make sure prototypes are restored correctly.
+
+# TODO: Taking a huge list of arguments is awful. Rewriting to
+# take a hash would be lovely.
+
+# TODO - BACKCOMPAT - This is not yet compatible with 5.10.0
+
+sub _make_fatal {
+ my($class, $sub, $pkg, $void, $lexical, $filename, $insist) = @_;
+ my($name, $code, $sref, $real_proto, $proto, $core, $call, $hints);
+ my $ini = $sub;
+
+ $sub = "${pkg}::$sub" unless $sub =~ /::/;
+
+ # Figure if we're using lexical or package semantics and
+ # twiddle the appropriate bits.
+
+ if (not $lexical) {
+ $Package_Fatal{$sub} = 1;
+ }
+
+ # TODO - We *should* be able to do skipping, since we know when
+ # we've lexicalised / unlexicalised a subroutine.
+
+ $name = $sub;
+ $name =~ s/.*::// or $name =~ s/^&//;
+
+ warn "# _make_fatal: sub=$sub pkg=$pkg name=$name void=$void\n" if $Debug;
+ croak(sprintf(ERROR_BADNAME, $class, $name)) unless $name =~ /^\w+$/;
+
+ if (defined(&$sub)) { # user subroutine
+
+ # NOTE: Previously we would localise $@ at this point, so
+ # the following calls to eval {} wouldn't interfere with anything
+ # that's already in $@. Unfortunately, it would also stop
+ # any of our croaks from triggering(!), which is even worse.
+
+ # This could be something that we've fatalised that
+ # was in core.
+
+ if ( $Package_Fatal{$sub} and do { local $@; eval { prototype "CORE::$name" } } ) {
+
+ # Something we previously made Fatal that was core.
+ # This is safe to replace with an autodying to core
+ # version.
+
+ $core = 1;
+ $call = "CORE::$name";
+ $proto = prototype $call;
+
+ # We return our $sref from this subroutine later
+ # on, indicating this subroutine should be placed
+ # back when we're finished.
+
+ $sref = \&$sub;
+
+ } else {
+
+ # If this is something we've already fatalised or played with,
+ # then look-up the name of the original sub for the rest of
+ # our processing.
+
+ $sub = $Is_fatalised_sub{\&$sub} || $sub;
+
+ # A regular user sub, or a user sub wrapping a
+ # core sub.
+
+ $sref = \&$sub;
+ $proto = prototype $sref;
+ $call = '&$sref';
+ require autodie::hints;
+
+ $hints = autodie::hints->get_hints_for( $sref );
+
+ # If we've insisted on hints, but don't have them, then
+ # bail out!
+
+ if ($insist and not $hints) {
+ croak(sprintf(ERROR_NOHINTS, $name));
+ }
+
+ # Otherwise, use the default hints if we don't have
+ # any.
+
+ $hints ||= autodie::hints::DEFAULT_HINTS();
+
+ }
+
+ } elsif ($sub eq $ini && $sub !~ /^CORE::GLOBAL::/) {
+ # Stray user subroutine
+ croak(sprintf(ERROR_NOTSUB,$sub));
+
+ } elsif ($name eq 'system') {
+
+ # If we're fatalising system, then we need to load
+ # helper code.
+
+ # The business with $E is to avoid clobbering our caller's
+ # $@, and to avoid $@ being localised when we croak.
+
+ my $E;
+
+ {
+ local $@;
+
+ eval {
+ require IPC::System::Simple; # Only load it if we need it.
+ require autodie::exception::system;
+ };
+ $E = $@;
+ }
+
+ if ($E) { croak ERROR_NO_IPC_SYS_SIMPLE; }
+
+ # Make sure we're using a recent version of ISS that actually
+ # support fatalised system.
+ if ($IPC::System::Simple::VERSION < MIN_IPC_SYS_SIMPLE_VER) {
+ croak sprintf(
+ ERROR_IPC_SYS_SIMPLE_OLD, MIN_IPC_SYS_SIMPLE_VER,
+ $IPC::System::Simple::VERSION
+ );
+ }
+
+ $call = 'CORE::system';
+ $name = 'system';
+ $core = 1;
+
+ } elsif ($name eq 'exec') {
+ # Exec doesn't have a prototype. We don't care. This
+ # breaks the exotic form with lexical scope, and gives
+ # the regular form a "do or die" beaviour as expected.
+
+ $call = 'CORE::exec';
+ $name = 'exec';
+ $core = 1;
+
+ } else { # CORE subroutine
+ my $E;
+ {
+ local $@;
+ $proto = eval { prototype "CORE::$name" };
+ $E = $@;
+ }
+ croak(sprintf(ERROR_NOT_BUILT,$name)) if $E;
+ croak(sprintf(ERROR_CANT_OVERRIDE,$name)) if not defined $proto;
+ $core = 1;
+ $call = "CORE::$name";
+ }
+
+ if (defined $proto) {
+ $real_proto = " ($proto)";
+ } else {
+ $real_proto = '';
+ $proto = '@';
+ }
+
+ my $true_name = $core ? $call : $sub;
+
+ # TODO: This caching works, but I don't like using $void and
+ # $lexical as keys. In particular, I suspect our code may end up
+ # wrapping already wrapped code when autodie and Fatal are used
+ # together.
+
+ # NB: We must use '$sub' (the name plus package) and not
+ # just '$name' (the short name) here. Failing to do so
+ # results code that's in the wrong package, and hence has
+ # access to the wrong package filehandles.
+
+ if (my $subref = $Cached_fatalised_sub{$class}{$sub}{$void}{$lexical}) {
+ $class->_install_subs($pkg, { $name => $subref });
+ return $sref;
+ }
+
+ $code = qq[
+ sub$real_proto {
+ local(\$", \$!) = (', ', 0); # TODO - Why do we do this?
+ ];
+
+ # Don't have perl whine if exec fails, since we'll be handling
+ # the exception now.
+ $code .= "no warnings qw(exec);\n" if $call eq "CORE::exec";
+
+ my @protos = fill_protos($proto);
+ $code .= $class->_write_invocation($core, $call, $name, $void, $lexical, $sub, $sref, @protos);
+ $code .= "}\n";
+ warn $code if $Debug;
+
+ # I thought that changing package was a monumental waste of
+ # time for CORE subs, since they'll always be the same. However
+ # that's not the case, since they may refer to package-based
+ # filehandles (eg, with open).
+ #
+ # There is potential to more aggressively cache core subs
+ # that we know will never want to interact with package variables
+ # and filehandles.
+
+ {
+ no strict 'refs'; ## no critic # to avoid: Can't use string (...) as a symbol ref ...
+
+ my $E;
+
+ {
+ local $@;
+ $code = eval("package $pkg; use Carp; $code"); ## no critic
+ $E = $@;
+ }
+
+ if (not $code) {
+ croak("Internal error in autodie/Fatal processing $true_name: $E");
+
+ }
+ }
+
+ # Now we need to wrap our fatalised sub inside an itty bitty
+ # closure, which can detect if we've leaked into another file.
+ # Luckily, we only need to do this for lexical (autodie)
+ # subs. Fatal subs can leak all they want, it's considered
+ # a "feature" (or at least backwards compatible).
+
+ # TODO: Cache our leak guards!
+
+ # TODO: This is pretty hairy code. A lot more tests would
+ # be really nice for this.
+
+ my $leak_guard;
+
+ if ($lexical) {
+
+ $leak_guard = qq<
+ package $pkg;
+
+ sub$real_proto {
+
+ # If we're inside a string eval, we can end up with a
+ # whacky filename. The following code allows autodie
+ # to propagate correctly into string evals.
+
+ my \$caller_level = 0;
+
+ my \$caller;
+
+ while ( (\$caller = (caller \$caller_level)[1]) =~ m{^\\(eval \\d+\\)\$} ) {
+
+ # If our filename is actually an eval, and we
+ # reach it, then go to our autodying code immediatately.
+
+ goto &\$code if (\$caller eq \$filename);
+ \$caller_level++;
+ }
+
+ # We're now out of the eval stack.
+
+ # If we're called from the correct file, then use the
+ # autodying code.
+ goto &\$code if ((caller \$caller_level)[1] eq \$filename);
+
+ # Oh bother, we've leaked into another file. Call the
+ # original code. Note that \$sref may actually be a
+ # reference to a Fatalised version of a core built-in.
+ # That's okay, because Fatal *always* leaks between files.
+
+ goto &\$sref if \$sref;
+ >;
+
+
+ # If we're here, it must have been a core subroutine called.
+ # Warning: The following code may disturb some viewers.
+
+ # TODO: It should be possible to combine this with
+ # write_invocation().
+
+ foreach my $proto (@protos) {
+ local $" = ", "; # So @args is formatted correctly.
+ my ($count, @args) = @$proto;
+ $leak_guard .= qq<
+ if (\@_ == $count) {
+ return $call(@args);
+ }
+ >;
+ }
+
+ $leak_guard .= qq< croak "Internal error in Fatal/autodie. Leak-guard failure"; } >;
+
+ # warn "$leak_guard\n";
+
+ my $E;
+ {
+ local $@;
+
+ $leak_guard = eval $leak_guard; ## no critic
+
+ $E = $@;
+ }
+
+ die "Internal error in $class: Leak-guard installation failure: $E" if $E;
+ }
+
+ my $installed_sub = $leak_guard || $code;
+
+ $class->_install_subs($pkg, { $name => $installed_sub });
+
+ $Cached_fatalised_sub{$class}{$sub}{$void}{$lexical} = $installed_sub;
+
+ # Cache that we've now overriddent this sub. If we get called
+ # again, we may need to find that find subroutine again (eg, for hints).
+
+ $Is_fatalised_sub{$installed_sub} = $sref;
+
+ return $sref;
+
+}
+
+# This subroutine exists primarily so that child classes can override
+# it to point to their own exception class. Doing this is significantly
+# less complex than overriding throw()
+
+sub exception_class { return "autodie::exception" };
+
+{
+ my %exception_class_for;
+ my %class_loaded;
+
+ sub throw {
+ my ($class, @args) = @_;
+
+ # Find our exception class if we need it.
+ my $exception_class =
+ $exception_class_for{$class} ||= $class->exception_class;
+
+ if (not $class_loaded{$exception_class}) {
+ if ($exception_class =~ /[^\w:']/) {
+ confess "Bad exception class '$exception_class'.\nThe '$class->exception_class' method wants to use $exception_class\nfor exceptions, but it contains characters which are not word-characters or colons.";
+ }
+
+ # Alas, Perl does turn barewords into modules unless they're
+ # actually barewords. As such, we're left doing a string eval
+ # to make sure we load our file correctly.
+
+ my $E;
+
+ {
+ local $@; # We can't clobber $@, it's wrong!
+ eval "require $exception_class"; ## no critic
+ $E = $@; # Save $E despite ending our local.
+ }
+
+ # We need quotes around $@ to make sure it's stringified
+ # while still in scope. Without them, we run the risk of
+ # $@ having been cleared by us exiting the local() block.
+
+ confess "Failed to load '$exception_class'.\nThis may be a typo in the '$class->exception_class' method,\nor the '$exception_class' module may not exist.\n\n $E" if $E;
+
+ $class_loaded{$exception_class}++;
+
+ }
+
+ return $exception_class->new(@args);
+ }
+}
+
+# For some reason, dying while replacing our subs doesn't
+# kill our calling program. It simply stops the loading of
+# autodie and keeps going with everything else. The _autocroak
+# sub allows us to die with a vegence. It should *only* ever be
+# used for serious internal errors, since the results of it can't
+# be captured.
+
+sub _autocroak {
+ warn Carp::longmess(@_);
+ exit(255); # Ugh!
+}
+
+package autodie::Scope::Guard;
+
+# This code schedules the cleanup of subroutines at the end of
+# scope. It's directly inspired by chocolateboy's excellent
+# Scope::Guard module.
+
+sub new {
+ my ($class, $handler) = @_;
+
+ return bless $handler, $class;
+}
+
+sub DESTROY {
+ my ($self) = @_;
+
+ $self->();
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Fatal - Replace functions with equivalents which succeed or die
+
+=head1 SYNOPSIS
+
+ use Fatal qw(open close);
+
+ open(my $fh, "<", $filename); # No need to check errors!
+
+ use File::Copy qw(move);
+ use Fatal qw(move);
+
+ move($file1, $file2); # No need to check errors!
+
+ sub juggle { . . . }
+ Fatal->import('juggle');
+
+=head1 BEST PRACTICE
+
+B<Fatal has been obsoleted by the new L<autodie> pragma.> Please use
+L<autodie> in preference to C<Fatal>. L<autodie> supports lexical scoping,
+throws real exception objects, and provides much nicer error messages.
+
+The use of C<:void> with Fatal is discouraged.
+
+=head1 DESCRIPTION
+
+C<Fatal> provides a way to conveniently replace
+functions which normally return a false value when they fail with
+equivalents which raise exceptions if they are not successful. This
+lets you use these functions without having to test their return
+values explicitly on each call. Exceptions can be caught using
+C<eval{}>. See L<perlfunc> and L<perlvar> for details.
+
+The do-or-die equivalents are set up simply by calling Fatal's
+C<import> routine, passing it the names of the functions to be
+replaced. You may wrap both user-defined functions and overridable
+CORE operators (except C<exec>, C<system>, C<print>, or any other
+built-in that cannot be expressed via prototypes) in this way.
+
+If the symbol C<:void> appears in the import list, then functions
+named later in that import list raise an exception only when
+these are called in void context--that is, when their return
+values are ignored. For example
+
+ use Fatal qw/:void open close/;
+
+ # properly checked, so no exception raised on error
+ if (not open(my $fh, '<', '/bogotic') {
+ warn "Can't open /bogotic: $!";
+ }
+
+ # not checked, so error raises an exception
+ close FH;
+
+The use of C<:void> is discouraged, as it can result in exceptions
+not being thrown if you I<accidentally> call a method without
+void context. Use L<autodie> instead if you need to be able to
+disable autodying/Fatal behaviour for a small block of code.
+
+=head1 DIAGNOSTICS
+
+=over 4
+
+=item Bad subroutine name for Fatal: %s
+
+You've called C<Fatal> with an argument that doesn't look like
+a subroutine name, nor a switch that this version of Fatal
+understands.
+
+=item %s is not a Perl subroutine
+
+You've asked C<Fatal> to try and replace a subroutine which does not
+exist, or has not yet been defined.
+
+=item %s is neither a builtin, nor a Perl subroutine
+
+You've asked C<Fatal> to replace a subroutine, but it's not a Perl
+built-in, and C<Fatal> couldn't find it as a regular subroutine.
+It either doesn't exist or has not yet been defined.
+
+=item Cannot make the non-overridable %s fatal
+
+You've tried to use C<Fatal> on a Perl built-in that can't be
+overridden, such as C<print> or C<system>, which means that
+C<Fatal> can't help you, although some other modules might.
+See the L</"SEE ALSO"> section of this documentation.
+
+=item Internal error: %s
+
+You've found a bug in C<Fatal>. Please report it using
+the C<perlbug> command.
+
+=back
+
+=head1 BUGS
+
+C<Fatal> clobbers the context in which a function is called and always
+makes it a scalar context, except when the C<:void> tag is used.
+This problem does not exist in L<autodie>.
+
+"Used only once" warnings can be generated when C<autodie> or C<Fatal>
+is used with package filehandles (eg, C<FILE>). It's strongly recommended
+you use scalar filehandles instead.
+
+=head1 AUTHOR
+
+Original module by Lionel Cons (CERN).
+
+Prototype updates by Ilya Zakharevich <ilya at math.ohio-state.edu>.
+
+L<autodie> support, bugfixes, extended diagnostics, C<system>
+support, and major overhauling by Paul Fenwick <pjf at perltraining.com.au>
+
+=head1 LICENSE
+
+This module is free software, you may distribute it under the
+same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<autodie> for a nicer way to use lexical Fatal.
+
+L<IPC::System::Simple> for a similar idea for calls to C<system()>
+and backticks.
+
+=cut
Copied: trunk/contrib/perl/lib/Fatal.t (from rev 6437, vendor/perl/5.18.1/lib/Fatal.t)
===================================================================
--- trunk/contrib/perl/lib/Fatal.t (rev 0)
+++ trunk/contrib/perl/lib/Fatal.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,36 @@
+#!./perl -w
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ print "1..15\n";
+}
+
+use strict;
+use Fatal qw(open close :void opendir sin);
+
+my $i = 1;
+eval { open FOO, '<lkjqweriuapofukndajsdlfjnvcvn' };
+print "not " unless $@ =~ /^Can't open/;
+print "ok $i\n"; ++$i;
+
+my $foo = 'FOO';
+for ('$foo', "'$foo'", "*$foo", "\\*$foo") {
+ eval qq{ open $_, '<$0' };
+ print "not " if $@;
+ print "ok $i\n"; ++$i;
+
+ print "not " if $@ or scalar(<$foo>) !~ m|^#!./perl|;
+ print "ok $i\n"; ++$i;
+ eval qq{ close FOO };
+ print "not " if $@;
+ print "ok $i\n"; ++$i;
+}
+
+eval { opendir FOO, 'lkjqweriuapofukndajsdlfjnvcvn' };
+print "not " unless $@ =~ /^Can't open/;
+print "ok $i\n"; ++$i;
+
+eval { my $a = opendir FOO, 'lkjqweriuapofukndajsdlfjnvcvn' };
+print "not " if $@ =~ /^Can't open/;
+print "ok $i\n"; ++$i;
Modified: trunk/contrib/perl/lib/File/Basename.pm
===================================================================
--- trunk/contrib/perl/lib/File/Basename.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/File/Basename.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -54,7 +54,7 @@
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(fileparse fileparse_set_fstype basename dirname);
-$VERSION = "2.82";
+$VERSION = "2.84";
fileparse_set_fstype($^O);
@@ -91,7 +91,7 @@
# On Unix returns ("baz", "/foo/bar/", ".txt")
fileparse("/foo/bar/baz.txt", qr/\.[^.]*/);
-If type is non-Unix (see C<fileparse_set_fstype()>) then the pattern
+If type is non-Unix (see L</fileparse_set_fstype>) then the pattern
matching for suffix removal is performed case-insensitively, since
those systems are not case-sensitive when opening existing files.
@@ -215,7 +215,7 @@
my($path) = shift;
# From BSD basename(1)
- # The basename utility deletes any prefix ending with the last slash `/'
+ # The basename utility deletes any prefix ending with the last slash '/'
# character present in string (after first stripping trailing slashes)
_strip_trailing_sep($path);
Property changes on: trunk/contrib/perl/lib/File/Basename.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/File/Basename.t
===================================================================
--- trunk/contrib/perl/lib/File/Basename.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/File/Basename.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -154,7 +154,9 @@
### Test tainting
-{
+SKIP: {
+ skip "A perl without taint support", 2
+ if not ${^TAINT};
# The empty tainted value, for tainting strings
my $TAINT = substr($^X, 0, 0);
Property changes on: trunk/contrib/perl/lib/File/Basename.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/lib/File/CheckTree.pm (from rev 6437, vendor/perl/5.18.1/lib/File/CheckTree.pm)
===================================================================
--- trunk/contrib/perl/lib/File/CheckTree.pm (rev 0)
+++ trunk/contrib/perl/lib/File/CheckTree.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,238 @@
+package File::CheckTree;
+
+use 5.006;
+use Cwd;
+use Exporter;
+use File::Spec;
+use warnings;
+use strict;
+
+our $VERSION = '4.4';
+our @ISA = qw(Exporter);
+our @EXPORT = qw(validate);
+
+=head1 NAME
+
+File::CheckTree - run many filetest checks on a tree
+
+=head1 SYNOPSIS
+
+ use File::CheckTree;
+
+ $num_warnings = validate( q{
+ /vmunix -e || die
+ /boot -e || die
+ /bin cd
+ csh -ex
+ csh !-ug
+ sh -ex
+ sh !-ug
+ /usr -d || warn "What happened to $file?\n"
+ });
+
+=head1 DESCRIPTION
+
+The validate() routine takes a single multiline string consisting of
+directives, each containing a filename plus a file test to try on it.
+(The file test may also be a "cd", causing subsequent relative filenames
+to be interpreted relative to that directory.) After the file test
+you may put C<|| die> to make it a fatal error if the file test fails.
+The default is C<|| warn>. The file test may optionally have a "!' prepended
+to test for the opposite condition. If you do a cd and then list some
+relative filenames, you may want to indent them slightly for readability.
+If you supply your own die() or warn() message, you can use $file to
+interpolate the filename.
+
+Filetests may be bunched: "-rwx" tests for all of C<-r>, C<-w>, and C<-x>.
+Only the first failed test of the bunch will produce a warning.
+
+The routine returns the number of warnings issued.
+
+=head1 AUTHOR
+
+File::CheckTree was derived from lib/validate.pl which was
+written by Larry Wall.
+Revised by Paul Grassie <F<grassie at perl.com>> in 2002.
+
+=head1 HISTORY
+
+File::CheckTree used to not display fatal error messages.
+It used to count only those warnings produced by a generic C<|| warn>
+(and not those in which the user supplied the message). In addition,
+the validate() routine would leave the user program in whatever
+directory was last entered through the use of "cd" directives.
+These bugs were fixed during the development of perl 5.8.
+The first fixed version of File::CheckTree was 4.2.
+
+=cut
+
+my $Warnings;
+
+sub validate {
+ my ($starting_dir, $file, $test, $cwd, $oldwarnings);
+
+ $starting_dir = cwd;
+
+ $cwd = "";
+ $Warnings = 0;
+
+ foreach my $check (split /\n/, $_[0]) {
+ my ($testlist, @testlist);
+
+ # skip blanks/comments
+ next if $check =~ /^\s*#/ || $check =~ /^\s*$/;
+
+ # Todo:
+ # should probably check for invalid directives and die
+ # but earlier versions of File::CheckTree did not do this either
+
+ # split a line like "/foo -r || die"
+ # so that $file is "/foo", $test is "-r || die"
+ # (making special allowance for quoted filenames).
+ if ($check =~ m/^\s*"([^"]+)"\s+(.*?)\s*$/ or
+ $check =~ m/^\s*'([^']+)'\s+(.*?)\s*$/ or
+ $check =~ m/^\s*(\S+?)\s+(\S.*?)\s*$/)
+ {
+ ($file, $test) = ($1,$2);
+ }
+ else {
+ die "Malformed line: '$check'";
+ };
+
+ # change a $test like "!-ug || die" to "!-Z || die",
+ # capturing the bundled tests (e.g. "ug") in $2
+ if ($test =~ s/ ^ (!?-) (\w{2,}) \b /$1Z/x) {
+ $testlist = $2;
+ # split bundled tests, e.g. "ug" to 'u', 'g'
+ @testlist = split(//, $testlist);
+ }
+ else {
+ # put in placeholder Z for stand-alone test
+ @testlist = ('Z');
+ }
+
+ # will compare these two later to stop on 1st warning w/in a bundle
+ $oldwarnings = $Warnings;
+
+ foreach my $one (@testlist) {
+ # examples of $test: "!-Z || die" or "-w || warn"
+ my $this = $test;
+
+ # expand relative $file to full pathname if preceded by cd directive
+ $file = File::Spec->catfile($cwd, $file)
+ if $cwd && !File::Spec->file_name_is_absolute($file);
+
+ # put filename in after the test operator
+ $this =~ s/(-\w\b)/$1 "\$file"/g;
+
+ # change the "-Z" representing a bundle with the $one test
+ $this =~ s/-Z/-$one/;
+
+ # if it's a "cd" directive...
+ if ($this =~ /^cd\b/) {
+ # add "|| die ..."
+ $this .= ' || die "cannot cd to $file\n"';
+ # expand "cd" directive with directory name
+ $this =~ s/\bcd\b/chdir(\$cwd = '$file')/;
+ }
+ else {
+ # add "|| warn" as a default disposition
+ $this .= ' || warn' unless $this =~ /\|\|/;
+
+ # change a generic ".. || die" or ".. || warn"
+ # to call valmess instead of die/warn directly
+ # valmess will look up the error message from %Val_Message
+ $this =~ s/ ^ ( (\S+) \s+ \S+ ) \s* \|\| \s* (die|warn) \s* $
+ /$1 || valmess('$3', '$2', \$file)/x;
+ }
+
+ {
+ # count warnings, either from valmess or '-r || warn "my msg"'
+ # also, call any pre-existing signal handler for __WARN__
+ my $orig_sigwarn = $SIG{__WARN__};
+ local $SIG{__WARN__} = sub {
+ ++$Warnings;
+ if ( $orig_sigwarn ) {
+ $orig_sigwarn->(@_);
+ }
+ else {
+ warn "@_";
+ }
+ };
+
+ # do the test
+ eval $this;
+
+ # re-raise an exception caused by a "... || die" test
+ if (my $err = $@) {
+ # in case of any cd directives, return from whence we came
+ if ($starting_dir ne cwd) {
+ chdir($starting_dir) || die "$starting_dir: $!";
+ }
+ die $err;
+ }
+ }
+
+ # stop on 1st warning within a bundle of tests
+ last if $Warnings > $oldwarnings;
+ }
+ }
+
+ # in case of any cd directives, return from whence we came
+ if ($starting_dir ne cwd) {
+ chdir($starting_dir) || die "chdir $starting_dir: $!";
+ }
+
+ return $Warnings;
+}
+
+my %Val_Message = (
+ 'r' => "is not readable by uid $>.",
+ 'w' => "is not writable by uid $>.",
+ 'x' => "is not executable by uid $>.",
+ 'o' => "is not owned by uid $>.",
+ 'R' => "is not readable by you.",
+ 'W' => "is not writable by you.",
+ 'X' => "is not executable by you.",
+ 'O' => "is not owned by you.",
+ 'e' => "does not exist.",
+ 'z' => "does not have zero size.",
+ 's' => "does not have non-zero size.",
+ 'f' => "is not a plain file.",
+ 'd' => "is not a directory.",
+ 'l' => "is not a symbolic link.",
+ 'p' => "is not a named pipe (FIFO).",
+ 'S' => "is not a socket.",
+ 'b' => "is not a block special file.",
+ 'c' => "is not a character special file.",
+ 'u' => "does not have the setuid bit set.",
+ 'g' => "does not have the setgid bit set.",
+ 'k' => "does not have the sticky bit set.",
+ 'T' => "is not a text file.",
+ 'B' => "is not a binary file."
+);
+
+sub valmess {
+ my ($disposition, $test, $file) = @_;
+ my $ferror;
+
+ if ($test =~ / ^ (!?) -(\w) \s* $ /x) {
+ my ($neg, $ftype) = ($1, $2);
+
+ $ferror = "$file $Val_Message{$ftype}";
+
+ if ($neg eq '!') {
+ $ferror =~ s/ is not / should not be / ||
+ $ferror =~ s/ does not / should not / ||
+ $ferror =~ s/ not / /;
+ }
+ }
+ else {
+ $ferror = "Can't do $test $file.\n";
+ }
+
+ die "$ferror\n" if $disposition eq 'die';
+ warn "$ferror\n";
+}
+
+1;
Copied: trunk/contrib/perl/lib/File/CheckTree.t (from rev 6437, vendor/perl/5.18.1/lib/File/CheckTree.t)
===================================================================
--- trunk/contrib/perl/lib/File/CheckTree.t (rev 0)
+++ trunk/contrib/perl/lib/File/CheckTree.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,241 @@
+#!./perl -w
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use Test;
+
+BEGIN { plan tests => 8 }
+
+use strict;
+
+BEGIN {
+# Cwd::cwd does an implicit "require Win32", but
+# the ../lib directory in @INC will no longer work once
+# we chdir() out of the "t" directory.
+ if ($^O eq 'MSWin32') {
+ require Win32;
+ Win32->import();
+ }
+}
+
+use File::CheckTree;
+use File::Spec; # used to get absolute paths
+
+# We assume that we start from the perl "t" directory.
+# Will move up one level to make it easier to generate
+# reliable pathnames for testing File::CheckTree
+
+chdir(File::Spec->updir) or die "cannot change to parent of t/ directory: $!";
+
+
+#### TEST 1 -- No warnings ####
+# usings both relative and full paths, indented comments
+
+{
+ my ($num_warnings, $path_to_README);
+ $path_to_README = File::Spec->rel2abs('README');
+
+ my @warnings;
+ local $SIG{__WARN__} = sub { push @warnings, "@_" };
+
+ eval {
+ $num_warnings = validate qq{
+ lib -d
+# comment, followed "blank" line (w/ whitespace):
+
+ # indented comment, followed blank line (w/o whitespace):
+
+ README -f
+ '$path_to_README' -e || warn
+ };
+ };
+
+ print STDERR $_ for @warnings;
+ if ( !$@ && !@warnings && defined($num_warnings) && $num_warnings == 0 ) {
+ ok(1);
+ }
+ else {
+ ok(0);
+ }
+}
+
+
+#### TEST 2 -- One warning ####
+
+{
+ my ($num_warnings, @warnings);
+
+ local $SIG{__WARN__} = sub { push @warnings, "@_" };
+
+ eval {
+ $num_warnings = validate qq{
+ lib -f
+ README -f
+ };
+ };
+
+ if ( !$@ && @warnings == 1
+ && $warnings[0] =~ /lib is not a plain file/
+ && defined($num_warnings)
+ && $num_warnings == 1 )
+ {
+ ok(1);
+ }
+ else {
+ ok(0);
+ }
+}
+
+
+#### TEST 3 -- Multiple warnings ####
+# including first warning only from a bundle of tests,
+# generic "|| warn", default "|| warn" and "|| warn '...' "
+
+{
+ my ($num_warnings, @warnings);
+
+ local $SIG{__WARN__} = sub { push @warnings, "@_" };
+
+ eval {
+ $num_warnings = validate q{
+ lib -effd
+ README -f || die
+ README -d || warn
+ lib -f || warn "my warning: $file\n"
+ };
+ };
+
+ if ( !$@ && @warnings == 3
+ && $warnings[0] =~ /lib is not a plain file/
+ && $warnings[1] =~ /README is not a directory/
+ && $warnings[2] =~ /my warning: lib/
+ && defined($num_warnings)
+ && $num_warnings == 3 )
+ {
+ ok(1);
+ }
+ else {
+ ok(0);
+ }
+}
+
+
+#### TEST 4 -- cd directive ####
+# cd directive followed by relative paths, followed by full paths
+{
+ my ($num_warnings, @warnings, $path_to_libFile, $path_to_dist);
+ $path_to_libFile = File::Spec->rel2abs(File::Spec->catdir('lib','File'));
+ $path_to_dist = File::Spec->rel2abs(File::Spec->curdir);
+
+ local $SIG{__WARN__} = sub { push @warnings, "@_" };
+
+ eval {
+ $num_warnings = validate qq{
+ lib -d || die
+ '$path_to_libFile' cd
+ Spec -e
+ Spec -f
+ '$path_to_dist' cd
+ README -ef
+ INSTALL -d || warn
+ '$path_to_libFile' -d || die
+ };
+ };
+
+ if ( !$@ && @warnings == 2
+ && $warnings[0] =~ /Spec is not a plain file/
+ && $warnings[1] =~ /INSTALL is not a directory/
+ && defined($num_warnings)
+ && $num_warnings == 2 )
+ {
+ ok(1);
+ }
+ else {
+ ok(0);
+ }
+}
+
+
+#### TEST 5 -- Exception ####
+# test with generic "|| die"
+{
+ my $num_warnings;
+
+ eval {
+ $num_warnings = validate q{
+ lib -ef || die
+ README -d
+ };
+ };
+
+ if ( $@ && $@ =~ /lib is not a plain file/
+ && not defined $num_warnings )
+ {
+ ok(1);
+ }
+ else {
+ ok(0);
+ }
+}
+
+
+#### TEST 6 -- Exception ####
+# test with "|| die 'my error message'"
+{
+ my $num_warnings;
+
+ eval {
+ $num_warnings = validate q{
+ lib -ef || die "yadda $file yadda...\n"
+ README -d
+ };
+ };
+
+ if ( $@ && $@ =~ /yadda lib yadda/
+ && not defined $num_warnings )
+ {
+ ok(1);
+ }
+ else {
+ ok(0);
+ }
+}
+
+#### TEST 7 -- Quoted file names ####
+{
+ my $num_warnings;
+ eval {
+ $num_warnings = validate q{
+ "a file with whitespace" !-ef
+ 'a file with whitespace' !-ef
+ };
+ };
+
+ if ( !$@ ) {
+ # No errors mean we compile correctly
+ ok(1);
+ } else {
+ ok(0);
+ print STDERR $@;
+ };
+}
+
+#### TEST 8 -- Malformed query ####
+{
+ my $num_warnings;
+ eval {
+ $num_warnings = validate q{
+ a file with whitespace !-ef
+ };
+ };
+
+ if ( $@ =~ /syntax error/) {
+ # We got a syntax error for a malformed file query
+ ok(1);
+ } else {
+ ok(0);
+ };
+}
Index: trunk/contrib/perl/lib/File/Compare.pm
===================================================================
--- trunk/contrib/perl/lib/File/Compare.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/File/Compare.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/File/Compare.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/lib/File/Compare.t
===================================================================
--- trunk/contrib/perl/lib/File/Compare.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/File/Compare.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -112,6 +112,7 @@
print "not " unless $donetests[2] == 0;
print "ok 13 # ";
print "TODO" if $^O eq "cygwin"; # spaces after filename silently trunc'd
+ print "TODO" if $^O eq "vos"; # spaces after filename silently trunc'd
print " file/fileCR [$donetests[2]]\n";
}
else {
Property changes on: trunk/contrib/perl/lib/File/Compare.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/lib/File/Copy.pm
===================================================================
--- trunk/contrib/perl/lib/File/Copy.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/File/Copy.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -9,7 +9,7 @@
use 5.006;
use strict;
-use warnings;
+use warnings; no warnings 'newline';
use File::Spec;
use Config;
# During perl build, we need File::Copy but Scalar::Util might not be built yet
@@ -22,7 +22,7 @@
sub cp;
sub mv;
-$VERSION = '2.21';
+$VERSION = '2.26';
require Exporter;
@ISA = qw(Exporter);
@@ -128,11 +128,13 @@
if (_eq($from, $to)) { # works for references, too
carp("'$from' and '$to' are identical (not copied)");
- # The "copy" was a success as the source and destination contain
- # the same data.
- return 1;
+ return 0;
}
+ if (!$from_a_handle && !$to_a_handle && -d $to && ! -d $from) {
+ $to = _catname($from, $to);
+ }
+
if ((($Config{d_symlink} && $Config{d_readlink}) || $Config{d_link}) &&
!($^O eq 'MSWin32' || $^O eq 'os2')) {
my @fs = stat($from);
@@ -144,15 +146,14 @@
}
}
}
-
- if (!$from_a_handle && !$to_a_handle && -d $to && ! -d $from) {
- $to = _catname($from, $to);
+ elsif (_eq($from, $to)) {
+ carp("'$from' and '$to' are identical (not copied)");
+ return 0;
}
if (defined &syscopy && !$Syscopy_is_copy
&& !$to_a_handle
&& !($from_a_handle && $^O eq 'os2' ) # OS/2 cannot handle handles
- && !($from_a_handle && $^O eq 'mpeix') # and neither can MPE/iX.
&& !($from_a_handle && $^O eq 'MSWin32')
&& !($from_a_handle && $^O eq 'NetWare')
)
@@ -410,13 +411,6 @@
unless (defined &syscopy) {
if ($^O eq 'VMS') {
*syscopy = \&rmscopy;
- } elsif ($^O eq 'mpeix') {
- *syscopy = sub {
- return 0 unless @_ == 2;
- # Use the MPE cp program in order to
- # preserve MPE file attributes.
- return system('/bin/cp', '-f', $_[0], $_[1]) == 0;
- };
} elsif ($^O eq 'MSWin32' && defined &DynaLoader::boot_DynaLoader) {
# Win32::CopyFile() fill only work if we can load Win32.xs
*syscopy = sub {
@@ -468,7 +462,7 @@
sort, it will be read from, and if it is a file I<name> it will
be opened for reading. Likewise, the second argument will be
written to (and created if need be). Trying to copy a file on top
-of itself is a fatal error.
+of itself is an error.
If the destination (second argument) already exists and is a directory,
and the source (first argument) is not a filehandle, then the source
@@ -492,7 +486,7 @@
You may use the syntax C<use File::Copy "cp"> to get at the C<cp>
alias for this function. The syntax is I<exactly> the same. The
-behavior is nearly the same as well: as of version 2.15, <cp> will
+behavior is nearly the same as well: as of version 2.15, C<cp> will
preserve the source file's permission bits like the shell utility
C<cp(1)> would do, while C<copy> uses the default permissions for the
target file (which may depend on the process' C<umask>, file
@@ -515,7 +509,7 @@
copy of the file under the destination name.
You may use the C<mv> alias for this function in the same way that
-you may use the <cp> alias for C<copy>.
+you may use the C<cp> alias for C<copy>.
=item syscopy
X<syscopy>
Property changes on: trunk/contrib/perl/lib/File/Copy.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/File/Copy.t
===================================================================
--- trunk/contrib/perl/lib/File/Copy.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/File/Copy.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -14,7 +14,7 @@
my $TB = Test::More->builder;
-plan tests => 463;
+plan tests => 465;
# We're going to override rename() later on but Perl has to see an override
# at compile time to honor it.
@@ -139,7 +139,7 @@
{
my $warnings = '';
local $SIG{__WARN__} = sub { $warnings .= join '', @_ };
- ok copy("file-$$", "file-$$"), 'copy(fn, fn) succeeds';
+ ok !copy("file-$$", "file-$$"), 'copy to itself fails';
like $warnings, qr/are identical/, 'but warns';
ok -s "file-$$", 'contents preserved';
@@ -265,7 +265,12 @@
if $^O eq 'VMS';
skip "Copy doesn't set file permissions correctly on Win32.", $skips
if $^O eq "MSWin32";
+ skip "Copy maps POSIX permissions to VOS permissions.", $skips
+ if $^O eq "vos";
+ skip "There be dragons here with DragonflyBSD.", $skips
+ if $^O eq 'dragonfly';
+
# Just a sub to get better failure messages.
sub __ ($) {
my $perm = shift;
@@ -409,7 +414,7 @@
foreach my $right (qw(plain object1 object2)) {
@warnings = ();
$! = 0;
- is eval {copy $what{$left}, $what{$right}}, 1, "copy $left $right";
+ is eval {copy $what{$left}, $what{$right}}, 0, "copy $left $right";
is $@, '', 'No croaking';
is $!, '', 'No system call errors';
is @warnings, 1, 'Exactly 1 warning';
@@ -470,6 +475,31 @@
close($IN);
}
+use File::Temp qw(tempdir);
+use File::Spec;
+
+SKIP: {
+ # RT #111126: File::Copy copy() zeros file when copying a file
+ # into the same directory it is stored in
+
+ my $temp_dir = tempdir( CLEANUP => 1 );
+ my $temp_file = File::Spec->catfile($temp_dir, "somefile");
+
+ open my $fh, ">", $temp_file
+ or skip "Cannot create $temp_file: $!", 2;
+ print $fh "Just some data";
+ close $fh
+ or skip "Cannot close $temp_file: $!", 2;
+
+ my $warn_message = "";
+ local $SIG{__WARN__} = sub { $warn_message .= "@_" };
+ ok(!copy($temp_file, $temp_dir),
+ "Copy of foo/file to foo/ should fail");
+ like($warn_message, qr/^\Q'$temp_file' and '$temp_file'\E are identical.*Copy\.t/i,
+ "error message should describe the problem");
+ 1 while unlink $temp_file;
+}
+
END {
1 while unlink "file-$$";
1 while unlink "lib/file-$$";
Property changes on: trunk/contrib/perl/lib/File/Copy.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/lib/File/DosGlob.pm
===================================================================
--- trunk/contrib/perl/lib/File/DosGlob.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/File/DosGlob.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/File/DosGlob.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/lib/File/DosGlob.t
===================================================================
--- trunk/contrib/perl/lib/File/DosGlob.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/File/DosGlob.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/File/DosGlob.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/lib/File/Fetch.pm (from rev 6437, vendor/perl/5.18.1/lib/File/Fetch.pm)
===================================================================
--- trunk/contrib/perl/lib/File/Fetch.pm (rev 0)
+++ trunk/contrib/perl/lib/File/Fetch.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,1382 @@
+package File::Fetch;
+
+use strict;
+use FileHandle;
+use File::Temp;
+use File::Copy;
+use File::Spec;
+use File::Spec::Unix;
+use File::Basename qw[dirname];
+
+use Cwd qw[cwd];
+use Carp qw[carp];
+use IPC::Cmd qw[can_run run QUOTE];
+use File::Path qw[mkpath];
+use File::Temp qw[tempdir];
+use Params::Check qw[check];
+use Module::Load::Conditional qw[can_load];
+use Locale::Maketext::Simple Style => 'gettext';
+
+use vars qw[ $VERBOSE $PREFER_BIN $FROM_EMAIL $USER_AGENT
+ $BLACKLIST $METHOD_FAIL $VERSION $METHODS
+ $FTP_PASSIVE $TIMEOUT $DEBUG $WARN
+ ];
+
+$VERSION = '0.20';
+$VERSION = eval $VERSION; # avoid warnings with development releases
+$PREFER_BIN = 0; # XXX TODO implement
+$FROM_EMAIL = 'File-Fetch at example.com';
+$USER_AGENT = "File::Fetch/$VERSION";
+$BLACKLIST = [qw|ftp|];
+$METHOD_FAIL = { };
+$FTP_PASSIVE = 1;
+$TIMEOUT = 0;
+$DEBUG = 0;
+$WARN = 1;
+
+### methods available to fetch the file depending on the scheme
+$METHODS = {
+ http => [ qw|lwp wget curl lftp lynx| ],
+ ftp => [ qw|lwp netftp wget curl lftp ncftp ftp| ],
+ file => [ qw|lwp lftp file| ],
+ rsync => [ qw|rsync| ]
+};
+
+### silly warnings ###
+local $Params::Check::VERBOSE = 1;
+local $Params::Check::VERBOSE = 1;
+local $Module::Load::Conditional::VERBOSE = 0;
+local $Module::Load::Conditional::VERBOSE = 0;
+
+### see what OS we are on, important for file:// uris ###
+use constant ON_WIN => ($^O eq 'MSWin32');
+use constant ON_VMS => ($^O eq 'VMS');
+use constant ON_UNIX => (!ON_WIN);
+use constant HAS_VOL => (ON_WIN);
+use constant HAS_SHARE => (ON_WIN);
+
+
+=pod
+
+=head1 NAME
+
+File::Fetch - A generic file fetching mechanism
+
+=head1 SYNOPSIS
+
+ use File::Fetch;
+
+ ### build a File::Fetch object ###
+ my $ff = File::Fetch->new(uri => 'http://some.where.com/dir/a.txt');
+
+ ### fetch the uri to cwd() ###
+ my $where = $ff->fetch() or die $ff->error;
+
+ ### fetch the uri to /tmp ###
+ my $where = $ff->fetch( to => '/tmp' );
+
+ ### parsed bits from the uri ###
+ $ff->uri;
+ $ff->scheme;
+ $ff->host;
+ $ff->path;
+ $ff->file;
+
+=head1 DESCRIPTION
+
+File::Fetch is a generic file fetching mechanism.
+
+It allows you to fetch any file pointed to by a C<ftp>, C<http>,
+C<file>, or C<rsync> uri by a number of different means.
+
+See the C<HOW IT WORKS> section further down for details.
+
+=head1 ACCESSORS
+
+A C<File::Fetch> object has the following accessors
+
+=over 4
+
+=item $ff->uri
+
+The uri you passed to the constructor
+
+=item $ff->scheme
+
+The scheme from the uri (like 'file', 'http', etc)
+
+=item $ff->host
+
+The hostname in the uri. Will be empty if host was originally
+'localhost' for a 'file://' url.
+
+=item $ff->vol
+
+On operating systems with the concept of a volume the second element
+of a file:// is considered to the be volume specification for the file.
+Thus on Win32 this routine returns the volume, on other operating
+systems this returns nothing.
+
+On Windows this value may be empty if the uri is to a network share, in
+which case the 'share' property will be defined. Additionally, volume
+specifications that use '|' as ':' will be converted on read to use ':'.
+
+On VMS, which has a volume concept, this field will be empty because VMS
+file specifications are converted to absolute UNIX format and the volume
+information is transparently included.
+
+=item $ff->share
+
+On systems with the concept of a network share (currently only Windows) returns
+the sharename from a file://// url. On other operating systems returns empty.
+
+=item $ff->path
+
+The path from the uri, will be at least a single '/'.
+
+=item $ff->file
+
+The name of the remote file. For the local file name, the
+result of $ff->output_file will be used.
+
+=cut
+
+
+##########################
+### Object & Accessors ###
+##########################
+
+{
+ ### template for autogenerated accessors ###
+ my $Tmpl = {
+ scheme => { default => 'http' },
+ host => { default => 'localhost' },
+ path => { default => '/' },
+ file => { required => 1 },
+ uri => { required => 1 },
+ vol => { default => '' }, # windows for file:// uris
+ share => { default => '' }, # windows for file:// uris
+ _error_msg => { no_override => 1 },
+ _error_msg_long => { no_override => 1 },
+ };
+
+ for my $method ( keys %$Tmpl ) {
+ no strict 'refs';
+ *$method = sub {
+ my $self = shift;
+ $self->{$method} = $_[0] if @_;
+ return $self->{$method};
+ }
+ }
+
+ sub _create {
+ my $class = shift;
+ my %hash = @_;
+
+ my $args = check( $Tmpl, \%hash ) or return;
+
+ bless $args, $class;
+
+ if( lc($args->scheme) ne 'file' and not $args->host ) {
+ return File::Fetch->_error(loc(
+ "Hostname required when fetching from '%1'",$args->scheme));
+ }
+
+ for (qw[path file]) {
+ unless( $args->$_() ) { # 5.5.x needs the ()
+ return File::Fetch->_error(loc("No '%1' specified",$_));
+ }
+ }
+
+ return $args;
+ }
+}
+
+=item $ff->output_file
+
+The name of the output file. This is the same as $ff->file,
+but any query parameters are stripped off. For example:
+
+ http://example.com/index.html?x=y
+
+would make the output file be C<index.html> rather than
+C<index.html?x=y>.
+
+=back
+
+=cut
+
+sub output_file {
+ my $self = shift;
+ my $file = $self->file;
+
+ $file =~ s/\?.*$//g;
+
+ return $file;
+}
+
+### XXX do this or just point to URI::Escape?
+# =head2 $esc_uri = $ff->escaped_uri
+#
+# =cut
+#
+# ### most of this is stolen straight from URI::escape
+# { ### Build a char->hex map
+# my %escapes = map { chr($_) => sprintf("%%%02X", $_) } 0..255;
+#
+# sub escaped_uri {
+# my $self = shift;
+# my $uri = $self->uri;
+#
+# ### Default unsafe characters. RFC 2732 ^(uric - reserved)
+# $uri =~ s/([^A-Za-z0-9\-_.!~*'()])/
+# $escapes{$1} || $self->_fail_hi($1)/ge;
+#
+# return $uri;
+# }
+#
+# sub _fail_hi {
+# my $self = shift;
+# my $char = shift;
+#
+# $self->_error(loc(
+# "Can't escape '%1', try using the '%2' module instead",
+# sprintf("\\x{%04X}", ord($char)), 'URI::Escape'
+# ));
+# }
+#
+# sub output_file {
+#
+# }
+#
+#
+# }
+
+=head1 METHODS
+
+=head2 $ff = File::Fetch->new( uri => 'http://some.where.com/dir/file.txt' );
+
+Parses the uri and creates a corresponding File::Fetch::Item object,
+that is ready to be C<fetch>ed and returns it.
+
+Returns false on failure.
+
+=cut
+
+sub new {
+ my $class = shift;
+ my %hash = @_;
+
+ my ($uri);
+ my $tmpl = {
+ uri => { required => 1, store => \$uri },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ ### parse the uri to usable parts ###
+ my $href = __PACKAGE__->_parse_uri( $uri ) or return;
+
+ ### make it into a FFI object ###
+ my $ff = File::Fetch->_create( %$href ) or return;
+
+
+ ### return the object ###
+ return $ff;
+}
+
+### parses an uri to a hash structure:
+###
+### $class->_parse_uri( 'ftp://ftp.cpan.org/pub/mirror/index.txt' )
+###
+### becomes:
+###
+### $href = {
+### scheme => 'ftp',
+### host => 'ftp.cpan.org',
+### path => '/pub/mirror',
+### file => 'index.html'
+### };
+###
+### In the case of file:// urls there maybe be additional fields
+###
+### For systems with volume specifications such as Win32 there will be
+### a volume specifier provided in the 'vol' field.
+###
+### 'vol' => 'volumename'
+###
+### For windows file shares there may be a 'share' key specified
+###
+### 'share' => 'sharename'
+###
+### Note that the rules of what a file:// url means vary by the operating system
+### of the host being addressed. Thus file:///d|/foo/bar.txt means the obvious
+### 'D:\foo\bar.txt' on windows, but on unix it means '/d|/foo/bar.txt' and
+### not '/foo/bar.txt'
+###
+### Similarly if the host interpreting the url is VMS then
+### file:///disk$user/my/notes/note12345.txt' means
+### 'DISK$USER:[MY.NOTES]NOTE123456.TXT' but will be returned the same as
+### if it is unix where it means /disk$user/my/notes/note12345.txt'.
+### Except for some cases in the File::Spec methods, Perl on VMS will generally
+### handle UNIX format file specifications.
+###
+### This means it is impossible to serve certain file:// urls on certain systems.
+###
+### Thus are the problems with a protocol-less specification. :-(
+###
+
+sub _parse_uri {
+ my $self = shift;
+ my $uri = shift or return;
+
+ my $href = { uri => $uri };
+
+ ### find the scheme ###
+ $uri =~ s|^(\w+)://||;
+ $href->{scheme} = $1;
+
+ ### See rfc 1738 section 3.10
+ ### http://www.faqs.org/rfcs/rfc1738.html
+ ### And wikipedia for more on windows file:// urls
+ ### http://en.wikipedia.org/wiki/File://
+ if( $href->{scheme} eq 'file' ) {
+
+ my @parts = split '/',$uri;
+
+ ### file://hostname/...
+ ### file://hostname/...
+ ### normalize file://localhost with file:///
+ $href->{host} = $parts[0] || '';
+
+ ### index in @parts where the path components begin;
+ my $index = 1;
+
+ ### file:////hostname/sharename/blah.txt
+ if ( HAS_SHARE and not length $parts[0] and not length $parts[1] ) {
+
+ $href->{host} = $parts[2] || ''; # avoid warnings
+ $href->{share} = $parts[3] || ''; # avoid warnings
+
+ $index = 4 # index after the share
+
+ ### file:///D|/blah.txt
+ ### file:///D:/blah.txt
+ } elsif (HAS_VOL) {
+
+ ### this code comes from dmq's patch, but:
+ ### XXX if volume is empty, wouldn't that be an error? --kane
+ ### if so, our file://localhost test needs to be fixed as wel
+ $href->{vol} = $parts[1] || '';
+
+ ### correct D| style colume descriptors
+ $href->{vol} =~ s/\A([A-Z])\|\z/$1:/i if ON_WIN;
+
+ $index = 2; # index after the volume
+ }
+
+ ### rebuild the path from the leftover parts;
+ $href->{path} = join '/', '', splice( @parts, $index, $#parts );
+
+ } else {
+ ### using anything but qw() in hash slices may produce warnings
+ ### in older perls :-(
+ @{$href}{ qw(host path) } = $uri =~ m|([^/]*)(/.*)$|s;
+ }
+
+ ### split the path into file + dir ###
+ { my @parts = File::Spec::Unix->splitpath( delete $href->{path} );
+ $href->{path} = $parts[1];
+ $href->{file} = $parts[2];
+ }
+
+ ### host will be empty if the target was 'localhost' and the
+ ### scheme was 'file'
+ $href->{host} = '' if ($href->{host} eq 'localhost') and
+ ($href->{scheme} eq 'file');
+
+ return $href;
+}
+
+=head2 $where = $ff->fetch( [to => /my/output/dir/ | \$scalar] )
+
+Fetches the file you requested and returns the full path to the file.
+
+By default it writes to C<cwd()>, but you can override that by specifying
+the C<to> argument:
+
+ ### file fetch to /tmp, full path to the file in $where
+ $where = $ff->fetch( to => '/tmp' );
+
+ ### file slurped into $scalar, full path to the file in $where
+ ### file is downloaded to a temp directory and cleaned up at exit time
+ $where = $ff->fetch( to => \$scalar );
+
+Returns the full path to the downloaded file on success, and false
+on failure.
+
+=cut
+
+sub fetch {
+ my $self = shift or return;
+ my %hash = @_;
+
+ my $target;
+ my $tmpl = {
+ to => { default => cwd(), store => \$target },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ my ($to, $fh);
+ ### you want us to slurp the contents
+ if( ref $target and UNIVERSAL::isa( $target, 'SCALAR' ) ) {
+ $to = tempdir( 'FileFetch.XXXXXX', CLEANUP => 1 );
+
+ ### plain old fetch
+ } else {
+ $to = $target;
+
+ ### On VMS force to VMS format so File::Spec will work.
+ $to = VMS::Filespec::vmspath($to) if ON_VMS;
+
+ ### create the path if it doesn't exist yet ###
+ unless( -d $to ) {
+ eval { mkpath( $to ) };
+
+ return $self->_error(loc("Could not create path '%1'",$to)) if $@;
+ }
+ }
+
+ ### set passive ftp if required ###
+ local $ENV{FTP_PASSIVE} = $FTP_PASSIVE;
+
+ ### we dont use catfile on win32 because if we are using a cygwin tool
+ ### under cmd.exe they wont understand windows style separators.
+ my $out_to = ON_WIN ? $to.'/'.$self->output_file
+ : File::Spec->catfile( $to, $self->output_file );
+
+ for my $method ( @{ $METHODS->{$self->scheme} } ) {
+ my $sub = '_'.$method.'_fetch';
+
+ unless( __PACKAGE__->can($sub) ) {
+ $self->_error(loc("Cannot call method for '%1' -- WEIRD!",
+ $method));
+ next;
+ }
+
+ ### method is blacklisted ###
+ next if grep { lc $_ eq $method } @$BLACKLIST;
+
+ ### method is known to fail ###
+ next if $METHOD_FAIL->{$method};
+
+ ### there's serious issues with IPC::Run and quoting of command
+ ### line arguments. using quotes in the wrong place breaks things,
+ ### and in the case of say,
+ ### C:\cygwin\bin\wget.EXE --quiet --passive-ftp --output-document
+ ### "index.html" "http://www.cpan.org/index.html?q=1&y=2"
+ ### it doesn't matter how you quote, it always fails.
+ local $IPC::Cmd::USE_IPC_RUN = 0;
+
+ if( my $file = $self->$sub(
+ to => $out_to
+ )){
+
+ unless( -e $file && -s _ ) {
+ $self->_error(loc("'%1' said it fetched '%2', ".
+ "but it was not created",$method,$file));
+
+ ### mark the failure ###
+ $METHOD_FAIL->{$method} = 1;
+
+ next;
+
+ } else {
+
+ ### slurp mode?
+ if( ref $target and UNIVERSAL::isa( $target, 'SCALAR' ) ) {
+
+ ### open the file
+ open my $fh, $file or do {
+ $self->_error(
+ loc("Could not open '%1': %2", $file, $!));
+ return;
+ };
+
+ ### slurp
+ $$target = do { local $/; <$fh> };
+
+ }
+
+ my $abs = File::Spec->rel2abs( $file );
+ return $abs;
+
+ }
+ }
+ }
+
+
+ ### if we got here, we looped over all methods, but we weren't able
+ ### to fetch it.
+ return;
+}
+
+########################
+### _*_fetch methods ###
+########################
+
+### LWP fetching ###
+sub _lwp_fetch {
+ my $self = shift;
+ my %hash = @_;
+
+ my ($to);
+ my $tmpl = {
+ to => { required => 1, store => \$to }
+ };
+ check( $tmpl, \%hash ) or return;
+
+ ### modules required to download with lwp ###
+ my $use_list = {
+ LWP => '0.0',
+ 'LWP::UserAgent' => '0.0',
+ 'HTTP::Request' => '0.0',
+ 'HTTP::Status' => '0.0',
+ URI => '0.0',
+
+ };
+
+ if( can_load(modules => $use_list) ) {
+
+ ### setup the uri object
+ my $uri = URI->new( File::Spec::Unix->catfile(
+ $self->path, $self->file
+ ) );
+
+ ### special rules apply for file:// uris ###
+ $uri->scheme( $self->scheme );
+ $uri->host( $self->scheme eq 'file' ? '' : $self->host );
+ $uri->userinfo("anonymous:$FROM_EMAIL") if $self->scheme ne 'file';
+
+ ### set up the useragent object
+ my $ua = LWP::UserAgent->new();
+ $ua->timeout( $TIMEOUT ) if $TIMEOUT;
+ $ua->agent( $USER_AGENT );
+ $ua->from( $FROM_EMAIL );
+ $ua->env_proxy;
+
+ my $res = $ua->mirror($uri, $to) or return;
+
+ ### uptodate or fetched ok ###
+ if ( $res->code == 304 or $res->code == 200 ) {
+ return $to;
+
+ } else {
+ return $self->_error(loc("Fetch failed! HTTP response: %1 %2 [%3]",
+ $res->code, HTTP::Status::status_message($res->code),
+ $res->status_line));
+ }
+
+ } else {
+ $METHOD_FAIL->{'lwp'} = 1;
+ return;
+ }
+}
+
+### Net::FTP fetching
+sub _netftp_fetch {
+ my $self = shift;
+ my %hash = @_;
+
+ my ($to);
+ my $tmpl = {
+ to => { required => 1, store => \$to }
+ };
+ check( $tmpl, \%hash ) or return;
+
+ ### required modules ###
+ my $use_list = { 'Net::FTP' => 0 };
+
+ if( can_load( modules => $use_list ) ) {
+
+ ### make connection ###
+ my $ftp;
+ my @options = ($self->host);
+ push(@options, Timeout => $TIMEOUT) if $TIMEOUT;
+ unless( $ftp = Net::FTP->new( @options ) ) {
+ return $self->_error(loc("Ftp creation failed: %1",$@));
+ }
+
+ ### login ###
+ unless( $ftp->login( anonymous => $FROM_EMAIL ) ) {
+ return $self->_error(loc("Could not login to '%1'",$self->host));
+ }
+
+ ### set binary mode, just in case ###
+ $ftp->binary;
+
+ ### create the remote path
+ ### remember remote paths are unix paths! [#11483]
+ my $remote = File::Spec::Unix->catfile( $self->path, $self->file );
+
+ ### fetch the file ###
+ my $target;
+ unless( $target = $ftp->get( $remote, $to ) ) {
+ return $self->_error(loc("Could not fetch '%1' from '%2'",
+ $remote, $self->host));
+ }
+
+ ### log out ###
+ $ftp->quit;
+
+ return $target;
+
+ } else {
+ $METHOD_FAIL->{'netftp'} = 1;
+ return;
+ }
+}
+
+### /bin/wget fetch ###
+sub _wget_fetch {
+ my $self = shift;
+ my %hash = @_;
+
+ my ($to);
+ my $tmpl = {
+ to => { required => 1, store => \$to }
+ };
+ check( $tmpl, \%hash ) or return;
+
+ ### see if we have a wget binary ###
+ if( my $wget = can_run('wget') ) {
+
+ ### no verboseness, thanks ###
+ my $cmd = [ $wget, '--quiet' ];
+
+ ### if a timeout is set, add it ###
+ push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT;
+
+ ### run passive if specified ###
+ push @$cmd, '--passive-ftp' if $FTP_PASSIVE;
+
+ ### set the output document, add the uri ###
+ push @$cmd, '--output-document', $to, $self->uri;
+
+ ### with IPC::Cmd > 0.41, this is fixed in teh library,
+ ### and there's no need for special casing any more.
+ ### DO NOT quote things for IPC::Run, it breaks stuff.
+ # $IPC::Cmd::USE_IPC_RUN
+ # ? ($to, $self->uri)
+ # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
+
+ ### shell out ###
+ my $captured;
+ unless(run( command => $cmd,
+ buffer => \$captured,
+ verbose => $DEBUG
+ )) {
+ ### wget creates the output document always, even if the fetch
+ ### fails.. so unlink it in that case
+ 1 while unlink $to;
+
+ return $self->_error(loc( "Command failed: %1", $captured || '' ));
+ }
+
+ return $to;
+
+ } else {
+ $METHOD_FAIL->{'wget'} = 1;
+ return;
+ }
+}
+
+### /bin/lftp fetch ###
+sub _lftp_fetch {
+ my $self = shift;
+ my %hash = @_;
+
+ my ($to);
+ my $tmpl = {
+ to => { required => 1, store => \$to }
+ };
+ check( $tmpl, \%hash ) or return;
+
+ ### see if we have a wget binary ###
+ if( my $lftp = can_run('lftp') ) {
+
+ ### no verboseness, thanks ###
+ my $cmd = [ $lftp, '-f' ];
+
+ my $fh = File::Temp->new;
+
+ my $str;
+
+ ### if a timeout is set, add it ###
+ $str .= "set net:timeout $TIMEOUT;\n" if $TIMEOUT;
+
+ ### run passive if specified ###
+ $str .= "set ftp:passive-mode 1;\n" if $FTP_PASSIVE;
+
+ ### set the output document, add the uri ###
+ ### quote the URI, because lftp supports certain shell
+ ### expansions, most notably & for backgrounding.
+ ### ' quote does nto work, must be "
+ $str .= q[get ']. $self->uri .q[' -o ]. $to . $/;
+
+ if( $DEBUG ) {
+ my $pp_str = join ' ', split $/, $str;
+ print "# lftp command: $pp_str\n";
+ }
+
+ ### write straight to the file.
+ $fh->autoflush(1);
+ print $fh $str;
+
+ ### the command needs to be 1 string to be executed
+ push @$cmd, $fh->filename;
+
+ ### with IPC::Cmd > 0.41, this is fixed in teh library,
+ ### and there's no need for special casing any more.
+ ### DO NOT quote things for IPC::Run, it breaks stuff.
+ # $IPC::Cmd::USE_IPC_RUN
+ # ? ($to, $self->uri)
+ # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
+
+
+ ### shell out ###
+ my $captured;
+ unless(run( command => $cmd,
+ buffer => \$captured,
+ verbose => $DEBUG
+ )) {
+ ### wget creates the output document always, even if the fetch
+ ### fails.. so unlink it in that case
+ 1 while unlink $to;
+
+ return $self->_error(loc( "Command failed: %1", $captured || '' ));
+ }
+
+ return $to;
+
+ } else {
+ $METHOD_FAIL->{'lftp'} = 1;
+ return;
+ }
+}
+
+
+
+### /bin/ftp fetch ###
+sub _ftp_fetch {
+ my $self = shift;
+ my %hash = @_;
+
+ my ($to);
+ my $tmpl = {
+ to => { required => 1, store => \$to }
+ };
+ check( $tmpl, \%hash ) or return;
+
+ ### see if we have a ftp binary ###
+ if( my $ftp = can_run('ftp') ) {
+
+ my $fh = FileHandle->new;
+
+ local $SIG{CHLD} = 'IGNORE';
+
+ unless ($fh->open("|$ftp -n")) {
+ return $self->_error(loc("%1 creation failed: %2", $ftp, $!));
+ }
+
+ my @dialog = (
+ "lcd " . dirname($to),
+ "open " . $self->host,
+ "user anonymous $FROM_EMAIL",
+ "cd /",
+ "cd " . $self->path,
+ "binary",
+ "get " . $self->file . " " . $self->output_file,
+ "quit",
+ );
+
+ foreach (@dialog) { $fh->print($_, "\n") }
+ $fh->close or return;
+
+ return $to;
+ }
+}
+
+### lynx is stupid - it decompresses any .gz file it finds to be text
+### use /bin/lynx to fetch files
+sub _lynx_fetch {
+ my $self = shift;
+ my %hash = @_;
+
+ my ($to);
+ my $tmpl = {
+ to => { required => 1, store => \$to }
+ };
+ check( $tmpl, \%hash ) or return;
+
+ ### see if we have a lynx binary ###
+ if( my $lynx = can_run('lynx') ) {
+
+ unless( IPC::Cmd->can_capture_buffer ) {
+ $METHOD_FAIL->{'lynx'} = 1;
+
+ return $self->_error(loc(
+ "Can not capture buffers. Can not use '%1' to fetch files",
+ 'lynx' ));
+ }
+
+ ### check if the HTTP resource exists ###
+ if ($self->uri =~ /^https?:\/\//i) {
+ my $cmd = [
+ $lynx,
+ '-head',
+ '-source',
+ "-auth=anonymous:$FROM_EMAIL",
+ ];
+
+ push @$cmd, "-connect_timeout=$TIMEOUT" if $TIMEOUT;
+
+ push @$cmd, $self->uri;
+
+ ### shell out ###
+ my $head;
+ unless(run( command => $cmd,
+ buffer => \$head,
+ verbose => $DEBUG )
+ ) {
+ return $self->_error(loc("Command failed: %1", $head || ''));
+ }
+
+ unless($head =~ /^HTTP\/\d+\.\d+ 200\b/) {
+ return $self->_error(loc("Command failed: %1", $head || ''));
+ }
+ }
+
+ ### write to the output file ourselves, since lynx ass_u_mes to much
+ my $local = FileHandle->new(">$to")
+ or return $self->_error(loc(
+ "Could not open '%1' for writing: %2",$to,$!));
+
+ ### dump to stdout ###
+ my $cmd = [
+ $lynx,
+ '-source',
+ "-auth=anonymous:$FROM_EMAIL",
+ ];
+
+ push @$cmd, "-connect_timeout=$TIMEOUT" if $TIMEOUT;
+
+ ### DO NOT quote things for IPC::Run, it breaks stuff.
+ push @$cmd, $self->uri;
+
+ ### with IPC::Cmd > 0.41, this is fixed in teh library,
+ ### and there's no need for special casing any more.
+ ### DO NOT quote things for IPC::Run, it breaks stuff.
+ # $IPC::Cmd::USE_IPC_RUN
+ # ? $self->uri
+ # : QUOTE. $self->uri .QUOTE;
+
+
+ ### shell out ###
+ my $captured;
+ unless(run( command => $cmd,
+ buffer => \$captured,
+ verbose => $DEBUG )
+ ) {
+ return $self->_error(loc("Command failed: %1", $captured || ''));
+ }
+
+ ### print to local file ###
+ ### XXX on a 404 with a special error page, $captured will actually
+ ### hold the contents of that page, and make it *appear* like the
+ ### request was a success, when really it wasn't :(
+ ### there doesn't seem to be an option for lynx to change the exit
+ ### code based on a 4XX status or so.
+ ### the closest we can come is using --error_file and parsing that,
+ ### which is very unreliable ;(
+ $local->print( $captured );
+ $local->close or return;
+
+ return $to;
+
+ } else {
+ $METHOD_FAIL->{'lynx'} = 1;
+ return;
+ }
+}
+
+### use /bin/ncftp to fetch files
+sub _ncftp_fetch {
+ my $self = shift;
+ my %hash = @_;
+
+ my ($to);
+ my $tmpl = {
+ to => { required => 1, store => \$to }
+ };
+ check( $tmpl, \%hash ) or return;
+
+ ### we can only set passive mode in interactive sesssions, so bail out
+ ### if $FTP_PASSIVE is set
+ return if $FTP_PASSIVE;
+
+ ### see if we have a ncftp binary ###
+ if( my $ncftp = can_run('ncftp') ) {
+
+ my $cmd = [
+ $ncftp,
+ '-V', # do not be verbose
+ '-p', $FROM_EMAIL, # email as password
+ $self->host, # hostname
+ dirname($to), # local dir for the file
+ # remote path to the file
+ ### DO NOT quote things for IPC::Run, it breaks stuff.
+ $IPC::Cmd::USE_IPC_RUN
+ ? File::Spec::Unix->catdir( $self->path, $self->file )
+ : QUOTE. File::Spec::Unix->catdir(
+ $self->path, $self->file ) .QUOTE
+
+ ];
+
+ ### shell out ###
+ my $captured;
+ unless(run( command => $cmd,
+ buffer => \$captured,
+ verbose => $DEBUG )
+ ) {
+ return $self->_error(loc("Command failed: %1", $captured || ''));
+ }
+
+ return $to;
+
+ } else {
+ $METHOD_FAIL->{'ncftp'} = 1;
+ return;
+ }
+}
+
+### use /bin/curl to fetch files
+sub _curl_fetch {
+ my $self = shift;
+ my %hash = @_;
+
+ my ($to);
+ my $tmpl = {
+ to => { required => 1, store => \$to }
+ };
+ check( $tmpl, \%hash ) or return;
+
+ if (my $curl = can_run('curl')) {
+
+ ### these long opts are self explanatory - I like that -jmb
+ my $cmd = [ $curl, '-q' ];
+
+ push(@$cmd, '--connect-timeout', $TIMEOUT) if $TIMEOUT;
+
+ push(@$cmd, '--silent') unless $DEBUG;
+
+ ### curl does the right thing with passive, regardless ###
+ if ($self->scheme eq 'ftp') {
+ push(@$cmd, '--user', "anonymous:$FROM_EMAIL");
+ }
+
+ ### curl doesn't follow 302 (temporarily moved) etc automatically
+ ### so we add --location to enable that.
+ push @$cmd, '--fail', '--location', '--output', $to, $self->uri;
+
+ ### with IPC::Cmd > 0.41, this is fixed in teh library,
+ ### and there's no need for special casing any more.
+ ### DO NOT quote things for IPC::Run, it breaks stuff.
+ # $IPC::Cmd::USE_IPC_RUN
+ # ? ($to, $self->uri)
+ # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
+
+
+ my $captured;
+ unless(run( command => $cmd,
+ buffer => \$captured,
+ verbose => $DEBUG )
+ ) {
+
+ return $self->_error(loc("Command failed: %1", $captured || ''));
+ }
+
+ return $to;
+
+ } else {
+ $METHOD_FAIL->{'curl'} = 1;
+ return;
+ }
+}
+
+
+### use File::Copy for fetching file:// urls ###
+###
+### See section 3.10 of RFC 1738 (http://www.faqs.org/rfcs/rfc1738.html)
+### Also see wikipedia on file:// (http://en.wikipedia.org/wiki/File://)
+###
+
+sub _file_fetch {
+ my $self = shift;
+ my %hash = @_;
+
+ my ($to);
+ my $tmpl = {
+ to => { required => 1, store => \$to }
+ };
+ check( $tmpl, \%hash ) or return;
+
+
+
+ ### prefix a / on unix systems with a file uri, since it would
+ ### look somewhat like this:
+ ### file:///home/kane/file
+ ### wheras windows file uris for 'c:\some\dir\file' might look like:
+ ### file:///C:/some/dir/file
+ ### file:///C|/some/dir/file
+ ### or for a network share '\\host\share\some\dir\file':
+ ### file:////host/share/some/dir/file
+ ###
+ ### VMS file uri's for 'DISK$USER:[MY.NOTES]NOTE123456.TXT' might look like:
+ ### file://vms.host.edu/disk$user/my/notes/note12345.txt
+ ###
+
+ my $path = $self->path;
+ my $vol = $self->vol;
+ my $share = $self->share;
+
+ my $remote;
+ if (!$share and $self->host) {
+ return $self->_error(loc(
+ "Currently %1 cannot handle hosts in %2 urls",
+ 'File::Fetch', 'file://'
+ ));
+ }
+
+ if( $vol ) {
+ $path = File::Spec->catdir( split /\//, $path );
+ $remote = File::Spec->catpath( $vol, $path, $self->file);
+
+ } elsif( $share ) {
+ ### win32 specific, and a share name, so we wont bother with File::Spec
+ $path =~ s|/+|\\|g;
+ $remote = "\\\\".$self->host."\\$share\\$path";
+
+ } else {
+ ### File::Spec on VMS can not currently handle UNIX syntax.
+ my $file_class = ON_VMS
+ ? 'File::Spec::Unix'
+ : 'File::Spec';
+
+ $remote = $file_class->catfile( $path, $self->file );
+ }
+
+ ### File::Copy is littered with 'die' statements :( ###
+ my $rv = eval { File::Copy::copy( $remote, $to ) };
+
+ ### something went wrong ###
+ if( !$rv or $@ ) {
+ return $self->_error(loc("Could not copy '%1' to '%2': %3 %4",
+ $remote, $to, $!, $@));
+ }
+
+ return $to;
+}
+
+### use /usr/bin/rsync to fetch files
+sub _rsync_fetch {
+ my $self = shift;
+ my %hash = @_;
+
+ my ($to);
+ my $tmpl = {
+ to => { required => 1, store => \$to }
+ };
+ check( $tmpl, \%hash ) or return;
+
+ if (my $rsync = can_run('rsync')) {
+
+ my $cmd = [ $rsync ];
+
+ ### XXX: rsync has no I/O timeouts at all, by default
+ push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT;
+
+ push(@$cmd, '--quiet') unless $DEBUG;
+
+ ### DO NOT quote things for IPC::Run, it breaks stuff.
+ push @$cmd, $self->uri, $to;
+
+ ### with IPC::Cmd > 0.41, this is fixed in teh library,
+ ### and there's no need for special casing any more.
+ ### DO NOT quote things for IPC::Run, it breaks stuff.
+ # $IPC::Cmd::USE_IPC_RUN
+ # ? ($to, $self->uri)
+ # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
+
+ my $captured;
+ unless(run( command => $cmd,
+ buffer => \$captured,
+ verbose => $DEBUG )
+ ) {
+
+ return $self->_error(loc("Command %1 failed: %2",
+ "@$cmd" || '', $captured || ''));
+ }
+
+ return $to;
+
+ } else {
+ $METHOD_FAIL->{'rsync'} = 1;
+ return;
+ }
+}
+
+#################################
+#
+# Error code
+#
+#################################
+
+=pod
+
+=head2 $ff->error([BOOL])
+
+Returns the last encountered error as string.
+Pass it a true value to get the C<Carp::longmess()> output instead.
+
+=cut
+
+### error handling the way Archive::Extract does it
+sub _error {
+ my $self = shift;
+ my $error = shift;
+
+ $self->_error_msg( $error );
+ $self->_error_msg_long( Carp::longmess($error) );
+
+ if( $WARN ) {
+ carp $DEBUG ? $self->_error_msg_long : $self->_error_msg;
+ }
+
+ return;
+}
+
+sub error {
+ my $self = shift;
+ return shift() ? $self->_error_msg_long : $self->_error_msg;
+}
+
+
+1;
+
+=pod
+
+=head1 HOW IT WORKS
+
+File::Fetch is able to fetch a variety of uris, by using several
+external programs and modules.
+
+Below is a mapping of what utilities will be used in what order
+for what schemes, if available:
+
+ file => LWP, lftp, file
+ http => LWP, wget, curl, lftp, lynx
+ ftp => LWP, Net::FTP, wget, curl, lftp, ncftp, ftp
+ rsync => rsync
+
+If you'd like to disable the use of one or more of these utilities
+and/or modules, see the C<$BLACKLIST> variable further down.
+
+If a utility or module isn't available, it will be marked in a cache
+(see the C<$METHOD_FAIL> variable further down), so it will not be
+tried again. The C<fetch> method will only fail when all options are
+exhausted, and it was not able to retrieve the file.
+
+A special note about fetching files from an ftp uri:
+
+By default, all ftp connections are done in passive mode. To change
+that, see the C<$FTP_PASSIVE> variable further down.
+
+Furthermore, ftp uris only support anonymous connections, so no
+named user/password pair can be passed along.
+
+C</bin/ftp> is blacklisted by default; see the C<$BLACKLIST> variable
+further down.
+
+=head1 GLOBAL VARIABLES
+
+The behaviour of File::Fetch can be altered by changing the following
+global variables:
+
+=head2 $File::Fetch::FROM_EMAIL
+
+This is the email address that will be sent as your anonymous ftp
+password.
+
+Default is C<File-Fetch at example.com>.
+
+=head2 $File::Fetch::USER_AGENT
+
+This is the useragent as C<LWP> will report it.
+
+Default is C<File::Fetch/$VERSION>.
+
+=head2 $File::Fetch::FTP_PASSIVE
+
+This variable controls whether the environment variable C<FTP_PASSIVE>
+and any passive switches to commandline tools will be set to true.
+
+Default value is 1.
+
+Note: When $FTP_PASSIVE is true, C<ncftp> will not be used to fetch
+files, since passive mode can only be set interactively for this binary
+
+=head2 $File::Fetch::TIMEOUT
+
+When set, controls the network timeout (counted in seconds).
+
+Default value is 0.
+
+=head2 $File::Fetch::WARN
+
+This variable controls whether errors encountered internally by
+C<File::Fetch> should be C<carp>'d or not.
+
+Set to false to silence warnings. Inspect the output of the C<error()>
+method manually to see what went wrong.
+
+Defaults to C<true>.
+
+=head2 $File::Fetch::DEBUG
+
+This enables debugging output when calling commandline utilities to
+fetch files.
+This also enables C<Carp::longmess> errors, instead of the regular
+C<carp> errors.
+
+Good for tracking down why things don't work with your particular
+setup.
+
+Default is 0.
+
+=head2 $File::Fetch::BLACKLIST
+
+This is an array ref holding blacklisted modules/utilities for fetching
+files with.
+
+To disallow the use of, for example, C<LWP> and C<Net::FTP>, you could
+set $File::Fetch::BLACKLIST to:
+
+ $File::Fetch::BLACKLIST = [qw|lwp netftp|]
+
+The default blacklist is [qw|ftp|], as C</bin/ftp> is rather unreliable.
+
+See the note on C<MAPPING> below.
+
+=head2 $File::Fetch::METHOD_FAIL
+
+This is a hashref registering what modules/utilities were known to fail
+for fetching files (mostly because they weren't installed).
+
+You can reset this cache by assigning an empty hashref to it, or
+individually remove keys.
+
+See the note on C<MAPPING> below.
+
+=head1 MAPPING
+
+
+Here's a quick mapping for the utilities/modules, and their names for
+the $BLACKLIST, $METHOD_FAIL and other internal functions.
+
+ LWP => lwp
+ Net::FTP => netftp
+ wget => wget
+ lynx => lynx
+ ncftp => ncftp
+ ftp => ftp
+ curl => curl
+ rsync => rsync
+ lftp => lftp
+
+=head1 FREQUENTLY ASKED QUESTIONS
+
+=head2 So how do I use a proxy with File::Fetch?
+
+C<File::Fetch> currently only supports proxies with LWP::UserAgent.
+You will need to set your environment variables accordingly. For
+example, to use an ftp proxy:
+
+ $ENV{ftp_proxy} = 'foo.com';
+
+Refer to the LWP::UserAgent manpage for more details.
+
+=head2 I used 'lynx' to fetch a file, but its contents is all wrong!
+
+C<lynx> can only fetch remote files by dumping its contents to C<STDOUT>,
+which we in turn capture. If that content is a 'custom' error file
+(like, say, a C<404 handler>), you will get that contents instead.
+
+Sadly, C<lynx> doesn't support any options to return a different exit
+code on non-C<200 OK> status, giving us no way to tell the difference
+between a 'successfull' fetch and a custom error page.
+
+Therefor, we recommend to only use C<lynx> as a last resort. This is
+why it is at the back of our list of methods to try as well.
+
+=head2 Files I'm trying to fetch have reserved characters or non-ASCII characters in them. What do I do?
+
+C<File::Fetch> is relatively smart about things. When trying to write
+a file to disk, it removes the C<query parameters> (see the
+C<output_file> method for details) from the file name before creating
+it. In most cases this suffices.
+
+If you have any other characters you need to escape, please install
+the C<URI::Escape> module from CPAN, and pre-encode your URI before
+passing it to C<File::Fetch>. You can read about the details of URIs
+and URI encoding here:
+
+ http://www.faqs.org/rfcs/rfc2396.html
+
+=head1 TODO
+
+=over 4
+
+=item Implement $PREFER_BIN
+
+To indicate to rather use commandline tools than modules
+
+=back
+
+=head1 BUG REPORTS
+
+Please report bugs or other issues to E<lt>bug-file-fetch at rt.cpan.org<gt>.
+
+=head1 AUTHOR
+
+This module by Jos Boumans E<lt>kane at cpan.orgE<gt>.
+
+=head1 COPYRIGHT
+
+This library is free software; you may redistribute and/or modify it
+under the same terms as Perl itself.
+
+
+=cut
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
+
+
+
+
Modified: trunk/contrib/perl/lib/File/Find/t/find.t
===================================================================
--- trunk/contrib/perl/lib/File/Find/t/find.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/File/Find/t/find.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -18,7 +18,7 @@
$SIG{'__WARN__'} = sub { $warn_msg = $_[0]; warn "# $_[0]"; }
}
-my $test_count = 85;
+my $test_count = 98;
$test_count += 119 if $symlink_exists;
$test_count += 26 if $^O eq 'MSWin32';
$test_count += 2 if $^O eq 'MSWin32' and $symlink_exists;
@@ -108,6 +108,21 @@
rmdir dir_path('fb', 'fbc');
rmdir dir_path('fb');
}
+ if (-d dir_path('fc')) {
+ unlink (
+ file_path('fc', 'fca', 'match_alpha'),
+ file_path('fc', 'fca', 'match_beta'),
+ file_path('fc', 'fcb', 'match_gamma'),
+ file_path('fc', 'fcb', 'delta'),
+ file_path('fc', 'fcc', 'match_epsilon'),
+ file_path('fc', 'fcc', 'match_zeta'),
+ file_path('fc', 'fcc', 'eta'),
+ );
+ rmdir dir_path('fc', 'fca');
+ rmdir dir_path('fc', 'fcb');
+ rmdir dir_path('fc', 'fcc');
+ rmdir dir_path('fc');
+ }
if ($need_updir) {
my $updir = $^O eq 'VMS' ? File::Spec::VMS->updir() : File::Spec->updir;
chdir($updir);
@@ -197,7 +212,7 @@
print "# --preprocess--\n";
print "# \$File::Find::dir => '$File::Find::dir' \n";
foreach $file (@files) {
- $file =~ s/\.(dir)?$// if $^O eq 'VMS';
+ $file =~ s/\.(dir)?$//i if $^O eq 'VMS';
print "# $file \n";
delete $Expect_Dir{ $File::Find::dir }->{$file};
}
@@ -870,7 +885,42 @@
Check (!$dangling_symlink);
}
+print "# RT 59750\n";
+MkDir( dir_path('fc'), 0770 );
+MkDir( dir_path('fc', 'fca'), 0770 );
+MkDir( dir_path('fc', 'fcb'), 0770 );
+MkDir( dir_path('fc', 'fcc'), 0770 );
+touch( file_path('fc', 'fca', 'match_alpha') );
+touch( file_path('fc', 'fca', 'match_beta') );
+touch( file_path('fc', 'fcb', 'match_gamma') );
+touch( file_path('fc', 'fcb', 'delta') );
+touch( file_path('fc', 'fcc', 'match_epsilon') );
+touch( file_path('fc', 'fcc', 'match_zeta') );
+touch( file_path('fc', 'fcc', 'eta') );
+my @files_from_mixed = ();
+sub wantmatch {
+ if ( $File::Find::name =~ m/match/ ) {
+ push @files_from_mixed, $_;
+ print "# \$_ => '$_'\n";
+ }
+}
+find( \&wantmatch, (
+ dir_path('fc', 'fca'),
+ dir_path('fc', 'fcb'),
+ dir_path('fc', 'fcc'),
+) );
+Check( scalar(@files_from_mixed) == 5 );
+
+ at files_from_mixed = ();
+find( \&wantmatch, (
+ dir_path('fc', 'fca'),
+ dir_path('fc', 'fcb'),
+ file_path('fc', 'fcc', 'match_epsilon'),
+ file_path('fc', 'fcc', 'eta'),
+) );
+Check( scalar(@files_from_mixed) == 4 );
+
if ($^O eq 'MSWin32') {
# Check F:F:f correctly handles a root directory path.
# Rather than processing the entire drive (!), simply test that the
Property changes on: trunk/contrib/perl/lib/File/Find/t/find.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/File/Find/t/taint.t
===================================================================
--- trunk/contrib/perl/lib/File/Find/t/taint.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/File/Find/t/taint.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,5 +1,13 @@
#!./perl -T
use strict;
+use Test::More;
+BEGIN {
+ plan(
+ ${^TAINT}
+ ? (tests => 45)
+ : (skip_all => "A perl without taint support")
+ );
+}
my %Expect_File = (); # what we expect for $_
my %Expect_Name = (); # what we expect for $File::Find::name/fullname
@@ -6,7 +14,6 @@
my %Expect_Dir = (); # what we expect for $File::Find::dir
my ($cwd, $cwd_untainted);
-
BEGIN {
require File::Spec;
chdir 't' if -d 't';
@@ -42,8 +49,6 @@
$ENV{'PATH'} = join($sep, at path);
}
-use Test::More tests => 45;
-
my $symlink_exists = eval { symlink("",""); 1 };
use File::Find;
Property changes on: trunk/contrib/perl/lib/File/Find/t/taint.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/lib/File/Find.pm
===================================================================
--- trunk/contrib/perl/lib/File/Find.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/File/Find.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -3,7 +3,7 @@
use strict;
use warnings;
use warnings::register;
-our $VERSION = '1.19';
+our $VERSION = '1.23';
require Exporter;
require Cwd;
@@ -114,7 +114,7 @@
links (followed) may contain files more than once and may even have
cycles, a hash has to be built up with an entry for each file.
This might be expensive both in space and time for a large
-directory tree. See I<follow_fast> and I<follow_skip> below.
+directory tree. See L</follow_fast> and L</follow_skip> below.
If either I<follow> or I<follow_fast> is in effect:
=over 6
@@ -280,6 +280,14 @@
-l && !-e && print "bogus link: $File::Find::name\n";
}
+Note that you may mix directories and (non-directory) files in the list of
+directories to be searched by the C<wanted()> function.
+
+ find(\&wanted, "./foo", "./bar", "./baz/epsilon");
+
+In the example above, no file in F<./baz/> other than F<./baz/epsilon> will be
+evaluated by C<wanted()>.
+
See also the script C<pfind> on CPAN for a nice application of this
module.
@@ -515,6 +523,7 @@
Proc_Top_Item:
foreach my $TOP (@_) {
my $top_item = $TOP;
+ $top_item = VMS::Filespec::unixify($top_item) if $Is_VMS;
($topdev,$topino,$topmode,$topnlink) = $follow ? stat $top_item : lstat $top_item;
@@ -1095,8 +1104,7 @@
$File::Find::dont_use_nlink = 1
if $^O eq 'os2' || $^O eq 'dos' || $^O eq 'amigaos' || $Is_Win32 ||
- $^O eq 'interix' || $^O eq 'cygwin' || $^O eq 'epoc' || $^O eq 'qnx' ||
- $^O eq 'nto';
+ $^O eq 'interix' || $^O eq 'cygwin' || $^O eq 'qnx' || $^O eq 'nto';
# Set dont_use_nlink in your hint file if your system's stat doesn't
# report the number of links in a directory as an indication
Property changes on: trunk/contrib/perl/lib/File/Find.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Copied: trunk/contrib/perl/lib/File/Path.pm (from rev 6437, vendor/perl/5.18.1/lib/File/Path.pm)
===================================================================
--- trunk/contrib/perl/lib/File/Path.pm (rev 0)
+++ trunk/contrib/perl/lib/File/Path.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,895 @@
+package File::Path;
+
+use 5.005_04;
+use strict;
+
+use Cwd 'getcwd';
+use File::Basename ();
+use File::Spec ();
+
+BEGIN {
+ if ($] < 5.006) {
+ # can't say 'opendir my $dh, $dirname'
+ # need to initialise $dh
+ eval "use Symbol";
+ }
+}
+
+use Exporter ();
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
+$VERSION = '2.07_03';
+ at ISA = qw(Exporter);
+ at EXPORT = qw(mkpath rmtree);
+ at EXPORT_OK = qw(make_path remove_tree);
+
+my $Is_VMS = $^O eq 'VMS';
+my $Is_MacOS = $^O eq 'MacOS';
+
+# These OSes complain if you want to remove a file that you have no
+# write permission to:
+my $Force_Writeable = grep {$^O eq $_} qw(amigaos dos epoc MSWin32 MacOS os2);
+
+# Unix-like systems need to stat each directory in order to detect
+# race condition. MS-Windows is immune to this particular attack.
+my $Need_Stat_Check = !($^O eq 'MSWin32');
+
+sub _carp {
+ require Carp;
+ goto &Carp::carp;
+}
+
+sub _croak {
+ require Carp;
+ goto &Carp::croak;
+}
+
+sub _error {
+ my $arg = shift;
+ my $message = shift;
+ my $object = shift;
+
+ if ($arg->{error}) {
+ $object = '' unless defined $object;
+ $message .= ": $!" if $!;
+ push @{${$arg->{error}}}, {$object => $message};
+ }
+ else {
+ _carp(defined($object) ? "$message for $object: $!" : "$message: $!");
+ }
+}
+
+sub make_path {
+ push @_, {} unless @_ and UNIVERSAL::isa($_[-1],'HASH');
+ goto &mkpath;
+}
+
+sub mkpath {
+ my $old_style = !(@_ and UNIVERSAL::isa($_[-1],'HASH'));
+
+ my $arg;
+ my $paths;
+
+ if ($old_style) {
+ my ($verbose, $mode);
+ ($paths, $verbose, $mode) = @_;
+ $paths = [$paths] unless UNIVERSAL::isa($paths,'ARRAY');
+ $arg->{verbose} = $verbose;
+ $arg->{mode} = defined $mode ? $mode : 0777;
+ }
+ else {
+ $arg = pop @_;
+ $arg->{mode} = delete $arg->{mask} if exists $arg->{mask};
+ $arg->{mode} = 0777 unless exists $arg->{mode};
+ ${$arg->{error}} = [] if exists $arg->{error};
+ $paths = [@_];
+ }
+ return _mkpath($arg, $paths);
+}
+
+sub _mkpath {
+ my $arg = shift;
+ my $paths = shift;
+
+ my(@created,$path);
+ foreach $path (@$paths) {
+ next unless defined($path) and length($path);
+ $path .= '/' if $^O eq 'os2' and $path =~ /^\w:\z/s; # feature of CRT
+ # Logic wants Unix paths, so go with the flow.
+ if ($Is_VMS) {
+ next if $path eq '/';
+ $path = VMS::Filespec::unixify($path);
+ }
+ next if -d $path;
+ my $parent = File::Basename::dirname($path);
+ unless (-d $parent or $path eq $parent) {
+ push(@created,_mkpath($arg, [$parent]));
+ }
+ print "mkdir $path\n" if $arg->{verbose};
+ if (mkdir($path,$arg->{mode})) {
+ push(@created, $path);
+ }
+ else {
+ my $save_bang = $!;
+ my ($e, $e1) = ($save_bang, $^E);
+ $e .= "; $e1" if $e ne $e1;
+ # allow for another process to have created it meanwhile
+ if (!-d $path) {
+ $! = $save_bang;
+ if ($arg->{error}) {
+ push @{${$arg->{error}}}, {$path => $e};
+ }
+ else {
+ _croak("mkdir $path: $e");
+ }
+ }
+ }
+ }
+ return @created;
+}
+
+sub remove_tree {
+ push @_, {} unless @_ and UNIVERSAL::isa($_[-1],'HASH');
+ goto &rmtree;
+}
+
+sub _is_subdir {
+ my($dir, $test) = @_;
+
+ my($dv, $dd) = File::Spec->splitpath($dir, 1);
+ my($tv, $td) = File::Spec->splitpath($test, 1);
+
+ # not on same volume
+ return 0 if $dv ne $tv;
+
+ my @d = File::Spec->splitdir($dd);
+ my @t = File::Spec->splitdir($td);
+
+ # @t can't be a subdir if it's shorter than @d
+ return 0 if @t < @d;
+
+ return join('/', @d) eq join('/', splice @t, 0, + at d);
+}
+
+sub rmtree {
+ my $old_style = !(@_ and UNIVERSAL::isa($_[-1],'HASH'));
+
+ my $arg;
+ my $paths;
+
+ if ($old_style) {
+ my ($verbose, $safe);
+ ($paths, $verbose, $safe) = @_;
+ $arg->{verbose} = $verbose;
+ $arg->{safe} = defined $safe ? $safe : 0;
+
+ if (defined($paths) and length($paths)) {
+ $paths = [$paths] unless UNIVERSAL::isa($paths,'ARRAY');
+ }
+ else {
+ _carp ("No root path(s) specified\n");
+ return 0;
+ }
+ }
+ else {
+ $arg = pop @_;
+ ${$arg->{error}} = [] if exists $arg->{error};
+ ${$arg->{result}} = [] if exists $arg->{result};
+ $paths = [@_];
+ }
+
+ $arg->{prefix} = '';
+ $arg->{depth} = 0;
+
+ my @clean_path;
+ $arg->{cwd} = getcwd() or do {
+ _error($arg, "cannot fetch initial working directory");
+ return 0;
+ };
+ for ($arg->{cwd}) { /\A(.*)\Z/; $_ = $1 } # untaint
+
+ for my $p (@$paths) {
+ # need to fixup case and map \ to / on Windows
+ my $ortho_root = $^O eq 'MSWin32' ? _slash_lc($p) : $p;
+ my $ortho_cwd = $^O eq 'MSWin32' ? _slash_lc($arg->{cwd}) : $arg->{cwd};
+ my $ortho_root_length = length($ortho_root);
+ $ortho_root_length-- if $^O eq 'VMS'; # don't compare '.' with ']'
+ if ($ortho_root_length && _is_subdir($ortho_root, $ortho_cwd)) {
+ local $! = 0;
+ _error($arg, "cannot remove path when cwd is $arg->{cwd}", $p);
+ next;
+ }
+
+ if ($Is_MacOS) {
+ $p = ":$p" unless $p =~ /:/;
+ $p .= ":" unless $p =~ /:\z/;
+ }
+ elsif ($^O eq 'MSWin32') {
+ $p =~ s{[/\\]\z}{};
+ }
+ else {
+ $p =~ s{/\z}{};
+ }
+ push @clean_path, $p;
+ }
+
+ @{$arg}{qw(device inode perm)} = (lstat $arg->{cwd})[0,1] or do {
+ _error($arg, "cannot stat initial working directory", $arg->{cwd});
+ return 0;
+ };
+
+ return _rmtree($arg, \@clean_path);
+}
+
+sub _rmtree {
+ my $arg = shift;
+ my $paths = shift;
+
+ my $count = 0;
+ my $curdir = File::Spec->curdir();
+ my $updir = File::Spec->updir();
+
+ my (@files, $root);
+ ROOT_DIR:
+ foreach $root (@$paths) {
+ # since we chdir into each directory, it may not be obvious
+ # to figure out where we are if we generate a message about
+ # a file name. We therefore construct a semi-canonical
+ # filename, anchored from the directory being unlinked (as
+ # opposed to being truly canonical, anchored from the root (/).
+
+ my $canon = $arg->{prefix}
+ ? File::Spec->catfile($arg->{prefix}, $root)
+ : $root
+ ;
+
+ my ($ldev, $lino, $perm) = (lstat $root)[0,1,2] or next ROOT_DIR;
+
+ if ( -d _ ) {
+ $root = VMS::Filespec::pathify($root) if $Is_VMS;
+
+ if (!chdir($root)) {
+ # see if we can escalate privileges to get in
+ # (e.g. funny protection mask such as -w- instead of rwx)
+ $perm &= 07777;
+ my $nperm = $perm | 0700;
+ if (!($arg->{safe} or $nperm == $perm or chmod($nperm, $root))) {
+ _error($arg, "cannot make child directory read-write-exec", $canon);
+ next ROOT_DIR;
+ }
+ elsif (!chdir($root)) {
+ _error($arg, "cannot chdir to child", $canon);
+ next ROOT_DIR;
+ }
+ }
+
+ my ($cur_dev, $cur_inode, $perm) = (stat $curdir)[0,1,2] or do {
+ _error($arg, "cannot stat current working directory", $canon);
+ next ROOT_DIR;
+ };
+
+ if ($Need_Stat_Check) {
+ ($ldev eq $cur_dev and $lino eq $cur_inode)
+ or _croak("directory $canon changed before chdir, expected dev=$ldev ino=$lino, actual dev=$cur_dev ino=$cur_inode, aborting.");
+ }
+
+ $perm &= 07777; # don't forget setuid, setgid, sticky bits
+ my $nperm = $perm | 0700;
+
+ # notabene: 0700 is for making readable in the first place,
+ # it's also intended to change it to writable in case we have
+ # to recurse in which case we are better than rm -rf for
+ # subtrees with strange permissions
+
+ if (!($arg->{safe} or $nperm == $perm or chmod($nperm, $curdir))) {
+ _error($arg, "cannot make directory read+writeable", $canon);
+ $nperm = $perm;
+ }
+
+ my $d;
+ $d = gensym() if $] < 5.006;
+ if (!opendir $d, $curdir) {
+ _error($arg, "cannot opendir", $canon);
+ @files = ();
+ }
+ else {
+ no strict 'refs';
+ if (!defined ${"\cTAINT"} or ${"\cTAINT"}) {
+ # Blindly untaint dir names if taint mode is
+ # active, or any perl < 5.006
+ @files = map { /\A(.*)\z/s; $1 } readdir $d;
+ }
+ else {
+ @files = readdir $d;
+ }
+ closedir $d;
+ }
+
+ if ($Is_VMS) {
+ # Deleting large numbers of files from VMS Files-11
+ # filesystems is faster if done in reverse ASCIIbetical order.
+ # include '.' to '.;' from blead patch #31775
+ @files = map {$_ eq '.' ? '.;' : $_} reverse @files;
+ ($root = VMS::Filespec::unixify($root)) =~ s/\.dir\z//;
+ }
+
+ @files = grep {$_ ne $updir and $_ ne $curdir} @files;
+
+ if (@files) {
+ # remove the contained files before the directory itself
+ my $narg = {%$arg};
+ @{$narg}{qw(device inode cwd prefix depth)}
+ = ($cur_dev, $cur_inode, $updir, $canon, $arg->{depth}+1);
+ $count += _rmtree($narg, \@files);
+ }
+
+ # restore directory permissions of required now (in case the rmdir
+ # below fails), while we are still in the directory and may do so
+ # without a race via '.'
+ if ($nperm != $perm and not chmod($perm, $curdir)) {
+ _error($arg, "cannot reset chmod", $canon);
+ }
+
+ # don't leave the client code in an unexpected directory
+ chdir($arg->{cwd})
+ or _croak("cannot chdir to $arg->{cwd} from $canon: $!, aborting.");
+
+ # ensure that a chdir upwards didn't take us somewhere other
+ # than we expected (see CVE-2002-0435)
+ ($cur_dev, $cur_inode) = (stat $curdir)[0,1]
+ or _croak("cannot stat prior working directory $arg->{cwd}: $!, aborting.");
+
+ if ($Need_Stat_Check) {
+ ($arg->{device} eq $cur_dev and $arg->{inode} eq $cur_inode)
+ or _croak("previous directory $arg->{cwd} changed before entering $canon, expected dev=$ldev ino=$lino, actual dev=$cur_dev ino=$cur_inode, aborting.");
+ }
+
+ if ($arg->{depth} or !$arg->{keep_root}) {
+ if ($arg->{safe} &&
+ ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) {
+ print "skipped $root\n" if $arg->{verbose};
+ next ROOT_DIR;
+ }
+ if ($Force_Writeable and !chmod $perm | 0700, $root) {
+ _error($arg, "cannot make directory writeable", $canon);
+ }
+ print "rmdir $root\n" if $arg->{verbose};
+ if (rmdir $root) {
+ push @{${$arg->{result}}}, $root if $arg->{result};
+ ++$count;
+ }
+ else {
+ _error($arg, "cannot remove directory", $canon);
+ if ($Force_Writeable && !chmod($perm, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
+ ) {
+ _error($arg, sprintf("cannot restore permissions to 0%o",$perm), $canon);
+ }
+ }
+ }
+ }
+ else {
+ # not a directory
+ $root = VMS::Filespec::vmsify("./$root")
+ if $Is_VMS
+ && !File::Spec->file_name_is_absolute($root)
+ && ($root !~ m/(?<!\^)[\]>]+/); # not already in VMS syntax
+
+ if ($arg->{safe} &&
+ ($Is_VMS ? !&VMS::Filespec::candelete($root)
+ : !(-l $root || -w $root)))
+ {
+ print "skipped $root\n" if $arg->{verbose};
+ next ROOT_DIR;
+ }
+
+ my $nperm = $perm & 07777 | 0600;
+ if ($Force_Writeable and $nperm != $perm and not chmod $nperm, $root) {
+ _error($arg, "cannot make file writeable", $canon);
+ }
+ print "unlink $canon\n" if $arg->{verbose};
+ # delete all versions under VMS
+ for (;;) {
+ if (unlink $root) {
+ push @{${$arg->{result}}}, $root if $arg->{result};
+ }
+ else {
+ _error($arg, "cannot unlink file", $canon);
+ $Force_Writeable and chmod($perm, $root) or
+ _error($arg, sprintf("cannot restore permissions to 0%o",$perm), $canon);
+ last;
+ }
+ ++$count;
+ last unless $Is_VMS && lstat $root;
+ }
+ }
+ }
+ return $count;
+}
+
+sub _slash_lc {
+ # fix up slashes and case on MSWin32 so that we can determine that
+ # c:\path\to\dir is underneath C:/Path/To
+ my $path = shift;
+ $path =~ tr{\\}{/};
+ return lc($path);
+}
+
+1;
+__END__
+
+=head1 NAME
+
+File::Path - Create or remove directory trees
+
+=head1 VERSION
+
+This document describes version 2.07 of File::Path, released
+2008-11-09.
+
+=head1 SYNOPSIS
+
+ use File::Path qw(make_path remove_tree);
+
+ make_path('foo/bar/baz', '/zug/zwang');
+ make_path('foo/bar/baz', '/zug/zwang', {
+ verbose => 1,
+ mode => 0711,
+ });
+
+ remove_tree('foo/bar/baz', '/zug/zwang');
+ remove_tree('foo/bar/baz', '/zug/zwang', {
+ verbose => 1,
+ error => \my $err_list,
+ });
+
+ # legacy (interface promoted before v2.00)
+ mkpath('/foo/bar/baz');
+ mkpath('/foo/bar/baz', 1, 0711);
+ mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711);
+ rmtree('foo/bar/baz', 1, 1);
+ rmtree(['foo/bar/baz', 'blurfl/quux'], 1, 1);
+
+ # legacy (interface promoted before v2.06)
+ mkpath('foo/bar/baz', '/zug/zwang', { verbose => 1, mode => 0711 });
+ rmtree('foo/bar/baz', '/zug/zwang', { verbose => 1, mode => 0711 });
+
+=head1 DESCRIPTION
+
+This module provide a convenient way to create directories of
+arbitrary depth and to delete an entire directory subtree from the
+filesystem.
+
+The following functions are provided:
+
+=over
+
+=item make_path( $dir1, $dir2, .... )
+
+=item make_path( $dir1, $dir2, ...., \%opts )
+
+The C<make_path> function creates the given directories if they don't
+exists before, much like the Unix command C<mkdir -p>.
+
+The function accepts a list of directories to be created. Its
+behaviour may be tuned by an optional hashref appearing as the last
+parameter on the call.
+
+The function returns the list of directories actually created during
+the call; in scalar context the number of directories created.
+
+The following keys are recognised in the option hash:
+
+=over
+
+=item mode => $num
+
+The numeric permissions mode to apply to each created directory
+(defaults to 0777), to be modified by the current C<umask>. If the
+directory already exists (and thus does not need to be created),
+the permissions will not be modified.
+
+C<mask> is recognised as an alias for this parameter.
+
+=item verbose => $bool
+
+If present, will cause C<make_path> to print the name of each directory
+as it is created. By default nothing is printed.
+
+=item error => \$err
+
+If present, it should be a reference to a scalar.
+This scalar will be made to reference an array, which will
+be used to store any errors that are encountered. See the L</"ERROR
+HANDLING"> section for more information.
+
+If this parameter is not used, certain error conditions may raise
+a fatal error that will cause the program will halt, unless trapped
+in an C<eval> block.
+
+=back
+
+=item mkpath( $dir )
+
+=item mkpath( $dir, $verbose, $mode )
+
+=item mkpath( [$dir1, $dir2,...], $verbose, $mode )
+
+=item mkpath( $dir1, $dir2,..., \%opt )
+
+The mkpath() function provide the legacy interface of make_path() with
+a different interpretation of the arguments passed. The behaviour and
+return value of the function is otherwise identical to make_path().
+
+=item remove_tree( $dir1, $dir2, .... )
+
+=item remove_tree( $dir1, $dir2, ...., \%opts )
+
+The C<remove_tree> function deletes the given directories and any
+files and subdirectories they might contain, much like the Unix
+command C<rm -r> or C<del /s> on Windows.
+
+The function accepts a list of directories to be
+removed. Its behaviour may be tuned by an optional hashref
+appearing as the last parameter on the call.
+
+The functions returns the number of files successfully deleted.
+
+The following keys are recognised in the option hash:
+
+=over
+
+=item verbose => $bool
+
+If present, will cause C<remove_tree> to print the name of each file as
+it is unlinked. By default nothing is printed.
+
+=item safe => $bool
+
+When set to a true value, will cause C<remove_tree> to skip the files
+for which the process lacks the required privileges needed to delete
+files, such as delete privileges on VMS. In other words, the code
+will make no attempt to alter file permissions. Thus, if the process
+is interrupted, no filesystem object will be left in a more
+permissive mode.
+
+=item keep_root => $bool
+
+When set to a true value, will cause all files and subdirectories
+to be removed, except the initially specified directories. This comes
+in handy when cleaning out an application's scratch directory.
+
+ remove_tree( '/tmp', {keep_root => 1} );
+
+=item result => \$res
+
+If present, it should be a reference to a scalar.
+This scalar will be made to reference an array, which will
+be used to store all files and directories unlinked
+during the call. If nothing is unlinked, the array will be empty.
+
+ remove_tree( '/tmp', {result => \my $list} );
+ print "unlinked $_\n" for @$list;
+
+This is a useful alternative to the C<verbose> key.
+
+=item error => \$err
+
+If present, it should be a reference to a scalar.
+This scalar will be made to reference an array, which will
+be used to store any errors that are encountered. See the L</"ERROR
+HANDLING"> section for more information.
+
+Removing things is a much more dangerous proposition than
+creating things. As such, there are certain conditions that
+C<remove_tree> may encounter that are so dangerous that the only
+sane action left is to kill the program.
+
+Use C<error> to trap all that is reasonable (problems with
+permissions and the like), and let it die if things get out
+of hand. This is the safest course of action.
+
+=back
+
+=item rmtree( $dir )
+
+=item rmtree( $dir, $verbose, $safe )
+
+=item rmtree( [$dir1, $dir2,...], $verbose, $safe )
+
+=item rmtree( $dir1, $dir2,..., \%opt )
+
+The rmtree() function provide the legacy interface of remove_tree()
+with a different interpretation of the arguments passed. The behaviour
+and return value of the function is otherwise identical to
+remove_tree().
+
+=back
+
+=head2 ERROR HANDLING
+
+=over 4
+
+=item B<NOTE:>
+
+The following error handling mechanism is considered
+experimental and is subject to change pending feedback from
+users.
+
+=back
+
+If C<make_path> or C<remove_tree> encounter an error, a diagnostic
+message will be printed to C<STDERR> via C<carp> (for non-fatal
+errors), or via C<croak> (for fatal errors).
+
+If this behaviour is not desirable, the C<error> attribute may be
+used to hold a reference to a variable, which will be used to store
+the diagnostics. The variable is made a reference to an array of hash
+references. Each hash contain a single key/value pair where the key
+is the name of the file, and the value is the error message (including
+the contents of C<$!> when appropriate). If a general error is
+encountered the diagnostic key will be empty.
+
+An example usage looks like:
+
+ remove_tree( 'foo/bar', 'bar/rat', {error => \my $err} );
+ if (@$err) {
+ for my $diag (@$err) {
+ my ($file, $message) = %$diag;
+ if ($file eq '') {
+ print "general error: $message\n";
+ }
+ else {
+ print "problem unlinking $file: $message\n";
+ }
+ }
+ }
+ else {
+ print "No error encountered\n";
+ }
+
+Note that if no errors are encountered, C<$err> will reference an
+empty array. This means that C<$err> will always end up TRUE; so you
+need to test C<@$err> to determine if errors occured.
+
+=head2 NOTES
+
+C<File::Path> blindly exports C<mkpath> and C<rmtree> into the
+current namespace. These days, this is considered bad style, but
+to change it now would break too much code. Nonetheless, you are
+invited to specify what it is you are expecting to use:
+
+ use File::Path 'rmtree';
+
+The routines C<make_path> and C<remove_tree> are B<not> exported
+by default. You must specify which ones you want to use.
+
+ use File::Path 'remove_tree';
+
+Note that a side-effect of the above is that C<mkpath> and C<rmtree>
+are no longer exported at all. This is due to the way the C<Exporter>
+module works. If you are migrating a codebase to use the new
+interface, you will have to list everything explicitly. But that's
+just good practice anyway.
+
+ use File::Path qw(remove_tree rmtree);
+
+=head3 SECURITY CONSIDERATIONS
+
+There were race conditions 1.x implementations of File::Path's
+C<rmtree> function (although sometimes patched depending on the OS
+distribution or platform). The 2.0 version contains code to avoid the
+problem mentioned in CVE-2002-0435.
+
+See the following pages for more information:
+
+ http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=286905
+ http://www.nntp.perl.org/group/perl.perl5.porters/2005/01/msg97623.html
+ http://www.debian.org/security/2005/dsa-696
+
+Additionally, unless the C<safe> parameter is set (or the
+third parameter in the traditional interface is TRUE), should a
+C<remove_tree> be interrupted, files that were originally in read-only
+mode may now have their permissions set to a read-write (or "delete
+OK") mode.
+
+=head1 DIAGNOSTICS
+
+FATAL errors will cause the program to halt (C<croak>), since the
+problem is so severe that it would be dangerous to continue. (This
+can always be trapped with C<eval>, but it's not a good idea. Under
+the circumstances, dying is the best thing to do).
+
+SEVERE errors may be trapped using the modern interface. If the
+they are not trapped, or the old interface is used, such an error
+will cause the program will halt.
+
+All other errors may be trapped using the modern interface, otherwise
+they will be C<carp>ed about. Program execution will not be halted.
+
+=over 4
+
+=item mkdir [path]: [errmsg] (SEVERE)
+
+C<make_path> was unable to create the path. Probably some sort of
+permissions error at the point of departure, or insufficient resources
+(such as free inodes on Unix).
+
+=item No root path(s) specified
+
+C<make_path> was not given any paths to create. This message is only
+emitted if the routine is called with the traditional interface.
+The modern interface will remain silent if given nothing to do.
+
+=item No such file or directory
+
+On Windows, if C<make_path> gives you this warning, it may mean that
+you have exceeded your filesystem's maximum path length.
+
+=item cannot fetch initial working directory: [errmsg]
+
+C<remove_tree> attempted to determine the initial directory by calling
+C<Cwd::getcwd>, but the call failed for some reason. No attempt
+will be made to delete anything.
+
+=item cannot stat initial working directory: [errmsg]
+
+C<remove_tree> attempted to stat the initial directory (after having
+successfully obtained its name via C<getcwd>), however, the call
+failed for some reason. No attempt will be made to delete anything.
+
+=item cannot chdir to [dir]: [errmsg]
+
+C<remove_tree> attempted to set the working directory in order to
+begin deleting the objects therein, but was unsuccessful. This is
+usually a permissions issue. The routine will continue to delete
+other things, but this directory will be left intact.
+
+=item directory [dir] changed before chdir, expected dev=[n] ino=[n], actual dev=[n] ino=[n], aborting. (FATAL)
+
+C<remove_tree> recorded the device and inode of a directory, and then
+moved into it. It then performed a C<stat> on the current directory
+and detected that the device and inode were no longer the same. As
+this is at the heart of the race condition problem, the program
+will die at this point.
+
+=item cannot make directory [dir] read+writeable: [errmsg]
+
+C<remove_tree> attempted to change the permissions on the current directory
+to ensure that subsequent unlinkings would not run into problems,
+but was unable to do so. The permissions remain as they were, and
+the program will carry on, doing the best it can.
+
+=item cannot read [dir]: [errmsg]
+
+C<remove_tree> tried to read the contents of the directory in order
+to acquire the names of the directory entries to be unlinked, but
+was unsuccessful. This is usually a permissions issue. The
+program will continue, but the files in this directory will remain
+after the call.
+
+=item cannot reset chmod [dir]: [errmsg]
+
+C<remove_tree>, after having deleted everything in a directory, attempted
+to restore its permissions to the original state but failed. The
+directory may wind up being left behind.
+
+=item cannot remove [dir] when cwd is [dir]
+
+The current working directory of the program is F</some/path/to/here>
+and you are attempting to remove an ancestor, such as F</some/path>.
+The directory tree is left untouched.
+
+The solution is to C<chdir> out of the child directory to a place
+outside the directory tree to be removed.
+
+=item cannot chdir to [parent-dir] from [child-dir]: [errmsg], aborting. (FATAL)
+
+C<remove_tree>, after having deleted everything and restored the permissions
+of a directory, was unable to chdir back to the parent. The program
+halts to avoid a race condition from occurring.
+
+=item cannot stat prior working directory [dir]: [errmsg], aborting. (FATAL)
+
+C<remove_tree> was unable to stat the parent directory after have returned
+from the child. Since there is no way of knowing if we returned to
+where we think we should be (by comparing device and inode) the only
+way out is to C<croak>.
+
+=item previous directory [parent-dir] changed before entering [child-dir], expected dev=[n] ino=[n], actual dev=[n] ino=[n], aborting. (FATAL)
+
+When C<remove_tree> returned from deleting files in a child directory, a
+check revealed that the parent directory it returned to wasn't the one
+it started out from. This is considered a sign of malicious activity.
+
+=item cannot make directory [dir] writeable: [errmsg]
+
+Just before removing a directory (after having successfully removed
+everything it contained), C<remove_tree> attempted to set the permissions
+on the directory to ensure it could be removed and failed. Program
+execution continues, but the directory may possibly not be deleted.
+
+=item cannot remove directory [dir]: [errmsg]
+
+C<remove_tree> attempted to remove a directory, but failed. This may because
+some objects that were unable to be removed remain in the directory, or
+a permissions issue. The directory will be left behind.
+
+=item cannot restore permissions of [dir] to [0nnn]: [errmsg]
+
+After having failed to remove a directory, C<remove_tree> was unable to
+restore its permissions from a permissive state back to a possibly
+more restrictive setting. (Permissions given in octal).
+
+=item cannot make file [file] writeable: [errmsg]
+
+C<remove_tree> attempted to force the permissions of a file to ensure it
+could be deleted, but failed to do so. It will, however, still attempt
+to unlink the file.
+
+=item cannot unlink file [file]: [errmsg]
+
+C<remove_tree> failed to remove a file. Probably a permissions issue.
+
+=item cannot restore permissions of [file] to [0nnn]: [errmsg]
+
+After having failed to remove a file, C<remove_tree> was also unable
+to restore the permissions on the file to a possibly less permissive
+setting. (Permissions given in octal).
+
+=back
+
+=head1 SEE ALSO
+
+=over 4
+
+=item *
+
+L<File::Remove>
+
+Allows files and directories to be moved to the Trashcan/Recycle
+Bin (where they may later be restored if necessary) if the operating
+system supports such functionality. This feature may one day be
+made available directly in C<File::Path>.
+
+=item *
+
+L<File::Find::Rule>
+
+When removing directory trees, if you want to examine each file to
+decide whether to delete it (and possibly leaving large swathes
+alone), F<File::Find::Rule> offers a convenient and flexible approach
+to examining directory trees.
+
+=back
+
+=head1 BUGS
+
+Please report all bugs on the RT queue:
+
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=File-Path>
+
+=head1 ACKNOWLEDGEMENTS
+
+Paul Szabo identified the race condition originally, and Brendan
+O'Dea wrote an implementation for Debian that addressed the problem.
+That code was used as a basis for the current code. Their efforts
+are greatly appreciated.
+
+Gisle Aas made a number of improvements to the documentation for
+2.07 and his advice and assistance is also greatly appreciated.
+
+=head1 AUTHORS
+
+Tim Bunce and Charles Bailey. Currently maintained by David Landgren
+<F<david at landgren.net>>.
+
+=head1 COPYRIGHT
+
+This module is copyright (C) Charles Bailey, Tim Bunce and
+David Landgren 1995-2008. All rights reserved.
+
+=head1 LICENSE
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
Copied: trunk/contrib/perl/lib/File/Path.t (from rev 6437, vendor/perl/5.18.1/lib/File/Path.t)
===================================================================
--- trunk/contrib/perl/lib/File/Path.t (rev 0)
+++ trunk/contrib/perl/lib/File/Path.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,588 @@
+# Path.t -- tests for module File::Path
+
+use strict;
+
+use Test::More tests => 121;
+use Config;
+
+BEGIN {
+ use_ok('Cwd');
+ use_ok('File::Path', qw(rmtree mkpath make_path remove_tree));
+ use_ok('File::Spec::Functions');
+}
+
+eval "use Test::Output";
+my $has_Test_Output = $@ ? 0 : 1;
+
+my $Is_VMS = $^O eq 'VMS';
+
+# first check for stupid permissions second for full, so we clean up
+# behind ourselves
+for my $perm (0111,0777) {
+ my $path = catdir(curdir(), "mhx", "bar");
+ mkpath($path);
+ chmod $perm, "mhx", $path;
+
+ my $oct = sprintf('0%o', $perm);
+ ok(-d "mhx", "mkdir parent dir $oct");
+ ok(-d $path, "mkdir child dir $oct");
+
+ rmtree("mhx");
+ ok(! -e "mhx", "mhx does not exist $oct");
+}
+
+# find a place to work
+my ($error, $list, $file, $message);
+my $tmp_base = catdir(
+ curdir(),
+ sprintf( 'test-%x-%x-%x', time, $$, rand(99999) ),
+);
+
+# invent some names
+my @dir = (
+ catdir($tmp_base, qw(a b)),
+ catdir($tmp_base, qw(a c)),
+ catdir($tmp_base, qw(z b)),
+ catdir($tmp_base, qw(z c)),
+);
+
+# create them
+my @created = mkpath([@dir]);
+
+is(scalar(@created), 7, "created list of directories");
+
+# pray for no race conditions blowing them out from under us
+ at created = mkpath([$tmp_base]);
+is(scalar(@created), 0, "skipped making existing directory")
+ or diag("unexpectedly recreated @created");
+
+# create a file
+my $file_name = catfile( $tmp_base, 'a', 'delete.me' );
+my $file_count = 0;
+if (open OUT, "> $file_name") {
+ print OUT "this file may be deleted\n";
+ close OUT;
+ ++$file_count;
+}
+else {
+ diag( "Failed to create file $file_name: $!" );
+}
+
+SKIP: {
+ skip "cannot remove a file we failed to create", 1
+ unless $file_count == 1;
+ my $count = rmtree($file_name);
+ is($count, 1, "rmtree'ed a file");
+}
+
+ at created = mkpath('');
+is(scalar(@created), 0, "Can't create a directory named ''");
+
+my $dir;
+my $dir2;
+
+sub gisle {
+ # background info: @_ = 1; !shift # gives '' not 0
+ # Message-Id: <3C820CE6-4400-4E91-AF43-A3D19B356E68 at activestate.com>
+ # http://www.nntp.perl.org/group/perl.perl5.porters/2008/05/msg136625.html
+ mkpath(shift, !shift, 0755);
+}
+
+sub count {
+ opendir D, shift or return -1;
+ my $count = () = readdir D;
+ closedir D or return -1;
+ return $count;
+}
+
+{
+ mkdir 'solo', 0755;
+ chdir 'solo';
+ open my $f, '>', 'foo.dat';
+ close $f;
+ my $before = count(curdir());
+ cmp_ok($before, '>', 0, "baseline $before");
+
+ gisle('1st', 1);
+ is(count(curdir()), $before + 1, "first after $before");
+
+ $before = count(curdir());
+ gisle('2nd', 1);
+ is(count(curdir()), $before + 1, "second after $before");
+
+ chdir updir();
+ rmtree 'solo';
+}
+
+{
+ mkdir 'solo', 0755;
+ chdir 'solo';
+ open my $f, '>', 'foo.dat';
+ close $f;
+ my $before = count(curdir());
+ cmp_ok($before, '>', 0, "ARGV $before");
+ {
+ local @ARGV = (1);
+ mkpath('3rd', !shift, 0755);
+ }
+ is(count(curdir()), $before + 1, "third after $before");
+
+ $before = count(curdir());
+ {
+ local @ARGV = (1);
+ mkpath('4th', !shift, 0755);
+ }
+ is(count(curdir()), $before + 1, "fourth after $before");
+
+ chdir updir();
+ rmtree 'solo';
+}
+
+SKIP: {
+ # tests for rmtree() of ancestor directory
+ my $nr_tests = 6;
+ my $cwd = getcwd() or skip "failed to getcwd: $!", $nr_tests;
+ my $dir = catdir($cwd, 'remove');
+ my $dir2 = catdir($cwd, 'remove', 'this', 'dir');
+
+ skip "failed to mkpath '$dir2': $!", $nr_tests
+ unless mkpath($dir2, {verbose => 0});
+ skip "failed to chdir dir '$dir2': $!", $nr_tests
+ unless chdir($dir2);
+
+ rmtree($dir, {error => \$error});
+ my $nr_err = @$error;
+ is($nr_err, 1, "ancestor error");
+
+ if ($nr_err) {
+ my ($file, $message) = each %{$error->[0]};
+ is($file, $dir, "ancestor named");
+ my $ortho_dir = $^O eq 'MSWin32' ? File::Path::_slash_lc($dir2) : $dir2;
+ $^O eq 'MSWin32' and $message
+ =~ s/\A(cannot remove path when cwd is )(.*)\Z/$1 . File::Path::_slash_lc($2)/e;
+ is($message, "cannot remove path when cwd is $ortho_dir", "ancestor reason");
+ ok(-d $dir2, "child not removed");
+ ok(-d $dir, "ancestor not removed");
+ }
+ else {
+ fail( "ancestor 1");
+ fail( "ancestor 2");
+ fail( "ancestor 3");
+ fail( "ancestor 4");
+ }
+ chdir $cwd;
+ rmtree($dir);
+ ok(!(-d $dir), "ancestor now removed");
+};
+
+my $count = rmtree({error => \$error});
+is( $count, 0, 'rmtree of nothing, count of zero' );
+is( scalar(@$error), 0, 'no diagnostic captured' );
+
+ at created = mkpath($tmp_base, 0);
+is(scalar(@created), 0, "skipped making existing directories (old style 1)")
+ or diag("unexpectedly recreated @created");
+
+$dir = catdir($tmp_base,'C');
+# mkpath returns unix syntax filespecs on VMS
+$dir = VMS::Filespec::unixify($dir) if $Is_VMS;
+ at created = make_path($tmp_base, $dir);
+is(scalar(@created), 1, "created directory (new style 1)");
+is($created[0], $dir, "created directory (new style 1) cross-check");
+
+ at created = mkpath($tmp_base, 0, 0700);
+is(scalar(@created), 0, "skipped making existing directories (old style 2)")
+ or diag("unexpectedly recreated @created");
+
+$dir2 = catdir($tmp_base,'D');
+# mkpath returns unix syntax filespecs on VMS
+$dir2 = VMS::Filespec::unixify($dir2) if $Is_VMS;
+ at created = make_path($tmp_base, $dir, $dir2);
+is(scalar(@created), 1, "created directory (new style 2)");
+is($created[0], $dir2, "created directory (new style 2) cross-check");
+
+$count = rmtree($dir, 0);
+is($count, 1, "removed directory unsafe mode");
+
+$count = rmtree($dir2, 0, 1);
+my $removed = $Is_VMS ? 0 : 1;
+is($count, $removed, "removed directory safe mode");
+
+# mkdir foo ./E/../Y
+# Y should exist
+# existence of E is neither here nor there
+$dir = catdir($tmp_base, 'E', updir(), 'Y');
+ at created =mkpath($dir);
+cmp_ok(scalar(@created), '>=', 1, "made one or more dirs because of ..");
+cmp_ok(scalar(@created), '<=', 2, "made less than two dirs because of ..");
+ok( -d catdir($tmp_base, 'Y'), "directory after parent" );
+
+ at created = make_path(catdir(curdir(), $tmp_base));
+is(scalar(@created), 0, "nothing created")
+ or diag(@created);
+
+$dir = catdir($tmp_base, 'a');
+$dir2 = catdir($tmp_base, 'z');
+
+rmtree( $dir, $dir2,
+ {
+ error => \$error,
+ result => \$list,
+ keep_root => 1,
+ }
+);
+
+is(scalar(@$error), 0, "no errors unlinking a and z");
+is(scalar(@$list), 4, "list contains 4 elements")
+ or diag("@$list");
+
+ok(-d $dir, "dir a still exists");
+ok(-d $dir2, "dir z still exists");
+
+$dir = catdir($tmp_base,'F');
+# mkpath returns unix syntax filespecs on VMS
+$dir = VMS::Filespec::unixify($dir) if $Is_VMS;
+
+ at created = mkpath($dir, undef, 0770);
+is(scalar(@created), 1, "created directory (old style 2 verbose undef)");
+is($created[0], $dir, "created directory (old style 2 verbose undef) cross-check");
+is(rmtree($dir, undef, 0), 1, "removed directory 2 verbose undef");
+
+ at created = mkpath($dir, undef);
+is(scalar(@created), 1, "created directory (old style 2a verbose undef)");
+is($created[0], $dir, "created directory (old style 2a verbose undef) cross-check");
+is(rmtree($dir, undef), 1, "removed directory 2a verbose undef");
+
+ at created = mkpath($dir, 0, undef);
+is(scalar(@created), 1, "created directory (old style 3 mode undef)");
+is($created[0], $dir, "created directory (old style 3 mode undef) cross-check");
+is(rmtree($dir, 0, undef), 1, "removed directory 3 verbose undef");
+
+$dir = catdir($tmp_base,'G');
+$dir = VMS::Filespec::unixify($dir) if $Is_VMS;
+
+ at created = mkpath($dir, undef, 0200);
+is(scalar(@created), 1, "created write-only dir");
+is($created[0], $dir, "created write-only directory cross-check");
+is(rmtree($dir), 1, "removed write-only dir");
+
+# borderline new-style heuristics
+if (chdir $tmp_base) {
+ pass("chdir to temp dir");
+}
+else {
+ fail("chdir to temp dir: $!");
+}
+
+$dir = catdir('a', 'd1');
+$dir2 = catdir('a', 'd2');
+
+ at created = make_path( $dir, 0, $dir2 );
+is(scalar @created, 3, 'new-style 3 dirs created');
+
+$count = remove_tree( $dir, 0, $dir2, );
+is($count, 3, 'new-style 3 dirs removed');
+
+ at created = make_path( $dir, $dir2, 1 );
+is(scalar @created, 3, 'new-style 3 dirs created (redux)');
+
+$count = remove_tree( $dir, $dir2, 1 );
+is($count, 3, 'new-style 3 dirs removed (redux)');
+
+ at created = make_path( $dir, $dir2 );
+is(scalar @created, 2, 'new-style 2 dirs created');
+
+$count = remove_tree( $dir, $dir2 );
+is($count, 2, 'new-style 2 dirs removed');
+
+if (chdir updir()) {
+ pass("chdir parent");
+}
+else {
+ fail("chdir parent: $!");
+}
+
+SKIP: {
+ skip "This is not a MSWin32 platform", 1
+ unless $^O eq 'MSWin32';
+
+ my $UNC_path_taint = $ENV{PERL_FILE_PATH_UNC_TESTDIR};
+ skip "PERL_FILE_PATH_UNC_TESTDIR environment variable not set", 1
+ unless defined($UNC_path_taint);
+
+ my ($UNC_path) = ($UNC_path_taint =~ m{^([/\\]{2}\w+[/\\]\w+[/\\]\w+)$});
+
+ skip "PERL_FILE_PATH_UNC_TESTDIR environment variable does not point to a directory", 1
+ unless -d $UNC_path;
+
+ my $removed = rmtree($UNC_path);
+ cmp_ok($removed, '>', 0, "removed $removed entries from $UNC_path");
+}
+
+SKIP: {
+ # test bug http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=487319
+ skip "Don't need Force_Writeable semantics on $^O", 4
+ if grep {$^O eq $_} qw(amigaos dos epoc MSWin32 MacOS os2);
+ skip "Symlinks not available", 4 unless $Config{'d_symlink'};
+ $dir = 'bug487319';
+ $dir2 = 'bug487319-symlink';
+ @created = make_path($dir, {mask => 0700});
+ is(scalar @created, 1, 'bug 487319 setup');
+ symlink($dir, $dir2);
+ ok(-e $dir2, "debian bug 487319 setup symlink") or diag($dir2);
+
+ chmod 0500, $dir;
+ my $mask_initial = (stat $dir)[2];
+ remove_tree($dir2);
+
+ my $mask = (stat $dir)[2];
+ is( $mask, $mask_initial, 'mask of symlink target dir unchanged (debian bug 487319)');
+
+ # now try a file
+ my $file = catfile($dir, 'file');
+ open my $out, '>', $file;
+ close $out;
+
+ chmod 0500, $file;
+ $mask_initial = (stat $file)[2];
+
+ my $file2 = catfile($dir, 'symlink');
+ symlink($file, $file2);
+ remove_tree($file2);
+
+ $mask = (stat $file)[2];
+ is( $mask, $mask_initial, 'mask of symlink target file unchanged (debian bug 487319)');
+
+ remove_tree($dir);
+}
+
+# see what happens if a file exists where we want a directory
+SKIP: {
+ my $entry = catdir($tmp_base, "file");
+ skip "Cannot create $entry", 4 unless open OUT, "> $entry";
+ print OUT "test file, safe to delete\n", scalar(localtime), "\n";
+ close OUT;
+ ok(-e $entry, "file exists in place of directory");
+
+ mkpath( $entry, {error => \$error} );
+ is( scalar(@$error), 1, "caught error condition" );
+ ($file, $message) = each %{$error->[0]};
+ is( $entry, $file, "and the message is: $message");
+
+ eval {@created = mkpath($entry, 0, 0700)};
+ $error = $@;
+ chomp $error; # just to remove silly # in TAP output
+ cmp_ok( $error, 'ne', "", "no directory created (old-style) err=$error" )
+ or diag(@created);
+}
+
+my $extra = catdir(curdir(), qw(EXTRA 1 a));
+
+SKIP: {
+ skip "extra scenarios not set up, see eg/setup-extra-tests", 14
+ unless -e $extra;
+ skip "Symlinks not available", 14 unless $Config{'d_symlink'};
+
+ my ($list, $err);
+ $dir = catdir( 'EXTRA', '1' );
+ rmtree( $dir, {result => \$list, error => \$err} );
+ is(scalar(@$list), 2, "extra dir $dir removed");
+ is(scalar(@$err), 1, "one error encountered");
+
+ $dir = catdir( 'EXTRA', '3', 'N' );
+ rmtree( $dir, {result => \$list, error => \$err} );
+ is( @$list, 1, q{remove a symlinked dir} );
+ is( @$err, 0, q{with no errors} );
+
+ $dir = catdir('EXTRA', '3', 'S');
+ rmtree($dir, {error => \$error});
+ is( scalar(@$error), 1, 'one error for an unreadable dir' );
+ eval { ($file, $message) = each %{$error->[0]}};
+ is( $file, $dir, 'unreadable dir reported in error' )
+ or diag($message);
+
+ $dir = catdir('EXTRA', '3', 'T');
+ rmtree($dir, {error => \$error});
+ is( scalar(@$error), 1, 'one error for an unreadable dir T' );
+ eval { ($file, $message) = each %{$error->[0]}};
+ is( $file, $dir, 'unreadable dir reported in error T' );
+
+ $dir = catdir( 'EXTRA', '4' );
+ rmtree($dir, {result => \$list, error => \$err} );
+ is( scalar(@$list), 0, q{don't follow a symlinked dir} );
+ is( scalar(@$err), 2, q{two errors when removing a symlink in r/o dir} );
+ eval { ($file, $message) = each %{$err->[0]} };
+ is( $file, $dir, 'symlink reported in error' );
+
+ $dir = catdir('EXTRA', '3', 'U');
+ $dir2 = catdir('EXTRA', '3', 'V');
+ rmtree($dir, $dir2, {verbose => 0, error => \$err, result => \$list});
+ is( scalar(@$list), 1, q{deleted 1 out of 2 directories} );
+ is( scalar(@$error), 1, q{left behind 1 out of 2 directories} );
+ eval { ($file, $message) = each %{$err->[0]} };
+ is( $file, $dir, 'first dir reported in error' );
+}
+
+{
+ $dir = catdir($tmp_base, 'ZZ');
+ @created = mkpath($dir);
+ is(scalar(@created), 1, "create a ZZ directory");
+
+ local @ARGV = ($dir);
+ rmtree( [grep -e $_, @ARGV], 0, 0 );
+ ok(!-e $dir, "blow it away via \@ARGV");
+}
+
+SKIP: {
+ skip 'Test::Output not available', 14
+ unless $has_Test_Output;
+
+ SKIP: {
+ $dir = catdir('EXTRA', '3');
+ skip "extra scenarios not set up, see eg/setup-extra-tests", 3
+ unless -e $dir;
+
+ $dir = catdir('EXTRA', '3', 'U');
+ stderr_like(
+ sub {rmtree($dir, {verbose => 0})},
+ qr{\Acannot make child directory read-write-exec for [^:]+: .* at \S+ line \d+},
+ q(rmtree can't chdir into root dir)
+ );
+
+ $dir = catdir('EXTRA', '3');
+ stderr_like(
+ sub {rmtree($dir, {})},
+ qr{\Acannot make child directory read-write-exec for [^:]+: .* at (\S+) line (\d+)
+cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
+cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
+cannot remove directory for [^:]+: .* at \1 line \2},
+ 'rmtree with file owned by root'
+ );
+
+ stderr_like(
+ sub {rmtree('EXTRA', {})},
+ qr{\Acannot remove directory for [^:]+: .* at (\S+) line (\d+)
+cannot remove directory for [^:]+: .* at \1 line \2
+cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
+cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
+cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
+cannot remove directory for [^:]+: .* at \1 line \2
+cannot unlink file for [^:]+: .* at \1 line \2
+cannot restore permissions to \d+ for [^:]+: .* at \1 line \2
+cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
+cannot remove directory for [^:]+: .* at \1 line \2},
+ 'rmtree with insufficient privileges'
+ );
+ }
+
+ my $base = catdir($tmp_base,'output');
+ $dir = catdir($base,'A');
+ $dir2 = catdir($base,'B');
+
+ stderr_like(
+ sub { rmtree( undef, 1 ) },
+ qr/\ANo root path\(s\) specified\b/,
+ "rmtree of nothing carps sensibly"
+ );
+
+ stderr_like(
+ sub { rmtree( '', 1 ) },
+ qr/\ANo root path\(s\) specified\b/,
+ "rmtree of empty dir carps sensibly"
+ );
+
+ stderr_is( sub { make_path() }, '', "make_path no args does not carp" );
+ stderr_is( sub { remove_tree() }, '', "remove_tree no args does not carp" );
+
+ stdout_is(
+ sub {@created = mkpath($dir, 1)},
+ "mkdir $base\nmkdir $dir\n",
+ 'mkpath verbose (old style 1)'
+ );
+
+ stdout_is(
+ sub {@created = mkpath([$dir2], 1)},
+ "mkdir $dir2\n",
+ 'mkpath verbose (old style 2)'
+ );
+
+ stdout_is(
+ sub {$count = rmtree([$dir, $dir2], 1, 1)},
+ "rmdir $dir\nrmdir $dir2\n",
+ 'rmtree verbose (old style)'
+ );
+
+ stdout_is(
+ sub {@created = mkpath($dir, {verbose => 1, mask => 0750})},
+ "mkdir $dir\n",
+ 'mkpath verbose (new style 1)'
+ );
+
+ stdout_is(
+ sub {@created = mkpath($dir2, 1, 0771)},
+ "mkdir $dir2\n",
+ 'mkpath verbose (new style 2)'
+ );
+
+ SKIP: {
+ $file = catdir($dir2, "file");
+ skip "Cannot create $file", 2 unless open OUT, "> $file";
+ print OUT "test file, safe to delete\n", scalar(localtime), "\n";
+ close OUT;
+
+ ok(-e $file, "file created in directory");
+
+ stdout_is(
+ sub {$count = rmtree($dir, $dir2, {verbose => 1, safe => 1})},
+ "rmdir $dir\nunlink $file\nrmdir $dir2\n",
+ 'rmtree safe verbose (new style)'
+ );
+ }
+}
+
+SKIP: {
+ skip "extra scenarios not set up, see eg/setup-extra-tests", 11
+ unless -d catdir(qw(EXTRA 1));
+
+ rmtree 'EXTRA', {safe => 0, error => \$error};
+ is( scalar(@$error), 10, 'seven deadly sins' ); # well there used to be 7
+
+ rmtree 'EXTRA', {safe => 1, error => \$error};
+ is( scalar(@$error), 9, 'safe is better' );
+ for (@$error) {
+ ($file, $message) = each %$_;
+ if ($file =~ /[123]\z/) {
+ is(index($message, 'cannot remove directory: '), 0, "failed to remove $file with rmdir")
+ or diag($message);
+ }
+ else {
+ like($message, qr(\Acannot (?:restore permissions to \d+|chdir to child|unlink file): ), "failed to remove $file with unlink")
+ or diag($message)
+ }
+ }
+}
+
+SKIP: {
+ my $nr_tests = 6;
+ my $cwd = getcwd() or skip "failed to getcwd: $!", $nr_tests;
+ rmtree($tmp_base, {result => \$list} );
+ is(ref($list), 'ARRAY', "received a final list of results");
+ ok( !(-d $tmp_base), "test base directory gone" );
+
+ my $p = getcwd();
+ my $x = "x$$";
+ my $xx = $x . "x";
+
+ # setup
+ ok(mkpath($xx));
+ ok(chdir($xx));
+ END {
+ ok(chdir($p));
+ ok(rmtree($xx));
+ }
+
+ # create and delete directory
+ my $px = catdir($p, $x);
+ ok(mkpath($px));
+ ok(rmtree($px), "rmtree"); # fails in File-Path-2.07
+}
Copied: trunk/contrib/perl/lib/File/Spec.pm (from rev 6437, vendor/perl/5.18.1/lib/File/Spec.pm)
===================================================================
--- trunk/contrib/perl/lib/File/Spec.pm (rev 0)
+++ trunk/contrib/perl/lib/File/Spec.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,336 @@
+package File::Spec;
+
+use strict;
+use vars qw(@ISA $VERSION);
+
+$VERSION = '3.30';
+$VERSION = eval $VERSION;
+
+my %module = (MacOS => 'Mac',
+ MSWin32 => 'Win32',
+ os2 => 'OS2',
+ VMS => 'VMS',
+ epoc => 'Epoc',
+ NetWare => 'Win32', # Yes, File::Spec::Win32 works on NetWare.
+ symbian => 'Win32', # Yes, File::Spec::Win32 works on symbian.
+ dos => 'OS2', # Yes, File::Spec::OS2 works on DJGPP.
+ cygwin => 'Cygwin');
+
+
+my $module = $module{$^O} || 'Unix';
+
+require "File/Spec/$module.pm";
+ at ISA = ("File::Spec::$module");
+
+1;
+
+__END__
+
+=head1 NAME
+
+File::Spec - portably perform operations on file names
+
+=head1 SYNOPSIS
+
+ use File::Spec;
+
+ $x=File::Spec->catfile('a', 'b', 'c');
+
+which returns 'a/b/c' under Unix. Or:
+
+ use File::Spec::Functions;
+
+ $x = catfile('a', 'b', 'c');
+
+=head1 DESCRIPTION
+
+This module is designed to support operations commonly performed on file
+specifications (usually called "file names", but not to be confused with the
+contents of a file, or Perl's file handles), such as concatenating several
+directory and file names into a single path, or determining whether a path
+is rooted. It is based on code directly taken from MakeMaker 5.17, code
+written by Andreas KE<ouml>nig, Andy Dougherty, Charles Bailey, Ilya
+Zakharevich, Paul Schinder, and others.
+
+Since these functions are different for most operating systems, each set of
+OS specific routines is available in a separate module, including:
+
+ File::Spec::Unix
+ File::Spec::Mac
+ File::Spec::OS2
+ File::Spec::Win32
+ File::Spec::VMS
+
+The module appropriate for the current OS is automatically loaded by
+File::Spec. Since some modules (like VMS) make use of facilities available
+only under that OS, it may not be possible to load all modules under all
+operating systems.
+
+Since File::Spec is object oriented, subroutines should not be called directly,
+as in:
+
+ File::Spec::catfile('a','b');
+
+but rather as class methods:
+
+ File::Spec->catfile('a','b');
+
+For simple uses, L<File::Spec::Functions> provides convenient functional
+forms of these methods.
+
+=head1 METHODS
+
+=over 2
+
+=item canonpath
+X<canonpath>
+
+No physical check on the filesystem, but a logical cleanup of a
+path.
+
+ $cpath = File::Spec->canonpath( $path ) ;
+
+Note that this does *not* collapse F<x/../y> sections into F<y>. This
+is by design. If F</foo> on your system is a symlink to F</bar/baz>,
+then F</foo/../quux> is actually F</bar/quux>, not F</quux> as a naive
+F<../>-removal would give you. If you want to do this kind of
+processing, you probably want C<Cwd>'s C<realpath()> function to
+actually traverse the filesystem cleaning up paths like this.
+
+=item catdir
+X<catdir>
+
+Concatenate two or more directory names to form a complete path ending
+with a directory. But remove the trailing slash from the resulting
+string, because it doesn't look good, isn't necessary and confuses
+OS/2. Of course, if this is the root directory, don't cut off the
+trailing slash :-)
+
+ $path = File::Spec->catdir( @directories );
+
+=item catfile
+X<catfile>
+
+Concatenate one or more directory names and a filename to form a
+complete path ending with a filename
+
+ $path = File::Spec->catfile( @directories, $filename );
+
+=item curdir
+X<curdir>
+
+Returns a string representation of the current directory.
+
+ $curdir = File::Spec->curdir();
+
+=item devnull
+X<devnull>
+
+Returns a string representation of the null device.
+
+ $devnull = File::Spec->devnull();
+
+=item rootdir
+X<rootdir>
+
+Returns a string representation of the root directory.
+
+ $rootdir = File::Spec->rootdir();
+
+=item tmpdir
+X<tmpdir>
+
+Returns a string representation of the first writable directory from a
+list of possible temporary directories. Returns the current directory
+if no writable temporary directories are found. The list of directories
+checked depends on the platform; e.g. File::Spec::Unix checks C<$ENV{TMPDIR}>
+(unless taint is on) and F</tmp>.
+
+ $tmpdir = File::Spec->tmpdir();
+
+=item updir
+X<updir>
+
+Returns a string representation of the parent directory.
+
+ $updir = File::Spec->updir();
+
+=item no_upwards
+
+Given a list of file names, strip out those that refer to a parent
+directory. (Does not strip symlinks, only '.', '..', and equivalents.)
+
+ @paths = File::Spec->no_upwards( @paths );
+
+=item case_tolerant
+
+Returns a true or false value indicating, respectively, that alphabetic
+case is not or is significant when comparing file specifications.
+
+ $is_case_tolerant = File::Spec->case_tolerant();
+
+=item file_name_is_absolute
+
+Takes as its argument a path, and returns true if it is an absolute path.
+
+ $is_absolute = File::Spec->file_name_is_absolute( $path );
+
+This does not consult the local filesystem on Unix, Win32, OS/2, or
+Mac OS (Classic). It does consult the working environment for VMS
+(see L<File::Spec::VMS/file_name_is_absolute>).
+
+=item path
+X<path>
+
+Takes no argument. Returns the environment variable C<PATH> (or the local
+platform's equivalent) as a list.
+
+ @PATH = File::Spec->path();
+
+=item join
+X<join, path>
+
+join is the same as catfile.
+
+=item splitpath
+X<splitpath> X<split, path>
+
+Splits a path in to volume, directory, and filename portions. On systems
+with no concept of volume, returns '' for volume.
+
+ ($volume,$directories,$file) = File::Spec->splitpath( $path );
+ ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
+
+For systems with no syntax differentiating filenames from directories,
+assumes that the last file is a path unless C<$no_file> is true or a
+trailing separator or F</.> or F</..> is present. On Unix, this means that C<$no_file>
+true makes this return ( '', $path, '' ).
+
+The directory portion may or may not be returned with a trailing '/'.
+
+The results can be passed to L</catpath()> to get back a path equivalent to
+(usually identical to) the original path.
+
+=item splitdir
+X<splitdir> X<split, dir>
+
+The opposite of L</catdir()>.
+
+ @dirs = File::Spec->splitdir( $directories );
+
+C<$directories> must be only the directory portion of the path on systems
+that have the concept of a volume or that have path syntax that differentiates
+files from directories.
+
+Unlike just splitting the directories on the separator, empty
+directory names (C<''>) can be returned, because these are significant
+on some OSes.
+
+=item catpath()
+
+Takes volume, directory and file portions and returns an entire path. Under
+Unix, C<$volume> is ignored, and directory and file are concatenated. A '/' is
+inserted if need be. On other OSes, C<$volume> is significant.
+
+ $full_path = File::Spec->catpath( $volume, $directory, $file );
+
+=item abs2rel
+X<abs2rel> X<absolute, path> X<relative, path>
+
+Takes a destination path and an optional base path returns a relative path
+from the base path to the destination path:
+
+ $rel_path = File::Spec->abs2rel( $path ) ;
+ $rel_path = File::Spec->abs2rel( $path, $base ) ;
+
+If C<$base> is not present or '', then L<Cwd::cwd()|Cwd> is used. If C<$base> is
+relative, then it is converted to absolute form using
+L</rel2abs()>. This means that it is taken to be relative to
+L<Cwd::cwd()|Cwd>.
+
+On systems with the concept of volume, if C<$path> and C<$base> appear to be
+on two different volumes, we will not attempt to resolve the two
+paths, and we will instead simply return C<$path>. Note that previous
+versions of this module ignored the volume of C<$base>, which resulted in
+garbage results part of the time.
+
+On systems that have a grammar that indicates filenames, this ignores the
+C<$base> filename as well. Otherwise all path components are assumed to be
+directories.
+
+If C<$path> is relative, it is converted to absolute form using L</rel2abs()>.
+This means that it is taken to be relative to L<Cwd::cwd()|Cwd>.
+
+No checks against the filesystem are made. On VMS, there is
+interaction with the working environment, as logicals and
+macros are expanded.
+
+Based on code written by Shigio Yamaguchi.
+
+=item rel2abs()
+X<rel2abs> X<absolute, path> X<relative, path>
+
+Converts a relative path to an absolute path.
+
+ $abs_path = File::Spec->rel2abs( $path ) ;
+ $abs_path = File::Spec->rel2abs( $path, $base ) ;
+
+If C<$base> is not present or '', then L<Cwd::cwd()|Cwd> is used. If C<$base> is relative,
+then it is converted to absolute form using L</rel2abs()>. This means that it
+is taken to be relative to L<Cwd::cwd()|Cwd>.
+
+On systems with the concept of volume, if C<$path> and C<$base> appear to be
+on two different volumes, we will not attempt to resolve the two
+paths, and we will instead simply return C<$path>. Note that previous
+versions of this module ignored the volume of C<$base>, which resulted in
+garbage results part of the time.
+
+On systems that have a grammar that indicates filenames, this ignores the
+C<$base> filename as well. Otherwise all path components are assumed to be
+directories.
+
+If C<$path> is absolute, it is cleaned up and returned using L</canonpath()>.
+
+No checks against the filesystem are made. On VMS, there is
+interaction with the working environment, as logicals and
+macros are expanded.
+
+Based on code written by Shigio Yamaguchi.
+
+=back
+
+For further information, please see L<File::Spec::Unix>,
+L<File::Spec::Mac>, L<File::Spec::OS2>, L<File::Spec::Win32>, or
+L<File::Spec::VMS>.
+
+=head1 SEE ALSO
+
+L<File::Spec::Unix>, L<File::Spec::Mac>, L<File::Spec::OS2>,
+L<File::Spec::Win32>, L<File::Spec::VMS>, L<File::Spec::Functions>,
+L<ExtUtils::MakeMaker>
+
+=head1 AUTHOR
+
+Currently maintained by Ken Williams C<< <KWILLIAMS at cpan.org> >>.
+
+The vast majority of the code was written by
+Kenneth Albanowski C<< <kjahds at kjahds.com> >>,
+Andy Dougherty C<< <doughera at lafayette.edu> >>,
+Andreas KE<ouml>nig C<< <A.Koenig at franz.ww.TU-Berlin.DE> >>,
+Tim Bunce C<< <Tim.Bunce at ig.co.uk> >>.
+VMS support by Charles Bailey C<< <bailey at newman.upenn.edu> >>.
+OS/2 support by Ilya Zakharevich C<< <ilya at math.ohio-state.edu> >>.
+Mac support by Paul Schinder C<< <schinder at pobox.com> >>, and
+Thomas Wegner C<< <wegner_thomas at yahoo.com> >>.
+abs2rel() and rel2abs() written by Shigio Yamaguchi C<< <shigio at tamacom.com> >>,
+modified by Barrie Slaymaker C<< <barries at slaysys.com> >>.
+splitpath(), splitdir(), catpath() and catdir() by Barrie Slaymaker.
+
+=head1 COPYRIGHT
+
+Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
Copied: trunk/contrib/perl/lib/File/Temp.pm (from rev 6437, vendor/perl/5.18.1/lib/File/Temp.pm)
===================================================================
--- trunk/contrib/perl/lib/File/Temp.pm (rev 0)
+++ trunk/contrib/perl/lib/File/Temp.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,2452 @@
+package File::Temp;
+
+=head1 NAME
+
+File::Temp - return name and handle of a temporary file safely
+
+=begin __INTERNALS
+
+=head1 PORTABILITY
+
+This section is at the top in order to provide easier access to
+porters. It is not expected to be rendered by a standard pod
+formatting tool. Please skip straight to the SYNOPSIS section if you
+are not trying to port this module to a new platform.
+
+This module is designed to be portable across operating systems and it
+currently supports Unix, VMS, DOS, OS/2, Windows and Mac OS
+(Classic). When porting to a new OS there are generally three main
+issues that have to be solved:
+
+=over 4
+
+=item *
+
+Can the OS unlink an open file? If it can not then the
+C<_can_unlink_opened_file> method should be modified.
+
+=item *
+
+Are the return values from C<stat> reliable? By default all the
+return values from C<stat> are compared when unlinking a temporary
+file using the filename and the handle. Operating systems other than
+unix do not always have valid entries in all fields. If C<unlink0> fails
+then the C<stat> comparison should be modified accordingly.
+
+=item *
+
+Security. Systems that can not support a test for the sticky bit
+on a directory can not use the MEDIUM and HIGH security tests.
+The C<_can_do_level> method should be modified accordingly.
+
+=back
+
+=end __INTERNALS
+
+=head1 SYNOPSIS
+
+ use File::Temp qw/ tempfile tempdir /;
+
+ $fh = tempfile();
+ ($fh, $filename) = tempfile();
+
+ ($fh, $filename) = tempfile( $template, DIR => $dir);
+ ($fh, $filename) = tempfile( $template, SUFFIX => '.dat');
+ ($fh, $filename) = tempfile( $template, TMPDIR => 1 );
+
+ binmode( $fh, ":utf8" );
+
+ $dir = tempdir( CLEANUP => 1 );
+ ($fh, $filename) = tempfile( DIR => $dir );
+
+Object interface:
+
+ require File::Temp;
+ use File::Temp ();
+ use File::Temp qw/ :seekable /;
+
+ $fh = File::Temp->new();
+ $fname = $fh->filename;
+
+ $fh = File::Temp->new(TEMPLATE => $template);
+ $fname = $fh->filename;
+
+ $tmp = File::Temp->new( UNLINK => 0, SUFFIX => '.dat' );
+ print $tmp "Some data\n";
+ print "Filename is $tmp\n";
+ $tmp->seek( 0, SEEK_END );
+
+The following interfaces are provided for compatibility with
+existing APIs. They should not be used in new code.
+
+MkTemp family:
+
+ use File::Temp qw/ :mktemp /;
+
+ ($fh, $file) = mkstemp( "tmpfileXXXXX" );
+ ($fh, $file) = mkstemps( "tmpfileXXXXXX", $suffix);
+
+ $tmpdir = mkdtemp( $template );
+
+ $unopened_file = mktemp( $template );
+
+POSIX functions:
+
+ use File::Temp qw/ :POSIX /;
+
+ $file = tmpnam();
+ $fh = tmpfile();
+
+ ($fh, $file) = tmpnam();
+
+Compatibility functions:
+
+ $unopened_file = File::Temp::tempnam( $dir, $pfx );
+
+=head1 DESCRIPTION
+
+C<File::Temp> can be used to create and open temporary files in a safe
+way. There is both a function interface and an object-oriented
+interface. The File::Temp constructor or the tempfile() function can
+be used to return the name and the open filehandle of a temporary
+file. The tempdir() function can be used to create a temporary
+directory.
+
+The security aspect of temporary file creation is emphasized such that
+a filehandle and filename are returned together. This helps guarantee
+that a race condition can not occur where the temporary file is
+created by another process between checking for the existence of the
+file and its opening. Additional security levels are provided to
+check, for example, that the sticky bit is set on world writable
+directories. See L<"safe_level"> for more information.
+
+For compatibility with popular C library functions, Perl implementations of
+the mkstemp() family of functions are provided. These are, mkstemp(),
+mkstemps(), mkdtemp() and mktemp().
+
+Additionally, implementations of the standard L<POSIX|POSIX>
+tmpnam() and tmpfile() functions are provided if required.
+
+Implementations of mktemp(), tmpnam(), and tempnam() are provided,
+but should be used with caution since they return only a filename
+that was valid when function was called, so cannot guarantee
+that the file will not exist by the time the caller opens the filename.
+
+Filehandles returned by these functions support the seekable methods.
+
+=cut
+
+# 5.6.0 gives us S_IWOTH, S_IWGRP, our and auto-vivifying filehandls
+# People would like a version on 5.004 so give them what they want :-)
+use 5.004;
+use strict;
+use Carp;
+use File::Spec 0.8;
+use File::Path qw/ rmtree /;
+use Fcntl 1.03;
+use IO::Seekable; # For SEEK_*
+use Errno;
+require VMS::Stdio if $^O eq 'VMS';
+
+# pre-emptively load Carp::Heavy. If we don't when we run out of file
+# handles and attempt to call croak() we get an error message telling
+# us that Carp::Heavy won't load rather than an error telling us we
+# have run out of file handles. We either preload croak() or we
+# switch the calls to croak from _gettemp() to use die.
+eval { require Carp::Heavy; };
+
+# Need the Symbol package if we are running older perl
+require Symbol if $] < 5.006;
+
+### For the OO interface
+use base qw/ IO::Handle IO::Seekable /;
+use overload '""' => "STRINGIFY", fallback => 1;
+
+# use 'our' on v5.6.0
+use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS $DEBUG $KEEP_ALL);
+
+$DEBUG = 0;
+$KEEP_ALL = 0;
+
+# We are exporting functions
+
+use base qw/Exporter/;
+
+# Export list - to allow fine tuning of export table
+
+ at EXPORT_OK = qw{
+ tempfile
+ tempdir
+ tmpnam
+ tmpfile
+ mktemp
+ mkstemp
+ mkstemps
+ mkdtemp
+ unlink0
+ cleanup
+ SEEK_SET
+ SEEK_CUR
+ SEEK_END
+ };
+
+# Groups of functions for export
+
+%EXPORT_TAGS = (
+ 'POSIX' => [qw/ tmpnam tmpfile /],
+ 'mktemp' => [qw/ mktemp mkstemp mkstemps mkdtemp/],
+ 'seekable' => [qw/ SEEK_SET SEEK_CUR SEEK_END /],
+ );
+
+# add contents of these tags to @EXPORT
+Exporter::export_tags('POSIX','mktemp','seekable');
+
+# Version number
+
+$VERSION = '0.22';
+
+# This is a list of characters that can be used in random filenames
+
+my @CHARS = (qw/ A B C D E F G H I J K L M N O P Q R S T U V W X Y Z
+ a b c d e f g h i j k l m n o p q r s t u v w x y z
+ 0 1 2 3 4 5 6 7 8 9 _
+ /);
+
+# Maximum number of tries to make a temp file before failing
+
+use constant MAX_TRIES => 1000;
+
+# Minimum number of X characters that should be in a template
+use constant MINX => 4;
+
+# Default template when no template supplied
+
+use constant TEMPXXX => 'X' x 10;
+
+# Constants for the security level
+
+use constant STANDARD => 0;
+use constant MEDIUM => 1;
+use constant HIGH => 2;
+
+# OPENFLAGS. If we defined the flag to use with Sysopen here this gives
+# us an optimisation when many temporary files are requested
+
+my $OPENFLAGS = O_CREAT | O_EXCL | O_RDWR;
+my $LOCKFLAG;
+
+unless ($^O eq 'MacOS') {
+ for my $oflag (qw/ NOFOLLOW BINARY LARGEFILE NOINHERIT /) {
+ my ($bit, $func) = (0, "Fcntl::O_" . $oflag);
+ no strict 'refs';
+ $OPENFLAGS |= $bit if eval {
+ # Make sure that redefined die handlers do not cause problems
+ # e.g. CGI::Carp
+ local $SIG{__DIE__} = sub {};
+ local $SIG{__WARN__} = sub {};
+ $bit = &$func();
+ 1;
+ };
+ }
+ # Special case O_EXLOCK
+ $LOCKFLAG = eval {
+ local $SIG{__DIE__} = sub {};
+ local $SIG{__WARN__} = sub {};
+ &Fcntl::O_EXLOCK();
+ };
+}
+
+# On some systems the O_TEMPORARY flag can be used to tell the OS
+# to automatically remove the file when it is closed. This is fine
+# in most cases but not if tempfile is called with UNLINK=>0 and
+# the filename is requested -- in the case where the filename is to
+# be passed to another routine. This happens on windows. We overcome
+# this by using a second open flags variable
+
+my $OPENTEMPFLAGS = $OPENFLAGS;
+unless ($^O eq 'MacOS') {
+ for my $oflag (qw/ TEMPORARY /) {
+ my ($bit, $func) = (0, "Fcntl::O_" . $oflag);
+ local($@);
+ no strict 'refs';
+ $OPENTEMPFLAGS |= $bit if eval {
+ # Make sure that redefined die handlers do not cause problems
+ # e.g. CGI::Carp
+ local $SIG{__DIE__} = sub {};
+ local $SIG{__WARN__} = sub {};
+ $bit = &$func();
+ 1;
+ };
+ }
+}
+
+# Private hash tracking which files have been created by each process id via the OO interface
+my %FILES_CREATED_BY_OBJECT;
+
+# INTERNAL ROUTINES - not to be used outside of package
+
+# Generic routine for getting a temporary filename
+# modelled on OpenBSD _gettemp() in mktemp.c
+
+# The template must contain X's that are to be replaced
+# with the random values
+
+# Arguments:
+
+# TEMPLATE - string containing the XXXXX's that is converted
+# to a random filename and opened if required
+
+# Optionally, a hash can also be supplied containing specific options
+# "open" => if true open the temp file, else just return the name
+# default is 0
+# "mkdir"=> if true, we are creating a temp directory rather than tempfile
+# default is 0
+# "suffixlen" => number of characters at end of PATH to be ignored.
+# default is 0.
+# "unlink_on_close" => indicates that, if possible, the OS should remove
+# the file as soon as it is closed. Usually indicates
+# use of the O_TEMPORARY flag to sysopen.
+# Usually irrelevant on unix
+# "use_exlock" => Indicates that O_EXLOCK should be used. Default is true.
+
+# Optionally a reference to a scalar can be passed into the function
+# On error this will be used to store the reason for the error
+# "ErrStr" => \$errstr
+
+# "open" and "mkdir" can not both be true
+# "unlink_on_close" is not used when "mkdir" is true.
+
+# The default options are equivalent to mktemp().
+
+# Returns:
+# filehandle - open file handle (if called with doopen=1, else undef)
+# temp name - name of the temp file or directory
+
+# For example:
+# ($fh, $name) = _gettemp($template, "open" => 1);
+
+# for the current version, failures are associated with
+# stored in an error string and returned to give the reason whilst debugging
+# This routine is not called by any external function
+sub _gettemp {
+
+ croak 'Usage: ($fh, $name) = _gettemp($template, OPTIONS);'
+ unless scalar(@_) >= 1;
+
+ # the internal error string - expect it to be overridden
+ # Need this in case the caller decides not to supply us a value
+ # need an anonymous scalar
+ my $tempErrStr;
+
+ # Default options
+ my %options = (
+ "open" => 0,
+ "mkdir" => 0,
+ "suffixlen" => 0,
+ "unlink_on_close" => 0,
+ "use_exlock" => 1,
+ "ErrStr" => \$tempErrStr,
+ );
+
+ # Read the template
+ my $template = shift;
+ if (ref($template)) {
+ # Use a warning here since we have not yet merged ErrStr
+ carp "File::Temp::_gettemp: template must not be a reference";
+ return ();
+ }
+
+ # Check that the number of entries on stack are even
+ if (scalar(@_) % 2 != 0) {
+ # Use a warning here since we have not yet merged ErrStr
+ carp "File::Temp::_gettemp: Must have even number of options";
+ return ();
+ }
+
+ # Read the options and merge with defaults
+ %options = (%options, @_) if @_;
+
+ # Make sure the error string is set to undef
+ ${$options{ErrStr}} = undef;
+
+ # Can not open the file and make a directory in a single call
+ if ($options{"open"} && $options{"mkdir"}) {
+ ${$options{ErrStr}} = "doopen and domkdir can not both be true\n";
+ return ();
+ }
+
+ # Find the start of the end of the Xs (position of last X)
+ # Substr starts from 0
+ my $start = length($template) - 1 - $options{"suffixlen"};
+
+ # Check that we have at least MINX x X (e.g. 'XXXX") at the end of the string
+ # (taking suffixlen into account). Any fewer is insecure.
+
+ # Do it using substr - no reason to use a pattern match since
+ # we know where we are looking and what we are looking for
+
+ if (substr($template, $start - MINX + 1, MINX) ne 'X' x MINX) {
+ ${$options{ErrStr}} = "The template must end with at least ".
+ MINX . " 'X' characters\n";
+ return ();
+ }
+
+ # Replace all the X at the end of the substring with a
+ # random character or just all the XX at the end of a full string.
+ # Do it as an if, since the suffix adjusts which section to replace
+ # and suffixlen=0 returns nothing if used in the substr directly
+ # and generate a full path from the template
+
+ my $path = _replace_XX($template, $options{"suffixlen"});
+
+
+ # Split the path into constituent parts - eventually we need to check
+ # whether the directory exists
+ # We need to know whether we are making a temp directory
+ # or a tempfile
+
+ my ($volume, $directories, $file);
+ my $parent; # parent directory
+ if ($options{"mkdir"}) {
+ # There is no filename at the end
+ ($volume, $directories, $file) = File::Spec->splitpath( $path, 1);
+
+ # The parent is then $directories without the last directory
+ # Split the directory and put it back together again
+ my @dirs = File::Spec->splitdir($directories);
+
+ # If @dirs only has one entry (i.e. the directory template) that means
+ # we are in the current directory
+ if ($#dirs == 0) {
+ $parent = File::Spec->curdir;
+ } else {
+
+ if ($^O eq 'VMS') { # need volume to avoid relative dir spec
+ $parent = File::Spec->catdir($volume, @dirs[0..$#dirs-1]);
+ $parent = 'sys$disk:[]' if $parent eq '';
+ } else {
+
+ # Put it back together without the last one
+ $parent = File::Spec->catdir(@dirs[0..$#dirs-1]);
+
+ # ...and attach the volume (no filename)
+ $parent = File::Spec->catpath($volume, $parent, '');
+ }
+
+ }
+
+ } else {
+
+ # Get rid of the last filename (use File::Basename for this?)
+ ($volume, $directories, $file) = File::Spec->splitpath( $path );
+
+ # Join up without the file part
+ $parent = File::Spec->catpath($volume,$directories,'');
+
+ # If $parent is empty replace with curdir
+ $parent = File::Spec->curdir
+ unless $directories ne '';
+
+ }
+
+ # Check that the parent directories exist
+ # Do this even for the case where we are simply returning a name
+ # not a file -- no point returning a name that includes a directory
+ # that does not exist or is not writable
+
+ unless (-e $parent) {
+ ${$options{ErrStr}} = "Parent directory ($parent) does not exist";
+ return ();
+ }
+ unless (-d $parent) {
+ ${$options{ErrStr}} = "Parent directory ($parent) is not a directory";
+ return ();
+ }
+
+ # Check the stickiness of the directory and chown giveaway if required
+ # If the directory is world writable the sticky bit
+ # must be set
+
+ if (File::Temp->safe_level == MEDIUM) {
+ my $safeerr;
+ unless (_is_safe($parent,\$safeerr)) {
+ ${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)";
+ return ();
+ }
+ } elsif (File::Temp->safe_level == HIGH) {
+ my $safeerr;
+ unless (_is_verysafe($parent, \$safeerr)) {
+ ${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)";
+ return ();
+ }
+ }
+
+
+ # Now try MAX_TRIES time to open the file
+ for (my $i = 0; $i < MAX_TRIES; $i++) {
+
+ # Try to open the file if requested
+ if ($options{"open"}) {
+ my $fh;
+
+ # If we are running before perl5.6.0 we can not auto-vivify
+ if ($] < 5.006) {
+ $fh = &Symbol::gensym;
+ }
+
+ # Try to make sure this will be marked close-on-exec
+ # XXX: Win32 doesn't respect this, nor the proper fcntl,
+ # but may have O_NOINHERIT. This may or may not be in Fcntl.
+ local $^F = 2;
+
+ # Attempt to open the file
+ my $open_success = undef;
+ if ( $^O eq 'VMS' and $options{"unlink_on_close"} && !$KEEP_ALL) {
+ # make it auto delete on close by setting FAB$V_DLT bit
+ $fh = VMS::Stdio::vmssysopen($path, $OPENFLAGS, 0600, 'fop=dlt');
+ $open_success = $fh;
+ } else {
+ my $flags = ( ($options{"unlink_on_close"} && !$KEEP_ALL) ?
+ $OPENTEMPFLAGS :
+ $OPENFLAGS );
+ $flags |= $LOCKFLAG if (defined $LOCKFLAG && $options{use_exlock});
+ $open_success = sysopen($fh, $path, $flags, 0600);
+ }
+ if ( $open_success ) {
+
+ # in case of odd umask force rw
+ chmod(0600, $path);
+
+ # Opened successfully - return file handle and name
+ return ($fh, $path);
+
+ } else {
+
+ # Error opening file - abort with error
+ # if the reason was anything but EEXIST
+ unless ($!{EEXIST}) {
+ ${$options{ErrStr}} = "Could not create temp file $path: $!";
+ return ();
+ }
+
+ # Loop round for another try
+
+ }
+ } elsif ($options{"mkdir"}) {
+
+ # Open the temp directory
+ if (mkdir( $path, 0700)) {
+ # in case of odd umask
+ chmod(0700, $path);
+
+ return undef, $path;
+ } else {
+
+ # Abort with error if the reason for failure was anything
+ # except EEXIST
+ unless ($!{EEXIST}) {
+ ${$options{ErrStr}} = "Could not create directory $path: $!";
+ return ();
+ }
+
+ # Loop round for another try
+
+ }
+
+ } else {
+
+ # Return true if the file can not be found
+ # Directory has been checked previously
+
+ return (undef, $path) unless -e $path;
+
+ # Try again until MAX_TRIES
+
+ }
+
+ # Did not successfully open the tempfile/dir
+ # so try again with a different set of random letters
+ # No point in trying to increment unless we have only
+ # 1 X say and the randomness could come up with the same
+ # file MAX_TRIES in a row.
+
+ # Store current attempt - in principal this implies that the
+ # 3rd time around the open attempt that the first temp file
+ # name could be generated again. Probably should store each
+ # attempt and make sure that none are repeated
+
+ my $original = $path;
+ my $counter = 0; # Stop infinite loop
+ my $MAX_GUESS = 50;
+
+ do {
+
+ # Generate new name from original template
+ $path = _replace_XX($template, $options{"suffixlen"});
+
+ $counter++;
+
+ } until ($path ne $original || $counter > $MAX_GUESS);
+
+ # Check for out of control looping
+ if ($counter > $MAX_GUESS) {
+ ${$options{ErrStr}} = "Tried to get a new temp name different to the previous value $MAX_GUESS times.\nSomething wrong with template?? ($template)";
+ return ();
+ }
+
+ }
+
+ # If we get here, we have run out of tries
+ ${ $options{ErrStr} } = "Have exceeded the maximum number of attempts ("
+ . MAX_TRIES . ") to open temp file/dir";
+
+ return ();
+
+}
+
+# Internal routine to replace the XXXX... with random characters
+# This has to be done by _gettemp() every time it fails to
+# open a temp file/dir
+
+# Arguments: $template (the template with XXX),
+# $ignore (number of characters at end to ignore)
+
+# Returns: modified template
+
+sub _replace_XX {
+
+ croak 'Usage: _replace_XX($template, $ignore)'
+ unless scalar(@_) == 2;
+
+ my ($path, $ignore) = @_;
+
+ # Do it as an if, since the suffix adjusts which section to replace
+ # and suffixlen=0 returns nothing if used in the substr directly
+ # Alternatively, could simply set $ignore to length($path)-1
+ # Don't want to always use substr when not required though.
+ my $end = ( $] >= 5.006 ? "\\z" : "\\Z" );
+
+ if ($ignore) {
+ substr($path, 0, - $ignore) =~ s/X(?=X*$end)/$CHARS[ int( rand( @CHARS ) ) ]/ge;
+ } else {
+ $path =~ s/X(?=X*$end)/$CHARS[ int( rand( @CHARS ) ) ]/ge;
+ }
+ return $path;
+}
+
+# Internal routine to force a temp file to be writable after
+# it is created so that we can unlink it. Windows seems to occassionally
+# force a file to be readonly when written to certain temp locations
+sub _force_writable {
+ my $file = shift;
+ chmod 0600, $file;
+}
+
+
+# internal routine to check to see if the directory is safe
+# First checks to see if the directory is not owned by the
+# current user or root. Then checks to see if anyone else
+# can write to the directory and if so, checks to see if
+# it has the sticky bit set
+
+# Will not work on systems that do not support sticky bit
+
+#Args: directory path to check
+# Optionally: reference to scalar to contain error message
+# Returns true if the path is safe and false otherwise.
+# Returns undef if can not even run stat() on the path
+
+# This routine based on version written by Tom Christiansen
+
+# Presumably, by the time we actually attempt to create the
+# file or directory in this directory, it may not be safe
+# anymore... Have to run _is_safe directly after the open.
+
+sub _is_safe {
+
+ my $path = shift;
+ my $err_ref = shift;
+
+ # Stat path
+ my @info = stat($path);
+ unless (scalar(@info)) {
+ $$err_ref = "stat(path) returned no values";
+ return 0;
+ }
+ ;
+ return 1 if $^O eq 'VMS'; # owner delete control at file level
+
+ # Check to see whether owner is neither superuser (or a system uid) nor me
+ # Use the effective uid from the $> variable
+ # UID is in [4]
+ if ($info[4] > File::Temp->top_system_uid() && $info[4] != $>) {
+
+ Carp::cluck(sprintf "uid=$info[4] topuid=%s euid=$> path='$path'",
+ File::Temp->top_system_uid());
+
+ $$err_ref = "Directory owned neither by root nor the current user"
+ if ref($err_ref);
+ return 0;
+ }
+
+ # check whether group or other can write file
+ # use 066 to detect either reading or writing
+ # use 022 to check writability
+ # Do it with S_IWOTH and S_IWGRP for portability (maybe)
+ # mode is in info[2]
+ if (($info[2] & &Fcntl::S_IWGRP) || # Is group writable?
+ ($info[2] & &Fcntl::S_IWOTH) ) { # Is world writable?
+ # Must be a directory
+ unless (-d $path) {
+ $$err_ref = "Path ($path) is not a directory"
+ if ref($err_ref);
+ return 0;
+ }
+ # Must have sticky bit set
+ unless (-k $path) {
+ $$err_ref = "Sticky bit not set on $path when dir is group|world writable"
+ if ref($err_ref);
+ return 0;
+ }
+ }
+
+ return 1;
+}
+
+# Internal routine to check whether a directory is safe
+# for temp files. Safer than _is_safe since it checks for
+# the possibility of chown giveaway and if that is a possibility
+# checks each directory in the path to see if it is safe (with _is_safe)
+
+# If _PC_CHOWN_RESTRICTED is not set, does the full test of each
+# directory anyway.
+
+# Takes optional second arg as scalar ref to error reason
+
+sub _is_verysafe {
+
+ # Need POSIX - but only want to bother if really necessary due to overhead
+ require POSIX;
+
+ my $path = shift;
+ print "_is_verysafe testing $path\n" if $DEBUG;
+ return 1 if $^O eq 'VMS'; # owner delete control at file level
+
+ my $err_ref = shift;
+
+ # Should Get the value of _PC_CHOWN_RESTRICTED if it is defined
+ # and If it is not there do the extensive test
+ local($@);
+ my $chown_restricted;
+ $chown_restricted = &POSIX::_PC_CHOWN_RESTRICTED()
+ if eval { &POSIX::_PC_CHOWN_RESTRICTED(); 1};
+
+ # If chown_resticted is set to some value we should test it
+ if (defined $chown_restricted) {
+
+ # Return if the current directory is safe
+ return _is_safe($path,$err_ref) if POSIX::sysconf( $chown_restricted );
+
+ }
+
+ # To reach this point either, the _PC_CHOWN_RESTRICTED symbol
+ # was not avialable or the symbol was there but chown giveaway
+ # is allowed. Either way, we now have to test the entire tree for
+ # safety.
+
+ # Convert path to an absolute directory if required
+ unless (File::Spec->file_name_is_absolute($path)) {
+ $path = File::Spec->rel2abs($path);
+ }
+
+ # Split directory into components - assume no file
+ my ($volume, $directories, undef) = File::Spec->splitpath( $path, 1);
+
+ # Slightly less efficient than having a function in File::Spec
+ # to chop off the end of a directory or even a function that
+ # can handle ../ in a directory tree
+ # Sometimes splitdir() returns a blank at the end
+ # so we will probably check the bottom directory twice in some cases
+ my @dirs = File::Spec->splitdir($directories);
+
+ # Concatenate one less directory each time around
+ foreach my $pos (0.. $#dirs) {
+ # Get a directory name
+ my $dir = File::Spec->catpath($volume,
+ File::Spec->catdir(@dirs[0.. $#dirs - $pos]),
+ ''
+ );
+
+ print "TESTING DIR $dir\n" if $DEBUG;
+
+ # Check the directory
+ return 0 unless _is_safe($dir,$err_ref);
+
+ }
+
+ return 1;
+}
+
+
+
+# internal routine to determine whether unlink works on this
+# platform for files that are currently open.
+# Returns true if we can, false otherwise.
+
+# Currently WinNT, OS/2 and VMS can not unlink an opened file
+# On VMS this is because the O_EXCL flag is used to open the
+# temporary file. Currently I do not know enough about the issues
+# on VMS to decide whether O_EXCL is a requirement.
+
+sub _can_unlink_opened_file {
+
+ if ($^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'VMS' || $^O eq 'dos' || $^O eq 'MacOS') {
+ return 0;
+ } else {
+ return 1;
+ }
+
+}
+
+# internal routine to decide which security levels are allowed
+# see safe_level() for more information on this
+
+# Controls whether the supplied security level is allowed
+
+# $cando = _can_do_level( $level )
+
+sub _can_do_level {
+
+ # Get security level
+ my $level = shift;
+
+ # Always have to be able to do STANDARD
+ return 1 if $level == STANDARD;
+
+ # Currently, the systems that can do HIGH or MEDIUM are identical
+ if ( $^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'cygwin' || $^O eq 'dos' || $^O eq 'MacOS' || $^O eq 'mpeix') {
+ return 0;
+ } else {
+ return 1;
+ }
+
+}
+
+# This routine sets up a deferred unlinking of a specified
+# filename and filehandle. It is used in the following cases:
+# - Called by unlink0 if an opened file can not be unlinked
+# - Called by tempfile() if files are to be removed on shutdown
+# - Called by tempdir() if directories are to be removed on shutdown
+
+# Arguments:
+# _deferred_unlink( $fh, $fname, $isdir );
+#
+# - filehandle (so that it can be expclicitly closed if open
+# - filename (the thing we want to remove)
+# - isdir (flag to indicate that we are being given a directory)
+# [and hence no filehandle]
+
+# Status is not referred to since all the magic is done with an END block
+
+{
+ # Will set up two lexical variables to contain all the files to be
+ # removed. One array for files, another for directories They will
+ # only exist in this block.
+
+ # This means we only have to set up a single END block to remove
+ # all files.
+
+ # in order to prevent child processes inadvertently deleting the parent
+ # temp files we use a hash to store the temp files and directories
+ # created by a particular process id.
+
+ # %files_to_unlink contains values that are references to an array of
+ # array references containing the filehandle and filename associated with
+ # the temp file.
+ my (%files_to_unlink, %dirs_to_unlink);
+
+ # Set up an end block to use these arrays
+ END {
+ local($., $@, $!, $^E, $?);
+ cleanup();
+ }
+
+ # Cleanup function. Always triggered on END but can be invoked
+ # manually.
+ sub cleanup {
+ if (!$KEEP_ALL) {
+ # Files
+ my @files = (exists $files_to_unlink{$$} ?
+ @{ $files_to_unlink{$$} } : () );
+ foreach my $file (@files) {
+ # close the filehandle without checking its state
+ # in order to make real sure that this is closed
+ # if its already closed then I dont care about the answer
+ # probably a better way to do this
+ close($file->[0]); # file handle is [0]
+
+ if (-f $file->[1]) { # file name is [1]
+ _force_writable( $file->[1] ); # for windows
+ unlink $file->[1] or warn "Error removing ".$file->[1];
+ }
+ }
+ # Dirs
+ my @dirs = (exists $dirs_to_unlink{$$} ?
+ @{ $dirs_to_unlink{$$} } : () );
+ foreach my $dir (@dirs) {
+ if (-d $dir) {
+ # Some versions of rmtree will abort if you attempt to remove
+ # the directory you are sitting in. We protect that and turn it
+ # into a warning. We do this because this occurs during
+ # cleanup and so can not be caught by the user.
+ eval { rmtree($dir, $DEBUG, 0); };
+ warn $@ if ($@ && $^W);
+ }
+ }
+
+ # clear the arrays
+ @{ $files_to_unlink{$$} } = ()
+ if exists $files_to_unlink{$$};
+ @{ $dirs_to_unlink{$$} } = ()
+ if exists $dirs_to_unlink{$$};
+ }
+ }
+
+
+ # This is the sub called to register a file for deferred unlinking
+ # This could simply store the input parameters and defer everything
+ # until the END block. For now we do a bit of checking at this
+ # point in order to make sure that (1) we have a file/dir to delete
+ # and (2) we have been called with the correct arguments.
+ sub _deferred_unlink {
+
+ croak 'Usage: _deferred_unlink($fh, $fname, $isdir)'
+ unless scalar(@_) == 3;
+
+ my ($fh, $fname, $isdir) = @_;
+
+ warn "Setting up deferred removal of $fname\n"
+ if $DEBUG;
+
+ # If we have a directory, check that it is a directory
+ if ($isdir) {
+
+ if (-d $fname) {
+
+ # Directory exists so store it
+ # first on VMS turn []foo into [.foo] for rmtree
+ $fname = VMS::Filespec::vmspath($fname) if $^O eq 'VMS';
+ $dirs_to_unlink{$$} = []
+ unless exists $dirs_to_unlink{$$};
+ push (@{ $dirs_to_unlink{$$} }, $fname);
+
+ } else {
+ carp "Request to remove directory $fname could not be completed since it does not exist!\n" if $^W;
+ }
+
+ } else {
+
+ if (-f $fname) {
+
+ # file exists so store handle and name for later removal
+ $files_to_unlink{$$} = []
+ unless exists $files_to_unlink{$$};
+ push(@{ $files_to_unlink{$$} }, [$fh, $fname]);
+
+ } else {
+ carp "Request to remove file $fname could not be completed since it is not there!\n" if $^W;
+ }
+
+ }
+
+ }
+
+
+}
+
+=head1 OBJECT-ORIENTED INTERFACE
+
+This is the primary interface for interacting with
+C<File::Temp>. Using the OO interface a temporary file can be created
+when the object is constructed and the file can be removed when the
+object is no longer required.
+
+Note that there is no method to obtain the filehandle from the
+C<File::Temp> object. The object itself acts as a filehandle. Also,
+the object is configured such that it stringifies to the name of the
+temporary file, and can be compared to a filename directly. The object
+isa C<IO::Handle> and isa C<IO::Seekable> so all those methods are
+available.
+
+=over 4
+
+=item B<new>
+
+Create a temporary file object.
+
+ my $tmp = File::Temp->new();
+
+by default the object is constructed as if C<tempfile>
+was called without options, but with the additional behaviour
+that the temporary file is removed by the object destructor
+if UNLINK is set to true (the default).
+
+Supported arguments are the same as for C<tempfile>: UNLINK
+(defaulting to true), DIR, EXLOCK and SUFFIX. Additionally, the filename
+template is specified using the TEMPLATE option. The OPEN option
+is not supported (the file is always opened).
+
+ $tmp = File::Temp->new( TEMPLATE => 'tempXXXXX',
+ DIR => 'mydir',
+ SUFFIX => '.dat');
+
+Arguments are case insensitive.
+
+Can call croak() if an error occurs.
+
+=cut
+
+sub new {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+
+ # read arguments and convert keys to upper case
+ my %args = @_;
+ %args = map { uc($_), $args{$_} } keys %args;
+
+ # see if they are unlinking (defaulting to yes)
+ my $unlink = (exists $args{UNLINK} ? $args{UNLINK} : 1 );
+ delete $args{UNLINK};
+
+ # template (store it in an array so that it will
+ # disappear from the arg list of tempfile)
+ my @template = ( exists $args{TEMPLATE} ? $args{TEMPLATE} : () );
+ delete $args{TEMPLATE};
+
+ # Protect OPEN
+ delete $args{OPEN};
+
+ # Open the file and retain file handle and file name
+ my ($fh, $path) = tempfile( @template, %args );
+
+ print "Tmp: $fh - $path\n" if $DEBUG;
+
+ # Store the filename in the scalar slot
+ ${*$fh} = $path;
+
+ # Cache the filename by pid so that the destructor can decide whether to remove it
+ $FILES_CREATED_BY_OBJECT{$$}{$path} = 1;
+
+ # Store unlink information in hash slot (plus other constructor info)
+ %{*$fh} = %args;
+
+ # create the object
+ bless $fh, $class;
+
+ # final method-based configuration
+ $fh->unlink_on_destroy( $unlink );
+
+ return $fh;
+}
+
+=item B<newdir>
+
+Create a temporary directory using an object oriented interface.
+
+ $dir = File::Temp->newdir();
+
+By default the directory is deleted when the object goes out of scope.
+
+Supports the same options as the C<tempdir> function. Note that directories
+created with this method default to CLEANUP => 1.
+
+ $dir = File::Temp->newdir( $template, %options );
+
+=cut
+
+sub newdir {
+ my $self = shift;
+
+ # need to handle args as in tempdir because we have to force CLEANUP
+ # default without passing CLEANUP to tempdir
+ my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef );
+ my %options = @_;
+ my $cleanup = (exists $options{CLEANUP} ? $options{CLEANUP} : 1 );
+
+ delete $options{CLEANUP};
+
+ my $tempdir;
+ if (defined $template) {
+ $tempdir = tempdir( $template, %options );
+ } else {
+ $tempdir = tempdir( %options );
+ }
+ return bless { DIRNAME => $tempdir,
+ CLEANUP => $cleanup,
+ LAUNCHPID => $$,
+ }, "File::Temp::Dir";
+}
+
+=item B<filename>
+
+Return the name of the temporary file associated with this object
+(if the object was created using the "new" constructor).
+
+ $filename = $tmp->filename;
+
+This method is called automatically when the object is used as
+a string.
+
+=cut
+
+sub filename {
+ my $self = shift;
+ return ${*$self};
+}
+
+sub STRINGIFY {
+ my $self = shift;
+ return $self->filename;
+}
+
+=item B<dirname>
+
+Return the name of the temporary directory associated with this
+object (if the object was created using the "newdir" constructor).
+
+ $dirname = $tmpdir->dirname;
+
+This method is called automatically when the object is used in string context.
+
+=item B<unlink_on_destroy>
+
+Control whether the file is unlinked when the object goes out of scope.
+The file is removed if this value is true and $KEEP_ALL is not.
+
+ $fh->unlink_on_destroy( 1 );
+
+Default is for the file to be removed.
+
+=cut
+
+sub unlink_on_destroy {
+ my $self = shift;
+ if (@_) {
+ ${*$self}{UNLINK} = shift;
+ }
+ return ${*$self}{UNLINK};
+}
+
+=item B<DESTROY>
+
+When the object goes out of scope, the destructor is called. This
+destructor will attempt to unlink the file (using C<unlink1>)
+if the constructor was called with UNLINK set to 1 (the default state
+if UNLINK is not specified).
+
+No error is given if the unlink fails.
+
+If the object has been passed to a child process during a fork, the
+file will be deleted when the object goes out of scope in the parent.
+
+For a temporary directory object the directory will be removed
+unless the CLEANUP argument was used in the constructor (and set to
+false) or C<unlink_on_destroy> was modified after creation.
+
+If the global variable $KEEP_ALL is true, the file or directory
+will not be removed.
+
+=cut
+
+sub DESTROY {
+ local($., $@, $!, $^E, $?);
+ my $self = shift;
+
+ # Make sure we always remove the file from the global hash
+ # on destruction. This prevents the hash from growing uncontrollably
+ # and post-destruction there is no reason to know about the file.
+ my $file = $self->filename;
+ my $was_created_by_proc;
+ if (exists $FILES_CREATED_BY_OBJECT{$$}{$file}) {
+ $was_created_by_proc = 1;
+ delete $FILES_CREATED_BY_OBJECT{$$}{$file};
+ }
+
+ if (${*$self}{UNLINK} && !$KEEP_ALL) {
+ print "# ---------> Unlinking $self\n" if $DEBUG;
+
+ # only delete if this process created it
+ return unless $was_created_by_proc;
+
+ # The unlink1 may fail if the file has been closed
+ # by the caller. This leaves us with the decision
+ # of whether to refuse to remove the file or simply
+ # do an unlink without test. Seems to be silly
+ # to do this when we are trying to be careful
+ # about security
+ _force_writable( $file ); # for windows
+ unlink1( $self, $file )
+ or unlink($file);
+ }
+}
+
+=back
+
+=head1 FUNCTIONS
+
+This section describes the recommended interface for generating
+temporary files and directories.
+
+=over 4
+
+=item B<tempfile>
+
+This is the basic function to generate temporary files.
+The behaviour of the file can be changed using various options:
+
+ $fh = tempfile();
+ ($fh, $filename) = tempfile();
+
+Create a temporary file in the directory specified for temporary
+files, as specified by the tmpdir() function in L<File::Spec>.
+
+ ($fh, $filename) = tempfile($template);
+
+Create a temporary file in the current directory using the supplied
+template. Trailing `X' characters are replaced with random letters to
+generate the filename. At least four `X' characters must be present
+at the end of the template.
+
+ ($fh, $filename) = tempfile($template, SUFFIX => $suffix)
+
+Same as previously, except that a suffix is added to the template
+after the `X' translation. Useful for ensuring that a temporary
+filename has a particular extension when needed by other applications.
+But see the WARNING at the end.
+
+ ($fh, $filename) = tempfile($template, DIR => $dir);
+
+Translates the template as before except that a directory name
+is specified.
+
+ ($fh, $filename) = tempfile($template, TMPDIR => 1);
+
+Equivalent to specifying a DIR of "File::Spec->tmpdir", writing the file
+into the same temporary directory as would be used if no template was
+specified at all.
+
+ ($fh, $filename) = tempfile($template, UNLINK => 1);
+
+Return the filename and filehandle as before except that the file is
+automatically removed when the program exits (dependent on
+$KEEP_ALL). Default is for the file to be removed if a file handle is
+requested and to be kept if the filename is requested. In a scalar
+context (where no filename is returned) the file is always deleted
+either (depending on the operating system) on exit or when it is
+closed (unless $KEEP_ALL is true when the temp file is created).
+
+Use the object-oriented interface if fine-grained control of when
+a file is removed is required.
+
+If the template is not specified, a template is always
+automatically generated. This temporary file is placed in tmpdir()
+(L<File::Spec>) unless a directory is specified explicitly with the
+DIR option.
+
+ $fh = tempfile( DIR => $dir );
+
+If called in scalar context, only the filehandle is returned and the
+file will automatically be deleted when closed on operating systems
+that support this (see the description of tmpfile() elsewhere in this
+document). This is the preferred mode of operation, as if you only
+have a filehandle, you can never create a race condition by fumbling
+with the filename. On systems that can not unlink an open file or can
+not mark a file as temporary when it is opened (for example, Windows
+NT uses the C<O_TEMPORARY> flag) the file is marked for deletion when
+the program ends (equivalent to setting UNLINK to 1). The C<UNLINK>
+flag is ignored if present.
+
+ (undef, $filename) = tempfile($template, OPEN => 0);
+
+This will return the filename based on the template but
+will not open this file. Cannot be used in conjunction with
+UNLINK set to true. Default is to always open the file
+to protect from possible race conditions. A warning is issued
+if warnings are turned on. Consider using the tmpnam()
+and mktemp() functions described elsewhere in this document
+if opening the file is not required.
+
+If the operating system supports it (for example BSD derived systems), the
+filehandle will be opened with O_EXLOCK (open with exclusive file lock).
+This can sometimes cause problems if the intention is to pass the filename
+to another system that expects to take an exclusive lock itself (such as
+DBD::SQLite) whilst ensuring that the tempfile is not reused. In this
+situation the "EXLOCK" option can be passed to tempfile. By default EXLOCK
+will be true (this retains compatibility with earlier releases).
+
+ ($fh, $filename) = tempfile($template, EXLOCK => 0);
+
+Options can be combined as required.
+
+Will croak() if there is an error.
+
+=cut
+
+sub tempfile {
+
+ # Can not check for argument count since we can have any
+ # number of args
+
+ # Default options
+ my %options = (
+ "DIR" => undef, # Directory prefix
+ "SUFFIX" => '', # Template suffix
+ "UNLINK" => 0, # Do not unlink file on exit
+ "OPEN" => 1, # Open file
+ "TMPDIR" => 0, # Place tempfile in tempdir if template specified
+ "EXLOCK" => 1, # Open file with O_EXLOCK
+ );
+
+ # Check to see whether we have an odd or even number of arguments
+ my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef);
+
+ # Read the options and merge with defaults
+ %options = (%options, @_) if @_;
+
+ # First decision is whether or not to open the file
+ if (! $options{"OPEN"}) {
+
+ warn "tempfile(): temporary filename requested but not opened.\nPossibly unsafe, consider using tempfile() with OPEN set to true\n"
+ if $^W;
+
+ }
+
+ if ($options{"DIR"} and $^O eq 'VMS') {
+
+ # on VMS turn []foo into [.foo] for concatenation
+ $options{"DIR"} = VMS::Filespec::vmspath($options{"DIR"});
+ }
+
+ # Construct the template
+
+ # Have a choice of trying to work around the mkstemp/mktemp/tmpnam etc
+ # functions or simply constructing a template and using _gettemp()
+ # explicitly. Go for the latter
+
+ # First generate a template if not defined and prefix the directory
+ # If no template must prefix the temp directory
+ if (defined $template) {
+ # End up with current directory if neither DIR not TMPDIR are set
+ if ($options{"DIR"}) {
+
+ $template = File::Spec->catfile($options{"DIR"}, $template);
+
+ } elsif ($options{TMPDIR}) {
+
+ $template = File::Spec->catfile(File::Spec->tmpdir, $template );
+
+ }
+
+ } else {
+
+ if ($options{"DIR"}) {
+
+ $template = File::Spec->catfile($options{"DIR"}, TEMPXXX);
+
+ } else {
+
+ $template = File::Spec->catfile(File::Spec->tmpdir, TEMPXXX);
+
+ }
+
+ }
+
+ # Now add a suffix
+ $template .= $options{"SUFFIX"};
+
+ # Determine whether we should tell _gettemp to unlink the file
+ # On unix this is irrelevant and can be worked out after the file is
+ # opened (simply by unlinking the open filehandle). On Windows or VMS
+ # we have to indicate temporary-ness when we open the file. In general
+ # we only want a true temporary file if we are returning just the
+ # filehandle - if the user wants the filename they probably do not
+ # want the file to disappear as soon as they close it (which may be
+ # important if they want a child process to use the file)
+ # For this reason, tie unlink_on_close to the return context regardless
+ # of OS.
+ my $unlink_on_close = ( wantarray ? 0 : 1);
+
+ # Create the file
+ my ($fh, $path, $errstr);
+ croak "Error in tempfile() using $template: $errstr"
+ unless (($fh, $path) = _gettemp($template,
+ "open" => $options{'OPEN'},
+ "mkdir"=> 0 ,
+ "unlink_on_close" => $unlink_on_close,
+ "suffixlen" => length($options{'SUFFIX'}),
+ "ErrStr" => \$errstr,
+ "use_exlock" => $options{EXLOCK},
+ ) );
+
+ # Set up an exit handler that can do whatever is right for the
+ # system. This removes files at exit when requested explicitly or when
+ # system is asked to unlink_on_close but is unable to do so because
+ # of OS limitations.
+ # The latter should be achieved by using a tied filehandle.
+ # Do not check return status since this is all done with END blocks.
+ _deferred_unlink($fh, $path, 0) if $options{"UNLINK"};
+
+ # Return
+ if (wantarray()) {
+
+ if ($options{'OPEN'}) {
+ return ($fh, $path);
+ } else {
+ return (undef, $path);
+ }
+
+ } else {
+
+ # Unlink the file. It is up to unlink0 to decide what to do with
+ # this (whether to unlink now or to defer until later)
+ unlink0($fh, $path) or croak "Error unlinking file $path using unlink0";
+
+ # Return just the filehandle.
+ return $fh;
+ }
+
+
+}
+
+=item B<tempdir>
+
+This is the recommended interface for creation of temporary
+directories. By default the directory will not be removed on exit
+(that is, it won't be temporary; this behaviour can not be changed
+because of issues with backwards compatibility). To enable removal
+either use the CLEANUP option which will trigger removal on program
+exit, or consider using the "newdir" method in the object interface which
+will allow the directory to be cleaned up when the object goes out of
+scope.
+
+The behaviour of the function depends on the arguments:
+
+ $tempdir = tempdir();
+
+Create a directory in tmpdir() (see L<File::Spec|File::Spec>).
+
+ $tempdir = tempdir( $template );
+
+Create a directory from the supplied template. This template is
+similar to that described for tempfile(). `X' characters at the end
+of the template are replaced with random letters to construct the
+directory name. At least four `X' characters must be in the template.
+
+ $tempdir = tempdir ( DIR => $dir );
+
+Specifies the directory to use for the temporary directory.
+The temporary directory name is derived from an internal template.
+
+ $tempdir = tempdir ( $template, DIR => $dir );
+
+Prepend the supplied directory name to the template. The template
+should not include parent directory specifications itself. Any parent
+directory specifications are removed from the template before
+prepending the supplied directory.
+
+ $tempdir = tempdir ( $template, TMPDIR => 1 );
+
+Using the supplied template, create the temporary directory in
+a standard location for temporary files. Equivalent to doing
+
+ $tempdir = tempdir ( $template, DIR => File::Spec->tmpdir);
+
+but shorter. Parent directory specifications are stripped from the
+template itself. The C<TMPDIR> option is ignored if C<DIR> is set
+explicitly. Additionally, C<TMPDIR> is implied if neither a template
+nor a directory are supplied.
+
+ $tempdir = tempdir( $template, CLEANUP => 1);
+
+Create a temporary directory using the supplied template, but
+attempt to remove it (and all files inside it) when the program
+exits. Note that an attempt will be made to remove all files from
+the directory even if they were not created by this module (otherwise
+why ask to clean it up?). The directory removal is made with
+the rmtree() function from the L<File::Path|File::Path> module.
+Of course, if the template is not specified, the temporary directory
+will be created in tmpdir() and will also be removed at program exit.
+
+Will croak() if there is an error.
+
+=cut
+
+# '
+
+sub tempdir {
+
+ # Can not check for argument count since we can have any
+ # number of args
+
+ # Default options
+ my %options = (
+ "CLEANUP" => 0, # Remove directory on exit
+ "DIR" => '', # Root directory
+ "TMPDIR" => 0, # Use tempdir with template
+ );
+
+ # Check to see whether we have an odd or even number of arguments
+ my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef );
+
+ # Read the options and merge with defaults
+ %options = (%options, @_) if @_;
+
+ # Modify or generate the template
+
+ # Deal with the DIR and TMPDIR options
+ if (defined $template) {
+
+ # Need to strip directory path if using DIR or TMPDIR
+ if ($options{'TMPDIR'} || $options{'DIR'}) {
+
+ # Strip parent directory from the filename
+ #
+ # There is no filename at the end
+ $template = VMS::Filespec::vmspath($template) if $^O eq 'VMS';
+ my ($volume, $directories, undef) = File::Spec->splitpath( $template, 1);
+
+ # Last directory is then our template
+ $template = (File::Spec->splitdir($directories))[-1];
+
+ # Prepend the supplied directory or temp dir
+ if ($options{"DIR"}) {
+
+ $template = File::Spec->catdir($options{"DIR"}, $template);
+
+ } elsif ($options{TMPDIR}) {
+
+ # Prepend tmpdir
+ $template = File::Spec->catdir(File::Spec->tmpdir, $template);
+
+ }
+
+ }
+
+ } else {
+
+ if ($options{"DIR"}) {
+
+ $template = File::Spec->catdir($options{"DIR"}, TEMPXXX);
+
+ } else {
+
+ $template = File::Spec->catdir(File::Spec->tmpdir, TEMPXXX);
+
+ }
+
+ }
+
+ # Create the directory
+ my $tempdir;
+ my $suffixlen = 0;
+ if ($^O eq 'VMS') { # dir names can end in delimiters
+ $template =~ m/([\.\]:>]+)$/;
+ $suffixlen = length($1);
+ }
+ if ( ($^O eq 'MacOS') && (substr($template, -1) eq ':') ) {
+ # dir name has a trailing ':'
+ ++$suffixlen;
+ }
+
+ my $errstr;
+ croak "Error in tempdir() using $template: $errstr"
+ unless ((undef, $tempdir) = _gettemp($template,
+ "open" => 0,
+ "mkdir"=> 1 ,
+ "suffixlen" => $suffixlen,
+ "ErrStr" => \$errstr,
+ ) );
+
+ # Install exit handler; must be dynamic to get lexical
+ if ( $options{'CLEANUP'} && -d $tempdir) {
+ _deferred_unlink(undef, $tempdir, 1);
+ }
+
+ # Return the dir name
+ return $tempdir;
+
+}
+
+=back
+
+=head1 MKTEMP FUNCTIONS
+
+The following functions are Perl implementations of the
+mktemp() family of temp file generation system calls.
+
+=over 4
+
+=item B<mkstemp>
+
+Given a template, returns a filehandle to the temporary file and the name
+of the file.
+
+ ($fh, $name) = mkstemp( $template );
+
+In scalar context, just the filehandle is returned.
+
+The template may be any filename with some number of X's appended
+to it, for example F</tmp/temp.XXXX>. The trailing X's are replaced
+with unique alphanumeric combinations.
+
+Will croak() if there is an error.
+
+=cut
+
+
+
+sub mkstemp {
+
+ croak "Usage: mkstemp(template)"
+ if scalar(@_) != 1;
+
+ my $template = shift;
+
+ my ($fh, $path, $errstr);
+ croak "Error in mkstemp using $template: $errstr"
+ unless (($fh, $path) = _gettemp($template,
+ "open" => 1,
+ "mkdir"=> 0 ,
+ "suffixlen" => 0,
+ "ErrStr" => \$errstr,
+ ) );
+
+ if (wantarray()) {
+ return ($fh, $path);
+ } else {
+ return $fh;
+ }
+
+}
+
+
+=item B<mkstemps>
+
+Similar to mkstemp(), except that an extra argument can be supplied
+with a suffix to be appended to the template.
+
+ ($fh, $name) = mkstemps( $template, $suffix );
+
+For example a template of C<testXXXXXX> and suffix of C<.dat>
+would generate a file similar to F<testhGji_w.dat>.
+
+Returns just the filehandle alone when called in scalar context.
+
+Will croak() if there is an error.
+
+=cut
+
+sub mkstemps {
+
+ croak "Usage: mkstemps(template, suffix)"
+ if scalar(@_) != 2;
+
+
+ my $template = shift;
+ my $suffix = shift;
+
+ $template .= $suffix;
+
+ my ($fh, $path, $errstr);
+ croak "Error in mkstemps using $template: $errstr"
+ unless (($fh, $path) = _gettemp($template,
+ "open" => 1,
+ "mkdir"=> 0 ,
+ "suffixlen" => length($suffix),
+ "ErrStr" => \$errstr,
+ ) );
+
+ if (wantarray()) {
+ return ($fh, $path);
+ } else {
+ return $fh;
+ }
+
+}
+
+=item B<mkdtemp>
+
+Create a directory from a template. The template must end in
+X's that are replaced by the routine.
+
+ $tmpdir_name = mkdtemp($template);
+
+Returns the name of the temporary directory created.
+
+Directory must be removed by the caller.
+
+Will croak() if there is an error.
+
+=cut
+
+#' # for emacs
+
+sub mkdtemp {
+
+ croak "Usage: mkdtemp(template)"
+ if scalar(@_) != 1;
+
+ my $template = shift;
+ my $suffixlen = 0;
+ if ($^O eq 'VMS') { # dir names can end in delimiters
+ $template =~ m/([\.\]:>]+)$/;
+ $suffixlen = length($1);
+ }
+ if ( ($^O eq 'MacOS') && (substr($template, -1) eq ':') ) {
+ # dir name has a trailing ':'
+ ++$suffixlen;
+ }
+ my ($junk, $tmpdir, $errstr);
+ croak "Error creating temp directory from template $template\: $errstr"
+ unless (($junk, $tmpdir) = _gettemp($template,
+ "open" => 0,
+ "mkdir"=> 1 ,
+ "suffixlen" => $suffixlen,
+ "ErrStr" => \$errstr,
+ ) );
+
+ return $tmpdir;
+
+}
+
+=item B<mktemp>
+
+Returns a valid temporary filename but does not guarantee
+that the file will not be opened by someone else.
+
+ $unopened_file = mktemp($template);
+
+Template is the same as that required by mkstemp().
+
+Will croak() if there is an error.
+
+=cut
+
+sub mktemp {
+
+ croak "Usage: mktemp(template)"
+ if scalar(@_) != 1;
+
+ my $template = shift;
+
+ my ($tmpname, $junk, $errstr);
+ croak "Error getting name to temp file from template $template: $errstr"
+ unless (($junk, $tmpname) = _gettemp($template,
+ "open" => 0,
+ "mkdir"=> 0 ,
+ "suffixlen" => 0,
+ "ErrStr" => \$errstr,
+ ) );
+
+ return $tmpname;
+}
+
+=back
+
+=head1 POSIX FUNCTIONS
+
+This section describes the re-implementation of the tmpnam()
+and tmpfile() functions described in L<POSIX>
+using the mkstemp() from this module.
+
+Unlike the L<POSIX|POSIX> implementations, the directory used
+for the temporary file is not specified in a system include
+file (C<P_tmpdir>) but simply depends on the choice of tmpdir()
+returned by L<File::Spec|File::Spec>. On some implementations this
+location can be set using the C<TMPDIR> environment variable, which
+may not be secure.
+If this is a problem, simply use mkstemp() and specify a template.
+
+=over 4
+
+=item B<tmpnam>
+
+When called in scalar context, returns the full name (including path)
+of a temporary file (uses mktemp()). The only check is that the file does
+not already exist, but there is no guarantee that that condition will
+continue to apply.
+
+ $file = tmpnam();
+
+When called in list context, a filehandle to the open file and
+a filename are returned. This is achieved by calling mkstemp()
+after constructing a suitable template.
+
+ ($fh, $file) = tmpnam();
+
+If possible, this form should be used to prevent possible
+race conditions.
+
+See L<File::Spec/tmpdir> for information on the choice of temporary
+directory for a particular operating system.
+
+Will croak() if there is an error.
+
+=cut
+
+sub tmpnam {
+
+ # Retrieve the temporary directory name
+ my $tmpdir = File::Spec->tmpdir;
+
+ croak "Error temporary directory is not writable"
+ if $tmpdir eq '';
+
+ # Use a ten character template and append to tmpdir
+ my $template = File::Spec->catfile($tmpdir, TEMPXXX);
+
+ if (wantarray() ) {
+ return mkstemp($template);
+ } else {
+ return mktemp($template);
+ }
+
+}
+
+=item B<tmpfile>
+
+Returns the filehandle of a temporary file.
+
+ $fh = tmpfile();
+
+The file is removed when the filehandle is closed or when the program
+exits. No access to the filename is provided.
+
+If the temporary file can not be created undef is returned.
+Currently this command will probably not work when the temporary
+directory is on an NFS file system.
+
+Will croak() if there is an error.
+
+=cut
+
+sub tmpfile {
+
+ # Simply call tmpnam() in a list context
+ my ($fh, $file) = tmpnam();
+
+ # Make sure file is removed when filehandle is closed
+ # This will fail on NFS
+ unlink0($fh, $file)
+ or return undef;
+
+ return $fh;
+
+}
+
+=back
+
+=head1 ADDITIONAL FUNCTIONS
+
+These functions are provided for backwards compatibility
+with common tempfile generation C library functions.
+
+They are not exported and must be addressed using the full package
+name.
+
+=over 4
+
+=item B<tempnam>
+
+Return the name of a temporary file in the specified directory
+using a prefix. The file is guaranteed not to exist at the time
+the function was called, but such guarantees are good for one
+clock tick only. Always use the proper form of C<sysopen>
+with C<O_CREAT | O_EXCL> if you must open such a filename.
+
+ $filename = File::Temp::tempnam( $dir, $prefix );
+
+Equivalent to running mktemp() with $dir/$prefixXXXXXXXX
+(using unix file convention as an example)
+
+Because this function uses mktemp(), it can suffer from race conditions.
+
+Will croak() if there is an error.
+
+=cut
+
+sub tempnam {
+
+ croak 'Usage tempnam($dir, $prefix)' unless scalar(@_) == 2;
+
+ my ($dir, $prefix) = @_;
+
+ # Add a string to the prefix
+ $prefix .= 'XXXXXXXX';
+
+ # Concatenate the directory to the file
+ my $template = File::Spec->catfile($dir, $prefix);
+
+ return mktemp($template);
+
+}
+
+=back
+
+=head1 UTILITY FUNCTIONS
+
+Useful functions for dealing with the filehandle and filename.
+
+=over 4
+
+=item B<unlink0>
+
+Given an open filehandle and the associated filename, make a safe
+unlink. This is achieved by first checking that the filename and
+filehandle initially point to the same file and that the number of
+links to the file is 1 (all fields returned by stat() are compared).
+Then the filename is unlinked and the filehandle checked once again to
+verify that the number of links on that file is now 0. This is the
+closest you can come to making sure that the filename unlinked was the
+same as the file whose descriptor you hold.
+
+ unlink0($fh, $path)
+ or die "Error unlinking file $path safely";
+
+Returns false on error but croaks() if there is a security
+anomaly. The filehandle is not closed since on some occasions this is
+not required.
+
+On some platforms, for example Windows NT, it is not possible to
+unlink an open file (the file must be closed first). On those
+platforms, the actual unlinking is deferred until the program ends and
+good status is returned. A check is still performed to make sure that
+the filehandle and filename are pointing to the same thing (but not at
+the time the end block is executed since the deferred removal may not
+have access to the filehandle).
+
+Additionally, on Windows NT not all the fields returned by stat() can
+be compared. For example, the C<dev> and C<rdev> fields seem to be
+different. Also, it seems that the size of the file returned by stat()
+does not always agree, with C<stat(FH)> being more accurate than
+C<stat(filename)>, presumably because of caching issues even when
+using autoflush (this is usually overcome by waiting a while after
+writing to the tempfile before attempting to C<unlink0> it).
+
+Finally, on NFS file systems the link count of the file handle does
+not always go to zero immediately after unlinking. Currently, this
+command is expected to fail on NFS disks.
+
+This function is disabled if the global variable $KEEP_ALL is true
+and an unlink on open file is supported. If the unlink is to be deferred
+to the END block, the file is still registered for removal.
+
+This function should not be called if you are using the object oriented
+interface since the it will interfere with the object destructor deleting
+the file.
+
+=cut
+
+sub unlink0 {
+
+ croak 'Usage: unlink0(filehandle, filename)'
+ unless scalar(@_) == 2;
+
+ # Read args
+ my ($fh, $path) = @_;
+
+ cmpstat($fh, $path) or return 0;
+
+ # attempt remove the file (does not work on some platforms)
+ if (_can_unlink_opened_file()) {
+
+ # return early (Without unlink) if we have been instructed to retain files.
+ return 1 if $KEEP_ALL;
+
+ # XXX: do *not* call this on a directory; possible race
+ # resulting in recursive removal
+ croak "unlink0: $path has become a directory!" if -d $path;
+ unlink($path) or return 0;
+
+ # Stat the filehandle
+ my @fh = stat $fh;
+
+ print "Link count = $fh[3] \n" if $DEBUG;
+
+ # Make sure that the link count is zero
+ # - Cygwin provides deferred unlinking, however,
+ # on Win9x the link count remains 1
+ # On NFS the link count may still be 1 but we cant know that
+ # we are on NFS
+ return ( $fh[3] == 0 or $^O eq 'cygwin' ? 1 : 0);
+
+ } else {
+ _deferred_unlink($fh, $path, 0);
+ return 1;
+ }
+
+}
+
+=item B<cmpstat>
+
+Compare C<stat> of filehandle with C<stat> of provided filename. This
+can be used to check that the filename and filehandle initially point
+to the same file and that the number of links to the file is 1 (all
+fields returned by stat() are compared).
+
+ cmpstat($fh, $path)
+ or die "Error comparing handle with file";
+
+Returns false if the stat information differs or if the link count is
+greater than 1. Calls croak if there is a security anomaly.
+
+On certain platforms, for example Windows, not all the fields returned by stat()
+can be compared. For example, the C<dev> and C<rdev> fields seem to be
+different in Windows. Also, it seems that the size of the file
+returned by stat() does not always agree, with C<stat(FH)> being more
+accurate than C<stat(filename)>, presumably because of caching issues
+even when using autoflush (this is usually overcome by waiting a while
+after writing to the tempfile before attempting to C<unlink0> it).
+
+Not exported by default.
+
+=cut
+
+sub cmpstat {
+
+ croak 'Usage: cmpstat(filehandle, filename)'
+ unless scalar(@_) == 2;
+
+ # Read args
+ my ($fh, $path) = @_;
+
+ warn "Comparing stat\n"
+ if $DEBUG;
+
+ # Stat the filehandle - which may be closed if someone has manually
+ # closed the file. Can not turn off warnings without using $^W
+ # unless we upgrade to 5.006 minimum requirement
+ my @fh;
+ {
+ local ($^W) = 0;
+ @fh = stat $fh;
+ }
+ return unless @fh;
+
+ if ($fh[3] > 1 && $^W) {
+ carp "unlink0: fstat found too many links; SB=@fh" if $^W;
+ }
+
+ # Stat the path
+ my @path = stat $path;
+
+ unless (@path) {
+ carp "unlink0: $path is gone already" if $^W;
+ return;
+ }
+
+ # this is no longer a file, but may be a directory, or worse
+ unless (-f $path) {
+ confess "panic: $path is no longer a file: SB=@fh";
+ }
+
+ # Do comparison of each member of the array
+ # On WinNT dev and rdev seem to be different
+ # depending on whether it is a file or a handle.
+ # Cannot simply compare all members of the stat return
+ # Select the ones we can use
+ my @okstat = (0..$#fh); # Use all by default
+ if ($^O eq 'MSWin32') {
+ @okstat = (1,2,3,4,5,7,8,9,10);
+ } elsif ($^O eq 'os2') {
+ @okstat = (0, 2..$#fh);
+ } elsif ($^O eq 'VMS') { # device and file ID are sufficient
+ @okstat = (0, 1);
+ } elsif ($^O eq 'dos') {
+ @okstat = (0,2..7,11..$#fh);
+ } elsif ($^O eq 'mpeix') {
+ @okstat = (0..4,8..10);
+ }
+
+ # Now compare each entry explicitly by number
+ for (@okstat) {
+ print "Comparing: $_ : $fh[$_] and $path[$_]\n" if $DEBUG;
+ # Use eq rather than == since rdev, blksize, and blocks (6, 11,
+ # and 12) will be '' on platforms that do not support them. This
+ # is fine since we are only comparing integers.
+ unless ($fh[$_] eq $path[$_]) {
+ warn "Did not match $_ element of stat\n" if $DEBUG;
+ return 0;
+ }
+ }
+
+ return 1;
+}
+
+=item B<unlink1>
+
+Similar to C<unlink0> except after file comparison using cmpstat, the
+filehandle is closed prior to attempting to unlink the file. This
+allows the file to be removed without using an END block, but does
+mean that the post-unlink comparison of the filehandle state provided
+by C<unlink0> is not available.
+
+ unlink1($fh, $path)
+ or die "Error closing and unlinking file";
+
+Usually called from the object destructor when using the OO interface.
+
+Not exported by default.
+
+This function is disabled if the global variable $KEEP_ALL is true.
+
+Can call croak() if there is a security anomaly during the stat()
+comparison.
+
+=cut
+
+sub unlink1 {
+ croak 'Usage: unlink1(filehandle, filename)'
+ unless scalar(@_) == 2;
+
+ # Read args
+ my ($fh, $path) = @_;
+
+ cmpstat($fh, $path) or return 0;
+
+ # Close the file
+ close( $fh ) or return 0;
+
+ # Make sure the file is writable (for windows)
+ _force_writable( $path );
+
+ # return early (without unlink) if we have been instructed to retain files.
+ return 1 if $KEEP_ALL;
+
+ # remove the file
+ return unlink($path);
+}
+
+=item B<cleanup>
+
+Calling this function will cause any temp files or temp directories
+that are registered for removal to be removed. This happens automatically
+when the process exits but can be triggered manually if the caller is sure
+that none of the temp files are required. This method can be registered as
+an Apache callback.
+
+On OSes where temp files are automatically removed when the temp file
+is closed, calling this function will have no effect other than to remove
+temporary directories (which may include temporary files).
+
+ File::Temp::cleanup();
+
+Not exported by default.
+
+=back
+
+=head1 PACKAGE VARIABLES
+
+These functions control the global state of the package.
+
+=over 4
+
+=item B<safe_level>
+
+Controls the lengths to which the module will go to check the safety of the
+temporary file or directory before proceeding.
+Options are:
+
+=over 8
+
+=item STANDARD
+
+Do the basic security measures to ensure the directory exists and is
+writable, that temporary files are opened only if they do not already
+exist, and that possible race conditions are avoided. Finally the
+L<unlink0|"unlink0"> function is used to remove files safely.
+
+=item MEDIUM
+
+In addition to the STANDARD security, the output directory is checked
+to make sure that it is owned either by root or the user running the
+program. If the directory is writable by group or by other, it is then
+checked to make sure that the sticky bit is set.
+
+Will not work on platforms that do not support the C<-k> test
+for sticky bit.
+
+=item HIGH
+
+In addition to the MEDIUM security checks, also check for the
+possibility of ``chown() giveaway'' using the L<POSIX|POSIX>
+sysconf() function. If this is a possibility, each directory in the
+path is checked in turn for safeness, recursively walking back to the
+root directory.
+
+For platforms that do not support the L<POSIX|POSIX>
+C<_PC_CHOWN_RESTRICTED> symbol (for example, Windows NT) it is
+assumed that ``chown() giveaway'' is possible and the recursive test
+is performed.
+
+=back
+
+The level can be changed as follows:
+
+ File::Temp->safe_level( File::Temp::HIGH );
+
+The level constants are not exported by the module.
+
+Currently, you must be running at least perl v5.6.0 in order to
+run with MEDIUM or HIGH security. This is simply because the
+safety tests use functions from L<Fcntl|Fcntl> that are not
+available in older versions of perl. The problem is that the version
+number for Fcntl is the same in perl 5.6.0 and in 5.005_03 even though
+they are different versions.
+
+On systems that do not support the HIGH or MEDIUM safety levels
+(for example Win NT or OS/2) any attempt to change the level will
+be ignored. The decision to ignore rather than raise an exception
+allows portable programs to be written with high security in mind
+for the systems that can support this without those programs failing
+on systems where the extra tests are irrelevant.
+
+If you really need to see whether the change has been accepted
+simply examine the return value of C<safe_level>.
+
+ $newlevel = File::Temp->safe_level( File::Temp::HIGH );
+ die "Could not change to high security"
+ if $newlevel != File::Temp::HIGH;
+
+=cut
+
+{
+ # protect from using the variable itself
+ my $LEVEL = STANDARD;
+ sub safe_level {
+ my $self = shift;
+ if (@_) {
+ my $level = shift;
+ if (($level != STANDARD) && ($level != MEDIUM) && ($level != HIGH)) {
+ carp "safe_level: Specified level ($level) not STANDARD, MEDIUM or HIGH - ignoring\n" if $^W;
+ } else {
+ # Dont allow this on perl 5.005 or earlier
+ if ($] < 5.006 && $level != STANDARD) {
+ # Cant do MEDIUM or HIGH checks
+ croak "Currently requires perl 5.006 or newer to do the safe checks";
+ }
+ # Check that we are allowed to change level
+ # Silently ignore if we can not.
+ $LEVEL = $level if _can_do_level($level);
+ }
+ }
+ return $LEVEL;
+ }
+}
+
+=item TopSystemUID
+
+This is the highest UID on the current system that refers to a root
+UID. This is used to make sure that the temporary directory is
+owned by a system UID (C<root>, C<bin>, C<sys> etc) rather than
+simply by root.
+
+This is required since on many unix systems C</tmp> is not owned
+by root.
+
+Default is to assume that any UID less than or equal to 10 is a root
+UID.
+
+ File::Temp->top_system_uid(10);
+ my $topid = File::Temp->top_system_uid;
+
+This value can be adjusted to reduce security checking if required.
+The value is only relevant when C<safe_level> is set to MEDIUM or higher.
+
+=cut
+
+{
+ my $TopSystemUID = 10;
+ $TopSystemUID = 197108 if $^O eq 'interix'; # "Administrator"
+ sub top_system_uid {
+ my $self = shift;
+ if (@_) {
+ my $newuid = shift;
+ croak "top_system_uid: UIDs should be numeric"
+ unless $newuid =~ /^\d+$/s;
+ $TopSystemUID = $newuid;
+ }
+ return $TopSystemUID;
+ }
+}
+
+=item B<$KEEP_ALL>
+
+Controls whether temporary files and directories should be retained
+regardless of any instructions in the program to remove them
+automatically. This is useful for debugging but should not be used in
+production code.
+
+ $File::Temp::KEEP_ALL = 1;
+
+Default is for files to be removed as requested by the caller.
+
+In some cases, files will only be retained if this variable is true
+when the file is created. This means that you can not create a temporary
+file, set this variable and expect the temp file to still be around
+when the program exits.
+
+=item B<$DEBUG>
+
+Controls whether debugging messages should be enabled.
+
+ $File::Temp::DEBUG = 1;
+
+Default is for debugging mode to be disabled.
+
+=back
+
+=head1 WARNING
+
+For maximum security, endeavour always to avoid ever looking at,
+touching, or even imputing the existence of the filename. You do not
+know that that filename is connected to the same file as the handle
+you have, and attempts to check this can only trigger more race
+conditions. It's far more secure to use the filehandle alone and
+dispense with the filename altogether.
+
+If you need to pass the handle to something that expects a filename
+then, on a unix system, use C<"/dev/fd/" . fileno($fh)> for arbitrary
+programs, or more generally C<< "+<=&" . fileno($fh) >> for Perl
+programs. You will have to clear the close-on-exec bit on that file
+descriptor before passing it to another process.
+
+ use Fcntl qw/F_SETFD F_GETFD/;
+ fcntl($tmpfh, F_SETFD, 0)
+ or die "Can't clear close-on-exec flag on temp fh: $!\n";
+
+=head2 Temporary files and NFS
+
+Some problems are associated with using temporary files that reside
+on NFS file systems and it is recommended that a local filesystem
+is used whenever possible. Some of the security tests will most probably
+fail when the temp file is not local. Additionally, be aware that
+the performance of I/O operations over NFS will not be as good as for
+a local disk.
+
+=head2 Forking
+
+In some cases files created by File::Temp are removed from within an
+END block. Since END blocks are triggered when a child process exits
+(unless C<POSIX::_exit()> is used by the child) File::Temp takes care
+to only remove those temp files created by a particular process ID. This
+means that a child will not attempt to remove temp files created by the
+parent process.
+
+If you are forking many processes in parallel that are all creating
+temporary files, you may need to reset the random number seed using
+srand(EXPR) in each child else all the children will attempt to walk
+through the same set of random file names and may well cause
+themselves to give up if they exceed the number of retry attempts.
+
+=head2 Directory removal
+
+Note that if you have chdir'ed into the temporary directory and it is
+subsequently cleaned up (either in the END block or as part of object
+destruction), then you will get a warning from File::Path::rmtree().
+
+=head2 BINMODE
+
+The file returned by File::Temp will have been opened in binary mode
+if such a mode is available. If that is not correct, use the C<binmode()>
+function to change the mode of the filehandle.
+
+Note that you can modify the encoding of a file opened by File::Temp
+also by using C<binmode()>.
+
+=head1 HISTORY
+
+Originally began life in May 1999 as an XS interface to the system
+mkstemp() function. In March 2000, the OpenBSD mkstemp() code was
+translated to Perl for total control of the code's
+security checking, to ensure the presence of the function regardless of
+operating system and to help with portability. The module was shipped
+as a standard part of perl from v5.6.1.
+
+=head1 SEE ALSO
+
+L<POSIX/tmpnam>, L<POSIX/tmpfile>, L<File::Spec>, L<File::Path>
+
+See L<IO::File> and L<File::MkTemp>, L<Apache::TempFile> for
+different implementations of temporary file handling.
+
+See L<File::Tempdir> for an alternative object-oriented wrapper for
+the C<tempdir> function.
+
+=head1 AUTHOR
+
+Tim Jenness E<lt>tjenness at cpan.orgE<gt>
+
+Copyright (C) 2007-2009 Tim Jenness.
+Copyright (C) 1999-2007 Tim Jenness and the UK Particle Physics and
+Astronomy Research Council. All Rights Reserved. This program is free
+software; you can redistribute it and/or modify it under the same
+terms as Perl itself.
+
+Original Perl implementation loosely based on the OpenBSD C code for
+mkstemp(). Thanks to Tom Christiansen for suggesting that this module
+should be written and providing ideas for code improvements and
+security enhancements.
+
+=cut
+
+package File::Temp::Dir;
+
+use File::Path qw/ rmtree /;
+use strict;
+use overload '""' => "STRINGIFY", fallback => 1;
+
+# private class specifically to support tempdir objects
+# created by File::Temp->newdir
+
+# ostensibly the same method interface as File::Temp but without
+# inheriting all the IO::Seekable methods and other cruft
+
+# Read-only - returns the name of the temp directory
+
+sub dirname {
+ my $self = shift;
+ return $self->{DIRNAME};
+}
+
+sub STRINGIFY {
+ my $self = shift;
+ return $self->dirname;
+}
+
+sub unlink_on_destroy {
+ my $self = shift;
+ if (@_) {
+ $self->{CLEANUP} = shift;
+ }
+ return $self->{CLEANUP};
+}
+
+sub DESTROY {
+ my $self = shift;
+ local($., $@, $!, $^E, $?);
+ if ($self->unlink_on_destroy &&
+ $$ == $self->{LAUNCHPID} && !$File::Temp::KEEP_ALL) {
+ if (-d $self->{DIRNAME}) {
+ # Some versions of rmtree will abort if you attempt to remove
+ # the directory you are sitting in. We protect that and turn it
+ # into a warning. We do this because this occurs during object
+ # destruction and so can not be caught by the user.
+ eval { rmtree($self->{DIRNAME}, $File::Temp::DEBUG, 0); };
+ warn $@ if ($@ && $^W);
+ }
+ }
+}
+
+
+1;
Copied: trunk/contrib/perl/lib/File/stat-7896.t (from rev 6437, vendor/perl/5.18.1/lib/File/stat-7896.t)
===================================================================
--- trunk/contrib/perl/lib/File/stat-7896.t (rev 0)
+++ trunk/contrib/perl/lib/File/stat-7896.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,28 @@
+#!./perl -w
+use strict;
+
+use Test::More;
+use File::stat;
+
+# This is possibly a bit black-box, but for now it works.
+# If (either) File::stat stops lazy loading Symbol, or Test::More starts, it
+# should be revisited
+is($INC{'Symbol.pm'}, undef, "Symbol isn't loaded yet");
+
+# ID 20011110.104 (RT #7896)
+$! = 0;
+is($!, '', '$! is empty');
+is(File::stat::stat('/notafile'), undef, 'invalid file should fail');
+isnt($!, '', 'should populate $!, given invalid file');
+my $e = $!;
+
+isnt($INC{'Symbol.pm'}, undef, "Symbol has been loaded");
+
+# Repeat twice
+is(File::stat::stat('/notafile'), undef, 'invalid file should fail again');
+is($!, $e, '$! should be consistent for an invalid file');
+$e = $!;
+is(File::stat::stat('/notafile'), undef, 'invalid file should fail again');
+is($!, $e, '$! should be consistent for an invalid file');
+
+done_testing();
Modified: trunk/contrib/perl/lib/File/stat.pm
===================================================================
--- trunk/contrib/perl/lib/File/stat.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/File/stat.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -10,7 +10,7 @@
our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
-our $VERSION = '1.05';
+our $VERSION = '1.07';
my @fields;
BEGIN {
@@ -37,10 +37,14 @@
my $val = eval { &{"Fcntl::S_I\U$_"} };
*{"_$_"} = defined $val ? sub { $_[0] & $val ? 1 : "" } : sub { "" };
}
- for (qw(SOCK CHR BLK REG DIR FIFO LNK)) {
+ for (qw(SOCK CHR BLK REG DIR LNK)) {
*{"S_IS$_"} = defined eval { &{"Fcntl::S_IF$_"} }
? \&{"Fcntl::S_IS$_"} : sub { "" };
}
+ # FIFO flag and macro don't quite follow the S_IF/S_IS pattern above
+ # RT #111638
+ *{"S_ISFIFO"} = defined &Fcntl::S_IFIFO
+ ? \&Fcntl::S_ISFIFO : sub { "" };
}
# from doio.c
@@ -83,15 +87,22 @@
*cando = sub {
my ($s, $mode, $eff) = @_;
my $uid = $eff ? $> : $<;
-
- # If we're root on unix and we are not testing for executable
- # status, then all file tests are true.
- $^O ne "VMS" and $uid == 0 and !($mode & 0111) and return 1;
-
my ($stmode, $stuid, $stgid) = @$s[2,4,5];
# This code basically assumes that the rwx bits of the mode are
# the 0777 bits, but so does Perl_cando.
+
+ if ($uid == 0 && $^O ne "VMS") {
+ # If we're root on unix
+ # not testing for executable status => all file tests are true
+ return 1 if !($mode & 0111);
+ # testing for executable status =>
+ # for a file, any x bit will do
+ # for a directory, always true
+ return 1 if $stmode & 0111 || S_ISDIR($stmode);
+ return "";
+ }
+
if ($stuid == $uid) {
$stmode & $mode and return 1;
}
@@ -148,7 +159,7 @@
-X => sub {
my ($s, $op) = @_;
- if (index "rwxRWX", $op) {
+ if (index("rwxRWX", $op) >= 0) {
(caller 0)[8] & HINT_FILETEST_ACCESS
and warnif("File::stat ignores use filetest 'access'");
Property changes on: trunk/contrib/perl/lib/File/stat.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/File/stat.t
===================================================================
--- trunk/contrib/perl/lib/File/stat.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/File/stat.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -5,107 +5,136 @@
@INC = '../lib';
}
+use strict;
+use warnings;
use Test::More;
use Config qw( %Config );
+use File::Temp qw( tempfile tempdir );
-BEGIN {
- # Check whether the build is configured with -Dmksymlinks
- our $Dmksymlinks =
- grep { /^config_arg\d+$/ && $Config{$_} eq '-Dmksymlinks' }
- keys %Config;
+use File::stat;
- # Resolve symlink to ./lib/File/stat.t if this build is configured
- # with -Dmksymlinks
- # Originally we worked with ./TEST, but other test scripts read from
- # that file and modify its access time.
- our $file = '../lib/File/stat.t';
- if ( $Dmksymlinks ) {
- $file = readlink $file;
- die "Can't readlink(../lib/File/stat.t): $!" if ! defined $file;
+my (undef, $file) = tempfile();
+
+{
+ my @stat = CORE::stat $file;
+ my $stat = File::stat::stat($file);
+ isa_ok($stat, 'File::stat', 'should build a stat object');
+ is_deeply($stat, \@stat, '... and matches the builtin');
+
+ my $i = 0;
+ foreach ([dev => 'device number'],
+ [ino => 'inode number'],
+ [mode => 'file mode'],
+ [nlink => 'number of links'],
+ [uid => 'owner uid'],
+ [gid => 'group id'],
+ [rdev => 'device identifier'],
+ [size => 'file size'],
+ [atime => 'last access time'],
+ [mtime => 'last modify time'],
+ [ctime => 'change time'],
+ [blksize => 'IO block size'],
+ [blocks => 'number of blocks']) {
+ my ($meth, $desc) = @$_;
+ # On OS/2 (fake) ino is not constant, it is incremented each time
+ SKIP: {
+ skip('inode number is not constant on OS/2', 1)
+ if $i == 1 && $^O eq 'os2';
+ is($stat->$meth, $stat[$i], "$desc in position $i");
+ }
+ ++$i;
}
- our $hasst;
- eval { my @n = stat $file };
- $hasst = 1 unless $@ && $@ =~ /unimplemented/;
- unless ($hasst) { plan skip_all => "no stat"; exit 0 }
- use Config;
- $hasst = 0 unless $Config{'i_sysstat'} eq 'define';
- unless ($hasst) { plan skip_all => "no sys/stat.h"; exit 0 }
+ my $stat2 = stat $file;
+ isa_ok($stat2, 'File::stat',
+ 'File::stat exports stat, overriding the builtin');
+ is_deeply($stat2, $stat, '... and matches the direct call');
}
-# Originally this was done in the BEGIN block, but perl is still
-# compiling (and hence reading) the script at that point, which can
-# change the file's access time, causing a different in the comparison
-# tests if the clock ticked over the second between the stat() and the
-# final read.
-# At this point all of the reading is done.
-our @stat = stat $file; # This is the function stat.
-unless (@stat) { plan skip_all => "1..0 # Skip: no file $file"; exit 0 }
+sub test_X_ops {
+ my ($file, $desc_tail, $skip) = @_;
+ my @stat = CORE::stat $file;
+ my $stat = File::stat::stat($file);
+ my $lstat = File::stat::lstat($file);
+ isa_ok($stat, 'File::stat', 'should build a stat object');
-plan tests => 19 + 24*2 + 4 + 3;
+ for my $op (split //, "rwxoRWXOezsfdlpSbcugkMCA") {
+ if ($skip && $op =~ $skip) {
+ note("Not testing -A $desc_tail");
+ next;
+ }
+ my $stat = $op eq 'l' ? $lstat : $stat;
+ for my $access ('', 'use filetest "access";') {
+ my ($warnings, $awarn, $vwarn, $rv);
+ my $desc = $access
+ ? "for -$op under use filetest 'access' $desc_tail"
+ : "for -$op $desc_tail";
+ {
+ local $SIG{__WARN__} = sub {
+ my $w = shift;
+ if ($w =~ /^File::stat ignores VMS ACLs/) {
+ ++$vwarn;
+ } elsif ($w =~ /^File::stat ignores use filetest 'access'/) {
+ ++$awarn;
+ } else {
+ $warnings .= $w;
+ }
+ };
+ $rv = eval "$access; -$op \$stat";
+ }
+ is($@, '', "Overload succeeds $desc");
-use_ok( 'File::stat' );
+ if ($^O eq "VMS" && $op =~ /[rwxRWX]/) {
+ is($vwarn, 1, "warning about VMS ACLs $desc");
+ } else {
+ is($rv, eval "-$op \$file", "correct overload $desc")
+ unless $access;
+ is($vwarn, undef, "no warnings about VMS ACLs $desc");
+ }
-my $stat = File::stat::stat( $file ); # This is the OO stat.
-ok( ref($stat), 'should build a stat object' );
+ # 111640 - File::stat bogus index check in overload
+ if ($access && $op =~ /[rwxRXW]/) {
+ # these should all warn with filetest access
+ is($awarn, 1,
+ "produced the right warning $desc");
+ } else {
+ # -d and others shouldn't warn
+ is($awarn, undef, "should be no warning $desc")
+ }
-is( $stat->dev, $stat[0], "device number in position 0" );
-
-# On OS/2 (fake) ino is not constant, it is incremented each time
-SKIP: {
- skip('inode number is not constant on OS/2', 1) if $^O eq 'os2';
- is( $stat->ino, $stat[1], "inode number in position 1" );
+ is($warnings, undef, "no other warnings seen $desc");
+ }
+ }
}
-is( $stat->mode, $stat[2], "file mode in position 2" );
+foreach ([file => $file],
+ [dir => tempdir(CLEANUP => 1)]) {
+ my ($what, $pathname) = @$_;
+ test_X_ops($pathname, "for $what $pathname");
-is( $stat->nlink, $stat[3], "number of links in position 3" );
-
-is( $stat->uid, $stat[4], "owner uid in position 4" );
-
-is( $stat->gid, $stat[5], "group id in position 5" );
-
-is( $stat->rdev, $stat[6], "device identifier in position 6" );
-
-is( $stat->size, $stat[7], "file size in position 7" );
-
-is( $stat->atime, $stat[8], "last access time in position 8" );
-
-is( $stat->mtime, $stat[9], "last modify time in position 9" );
-
-is( $stat->ctime, $stat[10], "change time in position 10" );
-
-is( $stat->blksize, $stat[11], "IO block size in position 11" );
-
-is( $stat->blocks, $stat[12], "number of blocks in position 12" );
-
-for (split //, "rwxoRWXOezsfdlpSbcugkMCA") {
- SKIP: {
- $^O eq "VMS" and index("rwxRWX", $_) >= 0
- and skip "File::stat ignores VMS ACLs", 2;
-
- my $rv = eval "-$_ \$stat";
- ok( !$@, "-$_ overload succeeds" )
- or diag( $@ );
- is( $rv, eval "-$_ \$file", "correct -$_ overload" );
+ my $mode = 01000;
+ while ($mode) {
+ $mode >>= 1;
+ my $mode_oct = sprintf "0%03o", $mode;
+ chmod $mode, $pathname or die "Can't chmod $mode_oct $pathname: $!";
+ test_X_ops($pathname, "for $what with mode=$mode_oct");
}
+ chmod 0600, $pathname
+ or die "Can't restore permissions on $pathname to 0600";
}
SKIP: {
- my $file = '../perl';
- -e $file && -x $file or skip "$file is not present and executable", 4;
+ -e $^X && -x $^X or skip "$^X is not present and executable", 4;
$^O eq "VMS" and skip "File::stat ignores VMS ACLs", 4;
- my $stat = File::stat::stat( $file ); # This is the OO stat.
- foreach (qw/x X/) {
- my $rv = eval "-$_ \$stat";
- ok( !$@, "-$_ overload succeeds" )
- or diag( $@ );
- is( $rv, eval "-$_ \$file", "correct -$_ overload" );
- }
+ # Other tests running in parallel mean that $^X is read, updating its atime
+ test_X_ops($^X, "for $^X", qr/A/);
}
+my $stat = File::stat::stat($file);
+isa_ok($stat, 'File::stat', 'should build a stat object');
+
for (split //, "tTB") {
eval "-$_ \$stat";
like( $@, qr/\Q-$_ is not implemented/, "-$_ overload fails" );
@@ -114,12 +143,14 @@
SKIP: {
local *STAT;
skip("Could not open file: $!", 2) unless open(STAT, $file);
- ok( File::stat::stat('STAT'), '... should be able to find filehandle' );
+ isa_ok(File::stat::stat('STAT'), 'File::stat',
+ '... should be able to find filehandle');
package foo;
local *STAT = *main::STAT;
- main::ok( my $stat2 = File::stat::stat('STAT'),
- '... and filehandle in another package' );
+ my $stat2 = File::stat::stat('STAT');
+ main::isa_ok($stat2, 'File::stat',
+ '... and filehandle in another package');
close STAT;
# VOS open() updates atime; ignore this error (posix-975).
@@ -133,12 +164,29 @@
main::skip("OS/2: inode number is not constant on os/2", 1) if $^O eq 'os2';
- main::is( "@$stat", "@$stat3", '... and must match normal stat' );
+ main::is_deeply($stat, $stat3, '... and must match normal stat');
}
+SKIP:
+{ # RT #111638
+ skip "We can't check for FIFOs", 2 unless defined &Fcntl::S_ISFIFO;
+ skip "No pipes", 2 unless defined $Config{d_pipe};
+ pipe my ($rh, $wh)
+ or skip "Couldn't create a pipe: $!", 2;
+ skip "Built-in -p doesn't detect a pipe", 2 unless -p $rh;
-local $!;
-$stat = stat '/notafile';
-isnt( $!, '', 'should populate $!, given invalid file' );
+ my $pstat = File::stat::stat($rh);
+ ok(!-p($stat), "-p should be false on a file");
+ ok(-p($pstat), "check -p detects a pipe");
+}
# Testing pretty much anything else is unportable.
+
+done_testing;
+
+# Local variables:
+# cperl-indent-level: 4
+# indent-tabs-mode: nil
+# End:
+#
+# ex: set ts=8 sts=4 sw=4 et:
Property changes on: trunk/contrib/perl/lib/File/stat.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/lib/FileCache.pm (from rev 6437, vendor/perl/5.18.1/lib/FileCache.pm)
===================================================================
--- trunk/contrib/perl/lib/FileCache.pm (rev 0)
+++ trunk/contrib/perl/lib/FileCache.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,188 @@
+package FileCache;
+
+our $VERSION = '1.08';
+
+=head1 NAME
+
+FileCache - keep more files open than the system permits
+
+=head1 SYNOPSIS
+
+ no strict 'refs';
+
+ use FileCache;
+ # or
+ use FileCache maxopen => 16;
+
+ cacheout $mode, $path;
+ # or
+ cacheout $path;
+ print $path @data;
+
+ $fh = cacheout $mode, $path;
+ # or
+ $fh = cacheout $path;
+ print $fh @data;
+
+=head1 DESCRIPTION
+
+The C<cacheout> function will make sure that there's a filehandle open
+for reading or writing available as the pathname you give it. It
+automatically closes and re-opens files if you exceed your system's
+maximum number of file descriptors, or the suggested maximum I<maxopen>.
+
+=over
+
+=item cacheout EXPR
+
+The 1-argument form of cacheout will open a file for writing (C<< '>' >>)
+on it's first use, and appending (C<<< '>>' >>>) thereafter.
+
+Returns EXPR on success for convenience. You may neglect the
+return value and manipulate EXPR as the filehandle directly if you prefer.
+
+=item cacheout MODE, EXPR
+
+The 2-argument form of cacheout will use the supplied mode for the initial
+and subsequent openings. Most valid modes for 3-argument C<open> are supported
+namely; C<< '>' >>, C<< '+>' >>, C<< '<' >>, C<< '<+' >>, C<<< '>>' >>>,
+C< '|-' > and C< '-|' >
+
+To pass supplemental arguments to a program opened with C< '|-' > or C< '-|' >
+append them to the command string as you would system EXPR.
+
+Returns EXPR on success for convenience. You may neglect the
+return value and manipulate EXPR as the filehandle directly if you prefer.
+
+=back
+
+=head1 CAVEATS
+
+While it is permissible to C<close> a FileCache managed file,
+do not do so if you are calling C<FileCache::cacheout> from a package other
+than which it was imported, or with another module which overrides C<close>.
+If you must, use C<FileCache::cacheout_close>.
+
+Although FileCache can be used with piped opens ('-|' or '|-') doing so is
+strongly discouraged. If FileCache finds it necessary to close and then reopen
+a pipe, the command at the far end of the pipe will be reexecuted - the results
+of performing IO on FileCache'd pipes is unlikely to be what you expect. The
+ability to use FileCache on pipes may be removed in a future release.
+
+FileCache does not store the current file offset if it finds it necessary to
+close a file. When the file is reopened, the offset will be as specified by the
+original C<open> file mode. This could be construed to be a bug.
+
+The module functionality relies on symbolic references, so things will break
+under 'use strict' unless 'no strict "refs"' is also specified.
+
+=head1 BUGS
+
+F<sys/param.h> lies with its C<NOFILE> define on some systems,
+so you may have to set I<maxopen> yourself.
+
+=cut
+
+require 5.006;
+use Carp;
+use strict;
+no strict 'refs';
+
+# These are not C<my> for legacy reasons.
+# Previous versions requested the user set $cacheout_maxopen by hand.
+# Some authors fiddled with %saw to overcome the clobber on initial open.
+use vars qw(%saw $cacheout_maxopen);
+$cacheout_maxopen = 16;
+
+use base 'Exporter';
+our @EXPORT = qw[cacheout cacheout_close];
+
+
+my %isopen;
+my $cacheout_seq = 0;
+
+sub import {
+ my ($pkg,%args) = @_;
+
+ # Use Exporter. %args are for us, not Exporter.
+ # Make sure to up export_to_level, or we will import into ourselves,
+ # rather than our calling package;
+
+ __PACKAGE__->export_to_level(1);
+ Exporter::import( $pkg );
+
+ # Truth is okay here because setting maxopen to 0 would be bad
+ return $cacheout_maxopen = $args{maxopen} if $args{maxopen};
+
+ # XXX This code is crazy. Why is it a one element foreach loop?
+ # Why is it using $param both as a filename and filehandle?
+ foreach my $param ( '/usr/include/sys/param.h' ){
+ if (open($param, '<', $param)) {
+ local ($_, $.);
+ while (<$param>) {
+ if( /^\s*#\s*define\s+NOFILE\s+(\d+)/ ){
+ $cacheout_maxopen = $1 - 4;
+ close($param);
+ last;
+ }
+ }
+ close $param;
+ }
+ }
+ $cacheout_maxopen ||= 16;
+}
+
+# Open in their package.
+sub cacheout_open {
+ return open(*{caller(1) . '::' . $_[1]}, $_[0], $_[1]) && $_[1];
+}
+
+# Close in their package.
+sub cacheout_close {
+ # Short-circuit in case the filehandle disappeared
+ my $pkg = caller($_[1]||0);
+ defined fileno(*{$pkg . '::' . $_[0]}) &&
+ CORE::close(*{$pkg . '::' . $_[0]});
+ delete $isopen{$_[0]};
+}
+
+# But only this sub name is visible to them.
+sub cacheout {
+ my($mode, $file, $class, $ret, $ref, $narg);
+ croak "Not enough arguments for cacheout" unless $narg = scalar @_;
+ croak "Too many arguments for cacheout" if $narg > 2;
+
+ ($mode, $file) = @_;
+ ($file, $mode) = ($mode, $file) if $narg == 1;
+ croak "Invalid mode for cacheout" if $mode &&
+ ( $mode !~ /^\s*(?:>>|\+?>|\+?<|\|\-|)|\-\|\s*$/ );
+
+ # Mode changed?
+ if( $isopen{$file} && ($mode||'>') ne $isopen{$file}->[1] ){
+ &cacheout_close($file, 1);
+ }
+
+ if( $isopen{$file}) {
+ $ret = $file;
+ $isopen{$file}->[0]++;
+ }
+ else{
+ if( scalar keys(%isopen) > $cacheout_maxopen -1 ) {
+ my @lru = sort{ $isopen{$a}->[0] <=> $isopen{$b}->[0] } keys(%isopen);
+ $cacheout_seq = 0;
+ $isopen{$_}->[0] = $cacheout_seq++ for
+ splice(@lru, int($cacheout_maxopen / 3)||$cacheout_maxopen);
+ &cacheout_close($_, 1) for @lru;
+ }
+
+ unless( $ref ){
+ $mode ||= $saw{$file} ? '>>' : ($saw{$file}=1, '>');
+ }
+ #XXX should we just return the value from cacheout_open, no croak?
+ $ret = cacheout_open($mode, $file) or croak("Can't create $file: $!");
+
+ $isopen{$file} = [++$cacheout_seq, $mode];
+ }
+ return $ret;
+}
+1;
Index: trunk/contrib/perl/lib/FileHandle.pm
===================================================================
--- trunk/contrib/perl/lib/FileHandle.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/FileHandle.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/FileHandle.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/lib/FileHandle.t
===================================================================
--- trunk/contrib/perl/lib/FileHandle.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/FileHandle.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -8,10 +8,6 @@
print "1..0\n";
exit 0;
}
- if ($^O eq 'mpeix') {
- print "1..0 # Skip: broken on MPE/iX\n";
- exit 0;
- }
}
use FileHandle;
Property changes on: trunk/contrib/perl/lib/FileHandle.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/lib/FindBin.pm
===================================================================
--- trunk/contrib/perl/lib/FindBin.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/FindBin.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -59,21 +59,6 @@
delete $INC{'FindBin.pm'};
require FindBin;
-=head1 KNOWN BUGS
-
-If perl is invoked as
-
- perl filename
-
-and I<filename> does not have executable rights and a program called
-I<filename> exists in the users C<$ENV{PATH}> which satisfies both B<-x>
-and B<-T> then FindBin assumes that it was invoked via the
-C<$ENV{PATH}>.
-
-Workaround is to invoke perl as
-
- perl ./filename
-
=head1 AUTHORS
FindBin is supported as part of the core perl distribution. Please send bug
@@ -103,7 +88,7 @@
%EXPORT_TAGS = (ALL => [qw($Bin $Script $RealBin $RealScript $Dir $RealDir)]);
@ISA = qw(Exporter);
-$VERSION = "1.50";
+$VERSION = "1.51";
# needed for VMS-specific filename translation
@@ -145,30 +130,6 @@
}
else
{
- my $dosish = ($^O eq 'MSWin32' or $^O eq 'os2');
- unless(($script =~ m#/# || ($dosish && $script =~ m#\\#))
- && -f $script)
- {
- my $dir;
- foreach $dir (File::Spec->path)
- {
- my $scr = File::Spec->catfile($dir, $script);
-
- # $script can been found via PATH but perl could have
- # been invoked as 'perl file'. Do a dumb check to see
- # if $script is a perl program, if not then keep $script = $0
- #
- # well we actually only check that it is an ASCII file
- # we know its executable so it is probably a script
- # of some sort.
- if(-f $scr && -r _ && ($dosish || -x _) && -s _ && -T _)
- {
- $script = $scr;
- last;
- }
- }
- }
-
croak("Cannot find current script '$0'") unless(-f $script);
# Ensure $script contains the complete path in case we C<chdir>
Property changes on: trunk/contrib/perl/lib/FindBin.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/FindBin.t
===================================================================
--- trunk/contrib/perl/lib/FindBin.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/FindBin.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/FindBin.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/lib/Getopt/Long.pm (from rev 6437, vendor/perl/5.18.1/lib/Getopt/Long.pm)
===================================================================
--- trunk/contrib/perl/lib/Getopt/Long.pm (rev 0)
+++ trunk/contrib/perl/lib/Getopt/Long.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,2649 @@
+# Getopt::Long.pm -- Universal options parsing
+
+package Getopt::Long;
+
+# RCS Status : $Id: Long.pm,v 1.1.1.2 2011-02-17 12:49:39 laffer1 Exp $
+# Author : Johan Vromans
+# Created On : Tue Sep 11 15:00:12 1990
+# Last Modified By: Johan Vromans
+# Last Modified On: Mon Mar 30 22:51:17 2009
+# Update Count : 1601
+# Status : Released
+
+################ Module Preamble ################
+
+use 5.004;
+
+use strict;
+
+use vars qw($VERSION);
+$VERSION = 2.38;
+# For testing versions only.
+#use vars qw($VERSION_STRING);
+#$VERSION_STRING = "2.38";
+
+use Exporter;
+use vars qw(@ISA @EXPORT @EXPORT_OK);
+ at ISA = qw(Exporter);
+
+# Exported subroutines.
+sub GetOptions(@); # always
+sub GetOptionsFromArray(@); # on demand
+sub GetOptionsFromString(@); # on demand
+sub Configure(@); # on demand
+sub HelpMessage(@); # on demand
+sub VersionMessage(@); # in demand
+
+BEGIN {
+ # Init immediately so their contents can be used in the 'use vars' below.
+ @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
+ @EXPORT_OK = qw(&HelpMessage &VersionMessage &Configure
+ &GetOptionsFromArray &GetOptionsFromString);
+}
+
+# User visible variables.
+use vars @EXPORT, @EXPORT_OK;
+use vars qw($error $debug $major_version $minor_version);
+# Deprecated visible variables.
+use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order
+ $passthrough);
+# Official invisible variables.
+use vars qw($genprefix $caller $gnu_compat $auto_help $auto_version $longprefix);
+
+# Public subroutines.
+sub config(@); # deprecated name
+
+# Private subroutines.
+sub ConfigDefaults();
+sub ParseOptionSpec($$);
+sub OptCtl($);
+sub FindOption($$$$$);
+sub ValidValue ($$$$$);
+
+################ Local Variables ################
+
+# $requested_version holds the version that was mentioned in the 'use'
+# or 'require', if any. It can be used to enable or disable specific
+# features.
+my $requested_version = 0;
+
+################ Resident subroutines ################
+
+sub ConfigDefaults() {
+ # Handle POSIX compliancy.
+ if ( defined $ENV{"POSIXLY_CORRECT"} ) {
+ $genprefix = "(--|-)";
+ $autoabbrev = 0; # no automatic abbrev of options
+ $bundling = 0; # no bundling of single letter switches
+ $getopt_compat = 0; # disallow '+' to start options
+ $order = $REQUIRE_ORDER;
+ }
+ else {
+ $genprefix = "(--|-|\\+)";
+ $autoabbrev = 1; # automatic abbrev of options
+ $bundling = 0; # bundling off by default
+ $getopt_compat = 1; # allow '+' to start options
+ $order = $PERMUTE;
+ }
+ # Other configurable settings.
+ $debug = 0; # for debugging
+ $error = 0; # error tally
+ $ignorecase = 1; # ignore case when matching options
+ $passthrough = 0; # leave unrecognized options alone
+ $gnu_compat = 0; # require --opt=val if value is optional
+ $longprefix = "(--)"; # what does a long prefix look like
+}
+
+# Override import.
+sub import {
+ my $pkg = shift; # package
+ my @syms = (); # symbols to import
+ my @config = (); # configuration
+ my $dest = \@syms; # symbols first
+ for ( @_ ) {
+ if ( $_ eq ':config' ) {
+ $dest = \@config; # config next
+ next;
+ }
+ push(@$dest, $_); # push
+ }
+ # Hide one level and call super.
+ local $Exporter::ExportLevel = 1;
+ push(@syms, qw(&GetOptions)) if @syms; # always export GetOptions
+ $pkg->SUPER::import(@syms);
+ # And configure.
+ Configure(@config) if @config;
+}
+
+################ Initialization ################
+
+# Values for $order. See GNU getopt.c for details.
+($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2);
+# Version major/minor numbers.
+($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/;
+
+ConfigDefaults();
+
+################ OO Interface ################
+
+package Getopt::Long::Parser;
+
+# Store a copy of the default configuration. Since ConfigDefaults has
+# just been called, what we get from Configure is the default.
+my $default_config = do {
+ Getopt::Long::Configure ()
+};
+
+sub new {
+ my $that = shift;
+ my $class = ref($that) || $that;
+ my %atts = @_;
+
+ # Register the callers package.
+ my $self = { caller_pkg => (caller)[0] };
+
+ bless ($self, $class);
+
+ # Process config attributes.
+ if ( defined $atts{config} ) {
+ my $save = Getopt::Long::Configure ($default_config, @{$atts{config}});
+ $self->{settings} = Getopt::Long::Configure ($save);
+ delete ($atts{config});
+ }
+ # Else use default config.
+ else {
+ $self->{settings} = $default_config;
+ }
+
+ if ( %atts ) { # Oops
+ die(__PACKAGE__.": unhandled attributes: ".
+ join(" ", sort(keys(%atts)))."\n");
+ }
+
+ $self;
+}
+
+sub configure {
+ my ($self) = shift;
+
+ # Restore settings, merge new settings in.
+ my $save = Getopt::Long::Configure ($self->{settings}, @_);
+
+ # Restore orig config and save the new config.
+ $self->{settings} = Getopt::Long::Configure ($save);
+}
+
+sub getoptions {
+ my ($self) = shift;
+
+ # Restore config settings.
+ my $save = Getopt::Long::Configure ($self->{settings});
+
+ # Call main routine.
+ my $ret = 0;
+ $Getopt::Long::caller = $self->{caller_pkg};
+
+ eval {
+ # Locally set exception handler to default, otherwise it will
+ # be called implicitly here, and again explicitly when we try
+ # to deliver the messages.
+ local ($SIG{__DIE__}) = 'DEFAULT';
+ $ret = Getopt::Long::GetOptions (@_);
+ };
+
+ # Restore saved settings.
+ Getopt::Long::Configure ($save);
+
+ # Handle errors and return value.
+ die ($@) if $@;
+ return $ret;
+}
+
+package Getopt::Long;
+
+################ Back to Normal ################
+
+# Indices in option control info.
+# Note that ParseOptions uses the fields directly. Search for 'hard-wired'.
+use constant CTL_TYPE => 0;
+#use constant CTL_TYPE_FLAG => '';
+#use constant CTL_TYPE_NEG => '!';
+#use constant CTL_TYPE_INCR => '+';
+#use constant CTL_TYPE_INT => 'i';
+#use constant CTL_TYPE_INTINC => 'I';
+#use constant CTL_TYPE_XINT => 'o';
+#use constant CTL_TYPE_FLOAT => 'f';
+#use constant CTL_TYPE_STRING => 's';
+
+use constant CTL_CNAME => 1;
+
+use constant CTL_DEFAULT => 2;
+
+use constant CTL_DEST => 3;
+ use constant CTL_DEST_SCALAR => 0;
+ use constant CTL_DEST_ARRAY => 1;
+ use constant CTL_DEST_HASH => 2;
+ use constant CTL_DEST_CODE => 3;
+
+use constant CTL_AMIN => 4;
+use constant CTL_AMAX => 5;
+
+# FFU.
+#use constant CTL_RANGE => ;
+#use constant CTL_REPEAT => ;
+
+# Rather liberal patterns to match numbers.
+use constant PAT_INT => "[-+]?_*[0-9][0-9_]*";
+use constant PAT_XINT =>
+ "(?:".
+ "[-+]?_*[1-9][0-9_]*".
+ "|".
+ "0x_*[0-9a-f][0-9a-f_]*".
+ "|".
+ "0b_*[01][01_]*".
+ "|".
+ "0[0-7_]*".
+ ")";
+use constant PAT_FLOAT => "[-+]?[0-9._]+(\.[0-9_]+)?([eE][-+]?[0-9_]+)?";
+
+sub GetOptions(@) {
+ # Shift in default array.
+ unshift(@_, \@ARGV);
+ # Try to keep caller() and Carp consitent.
+ goto &GetOptionsFromArray;
+}
+
+sub GetOptionsFromString(@) {
+ my ($string) = shift;
+ require Text::ParseWords;
+ my $args = [ Text::ParseWords::shellwords($string) ];
+ $caller ||= (caller)[0]; # current context
+ my $ret = GetOptionsFromArray($args, @_);
+ return ( $ret, $args ) if wantarray;
+ if ( @$args ) {
+ $ret = 0;
+ warn("GetOptionsFromString: Excess data \"@$args\" in string \"$string\"\n");
+ }
+ $ret;
+}
+
+sub GetOptionsFromArray(@) {
+
+ my ($argv, @optionlist) = @_; # local copy of the option descriptions
+ my $argend = '--'; # option list terminator
+ my %opctl = (); # table of option specs
+ my $pkg = $caller || (caller)[0]; # current context
+ # Needed if linkage is omitted.
+ my @ret = (); # accum for non-options
+ my %linkage; # linkage
+ my $userlinkage; # user supplied HASH
+ my $opt; # current option
+ my $prefix = $genprefix; # current prefix
+
+ $error = '';
+
+ if ( $debug ) {
+ # Avoid some warnings if debugging.
+ local ($^W) = 0;
+ print STDERR
+ ("Getopt::Long $Getopt::Long::VERSION (",
+ '$Revision: 1.1.1.2 $', ") ",
+ "called from package \"$pkg\".",
+ "\n ",
+ "argv: (@$argv)",
+ "\n ",
+ "autoabbrev=$autoabbrev,".
+ "bundling=$bundling,",
+ "getopt_compat=$getopt_compat,",
+ "gnu_compat=$gnu_compat,",
+ "order=$order,",
+ "\n ",
+ "ignorecase=$ignorecase,",
+ "requested_version=$requested_version,",
+ "passthrough=$passthrough,",
+ "genprefix=\"$genprefix\",",
+ "longprefix=\"$longprefix\".",
+ "\n");
+ }
+
+ # Check for ref HASH as first argument.
+ # First argument may be an object. It's OK to use this as long
+ # as it is really a hash underneath.
+ $userlinkage = undef;
+ if ( @optionlist && ref($optionlist[0]) and
+ UNIVERSAL::isa($optionlist[0],'HASH') ) {
+ $userlinkage = shift (@optionlist);
+ print STDERR ("=> user linkage: $userlinkage\n") if $debug;
+ }
+
+ # See if the first element of the optionlist contains option
+ # starter characters.
+ # Be careful not to interpret '<>' as option starters.
+ if ( @optionlist && $optionlist[0] =~ /^\W+$/
+ && !($optionlist[0] eq '<>'
+ && @optionlist > 0
+ && ref($optionlist[1])) ) {
+ $prefix = shift (@optionlist);
+ # Turn into regexp. Needs to be parenthesized!
+ $prefix =~ s/(\W)/\\$1/g;
+ $prefix = "([" . $prefix . "])";
+ print STDERR ("=> prefix=\"$prefix\"\n") if $debug;
+ }
+
+ # Verify correctness of optionlist.
+ %opctl = ();
+ while ( @optionlist ) {
+ my $opt = shift (@optionlist);
+
+ unless ( defined($opt) ) {
+ $error .= "Undefined argument in option spec\n";
+ next;
+ }
+
+ # Strip leading prefix so people can specify "--foo=i" if they like.
+ $opt = $+ if $opt =~ /^$prefix+(.*)$/s;
+
+ if ( $opt eq '<>' ) {
+ if ( (defined $userlinkage)
+ && !(@optionlist > 0 && ref($optionlist[0]))
+ && (exists $userlinkage->{$opt})
+ && ref($userlinkage->{$opt}) ) {
+ unshift (@optionlist, $userlinkage->{$opt});
+ }
+ unless ( @optionlist > 0
+ && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) {
+ $error .= "Option spec <> requires a reference to a subroutine\n";
+ # Kill the linkage (to avoid another error).
+ shift (@optionlist)
+ if @optionlist && ref($optionlist[0]);
+ next;
+ }
+ $linkage{'<>'} = shift (@optionlist);
+ next;
+ }
+
+ # Parse option spec.
+ my ($name, $orig) = ParseOptionSpec ($opt, \%opctl);
+ unless ( defined $name ) {
+ # Failed. $orig contains the error message. Sorry for the abuse.
+ $error .= $orig;
+ # Kill the linkage (to avoid another error).
+ shift (@optionlist)
+ if @optionlist && ref($optionlist[0]);
+ next;
+ }
+
+ # If no linkage is supplied in the @optionlist, copy it from
+ # the userlinkage if available.
+ if ( defined $userlinkage ) {
+ unless ( @optionlist > 0 && ref($optionlist[0]) ) {
+ if ( exists $userlinkage->{$orig} &&
+ ref($userlinkage->{$orig}) ) {
+ print STDERR ("=> found userlinkage for \"$orig\": ",
+ "$userlinkage->{$orig}\n")
+ if $debug;
+ unshift (@optionlist, $userlinkage->{$orig});
+ }
+ else {
+ # Do nothing. Being undefined will be handled later.
+ next;
+ }
+ }
+ }
+
+ # Copy the linkage. If omitted, link to global variable.
+ if ( @optionlist > 0 && ref($optionlist[0]) ) {
+ print STDERR ("=> link \"$orig\" to $optionlist[0]\n")
+ if $debug;
+ my $rl = ref($linkage{$orig} = shift (@optionlist));
+
+ if ( $rl eq "ARRAY" ) {
+ $opctl{$name}[CTL_DEST] = CTL_DEST_ARRAY;
+ }
+ elsif ( $rl eq "HASH" ) {
+ $opctl{$name}[CTL_DEST] = CTL_DEST_HASH;
+ }
+ elsif ( $rl eq "SCALAR" || $rl eq "REF" ) {
+# if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) {
+# my $t = $linkage{$orig};
+# $$t = $linkage{$orig} = [];
+# }
+# elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) {
+# }
+# else {
+ # Ok.
+# }
+ }
+ elsif ( $rl eq "CODE" ) {
+ # Ok.
+ }
+ else {
+ $error .= "Invalid option linkage for \"$opt\"\n";
+ }
+ }
+ else {
+ # Link to global $opt_XXX variable.
+ # Make sure a valid perl identifier results.
+ my $ov = $orig;
+ $ov =~ s/\W/_/g;
+ if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) {
+ print STDERR ("=> link \"$orig\" to \@$pkg","::opt_$ov\n")
+ if $debug;
+ eval ("\$linkage{\$orig} = \\\@".$pkg."::opt_$ov;");
+ }
+ elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) {
+ print STDERR ("=> link \"$orig\" to \%$pkg","::opt_$ov\n")
+ if $debug;
+ eval ("\$linkage{\$orig} = \\\%".$pkg."::opt_$ov;");
+ }
+ else {
+ print STDERR ("=> link \"$orig\" to \$$pkg","::opt_$ov\n")
+ if $debug;
+ eval ("\$linkage{\$orig} = \\\$".$pkg."::opt_$ov;");
+ }
+ }
+
+ if ( $opctl{$name}[CTL_TYPE] eq 'I'
+ && ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY
+ || $opctl{$name}[CTL_DEST] == CTL_DEST_HASH )
+ ) {
+ $error .= "Invalid option linkage for \"$opt\"\n";
+ }
+
+ }
+
+ # Bail out if errors found.
+ die ($error) if $error;
+ $error = 0;
+
+ # Supply --version and --help support, if needed and allowed.
+ if ( defined($auto_version) ? $auto_version : ($requested_version >= 2.3203) ) {
+ if ( !defined($opctl{version}) ) {
+ $opctl{version} = ['','version',0,CTL_DEST_CODE,undef];
+ $linkage{version} = \&VersionMessage;
+ }
+ $auto_version = 1;
+ }
+ if ( defined($auto_help) ? $auto_help : ($requested_version >= 2.3203) ) {
+ if ( !defined($opctl{help}) && !defined($opctl{'?'}) ) {
+ $opctl{help} = $opctl{'?'} = ['','help',0,CTL_DEST_CODE,undef];
+ $linkage{help} = \&HelpMessage;
+ }
+ $auto_help = 1;
+ }
+
+ # Show the options tables if debugging.
+ if ( $debug ) {
+ my ($arrow, $k, $v);
+ $arrow = "=> ";
+ while ( ($k,$v) = each(%opctl) ) {
+ print STDERR ($arrow, "\$opctl{$k} = $v ", OptCtl($v), "\n");
+ $arrow = " ";
+ }
+ }
+
+ # Process argument list
+ my $goon = 1;
+ while ( $goon && @$argv > 0 ) {
+
+ # Get next argument.
+ $opt = shift (@$argv);
+ print STDERR ("=> arg \"", $opt, "\"\n") if $debug;
+
+ # Double dash is option list terminator.
+ if ( $opt eq $argend ) {
+ push (@ret, $argend) if $passthrough;
+ last;
+ }
+
+ # Look it up.
+ my $tryopt = $opt;
+ my $found; # success status
+ my $key; # key (if hash type)
+ my $arg; # option argument
+ my $ctl; # the opctl entry
+
+ ($found, $opt, $ctl, $arg, $key) =
+ FindOption ($argv, $prefix, $argend, $opt, \%opctl);
+
+ if ( $found ) {
+
+ # FindOption undefines $opt in case of errors.
+ next unless defined $opt;
+
+ my $argcnt = 0;
+ while ( defined $arg ) {
+
+ # Get the canonical name.
+ print STDERR ("=> cname for \"$opt\" is ") if $debug;
+ $opt = $ctl->[CTL_CNAME];
+ print STDERR ("\"$ctl->[CTL_CNAME]\"\n") if $debug;
+
+ if ( defined $linkage{$opt} ) {
+ print STDERR ("=> ref(\$L{$opt}) -> ",
+ ref($linkage{$opt}), "\n") if $debug;
+
+ if ( ref($linkage{$opt}) eq 'SCALAR'
+ || ref($linkage{$opt}) eq 'REF' ) {
+ if ( $ctl->[CTL_TYPE] eq '+' ) {
+ print STDERR ("=> \$\$L{$opt} += \"$arg\"\n")
+ if $debug;
+ if ( defined ${$linkage{$opt}} ) {
+ ${$linkage{$opt}} += $arg;
+ }
+ else {
+ ${$linkage{$opt}} = $arg;
+ }
+ }
+ elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) {
+ print STDERR ("=> ref(\$L{$opt}) auto-vivified",
+ " to ARRAY\n")
+ if $debug;
+ my $t = $linkage{$opt};
+ $$t = $linkage{$opt} = [];
+ print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
+ if $debug;
+ push (@{$linkage{$opt}}, $arg);
+ }
+ elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
+ print STDERR ("=> ref(\$L{$opt}) auto-vivified",
+ " to HASH\n")
+ if $debug;
+ my $t = $linkage{$opt};
+ $$t = $linkage{$opt} = {};
+ print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
+ if $debug;
+ $linkage{$opt}->{$key} = $arg;
+ }
+ else {
+ print STDERR ("=> \$\$L{$opt} = \"$arg\"\n")
+ if $debug;
+ ${$linkage{$opt}} = $arg;
+ }
+ }
+ elsif ( ref($linkage{$opt}) eq 'ARRAY' ) {
+ print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
+ if $debug;
+ push (@{$linkage{$opt}}, $arg);
+ }
+ elsif ( ref($linkage{$opt}) eq 'HASH' ) {
+ print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
+ if $debug;
+ $linkage{$opt}->{$key} = $arg;
+ }
+ elsif ( ref($linkage{$opt}) eq 'CODE' ) {
+ print STDERR ("=> &L{$opt}(\"$opt\"",
+ $ctl->[CTL_DEST] == CTL_DEST_HASH ? ", \"$key\"" : "",
+ ", \"$arg\")\n")
+ if $debug;
+ my $eval_error = do {
+ local $@;
+ local $SIG{__DIE__} = 'DEFAULT';
+ eval {
+ &{$linkage{$opt}}
+ (Getopt::Long::CallBack->new
+ (name => $opt,
+ ctl => $ctl,
+ opctl => \%opctl,
+ linkage => \%linkage,
+ prefix => $prefix,
+ ),
+ $ctl->[CTL_DEST] == CTL_DEST_HASH ? ($key) : (),
+ $arg);
+ };
+ $@;
+ };
+ print STDERR ("=> die($eval_error)\n")
+ if $debug && $eval_error ne '';
+ if ( $eval_error =~ /^!/ ) {
+ if ( $eval_error =~ /^!FINISH\b/ ) {
+ $goon = 0;
+ }
+ }
+ elsif ( $eval_error ne '' ) {
+ warn ($eval_error);
+ $error++;
+ }
+ }
+ else {
+ print STDERR ("Invalid REF type \"", ref($linkage{$opt}),
+ "\" in linkage\n");
+ die("Getopt::Long -- internal error!\n");
+ }
+ }
+ # No entry in linkage means entry in userlinkage.
+ elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) {
+ if ( defined $userlinkage->{$opt} ) {
+ print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n")
+ if $debug;
+ push (@{$userlinkage->{$opt}}, $arg);
+ }
+ else {
+ print STDERR ("=>\$L{$opt} = [\"$arg\"]\n")
+ if $debug;
+ $userlinkage->{$opt} = [$arg];
+ }
+ }
+ elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
+ if ( defined $userlinkage->{$opt} ) {
+ print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n")
+ if $debug;
+ $userlinkage->{$opt}->{$key} = $arg;
+ }
+ else {
+ print STDERR ("=>\$L{$opt} = {$key => \"$arg\"}\n")
+ if $debug;
+ $userlinkage->{$opt} = {$key => $arg};
+ }
+ }
+ else {
+ if ( $ctl->[CTL_TYPE] eq '+' ) {
+ print STDERR ("=> \$L{$opt} += \"$arg\"\n")
+ if $debug;
+ if ( defined $userlinkage->{$opt} ) {
+ $userlinkage->{$opt} += $arg;
+ }
+ else {
+ $userlinkage->{$opt} = $arg;
+ }
+ }
+ else {
+ print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug;
+ $userlinkage->{$opt} = $arg;
+ }
+ }
+
+ $argcnt++;
+ last if $argcnt >= $ctl->[CTL_AMAX] && $ctl->[CTL_AMAX] != -1;
+ undef($arg);
+
+ # Need more args?
+ if ( $argcnt < $ctl->[CTL_AMIN] ) {
+ if ( @$argv ) {
+ if ( ValidValue($ctl, $argv->[0], 1, $argend, $prefix) ) {
+ $arg = shift(@$argv);
+ $arg =~ tr/_//d if $ctl->[CTL_TYPE] =~ /^[iIo]$/;
+ ($key,$arg) = $arg =~ /^([^=]+)=(.*)/
+ if $ctl->[CTL_DEST] == CTL_DEST_HASH;
+ next;
+ }
+ warn("Value \"$$argv[0]\" invalid for option $opt\n");
+ $error++;
+ }
+ else {
+ warn("Insufficient arguments for option $opt\n");
+ $error++;
+ }
+ }
+
+ # Any more args?
+ if ( @$argv && ValidValue($ctl, $argv->[0], 0, $argend, $prefix) ) {
+ $arg = shift(@$argv);
+ $arg =~ tr/_//d if $ctl->[CTL_TYPE] =~ /^[iIo]$/;
+ ($key,$arg) = $arg =~ /^([^=]+)=(.*)/
+ if $ctl->[CTL_DEST] == CTL_DEST_HASH;
+ next;
+ }
+ }
+ }
+
+ # Not an option. Save it if we $PERMUTE and don't have a <>.
+ elsif ( $order == $PERMUTE ) {
+ # Try non-options call-back.
+ my $cb;
+ if ( (defined ($cb = $linkage{'<>'})) ) {
+ print STDERR ("=> &L{$tryopt}(\"$tryopt\")\n")
+ if $debug;
+ my $eval_error = do {
+ local $@;
+ local $SIG{__DIE__} = 'DEFAULT';
+ eval {
+ &$cb
+ (Getopt::Long::CallBack->new
+ (name => $tryopt,
+ ctl => $ctl,
+ opctl => \%opctl,
+ linkage => \%linkage,
+ prefix => $prefix,
+ ));
+ };
+ $@;
+ };
+ print STDERR ("=> die($eval_error)\n")
+ if $debug && $eval_error ne '';
+ if ( $eval_error =~ /^!/ ) {
+ if ( $eval_error =~ /^!FINISH\b/ ) {
+ $goon = 0;
+ }
+ }
+ elsif ( $eval_error ne '' ) {
+ warn ($eval_error);
+ $error++;
+ }
+ }
+ else {
+ print STDERR ("=> saving \"$tryopt\" ",
+ "(not an option, may permute)\n") if $debug;
+ push (@ret, $tryopt);
+ }
+ next;
+ }
+
+ # ...otherwise, terminate.
+ else {
+ # Push this one back and exit.
+ unshift (@$argv, $tryopt);
+ return ($error == 0);
+ }
+
+ }
+
+ # Finish.
+ if ( @ret && $order == $PERMUTE ) {
+ # Push back accumulated arguments
+ print STDERR ("=> restoring \"", join('" "', @ret), "\"\n")
+ if $debug;
+ unshift (@$argv, @ret);
+ }
+
+ return ($error == 0);
+}
+
+# A readable representation of what's in an optbl.
+sub OptCtl ($) {
+ my ($v) = @_;
+ my @v = map { defined($_) ? ($_) : ("<undef>") } @$v;
+ "[".
+ join(",",
+ "\"$v[CTL_TYPE]\"",
+ "\"$v[CTL_CNAME]\"",
+ "\"$v[CTL_DEFAULT]\"",
+ ("\$","\@","\%","\&")[$v[CTL_DEST] || 0],
+ $v[CTL_AMIN] || '',
+ $v[CTL_AMAX] || '',
+# $v[CTL_RANGE] || '',
+# $v[CTL_REPEAT] || '',
+ ). "]";
+}
+
+# Parse an option specification and fill the tables.
+sub ParseOptionSpec ($$) {
+ my ($opt, $opctl) = @_;
+
+ # Match option spec.
+ if ( $opt !~ m;^
+ (
+ # Option name
+ (?: \w+[-\w]* )
+ # Alias names, or "?"
+ (?: \| (?: \? | \w[-\w]* ) )*
+ )?
+ (
+ # Either modifiers ...
+ [!+]
+ |
+ # ... or a value/dest/repeat specification
+ [=:] [ionfs] [@%]? (?: \{\d*,?\d*\} )?
+ |
+ # ... or an optional-with-default spec
+ : (?: -?\d+ | \+ ) [@%]?
+ )?
+ $;x ) {
+ return (undef, "Error in option spec: \"$opt\"\n");
+ }
+
+ my ($names, $spec) = ($1, $2);
+ $spec = '' unless defined $spec;
+
+ # $orig keeps track of the primary name the user specified.
+ # This name will be used for the internal or external linkage.
+ # In other words, if the user specifies "FoO|BaR", it will
+ # match any case combinations of 'foo' and 'bar', but if a global
+ # variable needs to be set, it will be $opt_FoO in the exact case
+ # as specified.
+ my $orig;
+
+ my @names;
+ if ( defined $names ) {
+ @names = split (/\|/, $names);
+ $orig = $names[0];
+ }
+ else {
+ @names = ('');
+ $orig = '';
+ }
+
+ # Construct the opctl entries.
+ my $entry;
+ if ( $spec eq '' || $spec eq '+' || $spec eq '!' ) {
+ # Fields are hard-wired here.
+ $entry = [$spec,$orig,undef,CTL_DEST_SCALAR,0,0];
+ }
+ elsif ( $spec =~ /^:(-?\d+|\+)([@%])?$/ ) {
+ my $def = $1;
+ my $dest = $2;
+ my $type = $def eq '+' ? 'I' : 'i';
+ $dest ||= '$';
+ $dest = $dest eq '@' ? CTL_DEST_ARRAY
+ : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR;
+ # Fields are hard-wired here.
+ $entry = [$type,$orig,$def eq '+' ? undef : $def,
+ $dest,0,1];
+ }
+ else {
+ my ($mand, $type, $dest) =
+ $spec =~ /^([=:])([ionfs])([@%])?(\{(\d+)?(,)?(\d+)?\})?$/;
+ return (undef, "Cannot repeat while bundling: \"$opt\"\n")
+ if $bundling && defined($4);
+ my ($mi, $cm, $ma) = ($5, $6, $7);
+ return (undef, "{0} is useless in option spec: \"$opt\"\n")
+ if defined($mi) && !$mi && !defined($ma) && !defined($cm);
+
+ $type = 'i' if $type eq 'n';
+ $dest ||= '$';
+ $dest = $dest eq '@' ? CTL_DEST_ARRAY
+ : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR;
+ # Default minargs to 1/0 depending on mand status.
+ $mi = $mand eq '=' ? 1 : 0 unless defined $mi;
+ # Adjust mand status according to minargs.
+ $mand = $mi ? '=' : ':';
+ # Adjust maxargs.
+ $ma = $mi ? $mi : 1 unless defined $ma || defined $cm;
+ return (undef, "Max must be greater than zero in option spec: \"$opt\"\n")
+ if defined($ma) && !$ma;
+ return (undef, "Max less than min in option spec: \"$opt\"\n")
+ if defined($ma) && $ma < $mi;
+
+ # Fields are hard-wired here.
+ $entry = [$type,$orig,undef,$dest,$mi,$ma||-1];
+ }
+
+ # Process all names. First is canonical, the rest are aliases.
+ my $dups = '';
+ foreach ( @names ) {
+
+ $_ = lc ($_)
+ if $ignorecase > (($bundling && length($_) == 1) ? 1 : 0);
+
+ if ( exists $opctl->{$_} ) {
+ $dups .= "Duplicate specification \"$opt\" for option \"$_\"\n";
+ }
+
+ if ( $spec eq '!' ) {
+ $opctl->{"no$_"} = $entry;
+ $opctl->{"no-$_"} = $entry;
+ $opctl->{$_} = [@$entry];
+ $opctl->{$_}->[CTL_TYPE] = '';
+ }
+ else {
+ $opctl->{$_} = $entry;
+ }
+ }
+
+ if ( $dups && $^W ) {
+ foreach ( split(/\n+/, $dups) ) {
+ warn($_."\n");
+ }
+ }
+ ($names[0], $orig);
+}
+
+# Option lookup.
+sub FindOption ($$$$$) {
+
+ # returns (1, $opt, $ctl, $arg, $key) if okay,
+ # returns (1, undef) if option in error,
+ # returns (0) otherwise.
+
+ my ($argv, $prefix, $argend, $opt, $opctl) = @_;
+
+ print STDERR ("=> find \"$opt\"\n") if $debug;
+
+ return (0) unless $opt =~ /^$prefix(.*)$/s;
+ return (0) if $opt eq "-" && !defined $opctl->{''};
+
+ $opt = $+;
+ my $starter = $1;
+
+ print STDERR ("=> split \"$starter\"+\"$opt\"\n") if $debug;
+
+ my $optarg; # value supplied with --opt=value
+ my $rest; # remainder from unbundling
+
+ # If it is a long option, it may include the value.
+ # With getopt_compat, only if not bundling.
+ if ( ($starter=~/^$longprefix$/
+ || ($getopt_compat && ($bundling == 0 || $bundling == 2)))
+ && $opt =~ /^([^=]+)=(.*)$/s ) {
+ $opt = $1;
+ $optarg = $2;
+ print STDERR ("=> option \"", $opt,
+ "\", optarg = \"$optarg\"\n") if $debug;
+ }
+
+ #### Look it up ###
+
+ my $tryopt = $opt; # option to try
+
+ if ( $bundling && $starter eq '-' ) {
+
+ # To try overrides, obey case ignore.
+ $tryopt = $ignorecase ? lc($opt) : $opt;
+
+ # If bundling == 2, long options can override bundles.
+ if ( $bundling == 2 && length($tryopt) > 1
+ && defined ($opctl->{$tryopt}) ) {
+ print STDERR ("=> $starter$tryopt overrides unbundling\n")
+ if $debug;
+ }
+ else {
+ $tryopt = $opt;
+ # Unbundle single letter option.
+ $rest = length ($tryopt) > 0 ? substr ($tryopt, 1) : '';
+ $tryopt = substr ($tryopt, 0, 1);
+ $tryopt = lc ($tryopt) if $ignorecase > 1;
+ print STDERR ("=> $starter$tryopt unbundled from ",
+ "$starter$tryopt$rest\n") if $debug;
+ $rest = undef unless $rest ne '';
+ }
+ }
+
+ # Try auto-abbreviation.
+ elsif ( $autoabbrev && $opt ne "" ) {
+ # Sort the possible long option names.
+ my @names = sort(keys (%$opctl));
+ # Downcase if allowed.
+ $opt = lc ($opt) if $ignorecase;
+ $tryopt = $opt;
+ # Turn option name into pattern.
+ my $pat = quotemeta ($opt);
+ # Look up in option names.
+ my @hits = grep (/^$pat/, @names);
+ print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ",
+ "out of ", scalar(@names), "\n") if $debug;
+
+ # Check for ambiguous results.
+ unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
+ # See if all matches are for the same option.
+ my %hit;
+ foreach ( @hits ) {
+ my $hit = $_;
+ $hit = $opctl->{$hit}->[CTL_CNAME]
+ if defined $opctl->{$hit}->[CTL_CNAME];
+ $hit{$hit} = 1;
+ }
+ # Remove auto-supplied options (version, help).
+ if ( keys(%hit) == 2 ) {
+ if ( $auto_version && exists($hit{version}) ) {
+ delete $hit{version};
+ }
+ elsif ( $auto_help && exists($hit{help}) ) {
+ delete $hit{help};
+ }
+ }
+ # Now see if it really is ambiguous.
+ unless ( keys(%hit) == 1 ) {
+ return (0) if $passthrough;
+ warn ("Option ", $opt, " is ambiguous (",
+ join(", ", @hits), ")\n");
+ $error++;
+ return (1, undef);
+ }
+ @hits = keys(%hit);
+ }
+
+ # Complete the option name, if appropriate.
+ if ( @hits == 1 && $hits[0] ne $opt ) {
+ $tryopt = $hits[0];
+ $tryopt = lc ($tryopt) if $ignorecase;
+ print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
+ if $debug;
+ }
+ }
+
+ # Map to all lowercase if ignoring case.
+ elsif ( $ignorecase ) {
+ $tryopt = lc ($opt);
+ }
+
+ # Check validity by fetching the info.
+ my $ctl = $opctl->{$tryopt};
+ unless ( defined $ctl ) {
+ return (0) if $passthrough;
+ # Pretend one char when bundling.
+ if ( $bundling == 1 && length($starter) == 1 ) {
+ $opt = substr($opt,0,1);
+ unshift (@$argv, $starter.$rest) if defined $rest;
+ }
+ if ( $opt eq "" ) {
+ warn ("Missing option after ", $starter, "\n");
+ }
+ else {
+ warn ("Unknown option: ", $opt, "\n");
+ }
+ $error++;
+ return (1, undef);
+ }
+ # Apparently valid.
+ $opt = $tryopt;
+ print STDERR ("=> found ", OptCtl($ctl),
+ " for \"", $opt, "\"\n") if $debug;
+
+ #### Determine argument status ####
+
+ # If it is an option w/o argument, we're almost finished with it.
+ my $type = $ctl->[CTL_TYPE];
+ my $arg;
+
+ if ( $type eq '' || $type eq '!' || $type eq '+' ) {
+ if ( defined $optarg ) {
+ return (0) if $passthrough;
+ warn ("Option ", $opt, " does not take an argument\n");
+ $error++;
+ undef $opt;
+ }
+ elsif ( $type eq '' || $type eq '+' ) {
+ # Supply explicit value.
+ $arg = 1;
+ }
+ else {
+ $opt =~ s/^no-?//i; # strip NO prefix
+ $arg = 0; # supply explicit value
+ }
+ unshift (@$argv, $starter.$rest) if defined $rest;
+ return (1, $opt, $ctl, $arg);
+ }
+
+ # Get mandatory status and type info.
+ my $mand = $ctl->[CTL_AMIN];
+
+ # Check if there is an option argument available.
+ if ( $gnu_compat && defined $optarg && $optarg eq '' ) {
+ return (1, $opt, $ctl, $type eq 's' ? '' : 0) ;#unless $mand;
+ $optarg = 0 unless $type eq 's';
+ }
+
+ # Check if there is an option argument available.
+ if ( defined $optarg
+ ? ($optarg eq '')
+ : !(defined $rest || @$argv > 0) ) {
+ # Complain if this option needs an argument.
+# if ( $mand && !($type eq 's' ? defined($optarg) : 0) ) {
+ if ( $mand ) {
+ return (0) if $passthrough;
+ warn ("Option ", $opt, " requires an argument\n");
+ $error++;
+ return (1, undef);
+ }
+ if ( $type eq 'I' ) {
+ # Fake incremental type.
+ my @c = @$ctl;
+ $c[CTL_TYPE] = '+';
+ return (1, $opt, \@c, 1);
+ }
+ return (1, $opt, $ctl,
+ defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] :
+ $type eq 's' ? '' : 0);
+ }
+
+ # Get (possibly optional) argument.
+ $arg = (defined $rest ? $rest
+ : (defined $optarg ? $optarg : shift (@$argv)));
+
+ # Get key if this is a "name=value" pair for a hash option.
+ my $key;
+ if ($ctl->[CTL_DEST] == CTL_DEST_HASH && defined $arg) {
+ ($key, $arg) = ($arg =~ /^([^=]*)=(.*)$/s) ? ($1, $2)
+ : ($arg, defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] :
+ ($mand ? undef : ($type eq 's' ? "" : 1)));
+ if (! defined $arg) {
+ warn ("Option $opt, key \"$key\", requires a value\n");
+ $error++;
+ # Push back.
+ unshift (@$argv, $starter.$rest) if defined $rest;
+ return (1, undef);
+ }
+ }
+
+ #### Check if the argument is valid for this option ####
+
+ my $key_valid = $ctl->[CTL_DEST] == CTL_DEST_HASH ? "[^=]+=" : "";
+
+ if ( $type eq 's' ) { # string
+ # A mandatory string takes anything.
+ return (1, $opt, $ctl, $arg, $key) if $mand;
+
+ # Same for optional string as a hash value
+ return (1, $opt, $ctl, $arg, $key)
+ if $ctl->[CTL_DEST] == CTL_DEST_HASH;
+
+ # An optional string takes almost anything.
+ return (1, $opt, $ctl, $arg, $key)
+ if defined $optarg || defined $rest;
+ return (1, $opt, $ctl, $arg, $key) if $arg eq "-"; # ??
+
+ # Check for option or option list terminator.
+ if ($arg eq $argend ||
+ $arg =~ /^$prefix.+/) {
+ # Push back.
+ unshift (@$argv, $arg);
+ # Supply empty value.
+ $arg = '';
+ }
+ }
+
+ elsif ( $type eq 'i' # numeric/integer
+ || $type eq 'I' # numeric/integer w/ incr default
+ || $type eq 'o' ) { # dec/oct/hex/bin value
+
+ my $o_valid = $type eq 'o' ? PAT_XINT : PAT_INT;
+
+ if ( $bundling && defined $rest
+ && $rest =~ /^($key_valid)($o_valid)(.*)$/si ) {
+ ($key, $arg, $rest) = ($1, $2, $+);
+ chop($key) if $key;
+ $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg;
+ unshift (@$argv, $starter.$rest) if defined $rest && $rest ne '';
+ }
+ elsif ( $arg =~ /^$o_valid$/si ) {
+ $arg =~ tr/_//d;
+ $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg;
+ }
+ else {
+ if ( defined $optarg || $mand ) {
+ if ( $passthrough ) {
+ unshift (@$argv, defined $rest ? $starter.$rest : $arg)
+ unless defined $optarg;
+ return (0);
+ }
+ warn ("Value \"", $arg, "\" invalid for option ",
+ $opt, " (",
+ $type eq 'o' ? "extended " : '',
+ "number expected)\n");
+ $error++;
+ # Push back.
+ unshift (@$argv, $starter.$rest) if defined $rest;
+ return (1, undef);
+ }
+ else {
+ # Push back.
+ unshift (@$argv, defined $rest ? $starter.$rest : $arg);
+ if ( $type eq 'I' ) {
+ # Fake incremental type.
+ my @c = @$ctl;
+ $c[CTL_TYPE] = '+';
+ return (1, $opt, \@c, 1);
+ }
+ # Supply default value.
+ $arg = defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : 0;
+ }
+ }
+ }
+
+ elsif ( $type eq 'f' ) { # real number, int is also ok
+ # We require at least one digit before a point or 'e',
+ # and at least one digit following the point and 'e'.
+ # [-]NN[.NN][eNN]
+ my $o_valid = PAT_FLOAT;
+ if ( $bundling && defined $rest &&
+ $rest =~ /^($key_valid)($o_valid)(.*)$/s ) {
+ $arg =~ tr/_//d;
+ ($key, $arg, $rest) = ($1, $2, $+);
+ chop($key) if $key;
+ unshift (@$argv, $starter.$rest) if defined $rest && $rest ne '';
+ }
+ elsif ( $arg =~ /^$o_valid$/ ) {
+ $arg =~ tr/_//d;
+ }
+ else {
+ if ( defined $optarg || $mand ) {
+ if ( $passthrough ) {
+ unshift (@$argv, defined $rest ? $starter.$rest : $arg)
+ unless defined $optarg;
+ return (0);
+ }
+ warn ("Value \"", $arg, "\" invalid for option ",
+ $opt, " (real number expected)\n");
+ $error++;
+ # Push back.
+ unshift (@$argv, $starter.$rest) if defined $rest;
+ return (1, undef);
+ }
+ else {
+ # Push back.
+ unshift (@$argv, defined $rest ? $starter.$rest : $arg);
+ # Supply default value.
+ $arg = 0.0;
+ }
+ }
+ }
+ else {
+ die("Getopt::Long internal error (Can't happen)\n");
+ }
+ return (1, $opt, $ctl, $arg, $key);
+}
+
+sub ValidValue ($$$$$) {
+ my ($ctl, $arg, $mand, $argend, $prefix) = @_;
+
+ if ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
+ return 0 unless $arg =~ /[^=]+=(.*)/;
+ $arg = $1;
+ }
+
+ my $type = $ctl->[CTL_TYPE];
+
+ if ( $type eq 's' ) { # string
+ # A mandatory string takes anything.
+ return (1) if $mand;
+
+ return (1) if $arg eq "-";
+
+ # Check for option or option list terminator.
+ return 0 if $arg eq $argend || $arg =~ /^$prefix.+/;
+ return 1;
+ }
+
+ elsif ( $type eq 'i' # numeric/integer
+ || $type eq 'I' # numeric/integer w/ incr default
+ || $type eq 'o' ) { # dec/oct/hex/bin value
+
+ my $o_valid = $type eq 'o' ? PAT_XINT : PAT_INT;
+ return $arg =~ /^$o_valid$/si;
+ }
+
+ elsif ( $type eq 'f' ) { # real number, int is also ok
+ # We require at least one digit before a point or 'e',
+ # and at least one digit following the point and 'e'.
+ # [-]NN[.NN][eNN]
+ my $o_valid = PAT_FLOAT;
+ return $arg =~ /^$o_valid$/;
+ }
+ die("ValidValue: Cannot happen\n");
+}
+
+# Getopt::Long Configuration.
+sub Configure (@) {
+ my (@options) = @_;
+
+ my $prevconfig =
+ [ $error, $debug, $major_version, $minor_version,
+ $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
+ $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help,
+ $longprefix ];
+
+ if ( ref($options[0]) eq 'ARRAY' ) {
+ ( $error, $debug, $major_version, $minor_version,
+ $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
+ $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help,
+ $longprefix ) = @{shift(@options)};
+ }
+
+ my $opt;
+ foreach $opt ( @options ) {
+ my $try = lc ($opt);
+ my $action = 1;
+ if ( $try =~ /^no_?(.*)$/s ) {
+ $action = 0;
+ $try = $+;
+ }
+ if ( ($try eq 'default' or $try eq 'defaults') && $action ) {
+ ConfigDefaults ();
+ }
+ elsif ( ($try eq 'posix_default' or $try eq 'posix_defaults') ) {
+ local $ENV{POSIXLY_CORRECT};
+ $ENV{POSIXLY_CORRECT} = 1 if $action;
+ ConfigDefaults ();
+ }
+ elsif ( $try eq 'auto_abbrev' or $try eq 'autoabbrev' ) {
+ $autoabbrev = $action;
+ }
+ elsif ( $try eq 'getopt_compat' ) {
+ $getopt_compat = $action;
+ $genprefix = $action ? "(--|-|\\+)" : "(--|-)";
+ }
+ elsif ( $try eq 'gnu_getopt' ) {
+ if ( $action ) {
+ $gnu_compat = 1;
+ $bundling = 1;
+ $getopt_compat = 0;
+ $genprefix = "(--|-)";
+ $order = $PERMUTE;
+ }
+ }
+ elsif ( $try eq 'gnu_compat' ) {
+ $gnu_compat = $action;
+ }
+ elsif ( $try =~ /^(auto_?)?version$/ ) {
+ $auto_version = $action;
+ }
+ elsif ( $try =~ /^(auto_?)?help$/ ) {
+ $auto_help = $action;
+ }
+ elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) {
+ $ignorecase = $action;
+ }
+ elsif ( $try eq 'ignorecase_always' or $try eq 'ignore_case_always' ) {
+ $ignorecase = $action ? 2 : 0;
+ }
+ elsif ( $try eq 'bundling' ) {
+ $bundling = $action;
+ }
+ elsif ( $try eq 'bundling_override' ) {
+ $bundling = $action ? 2 : 0;
+ }
+ elsif ( $try eq 'require_order' ) {
+ $order = $action ? $REQUIRE_ORDER : $PERMUTE;
+ }
+ elsif ( $try eq 'permute' ) {
+ $order = $action ? $PERMUTE : $REQUIRE_ORDER;
+ }
+ elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) {
+ $passthrough = $action;
+ }
+ elsif ( $try =~ /^prefix=(.+)$/ && $action ) {
+ $genprefix = $1;
+ # Turn into regexp. Needs to be parenthesized!
+ $genprefix = "(" . quotemeta($genprefix) . ")";
+ eval { '' =~ /$genprefix/; };
+ die("Getopt::Long: invalid pattern \"$genprefix\"") if $@;
+ }
+ elsif ( $try =~ /^prefix_pattern=(.+)$/ && $action ) {
+ $genprefix = $1;
+ # Parenthesize if needed.
+ $genprefix = "(" . $genprefix . ")"
+ unless $genprefix =~ /^\(.*\)$/;
+ eval { '' =~ m"$genprefix"; };
+ die("Getopt::Long: invalid pattern \"$genprefix\"") if $@;
+ }
+ elsif ( $try =~ /^long_prefix_pattern=(.+)$/ && $action ) {
+ $longprefix = $1;
+ # Parenthesize if needed.
+ $longprefix = "(" . $longprefix . ")"
+ unless $longprefix =~ /^\(.*\)$/;
+ eval { '' =~ m"$longprefix"; };
+ die("Getopt::Long: invalid long prefix pattern \"$longprefix\"") if $@;
+ }
+ elsif ( $try eq 'debug' ) {
+ $debug = $action;
+ }
+ else {
+ die("Getopt::Long: unknown config parameter \"$opt\"")
+ }
+ }
+ $prevconfig;
+}
+
+# Deprecated name.
+sub config (@) {
+ Configure (@_);
+}
+
+# Issue a standard message for --version.
+#
+# The arguments are mostly the same as for Pod::Usage::pod2usage:
+#
+# - a number (exit value)
+# - a string (lead in message)
+# - a hash with options. See Pod::Usage for details.
+#
+sub VersionMessage(@) {
+ # Massage args.
+ my $pa = setup_pa_args("version", @_);
+
+ my $v = $main::VERSION;
+ my $fh = $pa->{-output} ||
+ ($pa->{-exitval} eq "NOEXIT" || $pa->{-exitval} < 2) ? \*STDOUT : \*STDERR;
+
+ print $fh (defined($pa->{-message}) ? $pa->{-message} : (),
+ $0, defined $v ? " version $v" : (),
+ "\n",
+ "(", __PACKAGE__, "::", "GetOptions",
+ " version ",
+ defined($Getopt::Long::VERSION_STRING)
+ ? $Getopt::Long::VERSION_STRING : $VERSION, ";",
+ " Perl version ",
+ $] >= 5.006 ? sprintf("%vd", $^V) : $],
+ ")\n");
+ exit($pa->{-exitval}) unless $pa->{-exitval} eq "NOEXIT";
+}
+
+# Issue a standard message for --help.
+#
+# The arguments are the same as for Pod::Usage::pod2usage:
+#
+# - a number (exit value)
+# - a string (lead in message)
+# - a hash with options. See Pod::Usage for details.
+#
+sub HelpMessage(@) {
+ eval {
+ require Pod::Usage;
+ import Pod::Usage;
+ 1;
+ } || die("Cannot provide help: cannot load Pod::Usage\n");
+
+ # Note that pod2usage will issue a warning if -exitval => NOEXIT.
+ pod2usage(setup_pa_args("help", @_));
+
+}
+
+# Helper routine to set up a normalized hash ref to be used as
+# argument to pod2usage.
+sub setup_pa_args($@) {
+ my $tag = shift; # who's calling
+
+ # If called by direct binding to an option, it will get the option
+ # name and value as arguments. Remove these, if so.
+ @_ = () if @_ == 2 && $_[0] eq $tag;
+
+ my $pa;
+ if ( @_ > 1 ) {
+ $pa = { @_ };
+ }
+ else {
+ $pa = shift || {};
+ }
+
+ # At this point, $pa can be a number (exit value), string
+ # (message) or hash with options.
+
+ if ( UNIVERSAL::isa($pa, 'HASH') ) {
+ # Get rid of -msg vs. -message ambiguity.
+ $pa->{-message} = $pa->{-msg};
+ delete($pa->{-msg});
+ }
+ elsif ( $pa =~ /^-?\d+$/ ) {
+ $pa = { -exitval => $pa };
+ }
+ else {
+ $pa = { -message => $pa };
+ }
+
+ # These are _our_ defaults.
+ $pa->{-verbose} = 0 unless exists($pa->{-verbose});
+ $pa->{-exitval} = 0 unless exists($pa->{-exitval});
+ $pa;
+}
+
+# Sneak way to know what version the user requested.
+sub VERSION {
+ $requested_version = $_[1];
+ shift->SUPER::VERSION(@_);
+}
+
+package Getopt::Long::CallBack;
+
+sub new {
+ my ($pkg, %atts) = @_;
+ bless { %atts }, $pkg;
+}
+
+sub name {
+ my $self = shift;
+ ''.$self->{name};
+}
+
+use overload
+ # Treat this object as an ordinary string for legacy API.
+ '""' => \&name,
+ fallback => 1;
+
+1;
+
+################ Documentation ################
+
+=head1 NAME
+
+Getopt::Long - Extended processing of command line options
+
+=head1 SYNOPSIS
+
+ use Getopt::Long;
+ my $data = "file.dat";
+ my $length = 24;
+ my $verbose;
+ $result = GetOptions ("length=i" => \$length, # numeric
+ "file=s" => \$data, # string
+ "verbose" => \$verbose); # flag
+
+=head1 DESCRIPTION
+
+The Getopt::Long module implements an extended getopt function called
+GetOptions(). This function adheres to the POSIX syntax for command
+line options, with GNU extensions. In general, this means that options
+have long names instead of single letters, and are introduced with a
+double dash "--". Support for bundling of command line options, as was
+the case with the more traditional single-letter approach, is provided
+but not enabled by default.
+
+=head1 Command Line Options, an Introduction
+
+Command line operated programs traditionally take their arguments from
+the command line, for example filenames or other information that the
+program needs to know. Besides arguments, these programs often take
+command line I<options> as well. Options are not necessary for the
+program to work, hence the name 'option', but are used to modify its
+default behaviour. For example, a program could do its job quietly,
+but with a suitable option it could provide verbose information about
+what it did.
+
+Command line options come in several flavours. Historically, they are
+preceded by a single dash C<->, and consist of a single letter.
+
+ -l -a -c
+
+Usually, these single-character options can be bundled:
+
+ -lac
+
+Options can have values, the value is placed after the option
+character. Sometimes with whitespace in between, sometimes not:
+
+ -s 24 -s24
+
+Due to the very cryptic nature of these options, another style was
+developed that used long names. So instead of a cryptic C<-l> one
+could use the more descriptive C<--long>. To distinguish between a
+bundle of single-character options and a long one, two dashes are used
+to precede the option name. Early implementations of long options used
+a plus C<+> instead. Also, option values could be specified either
+like
+
+ --size=24
+
+or
+
+ --size 24
+
+The C<+> form is now obsolete and strongly deprecated.
+
+=head1 Getting Started with Getopt::Long
+
+Getopt::Long is the Perl5 successor of C<newgetopt.pl>. This was the
+first Perl module that provided support for handling the new style of
+command line options, hence the name Getopt::Long. This module also
+supports single-character options and bundling. Single character
+options may be any alphabetic character, a question mark, and a dash.
+Long options may consist of a series of letters, digits, and dashes.
+Although this is currently not enforced by Getopt::Long, multiple
+consecutive dashes are not allowed, and the option name must not end
+with a dash.
+
+To use Getopt::Long from a Perl program, you must include the
+following line in your Perl program:
+
+ use Getopt::Long;
+
+This will load the core of the Getopt::Long module and prepare your
+program for using it. Most of the actual Getopt::Long code is not
+loaded until you really call one of its functions.
+
+In the default configuration, options names may be abbreviated to
+uniqueness, case does not matter, and a single dash is sufficient,
+even for long option names. Also, options may be placed between
+non-option arguments. See L<Configuring Getopt::Long> for more
+details on how to configure Getopt::Long.
+
+=head2 Simple options
+
+The most simple options are the ones that take no values. Their mere
+presence on the command line enables the option. Popular examples are:
+
+ --all --verbose --quiet --debug
+
+Handling simple options is straightforward:
+
+ my $verbose = ''; # option variable with default value (false)
+ my $all = ''; # option variable with default value (false)
+ GetOptions ('verbose' => \$verbose, 'all' => \$all);
+
+The call to GetOptions() parses the command line arguments that are
+present in C<@ARGV> and sets the option variable to the value C<1> if
+the option did occur on the command line. Otherwise, the option
+variable is not touched. Setting the option value to true is often
+called I<enabling> the option.
+
+The option name as specified to the GetOptions() function is called
+the option I<specification>. Later we'll see that this specification
+can contain more than just the option name. The reference to the
+variable is called the option I<destination>.
+
+GetOptions() will return a true value if the command line could be
+processed successfully. Otherwise, it will write error messages to
+STDERR, and return a false result.
+
+=head2 A little bit less simple options
+
+Getopt::Long supports two useful variants of simple options:
+I<negatable> options and I<incremental> options.
+
+A negatable option is specified with an exclamation mark C<!> after the
+option name:
+
+ my $verbose = ''; # option variable with default value (false)
+ GetOptions ('verbose!' => \$verbose);
+
+Now, using C<--verbose> on the command line will enable C<$verbose>,
+as expected. But it is also allowed to use C<--noverbose>, which will
+disable C<$verbose> by setting its value to C<0>. Using a suitable
+default value, the program can find out whether C<$verbose> is false
+by default, or disabled by using C<--noverbose>.
+
+An incremental option is specified with a plus C<+> after the
+option name:
+
+ my $verbose = ''; # option variable with default value (false)
+ GetOptions ('verbose+' => \$verbose);
+
+Using C<--verbose> on the command line will increment the value of
+C<$verbose>. This way the program can keep track of how many times the
+option occurred on the command line. For example, each occurrence of
+C<--verbose> could increase the verbosity level of the program.
+
+=head2 Mixing command line option with other arguments
+
+Usually programs take command line options as well as other arguments,
+for example, file names. It is good practice to always specify the
+options first, and the other arguments last. Getopt::Long will,
+however, allow the options and arguments to be mixed and 'filter out'
+all the options before passing the rest of the arguments to the
+program. To stop Getopt::Long from processing further arguments,
+insert a double dash C<--> on the command line:
+
+ --size 24 -- --all
+
+In this example, C<--all> will I<not> be treated as an option, but
+passed to the program unharmed, in C<@ARGV>.
+
+=head2 Options with values
+
+For options that take values it must be specified whether the option
+value is required or not, and what kind of value the option expects.
+
+Three kinds of values are supported: integer numbers, floating point
+numbers, and strings.
+
+If the option value is required, Getopt::Long will take the
+command line argument that follows the option and assign this to the
+option variable. If, however, the option value is specified as
+optional, this will only be done if that value does not look like a
+valid command line option itself.
+
+ my $tag = ''; # option variable with default value
+ GetOptions ('tag=s' => \$tag);
+
+In the option specification, the option name is followed by an equals
+sign C<=> and the letter C<s>. The equals sign indicates that this
+option requires a value. The letter C<s> indicates that this value is
+an arbitrary string. Other possible value types are C<i> for integer
+values, and C<f> for floating point values. Using a colon C<:> instead
+of the equals sign indicates that the option value is optional. In
+this case, if no suitable value is supplied, string valued options get
+an empty string C<''> assigned, while numeric options are set to C<0>.
+
+=head2 Options with multiple values
+
+Options sometimes take several values. For example, a program could
+use multiple directories to search for library files:
+
+ --library lib/stdlib --library lib/extlib
+
+To accomplish this behaviour, simply specify an array reference as the
+destination for the option:
+
+ GetOptions ("library=s" => \@libfiles);
+
+Alternatively, you can specify that the option can have multiple
+values by adding a "@", and pass a scalar reference as the
+destination:
+
+ GetOptions ("library=s@" => \$libfiles);
+
+Used with the example above, C<@libfiles> (or C<@$libfiles>) would
+contain two strings upon completion: C<"lib/srdlib"> and
+C<"lib/extlib">, in that order. It is also possible to specify that
+only integer or floating point numbers are acceptable values.
+
+Often it is useful to allow comma-separated lists of values as well as
+multiple occurrences of the options. This is easy using Perl's split()
+and join() operators:
+
+ GetOptions ("library=s" => \@libfiles);
+ @libfiles = split(/,/,join(',', at libfiles));
+
+Of course, it is important to choose the right separator string for
+each purpose.
+
+Warning: What follows is an experimental feature.
+
+Options can take multiple values at once, for example
+
+ --coordinates 52.2 16.4 --rgbcolor 255 255 149
+
+This can be accomplished by adding a repeat specifier to the option
+specification. Repeat specifiers are very similar to the C<{...}>
+repeat specifiers that can be used with regular expression patterns.
+For example, the above command line would be handled as follows:
+
+ GetOptions('coordinates=f{2}' => \@coor, 'rgbcolor=i{3}' => \@color);
+
+The destination for the option must be an array or array reference.
+
+It is also possible to specify the minimal and maximal number of
+arguments an option takes. C<foo=s{2,4}> indicates an option that
+takes at least two and at most 4 arguments. C<foo=s{,}> indicates one
+or more values; C<foo:s{,}> indicates zero or more option values.
+
+=head2 Options with hash values
+
+If the option destination is a reference to a hash, the option will
+take, as value, strings of the form I<key>C<=>I<value>. The value will
+be stored with the specified key in the hash.
+
+ GetOptions ("define=s" => \%defines);
+
+Alternatively you can use:
+
+ GetOptions ("define=s%" => \$defines);
+
+When used with command line options:
+
+ --define os=linux --define vendor=redhat
+
+the hash C<%defines> (or C<%$defines>) will contain two keys, C<"os">
+with value C<"linux"> and C<"vendor"> with value C<"redhat">. It is
+also possible to specify that only integer or floating point numbers
+are acceptable values. The keys are always taken to be strings.
+
+=head2 User-defined subroutines to handle options
+
+Ultimate control over what should be done when (actually: each time)
+an option is encountered on the command line can be achieved by
+designating a reference to a subroutine (or an anonymous subroutine)
+as the option destination. When GetOptions() encounters the option, it
+will call the subroutine with two or three arguments. The first
+argument is the name of the option. (Actually, it is an object that
+stringifies to the name of the option.) For a scalar or array destination,
+the second argument is the value to be stored. For a hash destination,
+the second arguments is the key to the hash, and the third argument
+the value to be stored. It is up to the subroutine to store the value,
+or do whatever it thinks is appropriate.
+
+A trivial application of this mechanism is to implement options that
+are related to each other. For example:
+
+ my $verbose = ''; # option variable with default value (false)
+ GetOptions ('verbose' => \$verbose,
+ 'quiet' => sub { $verbose = 0 });
+
+Here C<--verbose> and C<--quiet> control the same variable
+C<$verbose>, but with opposite values.
+
+If the subroutine needs to signal an error, it should call die() with
+the desired error message as its argument. GetOptions() will catch the
+die(), issue the error message, and record that an error result must
+be returned upon completion.
+
+If the text of the error message starts with an exclamation mark C<!>
+it is interpreted specially by GetOptions(). There is currently one
+special command implemented: C<die("!FINISH")> will cause GetOptions()
+to stop processing options, as if it encountered a double dash C<-->.
+
+In version 2.37 the first argument to the callback function was
+changed from string to object. This was done to make room for
+extensions and more detailed control. The object stringifies to the
+option name so this change should not introduce compatibility
+problems.
+
+=head2 Options with multiple names
+
+Often it is user friendly to supply alternate mnemonic names for
+options. For example C<--height> could be an alternate name for
+C<--length>. Alternate names can be included in the option
+specification, separated by vertical bar C<|> characters. To implement
+the above example:
+
+ GetOptions ('length|height=f' => \$length);
+
+The first name is called the I<primary> name, the other names are
+called I<aliases>. When using a hash to store options, the key will
+always be the primary name.
+
+Multiple alternate names are possible.
+
+=head2 Case and abbreviations
+
+Without additional configuration, GetOptions() will ignore the case of
+option names, and allow the options to be abbreviated to uniqueness.
+
+ GetOptions ('length|height=f' => \$length, "head" => \$head);
+
+This call will allow C<--l> and C<--L> for the length option, but
+requires a least C<--hea> and C<--hei> for the head and height options.
+
+=head2 Summary of Option Specifications
+
+Each option specifier consists of two parts: the name specification
+and the argument specification.
+
+The name specification contains the name of the option, optionally
+followed by a list of alternative names separated by vertical bar
+characters.
+
+ length option name is "length"
+ length|size|l name is "length", aliases are "size" and "l"
+
+The argument specification is optional. If omitted, the option is
+considered boolean, a value of 1 will be assigned when the option is
+used on the command line.
+
+The argument specification can be
+
+=over 4
+
+=item !
+
+The option does not take an argument and may be negated by prefixing
+it with "no" or "no-". E.g. C<"foo!"> will allow C<--foo> (a value of
+1 will be assigned) as well as C<--nofoo> and C<--no-foo> (a value of
+0 will be assigned). If the option has aliases, this applies to the
+aliases as well.
+
+Using negation on a single letter option when bundling is in effect is
+pointless and will result in a warning.
+
+=item +
+
+The option does not take an argument and will be incremented by 1
+every time it appears on the command line. E.g. C<"more+">, when used
+with C<--more --more --more>, will increment the value three times,
+resulting in a value of 3 (provided it was 0 or undefined at first).
+
+The C<+> specifier is ignored if the option destination is not a scalar.
+
+=item = I<type> [ I<desttype> ] [ I<repeat> ]
+
+The option requires an argument of the given type. Supported types
+are:
+
+=over 4
+
+=item s
+
+String. An arbitrary sequence of characters. It is valid for the
+argument to start with C<-> or C<-->.
+
+=item i
+
+Integer. An optional leading plus or minus sign, followed by a
+sequence of digits.
+
+=item o
+
+Extended integer, Perl style. This can be either an optional leading
+plus or minus sign, followed by a sequence of digits, or an octal
+string (a zero, optionally followed by '0', '1', .. '7'), or a
+hexadecimal string (C<0x> followed by '0' .. '9', 'a' .. 'f', case
+insensitive), or a binary string (C<0b> followed by a series of '0'
+and '1').
+
+=item f
+
+Real number. For example C<3.14>, C<-6.23E24> and so on.
+
+=back
+
+The I<desttype> can be C<@> or C<%> to specify that the option is
+list or a hash valued. This is only needed when the destination for
+the option value is not otherwise specified. It should be omitted when
+not needed.
+
+The I<repeat> specifies the number of values this option takes per
+occurrence on the command line. It has the format C<{> [ I<min> ] [ C<,> [ I<max> ] ] C<}>.
+
+I<min> denotes the minimal number of arguments. It defaults to 1 for
+options with C<=> and to 0 for options with C<:>, see below. Note that
+I<min> overrules the C<=> / C<:> semantics.
+
+I<max> denotes the maximum number of arguments. It must be at least
+I<min>. If I<max> is omitted, I<but the comma is not>, there is no
+upper bound to the number of argument values taken.
+
+=item : I<type> [ I<desttype> ]
+
+Like C<=>, but designates the argument as optional.
+If omitted, an empty string will be assigned to string values options,
+and the value zero to numeric options.
+
+Note that if a string argument starts with C<-> or C<-->, it will be
+considered an option on itself.
+
+=item : I<number> [ I<desttype> ]
+
+Like C<:i>, but if the value is omitted, the I<number> will be assigned.
+
+=item : + [ I<desttype> ]
+
+Like C<:i>, but if the value is omitted, the current value for the
+option will be incremented.
+
+=back
+
+=head1 Advanced Possibilities
+
+=head2 Object oriented interface
+
+Getopt::Long can be used in an object oriented way as well:
+
+ use Getopt::Long;
+ $p = new Getopt::Long::Parser;
+ $p->configure(...configuration options...);
+ if ($p->getoptions(...options descriptions...)) ...
+
+Configuration options can be passed to the constructor:
+
+ $p = new Getopt::Long::Parser
+ config => [...configuration options...];
+
+=head2 Thread Safety
+
+Getopt::Long is thread safe when using ithreads as of Perl 5.8. It is
+I<not> thread safe when using the older (experimental and now
+obsolete) threads implementation that was added to Perl 5.005.
+
+=head2 Documentation and help texts
+
+Getopt::Long encourages the use of Pod::Usage to produce help
+messages. For example:
+
+ use Getopt::Long;
+ use Pod::Usage;
+
+ my $man = 0;
+ my $help = 0;
+
+ GetOptions('help|?' => \$help, man => \$man) or pod2usage(2);
+ pod2usage(1) if $help;
+ pod2usage(-exitstatus => 0, -verbose => 2) if $man;
+
+ __END__
+
+ =head1 NAME
+
+ sample - Using Getopt::Long and Pod::Usage
+
+ =head1 SYNOPSIS
+
+ sample [options] [file ...]
+
+ Options:
+ -help brief help message
+ -man full documentation
+
+ =head1 OPTIONS
+
+ =over 8
+
+ =item B<-help>
+
+ Print a brief help message and exits.
+
+ =item B<-man>
+
+ Prints the manual page and exits.
+
+ =back
+
+ =head1 DESCRIPTION
+
+ B<This program> will read the given input file(s) and do something
+ useful with the contents thereof.
+
+ =cut
+
+See L<Pod::Usage> for details.
+
+=head2 Parsing options from an arbitrary array
+
+By default, GetOptions parses the options that are present in the
+global array C<@ARGV>. A special entry C<GetOptionsFromArray> can be
+used to parse options from an arbitrary array.
+
+ use Getopt::Long qw(GetOptionsFromArray);
+ $ret = GetOptionsFromArray(\@myopts, ...);
+
+When used like this, the global C<@ARGV> is not touched at all.
+
+The following two calls behave identically:
+
+ $ret = GetOptions( ... );
+ $ret = GetOptionsFromArray(\@ARGV, ... );
+
+=head2 Parsing options from an arbitrary string
+
+A special entry C<GetOptionsFromString> can be used to parse options
+from an arbitrary string.
+
+ use Getopt::Long qw(GetOptionsFromString);
+ $ret = GetOptionsFromString($string, ...);
+
+The contents of the string are split into arguments using a call to
+C<Text::ParseWords::shellwords>. As with C<GetOptionsFromArray>, the
+global C<@ARGV> is not touched.
+
+It is possible that, upon completion, not all arguments in the string
+have been processed. C<GetOptionsFromString> will, when called in list
+context, return both the return status and an array reference to any
+remaining arguments:
+
+ ($ret, $args) = GetOptionsFromString($string, ... );
+
+If any arguments remain, and C<GetOptionsFromString> was not called in
+list context, a message will be given and C<GetOptionsFromString> will
+return failure.
+
+=head2 Storing options values in a hash
+
+Sometimes, for example when there are a lot of options, having a
+separate variable for each of them can be cumbersome. GetOptions()
+supports, as an alternative mechanism, storing options values in a
+hash.
+
+To obtain this, a reference to a hash must be passed I<as the first
+argument> to GetOptions(). For each option that is specified on the
+command line, the option value will be stored in the hash with the
+option name as key. Options that are not actually used on the command
+line will not be put in the hash, on other words,
+C<exists($h{option})> (or defined()) can be used to test if an option
+was used. The drawback is that warnings will be issued if the program
+runs under C<use strict> and uses C<$h{option}> without testing with
+exists() or defined() first.
+
+ my %h = ();
+ GetOptions (\%h, 'length=i'); # will store in $h{length}
+
+For options that take list or hash values, it is necessary to indicate
+this by appending an C<@> or C<%> sign after the type:
+
+ GetOptions (\%h, 'colours=s@'); # will push to @{$h{colours}}
+
+To make things more complicated, the hash may contain references to
+the actual destinations, for example:
+
+ my $len = 0;
+ my %h = ('length' => \$len);
+ GetOptions (\%h, 'length=i'); # will store in $len
+
+This example is fully equivalent with:
+
+ my $len = 0;
+ GetOptions ('length=i' => \$len); # will store in $len
+
+Any mixture is possible. For example, the most frequently used options
+could be stored in variables while all other options get stored in the
+hash:
+
+ my $verbose = 0; # frequently referred
+ my $debug = 0; # frequently referred
+ my %h = ('verbose' => \$verbose, 'debug' => \$debug);
+ GetOptions (\%h, 'verbose', 'debug', 'filter', 'size=i');
+ if ( $verbose ) { ... }
+ if ( exists $h{filter} ) { ... option 'filter' was specified ... }
+
+=head2 Bundling
+
+With bundling it is possible to set several single-character options
+at once. For example if C<a>, C<v> and C<x> are all valid options,
+
+ -vax
+
+would set all three.
+
+Getopt::Long supports two levels of bundling. To enable bundling, a
+call to Getopt::Long::Configure is required.
+
+The first level of bundling can be enabled with:
+
+ Getopt::Long::Configure ("bundling");
+
+Configured this way, single-character options can be bundled but long
+options B<must> always start with a double dash C<--> to avoid
+ambiguity. For example, when C<vax>, C<a>, C<v> and C<x> are all valid
+options,
+
+ -vax
+
+would set C<a>, C<v> and C<x>, but
+
+ --vax
+
+would set C<vax>.
+
+The second level of bundling lifts this restriction. It can be enabled
+with:
+
+ Getopt::Long::Configure ("bundling_override");
+
+Now, C<-vax> would set the option C<vax>.
+
+When any level of bundling is enabled, option values may be inserted
+in the bundle. For example:
+
+ -h24w80
+
+is equivalent to
+
+ -h 24 -w 80
+
+When configured for bundling, single-character options are matched
+case sensitive while long options are matched case insensitive. To
+have the single-character options matched case insensitive as well,
+use:
+
+ Getopt::Long::Configure ("bundling", "ignorecase_always");
+
+It goes without saying that bundling can be quite confusing.
+
+=head2 The lonesome dash
+
+Normally, a lone dash C<-> on the command line will not be considered
+an option. Option processing will terminate (unless "permute" is
+configured) and the dash will be left in C<@ARGV>.
+
+It is possible to get special treatment for a lone dash. This can be
+achieved by adding an option specification with an empty name, for
+example:
+
+ GetOptions ('' => \$stdio);
+
+A lone dash on the command line will now be a legal option, and using
+it will set variable C<$stdio>.
+
+=head2 Argument callback
+
+A special option 'name' C<< <> >> can be used to designate a subroutine
+to handle non-option arguments. When GetOptions() encounters an
+argument that does not look like an option, it will immediately call this
+subroutine and passes it one parameter: the argument name. Well, actually
+it is an object that stringifies to the argument name.
+
+For example:
+
+ my $width = 80;
+ sub process { ... }
+ GetOptions ('width=i' => \$width, '<>' => \&process);
+
+When applied to the following command line:
+
+ arg1 --width=72 arg2 --width=60 arg3
+
+This will call
+C<process("arg1")> while C<$width> is C<80>,
+C<process("arg2")> while C<$width> is C<72>, and
+C<process("arg3")> while C<$width> is C<60>.
+
+This feature requires configuration option B<permute>, see section
+L<Configuring Getopt::Long>.
+
+=head1 Configuring Getopt::Long
+
+Getopt::Long can be configured by calling subroutine
+Getopt::Long::Configure(). This subroutine takes a list of quoted
+strings, each specifying a configuration option to be enabled, e.g.
+C<ignore_case>, or disabled, e.g. C<no_ignore_case>. Case does not
+matter. Multiple calls to Configure() are possible.
+
+Alternatively, as of version 2.24, the configuration options may be
+passed together with the C<use> statement:
+
+ use Getopt::Long qw(:config no_ignore_case bundling);
+
+The following options are available:
+
+=over 12
+
+=item default
+
+This option causes all configuration options to be reset to their
+default values.
+
+=item posix_default
+
+This option causes all configuration options to be reset to their
+default values as if the environment variable POSIXLY_CORRECT had
+been set.
+
+=item auto_abbrev
+
+Allow option names to be abbreviated to uniqueness.
+Default is enabled unless environment variable
+POSIXLY_CORRECT has been set, in which case C<auto_abbrev> is disabled.
+
+=item getopt_compat
+
+Allow C<+> to start options.
+Default is enabled unless environment variable
+POSIXLY_CORRECT has been set, in which case C<getopt_compat> is disabled.
+
+=item gnu_compat
+
+C<gnu_compat> controls whether C<--opt=> is allowed, and what it should
+do. Without C<gnu_compat>, C<--opt=> gives an error. With C<gnu_compat>,
+C<--opt=> will give option C<opt> and empty value.
+This is the way GNU getopt_long() does it.
+
+=item gnu_getopt
+
+This is a short way of setting C<gnu_compat> C<bundling> C<permute>
+C<no_getopt_compat>. With C<gnu_getopt>, command line handling should be
+fully compatible with GNU getopt_long().
+
+=item require_order
+
+Whether command line arguments are allowed to be mixed with options.
+Default is disabled unless environment variable
+POSIXLY_CORRECT has been set, in which case C<require_order> is enabled.
+
+See also C<permute>, which is the opposite of C<require_order>.
+
+=item permute
+
+Whether command line arguments are allowed to be mixed with options.
+Default is enabled unless environment variable
+POSIXLY_CORRECT has been set, in which case C<permute> is disabled.
+Note that C<permute> is the opposite of C<require_order>.
+
+If C<permute> is enabled, this means that
+
+ --foo arg1 --bar arg2 arg3
+
+is equivalent to
+
+ --foo --bar arg1 arg2 arg3
+
+If an argument callback routine is specified, C<@ARGV> will always be
+empty upon successful return of GetOptions() since all options have been
+processed. The only exception is when C<--> is used:
+
+ --foo arg1 --bar arg2 -- arg3
+
+This will call the callback routine for arg1 and arg2, and then
+terminate GetOptions() leaving C<"arg3"> in C<@ARGV>.
+
+If C<require_order> is enabled, options processing
+terminates when the first non-option is encountered.
+
+ --foo arg1 --bar arg2 arg3
+
+is equivalent to
+
+ --foo -- arg1 --bar arg2 arg3
+
+If C<pass_through> is also enabled, options processing will terminate
+at the first unrecognized option, or non-option, whichever comes
+first.
+
+=item bundling (default: disabled)
+
+Enabling this option will allow single-character options to be
+bundled. To distinguish bundles from long option names, long options
+I<must> be introduced with C<--> and bundles with C<->.
+
+Note that, if you have options C<a>, C<l> and C<all>, and
+auto_abbrev enabled, possible arguments and option settings are:
+
+ using argument sets option(s)
+ ------------------------------------------
+ -a, --a a
+ -l, --l l
+ -al, -la, -ala, -all,... a, l
+ --al, --all all
+
+The surprising part is that C<--a> sets option C<a> (due to auto
+completion), not C<all>.
+
+Note: disabling C<bundling> also disables C<bundling_override>.
+
+=item bundling_override (default: disabled)
+
+If C<bundling_override> is enabled, bundling is enabled as with
+C<bundling> but now long option names override option bundles.
+
+Note: disabling C<bundling_override> also disables C<bundling>.
+
+B<Note:> Using option bundling can easily lead to unexpected results,
+especially when mixing long options and bundles. Caveat emptor.
+
+=item ignore_case (default: enabled)
+
+If enabled, case is ignored when matching long option names. If,
+however, bundling is enabled as well, single character options will be
+treated case-sensitive.
+
+With C<ignore_case>, option specifications for options that only
+differ in case, e.g., C<"foo"> and C<"Foo">, will be flagged as
+duplicates.
+
+Note: disabling C<ignore_case> also disables C<ignore_case_always>.
+
+=item ignore_case_always (default: disabled)
+
+When bundling is in effect, case is ignored on single-character
+options also.
+
+Note: disabling C<ignore_case_always> also disables C<ignore_case>.
+
+=item auto_version (default:disabled)
+
+Automatically provide support for the B<--version> option if
+the application did not specify a handler for this option itself.
+
+Getopt::Long will provide a standard version message that includes the
+program name, its version (if $main::VERSION is defined), and the
+versions of Getopt::Long and Perl. The message will be written to
+standard output and processing will terminate.
+
+C<auto_version> will be enabled if the calling program explicitly
+specified a version number higher than 2.32 in the C<use> or
+C<require> statement.
+
+=item auto_help (default:disabled)
+
+Automatically provide support for the B<--help> and B<-?> options if
+the application did not specify a handler for this option itself.
+
+Getopt::Long will provide a help message using module L<Pod::Usage>. The
+message, derived from the SYNOPSIS POD section, will be written to
+standard output and processing will terminate.
+
+C<auto_help> will be enabled if the calling program explicitly
+specified a version number higher than 2.32 in the C<use> or
+C<require> statement.
+
+=item pass_through (default: disabled)
+
+Options that are unknown, ambiguous or supplied with an invalid option
+value are passed through in C<@ARGV> instead of being flagged as
+errors. This makes it possible to write wrapper scripts that process
+only part of the user supplied command line arguments, and pass the
+remaining options to some other program.
+
+If C<require_order> is enabled, options processing will terminate at
+the first unrecognized option, or non-option, whichever comes first.
+However, if C<permute> is enabled instead, results can become confusing.
+
+Note that the options terminator (default C<-->), if present, will
+also be passed through in C<@ARGV>.
+
+=item prefix
+
+The string that starts options. If a constant string is not
+sufficient, see C<prefix_pattern>.
+
+=item prefix_pattern
+
+A Perl pattern that identifies the strings that introduce options.
+Default is C<--|-|\+> unless environment variable
+POSIXLY_CORRECT has been set, in which case it is C<--|->.
+
+=item long_prefix_pattern
+
+A Perl pattern that allows the disambiguation of long and short
+prefixes. Default is C<-->.
+
+Typically you only need to set this if you are using nonstandard
+prefixes and want some or all of them to have the same semantics as
+'--' does under normal circumstances.
+
+For example, setting prefix_pattern to C<--|-|\+|\/> and
+long_prefix_pattern to C<--|\/> would add Win32 style argument
+handling.
+
+=item debug (default: disabled)
+
+Enable debugging output.
+
+=back
+
+=head1 Exportable Methods
+
+=over
+
+=item VersionMessage
+
+This subroutine provides a standard version message. Its argument can be:
+
+=over 4
+
+=item *
+
+A string containing the text of a message to print I<before> printing
+the standard message.
+
+=item *
+
+A numeric value corresponding to the desired exit status.
+
+=item *
+
+A reference to a hash.
+
+=back
+
+If more than one argument is given then the entire argument list is
+assumed to be a hash. If a hash is supplied (either as a reference or
+as a list) it should contain one or more elements with the following
+keys:
+
+=over 4
+
+=item C<-message>
+
+=item C<-msg>
+
+The text of a message to print immediately prior to printing the
+program's usage message.
+
+=item C<-exitval>
+
+The desired exit status to pass to the B<exit()> function.
+This should be an integer, or else the string "NOEXIT" to
+indicate that control should simply be returned without
+terminating the invoking process.
+
+=item C<-output>
+
+A reference to a filehandle, or the pathname of a file to which the
+usage message should be written. The default is C<\*STDERR> unless the
+exit value is less than 2 (in which case the default is C<\*STDOUT>).
+
+=back
+
+You cannot tie this routine directly to an option, e.g.:
+
+ GetOptions("version" => \&VersionMessage);
+
+Use this instead:
+
+ GetOptions("version" => sub { VersionMessage() });
+
+=item HelpMessage
+
+This subroutine produces a standard help message, derived from the
+program's POD section SYNOPSIS using L<Pod::Usage>. It takes the same
+arguments as VersionMessage(). In particular, you cannot tie it
+directly to an option, e.g.:
+
+ GetOptions("help" => \&HelpMessage);
+
+Use this instead:
+
+ GetOptions("help" => sub { HelpMessage() });
+
+=back
+
+=head1 Return values and Errors
+
+Configuration errors and errors in the option definitions are
+signalled using die() and will terminate the calling program unless
+the call to Getopt::Long::GetOptions() was embedded in C<eval { ...
+}>, or die() was trapped using C<$SIG{__DIE__}>.
+
+GetOptions returns true to indicate success.
+It returns false when the function detected one or more errors during
+option parsing. These errors are signalled using warn() and can be
+trapped with C<$SIG{__WARN__}>.
+
+=head1 Legacy
+
+The earliest development of C<newgetopt.pl> started in 1990, with Perl
+version 4. As a result, its development, and the development of
+Getopt::Long, has gone through several stages. Since backward
+compatibility has always been extremely important, the current version
+of Getopt::Long still supports a lot of constructs that nowadays are
+no longer necessary or otherwise unwanted. This section describes
+briefly some of these 'features'.
+
+=head2 Default destinations
+
+When no destination is specified for an option, GetOptions will store
+the resultant value in a global variable named C<opt_>I<XXX>, where
+I<XXX> is the primary name of this option. When a progam executes
+under C<use strict> (recommended), these variables must be
+pre-declared with our() or C<use vars>.
+
+ our $opt_length = 0;
+ GetOptions ('length=i'); # will store in $opt_length
+
+To yield a usable Perl variable, characters that are not part of the
+syntax for variables are translated to underscores. For example,
+C<--fpp-struct-return> will set the variable
+C<$opt_fpp_struct_return>. Note that this variable resides in the
+namespace of the calling program, not necessarily C<main>. For
+example:
+
+ GetOptions ("size=i", "sizes=i@");
+
+with command line "-size 10 -sizes 24 -sizes 48" will perform the
+equivalent of the assignments
+
+ $opt_size = 10;
+ @opt_sizes = (24, 48);
+
+=head2 Alternative option starters
+
+A string of alternative option starter characters may be passed as the
+first argument (or the first argument after a leading hash reference
+argument).
+
+ my $len = 0;
+ GetOptions ('/', 'length=i' => $len);
+
+Now the command line may look like:
+
+ /length 24 -- arg
+
+Note that to terminate options processing still requires a double dash
+C<-->.
+
+GetOptions() will not interpret a leading C<< "<>" >> as option starters
+if the next argument is a reference. To force C<< "<" >> and C<< ">" >> as
+option starters, use C<< "><" >>. Confusing? Well, B<using a starter
+argument is strongly deprecated> anyway.
+
+=head2 Configuration variables
+
+Previous versions of Getopt::Long used variables for the purpose of
+configuring. Although manipulating these variables still work, it is
+strongly encouraged to use the C<Configure> routine that was introduced
+in version 2.17. Besides, it is much easier.
+
+=head1 Tips and Techniques
+
+=head2 Pushing multiple values in a hash option
+
+Sometimes you want to combine the best of hashes and arrays. For
+example, the command line:
+
+ --list add=first --list add=second --list add=third
+
+where each successive 'list add' option will push the value of add
+into array ref $list->{'add'}. The result would be like
+
+ $list->{add} = [qw(first second third)];
+
+This can be accomplished with a destination routine:
+
+ GetOptions('list=s%' =>
+ sub { push(@{$list{$_[1]}}, $_[2]) });
+
+=head1 Troubleshooting
+
+=head2 GetOptions does not return a false result when an option is not supplied
+
+That's why they're called 'options'.
+
+=head2 GetOptions does not split the command line correctly
+
+The command line is not split by GetOptions, but by the command line
+interpreter (CLI). On Unix, this is the shell. On Windows, it is
+COMMAND.COM or CMD.EXE. Other operating systems have other CLIs.
+
+It is important to know that these CLIs may behave different when the
+command line contains special characters, in particular quotes or
+backslashes. For example, with Unix shells you can use single quotes
+(C<'>) and double quotes (C<">) to group words together. The following
+alternatives are equivalent on Unix:
+
+ "two words"
+ 'two words'
+ two\ words
+
+In case of doubt, insert the following statement in front of your Perl
+program:
+
+ print STDERR (join("|", at ARGV),"\n");
+
+to verify how your CLI passes the arguments to the program.
+
+=head2 Undefined subroutine &main::GetOptions called
+
+Are you running Windows, and did you write
+
+ use GetOpt::Long;
+
+(note the capital 'O')?
+
+=head2 How do I put a "-?" option into a Getopt::Long?
+
+You can only obtain this using an alias, and Getopt::Long of at least
+version 2.13.
+
+ use Getopt::Long;
+ GetOptions ("help|?"); # -help and -? will both set $opt_help
+
+=head1 AUTHOR
+
+Johan Vromans <jvromans at squirrel.nl>
+
+=head1 COPYRIGHT AND DISCLAIMER
+
+This program is Copyright 1990,2009 by Johan Vromans.
+This program is free software; you can redistribute it and/or
+modify it under the terms of the Perl Artistic License or the
+GNU General Public License as published by the Free Software
+Foundation; either version 2 of the License, 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.
+
+If you do not have a copy of the GNU General Public License write to
+the Free Software Foundation, Inc., 675 Mass Ave, Cambridge,
+MA 02139, USA.
+
+=cut
+
Modified: trunk/contrib/perl/lib/Getopt/Std.pm
===================================================================
--- trunk/contrib/perl/lib/Getopt/Std.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Getopt/Std.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -72,7 +72,7 @@
@ISA = qw(Exporter);
@EXPORT = qw(getopt getopts);
-$VERSION = '1.06';
+$VERSION = '1.07';
# uncomment the next line to disable 1.03-backward compatibility paranoia
# $STANDARD_HELP_VERSION = 1;
@@ -147,7 +147,7 @@
my $p = __PACKAGE__;
print {output_h()} <<EOM;
[Now continuing due to backward compatibility and excessive paranoia.
- See ``perldoc $p'' about \$$p\::STANDARD_HELP_VERSION.]
+ See 'perldoc $p' about \$$p\::STANDARD_HELP_VERSION.]
EOM
}
Property changes on: trunk/contrib/perl/lib/Getopt/Std.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/Getopt/Std.t
===================================================================
--- trunk/contrib/perl/lib/Getopt/Std.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Getopt/Std.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Getopt/Std.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/lib/Internals.t
===================================================================
--- trunk/contrib/perl/lib/Internals.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Internals.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -7,7 +7,7 @@
}
}
-use Test::More tests => 74;
+use Test::More tests => 82;
my $ro_err = qr/^Modification of a read-only value attempted/;
@@ -163,3 +163,28 @@
is( Internals::SvREFCNT(%foo), 1 );
is( Internals::SvREFCNT($foo{foo}), 1 );
+is( Internals::SvREFCNT($foo, 2), 2, "update ref count");
+is( Internals::SvREFCNT($foo), 2, "check we got the stored value");
+
+# the reference count is a U16, but was returned as an IV resulting in
+# different values between 32 and 64-bit builds
+my $big_count = 0xFFFFFFF0; # -16 32-bit signed
+is( Internals::SvREFCNT($foo, $big_count), $big_count,
+ "set reference count unsigned");
+is( Internals::SvREFCNT($foo), $big_count, "reference count unsigned");
+
+{
+ my @arr = Internals::SvREFCNT($foo, 1 );
+ is(scalar(@arr), 1, "SvREFCNT always returns only 1 item");
+}
+
+{
+ my $usage = 'Usage: Internals::SvREFCNT(SCALAR[, REFCOUNT])';
+ eval { &Internals::SvREFCNT();};
+ like($@, qr/\Q$usage\E/);
+ $foo = \"perl";
+ eval { &Internals::SvREFCNT($foo, 0..1);};
+ like($@, qr/\Q$usage\E/);
+ eval { &Internals::SvREFCNT($foo, 0..3);};
+ like($@, qr/\Q$usage\E/);
+}
Property changes on: trunk/contrib/perl/lib/Internals.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/lib/Memoize.pm (from rev 6437, vendor/perl/5.18.1/lib/Memoize.pm)
===================================================================
--- trunk/contrib/perl/lib/Memoize.pm (rev 0)
+++ trunk/contrib/perl/lib/Memoize.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,1047 @@
+# -*- mode: perl; perl-indent-level: 2; -*-
+# Memoize.pm
+#
+# Transparent memoization of idempotent functions
+#
+# Copyright 1998, 1999, 2000, 2001 M-J. Dominus.
+# You may copy and distribute this program under the
+# same terms as Perl itself. If in doubt,
+# write to mjd-perl-memoize+ at plover.com for a license.
+#
+# Version 1.01 $Revision: 1.1.1.2 $ $Date: 2011-02-17 12:49:38 $
+
+package Memoize;
+$VERSION = '1.01_03';
+
+# Compile-time constants
+sub SCALAR () { 0 }
+sub LIST () { 1 }
+
+
+#
+# Usage memoize(functionname/ref,
+# { NORMALIZER => coderef, INSTALL => name,
+# LIST_CACHE => descriptor, SCALAR_CACHE => descriptor }
+#
+
+use Carp;
+use Exporter;
+use vars qw($DEBUG);
+use Config; # Dammit.
+ at ISA = qw(Exporter);
+ at EXPORT = qw(memoize);
+ at EXPORT_OK = qw(unmemoize flush_cache);
+use strict;
+
+my %memotable;
+my %revmemotable;
+my @CONTEXT_TAGS = qw(MERGE TIE MEMORY FAULT HASH);
+my %IS_CACHE_TAG = map {($_ => 1)} @CONTEXT_TAGS;
+
+# Raise an error if the user tries to specify one of thesepackage as a
+# tie for LIST_CACHE
+
+my %scalar_only = map {($_ => 1)} qw(DB_File GDBM_File SDBM_File ODBM_File NDBM_File);
+
+sub memoize {
+ my $fn = shift;
+ my %options = @_;
+ my $options = \%options;
+
+ unless (defined($fn) &&
+ (ref $fn eq 'CODE' || ref $fn eq '')) {
+ croak "Usage: memoize 'functionname'|coderef {OPTIONS}";
+ }
+
+ my $uppack = caller; # TCL me Elmo!
+ my $cref; # Code reference to original function
+ my $name = (ref $fn ? undef : $fn);
+
+ # Convert function names to code references
+ $cref = &_make_cref($fn, $uppack);
+
+ # Locate function prototype, if any
+ my $proto = prototype $cref;
+ if (defined $proto) { $proto = "($proto)" }
+ else { $proto = "" }
+
+ # I would like to get rid of the eval, but there seems not to be any
+ # other way to set the prototype properly. The switch here for
+ # 'usethreads' works around a bug in threadperl having to do with
+ # magic goto. It would be better to fix the bug and use the magic
+ # goto version everywhere.
+ my $wrapper =
+ $Config{usethreads}
+ ? eval "sub $proto { &_memoizer(\$cref, \@_); }"
+ : eval "sub $proto { unshift \@_, \$cref; goto &_memoizer; }";
+
+ my $normalizer = $options{NORMALIZER};
+ if (defined $normalizer && ! ref $normalizer) {
+ $normalizer = _make_cref($normalizer, $uppack);
+ }
+
+ my $install_name;
+ if (defined $options->{INSTALL}) {
+ # INSTALL => name
+ $install_name = $options->{INSTALL};
+ } elsif (! exists $options->{INSTALL}) {
+ # No INSTALL option provided; use original name if possible
+ $install_name = $name;
+ } else {
+ # INSTALL => undef means don't install
+ }
+
+ if (defined $install_name) {
+ $install_name = $uppack . '::' . $install_name
+ unless $install_name =~ /::/;
+ no strict;
+ local($^W) = 0; # ``Subroutine $install_name redefined at ...''
+ *{$install_name} = $wrapper; # Install memoized version
+ }
+
+ $revmemotable{$wrapper} = "" . $cref; # Turn code ref into hash key
+
+ # These will be the caches
+ my %caches;
+ for my $context (qw(SCALAR LIST)) {
+ # suppress subsequent 'uninitialized value' warnings
+ $options{"${context}_CACHE"} ||= '';
+
+ my $cache_opt = $options{"${context}_CACHE"};
+ my @cache_opt_args;
+ if (ref $cache_opt) {
+ @cache_opt_args = @$cache_opt;
+ $cache_opt = shift @cache_opt_args;
+ }
+ if ($cache_opt eq 'FAULT') { # no cache
+ $caches{$context} = undef;
+ } elsif ($cache_opt eq 'HASH') { # user-supplied hash
+ my $cache = $cache_opt_args[0];
+ my $package = ref(tied %$cache);
+ if ($context eq 'LIST' && $scalar_only{$package}) {
+ croak("You can't use $package for LIST_CACHE because it can only store scalars");
+ }
+ $caches{$context} = $cache;
+ } elsif ($cache_opt eq '' || $IS_CACHE_TAG{$cache_opt}) {
+ # default is that we make up an in-memory hash
+ $caches{$context} = {};
+ # (this might get tied later, or MERGEd away)
+ } else {
+ croak "Unrecognized option to `${context}_CACHE': `$cache_opt' should be one of (@CONTEXT_TAGS); aborting";
+ }
+ }
+
+ # Perhaps I should check here that you didn't supply *both* merge
+ # options. But if you did, it does do something reasonable: They
+ # both get merged to the same in-memory hash.
+ if ($options{SCALAR_CACHE} eq 'MERGE') {
+ $caches{SCALAR} = $caches{LIST};
+ } elsif ($options{LIST_CACHE} eq 'MERGE') {
+ $caches{LIST} = $caches{SCALAR};
+ }
+
+ # Now deal with the TIE options
+ {
+ my $context;
+ foreach $context (qw(SCALAR LIST)) {
+ # If the relevant option wasn't `TIE', this call does nothing.
+ _my_tie($context, $caches{$context}, $options); # Croaks on failure
+ }
+ }
+
+ # We should put some more stuff in here eventually.
+ # We've been saying that for serveral versions now.
+ # And you know what? More stuff keeps going in!
+ $memotable{$cref} =
+ {
+ O => $options, # Short keys here for things we need to access frequently
+ N => $normalizer,
+ U => $cref,
+ MEMOIZED => $wrapper,
+ PACKAGE => $uppack,
+ NAME => $install_name,
+ S => $caches{SCALAR},
+ L => $caches{LIST},
+ };
+
+ $wrapper # Return just memoized version
+}
+
+# This function tries to load a tied hash class and tie the hash to it.
+sub _my_tie {
+ my ($context, $hash, $options) = @_;
+ my $fullopt = $options->{"${context}_CACHE"};
+
+ # We already checked to make sure that this works.
+ my $shortopt = (ref $fullopt) ? $fullopt->[0] : $fullopt;
+
+ return unless defined $shortopt && $shortopt eq 'TIE';
+ carp("TIE option to memoize() is deprecated; use HASH instead")
+ if $^W;
+
+ my @args = ref $fullopt ? @$fullopt : ();
+ shift @args;
+ my $module = shift @args;
+ if ($context eq 'LIST' && $scalar_only{$module}) {
+ croak("You can't use $module for LIST_CACHE because it can only store scalars");
+ }
+ my $modulefile = $module . '.pm';
+ $modulefile =~ s{::}{/}g;
+ eval { require $modulefile };
+ if ($@) {
+ croak "Memoize: Couldn't load hash tie module `$module': $@; aborting";
+ }
+ my $rc = (tie %$hash => $module, @args);
+ unless ($rc) {
+ croak "Memoize: Couldn't tie hash to `$module': $!; aborting";
+ }
+ 1;
+}
+
+sub flush_cache {
+ my $func = _make_cref($_[0], scalar caller);
+ my $info = $memotable{$revmemotable{$func}};
+ die "$func not memoized" unless defined $info;
+ for my $context (qw(S L)) {
+ my $cache = $info->{$context};
+ if (tied %$cache && ! (tied %$cache)->can('CLEAR')) {
+ my $funcname = defined($info->{NAME}) ?
+ "function $info->{NAME}" : "anonymous function $func";
+ my $context = {S => 'scalar', L => 'list'}->{$context};
+ croak "Tied cache hash for $context-context $funcname does not support flushing";
+ } else {
+ %$cache = ();
+ }
+ }
+}
+
+# This is the function that manages the memo tables.
+sub _memoizer {
+ my $orig = shift; # stringized version of ref to original func.
+ my $info = $memotable{$orig};
+ my $normalizer = $info->{N};
+
+ my $argstr;
+ my $context = (wantarray() ? LIST : SCALAR);
+
+ if (defined $normalizer) {
+ no strict;
+ if ($context == SCALAR) {
+ $argstr = &{$normalizer}(@_);
+ } elsif ($context == LIST) {
+ ($argstr) = &{$normalizer}(@_);
+ } else {
+ croak "Internal error \#41; context was neither LIST nor SCALAR\n";
+ }
+ } else { # Default normalizer
+ local $^W = 0;
+ $argstr = join chr(28), at _;
+ }
+
+ if ($context == SCALAR) {
+ my $cache = $info->{S};
+ _crap_out($info->{NAME}, 'scalar') unless $cache;
+ if (exists $cache->{$argstr}) {
+ return $cache->{$argstr};
+ } else {
+ my $val = &{$info->{U}}(@_);
+ # Scalars are considered to be lists; store appropriately
+ if ($info->{O}{SCALAR_CACHE} eq 'MERGE') {
+ $cache->{$argstr} = [$val];
+ } else {
+ $cache->{$argstr} = $val;
+ }
+ $val;
+ }
+ } elsif ($context == LIST) {
+ my $cache = $info->{L};
+ _crap_out($info->{NAME}, 'list') unless $cache;
+ if (exists $cache->{$argstr}) {
+ my $val = $cache->{$argstr};
+ # If LISTCONTEXT=>MERGE, then the function never returns lists,
+ # so we have a scalar value cached, so just return it straightaway:
+ return ($val) if $info->{O}{LIST_CACHE} eq 'MERGE';
+ # Maybe in a later version we can use a faster test.
+
+ # Otherwise, we cached an array containing the returned list:
+ return @$val;
+ } else {
+ my @q = &{$info->{U}}(@_);
+ $cache->{$argstr} = $info->{O}{LIST_CACHE} eq 'MERGE' ? $q [0] : \@q;
+ @q;
+ }
+ } else {
+ croak "Internal error \#42; context was neither LIST nor SCALAR\n";
+ }
+}
+
+sub unmemoize {
+ my $f = shift;
+ my $uppack = caller;
+ my $cref = _make_cref($f, $uppack);
+
+ unless (exists $revmemotable{$cref}) {
+ croak "Could not unmemoize function `$f', because it was not memoized to begin with";
+ }
+
+ my $tabent = $memotable{$revmemotable{$cref}};
+ unless (defined $tabent) {
+ croak "Could not figure out how to unmemoize function `$f'";
+ }
+ my $name = $tabent->{NAME};
+ if (defined $name) {
+ no strict;
+ local($^W) = 0; # ``Subroutine $install_name redefined at ...''
+ *{$name} = $tabent->{U}; # Replace with original function
+ }
+ undef $memotable{$revmemotable{$cref}};
+ undef $revmemotable{$cref};
+
+ # This removes the last reference to the (possibly tied) memo tables
+ # my ($old_function, $memotabs) = @{$tabent}{'U','S','L'};
+ # undef $tabent;
+
+# # Untie the memo tables if they were tied.
+# my $i;
+# for $i (0,1) {
+# if (tied %{$memotabs->[$i]}) {
+# warn "Untying hash #$i\n";
+# untie %{$memotabs->[$i]};
+# }
+# }
+
+ $tabent->{U};
+}
+
+sub _make_cref {
+ my $fn = shift;
+ my $uppack = shift;
+ my $cref;
+ my $name;
+
+ if (ref $fn eq 'CODE') {
+ $cref = $fn;
+ } elsif (! ref $fn) {
+ if ($fn =~ /::/) {
+ $name = $fn;
+ } else {
+ $name = $uppack . '::' . $fn;
+ }
+ no strict;
+ if (defined $name and !defined(&$name)) {
+ croak "Cannot operate on nonexistent function `$fn'";
+ }
+# $cref = \&$name;
+ $cref = *{$name}{CODE};
+ } else {
+ my $parent = (caller(1))[3]; # Function that called _make_cref
+ croak "Usage: argument 1 to `$parent' must be a function name or reference.\n";
+ }
+ $DEBUG and warn "${name}($fn) => $cref in _make_cref\n";
+ $cref;
+}
+
+sub _crap_out {
+ my ($funcname, $context) = @_;
+ if (defined $funcname) {
+ croak "Function `$funcname' called in forbidden $context context; faulting";
+ } else {
+ croak "Anonymous function called in forbidden $context context; faulting";
+ }
+}
+
+1;
+
+
+
+
+
+=head1 NAME
+
+Memoize - Make functions faster by trading space for time
+
+=head1 SYNOPSIS
+
+ # This is the documentation for Memoize 1.01
+ use Memoize;
+ memoize('slow_function');
+ slow_function(arguments); # Is faster than it was before
+
+
+This is normally all you need to know. However, many options are available:
+
+ memoize(function, options...);
+
+Options include:
+
+ NORMALIZER => function
+ INSTALL => new_name
+
+ SCALAR_CACHE => 'MEMORY'
+ SCALAR_CACHE => ['HASH', \%cache_hash ]
+ SCALAR_CACHE => 'FAULT'
+ SCALAR_CACHE => 'MERGE'
+
+ LIST_CACHE => 'MEMORY'
+ LIST_CACHE => ['HASH', \%cache_hash ]
+ LIST_CACHE => 'FAULT'
+ LIST_CACHE => 'MERGE'
+
+=head1 DESCRIPTION
+
+`Memoizing' a function makes it faster by trading space for time. It
+does this by caching the return values of the function in a table.
+If you call the function again with the same arguments, C<memoize>
+jumps in and gives you the value out of the table, instead of letting
+the function compute the value all over again.
+
+Here is an extreme example. Consider the Fibonacci sequence, defined
+by the following function:
+
+ # Compute Fibonacci numbers
+ sub fib {
+ my $n = shift;
+ return $n if $n < 2;
+ fib($n-1) + fib($n-2);
+ }
+
+This function is very slow. Why? To compute fib(14), it first wants
+to compute fib(13) and fib(12), and add the results. But to compute
+fib(13), it first has to compute fib(12) and fib(11), and then it
+comes back and computes fib(12) all over again even though the answer
+is the same. And both of the times that it wants to compute fib(12),
+it has to compute fib(11) from scratch, and then it has to do it
+again each time it wants to compute fib(13). This function does so
+much recomputing of old results that it takes a really long time to
+run---fib(14) makes 1,200 extra recursive calls to itself, to compute
+and recompute things that it already computed.
+
+This function is a good candidate for memoization. If you memoize the
+`fib' function above, it will compute fib(14) exactly once, the first
+time it needs to, and then save the result in a table. Then if you
+ask for fib(14) again, it gives you the result out of the table.
+While computing fib(14), instead of computing fib(12) twice, it does
+it once; the second time it needs the value it gets it from the table.
+It doesn't compute fib(11) four times; it computes it once, getting it
+from the table the next three times. Instead of making 1,200
+recursive calls to `fib', it makes 15. This makes the function about
+150 times faster.
+
+You could do the memoization yourself, by rewriting the function, like
+this:
+
+ # Compute Fibonacci numbers, memoized version
+ { my @fib;
+ sub fib {
+ my $n = shift;
+ return $fib[$n] if defined $fib[$n];
+ return $fib[$n] = $n if $n < 2;
+ $fib[$n] = fib($n-1) + fib($n-2);
+ }
+ }
+
+Or you could use this module, like this:
+
+ use Memoize;
+ memoize('fib');
+
+ # Rest of the fib function just like the original version.
+
+This makes it easy to turn memoizing on and off.
+
+Here's an even simpler example: I wrote a simple ray tracer; the
+program would look in a certain direction, figure out what it was
+looking at, and then convert the `color' value (typically a string
+like `red') of that object to a red, green, and blue pixel value, like
+this:
+
+ for ($direction = 0; $direction < 300; $direction++) {
+ # Figure out which object is in direction $direction
+ $color = $object->{color};
+ ($r, $g, $b) = @{&ColorToRGB($color)};
+ ...
+ }
+
+Since there are relatively few objects in a picture, there are only a
+few colors, which get looked up over and over again. Memoizing
+C<ColorToRGB> sped up the program by several percent.
+
+=head1 DETAILS
+
+This module exports exactly one function, C<memoize>. The rest of the
+functions in this package are None of Your Business.
+
+You should say
+
+ memoize(function)
+
+where C<function> is the name of the function you want to memoize, or
+a reference to it. C<memoize> returns a reference to the new,
+memoized version of the function, or C<undef> on a non-fatal error.
+At present, there are no non-fatal errors, but there might be some in
+the future.
+
+If C<function> was the name of a function, then C<memoize> hides the
+old version and installs the new memoized version under the old name,
+so that C<&function(...)> actually invokes the memoized version.
+
+=head1 OPTIONS
+
+There are some optional options you can pass to C<memoize> to change
+the way it behaves a little. To supply options, invoke C<memoize>
+like this:
+
+ memoize(function, NORMALIZER => function,
+ INSTALL => newname,
+ SCALAR_CACHE => option,
+ LIST_CACHE => option
+ );
+
+Each of these options is optional; you can include some, all, or none
+of them.
+
+=head2 INSTALL
+
+If you supply a function name with C<INSTALL>, memoize will install
+the new, memoized version of the function under the name you give.
+For example,
+
+ memoize('fib', INSTALL => 'fastfib')
+
+installs the memoized version of C<fib> as C<fastfib>; without the
+C<INSTALL> option it would have replaced the old C<fib> with the
+memoized version.
+
+To prevent C<memoize> from installing the memoized version anywhere, use
+C<INSTALL =E<gt> undef>.
+
+=head2 NORMALIZER
+
+Suppose your function looks like this:
+
+ # Typical call: f('aha!', A => 11, B => 12);
+ sub f {
+ my $a = shift;
+ my %hash = @_;
+ $hash{B} ||= 2; # B defaults to 2
+ $hash{C} ||= 7; # C defaults to 7
+
+ # Do something with $a, %hash
+ }
+
+Now, the following calls to your function are all completely equivalent:
+
+ f(OUCH);
+ f(OUCH, B => 2);
+ f(OUCH, C => 7);
+ f(OUCH, B => 2, C => 7);
+ f(OUCH, C => 7, B => 2);
+ (etc.)
+
+However, unless you tell C<Memoize> that these calls are equivalent,
+it will not know that, and it will compute the values for these
+invocations of your function separately, and store them separately.
+
+To prevent this, supply a C<NORMALIZER> function that turns the
+program arguments into a string in a way that equivalent arguments
+turn into the same string. A C<NORMALIZER> function for C<f> above
+might look like this:
+
+ sub normalize_f {
+ my $a = shift;
+ my %hash = @_;
+ $hash{B} ||= 2;
+ $hash{C} ||= 7;
+
+ join(',', $a, map ($_ => $hash{$_}) sort keys %hash);
+ }
+
+Each of the argument lists above comes out of the C<normalize_f>
+function looking exactly the same, like this:
+
+ OUCH,B,2,C,7
+
+You would tell C<Memoize> to use this normalizer this way:
+
+ memoize('f', NORMALIZER => 'normalize_f');
+
+C<memoize> knows that if the normalized version of the arguments is
+the same for two argument lists, then it can safely look up the value
+that it computed for one argument list and return it as the result of
+calling the function with the other argument list, even if the
+argument lists look different.
+
+The default normalizer just concatenates the arguments with character
+28 in between. (In ASCII, this is called FS or control-\.) This
+always works correctly for functions with only one string argument,
+and also when the arguments never contain character 28. However, it
+can confuse certain argument lists:
+
+ normalizer("a\034", "b")
+ normalizer("a", "\034b")
+ normalizer("a\034\034b")
+
+for example.
+
+Since hash keys are strings, the default normalizer will not
+distinguish between C<undef> and the empty string. It also won't work
+when the function's arguments are references. For example, consider a
+function C<g> which gets two arguments: A number, and a reference to
+an array of numbers:
+
+ g(13, [1,2,3,4,5,6,7]);
+
+The default normalizer will turn this into something like
+C<"13\034ARRAY(0x436c1f)">. That would be all right, except that a
+subsequent array of numbers might be stored at a different location
+even though it contains the same data. If this happens, C<Memoize>
+will think that the arguments are different, even though they are
+equivalent. In this case, a normalizer like this is appropriate:
+
+ sub normalize { join ' ', $_[0], @{$_[1]} }
+
+For the example above, this produces the key "13 1 2 3 4 5 6 7".
+
+Another use for normalizers is when the function depends on data other
+than those in its arguments. Suppose you have a function which
+returns a value which depends on the current hour of the day:
+
+ sub on_duty {
+ my ($problem_type) = @_;
+ my $hour = (localtime)[2];
+ open my $fh, "$DIR/$problem_type" or die...;
+ my $line;
+ while ($hour-- > 0)
+ $line = <$fh>;
+ }
+ return $line;
+ }
+
+At 10:23, this function generates the 10th line of a data file; at
+3:45 PM it generates the 15th line instead. By default, C<Memoize>
+will only see the $problem_type argument. To fix this, include the
+current hour in the normalizer:
+
+ sub normalize { join ' ', (localtime)[2], @_ }
+
+The calling context of the function (scalar or list context) is
+propagated to the normalizer. This means that if the memoized
+function will treat its arguments differently in list context than it
+would in scalar context, you can have the normalizer function select
+its behavior based on the results of C<wantarray>. Even if called in
+a list context, a normalizer should still return a single string.
+
+=head2 C<SCALAR_CACHE>, C<LIST_CACHE>
+
+Normally, C<Memoize> caches your function's return values into an
+ordinary Perl hash variable. However, you might like to have the
+values cached on the disk, so that they persist from one run of your
+program to the next, or you might like to associate some other
+interesting semantics with the cached values.
+
+There's a slight complication under the hood of C<Memoize>: There are
+actually I<two> caches, one for scalar values and one for list values.
+When your function is called in scalar context, its return value is
+cached in one hash, and when your function is called in list context,
+its value is cached in the other hash. You can control the caching
+behavior of both contexts independently with these options.
+
+The argument to C<LIST_CACHE> or C<SCALAR_CACHE> must either be one of
+the following four strings:
+
+ MEMORY
+ FAULT
+ MERGE
+ HASH
+
+or else it must be a reference to a list whose first element is one of
+these four strings, such as C<[HASH, arguments...]>.
+
+=over 4
+
+=item C<MEMORY>
+
+C<MEMORY> means that return values from the function will be cached in
+an ordinary Perl hash variable. The hash variable will not persist
+after the program exits. This is the default.
+
+=item C<HASH>
+
+C<HASH> allows you to specify that a particular hash that you supply
+will be used as the cache. You can tie this hash beforehand to give
+it any behavior you want.
+
+A tied hash can have any semantics at all. It is typically tied to an
+on-disk database, so that cached values are stored in the database and
+retrieved from it again when needed, and the disk file typically
+persists after your program has exited. See C<perltie> for more
+complete details about C<tie>.
+
+A typical example is:
+
+ use DB_File;
+ tie my %cache => 'DB_File', $filename, O_RDWR|O_CREAT, 0666;
+ memoize 'function', SCALAR_CACHE => [HASH => \%cache];
+
+This has the effect of storing the cache in a C<DB_File> database
+whose name is in C<$filename>. The cache will persist after the
+program has exited. Next time the program runs, it will find the
+cache already populated from the previous run of the program. Or you
+can forcibly populate the cache by constructing a batch program that
+runs in the background and populates the cache file. Then when you
+come to run your real program the memoized function will be fast
+because all its results have been precomputed.
+
+=item C<TIE>
+
+This option is no longer supported. It is still documented only to
+aid in the debugging of old programs that use it. Old programs should
+be converted to use the C<HASH> option instead.
+
+ memoize ... [TIE, PACKAGE, ARGS...]
+
+is merely a shortcut for
+
+ require PACKAGE;
+ { my %cache;
+ tie %cache, PACKAGE, ARGS...;
+ }
+ memoize ... [HASH => \%cache];
+
+=item C<FAULT>
+
+C<FAULT> means that you never expect to call the function in scalar
+(or list) context, and that if C<Memoize> detects such a call, it
+should abort the program. The error message is one of
+
+ `foo' function called in forbidden list context at line ...
+ `foo' function called in forbidden scalar context at line ...
+
+=item C<MERGE>
+
+C<MERGE> normally means the function does not distinguish between list
+and sclar context, and that return values in both contexts should be
+stored together. C<LIST_CACHE =E<gt> MERGE> means that list context
+return values should be stored in the same hash that is used for
+scalar context returns, and C<SCALAR_CACHE =E<gt> MERGE> means the
+same, mutatis mutandis. It is an error to specify C<MERGE> for both,
+but it probably does something useful.
+
+Consider this function:
+
+ sub pi { 3; }
+
+Normally, the following code will result in two calls to C<pi>:
+
+ $x = pi();
+ ($y) = pi();
+ $z = pi();
+
+The first call caches the value C<3> in the scalar cache; the second
+caches the list C<(3)> in the list cache. The third call doesn't call
+the real C<pi> function; it gets the value from the scalar cache.
+
+Obviously, the second call to C<pi> is a waste of time, and storing
+its return value is a waste of space. Specifying C<LIST_CACHE =E<gt>
+MERGE> will make C<memoize> use the same cache for scalar and list
+context return values, so that the second call uses the scalar cache
+that was populated by the first call. C<pi> ends up being called only
+once, and both subsequent calls return C<3> from the cache, regardless
+of the calling context.
+
+Another use for C<MERGE> is when you want both kinds of return values
+stored in the same disk file; this saves you from having to deal with
+two disk files instead of one. You can use a normalizer function to
+keep the two sets of return values separate. For example:
+
+ tie my %cache => 'MLDBM', 'DB_File', $filename, ...;
+
+ memoize 'myfunc',
+ NORMALIZER => 'n',
+ SCALAR_CACHE => [HASH => \%cache],
+ LIST_CACHE => MERGE,
+ ;
+
+ sub n {
+ my $context = wantarray() ? 'L' : 'S';
+ # ... now compute the hash key from the arguments ...
+ $hashkey = "$context:$hashkey";
+ }
+
+This normalizer function will store scalar context return values in
+the disk file under keys that begin with C<S:>, and list context
+return values under keys that begin with C<L:>.
+
+=back
+
+=head1 OTHER FACILITIES
+
+=head2 C<unmemoize>
+
+There's an C<unmemoize> function that you can import if you want to.
+Why would you want to? Here's an example: Suppose you have your cache
+tied to a DBM file, and you want to make sure that the cache is
+written out to disk if someone interrupts the program. If the program
+exits normally, this will happen anyway, but if someone types
+control-C or something then the program will terminate immediately
+without synchronizing the database. So what you can do instead is
+
+ $SIG{INT} = sub { unmemoize 'function' };
+
+C<unmemoize> accepts a reference to, or the name of a previously
+memoized function, and undoes whatever it did to provide the memoized
+version in the first place, including making the name refer to the
+unmemoized version if appropriate. It returns a reference to the
+unmemoized version of the function.
+
+If you ask it to unmemoize a function that was never memoized, it
+croaks.
+
+=head2 C<flush_cache>
+
+C<flush_cache(function)> will flush out the caches, discarding I<all>
+the cached data. The argument may be a function name or a reference
+to a function. For finer control over when data is discarded or
+expired, see the documentation for C<Memoize::Expire>, included in
+this package.
+
+Note that if the cache is a tied hash, C<flush_cache> will attempt to
+invoke the C<CLEAR> method on the hash. If there is no C<CLEAR>
+method, this will cause a run-time error.
+
+An alternative approach to cache flushing is to use the C<HASH> option
+(see above) to request that C<Memoize> use a particular hash variable
+as its cache. Then you can examine or modify the hash at any time in
+any way you desire. You may flush the cache by using C<%hash = ()>.
+
+=head1 CAVEATS
+
+Memoization is not a cure-all:
+
+=over 4
+
+=item *
+
+Do not memoize a function whose behavior depends on program
+state other than its own arguments, such as global variables, the time
+of day, or file input. These functions will not produce correct
+results when memoized. For a particularly easy example:
+
+ sub f {
+ time;
+ }
+
+This function takes no arguments, and as far as C<Memoize> is
+concerned, it always returns the same result. C<Memoize> is wrong, of
+course, and the memoized version of this function will call C<time> once
+to get the current time, and it will return that same time
+every time you call it after that.
+
+=item *
+
+Do not memoize a function with side effects.
+
+ sub f {
+ my ($a, $b) = @_;
+ my $s = $a + $b;
+ print "$a + $b = $s.\n";
+ }
+
+This function accepts two arguments, adds them, and prints their sum.
+Its return value is the numuber of characters it printed, but you
+probably didn't care about that. But C<Memoize> doesn't understand
+that. If you memoize this function, you will get the result you
+expect the first time you ask it to print the sum of 2 and 3, but
+subsequent calls will return 1 (the return value of
+C<print>) without actually printing anything.
+
+=item *
+
+Do not memoize a function that returns a data structure that is
+modified by its caller.
+
+Consider these functions: C<getusers> returns a list of users somehow,
+and then C<main> throws away the first user on the list and prints the
+rest:
+
+ sub main {
+ my $userlist = getusers();
+ shift @$userlist;
+ foreach $u (@$userlist) {
+ print "User $u\n";
+ }
+ }
+
+ sub getusers {
+ my @users;
+ # Do something to get a list of users;
+ \@users; # Return reference to list.
+ }
+
+If you memoize C<getusers> here, it will work right exactly once. The
+reference to the users list will be stored in the memo table. C<main>
+will discard the first element from the referenced list. The next
+time you invoke C<main>, C<Memoize> will not call C<getusers>; it will
+just return the same reference to the same list it got last time. But
+this time the list has already had its head removed; C<main> will
+erroneously remove another element from it. The list will get shorter
+and shorter every time you call C<main>.
+
+Similarly, this:
+
+ $u1 = getusers();
+ $u2 = getusers();
+ pop @$u1;
+
+will modify $u2 as well as $u1, because both variables are references
+to the same array. Had C<getusers> not been memoized, $u1 and $u2
+would have referred to different arrays.
+
+=item *
+
+Do not memoize a very simple function.
+
+Recently someone mentioned to me that the Memoize module made his
+program run slower instead of faster. It turned out that he was
+memoizing the following function:
+
+ sub square {
+ $_[0] * $_[0];
+ }
+
+I pointed out that C<Memoize> uses a hash, and that looking up a
+number in the hash is necessarily going to take a lot longer than a
+single multiplication. There really is no way to speed up the
+C<square> function.
+
+Memoization is not magical.
+
+=back
+
+=head1 PERSISTENT CACHE SUPPORT
+
+You can tie the cache tables to any sort of tied hash that you want
+to, as long as it supports C<TIEHASH>, C<FETCH>, C<STORE>, and
+C<EXISTS>. For example,
+
+ tie my %cache => 'GDBM_File', $filename, O_RDWR|O_CREAT, 0666;
+ memoize 'function', SCALAR_CACHE => [HASH => \%cache];
+
+works just fine. For some storage methods, you need a little glue.
+
+C<SDBM_File> doesn't supply an C<EXISTS> method, so included in this
+package is a glue module called C<Memoize::SDBM_File> which does
+provide one. Use this instead of plain C<SDBM_File> to store your
+cache table on disk in an C<SDBM_File> database:
+
+ tie my %cache => 'Memoize::SDBM_File', $filename, O_RDWR|O_CREAT, 0666;
+ memoize 'function', SCALAR_CACHE => [HASH => \%cache];
+
+C<NDBM_File> has the same problem and the same solution. (Use
+C<Memoize::NDBM_File instead of plain NDBM_File.>)
+
+C<Storable> isn't a tied hash class at all. You can use it to store a
+hash to disk and retrieve it again, but you can't modify the hash while
+it's on the disk. So if you want to store your cache table in a
+C<Storable> database, use C<Memoize::Storable>, which puts a hashlike
+front-end onto C<Storable>. The hash table is actually kept in
+memory, and is loaded from your C<Storable> file at the time you
+memoize the function, and stored back at the time you unmemoize the
+function (or when your program exits):
+
+ tie my %cache => 'Memoize::Storable', $filename;
+ memoize 'function', SCALAR_CACHE => [HASH => \%cache];
+
+ tie my %cache => 'Memoize::Storable', $filename, 'nstore';
+ memoize 'function', SCALAR_CACHE => [HASH => \%cache];
+
+Include the `nstore' option to have the C<Storable> database written
+in `network order'. (See L<Storable> for more details about this.)
+
+The C<flush_cache()> function will raise a run-time error unless the
+tied package provides a C<CLEAR> method.
+
+=head1 EXPIRATION SUPPORT
+
+See Memoize::Expire, which is a plug-in module that adds expiration
+functionality to Memoize. If you don't like the kinds of policies
+that Memoize::Expire implements, it is easy to write your own plug-in
+module to implement whatever policy you desire. Memoize comes with
+several examples. An expiration manager that implements a LRU policy
+is available on CPAN as Memoize::ExpireLRU.
+
+=head1 BUGS
+
+The test suite is much better, but always needs improvement.
+
+There is some problem with the way C<goto &f> works under threaded
+Perl, perhaps because of the lexical scoping of C<@_>. This is a bug
+in Perl, and until it is resolved, memoized functions will see a
+slightly different C<caller()> and will perform a little more slowly
+on threaded perls than unthreaded perls.
+
+Some versions of C<DB_File> won't let you store data under a key of
+length 0. That means that if you have a function C<f> which you
+memoized and the cache is in a C<DB_File> database, then the value of
+C<f()> (C<f> called with no arguments) will not be memoized. If this
+is a big problem, you can supply a normalizer function that prepends
+C<"x"> to every key.
+
+=head1 MAILING LIST
+
+To join a very low-traffic mailing list for announcements about
+C<Memoize>, send an empty note to C<mjd-perl-memoize-request at plover.com>.
+
+=head1 AUTHOR
+
+Mark-Jason Dominus (C<mjd-perl-memoize+ at plover.com>), Plover Systems co.
+
+See the C<Memoize.pm> Page at http://www.plover.com/~mjd/perl/Memoize/
+for news and upgrades. Near this page, at
+http://www.plover.com/~mjd/perl/MiniMemoize/ there is an article about
+memoization and about the internals of Memoize that appeared in The
+Perl Journal, issue #13. (This article is also included in the
+Memoize distribution as `article.html'.)
+
+The author's book I<Higher Order Perl> (2005, ISBN 1558607013, published
+by Morgan Kaufmann) discusses memoization (and many other fascinating
+topics) in tremendous detail. It will also be available on-line for free.
+For more information, visit http://perl.plover.com/book/ .
+
+To join a mailing list for announcements about C<Memoize>, send an
+empty message to C<mjd-perl-memoize-request at plover.com>. This mailing
+list is for announcements only and has extremely low traffic---about
+two messages per year.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 1998, 1999, 2000, 2001 by Mark Jason Dominus
+
+This library is free software; you may redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=head1 THANK YOU
+
+Many thanks to Jonathan Roy for bug reports and suggestions, to
+Michael Schwern for other bug reports and patches, to Mike Cariaso for
+helping me to figure out the Right Thing to Do About Expiration, to
+Joshua Gerth, Joshua Chamas, Jonathan Roy (again), Mark D. Anderson,
+and Andrew Johnson for more suggestions about expiration, to Brent
+Powers for the Memoize::ExpireLRU module, to Ariel Scolnicov for
+delightful messages about the Fibonacci function, to Dion Almaer for
+thought-provoking suggestions about the default normalizer, to Walt
+Mankowski and Kurt Starsinic for much help investigating problems
+under threaded Perl, to Alex Dudkevich for reporting the bug in
+prototyped functions and for checking my patch, to Tony Bass for many
+helpful suggestions, to Jonathan Roy (again) for finding a use for
+C<unmemoize()>, to Philippe Verdret for enlightening discussion of
+C<Hook::PrePostCall>, to Nat Torkington for advice I ignored, to Chris
+Nandor for portability advice, to Randal Schwartz for suggesting the
+'C<flush_cache> function, and to Jenda Krynicky for being a light in
+the world.
+
+Special thanks to Jarkko Hietaniemi, the 5.8.0 pumpking, for including
+this module in the core and for his patient and helpful guidance
+during the integration process.
+
+=cut
Copied: trunk/contrib/perl/lib/NEXT.pm (from rev 6437, vendor/perl/5.18.1/lib/NEXT.pm)
===================================================================
--- trunk/contrib/perl/lib/NEXT.pm (rev 0)
+++ trunk/contrib/perl/lib/NEXT.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,563 @@
+package NEXT;
+$VERSION = '0.64';
+use Carp;
+use strict;
+use overload ();
+
+sub NEXT::ELSEWHERE::ancestors
+{
+ my @inlist = shift;
+ my @outlist = ();
+ while (my $next = shift @inlist) {
+ push @outlist, $next;
+ no strict 'refs';
+ unshift @inlist, @{"$outlist[-1]::ISA"};
+ }
+ return @outlist;
+}
+
+sub NEXT::ELSEWHERE::ordered_ancestors
+{
+ my @inlist = shift;
+ my @outlist = ();
+ while (my $next = shift @inlist) {
+ push @outlist, $next;
+ no strict 'refs';
+ push @inlist, @{"$outlist[-1]::ISA"};
+ }
+ return sort { $a->isa($b) ? -1
+ : $b->isa($a) ? +1
+ : 0 } @outlist;
+}
+
+sub NEXT::ELSEWHERE::buildAUTOLOAD
+{
+ my $autoload_name = caller() . '::AUTOLOAD';
+
+ no strict 'refs';
+ *{$autoload_name} = sub {
+ my ($self) = @_;
+ my $depth = 1;
+ until (((caller($depth))[3]||q{}) !~ /^\(eval\)$/) { $depth++ }
+ my $caller = (caller($depth))[3];
+ my $wanted = $NEXT::AUTOLOAD || $autoload_name;
+ undef $NEXT::AUTOLOAD;
+ my ($caller_class, $caller_method) = do { $caller =~ m{(.*)::(.*)}g };
+ my ($wanted_class, $wanted_method) = do { $wanted =~ m{(.*)::(.*)}g };
+ croak "Can't call $wanted from $caller"
+ unless $caller_method eq $wanted_method;
+
+ my $key = ref $self && overload::Overloaded($self)
+ ? overload::StrVal($self) : $self;
+
+ local ($NEXT::NEXT{$key,$wanted_method}, $NEXT::SEEN) =
+ ($NEXT::NEXT{$key,$wanted_method}, $NEXT::SEEN);
+
+ unless ($NEXT::NEXT{$key,$wanted_method}) {
+ my @forebears =
+ NEXT::ELSEWHERE::ancestors ref $self || $self,
+ $wanted_class;
+ while (@forebears) {
+ last if shift @forebears eq $caller_class
+ }
+ no strict 'refs';
+ @{$NEXT::NEXT{$key,$wanted_method}} =
+ map {
+ my $stash = \%{"${_}::"};
+ ($stash->{$caller_method} && (*{$stash->{$caller_method}}{CODE}))
+ ? *{$stash->{$caller_method}}{CODE}
+ : () } @forebears
+ unless $wanted_method eq 'AUTOLOAD';
+ @{$NEXT::NEXT{$key,$wanted_method}} =
+ map {
+ my $stash = \%{"${_}::"};
+ ($stash->{AUTOLOAD} && (*{$stash->{AUTOLOAD}}{CODE}))
+ ? "${_}::AUTOLOAD"
+ : () } @forebears
+ unless @{$NEXT::NEXT{$key,$wanted_method}||[]};
+ $NEXT::SEEN->{$key,*{$caller}{CODE}}++;
+ }
+ my $call_method = shift @{$NEXT::NEXT{$key,$wanted_method}};
+ while (do { $wanted_class =~ /^NEXT\b.*\b(UNSEEN|DISTINCT)\b/ }
+ && defined $call_method
+ && $NEXT::SEEN->{$key,$call_method}++) {
+ $call_method = shift @{$NEXT::NEXT{$key,$wanted_method}};
+ }
+ unless (defined $call_method) {
+ return unless do { $wanted_class =~ /^NEXT:.*:ACTUAL/ };
+ (local $Carp::CarpLevel)++;
+ croak qq(Can't locate object method "$wanted_method" ),
+ qq(via package "$caller_class");
+ };
+ return $self->$call_method(@_[1..$#_]) if ref $call_method eq 'CODE';
+ no strict 'refs';
+ do { ($wanted_method=${$caller_class."::AUTOLOAD"}) =~ s/.*::// }
+ if $wanted_method eq 'AUTOLOAD';
+ $$call_method = $caller_class."::NEXT::".$wanted_method;
+ return $call_method->(@_);
+ };
+}
+
+no strict 'vars';
+package NEXT; NEXT::ELSEWHERE::buildAUTOLOAD();
+package NEXT::UNSEEN; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD();
+package NEXT::DISTINCT; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD();
+package NEXT::ACTUAL; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD();
+package NEXT::ACTUAL::UNSEEN; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD();
+package NEXT::ACTUAL::DISTINCT; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD();
+package NEXT::UNSEEN::ACTUAL; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD();
+package NEXT::DISTINCT::ACTUAL; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD();
+
+package EVERY;
+
+sub EVERY::ELSEWHERE::buildAUTOLOAD {
+ my $autoload_name = caller() . '::AUTOLOAD';
+
+ no strict 'refs';
+ *{$autoload_name} = sub {
+ my ($self) = @_;
+ my $depth = 1;
+ until (((caller($depth))[3]||q{}) !~ /^\(eval\)$/) { $depth++ }
+ my $caller = (caller($depth))[3];
+ my $wanted = $EVERY::AUTOLOAD || $autoload_name;
+ undef $EVERY::AUTOLOAD;
+ my ($wanted_class, $wanted_method) = do { $wanted =~ m{(.*)::(.*)}g };
+
+ my $key = ref($self) && overload::Overloaded($self)
+ ? overload::StrVal($self) : $self;
+
+ local $NEXT::ALREADY_IN_EVERY{$key,$wanted_method} =
+ $NEXT::ALREADY_IN_EVERY{$key,$wanted_method};
+
+ return if $NEXT::ALREADY_IN_EVERY{$key,$wanted_method}++;
+
+ my @forebears = NEXT::ELSEWHERE::ordered_ancestors ref $self || $self,
+ $wanted_class;
+ @forebears = reverse @forebears if do { $wanted_class =~ /\bLAST\b/ };
+ no strict 'refs';
+ my %seen;
+ my @every = map { my $sub = "${_}::$wanted_method";
+ !*{$sub}{CODE} || $seen{$sub}++ ? () : $sub
+ } @forebears
+ unless $wanted_method eq 'AUTOLOAD';
+
+ my $want = wantarray;
+ if (@every) {
+ if ($want) {
+ return map {($_, [$self->$_(@_[1..$#_])])} @every;
+ }
+ elsif (defined $want) {
+ return { map {($_, scalar($self->$_(@_[1..$#_])))}
+ @every
+ };
+ }
+ else {
+ $self->$_(@_[1..$#_]) for @every;
+ return;
+ }
+ }
+
+ @every = map { my $sub = "${_}::AUTOLOAD";
+ !*{$sub}{CODE} || $seen{$sub}++ ? () : "${_}::AUTOLOAD"
+ } @forebears;
+ if ($want) {
+ return map { $$_ = ref($self)."::EVERY::".$wanted_method;
+ ($_, [$self->$_(@_[1..$#_])]);
+ } @every;
+ }
+ elsif (defined $want) {
+ return { map { $$_ = ref($self)."::EVERY::".$wanted_method;
+ ($_, scalar($self->$_(@_[1..$#_])))
+ } @every
+ };
+ }
+ else {
+ for (@every) {
+ $$_ = ref($self)."::EVERY::".$wanted_method;
+ $self->$_(@_[1..$#_]);
+ }
+ return;
+ }
+ };
+}
+
+package EVERY::LAST; @ISA = 'EVERY'; EVERY::ELSEWHERE::buildAUTOLOAD();
+package EVERY; @ISA = 'NEXT'; EVERY::ELSEWHERE::buildAUTOLOAD();
+
+1;
+
+__END__
+
+=head1 NAME
+
+NEXT.pm - Provide a pseudo-class NEXT (et al) that allows method redispatch
+
+
+=head1 SYNOPSIS
+
+ use NEXT;
+
+ package A;
+ sub A::method { print "$_[0]: A method\n"; $_[0]->NEXT::method() }
+ sub A::DESTROY { print "$_[0]: A dtor\n"; $_[0]->NEXT::DESTROY() }
+
+ package B;
+ use base qw( A );
+ sub B::AUTOLOAD { print "$_[0]: B AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
+ sub B::DESTROY { print "$_[0]: B dtor\n"; $_[0]->NEXT::DESTROY() }
+
+ package C;
+ sub C::method { print "$_[0]: C method\n"; $_[0]->NEXT::method() }
+ sub C::AUTOLOAD { print "$_[0]: C AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
+ sub C::DESTROY { print "$_[0]: C dtor\n"; $_[0]->NEXT::DESTROY() }
+
+ package D;
+ use base qw( B C );
+ sub D::method { print "$_[0]: D method\n"; $_[0]->NEXT::method() }
+ sub D::AUTOLOAD { print "$_[0]: D AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
+ sub D::DESTROY { print "$_[0]: D dtor\n"; $_[0]->NEXT::DESTROY() }
+
+ package main;
+
+ my $obj = bless {}, "D";
+
+ $obj->method(); # Calls D::method, A::method, C::method
+ $obj->missing_method(); # Calls D::AUTOLOAD, B::AUTOLOAD, C::AUTOLOAD
+
+ # Clean-up calls D::DESTROY, B::DESTROY, A::DESTROY, C::DESTROY
+
+
+
+=head1 DESCRIPTION
+
+NEXT.pm adds a pseudoclass named C<NEXT> to any program
+that uses it. If a method C<m> calls C<$self-E<gt>NEXT::m()>, the call to
+C<m> is redispatched as if the calling method had not originally been found.
+
+In other words, a call to C<$self-E<gt>NEXT::m()> resumes the depth-first,
+left-to-right search of C<$self>'s class hierarchy that resulted in the
+original call to C<m>.
+
+Note that this is not the same thing as C<$self-E<gt>SUPER::m()>, which
+begins a new dispatch that is restricted to searching the ancestors
+of the current class. C<$self-E<gt>NEXT::m()> can backtrack
+past the current class -- to look for a suitable method in other
+ancestors of C<$self> -- whereas C<$self-E<gt>SUPER::m()> cannot.
+
+A typical use would be in the destructors of a class hierarchy,
+as illustrated in the synopsis above. Each class in the hierarchy
+has a DESTROY method that performs some class-specific action
+and then redispatches the call up the hierarchy. As a result,
+when an object of class D is destroyed, the destructors of I<all>
+its parent classes are called (in depth-first, left-to-right order).
+
+Another typical use of redispatch would be in C<AUTOLOAD>'ed methods.
+If such a method determined that it was not able to handle a
+particular call, it might choose to redispatch that call, in the
+hope that some other C<AUTOLOAD> (above it, or to its left) might
+do better.
+
+By default, if a redispatch attempt fails to find another method
+elsewhere in the objects class hierarchy, it quietly gives up and does
+nothing (but see L<"Enforcing redispatch">). This gracious acquiescence
+is also unlike the (generally annoying) behaviour of C<SUPER>, which
+throws an exception if it cannot redispatch.
+
+Note that it is a fatal error for any method (including C<AUTOLOAD>)
+to attempt to redispatch any method that does not have the
+same name. For example:
+
+ sub D::oops { print "oops!\n"; $_[0]->NEXT::other_method() }
+
+
+=head2 Enforcing redispatch
+
+It is possible to make C<NEXT> redispatch more demandingly (i.e. like
+C<SUPER> does), so that the redispatch throws an exception if it cannot
+find a "next" method to call.
+
+To do this, simple invoke the redispatch as:
+
+ $self->NEXT::ACTUAL::method();
+
+rather than:
+
+ $self->NEXT::method();
+
+The C<ACTUAL> tells C<NEXT> that there must actually be a next method to call,
+or it should throw an exception.
+
+C<NEXT::ACTUAL> is most commonly used in C<AUTOLOAD> methods, as a means to
+decline an C<AUTOLOAD> request, but preserve the normal exception-on-failure
+semantics:
+
+ sub AUTOLOAD {
+ if ($AUTOLOAD =~ /foo|bar/) {
+ # handle here
+ }
+ else { # try elsewhere
+ shift()->NEXT::ACTUAL::AUTOLOAD(@_);
+ }
+ }
+
+By using C<NEXT::ACTUAL>, if there is no other C<AUTOLOAD> to handle the
+method call, an exception will be thrown (as usually happens in the absence of
+a suitable C<AUTOLOAD>).
+
+
+=head2 Avoiding repetitions
+
+If C<NEXT> redispatching is used in the methods of a "diamond" class hierarchy:
+
+ # A B
+ # / \ /
+ # C D
+ # \ /
+ # E
+
+ use NEXT;
+
+ package A;
+ sub foo { print "called A::foo\n"; shift->NEXT::foo() }
+
+ package B;
+ sub foo { print "called B::foo\n"; shift->NEXT::foo() }
+
+ package C; @ISA = qw( A );
+ sub foo { print "called C::foo\n"; shift->NEXT::foo() }
+
+ package D; @ISA = qw(A B);
+ sub foo { print "called D::foo\n"; shift->NEXT::foo() }
+
+ package E; @ISA = qw(C D);
+ sub foo { print "called E::foo\n"; shift->NEXT::foo() }
+
+ E->foo();
+
+then derived classes may (re-)inherit base-class methods through two or
+more distinct paths (e.g. in the way C<E> inherits C<A::foo> twice --
+through C<C> and C<D>). In such cases, a sequence of C<NEXT> redispatches
+will invoke the multiply inherited method as many times as it is
+inherited. For example, the above code prints:
+
+ called E::foo
+ called C::foo
+ called A::foo
+ called D::foo
+ called A::foo
+ called B::foo
+
+(i.e. C<A::foo> is called twice).
+
+In some cases this I<may> be the desired effect within a diamond hierarchy,
+but in others (e.g. for destructors) it may be more appropriate to
+call each method only once during a sequence of redispatches.
+
+To cover such cases, you can redispatch methods via:
+
+ $self->NEXT::DISTINCT::method();
+
+rather than:
+
+ $self->NEXT::method();
+
+This causes the redispatcher to only visit each distinct C<method> method
+once. That is, to skip any classes in the hierarchy that it has
+already visited during redispatch. So, for example, if the
+previous example were rewritten:
+
+ package A;
+ sub foo { print "called A::foo\n"; shift->NEXT::DISTINCT::foo() }
+
+ package B;
+ sub foo { print "called B::foo\n"; shift->NEXT::DISTINCT::foo() }
+
+ package C; @ISA = qw( A );
+ sub foo { print "called C::foo\n"; shift->NEXT::DISTINCT::foo() }
+
+ package D; @ISA = qw(A B);
+ sub foo { print "called D::foo\n"; shift->NEXT::DISTINCT::foo() }
+
+ package E; @ISA = qw(C D);
+ sub foo { print "called E::foo\n"; shift->NEXT::DISTINCT::foo() }
+
+ E->foo();
+
+then it would print:
+
+ called E::foo
+ called C::foo
+ called A::foo
+ called D::foo
+ called B::foo
+
+and omit the second call to C<A::foo> (since it would not be distinct
+from the first call to C<A::foo>).
+
+Note that you can also use:
+
+ $self->NEXT::DISTINCT::ACTUAL::method();
+
+or:
+
+ $self->NEXT::ACTUAL::DISTINCT::method();
+
+to get both unique invocation I<and> exception-on-failure.
+
+Note that, for historical compatibility, you can also use
+C<NEXT::UNSEEN> instead of C<NEXT::DISTINCT>.
+
+
+=head2 Invoking all versions of a method with a single call
+
+Yet another pseudo-class that NEXT.pm provides is C<EVERY>.
+Its behaviour is considerably simpler than that of the C<NEXT> family.
+A call to:
+
+ $obj->EVERY::foo();
+
+calls I<every> method named C<foo> that the object in C<$obj> has inherited.
+That is:
+
+ use NEXT;
+
+ package A; @ISA = qw(B D X);
+ sub foo { print "A::foo " }
+
+ package B; @ISA = qw(D X);
+ sub foo { print "B::foo " }
+
+ package X; @ISA = qw(D);
+ sub foo { print "X::foo " }
+
+ package D;
+ sub foo { print "D::foo " }
+
+ package main;
+
+ my $obj = bless {}, 'A';
+ $obj->EVERY::foo(); # prints" A::foo B::foo X::foo D::foo
+
+Prefixing a method call with C<EVERY::> causes every method in the
+object's hierarchy with that name to be invoked. As the above example
+illustrates, they are not called in Perl's usual "left-most-depth-first"
+order. Instead, they are called "breadth-first-dependency-wise".
+
+That means that the inheritance tree of the object is traversed breadth-first
+and the resulting order of classes is used as the sequence in which methods
+are called. However, that sequence is modified by imposing a rule that the
+appropriate method of a derived class must be called before the same method of
+any ancestral class. That's why, in the above example, C<X::foo> is called
+before C<D::foo>, even though C<D> comes before C<X> in C<@B::ISA>.
+
+In general, there's no need to worry about the order of calls. They will be
+left-to-right, breadth-first, most-derived-first. This works perfectly for
+most inherited methods (including destructors), but is inappropriate for
+some kinds of methods (such as constructors, cloners, debuggers, and
+initializers) where it's more appropriate that the least-derived methods be
+called first (as more-derived methods may rely on the behaviour of their
+"ancestors"). In that case, instead of using the C<EVERY> pseudo-class:
+
+ $obj->EVERY::foo(); # prints" A::foo B::foo X::foo D::foo
+
+you can use the C<EVERY::LAST> pseudo-class:
+
+ $obj->EVERY::LAST::foo(); # prints" D::foo X::foo B::foo A::foo
+
+which reverses the order of method call.
+
+Whichever version is used, the actual methods are called in the same
+context (list, scalar, or void) as the original call via C<EVERY>, and return:
+
+=over
+
+=item *
+
+A hash of array references in list context. Each entry of the hash has the
+fully qualified method name as its key and a reference to an array containing
+the method's list-context return values as its value.
+
+=item *
+
+A reference to a hash of scalar values in scalar context. Each entry of the hash has the
+fully qualified method name as its key and the method's scalar-context return values as its value.
+
+=item *
+
+Nothing in void context (obviously).
+
+=back
+
+=head2 Using C<EVERY> methods
+
+The typical way to use an C<EVERY> call is to wrap it in another base
+method, that all classes inherit. For example, to ensure that every
+destructor an object inherits is actually called (as opposed to just the
+left-most-depth-first-est one):
+
+ package Base;
+ sub DESTROY { $_[0]->EVERY::Destroy }
+
+ package Derived1;
+ use base 'Base';
+ sub Destroy {...}
+
+ package Derived2;
+ use base 'Base', 'Derived1';
+ sub Destroy {...}
+
+et cetera. Every derived class than needs its own clean-up
+behaviour simply adds its own C<Destroy> method (I<not> a C<DESTROY> method),
+which the call to C<EVERY::LAST::Destroy> in the inherited destructor
+then correctly picks up.
+
+Likewise, to create a class hierarchy in which every initializer inherited by
+a new object is invoked:
+
+ package Base;
+ sub new {
+ my ($class, %args) = @_;
+ my $obj = bless {}, $class;
+ $obj->EVERY::LAST::Init(\%args);
+ }
+
+ package Derived1;
+ use base 'Base';
+ sub Init {
+ my ($argsref) = @_;
+ ...
+ }
+
+ package Derived2;
+ use base 'Base', 'Derived1';
+ sub Init {
+ my ($argsref) = @_;
+ ...
+ }
+
+et cetera. Every derived class than needs some additional initialization
+behaviour simply adds its own C<Init> method (I<not> a C<new> method),
+which the call to C<EVERY::LAST::Init> in the inherited constructor
+then correctly picks up.
+
+
+=head1 AUTHOR
+
+Damian Conway (damian at conway.org)
+
+=head1 BUGS AND IRRITATIONS
+
+Because it's a module, not an integral part of the interpreter, NEXT.pm
+has to guess where the surrounding call was found in the method
+look-up sequence. In the presence of diamond inheritance patterns
+it occasionally guesses wrong.
+
+It's also too slow (despite caching).
+
+Comment, suggestions, and patches welcome.
+
+=head1 COPYRIGHT
+
+ Copyright (c) 2000-2001, Damian Conway. All Rights Reserved.
+ This module is free software. It may be used, redistributed
+ and/or modified under the same terms as Perl itself.
Copied: trunk/contrib/perl/lib/Net/Cmd.pm (from rev 6437, vendor/perl/5.18.1/lib/Net/Cmd.pm)
===================================================================
--- trunk/contrib/perl/lib/Net/Cmd.pm (rev 0)
+++ trunk/contrib/perl/lib/Net/Cmd.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,783 @@
+# Net::Cmd.pm
+#
+# Copyright (c) 1995-2006 Graham Barr <gbarr at pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Net::Cmd;
+
+require 5.001;
+require Exporter;
+
+use strict;
+use vars qw(@ISA @EXPORT $VERSION);
+use Carp;
+use Symbol 'gensym';
+
+BEGIN {
+ if ($^O eq 'os390') {
+ require Convert::EBCDIC;
+
+ # Convert::EBCDIC->import;
+ }
+}
+
+BEGIN {
+ if (!eval { require utf8 }) {
+ *is_utf8 = sub { 0 };
+ }
+ elsif (eval { utf8::is_utf8(undef); 1 }) {
+ *is_utf8 = \&utf8::is_utf8;
+ }
+ elsif (eval { require Encode; Encode::is_utf8(undef); 1 }) {
+ *is_utf8 = \&Encode::is_utf8;
+ }
+ else {
+ *is_utf8 = sub { $_[0] =~ /[^\x00-\xff]/ };
+ }
+}
+
+$VERSION = "2.29";
+ at ISA = qw(Exporter);
+ at EXPORT = qw(CMD_INFO CMD_OK CMD_MORE CMD_REJECT CMD_ERROR CMD_PENDING);
+
+
+sub CMD_INFO {1}
+sub CMD_OK {2}
+sub CMD_MORE {3}
+sub CMD_REJECT {4}
+sub CMD_ERROR {5}
+sub CMD_PENDING {0}
+
+my %debug = ();
+
+my $tr = $^O eq 'os390' ? Convert::EBCDIC->new() : undef;
+
+
+sub toebcdic {
+ my $cmd = shift;
+
+ unless (exists ${*$cmd}{'net_cmd_asciipeer'}) {
+ my $string = $_[0];
+ my $ebcdicstr = $tr->toebcdic($string);
+ ${*$cmd}{'net_cmd_asciipeer'} = $string !~ /^\d+/ && $ebcdicstr =~ /^\d+/;
+ }
+
+ ${*$cmd}{'net_cmd_asciipeer'}
+ ? $tr->toebcdic($_[0])
+ : $_[0];
+}
+
+
+sub toascii {
+ my $cmd = shift;
+ ${*$cmd}{'net_cmd_asciipeer'}
+ ? $tr->toascii($_[0])
+ : $_[0];
+}
+
+
+sub _print_isa {
+ no strict qw(refs);
+
+ my $pkg = shift;
+ my $cmd = $pkg;
+
+ $debug{$pkg} ||= 0;
+
+ my %done = ();
+ my @do = ($pkg);
+ my %spc = ($pkg, "");
+
+ while ($pkg = shift @do) {
+ next if defined $done{$pkg};
+
+ $done{$pkg} = 1;
+
+ my $v =
+ defined ${"${pkg}::VERSION"}
+ ? "(" . ${"${pkg}::VERSION"} . ")"
+ : "";
+
+ my $spc = $spc{$pkg};
+ $cmd->debug_print(1, "${spc}${pkg}${v}\n");
+
+ if (@{"${pkg}::ISA"}) {
+ @spc{@{"${pkg}::ISA"}} = (" " . $spc{$pkg}) x @{"${pkg}::ISA"};
+ unshift(@do, @{"${pkg}::ISA"});
+ }
+ }
+}
+
+
+sub debug {
+ @_ == 1 or @_ == 2 or croak 'usage: $obj->debug([LEVEL])';
+
+ my ($cmd, $level) = @_;
+ my $pkg = ref($cmd) || $cmd;
+ my $oldval = 0;
+
+ if (ref($cmd)) {
+ $oldval = ${*$cmd}{'net_cmd_debug'} || 0;
+ }
+ else {
+ $oldval = $debug{$pkg} || 0;
+ }
+
+ return $oldval
+ unless @_ == 2;
+
+ $level = $debug{$pkg} || 0
+ unless defined $level;
+
+ _print_isa($pkg)
+ if ($level && !exists $debug{$pkg});
+
+ if (ref($cmd)) {
+ ${*$cmd}{'net_cmd_debug'} = $level;
+ }
+ else {
+ $debug{$pkg} = $level;
+ }
+
+ $oldval;
+}
+
+
+sub message {
+ @_ == 1 or croak 'usage: $obj->message()';
+
+ my $cmd = shift;
+
+ wantarray
+ ? @{${*$cmd}{'net_cmd_resp'}}
+ : join("", @{${*$cmd}{'net_cmd_resp'}});
+}
+
+
+sub debug_text { $_[2] }
+
+
+sub debug_print {
+ my ($cmd, $out, $text) = @_;
+ print STDERR $cmd, ($out ? '>>> ' : '<<< '), $cmd->debug_text($out, $text);
+}
+
+
+sub code {
+ @_ == 1 or croak 'usage: $obj->code()';
+
+ my $cmd = shift;
+
+ ${*$cmd}{'net_cmd_code'} = "000"
+ unless exists ${*$cmd}{'net_cmd_code'};
+
+ ${*$cmd}{'net_cmd_code'};
+}
+
+
+sub status {
+ @_ == 1 or croak 'usage: $obj->status()';
+
+ my $cmd = shift;
+
+ substr(${*$cmd}{'net_cmd_code'}, 0, 1);
+}
+
+
+sub set_status {
+ @_ == 3 or croak 'usage: $obj->set_status(CODE, MESSAGE)';
+
+ my $cmd = shift;
+ my ($code, $resp) = @_;
+
+ $resp = [$resp]
+ unless ref($resp);
+
+ (${*$cmd}{'net_cmd_code'}, ${*$cmd}{'net_cmd_resp'}) = ($code, $resp);
+
+ 1;
+}
+
+
+sub command {
+ my $cmd = shift;
+
+ unless (defined fileno($cmd)) {
+ $cmd->set_status("599", "Connection closed");
+ return $cmd;
+ }
+
+
+ $cmd->dataend()
+ if (exists ${*$cmd}{'net_cmd_last_ch'});
+
+ if (scalar(@_)) {
+ local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
+
+ my $str = join(
+ " ",
+ map {
+ /\n/
+ ? do { my $n = $_; $n =~ tr/\n/ /; $n }
+ : $_;
+ } @_
+ );
+ $str = $cmd->toascii($str) if $tr;
+ $str .= "\015\012";
+
+ my $len = length $str;
+ my $swlen;
+
+ $cmd->close
+ unless (defined($swlen = syswrite($cmd, $str, $len)) && $swlen == $len);
+
+ $cmd->debug_print(1, $str)
+ if ($cmd->debug);
+
+ ${*$cmd}{'net_cmd_resp'} = []; # the response
+ ${*$cmd}{'net_cmd_code'} = "000"; # Made this one up :-)
+ }
+
+ $cmd;
+}
+
+
+sub ok {
+ @_ == 1 or croak 'usage: $obj->ok()';
+
+ my $code = $_[0]->code;
+ 0 < $code && $code < 400;
+}
+
+
+sub unsupported {
+ my $cmd = shift;
+
+ ${*$cmd}{'net_cmd_resp'} = ['Unsupported command'];
+ ${*$cmd}{'net_cmd_code'} = 580;
+ 0;
+}
+
+
+sub getline {
+ my $cmd = shift;
+
+ ${*$cmd}{'net_cmd_lines'} ||= [];
+
+ return shift @{${*$cmd}{'net_cmd_lines'}}
+ if scalar(@{${*$cmd}{'net_cmd_lines'}});
+
+ my $partial = defined(${*$cmd}{'net_cmd_partial'}) ? ${*$cmd}{'net_cmd_partial'} : "";
+ my $fd = fileno($cmd);
+
+ return undef
+ unless defined $fd;
+
+ my $rin = "";
+ vec($rin, $fd, 1) = 1;
+
+ my $buf;
+
+ until (scalar(@{${*$cmd}{'net_cmd_lines'}})) {
+ my $timeout = $cmd->timeout || undef;
+ my $rout;
+
+ my $select_ret = select($rout = $rin, undef, undef, $timeout);
+ if ($select_ret > 0) {
+ unless (sysread($cmd, $buf = "", 1024)) {
+ carp(ref($cmd) . ": Unexpected EOF on command channel")
+ if $cmd->debug;
+ $cmd->close;
+ return undef;
+ }
+
+ substr($buf, 0, 0) = $partial; ## prepend from last sysread
+
+ my @buf = split(/\015?\012/, $buf, -1); ## break into lines
+
+ $partial = pop @buf;
+
+ push(@{${*$cmd}{'net_cmd_lines'}}, map {"$_\n"} @buf);
+
+ }
+ else {
+ my $msg = $select_ret ? "Error or Interrupted: $!" : "Timeout";
+ carp("$cmd: $msg") if ($cmd->debug);
+ return undef;
+ }
+ }
+
+ ${*$cmd}{'net_cmd_partial'} = $partial;
+
+ if ($tr) {
+ foreach my $ln (@{${*$cmd}{'net_cmd_lines'}}) {
+ $ln = $cmd->toebcdic($ln);
+ }
+ }
+
+ shift @{${*$cmd}{'net_cmd_lines'}};
+}
+
+
+sub ungetline {
+ my ($cmd, $str) = @_;
+
+ ${*$cmd}{'net_cmd_lines'} ||= [];
+ unshift(@{${*$cmd}{'net_cmd_lines'}}, $str);
+}
+
+
+sub parse_response {
+ return ()
+ unless $_[1] =~ s/^(\d\d\d)(.?)//o;
+ ($1, $2 eq "-");
+}
+
+
+sub response {
+ my $cmd = shift;
+ my ($code, $more) = (undef) x 2;
+
+ ${*$cmd}{'net_cmd_resp'} ||= [];
+
+ while (1) {
+ my $str = $cmd->getline();
+
+ return CMD_ERROR
+ unless defined($str);
+
+ $cmd->debug_print(0, $str)
+ if ($cmd->debug);
+
+ ($code, $more) = $cmd->parse_response($str);
+ unless (defined $code) {
+ $cmd->ungetline($str);
+ last;
+ }
+
+ ${*$cmd}{'net_cmd_code'} = $code;
+
+ push(@{${*$cmd}{'net_cmd_resp'}}, $str);
+
+ last unless ($more);
+ }
+
+ substr($code, 0, 1);
+}
+
+
+sub read_until_dot {
+ my $cmd = shift;
+ my $fh = shift;
+ my $arr = [];
+
+ while (1) {
+ my $str = $cmd->getline() or return undef;
+
+ $cmd->debug_print(0, $str)
+ if ($cmd->debug & 4);
+
+ last if ($str =~ /^\.\r?\n/o);
+
+ $str =~ s/^\.\././o;
+
+ if (defined $fh) {
+ print $fh $str;
+ }
+ else {
+ push(@$arr, $str);
+ }
+ }
+
+ $arr;
+}
+
+
+sub datasend {
+ my $cmd = shift;
+ my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
+ my $line = join("", @$arr);
+
+ # encode to individual utf8 bytes if
+ # $line is a string (in internal UTF-8)
+ utf8::encode($line) if is_utf8($line);
+
+ return 0 unless defined(fileno($cmd));
+
+ my $last_ch = ${*$cmd}{'net_cmd_last_ch'};
+ $last_ch = ${*$cmd}{'net_cmd_last_ch'} = "\012" unless defined $last_ch;
+
+ return 1 unless length $line;
+
+ if ($cmd->debug) {
+ foreach my $b (split(/\n/, $line)) {
+ $cmd->debug_print(1, "$b\n");
+ }
+ }
+
+ $line =~ tr/\r\n/\015\012/ unless "\r" eq "\015";
+
+ my $first_ch = '';
+
+ if ($last_ch eq "\015") {
+ $first_ch = "\012" if $line =~ s/^\012//;
+ }
+ elsif ($last_ch eq "\012") {
+ $first_ch = "." if $line =~ /^\./;
+ }
+
+ $line =~ s/\015?\012(\.?)/\015\012$1$1/sg;
+
+ substr($line, 0, 0) = $first_ch;
+
+ ${*$cmd}{'net_cmd_last_ch'} = substr($line, -1, 1);
+
+ my $len = length($line);
+ my $offset = 0;
+ my $win = "";
+ vec($win, fileno($cmd), 1) = 1;
+ my $timeout = $cmd->timeout || undef;
+
+ local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
+
+ while ($len) {
+ my $wout;
+ my $s = select(undef, $wout = $win, undef, $timeout);
+ if ((defined $s and $s > 0) or -f $cmd) # -f for testing on win32
+ {
+ my $w = syswrite($cmd, $line, $len, $offset);
+ unless (defined($w)) {
+ carp("$cmd: $!") if $cmd->debug;
+ return undef;
+ }
+ $len -= $w;
+ $offset += $w;
+ }
+ else {
+ carp("$cmd: Timeout") if ($cmd->debug);
+ return undef;
+ }
+ }
+
+ 1;
+}
+
+
+sub rawdatasend {
+ my $cmd = shift;
+ my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
+ my $line = join("", @$arr);
+
+ return 0 unless defined(fileno($cmd));
+
+ return 1
+ unless length($line);
+
+ if ($cmd->debug) {
+ my $b = "$cmd>>> ";
+ print STDERR $b, join("\n$b", split(/\n/, $line)), "\n";
+ }
+
+ my $len = length($line);
+ my $offset = 0;
+ my $win = "";
+ vec($win, fileno($cmd), 1) = 1;
+ my $timeout = $cmd->timeout || undef;
+
+ local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
+ while ($len) {
+ my $wout;
+ if (select(undef, $wout = $win, undef, $timeout) > 0) {
+ my $w = syswrite($cmd, $line, $len, $offset);
+ unless (defined($w)) {
+ carp("$cmd: $!") if $cmd->debug;
+ return undef;
+ }
+ $len -= $w;
+ $offset += $w;
+ }
+ else {
+ carp("$cmd: Timeout") if ($cmd->debug);
+ return undef;
+ }
+ }
+
+ 1;
+}
+
+
+sub dataend {
+ my $cmd = shift;
+
+ return 0 unless defined(fileno($cmd));
+
+ my $ch = ${*$cmd}{'net_cmd_last_ch'};
+ my $tosend;
+
+ if (!defined $ch) {
+ return 1;
+ }
+ elsif ($ch ne "\012") {
+ $tosend = "\015\012";
+ }
+
+ $tosend .= ".\015\012";
+
+ local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
+
+ $cmd->debug_print(1, ".\n")
+ if ($cmd->debug);
+
+ syswrite($cmd, $tosend, length $tosend);
+
+ delete ${*$cmd}{'net_cmd_last_ch'};
+
+ $cmd->response() == CMD_OK;
+}
+
+# read and write to tied filehandle
+sub tied_fh {
+ my $cmd = shift;
+ ${*$cmd}{'net_cmd_readbuf'} = '';
+ my $fh = gensym();
+ tie *$fh, ref($cmd), $cmd;
+ return $fh;
+}
+
+# tie to myself
+sub TIEHANDLE {
+ my $class = shift;
+ my $cmd = shift;
+ return $cmd;
+}
+
+# Tied filehandle read. Reads requested data length, returning
+# end-of-file when the dot is encountered.
+sub READ {
+ my $cmd = shift;
+ my ($len, $offset) = @_[1, 2];
+ return unless exists ${*$cmd}{'net_cmd_readbuf'};
+ my $done = 0;
+ while (!$done and length(${*$cmd}{'net_cmd_readbuf'}) < $len) {
+ ${*$cmd}{'net_cmd_readbuf'} .= $cmd->getline() or return;
+ $done++ if ${*$cmd}{'net_cmd_readbuf'} =~ s/^\.\r?\n\Z//m;
+ }
+
+ $_[0] = '';
+ substr($_[0], $offset + 0) = substr(${*$cmd}{'net_cmd_readbuf'}, 0, $len);
+ substr(${*$cmd}{'net_cmd_readbuf'}, 0, $len) = '';
+ delete ${*$cmd}{'net_cmd_readbuf'} if $done;
+
+ return length $_[0];
+}
+
+
+sub READLINE {
+ my $cmd = shift;
+
+ # in this context, we use the presence of readbuf to
+ # indicate that we have not yet reached the eof
+ return unless exists ${*$cmd}{'net_cmd_readbuf'};
+ my $line = $cmd->getline;
+ return if $line =~ /^\.\r?\n/;
+ $line;
+}
+
+
+sub PRINT {
+ my $cmd = shift;
+ my ($buf, $len, $offset) = @_;
+ $len ||= length($buf);
+ $offset += 0;
+ return unless $cmd->datasend(substr($buf, $offset, $len));
+ ${*$cmd}{'net_cmd_sending'}++; # flag that we should call dataend()
+ return $len;
+}
+
+
+sub CLOSE {
+ my $cmd = shift;
+ my $r = exists(${*$cmd}{'net_cmd_sending'}) ? $cmd->dataend : 1;
+ delete ${*$cmd}{'net_cmd_readbuf'};
+ delete ${*$cmd}{'net_cmd_sending'};
+ $r;
+}
+
+1;
+
+__END__
+
+
+=head1 NAME
+
+Net::Cmd - Network Command class (as used by FTP, SMTP etc)
+
+=head1 SYNOPSIS
+
+ use Net::Cmd;
+
+ @ISA = qw(Net::Cmd);
+
+=head1 DESCRIPTION
+
+C<Net::Cmd> is a collection of methods that can be inherited by a sub class
+of C<IO::Handle>. These methods implement the functionality required for a
+command based protocol, for example FTP and SMTP.
+
+=head1 USER METHODS
+
+These methods provide a user interface to the C<Net::Cmd> object.
+
+=over 4
+
+=item debug ( VALUE )
+
+Set the level of debug information for this object. If C<VALUE> is not given
+then the current state is returned. Otherwise the state is changed to
+C<VALUE> and the previous state returned.
+
+Different packages
+may implement different levels of debug but a non-zero value results in
+copies of all commands and responses also being sent to STDERR.
+
+If C<VALUE> is C<undef> then the debug level will be set to the default
+debug level for the class.
+
+This method can also be called as a I<static> method to set/get the default
+debug level for a given class.
+
+=item message ()
+
+Returns the text message returned from the last command
+
+=item code ()
+
+Returns the 3-digit code from the last command. If a command is pending
+then the value 0 is returned
+
+=item ok ()
+
+Returns non-zero if the last code value was greater than zero and
+less than 400. This holds true for most command servers. Servers
+where this does not hold may override this method.
+
+=item status ()
+
+Returns the most significant digit of the current status code. If a command
+is pending then C<CMD_PENDING> is returned.
+
+=item datasend ( DATA )
+
+Send data to the remote server, converting LF to CRLF. Any line starting
+with a '.' will be prefixed with another '.'.
+C<DATA> may be an array or a reference to an array.
+
+=item dataend ()
+
+End the sending of data to the remote server. This is done by ensuring that
+the data already sent ends with CRLF then sending '.CRLF' to end the
+transmission. Once this data has been sent C<dataend> calls C<response> and
+returns true if C<response> returns CMD_OK.
+
+=back
+
+=head1 CLASS METHODS
+
+These methods are not intended to be called by the user, but used or
+over-ridden by a sub-class of C<Net::Cmd>
+
+=over 4
+
+=item debug_print ( DIR, TEXT )
+
+Print debugging information. C<DIR> denotes the direction I<true> being
+data being sent to the server. Calls C<debug_text> before printing to
+STDERR.
+
+=item debug_text ( TEXT )
+
+This method is called to print debugging information. TEXT is
+the text being sent. The method should return the text to be printed
+
+This is primarily meant for the use of modules such as FTP where passwords
+are sent, but we do not want to display them in the debugging information.
+
+=item command ( CMD [, ARGS, ... ])
+
+Send a command to the command server. All arguments a first joined with
+a space character and CRLF is appended, this string is then sent to the
+command server.
+
+Returns undef upon failure
+
+=item unsupported ()
+
+Sets the status code to 580 and the response text to 'Unsupported command'.
+Returns zero.
+
+=item response ()
+
+Obtain a response from the server. Upon success the most significant digit
+of the status code is returned. Upon failure, timeout etc., I<undef> is
+returned.
+
+=item parse_response ( TEXT )
+
+This method is called by C<response> as a method with one argument. It should
+return an array of 2 values, the 3-digit status code and a flag which is true
+when this is part of a multi-line response and this line is not the list.
+
+=item getline ()
+
+Retrieve one line, delimited by CRLF, from the remote server. Returns I<undef>
+upon failure.
+
+B<NOTE>: If you do use this method for any reason, please remember to add
+some C<debug_print> calls into your method.
+
+=item ungetline ( TEXT )
+
+Unget a line of text from the server.
+
+=item rawdatasend ( DATA )
+
+Send data to the remote server without performing any conversions. C<DATA>
+is a scalar.
+
+=item read_until_dot ()
+
+Read data from the remote server until a line consisting of a single '.'.
+Any lines starting with '..' will have one of the '.'s removed.
+
+Returns a reference to a list containing the lines, or I<undef> upon failure.
+
+=item tied_fh ()
+
+Returns a filehandle tied to the Net::Cmd object. After issuing a
+command, you may read from this filehandle using read() or <>. The
+filehandle will return EOF when the final dot is encountered.
+Similarly, you may write to the filehandle in order to send data to
+the server after issuing a command that expects data to be written.
+
+See the Net::POP3 and Net::SMTP modules for examples of this.
+
+=back
+
+=head1 EXPORTS
+
+C<Net::Cmd> exports six subroutines, five of these, C<CMD_INFO>, C<CMD_OK>,
+C<CMD_MORE>, C<CMD_REJECT> and C<CMD_ERROR>, correspond to possible results
+of C<response> and C<status>. The sixth is C<CMD_PENDING>.
+
+=head1 AUTHOR
+
+Graham Barr <gbarr at pobox.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1995-2006 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.
+
+=cut
Copied: trunk/contrib/perl/lib/Net/Config.eg (from rev 6437, vendor/perl/5.18.1/lib/Net/Config.eg)
===================================================================
--- trunk/contrib/perl/lib/Net/Config.eg (rev 0)
+++ trunk/contrib/perl/lib/Net/Config.eg 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,49 @@
+package Net::Config;
+
+require Exporter;
+use vars qw(@ISA @EXPORT %NetConfig);
+use strict;
+
+ at EXPORT = qw(%NetConfig);
+ at ISA = qw(Exporter);
+
+# WARNING WARNING WARNING WARNING WARNING WARNING WARNING
+# WARNING WARNING WARNING WARNING WARNING WARNING WARNING
+#
+# Below this line is auto-generated, *ANY* changes will be lost
+
+%NetConfig = (
+ # the followinf parameters are all lists of hosts for the
+ # respective protocols.
+ nntp_hosts => [],
+ snpp_hosts => [],
+ pop3_hosts => [],
+ smtp_hosts => [],
+ ph_hosts => [],
+ daytime_hosts => [],
+ time_hosts => [],
+
+ # your internet domain
+ inet_domain => undef,
+
+ # If you have an ftp proxy firewall (not an http firewall)
+ # then set this to the name of the firewall
+ ftp_firewall => undef,
+
+ # set if all connections done via the firewall should use
+ # passive data connections
+ ftp_ext_passive => 0,
+
+ # set if all connections not done via the firewall should use
+ # passive data connections
+ ftp_int_passive => 0,
+
+ # If set the make test will attempt to connect to the hosts above
+ test_hosts => 0,
+
+ # Used during Configure (which you are not using) to do
+ # DNS lookups to ensure hosts exist
+ test_exist => 0,
+
+);
+1;
Copied: trunk/contrib/perl/lib/Net/Config.pm (from rev 6437, vendor/perl/5.18.1/lib/Net/Config.pm)
===================================================================
--- trunk/contrib/perl/lib/Net/Config.pm (rev 0)
+++ trunk/contrib/perl/lib/Net/Config.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,312 @@
+# Net::Config.pm
+#
+# Copyright (c) 2000 Graham Barr <gbarr at pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Net::Config;
+
+require Exporter;
+use vars qw(@ISA @EXPORT %NetConfig $VERSION $CONFIGURE $LIBNET_CFG);
+use Socket qw(inet_aton inet_ntoa);
+use strict;
+
+ at EXPORT = qw(%NetConfig);
+ at ISA = qw(Net::LocalCfg Exporter);
+$VERSION = "1.11";
+
+eval { local $SIG{__DIE__}; require Net::LocalCfg };
+
+%NetConfig = (
+ nntp_hosts => [],
+ snpp_hosts => [],
+ pop3_hosts => [],
+ smtp_hosts => [],
+ ph_hosts => [],
+ daytime_hosts => [],
+ time_hosts => [],
+ inet_domain => undef,
+ ftp_firewall => undef,
+ ftp_ext_passive => 1,
+ ftp_int_passive => 1,
+ test_hosts => 1,
+ test_exist => 1,
+);
+
+#
+# Try to get as much configuration info as possible from InternetConfig
+#
+$^O eq 'MacOS' and eval <<TRY_INTERNET_CONFIG;
+use Mac::InternetConfig;
+
+{
+my %nc = (
+ nntp_hosts => [ \$InternetConfig{ kICNNTPHost() } ],
+ pop3_hosts => [ \$InternetConfig{ kICMailAccount() } =~ /\@(.*)/ ],
+ smtp_hosts => [ \$InternetConfig{ kICSMTPHost() } ],
+ ftp_testhost => \$InternetConfig{ kICFTPHost() } ? \$InternetConfig{ kICFTPHost()} : undef,
+ ph_hosts => [ \$InternetConfig{ kICPhHost() } ],
+ ftp_ext_passive => \$InternetConfig{"646F676F\xA5UsePassiveMode"} || 0,
+ ftp_int_passive => \$InternetConfig{"646F676F\xA5UsePassiveMode"} || 0,
+ socks_hosts =>
+ \$InternetConfig{ kICUseSocks() } ? [ \$InternetConfig{ kICSocksHost() } ] : [],
+ ftp_firewall =>
+ \$InternetConfig{ kICUseFTPProxy() } ? [ \$InternetConfig{ kICFTPProxyHost() } ] : [],
+);
+\@NetConfig{keys %nc} = values %nc;
+}
+TRY_INTERNET_CONFIG
+
+my $file = __FILE__;
+my $ref;
+$file =~ s/Config.pm/libnet.cfg/;
+if (-f $file) {
+ $ref = eval { local $SIG{__DIE__}; do $file };
+ if (ref($ref) eq 'HASH') {
+ %NetConfig = (%NetConfig, %{$ref});
+ $LIBNET_CFG = $file;
+ }
+}
+if ($< == $> and !$CONFIGURE) {
+ my $home = eval { local $SIG{__DIE__}; (getpwuid($>))[7] } || $ENV{HOME};
+ $home ||= $ENV{HOMEDRIVE} . ($ENV{HOMEPATH} || '') if defined $ENV{HOMEDRIVE};
+ if (defined $home) {
+ $file = $home . "/.libnetrc";
+ $ref = eval { local $SIG{__DIE__}; do $file } if -f $file;
+ %NetConfig = (%NetConfig, %{$ref})
+ if ref($ref) eq 'HASH';
+ }
+}
+my ($k, $v);
+while (($k, $v) = each %NetConfig) {
+ $NetConfig{$k} = [$v]
+ if ($k =~ /_hosts$/ and $k ne "test_hosts" and defined($v) and !ref($v));
+}
+
+# Take a hostname and determine if it is inside the firewall
+
+
+sub requires_firewall {
+ shift; # ignore package
+ my $host = shift;
+
+ return 0 unless defined $NetConfig{'ftp_firewall'};
+
+ $host = inet_aton($host) or return -1;
+ $host = inet_ntoa($host);
+
+ if (exists $NetConfig{'local_netmask'}) {
+ my $quad = unpack("N", pack("C*", split(/\./, $host)));
+ my $list = $NetConfig{'local_netmask'};
+ $list = [$list] unless ref($list);
+ foreach (@$list) {
+ my ($net, $bits) = (m#^(\d+\.\d+\.\d+\.\d+)/(\d+)$#) or next;
+ my $mask = ~0 << (32 - $bits);
+ my $addr = unpack("N", pack("C*", split(/\./, $net)));
+
+ return 0 if (($addr & $mask) == ($quad & $mask));
+ }
+ return 1;
+ }
+
+ return 0;
+}
+
+use vars qw(*is_external);
+*is_external = \&requires_firewall;
+
+1;
+
+__END__
+
+=head1 NAME
+
+Net::Config - Local configuration data for libnet
+
+=head1 SYNOPSYS
+
+ use Net::Config qw(%NetConfig);
+
+=head1 DESCRIPTION
+
+C<Net::Config> holds configuration data for the modules in the libnet
+distribution. During installation you will be asked for these values.
+
+The configuration data is held globally in a file in the perl installation
+tree, but a user may override any of these values by providing their own. This
+can be done by having a C<.libnetrc> file in their home directory. This file
+should return a reference to a HASH containing the keys described below.
+For example
+
+ # .libnetrc
+ {
+ nntp_hosts => [ "my_preferred_host" ],
+ ph_hosts => [ "my_ph_server" ],
+ }
+ __END__
+
+=head1 METHODS
+
+C<Net::Config> defines the following methods. They are methods as they are
+invoked as class methods. This is because C<Net::Config> inherits from
+C<Net::LocalCfg> so you can override these methods if you want.
+
+=over 4
+
+=item requires_firewall HOST
+
+Attempts to determine if a given host is outside your firewall. Possible
+return values are.
+
+ -1 Cannot lookup hostname
+ 0 Host is inside firewall (or there is no ftp_firewall entry)
+ 1 Host is outside the firewall
+
+This is done by using hostname lookup and the C<local_netmask> entry in
+the configuration data.
+
+=back
+
+=head1 NetConfig VALUES
+
+=over 4
+
+=item nntp_hosts
+
+=item snpp_hosts
+
+=item pop3_hosts
+
+=item smtp_hosts
+
+=item ph_hosts
+
+=item daytime_hosts
+
+=item time_hosts
+
+Each is a reference to an array of hostnames (in order of preference),
+which should be used for the given protocol
+
+=item inet_domain
+
+Your internet domain name
+
+=item ftp_firewall
+
+If you have an FTP proxy firewall (B<NOT> an HTTP or SOCKS firewall)
+then this value should be set to the firewall hostname. If your firewall
+does not listen to port 21, then this value should be set to
+C<"hostname:port"> (eg C<"hostname:99">)
+
+=item ftp_firewall_type
+
+There are many different ftp firewall products available. But unfortunately
+there is no standard for how to traverse a firewall. The list below shows the
+sequence of commands that Net::FTP will use
+
+ user Username for remote host
+ pass Password for remote host
+ fwuser Username for firewall
+ fwpass Password for firewall
+ remote.host The hostname of the remote ftp server
+
+=over 4
+
+=item 0
+
+There is no firewall
+
+=item 1
+
+ USER user at remote.host
+ PASS pass
+
+=item 2
+
+ USER fwuser
+ PASS fwpass
+ USER user at remote.host
+ PASS pass
+
+=item 3
+
+ USER fwuser
+ PASS fwpass
+ SITE remote.site
+ USER user
+ PASS pass
+
+=item 4
+
+ USER fwuser
+ PASS fwpass
+ OPEN remote.site
+ USER user
+ PASS pass
+
+=item 5
+
+ USER user at fwuser@remote.site
+ PASS pass at fwpass
+
+=item 6
+
+ USER fwuser at remote.site
+ PASS fwpass
+ USER user
+ PASS pass
+
+=item 7
+
+ USER user at remote.host
+ PASS pass
+ AUTH fwuser
+ RESP fwpass
+
+=back
+
+=item ftp_ext_passive
+
+=item ftp_int_passive
+
+FTP servers can work in passive or active mode. Active mode is when
+you want to transfer data you have to tell the server the address and
+port to connect to. Passive mode is when the server provide the
+address and port and you establish the connection.
+
+With some firewalls active mode does not work as the server cannot
+connect to your machine (because you are behind a firewall) and the firewall
+does not re-write the command. In this case you should set C<ftp_ext_passive>
+to a I<true> value.
+
+Some servers are configured to only work in passive mode. If you have
+one of these you can force C<Net::FTP> to always transfer in passive
+mode; when not going via a firewall, by setting C<ftp_int_passive> to
+a I<true> value.
+
+=item local_netmask
+
+A reference to a list of netmask strings in the form C<"134.99.4.0/24">.
+These are used by the C<requires_firewall> function to determine if a given
+host is inside or outside your firewall.
+
+=back
+
+The following entries are used during installation & testing on the
+libnet package
+
+=over 4
+
+=item test_hosts
+
+If true then C<make test> may attempt to connect to hosts given in the
+configuration.
+
+=item test_exists
+
+If true then C<Configure> will check each hostname given that it exists
+
+=back
+
+=cut
Copied: trunk/contrib/perl/lib/Net/Domain.pm (from rev 6437, vendor/perl/5.18.1/lib/Net/Domain.pm)
===================================================================
--- trunk/contrib/perl/lib/Net/Domain.pm (rev 0)
+++ trunk/contrib/perl/lib/Net/Domain.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,347 @@
+# Net::Domain.pm
+#
+# Copyright (c) 1995-1998 Graham Barr <gbarr at pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Net::Domain;
+
+require Exporter;
+
+use Carp;
+use strict;
+use vars qw($VERSION @ISA @EXPORT_OK);
+use Net::Config;
+
+ at ISA = qw(Exporter);
+ at EXPORT_OK = qw(hostname hostdomain hostfqdn domainname);
+
+$VERSION = "2.20";
+
+my ($host, $domain, $fqdn) = (undef, undef, undef);
+
+# Try every conceivable way to get hostname.
+
+
+sub _hostname {
+
+ # we already know it
+ return $host
+ if (defined $host);
+
+ if ($^O eq 'MSWin32') {
+ require Socket;
+ my ($name, $alias, $type, $len, @addr) = gethostbyname($ENV{'COMPUTERNAME'} || 'localhost');
+ while (@addr) {
+ my $a = shift(@addr);
+ $host = gethostbyaddr($a, Socket::AF_INET());
+ last if defined $host;
+ }
+ if (defined($host) && index($host, '.') > 0) {
+ $fqdn = $host;
+ ($host, $domain) = $fqdn =~ /^([^\.]+)\.(.*)$/;
+ }
+ return $host;
+ }
+ elsif ($^O eq 'MacOS') {
+ chomp($host = `hostname`);
+ }
+ elsif ($^O eq 'VMS') { ## multiple varieties of net s/w makes this hard
+ $host = $ENV{'UCX$INET_HOST'} if defined($ENV{'UCX$INET_HOST'});
+ $host = $ENV{'MULTINET_HOST_NAME'} if defined($ENV{'MULTINET_HOST_NAME'});
+ if (index($host, '.') > 0) {
+ $fqdn = $host;
+ ($host, $domain) = $fqdn =~ /^([^\.]+)\.(.*)$/;
+ }
+ return $host;
+ }
+ else {
+ local $SIG{'__DIE__'};
+
+ # syscall is preferred since it avoids tainting problems
+ eval {
+ my $tmp = "\0" x 256; ## preload scalar
+ eval {
+ package main;
+ require "syscall.ph";
+ defined(&main::SYS_gethostname);
+ }
+ || eval {
+ package main;
+ require "sys/syscall.ph";
+ defined(&main::SYS_gethostname);
+ }
+ and $host =
+ (syscall(&main::SYS_gethostname, $tmp, 256) == 0)
+ ? $tmp
+ : undef;
+ }
+
+ # POSIX
+ || eval {
+ require POSIX;
+ $host = (POSIX::uname())[1];
+ }
+
+ # trusty old hostname command
+ || eval {
+ chop($host = `(hostname) 2>/dev/null`); # BSD'ish
+ }
+
+ # sysV/POSIX uname command (may truncate)
+ || eval {
+ chop($host = `uname -n 2>/dev/null`); ## SYSV'ish && POSIX'ish
+ }
+
+ # Apollo pre-SR10
+ || eval { $host = (split(/[:\. ]/, `/com/host`, 6))[0]; }
+
+ || eval { $host = ""; };
+ }
+
+ # remove garbage
+ $host =~ s/[\0\r\n]+//go;
+ $host =~ s/(\A\.+|\.+\Z)//go;
+ $host =~ s/\.\.+/\./go;
+
+ $host;
+}
+
+
+sub _hostdomain {
+
+ # we already know it
+ return $domain
+ if (defined $domain);
+
+ local $SIG{'__DIE__'};
+
+ return $domain = $NetConfig{'inet_domain'}
+ if defined $NetConfig{'inet_domain'};
+
+ # try looking in /etc/resolv.conf
+ # putting this here and assuming that it is correct, eliminates
+ # calls to gethostbyname, and therefore DNS lookups. This helps
+ # those on dialup systems.
+
+ local *RES;
+ local ($_);
+
+ if (open(RES, "/etc/resolv.conf")) {
+ while (<RES>) {
+ $domain = $1
+ if (/\A\s*(?:domain|search)\s+(\S+)/);
+ }
+ close(RES);
+
+ return $domain
+ if (defined $domain);
+ }
+
+ # just try hostname and system calls
+
+ my $host = _hostname();
+ my (@hosts);
+
+ @hosts = ($host, "localhost");
+
+ unless (defined($host) && $host =~ /\./) {
+ my $dom = undef;
+ eval {
+ my $tmp = "\0" x 256; ## preload scalar
+ eval {
+ package main;
+ require "syscall.ph";
+ }
+ || eval {
+ package main;
+ require "sys/syscall.ph";
+ }
+ and $dom =
+ (syscall(&main::SYS_getdomainname, $tmp, 256) == 0)
+ ? $tmp
+ : undef;
+ };
+
+ if ($^O eq 'VMS') {
+ $dom ||= $ENV{'TCPIP$INET_DOMAIN'}
+ || $ENV{'UCX$INET_DOMAIN'};
+ }
+
+ chop($dom = `domainname 2>/dev/null`)
+ unless (defined $dom || $^O =~ /^(?:cygwin|MSWin32)/);
+
+ if (defined $dom) {
+ my @h = ();
+ $dom =~ s/^\.+//;
+ while (length($dom)) {
+ push(@h, "$host.$dom");
+ $dom =~ s/^[^.]+.+// or last;
+ }
+ unshift(@hosts, @h);
+ }
+ }
+
+ # Attempt to locate FQDN
+
+ foreach (grep { defined $_ } @hosts) {
+ my @info = gethostbyname($_);
+
+ next unless @info;
+
+ # look at real name & aliases
+ my $site;
+ foreach $site ($info[0], split(/ /, $info[1])) {
+ if (rindex($site, ".") > 0) {
+
+ # Extract domain from FQDN
+
+ ($domain = $site) =~ s/\A[^\.]+\.//;
+ return $domain;
+ }
+ }
+ }
+
+ # Look for environment variable
+
+ $domain ||= $ENV{LOCALDOMAIN} || $ENV{DOMAIN};
+
+ if (defined $domain) {
+ $domain =~ s/[\r\n\0]+//g;
+ $domain =~ s/(\A\.+|\.+\Z)//g;
+ $domain =~ s/\.\.+/\./g;
+ }
+
+ $domain;
+}
+
+
+sub domainname {
+
+ return $fqdn
+ if (defined $fqdn);
+
+ _hostname();
+ _hostdomain();
+
+ # Assumption: If the host name does not contain a period
+ # and the domain name does, then assume that they are correct
+ # this helps to eliminate calls to gethostbyname, and therefore
+ # eleminate DNS lookups
+
+ return $fqdn = $host . "." . $domain
+ if (defined $host
+ and defined $domain
+ and $host !~ /\./
+ and $domain =~ /\./);
+
+ # For hosts that have no name, just an IP address
+ return $fqdn = $host if defined $host and $host =~ /^\d+(\.\d+){3}$/;
+
+ my @host = defined $host ? split(/\./, $host) : ('localhost');
+ my @domain = defined $domain ? split(/\./, $domain) : ();
+ my @fqdn = ();
+
+ # Determine from @host & @domain the FQDN
+
+ my @d = @domain;
+
+LOOP:
+ while (1) {
+ my @h = @host;
+ while (@h) {
+ my $tmp = join(".", @h, @d);
+ if ((gethostbyname($tmp))[0]) {
+ @fqdn = (@h, @d);
+ $fqdn = $tmp;
+ last LOOP;
+ }
+ pop @h;
+ }
+ last unless shift @d;
+ }
+
+ if (@fqdn) {
+ $host = shift @fqdn;
+ until ((gethostbyname($host))[0]) {
+ $host .= "." . shift @fqdn;
+ }
+ $domain = join(".", @fqdn);
+ }
+ else {
+ undef $host;
+ undef $domain;
+ undef $fqdn;
+ }
+
+ $fqdn;
+}
+
+
+sub hostfqdn { domainname() }
+
+
+sub hostname {
+ domainname()
+ unless (defined $host);
+ return $host;
+}
+
+
+sub hostdomain {
+ domainname()
+ unless (defined $domain);
+ return $domain;
+}
+
+1; # Keep require happy
+
+__END__
+
+=head1 NAME
+
+Net::Domain - Attempt to evaluate the current host's internet name and domain
+
+=head1 SYNOPSIS
+
+ use Net::Domain qw(hostname hostfqdn hostdomain domainname);
+
+=head1 DESCRIPTION
+
+Using various methods B<attempt> to find the Fully Qualified Domain Name (FQDN)
+of the current host. From this determine the host-name and the host-domain.
+
+Each of the functions will return I<undef> if the FQDN cannot be determined.
+
+=over 4
+
+=item hostfqdn ()
+
+Identify and return the FQDN of the current host.
+
+=item domainname ()
+
+An alias for hostfqdn ().
+
+=item hostname ()
+
+Returns the smallest part of the FQDN which can be used to identify the host.
+
+=item hostdomain ()
+
+Returns the remainder of the FQDN after the I<hostname> has been removed.
+
+=back
+
+=head1 AUTHOR
+
+Graham Barr <gbarr at pobox.com>.
+Adapted from Sys::Hostname by David Sundstrom <sunds at asictest.sc.ti.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1995-1998 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.
+
+=cut
Copied: trunk/contrib/perl/lib/Net/FTP.pm (from rev 6437, vendor/perl/5.18.1/lib/Net/FTP.pm)
===================================================================
--- trunk/contrib/perl/lib/Net/FTP.pm (rev 0)
+++ trunk/contrib/perl/lib/Net/FTP.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,1829 @@
+# Net::FTP.pm
+#
+# Copyright (c) 1995-2004 Graham Barr <gbarr at pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+#
+# Documentation (at end) improved 1996 by Nathan Torkington <gnat at frii.com>.
+
+package Net::FTP;
+
+require 5.001;
+
+use strict;
+use vars qw(@ISA $VERSION);
+use Carp;
+
+use Socket 1.3;
+use IO::Socket;
+use Time::Local;
+use Net::Cmd;
+use Net::Config;
+use Fcntl qw(O_WRONLY O_RDONLY O_APPEND O_CREAT O_TRUNC);
+
+$VERSION = '2.77';
+ at ISA = qw(Exporter Net::Cmd IO::Socket::INET);
+
+# Someday I will "use constant", when I am not bothered to much about
+# compatability with older releases of perl
+
+use vars qw($TELNET_IAC $TELNET_IP $TELNET_DM);
+($TELNET_IAC, $TELNET_IP, $TELNET_DM) = (255, 244, 242);
+
+
+BEGIN {
+
+ # make a constant so code is fast'ish
+ my $is_os390 = $^O eq 'os390';
+ *trEBCDIC = sub () {$is_os390}
+}
+
+
+sub new {
+ my $pkg = shift;
+ my ($peer, %arg);
+ if (@_ % 2) {
+ $peer = shift;
+ %arg = @_;
+ }
+ else {
+ %arg = @_;
+ $peer = delete $arg{Host};
+ }
+
+ my $host = $peer;
+ my $fire = undef;
+ my $fire_type = undef;
+
+ if (exists($arg{Firewall}) || Net::Config->requires_firewall($peer)) {
+ $fire = $arg{Firewall}
+ || $ENV{FTP_FIREWALL}
+ || $NetConfig{ftp_firewall}
+ || undef;
+
+ if (defined $fire) {
+ $peer = $fire;
+ delete $arg{Port};
+ $fire_type = $arg{FirewallType}
+ || $ENV{FTP_FIREWALL_TYPE}
+ || $NetConfig{firewall_type}
+ || undef;
+ }
+ }
+
+ my $ftp = $pkg->SUPER::new(
+ PeerAddr => $peer,
+ PeerPort => $arg{Port} || 'ftp(21)',
+ LocalAddr => $arg{'LocalAddr'},
+ Proto => 'tcp',
+ Timeout => defined $arg{Timeout}
+ ? $arg{Timeout}
+ : 120
+ )
+ or return undef;
+
+ ${*$ftp}{'net_ftp_host'} = $host; # Remote hostname
+ ${*$ftp}{'net_ftp_type'} = 'A'; # ASCII/binary/etc mode
+ ${*$ftp}{'net_ftp_blksize'} = abs($arg{'BlockSize'} || 10240);
+
+ ${*$ftp}{'net_ftp_localaddr'} = $arg{'LocalAddr'};
+
+ ${*$ftp}{'net_ftp_firewall'} = $fire
+ if (defined $fire);
+ ${*$ftp}{'net_ftp_firewall_type'} = $fire_type
+ if (defined $fire_type);
+
+ ${*$ftp}{'net_ftp_passive'} =
+ int exists $arg{Passive} ? $arg{Passive}
+ : exists $ENV{FTP_PASSIVE} ? $ENV{FTP_PASSIVE}
+ : defined $fire ? $NetConfig{ftp_ext_passive}
+ : $NetConfig{ftp_int_passive}; # Whew! :-)
+
+ $ftp->hash(exists $arg{Hash} ? $arg{Hash} : 0, 1024);
+
+ $ftp->autoflush(1);
+
+ $ftp->debug(exists $arg{Debug} ? $arg{Debug} : undef);
+
+ unless ($ftp->response() == CMD_OK) {
+ $ftp->close();
+ $@ = $ftp->message;
+ undef $ftp;
+ }
+
+ $ftp;
+}
+
+##
+## User interface methods
+##
+
+
+sub host {
+ my $me = shift;
+ ${*$me}{'net_ftp_host'};
+}
+
+
+sub hash {
+ my $ftp = shift; # self
+
+ my ($h, $b) = @_;
+ unless ($h) {
+ delete ${*$ftp}{'net_ftp_hash'};
+ return [\*STDERR, 0];
+ }
+ ($h, $b) = (ref($h) ? $h : \*STDERR, $b || 1024);
+ select((select($h), $| = 1)[0]);
+ $b = 512 if $b < 512;
+ ${*$ftp}{'net_ftp_hash'} = [$h, $b];
+}
+
+
+sub quit {
+ my $ftp = shift;
+
+ $ftp->_QUIT;
+ $ftp->close;
+}
+
+
+sub DESTROY { }
+
+
+sub ascii { shift->type('A', @_); }
+sub binary { shift->type('I', @_); }
+
+
+sub ebcdic {
+ carp "TYPE E is unsupported, shall default to I";
+ shift->type('E', @_);
+}
+
+
+sub byte {
+ carp "TYPE L is unsupported, shall default to I";
+ shift->type('L', @_);
+}
+
+# Allow the user to send a command directly, BE CAREFUL !!
+
+
+sub quot {
+ my $ftp = shift;
+ my $cmd = shift;
+
+ $ftp->command(uc $cmd, @_);
+ $ftp->response();
+}
+
+
+sub site {
+ my $ftp = shift;
+
+ $ftp->command("SITE", @_);
+ $ftp->response();
+}
+
+
+sub mdtm {
+ my $ftp = shift;
+ my $file = shift;
+
+ # Server Y2K bug workaround
+ #
+ # sigh; some idiotic FTP servers use ("19%d",tm.tm_year) instead of
+ # ("%d",tm.tm_year+1900). This results in an extra digit in the
+ # string returned. To account for this we allow an optional extra
+ # digit in the year. Then if the first two digits are 19 we use the
+ # remainder, otherwise we subtract 1900 from the whole year.
+
+ $ftp->_MDTM($file)
+ && $ftp->message =~ /((\d\d)(\d\d\d?))(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/
+ ? timegm($8, $7, $6, $5, $4 - 1, $2 eq '19' ? $3 : ($1 - 1900))
+ : undef;
+}
+
+
+sub size {
+ my $ftp = shift;
+ my $file = shift;
+ my $io;
+ if ($ftp->supported("SIZE")) {
+ return $ftp->_SIZE($file)
+ ? ($ftp->message =~ /(\d+)\s*(bytes?\s*)?$/)[0]
+ : undef;
+ }
+ elsif ($ftp->supported("STAT")) {
+ my @msg;
+ return undef
+ unless $ftp->_STAT($file) && (@msg = $ftp->message) == 3;
+ my $line;
+ foreach $line (@msg) {
+ return (split(/\s+/, $line))[4]
+ if $line =~ /^[-rwxSsTt]{10}/;
+ }
+ }
+ else {
+ my @files = $ftp->dir($file);
+ if (@files) {
+ return (split(/\s+/, $1))[4]
+ if $files[0] =~ /^([-rwxSsTt]{10}.*)$/;
+ }
+ }
+ undef;
+}
+
+
+sub login {
+ my ($ftp, $user, $pass, $acct) = @_;
+ my ($ok, $ruser, $fwtype);
+
+ unless (defined $user) {
+ require Net::Netrc;
+
+ my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_host'});
+
+ ($user, $pass, $acct) = $rc->lpa()
+ if ($rc);
+ }
+
+ $user ||= "anonymous";
+ $ruser = $user;
+
+ $fwtype = ${*$ftp}{'net_ftp_firewall_type'}
+ || $NetConfig{'ftp_firewall_type'}
+ || 0;
+
+ if ($fwtype && defined ${*$ftp}{'net_ftp_firewall'}) {
+ if ($fwtype == 1 || $fwtype == 7) {
+ $user .= '@' . ${*$ftp}{'net_ftp_host'};
+ }
+ else {
+ require Net::Netrc;
+
+ my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'});
+
+ my ($fwuser, $fwpass, $fwacct) = $rc ? $rc->lpa() : ();
+
+ if ($fwtype == 5) {
+ $user = join('@', $user, $fwuser, ${*$ftp}{'net_ftp_host'});
+ $pass = $pass . '@' . $fwpass;
+ }
+ else {
+ if ($fwtype == 2) {
+ $user .= '@' . ${*$ftp}{'net_ftp_host'};
+ }
+ elsif ($fwtype == 6) {
+ $fwuser .= '@' . ${*$ftp}{'net_ftp_host'};
+ }
+
+ $ok = $ftp->_USER($fwuser);
+
+ return 0 unless $ok == CMD_OK || $ok == CMD_MORE;
+
+ $ok = $ftp->_PASS($fwpass || "");
+
+ return 0 unless $ok == CMD_OK || $ok == CMD_MORE;
+
+ $ok = $ftp->_ACCT($fwacct)
+ if defined($fwacct);
+
+ if ($fwtype == 3) {
+ $ok = $ftp->command("SITE", ${*$ftp}{'net_ftp_host'})->response;
+ }
+ elsif ($fwtype == 4) {
+ $ok = $ftp->command("OPEN", ${*$ftp}{'net_ftp_host'})->response;
+ }
+
+ return 0 unless $ok == CMD_OK || $ok == CMD_MORE;
+ }
+ }
+ }
+
+ $ok = $ftp->_USER($user);
+
+ # Some dumb firewalls don't prefix the connection messages
+ $ok = $ftp->response()
+ if ($ok == CMD_OK && $ftp->code == 220 && $user =~ /\@/);
+
+ if ($ok == CMD_MORE) {
+ unless (defined $pass) {
+ require Net::Netrc;
+
+ my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_host'}, $ruser);
+
+ ($ruser, $pass, $acct) = $rc->lpa()
+ if ($rc);
+
+ $pass = '-anonymous@'
+ if (!defined $pass && (!defined($ruser) || $ruser =~ /^anonymous/o));
+ }
+
+ $ok = $ftp->_PASS($pass || "");
+ }
+
+ $ok = $ftp->_ACCT($acct)
+ if (defined($acct) && ($ok == CMD_MORE || $ok == CMD_OK));
+
+ if ($fwtype == 7 && $ok == CMD_OK && defined ${*$ftp}{'net_ftp_firewall'}) {
+ my ($f, $auth, $resp) = _auth_id($ftp);
+ $ftp->authorize($auth, $resp) if defined($resp);
+ }
+
+ $ok == CMD_OK;
+}
+
+
+sub account {
+ @_ == 2 or croak 'usage: $ftp->account( ACCT )';
+ my $ftp = shift;
+ my $acct = shift;
+ $ftp->_ACCT($acct) == CMD_OK;
+}
+
+
+sub _auth_id {
+ my ($ftp, $auth, $resp) = @_;
+
+ unless (defined $resp) {
+ require Net::Netrc;
+
+ $auth ||= eval { (getpwuid($>))[0] } || $ENV{NAME};
+
+ my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'}, $auth)
+ || Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'});
+
+ ($auth, $resp) = $rc->lpa()
+ if ($rc);
+ }
+ ($ftp, $auth, $resp);
+}
+
+
+sub authorize {
+ @_ >= 1 || @_ <= 3 or croak 'usage: $ftp->authorize( [AUTH [, RESP]])';
+
+ my ($ftp, $auth, $resp) = &_auth_id;
+
+ my $ok = $ftp->_AUTH($auth || "");
+
+ $ok = $ftp->_RESP($resp || "")
+ if ($ok == CMD_MORE);
+
+ $ok == CMD_OK;
+}
+
+
+sub rename {
+ @_ == 3 or croak 'usage: $ftp->rename(FROM, TO)';
+
+ my ($ftp, $from, $to) = @_;
+
+ $ftp->_RNFR($from)
+ && $ftp->_RNTO($to);
+}
+
+
+sub type {
+ my $ftp = shift;
+ my $type = shift;
+ my $oldval = ${*$ftp}{'net_ftp_type'};
+
+ return $oldval
+ unless (defined $type);
+
+ return undef
+ unless ($ftp->_TYPE($type, @_));
+
+ ${*$ftp}{'net_ftp_type'} = join(" ", $type, @_);
+
+ $oldval;
+}
+
+
+sub alloc {
+ my $ftp = shift;
+ my $size = shift;
+ my $oldval = ${*$ftp}{'net_ftp_allo'};
+
+ return $oldval
+ unless (defined $size);
+
+ return undef
+ unless ($ftp->_ALLO($size, @_));
+
+ ${*$ftp}{'net_ftp_allo'} = join(" ", $size, @_);
+
+ $oldval;
+}
+
+
+sub abort {
+ my $ftp = shift;
+
+ send($ftp, pack("CCC", $TELNET_IAC, $TELNET_IP, $TELNET_IAC), MSG_OOB);
+
+ $ftp->command(pack("C", $TELNET_DM) . "ABOR");
+
+ ${*$ftp}{'net_ftp_dataconn'}->close()
+ if defined ${*$ftp}{'net_ftp_dataconn'};
+
+ $ftp->response();
+
+ $ftp->status == CMD_OK;
+}
+
+
+sub get {
+ my ($ftp, $remote, $local, $where) = @_;
+
+ my ($loc, $len, $buf, $resp, $data);
+ local *FD;
+
+ my $localfd = ref($local) || ref(\$local) eq "GLOB";
+
+ ($local = $remote) =~ s#^.*/##
+ unless (defined $local);
+
+ croak("Bad remote filename '$remote'\n")
+ if $remote =~ /[\r\n]/s;
+
+ ${*$ftp}{'net_ftp_rest'} = $where if defined $where;
+ my $rest = ${*$ftp}{'net_ftp_rest'};
+
+ delete ${*$ftp}{'net_ftp_port'};
+ delete ${*$ftp}{'net_ftp_pasv'};
+
+ $data = $ftp->retr($remote)
+ or return undef;
+
+ if ($localfd) {
+ $loc = $local;
+ }
+ else {
+ $loc = \*FD;
+
+ unless (sysopen($loc, $local, O_CREAT | O_WRONLY | ($rest ? O_APPEND: O_TRUNC))) {
+ carp "Cannot open Local file $local: $!\n";
+ $data->abort;
+ return undef;
+ }
+ }
+
+ if ($ftp->type eq 'I' && !binmode($loc)) {
+ carp "Cannot binmode Local file $local: $!\n";
+ $data->abort;
+ close($loc) unless $localfd;
+ return undef;
+ }
+
+ $buf = '';
+ my ($count, $hashh, $hashb, $ref) = (0);
+
+ ($hashh, $hashb) = @$ref
+ if ($ref = ${*$ftp}{'net_ftp_hash'});
+
+ my $blksize = ${*$ftp}{'net_ftp_blksize'};
+ local $\; # Just in case
+
+ while (1) {
+ last unless $len = $data->read($buf, $blksize);
+
+ if (trEBCDIC && $ftp->type ne 'I') {
+ $buf = $ftp->toebcdic($buf);
+ $len = length($buf);
+ }
+
+ if ($hashh) {
+ $count += $len;
+ print $hashh "#" x (int($count / $hashb));
+ $count %= $hashb;
+ }
+ unless (print $loc $buf) {
+ carp "Cannot write to Local file $local: $!\n";
+ $data->abort;
+ close($loc)
+ unless $localfd;
+ return undef;
+ }
+ }
+
+ print $hashh "\n" if $hashh;
+
+ unless ($localfd) {
+ unless (close($loc)) {
+ carp "Cannot close file $local (perhaps disk space) $!\n";
+ return undef;
+ }
+ }
+
+ unless ($data->close()) # implied $ftp->response
+ {
+ carp "Unable to close datastream";
+ return undef;
+ }
+
+ return $local;
+}
+
+
+sub cwd {
+ @_ == 1 || @_ == 2 or croak 'usage: $ftp->cwd( [ DIR ] )';
+
+ my ($ftp, $dir) = @_;
+
+ $dir = "/" unless defined($dir) && $dir =~ /\S/;
+
+ $dir eq ".."
+ ? $ftp->_CDUP()
+ : $ftp->_CWD($dir);
+}
+
+
+sub cdup {
+ @_ == 1 or croak 'usage: $ftp->cdup()';
+ $_[0]->_CDUP;
+}
+
+
+sub pwd {
+ @_ == 1 || croak 'usage: $ftp->pwd()';
+ my $ftp = shift;
+
+ $ftp->_PWD();
+ $ftp->_extract_path;
+}
+
+# rmdir( $ftp, $dir, [ $recurse ] )
+#
+# Removes $dir on remote host via FTP.
+# $ftp is handle for remote host
+#
+# If $recurse is TRUE, the directory and deleted recursively.
+# This means all of its contents and subdirectories.
+#
+# Initial version contributed by Dinkum Software
+#
+sub rmdir {
+ @_ == 2 || @_ == 3 or croak('usage: $ftp->rmdir( DIR [, RECURSE ] )');
+
+ # Pick off the args
+ my ($ftp, $dir, $recurse) = @_;
+ my $ok;
+
+ return $ok
+ if $ok = $ftp->_RMD($dir)
+ or !$recurse;
+
+ # Try to delete the contents
+ # Get a list of all the files in the directory
+ my @filelist = grep { !/^\.{1,2}$/ } $ftp->ls($dir);
+
+ return undef
+ unless @filelist; # failed, it is probably not a directory
+
+ # Go thru and delete each file or the directory
+ my $file;
+ foreach $file (map { m,/, ? $_ : "$dir/$_" } @filelist) {
+ next # successfully deleted the file
+ if $ftp->delete($file);
+
+ # Failed to delete it, assume its a directory
+ # Recurse and ignore errors, the final rmdir() will
+ # fail on any errors here
+ return $ok
+ unless $ok = $ftp->rmdir($file, 1);
+ }
+
+ # Directory should be empty
+ # Try to remove the directory again
+ # Pass results directly to caller
+ # If any of the prior deletes failed, this
+ # rmdir() will fail because directory is not empty
+ return $ftp->_RMD($dir);
+}
+
+
+sub restart {
+ @_ == 2 || croak 'usage: $ftp->restart( BYTE_OFFSET )';
+
+ my ($ftp, $where) = @_;
+
+ ${*$ftp}{'net_ftp_rest'} = $where;
+
+ return undef;
+}
+
+
+sub mkdir {
+ @_ == 2 || @_ == 3 or croak 'usage: $ftp->mkdir( DIR [, RECURSE ] )';
+
+ my ($ftp, $dir, $recurse) = @_;
+
+ $ftp->_MKD($dir) || $recurse
+ or return undef;
+
+ my $path = $dir;
+
+ unless ($ftp->ok) {
+ my @path = split(m#(?=/+)#, $dir);
+
+ $path = "";
+
+ while (@path) {
+ $path .= shift @path;
+
+ $ftp->_MKD($path);
+
+ $path = $ftp->_extract_path($path);
+ }
+
+ # If the creation of the last element was not successful, see if we
+ # can cd to it, if so then return path
+
+ unless ($ftp->ok) {
+ my ($status, $message) = ($ftp->status, $ftp->message);
+ my $pwd = $ftp->pwd;
+
+ if ($pwd && $ftp->cwd($dir)) {
+ $path = $dir;
+ $ftp->cwd($pwd);
+ }
+ else {
+ undef $path;
+ }
+ $ftp->set_status($status, $message);
+ }
+ }
+
+ $path;
+}
+
+
+sub delete {
+ @_ == 2 || croak 'usage: $ftp->delete( FILENAME )';
+
+ $_[0]->_DELE($_[1]);
+}
+
+
+sub put { shift->_store_cmd("stor", @_) }
+sub put_unique { shift->_store_cmd("stou", @_) }
+sub append { shift->_store_cmd("appe", @_) }
+
+
+sub nlst { shift->_data_cmd("NLST", @_) }
+sub list { shift->_data_cmd("LIST", @_) }
+sub retr { shift->_data_cmd("RETR", @_) }
+sub stor { shift->_data_cmd("STOR", @_) }
+sub stou { shift->_data_cmd("STOU", @_) }
+sub appe { shift->_data_cmd("APPE", @_) }
+
+
+sub _store_cmd {
+ my ($ftp, $cmd, $local, $remote) = @_;
+ my ($loc, $sock, $len, $buf);
+ local *FD;
+
+ my $localfd = ref($local) || ref(\$local) eq "GLOB";
+
+ unless (defined $remote) {
+ croak 'Must specify remote filename with stream input'
+ if $localfd;
+
+ require File::Basename;
+ $remote = File::Basename::basename($local);
+ }
+ if (defined ${*$ftp}{'net_ftp_allo'}) {
+ delete ${*$ftp}{'net_ftp_allo'};
+ }
+ else {
+
+ # if the user hasn't already invoked the alloc method since the last
+ # _store_cmd call, figure out if the local file is a regular file(not
+ # a pipe, or device) and if so get the file size from stat, and send
+ # an ALLO command before sending the STOR, STOU, or APPE command.
+ my $size = do { local $^W; -f $local && -s _ }; # no ALLO if sending data from a pipe
+ $ftp->_ALLO($size) if $size;
+ }
+ croak("Bad remote filename '$remote'\n")
+ if $remote =~ /[\r\n]/s;
+
+ if ($localfd) {
+ $loc = $local;
+ }
+ else {
+ $loc = \*FD;
+
+ unless (sysopen($loc, $local, O_RDONLY)) {
+ carp "Cannot open Local file $local: $!\n";
+ return undef;
+ }
+ }
+
+ if ($ftp->type eq 'I' && !binmode($loc)) {
+ carp "Cannot binmode Local file $local: $!\n";
+ return undef;
+ }
+
+ delete ${*$ftp}{'net_ftp_port'};
+ delete ${*$ftp}{'net_ftp_pasv'};
+
+ $sock = $ftp->_data_cmd($cmd, $remote)
+ or return undef;
+
+ $remote = ($ftp->message =~ /FILE:\s*(.*)/)[0]
+ if 'STOU' eq uc $cmd;
+
+ my $blksize = ${*$ftp}{'net_ftp_blksize'};
+
+ my ($count, $hashh, $hashb, $ref) = (0);
+
+ ($hashh, $hashb) = @$ref
+ if ($ref = ${*$ftp}{'net_ftp_hash'});
+
+ while (1) {
+ last unless $len = read($loc, $buf = "", $blksize);
+
+ if (trEBCDIC && $ftp->type ne 'I') {
+ $buf = $ftp->toascii($buf);
+ $len = length($buf);
+ }
+
+ if ($hashh) {
+ $count += $len;
+ print $hashh "#" x (int($count / $hashb));
+ $count %= $hashb;
+ }
+
+ my $wlen;
+ unless (defined($wlen = $sock->write($buf, $len)) && $wlen == $len) {
+ $sock->abort;
+ close($loc)
+ unless $localfd;
+ print $hashh "\n" if $hashh;
+ return undef;
+ }
+ }
+
+ print $hashh "\n" if $hashh;
+
+ close($loc)
+ unless $localfd;
+
+ $sock->close()
+ or return undef;
+
+ if ('STOU' eq uc $cmd and $ftp->message =~ m/unique\s+file\s*name\s*:\s*(.*)\)|"(.*)"/) {
+ require File::Basename;
+ $remote = File::Basename::basename($+);
+ }
+
+ return $remote;
+}
+
+
+sub port {
+ @_ == 1 || @_ == 2 or croak 'usage: $ftp->port([PORT])';
+
+ my ($ftp, $port) = @_;
+ my $ok;
+
+ delete ${*$ftp}{'net_ftp_intern_port'};
+
+ unless (defined $port) {
+
+ # create a Listen socket at same address as the command socket
+
+ ${*$ftp}{'net_ftp_listen'} ||= IO::Socket::INET->new(
+ Listen => 5,
+ Proto => 'tcp',
+ Timeout => $ftp->timeout,
+ LocalAddr => $ftp->sockhost,
+ );
+
+ my $listen = ${*$ftp}{'net_ftp_listen'};
+
+ my ($myport, @myaddr) = ($listen->sockport, split(/\./, $listen->sockhost));
+
+ $port = join(',', @myaddr, $myport >> 8, $myport & 0xff);
+
+ ${*$ftp}{'net_ftp_intern_port'} = 1;
+ }
+
+ $ok = $ftp->_PORT($port);
+
+ ${*$ftp}{'net_ftp_port'} = $port;
+
+ $ok;
+}
+
+
+sub ls { shift->_list_cmd("NLST", @_); }
+sub dir { shift->_list_cmd("LIST", @_); }
+
+
+sub pasv {
+ @_ == 1 or croak 'usage: $ftp->pasv()';
+
+ my $ftp = shift;
+
+ delete ${*$ftp}{'net_ftp_intern_port'};
+
+ $ftp->_PASV && $ftp->message =~ /(\d+(,\d+)+)/
+ ? ${*$ftp}{'net_ftp_pasv'} = $1
+ : undef;
+}
+
+
+sub unique_name {
+ my $ftp = shift;
+ ${*$ftp}{'net_ftp_unique'} || undef;
+}
+
+
+sub supported {
+ @_ == 2 or croak 'usage: $ftp->supported( CMD )';
+ my $ftp = shift;
+ my $cmd = uc shift;
+ my $hash = ${*$ftp}{'net_ftp_supported'} ||= {};
+
+ return $hash->{$cmd}
+ if exists $hash->{$cmd};
+
+ return $hash->{$cmd} = 0
+ unless $ftp->_HELP($cmd);
+
+ my $text = $ftp->message;
+ if ($text =~ /following\s+commands/i) {
+ $text =~ s/^.*\n//;
+ while ($text =~ /(\*?)(\w+)(\*?)/sg) {
+ $hash->{"\U$2"} = !length("$1$3");
+ }
+ }
+ else {
+ $hash->{$cmd} = $text !~ /unimplemented/i;
+ }
+
+ $hash->{$cmd} ||= 0;
+}
+
+##
+## Deprecated methods
+##
+
+
+sub lsl {
+ carp "Use of Net::FTP::lsl deprecated, use 'dir'"
+ if $^W;
+ goto &dir;
+}
+
+
+sub authorise {
+ carp "Use of Net::FTP::authorise deprecated, use 'authorize'"
+ if $^W;
+ goto &authorize;
+}
+
+
+##
+## Private methods
+##
+
+
+sub _extract_path {
+ my ($ftp, $path) = @_;
+
+ # This tries to work both with and without the quote doubling
+ # convention (RFC 959 requires it, but the first 3 servers I checked
+ # didn't implement it). It will fail on a server which uses a quote in
+ # the message which isn't a part of or surrounding the path.
+ $ftp->ok
+ && $ftp->message =~ /(?:^|\s)\"(.*)\"(?:$|\s)/
+ && ($path = $1) =~ s/\"\"/\"/g;
+
+ $path;
+}
+
+##
+## Communication methods
+##
+
+
+sub _dataconn {
+ my $ftp = shift;
+ my $data = undef;
+ my $pkg = "Net::FTP::" . $ftp->type;
+
+ eval "require " . $pkg;
+
+ $pkg =~ s/ /_/g;
+
+ delete ${*$ftp}{'net_ftp_dataconn'};
+
+ if (defined ${*$ftp}{'net_ftp_pasv'}) {
+ my @port = map { 0 + $_ } split(/,/, ${*$ftp}{'net_ftp_pasv'});
+
+ $data = $pkg->new(
+ PeerAddr => join(".", @port[0 .. 3]),
+ PeerPort => $port[4] * 256 + $port[5],
+ LocalAddr => ${*$ftp}{'net_ftp_localaddr'},
+ Proto => 'tcp'
+ );
+ }
+ elsif (defined ${*$ftp}{'net_ftp_listen'}) {
+ $data = ${*$ftp}{'net_ftp_listen'}->accept($pkg);
+ close(delete ${*$ftp}{'net_ftp_listen'});
+ }
+
+ if ($data) {
+ ${*$data} = "";
+ $data->timeout($ftp->timeout);
+ ${*$ftp}{'net_ftp_dataconn'} = $data;
+ ${*$data}{'net_ftp_cmd'} = $ftp;
+ ${*$data}{'net_ftp_blksize'} = ${*$ftp}{'net_ftp_blksize'};
+ }
+
+ $data;
+}
+
+
+sub _list_cmd {
+ my $ftp = shift;
+ my $cmd = uc shift;
+
+ delete ${*$ftp}{'net_ftp_port'};
+ delete ${*$ftp}{'net_ftp_pasv'};
+
+ my $data = $ftp->_data_cmd($cmd, @_);
+
+ return
+ unless (defined $data);
+
+ require Net::FTP::A;
+ bless $data, "Net::FTP::A"; # Force ASCII mode
+
+ my $databuf = '';
+ my $buf = '';
+ my $blksize = ${*$ftp}{'net_ftp_blksize'};
+
+ while ($data->read($databuf, $blksize)) {
+ $buf .= $databuf;
+ }
+
+ my $list = [split(/\n/, $buf)];
+
+ $data->close();
+
+ if (trEBCDIC) {
+ for (@$list) { $_ = $ftp->toebcdic($_) }
+ }
+
+ wantarray
+ ? @{$list}
+ : $list;
+}
+
+
+sub _data_cmd {
+ my $ftp = shift;
+ my $cmd = uc shift;
+ my $ok = 1;
+ my $where = delete ${*$ftp}{'net_ftp_rest'} || 0;
+ my $arg;
+
+ for $arg (@_) {
+ croak("Bad argument '$arg'\n")
+ if $arg =~ /[\r\n]/s;
+ }
+
+ if ( ${*$ftp}{'net_ftp_passive'}
+ && !defined ${*$ftp}{'net_ftp_pasv'}
+ && !defined ${*$ftp}{'net_ftp_port'})
+ {
+ my $data = undef;
+
+ $ok = defined $ftp->pasv;
+ $ok = $ftp->_REST($where)
+ if $ok && $where;
+
+ if ($ok) {
+ $ftp->command($cmd, @_);
+ $data = $ftp->_dataconn();
+ $ok = CMD_INFO == $ftp->response();
+ if ($ok) {
+ $data->reading
+ if $data && $cmd =~ /RETR|LIST|NLST/;
+ return $data;
+ }
+ $data->_close
+ if $data;
+ }
+ return undef;
+ }
+
+ $ok = $ftp->port
+ unless (defined ${*$ftp}{'net_ftp_port'}
+ || defined ${*$ftp}{'net_ftp_pasv'});
+
+ $ok = $ftp->_REST($where)
+ if $ok && $where;
+
+ return undef
+ unless $ok;
+
+ $ftp->command($cmd, @_);
+
+ return 1
+ if (defined ${*$ftp}{'net_ftp_pasv'});
+
+ $ok = CMD_INFO == $ftp->response();
+
+ return $ok
+ unless exists ${*$ftp}{'net_ftp_intern_port'};
+
+ if ($ok) {
+ my $data = $ftp->_dataconn();
+
+ $data->reading
+ if $data && $cmd =~ /RETR|LIST|NLST/;
+
+ return $data;
+ }
+
+
+ close(delete ${*$ftp}{'net_ftp_listen'});
+
+ return undef;
+}
+
+##
+## Over-ride methods (Net::Cmd)
+##
+
+
+sub debug_text { $_[2] =~ /^(pass|resp|acct)/i ? "$1 ....\n" : $_[2]; }
+
+
+sub command {
+ my $ftp = shift;
+
+ delete ${*$ftp}{'net_ftp_port'};
+ $ftp->SUPER::command(@_);
+}
+
+
+sub response {
+ my $ftp = shift;
+ my $code = $ftp->SUPER::response();
+
+ delete ${*$ftp}{'net_ftp_pasv'}
+ if ($code != CMD_MORE && $code != CMD_INFO);
+
+ $code;
+}
+
+
+sub parse_response {
+ return ($1, $2 eq "-")
+ if $_[1] =~ s/^(\d\d\d)([- ]?)//o;
+
+ my $ftp = shift;
+
+ # Darn MS FTP server is a load of CRAP !!!!
+ return ()
+ unless ${*$ftp}{'net_cmd_code'} + 0;
+
+ (${*$ftp}{'net_cmd_code'}, 1);
+}
+
+##
+## Allow 2 servers to talk directly
+##
+
+
+sub pasv_xfer_unique {
+ my ($sftp, $sfile, $dftp, $dfile) = @_;
+ $sftp->pasv_xfer($sfile, $dftp, $dfile, 1);
+}
+
+
+sub pasv_xfer {
+ my ($sftp, $sfile, $dftp, $dfile, $unique) = @_;
+
+ ($dfile = $sfile) =~ s#.*/##
+ unless (defined $dfile);
+
+ my $port = $sftp->pasv
+ or return undef;
+
+ $dftp->port($port)
+ or return undef;
+
+ return undef
+ unless ($unique ? $dftp->stou($dfile) : $dftp->stor($dfile));
+
+ unless ($sftp->retr($sfile) && $sftp->response == CMD_INFO) {
+ $sftp->retr($sfile);
+ $dftp->abort;
+ $dftp->response();
+ return undef;
+ }
+
+ $dftp->pasv_wait($sftp);
+}
+
+
+sub pasv_wait {
+ @_ == 2 or croak 'usage: $ftp->pasv_wait(NON_PASV_FTP)';
+
+ my ($ftp, $non_pasv) = @_;
+ my ($file, $rin, $rout);
+
+ vec($rin = '', fileno($ftp), 1) = 1;
+ select($rout = $rin, undef, undef, undef);
+
+ $ftp->response();
+ $non_pasv->response();
+
+ return undef
+ unless $ftp->ok() && $non_pasv->ok();
+
+ return $1
+ if $ftp->message =~ /unique file name:\s*(\S*)\s*\)/;
+
+ return $1
+ if $non_pasv->message =~ /unique file name:\s*(\S*)\s*\)/;
+
+ return 1;
+}
+
+
+sub feature {
+ @_ == 2 or croak 'usage: $ftp->feature( NAME )';
+ my ($ftp, $feat) = @_;
+
+ my $feature = ${*$ftp}{net_ftp_feature} ||= do {
+ my @feat;
+
+ # Example response
+ # 211-Features:
+ # MDTM
+ # REST STREAM
+ # SIZE
+ # 211 End
+
+ @feat = map { /^\s+(.*\S)/ } $ftp->message
+ if $ftp->_FEAT;
+
+ \@feat;
+ };
+
+ return grep { /^\Q$feat\E\b/i } @$feature;
+}
+
+
+sub cmd { shift->command(@_)->response() }
+
+########################################
+#
+# RFC959 commands
+#
+
+
+sub _ABOR { shift->command("ABOR")->response() == CMD_OK }
+sub _ALLO { shift->command("ALLO", @_)->response() == CMD_OK }
+sub _CDUP { shift->command("CDUP")->response() == CMD_OK }
+sub _NOOP { shift->command("NOOP")->response() == CMD_OK }
+sub _PASV { shift->command("PASV")->response() == CMD_OK }
+sub _QUIT { shift->command("QUIT")->response() == CMD_OK }
+sub _DELE { shift->command("DELE", @_)->response() == CMD_OK }
+sub _CWD { shift->command("CWD", @_)->response() == CMD_OK }
+sub _PORT { shift->command("PORT", @_)->response() == CMD_OK }
+sub _RMD { shift->command("RMD", @_)->response() == CMD_OK }
+sub _MKD { shift->command("MKD", @_)->response() == CMD_OK }
+sub _PWD { shift->command("PWD", @_)->response() == CMD_OK }
+sub _TYPE { shift->command("TYPE", @_)->response() == CMD_OK }
+sub _RNTO { shift->command("RNTO", @_)->response() == CMD_OK }
+sub _RESP { shift->command("RESP", @_)->response() == CMD_OK }
+sub _MDTM { shift->command("MDTM", @_)->response() == CMD_OK }
+sub _SIZE { shift->command("SIZE", @_)->response() == CMD_OK }
+sub _HELP { shift->command("HELP", @_)->response() == CMD_OK }
+sub _STAT { shift->command("STAT", @_)->response() == CMD_OK }
+sub _FEAT { shift->command("FEAT", @_)->response() == CMD_OK }
+sub _APPE { shift->command("APPE", @_)->response() == CMD_INFO }
+sub _LIST { shift->command("LIST", @_)->response() == CMD_INFO }
+sub _NLST { shift->command("NLST", @_)->response() == CMD_INFO }
+sub _RETR { shift->command("RETR", @_)->response() == CMD_INFO }
+sub _STOR { shift->command("STOR", @_)->response() == CMD_INFO }
+sub _STOU { shift->command("STOU", @_)->response() == CMD_INFO }
+sub _RNFR { shift->command("RNFR", @_)->response() == CMD_MORE }
+sub _REST { shift->command("REST", @_)->response() == CMD_MORE }
+sub _PASS { shift->command("PASS", @_)->response() }
+sub _ACCT { shift->command("ACCT", @_)->response() }
+sub _AUTH { shift->command("AUTH", @_)->response() }
+
+
+sub _USER {
+ my $ftp = shift;
+ my $ok = $ftp->command("USER", @_)->response();
+
+ # A certain brain dead firewall :-)
+ $ok = $ftp->command("user", @_)->response()
+ unless $ok == CMD_MORE or $ok == CMD_OK;
+
+ $ok;
+}
+
+
+sub _SMNT { shift->unsupported(@_) }
+sub _MODE { shift->unsupported(@_) }
+sub _SYST { shift->unsupported(@_) }
+sub _STRU { shift->unsupported(@_) }
+sub _REIN { shift->unsupported(@_) }
+
+1;
+
+__END__
+
+=head1 NAME
+
+Net::FTP - FTP Client class
+
+=head1 SYNOPSIS
+
+ use Net::FTP;
+
+ $ftp = Net::FTP->new("some.host.name", Debug => 0)
+ or die "Cannot connect to some.host.name: $@";
+
+ $ftp->login("anonymous",'-anonymous@')
+ or die "Cannot login ", $ftp->message;
+
+ $ftp->cwd("/pub")
+ or die "Cannot change working directory ", $ftp->message;
+
+ $ftp->get("that.file")
+ or die "get failed ", $ftp->message;
+
+ $ftp->quit;
+
+=head1 DESCRIPTION
+
+C<Net::FTP> is a class implementing a simple FTP client in Perl as
+described in RFC959. It provides wrappers for a subset of the RFC959
+commands.
+
+=head1 OVERVIEW
+
+FTP stands for File Transfer Protocol. It is a way of transferring
+files between networked machines. The protocol defines a client
+(whose commands are provided by this module) and a server (not
+implemented in this module). Communication is always initiated by the
+client, and the server responds with a message and a status code (and
+sometimes with data).
+
+The FTP protocol allows files to be sent to or fetched from the
+server. Each transfer involves a B<local file> (on the client) and a
+B<remote file> (on the server). In this module, the same file name
+will be used for both local and remote if only one is specified. This
+means that transferring remote file C</path/to/file> will try to put
+that file in C</path/to/file> locally, unless you specify a local file
+name.
+
+The protocol also defines several standard B<translations> which the
+file can undergo during transfer. These are ASCII, EBCDIC, binary,
+and byte. ASCII is the default type, and indicates that the sender of
+files will translate the ends of lines to a standard representation
+which the receiver will then translate back into their local
+representation. EBCDIC indicates the file being transferred is in
+EBCDIC format. Binary (also known as image) format sends the data as
+a contiguous bit stream. Byte format transfers the data as bytes, the
+values of which remain the same regardless of differences in byte size
+between the two machines (in theory - in practice you should only use
+this if you really know what you're doing).
+
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item new ([ HOST ] [, OPTIONS ])
+
+This is the constructor for a new Net::FTP object. C<HOST> is the
+name of the remote host to which an FTP connection is required.
+
+C<HOST> is optional. If C<HOST> is not given then it may instead be
+passed as the C<Host> option described below.
+
+C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
+Possible options are:
+
+B<Host> - FTP host to connect to. It may be a single scalar, as defined for
+the C<PeerAddr> option in L<IO::Socket::INET>, or a reference to
+an array with hosts to try in turn. The L</host> method will return the value
+which was used to connect to the host.
+
+
+B<Firewall> - The name of a machine which acts as an FTP firewall. This can be
+overridden by an environment variable C<FTP_FIREWALL>. If specified, and the
+given host cannot be directly connected to, then the
+connection is made to the firewall machine and the string C<@hostname> is
+appended to the login identifier. This kind of setup is also referred to
+as an ftp proxy.
+
+B<FirewallType> - The type of firewall running on the machine indicated by
+B<Firewall>. This can be overridden by an environment variable
+C<FTP_FIREWALL_TYPE>. For a list of permissible types, see the description of
+ftp_firewall_type in L<Net::Config>.
+
+B<BlockSize> - This is the block size that Net::FTP will use when doing
+transfers. (defaults to 10240)
+
+B<Port> - The port number to connect to on the remote machine for the
+FTP connection
+
+B<Timeout> - Set a timeout value (defaults to 120)
+
+B<Debug> - debug level (see the debug method in L<Net::Cmd>)
+
+B<Passive> - If set to a non-zero value then all data transfers will
+be done using passive mode. If set to zero then data transfers will be
+done using active mode. If the machine is connected to the Internet
+directly, both passive and active mode should work equally well.
+Behind most firewall and NAT configurations passive mode has a better
+chance of working. However, in some rare firewall configurations,
+active mode actually works when passive mode doesn't. Some really old
+FTP servers might not implement passive transfers. If not specified,
+then the transfer mode is set by the environment variable
+C<FTP_PASSIVE> or if that one is not set by the settings done by the
+F<libnetcfg> utility. If none of these apply then passive mode is
+used.
+
+B<Hash> - If given a reference to a file handle (e.g., C<\*STDERR>),
+print hash marks (#) on that filehandle every 1024 bytes. This
+simply invokes the C<hash()> method for you, so that hash marks
+are displayed for all transfers. You can, of course, call C<hash()>
+explicitly whenever you'd like.
+
+B<LocalAddr> - Local address to use for all socket connections, this
+argument will be passed to L<IO::Socket::INET>
+
+If the constructor fails undef will be returned and an error message will
+be in $@
+
+=back
+
+=head1 METHODS
+
+Unless otherwise stated all methods return either a I<true> or I<false>
+value, with I<true> meaning that the operation was a success. When a method
+states that it returns a value, failure will be returned as I<undef> or an
+empty list.
+
+=over 4
+
+=item login ([LOGIN [,PASSWORD [, ACCOUNT] ] ])
+
+Log into the remote FTP server with the given login information. If
+no arguments are given then the C<Net::FTP> uses the C<Net::Netrc>
+package to lookup the login information for the connected host.
+If no information is found then a login of I<anonymous> is used.
+If no password is given and the login is I<anonymous> then I<anonymous@>
+will be used for password.
+
+If the connection is via a firewall then the C<authorize> method will
+be called with no arguments.
+
+=item authorize ( [AUTH [, RESP]])
+
+This is a protocol used by some firewall ftp proxies. It is used
+to authorise the user to send data out. If both arguments are not specified
+then C<authorize> uses C<Net::Netrc> to do a lookup.
+
+=item site (ARGS)
+
+Send a SITE command to the remote server and wait for a response.
+
+Returns most significant digit of the response code.
+
+=item ascii
+
+Transfer file in ASCII. CRLF translation will be done if required
+
+=item binary
+
+Transfer file in binary mode. No transformation will be done.
+
+B<Hint>: If both server and client machines use the same line ending for
+text files, then it will be faster to transfer all files in binary mode.
+
+=item rename ( OLDNAME, NEWNAME )
+
+Rename a file on the remote FTP server from C<OLDNAME> to C<NEWNAME>. This
+is done by sending the RNFR and RNTO commands.
+
+=item delete ( FILENAME )
+
+Send a request to the server to delete C<FILENAME>.
+
+=item cwd ( [ DIR ] )
+
+Attempt to change directory to the directory given in C<$dir>. If
+C<$dir> is C<"..">, the FTP C<CDUP> command is used to attempt to
+move up one directory. If no directory is given then an attempt is made
+to change the directory to the root directory.
+
+=item cdup ()
+
+Change directory to the parent of the current directory.
+
+=item pwd ()
+
+Returns the full pathname of the current directory.
+
+=item restart ( WHERE )
+
+Set the byte offset at which to begin the next data transfer. Net::FTP simply
+records this value and uses it when during the next data transfer. For this
+reason this method will not return an error, but setting it may cause
+a subsequent data transfer to fail.
+
+=item rmdir ( DIR [, RECURSE ])
+
+Remove the directory with the name C<DIR>. If C<RECURSE> is I<true> then
+C<rmdir> will attempt to delete everything inside the directory.
+
+=item mkdir ( DIR [, RECURSE ])
+
+Create a new directory with the name C<DIR>. If C<RECURSE> is I<true> then
+C<mkdir> will attempt to create all the directories in the given path.
+
+Returns the full pathname to the new directory.
+
+=item alloc ( SIZE [, RECORD_SIZE] )
+
+The alloc command allows you to give the ftp server a hint about the size
+of the file about to be transferred using the ALLO ftp command. Some storage
+systems use this to make intelligent decisions about how to store the file.
+The C<SIZE> argument represents the size of the file in bytes. The
+C<RECORD_SIZE> argument indicates a maximum record or page size for files
+sent with a record or page structure.
+
+The size of the file will be determined, and sent to the server
+automatically for normal files so that this method need only be called if
+you are transferring data from a socket, named pipe, or other stream not
+associated with a normal file.
+
+=item ls ( [ DIR ] )
+
+Get a directory listing of C<DIR>, or the current directory.
+
+In an array context, returns a list of lines returned from the server. In
+a scalar context, returns a reference to a list.
+
+=item dir ( [ DIR ] )
+
+Get a directory listing of C<DIR>, or the current directory in long format.
+
+In an array context, returns a list of lines returned from the server. In
+a scalar context, returns a reference to a list.
+
+=item get ( REMOTE_FILE [, LOCAL_FILE [, WHERE]] )
+
+Get C<REMOTE_FILE> from the server and store locally. C<LOCAL_FILE> may be
+a filename or a filehandle. If not specified, the file will be stored in
+the current directory with the same leafname as the remote file.
+
+If C<WHERE> is given then the first C<WHERE> bytes of the file will
+not be transferred, and the remaining bytes will be appended to
+the local file if it already exists.
+
+Returns C<LOCAL_FILE>, or the generated local file name if C<LOCAL_FILE>
+is not given. If an error was encountered undef is returned.
+
+=item put ( LOCAL_FILE [, REMOTE_FILE ] )
+
+Put a file on the remote server. C<LOCAL_FILE> may be a name or a filehandle.
+If C<LOCAL_FILE> is a filehandle then C<REMOTE_FILE> must be specified. If
+C<REMOTE_FILE> is not specified then the file will be stored in the current
+directory with the same leafname as C<LOCAL_FILE>.
+
+Returns C<REMOTE_FILE>, or the generated remote filename if C<REMOTE_FILE>
+is not given.
+
+B<NOTE>: If for some reason the transfer does not complete and an error is
+returned then the contents that had been transferred will not be remove
+automatically.
+
+=item put_unique ( LOCAL_FILE [, REMOTE_FILE ] )
+
+Same as put but uses the C<STOU> command.
+
+Returns the name of the file on the server.
+
+=item append ( LOCAL_FILE [, REMOTE_FILE ] )
+
+Same as put but appends to the file on the remote server.
+
+Returns C<REMOTE_FILE>, or the generated remote filename if C<REMOTE_FILE>
+is not given.
+
+=item unique_name ()
+
+Returns the name of the last file stored on the server using the
+C<STOU> command.
+
+=item mdtm ( FILE )
+
+Returns the I<modification time> of the given file
+
+=item size ( FILE )
+
+Returns the size in bytes for the given file as stored on the remote server.
+
+B<NOTE>: The size reported is the size of the stored file on the remote server.
+If the file is subsequently transferred from the server in ASCII mode
+and the remote server and local machine have different ideas about
+"End Of Line" then the size of file on the local machine after transfer
+may be different.
+
+=item supported ( CMD )
+
+Returns TRUE if the remote server supports the given command.
+
+=item hash ( [FILEHANDLE_GLOB_REF],[ BYTES_PER_HASH_MARK] )
+
+Called without parameters, or with the first argument false, hash marks
+are suppressed. If the first argument is true but not a reference to a
+file handle glob, then \*STDERR is used. The second argument is the number
+of bytes per hash mark printed, and defaults to 1024. In all cases the
+return value is a reference to an array of two: the filehandle glob reference
+and the bytes per hash mark.
+
+=item feature ( NAME )
+
+Determine if the server supports the specified feature. The return
+value is a list of lines the server responded with to describe the
+options that it supports for the given feature. If the feature is
+unsupported then the empty list is returned.
+
+ if ($ftp->feature( 'MDTM' )) {
+ # Do something
+ }
+
+ if (grep { /\bTLS\b/ } $ftp->feature('AUTH')) {
+ # Server supports TLS
+ }
+
+=back
+
+The following methods can return different results depending on
+how they are called. If the user explicitly calls either
+of the C<pasv> or C<port> methods then these methods will
+return a I<true> or I<false> value. If the user does not
+call either of these methods then the result will be a
+reference to a C<Net::FTP::dataconn> based object.
+
+=over 4
+
+=item nlst ( [ DIR ] )
+
+Send an C<NLST> command to the server, with an optional parameter.
+
+=item list ( [ DIR ] )
+
+Same as C<nlst> but using the C<LIST> command
+
+=item retr ( FILE )
+
+Begin the retrieval of a file called C<FILE> from the remote server.
+
+=item stor ( FILE )
+
+Tell the server that you wish to store a file. C<FILE> is the
+name of the new file that should be created.
+
+=item stou ( FILE )
+
+Same as C<stor> but using the C<STOU> command. The name of the unique
+file which was created on the server will be available via the C<unique_name>
+method after the data connection has been closed.
+
+=item appe ( FILE )
+
+Tell the server that we want to append some data to the end of a file
+called C<FILE>. If this file does not exist then create it.
+
+=back
+
+If for some reason you want to have complete control over the data connection,
+this includes generating it and calling the C<response> method when required,
+then the user can use these methods to do so.
+
+However calling these methods only affects the use of the methods above that
+can return a data connection. They have no effect on methods C<get>, C<put>,
+C<put_unique> and those that do not require data connections.
+
+=over 4
+
+=item port ( [ PORT ] )
+
+Send a C<PORT> command to the server. If C<PORT> is specified then it is sent
+to the server. If not, then a listen socket is created and the correct information
+sent to the server.
+
+=item pasv ()
+
+Tell the server to go into passive mode. Returns the text that represents the
+port on which the server is listening, this text is in a suitable form to
+sent to another ftp server using the C<port> method.
+
+=back
+
+The following methods can be used to transfer files between two remote
+servers, providing that these two servers can connect directly to each other.
+
+=over 4
+
+=item pasv_xfer ( SRC_FILE, DEST_SERVER [, DEST_FILE ] )
+
+This method will do a file transfer between two remote ftp servers. If
+C<DEST_FILE> is omitted then the leaf name of C<SRC_FILE> will be used.
+
+=item pasv_xfer_unique ( SRC_FILE, DEST_SERVER [, DEST_FILE ] )
+
+Like C<pasv_xfer> but the file is stored on the remote server using
+the STOU command.
+
+=item pasv_wait ( NON_PASV_SERVER )
+
+This method can be used to wait for a transfer to complete between a passive
+server and a non-passive server. The method should be called on the passive
+server with the C<Net::FTP> object for the non-passive server passed as an
+argument.
+
+=item abort ()
+
+Abort the current data transfer.
+
+=item quit ()
+
+Send the QUIT command to the remote FTP server and close the socket connection.
+
+=back
+
+=head2 Methods for the adventurous
+
+C<Net::FTP> inherits from C<Net::Cmd> so methods defined in C<Net::Cmd> may
+be used to send commands to the remote FTP server.
+
+=over 4
+
+=item quot (CMD [,ARGS])
+
+Send a command, that Net::FTP does not directly support, to the remote
+server and wait for a response.
+
+Returns most significant digit of the response code.
+
+B<WARNING> This call should only be used on commands that do not require
+data connections. Misuse of this method can hang the connection.
+
+=back
+
+=head1 THE dataconn CLASS
+
+Some of the methods defined in C<Net::FTP> return an object which will
+be derived from this class.The dataconn class itself is derived from
+the C<IO::Socket::INET> class, so any normal IO operations can be performed.
+However the following methods are defined in the dataconn class and IO should
+be performed using these.
+
+=over 4
+
+=item read ( BUFFER, SIZE [, TIMEOUT ] )
+
+Read C<SIZE> bytes of data from the server and place it into C<BUFFER>, also
+performing any <CRLF> translation necessary. C<TIMEOUT> is optional, if not
+given, the timeout value from the command connection will be used.
+
+Returns the number of bytes read before any <CRLF> translation.
+
+=item write ( BUFFER, SIZE [, TIMEOUT ] )
+
+Write C<SIZE> bytes of data from C<BUFFER> to the server, also
+performing any <CRLF> translation necessary. C<TIMEOUT> is optional, if not
+given, the timeout value from the command connection will be used.
+
+Returns the number of bytes written before any <CRLF> translation.
+
+=item bytes_read ()
+
+Returns the number of bytes read so far.
+
+=item abort ()
+
+Abort the current data transfer.
+
+=item close ()
+
+Close the data connection and get a response from the FTP server. Returns
+I<true> if the connection was closed successfully and the first digit of
+the response from the server was a '2'.
+
+=back
+
+=head1 UNIMPLEMENTED
+
+The following RFC959 commands have not been implemented:
+
+=over 4
+
+=item B<SMNT>
+
+Mount a different file system structure without changing login or
+accounting information.
+
+=item B<HELP>
+
+Ask the server for "helpful information" (that's what the RFC says) on
+the commands it accepts.
+
+=item B<MODE>
+
+Specifies transfer mode (stream, block or compressed) for file to be
+transferred.
+
+=item B<SYST>
+
+Request remote server system identification.
+
+=item B<STAT>
+
+Request remote server status.
+
+=item B<STRU>
+
+Specifies file structure for file to be transferred.
+
+=item B<REIN>
+
+Reinitialize the connection, flushing all I/O and account information.
+
+=back
+
+=head1 REPORTING BUGS
+
+When reporting bugs/problems please include as much information as possible.
+It may be difficult for me to reproduce the problem as almost every setup
+is different.
+
+A small script which yields the problem will probably be of help. It would
+also be useful if this script was run with the extra options C<Debug => 1>
+passed to the constructor, and the output sent with the bug report. If you
+cannot include a small script then please include a Debug trace from a
+run of your program which does yield the problem.
+
+=head1 AUTHOR
+
+Graham Barr <gbarr at pobox.com>
+
+=head1 SEE ALSO
+
+L<Net::Netrc>
+L<Net::Cmd>
+
+ftp(1), ftpd(8), RFC 959
+http://www.cis.ohio-state.edu/htbin/rfc/rfc959.html
+
+=head1 USE EXAMPLES
+
+For an example of the use of Net::FTP see
+
+=over 4
+
+=item http://www.csh.rit.edu/~adam/Progs/
+
+C<autoftp> is a program that can retrieve, send, or list files via
+the FTP protocol in a non-interactive manner.
+
+=back
+
+=head1 CREDITS
+
+Henry Gabryjelski <henryg at WPI.EDU> - for the suggestion of creating directories
+recursively.
+
+Nathan Torkington <gnat at frii.com> - for some input on the documentation.
+
+Roderick Schertler <roderick at gate.net> - for various inputs
+
+=head1 COPYRIGHT
+
+Copyright (c) 1995-2004 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.
+
+=cut
Copied: trunk/contrib/perl/lib/Net/Hostname.pm.eg (from rev 6437, vendor/perl/5.18.1/lib/Net/Hostname.pm.eg)
===================================================================
--- trunk/contrib/perl/lib/Net/Hostname.pm.eg (rev 0)
+++ trunk/contrib/perl/lib/Net/Hostname.pm.eg 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,14 @@
+#
+
+package Sys::Hostname;
+
+use Net::Domain qw(hostname);
+use Carp;
+
+require Exporter;
+ at ISA = qw(Exporter);
+ at EXPORT = qw(hostname);
+
+carp "deprecated package 'Sys::Hostname', use Net::Domain" if $^W;
+
+1;
Copied: trunk/contrib/perl/lib/Net/NNTP.pm (from rev 6437, vendor/perl/5.18.1/lib/Net/NNTP.pm)
===================================================================
--- trunk/contrib/perl/lib/Net/NNTP.pm (rev 0)
+++ trunk/contrib/perl/lib/Net/NNTP.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,1140 @@
+# Net::NNTP.pm
+#
+# Copyright (c) 1995-1997 Graham Barr <gbarr at pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Net::NNTP;
+
+use strict;
+use vars qw(@ISA $VERSION $debug);
+use IO::Socket;
+use Net::Cmd;
+use Carp;
+use Time::Local;
+use Net::Config;
+
+$VERSION = "2.24";
+ at ISA = qw(Net::Cmd IO::Socket::INET);
+
+
+sub new {
+ my $self = shift;
+ my $type = ref($self) || $self;
+ my ($host, %arg);
+ if (@_ % 2) {
+ $host = shift;
+ %arg = @_;
+ }
+ else {
+ %arg = @_;
+ $host = delete $arg{Host};
+ }
+ my $obj;
+
+ $host ||= $ENV{NNTPSERVER} || $ENV{NEWSHOST};
+
+ my $hosts = defined $host ? [$host] : $NetConfig{nntp_hosts};
+
+ @{$hosts} = qw(news)
+ unless @{$hosts};
+
+ my $h;
+ foreach $h (@{$hosts}) {
+ $obj = $type->SUPER::new(
+ PeerAddr => ($host = $h),
+ PeerPort => $arg{Port} || 'nntp(119)',
+ Proto => 'tcp',
+ Timeout => defined $arg{Timeout}
+ ? $arg{Timeout}
+ : 120
+ )
+ and last;
+ }
+
+ return undef
+ unless defined $obj;
+
+ ${*$obj}{'net_nntp_host'} = $host;
+
+ $obj->autoflush(1);
+ $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
+
+ unless ($obj->response() == CMD_OK) {
+ $obj->close;
+ return undef;
+ }
+
+ my $c = $obj->code;
+ my @m = $obj->message;
+
+ unless (exists $arg{Reader} && $arg{Reader} == 0) {
+
+ # if server is INN and we have transfer rights the we are currently
+ # talking to innd not nnrpd
+ if ($obj->reader) {
+
+ # If reader suceeds the we need to consider this code to determine postok
+ $c = $obj->code;
+ }
+ else {
+
+ # I want to ignore this failure, so restore the previous status.
+ $obj->set_status($c, \@m);
+ }
+ }
+
+ ${*$obj}{'net_nntp_post'} = $c == 200 ? 1 : 0;
+
+ $obj;
+}
+
+
+sub host {
+ my $me = shift;
+ ${*$me}{'net_nntp_host'};
+}
+
+
+sub debug_text {
+ my $nntp = shift;
+ my $inout = shift;
+ my $text = shift;
+
+ if ( (ref($nntp) and $nntp->code == 350 and $text =~ /^(\S+)/)
+ || ($text =~ /^(authinfo\s+pass)/io))
+ {
+ $text = "$1 ....\n";
+ }
+
+ $text;
+}
+
+
+sub postok {
+ @_ == 1 or croak 'usage: $nntp->postok()';
+ my $nntp = shift;
+ ${*$nntp}{'net_nntp_post'} || 0;
+}
+
+
+sub article {
+ @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->article( [ MSGID ], [ FH ] )';
+ my $nntp = shift;
+ my @fh;
+
+ @fh = (pop) if @_ == 2 || (@_ && (ref($_[0]) || ref(\$_[0]) eq 'GLOB'));
+
+ $nntp->_ARTICLE(@_)
+ ? $nntp->read_until_dot(@fh)
+ : undef;
+}
+
+
+sub articlefh {
+ @_ >= 1 && @_ <= 2 or croak 'usage: $nntp->articlefh( [ MSGID ] )';
+ my $nntp = shift;
+
+ return unless $nntp->_ARTICLE(@_);
+ return $nntp->tied_fh;
+}
+
+
+sub authinfo {
+ @_ == 3 or croak 'usage: $nntp->authinfo( USER, PASS )';
+ my ($nntp, $user, $pass) = @_;
+
+ $nntp->_AUTHINFO("USER", $user) == CMD_MORE
+ && $nntp->_AUTHINFO("PASS", $pass) == CMD_OK;
+}
+
+
+sub authinfo_simple {
+ @_ == 3 or croak 'usage: $nntp->authinfo( USER, PASS )';
+ my ($nntp, $user, $pass) = @_;
+
+ $nntp->_AUTHINFO('SIMPLE') == CMD_MORE
+ && $nntp->command($user, $pass)->response == CMD_OK;
+}
+
+
+sub body {
+ @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->body( [ MSGID ], [ FH ] )';
+ my $nntp = shift;
+ my @fh;
+
+ @fh = (pop) if @_ == 2 || (@_ && ref($_[0]) || ref(\$_[0]) eq 'GLOB');
+
+ $nntp->_BODY(@_)
+ ? $nntp->read_until_dot(@fh)
+ : undef;
+}
+
+
+sub bodyfh {
+ @_ >= 1 && @_ <= 2 or croak 'usage: $nntp->bodyfh( [ MSGID ] )';
+ my $nntp = shift;
+ return unless $nntp->_BODY(@_);
+ return $nntp->tied_fh;
+}
+
+
+sub head {
+ @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->head( [ MSGID ], [ FH ] )';
+ my $nntp = shift;
+ my @fh;
+
+ @fh = (pop) if @_ == 2 || (@_ && ref($_[0]) || ref(\$_[0]) eq 'GLOB');
+
+ $nntp->_HEAD(@_)
+ ? $nntp->read_until_dot(@fh)
+ : undef;
+}
+
+
+sub headfh {
+ @_ >= 1 && @_ <= 2 or croak 'usage: $nntp->headfh( [ MSGID ] )';
+ my $nntp = shift;
+ return unless $nntp->_HEAD(@_);
+ return $nntp->tied_fh;
+}
+
+
+sub nntpstat {
+ @_ == 1 || @_ == 2 or croak 'usage: $nntp->nntpstat( [ MSGID ] )';
+ my $nntp = shift;
+
+ $nntp->_STAT(@_) && $nntp->message =~ /(<[^>]+>)/o
+ ? $1
+ : undef;
+}
+
+
+sub group {
+ @_ == 1 || @_ == 2 or croak 'usage: $nntp->group( [ GROUP ] )';
+ my $nntp = shift;
+ my $grp = ${*$nntp}{'net_nntp_group'} || undef;
+
+ return $grp
+ unless (@_ || wantarray);
+
+ my $newgrp = shift;
+
+ return wantarray ? () : undef
+ unless $nntp->_GROUP($newgrp || $grp || "")
+ && $nntp->message =~ /(\d+)\s+(\d+)\s+(\d+)\s+(\S+)/;
+
+ my ($count, $first, $last, $group) = ($1, $2, $3, $4);
+
+ # group may be replied as '(current group)'
+ $group = ${*$nntp}{'net_nntp_group'}
+ if $group =~ /\(/;
+
+ ${*$nntp}{'net_nntp_group'} = $group;
+
+ wantarray
+ ? ($count, $first, $last, $group)
+ : $group;
+}
+
+
+sub help {
+ @_ == 1 or croak 'usage: $nntp->help()';
+ my $nntp = shift;
+
+ $nntp->_HELP
+ ? $nntp->read_until_dot
+ : undef;
+}
+
+
+sub ihave {
+ @_ >= 2 or croak 'usage: $nntp->ihave( MESSAGE-ID [, MESSAGE ])';
+ my $nntp = shift;
+ my $mid = shift;
+
+ $nntp->_IHAVE($mid) && $nntp->datasend(@_)
+ ? @_ == 0 || $nntp->dataend
+ : undef;
+}
+
+
+sub last {
+ @_ == 1 or croak 'usage: $nntp->last()';
+ my $nntp = shift;
+
+ $nntp->_LAST && $nntp->message =~ /(<[^>]+>)/o
+ ? $1
+ : undef;
+}
+
+
+sub list {
+ @_ == 1 or croak 'usage: $nntp->list()';
+ my $nntp = shift;
+
+ $nntp->_LIST
+ ? $nntp->_grouplist
+ : undef;
+}
+
+
+sub newgroups {
+ @_ >= 2 or croak 'usage: $nntp->newgroups( SINCE [, DISTRIBUTIONS ])';
+ my $nntp = shift;
+ my $time = _timestr(shift);
+ my $dist = shift || "";
+
+ $dist = join(",", @{$dist})
+ if ref($dist);
+
+ $nntp->_NEWGROUPS($time, $dist)
+ ? $nntp->_grouplist
+ : undef;
+}
+
+
+sub newnews {
+ @_ >= 2 && @_ <= 4
+ or croak 'usage: $nntp->newnews( SINCE [, GROUPS [, DISTRIBUTIONS ]])';
+ my $nntp = shift;
+ my $time = _timestr(shift);
+ my $grp = @_ ? shift: $nntp->group;
+ my $dist = shift || "";
+
+ $grp ||= "*";
+ $grp = join(",", @{$grp})
+ if ref($grp);
+
+ $dist = join(",", @{$dist})
+ if ref($dist);
+
+ $nntp->_NEWNEWS($grp, $time, $dist)
+ ? $nntp->_articlelist
+ : undef;
+}
+
+
+sub next {
+ @_ == 1 or croak 'usage: $nntp->next()';
+ my $nntp = shift;
+
+ $nntp->_NEXT && $nntp->message =~ /(<[^>]+>)/o
+ ? $1
+ : undef;
+}
+
+
+sub post {
+ @_ >= 1 or croak 'usage: $nntp->post( [ MESSAGE ] )';
+ my $nntp = shift;
+
+ $nntp->_POST() && $nntp->datasend(@_)
+ ? @_ == 0 || $nntp->dataend
+ : undef;
+}
+
+
+sub postfh {
+ my $nntp = shift;
+ return unless $nntp->_POST();
+ return $nntp->tied_fh;
+}
+
+
+sub quit {
+ @_ == 1 or croak 'usage: $nntp->quit()';
+ my $nntp = shift;
+
+ $nntp->_QUIT;
+ $nntp->close;
+}
+
+
+sub slave {
+ @_ == 1 or croak 'usage: $nntp->slave()';
+ my $nntp = shift;
+
+ $nntp->_SLAVE;
+}
+
+##
+## The following methods are not implemented by all servers
+##
+
+
+sub active {
+ @_ == 1 || @_ == 2 or croak 'usage: $nntp->active( [ PATTERN ] )';
+ my $nntp = shift;
+
+ $nntp->_LIST('ACTIVE', @_)
+ ? $nntp->_grouplist
+ : undef;
+}
+
+
+sub active_times {
+ @_ == 1 or croak 'usage: $nntp->active_times()';
+ my $nntp = shift;
+
+ $nntp->_LIST('ACTIVE.TIMES')
+ ? $nntp->_grouplist
+ : undef;
+}
+
+
+sub distributions {
+ @_ == 1 or croak 'usage: $nntp->distributions()';
+ my $nntp = shift;
+
+ $nntp->_LIST('DISTRIBUTIONS')
+ ? $nntp->_description
+ : undef;
+}
+
+
+sub distribution_patterns {
+ @_ == 1 or croak 'usage: $nntp->distributions()';
+ my $nntp = shift;
+
+ my $arr;
+ local $_;
+
+ $nntp->_LIST('DISTRIB.PATS')
+ && ($arr = $nntp->read_until_dot)
+ ? [grep { /^\d/ && (chomp, $_ = [split /:/]) } @$arr]
+ : undef;
+}
+
+
+sub newsgroups {
+ @_ == 1 || @_ == 2 or croak 'usage: $nntp->newsgroups( [ PATTERN ] )';
+ my $nntp = shift;
+
+ $nntp->_LIST('NEWSGROUPS', @_)
+ ? $nntp->_description
+ : undef;
+}
+
+
+sub overview_fmt {
+ @_ == 1 or croak 'usage: $nntp->overview_fmt()';
+ my $nntp = shift;
+
+ $nntp->_LIST('OVERVIEW.FMT')
+ ? $nntp->_articlelist
+ : undef;
+}
+
+
+sub subscriptions {
+ @_ == 1 or croak 'usage: $nntp->subscriptions()';
+ my $nntp = shift;
+
+ $nntp->_LIST('SUBSCRIPTIONS')
+ ? $nntp->_articlelist
+ : undef;
+}
+
+
+sub listgroup {
+ @_ == 1 || @_ == 2 or croak 'usage: $nntp->listgroup( [ GROUP ] )';
+ my $nntp = shift;
+
+ $nntp->_LISTGROUP(@_)
+ ? $nntp->_articlelist
+ : undef;
+}
+
+
+sub reader {
+ @_ == 1 or croak 'usage: $nntp->reader()';
+ my $nntp = shift;
+
+ $nntp->_MODE('READER');
+}
+
+
+sub xgtitle {
+ @_ == 1 || @_ == 2 or croak 'usage: $nntp->xgtitle( [ PATTERN ] )';
+ my $nntp = shift;
+
+ $nntp->_XGTITLE(@_)
+ ? $nntp->_description
+ : undef;
+}
+
+
+sub xhdr {
+ @_ >= 2 && @_ <= 4 or croak 'usage: $nntp->xhdr( HEADER, [ MESSAGE-SPEC ] )';
+ my $nntp = shift;
+ my $hdr = shift;
+ my $arg = _msg_arg(@_);
+
+ $nntp->_XHDR($hdr, $arg)
+ ? $nntp->_description
+ : undef;
+}
+
+
+sub xover {
+ @_ == 2 || @_ == 3 or croak 'usage: $nntp->xover( MESSAGE-SPEC )';
+ my $nntp = shift;
+ my $arg = _msg_arg(@_);
+
+ $nntp->_XOVER($arg)
+ ? $nntp->_fieldlist
+ : undef;
+}
+
+
+sub xpat {
+ @_ == 4 || @_ == 5 or croak '$nntp->xpat( HEADER, PATTERN, MESSAGE-SPEC )';
+ my $nntp = shift;
+ my $hdr = shift;
+ my $pat = shift;
+ my $arg = _msg_arg(@_);
+
+ $pat = join(" ", @$pat)
+ if ref($pat);
+
+ $nntp->_XPAT($hdr, $arg, $pat)
+ ? $nntp->_description
+ : undef;
+}
+
+
+sub xpath {
+ @_ == 2 or croak 'usage: $nntp->xpath( MESSAGE-ID )';
+ my ($nntp, $mid) = @_;
+
+ return undef
+ unless $nntp->_XPATH($mid);
+
+ my $m;
+ ($m = $nntp->message) =~ s/^\d+\s+//o;
+ my @p = split /\s+/, $m;
+
+ wantarray ? @p : $p[0];
+}
+
+
+sub xrover {
+ @_ == 2 || @_ == 3 or croak 'usage: $nntp->xrover( MESSAGE-SPEC )';
+ my $nntp = shift;
+ my $arg = _msg_arg(@_);
+
+ $nntp->_XROVER($arg)
+ ? $nntp->_description
+ : undef;
+}
+
+
+sub date {
+ @_ == 1 or croak 'usage: $nntp->date()';
+ my $nntp = shift;
+
+ $nntp->_DATE
+ && $nntp->message =~ /(\d{4})(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/
+ ? timegm($6, $5, $4, $3, $2 - 1, $1 - 1900)
+ : undef;
+}
+
+
+##
+## Private subroutines
+##
+
+
+sub _msg_arg {
+ my $spec = shift;
+ my $arg = "";
+
+ if (@_) {
+ carp "Depriciated passing of two message numbers, " . "pass a reference"
+ if $^W;
+ $spec = [$spec, $_[0]];
+ }
+
+ if (defined $spec) {
+ if (ref($spec)) {
+ $arg = $spec->[0];
+ if (defined $spec->[1]) {
+ $arg .= "-"
+ if $spec->[1] != $spec->[0];
+ $arg .= $spec->[1]
+ if $spec->[1] > $spec->[0];
+ }
+ }
+ else {
+ $arg = $spec;
+ }
+ }
+
+ $arg;
+}
+
+
+sub _timestr {
+ my $time = shift;
+ my @g = reverse((gmtime($time))[0 .. 5]);
+ $g[1] += 1;
+ $g[0] %= 100;
+ sprintf "%02d%02d%02d %02d%02d%02d GMT", @g;
+}
+
+
+sub _grouplist {
+ my $nntp = shift;
+ my $arr = $nntp->read_until_dot
+ or return undef;
+
+ my $hash = {};
+ my $ln;
+
+ foreach $ln (@$arr) {
+ my @a = split(/[\s\n]+/, $ln);
+ $hash->{$a[0]} = [@a[1, 2, 3]];
+ }
+
+ $hash;
+}
+
+
+sub _fieldlist {
+ my $nntp = shift;
+ my $arr = $nntp->read_until_dot
+ or return undef;
+
+ my $hash = {};
+ my $ln;
+
+ foreach $ln (@$arr) {
+ my @a = split(/[\t\n]/, $ln);
+ my $m = shift @a;
+ $hash->{$m} = [@a];
+ }
+
+ $hash;
+}
+
+
+sub _articlelist {
+ my $nntp = shift;
+ my $arr = $nntp->read_until_dot;
+
+ chomp(@$arr)
+ if $arr;
+
+ $arr;
+}
+
+
+sub _description {
+ my $nntp = shift;
+ my $arr = $nntp->read_until_dot
+ or return undef;
+
+ my $hash = {};
+ my $ln;
+
+ foreach $ln (@$arr) {
+ chomp($ln);
+
+ $hash->{$1} = $ln
+ if $ln =~ s/^\s*(\S+)\s*//o;
+ }
+
+ $hash;
+
+}
+
+##
+## The commands
+##
+
+
+sub _ARTICLE { shift->command('ARTICLE', @_)->response == CMD_OK }
+sub _AUTHINFO { shift->command('AUTHINFO', @_)->response }
+sub _BODY { shift->command('BODY', @_)->response == CMD_OK }
+sub _DATE { shift->command('DATE')->response == CMD_INFO }
+sub _GROUP { shift->command('GROUP', @_)->response == CMD_OK }
+sub _HEAD { shift->command('HEAD', @_)->response == CMD_OK }
+sub _HELP { shift->command('HELP', @_)->response == CMD_INFO }
+sub _IHAVE { shift->command('IHAVE', @_)->response == CMD_MORE }
+sub _LAST { shift->command('LAST')->response == CMD_OK }
+sub _LIST { shift->command('LIST', @_)->response == CMD_OK }
+sub _LISTGROUP { shift->command('LISTGROUP', @_)->response == CMD_OK }
+sub _NEWGROUPS { shift->command('NEWGROUPS', @_)->response == CMD_OK }
+sub _NEWNEWS { shift->command('NEWNEWS', @_)->response == CMD_OK }
+sub _NEXT { shift->command('NEXT')->response == CMD_OK }
+sub _POST { shift->command('POST', @_)->response == CMD_MORE }
+sub _QUIT { shift->command('QUIT', @_)->response == CMD_OK }
+sub _SLAVE { shift->command('SLAVE', @_)->response == CMD_OK }
+sub _STAT { shift->command('STAT', @_)->response == CMD_OK }
+sub _MODE { shift->command('MODE', @_)->response == CMD_OK }
+sub _XGTITLE { shift->command('XGTITLE', @_)->response == CMD_OK }
+sub _XHDR { shift->command('XHDR', @_)->response == CMD_OK }
+sub _XPAT { shift->command('XPAT', @_)->response == CMD_OK }
+sub _XPATH { shift->command('XPATH', @_)->response == CMD_OK }
+sub _XOVER { shift->command('XOVER', @_)->response == CMD_OK }
+sub _XROVER { shift->command('XROVER', @_)->response == CMD_OK }
+sub _XTHREAD { shift->unsupported }
+sub _XSEARCH { shift->unsupported }
+sub _XINDEX { shift->unsupported }
+
+##
+## IO/perl methods
+##
+
+
+sub DESTROY {
+ my $nntp = shift;
+ defined(fileno($nntp)) && $nntp->quit;
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+Net::NNTP - NNTP Client class
+
+=head1 SYNOPSIS
+
+ use Net::NNTP;
+
+ $nntp = Net::NNTP->new("some.host.name");
+ $nntp->quit;
+
+=head1 DESCRIPTION
+
+C<Net::NNTP> is a class implementing a simple NNTP client in Perl as described
+in RFC977. C<Net::NNTP> inherits its communication methods from C<Net::Cmd>
+
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item new ( [ HOST ] [, OPTIONS ])
+
+This is the constructor for a new Net::NNTP object. C<HOST> is the
+name of the remote host to which a NNTP connection is required. If not
+given then it may be passed as the C<Host> option described below. If no host is passed
+then two environment variables are checked, first C<NNTPSERVER> then
+C<NEWSHOST>, then C<Net::Config> is checked, and if a host is not found
+then C<news> is used.
+
+C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
+Possible options are:
+
+B<Host> - NNTP host to connect to. It may be a single scalar, as defined for
+the C<PeerAddr> option in L<IO::Socket::INET>, or a reference to
+an array with hosts to try in turn. The L</host> method will return the value
+which was used to connect to the host.
+
+B<Timeout> - Maximum time, in seconds, to wait for a response from the
+NNTP server, a value of zero will cause all IO operations to block.
+(default: 120)
+
+B<Debug> - Enable the printing of debugging information to STDERR
+
+B<Reader> - If the remote server is INN then initially the connection
+will be to nnrpd, by default C<Net::NNTP> will issue a C<MODE READER> command
+so that the remote server becomes innd. If the C<Reader> option is given
+with a value of zero, then this command will not be sent and the
+connection will be left talking to nnrpd.
+
+=back
+
+=head1 METHODS
+
+Unless otherwise stated all methods return either a I<true> or I<false>
+value, with I<true> meaning that the operation was a success. When a method
+states that it returns a value, failure will be returned as I<undef> or an
+empty list.
+
+=over 4
+
+=item article ( [ MSGID|MSGNUM ], [FH] )
+
+Retrieve the header, a blank line, then the body (text) of the
+specified article.
+
+If C<FH> is specified then it is expected to be a valid filehandle
+and the result will be printed to it, on success a true value will be
+returned. If C<FH> is not specified then the return value, on success,
+will be a reference to an array containing the article requested, each
+entry in the array will contain one line of the article.
+
+If no arguments are passed then the current article in the currently
+selected newsgroup is fetched.
+
+C<MSGNUM> is a numeric id of an article in the current newsgroup, and
+will change the current article pointer. C<MSGID> is the message id of
+an article as shown in that article's header. It is anticipated that the
+client will obtain the C<MSGID> from a list provided by the C<newnews>
+command, from references contained within another article, or from the
+message-id provided in the response to some other commands.
+
+If there is an error then C<undef> will be returned.
+
+=item body ( [ MSGID|MSGNUM ], [FH] )
+
+Like C<article> but only fetches the body of the article.
+
+=item head ( [ MSGID|MSGNUM ], [FH] )
+
+Like C<article> but only fetches the headers for the article.
+
+=item articlefh ( [ MSGID|MSGNUM ] )
+
+=item bodyfh ( [ MSGID|MSGNUM ] )
+
+=item headfh ( [ MSGID|MSGNUM ] )
+
+These are similar to article(), body() and head(), but rather than
+returning the requested data directly, they return a tied filehandle
+from which to read the article.
+
+=item nntpstat ( [ MSGID|MSGNUM ] )
+
+The C<nntpstat> command is similar to the C<article> command except that no
+text is returned. When selecting by message number within a group,
+the C<nntpstat> command serves to set the "current article pointer" without
+sending text.
+
+Using the C<nntpstat> command to
+select by message-id is valid but of questionable value, since a
+selection by message-id does B<not> alter the "current article pointer".
+
+Returns the message-id of the "current article".
+
+=item group ( [ GROUP ] )
+
+Set and/or get the current group. If C<GROUP> is not given then information
+is returned on the current group.
+
+In a scalar context it returns the group name.
+
+In an array context the return value is a list containing, the number
+of articles in the group, the number of the first article, the number
+of the last article and the group name.
+
+=item ihave ( MSGID [, MESSAGE ])
+
+The C<ihave> command informs the server that the client has an article
+whose id is C<MSGID>. If the server desires a copy of that
+article, and C<MESSAGE> has been given the it will be sent.
+
+Returns I<true> if the server desires the article and C<MESSAGE> was
+successfully sent,if specified.
+
+If C<MESSAGE> is not specified then the message must be sent using the
+C<datasend> and C<dataend> methods from L<Net::Cmd>
+
+C<MESSAGE> can be either an array of lines or a reference to an array.
+
+=item last ()
+
+Set the "current article pointer" to the previous article in the current
+newsgroup.
+
+Returns the message-id of the article.
+
+=item date ()
+
+Returns the date on the remote server. This date will be in a UNIX time
+format (seconds since 1970)
+
+=item postok ()
+
+C<postok> will return I<true> if the servers initial response indicated
+that it will allow posting.
+
+=item authinfo ( USER, PASS )
+
+Authenticates to the server (using AUTHINFO USER / AUTHINFO PASS)
+using the supplied username and password. Please note that the
+password is sent in clear text to the server. This command should not
+be used with valuable passwords unless the connection to the server is
+somehow protected.
+
+=item list ()
+
+Obtain information about all the active newsgroups. The results is a reference
+to a hash where the key is a group name and each value is a reference to an
+array. The elements in this array are:- the last article number in the group,
+the first article number in the group and any information flags about the group.
+
+=item newgroups ( SINCE [, DISTRIBUTIONS ])
+
+C<SINCE> is a time value and C<DISTRIBUTIONS> is either a distribution
+pattern or a reference to a list of distribution patterns.
+The result is the same as C<list>, but the
+groups return will be limited to those created after C<SINCE> and, if
+specified, in one of the distribution areas in C<DISTRIBUTIONS>.
+
+=item newnews ( SINCE [, GROUPS [, DISTRIBUTIONS ]])
+
+C<SINCE> is a time value. C<GROUPS> is either a group pattern or a reference
+to a list of group patterns. C<DISTRIBUTIONS> is either a distribution
+pattern or a reference to a list of distribution patterns.
+
+Returns a reference to a list which contains the message-ids of all news posted
+after C<SINCE>, that are in a groups which matched C<GROUPS> and a
+distribution which matches C<DISTRIBUTIONS>.
+
+=item next ()
+
+Set the "current article pointer" to the next article in the current
+newsgroup.
+
+Returns the message-id of the article.
+
+=item post ( [ MESSAGE ] )
+
+Post a new article to the news server. If C<MESSAGE> is specified and posting
+is allowed then the message will be sent.
+
+If C<MESSAGE> is not specified then the message must be sent using the
+C<datasend> and C<dataend> methods from L<Net::Cmd>
+
+C<MESSAGE> can be either an array of lines or a reference to an array.
+
+The message, either sent via C<datasend> or as the C<MESSAGE>
+parameter, must be in the format as described by RFC822 and must
+contain From:, Newsgroups: and Subject: headers.
+
+=item postfh ()
+
+Post a new article to the news server using a tied filehandle. If
+posting is allowed, this method will return a tied filehandle that you
+can print() the contents of the article to be posted. You must
+explicitly close() the filehandle when you are finished posting the
+article, and the return value from the close() call will indicate
+whether the message was successfully posted.
+
+=item slave ()
+
+Tell the remote server that I am not a user client, but probably another
+news server.
+
+=item quit ()
+
+Quit the remote server and close the socket connection.
+
+=back
+
+=head2 Extension methods
+
+These methods use commands that are not part of the RFC977 documentation. Some
+servers may not support all of them.
+
+=over 4
+
+=item newsgroups ( [ PATTERN ] )
+
+Returns a reference to a hash where the keys are all the group names which
+match C<PATTERN>, or all of the groups if no pattern is specified, and
+each value contains the description text for the group.
+
+=item distributions ()
+
+Returns a reference to a hash where the keys are all the possible
+distribution names and the values are the distribution descriptions.
+
+=item subscriptions ()
+
+Returns a reference to a list which contains a list of groups which
+are recommended for a new user to subscribe to.
+
+=item overview_fmt ()
+
+Returns a reference to an array which contain the names of the fields returned
+by C<xover>.
+
+=item active_times ()
+
+Returns a reference to a hash where the keys are the group names and each
+value is a reference to an array containing the time the groups was created
+and an identifier, possibly an Email address, of the creator.
+
+=item active ( [ PATTERN ] )
+
+Similar to C<list> but only active groups that match the pattern are returned.
+C<PATTERN> can be a group pattern.
+
+=item xgtitle ( PATTERN )
+
+Returns a reference to a hash where the keys are all the group names which
+match C<PATTERN> and each value is the description text for the group.
+
+=item xhdr ( HEADER, MESSAGE-SPEC )
+
+Obtain the header field C<HEADER> for all the messages specified.
+
+The return value will be a reference
+to a hash where the keys are the message numbers and each value contains
+the text of the requested header for that message.
+
+=item xover ( MESSAGE-SPEC )
+
+The return value will be a reference
+to a hash where the keys are the message numbers and each value contains
+a reference to an array which contains the overview fields for that
+message.
+
+The names of the fields can be obtained by calling C<overview_fmt>.
+
+=item xpath ( MESSAGE-ID )
+
+Returns the path name to the file on the server which contains the specified
+message.
+
+=item xpat ( HEADER, PATTERN, MESSAGE-SPEC)
+
+The result is the same as C<xhdr> except the is will be restricted to
+headers where the text of the header matches C<PATTERN>
+
+=item xrover
+
+The XROVER command returns reference information for the article(s)
+specified.
+
+Returns a reference to a HASH where the keys are the message numbers and the
+values are the References: lines from the articles
+
+=item listgroup ( [ GROUP ] )
+
+Returns a reference to a list of all the active messages in C<GROUP>, or
+the current group if C<GROUP> is not specified.
+
+=item reader
+
+Tell the server that you are a reader and not another server.
+
+This is required by some servers. For example if you are connecting to
+an INN server and you have transfer permission your connection will
+be connected to the transfer daemon, not the NNTP daemon. Issuing
+this command will cause the transfer daemon to hand over control
+to the NNTP daemon.
+
+Some servers do not understand this command, but issuing it and ignoring
+the response is harmless.
+
+=back
+
+=head1 UNSUPPORTED
+
+The following NNTP command are unsupported by the package, and there are
+no plans to do so.
+
+ AUTHINFO GENERIC
+ XTHREAD
+ XSEARCH
+ XINDEX
+
+=head1 DEFINITIONS
+
+=over 4
+
+=item MESSAGE-SPEC
+
+C<MESSAGE-SPEC> is either a single message-id, a single message number, or
+a reference to a list of two message numbers.
+
+If C<MESSAGE-SPEC> is a reference to a list of two message numbers and the
+second number in a range is less than or equal to the first then the range
+represents all messages in the group after the first message number.
+
+B<NOTE> For compatibility reasons only with earlier versions of Net::NNTP
+a message spec can be passed as a list of two numbers, this is deprecated
+and a reference to the list should now be passed
+
+=item PATTERN
+
+The C<NNTP> protocol uses the C<WILDMAT> format for patterns.
+The WILDMAT format was first developed by Rich Salz based on
+the format used in the UNIX "find" command to articulate
+file names. It was developed to provide a uniform mechanism
+for matching patterns in the same manner that the UNIX shell
+matches filenames.
+
+Patterns are implicitly anchored at the
+beginning and end of each string when testing for a match.
+
+There are five pattern matching operations other than a strict
+one-to-one match between the pattern and the source to be
+checked for a match.
+
+The first is an asterisk C<*> to match any sequence of zero or more
+characters.
+
+The second is a question mark C<?> to match any single character. The
+third specifies a specific set of characters.
+
+The set is specified as a list of characters, or as a range of characters
+where the beginning and end of the range are separated by a minus (or dash)
+character, or as any combination of lists and ranges. The dash can
+also be included in the set as a character it if is the beginning
+or end of the set. This set is enclosed in square brackets. The
+close square bracket C<]> may be used in a set if it is the first
+character in the set.
+
+The fourth operation is the same as the
+logical not of the third operation and is specified the same
+way as the third with the addition of a caret character C<^> at
+the beginning of the test string just inside the open square
+bracket.
+
+The final operation uses the backslash character to
+invalidate the special meaning of an open square bracket C<[>,
+the asterisk, backslash or the question mark. Two backslashes in
+sequence will result in the evaluation of the backslash as a
+character with no special meaning.
+
+=over 4
+
+=item Examples
+
+=item C<[^]-]>
+
+matches any single character other than a close square
+bracket or a minus sign/dash.
+
+=item C<*bdc>
+
+matches any string that ends with the string "bdc"
+including the string "bdc" (without quotes).
+
+=item C<[0-9a-zA-Z]>
+
+matches any single printable alphanumeric ASCII character.
+
+=item C<a??d>
+
+matches any four character string which begins
+with a and ends with d.
+
+=back
+
+=back
+
+=head1 SEE ALSO
+
+L<Net::Cmd>
+
+=head1 AUTHOR
+
+Graham Barr <gbarr at pobox.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1995-1997 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.
+
+=cut
Copied: trunk/contrib/perl/lib/Net/Netrc.pm (from rev 6437, vendor/perl/5.18.1/lib/Net/Netrc.pm)
===================================================================
--- trunk/contrib/perl/lib/Net/Netrc.pm (rev 0)
+++ trunk/contrib/perl/lib/Net/Netrc.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,325 @@
+# Net::Netrc.pm
+#
+# Copyright (c) 1995-1998 Graham Barr <gbarr at pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Net::Netrc;
+
+use Carp;
+use strict;
+use FileHandle;
+use vars qw($VERSION);
+
+$VERSION = "2.12";
+
+my %netrc = ();
+
+
+sub _readrc {
+ my $host = shift;
+ my ($home, $file);
+
+ if ($^O eq "MacOS") {
+ $home = $ENV{HOME} || `pwd`;
+ chomp($home);
+ $file = ($home =~ /:$/ ? $home . "netrc" : $home . ":netrc");
+ }
+ else {
+
+ # Some OS's don't have `getpwuid', so we default to $ENV{HOME}
+ $home = eval { (getpwuid($>))[7] } || $ENV{HOME};
+ $home ||= $ENV{HOMEDRIVE} . ($ENV{HOMEPATH} || '') if defined $ENV{HOMEDRIVE};
+ $file = $home . "/.netrc";
+ }
+
+ my ($login, $pass, $acct) = (undef, undef, undef);
+ my $fh;
+ local $_;
+
+ $netrc{default} = undef;
+
+ # OS/2 and Win32 do not handle stat in a way compatable with this check :-(
+ unless ($^O eq 'os2'
+ || $^O eq 'MSWin32'
+ || $^O eq 'MacOS'
+ || $^O =~ /^cygwin/)
+ {
+ my @stat = stat($file);
+
+ if (@stat) {
+ if ($stat[2] & 077) {
+ carp "Bad permissions: $file";
+ return;
+ }
+ if ($stat[4] != $<) {
+ carp "Not owner: $file";
+ return;
+ }
+ }
+ }
+
+ if ($fh = FileHandle->new($file, "r")) {
+ my ($mach, $macdef, $tok, @tok) = (0, 0);
+
+ while (<$fh>) {
+ undef $macdef if /\A\n\Z/;
+
+ if ($macdef) {
+ push(@$macdef, $_);
+ next;
+ }
+
+ s/^\s*//;
+ chomp;
+
+ while (length && s/^("((?:[^"]+|\\.)*)"|((?:[^\\\s]+|\\.)*))\s*//) {
+ (my $tok = $+) =~ s/\\(.)/$1/g;
+ push(@tok, $tok);
+ }
+
+ TOKEN:
+ while (@tok) {
+ if ($tok[0] eq "default") {
+ shift(@tok);
+ $mach = bless {};
+ $netrc{default} = [$mach];
+
+ next TOKEN;
+ }
+
+ last TOKEN
+ unless @tok > 1;
+
+ $tok = shift(@tok);
+
+ if ($tok eq "machine") {
+ my $host = shift @tok;
+ $mach = bless {machine => $host};
+
+ $netrc{$host} = []
+ unless exists($netrc{$host});
+ push(@{$netrc{$host}}, $mach);
+ }
+ elsif ($tok =~ /^(login|password|account)$/) {
+ next TOKEN unless $mach;
+ my $value = shift @tok;
+
+ # Following line added by rmerrell to remove '/' escape char in .netrc
+ $value =~ s/\/\\/\\/g;
+ $mach->{$1} = $value;
+ }
+ elsif ($tok eq "macdef") {
+ next TOKEN unless $mach;
+ my $value = shift @tok;
+ $mach->{macdef} = {}
+ unless exists $mach->{macdef};
+ $macdef = $mach->{machdef}{$value} = [];
+ }
+ }
+ }
+ $fh->close();
+ }
+}
+
+
+sub lookup {
+ my ($pkg, $mach, $login) = @_;
+
+ _readrc()
+ unless exists $netrc{default};
+
+ $mach ||= 'default';
+ undef $login
+ if $mach eq 'default';
+
+ if (exists $netrc{$mach}) {
+ if (defined $login) {
+ my $m;
+ foreach $m (@{$netrc{$mach}}) {
+ return $m
+ if (exists $m->{login} && $m->{login} eq $login);
+ }
+ return undef;
+ }
+ return $netrc{$mach}->[0];
+ }
+
+ return $netrc{default}->[0]
+ if defined $netrc{default};
+
+ return undef;
+}
+
+
+sub login {
+ my $me = shift;
+
+ exists $me->{login}
+ ? $me->{login}
+ : undef;
+}
+
+
+sub account {
+ my $me = shift;
+
+ exists $me->{account}
+ ? $me->{account}
+ : undef;
+}
+
+
+sub password {
+ my $me = shift;
+
+ exists $me->{password}
+ ? $me->{password}
+ : undef;
+}
+
+
+sub lpa {
+ my $me = shift;
+ ($me->login, $me->password, $me->account);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Net::Netrc - OO interface to users netrc file
+
+=head1 SYNOPSIS
+
+ use Net::Netrc;
+
+ $mach = Net::Netrc->lookup('some.machine');
+ $login = $mach->login;
+ ($login, $password, $account) = $mach->lpa;
+
+=head1 DESCRIPTION
+
+C<Net::Netrc> is a class implementing a simple interface to the .netrc file
+used as by the ftp program.
+
+C<Net::Netrc> also implements security checks just like the ftp program,
+these checks are, first that the .netrc file must be owned by the user and
+second the ownership permissions should be such that only the owner has
+read and write access. If these conditions are not met then a warning is
+output and the .netrc file is not read.
+
+=head1 THE .netrc FILE
+
+The .netrc file contains login and initialization information used by the
+auto-login process. It resides in the user's home directory. The following
+tokens are recognized; they may be separated by spaces, tabs, or new-lines:
+
+=over 4
+
+=item machine name
+
+Identify a remote machine name. The auto-login process searches
+the .netrc file for a machine token that matches the remote machine
+specified. Once a match is made, the subsequent .netrc tokens
+are processed, stopping when the end of file is reached or an-
+other machine or a default token is encountered.
+
+=item default
+
+This is the same as machine name except that default matches
+any name. There can be only one default token, and it must be
+after all machine tokens. This is normally used as:
+
+ default login anonymous password user at site
+
+thereby giving the user automatic anonymous login to machines
+not specified in .netrc.
+
+=item login name
+
+Identify a user on the remote machine. If this token is present,
+the auto-login process will initiate a login using the
+specified name.
+
+=item password string
+
+Supply a password. If this token is present, the auto-login
+process will supply the specified string if the remote server
+requires a password as part of the login process.
+
+=item account string
+
+Supply an additional account password. If this token is present,
+the auto-login process will supply the specified string
+if the remote server requires an additional account password.
+
+=item macdef name
+
+Define a macro. C<Net::Netrc> only parses this field to be compatible
+with I<ftp>.
+
+=back
+
+=head1 CONSTRUCTOR
+
+The constructor for a C<Net::Netrc> object is not called new as it does not
+really create a new object. But instead is called C<lookup> as this is
+essentially what it does.
+
+=over 4
+
+=item lookup ( MACHINE [, LOGIN ])
+
+Lookup and return a reference to the entry for C<MACHINE>. If C<LOGIN> is given
+then the entry returned will have the given login. If C<LOGIN> is not given then
+the first entry in the .netrc file for C<MACHINE> will be returned.
+
+If a matching entry cannot be found, and a default entry exists, then a
+reference to the default entry is returned.
+
+If there is no matching entry found and there is no default defined, or
+no .netrc file is found, then C<undef> is returned.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item login ()
+
+Return the login id for the netrc entry
+
+=item password ()
+
+Return the password for the netrc entry
+
+=item account ()
+
+Return the account information for the netrc entry
+
+=item lpa ()
+
+Return a list of login, password and account information fir the netrc entry
+
+=back
+
+=head1 AUTHOR
+
+Graham Barr <gbarr at pobox.com>
+
+=head1 SEE ALSO
+
+L<Net::Netrc>
+L<Net::Cmd>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1995-1998 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.
+
+=cut
Copied: trunk/contrib/perl/lib/Net/POP3.pm (from rev 6437, vendor/perl/5.18.1/lib/Net/POP3.pm)
===================================================================
--- trunk/contrib/perl/lib/Net/POP3.pm (rev 0)
+++ trunk/contrib/perl/lib/Net/POP3.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,742 @@
+# Net::POP3.pm
+#
+# Copyright (c) 1995-2004 Graham Barr <gbarr at pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Net::POP3;
+
+use strict;
+use IO::Socket;
+use vars qw(@ISA $VERSION $debug);
+use Net::Cmd;
+use Carp;
+use Net::Config;
+
+$VERSION = "2.29";
+
+ at ISA = qw(Net::Cmd IO::Socket::INET);
+
+
+sub new {
+ my $self = shift;
+ my $type = ref($self) || $self;
+ my ($host, %arg);
+ if (@_ % 2) {
+ $host = shift;
+ %arg = @_;
+ }
+ else {
+ %arg = @_;
+ $host = delete $arg{Host};
+ }
+ my $hosts = defined $host ? [$host] : $NetConfig{pop3_hosts};
+ my $obj;
+ my @localport = exists $arg{ResvPort} ? (LocalPort => $arg{ResvPort}) : ();
+
+ my $h;
+ foreach $h (@{$hosts}) {
+ $obj = $type->SUPER::new(
+ PeerAddr => ($host = $h),
+ PeerPort => $arg{Port} || 'pop3(110)',
+ Proto => 'tcp',
+ @localport,
+ Timeout => defined $arg{Timeout}
+ ? $arg{Timeout}
+ : 120
+ )
+ and last;
+ }
+
+ return undef
+ unless defined $obj;
+
+ ${*$obj}{'net_pop3_host'} = $host;
+
+ $obj->autoflush(1);
+ $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
+
+ unless ($obj->response() == CMD_OK) {
+ $obj->close();
+ return undef;
+ }
+
+ ${*$obj}{'net_pop3_banner'} = $obj->message;
+
+ $obj;
+}
+
+
+sub host {
+ my $me = shift;
+ ${*$me}{'net_pop3_host'};
+}
+
+##
+## We don't want people sending me their passwords when they report problems
+## now do we :-)
+##
+
+
+sub debug_text { $_[2] =~ /^(pass|rpop)/i ? "$1 ....\n" : $_[2]; }
+
+
+sub login {
+ @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->login( USER, PASS )';
+ my ($me, $user, $pass) = @_;
+
+ if (@_ <= 2) {
+ ($user, $pass) = $me->_lookup_credentials($user);
+ }
+
+ $me->user($user)
+ and $me->pass($pass);
+}
+
+
+sub apop {
+ @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->apop( USER, PASS )';
+ my ($me, $user, $pass) = @_;
+ my $banner;
+ my $md;
+
+ if (eval { local $SIG{__DIE__}; require Digest::MD5 }) {
+ $md = Digest::MD5->new();
+ }
+ elsif (eval { local $SIG{__DIE__}; require MD5 }) {
+ $md = MD5->new();
+ }
+ else {
+ carp "You need to install Digest::MD5 or MD5 to use the APOP command";
+ return undef;
+ }
+
+ return undef
+ unless ($banner = (${*$me}{'net_pop3_banner'} =~ /(<.*>)/)[0]);
+
+ if (@_ <= 2) {
+ ($user, $pass) = $me->_lookup_credentials($user);
+ }
+
+ $md->add($banner, $pass);
+
+ return undef
+ unless ($me->_APOP($user, $md->hexdigest));
+
+ $me->_get_mailbox_count();
+}
+
+
+sub user {
+ @_ == 2 or croak 'usage: $pop3->user( USER )';
+ $_[0]->_USER($_[1]) ? 1 : undef;
+}
+
+
+sub pass {
+ @_ == 2 or croak 'usage: $pop3->pass( PASS )';
+
+ my ($me, $pass) = @_;
+
+ return undef
+ unless ($me->_PASS($pass));
+
+ $me->_get_mailbox_count();
+}
+
+
+sub reset {
+ @_ == 1 or croak 'usage: $obj->reset()';
+
+ my $me = shift;
+
+ return 0
+ unless ($me->_RSET);
+
+ if (defined ${*$me}{'net_pop3_mail'}) {
+ local $_;
+ foreach (@{${*$me}{'net_pop3_mail'}}) {
+ delete $_->{'net_pop3_deleted'};
+ }
+ }
+}
+
+
+sub last {
+ @_ == 1 or croak 'usage: $obj->last()';
+
+ return undef
+ unless $_[0]->_LAST && $_[0]->message =~ /(\d+)/;
+
+ return $1;
+}
+
+
+sub top {
+ @_ == 2 || @_ == 3 or croak 'usage: $pop3->top( MSGNUM [, NUMLINES ])';
+ my $me = shift;
+
+ return undef
+ unless $me->_TOP($_[0], $_[1] || 0);
+
+ $me->read_until_dot;
+}
+
+
+sub popstat {
+ @_ == 1 or croak 'usage: $pop3->popstat()';
+ my $me = shift;
+
+ return ()
+ unless $me->_STAT && $me->message =~ /(\d+)\D+(\d+)/;
+
+ ($1 || 0, $2 || 0);
+}
+
+
+sub list {
+ @_ == 1 || @_ == 2 or croak 'usage: $pop3->list( [ MSGNUM ] )';
+ my $me = shift;
+
+ return undef
+ unless $me->_LIST(@_);
+
+ if (@_) {
+ $me->message =~ /\d+\D+(\d+)/;
+ return $1 || undef;
+ }
+
+ my $info = $me->read_until_dot
+ or return undef;
+
+ my %hash = map { (/(\d+)\D+(\d+)/) } @$info;
+
+ return \%hash;
+}
+
+
+sub get {
+ @_ == 2 or @_ == 3 or croak 'usage: $pop3->get( MSGNUM [, FH ])';
+ my $me = shift;
+
+ return undef
+ unless $me->_RETR(shift);
+
+ $me->read_until_dot(@_);
+}
+
+
+sub getfh {
+ @_ == 2 or croak 'usage: $pop3->getfh( MSGNUM )';
+ my $me = shift;
+
+ return unless $me->_RETR(shift);
+ return $me->tied_fh;
+}
+
+
+sub delete {
+ @_ == 2 or croak 'usage: $pop3->delete( MSGNUM )';
+ my $me = shift;
+ return 0 unless $me->_DELE(@_);
+ ${*$me}{'net_pop3_deleted'} = 1;
+}
+
+
+sub uidl {
+ @_ == 1 || @_ == 2 or croak 'usage: $pop3->uidl( [ MSGNUM ] )';
+ my $me = shift;
+ my $uidl;
+
+ $me->_UIDL(@_)
+ or return undef;
+ if (@_) {
+ $uidl = ($me->message =~ /\d+\s+([\041-\176]+)/)[0];
+ }
+ else {
+ my $ref = $me->read_until_dot
+ or return undef;
+ my $ln;
+ $uidl = {};
+ foreach $ln (@$ref) {
+ my ($msg, $uid) = $ln =~ /^\s*(\d+)\s+([\041-\176]+)/;
+ $uidl->{$msg} = $uid;
+ }
+ }
+ return $uidl;
+}
+
+
+sub ping {
+ @_ == 2 or croak 'usage: $pop3->ping( USER )';
+ my $me = shift;
+
+ return () unless $me->_PING(@_) && $me->message =~ /(\d+)\D+(\d+)/;
+
+ ($1 || 0, $2 || 0);
+}
+
+
+sub _lookup_credentials {
+ my ($me, $user) = @_;
+
+ require Net::Netrc;
+
+ $user ||= eval { local $SIG{__DIE__}; (getpwuid($>))[0] }
+ || $ENV{NAME}
+ || $ENV{USER}
+ || $ENV{LOGNAME};
+
+ my $m = Net::Netrc->lookup(${*$me}{'net_pop3_host'}, $user);
+ $m ||= Net::Netrc->lookup(${*$me}{'net_pop3_host'});
+
+ my $pass = $m
+ ? $m->password || ""
+ : "";
+
+ ($user, $pass);
+}
+
+
+sub _get_mailbox_count {
+ my ($me) = @_;
+ my $ret = ${*$me}{'net_pop3_count'} =
+ ($me->message =~ /(\d+)\s+message/io) ? $1 : ($me->popstat)[0];
+
+ $ret ? $ret : "0E0";
+}
+
+
+sub _STAT { shift->command('STAT')->response() == CMD_OK }
+sub _LIST { shift->command('LIST', @_)->response() == CMD_OK }
+sub _RETR { shift->command('RETR', $_[0])->response() == CMD_OK }
+sub _DELE { shift->command('DELE', $_[0])->response() == CMD_OK }
+sub _NOOP { shift->command('NOOP')->response() == CMD_OK }
+sub _RSET { shift->command('RSET')->response() == CMD_OK }
+sub _QUIT { shift->command('QUIT')->response() == CMD_OK }
+sub _TOP { shift->command('TOP', @_)->response() == CMD_OK }
+sub _UIDL { shift->command('UIDL', @_)->response() == CMD_OK }
+sub _USER { shift->command('USER', $_[0])->response() == CMD_OK }
+sub _PASS { shift->command('PASS', $_[0])->response() == CMD_OK }
+sub _APOP { shift->command('APOP', @_)->response() == CMD_OK }
+sub _PING { shift->command('PING', $_[0])->response() == CMD_OK }
+
+
+sub _RPOP { shift->command('RPOP', $_[0])->response() == CMD_OK }
+sub _LAST { shift->command('LAST')->response() == CMD_OK }
+
+
+sub _CAPA { shift->command('CAPA')->response() == CMD_OK }
+
+
+sub quit {
+ my $me = shift;
+
+ $me->_QUIT;
+ $me->close;
+}
+
+
+sub DESTROY {
+ my $me = shift;
+
+ if (defined fileno($me) and ${*$me}{'net_pop3_deleted'}) {
+ $me->reset;
+ $me->quit;
+ }
+}
+
+##
+## POP3 has weird responses, so we emulate them to look the same :-)
+##
+
+
+sub response {
+ my $cmd = shift;
+ my $str = $cmd->getline() or return undef;
+ my $code = "500";
+
+ $cmd->debug_print(0, $str)
+ if ($cmd->debug);
+
+ if ($str =~ s/^\+OK\s*//io) {
+ $code = "200";
+ }
+ elsif ($str =~ s/^\+\s*//io) {
+ $code = "300";
+ }
+ else {
+ $str =~ s/^-ERR\s*//io;
+ }
+
+ ${*$cmd}{'net_cmd_resp'} = [$str];
+ ${*$cmd}{'net_cmd_code'} = $code;
+
+ substr($code, 0, 1);
+}
+
+
+sub capa {
+ my $this = shift;
+ my ($capa, %capabilities);
+
+ # Fake a capability here
+ $capabilities{APOP} = '' if ($this->banner() =~ /<.*>/);
+
+ if ($this->_CAPA()) {
+ $capabilities{CAPA} = 1;
+ $capa = $this->read_until_dot();
+ %capabilities = (%capabilities, map {/^\s*(\S+)\s*(.*)/} @$capa);
+ }
+ else {
+
+ # Check AUTH for SASL capabilities
+ if ($this->command('AUTH')->response() == CMD_OK) {
+ my $mechanism = $this->read_until_dot();
+ $capabilities{SASL} = join " ", map {m/([A-Z0-9_-]+)/} @{$mechanism};
+ }
+ }
+
+ return ${*$this}{'net_pop3e_capabilities'} = \%capabilities;
+}
+
+
+sub capabilities {
+ my $this = shift;
+
+ ${*$this}{'net_pop3e_capabilities'} || $this->capa;
+}
+
+
+sub auth {
+ my ($self, $username, $password) = @_;
+
+ eval {
+ require MIME::Base64;
+ require Authen::SASL;
+ } or $self->set_status(500, ["Need MIME::Base64 and Authen::SASL todo auth"]), return 0;
+
+ my $capa = $self->capa;
+ my $mechanisms = $capa->{SASL} || 'CRAM-MD5';
+
+ my $sasl;
+
+ if (ref($username) and UNIVERSAL::isa($username, 'Authen::SASL')) {
+ $sasl = $username;
+ my $user_mech = $sasl->mechanism || '';
+ my @user_mech = split(/\s+/, $user_mech);
+ my %user_mech;
+ @user_mech{@user_mech} = ();
+
+ my @server_mech = split(/\s+/, $mechanisms);
+ my @mech = @user_mech
+ ? grep { exists $user_mech{$_} } @server_mech
+ : @server_mech;
+ unless (@mech) {
+ $self->set_status(
+ 500,
+ [ 'Client SASL mechanisms (',
+ join(', ', @user_mech),
+ ') do not match the SASL mechnism the server announces (',
+ join(', ', @server_mech), ')',
+ ]
+ );
+ return 0;
+ }
+
+ $sasl->mechanism(join(" ", @mech));
+ }
+ else {
+ die "auth(username, password)" if not length $username;
+ $sasl = Authen::SASL->new(
+ mechanism => $mechanisms,
+ callback => {
+ user => $username,
+ pass => $password,
+ authname => $username,
+ }
+ );
+ }
+
+ # We should probably allow the user to pass the host, but I don't
+ # currently know and SASL mechanisms that are used by smtp that need it
+ my ($hostname) = split /:/, ${*$self}{'net_pop3_host'};
+ my $client = eval { $sasl->client_new('pop', $hostname, 0) };
+
+ unless ($client) {
+ my $mech = $sasl->mechanism;
+ $self->set_status(
+ 500,
+ [ " Authen::SASL failure: $@",
+ '(please check if your local Authen::SASL installation',
+ "supports mechanism '$mech'"
+ ]
+ );
+ return 0;
+ }
+
+ my ($token) = $client->client_start
+ or do {
+ my $mech = $client->mechanism;
+ $self->set_status(
+ 500,
+ [ ' Authen::SASL failure: $client->client_start ',
+ "mechanism '$mech' hostname #$hostname#",
+ $client->error
+ ]
+ );
+ return 0;
+ };
+
+ # We dont support sasl mechanisms that encrypt the socket traffic.
+ # todo that we would really need to change the ISA hierarchy
+ # so we dont inherit from IO::Socket, but instead hold it in an attribute
+
+ my @cmd = ("AUTH", $client->mechanism);
+ my $code;
+
+ push @cmd, MIME::Base64::encode_base64($token, '')
+ if defined $token and length $token;
+
+ while (($code = $self->command(@cmd)->response()) == CMD_MORE) {
+
+ my ($token) = $client->client_step(MIME::Base64::decode_base64(($self->message)[0])) or do {
+ $self->set_status(
+ 500,
+ [ ' Authen::SASL failure: $client->client_step ',
+ "mechanism '", $client->mechanism, " hostname #$hostname#, ",
+ $client->error
+ ]
+ );
+ return 0;
+ };
+
+ @cmd = (MIME::Base64::encode_base64(defined $token ? $token : '', ''));
+ }
+
+ $code == CMD_OK;
+}
+
+
+sub banner {
+ my $this = shift;
+
+ return ${*$this}{'net_pop3_banner'};
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Net::POP3 - Post Office Protocol 3 Client class (RFC1939)
+
+=head1 SYNOPSIS
+
+ use Net::POP3;
+
+ # Constructors
+ $pop = Net::POP3->new('pop3host');
+ $pop = Net::POP3->new('pop3host', Timeout => 60);
+
+ if ($pop->login($username, $password) > 0) {
+ my $msgnums = $pop->list; # hashref of msgnum => size
+ foreach my $msgnum (keys %$msgnums) {
+ my $msg = $pop->get($msgnum);
+ print @$msg;
+ $pop->delete($msgnum);
+ }
+ }
+
+ $pop->quit;
+
+=head1 DESCRIPTION
+
+This module implements a client interface to the POP3 protocol, enabling
+a perl5 application to talk to POP3 servers. This documentation assumes
+that you are familiar with the POP3 protocol described in RFC1939.
+
+A new Net::POP3 object must be created with the I<new> method. Once
+this has been done, all POP3 commands are accessed via method calls
+on the object.
+
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item new ( [ HOST ] [, OPTIONS ] 0
+
+This is the constructor for a new Net::POP3 object. C<HOST> is the
+name of the remote host to which an POP3 connection is required.
+
+C<HOST> is optional. If C<HOST> is not given then it may instead be
+passed as the C<Host> option described below. If neither is given then
+the C<POP3_Hosts> specified in C<Net::Config> will be used.
+
+C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
+Possible options are:
+
+B<Host> - POP3 host to connect to. It may be a single scalar, as defined for
+the C<PeerAddr> option in L<IO::Socket::INET>, or a reference to
+an array with hosts to try in turn. The L</host> method will return the value
+which was used to connect to the host.
+
+B<ResvPort> - If given then the socket for the C<Net::POP3> object
+will be bound to the local port given using C<bind> when the socket is
+created.
+
+B<Timeout> - Maximum time, in seconds, to wait for a response from the
+POP3 server (default: 120)
+
+B<Debug> - Enable debugging information
+
+=back
+
+=head1 METHODS
+
+Unless otherwise stated all methods return either a I<true> or I<false>
+value, with I<true> meaning that the operation was a success. When a method
+states that it returns a value, failure will be returned as I<undef> or an
+empty list.
+
+=over 4
+
+=item auth ( USERNAME, PASSWORD )
+
+Attempt SASL authentication.
+
+=item user ( USER )
+
+Send the USER command.
+
+=item pass ( PASS )
+
+Send the PASS command. Returns the number of messages in the mailbox.
+
+=item login ( [ USER [, PASS ]] )
+
+Send both the USER and PASS commands. If C<PASS> is not given the
+C<Net::POP3> uses C<Net::Netrc> to lookup the password using the host
+and username. If the username is not specified then the current user name
+will be used.
+
+Returns the number of messages in the mailbox. However if there are no
+messages on the server the string C<"0E0"> will be returned. This is
+will give a true value in a boolean context, but zero in a numeric context.
+
+If there was an error authenticating the user then I<undef> will be returned.
+
+=item apop ( [ USER [, PASS ]] )
+
+Authenticate with the server identifying as C<USER> with password C<PASS>.
+Similar to L</login>, but the password is not sent in clear text.
+
+To use this method you must have the Digest::MD5 or the MD5 module installed,
+otherwise this method will return I<undef>.
+
+=item banner ()
+
+Return the sever's connection banner
+
+=item capa ()
+
+Return a reference to a hash of the capabilities of the server. APOP
+is added as a pseudo capability. Note that I've been unable to
+find a list of the standard capability values, and some appear to
+be multi-word and some are not. We make an attempt at intelligently
+parsing them, but it may not be correct.
+
+=item capabilities ()
+
+Just like capa, but only uses a cache from the last time we asked
+the server, so as to avoid asking more than once.
+
+=item top ( MSGNUM [, NUMLINES ] )
+
+Get the header and the first C<NUMLINES> of the body for the message
+C<MSGNUM>. Returns a reference to an array which contains the lines of text
+read from the server.
+
+=item list ( [ MSGNUM ] )
+
+If called with an argument the C<list> returns the size of the message
+in octets.
+
+If called without arguments a reference to a hash is returned. The
+keys will be the C<MSGNUM>'s of all undeleted messages and the values will
+be their size in octets.
+
+=item get ( MSGNUM [, FH ] )
+
+Get the message C<MSGNUM> from the remote mailbox. If C<FH> is not given
+then get returns a reference to an array which contains the lines of
+text read from the server. If C<FH> is given then the lines returned
+from the server are printed to the filehandle C<FH>.
+
+=item getfh ( MSGNUM )
+
+As per get(), but returns a tied filehandle. Reading from this
+filehandle returns the requested message. The filehandle will return
+EOF at the end of the message and should not be reused.
+
+=item last ()
+
+Returns the highest C<MSGNUM> of all the messages accessed.
+
+=item popstat ()
+
+Returns a list of two elements. These are the number of undeleted
+elements and the size of the mbox in octets.
+
+=item ping ( USER )
+
+Returns a list of two elements. These are the number of new messages
+and the total number of messages for C<USER>.
+
+=item uidl ( [ MSGNUM ] )
+
+Returns a unique identifier for C<MSGNUM> if given. If C<MSGNUM> is not
+given C<uidl> returns a reference to a hash where the keys are the
+message numbers and the values are the unique identifiers.
+
+=item delete ( MSGNUM )
+
+Mark message C<MSGNUM> to be deleted from the remote mailbox. All messages
+that are marked to be deleted will be removed from the remote mailbox
+when the server connection closed.
+
+=item reset ()
+
+Reset the status of the remote POP3 server. This includes resetting the
+status of all messages to not be deleted.
+
+=item quit ()
+
+Quit and close the connection to the remote POP3 server. Any messages marked
+as deleted will be deleted from the remote mailbox.
+
+=back
+
+=head1 NOTES
+
+If a C<Net::POP3> object goes out of scope before C<quit> method is called
+then the C<reset> method will called before the connection is closed. This
+means that any messages marked to be deleted will not be.
+
+=head1 SEE ALSO
+
+L<Net::Netrc>,
+L<Net::Cmd>
+
+=head1 AUTHOR
+
+Graham Barr <gbarr at pobox.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1995-2003 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.
+
+=cut
Copied: trunk/contrib/perl/lib/Net/Ping.pm (from rev 6437, vendor/perl/5.18.1/lib/Net/Ping.pm)
===================================================================
--- trunk/contrib/perl/lib/Net/Ping.pm (rev 0)
+++ trunk/contrib/perl/lib/Net/Ping.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,1777 @@
+package Net::Ping;
+
+require 5.002;
+require Exporter;
+
+use strict;
+use vars qw(@ISA @EXPORT $VERSION
+ $def_timeout $def_proto $def_factor
+ $max_datasize $pingstring $hires $source_verify $syn_forking);
+use Fcntl qw( F_GETFL F_SETFL O_NONBLOCK );
+use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET SOL_SOCKET SO_ERROR
+ inet_aton inet_ntoa sockaddr_in );
+use POSIX qw( ENOTCONN ECONNREFUSED ECONNRESET EINPROGRESS EWOULDBLOCK EAGAIN WNOHANG );
+use FileHandle;
+use Carp;
+
+ at ISA = qw(Exporter);
+ at EXPORT = qw(pingecho);
+$VERSION = "2.36";
+
+sub SOL_IP { 0; };
+sub IP_TOS { 1; };
+
+# Constants
+
+$def_timeout = 5; # Default timeout to wait for a reply
+$def_proto = "tcp"; # Default protocol to use for pinging
+$def_factor = 1.2; # Default exponential backoff rate.
+$max_datasize = 1024; # Maximum data bytes in a packet
+# The data we exchange with the server for the stream protocol
+$pingstring = "pingschwingping!\n";
+$source_verify = 1; # Default is to verify source endpoint
+$syn_forking = 0;
+
+if ($^O =~ /Win32/i) {
+ # Hack to avoid this Win32 spewage:
+ # Your vendor has not defined POSIX macro ECONNREFUSED
+ my @pairs = (ECONNREFUSED => 10061, # "Unknown Error" Special Win32 Response?
+ ENOTCONN => 10057,
+ ECONNRESET => 10054,
+ EINPROGRESS => 10036,
+ EWOULDBLOCK => 10035,
+ );
+ while (my $name = shift @pairs) {
+ my $value = shift @pairs;
+ # When defined, these all are non-zero
+ unless (eval $name) {
+ no strict 'refs';
+ *{$name} = defined prototype \&{$name} ? sub () {$value} : sub {$value};
+ }
+ }
+# $syn_forking = 1; # XXX possibly useful in < Win2K ?
+};
+
+# h2ph "asm/socket.h"
+# require "asm/socket.ph";
+sub SO_BINDTODEVICE {25;}
+
+# Description: The pingecho() subroutine is provided for backward
+# compatibility with the original Net::Ping. It accepts a host
+# name/IP and an optional timeout in seconds. Create a tcp ping
+# object and try pinging the host. The result of the ping is returned.
+
+sub pingecho
+{
+ my ($host, # Name or IP number of host to ping
+ $timeout # Optional timeout in seconds
+ ) = @_;
+ my ($p); # A ping object
+
+ $p = Net::Ping->new("tcp", $timeout);
+ $p->ping($host); # Going out of scope closes the connection
+}
+
+# Description: The new() method creates a new ping object. Optional
+# parameters may be specified for the protocol to use, the timeout in
+# seconds and the size in bytes of additional data which should be
+# included in the packet.
+# After the optional parameters are checked, the data is constructed
+# and a socket is opened if appropriate. The object is returned.
+
+sub new
+{
+ my ($this,
+ $proto, # Optional protocol to use for pinging
+ $timeout, # Optional timeout in seconds
+ $data_size, # Optional additional bytes of data
+ $device, # Optional device to use
+ $tos, # Optional ToS to set
+ ) = @_;
+ my $class = ref($this) || $this;
+ my $self = {};
+ my ($cnt, # Count through data bytes
+ $min_datasize # Minimum data bytes required
+ );
+
+ bless($self, $class);
+
+ $proto = $def_proto unless $proto; # Determine the protocol
+ croak('Protocol for ping must be "icmp", "udp", "tcp", "syn", "stream", or "external"')
+ unless $proto =~ m/^(icmp|udp|tcp|syn|stream|external)$/;
+ $self->{"proto"} = $proto;
+
+ $timeout = $def_timeout unless $timeout; # Determine the timeout
+ croak("Default timeout for ping must be greater than 0 seconds")
+ if $timeout <= 0;
+ $self->{"timeout"} = $timeout;
+
+ $self->{"device"} = $device;
+
+ $self->{"tos"} = $tos;
+
+ $min_datasize = ($proto eq "udp") ? 1 : 0; # Determine data size
+ $data_size = $min_datasize unless defined($data_size) && $proto ne "tcp";
+ croak("Data for ping must be from $min_datasize to $max_datasize bytes")
+ if ($data_size < $min_datasize) || ($data_size > $max_datasize);
+ $data_size-- if $self->{"proto"} eq "udp"; # We provide the first byte
+ $self->{"data_size"} = $data_size;
+
+ $self->{"data"} = ""; # Construct data bytes
+ for ($cnt = 0; $cnt < $self->{"data_size"}; $cnt++)
+ {
+ $self->{"data"} .= chr($cnt % 256);
+ }
+
+ $self->{"local_addr"} = undef; # Don't bind by default
+ $self->{"retrans"} = $def_factor; # Default exponential backoff rate
+ $self->{"econnrefused"} = undef; # Default Connection refused behavior
+
+ $self->{"seq"} = 0; # For counting packets
+ if ($self->{"proto"} eq "udp") # Open a socket
+ {
+ $self->{"proto_num"} = (getprotobyname('udp'))[2] ||
+ croak("Can't udp protocol by name");
+ $self->{"port_num"} = (getservbyname('echo', 'udp'))[2] ||
+ croak("Can't get udp echo port by name");
+ $self->{"fh"} = FileHandle->new();
+ socket($self->{"fh"}, PF_INET, SOCK_DGRAM,
+ $self->{"proto_num"}) ||
+ croak("udp socket error - $!");
+ if ($self->{'device'}) {
+ setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
+ or croak "error binding to device $self->{'device'} $!";
+ }
+ if ($self->{'tos'}) {
+ setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
+ or croak "error configuring tos to $self->{'tos'} $!";
+ }
+ }
+ elsif ($self->{"proto"} eq "icmp")
+ {
+ croak("icmp ping requires root privilege") if ($> and $^O ne 'VMS' and $^O ne 'cygwin');
+ $self->{"proto_num"} = (getprotobyname('icmp'))[2] ||
+ croak("Can't get icmp protocol by name");
+ $self->{"pid"} = $$ & 0xffff; # Save lower 16 bits of pid
+ $self->{"fh"} = FileHandle->new();
+ socket($self->{"fh"}, PF_INET, SOCK_RAW, $self->{"proto_num"}) ||
+ croak("icmp socket error - $!");
+ if ($self->{'device'}) {
+ setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
+ or croak "error binding to device $self->{'device'} $!";
+ }
+ if ($self->{'tos'}) {
+ setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
+ or croak "error configuring tos to $self->{'tos'} $!";
+ }
+ }
+ elsif ($self->{"proto"} eq "tcp" || $self->{"proto"} eq "stream")
+ {
+ $self->{"proto_num"} = (getprotobyname('tcp'))[2] ||
+ croak("Can't get tcp protocol by name");
+ $self->{"port_num"} = (getservbyname('echo', 'tcp'))[2] ||
+ croak("Can't get tcp echo port by name");
+ $self->{"fh"} = FileHandle->new();
+ }
+ elsif ($self->{"proto"} eq "syn")
+ {
+ $self->{"proto_num"} = (getprotobyname('tcp'))[2] ||
+ croak("Can't get tcp protocol by name");
+ $self->{"port_num"} = (getservbyname('echo', 'tcp'))[2] ||
+ croak("Can't get tcp echo port by name");
+ if ($syn_forking) {
+ $self->{"fork_rd"} = FileHandle->new();
+ $self->{"fork_wr"} = FileHandle->new();
+ pipe($self->{"fork_rd"}, $self->{"fork_wr"});
+ $self->{"fh"} = FileHandle->new();
+ $self->{"good"} = {};
+ $self->{"bad"} = {};
+ } else {
+ $self->{"wbits"} = "";
+ $self->{"bad"} = {};
+ }
+ $self->{"syn"} = {};
+ $self->{"stop_time"} = 0;
+ }
+ elsif ($self->{"proto"} eq "external")
+ {
+ # No preliminary work needs to be done.
+ }
+
+ return($self);
+}
+
+# Description: Set the local IP address from which pings will be sent.
+# For ICMP and UDP pings, this calls bind() on the already-opened socket;
+# for TCP pings, just saves the address to be used when the socket is
+# opened. Returns non-zero if successful; croaks on error.
+sub bind
+{
+ my ($self,
+ $local_addr # Name or IP number of local interface
+ ) = @_;
+ my ($ip # Packed IP number of $local_addr
+ );
+
+ croak("Usage: \$p->bind(\$local_addr)") unless @_ == 2;
+ croak("already bound") if defined($self->{"local_addr"}) &&
+ ($self->{"proto"} eq "udp" || $self->{"proto"} eq "icmp");
+
+ $ip = inet_aton($local_addr);
+ croak("nonexistent local address $local_addr") unless defined($ip);
+ $self->{"local_addr"} = $ip; # Only used if proto is tcp
+
+ if ($self->{"proto"} eq "udp" || $self->{"proto"} eq "icmp")
+ {
+ CORE::bind($self->{"fh"}, sockaddr_in(0, $ip)) ||
+ croak("$self->{'proto'} bind error - $!");
+ }
+ elsif (($self->{"proto"} ne "tcp") && ($self->{"proto"} ne "syn"))
+ {
+ croak("Unknown protocol \"$self->{proto}\" in bind()");
+ }
+
+ return 1;
+}
+
+# Description: A select() wrapper that compensates for platform
+# peculiarities.
+sub mselect
+{
+ if ($_[3] > 0 and $^O eq 'MSWin32') {
+ # On windows, select() doesn't process the message loop,
+ # but sleep() will, allowing alarm() to interrupt the latter.
+ # So we chop up the timeout into smaller pieces and interleave
+ # select() and sleep() calls.
+ my $t = $_[3];
+ my $gran = 0.5; # polling granularity in seconds
+ my @args = @_;
+ while (1) {
+ $gran = $t if $gran > $t;
+ my $nfound = select($_[0], $_[1], $_[2], $gran);
+ undef $nfound if $nfound == -1;
+ $t -= $gran;
+ return $nfound if $nfound or !defined($nfound) or $t <= 0;
+
+ sleep(0);
+ ($_[0], $_[1], $_[2]) = @args;
+ }
+ }
+ else {
+ my $nfound = select($_[0], $_[1], $_[2], $_[3]);
+ undef $nfound if $nfound == -1;
+ return $nfound;
+ }
+}
+
+# Description: Allow UDP source endpoint comparison to be
+# skipped for those remote interfaces that do
+# not response from the same endpoint.
+
+sub source_verify
+{
+ my $self = shift;
+ $source_verify = 1 unless defined
+ ($source_verify = ((defined $self) && (ref $self)) ? shift() : $self);
+}
+
+# Description: Set whether or not the connect
+# behavior should enforce remote service
+# availability as well as reachability.
+
+sub service_check
+{
+ my $self = shift;
+ $self->{"econnrefused"} = 1 unless defined
+ ($self->{"econnrefused"} = shift());
+}
+
+sub tcp_service_check
+{
+ service_check(@_);
+}
+
+# Description: Set exponential backoff for retransmission.
+# Should be > 1 to retain exponential properties.
+# If set to 0, retransmissions are disabled.
+
+sub retrans
+{
+ my $self = shift;
+ $self->{"retrans"} = shift;
+}
+
+# Description: allows the module to use milliseconds as returned by
+# the Time::HiRes module
+
+$hires = 0;
+sub hires
+{
+ my $self = shift;
+ $hires = 1 unless defined
+ ($hires = ((defined $self) && (ref $self)) ? shift() : $self);
+ require Time::HiRes if $hires;
+}
+
+sub time
+{
+ return $hires ? Time::HiRes::time() : CORE::time();
+}
+
+# Description: Sets or clears the O_NONBLOCK flag on a file handle.
+sub socket_blocking_mode
+{
+ my ($self,
+ $fh, # the file handle whose flags are to be modified
+ $block) = @_; # if true then set the blocking
+ # mode (clear O_NONBLOCK), otherwise
+ # set the non-blocking mode (set O_NONBLOCK)
+
+ my $flags;
+ if ($^O eq 'MSWin32' || $^O eq 'VMS') {
+ # FIONBIO enables non-blocking sockets on windows and vms.
+ # FIONBIO is (0x80000000|(4<<16)|(ord('f')<<8)|126), as per winsock.h, ioctl.h
+ my $f = 0x8004667e;
+ my $v = pack("L", $block ? 0 : 1);
+ ioctl($fh, $f, $v) or croak("ioctl failed: $!");
+ return;
+ }
+ if ($flags = fcntl($fh, F_GETFL, 0)) {
+ $flags = $block ? ($flags & ~O_NONBLOCK) : ($flags | O_NONBLOCK);
+ if (!fcntl($fh, F_SETFL, $flags)) {
+ croak("fcntl F_SETFL: $!");
+ }
+ } else {
+ croak("fcntl F_GETFL: $!");
+ }
+}
+
+# Description: Ping a host name or IP number with an optional timeout.
+# First lookup the host, and return undef if it is not found. Otherwise
+# perform the specific ping method based on the protocol. Return the
+# result of the ping.
+
+sub ping
+{
+ my ($self,
+ $host, # Name or IP number of host to ping
+ $timeout, # Seconds after which ping times out
+ ) = @_;
+ my ($ip, # Packed IP number of $host
+ $ret, # The return value
+ $ping_time, # When ping began
+ );
+
+ croak("Usage: \$p->ping(\$host [, \$timeout])") unless @_ == 2 || @_ == 3;
+ $timeout = $self->{"timeout"} unless $timeout;
+ croak("Timeout must be greater than 0 seconds") if $timeout <= 0;
+
+ $ip = inet_aton($host);
+ return () unless defined($ip); # Does host exist?
+
+ # Dispatch to the appropriate routine.
+ $ping_time = &time();
+ if ($self->{"proto"} eq "external") {
+ $ret = $self->ping_external($ip, $timeout);
+ }
+ elsif ($self->{"proto"} eq "udp") {
+ $ret = $self->ping_udp($ip, $timeout);
+ }
+ elsif ($self->{"proto"} eq "icmp") {
+ $ret = $self->ping_icmp($ip, $timeout);
+ }
+ elsif ($self->{"proto"} eq "tcp") {
+ $ret = $self->ping_tcp($ip, $timeout);
+ }
+ elsif ($self->{"proto"} eq "stream") {
+ $ret = $self->ping_stream($ip, $timeout);
+ }
+ elsif ($self->{"proto"} eq "syn") {
+ $ret = $self->ping_syn($host, $ip, $ping_time, $ping_time+$timeout);
+ } else {
+ croak("Unknown protocol \"$self->{proto}\" in ping()");
+ }
+
+ return wantarray ? ($ret, &time() - $ping_time, inet_ntoa($ip)) : $ret;
+}
+
+# Uses Net::Ping::External to do an external ping.
+sub ping_external {
+ my ($self,
+ $ip, # Packed IP number of the host
+ $timeout # Seconds after which ping times out
+ ) = @_;
+
+ eval { require Net::Ping::External; }
+ or croak('Protocol "external" not supported on your system: Net::Ping::External not found');
+ return Net::Ping::External::ping(ip => $ip, timeout => $timeout);
+}
+
+use constant ICMP_ECHOREPLY => 0; # ICMP packet types
+use constant ICMP_UNREACHABLE => 3; # ICMP packet types
+use constant ICMP_ECHO => 8;
+use constant ICMP_STRUCT => "C2 n3 A"; # Structure of a minimal ICMP packet
+use constant SUBCODE => 0; # No ICMP subcode for ECHO and ECHOREPLY
+use constant ICMP_FLAGS => 0; # No special flags for send or recv
+use constant ICMP_PORT => 0; # No port with ICMP
+
+sub ping_icmp
+{
+ my ($self,
+ $ip, # Packed IP number of the host
+ $timeout # Seconds after which ping times out
+ ) = @_;
+
+ my ($saddr, # sockaddr_in with port and ip
+ $checksum, # Checksum of ICMP packet
+ $msg, # ICMP packet to send
+ $len_msg, # Length of $msg
+ $rbits, # Read bits, filehandles for reading
+ $nfound, # Number of ready filehandles found
+ $finish_time, # Time ping should be finished
+ $done, # set to 1 when we are done
+ $ret, # Return value
+ $recv_msg, # Received message including IP header
+ $from_saddr, # sockaddr_in of sender
+ $from_port, # Port packet was sent from
+ $from_ip, # Packed IP of sender
+ $from_type, # ICMP type
+ $from_subcode, # ICMP subcode
+ $from_chk, # ICMP packet checksum
+ $from_pid, # ICMP packet id
+ $from_seq, # ICMP packet sequence
+ $from_msg # ICMP message
+ );
+
+ $self->{"seq"} = ($self->{"seq"} + 1) % 65536; # Increment sequence
+ $checksum = 0; # No checksum for starters
+ $msg = pack(ICMP_STRUCT . $self->{"data_size"}, ICMP_ECHO, SUBCODE,
+ $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"});
+ $checksum = Net::Ping->checksum($msg);
+ $msg = pack(ICMP_STRUCT . $self->{"data_size"}, ICMP_ECHO, SUBCODE,
+ $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"});
+ $len_msg = length($msg);
+ $saddr = sockaddr_in(ICMP_PORT, $ip);
+ $self->{"from_ip"} = undef;
+ $self->{"from_type"} = undef;
+ $self->{"from_subcode"} = undef;
+ send($self->{"fh"}, $msg, ICMP_FLAGS, $saddr); # Send the message
+
+ $rbits = "";
+ vec($rbits, $self->{"fh"}->fileno(), 1) = 1;
+ $ret = 0;
+ $done = 0;
+ $finish_time = &time() + $timeout; # Must be done by this time
+ while (!$done && $timeout > 0) # Keep trying if we have time
+ {
+ $nfound = mselect((my $rout=$rbits), undef, undef, $timeout); # Wait for packet
+ $timeout = $finish_time - &time(); # Get remaining time
+ if (!defined($nfound)) # Hmm, a strange error
+ {
+ $ret = undef;
+ $done = 1;
+ }
+ elsif ($nfound) # Got a packet from somewhere
+ {
+ $recv_msg = "";
+ $from_pid = -1;
+ $from_seq = -1;
+ $from_saddr = recv($self->{"fh"}, $recv_msg, 1500, ICMP_FLAGS);
+ ($from_port, $from_ip) = sockaddr_in($from_saddr);
+ ($from_type, $from_subcode) = unpack("C2", substr($recv_msg, 20, 2));
+ if ($from_type == ICMP_ECHOREPLY) {
+ ($from_pid, $from_seq) = unpack("n3", substr($recv_msg, 24, 4))
+ if length $recv_msg >= 28;
+ } else {
+ ($from_pid, $from_seq) = unpack("n3", substr($recv_msg, 52, 4))
+ if length $recv_msg >= 56;
+ }
+ $self->{"from_ip"} = $from_ip;
+ $self->{"from_type"} = $from_type;
+ $self->{"from_subcode"} = $from_subcode;
+ if (($from_pid == $self->{"pid"}) && # Does the packet check out?
+ (! $source_verify || (inet_ntoa($from_ip) eq inet_ntoa($ip))) &&
+ ($from_seq == $self->{"seq"})) {
+ if ($from_type == ICMP_ECHOREPLY) {
+ $ret = 1;
+ $done = 1;
+ } elsif ($from_type == ICMP_UNREACHABLE) {
+ $done = 1;
+ }
+ }
+ } else { # Oops, timed out
+ $done = 1;
+ }
+ }
+ return $ret;
+}
+
+sub icmp_result {
+ my ($self) = @_;
+ my $ip = $self->{"from_ip"} || "";
+ $ip = "\0\0\0\0" unless 4 == length $ip;
+ return (inet_ntoa($ip),($self->{"from_type"} || 0), ($self->{"from_subcode"} || 0));
+}
+
+# Description: Do a checksum on the message. Basically sum all of
+# the short words and fold the high order bits into the low order bits.
+
+sub checksum
+{
+ my ($class,
+ $msg # The message to checksum
+ ) = @_;
+ my ($len_msg, # Length of the message
+ $num_short, # The number of short words in the message
+ $short, # One short word
+ $chk # The checksum
+ );
+
+ $len_msg = length($msg);
+ $num_short = int($len_msg / 2);
+ $chk = 0;
+ foreach $short (unpack("n$num_short", $msg))
+ {
+ $chk += $short;
+ } # Add the odd byte in
+ $chk += (unpack("C", substr($msg, $len_msg - 1, 1)) << 8) if $len_msg % 2;
+ $chk = ($chk >> 16) + ($chk & 0xffff); # Fold high into low
+ return(~(($chk >> 16) + $chk) & 0xffff); # Again and complement
+}
+
+
+# Description: Perform a tcp echo ping. Since a tcp connection is
+# host specific, we have to open and close each connection here. We
+# can't just leave a socket open. Because of the robust nature of
+# tcp, it will take a while before it gives up trying to establish a
+# connection. Therefore, we use select() on a non-blocking socket to
+# check against our timeout. No data bytes are actually
+# sent since the successful establishment of a connection is proof
+# enough of the reachability of the remote host. Also, tcp is
+# expensive and doesn't need our help to add to the overhead.
+
+sub ping_tcp
+{
+ my ($self,
+ $ip, # Packed IP number of the host
+ $timeout # Seconds after which ping times out
+ ) = @_;
+ my ($ret # The return value
+ );
+
+ $! = 0;
+ $ret = $self -> tcp_connect( $ip, $timeout);
+ if (!$self->{"econnrefused"} &&
+ $! == ECONNREFUSED) {
+ $ret = 1; # "Connection refused" means reachable
+ }
+ $self->{"fh"}->close();
+ return $ret;
+}
+
+sub tcp_connect
+{
+ my ($self,
+ $ip, # Packed IP number of the host
+ $timeout # Seconds after which connect times out
+ ) = @_;
+ my ($saddr); # Packed IP and Port
+
+ $saddr = sockaddr_in($self->{"port_num"}, $ip);
+
+ my $ret = 0; # Default to unreachable
+
+ my $do_socket = sub {
+ socket($self->{"fh"}, PF_INET, SOCK_STREAM, $self->{"proto_num"}) ||
+ croak("tcp socket error - $!");
+ if (defined $self->{"local_addr"} &&
+ !CORE::bind($self->{"fh"}, sockaddr_in(0, $self->{"local_addr"}))) {
+ croak("tcp bind error - $!");
+ }
+ if ($self->{'device'}) {
+ setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
+ or croak("error binding to device $self->{'device'} $!");
+ }
+ if ($self->{'tos'}) {
+ setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
+ or croak "error configuring tos to $self->{'tos'} $!";
+ }
+ };
+ my $do_connect = sub {
+ $self->{"ip"} = $ip;
+ # ECONNREFUSED is 10061 on MSWin32. If we pass it as child error through $?,
+ # we'll get (10061 & 255) = 77, so we cannot check it in the parent process.
+ return ($ret = connect($self->{"fh"}, $saddr) || ($! == ECONNREFUSED && !$self->{"econnrefused"}));
+ };
+ my $do_connect_nb = sub {
+ # Set O_NONBLOCK property on filehandle
+ $self->socket_blocking_mode($self->{"fh"}, 0);
+
+ # start the connection attempt
+ if (!connect($self->{"fh"}, $saddr)) {
+ if ($! == ECONNREFUSED) {
+ $ret = 1 unless $self->{"econnrefused"};
+ } elsif ($! != EINPROGRESS && ($^O ne 'MSWin32' || $! != EWOULDBLOCK)) {
+ # EINPROGRESS is the expected error code after a connect()
+ # on a non-blocking socket. But if the kernel immediately
+ # determined that this connect() will never work,
+ # Simply respond with "unreachable" status.
+ # (This can occur on some platforms with errno
+ # EHOSTUNREACH or ENETUNREACH.)
+ return 0;
+ } else {
+ # Got the expected EINPROGRESS.
+ # Just wait for connection completion...
+ my ($wbits, $wout, $wexc);
+ $wout = $wexc = $wbits = "";
+ vec($wbits, $self->{"fh"}->fileno, 1) = 1;
+
+ my $nfound = mselect(undef,
+ ($wout = $wbits),
+ ($^O eq 'MSWin32' ? ($wexc = $wbits) : undef),
+ $timeout);
+ warn("select: $!") unless defined $nfound;
+
+ if ($nfound && vec($wout, $self->{"fh"}->fileno, 1)) {
+ # the socket is ready for writing so the connection
+ # attempt completed. test whether the connection
+ # attempt was successful or not
+
+ if (getpeername($self->{"fh"})) {
+ # Connection established to remote host
+ $ret = 1;
+ } else {
+ # TCP ACK will never come from this host
+ # because there was an error connecting.
+
+ # This should set $! to the correct error.
+ my $char;
+ sysread($self->{"fh"},$char,1);
+ $! = ECONNREFUSED if ($! == EAGAIN && $^O =~ /cygwin/i);
+
+ $ret = 1 if (!$self->{"econnrefused"}
+ && $! == ECONNREFUSED);
+ }
+ } else {
+ # the connection attempt timed out (or there were connect
+ # errors on Windows)
+ if ($^O =~ 'MSWin32') {
+ # If the connect will fail on a non-blocking socket,
+ # winsock reports ECONNREFUSED as an exception, and we
+ # need to fetch the socket-level error code via getsockopt()
+ # instead of using the thread-level error code that is in $!.
+ if ($nfound && vec($wexc, $self->{"fh"}->fileno, 1)) {
+ $! = unpack("i", getsockopt($self->{"fh"}, SOL_SOCKET,
+ SO_ERROR));
+ }
+ }
+ }
+ }
+ } else {
+ # Connection established to remote host
+ $ret = 1;
+ }
+
+ # Unset O_NONBLOCK property on filehandle
+ $self->socket_blocking_mode($self->{"fh"}, 1);
+ $self->{"ip"} = $ip;
+ return $ret;
+ };
+
+ if ($syn_forking) {
+ # Buggy Winsock API doesn't allow nonblocking connect.
+ # Hence, if our OS is Windows, we need to create a separate
+ # process to do the blocking connect attempt.
+ # XXX Above comments are not true at least for Win2K, where
+ # nonblocking connect works.
+
+ $| = 1; # Clear buffer prior to fork to prevent duplicate flushing.
+ $self->{'tcp_chld'} = fork;
+ if (!$self->{'tcp_chld'}) {
+ if (!defined $self->{'tcp_chld'}) {
+ # Fork did not work
+ warn "Fork error: $!";
+ return 0;
+ }
+ &{ $do_socket }();
+
+ # Try a slow blocking connect() call
+ # and report the status to the parent.
+ if ( &{ $do_connect }() ) {
+ $self->{"fh"}->close();
+ # No error
+ exit 0;
+ } else {
+ # Pass the error status to the parent
+ # Make sure that $! <= 255
+ exit($! <= 255 ? $! : 255);
+ }
+ }
+
+ &{ $do_socket }();
+
+ my $patience = &time() + $timeout;
+
+ my ($child, $child_errno);
+ $? = 0; $child_errno = 0;
+ # Wait up to the timeout
+ # And clean off the zombie
+ do {
+ $child = waitpid($self->{'tcp_chld'}, &WNOHANG());
+ $child_errno = $? >> 8;
+ select(undef, undef, undef, 0.1);
+ } while &time() < $patience && $child != $self->{'tcp_chld'};
+
+ if ($child == $self->{'tcp_chld'}) {
+ if ($self->{"proto"} eq "stream") {
+ # We need the socket connected here, in parent
+ # Should be safe to connect because the child finished
+ # within the timeout
+ &{ $do_connect }();
+ }
+ # $ret cannot be set by the child process
+ $ret = !$child_errno;
+ } else {
+ # Time must have run out.
+ # Put that choking client out of its misery
+ kill "KILL", $self->{'tcp_chld'};
+ # Clean off the zombie
+ waitpid($self->{'tcp_chld'}, 0);
+ $ret = 0;
+ }
+ delete $self->{'tcp_chld'};
+ $! = $child_errno;
+ } else {
+ # Otherwise don't waste the resources to fork
+
+ &{ $do_socket }();
+
+ &{ $do_connect_nb }();
+ }
+
+ return $ret;
+}
+
+sub DESTROY {
+ my $self = shift;
+ if ($self->{'proto'} eq 'tcp' &&
+ $self->{'tcp_chld'}) {
+ # Put that choking client out of its misery
+ kill "KILL", $self->{'tcp_chld'};
+ # Clean off the zombie
+ waitpid($self->{'tcp_chld'}, 0);
+ }
+}
+
+# This writes the given string to the socket and then reads it
+# back. It returns 1 on success, 0 on failure.
+sub tcp_echo
+{
+ my $self = shift;
+ my $timeout = shift;
+ my $pingstring = shift;
+
+ my $ret = undef;
+ my $time = &time();
+ my $wrstr = $pingstring;
+ my $rdstr = "";
+
+ eval <<'EOM';
+ do {
+ my $rin = "";
+ vec($rin, $self->{"fh"}->fileno(), 1) = 1;
+
+ my $rout = undef;
+ if($wrstr) {
+ $rout = "";
+ vec($rout, $self->{"fh"}->fileno(), 1) = 1;
+ }
+
+ if(mselect($rin, $rout, undef, ($time + $timeout) - &time())) {
+
+ if($rout && vec($rout,$self->{"fh"}->fileno(),1)) {
+ my $num = syswrite($self->{"fh"}, $wrstr, length $wrstr);
+ if($num) {
+ # If it was a partial write, update and try again.
+ $wrstr = substr($wrstr,$num);
+ } else {
+ # There was an error.
+ $ret = 0;
+ }
+ }
+
+ if(vec($rin,$self->{"fh"}->fileno(),1)) {
+ my $reply;
+ if(sysread($self->{"fh"},$reply,length($pingstring)-length($rdstr))) {
+ $rdstr .= $reply;
+ $ret = 1 if $rdstr eq $pingstring;
+ } else {
+ # There was an error.
+ $ret = 0;
+ }
+ }
+
+ }
+ } until &time() > ($time + $timeout) || defined($ret);
+EOM
+
+ return $ret;
+}
+
+
+
+
+# Description: Perform a stream ping. If the tcp connection isn't
+# already open, it opens it. It then sends some data and waits for
+# a reply. It leaves the stream open on exit.
+
+sub ping_stream
+{
+ my ($self,
+ $ip, # Packed IP number of the host
+ $timeout # Seconds after which ping times out
+ ) = @_;
+
+ # Open the stream if it's not already open
+ if(!defined $self->{"fh"}->fileno()) {
+ $self->tcp_connect($ip, $timeout) or return 0;
+ }
+
+ croak "tried to switch servers while stream pinging"
+ if $self->{"ip"} ne $ip;
+
+ return $self->tcp_echo($timeout, $pingstring);
+}
+
+# Description: opens the stream. You would do this if you want to
+# separate the overhead of opening the stream from the first ping.
+
+sub open
+{
+ my ($self,
+ $host, # Host or IP address
+ $timeout # Seconds after which open times out
+ ) = @_;
+
+ my ($ip); # Packed IP number of the host
+ $ip = inet_aton($host);
+ $timeout = $self->{"timeout"} unless $timeout;
+
+ if($self->{"proto"} eq "stream") {
+ if(defined($self->{"fh"}->fileno())) {
+ croak("socket is already open");
+ } else {
+ $self->tcp_connect($ip, $timeout);
+ }
+ }
+}
+
+
+# Description: Perform a udp echo ping. Construct a message of
+# at least the one-byte sequence number and any additional data bytes.
+# Send the message out and wait for a message to come back. If we
+# get a message, make sure all of its parts match. If they do, we are
+# done. Otherwise go back and wait for the message until we run out
+# of time. Return the result of our efforts.
+
+use constant UDP_FLAGS => 0; # Nothing special on send or recv
+sub ping_udp
+{
+ my ($self,
+ $ip, # Packed IP number of the host
+ $timeout # Seconds after which ping times out
+ ) = @_;
+
+ my ($saddr, # sockaddr_in with port and ip
+ $ret, # The return value
+ $msg, # Message to be echoed
+ $finish_time, # Time ping should be finished
+ $flush, # Whether socket needs to be disconnected
+ $connect, # Whether socket needs to be connected
+ $done, # Set to 1 when we are done pinging
+ $rbits, # Read bits, filehandles for reading
+ $nfound, # Number of ready filehandles found
+ $from_saddr, # sockaddr_in of sender
+ $from_msg, # Characters echoed by $host
+ $from_port, # Port message was echoed from
+ $from_ip # Packed IP number of sender
+ );
+
+ $saddr = sockaddr_in($self->{"port_num"}, $ip);
+ $self->{"seq"} = ($self->{"seq"} + 1) % 256; # Increment sequence
+ $msg = chr($self->{"seq"}) . $self->{"data"}; # Add data if any
+
+ if ($self->{"connected"}) {
+ if ($self->{"connected"} ne $saddr) {
+ # Still connected to wrong destination.
+ # Need to flush out the old one.
+ $flush = 1;
+ }
+ } else {
+ # Not connected yet.
+ # Need to connect() before send()
+ $connect = 1;
+ }
+
+ # Have to connect() and send() instead of sendto()
+ # in order to pick up on the ECONNREFUSED setting
+ # from recv() or double send() errno as utilized in
+ # the concept by rdw @ perlmonks. See:
+ # http://perlmonks.thepen.com/42898.html
+ if ($flush) {
+ # Need to socket() again to flush the descriptor
+ # This will disconnect from the old saddr.
+ socket($self->{"fh"}, PF_INET, SOCK_DGRAM,
+ $self->{"proto_num"});
+ }
+ # Connect the socket if it isn't already connected
+ # to the right destination.
+ if ($flush || $connect) {
+ connect($self->{"fh"}, $saddr); # Tie destination to socket
+ $self->{"connected"} = $saddr;
+ }
+ send($self->{"fh"}, $msg, UDP_FLAGS); # Send it
+
+ $rbits = "";
+ vec($rbits, $self->{"fh"}->fileno(), 1) = 1;
+ $ret = 0; # Default to unreachable
+ $done = 0;
+ my $retrans = 0.01;
+ my $factor = $self->{"retrans"};
+ $finish_time = &time() + $timeout; # Ping needs to be done by then
+ while (!$done && $timeout > 0)
+ {
+ if ($factor > 1)
+ {
+ $timeout = $retrans if $timeout > $retrans;
+ $retrans*= $factor; # Exponential backoff
+ }
+ $nfound = mselect((my $rout=$rbits), undef, undef, $timeout); # Wait for response
+ my $why = $!;
+ $timeout = $finish_time - &time(); # Get remaining time
+
+ if (!defined($nfound)) # Hmm, a strange error
+ {
+ $ret = undef;
+ $done = 1;
+ }
+ elsif ($nfound) # A packet is waiting
+ {
+ $from_msg = "";
+ $from_saddr = recv($self->{"fh"}, $from_msg, 1500, UDP_FLAGS);
+ if (!$from_saddr) {
+ # For example an unreachable host will make recv() fail.
+ if (!$self->{"econnrefused"} &&
+ ($! == ECONNREFUSED ||
+ $! == ECONNRESET)) {
+ # "Connection refused" means reachable
+ # Good, continue
+ $ret = 1;
+ }
+ $done = 1;
+ } else {
+ ($from_port, $from_ip) = sockaddr_in($from_saddr);
+ if (!$source_verify ||
+ (($from_ip eq $ip) && # Does the packet check out?
+ ($from_port == $self->{"port_num"}) &&
+ ($from_msg eq $msg)))
+ {
+ $ret = 1; # It's a winner
+ $done = 1;
+ }
+ }
+ }
+ elsif ($timeout <= 0) # Oops, timed out
+ {
+ $done = 1;
+ }
+ else
+ {
+ # Send another in case the last one dropped
+ if (send($self->{"fh"}, $msg, UDP_FLAGS)) {
+ # Another send worked? The previous udp packet
+ # must have gotten lost or is still in transit.
+ # Hopefully this new packet will arrive safely.
+ } else {
+ if (!$self->{"econnrefused"} &&
+ $! == ECONNREFUSED) {
+ # "Connection refused" means reachable
+ # Good, continue
+ $ret = 1;
+ }
+ $done = 1;
+ }
+ }
+ }
+ return $ret;
+}
+
+# Description: Send a TCP SYN packet to host specified.
+sub ping_syn
+{
+ my $self = shift;
+ my $host = shift;
+ my $ip = shift;
+ my $start_time = shift;
+ my $stop_time = shift;
+
+ if ($syn_forking) {
+ return $self->ping_syn_fork($host, $ip, $start_time, $stop_time);
+ }
+
+ my $fh = FileHandle->new();
+ my $saddr = sockaddr_in($self->{"port_num"}, $ip);
+
+ # Create TCP socket
+ if (!socket ($fh, PF_INET, SOCK_STREAM, $self->{"proto_num"})) {
+ croak("tcp socket error - $!");
+ }
+
+ if (defined $self->{"local_addr"} &&
+ !CORE::bind($fh, sockaddr_in(0, $self->{"local_addr"}))) {
+ croak("tcp bind error - $!");
+ }
+
+ if ($self->{'device'}) {
+ setsockopt($fh, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
+ or croak("error binding to device $self->{'device'} $!");
+ }
+ if ($self->{'tos'}) {
+ setsockopt($fh, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
+ or croak "error configuring tos to $self->{'tos'} $!";
+ }
+ # Set O_NONBLOCK property on filehandle
+ $self->socket_blocking_mode($fh, 0);
+
+ # Attempt the non-blocking connect
+ # by just sending the TCP SYN packet
+ if (connect($fh, $saddr)) {
+ # Non-blocking, yet still connected?
+ # Must have connected very quickly,
+ # or else it wasn't very non-blocking.
+ #warn "WARNING: Nonblocking connect connected anyway? ($^O)";
+ } else {
+ # Error occurred connecting.
+ if ($! == EINPROGRESS || ($^O eq 'MSWin32' && $! == EWOULDBLOCK)) {
+ # The connection is just still in progress.
+ # This is the expected condition.
+ } else {
+ # Just save the error and continue on.
+ # The ack() can check the status later.
+ $self->{"bad"}->{$host} = $!;
+ }
+ }
+
+ my $entry = [ $host, $ip, $fh, $start_time, $stop_time ];
+ $self->{"syn"}->{$fh->fileno} = $entry;
+ if ($self->{"stop_time"} < $stop_time) {
+ $self->{"stop_time"} = $stop_time;
+ }
+ vec($self->{"wbits"}, $fh->fileno, 1) = 1;
+
+ return 1;
+}
+
+sub ping_syn_fork {
+ my ($self, $host, $ip, $start_time, $stop_time) = @_;
+
+ # Buggy Winsock API doesn't allow nonblocking connect.
+ # Hence, if our OS is Windows, we need to create a separate
+ # process to do the blocking connect attempt.
+ my $pid = fork();
+ if (defined $pid) {
+ if ($pid) {
+ # Parent process
+ my $entry = [ $host, $ip, $pid, $start_time, $stop_time ];
+ $self->{"syn"}->{$pid} = $entry;
+ if ($self->{"stop_time"} < $stop_time) {
+ $self->{"stop_time"} = $stop_time;
+ }
+ } else {
+ # Child process
+ my $saddr = sockaddr_in($self->{"port_num"}, $ip);
+
+ # Create TCP socket
+ if (!socket ($self->{"fh"}, PF_INET, SOCK_STREAM, $self->{"proto_num"})) {
+ croak("tcp socket error - $!");
+ }
+
+ if (defined $self->{"local_addr"} &&
+ !CORE::bind($self->{"fh"}, sockaddr_in(0, $self->{"local_addr"}))) {
+ croak("tcp bind error - $!");
+ }
+
+ if ($self->{'device'}) {
+ setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
+ or croak("error binding to device $self->{'device'} $!");
+ }
+ if ($self->{'tos'}) {
+ setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
+ or croak "error configuring tos to $self->{'tos'} $!";
+ }
+
+ $!=0;
+ # Try to connect (could take a long time)
+ connect($self->{"fh"}, $saddr);
+ # Notify parent of connect error status
+ my $err = $!+0;
+ my $wrstr = "$$ $err";
+ # Force to 16 chars including \n
+ $wrstr .= " "x(15 - length $wrstr). "\n";
+ syswrite($self->{"fork_wr"}, $wrstr, length $wrstr);
+ exit;
+ }
+ } else {
+ # fork() failed?
+ die "fork: $!";
+ }
+ return 1;
+}
+
+# Description: Wait for TCP ACK from host specified
+# from ping_syn above. If no host is specified, wait
+# for TCP ACK from any of the hosts in the SYN queue.
+sub ack
+{
+ my $self = shift;
+
+ if ($self->{"proto"} eq "syn") {
+ if ($syn_forking) {
+ my @answer = $self->ack_unfork(shift);
+ return wantarray ? @answer : $answer[0];
+ }
+ my $wbits = "";
+ my $stop_time = 0;
+ if (my $host = shift) {
+ # Host passed as arg
+ if (exists $self->{"bad"}->{$host}) {
+ if (!$self->{"econnrefused"} &&
+ $self->{"bad"}->{ $host } &&
+ (($! = ECONNREFUSED)>0) &&
+ $self->{"bad"}->{ $host } eq "$!") {
+ # "Connection refused" means reachable
+ # Good, continue
+ } else {
+ # ECONNREFUSED means no good
+ return ();
+ }
+ }
+ my $host_fd = undef;
+ foreach my $fd (keys %{ $self->{"syn"} }) {
+ my $entry = $self->{"syn"}->{$fd};
+ if ($entry->[0] eq $host) {
+ $host_fd = $fd;
+ $stop_time = $entry->[4]
+ || croak("Corrupted SYN entry for [$host]");
+ last;
+ }
+ }
+ croak("ack called on [$host] without calling ping first!")
+ unless defined $host_fd;
+ vec($wbits, $host_fd, 1) = 1;
+ } else {
+ # No $host passed so scan all hosts
+ # Use the latest stop_time
+ $stop_time = $self->{"stop_time"};
+ # Use all the bits
+ $wbits = $self->{"wbits"};
+ }
+
+ while ($wbits !~ /^\0*\z/) {
+ my $timeout = $stop_time - &time();
+ # Force a minimum of 10 ms timeout.
+ $timeout = 0.01 if $timeout <= 0.01;
+
+ my $winner_fd = undef;
+ my $wout = $wbits;
+ my $fd = 0;
+ # Do "bad" fds from $wbits first
+ while ($wout !~ /^\0*\z/) {
+ if (vec($wout, $fd, 1)) {
+ # Wipe it from future scanning.
+ vec($wout, $fd, 1) = 0;
+ if (my $entry = $self->{"syn"}->{$fd}) {
+ if ($self->{"bad"}->{ $entry->[0] }) {
+ $winner_fd = $fd;
+ last;
+ }
+ }
+ }
+ $fd++;
+ }
+
+ if (defined($winner_fd) or my $nfound = mselect(undef, ($wout=$wbits), undef, $timeout)) {
+ if (defined $winner_fd) {
+ $fd = $winner_fd;
+ } else {
+ # Done waiting for one of the ACKs
+ $fd = 0;
+ # Determine which one
+ while ($wout !~ /^\0*\z/ &&
+ !vec($wout, $fd, 1)) {
+ $fd++;
+ }
+ }
+ if (my $entry = $self->{"syn"}->{$fd}) {
+ # Wipe it from future scanning.
+ delete $self->{"syn"}->{$fd};
+ vec($self->{"wbits"}, $fd, 1) = 0;
+ vec($wbits, $fd, 1) = 0;
+ if (!$self->{"econnrefused"} &&
+ $self->{"bad"}->{ $entry->[0] } &&
+ (($! = ECONNREFUSED)>0) &&
+ $self->{"bad"}->{ $entry->[0] } eq "$!") {
+ # "Connection refused" means reachable
+ # Good, continue
+ } elsif (getpeername($entry->[2])) {
+ # Connection established to remote host
+ # Good, continue
+ } else {
+ # TCP ACK will never come from this host
+ # because there was an error connecting.
+
+ # This should set $! to the correct error.
+ my $char;
+ sysread($entry->[2],$char,1);
+ # Store the excuse why the connection failed.
+ $self->{"bad"}->{$entry->[0]} = $!;
+ if (!$self->{"econnrefused"} &&
+ (($! == ECONNREFUSED) ||
+ ($! == EAGAIN && $^O =~ /cygwin/i))) {
+ # "Connection refused" means reachable
+ # Good, continue
+ } else {
+ # No good, try the next socket...
+ next;
+ }
+ }
+ # Everything passed okay, return the answer
+ return wantarray ?
+ ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1]))
+ : $entry->[0];
+ } else {
+ warn "Corrupted SYN entry: unknown fd [$fd] ready!";
+ vec($wbits, $fd, 1) = 0;
+ vec($self->{"wbits"}, $fd, 1) = 0;
+ }
+ } elsif (defined $nfound) {
+ # Timed out waiting for ACK
+ foreach my $fd (keys %{ $self->{"syn"} }) {
+ if (vec($wbits, $fd, 1)) {
+ my $entry = $self->{"syn"}->{$fd};
+ $self->{"bad"}->{$entry->[0]} = "Timed out";
+ vec($wbits, $fd, 1) = 0;
+ vec($self->{"wbits"}, $fd, 1) = 0;
+ delete $self->{"syn"}->{$fd};
+ }
+ }
+ } else {
+ # Weird error occurred with select()
+ warn("select: $!");
+ $self->{"syn"} = {};
+ $wbits = "";
+ }
+ }
+ }
+ return ();
+}
+
+sub ack_unfork {
+ my ($self,$host) = @_;
+ my $stop_time = $self->{"stop_time"};
+ if ($host) {
+ # Host passed as arg
+ if (my $entry = $self->{"good"}->{$host}) {
+ delete $self->{"good"}->{$host};
+ return ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1]));
+ }
+ }
+
+ my $rbits = "";
+ my $timeout;
+
+ if (keys %{ $self->{"syn"} }) {
+ # Scan all hosts that are left
+ vec($rbits, fileno($self->{"fork_rd"}), 1) = 1;
+ $timeout = $stop_time - &time();
+ # Force a minimum of 10 ms timeout.
+ $timeout = 0.01 if $timeout < 0.01;
+ } else {
+ # No hosts left to wait for
+ $timeout = 0;
+ }
+
+ if ($timeout > 0) {
+ my $nfound;
+ while ( keys %{ $self->{"syn"} } and
+ $nfound = mselect((my $rout=$rbits), undef, undef, $timeout)) {
+ # Done waiting for one of the ACKs
+ if (!sysread($self->{"fork_rd"}, $_, 16)) {
+ # Socket closed, which means all children are done.
+ return ();
+ }
+ my ($pid, $how) = split;
+ if ($pid) {
+ # Flush the zombie
+ waitpid($pid, 0);
+ if (my $entry = $self->{"syn"}->{$pid}) {
+ # Connection attempt to remote host is done
+ delete $self->{"syn"}->{$pid};
+ if (!$how || # If there was no error connecting
+ (!$self->{"econnrefused"} &&
+ $how == ECONNREFUSED)) { # "Connection refused" means reachable
+ if ($host && $entry->[0] ne $host) {
+ # A good connection, but not the host we need.
+ # Move it from the "syn" hash to the "good" hash.
+ $self->{"good"}->{$entry->[0]} = $entry;
+ # And wait for the next winner
+ next;
+ }
+ return ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1]));
+ }
+ } else {
+ # Should never happen
+ die "Unknown ping from pid [$pid]";
+ }
+ } else {
+ die "Empty response from status socket?";
+ }
+ }
+ if (defined $nfound) {
+ # Timed out waiting for ACK status
+ } else {
+ # Weird error occurred with select()
+ warn("select: $!");
+ }
+ }
+ if (my @synners = keys %{ $self->{"syn"} }) {
+ # Kill all the synners
+ kill 9, @synners;
+ foreach my $pid (@synners) {
+ # Wait for the deaths to finish
+ # Then flush off the zombie
+ waitpid($pid, 0);
+ }
+ }
+ $self->{"syn"} = {};
+ return ();
+}
+
+# Description: Tell why the ack() failed
+sub nack {
+ my $self = shift;
+ my $host = shift || croak('Usage> nack($failed_ack_host)');
+ return $self->{"bad"}->{$host} || undef;
+}
+
+# Description: Close the connection.
+
+sub close
+{
+ my ($self) = @_;
+
+ if ($self->{"proto"} eq "syn") {
+ delete $self->{"syn"};
+ } elsif ($self->{"proto"} eq "tcp") {
+ # The connection will already be closed
+ } else {
+ $self->{"fh"}->close();
+ }
+}
+
+sub port_number {
+ my $self = shift;
+ if(@_) {
+ $self->{port_num} = shift @_;
+ $self->service_check(1);
+ }
+ return $self->{port_num};
+}
+
+
+1;
+__END__
+
+=head1 NAME
+
+Net::Ping - check a remote host for reachability
+
+=head1 SYNOPSIS
+
+ use Net::Ping;
+
+ $p = Net::Ping->new();
+ print "$host is alive.\n" if $p->ping($host);
+ $p->close();
+
+ $p = Net::Ping->new("icmp");
+ $p->bind($my_addr); # Specify source interface of pings
+ foreach $host (@host_array)
+ {
+ print "$host is ";
+ print "NOT " unless $p->ping($host, 2);
+ print "reachable.\n";
+ sleep(1);
+ }
+ $p->close();
+
+ $p = Net::Ping->new("tcp", 2);
+ # Try connecting to the www port instead of the echo port
+ $p->port_number(getservbyname("http", "tcp"));
+ while ($stop_time > time())
+ {
+ print "$host not reachable ", scalar(localtime()), "\n"
+ unless $p->ping($host);
+ sleep(300);
+ }
+ undef($p);
+
+ # Like tcp protocol, but with many hosts
+ $p = Net::Ping->new("syn");
+ $p->port_number(getservbyname("http", "tcp"));
+ foreach $host (@host_array) {
+ $p->ping($host);
+ }
+ while (($host,$rtt,$ip) = $p->ack) {
+ print "HOST: $host [$ip] ACKed in $rtt seconds.\n";
+ }
+
+ # High precision syntax (requires Time::HiRes)
+ $p = Net::Ping->new();
+ $p->hires();
+ ($ret, $duration, $ip) = $p->ping($host, 5.5);
+ printf("$host [ip: $ip] is alive (packet return time: %.2f ms)\n", 1000 * $duration)
+ if $ret;
+ $p->close();
+
+ # For backward compatibility
+ print "$host is alive.\n" if pingecho($host);
+
+=head1 DESCRIPTION
+
+This module contains methods to test the reachability of remote
+hosts on a network. A ping object is first created with optional
+parameters, a variable number of hosts may be pinged multiple
+times and then the connection is closed.
+
+You may choose one of six different protocols to use for the
+ping. The "tcp" protocol is the default. Note that a live remote host
+may still fail to be pingable by one or more of these protocols. For
+example, www.microsoft.com is generally alive but not "icmp" pingable.
+
+With the "tcp" protocol the ping() method attempts to establish a
+connection to the remote host's echo port. If the connection is
+successfully established, the remote host is considered reachable. No
+data is actually echoed. This protocol does not require any special
+privileges but has higher overhead than the "udp" and "icmp" protocols.
+
+Specifying the "udp" protocol causes the ping() method to send a udp
+packet to the remote host's echo port. If the echoed packet is
+received from the remote host and the received packet contains the
+same data as the packet that was sent, the remote host is considered
+reachable. This protocol does not require any special privileges.
+It should be borne in mind that, for a udp ping, a host
+will be reported as unreachable if it is not running the
+appropriate echo service. For Unix-like systems see L<inetd(8)>
+for more information.
+
+If the "icmp" protocol is specified, the ping() method sends an icmp
+echo message to the remote host, which is what the UNIX ping program
+does. If the echoed message is received from the remote host and
+the echoed information is correct, the remote host is considered
+reachable. Specifying the "icmp" protocol requires that the program
+be run as root or that the program be setuid to root.
+
+If the "external" protocol is specified, the ping() method attempts to
+use the C<Net::Ping::External> module to ping the remote host.
+C<Net::Ping::External> interfaces with your system's default C<ping>
+utility to perform the ping, and generally produces relatively
+accurate results. If C<Net::Ping::External> if not installed on your
+system, specifying the "external" protocol will result in an error.
+
+If the "syn" protocol is specified, the ping() method will only
+send a TCP SYN packet to the remote host then immediately return.
+If the syn packet was sent successfully, it will return a true value,
+otherwise it will return false. NOTE: Unlike the other protocols,
+the return value does NOT determine if the remote host is alive or
+not since the full TCP three-way handshake may not have completed
+yet. The remote host is only considered reachable if it receives
+a TCP ACK within the timeout specified. To begin waiting for the
+ACK packets, use the ack() method as explained below. Use the
+"syn" protocol instead the "tcp" protocol to determine reachability
+of multiple destinations simultaneously by sending parallel TCP
+SYN packets. It will not block while testing each remote host.
+demo/fping is provided in this distribution to demonstrate the
+"syn" protocol as an example.
+This protocol does not require any special privileges.
+
+=head2 Functions
+
+=over 4
+
+=item Net::Ping->new([$proto [, $def_timeout [, $bytes [, $device [, $tos ]]]]]);
+
+Create a new ping object. All of the parameters are optional. $proto
+specifies the protocol to use when doing a ping. The current choices
+are "tcp", "udp", "icmp", "stream", "syn", or "external".
+The default is "tcp".
+
+If a default timeout ($def_timeout) in seconds is provided, it is used
+when a timeout is not given to the ping() method (below). The timeout
+must be greater than 0 and the default, if not specified, is 5 seconds.
+
+If the number of data bytes ($bytes) is given, that many data bytes
+are included in the ping packet sent to the remote host. The number of
+data bytes is ignored if the protocol is "tcp". The minimum (and
+default) number of data bytes is 1 if the protocol is "udp" and 0
+otherwise. The maximum number of data bytes that can be specified is
+1024.
+
+If $device is given, this device is used to bind the source endpoint
+before sending the ping packet. I believe this only works with
+superuser privileges and with udp and icmp protocols at this time.
+
+If $tos is given, this ToS is configured into the socket.
+
+=item $p->ping($host [, $timeout]);
+
+Ping the remote host and wait for a response. $host can be either the
+hostname or the IP number of the remote host. The optional timeout
+must be greater than 0 seconds and defaults to whatever was specified
+when the ping object was created. Returns a success flag. If the
+hostname cannot be found or there is a problem with the IP number, the
+success flag returned will be undef. Otherwise, the success flag will
+be 1 if the host is reachable and 0 if it is not. For most practical
+purposes, undef and 0 and can be treated as the same case. In array
+context, the elapsed time as well as the string form of the ip the
+host resolved to are also returned. The elapsed time value will
+be a float, as retuned by the Time::HiRes::time() function, if hires()
+has been previously called, otherwise it is returned as an integer.
+
+=item $p->source_verify( { 0 | 1 } );
+
+Allows source endpoint verification to be enabled or disabled.
+This is useful for those remote destinations with multiples
+interfaces where the response may not originate from the same
+endpoint that the original destination endpoint was sent to.
+This only affects udp and icmp protocol pings.
+
+This is enabled by default.
+
+=item $p->service_check( { 0 | 1 } );
+
+Set whether or not the connect behavior should enforce
+remote service availability as well as reachability. Normally,
+if the remote server reported ECONNREFUSED, it must have been
+reachable because of the status packet that it reported.
+With this option enabled, the full three-way tcp handshake
+must have been established successfully before it will
+claim it is reachable. NOTE: It still does nothing more
+than connect and disconnect. It does not speak any protocol
+(i.e., HTTP or FTP) to ensure the remote server is sane in
+any way. The remote server CPU could be grinding to a halt
+and unresponsive to any clients connecting, but if the kernel
+throws the ACK packet, it is considered alive anyway. To
+really determine if the server is responding well would be
+application specific and is beyond the scope of Net::Ping.
+For udp protocol, enabling this option demands that the
+remote server replies with the same udp data that it was sent
+as defined by the udp echo service.
+
+This affects the "udp", "tcp", and "syn" protocols.
+
+This is disabled by default.
+
+=item $p->tcp_service_check( { 0 | 1 } );
+
+Deprecated method, but does the same as service_check() method.
+
+=item $p->hires( { 0 | 1 } );
+
+Causes this module to use Time::HiRes module, allowing milliseconds
+to be returned by subsequent calls to ping().
+
+This is disabled by default.
+
+=item $p->bind($local_addr);
+
+Sets the source address from which pings will be sent. This must be
+the address of one of the interfaces on the local host. $local_addr
+may be specified as a hostname or as a text IP address such as
+"192.168.1.1".
+
+If the protocol is set to "tcp", this method may be called any
+number of times, and each call to the ping() method (below) will use
+the most recent $local_addr. If the protocol is "icmp" or "udp",
+then bind() must be called at most once per object, and (if it is
+called at all) must be called before the first call to ping() for that
+object.
+
+=item $p->open($host);
+
+When you are using the "stream" protocol, this call pre-opens the
+tcp socket. It's only necessary to do this if you want to
+provide a different timeout when creating the connection, or
+remove the overhead of establishing the connection from the
+first ping. If you don't call C<open()>, the connection is
+automatically opened the first time C<ping()> is called.
+This call simply does nothing if you are using any protocol other
+than stream.
+
+=item $p->ack( [ $host ] );
+
+When using the "syn" protocol, use this method to determine
+the reachability of the remote host. This method is meant
+to be called up to as many times as ping() was called. Each
+call returns the host (as passed to ping()) that came back
+with the TCP ACK. The order in which the hosts are returned
+may not necessarily be the same order in which they were
+SYN queued using the ping() method. If the timeout is
+reached before the TCP ACK is received, or if the remote
+host is not listening on the port attempted, then the TCP
+connection will not be established and ack() will return
+undef. In list context, the host, the ack time, and the
+dotted ip string will be returned instead of just the host.
+If the optional $host argument is specified, the return
+value will be pertaining to that host only.
+This call simply does nothing if you are using any protocol
+other than syn.
+
+=item $p->nack( $failed_ack_host );
+
+The reason that host $failed_ack_host did not receive a
+valid ACK. Useful to find out why when ack( $fail_ack_host )
+returns a false value.
+
+=item $p->close();
+
+Close the network connection for this ping object. The network
+connection is also closed by "undef $p". The network connection is
+automatically closed if the ping object goes out of scope (e.g. $p is
+local to a subroutine and you leave the subroutine).
+
+=item $p->port_number([$port_number])
+
+When called with a port number, the port number used to ping is set to
+$port_number rather than using the echo port. It also has the effect
+of calling C<$p-E<gt>service_check(1)> causing a ping to return a successful
+response only if that specific port is accessible. This function returns
+the value of the port that C<ping()> will connect to.
+
+=item pingecho($host [, $timeout]);
+
+To provide backward compatibility with the previous version of
+Net::Ping, a pingecho() subroutine is available with the same
+functionality as before. pingecho() uses the tcp protocol. The
+return values and parameters are the same as described for the ping()
+method. This subroutine is obsolete and may be removed in a future
+version of Net::Ping.
+
+=back
+
+=head1 NOTES
+
+There will be less network overhead (and some efficiency in your
+program) if you specify either the udp or the icmp protocol. The tcp
+protocol will generate 2.5 times or more traffic for each ping than
+either udp or icmp. If many hosts are pinged frequently, you may wish
+to implement a small wait (e.g. 25ms or more) between each ping to
+avoid flooding your network with packets.
+
+The icmp protocol requires that the program be run as root or that it
+be setuid to root. The other protocols do not require special
+privileges, but not all network devices implement tcp or udp echo.
+
+Local hosts should normally respond to pings within milliseconds.
+However, on a very congested network it may take up to 3 seconds or
+longer to receive an echo packet from the remote host. If the timeout
+is set too low under these conditions, it will appear that the remote
+host is not reachable (which is almost the truth).
+
+Reachability doesn't necessarily mean that the remote host is actually
+functioning beyond its ability to echo packets. tcp is slightly better
+at indicating the health of a system than icmp because it uses more
+of the networking stack to respond.
+
+Because of a lack of anything better, this module uses its own
+routines to pack and unpack ICMP packets. It would be better for a
+separate module to be written which understands all of the different
+kinds of ICMP packets.
+
+=head1 INSTALL
+
+The latest source tree is available via cvs:
+
+ cvs -z3 -q -d :pserver:anonymous at cvs.roobik.com.:/usr/local/cvsroot/freeware checkout Net-Ping
+ cd Net-Ping
+
+The tarball can be created as follows:
+
+ perl Makefile.PL ; make ; make dist
+
+The latest Net::Ping release can be found at CPAN:
+
+ $CPAN/modules/by-module/Net/
+
+1) Extract the tarball
+
+ gtar -zxvf Net-Ping-xxxx.tar.gz
+ cd Net-Ping-xxxx
+
+2) Build:
+
+ make realclean
+ perl Makefile.PL
+ make
+ make test
+
+3) Install
+
+ make install
+
+Or install it RPM Style:
+
+ rpm -ta SOURCES/Net-Ping-xxxx.tar.gz
+
+ rpm -ih RPMS/noarch/perl-Net-Ping-xxxx.rpm
+
+=head1 BUGS
+
+For a list of known issues, visit:
+
+https://rt.cpan.org/NoAuth/Bugs.html?Dist=Net-Ping
+
+To report a new bug, visit:
+
+https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net-Ping
+
+=head1 AUTHORS
+
+ Current maintainer:
+ bbb at cpan.org (Rob Brown)
+
+ External protocol:
+ colinm at cpan.org (Colin McMillen)
+
+ Stream protocol:
+ bronson at trestle.com (Scott Bronson)
+
+ Original pingecho():
+ karrer at bernina.ethz.ch (Andreas Karrer)
+ pmarquess at bfsec.bt.co.uk (Paul Marquess)
+
+ Original Net::Ping author:
+ mose at ns.ccsn.edu (Russell Mosemann)
+
+=head1 COPYRIGHT
+
+Copyright (c) 2002-2003, Rob Brown. All rights reserved.
+
+Copyright (c) 2001, Colin McMillen. All rights reserved.
+
+This program is free software; you may redistribute it and/or
+modify it under the same terms as Perl itself.
+
+$Id: Ping.pm,v 1.1.1.2 2011-02-17 12:49:38 laffer1 Exp $
+
+=cut
Copied: trunk/contrib/perl/lib/Net/README (from rev 6437, vendor/perl/5.18.1/lib/Net/README)
===================================================================
--- trunk/contrib/perl/lib/Net/README (rev 0)
+++ trunk/contrib/perl/lib/Net/README 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,109 @@
+libnet is a collection of Perl modules which provides a simple
+and consistent programming interface (API) to the client side
+of various protocols used in the internet community.
+
+For details of each protocol please refer to the RFC. RFC's
+can be found a various places on the WEB, for a starting
+point look at:
+
+ http://www.yahoo.com/Computers_and_Internet/Standards/RFCs/
+
+The RFC implemented in this distribution are
+
+Net::FTP RFC959 File Transfer Protocol
+Net::SMTP RFC821 Simple Mail Transfer Protocol
+Net::Time RFC867 Daytime Protocol
+Net::Time RFC868 Time Protocol
+Net::NNTP RFC977 Network News Transfer Protocol
+Net::POP3 RFC1939 Post Office Protocol 3
+
+AVAILABILITY
+
+The latest version of libnet is available from the Comprehensive Perl
+Archive Network (CPAN). To find a CPAN site near you see:
+
+ http://search.cpan.org/~gbarr/libnet/
+
+The subversion source repository can be browsed at
+
+ http://svn.goingon.net/viewvc/libnet/
+
+If you have a subversion client, then you can checkout the latest code with
+
+ svn co http://svn.goingon.net/repos/libnet/trunk libnet
+
+INSTALLATION
+
+In order to use this package you will need Perl version 5.002 or
+better. You install libnet, as you would install any perl module
+library, by running these commands:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+If you want to install a private copy of libnet in your home
+directory, then you should try to produce the initial Makefile with
+something like this command:
+
+ perl Makefile.PL PREFIX=~/perl
+
+
+The Makefile.PL program will start out by checking your perl
+installation for a few packages that are recommended to be installed
+together with libnet. These packages should be available on CPAN
+(described above).
+
+CONFIGURE
+
+Normally when perl Makefile.PL is run it will run Configure which will
+ask some questions about your system. The results of these questions
+will be stored in a file called libnet.cfg which will be installed
+alongside the other perl modules in this distribution. The Makefile.PL
+will run Configure in an interactive mode unless these exists a file
+called libnet.cfg in the build directory.
+
+If you are on a system which cannot run this script you can create an
+empty file to make Makefile.PL skip running Configure. If you want to
+keep your existing settings and not run interactivly the simple run
+
+ Configure -d
+
+before running the Makefile.PL.
+
+DOCUMENTATION
+
+See ChangeLog for recent changes. POD style documentation is included
+in all modules and scripts. These are normally converted to manual
+pages and installed as part of the "make install" process. You should
+also be able to use the 'perldoc' utility to extract documentation from
+the module files directly.
+
+DEMOS
+
+The demos directory does contain a few demo scripts. These should be
+run from the top directory like
+
+ demos/smtp.self -user my-email-address -debug
+
+However I do not guarantee these scripts to work.
+
+SUPPORT
+
+Questions about how to use this library should be directed to the
+comp.lang.perl.modules USENET Newsgroup. Bug reports and suggestions
+for improvements can be sent to me at <gbarr at pobox.com>.
+
+Most of the modules in this library have an option to output a debug
+transcript to STDERR. When reporting bugs/problems please, if possible,
+include a transcript of a run.
+
+COPYRIGHT
+
+ (C) 1996-2007 Graham Barr. All rights reserved.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+Share and Enjoy!
Copied: trunk/contrib/perl/lib/Net/SMTP.pm (from rev 6437, vendor/perl/5.18.1/lib/Net/SMTP.pm)
===================================================================
--- trunk/contrib/perl/lib/Net/SMTP.pm (rev 0)
+++ trunk/contrib/perl/lib/Net/SMTP.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,867 @@
+# Net::SMTP.pm
+#
+# Copyright (c) 1995-2004 Graham Barr <gbarr at pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Net::SMTP;
+
+require 5.001;
+
+use strict;
+use vars qw($VERSION @ISA);
+use Socket 1.3;
+use Carp;
+use IO::Socket;
+use Net::Cmd;
+use Net::Config;
+
+$VERSION = "2.31";
+
+ at ISA = qw(Net::Cmd IO::Socket::INET);
+
+
+sub new {
+ my $self = shift;
+ my $type = ref($self) || $self;
+ my ($host, %arg);
+ if (@_ % 2) {
+ $host = shift;
+ %arg = @_;
+ }
+ else {
+ %arg = @_;
+ $host = delete $arg{Host};
+ }
+ my $hosts = defined $host ? $host : $NetConfig{smtp_hosts};
+ my $obj;
+
+ my $h;
+ foreach $h (@{ref($hosts) ? $hosts : [$hosts]}) {
+ $obj = $type->SUPER::new(
+ PeerAddr => ($host = $h),
+ PeerPort => $arg{Port} || 'smtp(25)',
+ LocalAddr => $arg{LocalAddr},
+ LocalPort => $arg{LocalPort},
+ Proto => 'tcp',
+ Timeout => defined $arg{Timeout}
+ ? $arg{Timeout}
+ : 120
+ )
+ and last;
+ }
+
+ return undef
+ unless defined $obj;
+
+ $obj->autoflush(1);
+
+ $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
+
+ unless ($obj->response() == CMD_OK) {
+ $obj->close();
+ return undef;
+ }
+
+ ${*$obj}{'net_smtp_exact_addr'} = $arg{ExactAddresses};
+ ${*$obj}{'net_smtp_host'} = $host;
+
+ (${*$obj}{'net_smtp_banner'}) = $obj->message;
+ (${*$obj}{'net_smtp_domain'}) = $obj->message =~ /\A\s*(\S+)/;
+
+ unless ($obj->hello($arg{Hello} || "")) {
+ $obj->close();
+ return undef;
+ }
+
+ $obj;
+}
+
+
+sub host {
+ my $me = shift;
+ ${*$me}{'net_smtp_host'};
+}
+
+##
+## User interface methods
+##
+
+
+sub banner {
+ my $me = shift;
+
+ return ${*$me}{'net_smtp_banner'} || undef;
+}
+
+
+sub domain {
+ my $me = shift;
+
+ return ${*$me}{'net_smtp_domain'} || undef;
+}
+
+
+sub etrn {
+ my $self = shift;
+ defined($self->supports('ETRN', 500, ["Command unknown: 'ETRN'"]))
+ && $self->_ETRN(@_);
+}
+
+
+sub auth {
+ my ($self, $username, $password) = @_;
+
+ eval {
+ require MIME::Base64;
+ require Authen::SASL;
+ } or $self->set_status(500, ["Need MIME::Base64 and Authen::SASL todo auth"]), return 0;
+
+ my $mechanisms = $self->supports('AUTH', 500, ["Command unknown: 'AUTH'"]);
+ return unless defined $mechanisms;
+
+ my $sasl;
+
+ if (ref($username) and UNIVERSAL::isa($username, 'Authen::SASL')) {
+ $sasl = $username;
+ $sasl->mechanism($mechanisms);
+ }
+ else {
+ die "auth(username, password)" if not length $username;
+ $sasl = Authen::SASL->new(
+ mechanism => $mechanisms,
+ callback => {
+ user => $username,
+ pass => $password,
+ authname => $username,
+ }
+ );
+ }
+
+ # We should probably allow the user to pass the host, but I don't
+ # currently know and SASL mechanisms that are used by smtp that need it
+ my $client = $sasl->client_new('smtp', ${*$self}{'net_smtp_host'}, 0);
+ my $str = $client->client_start;
+
+ # We dont support sasl mechanisms that encrypt the socket traffic.
+ # todo that we would really need to change the ISA hierarchy
+ # so we dont inherit from IO::Socket, but instead hold it in an attribute
+
+ my @cmd = ("AUTH", $client->mechanism);
+ my $code;
+
+ push @cmd, MIME::Base64::encode_base64($str, '')
+ if defined $str and length $str;
+
+ while (($code = $self->command(@cmd)->response()) == CMD_MORE) {
+ @cmd = (
+ MIME::Base64::encode_base64(
+ $client->client_step(MIME::Base64::decode_base64(($self->message)[0])), ''
+ )
+ );
+ }
+
+ $code == CMD_OK;
+}
+
+
+sub hello {
+ my $me = shift;
+ my $domain = shift || "localhost.localdomain";
+ my $ok = $me->_EHLO($domain);
+ my @msg = $me->message;
+
+ if ($ok) {
+ my $h = ${*$me}{'net_smtp_esmtp'} = {};
+ my $ln;
+ foreach $ln (@msg) {
+ $h->{uc $1} = $2
+ if $ln =~ /(\w+)\b[= \t]*([^\n]*)/;
+ }
+ }
+ elsif ($me->status == CMD_ERROR) {
+ @msg = $me->message
+ if $ok = $me->_HELO($domain);
+ }
+
+ return undef unless $ok;
+
+ $msg[0] =~ /\A\s*(\S+)/;
+ return ($1 || " ");
+}
+
+
+sub supports {
+ my $self = shift;
+ my $cmd = uc shift;
+ return ${*$self}{'net_smtp_esmtp'}->{$cmd}
+ if exists ${*$self}{'net_smtp_esmtp'}->{$cmd};
+ $self->set_status(@_)
+ if @_;
+ return;
+}
+
+
+sub _addr {
+ my $self = shift;
+ my $addr = shift;
+ $addr = "" unless defined $addr;
+
+ if (${*$self}{'net_smtp_exact_addr'}) {
+ return $1 if $addr =~ /^\s*(<.*>)\s*$/s;
+ }
+ else {
+ return $1 if $addr =~ /(<[^>]*>)/;
+ $addr =~ s/^\s+|\s+$//sg;
+ }
+
+ "<$addr>";
+}
+
+
+sub mail {
+ my $me = shift;
+ my $addr = _addr($me, shift);
+ my $opts = "";
+
+ if (@_) {
+ my %opt = @_;
+ my ($k, $v);
+
+ if (exists ${*$me}{'net_smtp_esmtp'}) {
+ my $esmtp = ${*$me}{'net_smtp_esmtp'};
+
+ if (defined($v = delete $opt{Size})) {
+ if (exists $esmtp->{SIZE}) {
+ $opts .= sprintf " SIZE=%d", $v + 0;
+ }
+ else {
+ carp 'Net::SMTP::mail: SIZE option not supported by host';
+ }
+ }
+
+ if (defined($v = delete $opt{Return})) {
+ if (exists $esmtp->{DSN}) {
+ $opts .= " RET=" . ((uc($v) eq "FULL") ? "FULL" : "HDRS");
+ }
+ else {
+ carp 'Net::SMTP::mail: DSN option not supported by host';
+ }
+ }
+
+ if (defined($v = delete $opt{Bits})) {
+ if ($v eq "8") {
+ if (exists $esmtp->{'8BITMIME'}) {
+ $opts .= " BODY=8BITMIME";
+ }
+ else {
+ carp 'Net::SMTP::mail: 8BITMIME option not supported by host';
+ }
+ }
+ elsif ($v eq "binary") {
+ if (exists $esmtp->{'BINARYMIME'} && exists $esmtp->{'CHUNKING'}) {
+ $opts .= " BODY=BINARYMIME";
+ ${*$me}{'net_smtp_chunking'} = 1;
+ }
+ else {
+ carp 'Net::SMTP::mail: BINARYMIME option not supported by host';
+ }
+ }
+ elsif (exists $esmtp->{'8BITMIME'} or exists $esmtp->{'BINARYMIME'}) {
+ $opts .= " BODY=7BIT";
+ }
+ else {
+ carp 'Net::SMTP::mail: 8BITMIME and BINARYMIME options not supported by host';
+ }
+ }
+
+ if (defined($v = delete $opt{Transaction})) {
+ if (exists $esmtp->{CHECKPOINT}) {
+ $opts .= " TRANSID=" . _addr($me, $v);
+ }
+ else {
+ carp 'Net::SMTP::mail: CHECKPOINT option not supported by host';
+ }
+ }
+
+ if (defined($v = delete $opt{Envelope})) {
+ if (exists $esmtp->{DSN}) {
+ $v =~ s/([^\041-\176]|=|\+)/sprintf "+%02x", ord($1)/sge;
+ $opts .= " ENVID=$v";
+ }
+ else {
+ carp 'Net::SMTP::mail: DSN option not supported by host';
+ }
+ }
+
+ if (defined($v = delete $opt{ENVID})) {
+
+ # expected to be in a format as required by RFC 3461, xtext-encoded
+ if (exists $esmtp->{DSN}) {
+ $opts .= " ENVID=$v";
+ }
+ else {
+ carp 'Net::SMTP::mail: DSN option not supported by host';
+ }
+ }
+
+ if (defined($v = delete $opt{AUTH})) {
+
+ # expected to be in a format as required by RFC 2554,
+ # rfc2821-quoted and xtext-encoded, or <>
+ if (exists $esmtp->{AUTH}) {
+ $v = '<>' if !defined($v) || $v eq '';
+ $opts .= " AUTH=$v";
+ }
+ else {
+ carp 'Net::SMTP::mail: AUTH option not supported by host';
+ }
+ }
+
+ if (defined($v = delete $opt{XVERP})) {
+ if (exists $esmtp->{'XVERP'}) {
+ $opts .= " XVERP";
+ }
+ else {
+ carp 'Net::SMTP::mail: XVERP option not supported by host';
+ }
+ }
+
+ carp 'Net::SMTP::recipient: unknown option(s) ' . join(" ", keys %opt) . ' - ignored'
+ if scalar keys %opt;
+ }
+ else {
+ carp 'Net::SMTP::mail: ESMTP not supported by host - options discarded :-(';
+ }
+ }
+
+ $me->_MAIL("FROM:" . $addr . $opts);
+}
+
+
+sub send { my $me = shift; $me->_SEND("FROM:" . _addr($me, $_[0])) }
+sub send_or_mail { my $me = shift; $me->_SOML("FROM:" . _addr($me, $_[0])) }
+sub send_and_mail { my $me = shift; $me->_SAML("FROM:" . _addr($me, $_[0])) }
+
+
+sub reset {
+ my $me = shift;
+
+ $me->dataend()
+ if (exists ${*$me}{'net_smtp_lastch'});
+
+ $me->_RSET();
+}
+
+
+sub recipient {
+ my $smtp = shift;
+ my $opts = "";
+ my $skip_bad = 0;
+
+ if (@_ && ref($_[-1])) {
+ my %opt = %{pop(@_)};
+ my $v;
+
+ $skip_bad = delete $opt{'SkipBad'};
+
+ if (exists ${*$smtp}{'net_smtp_esmtp'}) {
+ my $esmtp = ${*$smtp}{'net_smtp_esmtp'};
+
+ if (defined($v = delete $opt{Notify})) {
+ if (exists $esmtp->{DSN}) {
+ $opts .= " NOTIFY=" . join(",", map { uc $_ } @$v);
+ }
+ else {
+ carp 'Net::SMTP::recipient: DSN option not supported by host';
+ }
+ }
+
+ if (defined($v = delete $opt{ORcpt})) {
+ if (exists $esmtp->{DSN}) {
+ $opts .= " ORCPT=" . $v;
+ }
+ else {
+ carp 'Net::SMTP::recipient: DSN option not supported by host';
+ }
+ }
+
+ carp 'Net::SMTP::recipient: unknown option(s) ' . join(" ", keys %opt) . ' - ignored'
+ if scalar keys %opt;
+ }
+ elsif (%opt) {
+ carp 'Net::SMTP::recipient: ESMTP not supported by host - options discarded :-(';
+ }
+ }
+
+ my @ok;
+ my $addr;
+ foreach $addr (@_) {
+ if ($smtp->_RCPT("TO:" . _addr($smtp, $addr) . $opts)) {
+ push(@ok, $addr) if $skip_bad;
+ }
+ elsif (!$skip_bad) {
+ return 0;
+ }
+ }
+
+ return $skip_bad ? @ok : 1;
+}
+
+BEGIN {
+ *to = \&recipient;
+ *cc = \&recipient;
+ *bcc = \&recipient;
+}
+
+
+sub data {
+ my $me = shift;
+
+ if (exists ${*$me}{'net_smtp_chunking'}) {
+ carp 'Net::SMTP::data: CHUNKING extension in use, must call bdat instead';
+ }
+ else {
+ my $ok = $me->_DATA() && $me->datasend(@_);
+
+ $ok && @_
+ ? $me->dataend
+ : $ok;
+ }
+}
+
+
+sub bdat {
+ my $me = shift;
+
+ if (exists ${*$me}{'net_smtp_chunking'}) {
+ my $data = shift;
+
+ $me->_BDAT(length $data)
+ && $me->rawdatasend($data)
+ && $me->response() == CMD_OK;
+ }
+ else {
+ carp 'Net::SMTP::bdat: CHUNKING extension is not in use, call data instead';
+ }
+}
+
+
+sub bdatlast {
+ my $me = shift;
+
+ if (exists ${*$me}{'net_smtp_chunking'}) {
+ my $data = shift;
+
+ $me->_BDAT(length $data, "LAST")
+ && $me->rawdatasend($data)
+ && $me->response() == CMD_OK;
+ }
+ else {
+ carp 'Net::SMTP::bdat: CHUNKING extension is not in use, call data instead';
+ }
+}
+
+
+sub datafh {
+ my $me = shift;
+ return unless $me->_DATA();
+ return $me->tied_fh;
+}
+
+
+sub expand {
+ my $me = shift;
+
+ $me->_EXPN(@_)
+ ? ($me->message)
+ : ();
+}
+
+
+sub verify { shift->_VRFY(@_) }
+
+
+sub help {
+ my $me = shift;
+
+ $me->_HELP(@_)
+ ? scalar $me->message
+ : undef;
+}
+
+
+sub quit {
+ my $me = shift;
+
+ $me->_QUIT;
+ $me->close;
+}
+
+
+sub DESTROY {
+
+ # ignore
+}
+
+##
+## RFC821 commands
+##
+
+
+sub _EHLO { shift->command("EHLO", @_)->response() == CMD_OK }
+sub _HELO { shift->command("HELO", @_)->response() == CMD_OK }
+sub _MAIL { shift->command("MAIL", @_)->response() == CMD_OK }
+sub _RCPT { shift->command("RCPT", @_)->response() == CMD_OK }
+sub _SEND { shift->command("SEND", @_)->response() == CMD_OK }
+sub _SAML { shift->command("SAML", @_)->response() == CMD_OK }
+sub _SOML { shift->command("SOML", @_)->response() == CMD_OK }
+sub _VRFY { shift->command("VRFY", @_)->response() == CMD_OK }
+sub _EXPN { shift->command("EXPN", @_)->response() == CMD_OK }
+sub _HELP { shift->command("HELP", @_)->response() == CMD_OK }
+sub _RSET { shift->command("RSET")->response() == CMD_OK }
+sub _NOOP { shift->command("NOOP")->response() == CMD_OK }
+sub _QUIT { shift->command("QUIT")->response() == CMD_OK }
+sub _DATA { shift->command("DATA")->response() == CMD_MORE }
+sub _BDAT { shift->command("BDAT", @_) }
+sub _TURN { shift->unsupported(@_); }
+sub _ETRN { shift->command("ETRN", @_)->response() == CMD_OK }
+sub _AUTH { shift->command("AUTH", @_)->response() == CMD_OK }
+
+1;
+
+__END__
+
+=head1 NAME
+
+Net::SMTP - Simple Mail Transfer Protocol Client
+
+=head1 SYNOPSIS
+
+ use Net::SMTP;
+
+ # Constructors
+ $smtp = Net::SMTP->new('mailhost');
+ $smtp = Net::SMTP->new('mailhost', Timeout => 60);
+
+=head1 DESCRIPTION
+
+This module implements a client interface to the SMTP and ESMTP
+protocol, enabling a perl5 application to talk to SMTP servers. This
+documentation assumes that you are familiar with the concepts of the
+SMTP protocol described in RFC821.
+
+A new Net::SMTP object must be created with the I<new> method. Once
+this has been done, all SMTP commands are accessed through this object.
+
+The Net::SMTP class is a subclass of Net::Cmd and IO::Socket::INET.
+
+=head1 EXAMPLES
+
+This example prints the mail domain name of the SMTP server known as mailhost:
+
+ #!/usr/local/bin/perl -w
+
+ use Net::SMTP;
+
+ $smtp = Net::SMTP->new('mailhost');
+ print $smtp->domain,"\n";
+ $smtp->quit;
+
+This example sends a small message to the postmaster at the SMTP server
+known as mailhost:
+
+ #!/usr/local/bin/perl -w
+
+ use Net::SMTP;
+
+ $smtp = Net::SMTP->new('mailhost');
+
+ $smtp->mail($ENV{USER});
+ $smtp->to('postmaster');
+
+ $smtp->data();
+ $smtp->datasend("To: postmaster\n");
+ $smtp->datasend("\n");
+ $smtp->datasend("A simple test message\n");
+ $smtp->dataend();
+
+ $smtp->quit;
+
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item new ( [ HOST ] [, OPTIONS ] )
+
+This is the constructor for a new Net::SMTP object. C<HOST> is the
+name of the remote host to which an SMTP connection is required.
+
+C<HOST> is optional. If C<HOST> is not given then it may instead be
+passed as the C<Host> option described below. If neither is given then
+the C<SMTP_Hosts> specified in C<Net::Config> will be used.
+
+C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
+Possible options are:
+
+B<Hello> - SMTP requires that you identify yourself. This option
+specifies a string to pass as your mail domain. If not given localhost.localdomain
+will be used.
+
+B<Host> - SMTP host to connect to. It may be a single scalar, as defined for
+the C<PeerAddr> option in L<IO::Socket::INET>, or a reference to
+an array with hosts to try in turn. The L</host> method will return the value
+which was used to connect to the host.
+
+B<LocalAddr> and B<LocalPort> - These parameters are passed directly
+to IO::Socket to allow binding the socket to a local port.
+
+B<Timeout> - Maximum time, in seconds, to wait for a response from the
+SMTP server (default: 120)
+
+B<ExactAddresses> - If true the all ADDRESS arguments must be as
+defined by C<addr-spec> in RFC2822. If not given, or false, then
+Net::SMTP will attempt to extract the address from the value passed.
+
+B<Debug> - Enable debugging information
+
+
+Example:
+
+
+ $smtp = Net::SMTP->new('mailhost',
+ Hello => 'my.mail.domain',
+ Timeout => 30,
+ Debug => 1,
+ );
+
+ # the same
+ $smtp = Net::SMTP->new(
+ Host => 'mailhost',
+ Hello => 'my.mail.domain',
+ Timeout => 30,
+ Debug => 1,
+ );
+
+ # Connect to the default server from Net::config
+ $smtp = Net::SMTP->new(
+ Hello => 'my.mail.domain',
+ Timeout => 30,
+ );
+
+=back
+
+=head1 METHODS
+
+Unless otherwise stated all methods return either a I<true> or I<false>
+value, with I<true> meaning that the operation was a success. When a method
+states that it returns a value, failure will be returned as I<undef> or an
+empty list.
+
+=over 4
+
+=item banner ()
+
+Returns the banner message which the server replied with when the
+initial connection was made.
+
+=item domain ()
+
+Returns the domain that the remote SMTP server identified itself as during
+connection.
+
+=item hello ( DOMAIN )
+
+Tell the remote server the mail domain which you are in using the EHLO
+command (or HELO if EHLO fails). Since this method is invoked
+automatically when the Net::SMTP object is constructed the user should
+normally not have to call it manually.
+
+=item host ()
+
+Returns the value used by the constructor, and passed to IO::Socket::INET,
+to connect to the host.
+
+=item etrn ( DOMAIN )
+
+Request a queue run for the DOMAIN given.
+
+=item auth ( USERNAME, PASSWORD )
+
+Attempt SASL authentication.
+
+=item mail ( ADDRESS [, OPTIONS] )
+
+=item send ( ADDRESS )
+
+=item send_or_mail ( ADDRESS )
+
+=item send_and_mail ( ADDRESS )
+
+Send the appropriate command to the server MAIL, SEND, SOML or SAML. C<ADDRESS>
+is the address of the sender. This initiates the sending of a message. The
+method C<recipient> should be called for each address that the message is to
+be sent to.
+
+The C<mail> method can some additional ESMTP OPTIONS which is passed
+in hash like fashion, using key and value pairs. Possible options are:
+
+ Size => <bytes>
+ Return => "FULL" | "HDRS"
+ Bits => "7" | "8" | "binary"
+ Transaction => <ADDRESS>
+ Envelope => <ENVID> # xtext-encodes its argument
+ ENVID => <ENVID> # similar to Envelope, but expects argument encoded
+ XVERP => 1
+ AUTH => <submitter> # encoded address according to RFC 2554
+
+The C<Return> and C<Envelope> parameters are used for DSN (Delivery
+Status Notification).
+
+The submitter address in C<AUTH> option is expected to be in a format as
+required by RFC 2554, in an RFC2821-quoted form and xtext-encoded, or <> .
+
+=item reset ()
+
+Reset the status of the server. This may be called after a message has been
+initiated, but before any data has been sent, to cancel the sending of the
+message.
+
+=item recipient ( ADDRESS [, ADDRESS, [...]] [, OPTIONS ] )
+
+Notify the server that the current message should be sent to all of the
+addresses given. Each address is sent as a separate command to the server.
+Should the sending of any address result in a failure then the process is
+aborted and a I<false> value is returned. It is up to the user to call
+C<reset> if they so desire.
+
+The C<recipient> method can also pass additional case-sensitive OPTIONS as an
+anonymous hash using key and value pairs. Possible options are:
+
+ Notify => ['NEVER'] or ['SUCCESS','FAILURE','DELAY'] (see below)
+ ORcpt => <ORCPT>
+ SkipBad => 1 (to ignore bad addresses)
+
+If C<SkipBad> is true the C<recipient> will not return an error when a bad
+address is encountered and it will return an array of addresses that did
+succeed.
+
+ $smtp->recipient($recipient1,$recipient2); # Good
+ $smtp->recipient($recipient1,$recipient2, { SkipBad => 1 }); # Good
+ $smtp->recipient($recipient1,$recipient2, { Notify => ['FAILURE','DELAY'], SkipBad => 1 }); # Good
+ @goodrecips=$smtp->recipient(@recipients, { Notify => ['FAILURE'], SkipBad => 1 }); # Good
+ $smtp->recipient("$recipient,$recipient2"); # BAD
+
+Notify is used to request Delivery Status Notifications (DSNs), but your
+SMTP/ESMTP service may not respect this request depending upon its version and
+your site's SMTP configuration.
+
+Leaving out the Notify option usually defaults an SMTP service to its default
+behavior equivalent to ['FAILURE'] notifications only, but again this may be
+dependent upon your site's SMTP configuration.
+
+The NEVER keyword must appear by itself if used within the Notify option and "requests
+that a DSN not be returned to the sender under any conditions."
+
+ {Notify => ['NEVER']}
+
+ $smtp->recipient(@recipients, { Notify => ['NEVER'], SkipBad => 1 }); # Good
+
+You may use any combination of these three values 'SUCCESS','FAILURE','DELAY' in
+the anonymous array reference as defined by RFC3461 (see http://rfc.net/rfc3461.html
+for more information. Note: quotations in this topic from same.).
+
+A Notify parameter of 'SUCCESS' or 'FAILURE' "requests that a DSN be issued on
+successful delivery or delivery failure, respectively."
+
+A Notify parameter of 'DELAY' "indicates the sender's willingness to receive
+delayed DSNs. Delayed DSNs may be issued if delivery of a message has been
+delayed for an unusual amount of time (as determined by the Message Transfer
+Agent (MTA) at which the message is delayed), but the final delivery status
+(whether successful or failure) cannot be determined. The absence of the DELAY
+keyword in a NOTIFY parameter requests that a "delayed" DSN NOT be issued under
+any conditions."
+
+ {Notify => ['SUCCESS','FAILURE','DELAY']}
+
+ $smtp->recipient(@recipients, { Notify => ['FAILURE','DELAY'], SkipBad => 1 }); # Good
+
+ORcpt is also part of the SMTP DSN extension according to RFC3461.
+It is used to pass along the original recipient that the mail was first
+sent to. The machine that generates a DSN will use this address to inform
+the sender, because he can't know if recipients get rewritten by mail servers.
+It is expected to be in a format as required by RFC3461, xtext-encoded.
+
+=item to ( ADDRESS [, ADDRESS [...]] )
+
+=item cc ( ADDRESS [, ADDRESS [...]] )
+
+=item bcc ( ADDRESS [, ADDRESS [...]] )
+
+Synonyms for C<recipient>.
+
+=item data ( [ DATA ] )
+
+Initiate the sending of the data from the current message.
+
+C<DATA> may be a reference to a list or a list. If specified the contents
+of C<DATA> and a termination string C<".\r\n"> is sent to the server. And the
+result will be true if the data was accepted.
+
+If C<DATA> is not specified then the result will indicate that the server
+wishes the data to be sent. The data must then be sent using the C<datasend>
+and C<dataend> methods described in L<Net::Cmd>.
+
+=item expand ( ADDRESS )
+
+Request the server to expand the given address Returns an array
+which contains the text read from the server.
+
+=item verify ( ADDRESS )
+
+Verify that C<ADDRESS> is a legitimate mailing address.
+
+Most sites usually disable this feature in their SMTP service configuration.
+Use "Debug => 1" option under new() to see if disabled.
+
+=item help ( [ $subject ] )
+
+Request help text from the server. Returns the text or undef upon failure
+
+=item quit ()
+
+Send the QUIT command to the remote SMTP server and close the socket connection.
+
+=back
+
+=head1 ADDRESSES
+
+Net::SMTP attempts to DWIM with addresses that are passed. For
+example an application might extract The From: line from an email
+and pass that to mail(). While this may work, it is not recommended.
+The application should really use a module like L<Mail::Address>
+to extract the mail address and pass that.
+
+If C<ExactAddresses> is passed to the constructor, then addresses
+should be a valid rfc2821-quoted address, although Net::SMTP will
+accept accept the address surrounded by angle brackets.
+
+ funny user at domain WRONG
+ "funny user"@domain RIGHT, recommended
+ <"funny user"@domain> OK
+
+=head1 SEE ALSO
+
+L<Net::Cmd>
+
+=head1 AUTHOR
+
+Graham Barr <gbarr at pobox.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1995-2004 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.
+
+=cut
Copied: trunk/contrib/perl/lib/Net/Time.pm (from rev 6437, vendor/perl/5.18.1/lib/Net/Time.pm)
===================================================================
--- trunk/contrib/perl/lib/Net/Time.pm (rev 0)
+++ trunk/contrib/perl/lib/Net/Time.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,151 @@
+# Net::Time.pm
+#
+# Copyright (c) 1995-2004 Graham Barr <gbarr at pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Net::Time;
+
+use strict;
+use vars qw($VERSION @ISA @EXPORT_OK $TIMEOUT);
+use Carp;
+use IO::Socket;
+require Exporter;
+use Net::Config;
+use IO::Select;
+
+ at ISA = qw(Exporter);
+ at EXPORT_OK = qw(inet_time inet_daytime);
+
+$VERSION = "2.10";
+
+$TIMEOUT = 120;
+
+
+sub _socket {
+ my ($pname, $pnum, $host, $proto, $timeout) = @_;
+
+ $proto ||= 'udp';
+
+ my $port = (getservbyname($pname, $proto))[2] || $pnum;
+
+ my $hosts = defined $host ? [$host] : $NetConfig{$pname . '_hosts'};
+
+ my $me;
+
+ foreach $host (@$hosts) {
+ $me = IO::Socket::INET->new(
+ PeerAddr => $host,
+ PeerPort => $port,
+ Proto => $proto
+ )
+ and last;
+ }
+
+ return unless $me;
+
+ $me->send("\n")
+ if $proto eq 'udp';
+
+ $timeout = $TIMEOUT
+ unless defined $timeout;
+
+ IO::Select->new($me)->can_read($timeout)
+ ? $me
+ : undef;
+}
+
+
+sub inet_time {
+ my $s = _socket('time', 37, @_) || return undef;
+ my $buf = '';
+ my $offset = 0 | 0;
+
+ return undef
+ unless defined $s->recv($buf, length(pack("N", 0)));
+
+ # unpack, we | 0 to ensure we have an unsigned
+ my $time = (unpack("N", $buf))[0] | 0;
+
+ # the time protocol return time in seconds since 1900, convert
+ # it to a the required format
+
+ if ($^O eq "MacOS") {
+
+ # MacOS return seconds since 1904, 1900 was not a leap year.
+ $offset = (4 * 31536000) | 0;
+ }
+ else {
+
+ # otherwise return seconds since 1972, there were 17 leap years between
+ # 1900 and 1972
+ $offset = (70 * 31536000 + 17 * 86400) | 0;
+ }
+
+ $time - $offset;
+}
+
+
+sub inet_daytime {
+ my $s = _socket('daytime', 13, @_) || return undef;
+ my $buf = '';
+
+ defined($s->recv($buf, 1024))
+ ? $buf
+ : undef;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Net::Time - time and daytime network client interface
+
+=head1 SYNOPSIS
+
+ use Net::Time qw(inet_time inet_daytime);
+
+ print inet_time(); # use default host from Net::Config
+ print inet_time('localhost');
+ print inet_time('localhost', 'tcp');
+
+ print inet_daytime(); # use default host from Net::Config
+ print inet_daytime('localhost');
+ print inet_daytime('localhost', 'tcp');
+
+=head1 DESCRIPTION
+
+C<Net::Time> provides subroutines that obtain the time on a remote machine.
+
+=over 4
+
+=item inet_time ( [HOST [, PROTOCOL [, TIMEOUT]]])
+
+Obtain the time on C<HOST>, or some default host if C<HOST> is not given
+or not defined, using the protocol as defined in RFC868. The optional
+argument C<PROTOCOL> should define the protocol to use, either C<tcp> or
+C<udp>. The result will be a time value in the same units as returned
+by time() or I<undef> upon failure.
+
+=item inet_daytime ( [HOST [, PROTOCOL [, TIMEOUT]]])
+
+Obtain the time on C<HOST>, or some default host if C<HOST> is not given
+or not defined, using the protocol as defined in RFC867. The optional
+argument C<PROTOCOL> should define the protocol to use, either C<tcp> or
+C<udp>. The result will be an ASCII string or I<undef> upon failure.
+
+=back
+
+=head1 AUTHOR
+
+Graham Barr <gbarr at pobox.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1995-2004 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.
+
+=cut
Index: trunk/contrib/perl/lib/Net/hostent.pm
===================================================================
--- trunk/contrib/perl/lib/Net/hostent.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Net/hostent.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Net/hostent.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/Net/hostent.t
===================================================================
--- trunk/contrib/perl/lib/Net/hostent.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Net/hostent.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Net/hostent.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Copied: trunk/contrib/perl/lib/Net/libnetFAQ.pod (from rev 6437, vendor/perl/5.18.1/lib/Net/libnetFAQ.pod)
===================================================================
--- trunk/contrib/perl/lib/Net/libnetFAQ.pod (rev 0)
+++ trunk/contrib/perl/lib/Net/libnetFAQ.pod 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,303 @@
+=head1 NAME
+
+libnetFAQ - libnet Frequently Asked Questions
+
+=head1 DESCRIPTION
+
+=head2 Where to get this document
+
+This document is distributed with the libnet distribution, and is also
+available on the libnet web page at
+
+ http://search.cpan.org/~gbarr/libnet/
+
+=head2 How to contribute to this document
+
+You may mail corrections, additions, and suggestions to me
+gbarr at pobox.com.
+
+=head1 Author and Copyright Information
+
+Copyright (c) 1997-1998 Graham Barr. All rights reserved.
+This document is free; you can redistribute it and/or modify it
+under the terms of the Artistic License.
+
+=head2 Disclaimer
+
+This information is offered in good faith and in the hope that it may
+be of use, but is not guaranteed to be correct, up to date, or suitable
+for any particular purpose whatsoever. The authors accept no liability
+in respect of this information or its use.
+
+
+=head1 Obtaining and installing libnet
+
+=head2 What is libnet ?
+
+libnet is a collection of perl5 modules which all related to network
+programming. The majority of the modules available provided the
+client side of popular server-client protocols that are used in
+the internet community.
+
+=head2 Which version of perl do I need ?
+
+libnet has been know to work with versions of perl from 5.002 onwards. However
+if your release of perl is prior to perl5.004 then you will need to
+obtain and install the IO distribution from CPAN. If you have perl5.004
+or later then you will have the IO modules in your installation already,
+but CPAN may contain updates.
+
+=head2 What other modules do I need ?
+
+The only modules you will need installed are the modules from the IO
+distribution. If you have perl5.004 or later you will already have
+these modules.
+
+=head2 What machines support libnet ?
+
+libnet itself is an entirely perl-code distribution so it should work
+on any machine that perl runs on. However IO may not work
+with some machines and earlier releases of perl. But this
+should not be the case with perl version 5.004 or later.
+
+=head2 Where can I get the latest libnet release
+
+The latest libnet release is always on CPAN, you will find it
+in
+
+ http://www.cpan.org/modules/by-module/Net/
+
+The latest release and information is also available on the libnet web page
+at
+
+ http://search.cpan.org/~gbarr/libnet/
+
+=head1 Using Net::FTP
+
+=head2 How do I download files from an FTP server ?
+
+An example taken from an article posted to comp.lang.perl.misc
+
+ #!/your/path/to/perl
+
+ # a module making life easier
+
+ use Net::FTP;
+
+ # for debugging: $ftp = Net::FTP->new('site','Debug',10);
+ # open a connection and log in!
+
+ $ftp = Net::FTP->new('target_site.somewhere.xxx');
+ $ftp->login('username','password');
+
+ # set transfer mode to binary
+
+ $ftp->binary();
+
+ # change the directory on the ftp site
+
+ $ftp->cwd('/some/path/to/somewhere/');
+
+ foreach $name ('file1', 'file2', 'file3') {
+
+ # get's arguments are in the following order:
+ # ftp server's filename
+ # filename to save the transfer to on the local machine
+ # can be simply used as get($name) if you want the same name
+
+ $ftp->get($name,$name);
+ }
+
+ # ftp done!
+
+ $ftp->quit;
+
+=head2 How do I transfer files in binary mode ?
+
+To transfer files without <LF><CR> translation Net::FTP provides
+the C<binary> method
+
+ $ftp->binary;
+
+=head2 How can I get the size of a file on a remote FTP server ?
+
+=head2 How can I get the modification time of a file on a remote FTP server ?
+
+=head2 How can I change the permissions of a file on a remote server ?
+
+The FTP protocol does not have a command for changing the permissions
+of a file on the remote server. But some ftp servers may allow a chmod
+command to be issued via a SITE command, eg
+
+ $ftp->quot('site chmod 0777',$filename);
+
+But this is not guaranteed to work.
+
+=head2 Can I do a reget operation like the ftp command ?
+
+=head2 How do I get a directory listing from an FTP server ?
+
+=head2 Changing directory to "" does not fail ?
+
+Passing an argument of "" to ->cwd() has the same affect of calling ->cwd()
+without any arguments. Turn on Debug (I<See below>) and you will see what is
+happening
+
+ $ftp = Net::FTP->new($host, Debug => 1);
+ $ftp->login;
+ $ftp->cwd("");
+
+gives
+
+ Net::FTP=GLOB(0x82196d8)>>> CWD /
+ Net::FTP=GLOB(0x82196d8)<<< 250 CWD command successful.
+
+=head2 I am behind a SOCKS firewall, but the Firewall option does not work ?
+
+The Firewall option is only for support of one type of firewall. The type
+supported is an ftp proxy.
+
+To use Net::FTP, or any other module in the libnet distribution,
+through a SOCKS firewall you must create a socks-ified perl executable
+by compiling perl with the socks library.
+
+=head2 I am behind an FTP proxy firewall, but cannot access machines outside ?
+
+Net::FTP implements the most popular ftp proxy firewall approach. The scheme
+implemented is that where you log in to the firewall with C<user at hostname>
+
+I have heard of one other type of firewall which requires a login to the
+firewall with an account, then a second login with C<user at hostname>. You can
+still use Net::FTP to traverse these firewalls, but a more manual approach
+must be taken, eg
+
+ $ftp = Net::FTP->new($firewall) or die $@;
+ $ftp->login($firewall_user, $firewall_passwd) or die $ftp->message;
+ $ftp->login($ext_user . '@' . $ext_host, $ext_passwd) or die $ftp->message.
+
+=head2 My ftp proxy firewall does not listen on port 21
+
+FTP servers usually listen on the same port number, port 21, as any other
+FTP server. But there is no reason why this has to be the case.
+
+If you pass a port number to Net::FTP then it assumes this is the port
+number of the final destination. By default Net::FTP will always try
+to connect to the firewall on port 21.
+
+Net::FTP uses IO::Socket to open the connection and IO::Socket allows
+the port number to be specified as part of the hostname. So this problem
+can be resolved by either passing a Firewall option like C<"hostname:1234">
+or by setting the C<ftp_firewall> option in Net::Config to be a string
+in in the same form.
+
+=head2 Is it possible to change the file permissions of a file on an FTP server ?
+
+The answer to this is "maybe". The FTP protocol does not specify a command to change
+file permissions on a remote host. However many servers do allow you to run the
+chmod command via the C<SITE> command. This can be done with
+
+ $ftp->site('chmod','0775',$file);
+
+=head2 I have seen scripts call a method message, but cannot find it documented ?
+
+Net::FTP, like several other packages in libnet, inherits from Net::Cmd, so
+all the methods described in Net::Cmd are also available on Net::FTP
+objects.
+
+=head2 Why does Net::FTP not implement mput and mget methods
+
+The quick answer is because they are easy to implement yourself. The long
+answer is that to write these in such a way that multiple platforms are
+supported correctly would just require too much code. Below are
+some examples how you can implement these yourself.
+
+sub mput {
+ my($ftp,$pattern) = @_;
+ foreach my $file (glob($pattern)) {
+ $ftp->put($file) or warn $ftp->message;
+ }
+}
+
+sub mget {
+ my($ftp,$pattern) = @_;
+ foreach my $file ($ftp->ls($pattern)) {
+ $ftp->get($file) or warn $ftp->message;
+ }
+}
+
+
+=head1 Using Net::SMTP
+
+=head2 Why can't the part of an Email address after the @ be used as the hostname ?
+
+The part of an Email address which follows the @ is not necessarily a hostname,
+it is a mail domain. To find the name of a host to connect for a mail domain
+you need to do a DNS MX lookup
+
+=head2 Why does Net::SMTP not do DNS MX lookups ?
+
+Net::SMTP implements the SMTP protocol. The DNS MX lookup is not part
+of this protocol.
+
+=head2 The verify method always returns true ?
+
+Well it may seem that way, but it does not. The verify method returns true
+if the command succeeded. If you pass verify an address which the
+server would normally have to forward to another machine, the command
+will succeed with something like
+
+ 252 Couldn't verify <someone at there> but will attempt delivery anyway
+
+This command will fail only if you pass it an address in a domain
+the server directly delivers for, and that address does not exist.
+
+=head1 Debugging scripts
+
+=head2 How can I debug my scripts that use Net::* modules ?
+
+Most of the libnet client classes allow options to be passed to the
+constructor, in most cases one option is called C<Debug>. Passing
+this option with a non-zero value will turn on a protocol trace, which
+will be sent to STDERR. This trace can be useful to see what commands
+are being sent to the remote server and what responses are being
+received back.
+
+ #!/your/path/to/perl
+
+ use Net::FTP;
+
+ my $ftp = new Net::FTP($host, Debug => 1);
+ $ftp->login('gbarr','password');
+ $ftp->quit;
+
+this script would output something like
+
+ Net::FTP: Net::FTP(2.22)
+ Net::FTP: Exporter
+ Net::FTP: Net::Cmd(2.0801)
+ Net::FTP: IO::Socket::INET
+ Net::FTP: IO::Socket(1.1603)
+ Net::FTP: IO::Handle(1.1504)
+
+ Net::FTP=GLOB(0x8152974)<<< 220 imagine FTP server (Version wu-2.4(5) Tue Jul 29 11:17:18 CDT 1997) ready.
+ Net::FTP=GLOB(0x8152974)>>> user gbarr
+ Net::FTP=GLOB(0x8152974)<<< 331 Password required for gbarr.
+ Net::FTP=GLOB(0x8152974)>>> PASS ....
+ Net::FTP=GLOB(0x8152974)<<< 230 User gbarr logged in. Access restrictions apply.
+ Net::FTP=GLOB(0x8152974)>>> QUIT
+ Net::FTP=GLOB(0x8152974)<<< 221 Goodbye.
+
+The first few lines tell you the modules that Net::FTP uses and their versions,
+this is useful data to me when a user reports a bug. The last seven lines
+show the communication with the server. Each line has three parts. The first
+part is the object itself, this is useful for separating the output
+if you are using multiple objects. The second part is either C<<<<<> to
+show data coming from the server or C<>>>>> to show data
+going to the server. The remainder of the line is the command
+being sent or response being received.
+
+=head1 AUTHOR AND COPYRIGHT
+
+Copyright (c) 1997 Graham Barr.
+All rights reserved.
+
Index: trunk/contrib/perl/lib/Net/netent.pm
===================================================================
--- trunk/contrib/perl/lib/Net/netent.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Net/netent.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Net/netent.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/Net/netent.t
===================================================================
--- trunk/contrib/perl/lib/Net/netent.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Net/netent.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Net/netent.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/Net/protoent.pm
===================================================================
--- trunk/contrib/perl/lib/Net/protoent.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Net/protoent.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Net/protoent.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/Net/protoent.t
===================================================================
--- trunk/contrib/perl/lib/Net/protoent.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Net/protoent.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Net/protoent.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/Net/servent.pm
===================================================================
--- trunk/contrib/perl/lib/Net/servent.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Net/servent.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Net/servent.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/Net/servent.t
===================================================================
--- trunk/contrib/perl/lib/Net/servent.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Net/servent.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Net/servent.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/lib/PerlIO.pm
===================================================================
--- trunk/contrib/perl/lib/PerlIO.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/PerlIO.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -93,20 +93,6 @@
Based on the C<:perlio> layer.
-=item :mmap
-
-A layer which implements "reading" of files by using C<mmap()> to
-make a (whole) file appear in the process's address space, and then
-using that as PerlIO's "buffer". This I<may> be faster in certain
-circumstances for large files, and may result in less physical memory
-use when multiple processes are reading the same file.
-
-Files which are not C<mmap()>-able revert to behaving like the C<:perlio>
-layer. Writes also behave like the C<:perlio> layer, as C<mmap()> for write
-needs extra house-keeping (to extend the file) which negates any advantage.
-
-The C<:mmap> layer will not exist if the platform does not support C<mmap()>.
-
=item :utf8
Declares that the stream accepts perl's I<internal> encoding of
@@ -208,6 +194,20 @@
an C<:encoding> also enables C<:utf8>. See L<PerlIO::encoding>
for more information.
+=item :mmap
+
+A layer which implements "reading" of files by using C<mmap()> to
+make a (whole) file appear in the process's address space, and then
+using that as PerlIO's "buffer". This I<may> be faster in certain
+circumstances for large files, and may result in less physical memory
+use when multiple processes are reading the same file.
+
+Files which are not C<mmap()>-able revert to behaving like the C<:perlio>
+layer. Writes also behave like the C<:perlio> layer, as C<mmap()> for write
+needs extra house-keeping (to extend the file) which negates any advantage.
+
+The C<:mmap> layer will not exist if the platform does not support C<mmap()>.
+
=item :via
Use C<:via(MODULE)> either in open() or binmode() to install a layer
@@ -284,7 +284,6 @@
unset / "" unix perlio / stdio [1] unix crlf
stdio unix perlio / stdio [1] stdio
perlio unix perlio unix perlio
- mmap unix mmap unix mmap
# [1] "stdio" if Configure found out how to do "fast stdio" (depends
# on the stdio implementation) and in Perl 5.8, otherwise "unix perlio"
Property changes on: trunk/contrib/perl/lib/PerlIO.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Copied: trunk/contrib/perl/lib/Pod/Checker.pm (from rev 6437, vendor/perl/5.18.1/lib/Pod/Checker.pm)
===================================================================
--- trunk/contrib/perl/lib/Pod/Checker.pm (rev 0)
+++ trunk/contrib/perl/lib/Pod/Checker.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,1268 @@
+#############################################################################
+# Pod/Checker.pm -- check pod documents for syntax errors
+#
+# Copyright (C) 1994-2000 by Bradford Appleton. All rights reserved.
+# This file is part of "PodParser". PodParser is free software;
+# you can redistribute it and/or modify it under the same terms
+# as Perl itself.
+#############################################################################
+
+package Pod::Checker;
+use strict;
+
+use vars qw($VERSION @ISA @EXPORT %VALID_COMMANDS %VALID_SEQUENCES);
+$VERSION = '1.45'; ## Current version of this package
+require 5.005; ## requires this Perl version or later
+
+use Pod::ParseUtils; ## for hyperlinks and lists
+
+=head1 NAME
+
+Pod::Checker, podchecker() - check pod documents for syntax errors
+
+=head1 SYNOPSIS
+
+ use Pod::Checker;
+
+ $syntax_okay = podchecker($filepath, $outputpath, %options);
+
+ my $checker = new Pod::Checker %options;
+ $checker->parse_from_file($filepath, \*STDERR);
+
+=head1 OPTIONS/ARGUMENTS
+
+C<$filepath> is the input POD to read and C<$outputpath> is
+where to write POD syntax error messages. Either argument may be a scalar
+indicating a file-path, or else a reference to an open filehandle.
+If unspecified, the input-file it defaults to C<\*STDIN>, and
+the output-file defaults to C<\*STDERR>.
+
+=head2 podchecker()
+
+This function can take a hash of options:
+
+=over 4
+
+=item B<-warnings> =E<gt> I<val>
+
+Turn warnings on/off. I<val> is usually 1 for on, but higher values
+trigger additional warnings. See L<"Warnings">.
+
+=back
+
+=head1 DESCRIPTION
+
+B<podchecker> will perform syntax checking of Perl5 POD format documentation.
+
+Curious/ambitious users are welcome to propose additional features they wish
+to see in B<Pod::Checker> and B<podchecker> and verify that the checks are
+consistent with L<perlpod>.
+
+The following checks are currently performed:
+
+=over 4
+
+=item *
+
+Unknown '=xxxx' commands, unknown 'XE<lt>...E<gt>' interior-sequences,
+and unterminated interior sequences.
+
+=item *
+
+Check for proper balancing of C<=begin> and C<=end>. The contents of such
+a block are generally ignored, i.e. no syntax checks are performed.
+
+=item *
+
+Check for proper nesting and balancing of C<=over>, C<=item> and C<=back>.
+
+=item *
+
+Check for same nested interior-sequences (e.g.
+C<LE<lt>...LE<lt>...E<gt>...E<gt>>).
+
+=item *
+
+Check for malformed or non-existing entities C<EE<lt>...E<gt>>.
+
+=item *
+
+Check for correct syntax of hyperlinks C<LE<lt>...E<gt>>. See L<perlpod>
+for details.
+
+=item *
+
+Check for unresolved document-internal links. This check may also reveal
+misspelled links that seem to be internal links but should be links
+to something else.
+
+=back
+
+=head1 DIAGNOSTICS
+
+=head2 Errors
+
+=over 4
+
+=item * empty =headn
+
+A heading (C<=head1> or C<=head2>) without any text? That ain't no
+heading!
+
+=item * =over on line I<N> without closing =back
+
+The C<=over> command does not have a corresponding C<=back> before the
+next heading (C<=head1> or C<=head2>) or the end of the file.
+
+=item * =item without previous =over
+
+=item * =back without previous =over
+
+An C<=item> or C<=back> command has been found outside a
+C<=over>/C<=back> block.
+
+=item * No argument for =begin
+
+A C<=begin> command was found that is not followed by the formatter
+specification.
+
+=item * =end without =begin
+
+A standalone C<=end> command was found.
+
+=item * Nested =begin's
+
+There were at least two consecutive C<=begin> commands without
+the corresponding C<=end>. Only one C<=begin> may be active at
+a time.
+
+=item * =for without formatter specification
+
+There is no specification of the formatter after the C<=for> command.
+
+=item * unresolved internal link I<NAME>
+
+The given link to I<NAME> does not have a matching node in the current
+POD. This also happened when a single word node name is not enclosed in
+C<"">.
+
+=item * Unknown command "I<CMD>"
+
+An invalid POD command has been found. Valid are C<=head1>, C<=head2>,
+C<=head3>, C<=head4>, C<=over>, C<=item>, C<=back>, C<=begin>, C<=end>,
+C<=for>, C<=pod>, C<=cut>
+
+=item * Unknown interior-sequence "I<SEQ>"
+
+An invalid markup command has been encountered. Valid are:
+C<BE<lt>E<gt>>, C<CE<lt>E<gt>>, C<EE<lt>E<gt>>, C<FE<lt>E<gt>>,
+C<IE<lt>E<gt>>, C<LE<lt>E<gt>>, C<SE<lt>E<gt>>, C<XE<lt>E<gt>>,
+C<ZE<lt>E<gt>>
+
+=item * nested commands I<CMD>E<lt>...I<CMD>E<lt>...E<gt>...E<gt>
+
+Two nested identical markup commands have been found. Generally this
+does not make sense.
+
+=item * garbled entity I<STRING>
+
+The I<STRING> found cannot be interpreted as a character entity.
+
+=item * Entity number out of range
+
+An entity specified by number (dec, hex, oct) is out of range (1-255).
+
+=item * malformed link LE<lt>E<gt>
+
+The link found cannot be parsed because it does not conform to the
+syntax described in L<perlpod>.
+
+=item * nonempty ZE<lt>E<gt>
+
+The C<ZE<lt>E<gt>> sequence is supposed to be empty.
+
+=item * empty XE<lt>E<gt>
+
+The index entry specified contains nothing but whitespace.
+
+=item * Spurious text after =pod / =cut
+
+The commands C<=pod> and C<=cut> do not take any arguments.
+
+=item * Spurious character(s) after =back
+
+The C<=back> command does not take any arguments.
+
+=back
+
+=head2 Warnings
+
+These may not necessarily cause trouble, but indicate mediocre style.
+
+=over 4
+
+=item * multiple occurrence of link target I<name>
+
+The POD file has some C<=item> and/or C<=head> commands that have
+the same text. Potential hyperlinks to such a text cannot be unique then.
+This warning is printed only with warning level greater than one.
+
+=item * line containing nothing but whitespace in paragraph
+
+There is some whitespace on a seemingly empty line. POD is very sensitive
+to such things, so this is flagged. B<vi> users switch on the B<list>
+option to avoid this problem.
+
+=begin _disabled_
+
+=item * file does not start with =head
+
+The file starts with a different POD directive than head.
+This is most probably something you do not want.
+
+=end _disabled_
+
+=item * previous =item has no contents
+
+There is a list C<=item> right above the flagged line that has no
+text contents. You probably want to delete empty items.
+
+=item * preceding non-item paragraph(s)
+
+A list introduced by C<=over> starts with a text or verbatim paragraph,
+but continues with C<=item>s. Move the non-item paragraph out of the
+C<=over>/C<=back> block.
+
+=item * =item type mismatch (I<one> vs. I<two>)
+
+A list started with e.g. a bullet-like C<=item> and continued with a
+numbered one. This is obviously inconsistent. For most translators the
+type of the I<first> C<=item> determines the type of the list.
+
+=item * I<N> unescaped C<E<lt>E<gt>> in paragraph
+
+Angle brackets not written as C<E<lt>ltE<gt>> and C<E<lt>gtE<gt>>
+can potentially cause errors as they could be misinterpreted as
+markup commands. This is only printed when the -warnings level is
+greater than 1.
+
+=item * Unknown entity
+
+A character entity was found that does not belong to the standard
+ISO set or the POD specials C<verbar> and C<sol>.
+
+=item * No items in =over
+
+The list opened with C<=over> does not contain any items.
+
+=item * No argument for =item
+
+C<=item> without any parameters is deprecated. It should either be followed
+by C<*> to indicate an unordered list, by a number (optionally followed
+by a dot) to indicate an ordered (numbered) list or simple text for a
+definition list.
+
+=item * empty section in previous paragraph
+
+The previous section (introduced by a C<=head> command) does not contain
+any text. This usually indicates that something is missing. Note: A
+C<=head1> followed immediately by C<=head2> does not trigger this warning.
+
+=item * Verbatim paragraph in NAME section
+
+The NAME section (C<=head1 NAME>) should consist of a single paragraph
+with the script/module name, followed by a dash `-' and a very short
+description of what the thing is good for.
+
+=item * =headI<n> without preceding higher level
+
+For example if there is a C<=head2> in the POD file prior to a
+C<=head1>.
+
+=back
+
+=head2 Hyperlinks
+
+There are some warnings with respect to malformed hyperlinks:
+
+=over 4
+
+=item * ignoring leading/trailing whitespace in link
+
+There is whitespace at the beginning or the end of the contents of
+LE<lt>...E<gt>.
+
+=item * (section) in '$page' deprecated
+
+There is a section detected in the page name of LE<lt>...E<gt>, e.g.
+C<LE<lt>passwd(2)E<gt>>. POD hyperlinks may point to POD documents only.
+Please write C<CE<lt>passwd(2)E<gt>> instead. Some formatters are able
+to expand this to appropriate code. For links to (builtin) functions,
+please say C<LE<lt>perlfunc/mkdirE<gt>>, without ().
+
+=item * alternative text/node '%s' contains non-escaped | or /
+
+The characters C<|> and C</> are special in the LE<lt>...E<gt> context.
+Although the hyperlink parser does its best to determine which "/" is
+text and which is a delimiter in case of doubt, one ought to escape
+these literal characters like this:
+
+ / E<sol>
+ | E<verbar>
+
+=back
+
+=head1 RETURN VALUE
+
+B<podchecker> returns the number of POD syntax errors found or -1 if
+there were no POD commands at all found in the file.
+
+=head1 EXAMPLES
+
+See L</SYNOPSIS>
+
+=head1 INTERFACE
+
+While checking, this module collects document properties, e.g. the nodes
+for hyperlinks (C<=headX>, C<=item>) and index entries (C<XE<lt>E<gt>>).
+POD translators can use this feature to syntax-check and get the nodes in
+a first pass before actually starting to convert. This is expensive in terms
+of execution time, but allows for very robust conversions.
+
+Since PodParser-1.24 the B<Pod::Checker> module uses only the B<poderror>
+method to print errors and warnings. The summary output (e.g.
+"Pod syntax OK") has been dropped from the module and has been included in
+B<podchecker> (the script). This allows users of B<Pod::Checker> to
+control completely the output behavior. Users of B<podchecker> (the script)
+get the well-known behavior.
+
+=cut
+
+#############################################################################
+
+#use diagnostics;
+use Carp qw(croak);
+use Exporter;
+use Pod::Parser;
+
+ at ISA = qw(Pod::Parser);
+ at EXPORT = qw(&podchecker);
+
+my %VALID_COMMANDS = (
+ 'pod' => 1,
+ 'cut' => 1,
+ 'head1' => 1,
+ 'head2' => 1,
+ 'head3' => 1,
+ 'head4' => 1,
+ 'over' => 1,
+ 'back' => 1,
+ 'item' => 1,
+ 'for' => 1,
+ 'begin' => 1,
+ 'end' => 1,
+ 'encoding' => 1,
+);
+
+my %VALID_SEQUENCES = (
+ 'I' => 1,
+ 'B' => 1,
+ 'S' => 1,
+ 'C' => 1,
+ 'L' => 1,
+ 'F' => 1,
+ 'X' => 1,
+ 'Z' => 1,
+ 'E' => 1,
+);
+
+# stolen from HTML::Entities
+my %ENTITIES = (
+ # Some normal chars that have special meaning in SGML context
+ amp => '&', # ampersand
+'gt' => '>', # greater than
+'lt' => '<', # less than
+ quot => '"', # double quote
+
+ # PUBLIC ISO 8879-1986//ENTITIES Added Latin 1//EN//HTML
+ AElig => '\xC6', # capital AE diphthong (ligature)
+ Aacute => '\xC1', # capital A, acute accent
+ Acirc => '\xC2', # capital A, circumflex accent
+ Agrave => '\xC0', # capital A, grave accent
+ Aring => '\xC5', # capital A, ring
+ Atilde => '\xC3', # capital A, tilde
+ Auml => '\xC4', # capital A, dieresis or umlaut mark
+ Ccedil => '\xC7', # capital C, cedilla
+ ETH => '\xD0', # capital Eth, Icelandic
+ Eacute => '\xC9', # capital E, acute accent
+ Ecirc => '\xCA', # capital E, circumflex accent
+ Egrave => '\xC8', # capital E, grave accent
+ Euml => '\xCB', # capital E, dieresis or umlaut mark
+ Iacute => '\xCD', # capital I, acute accent
+ Icirc => '\xCE', # capital I, circumflex accent
+ Igrave => '\xCC', # capital I, grave accent
+ Iuml => '\xCF', # capital I, dieresis or umlaut mark
+ Ntilde => '\xD1', # capital N, tilde
+ Oacute => '\xD3', # capital O, acute accent
+ Ocirc => '\xD4', # capital O, circumflex accent
+ Ograve => '\xD2', # capital O, grave accent
+ Oslash => '\xD8', # capital O, slash
+ Otilde => '\xD5', # capital O, tilde
+ Ouml => '\xD6', # capital O, dieresis or umlaut mark
+ THORN => '\xDE', # capital THORN, Icelandic
+ Uacute => '\xDA', # capital U, acute accent
+ Ucirc => '\xDB', # capital U, circumflex accent
+ Ugrave => '\xD9', # capital U, grave accent
+ Uuml => '\xDC', # capital U, dieresis or umlaut mark
+ Yacute => '\xDD', # capital Y, acute accent
+ aacute => '\xE1', # small a, acute accent
+ acirc => '\xE2', # small a, circumflex accent
+ aelig => '\xE6', # small ae diphthong (ligature)
+ agrave => '\xE0', # small a, grave accent
+ aring => '\xE5', # small a, ring
+ atilde => '\xE3', # small a, tilde
+ auml => '\xE4', # small a, dieresis or umlaut mark
+ ccedil => '\xE7', # small c, cedilla
+ eacute => '\xE9', # small e, acute accent
+ ecirc => '\xEA', # small e, circumflex accent
+ egrave => '\xE8', # small e, grave accent
+ eth => '\xF0', # small eth, Icelandic
+ euml => '\xEB', # small e, dieresis or umlaut mark
+ iacute => '\xED', # small i, acute accent
+ icirc => '\xEE', # small i, circumflex accent
+ igrave => '\xEC', # small i, grave accent
+ iuml => '\xEF', # small i, dieresis or umlaut mark
+ ntilde => '\xF1', # small n, tilde
+ oacute => '\xF3', # small o, acute accent
+ ocirc => '\xF4', # small o, circumflex accent
+ ograve => '\xF2', # small o, grave accent
+ oslash => '\xF8', # small o, slash
+ otilde => '\xF5', # small o, tilde
+ ouml => '\xF6', # small o, dieresis or umlaut mark
+ szlig => '\xDF', # small sharp s, German (sz ligature)
+ thorn => '\xFE', # small thorn, Icelandic
+ uacute => '\xFA', # small u, acute accent
+ ucirc => '\xFB', # small u, circumflex accent
+ ugrave => '\xF9', # small u, grave accent
+ uuml => '\xFC', # small u, dieresis or umlaut mark
+ yacute => '\xFD', # small y, acute accent
+ yuml => '\xFF', # small y, dieresis or umlaut mark
+
+ # Some extra Latin 1 chars that are listed in the HTML3.2 draft (21-May-96)
+ copy => '\xA9', # copyright sign
+ reg => '\xAE', # registered sign
+ nbsp => "\240", # non breaking space
+
+ # Additional ISO-8859/1 entities listed in rfc1866 (section 14)
+ iexcl => '\xA1',
+ cent => '\xA2',
+ pound => '\xA3',
+ curren => '\xA4',
+ yen => '\xA5',
+ brvbar => '\xA6',
+ sect => '\xA7',
+ uml => '\xA8',
+ ordf => '\xAA',
+ laquo => '\xAB',
+'not' => '\xAC', # not is a keyword in perl
+ shy => '\xAD',
+ macr => '\xAF',
+ deg => '\xB0',
+ plusmn => '\xB1',
+ sup1 => '\xB9',
+ sup2 => '\xB2',
+ sup3 => '\xB3',
+ acute => '\xB4',
+ micro => '\xB5',
+ para => '\xB6',
+ middot => '\xB7',
+ cedil => '\xB8',
+ ordm => '\xBA',
+ raquo => '\xBB',
+ frac14 => '\xBC',
+ frac12 => '\xBD',
+ frac34 => '\xBE',
+ iquest => '\xBF',
+'times' => '\xD7', # times is a keyword in perl
+ divide => '\xF7',
+
+# some POD special entities
+ verbar => '|',
+ sol => '/'
+);
+
+##---------------------------------------------------------------------------
+
+##---------------------------------
+## Function definitions begin here
+##---------------------------------
+
+sub podchecker {
+ my ($infile, $outfile, %options) = @_;
+ local $_;
+
+ ## Set defaults
+ $infile ||= \*STDIN;
+ $outfile ||= \*STDERR;
+
+ ## Now create a pod checker
+ my $checker = new Pod::Checker(%options);
+
+ ## Now check the pod document for errors
+ $checker->parse_from_file($infile, $outfile);
+
+ ## Return the number of errors found
+ return $checker->num_errors();
+}
+
+##---------------------------------------------------------------------------
+
+##-------------------------------
+## Method definitions begin here
+##-------------------------------
+
+##################################
+
+=over 4
+
+=item C<Pod::Checker-E<gt>new( %options )>
+
+Return a reference to a new Pod::Checker object that inherits from
+Pod::Parser and is used for calling the required methods later. The
+following options are recognized:
+
+C<-warnings =E<gt> num>
+ Print warnings if C<num> is true. The higher the value of C<num>,
+the more warnings are printed. Currently there are only levels 1 and 2.
+
+C<-quiet =E<gt> num>
+ If C<num> is true, do not print any errors/warnings. This is useful
+when Pod::Checker is used to munge POD code into plain text from within
+POD formatters.
+
+=cut
+
+## sub new {
+## my $this = shift;
+## my $class = ref($this) || $this;
+## my %params = @_;
+## my $self = {%params};
+## bless $self, $class;
+## $self->initialize();
+## return $self;
+## }
+
+sub initialize {
+ my $self = shift;
+ ## Initialize number of errors, and setup an error function to
+ ## increment this number and then print to the designated output.
+ $self->{_NUM_ERRORS} = 0;
+ $self->{_NUM_WARNINGS} = 0;
+ $self->{-quiet} ||= 0;
+ # set the error handling subroutine
+ $self->errorsub($self->{-quiet} ? sub { 1; } : 'poderror');
+ $self->{_commands} = 0; # total number of POD commands encountered
+ $self->{_list_stack} = []; # stack for nested lists
+ $self->{_have_begin} = ''; # stores =begin
+ $self->{_links} = []; # stack for internal hyperlinks
+ $self->{_nodes} = []; # stack for =head/=item nodes
+ $self->{_index} = []; # text in X<>
+ # print warnings?
+ $self->{-warnings} = 1 unless(defined $self->{-warnings});
+ $self->{_current_head1} = ''; # the current =head1 block
+ $self->parseopts(-process_cut_cmd => 1, -warnings => $self->{-warnings});
+}
+
+##################################
+
+=item C<$checker-E<gt>poderror( @args )>
+
+=item C<$checker-E<gt>poderror( {%opts}, @args )>
+
+Internal method for printing errors and warnings. If no options are
+given, simply prints "@_". The following options are recognized and used
+to form the output:
+
+ -msg
+
+A message to print prior to C<@args>.
+
+ -line
+
+The line number the error occurred in.
+
+ -file
+
+The file (name) the error occurred in.
+
+ -severity
+
+The error level, should be 'WARNING' or 'ERROR'.
+
+=cut
+
+# Invoked as $self->poderror( @args ), or $self->poderror( {%opts}, @args )
+sub poderror {
+ my $self = shift;
+ my %opts = (ref $_[0]) ? %{shift()} : ();
+
+ ## Retrieve options
+ chomp( my $msg = ($opts{-msg} || '')."@_" );
+ my $line = (exists $opts{-line}) ? " at line $opts{-line}" : '';
+ my $file = (exists $opts{-file}) ? " in file $opts{-file}" : '';
+ unless (exists $opts{-severity}) {
+ ## See if can find severity in message prefix
+ $opts{-severity} = $1 if ( $msg =~ s/^\**\s*([A-Z]{3,}):\s+// );
+ }
+ my $severity = (exists $opts{-severity}) ? "*** $opts{-severity}: " : '';
+
+ ## Increment error count and print message "
+ ++($self->{_NUM_ERRORS})
+ if(!%opts || ($opts{-severity} && $opts{-severity} eq 'ERROR'));
+ ++($self->{_NUM_WARNINGS})
+ if(!%opts || ($opts{-severity} && $opts{-severity} eq 'WARNING'));
+ unless($self->{-quiet}) {
+ my $out_fh = $self->output_handle() || \*STDERR;
+ print $out_fh ($severity, $msg, $line, $file, "\n")
+ if($self->{-warnings} || !%opts || $opts{-severity} ne 'WARNING');
+ }
+}
+
+##################################
+
+=item C<$checker-E<gt>num_errors()>
+
+Set (if argument specified) and retrieve the number of errors found.
+
+=cut
+
+sub num_errors {
+ return (@_ > 1) ? ($_[0]->{_NUM_ERRORS} = $_[1]) : $_[0]->{_NUM_ERRORS};
+}
+
+##################################
+
+=item C<$checker-E<gt>num_warnings()>
+
+Set (if argument specified) and retrieve the number of warnings found.
+
+=cut
+
+sub num_warnings {
+ return (@_ > 1) ? ($_[0]->{_NUM_WARNINGS} = $_[1]) : $_[0]->{_NUM_WARNINGS};
+}
+
+##################################
+
+=item C<$checker-E<gt>name()>
+
+Set (if argument specified) and retrieve the canonical name of POD as
+found in the C<=head1 NAME> section.
+
+=cut
+
+sub name {
+ return (@_ > 1 && $_[1]) ?
+ ($_[0]->{-name} = $_[1]) : $_[0]->{-name};
+}
+
+##################################
+
+=item C<$checker-E<gt>node()>
+
+Add (if argument specified) and retrieve the nodes (as defined by C<=headX>
+and C<=item>) of the current POD. The nodes are returned in the order of
+their occurrence. They consist of plain text, each piece of whitespace is
+collapsed to a single blank.
+
+=cut
+
+sub node {
+ my ($self,$text) = @_;
+ if(defined $text) {
+ $text =~ s/\s+$//s; # strip trailing whitespace
+ $text =~ s/\s+/ /gs; # collapse whitespace
+ # add node, order important!
+ push(@{$self->{_nodes}}, $text);
+ # keep also a uniqueness counter
+ $self->{_unique_nodes}->{$text}++ if($text !~ /^\s*$/s);
+ return $text;
+ }
+ @{$self->{_nodes}};
+}
+
+##################################
+
+=item C<$checker-E<gt>idx()>
+
+Add (if argument specified) and retrieve the index entries (as defined by
+C<XE<lt>E<gt>>) of the current POD. They consist of plain text, each piece
+of whitespace is collapsed to a single blank.
+
+=cut
+
+# set/return index entries of current POD
+sub idx {
+ my ($self,$text) = @_;
+ if(defined $text) {
+ $text =~ s/\s+$//s; # strip trailing whitespace
+ $text =~ s/\s+/ /gs; # collapse whitespace
+ # add node, order important!
+ push(@{$self->{_index}}, $text);
+ # keep also a uniqueness counter
+ $self->{_unique_nodes}->{$text}++ if($text !~ /^\s*$/s);
+ return $text;
+ }
+ @{$self->{_index}};
+}
+
+##################################
+
+=item C<$checker-E<gt>hyperlink()>
+
+Add (if argument specified) and retrieve the hyperlinks (as defined by
+C<LE<lt>E<gt>>) of the current POD. They consist of a 2-item array: line
+number and C<Pod::Hyperlink> object.
+
+=back
+
+=cut
+
+# set/return hyperlinks of the current POD
+sub hyperlink {
+ my $self = shift;
+ if($_[0]) {
+ push(@{$self->{_links}}, $_[0]);
+ return $_[0];
+ }
+ @{$self->{_links}};
+}
+
+## overrides for Pod::Parser
+
+sub end_pod {
+ ## Do some final checks and
+ ## print the number of errors found
+ my $self = shift;
+ my $infile = $self->input_file();
+
+ if(@{$self->{_list_stack}}) {
+ my $list;
+ while(($list = $self->_close_list('EOF',$infile)) &&
+ $list->indent() ne 'auto') {
+ $self->poderror({ -line => 'EOF', -file => $infile,
+ -severity => 'ERROR', -msg => '=over on line ' .
+ $list->start() . ' without closing =back' });
+ }
+ }
+
+ # check validity of document internal hyperlinks
+ # first build the node names from the paragraph text
+ my %nodes;
+ foreach($self->node()) {
+ $nodes{$_} = 1;
+ if(/^(\S+)\s+\S/) {
+ # we have more than one word. Use the first as a node, too.
+ # This is used heavily in perlfunc.pod
+ $nodes{$1} ||= 2; # derived node
+ }
+ }
+ foreach($self->idx()) {
+ $nodes{$_} = 3; # index node
+ }
+ foreach($self->hyperlink()) {
+ my ($line,$link) = @$_;
+ # _TODO_ what if there is a link to the page itself by the name,
+ # e.g. in Tk::Pod : L<Tk::Pod/"DESCRIPTION">
+ if($link->node() && !$link->page() && $link->type() ne 'hyperlink') {
+ my $node = $self->_check_ptree($self->parse_text($link->node(),
+ $line), $line, $infile, 'L');
+ if($node && !$nodes{$node}) {
+ $self->poderror({ -line => $line || '', -file => $infile,
+ -severity => 'ERROR',
+ -msg => "unresolved internal link '$node'"});
+ }
+ }
+ }
+
+ # check the internal nodes for uniqueness. This pertains to
+ # =headX, =item and X<...>
+ if($self->{-warnings} && $self->{-warnings}>1) {
+ foreach(grep($self->{_unique_nodes}->{$_} > 1,
+ keys %{$self->{_unique_nodes}})) {
+ $self->poderror({ -line => '-', -file => $infile,
+ -severity => 'WARNING',
+ -msg => "multiple occurrence of link target '$_'"});
+ }
+ }
+
+ # no POD found here
+ $self->num_errors(-1) if($self->{_commands} == 0);
+}
+
+# check a POD command directive
+sub command {
+ my ($self, $cmd, $paragraph, $line_num, $pod_para) = @_;
+ my ($file, $line) = $pod_para->file_line;
+ ## Check the command syntax
+ my $arg; # this will hold the command argument
+ if (! $VALID_COMMANDS{$cmd}) {
+ $self->poderror({ -line => $line, -file => $file, -severity => 'ERROR',
+ -msg => "Unknown command '$cmd'" });
+ }
+ else { # found a valid command
+ $self->{_commands}++; # delete this line if below is enabled again
+
+ ##### following check disabled due to strong request
+ #if(!$self->{_commands}++ && $cmd !~ /^head/) {
+ # $self->poderror({ -line => $line, -file => $file,
+ # -severity => 'WARNING',
+ # -msg => "file does not start with =head" });
+ #}
+
+ # check syntax of particular command
+ if($cmd eq 'over') {
+ # check for argument
+ $arg = $self->interpolate_and_check($paragraph, $line,$file);
+ my $indent = 4; # default
+ if($arg && $arg =~ /^\s*(\d+)\s*$/) {
+ $indent = $1;
+ }
+ # start a new list
+ $self->_open_list($indent,$line,$file);
+ }
+ elsif($cmd eq 'item') {
+ # are we in a list?
+ unless(@{$self->{_list_stack}}) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'ERROR',
+ -msg => '=item without previous =over' });
+ # auto-open in case we encounter many more
+ $self->_open_list('auto',$line,$file);
+ }
+ my $list = $self->{_list_stack}->[0];
+ # check whether the previous item had some contents
+ if(defined $self->{_list_item_contents} &&
+ $self->{_list_item_contents} == 0) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'WARNING',
+ -msg => 'previous =item has no contents' });
+ }
+ if($list->{_has_par}) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'WARNING',
+ -msg => 'preceding non-item paragraph(s)' });
+ delete $list->{_has_par};
+ }
+ # check for argument
+ $arg = $self->interpolate_and_check($paragraph, $line, $file);
+ if($arg && $arg =~ /(\S+)/) {
+ $arg =~ s/[\s\n]+$//;
+ my $type;
+ if($arg =~ /^[*]\s*(\S*.*)/) {
+ $type = 'bullet';
+ $self->{_list_item_contents} = $1 ? 1 : 0;
+ $arg = $1;
+ }
+ elsif($arg =~ /^\d+\.?\s+(\S*)/) {
+ $type = 'number';
+ $self->{_list_item_contents} = $1 ? 1 : 0;
+ $arg = $1;
+ }
+ else {
+ $type = 'definition';
+ $self->{_list_item_contents} = 1;
+ }
+ my $first = $list->type();
+ if($first && $first ne $type) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'WARNING',
+ -msg => "=item type mismatch ('$first' vs. '$type')"});
+ }
+ else { # first item
+ $list->type($type);
+ }
+ }
+ else {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'WARNING',
+ -msg => 'No argument for =item' });
+ $arg = ' '; # empty
+ $self->{_list_item_contents} = 0;
+ }
+ # add this item
+ $list->item($arg);
+ # remember this node
+ $self->node($arg);
+ }
+ elsif($cmd eq 'back') {
+ # check if we have an open list
+ unless(@{$self->{_list_stack}}) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'ERROR',
+ -msg => '=back without previous =over' });
+ }
+ else {
+ # check for spurious characters
+ $arg = $self->interpolate_and_check($paragraph, $line,$file);
+ if($arg && $arg =~ /\S/) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'ERROR',
+ -msg => 'Spurious character(s) after =back' });
+ }
+ # close list
+ my $list = $self->_close_list($line,$file);
+ # check for empty lists
+ if(!$list->item() && $self->{-warnings}) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'WARNING',
+ -msg => 'No items in =over (at line ' .
+ $list->start() . ') / =back list'});
+ }
+ }
+ }
+ elsif($cmd =~ /^head(\d+)/) {
+ my $hnum = $1;
+ $self->{"_have_head_$hnum"}++; # count head types
+ if($hnum > 1 && !$self->{'_have_head_'.($hnum -1)}) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'WARNING',
+ -msg => "=head$hnum without preceding higher level"});
+ }
+ # check whether the previous =head section had some contents
+ if(defined $self->{_commands_in_head} &&
+ $self->{_commands_in_head} == 0 &&
+ defined $self->{_last_head} &&
+ $self->{_last_head} >= $hnum) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'WARNING',
+ -msg => 'empty section in previous paragraph'});
+ }
+ $self->{_commands_in_head} = -1;
+ $self->{_last_head} = $hnum;
+ # check if there is an open list
+ if(@{$self->{_list_stack}}) {
+ my $list;
+ while(($list = $self->_close_list($line,$file)) &&
+ $list->indent() ne 'auto') {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'ERROR',
+ -msg => '=over on line '. $list->start() .
+ " without closing =back (at $cmd)" });
+ }
+ }
+ # remember this node
+ $arg = $self->interpolate_and_check($paragraph, $line,$file);
+ $arg =~ s/[\s\n]+$//s;
+ $self->node($arg);
+ unless(length($arg)) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'ERROR',
+ -msg => "empty =$cmd"});
+ }
+ if($cmd eq 'head1') {
+ $self->{_current_head1} = $arg;
+ } else {
+ $self->{_current_head1} = '';
+ }
+ }
+ elsif($cmd eq 'begin') {
+ if($self->{_have_begin}) {
+ # already have a begin
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'ERROR',
+ -msg => q{Nested =begin's (first at line } .
+ $self->{_have_begin} . ')'});
+ }
+ else {
+ # check for argument
+ $arg = $self->interpolate_and_check($paragraph, $line,$file);
+ unless($arg && $arg =~ /(\S+)/) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'ERROR',
+ -msg => 'No argument for =begin'});
+ }
+ # remember the =begin
+ $self->{_have_begin} = "$line:$1";
+ }
+ }
+ elsif($cmd eq 'end') {
+ if($self->{_have_begin}) {
+ # close the existing =begin
+ $self->{_have_begin} = '';
+ # check for spurious characters
+ $arg = $self->interpolate_and_check($paragraph, $line,$file);
+ # the closing argument is optional
+ #if($arg && $arg =~ /\S/) {
+ # $self->poderror({ -line => $line, -file => $file,
+ # -severity => 'WARNING',
+ # -msg => "Spurious character(s) after =end" });
+ #}
+ }
+ else {
+ # don't have a matching =begin
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'ERROR',
+ -msg => '=end without =begin' });
+ }
+ }
+ elsif($cmd eq 'for') {
+ unless($paragraph =~ /\s*(\S+)\s*/) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'ERROR',
+ -msg => '=for without formatter specification' });
+ }
+ $arg = ''; # do not expand paragraph below
+ }
+ elsif($cmd =~ /^(pod|cut)$/) {
+ # check for argument
+ $arg = $self->interpolate_and_check($paragraph, $line,$file);
+ if($arg && $arg =~ /(\S+)/) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'ERROR',
+ -msg => "Spurious text after =$cmd"});
+ }
+ }
+ $self->{_commands_in_head}++;
+ ## Check the interior sequences in the command-text
+ $self->interpolate_and_check($paragraph, $line,$file)
+ unless(defined $arg);
+ }
+}
+
+sub _open_list
+{
+ my ($self,$indent,$line,$file) = @_;
+ my $list = Pod::List->new(
+ -indent => $indent,
+ -start => $line,
+ -file => $file);
+ unshift(@{$self->{_list_stack}}, $list);
+ undef $self->{_list_item_contents};
+ $list;
+}
+
+sub _close_list
+{
+ my ($self,$line,$file) = @_;
+ my $list = shift(@{$self->{_list_stack}});
+ if(defined $self->{_list_item_contents} &&
+ $self->{_list_item_contents} == 0) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'WARNING',
+ -msg => 'previous =item has no contents' });
+ }
+ undef $self->{_list_item_contents};
+ $list;
+}
+
+# process a block of some text
+sub interpolate_and_check {
+ my ($self, $paragraph, $line, $file) = @_;
+ ## Check the interior sequences in the command-text
+ # and return the text
+ $self->_check_ptree(
+ $self->parse_text($paragraph,$line), $line, $file, '');
+}
+
+sub _check_ptree {
+ my ($self,$ptree,$line,$file,$nestlist) = @_;
+ local($_);
+ my $text = '';
+ # process each node in the parse tree
+ foreach(@$ptree) {
+ # regular text chunk
+ unless(ref) {
+ # count the unescaped angle brackets
+ # complain only when warning level is greater than 1
+ if($self->{-warnings} && $self->{-warnings}>1) {
+ my $count;
+ if($count = tr/<>/<>/) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'WARNING',
+ -msg => "$count unescaped <> in paragraph" });
+ }
+ }
+ $text .= $_;
+ next;
+ }
+ # have an interior sequence
+ my $cmd = $_->cmd_name();
+ my $contents = $_->parse_tree();
+ ($file,$line) = $_->file_line();
+ # check for valid tag
+ if (! $VALID_SEQUENCES{$cmd}) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'ERROR',
+ -msg => qq(Unknown interior-sequence '$cmd')});
+ # expand it anyway
+ $text .= $self->_check_ptree($contents, $line, $file, "$nestlist$cmd");
+ next;
+ }
+ if($nestlist =~ /$cmd/) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'WARNING',
+ -msg => "nested commands $cmd<...$cmd<...>...>"});
+ # _TODO_ should we add the contents anyway?
+ # expand it anyway, see below
+ }
+ if($cmd eq 'E') {
+ # preserve entities
+ if(@$contents > 1 || ref $$contents[0] || $$contents[0] !~ /^\w+$/) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'ERROR',
+ -msg => 'garbled entity ' . $_->raw_text()});
+ next;
+ }
+ my $ent = $$contents[0];
+ my $val;
+ if($ent =~ /^0x[0-9a-f]+$/i) {
+ # hexadec entity
+ $val = hex($ent);
+ }
+ elsif($ent =~ /^0\d+$/) {
+ # octal
+ $val = oct($ent);
+ }
+ elsif($ent =~ /^\d+$/) {
+ # numeric entity
+ $val = $ent;
+ }
+ if(defined $val) {
+ if($val>0 && $val<256) {
+ $text .= chr($val);
+ }
+ else {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'ERROR',
+ -msg => 'Entity number out of range ' . $_->raw_text()});
+ }
+ }
+ elsif($ENTITIES{$ent}) {
+ # known ISO entity
+ $text .= $ENTITIES{$ent};
+ }
+ else {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'WARNING',
+ -msg => 'Unknown entity ' . $_->raw_text()});
+ $text .= "E<$ent>";
+ }
+ }
+ elsif($cmd eq 'L') {
+ # try to parse the hyperlink
+ my $link = Pod::Hyperlink->new($contents->raw_text());
+ unless(defined $link) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'ERROR',
+ -msg => 'malformed link ' . $_->raw_text() ." : $@"});
+ next;
+ }
+ $link->line($line); # remember line
+ if($self->{-warnings}) {
+ foreach my $w ($link->warning()) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'WARNING',
+ -msg => $w });
+ }
+ }
+ # check the link text
+ $text .= $self->_check_ptree($self->parse_text($link->text(),
+ $line), $line, $file, "$nestlist$cmd");
+ # remember link
+ $self->hyperlink([$line,$link]);
+ }
+ elsif($cmd =~ /[BCFIS]/) {
+ # add the guts
+ $text .= $self->_check_ptree($contents, $line, $file, "$nestlist$cmd");
+ }
+ elsif($cmd eq 'Z') {
+ if(length($contents->raw_text())) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'ERROR',
+ -msg => 'Nonempty Z<>'});
+ }
+ }
+ elsif($cmd eq 'X') {
+ my $idx = $self->_check_ptree($contents, $line, $file, "$nestlist$cmd");
+ if($idx =~ /^\s*$/s) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'ERROR',
+ -msg => 'Empty X<>'});
+ }
+ else {
+ # remember this node
+ $self->idx($idx);
+ }
+ }
+ else {
+ # not reached
+ croak 'internal error';
+ }
+ }
+ $text;
+}
+
+# process a block of verbatim text
+sub verbatim {
+ ## Nothing particular to check
+ my ($self, $paragraph, $line_num, $pod_para) = @_;
+
+ $self->_preproc_par($paragraph);
+
+ if($self->{_current_head1} eq 'NAME') {
+ my ($file, $line) = $pod_para->file_line;
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'WARNING',
+ -msg => 'Verbatim paragraph in NAME section' });
+ }
+}
+
+# process a block of regular text
+sub textblock {
+ my ($self, $paragraph, $line_num, $pod_para) = @_;
+ my ($file, $line) = $pod_para->file_line;
+
+ $self->_preproc_par($paragraph);
+
+ # skip this paragraph if in a =begin block
+ unless($self->{_have_begin}) {
+ my $block = $self->interpolate_and_check($paragraph, $line,$file);
+ if($self->{_current_head1} eq 'NAME') {
+ if($block =~ /^\s*(\S+?)\s*[,-]/) {
+ # this is the canonical name
+ $self->{-name} = $1 unless(defined $self->{-name});
+ }
+ }
+ }
+}
+
+sub _preproc_par
+{
+ my $self = shift;
+ $_[0] =~ s/[\s\n]+$//;
+ if($_[0]) {
+ $self->{_commands_in_head}++;
+ $self->{_list_item_contents}++ if(defined $self->{_list_item_contents});
+ if(@{$self->{_list_stack}} && !$self->{_list_stack}->[0]->item()) {
+ $self->{_list_stack}->[0]->{_has_par} = 1;
+ }
+ }
+}
+
+1;
+
+__END__
+
+=head1 AUTHOR
+
+Please report bugs using L<http://rt.cpan.org>.
+
+Brad Appleton E<lt>bradapp at enteract.comE<gt> (initial version),
+Marek Rouchal E<lt>marekr at cpan.orgE<gt>
+
+Based on code for B<Pod::Text::pod2text()> written by
+Tom Christiansen E<lt>tchrist at mox.perl.comE<gt>
+
+=cut
+
Copied: trunk/contrib/perl/lib/Pod/Escapes.pm (from rev 6437, vendor/perl/5.18.1/lib/Pod/Escapes.pm)
===================================================================
--- trunk/contrib/perl/lib/Pod/Escapes.pm (rev 0)
+++ trunk/contrib/perl/lib/Pod/Escapes.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,721 @@
+
+require 5;
+# The documentation is at the end.
+# Time-stamp: "2004-05-07 15:31:25 ADT"
+package Pod::Escapes;
+require Exporter;
+ at ISA = ('Exporter');
+$VERSION = '1.04';
+ at EXPORT_OK = qw(
+ %Code2USASCII
+ %Name2character
+ %Name2character_number
+ %Latin1Code_to_fallback
+ %Latin1Char_to_fallback
+ e2char
+ e2charnum
+);
+%EXPORT_TAGS = ('ALL' => \@EXPORT_OK);
+
+#==========================================================================
+
+use strict;
+use vars qw(
+ %Code2USASCII
+ %Name2character
+ %Name2character_number
+ %Latin1Code_to_fallback
+ %Latin1Char_to_fallback
+ $FAR_CHAR
+ $FAR_CHAR_NUMBER
+ $NOT_ASCII
+);
+
+$FAR_CHAR = "?" unless defined $FAR_CHAR;
+$FAR_CHAR_NUMBER = ord($FAR_CHAR) unless defined $FAR_CHAR_NUMBER;
+
+$NOT_ASCII = 'A' ne chr(65) unless defined $NOT_ASCII;
+
+#--------------------------------------------------------------------------
+sub e2char {
+ my $in = $_[0];
+ return undef unless defined $in and length $in;
+
+ # Convert to decimal:
+ if($in =~ m/^(0[0-7]*)$/s ) {
+ $in = oct $in;
+ } elsif($in =~ m/^0?x([0-9a-fA-F]+)$/s ) {
+ $in = hex $1;
+ } # else it's decimal, or named
+
+ if($NOT_ASCII) {
+ # We're in bizarro world of not-ASCII!
+ # Cope with US-ASCII codes, use fallbacks for Latin-1, or use FAR_CHAR.
+ unless($in =~ m/^\d+$/s) {
+ # It's a named character reference. Get its numeric Unicode value.
+ $in = $Name2character{$in};
+ return undef unless defined $in; # (if there's no such name)
+ $in = ord $in; # (All ents must be one character long.)
+ # ...So $in holds the char's US-ASCII numeric value, which we'll
+ # now go get the local equivalent for.
+ }
+
+ # It's numeric, whether by origin or by mutation from a known name
+ return $Code2USASCII{$in} # so "65" => "A" everywhere
+ || $Latin1Code_to_fallback{$in} # Fallback.
+ || $FAR_CHAR; # Fall further back
+ }
+
+ # Normal handling:
+ if($in =~ m/^\d+$/s) {
+ if($] < 5.007 and $in > 255) { # can't be trusted with Unicode
+ return $FAR_CHAR;
+ } else {
+ return chr($in);
+ }
+ } else {
+ return $Name2character{$in}; # returns undef if unknown
+ }
+}
+
+#--------------------------------------------------------------------------
+sub e2charnum {
+ my $in = $_[0];
+ return undef unless defined $in and length $in;
+
+ # Convert to decimal:
+ if($in =~ m/^(0[0-7]*)$/s ) {
+ $in = oct $in;
+ } elsif($in =~ m/^0?x([0-9a-fA-F]+)$/s ) {
+ $in = hex $1;
+ } # else it's decimal, or named
+
+ if($in =~ m/^\d+$/s) {
+ return 0 + $in;
+ } else {
+ return $Name2character_number{$in}; # returns undef if unknown
+ }
+}
+
+#--------------------------------------------------------------------------
+
+%Name2character_number = (
+ # General XML/XHTML:
+ 'lt' => 60,
+ 'gt' => 62,
+ 'quot' => 34,
+ 'amp' => 38,
+ 'apos' => 39,
+
+ # POD-specific:
+ 'sol' => 47,
+ 'verbar' => 124,
+
+ 'lchevron' => 171, # legacy for laquo
+ 'rchevron' => 187, # legacy for raquo
+
+ # Remember, grave looks like \ (as in virtu\)
+ # acute looks like / (as in re/sume/)
+ # circumflex looks like ^ (as in papier ma^che/)
+ # umlaut/dieresis looks like " (as in nai"ve, Chloe")
+
+ # From the XHTML 1 .ent files:
+ 'nbsp' , 160,
+ 'iexcl' , 161,
+ 'cent' , 162,
+ 'pound' , 163,
+ 'curren' , 164,
+ 'yen' , 165,
+ 'brvbar' , 166,
+ 'sect' , 167,
+ 'uml' , 168,
+ 'copy' , 169,
+ 'ordf' , 170,
+ 'laquo' , 171,
+ 'not' , 172,
+ 'shy' , 173,
+ 'reg' , 174,
+ 'macr' , 175,
+ 'deg' , 176,
+ 'plusmn' , 177,
+ 'sup2' , 178,
+ 'sup3' , 179,
+ 'acute' , 180,
+ 'micro' , 181,
+ 'para' , 182,
+ 'middot' , 183,
+ 'cedil' , 184,
+ 'sup1' , 185,
+ 'ordm' , 186,
+ 'raquo' , 187,
+ 'frac14' , 188,
+ 'frac12' , 189,
+ 'frac34' , 190,
+ 'iquest' , 191,
+ 'Agrave' , 192,
+ 'Aacute' , 193,
+ 'Acirc' , 194,
+ 'Atilde' , 195,
+ 'Auml' , 196,
+ 'Aring' , 197,
+ 'AElig' , 198,
+ 'Ccedil' , 199,
+ 'Egrave' , 200,
+ 'Eacute' , 201,
+ 'Ecirc' , 202,
+ 'Euml' , 203,
+ 'Igrave' , 204,
+ 'Iacute' , 205,
+ 'Icirc' , 206,
+ 'Iuml' , 207,
+ 'ETH' , 208,
+ 'Ntilde' , 209,
+ 'Ograve' , 210,
+ 'Oacute' , 211,
+ 'Ocirc' , 212,
+ 'Otilde' , 213,
+ 'Ouml' , 214,
+ 'times' , 215,
+ 'Oslash' , 216,
+ 'Ugrave' , 217,
+ 'Uacute' , 218,
+ 'Ucirc' , 219,
+ 'Uuml' , 220,
+ 'Yacute' , 221,
+ 'THORN' , 222,
+ 'szlig' , 223,
+ 'agrave' , 224,
+ 'aacute' , 225,
+ 'acirc' , 226,
+ 'atilde' , 227,
+ 'auml' , 228,
+ 'aring' , 229,
+ 'aelig' , 230,
+ 'ccedil' , 231,
+ 'egrave' , 232,
+ 'eacute' , 233,
+ 'ecirc' , 234,
+ 'euml' , 235,
+ 'igrave' , 236,
+ 'iacute' , 237,
+ 'icirc' , 238,
+ 'iuml' , 239,
+ 'eth' , 240,
+ 'ntilde' , 241,
+ 'ograve' , 242,
+ 'oacute' , 243,
+ 'ocirc' , 244,
+ 'otilde' , 245,
+ 'ouml' , 246,
+ 'divide' , 247,
+ 'oslash' , 248,
+ 'ugrave' , 249,
+ 'uacute' , 250,
+ 'ucirc' , 251,
+ 'uuml' , 252,
+ 'yacute' , 253,
+ 'thorn' , 254,
+ 'yuml' , 255,
+
+ 'fnof' , 402,
+ 'Alpha' , 913,
+ 'Beta' , 914,
+ 'Gamma' , 915,
+ 'Delta' , 916,
+ 'Epsilon' , 917,
+ 'Zeta' , 918,
+ 'Eta' , 919,
+ 'Theta' , 920,
+ 'Iota' , 921,
+ 'Kappa' , 922,
+ 'Lambda' , 923,
+ 'Mu' , 924,
+ 'Nu' , 925,
+ 'Xi' , 926,
+ 'Omicron' , 927,
+ 'Pi' , 928,
+ 'Rho' , 929,
+ 'Sigma' , 931,
+ 'Tau' , 932,
+ 'Upsilon' , 933,
+ 'Phi' , 934,
+ 'Chi' , 935,
+ 'Psi' , 936,
+ 'Omega' , 937,
+ 'alpha' , 945,
+ 'beta' , 946,
+ 'gamma' , 947,
+ 'delta' , 948,
+ 'epsilon' , 949,
+ 'zeta' , 950,
+ 'eta' , 951,
+ 'theta' , 952,
+ 'iota' , 953,
+ 'kappa' , 954,
+ 'lambda' , 955,
+ 'mu' , 956,
+ 'nu' , 957,
+ 'xi' , 958,
+ 'omicron' , 959,
+ 'pi' , 960,
+ 'rho' , 961,
+ 'sigmaf' , 962,
+ 'sigma' , 963,
+ 'tau' , 964,
+ 'upsilon' , 965,
+ 'phi' , 966,
+ 'chi' , 967,
+ 'psi' , 968,
+ 'omega' , 969,
+ 'thetasym' , 977,
+ 'upsih' , 978,
+ 'piv' , 982,
+ 'bull' , 8226,
+ 'hellip' , 8230,
+ 'prime' , 8242,
+ 'Prime' , 8243,
+ 'oline' , 8254,
+ 'frasl' , 8260,
+ 'weierp' , 8472,
+ 'image' , 8465,
+ 'real' , 8476,
+ 'trade' , 8482,
+ 'alefsym' , 8501,
+ 'larr' , 8592,
+ 'uarr' , 8593,
+ 'rarr' , 8594,
+ 'darr' , 8595,
+ 'harr' , 8596,
+ 'crarr' , 8629,
+ 'lArr' , 8656,
+ 'uArr' , 8657,
+ 'rArr' , 8658,
+ 'dArr' , 8659,
+ 'hArr' , 8660,
+ 'forall' , 8704,
+ 'part' , 8706,
+ 'exist' , 8707,
+ 'empty' , 8709,
+ 'nabla' , 8711,
+ 'isin' , 8712,
+ 'notin' , 8713,
+ 'ni' , 8715,
+ 'prod' , 8719,
+ 'sum' , 8721,
+ 'minus' , 8722,
+ 'lowast' , 8727,
+ 'radic' , 8730,
+ 'prop' , 8733,
+ 'infin' , 8734,
+ 'ang' , 8736,
+ 'and' , 8743,
+ 'or' , 8744,
+ 'cap' , 8745,
+ 'cup' , 8746,
+ 'int' , 8747,
+ 'there4' , 8756,
+ 'sim' , 8764,
+ 'cong' , 8773,
+ 'asymp' , 8776,
+ 'ne' , 8800,
+ 'equiv' , 8801,
+ 'le' , 8804,
+ 'ge' , 8805,
+ 'sub' , 8834,
+ 'sup' , 8835,
+ 'nsub' , 8836,
+ 'sube' , 8838,
+ 'supe' , 8839,
+ 'oplus' , 8853,
+ 'otimes' , 8855,
+ 'perp' , 8869,
+ 'sdot' , 8901,
+ 'lceil' , 8968,
+ 'rceil' , 8969,
+ 'lfloor' , 8970,
+ 'rfloor' , 8971,
+ 'lang' , 9001,
+ 'rang' , 9002,
+ 'loz' , 9674,
+ 'spades' , 9824,
+ 'clubs' , 9827,
+ 'hearts' , 9829,
+ 'diams' , 9830,
+ 'OElig' , 338,
+ 'oelig' , 339,
+ 'Scaron' , 352,
+ 'scaron' , 353,
+ 'Yuml' , 376,
+ 'circ' , 710,
+ 'tilde' , 732,
+ 'ensp' , 8194,
+ 'emsp' , 8195,
+ 'thinsp' , 8201,
+ 'zwnj' , 8204,
+ 'zwj' , 8205,
+ 'lrm' , 8206,
+ 'rlm' , 8207,
+ 'ndash' , 8211,
+ 'mdash' , 8212,
+ 'lsquo' , 8216,
+ 'rsquo' , 8217,
+ 'sbquo' , 8218,
+ 'ldquo' , 8220,
+ 'rdquo' , 8221,
+ 'bdquo' , 8222,
+ 'dagger' , 8224,
+ 'Dagger' , 8225,
+ 'permil' , 8240,
+ 'lsaquo' , 8249,
+ 'rsaquo' , 8250,
+ 'euro' , 8364,
+);
+
+
+# Fill out %Name2character...
+{
+ %Name2character = ();
+ my($name, $number);
+ while( ($name, $number) = each %Name2character_number) {
+ if($] < 5.007 and $number > 255) {
+ $Name2character{$name} = $FAR_CHAR;
+ # substitute for Unicode characters, for perls
+ # that can't reliable handle them
+ } else {
+ $Name2character{$name} = chr $number;
+ # normal case
+ }
+ }
+ # So they resolve 'right' even in EBCDIC-land
+ $Name2character{'lt' } = '<';
+ $Name2character{'gt' } = '>';
+ $Name2character{'quot'} = '"';
+ $Name2character{'amp' } = '&';
+ $Name2character{'apos'} = "'";
+ $Name2character{'sol' } = '/';
+ $Name2character{'verbar'} = '|';
+}
+
+#--------------------------------------------------------------------------
+
+%Code2USASCII = (
+# mostly generated by
+# perl -e "printf qq{ \x25 3s, '\x25s',\n}, $_, chr($_) foreach (32 .. 126)"
+ 32, ' ',
+ 33, '!',
+ 34, '"',
+ 35, '#',
+ 36, '$',
+ 37, '%',
+ 38, '&',
+ 39, "'", #!
+ 40, '(',
+ 41, ')',
+ 42, '*',
+ 43, '+',
+ 44, ',',
+ 45, '-',
+ 46, '.',
+ 47, '/',
+ 48, '0',
+ 49, '1',
+ 50, '2',
+ 51, '3',
+ 52, '4',
+ 53, '5',
+ 54, '6',
+ 55, '7',
+ 56, '8',
+ 57, '9',
+ 58, ':',
+ 59, ';',
+ 60, '<',
+ 61, '=',
+ 62, '>',
+ 63, '?',
+ 64, '@',
+ 65, 'A',
+ 66, 'B',
+ 67, 'C',
+ 68, 'D',
+ 69, 'E',
+ 70, 'F',
+ 71, 'G',
+ 72, 'H',
+ 73, 'I',
+ 74, 'J',
+ 75, 'K',
+ 76, 'L',
+ 77, 'M',
+ 78, 'N',
+ 79, 'O',
+ 80, 'P',
+ 81, 'Q',
+ 82, 'R',
+ 83, 'S',
+ 84, 'T',
+ 85, 'U',
+ 86, 'V',
+ 87, 'W',
+ 88, 'X',
+ 89, 'Y',
+ 90, 'Z',
+ 91, '[',
+ 92, "\\", #!
+ 93, ']',
+ 94, '^',
+ 95, '_',
+ 96, '`',
+ 97, 'a',
+ 98, 'b',
+ 99, 'c',
+ 100, 'd',
+ 101, 'e',
+ 102, 'f',
+ 103, 'g',
+ 104, 'h',
+ 105, 'i',
+ 106, 'j',
+ 107, 'k',
+ 108, 'l',
+ 109, 'm',
+ 110, 'n',
+ 111, 'o',
+ 112, 'p',
+ 113, 'q',
+ 114, 'r',
+ 115, 's',
+ 116, 't',
+ 117, 'u',
+ 118, 'v',
+ 119, 'w',
+ 120, 'x',
+ 121, 'y',
+ 122, 'z',
+ 123, '{',
+ 124, '|',
+ 125, '}',
+ 126, '~',
+);
+
+#--------------------------------------------------------------------------
+
+%Latin1Code_to_fallback = ();
+ at Latin1Code_to_fallback{0xA0 .. 0xFF} = (
+# Copied from Text/Unidecode/x00.pm:
+
+' ', qq{!}, qq{C/}, 'PS', qq{\$?}, qq{Y=}, qq{|}, 'SS', qq{"}, qq{(c)}, 'a', qq{<<}, qq{!}, "", qq{(r)}, qq{-},
+'deg', qq{+-}, '2', '3', qq{'}, 'u', 'P', qq{*}, qq{,}, '1', 'o', qq{>>}, qq{1/4}, qq{1/2}, qq{3/4}, qq{?},
+'A', 'A', 'A', 'A', 'A', 'A', 'AE', 'C', 'E', 'E', 'E', 'E', 'I', 'I', 'I', 'I',
+'D', 'N', 'O', 'O', 'O', 'O', 'O', 'x', 'O', 'U', 'U', 'U', 'U', 'U', 'Th', 'ss',
+'a', 'a', 'a', 'a', 'a', 'a', 'ae', 'c', 'e', 'e', 'e', 'e', 'i', 'i', 'i', 'i',
+'d', 'n', 'o', 'o', 'o', 'o', 'o', qq{/}, 'o', 'u', 'u', 'u', 'u', 'y', 'th', 'y',
+
+);
+
+{
+ # Now stuff %Latin1Char_to_fallback:
+ %Latin1Char_to_fallback = ();
+ my($k,$v);
+ while( ($k,$v) = each %Latin1Code_to_fallback) {
+ $Latin1Char_to_fallback{chr $k} = $v;
+ #print chr($k), ' => ', $v, "\n";
+ }
+}
+
+#--------------------------------------------------------------------------
+1;
+__END__
+
+=head1 NAME
+
+Pod::Escapes -- for resolving Pod EE<lt>...E<gt> sequences
+
+=head1 SYNOPSIS
+
+ use Pod::Escapes qw(e2char);
+ ...la la la, parsing POD, la la la...
+ $text = e2char($e_node->label);
+ unless(defined $text) {
+ print "Unknown E sequence \"", $e_node->label, "\"!";
+ }
+ ...else print/interpolate $text...
+
+=head1 DESCRIPTION
+
+This module provides things that are useful in decoding
+Pod EE<lt>...E<gt> sequences. Presumably, it should be used
+only by Pod parsers and/or formatters.
+
+By default, Pod::Escapes exports none of its symbols. But
+you can request any of them to be exported.
+Either request them individually, as with
+C<use Pod::Escapes qw(symbolname symbolname2...);>,
+or you can do C<use Pod::Escapes qw(:ALL);> to get all
+exportable symbols.
+
+=head1 GOODIES
+
+=over
+
+=item e2char($e_content)
+
+Given a name or number that could appear in a
+C<EE<lt>name_or_numE<gt>> sequence, this returns the string that
+it stands for. For example, C<e2char('sol')>, C<e2char('47')>,
+C<e2char('0x2F')>, and C<e2char('057')> all return "/",
+because C<EE<lt>solE<gt>>, C<EE<lt>47E<gt>>, C<EE<lt>0x2fE<gt>>,
+and C<EE<lt>057E<gt>>, all mean "/". If
+the name has no known value (as with a name of "qacute") or is
+syntactally invalid (as with a name of "1/4"), this returns undef.
+
+=item e2charnum($e_content)
+
+Given a name or number that could appear in a
+C<EE<lt>name_or_numE<gt>> sequence, this returns the number of
+the Unicode character that this stands for. For example,
+C<e2char('sol')>, C<e2char('47')>,
+C<e2char('0x2F')>, and C<e2char('057')> all return 47,
+because C<EE<lt>solE<gt>>, C<EE<lt>47E<gt>>, C<EE<lt>0x2fE<gt>>,
+and C<EE<lt>057E<gt>>, all mean "/", whose Unicode number is 47. If
+the name has no known value (as with a name of "qacute") or is
+syntactally invalid (as with a name of "1/4"), this returns undef.
+
+=item $Name2character{I<name>}
+
+Maps from names (as in C<EE<lt>I<name>E<gt>>) like "eacute" or "sol"
+to the string that each stands for. Note that this does not
+include numerics (like "64" or "x981c"). Under old Perl versions
+(before 5.7) you get a "?" in place of characters whose Unicode
+value is over 255.
+
+=item $Name2character_number{I<name>}
+
+Maps from names (as in C<EE<lt>I<name>E<gt>>) like "eacute" or "sol"
+to the Unicode value that each stands for. For example,
+C<$Name2character_number{'eacute'}> is 201, and
+C<$Name2character_number{'eacute'}> is 8364. You get the correct
+Unicode value, regardless of the version of Perl you're using --
+which differs from C<%Name2character>'s behavior under pre-5.7 Perls.
+
+Note that this hash does not
+include numerics (like "64" or "x981c").
+
+=item $Latin1Code_to_fallback{I<integer>}
+
+For numbers in the range 160 (0x00A0) to 255 (0x00FF), this maps
+from the character code for a Latin-1 character (like 233 for
+lowercase e-acute) to the US-ASCII character that best aproximates
+it (like "e"). You may find this useful if you are rendering
+POD in a format that you think deals well only with US-ASCII
+characters.
+
+=item $Latin1Char_to_fallback{I<character>}
+
+Just as above, but maps from characters (like "\xE9",
+lowercase e-acute) to characters (like "e").
+
+=item $Code2USASCII{I<integer>}
+
+This maps from US-ASCII codes (like 32) to the corresponding
+character (like space, for 32). Only characters 32 to 126 are
+defined. This is meant for use by C<e2char($x)> when it senses
+that it's running on a non-ASCII platform (where chr(32) doesn't
+get you a space -- but $Code2USASCII{32} will). It's
+documented here just in case you might find it useful.
+
+=back
+
+=head1 CAVEATS
+
+On Perl versions before 5.7, Unicode characters with a value
+over 255 (like lambda or emdash) can't be conveyed. This
+module does work under such early Perl versions, but in the
+place of each such character, you get a "?". Latin-1
+characters (characters 160-255) are unaffected.
+
+Under EBCDIC platforms, C<e2char($n)> may not always be the
+same as C<chr(e2charnum($n))>, and ditto for
+C<$Name2character{$name}> and
+C<chr($Name2character_number{$name})>.
+
+=head1 SEE ALSO
+
+L<perlpod|perlpod>
+
+L<perlpodspec|perlpodspec>
+
+L<Text::Unidecode|Text::Unidecode>
+
+=head1 COPYRIGHT AND DISCLAIMERS
+
+Copyright (c) 2001-2004 Sean M. Burke. All rights reserved.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+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.
+
+Portions of the data tables in this module are derived from the
+entity declarations in the W3C XHTML specification.
+
+Currently (October 2001), that's these three:
+
+ http://www.w3.org/TR/xhtml1/DTD/xhtml-lat1.ent
+ http://www.w3.org/TR/xhtml1/DTD/xhtml-special.ent
+ http://www.w3.org/TR/xhtml1/DTD/xhtml-symbol.ent
+
+=head1 AUTHOR
+
+Sean M. Burke C<sburke at cpan.org>
+
+=cut
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+# What I used for reading the XHTML .ent files:
+
+use strict;
+my(@norms, @good, @bad);
+my $dir = 'c:/sgml/docbook/';
+my %escapes;
+foreach my $file (qw(
+ xhtml-symbol.ent
+ xhtml-lat1.ent
+ xhtml-special.ent
+)) {
+ open(IN, "<$dir$file") or die "can't read-open $dir$file: $!";
+ print "Reading $file...\n";
+ while(<IN>) {
+ if(m/<!ENTITY\s+(\S+)\s+"&#([^;]+);">/) {
+ my($name, $value) = ($1,$2);
+ next if $name eq 'quot' or $name eq 'apos' or $name eq 'gt';
+
+ $value = hex $1 if $value =~ m/^x([a-fA-F0-9]+)$/s;
+ print "ILLEGAL VALUE $value" unless $value =~ m/^\d+$/s;
+ if($value > 255) {
+ push @good , sprintf " %-10s , chr(%s),\n", "'$name'", $value;
+ push @bad , sprintf " %-10s , \$bad,\n", "'$name'", $value;
+ } else {
+ push @norms, sprintf " %-10s , chr(%s),\n", "'$name'", $value;
+ }
+ } elsif(m/<!ENT/) {
+ print "# Skipping $_";
+ }
+
+ }
+ close(IN);
+}
+
+print @norms;
+print "\n ( \$] .= 5.006001 ? (\n";
+print @good;
+print " ) : (\n";
+print @bad;
+print " )\n);\n";
+
+__END__
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
Copied: trunk/contrib/perl/lib/Pod/Find.pm (from rev 6437, vendor/perl/5.18.1/lib/Pod/Find.pm)
===================================================================
--- trunk/contrib/perl/lib/Pod/Find.pm (rev 0)
+++ trunk/contrib/perl/lib/Pod/Find.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,535 @@
+#############################################################################
+# Pod/Find.pm -- finds files containing POD documentation
+#
+# Author: Marek Rouchal <marekr at cpan.org>
+#
+# Copyright (C) 1999-2000 by Marek Rouchal (and borrowing code
+# from Nick Ing-Simmon's PodToHtml). All rights reserved.
+# This file is part of "PodParser". Pod::Find is free software;
+# you can redistribute it and/or modify it under the same terms
+# as Perl itself.
+#############################################################################
+
+package Pod::Find;
+use strict;
+
+use vars qw($VERSION);
+$VERSION = '1.35'; ## Current version of this package
+require 5.005; ## requires this Perl version or later
+use Carp;
+
+BEGIN {
+ if ($] < 5.006) {
+ require Symbol;
+ import Symbol;
+ }
+}
+
+#############################################################################
+
+=head1 NAME
+
+Pod::Find - find POD documents in directory trees
+
+=head1 SYNOPSIS
+
+ use Pod::Find qw(pod_find simplify_name);
+ my %pods = pod_find({ -verbose => 1, -inc => 1 });
+ foreach(keys %pods) {
+ print "found library POD `$pods{$_}' in $_\n";
+ }
+
+ print "podname=",simplify_name('a/b/c/mymodule.pod'),"\n";
+
+ $location = pod_where( { -inc => 1 }, "Pod::Find" );
+
+=head1 DESCRIPTION
+
+B<Pod::Find> provides a set of functions to locate POD files. Note that
+no function is exported by default to avoid pollution of your namespace,
+so be sure to specify them in the B<use> statement if you need them:
+
+ use Pod::Find qw(pod_find);
+
+From this version on the typical SCM (software configuration management)
+files/directories like RCS, CVS, SCCS, .svn are ignored.
+
+=cut
+
+#use diagnostics;
+use Exporter;
+use File::Spec;
+use File::Find;
+use Cwd;
+
+use vars qw(@ISA @EXPORT_OK $VERSION);
+ at ISA = qw(Exporter);
+ at EXPORT_OK = qw(&pod_find &simplify_name &pod_where &contains_pod);
+
+# package global variables
+my $SIMPLIFY_RX;
+
+=head2 C<pod_find( { %opts } , @directories )>
+
+The function B<pod_find> searches for POD documents in a given set of
+files and/or directories. It returns a hash with the file names as keys
+and the POD name as value. The POD name is derived from the file name
+and its position in the directory tree.
+
+E.g. when searching in F<$HOME/perl5lib>, the file
+F<$HOME/perl5lib/MyModule.pm> would get the POD name I<MyModule>,
+whereas F<$HOME/perl5lib/Myclass/Subclass.pm> would be
+I<Myclass::Subclass>. The name information can be used for POD
+translators.
+
+Only text files containing at least one valid POD command are found.
+
+A warning is printed if more than one POD file with the same POD name
+is found, e.g. F<CPAN.pm> in different directories. This usually
+indicates duplicate occurrences of modules in the I<@INC> search path.
+
+B<OPTIONS> The first argument for B<pod_find> may be a hash reference
+with options. The rest are either directories that are searched
+recursively or files. The POD names of files are the plain basenames
+with any Perl-like extension (.pm, .pl, .pod) stripped.
+
+=over 4
+
+=item C<-verbose =E<gt> 1>
+
+Print progress information while scanning.
+
+=item C<-perl =E<gt> 1>
+
+Apply Perl-specific heuristics to find the correct PODs. This includes
+stripping Perl-like extensions, omitting subdirectories that are numeric
+but do I<not> match the current Perl interpreter's version id, suppressing
+F<site_perl> as a module hierarchy name etc.
+
+=item C<-script =E<gt> 1>
+
+Search for PODs in the current Perl interpreter's installation
+B<scriptdir>. This is taken from the local L<Config|Config> module.
+
+=item C<-inc =E<gt> 1>
+
+Search for PODs in the current Perl interpreter's I<@INC> paths. This
+automatically considers paths specified in the C<PERL5LIB> environment
+as this is included in I<@INC> by the Perl interpreter itself.
+
+=back
+
+=cut
+
+# return a hash of the POD files found
+# first argument may be a hashref (options),
+# rest is a list of directories to search recursively
+sub pod_find
+{
+ my %opts;
+ if(ref $_[0]) {
+ %opts = %{shift()};
+ }
+
+ $opts{-verbose} ||= 0;
+ $opts{-perl} ||= 0;
+
+ my (@search) = @_;
+
+ if($opts{-script}) {
+ require Config;
+ push(@search, $Config::Config{scriptdir})
+ if -d $Config::Config{scriptdir};
+ $opts{-perl} = 1;
+ }
+
+ if($opts{-inc}) {
+ if ($^O eq 'MacOS') {
+ # tolerate '.', './some_dir' and '(../)+some_dir' on Mac OS
+ my @new_INC = @INC;
+ for (@new_INC) {
+ if ( $_ eq '.' ) {
+ $_ = ':';
+ } elsif ( $_ =~ s{^((?:\.\./)+)}{':' x (length($1)/3)}e ) {
+ $_ = ':'. $_;
+ } else {
+ $_ =~ s{^\./}{:};
+ }
+ }
+ push(@search, grep($_ ne File::Spec->curdir, @new_INC));
+ } else {
+ push(@search, grep($_ ne File::Spec->curdir, @INC));
+ }
+
+ $opts{-perl} = 1;
+ }
+
+ if($opts{-perl}) {
+ require Config;
+ # this code simplifies the POD name for Perl modules:
+ # * remove "site_perl"
+ # * remove e.g. "i586-linux" (from 'archname')
+ # * remove e.g. 5.00503
+ # * remove pod/ if followed by *.pod (e.g. in pod/perlfunc.pod)
+
+ # Mac OS:
+ # * remove ":?site_perl:"
+ # * remove :?pod: if followed by *.pod (e.g. in :pod:perlfunc.pod)
+
+ if ($^O eq 'MacOS') {
+ $SIMPLIFY_RX =
+ qq!^(?i:\:?site_perl\:|\:?pod\:(?=.*?\\.pod\\z))*!;
+ } else {
+ $SIMPLIFY_RX =
+ qq!^(?i:site(_perl)?/|\Q$Config::Config{archname}\E/|\\d+\\.\\d+([_.]?\\d+)?/|pod/(?=.*?\\.pod\\z))*!;
+ }
+ }
+
+ my %dirs_visited;
+ my %pods;
+ my %names;
+ my $pwd = cwd();
+
+ foreach my $try (@search) {
+ unless(File::Spec->file_name_is_absolute($try)) {
+ # make path absolute
+ $try = File::Spec->catfile($pwd,$try);
+ }
+ # simplify path
+ # on VMS canonpath will vmsify:[the.path], but File::Find::find
+ # wants /unixy/paths
+ $try = File::Spec->canonpath($try) if ($^O ne 'VMS');
+ $try = VMS::Filespec::unixify($try) if ($^O eq 'VMS');
+ my $name;
+ if(-f $try) {
+ if($name = _check_and_extract_name($try, $opts{-verbose})) {
+ _check_for_duplicates($try, $name, \%names, \%pods);
+ }
+ next;
+ }
+ my $root_rx = $^O eq 'MacOS' ? qq!^\Q$try\E! : qq!^\Q$try\E/!;
+ File::Find::find( sub {
+ my $item = $File::Find::name;
+ if(-d) {
+ if($item =~ m{/(?:RCS|CVS|SCCS|\.svn)$}) {
+ $File::Find::prune = 1;
+ return;
+ }
+ elsif($dirs_visited{$item}) {
+ warn "Directory '$item' already seen, skipping.\n"
+ if($opts{-verbose});
+ $File::Find::prune = 1;
+ return;
+ }
+ else {
+ $dirs_visited{$item} = 1;
+ }
+ if($opts{-perl} && /^(\d+\.[\d_]+)\z/s && eval "$1" != $]) {
+ $File::Find::prune = 1;
+ warn "Perl $] version mismatch on $_, skipping.\n"
+ if($opts{-verbose});
+ }
+ return;
+ }
+ if($name = _check_and_extract_name($item, $opts{-verbose}, $root_rx)) {
+ _check_for_duplicates($item, $name, \%names, \%pods);
+ }
+ }, $try); # end of File::Find::find
+ }
+ chdir $pwd;
+ return %pods;
+}
+
+sub _check_for_duplicates {
+ my ($file, $name, $names_ref, $pods_ref) = @_;
+ if($$names_ref{$name}) {
+ warn "Duplicate POD found (shadowing?): $name ($file)\n";
+ warn ' Already seen in ',
+ join(' ', grep($$pods_ref{$_} eq $name, keys %$pods_ref)),"\n";
+ }
+ else {
+ $$names_ref{$name} = 1;
+ }
+ return $$pods_ref{$file} = $name;
+}
+
+sub _check_and_extract_name {
+ my ($file, $verbose, $root_rx) = @_;
+
+ # check extension or executable flag
+ # this involves testing the .bat extension on Win32!
+ unless(-f $file && -T $file && ($file =~ /\.(pod|pm|plx?)\z/i || -x $file )) {
+ return;
+ }
+
+ return unless contains_pod($file,$verbose);
+
+ # strip non-significant path components
+ # TODO what happens on e.g. Win32?
+ my $name = $file;
+ if(defined $root_rx) {
+ $name =~ s/$root_rx//s;
+ $name =~ s/$SIMPLIFY_RX//s if(defined $SIMPLIFY_RX);
+ }
+ else {
+ if ($^O eq 'MacOS') {
+ $name =~ s/^.*://s;
+ } else {
+ $name =~ s{^.*/}{}s;
+ }
+ }
+ _simplify($name);
+ $name =~ s{/+}{::}g;
+ if ($^O eq 'MacOS') {
+ $name =~ s{:+}{::}g; # : -> ::
+ } else {
+ $name =~ s{/+}{::}g; # / -> ::
+ }
+ return $name;
+}
+
+=head2 C<simplify_name( $str )>
+
+The function B<simplify_name> is equivalent to B<basename>, but also
+strips Perl-like extensions (.pm, .pl, .pod) and extensions like
+F<.bat>, F<.cmd> on Win32 and OS/2, or F<.com> on VMS, respectively.
+
+=cut
+
+# basic simplification of the POD name:
+# basename & strip extension
+sub simplify_name {
+ my ($str) = @_;
+ # remove all path components
+ if ($^O eq 'MacOS') {
+ $str =~ s/^.*://s;
+ } else {
+ $str =~ s{^.*/}{}s;
+ }
+ _simplify($str);
+ return $str;
+}
+
+# internal sub only
+sub _simplify {
+ # strip Perl's own extensions
+ $_[0] =~ s/\.(pod|pm|plx?)\z//i;
+ # strip meaningless extensions on Win32 and OS/2
+ $_[0] =~ s/\.(bat|exe|cmd)\z//i if($^O =~ /mswin|os2/i);
+ # strip meaningless extensions on VMS
+ $_[0] =~ s/\.(com)\z//i if($^O eq 'VMS');
+}
+
+# contribution from Tim Jenness <t.jenness at jach.hawaii.edu>
+
+=head2 C<pod_where( { %opts }, $pod )>
+
+Returns the location of a pod document given a search directory
+and a module (e.g. C<File::Find>) or script (e.g. C<perldoc>) name.
+
+Options:
+
+=over 4
+
+=item C<-inc =E<gt> 1>
+
+Search @INC for the pod and also the C<scriptdir> defined in the
+L<Config|Config> module.
+
+=item C<-dirs =E<gt> [ $dir1, $dir2, ... ]>
+
+Reference to an array of search directories. These are searched in order
+before looking in C<@INC> (if B<-inc>). Current directory is used if
+none are specified.
+
+=item C<-verbose =E<gt> 1>
+
+List directories as they are searched
+
+=back
+
+Returns the full path of the first occurrence to the file.
+Package names (eg 'A::B') are automatically converted to directory
+names in the selected directory. (eg on unix 'A::B' is converted to
+'A/B'). Additionally, '.pm', '.pl' and '.pod' are appended to the
+search automatically if required.
+
+A subdirectory F<pod/> is also checked if it exists in any of the given
+search directories. This ensures that e.g. L<perlfunc|perlfunc> is
+found.
+
+It is assumed that if a module name is supplied, that that name
+matches the file name. Pods are not opened to check for the 'NAME'
+entry.
+
+A check is made to make sure that the file that is found does
+contain some pod documentation.
+
+=cut
+
+sub pod_where {
+
+ # default options
+ my %options = (
+ '-inc' => 0,
+ '-verbose' => 0,
+ '-dirs' => [ File::Spec->curdir ],
+ );
+
+ # Check for an options hash as first argument
+ if (defined $_[0] && ref($_[0]) eq 'HASH') {
+ my $opt = shift;
+
+ # Merge default options with supplied options
+ %options = (%options, %$opt);
+ }
+
+ # Check usage
+ carp 'Usage: pod_where({options}, $pod)' unless (scalar(@_));
+
+ # Read argument
+ my $pod = shift;
+
+ # Split on :: and then join the name together using File::Spec
+ my @parts = split (/::/, $pod);
+
+ # Get full directory list
+ my @search_dirs = @{ $options{'-dirs'} };
+
+ if ($options{'-inc'}) {
+
+ require Config;
+
+ # Add @INC
+ if ($^O eq 'MacOS' && $options{'-inc'}) {
+ # tolerate '.', './some_dir' and '(../)+some_dir' on Mac OS
+ my @new_INC = @INC;
+ for (@new_INC) {
+ if ( $_ eq '.' ) {
+ $_ = ':';
+ } elsif ( $_ =~ s{^((?:\.\./)+)}{':' x (length($1)/3)}e ) {
+ $_ = ':'. $_;
+ } else {
+ $_ =~ s{^\./}{:};
+ }
+ }
+ push (@search_dirs, @new_INC);
+ } elsif ($options{'-inc'}) {
+ push (@search_dirs, @INC);
+ }
+
+ # Add location of pod documentation for perl man pages (eg perlfunc)
+ # This is a pod directory in the private install tree
+ #my $perlpoddir = File::Spec->catdir($Config::Config{'installprivlib'},
+ # 'pod');
+ #push (@search_dirs, $perlpoddir)
+ # if -d $perlpoddir;
+
+ # Add location of binaries such as pod2text
+ push (@search_dirs, $Config::Config{'scriptdir'})
+ if -d $Config::Config{'scriptdir'};
+ }
+
+ warn 'Search path is: '.join(' ', @search_dirs)."\n"
+ if $options{'-verbose'};
+
+ # Loop over directories
+ Dir: foreach my $dir ( @search_dirs ) {
+
+ # Don't bother if can't find the directory
+ if (-d $dir) {
+ warn "Looking in directory $dir\n"
+ if $options{'-verbose'};
+
+ # Now concatenate this directory with the pod we are searching for
+ my $fullname = File::Spec->catfile($dir, @parts);
+ warn "Filename is now $fullname\n"
+ if $options{'-verbose'};
+
+ # Loop over possible extensions
+ foreach my $ext ('', '.pod', '.pm', '.pl') {
+ my $fullext = $fullname . $ext;
+ if (-f $fullext &&
+ contains_pod($fullext, $options{'-verbose'}) ) {
+ warn "FOUND: $fullext\n" if $options{'-verbose'};
+ return $fullext;
+ }
+ }
+ } else {
+ warn "Directory $dir does not exist\n"
+ if $options{'-verbose'};
+ next Dir;
+ }
+ # for some strange reason the path on MacOS/darwin/cygwin is
+ # 'pods' not 'pod'
+ # this could be the case also for other systems that
+ # have a case-tolerant file system, but File::Spec
+ # does not recognize 'darwin' yet. And cygwin also has "pods",
+ # but is not case tolerant. Oh well...
+ if((File::Spec->case_tolerant || $^O =~ /macos|darwin|cygwin/i)
+ && -d File::Spec->catdir($dir,'pods')) {
+ $dir = File::Spec->catdir($dir,'pods');
+ redo Dir;
+ }
+ if(-d File::Spec->catdir($dir,'pod')) {
+ $dir = File::Spec->catdir($dir,'pod');
+ redo Dir;
+ }
+ }
+ # No match;
+ return;
+}
+
+=head2 C<contains_pod( $file , $verbose )>
+
+Returns true if the supplied filename (not POD module) contains some pod
+information.
+
+=cut
+
+sub contains_pod {
+ my $file = shift;
+ my $verbose = 0;
+ $verbose = shift if @_;
+
+ # check for one line of POD
+ my $podfh;
+ if ($] < 5.006) {
+ $podfh = gensym();
+ }
+
+ unless(open($podfh,"<$file")) {
+ warn "Error: $file is unreadable: $!\n";
+ return;
+ }
+
+ local $/ = undef;
+ my $pod = <$podfh>;
+ close($podfh) || die "Error closing $file: $!\n";
+ unless($pod =~ /^=(head\d|pod|over|item|cut)\b/m) {
+ warn "No POD in $file, skipping.\n"
+ if($verbose);
+ return 0;
+ }
+
+ return 1;
+}
+
+=head1 AUTHOR
+
+Please report bugs using L<http://rt.cpan.org>.
+
+Marek Rouchal E<lt>marekr at cpan.orgE<gt>,
+heavily borrowing code from Nick Ing-Simmons' PodToHtml.
+
+Tim Jenness E<lt>t.jenness at jach.hawaii.eduE<gt> provided
+C<pod_where> and C<contains_pod>.
+
+=head1 SEE ALSO
+
+L<Pod::Parser>, L<Pod::Checker>, L<perldoc>
+
+=cut
+
+1;
+
Index: trunk/contrib/perl/lib/Pod/Functions.pm
===================================================================
--- trunk/contrib/perl/lib/Pod/Functions.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Pod/Functions.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Pod/Functions.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/lib/Pod/Html.pm (from rev 6437, vendor/perl/5.18.1/lib/Pod/Html.pm)
===================================================================
--- trunk/contrib/perl/lib/Pod/Html.pm (rev 0)
+++ trunk/contrib/perl/lib/Pod/Html.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,2233 @@
+package Pod::Html;
+use strict;
+require Exporter;
+
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
+$VERSION = 1.09;
+ at ISA = qw(Exporter);
+ at EXPORT = qw(pod2html htmlify);
+ at EXPORT_OK = qw(anchorify);
+
+use Carp;
+use Config;
+use Cwd;
+use File::Spec;
+use File::Spec::Unix;
+use Getopt::Long;
+
+use locale; # make \w work right in non-ASCII lands
+
+=head1 NAME
+
+Pod::Html - module to convert pod files to HTML
+
+=head1 SYNOPSIS
+
+ use Pod::Html;
+ pod2html([options]);
+
+=head1 DESCRIPTION
+
+Converts files from pod format (see L<perlpod>) to HTML format. It
+can automatically generate indexes and cross-references, and it keeps
+a cache of things it knows how to cross-reference.
+
+=head1 FUNCTIONS
+
+=head2 pod2html
+
+ pod2html("pod2html",
+ "--podpath=lib:ext:pod:vms",
+ "--podroot=/usr/src/perl",
+ "--htmlroot=/perl/nmanual",
+ "--libpods=perlfunc:perlguts:perlvar:perlrun:perlop",
+ "--recurse",
+ "--infile=foo.pod",
+ "--outfile=/perl/nmanual/foo.html");
+
+pod2html takes the following arguments:
+
+=over 4
+
+=item backlink
+
+ --backlink="Back to Top"
+
+Adds "Back to Top" links in front of every C<head1> heading (except for
+the first). By default, no backlinks are generated.
+
+=item cachedir
+
+ --cachedir=name
+
+Creates the item and directory caches in the given directory.
+
+=item css
+
+ --css=stylesheet
+
+Specify the URL of a cascading style sheet. Also disables all HTML/CSS
+C<style> attributes that are output by default (to avoid conflicts).
+
+=item flush
+
+ --flush
+
+Flushes the item and directory caches.
+
+=item header
+
+ --header
+ --noheader
+
+Creates header and footer blocks containing the text of the C<NAME>
+section. By default, no headers are generated.
+
+=item help
+
+ --help
+
+Displays the usage message.
+
+=item hiddendirs
+
+ --hiddendirs
+ --nohiddendirs
+
+Include hidden directories in the search for POD's in podpath if recurse
+is set.
+The default is not to traverse any directory whose name begins with C<.>.
+See L</"podpath"> and L</"recurse">.
+
+[This option is for backward compatibility only.
+It's hard to imagine that one would usefully create a module with a
+name component beginning with C<.>.]
+
+=item htmldir
+
+ --htmldir=name
+
+Sets the directory in which the resulting HTML file is placed. This
+is used to generate relative links to other files. Not passing this
+causes all links to be absolute, since this is the value that tells
+Pod::Html the root of the documentation tree.
+
+=item htmlroot
+
+ --htmlroot=name
+
+Sets the base URL for the HTML files. When cross-references are made,
+the HTML root is prepended to the URL.
+
+=item index
+
+ --index
+ --noindex
+
+Generate an index at the top of the HTML file. This is the default
+behaviour.
+
+=item infile
+
+ --infile=name
+
+Specify the pod file to convert. Input is taken from STDIN if no
+infile is specified.
+
+=item libpods
+
+ --libpods=name:...:name
+
+List of page names (eg, "perlfunc") which contain linkable C<=item>s.
+
+=item netscape
+
+ --netscape
+ --nonetscape
+
+B<Deprecated>, has no effect. For backwards compatibility only.
+
+=item outfile
+
+ --outfile=name
+
+Specify the HTML file to create. Output goes to STDOUT if no outfile
+is specified.
+
+=item podpath
+
+ --podpath=name:...:name
+
+Specify which subdirectories of the podroot contain pod files whose
+HTML converted forms can be linked to in cross references.
+
+=item podroot
+
+ --podroot=name
+
+Specify the base directory for finding library pods.
+
+=item quiet
+
+ --quiet
+ --noquiet
+
+Don't display I<mostly harmless> warning messages. These messages
+will be displayed by default. But this is not the same as C<verbose>
+mode.
+
+=item recurse
+
+ --recurse
+ --norecurse
+
+Recurse into subdirectories specified in podpath (default behaviour).
+
+=item title
+
+ --title=title
+
+Specify the title of the resulting HTML file.
+
+=item verbose
+
+ --verbose
+ --noverbose
+
+Display progress messages. By default, they won't be displayed.
+
+=back
+
+=head2 htmlify
+
+ htmlify($heading);
+
+Converts a pod section specification to a suitable section specification
+for HTML. Note that we keep spaces and special characters except
+C<", ?> (Netscape problem) and the hyphen (writer's problem...).
+
+=head2 anchorify
+
+ anchorify(@heading);
+
+Similar to C<htmlify()>, but turns non-alphanumerics into underscores. Note
+that C<anchorify()> is not exported by default.
+
+=head1 ENVIRONMENT
+
+Uses C<$Config{pod2html}> to setup default options.
+
+=head1 AUTHOR
+
+Tom Christiansen, E<lt>tchrist at perl.comE<gt>.
+
+=head1 SEE ALSO
+
+L<perlpod>
+
+=head1 COPYRIGHT
+
+This program is distributed under the Artistic License.
+
+=cut
+
+my($Cachedir);
+my($Dircache, $Itemcache);
+my @Begin_Stack;
+my @Libpods;
+my($Htmlroot, $Htmldir, $Htmlfile, $Htmlfileurl);
+my($Podfile, @Podpath, $Podroot);
+my $Css;
+
+my $Recurse;
+my $Quiet;
+my $HiddenDirs;
+my $Verbose;
+my $Doindex;
+
+my $Backlink;
+my($Listlevel, @Listtype);
+my $ListNewTerm;
+use vars qw($Ignore); # need to localize it later.
+
+my(%Items_Named, @Items_Seen);
+my($Title, $Header);
+
+my $Top;
+my $Paragraph;
+
+my %Sections;
+
+# Caches
+my %Pages = (); # associative array used to find the location
+ # of pages referenced by L<> links.
+my %Items = (); # associative array used to find the location
+ # of =item directives referenced by C<> links
+
+my %Local_Items;
+my $Is83;
+
+my $Curdir = File::Spec->curdir;
+
+init_globals();
+
+sub init_globals {
+ $Cachedir = "."; # The directory to which item and directory
+ # caches will be written.
+
+ $Dircache = "pod2htmd.tmp";
+ $Itemcache = "pod2htmi.tmp";
+
+ @Begin_Stack = (); # begin/end stack
+
+ @Libpods = (); # files to search for links from C<> directives
+ $Htmlroot = "/"; # http-server base directory from which all
+ # relative paths in $podpath stem.
+ $Htmldir = ""; # The directory to which the html pages
+ # will (eventually) be written.
+ $Htmlfile = ""; # write to stdout by default
+ $Htmlfileurl = ""; # The url that other files would use to
+ # refer to this file. This is only used
+ # to make relative urls that point to
+ # other files.
+
+ $Podfile = ""; # read from stdin by default
+ @Podpath = (); # list of directories containing library pods.
+ $Podroot = $Curdir; # filesystem base directory from which all
+ # relative paths in $podpath stem.
+ $Css = ''; # Cascading style sheet
+ $Recurse = 1; # recurse on subdirectories in $podpath.
+ $Quiet = 0; # not quiet by default
+ $Verbose = 0; # not verbose by default
+ $Doindex = 1; # non-zero if we should generate an index
+ $Backlink = ''; # text for "back to top" links
+ $Listlevel = 0; # current list depth
+ @Listtype = (); # list types for open lists
+ $ListNewTerm = 0; # indicates new term in definition list; used
+ # to correctly open/close <dd> tags
+ $Ignore = 1; # whether or not to format text. we don't
+ # format text until we hit our first pod
+ # directive.
+
+ @Items_Seen = (); # for multiples of the same item in perlfunc
+ %Items_Named = ();
+ $Header = 0; # produce block header/footer
+ $Title = ''; # title to give the pod(s)
+ $Top = 1; # true if we are at the top of the doc. used
+ # to prevent the first <hr /> directive.
+ $Paragraph = ''; # which paragraph we're processing (used
+ # for error messages)
+ %Sections = (); # sections within this page
+
+ %Local_Items = ();
+ $Is83 = $^O eq 'dos'; # Is it an 8.3 filesystem?
+}
+
+#
+# clean_data: global clean-up of pod data
+#
+sub clean_data($){
+ my( $dataref ) = @_;
+ for my $i ( 0..$#{$dataref} ) {
+ ${$dataref}[$i] =~ s/\s+\Z//;
+
+ # have a look for all-space lines
+ if( ${$dataref}[$i] =~ /^\s+$/m and $dataref->[$i] !~ /^\s/ ){
+ my @chunks = split( /^\s+$/m, ${$dataref}[$i] );
+ splice( @$dataref, $i, 1, @chunks );
+ }
+ }
+}
+
+
+sub pod2html {
+ local(@ARGV) = @_;
+ local($/);
+ local $_;
+
+ init_globals();
+
+ $Is83 = 0 if (defined (&Dos::UseLFN) && Dos::UseLFN());
+
+ # cache of %Pages and %Items from last time we ran pod2html
+
+ #undef $opt_help if defined $opt_help;
+
+ # parse the command-line parameters
+ parse_command_line();
+
+ # escape the backlink argument (same goes for title but is done later...)
+ $Backlink = html_escape($Backlink) if defined $Backlink;
+
+ # set some variables to their default values if necessary
+ local *POD;
+ unless (@ARGV && $ARGV[0]) {
+ $Podfile = "-" unless $Podfile; # stdin
+ open(POD, "<$Podfile")
+ || die "$0: cannot open $Podfile file for input: $!\n";
+ } else {
+ $Podfile = $ARGV[0]; # XXX: might be more filenames
+ *POD = *ARGV;
+ }
+ $Htmlfile = "-" unless $Htmlfile; # stdout
+ $Htmlroot = "" if $Htmlroot eq "/"; # so we don't get a //
+ $Htmldir =~ s#/\z## ; # so we don't get a //
+ if ( $Htmlroot eq ''
+ && defined( $Htmldir )
+ && $Htmldir ne ''
+ && substr( $Htmlfile, 0, length( $Htmldir ) ) eq $Htmldir
+ )
+ {
+ # Set the 'base' url for this file, so that we can use it
+ # as the location from which to calculate relative links
+ # to other files. If this is '', then absolute links will
+ # be used throughout.
+ $Htmlfileurl= "$Htmldir/" . substr( $Htmlfile, length( $Htmldir ) + 1);
+ }
+
+ # read the pod a paragraph at a time
+ warn "Scanning for sections in input file(s)\n" if $Verbose;
+ $/ = "";
+ my @poddata = <POD>;
+ close(POD);
+
+ # be eol agnostic
+ for (@poddata) {
+ if (/\r/) {
+ if (/\r\n/) {
+ @poddata = map { s/\r\n/\n/g;
+ /\n\n/ ?
+ map { "$_\n\n" } split /\n\n/ :
+ $_ } @poddata;
+ } else {
+ @poddata = map { s/\r/\n/g;
+ /\n\n/ ?
+ map { "$_\n\n" } split /\n\n/ :
+ $_ } @poddata;
+ }
+ last;
+ }
+ }
+
+ clean_data( \@poddata );
+
+ # scan the pod for =head[1-6] directives and build an index
+ my $index = scan_headings(\%Sections, @poddata);
+
+ unless($index) {
+ warn "No headings in $Podfile\n" if $Verbose;
+ }
+
+ # open the output file
+ open(HTML, ">$Htmlfile")
+ || die "$0: cannot open $Htmlfile file for output: $!\n";
+
+ # put a title in the HTML file if one wasn't specified
+ if ($Title eq '') {
+ TITLE_SEARCH: {
+ for (my $i = 0; $i < @poddata; $i++) {
+ if ($poddata[$i] =~ /^=head1\s*NAME\b/m) {
+ for my $para ( @poddata[$i, $i+1] ) {
+ last TITLE_SEARCH
+ if ($Title) = $para =~ /(\S+\s+-+.*\S)/s;
+ }
+ }
+
+ }
+ }
+ }
+ if (!$Title and $Podfile =~ /\.pod\z/) {
+ # probably a split pod so take first =head[12] as title
+ for (my $i = 0; $i < @poddata; $i++) {
+ last if ($Title) = $poddata[$i] =~ /^=head[12]\s*(.*)/;
+ }
+ warn "adopted '$Title' as title for $Podfile\n"
+ if $Verbose and $Title;
+ }
+ if ($Title) {
+ $Title =~ s/\s*\(.*\)//;
+ } else {
+ warn "$0: no title for $Podfile.\n" unless $Quiet;
+ $Podfile =~ /^(.*)(\.[^.\/]+)?\z/s;
+ $Title = ($Podfile eq "-" ? 'No Title' : $1);
+ warn "using $Title" if $Verbose;
+ }
+ $Title = html_escape($Title);
+
+ my $csslink = '';
+ my $bodystyle = ' style="background-color: white"';
+ my $tdstyle = ' style="background-color: #cccccc"';
+
+ if ($Css) {
+ $csslink = qq(\n<link rel="stylesheet" href="$Css" type="text/css" />);
+ $csslink =~ s,\\,/,g;
+ $csslink =~ s,(/.):,$1|,;
+ $bodystyle = '';
+ $tdstyle = '';
+ }
+
+ my $block = $Header ? <<END_OF_BLOCK : '';
+<table border="0" width="100%" cellspacing="0" cellpadding="3">
+<tr><td class="block"$tdstyle valign="middle">
+<big><strong><span class="block"> $Title</span></strong></big>
+</td></tr>
+</table>
+END_OF_BLOCK
+
+ print HTML <<END_OF_HEAD;
+<?xml version="1.0" ?>
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml">
+<head>
+<title>$Title</title>$csslink
+<meta http-equiv="content-type" content="text/html; charset=utf-8" />
+<link rev="made" href="mailto:$Config{perladmin}" />
+</head>
+
+<body$bodystyle>
+$block
+END_OF_HEAD
+
+ # load/reload/validate/cache %Pages and %Items
+ get_cache($Dircache, $Itemcache, \@Podpath, $Podroot, $Recurse);
+
+ # scan the pod for =item directives
+ scan_items( \%Local_Items, "", @poddata);
+
+ # put an index at the top of the file. note, if $Doindex is 0 we
+ # still generate an index, but surround it with an html comment.
+ # that way some other program can extract it if desired.
+ $index =~ s/--+/-/g;
+
+ my $hr = ($Doindex and $index) ? qq(<hr name="index" />) : "";
+
+ unless ($Doindex)
+ {
+ $index = qq(<!--\n$index\n-->\n);
+ }
+
+ print HTML << "END_OF_INDEX";
+
+<!-- INDEX BEGIN -->
+<div name="index">
+<p><a name=\"__index__\"></a></p>
+$index
+$hr
+</div>
+<!-- INDEX END -->
+
+END_OF_INDEX
+
+ # now convert this file
+ my $after_item; # set to true after an =item
+ warn "Converting input file $Podfile\n" if $Verbose;
+ foreach my $i (0..$#poddata){
+ $_ = $poddata[$i];
+ $Paragraph = $i+1;
+ if (/^(=.*)/s) { # is it a pod directive?
+ $Ignore = 0;
+ $after_item = 0;
+ $_ = $1;
+ if (/^=begin\s+(\S+)\s*(.*)/si) {# =begin
+ process_begin($1, $2);
+ } elsif (/^=end\s+(\S+)\s*(.*)/si) {# =end
+ process_end($1, $2);
+ } elsif (/^=cut/) { # =cut
+ process_cut();
+ } elsif (/^=pod/) { # =pod
+ process_pod();
+ } else {
+ next if @Begin_Stack && $Begin_Stack[-1] ne 'html';
+
+ if (/^=(head[1-6])\s+(.*\S)/s) { # =head[1-6] heading
+ process_head( $1, $2, $Doindex && $index );
+ } elsif (/^=item\s*(.*\S)?/sm) { # =item text
+ process_item( $1 );
+ $after_item = 1;
+ } elsif (/^=over\s*(.*)/) { # =over N
+ process_over();
+ } elsif (/^=back/) { # =back
+ process_back();
+ } elsif (/^=for\s+(\S+)\s*(.*)/si) {# =for
+ process_for($1,$2);
+ } else {
+ /^=(\S*)\s*/;
+ warn "$0: $Podfile: unknown pod directive '$1' in "
+ . "paragraph $Paragraph. ignoring.\n" unless $Quiet;
+ }
+ }
+ $Top = 0;
+ }
+ else {
+ next if $Ignore;
+ next if @Begin_Stack && $Begin_Stack[-1] ne 'html';
+ print HTML and next if @Begin_Stack && $Begin_Stack[-1] eq 'html';
+ my $text = $_;
+
+ # Open tag for definition list as we have something to put in it
+ if( $ListNewTerm ){
+ print HTML "<dd>\n";
+ $ListNewTerm = 0;
+ }
+
+ if( $text =~ /\A\s+/ ){
+ process_pre( \$text );
+ print HTML "<pre>\n$text</pre>\n";
+
+ } else {
+ process_text( \$text );
+
+ # experimental: check for a paragraph where all lines
+ # have some ...\t...\t...\n pattern
+ if( $text =~ /\t/ ){
+ my @lines = split( "\n", $text );
+ if( @lines > 1 ){
+ my $all = 2;
+ foreach my $line ( @lines ){
+ if( $line =~ /\S/ && $line !~ /\t/ ){
+ $all--;
+ last if $all == 0;
+ }
+ }
+ if( $all > 0 ){
+ $text =~ s/\t+/<td>/g;
+ $text =~ s/^/<tr><td>/gm;
+ $text = '<table cellspacing="0" cellpadding="0">' .
+ $text . '</table>';
+ }
+ }
+ }
+ ## end of experimental
+
+ print HTML "<p>$text</p>\n";
+ }
+ $after_item = 0;
+ }
+ }
+
+ # finish off any pending directives
+ finish_list();
+
+ # link to page index
+ print HTML "<p><a href=\"#__index__\"><small>$Backlink</small></a></p>\n"
+ if $Doindex and $index and $Backlink;
+
+ print HTML <<END_OF_TAIL;
+$block
+</body>
+
+</html>
+END_OF_TAIL
+
+ # close the html file
+ close(HTML);
+
+ warn "Finished\n" if $Verbose;
+}
+
+##############################################################################
+
+sub usage {
+ my $podfile = shift;
+ warn "$0: $podfile: @_\n" if @_;
+ die <<END_OF_USAGE;
+Usage: $0 --help --htmlroot=<name> --infile=<name> --outfile=<name>
+ --podpath=<name>:...:<name> --podroot=<name>
+ --libpods=<name>:...:<name> --recurse --verbose --index
+ --netscape --norecurse --noindex --cachedir=<name>
+
+ --backlink - set text for "back to top" links (default: none).
+ --cachedir - directory for the item and directory cache files.
+ --css - stylesheet URL
+ --flush - flushes the item and directory caches.
+ --[no]header - produce block header/footer (default is no headers).
+ --help - prints this message.
+ --hiddendirs - search hidden directories in podpath
+ --htmldir - directory for resulting HTML files.
+ --htmlroot - http-server base directory from which all relative paths
+ in podpath stem (default is /).
+ --[no]index - generate an index at the top of the resulting html
+ (default behaviour).
+ --infile - filename for the pod to convert (input taken from stdin
+ by default).
+ --libpods - colon-separated list of pages to search for =item pod
+ directives in as targets of C<> and implicit links (empty
+ by default). note, these are not filenames, but rather
+ page names like those that appear in L<> links.
+ --outfile - filename for the resulting html file (output sent to
+ stdout by default).
+ --podpath - colon-separated list of directories containing library
+ pods (empty by default).
+ --podroot - filesystem base directory from which all relative paths
+ in podpath stem (default is .).
+ --[no]quiet - suppress some benign warning messages (default is off).
+ --[no]recurse - recurse on those subdirectories listed in podpath
+ (default behaviour).
+ --title - title that will appear in resulting html file.
+ --[no]verbose - self-explanatory (off by default).
+ --[no]netscape - deprecated, has no effect. for backwards compatibility only.
+
+END_OF_USAGE
+
+}
+
+sub parse_command_line {
+ my ($opt_backlink,$opt_cachedir,$opt_css,$opt_flush,$opt_header,$opt_help,
+ $opt_htmldir,$opt_htmlroot,$opt_index,$opt_infile,$opt_libpods,
+ $opt_netscape,$opt_outfile,$opt_podpath,$opt_podroot,$opt_quiet,
+ $opt_recurse,$opt_title,$opt_verbose,$opt_hiddendirs);
+
+ unshift @ARGV, split ' ', $Config{pod2html} if $Config{pod2html};
+ my $result = GetOptions(
+ 'backlink=s' => \$opt_backlink,
+ 'cachedir=s' => \$opt_cachedir,
+ 'css=s' => \$opt_css,
+ 'flush' => \$opt_flush,
+ 'header!' => \$opt_header,
+ 'help' => \$opt_help,
+ 'hiddendirs!'=> \$opt_hiddendirs,
+ 'htmldir=s' => \$opt_htmldir,
+ 'htmlroot=s' => \$opt_htmlroot,
+ 'index!' => \$opt_index,
+ 'infile=s' => \$opt_infile,
+ 'libpods=s' => \$opt_libpods,
+ 'netscape!' => \$opt_netscape,
+ 'outfile=s' => \$opt_outfile,
+ 'podpath=s' => \$opt_podpath,
+ 'podroot=s' => \$opt_podroot,
+ 'quiet!' => \$opt_quiet,
+ 'recurse!' => \$opt_recurse,
+ 'title=s' => \$opt_title,
+ 'verbose!' => \$opt_verbose,
+ );
+ usage("-", "invalid parameters") if not $result;
+
+ usage("-") if defined $opt_help; # see if the user asked for help
+ $opt_help = ""; # just to make -w shut-up.
+
+ @Podpath = split(":", $opt_podpath) if defined $opt_podpath;
+ @Libpods = split(":", $opt_libpods) if defined $opt_libpods;
+
+ $Backlink = $opt_backlink if defined $opt_backlink;
+ $Cachedir = $opt_cachedir if defined $opt_cachedir;
+ $Css = $opt_css if defined $opt_css;
+ $Header = $opt_header if defined $opt_header;
+ $Htmldir = $opt_htmldir if defined $opt_htmldir;
+ $Htmlroot = $opt_htmlroot if defined $opt_htmlroot;
+ $Doindex = $opt_index if defined $opt_index;
+ $Podfile = $opt_infile if defined $opt_infile;
+ $HiddenDirs = $opt_hiddendirs if defined $opt_hiddendirs;
+ $Htmlfile = $opt_outfile if defined $opt_outfile;
+ $Podroot = $opt_podroot if defined $opt_podroot;
+ $Quiet = $opt_quiet if defined $opt_quiet;
+ $Recurse = $opt_recurse if defined $opt_recurse;
+ $Title = $opt_title if defined $opt_title;
+ $Verbose = $opt_verbose if defined $opt_verbose;
+
+ warn "Flushing item and directory caches\n"
+ if $opt_verbose && defined $opt_flush;
+ $Dircache = "$Cachedir/pod2htmd.tmp";
+ $Itemcache = "$Cachedir/pod2htmi.tmp";
+ if (defined $opt_flush) {
+ 1 while unlink($Dircache, $Itemcache);
+ }
+}
+
+
+my $Saved_Cache_Key;
+
+sub get_cache {
+ my($dircache, $itemcache, $podpath, $podroot, $recurse) = @_;
+ my @cache_key_args = @_;
+
+ # A first-level cache:
+ # Don't bother reading the cache files if they still apply
+ # and haven't changed since we last read them.
+
+ my $this_cache_key = cache_key(@cache_key_args);
+
+ return if $Saved_Cache_Key and $this_cache_key eq $Saved_Cache_Key;
+
+ # load the cache of %Pages and %Items if possible. $tests will be
+ # non-zero if successful.
+ my $tests = 0;
+ if (-f $dircache && -f $itemcache) {
+ warn "scanning for item cache\n" if $Verbose;
+ $tests = load_cache($dircache, $itemcache, $podpath, $podroot);
+ }
+
+ # if we didn't succeed in loading the cache then we must (re)build
+ # %Pages and %Items.
+ if (!$tests) {
+ warn "scanning directories in pod-path\n" if $Verbose;
+ scan_podpath($podroot, $recurse, 0);
+ }
+ $Saved_Cache_Key = cache_key(@cache_key_args);
+}
+
+sub cache_key {
+ my($dircache, $itemcache, $podpath, $podroot, $recurse) = @_;
+ return join('!', $dircache, $itemcache, $recurse,
+ @$podpath, $podroot, stat($dircache), stat($itemcache));
+}
+
+#
+# load_cache - tries to find if the caches stored in $dircache and $itemcache
+# are valid caches of %Pages and %Items. if they are valid then it loads
+# them and returns a non-zero value.
+#
+sub load_cache {
+ my($dircache, $itemcache, $podpath, $podroot) = @_;
+ my($tests);
+ local $_;
+
+ $tests = 0;
+
+ open(CACHE, "<$itemcache") ||
+ die "$0: error opening $itemcache for reading: $!\n";
+ $/ = "\n";
+
+ # is it the same podpath?
+ $_ = <CACHE>;
+ chomp($_);
+ $tests++ if (join(":", @$podpath) eq $_);
+
+ # is it the same podroot?
+ $_ = <CACHE>;
+ chomp($_);
+ $tests++ if ($podroot eq $_);
+
+ # load the cache if its good
+ if ($tests != 2) {
+ close(CACHE);
+ return 0;
+ }
+
+ warn "loading item cache\n" if $Verbose;
+ while (<CACHE>) {
+ /(.*?) (.*)$/;
+ $Items{$1} = $2;
+ }
+ close(CACHE);
+
+ warn "scanning for directory cache\n" if $Verbose;
+ open(CACHE, "<$dircache") ||
+ die "$0: error opening $dircache for reading: $!\n";
+ $/ = "\n";
+ $tests = 0;
+
+ # is it the same podpath?
+ $_ = <CACHE>;
+ chomp($_);
+ $tests++ if (join(":", @$podpath) eq $_);
+
+ # is it the same podroot?
+ $_ = <CACHE>;
+ chomp($_);
+ $tests++ if ($podroot eq $_);
+
+ # load the cache if its good
+ if ($tests != 2) {
+ close(CACHE);
+ return 0;
+ }
+
+ warn "loading directory cache\n" if $Verbose;
+ while (<CACHE>) {
+ /(.*?) (.*)$/;
+ $Pages{$1} = $2;
+ }
+
+ close(CACHE);
+
+ return 1;
+}
+
+#
+# scan_podpath - scans the directories specified in @podpath for directories,
+# .pod files, and .pm files. it also scans the pod files specified in
+# @Libpods for =item directives.
+#
+sub scan_podpath {
+ my($podroot, $recurse, $append) = @_;
+ my($pwd, $dir);
+ my($libpod, $dirname, $pod, @files, @poddata);
+
+ unless($append) {
+ %Items = ();
+ %Pages = ();
+ }
+
+ # scan each directory listed in @Podpath
+ $pwd = getcwd();
+ chdir($podroot)
+ || die "$0: error changing to directory $podroot: $!\n";
+ foreach $dir (@Podpath) {
+ scan_dir($dir, $recurse);
+ }
+
+ # scan the pods listed in @Libpods for =item directives
+ foreach $libpod (@Libpods) {
+ # if the page isn't defined then we won't know where to find it
+ # on the system.
+ next unless defined $Pages{$libpod} && $Pages{$libpod};
+
+ # if there is a directory then use the .pod and .pm files within it.
+ # NOTE: Only finds the first so-named directory in the tree.
+# if ($Pages{$libpod} =~ /([^:]*[^(\.pod|\.pm)]):/) {
+ if ($Pages{$libpod} =~ /([^:]*(?<!\.pod)(?<!\.pm)):/) {
+ # find all the .pod and .pm files within the directory
+ $dirname = $1;
+ opendir(DIR, $dirname) ||
+ die "$0: error opening directory $dirname: $!\n";
+ @files = grep(/(\.pod|\.pm)\z/ && ! -d $_, readdir(DIR));
+ closedir(DIR);
+
+ # scan each .pod and .pm file for =item directives
+ foreach $pod (@files) {
+ open(POD, "<$dirname/$pod") ||
+ die "$0: error opening $dirname/$pod for input: $!\n";
+ @poddata = <POD>;
+ close(POD);
+ clean_data( \@poddata );
+
+ scan_items( \%Items, "$dirname/$pod", @poddata);
+ }
+
+ # use the names of files as =item directives too.
+### Don't think this should be done this way - confuses issues.(WL)
+### foreach $pod (@files) {
+### $pod =~ /^(.*)(\.pod|\.pm)$/;
+### $Items{$1} = "$dirname/$1.html" if $1;
+### }
+ } elsif ($Pages{$libpod} =~ /([^:]*\.pod):/ ||
+ $Pages{$libpod} =~ /([^:]*\.pm):/) {
+ # scan the .pod or .pm file for =item directives
+ $pod = $1;
+ open(POD, "<$pod") ||
+ die "$0: error opening $pod for input: $!\n";
+ @poddata = <POD>;
+ close(POD);
+ clean_data( \@poddata );
+
+ scan_items( \%Items, "$pod", @poddata);
+ } else {
+ warn "$0: shouldn't be here (line ".__LINE__."\n" unless $Quiet;
+ }
+ }
+ @poddata = (); # clean-up a bit
+
+ chdir($pwd)
+ || die "$0: error changing to directory $pwd: $!\n";
+
+ # cache the item list for later use
+ warn "caching items for later use\n" if $Verbose;
+ open(CACHE, ">$Itemcache") ||
+ die "$0: error open $Itemcache for writing: $!\n";
+
+ print CACHE join(":", @Podpath) . "\n$podroot\n";
+ foreach my $key (keys %Items) {
+ print CACHE "$key $Items{$key}\n";
+ }
+
+ close(CACHE);
+
+ # cache the directory list for later use
+ warn "caching directories for later use\n" if $Verbose;
+ open(CACHE, ">$Dircache") ||
+ die "$0: error open $Dircache for writing: $!\n";
+
+ print CACHE join(":", @Podpath) . "\n$podroot\n";
+ foreach my $key (keys %Pages) {
+ print CACHE "$key $Pages{$key}\n";
+ }
+
+ close(CACHE);
+}
+
+#
+# scan_dir - scans the directory specified in $dir for subdirectories, .pod
+# files, and .pm files. notes those that it finds. this information will
+# be used later in order to figure out where the pages specified in L<>
+# links are on the filesystem.
+#
+sub scan_dir {
+ my($dir, $recurse) = @_;
+ my($t, @subdirs, @pods, $pod, $dirname, @dirs);
+ local $_;
+
+ @subdirs = ();
+ @pods = ();
+
+ opendir(DIR, $dir) ||
+ die "$0: error opening directory $dir: $!\n";
+ while (defined($_ = readdir(DIR))) {
+ if (-d "$dir/$_" && $_ ne "." && $_ ne ".."
+ && ($HiddenDirs || !/^\./)
+ ) { # directory
+ $Pages{$_} = "" unless defined $Pages{$_};
+ $Pages{$_} .= "$dir/$_:";
+ push(@subdirs, $_);
+ } elsif (/\.pod\z/) { # .pod
+ s/\.pod\z//;
+ $Pages{$_} = "" unless defined $Pages{$_};
+ $Pages{$_} .= "$dir/$_.pod:";
+ push(@pods, "$dir/$_.pod");
+ } elsif (/\.html\z/) { # .html
+ s/\.html\z//;
+ $Pages{$_} = "" unless defined $Pages{$_};
+ $Pages{$_} .= "$dir/$_.pod:";
+ } elsif (/\.pm\z/) { # .pm
+ s/\.pm\z//;
+ $Pages{$_} = "" unless defined $Pages{$_};
+ $Pages{$_} .= "$dir/$_.pm:";
+ push(@pods, "$dir/$_.pm");
+ } elsif (-T "$dir/$_") { # script(?)
+ local *F;
+ if (open(F, "$dir/$_")) {
+ my $line;
+ while (defined($line = <F>)) {
+ if ($line =~ /^=(?:pod|head1)/) {
+ $Pages{$_} = "" unless defined $Pages{$_};
+ $Pages{$_} .= "$dir/$_.pod:";
+ last;
+ }
+ }
+ close(F);
+ }
+ }
+ }
+ closedir(DIR);
+
+ # recurse on the subdirectories if necessary
+ if ($recurse) {
+ foreach my $subdir (@subdirs) {
+ scan_dir("$dir/$subdir", $recurse);
+ }
+ }
+}
+
+#
+# scan_headings - scan a pod file for head[1-6] tags, note the tags, and
+# build an index.
+#
+sub scan_headings {
+ my($sections, @data) = @_;
+ my($tag, $which_head, $otitle, $listdepth, $index);
+
+ local $Ignore = 0;
+
+ $listdepth = 0;
+ $index = "";
+
+ # scan for =head directives, note their name, and build an index
+ # pointing to each of them.
+ foreach my $line (@data) {
+ if ($line =~ /^=(head)([1-6])\s+(.*)/) {
+ ($tag, $which_head, $otitle) = ($1,$2,$3);
+
+ my $title = depod( $otitle );
+ my $name = anchorify( $title );
+ $$sections{$name} = 1;
+ $title = process_text( \$otitle );
+
+ while ($which_head != $listdepth) {
+ if ($which_head > $listdepth) {
+ $index .= "\n" . ("\t" x $listdepth) . "<ul>\n";
+ $listdepth++;
+ } elsif ($which_head < $listdepth) {
+ $listdepth--;
+ $index .= "\n" . ("\t" x $listdepth) . "</ul>\n";
+ }
+ }
+
+ $index .= "\n" . ("\t" x $listdepth) . "<li>" .
+ "<a href=\"#" . $name . "\">" .
+ $title . "</a></li>";
+ }
+ }
+
+ # finish off the lists
+ while ($listdepth--) {
+ $index .= "\n" . ("\t" x $listdepth) . "</ul>\n";
+ }
+
+ # get rid of bogus lists
+ $index =~ s,\t*<ul>\s*</ul>\n,,g;
+
+ return $index;
+}
+
+#
+# scan_items - scans the pod specified by $pod for =item directives. we
+# will use this information later on in resolving C<> links.
+#
+sub scan_items {
+ my( $itemref, $pod, @poddata ) = @_;
+ my($i, $item);
+ local $_;
+
+ $pod =~ s/\.pod\z//;
+ $pod .= ".html" if $pod;
+
+ foreach $i (0..$#poddata) {
+ my $txt = depod( $poddata[$i] );
+
+ # figure out what kind of item it is.
+ # Build string for referencing this item.
+ if ( $txt =~ /\A=item\s+\*\s*(.*)\Z/s ) { # bulleted list
+ next unless $1;
+ $item = $1;
+ } elsif( $txt =~ /\A=item\s+(?>\d+\.?)\s*(.*)\Z/s ) { # numbered list
+ $item = $1;
+ } elsif( $txt =~ /\A=item\s+(.*)\Z/s ) { # definition list
+ $item = $1;
+ } else {
+ next;
+ }
+ my $fid = fragment_id( $item );
+ $$itemref{$fid} = "$pod" if $fid;
+ }
+}
+
+#
+# process_head - convert a pod head[1-6] tag and convert it to HTML format.
+#
+sub process_head {
+ my($tag, $heading, $hasindex) = @_;
+
+ # figure out the level of the =head
+ $tag =~ /head([1-6])/;
+ my $level = $1;
+
+ finish_list();
+
+ print HTML "<p>\n";
+ if( $level == 1 && ! $Top ){
+ print HTML "<a href=\"#__index__\"><small>$Backlink</small></a>\n"
+ if $hasindex and $Backlink;
+ print HTML "</p>\n<hr />\n"
+ } else {
+ print HTML "</p>\n";
+ }
+
+ my $name = anchorify( depod( $heading ) );
+ my $convert = process_text( \$heading );
+ print HTML "<h$level><a name=\"$name\">$convert</a></h$level>\n";
+}
+
+
+#
+# emit_item_tag - print an =item's text
+# Note: The global $EmittedItem is used for inhibiting self-references.
+#
+my $EmittedItem;
+
+sub emit_item_tag($$$){
+ my( $otext, $text, $compact ) = @_;
+ my $item = fragment_id( depod($text) , -generate);
+ Carp::confess("Undefined fragment '$text' (".depod($text).") from fragment_id() in emit_item_tag() in $Podfile")
+ if !defined $item;
+ $EmittedItem = $item;
+ ### print STDERR "emit_item_tag=$item ($text)\n";
+
+ print HTML '<strong>';
+ if ($Items_Named{$item}++) {
+ print HTML process_text( \$otext );
+ } else {
+ my $name = $item;
+ $name = anchorify($name);
+ print HTML qq{<a name="$name" class="item">}, process_text( \$otext ), '</a>';
+ }
+ print HTML "</strong>";
+ undef( $EmittedItem );
+}
+
+sub new_listitem {
+ my( $tag ) = @_;
+ # Open tag for definition list as we have something to put in it
+ if( ($tag ne 'dl') && ($ListNewTerm) ){
+ print HTML "<dd>\n";
+ $ListNewTerm = 0;
+ }
+
+ if( $Items_Seen[$Listlevel]++ == 0 ){
+ # start of new list
+ push( @Listtype, "$tag" );
+ print HTML "<$tag>\n";
+ } else {
+ # if this is not the first item, close the previous one
+ if ( $tag eq 'dl' ){
+ print HTML "</dd>\n" unless $ListNewTerm;
+ } else {
+ print HTML "</li>\n";
+ }
+ }
+ my $opentag = $tag eq 'dl' ? 'dt' : 'li';
+ print HTML "<$opentag>";
+}
+
+#
+# process_item - convert a pod item tag and convert it to HTML format.
+#
+sub process_item {
+ my( $otext ) = @_;
+
+ # lots of documents start a list without doing an =over. this is
+ # bad! but, the proper thing to do seems to be to just assume
+ # they did do an =over. so warn them once and then continue.
+ if( $Listlevel == 0 ){
+ warn "$0: $Podfile: unexpected =item directive in paragraph $Paragraph. ignoring.\n" unless $Quiet;
+ process_over();
+ }
+
+ # remove formatting instructions from the text
+ my $text = depod( $otext );
+
+ # all the list variants:
+ if( $text =~ /\A\*/ ){ # bullet
+ new_listitem( 'ul' );
+ if ($text =~ /\A\*\s+(\S.*)\Z/s ) { # with additional text
+ my $tag = $1;
+ $otext =~ s/\A\*\s+//;
+ emit_item_tag( $otext, $tag, 1 );
+ print HTML "\n";
+ }
+
+ } elsif( $text =~ /\A\d+/ ){ # numbered list
+ new_listitem( 'ol' );
+ if ($text =~ /\A(?>\d+\.?)\s*(\S.*)\Z/s ) { # with additional text
+ my $tag = $1;
+ $otext =~ s/\A\d+\.?\s*//;
+ emit_item_tag( $otext, $tag, 1 );
+ print HTML "\n";
+ }
+
+ } else { # definition list
+ # new_listitem takes care of opening the <dt> tag
+ new_listitem( 'dl' );
+ if ($text =~ /\A(.+)\Z/s ){ # should have text
+ emit_item_tag( $otext, $text, 1 );
+ # write the definition term and close <dt> tag
+ print HTML "</dt>\n";
+ }
+ # trigger opening a <dd> tag for the actual definition; will not
+ # happen if next paragraph is also a definition term (=item)
+ $ListNewTerm = 1;
+ }
+ print HTML "\n";
+}
+
+#
+# process_over - process a pod over tag and start a corresponding HTML list.
+#
+sub process_over {
+ # start a new list
+ $Listlevel++;
+ push( @Items_Seen, 0 );
+}
+
+#
+# process_back - process a pod back tag and convert it to HTML format.
+#
+sub process_back {
+ if( $Listlevel == 0 ){
+ warn "$0: $Podfile: unexpected =back directive in paragraph $Paragraph. ignoring.\n" unless $Quiet;
+ return;
+ }
+
+ # close off the list. note, I check to see if $Listtype[$Listlevel] is
+ # defined because an =item directive may have never appeared and thus
+ # $Listtype[$Listlevel] may have never been initialized.
+ $Listlevel--;
+ if( defined $Listtype[$Listlevel] ){
+ if ( $Listtype[$Listlevel] eq 'dl' ){
+ print HTML "</dd>\n" unless $ListNewTerm;
+ } else {
+ print HTML "</li>\n";
+ }
+ print HTML "</$Listtype[$Listlevel]>\n";
+ pop( @Listtype );
+ $ListNewTerm = 0;
+ }
+
+ # clean up item count
+ pop( @Items_Seen );
+}
+
+#
+# process_cut - process a pod cut tag, thus start ignoring pod directives.
+#
+sub process_cut {
+ $Ignore = 1;
+}
+
+#
+# process_pod - process a pod tag, thus stop ignoring pod directives
+# until we see a corresponding cut.
+#
+sub process_pod {
+ # no need to set $Ignore to 0 cause the main loop did it
+}
+
+#
+# process_for - process a =for pod tag. if it's for html, spit
+# it out verbatim, if illustration, center it, otherwise ignore it.
+#
+sub process_for {
+ my($whom, $text) = @_;
+ if ( $whom =~ /^(pod2)?html$/i) {
+ print HTML $text;
+ } elsif ($whom =~ /^illustration$/i) {
+ 1 while chomp $text;
+ for my $ext (qw[.png .gif .jpeg .jpg .tga .pcl .bmp]) {
+ $text .= $ext, last if -r "$text$ext";
+ }
+ print HTML qq{<p align="center"><img src="$text" alt="$text illustration" /></p>};
+ }
+}
+
+#
+# process_begin - process a =begin pod tag. this pushes
+# whom we're beginning on the begin stack. if there's a
+# begin stack, we only print if it us.
+#
+sub process_begin {
+ my($whom, $text) = @_;
+ $whom = lc($whom);
+ push (@Begin_Stack, $whom);
+ if ( $whom =~ /^(pod2)?html$/) {
+ print HTML $text if $text;
+ }
+}
+
+#
+# process_end - process a =end pod tag. pop the
+# begin stack. die if we're mismatched.
+#
+sub process_end {
+ my($whom, $text) = @_;
+ $whom = lc($whom);
+ if (!defined $Begin_Stack[-1] or $Begin_Stack[-1] ne $whom ) {
+ Carp::confess("Unmatched begin/end at chunk $Paragraph in pod $Podfile\n")
+ }
+ pop( @Begin_Stack );
+}
+
+#
+# process_pre - indented paragraph, made into <pre></pre>
+#
+sub process_pre {
+ my( $text ) = @_;
+ my( $rest );
+ return if $Ignore;
+
+ $rest = $$text;
+
+ # insert spaces in place of tabs
+ $rest =~ s#(.+)#
+ my $line = $1;
+ 1 while $line =~ s/(\t+)/' ' x ((length($1) * 8) - $-[0] % 8)/e;
+ $line;
+ #eg;
+
+ # convert some special chars to HTML escapes
+ $rest = html_escape($rest);
+
+ # try and create links for all occurrences of perl.* within
+ # the preformatted text.
+ $rest =~ s{
+ (\s*)(perl\w+)
+ }{
+ if ( defined $Pages{$2} ){ # is a link
+ qq($1<a href="$Htmlroot/$Pages{$2}">$2</a>);
+ } elsif (defined $Pages{dosify($2)}) { # is a link
+ qq($1<a href="$Htmlroot/$Pages{dosify($2)}">$2</a>);
+ } else {
+ "$1$2";
+ }
+ }xeg;
+ $rest =~ s{
+ (<a\ href="?) ([^>:]*:)? ([^>:]*) \.pod: ([^>:]*:)?
+ }{
+ my $url ;
+ if ( $Htmlfileurl ne '' ){
+ # Here, we take advantage of the knowledge
+ # that $Htmlfileurl ne '' implies $Htmlroot eq ''.
+ # Since $Htmlroot eq '', we need to prepend $Htmldir
+ # on the fron of the link to get the absolute path
+ # of the link's target. We check for a leading '/'
+ # to avoid corrupting links that are #, file:, etc.
+ my $old_url = $3 ;
+ $old_url = "$Htmldir$old_url" if $old_url =~ m{^\/};
+ $url = relativize_url( "$old_url.html", $Htmlfileurl );
+ } else {
+ $url = "$3.html" ;
+ }
+ "$1$url" ;
+ }xeg;
+
+ # Look for embedded URLs and make them into links. We don't
+ # relativize them since they are best left as the author intended.
+
+ my $urls = '(' . join ('|', qw{
+ http
+ telnet
+ mailto
+ news
+ gopher
+ file
+ wais
+ ftp
+ } )
+ . ')';
+
+ my $ltrs = '\w';
+ my $gunk = '/#~:.?+=&%@!\-';
+ my $punc = '.:!?\-;';
+ my $any = "${ltrs}${gunk}${punc}";
+
+ $rest =~ s{
+ \b # start at word boundary
+ ( # begin $1 {
+ $urls : # need resource and a colon
+ (?!:) # Ignore File::, among others.
+ [$any] +? # followed by one or more of any valid
+ # character, but be conservative and
+ # take only what you need to....
+ ) # end $1 }
+ (?=
+ " > # maybe pre-quoted '<a href="...">'
+ | # or:
+ [$punc]* # 0 or more punctuation
+ (?: # followed
+ [^$any] # by a non-url char
+ | # or
+ $ # end of the string
+ ) #
+ | # or else
+ $ # then end of the string
+ )
+ }{<a href="$1">$1</a>}igox;
+
+ # text should be as it is (verbatim)
+ $$text = $rest;
+}
+
+
+#
+# pure text processing
+#
+# pure_text/inIS_text: differ with respect to automatic C<> recognition.
+# we don't want this to happen within IS
+#
+sub pure_text($){
+ my $text = shift();
+ process_puretext( $text, 1 );
+}
+
+sub inIS_text($){
+ my $text = shift();
+ process_puretext( $text, 0 );
+}
+
+#
+# process_puretext - process pure text (without pod-escapes) converting
+# double-quotes and handling implicit C<> links.
+#
+sub process_puretext {
+ my($text, $notinIS) = @_;
+
+ ## Guessing at func() or [\$\@%&]*var references in plain text is destined
+ ## to produce some strange looking ref's. uncomment to disable:
+ ## $notinIS = 0;
+
+ my(@words, $lead, $trail);
+
+ # keep track of leading and trailing white-space
+ $lead = ($text =~ s/\A(\s+)//s ? $1 : "");
+ $trail = ($text =~ s/(\s+)\Z//s ? $1 : "");
+
+ # split at space/non-space boundaries
+ @words = split( /(?<=\s)(?=\S)|(?<=\S)(?=\s)/, $text );
+
+ # process each word individually
+ foreach my $word (@words) {
+ # skip space runs
+ next if $word =~ /^\s*$/;
+ # see if we can infer a link or a function call
+ #
+ # NOTE: This is a word based search, it won't automatically
+ # mark "substr($var, 1, 2)" because the 1st word would be "substr($var"
+ # User has to enclose those with proper C<>
+
+ if( $notinIS && $word =~
+ m/
+ ^([a-z_]{2,}) # The function name
+ \(
+ ([0-9][a-z]* # Manual page(1) or page(1M)
+ |[^)]*[\$\@\%][^)]+ # ($foo), (1, @foo), (%hash)
+ | # ()
+ )
+ \)
+ ([.,;]?)$ # a possible punctuation follows
+ /xi
+ ) {
+ # has parenthesis so should have been a C<> ref
+ ## try for a pagename (perlXXX(1))?
+ my( $func, $args, $rest ) = ( $1, $2, $3 || '' );
+ if( $args =~ /^\d+$/ ){
+ my $url = page_sect( $word, '' );
+ if( defined $url ){
+ $word = qq(<a href="$url" class="man">the $word manpage</a>$rest);
+ next;
+ }
+ }
+ ## try function name for a link, append tt'ed argument list
+ $word = emit_C( $func, '', "($args)") . $rest;
+
+#### disabled. either all (including $\W, $\w+{.*} etc.) or nothing.
+## } elsif( $notinIS && $word =~ /^[\$\@%&*]+\w+$/) {
+## # perl variables, should be a C<> ref
+## $word = emit_C( $word );
+
+ } elsif ($word =~ m,^\w+://\w,) {
+ # looks like a URL
+ # Don't relativize it: leave it as the author intended
+ $word = qq(<a href="$word">$word</a>);
+ } elsif ($word =~ /[\w.-]+\@[\w-]+\.\w/) {
+ # looks like an e-mail address
+ my ($w1, $w2, $w3) = ("", $word, "");
+ ($w1, $w2, $w3) = ("(", $1, ")$2") if $word =~ /^\((.*?)\)(,?)/;
+ ($w1, $w2, $w3) = ("<", $1, ">$2") if $word =~ /^<(.*?)>(,?)/;
+ $word = qq($w1<a href="mailto:$w2">$w2</a>$w3);
+ } else {
+ $word = html_escape($word) if $word =~ /["&<>]/;
+ }
+ }
+
+ # put everything back together
+ return $lead . join( '', @words ) . $trail;
+}
+
+
+#
+# process_text - handles plaintext that appears in the input pod file.
+# there may be pod commands embedded within the text so those must be
+# converted to html commands.
+#
+
+sub process_text1($$;$$);
+sub pattern ($) { $_[0] ? '\s+'.('>' x ($_[0] + 1)) : '>' }
+sub closing ($) { local($_) = shift; (defined && s/\s+\z//) ? length : 0 }
+
+sub process_text {
+ return if $Ignore;
+ my( $tref ) = @_;
+ my $res = process_text1( 0, $tref );
+ $res =~ s/\s+$//s;
+ $$tref = $res;
+}
+
+sub process_text_rfc_links {
+ my $text = shift;
+
+ # For every "RFCnnnn" or "RFC nnn", link it to the authoritative
+ # ource. Do not use the /i modifier here. Require "RFC" to be written in
+ # in capital letters.
+
+ $text =~ s{
+ (?<=[^<>[:alpha:]]) # Make sure this is not an URL already
+ (RFC\s*([0-9]{1,5}))(?![0-9]) # max 5 digits
+ }
+ {<a href="http://www.ietf.org/rfc/rfc$2.txt" class="rfc">$1</a>}gx;
+
+ $text;
+}
+
+sub process_text1($$;$$){
+ my( $lev, $rstr, $func, $closing ) = @_;
+ my $res = '';
+
+ unless (defined $func) {
+ $func = '';
+ $lev++;
+ }
+
+ if( $func eq 'B' ){
+ # B<text> - boldface
+ $res = '<strong>' . process_text1( $lev, $rstr ) . '</strong>';
+
+ } elsif( $func eq 'C' ){
+ # C<code> - can be a ref or <code></code>
+ # need to extract text
+ my $par = go_ahead( $rstr, 'C', $closing );
+
+ ## clean-up of the link target
+ my $text = depod( $par );
+
+ ### my $x = $par =~ /[BI]</ ? 'yes' : 'no' ;
+ ### print STDERR "-->call emit_C($par) lev=$lev, par with BI=$x\n";
+
+ $res = emit_C( $text, $lev > 1 || ($par =~ /[BI]</) );
+
+ } elsif( $func eq 'E' ){
+ # E<x> - convert to character
+ $$rstr =~ s/^([^>]*)>//;
+ my $escape = $1;
+ $escape =~ s/^(\d+|X[\dA-F]+)$/#$1/i;
+ $res = "&$escape;";
+
+ } elsif( $func eq 'F' ){
+ # F<filename> - italicize
+ $res = '<em class="file">' . process_text1( $lev, $rstr ) . '</em>';
+
+ } elsif( $func eq 'I' ){
+ # I<text> - italicize
+ $res = '<em>' . process_text1( $lev, $rstr ) . '</em>';
+
+ } elsif( $func eq 'L' ){
+ # L<link> - link
+ ## L<text|cross-ref> => produce text, use cross-ref for linking
+ ## L<cross-ref> => make text from cross-ref
+ ## need to extract text
+ my $par = go_ahead( $rstr, 'L', $closing );
+
+ # some L<>'s that shouldn't be:
+ # a) full-blown URL's are emitted as-is
+ if( $par =~ m{^\w+://}s ){
+ return make_URL_href( $par );
+ }
+ # b) C<...> is stripped and treated as C<>
+ if( $par =~ /^C<(.*)>$/ ){
+ my $text = depod( $1 );
+ return emit_C( $text, $lev > 1 || ($par =~ /[BI]</) );
+ }
+
+ # analyze the contents
+ $par =~ s/\n/ /g; # undo word-wrapped tags
+ my $opar = $par;
+ my $linktext;
+ if( $par =~ s{^([^|]+)\|}{} ){
+ $linktext = $1;
+ }
+
+ # make sure sections start with a /
+ $par =~ s{^"}{/"};
+
+ my( $page, $section, $ident );
+
+ # check for link patterns
+ if( $par =~ m{^([^/]+?)/(?!")(.*?)$} ){ # name/ident
+ # we've got a name/ident (no quotes)
+ if (length $2) {
+ ( $page, $ident ) = ( $1, $2 );
+ } else {
+ ( $page, $section ) = ( $1, $2 );
+ }
+ ### print STDERR "--> L<$par> to page $page, ident $ident\n";
+
+ } elsif( $par =~ m{^(.*?)/"?(.*?)"?$} ){ # [name]/"section"
+ # even though this should be a "section", we go for ident first
+ ( $page, $ident ) = ( $1, $2 );
+ ### print STDERR "--> L<$par> to page $page, section $section\n";
+
+ } elsif( $par =~ /\s/ ){ # this must be a section with missing quotes
+ ( $page, $section ) = ( '', $par );
+ ### print STDERR "--> L<$par> to void page, section $section\n";
+
+ } else {
+ ( $page, $section ) = ( $par, '' );
+ ### print STDERR "--> L<$par> to page $par, void section\n";
+ }
+
+ # now, either $section or $ident is defined. the convoluted logic
+ # below tries to resolve L<> according to what the user specified.
+ # failing this, we try to find the next best thing...
+ my( $url, $ltext, $fid );
+
+ RESOLVE: {
+ if( defined $ident ){
+ ## try to resolve $ident as an item
+ ( $url, $fid ) = coderef( $page, $ident );
+ if( $url ){
+ if( ! defined( $linktext ) ){
+ $linktext = $ident;
+ $linktext .= " in " if $ident && $page;
+ $linktext .= "the $page manpage" if $page;
+ }
+ ### print STDERR "got coderef url=$url\n";
+ last RESOLVE;
+ }
+ ## no luck: go for a section (auto-quoting!)
+ $section = $ident;
+ }
+ ## now go for a section
+ my $htmlsection = htmlify( $section );
+ $url = page_sect( $page, $htmlsection );
+ if( $url ){
+ if( ! defined( $linktext ) ){
+ $linktext = $section;
+ $linktext .= " in " if $section && $page;
+ $linktext .= "the $page manpage" if $page;
+ }
+ ### print STDERR "got page/section url=$url\n";
+ last RESOLVE;
+ }
+ ## no luck: go for an ident
+ if( $section ){
+ $ident = $section;
+ } else {
+ $ident = $page;
+ $page = undef();
+ }
+ ( $url, $fid ) = coderef( $page, $ident );
+ if( $url ){
+ if( ! defined( $linktext ) ){
+ $linktext = $ident;
+ $linktext .= " in " if $ident && $page;
+ $linktext .= "the $page manpage" if $page;
+ }
+ ### print STDERR "got section=>coderef url=$url\n";
+ last RESOLVE;
+ }
+
+ # warning; show some text.
+ $linktext = $opar unless defined $linktext;
+ warn "$0: $Podfile: cannot resolve L<$opar> in paragraph $Paragraph.\n" unless $Quiet;
+ }
+
+ # now we have a URL or just plain code
+ $$rstr = $linktext . '>' . $$rstr;
+ if( defined( $url ) ){
+ $res = "<a href=\"$url\">" . process_text1( $lev, $rstr ) . '</a>';
+ } else {
+ $res = '<em>' . process_text1( $lev, $rstr ) . '</em>';
+ }
+
+ } elsif( $func eq 'S' ){
+ # S<text> - non-breaking spaces
+ $res = process_text1( $lev, $rstr );
+ $res =~ s/ / /g;
+
+ } elsif( $func eq 'X' ){
+ # X<> - ignore
+ warn "$0: $Podfile: invalid X<> in paragraph $Paragraph.\n"
+ unless $$rstr =~ s/^[^>]*>// or $Quiet;
+ } elsif( $func eq 'Z' ){
+ # Z<> - empty
+ warn "$0: $Podfile: invalid Z<> in paragraph $Paragraph.\n"
+ unless $$rstr =~ s/^>// or $Quiet;
+
+ } else {
+ my $term = pattern $closing;
+ while( $$rstr =~ s/\A(.*?)(([BCEFILSXZ])<(<+[^\S\n]+)?|$term)//s ){
+ # all others: either recurse into new function or
+ # terminate at closing angle bracket(s)
+ my $pt = $1;
+ $pt .= $2 if !$3 && $lev == 1;
+ $res .= $lev == 1 ? pure_text( $pt ) : inIS_text( $pt );
+ return $res if !$3 && $lev > 1;
+ if( $3 ){
+ $res .= process_text1( $lev, $rstr, $3, closing $4 );
+ }
+ }
+ if( $lev == 1 ){
+ $res .= pure_text( $$rstr );
+ } elsif( ! $Quiet ) {
+ my $snippet = substr($$rstr,0,60);
+ warn "$0: $Podfile: undelimited $func<> in paragraph $Paragraph: '$snippet'.\n"
+
+ }
+ $res = process_text_rfc_links($res);
+ }
+ return $res;
+}
+
+#
+# go_ahead: extract text of an IS (can be nested)
+#
+sub go_ahead($$$){
+ my( $rstr, $func, $closing ) = @_;
+ my $res = '';
+ my @closing = ($closing);
+ while( $$rstr =~
+ s/\A(.*?)(([BCEFILSXZ])<(<+\s+)?|@{[pattern $closing[0]]})//s ){
+ $res .= $1;
+ unless( $3 ){
+ shift @closing;
+ return $res unless @closing;
+ } else {
+ unshift @closing, closing $4;
+ }
+ $res .= $2;
+ }
+ unless ($Quiet) {
+ my $snippet = substr($$rstr,0,60);
+ warn "$0: $Podfile: undelimited $func<> in paragraph $Paragraph (go_ahead): '$snippet'.\n"
+ }
+ return $res;
+}
+
+#
+# emit_C - output result of C<text>
+# $text is the depod-ed text
+#
+sub emit_C($;$$){
+ my( $text, $nocode, $args ) = @_;
+ $args = '' unless defined $args;
+ my $res;
+ my( $url, $fid ) = coderef( undef(), $text );
+
+ # need HTML-safe text
+ my $linktext = html_escape( "$text$args" );
+
+ if( defined( $url ) &&
+ (!defined( $EmittedItem ) || $EmittedItem ne $fid ) ){
+ $res = "<a href=\"$url\"><code>$linktext</code></a>";
+ } elsif( 0 && $nocode ){
+ $res = $linktext;
+ } else {
+ $res = "<code>$linktext</code>";
+ }
+ return $res;
+}
+
+#
+# html_escape: make text safe for HTML
+#
+sub html_escape {
+ my $rest = $_[0];
+ $rest =~ s/&/&/g;
+ $rest =~ s/</</g;
+ $rest =~ s/>/>/g;
+ $rest =~ s/"/"/g;
+ # ' is only in XHTML, not HTML4. Be conservative
+ #$rest =~ s/'/'/g;
+ return $rest;
+}
+
+
+#
+# dosify - convert filenames to 8.3
+#
+sub dosify {
+ my($str) = @_;
+ return lc($str) if $^O eq 'VMS'; # VMS just needs casing
+ if ($Is83) {
+ $str = lc $str;
+ $str =~ s/(\.\w+)/substr ($1,0,4)/ge;
+ $str =~ s/(\w+)/substr ($1,0,8)/ge;
+ }
+ return $str;
+}
+
+#
+# page_sect - make a URL from the text of a L<>
+#
+sub page_sect($$) {
+ my( $page, $section ) = @_;
+ my( $linktext, $page83, $link); # work strings
+
+ # check if we know that this is a section in this page
+ if (!defined $Pages{$page} && defined $Sections{$page}) {
+ $section = $page;
+ $page = "";
+ ### print STDERR "reset page='', section=$section\n";
+ }
+
+ $page83=dosify($page);
+ $page=$page83 if (defined $Pages{$page83});
+ if ($page eq "") {
+ $link = "#" . anchorify( $section );
+ } elsif ( $page =~ /::/ ) {
+ $page =~ s,::,/,g;
+ # Search page cache for an entry keyed under the html page name,
+ # then look to see what directory that page might be in. NOTE:
+ # this will only find one page. A better solution might be to produce
+ # an intermediate page that is an index to all such pages.
+ my $page_name = $page ;
+ $page_name =~ s,^.*/,,s ;
+ if ( defined( $Pages{ $page_name } ) &&
+ $Pages{ $page_name } =~ /([^:]*$page)\.(?:pod|pm):/
+ ) {
+ $page = $1 ;
+ }
+ else {
+ # NOTE: This branch assumes that all A::B pages are located in
+ # $Htmlroot/A/B.html . This is often incorrect, since they are
+ # often in $Htmlroot/lib/A/B.html or such like. Perhaps we could
+ # analyze the contents of %Pages and figure out where any
+ # cousins of A::B are, then assume that. So, if A::B isn't found,
+ # but A::C is found in lib/A/C.pm, then A::B is assumed to be in
+ # lib/A/B.pm. This is also limited, but it's an improvement.
+ # Maybe a hints file so that the links point to the correct places
+ # nonetheless?
+
+ }
+ $link = "$Htmlroot/$page.html";
+ $link .= "#" . anchorify( $section ) if ($section);
+ } elsif (!defined $Pages{$page}) {
+ $link = "";
+ } else {
+ $section = anchorify( $section ) if $section ne "";
+ ### print STDERR "...section=$section\n";
+
+ # if there is a directory by the name of the page, then assume that an
+ # appropriate section will exist in the subdirectory
+# if ($section ne "" && $Pages{$page} =~ /([^:]*[^(\.pod|\.pm)]):/) {
+ if ($section ne "" && $Pages{$page} =~ /([^:]*(?<!\.pod)(?<!\.pm)):/) {
+ $link = "$Htmlroot/$1/$section.html";
+ ### print STDERR "...link=$link\n";
+
+ # since there is no directory by the name of the page, the section will
+ # have to exist within a .html of the same name. thus, make sure there
+ # is a .pod or .pm that might become that .html
+ } else {
+ $section = "#$section" if $section;
+ ### print STDERR "...section=$section\n";
+
+ # check if there is a .pod with the page name.
+ # for L<Foo>, Foo.(pod|pm) is preferred to A/Foo.(pod|pm)
+ if ($Pages{$page} =~ /([^:]*)\.(?:pod|pm):/) {
+ $link = "$Htmlroot/$1.html$section";
+ } else {
+ $link = "";
+ }
+ }
+ }
+
+ if ($link) {
+ # Here, we take advantage of the knowledge that $Htmlfileurl ne ''
+ # implies $Htmlroot eq ''. This means that the link in question
+ # needs a prefix of $Htmldir if it begins with '/'. The test for
+ # the initial '/' is done to avoid '#'-only links, and to allow
+ # for other kinds of links, like file:, ftp:, etc.
+ my $url ;
+ if ( $Htmlfileurl ne '' ) {
+ $link = "$Htmldir$link" if $link =~ m{^/}s;
+ $url = relativize_url( $link, $Htmlfileurl );
+# print( " b: [$link,$Htmlfileurl,$url]\n" );
+ }
+ else {
+ $url = $link ;
+ }
+ return $url;
+
+ } else {
+ return undef();
+ }
+}
+
+#
+# relativize_url - convert an absolute URL to one relative to a base URL.
+# Assumes both end in a filename.
+#
+sub relativize_url {
+ my ($dest,$source) = @_ ;
+
+ my ($dest_volume,$dest_directory,$dest_file) =
+ File::Spec::Unix->splitpath( $dest ) ;
+ $dest = File::Spec::Unix->catpath( $dest_volume, $dest_directory, '' ) ;
+
+ my ($source_volume,$source_directory,$source_file) =
+ File::Spec::Unix->splitpath( $source ) ;
+ $source = File::Spec::Unix->catpath( $source_volume, $source_directory, '' ) ;
+
+ my $rel_path = '' ;
+ if ( $dest ne '' ) {
+ $rel_path = File::Spec::Unix->abs2rel( $dest, $source ) ;
+ }
+
+ if ( $rel_path ne '' &&
+ substr( $rel_path, -1 ) ne '/' &&
+ substr( $dest_file, 0, 1 ) ne '#'
+ ) {
+ $rel_path .= "/$dest_file" ;
+ }
+ else {
+ $rel_path .= "$dest_file" ;
+ }
+
+ return $rel_path ;
+}
+
+
+#
+# coderef - make URL from the text of a C<>
+#
+sub coderef($$){
+ my( $page, $item ) = @_;
+ my( $url );
+
+ my $fid = fragment_id( $item );
+
+ if( defined( $page ) && $page ne "" ){
+ # we have been given a $page...
+ $page =~ s{::}{/}g;
+
+ Carp::confess("Undefined fragment '$item' from fragment_id() in coderef() in $Podfile")
+ if !defined $fid;
+ # Do we take it? Item could be a section!
+ my $base = $Items{$fid} || "";
+ $base =~ s{[^/]*/}{};
+ if( $base ne "$page.html" ){
+ ### print STDERR "coderef( $page, $item ): items{$fid} = $Items{$fid} = $base => discard page!\n";
+ $page = undef();
+ }
+
+ } else {
+ # no page - local items precede cached items
+ if( defined( $fid ) ){
+ if( exists $Local_Items{$fid} ){
+ $page = $Local_Items{$fid};
+ } else {
+ $page = $Items{$fid};
+ }
+ }
+ }
+
+ # if there was a pod file that we found earlier with an appropriate
+ # =item directive, then create a link to that page.
+ if( defined $page ){
+ if( $page ){
+ if( exists $Pages{$page} and $Pages{$page} =~ /([^:.]*)\.[^:]*:/){
+ $page = $1 . '.html';
+ }
+ my $link = "$Htmlroot/$page#" . anchorify($fid);
+
+ # Here, we take advantage of the knowledge that $Htmlfileurl
+ # ne '' implies $Htmlroot eq ''.
+ if ( $Htmlfileurl ne '' ) {
+ $link = "$Htmldir$link" ;
+ $url = relativize_url( $link, $Htmlfileurl ) ;
+ } else {
+ $url = $link ;
+ }
+ } else {
+ $url = "#" . anchorify($fid);
+ }
+
+ confess "url has space: $url" if $url =~ /"[^"]*\s[^"]*"/;
+ }
+ return( $url, $fid );
+}
+
+
+
+#
+# Adapted from Nick Ing-Simmons' PodToHtml package.
+sub relative_url {
+ my $source_file = shift ;
+ my $destination_file = shift;
+
+ my $source = URI::file->new_abs($source_file);
+ my $uo = URI::file->new($destination_file,$source)->abs;
+ return $uo->rel->as_string;
+}
+
+
+#
+# finish_list - finish off any pending HTML lists. this should be called
+# after the entire pod file has been read and converted.
+#
+sub finish_list {
+ if( $Listlevel ){
+ warn "$0: $Podfile: unterminated list(s) at =head in paragraph $Paragraph. ignoring.\n" unless $Quiet;
+ while( $Listlevel ){
+ process_back();
+ }
+ }
+}
+
+#
+# htmlify - converts a pod section specification to a suitable section
+# specification for HTML. Note that we keep spaces and special characters
+# except ", ? (Netscape problem) and the hyphen (writer's problem...).
+#
+sub htmlify {
+ my( $heading) = @_;
+ $heading =~ s/(\s+)/ /g;
+ $heading =~ s/\s+\Z//;
+ $heading =~ s/\A\s+//;
+ # The hyphen is a disgrace to the English language.
+ # $heading =~ s/[-"?]//g;
+ $heading =~ s/["?]//g;
+ $heading = lc( $heading );
+ return $heading;
+}
+
+#
+# similar to htmlify, but turns non-alphanumerics into underscores
+#
+sub anchorify {
+ my ($anchor) = @_;
+ $anchor = htmlify($anchor);
+ $anchor =~ s/\W/_/g;
+ return $anchor;
+}
+
+#
+# depod - convert text by eliminating all interior sequences
+# Note: can be called with copy or modify semantics
+#
+my %E2c;
+$E2c{lt} = '<';
+$E2c{gt} = '>';
+$E2c{sol} = '/';
+$E2c{verbar} = '|';
+$E2c{amp} = '&'; # in Tk's pods
+
+sub depod1($;$$);
+
+sub depod($){
+ my $string;
+ if( ref( $_[0] ) ){
+ $string = ${$_[0]};
+ ${$_[0]} = depod1( \$string );
+ } else {
+ $string = $_[0];
+ depod1( \$string );
+ }
+}
+
+sub depod1($;$$){
+ my( $rstr, $func, $closing ) = @_;
+ my $res = '';
+ return $res unless defined $$rstr;
+ if( ! defined( $func ) ){
+ # skip to next begin of an interior sequence
+ while( $$rstr =~ s/\A(.*?)([BCEFILSXZ])<(<+[^\S\n]+)?//s ){
+ # recurse into its text
+ $res .= $1 . depod1( $rstr, $2, closing $3);
+ }
+ $res .= $$rstr;
+ } elsif( $func eq 'E' ){
+ # E<x> - convert to character
+ $$rstr =~ s/^([^>]*)>//;
+ $res .= $E2c{$1} || "";
+ } elsif( $func eq 'X' ){
+ # X<> - ignore
+ $$rstr =~ s/^[^>]*>//;
+ } elsif( $func eq 'Z' ){
+ # Z<> - empty
+ $$rstr =~ s/^>//;
+ } else {
+ # all others: either recurse into new function or
+ # terminate at closing angle bracket
+ my $term = pattern $closing;
+ while( $$rstr =~ s/\A(.*?)(([BCEFILSXZ])<(<+[^\S\n]+)?|$term)//s ){
+ $res .= $1;
+ last unless $3;
+ $res .= depod1( $rstr, $3, closing $4 );
+ }
+ ## If we're here and $2 ne '>': undelimited interior sequence.
+ ## Ignored, as this is called without proper indication of where we are.
+ ## Rely on process_text to produce diagnostics.
+ }
+ return $res;
+}
+
+{
+ my %seen; # static fragment record hash
+
+sub fragment_id_readable {
+ my $text = shift;
+ my $generate = shift; # optional flag
+
+ my $orig = $text;
+
+ # leave the words for the fragment identifier,
+ # change everything else to underbars.
+ $text =~ s/[^A-Za-z0-9_]+/_/g; # do not use \W to avoid locale dependency.
+ $text =~ s/_{2,}/_/g;
+ $text =~ s/\A_//;
+ $text =~ s/_\Z//;
+
+ unless ($text)
+ {
+ # Nothing left after removing punctuation, so leave it as is
+ # E.g. if option is named: "=item -#"
+
+ $text = $orig;
+ }
+
+ if ($generate) {
+ if ( exists $seen{$text} ) {
+ # This already exists, make it unique
+ $seen{$text}++;
+ $text = $text . $seen{$text};
+ } else {
+ $seen{$text} = 1; # first time seen this fragment
+ }
+ }
+
+ $text;
+}}
+
+my @HC;
+sub fragment_id_obfuscated { # This was the old "_2d_2d__"
+ my $text = shift;
+ my $generate = shift; # optional flag
+
+ # text? Normalize by obfuscating the fragment id to make it unique
+ $text =~ s/\s+/_/sg;
+
+ $text =~ s{(\W)}{
+ defined( $HC[ord($1)] ) ? $HC[ord($1)]
+ : ( $HC[ord($1)] = sprintf( "%%%02X", ord($1) ) ) }gxe;
+ $text = substr( $text, 0, 50 );
+
+ $text;
+}
+
+#
+# fragment_id - construct a fragment identifier from:
+# a) =item text
+# b) contents of C<...>
+#
+
+sub fragment_id {
+ my $text = shift;
+ my $generate = shift; # optional flag
+
+ $text =~ s/\s+\Z//s;
+ if( $text ){
+ # a method or function?
+ return $1 if $text =~ /(\w+)\s*\(/;
+ return $1 if $text =~ /->\s*(\w+)\s*\(?/;
+
+ # a variable name?
+ return $1 if $text =~ /^([\$\@%*]\S+)/;
+
+ # some pattern matching operator?
+ return $1 if $text =~ m|^(\w+/).*/\w*$|;
+
+ # fancy stuff... like "do { }"
+ return $1 if $text =~ m|^(\w+)\s*{.*}$|;
+
+ # honour the perlfunc manpage: func [PAR[,[ ]PAR]...]
+ # and some funnies with ... Module ...
+ return $1 if $text =~ m{^([a-z\d_]+)(\s+[A-Z,/& ][A-Z\d,/& ]*)?$};
+ return $1 if $text =~ m{^([a-z\d]+)\s+Module(\s+[A-Z\d,/& ]+)?$};
+
+ return fragment_id_readable($text, $generate);
+ } else {
+ return;
+ }
+}
+
+#
+# make_URL_href - generate HTML href from URL
+# Special treatment for CGI queries.
+#
+sub make_URL_href($){
+ my( $url ) = @_;
+ if( $url !~
+ s{^(http:[-\w/#~:.+=&%@!]+)(\?.*)$}{<a href="$1$2">$1</a>}i ){
+ $url = "<a href=\"$url\">$url</a>";
+ }
+ return $url;
+}
+
+1;
Copied: trunk/contrib/perl/lib/Pod/InputObjects.pm (from rev 6437, vendor/perl/5.18.1/lib/Pod/InputObjects.pm)
===================================================================
--- trunk/contrib/perl/lib/Pod/InputObjects.pm (rev 0)
+++ trunk/contrib/perl/lib/Pod/InputObjects.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,936 @@
+#############################################################################
+# Pod/InputObjects.pm -- package which defines objects for input streams
+# and paragraphs and commands when parsing POD docs.
+#
+# Copyright (C) 1996-2000 by Bradford Appleton. All rights reserved.
+# This file is part of "PodParser". PodParser is free software;
+# you can redistribute it and/or modify it under the same terms
+# as Perl itself.
+#############################################################################
+
+package Pod::InputObjects;
+use strict;
+
+use vars qw($VERSION);
+$VERSION = '1.31'; ## Current version of this package
+require 5.005; ## requires this Perl version or later
+
+#############################################################################
+
+=head1 NAME
+
+Pod::InputObjects - objects representing POD input paragraphs, commands, etc.
+
+=head1 SYNOPSIS
+
+ use Pod::InputObjects;
+
+=head1 REQUIRES
+
+perl5.004, Carp
+
+=head1 EXPORTS
+
+Nothing.
+
+=head1 DESCRIPTION
+
+This module defines some basic input objects used by B<Pod::Parser> when
+reading and parsing POD text from an input source. The following objects
+are defined:
+
+=over 4
+
+=begin __PRIVATE__
+
+=item package B<Pod::InputSource>
+
+An object corresponding to a source of POD input text. It is mostly a
+wrapper around a filehandle or C<IO::Handle>-type object (or anything
+that implements the C<getline()> method) which keeps track of some
+additional information relevant to the parsing of PODs.
+
+=end __PRIVATE__
+
+=item package B<Pod::Paragraph>
+
+An object corresponding to a paragraph of POD input text. It may be a
+plain paragraph, a verbatim paragraph, or a command paragraph (see
+L<perlpod>).
+
+=item package B<Pod::InteriorSequence>
+
+An object corresponding to an interior sequence command from the POD
+input text (see L<perlpod>).
+
+=item package B<Pod::ParseTree>
+
+An object corresponding to a tree of parsed POD text. Each "node" in
+a parse-tree (or I<ptree>) is either a text-string or a reference to
+a B<Pod::InteriorSequence> object. The nodes appear in the parse-tree
+in the order in which they were parsed from left-to-right.
+
+=back
+
+Each of these input objects are described in further detail in the
+sections which follow.
+
+=cut
+
+#############################################################################
+
+package Pod::InputSource;
+
+##---------------------------------------------------------------------------
+
+=begin __PRIVATE__
+
+=head1 B<Pod::InputSource>
+
+This object corresponds to an input source or stream of POD
+documentation. When parsing PODs, it is necessary to associate and store
+certain context information with each input source. All of this
+information is kept together with the stream itself in one of these
+C<Pod::InputSource> objects. Each such object is merely a wrapper around
+an C<IO::Handle> object of some kind (or at least something that
+implements the C<getline()> method). They have the following
+methods/attributes:
+
+=end __PRIVATE__
+
+=cut
+
+##---------------------------------------------------------------------------
+
+=begin __PRIVATE__
+
+=head2 B<new()>
+
+ my $pod_input1 = Pod::InputSource->new(-handle => $filehandle);
+ my $pod_input2 = new Pod::InputSource(-handle => $filehandle,
+ -name => $name);
+ my $pod_input3 = new Pod::InputSource(-handle => \*STDIN);
+ my $pod_input4 = Pod::InputSource->new(-handle => \*STDIN,
+ -name => "(STDIN)");
+
+This is a class method that constructs a C<Pod::InputSource> object and
+returns a reference to the new input source object. It takes one or more
+keyword arguments in the form of a hash. The keyword C<-handle> is
+required and designates the corresponding input handle. The keyword
+C<-name> is optional and specifies the name associated with the input
+handle (typically a file name).
+
+=end __PRIVATE__
+
+=cut
+
+sub new {
+ ## Determine if we were called via an object-ref or a classname
+ my $this = shift;
+ my $class = ref($this) || $this;
+
+ ## Any remaining arguments are treated as initial values for the
+ ## hash that is used to represent this object. Note that we default
+ ## certain values by specifying them *before* the arguments passed.
+ ## If they are in the argument list, they will override the defaults.
+ my $self = { -name => '(unknown)',
+ -handle => undef,
+ -was_cutting => 0,
+ @_ };
+
+ ## Bless ourselves into the desired class and perform any initialization
+ bless $self, $class;
+ return $self;
+}
+
+##---------------------------------------------------------------------------
+
+=begin __PRIVATE__
+
+=head2 B<name()>
+
+ my $filename = $pod_input->name();
+ $pod_input->name($new_filename_to_use);
+
+This method gets/sets the name of the input source (usually a filename).
+If no argument is given, it returns a string containing the name of
+the input source; otherwise it sets the name of the input source to the
+contents of the given argument.
+
+=end __PRIVATE__
+
+=cut
+
+sub name {
+ (@_ > 1) and $_[0]->{'-name'} = $_[1];
+ return $_[0]->{'-name'};
+}
+
+## allow 'filename' as an alias for 'name'
+*filename = \&name;
+
+##---------------------------------------------------------------------------
+
+=begin __PRIVATE__
+
+=head2 B<handle()>
+
+ my $handle = $pod_input->handle();
+
+Returns a reference to the handle object from which input is read (the
+one used to contructed this input source object).
+
+=end __PRIVATE__
+
+=cut
+
+sub handle {
+ return $_[0]->{'-handle'};
+}
+
+##---------------------------------------------------------------------------
+
+=begin __PRIVATE__
+
+=head2 B<was_cutting()>
+
+ print "Yes.\n" if ($pod_input->was_cutting());
+
+The value of the C<cutting> state (that the B<cutting()> method would
+have returned) immediately before any input was read from this input
+stream. After all input from this stream has been read, the C<cutting>
+state is restored to this value.
+
+=end __PRIVATE__
+
+=cut
+
+sub was_cutting {
+ (@_ > 1) and $_[0]->{-was_cutting} = $_[1];
+ return $_[0]->{-was_cutting};
+}
+
+##---------------------------------------------------------------------------
+
+#############################################################################
+
+package Pod::Paragraph;
+
+##---------------------------------------------------------------------------
+
+=head1 B<Pod::Paragraph>
+
+An object representing a paragraph of POD input text.
+It has the following methods/attributes:
+
+=cut
+
+##---------------------------------------------------------------------------
+
+=head2 Pod::Paragraph-E<gt>B<new()>
+
+ my $pod_para1 = Pod::Paragraph->new(-text => $text);
+ my $pod_para2 = Pod::Paragraph->new(-name => $cmd,
+ -text => $text);
+ my $pod_para3 = new Pod::Paragraph(-text => $text);
+ my $pod_para4 = new Pod::Paragraph(-name => $cmd,
+ -text => $text);
+ my $pod_para5 = Pod::Paragraph->new(-name => $cmd,
+ -text => $text,
+ -file => $filename,
+ -line => $line_number);
+
+This is a class method that constructs a C<Pod::Paragraph> object and
+returns a reference to the new paragraph object. It may be given one or
+two keyword arguments. The C<-text> keyword indicates the corresponding
+text of the POD paragraph. The C<-name> keyword indicates the name of
+the corresponding POD command, such as C<head1> or C<item> (it should
+I<not> contain the C<=> prefix); this is needed only if the POD
+paragraph corresponds to a command paragraph. The C<-file> and C<-line>
+keywords indicate the filename and line number corresponding to the
+beginning of the paragraph
+
+=cut
+
+sub new {
+ ## Determine if we were called via an object-ref or a classname
+ my $this = shift;
+ my $class = ref($this) || $this;
+
+ ## Any remaining arguments are treated as initial values for the
+ ## hash that is used to represent this object. Note that we default
+ ## certain values by specifying them *before* the arguments passed.
+ ## If they are in the argument list, they will override the defaults.
+ my $self = {
+ -name => undef,
+ -text => (@_ == 1) ? shift : undef,
+ -file => '<unknown-file>',
+ -line => 0,
+ -prefix => '=',
+ -separator => ' ',
+ -ptree => [],
+ @_
+ };
+
+ ## Bless ourselves into the desired class and perform any initialization
+ bless $self, $class;
+ return $self;
+}
+
+##---------------------------------------------------------------------------
+
+=head2 $pod_para-E<gt>B<cmd_name()>
+
+ my $para_cmd = $pod_para->cmd_name();
+
+If this paragraph is a command paragraph, then this method will return
+the name of the command (I<without> any leading C<=> prefix).
+
+=cut
+
+sub cmd_name {
+ (@_ > 1) and $_[0]->{'-name'} = $_[1];
+ return $_[0]->{'-name'};
+}
+
+## let name() be an alias for cmd_name()
+*name = \&cmd_name;
+
+##---------------------------------------------------------------------------
+
+=head2 $pod_para-E<gt>B<text()>
+
+ my $para_text = $pod_para->text();
+
+This method will return the corresponding text of the paragraph.
+
+=cut
+
+sub text {
+ (@_ > 1) and $_[0]->{'-text'} = $_[1];
+ return $_[0]->{'-text'};
+}
+
+##---------------------------------------------------------------------------
+
+=head2 $pod_para-E<gt>B<raw_text()>
+
+ my $raw_pod_para = $pod_para->raw_text();
+
+This method will return the I<raw> text of the POD paragraph, exactly
+as it appeared in the input.
+
+=cut
+
+sub raw_text {
+ return $_[0]->{'-text'} unless (defined $_[0]->{'-name'});
+ return $_[0]->{'-prefix'} . $_[0]->{'-name'} .
+ $_[0]->{'-separator'} . $_[0]->{'-text'};
+}
+
+##---------------------------------------------------------------------------
+
+=head2 $pod_para-E<gt>B<cmd_prefix()>
+
+ my $prefix = $pod_para->cmd_prefix();
+
+If this paragraph is a command paragraph, then this method will return
+the prefix used to denote the command (which should be the string "="
+or "==").
+
+=cut
+
+sub cmd_prefix {
+ return $_[0]->{'-prefix'};
+}
+
+##---------------------------------------------------------------------------
+
+=head2 $pod_para-E<gt>B<cmd_separator()>
+
+ my $separator = $pod_para->cmd_separator();
+
+If this paragraph is a command paragraph, then this method will return
+the text used to separate the command name from the rest of the
+paragraph (if any).
+
+=cut
+
+sub cmd_separator {
+ return $_[0]->{'-separator'};
+}
+
+##---------------------------------------------------------------------------
+
+=head2 $pod_para-E<gt>B<parse_tree()>
+
+ my $ptree = $pod_parser->parse_text( $pod_para->text() );
+ $pod_para->parse_tree( $ptree );
+ $ptree = $pod_para->parse_tree();
+
+This method will get/set the corresponding parse-tree of the paragraph's text.
+
+=cut
+
+sub parse_tree {
+ (@_ > 1) and $_[0]->{'-ptree'} = $_[1];
+ return $_[0]->{'-ptree'};
+}
+
+## let ptree() be an alias for parse_tree()
+*ptree = \&parse_tree;
+
+##---------------------------------------------------------------------------
+
+=head2 $pod_para-E<gt>B<file_line()>
+
+ my ($filename, $line_number) = $pod_para->file_line();
+ my $position = $pod_para->file_line();
+
+Returns the current filename and line number for the paragraph
+object. If called in a list context, it returns a list of two
+elements: first the filename, then the line number. If called in
+a scalar context, it returns a string containing the filename, followed
+by a colon (':'), followed by the line number.
+
+=cut
+
+sub file_line {
+ my @loc = ($_[0]->{'-file'} || '<unknown-file>',
+ $_[0]->{'-line'} || 0);
+ return (wantarray) ? @loc : join(':', @loc);
+}
+
+##---------------------------------------------------------------------------
+
+#############################################################################
+
+package Pod::InteriorSequence;
+
+##---------------------------------------------------------------------------
+
+=head1 B<Pod::InteriorSequence>
+
+An object representing a POD interior sequence command.
+It has the following methods/attributes:
+
+=cut
+
+##---------------------------------------------------------------------------
+
+=head2 Pod::InteriorSequence-E<gt>B<new()>
+
+ my $pod_seq1 = Pod::InteriorSequence->new(-name => $cmd
+ -ldelim => $delimiter);
+ my $pod_seq2 = new Pod::InteriorSequence(-name => $cmd,
+ -ldelim => $delimiter);
+ my $pod_seq3 = new Pod::InteriorSequence(-name => $cmd,
+ -ldelim => $delimiter,
+ -file => $filename,
+ -line => $line_number);
+
+ my $pod_seq4 = new Pod::InteriorSequence(-name => $cmd, $ptree);
+ my $pod_seq5 = new Pod::InteriorSequence($cmd, $ptree);
+
+This is a class method that constructs a C<Pod::InteriorSequence> object
+and returns a reference to the new interior sequence object. It should
+be given two keyword arguments. The C<-ldelim> keyword indicates the
+corresponding left-delimiter of the interior sequence (e.g. 'E<lt>').
+The C<-name> keyword indicates the name of the corresponding interior
+sequence command, such as C<I> or C<B> or C<C>. The C<-file> and
+C<-line> keywords indicate the filename and line number corresponding
+to the beginning of the interior sequence. If the C<$ptree> argument is
+given, it must be the last argument, and it must be either string, or
+else an array-ref suitable for passing to B<Pod::ParseTree::new> (or
+it may be a reference to a Pod::ParseTree object).
+
+=cut
+
+sub new {
+ ## Determine if we were called via an object-ref or a classname
+ my $this = shift;
+ my $class = ref($this) || $this;
+
+ ## See if first argument has no keyword
+ if (((@_ <= 2) or (@_ % 2)) and $_[0] !~ /^-\w/) {
+ ## Yup - need an implicit '-name' before first parameter
+ unshift @_, '-name';
+ }
+
+ ## See if odd number of args
+ if ((@_ % 2) != 0) {
+ ## Yup - need an implicit '-ptree' before the last parameter
+ splice @_, $#_, 0, '-ptree';
+ }
+
+ ## Any remaining arguments are treated as initial values for the
+ ## hash that is used to represent this object. Note that we default
+ ## certain values by specifying them *before* the arguments passed.
+ ## If they are in the argument list, they will override the defaults.
+ my $self = {
+ -name => (@_ == 1) ? $_[0] : undef,
+ -file => '<unknown-file>',
+ -line => 0,
+ -ldelim => '<',
+ -rdelim => '>',
+ @_
+ };
+
+ ## Initialize contents if they havent been already
+ my $ptree = $self->{'-ptree'} || new Pod::ParseTree();
+ if ( ref $ptree =~ /^(ARRAY)?$/ ) {
+ ## We have an array-ref, or a normal scalar. Pass it as an
+ ## an argument to the ptree-constructor
+ $ptree = new Pod::ParseTree($1 ? [$ptree] : $ptree);
+ }
+ $self->{'-ptree'} = $ptree;
+
+ ## Bless ourselves into the desired class and perform any initialization
+ bless $self, $class;
+ return $self;
+}
+
+##---------------------------------------------------------------------------
+
+=head2 $pod_seq-E<gt>B<cmd_name()>
+
+ my $seq_cmd = $pod_seq->cmd_name();
+
+The name of the interior sequence command.
+
+=cut
+
+sub cmd_name {
+ (@_ > 1) and $_[0]->{'-name'} = $_[1];
+ return $_[0]->{'-name'};
+}
+
+## let name() be an alias for cmd_name()
+*name = \&cmd_name;
+
+##---------------------------------------------------------------------------
+
+## Private subroutine to set the parent pointer of all the given
+## children that are interior-sequences to be $self
+
+sub _set_child2parent_links {
+ my ($self, @children) = @_;
+ ## Make sure any sequences know who their parent is
+ for (@children) {
+ next unless (length and ref and ref ne 'SCALAR');
+ if (UNIVERSAL::isa($_, 'Pod::InteriorSequence') or
+ UNIVERSAL::can($_, 'nested'))
+ {
+ $_->nested($self);
+ }
+ }
+}
+
+## Private subroutine to unset child->parent links
+
+sub _unset_child2parent_links {
+ my $self = shift;
+ $self->{'-parent_sequence'} = undef;
+ my $ptree = $self->{'-ptree'};
+ for (@$ptree) {
+ next unless (length and ref and ref ne 'SCALAR');
+ $_->_unset_child2parent_links()
+ if UNIVERSAL::isa($_, 'Pod::InteriorSequence');
+ }
+}
+
+##---------------------------------------------------------------------------
+
+=head2 $pod_seq-E<gt>B<prepend()>
+
+ $pod_seq->prepend($text);
+ $pod_seq1->prepend($pod_seq2);
+
+Prepends the given string or parse-tree or sequence object to the parse-tree
+of this interior sequence.
+
+=cut
+
+sub prepend {
+ my $self = shift;
+ $self->{'-ptree'}->prepend(@_);
+ _set_child2parent_links($self, @_);
+ return $self;
+}
+
+##---------------------------------------------------------------------------
+
+=head2 $pod_seq-E<gt>B<append()>
+
+ $pod_seq->append($text);
+ $pod_seq1->append($pod_seq2);
+
+Appends the given string or parse-tree or sequence object to the parse-tree
+of this interior sequence.
+
+=cut
+
+sub append {
+ my $self = shift;
+ $self->{'-ptree'}->append(@_);
+ _set_child2parent_links($self, @_);
+ return $self;
+}
+
+##---------------------------------------------------------------------------
+
+=head2 $pod_seq-E<gt>B<nested()>
+
+ $outer_seq = $pod_seq->nested || print "not nested";
+
+If this interior sequence is nested inside of another interior
+sequence, then the outer/parent sequence that contains it is
+returned. Otherwise C<undef> is returned.
+
+=cut
+
+sub nested {
+ my $self = shift;
+ (@_ == 1) and $self->{'-parent_sequence'} = shift;
+ return $self->{'-parent_sequence'} || undef;
+}
+
+##---------------------------------------------------------------------------
+
+=head2 $pod_seq-E<gt>B<raw_text()>
+
+ my $seq_raw_text = $pod_seq->raw_text();
+
+This method will return the I<raw> text of the POD interior sequence,
+exactly as it appeared in the input.
+
+=cut
+
+sub raw_text {
+ my $self = shift;
+ my $text = $self->{'-name'} . $self->{'-ldelim'};
+ for ( $self->{'-ptree'}->children ) {
+ $text .= (ref $_) ? $_->raw_text : $_;
+ }
+ $text .= $self->{'-rdelim'};
+ return $text;
+}
+
+##---------------------------------------------------------------------------
+
+=head2 $pod_seq-E<gt>B<left_delimiter()>
+
+ my $ldelim = $pod_seq->left_delimiter();
+
+The leftmost delimiter beginning the argument text to the interior
+sequence (should be "<").
+
+=cut
+
+sub left_delimiter {
+ (@_ > 1) and $_[0]->{'-ldelim'} = $_[1];
+ return $_[0]->{'-ldelim'};
+}
+
+## let ldelim() be an alias for left_delimiter()
+*ldelim = \&left_delimiter;
+
+##---------------------------------------------------------------------------
+
+=head2 $pod_seq-E<gt>B<right_delimiter()>
+
+The rightmost delimiter beginning the argument text to the interior
+sequence (should be ">").
+
+=cut
+
+sub right_delimiter {
+ (@_ > 1) and $_[0]->{'-rdelim'} = $_[1];
+ return $_[0]->{'-rdelim'};
+}
+
+## let rdelim() be an alias for right_delimiter()
+*rdelim = \&right_delimiter;
+
+##---------------------------------------------------------------------------
+
+=head2 $pod_seq-E<gt>B<parse_tree()>
+
+ my $ptree = $pod_parser->parse_text($paragraph_text);
+ $pod_seq->parse_tree( $ptree );
+ $ptree = $pod_seq->parse_tree();
+
+This method will get/set the corresponding parse-tree of the interior
+sequence's text.
+
+=cut
+
+sub parse_tree {
+ (@_ > 1) and $_[0]->{'-ptree'} = $_[1];
+ return $_[0]->{'-ptree'};
+}
+
+## let ptree() be an alias for parse_tree()
+*ptree = \&parse_tree;
+
+##---------------------------------------------------------------------------
+
+=head2 $pod_seq-E<gt>B<file_line()>
+
+ my ($filename, $line_number) = $pod_seq->file_line();
+ my $position = $pod_seq->file_line();
+
+Returns the current filename and line number for the interior sequence
+object. If called in a list context, it returns a list of two
+elements: first the filename, then the line number. If called in
+a scalar context, it returns a string containing the filename, followed
+by a colon (':'), followed by the line number.
+
+=cut
+
+sub file_line {
+ my @loc = ($_[0]->{'-file'} || '<unknown-file>',
+ $_[0]->{'-line'} || 0);
+ return (wantarray) ? @loc : join(':', @loc);
+}
+
+##---------------------------------------------------------------------------
+
+=head2 Pod::InteriorSequence::B<DESTROY()>
+
+This method performs any necessary cleanup for the interior-sequence.
+If you override this method then it is B<imperative> that you invoke
+the parent method from within your own method, otherwise
+I<interior-sequence storage will not be reclaimed upon destruction!>
+
+=cut
+
+sub DESTROY {
+ ## We need to get rid of all child->parent pointers throughout the
+ ## tree so their reference counts will go to zero and they can be
+ ## garbage-collected
+ _unset_child2parent_links(@_);
+}
+
+##---------------------------------------------------------------------------
+
+#############################################################################
+
+package Pod::ParseTree;
+
+##---------------------------------------------------------------------------
+
+=head1 B<Pod::ParseTree>
+
+This object corresponds to a tree of parsed POD text. As POD text is
+scanned from left to right, it is parsed into an ordered list of
+text-strings and B<Pod::InteriorSequence> objects (in order of
+appearance). A B<Pod::ParseTree> object corresponds to this list of
+strings and sequences. Each interior sequence in the parse-tree may
+itself contain a parse-tree (since interior sequences may be nested).
+
+=cut
+
+##---------------------------------------------------------------------------
+
+=head2 Pod::ParseTree-E<gt>B<new()>
+
+ my $ptree1 = Pod::ParseTree->new;
+ my $ptree2 = new Pod::ParseTree;
+ my $ptree4 = Pod::ParseTree->new($array_ref);
+ my $ptree3 = new Pod::ParseTree($array_ref);
+
+This is a class method that constructs a C<Pod::Parse_tree> object and
+returns a reference to the new parse-tree. If a single-argument is given,
+it must be a reference to an array, and is used to initialize the root
+(top) of the parse tree.
+
+=cut
+
+sub new {
+ ## Determine if we were called via an object-ref or a classname
+ my $this = shift;
+ my $class = ref($this) || $this;
+
+ my $self = (@_ == 1 and ref $_[0]) ? $_[0] : [];
+
+ ## Bless ourselves into the desired class and perform any initialization
+ bless $self, $class;
+ return $self;
+}
+
+##---------------------------------------------------------------------------
+
+=head2 $ptree-E<gt>B<top()>
+
+ my $top_node = $ptree->top();
+ $ptree->top( $top_node );
+ $ptree->top( @children );
+
+This method gets/sets the top node of the parse-tree. If no arguments are
+given, it returns the topmost node in the tree (the root), which is also
+a B<Pod::ParseTree>. If it is given a single argument that is a reference,
+then the reference is assumed to a parse-tree and becomes the new top node.
+Otherwise, if arguments are given, they are treated as the new list of
+children for the top node.
+
+=cut
+
+sub top {
+ my $self = shift;
+ if (@_ > 0) {
+ @{ $self } = (@_ == 1 and ref $_[0]) ? ${ @_ } : @_;
+ }
+ return $self;
+}
+
+## let parse_tree() & ptree() be aliases for the 'top' method
+*parse_tree = *ptree = \⊤
+
+##---------------------------------------------------------------------------
+
+=head2 $ptree-E<gt>B<children()>
+
+This method gets/sets the children of the top node in the parse-tree.
+If no arguments are given, it returns the list (array) of children
+(each of which should be either a string or a B<Pod::InteriorSequence>.
+Otherwise, if arguments are given, they are treated as the new list of
+children for the top node.
+
+=cut
+
+sub children {
+ my $self = shift;
+ if (@_ > 0) {
+ @{ $self } = (@_ == 1 and ref $_[0]) ? ${ @_ } : @_;
+ }
+ return @{ $self };
+}
+
+##---------------------------------------------------------------------------
+
+=head2 $ptree-E<gt>B<prepend()>
+
+This method prepends the given text or parse-tree to the current parse-tree.
+If the first item on the parse-tree is text and the argument is also text,
+then the text is prepended to the first item (not added as a separate string).
+Otherwise the argument is added as a new string or parse-tree I<before>
+the current one.
+
+=cut
+
+use vars qw(@ptree); ## an alias used for performance reasons
+
+sub prepend {
+ my $self = shift;
+ local *ptree = $self;
+ for (@_) {
+ next unless length;
+ if (@ptree && !(ref $ptree[0]) && !(ref $_)) {
+ $ptree[0] = $_ . $ptree[0];
+ }
+ else {
+ unshift @ptree, $_;
+ }
+ }
+}
+
+##---------------------------------------------------------------------------
+
+=head2 $ptree-E<gt>B<append()>
+
+This method appends the given text or parse-tree to the current parse-tree.
+If the last item on the parse-tree is text and the argument is also text,
+then the text is appended to the last item (not added as a separate string).
+Otherwise the argument is added as a new string or parse-tree I<after>
+the current one.
+
+=cut
+
+sub append {
+ my $self = shift;
+ local *ptree = $self;
+ my $can_append = @ptree && !(ref $ptree[-1]);
+ for (@_) {
+ if (ref) {
+ push @ptree, $_;
+ }
+ elsif(!length) {
+ next;
+ }
+ elsif ($can_append) {
+ $ptree[-1] .= $_;
+ }
+ else {
+ push @ptree, $_;
+ }
+ }
+}
+
+=head2 $ptree-E<gt>B<raw_text()>
+
+ my $ptree_raw_text = $ptree->raw_text();
+
+This method will return the I<raw> text of the POD parse-tree
+exactly as it appeared in the input.
+
+=cut
+
+sub raw_text {
+ my $self = shift;
+ my $text = '';
+ for ( @$self ) {
+ $text .= (ref $_) ? $_->raw_text : $_;
+ }
+ return $text;
+}
+
+##---------------------------------------------------------------------------
+
+## Private routines to set/unset child->parent links
+
+sub _unset_child2parent_links {
+ my $self = shift;
+ local *ptree = $self;
+ for (@ptree) {
+ next unless (defined and length and ref and ref ne 'SCALAR');
+ $_->_unset_child2parent_links()
+ if UNIVERSAL::isa($_, 'Pod::InteriorSequence');
+ }
+}
+
+sub _set_child2parent_links {
+ ## nothing to do, Pod::ParseTrees cant have parent pointers
+}
+
+=head2 Pod::ParseTree::B<DESTROY()>
+
+This method performs any necessary cleanup for the parse-tree.
+If you override this method then it is B<imperative>
+that you invoke the parent method from within your own method,
+otherwise I<parse-tree storage will not be reclaimed upon destruction!>
+
+=cut
+
+sub DESTROY {
+ ## We need to get rid of all child->parent pointers throughout the
+ ## tree so their reference counts will go to zero and they can be
+ ## garbage-collected
+ _unset_child2parent_links(@_);
+}
+
+#############################################################################
+
+=head1 SEE ALSO
+
+See L<Pod::Parser>, L<Pod::Select>
+
+=head1 AUTHOR
+
+Please report bugs using L<http://rt.cpan.org>.
+
+Brad Appleton E<lt>bradapp at enteract.comE<gt>
+
+=cut
+
+1;
Copied: trunk/contrib/perl/lib/Pod/LaTeX.pm (from rev 6437, vendor/perl/5.18.1/lib/Pod/LaTeX.pm)
===================================================================
--- trunk/contrib/perl/lib/Pod/LaTeX.pm (rev 0)
+++ trunk/contrib/perl/lib/Pod/LaTeX.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,1876 @@
+package Pod::LaTeX;
+
+=head1 NAME
+
+Pod::LaTeX - Convert Pod data to formatted Latex
+
+=head1 SYNOPSIS
+
+ use Pod::LaTeX;
+ my $parser = Pod::LaTeX->new ( );
+
+ $parser->parse_from_filehandle;
+
+ $parser->parse_from_file ('file.pod', 'file.tex');
+
+=head1 DESCRIPTION
+
+C<Pod::LaTeX> is a module to convert documentation in the Pod format
+into Latex. The L<B<pod2latex>|pod2latex> X<pod2latex> command uses
+this module for translation.
+
+C<Pod::LaTeX> is a derived class from L<Pod::Select|Pod::Select>.
+
+=cut
+
+
+use strict;
+require Pod::ParseUtils;
+use base qw/ Pod::Select /;
+
+# use Data::Dumper; # for debugging
+use Carp;
+
+use vars qw/ $VERSION %HTML_Escapes @LatexSections /;
+
+$VERSION = '0.58';
+
+# Definitions of =headN -> latex mapping
+ at LatexSections = (qw/
+ chapter
+ section
+ subsection
+ subsubsection
+ paragraph
+ subparagraph
+ /);
+
+# Standard escape sequences converted to Latex.
+# The Unicode name of each character is given in the comments.
+# Complete LaTeX set added by Peter Acklam.
+
+%HTML_Escapes = (
+ 'sol' => '\textfractionsolidus{}', # xxx - or should it be just '/'
+ 'verbar' => '|',
+
+ # The stuff below is based on the information available at
+ # http://www.w3.org/TR/html401/sgml/entities.html
+
+ # All characters in the range 0xA0-0xFF of the ISO 8859-1 character set.
+ # Several of these characters require the `textcomp' LaTeX package.
+ 'nbsp' => q|~|, # 0xA0 - no-break space = non-breaking space
+ 'iexcl' => q|\textexclamdown{}|, # 0xA1 - inverted exclamation mark
+ 'cent' => q|\textcent{}|, # 0xA2 - cent sign
+ 'pound' => q|\textsterling{}|, # 0xA3 - pound sign
+ 'curren' => q|\textcurrency{}|, # 0xA4 - currency sign
+ 'yen' => q|\textyen{}|, # 0xA5 - yen sign = yuan sign
+ 'brvbar' => q|\textbrokenbar{}|, # 0xA6 - broken bar = broken vertical bar
+ 'sect' => q|\textsection{}|, # 0xA7 - section sign
+ 'uml' => q|\textasciidieresis{}|, # 0xA8 - diaeresis = spacing diaeresis
+ 'copy' => q|\textcopyright{}|, # 0xA9 - copyright sign
+ 'ordf' => q|\textordfeminine{}|, # 0xAA - feminine ordinal indicator
+ 'laquo' => q|\guillemotleft{}|, # 0xAB - left-pointing double angle quotation mark = left pointing guillemet
+ 'not' => q|\textlnot{}|, # 0xAC - not sign
+ 'shy' => q|\-|, # 0xAD - soft hyphen = discretionary hyphen
+ 'reg' => q|\textregistered{}|, # 0xAE - registered sign = registered trade mark sign
+ 'macr' => q|\textasciimacron{}|, # 0xAF - macron = spacing macron = overline = APL overbar
+ 'deg' => q|\textdegree{}|, # 0xB0 - degree sign
+ 'plusmn' => q|\textpm{}|, # 0xB1 - plus-minus sign = plus-or-minus sign
+ 'sup2' => q|\texttwosuperior{}|, # 0xB2 - superscript two = superscript digit two = squared
+ 'sup3' => q|\textthreesuperior{}|, # 0xB3 - superscript three = superscript digit three = cubed
+ 'acute' => q|\textasciiacute{}|, # 0xB4 - acute accent = spacing acute
+ 'micro' => q|\textmu{}|, # 0xB5 - micro sign
+ 'para' => q|\textparagraph{}|, # 0xB6 - pilcrow sign = paragraph sign
+ 'middot' => q|\textperiodcentered{}|, # 0xB7 - middle dot = Georgian comma = Greek middle dot
+ 'cedil' => q|\c{}|, # 0xB8 - cedilla = spacing cedilla
+ 'sup1' => q|\textonesuperior{}|, # 0xB9 - superscript one = superscript digit one
+ 'ordm' => q|\textordmasculine{}|, # 0xBA - masculine ordinal indicator
+ 'raquo' => q|\guillemotright{}|, # 0xBB - right-pointing double angle quotation mark = right pointing guillemet
+ 'frac14' => q|\textonequarter{}|, # 0xBC - vulgar fraction one quarter = fraction one quarter
+ 'frac12' => q|\textonehalf{}|, # 0xBD - vulgar fraction one half = fraction one half
+ 'frac34' => q|\textthreequarters{}|, # 0xBE - vulgar fraction three quarters = fraction three quarters
+ 'iquest' => q|\textquestiondown{}|, # 0xBF - inverted question mark = turned question mark
+ 'Agrave' => q|\`A|, # 0xC0 - latin capital letter A with grave = latin capital letter A grave
+ 'Aacute' => q|\'A|, # 0xC1 - latin capital letter A with acute
+ 'Acirc' => q|\^A|, # 0xC2 - latin capital letter A with circumflex
+ 'Atilde' => q|\~A|, # 0xC3 - latin capital letter A with tilde
+ 'Auml' => q|\"A|, # 0xC4 - latin capital letter A with diaeresis
+ 'Aring' => q|\AA{}|, # 0xC5 - latin capital letter A with ring above = latin capital letter A ring
+ 'AElig' => q|\AE{}|, # 0xC6 - latin capital letter AE = latin capital ligature AE
+ 'Ccedil' => q|\c{C}|, # 0xC7 - latin capital letter C with cedilla
+ 'Egrave' => q|\`E|, # 0xC8 - latin capital letter E with grave
+ 'Eacute' => q|\'E|, # 0xC9 - latin capital letter E with acute
+ 'Ecirc' => q|\^E|, # 0xCA - latin capital letter E with circumflex
+ 'Euml' => q|\"E|, # 0xCB - latin capital letter E with diaeresis
+ 'Igrave' => q|\`I|, # 0xCC - latin capital letter I with grave
+ 'Iacute' => q|\'I|, # 0xCD - latin capital letter I with acute
+ 'Icirc' => q|\^I|, # 0xCE - latin capital letter I with circumflex
+ 'Iuml' => q|\"I|, # 0xCF - latin capital letter I with diaeresis
+ 'ETH' => q|\DH{}|, # 0xD0 - latin capital letter ETH
+ 'Ntilde' => q|\~N|, # 0xD1 - latin capital letter N with tilde
+ 'Ograve' => q|\`O|, # 0xD2 - latin capital letter O with grave
+ 'Oacute' => q|\'O|, # 0xD3 - latin capital letter O with acute
+ 'Ocirc' => q|\^O|, # 0xD4 - latin capital letter O with circumflex
+ 'Otilde' => q|\~O|, # 0xD5 - latin capital letter O with tilde
+ 'Ouml' => q|\"O|, # 0xD6 - latin capital letter O with diaeresis
+ 'times' => q|\texttimes{}|, # 0xD7 - multiplication sign
+ 'Oslash' => q|\O{}|, # 0xD8 - latin capital letter O with stroke = latin capital letter O slash
+ 'Ugrave' => q|\`U|, # 0xD9 - latin capital letter U with grave
+ 'Uacute' => q|\'U|, # 0xDA - latin capital letter U with acute
+ 'Ucirc' => q|\^U|, # 0xDB - latin capital letter U with circumflex
+ 'Uuml' => q|\"U|, # 0xDC - latin capital letter U with diaeresis
+ 'Yacute' => q|\'Y|, # 0xDD - latin capital letter Y with acute
+ 'THORN' => q|\TH{}|, # 0xDE - latin capital letter THORN
+ 'szlig' => q|\ss{}|, # 0xDF - latin small letter sharp s = ess-zed
+ 'agrave' => q|\`a|, # 0xE0 - latin small letter a with grave = latin small letter a grave
+ 'aacute' => q|\'a|, # 0xE1 - latin small letter a with acute
+ 'acirc' => q|\^a|, # 0xE2 - latin small letter a with circumflex
+ 'atilde' => q|\~a|, # 0xE3 - latin small letter a with tilde
+ 'auml' => q|\"a|, # 0xE4 - latin small letter a with diaeresis
+ 'aring' => q|\aa{}|, # 0xE5 - latin small letter a with ring above = latin small letter a ring
+ 'aelig' => q|\ae{}|, # 0xE6 - latin small letter ae = latin small ligature ae
+ 'ccedil' => q|\c{c}|, # 0xE7 - latin small letter c with cedilla
+ 'egrave' => q|\`e|, # 0xE8 - latin small letter e with grave
+ 'eacute' => q|\'e|, # 0xE9 - latin small letter e with acute
+ 'ecirc' => q|\^e|, # 0xEA - latin small letter e with circumflex
+ 'euml' => q|\"e|, # 0xEB - latin small letter e with diaeresis
+ 'igrave' => q|\`i|, # 0xEC - latin small letter i with grave
+ 'iacute' => q|\'i|, # 0xED - latin small letter i with acute
+ 'icirc' => q|\^i|, # 0xEE - latin small letter i with circumflex
+ 'iuml' => q|\"i|, # 0xEF - latin small letter i with diaeresis
+ 'eth' => q|\dh{}|, # 0xF0 - latin small letter eth
+ 'ntilde' => q|\~n|, # 0xF1 - latin small letter n with tilde
+ 'ograve' => q|\`o|, # 0xF2 - latin small letter o with grave
+ 'oacute' => q|\'o|, # 0xF3 - latin small letter o with acute
+ 'ocirc' => q|\^o|, # 0xF4 - latin small letter o with circumflex
+ 'otilde' => q|\~o|, # 0xF5 - latin small letter o with tilde
+ 'ouml' => q|\"o|, # 0xF6 - latin small letter o with diaeresis
+ 'divide' => q|\textdiv{}|, # 0xF7 - division sign
+ 'oslash' => q|\o{}|, # 0xF8 - latin small letter o with stroke, = latin small letter o slash
+ 'ugrave' => q|\`u|, # 0xF9 - latin small letter u with grave
+ 'uacute' => q|\'u|, # 0xFA - latin small letter u with acute
+ 'ucirc' => q|\^u|, # 0xFB - latin small letter u with circumflex
+ 'uuml' => q|\"u|, # 0xFC - latin small letter u with diaeresis
+ 'yacute' => q|\'y|, # 0xFD - latin small letter y with acute
+ 'thorn' => q|\th{}|, # 0xFE - latin small letter thorn
+ 'yuml' => q|\"y|, # 0xFF - latin small letter y with diaeresis
+
+ # Latin Extended-B
+ 'fnof' => q|\textflorin{}|, # latin small f with hook = function = florin
+
+ # Greek
+ 'Alpha' => q|$\mathrm{A}$|, # greek capital letter alpha
+ 'Beta' => q|$\mathrm{B}$|, # greek capital letter beta
+ 'Gamma' => q|$\Gamma$|, # greek capital letter gamma
+ 'Delta' => q|$\Delta$|, # greek capital letter delta
+ 'Epsilon' => q|$\mathrm{E}$|, # greek capital letter epsilon
+ 'Zeta' => q|$\mathrm{Z}$|, # greek capital letter zeta
+ 'Eta' => q|$\mathrm{H}$|, # greek capital letter eta
+ 'Theta' => q|$\Theta$|, # greek capital letter theta
+ 'Iota' => q|$\mathrm{I}$|, # greek capital letter iota
+ 'Kappa' => q|$\mathrm{K}$|, # greek capital letter kappa
+ 'Lambda' => q|$\Lambda$|, # greek capital letter lambda
+ 'Mu' => q|$\mathrm{M}$|, # greek capital letter mu
+ 'Nu' => q|$\mathrm{N}$|, # greek capital letter nu
+ 'Xi' => q|$\Xi$|, # greek capital letter xi
+ 'Omicron' => q|$\mathrm{O}$|, # greek capital letter omicron
+ 'Pi' => q|$\Pi$|, # greek capital letter pi
+ 'Rho' => q|$\mathrm{R}$|, # greek capital letter rho
+ 'Sigma' => q|$\Sigma$|, # greek capital letter sigma
+ 'Tau' => q|$\mathrm{T}$|, # greek capital letter tau
+ 'Upsilon' => q|$\Upsilon$|, # greek capital letter upsilon
+ 'Phi' => q|$\Phi$|, # greek capital letter phi
+ 'Chi' => q|$\mathrm{X}$|, # greek capital letter chi
+ 'Psi' => q|$\Psi$|, # greek capital letter psi
+ 'Omega' => q|$\Omega$|, # greek capital letter omega
+
+ 'alpha' => q|$\alpha$|, # greek small letter alpha
+ 'beta' => q|$\beta$|, # greek small letter beta
+ 'gamma' => q|$\gamma$|, # greek small letter gamma
+ 'delta' => q|$\delta$|, # greek small letter delta
+ 'epsilon' => q|$\epsilon$|, # greek small letter epsilon
+ 'zeta' => q|$\zeta$|, # greek small letter zeta
+ 'eta' => q|$\eta$|, # greek small letter eta
+ 'theta' => q|$\theta$|, # greek small letter theta
+ 'iota' => q|$\iota$|, # greek small letter iota
+ 'kappa' => q|$\kappa$|, # greek small letter kappa
+ 'lambda' => q|$\lambda$|, # greek small letter lambda
+ 'mu' => q|$\mu$|, # greek small letter mu
+ 'nu' => q|$\nu$|, # greek small letter nu
+ 'xi' => q|$\xi$|, # greek small letter xi
+ 'omicron' => q|$o$|, # greek small letter omicron
+ 'pi' => q|$\pi$|, # greek small letter pi
+ 'rho' => q|$\rho$|, # greek small letter rho
+# 'sigmaf' => q||, # greek small letter final sigma
+ 'sigma' => q|$\sigma$|, # greek small letter sigma
+ 'tau' => q|$\tau$|, # greek small letter tau
+ 'upsilon' => q|$\upsilon$|, # greek small letter upsilon
+ 'phi' => q|$\phi$|, # greek small letter phi
+ 'chi' => q|$\chi$|, # greek small letter chi
+ 'psi' => q|$\psi$|, # greek small letter psi
+ 'omega' => q|$\omega$|, # greek small letter omega
+# 'thetasym' => q||, # greek small letter theta symbol
+# 'upsih' => q||, # greek upsilon with hook symbol
+# 'piv' => q||, # greek pi symbol
+
+ # General Punctuation
+ 'bull' => q|\textbullet{}|, # bullet = black small circle
+ # bullet is NOT the same as bullet operator
+ 'hellip' => q|\textellipsis{}|, # horizontal ellipsis = three dot leader
+ 'prime' => q|\textquotesingle{}|, # prime = minutes = feet
+ 'Prime' => q|\textquotedbl{}|, # double prime = seconds = inches
+ 'oline' => q|\textasciimacron{}|, # overline = spacing overscore
+ 'frasl' => q|\textfractionsolidus{}|, # fraction slash
+
+ # Letterlike Symbols
+ 'weierp' => q|$\wp$|, # script capital P = power set = Weierstrass p
+ 'image' => q|$\Re$|, # blackletter capital I = imaginary part
+ 'real' => q|$\Im$|, # blackletter capital R = real part symbol
+ 'trade' => q|\texttrademark{}|, # trade mark sign
+# 'alefsym' => q||, # alef symbol = first transfinite cardinal
+ # alef symbol is NOT the same as hebrew letter alef, although the same
+ # glyph could be used to depict both characters
+
+ # Arrows
+ 'larr' => q|\textleftarrow{}|, # leftwards arrow
+ 'uarr' => q|\textuparrow{}|, # upwards arrow
+ 'rarr' => q|\textrightarrow{}|, # rightwards arrow
+ 'darr' => q|\textdownarrow{}|, # downwards arrow
+ 'harr' => q|$\leftrightarrow$|, # left right arrow
+# 'crarr' => q||, # downwards arrow with corner leftwards = carriage return
+ 'lArr' => q|$\Leftarrow$|, # leftwards double arrow
+ # ISO 10646 does not say that lArr is the same as the 'is implied by'
+ # arrow but also does not have any other character for that function. So
+ # lArr can be used for 'is implied by' as ISOtech suggests
+ 'uArr' => q|$\Uparrow$|, # upwards double arrow
+ 'rArr' => q|$\Rightarrow$|, # rightwards double arrow
+ # ISO 10646 does not say this is the 'implies' character but does not
+ # have another character with this function so ? rArr can be used for
+ # 'implies' as ISOtech suggests
+ 'dArr' => q|$\Downarrow$|, # downwards double arrow
+ 'hArr' => q|$\Leftrightarrow$|, # left right double arrow
+
+ # Mathematical Operators.
+ # Some of these require the `amssymb' package.
+ 'forall' => q|$\forall$|, # for all
+ 'part' => q|$\partial$|, # partial differential
+ 'exist' => q|$\exists$|, # there exists
+ 'empty' => q|$\emptyset$|, # empty set = null set = diameter
+ 'nabla' => q|$\nabla$|, # nabla = backward difference
+ 'isin' => q|$\in$|, # element of
+ 'notin' => q|$\notin$|, # not an element of
+ 'ni' => q|$\ni$|, # contains as member
+ 'prod' => q|$\prod$|, # n-ary product = product sign
+ # prod is NOT the same character as 'greek capital letter pi' though the
+ # same glyph might be used for both
+ 'sum' => q|$\sum$|, # n-ary sumation
+ # sum is NOT the same character as 'greek capital letter sigma' though
+ # the same glyph might be used for both
+ 'minus' => q|$-$|, # minus sign
+ 'lowast' => q|$\ast$|, # asterisk operator
+ 'radic' => q|$\surd$|, # square root = radical sign
+ 'prop' => q|$\propto$|, # proportional to
+ 'infin' => q|$\infty$|, # infinity
+ 'ang' => q|$\angle$|, # angle
+ 'and' => q|$\wedge$|, # logical and = wedge
+ 'or' => q|$\vee$|, # logical or = vee
+ 'cap' => q|$\cap$|, # intersection = cap
+ 'cup' => q|$\cup$|, # union = cup
+ 'int' => q|$\int$|, # integral
+ 'there4' => q|$\therefore$|, # therefore
+ 'sim' => q|$\sim$|, # tilde operator = varies with = similar to
+ # tilde operator is NOT the same character as the tilde
+ 'cong' => q|$\cong$|, # approximately equal to
+ 'asymp' => q|$\asymp$|, # almost equal to = asymptotic to
+ 'ne' => q|$\neq$|, # not equal to
+ 'equiv' => q|$\equiv$|, # identical to
+ 'le' => q|$\leq$|, # less-than or equal to
+ 'ge' => q|$\geq$|, # greater-than or equal to
+ 'sub' => q|$\subset$|, # subset of
+ 'sup' => q|$\supset$|, # superset of
+ # note that nsup, 'not a superset of' is not covered by the Symbol font
+ # encoding and is not included.
+ 'nsub' => q|$\not\subset$|, # not a subset of
+ 'sube' => q|$\subseteq$|, # subset of or equal to
+ 'supe' => q|$\supseteq$|, # superset of or equal to
+ 'oplus' => q|$\oplus$|, # circled plus = direct sum
+ 'otimes' => q|$\otimes$|, # circled times = vector product
+ 'perp' => q|$\perp$|, # up tack = orthogonal to = perpendicular
+ 'sdot' => q|$\cdot$|, # dot operator
+ # dot operator is NOT the same character as middle dot
+
+ # Miscellaneous Technical
+ 'lceil' => q|$\lceil$|, # left ceiling = apl upstile
+ 'rceil' => q|$\rceil$|, # right ceiling
+ 'lfloor' => q|$\lfloor$|, # left floor = apl downstile
+ 'rfloor' => q|$\rfloor$|, # right floor
+ 'lang' => q|$\langle$|, # left-pointing angle bracket = bra
+ # lang is NOT the same character as 'less than' or 'single left-pointing
+ # angle quotation mark'
+ 'rang' => q|$\rangle$|, # right-pointing angle bracket = ket
+ # rang is NOT the same character as 'greater than' or 'single
+ # right-pointing angle quotation mark'
+
+ # Geometric Shapes
+ 'loz' => q|$\lozenge$|, # lozenge
+
+ # Miscellaneous Symbols
+ 'spades' => q|$\spadesuit$|, # black spade suit
+ 'clubs' => q|$\clubsuit$|, # black club suit = shamrock
+ 'hearts' => q|$\heartsuit$|, # black heart suit = valentine
+ 'diams' => q|$\diamondsuit$|, # black diamond suit
+
+ # C0 Controls and Basic Latin
+ 'quot' => q|"|, # quotation mark = APL quote ["]
+ 'amp' => q|\&|, # ampersand
+ 'lt' => q|<|, # less-than sign
+ 'gt' => q|>|, # greater-than sign
+ 'OElig' => q|\OE{}|, # latin capital ligature OE
+ 'oelig' => q|\oe{}|, # latin small ligature oe
+ 'Scaron' => q|\v{S}|, # latin capital letter S with caron
+ 'scaron' => q|\v{s}|, # latin small letter s with caron
+ 'Yuml' => q|\"Y|, # latin capital letter Y with diaeresis
+ 'circ' => q|\textasciicircum{}|, # modifier letter circumflex accent
+ 'tilde' => q|\textasciitilde{}|, # small tilde
+ 'ensp' => q|\phantom{n}|, # en space
+ 'emsp' => q|\hspace{1em}|, # em space
+ 'thinsp' => q|\,|, # thin space
+ 'zwnj' => q|{}|, # zero width non-joiner
+# 'zwj' => q||, # zero width joiner
+# 'lrm' => q||, # left-to-right mark
+# 'rlm' => q||, # right-to-left mark
+ 'ndash' => q|--|, # en dash
+ 'mdash' => q|---|, # em dash
+ 'lsquo' => q|\textquoteleft{}|, # left single quotation mark
+ 'rsquo' => q|\textquoteright{}|, # right single quotation mark
+ 'sbquo' => q|\quotesinglbase{}|, # single low-9 quotation mark
+ 'ldquo' => q|\textquotedblleft{}|, # left double quotation mark
+ 'rdquo' => q|\textquotedblright{}|, # right double quotation mark
+ 'bdquo' => q|\quotedblbase{}|, # double low-9 quotation mark
+ 'dagger' => q|\textdagger{}|, # dagger
+ 'Dagger' => q|\textdaggerdbl{}|, # double dagger
+ 'permil' => q|\textperthousand{}|, # per mille sign
+ 'lsaquo' => q|\guilsinglleft{}|, # single left-pointing angle quotation mark
+ 'rsaquo' => q|\guilsinglright{}|, # single right-pointing angle quotation mark
+ 'euro' => q|\texteuro{}|, # euro sign
+);
+
+=head1 OBJECT METHODS
+
+The following methods are provided in this module. Methods inherited
+from C<Pod::Select> are not described in the public interface.
+
+=over 4
+
+=begin __PRIVATE__
+
+=item C<initialize>
+
+Initialise the object. This method is subclassed from C<Pod::Parser>.
+The base class method is invoked. This method defines the default
+behaviour of the object unless overridden by supplying arguments to
+the constructor.
+
+Internal settings are defaulted as well as the public instance data.
+Internal hash values are accessed directly (rather than through
+a method) and start with an underscore.
+
+This method should not be invoked by the user directly.
+
+=end __PRIVATE__
+
+=cut
+
+
+
+# - An array for nested lists
+
+# Arguments have already been read by this point
+
+sub initialize {
+ my $self = shift;
+
+ # print Dumper($self);
+
+ # Internals
+ $self->{_Lists} = []; # For nested lists
+ $self->{_suppress_all_para} = 0; # For =begin blocks
+ $self->{_dont_modify_any_para}=0; # For =begin blocks
+ $self->{_CURRENT_HEAD1} = ''; # Name of current HEAD1 section
+
+ # Options - only initialise if not already set
+
+ # Cause the '=head1 NAME' field to be treated specially
+ # The contents of the NAME paragraph will be converted
+ # to a section title. All subsequent =head1 will be converted
+ # to =head2 and down. Will not affect =head1's prior to NAME
+ # Assumes: 'Module - purpose' format
+ # Also creates a purpose field
+ # The name is used for Labeling of the subsequent subsections
+ $self->{ReplaceNAMEwithSection} = 0
+ unless exists $self->{ReplaceNAMEwithSection};
+ $self->{AddPreamble} = 1 # make full latex document
+ unless exists $self->{AddPreamble};
+ $self->{StartWithNewPage} = 0 # Start new page for pod section
+ unless exists $self->{StartWithNewPage};
+ $self->{TableOfContents} = 0 # Add table of contents
+ unless exists $self->{TableOfContents}; # only relevent if AddPreamble=1
+ $self->{AddPostamble} = 1 # Add closing latex code at end
+ unless exists $self->{AddPostamble}; # effectively end{document} and index
+ $self->{MakeIndex} = 1 # Add index (only relevant AddPostamble
+ unless exists $self->{MakeIndex}; # and AddPreamble)
+
+ $self->{UniqueLabels} = 1 # Use label unique for each pod
+ unless exists $self->{UniqueLabels}; # either based on the filename
+ # or supplied
+
+ # Control the level of =head1. default is \section
+ #
+ $self->{Head1Level} = 1 # Offset in latex sections
+ unless exists $self->{Head1Level}; # 0 is chapter, 2 is subsection
+
+ # Control at which level numbering of sections is turned off
+ # ie subsection becomes subsection*
+ # The numbering is relative to the latex sectioning commands
+ # and is independent of Pod heading level
+ # default is to number \section but not \subsection
+ $self->{LevelNoNum} = 2
+ unless exists $self->{LevelNoNum};
+
+ # Label to be used as prefix to all internal section names
+ # If not defined will attempt to derive it from the filename
+ # This can not happen when running parse_from_filehandle though
+ # hence the ability to set the label externally
+ # The label could then be Pod::Parser_DESCRIPTION or somesuch
+
+ $self->{Label} = undef # label to be used as prefix
+ unless exists $self->{Label}; # to all internal section names
+
+ # These allow the caller to add arbritrary latex code to
+ # start and end of document. AddPreamble and AddPostamble are ignored
+ # if these are set.
+ # Also MakeIndex and TableOfContents are also ignored.
+ $self->{UserPreamble} = undef # User supplied start (AddPreamble =1)
+ unless exists $self->{Label};
+ $self->{UserPostamble} = undef # Use supplied end (AddPostamble=1)
+ unless exists $self->{Label};
+
+ # Run base initialize
+ $self->SUPER::initialize;
+
+}
+
+=back
+
+=head2 Data Accessors
+
+The following methods are provided for accessing instance data. These
+methods should be used for accessing configuration parameters rather
+than assuming the object is a hash.
+
+Default values can be supplied by using these names as keys to a hash
+of arguments when using the C<new()> constructor.
+
+=over 4
+
+=item B<AddPreamble>
+
+Logical to control whether a C<latex> preamble is to be written.
+If true, a valid C<latex> preamble is written before the pod data is written.
+This is similar to:
+
+ \documentclass{article}
+ \usepackage[T1]{fontenc}
+ \usepackage{textcomp}
+ \begin{document}
+
+but will be more complicated if table of contents and indexing are required.
+Can be used to set or retrieve the current value.
+
+ $add = $parser->AddPreamble();
+ $parser->AddPreamble(1);
+
+If used in conjunction with C<AddPostamble> a full latex document will
+be written that could be immediately processed by C<latex>.
+
+For some pod escapes it may be necessary to include the amsmath
+package. This is not yet added to the preamble automaatically.
+
+=cut
+
+sub AddPreamble {
+ my $self = shift;
+ if (@_) {
+ $self->{AddPreamble} = shift;
+ }
+ return $self->{AddPreamble};
+}
+
+=item B<AddPostamble>
+
+Logical to control whether a standard C<latex> ending is written to the output
+file after the document has been processed.
+In its simplest form this is simply:
+
+ \end{document}
+
+but can be more complicated if a index is required.
+Can be used to set or retrieve the current value.
+
+ $add = $parser->AddPostamble();
+ $parser->AddPostamble(1);
+
+If used in conjunction with C<AddPreaamble> a full latex document will
+be written that could be immediately processed by C<latex>.
+
+=cut
+
+sub AddPostamble {
+ my $self = shift;
+ if (@_) {
+ $self->{AddPostamble} = shift;
+ }
+ return $self->{AddPostamble};
+}
+
+=item B<Head1Level>
+
+The C<latex> sectioning level that should be used to correspond to
+a pod C<=head1> directive. This can be used, for example, to turn
+a C<=head1> into a C<latex> C<subsection>. This should hold a number
+corresponding to the required position in an array containing the
+following elements:
+
+ [0] chapter
+ [1] section
+ [2] subsection
+ [3] subsubsection
+ [4] paragraph
+ [5] subparagraph
+
+Can be used to set or retrieve the current value:
+
+ $parser->Head1Level(2);
+ $sect = $parser->Head1Level;
+
+Setting this number too high can result in sections that may not be reproducible
+in the expected way. For example, setting this to 4 would imply that C<=head3>
+do not have a corresponding C<latex> section (C<=head1> would correspond to
+a C<paragraph>).
+
+A check is made to ensure that the supplied value is an integer in the
+range 0 to 5.
+
+Default is for a value of 1 (i.e. a C<section>).
+
+=cut
+
+sub Head1Level {
+ my $self = shift;
+ if (@_) {
+ my $arg = shift;
+ if ($arg =~ /^\d$/ && $arg <= $#LatexSections) {
+ $self->{Head1Level} = $arg;
+ } else {
+ carp "Head1Level supplied ($arg) must be integer in range 0 to ".$#LatexSections . "- Ignoring\n";
+ }
+ }
+ return $self->{Head1Level};
+}
+
+=item B<Label>
+
+This is the label that is prefixed to all C<latex> label and index
+entries to make them unique. In general, pods have similarly titled
+sections (NAME, DESCRIPTION etc) and a C<latex> label will be multiply
+defined if more than one pod document is to be included in a single
+C<latex> file. To overcome this, this label is prefixed to a label
+whenever a label is required (joined with an underscore) or to an
+index entry (joined by an exclamation mark which is the normal index
+separator). For example, C<\label{text}> becomes C<\label{Label_text}>.
+
+Can be used to set or retrieve the current value:
+
+ $label = $parser->Label;
+ $parser->Label($label);
+
+This label is only used if C<UniqueLabels> is true.
+Its value is set automatically from the C<NAME> field
+if C<ReplaceNAMEwithSection> is true. If this is not the case
+it must be set manually before starting the parse.
+
+Default value is C<undef>.
+
+=cut
+
+sub Label {
+ my $self = shift;
+ if (@_) {
+ $self->{Label} = shift;
+ }
+ return $self->{Label};
+}
+
+=item B<LevelNoNum>
+
+Control the point at which C<latex> section numbering is turned off.
+For example, this can be used to make sure that C<latex> sections
+are numbered but subsections are not.
+
+Can be used to set or retrieve the current value:
+
+ $lev = $parser->LevelNoNum;
+ $parser->LevelNoNum(2);
+
+The argument must be an integer between 0 and 5 and is the same as the
+number described in C<Head1Level> method description. The number has
+nothing to do with the pod heading number, only the C<latex> sectioning.
+
+Default is 2. (i.e. C<latex> subsections are written as C<subsection*>
+but sections are numbered).
+
+=cut
+
+sub LevelNoNum {
+ my $self = shift;
+ if (@_) {
+ $self->{LevelNoNum} = shift;
+ }
+ return $self->{LevelNoNum};
+}
+
+=item B<MakeIndex>
+
+Controls whether C<latex> commands for creating an index are to be inserted
+into the preamble and postamble
+
+ $makeindex = $parser->MakeIndex;
+ $parser->MakeIndex(0);
+
+Irrelevant if both C<AddPreamble> and C<AddPostamble> are false (or equivalently,
+C<UserPreamble> and C<UserPostamble> are set).
+
+Default is for an index to be created.
+
+=cut
+
+sub MakeIndex {
+ my $self = shift;
+ if (@_) {
+ $self->{MakeIndex} = shift;
+ }
+ return $self->{MakeIndex};
+}
+
+=item B<ReplaceNAMEwithSection>
+
+This controls whether the C<NAME> section in the pod is to be translated
+literally or converted to a slightly modified output where the section
+name is the pod name rather than "NAME".
+
+If true, the pod segment
+
+ =head1 NAME
+
+ pod::name - purpose
+
+ =head1 SYNOPSIS
+
+is converted to the C<latex>
+
+ \section{pod::name\label{pod_name}\index{pod::name}}
+
+ Purpose
+
+ \subsection*{SYNOPSIS\label{pod_name_SYNOPSIS}%
+ \index{pod::name!SYNOPSIS}}
+
+(dependent on the value of C<Head1Level> and C<LevelNoNum>). Note that
+subsequent C<head1> directives translate to subsections rather than
+sections and that the labels and index now include the pod name (dependent
+on the value of C<UniqueLabels>).
+
+The C<Label> is set from the pod name regardless of any current value
+of C<Label>.
+
+ $mod = $parser->ReplaceNAMEwithSection;
+ $parser->ReplaceNAMEwithSection(0);
+
+Default is to translate the pod literally.
+
+=cut
+
+sub ReplaceNAMEwithSection {
+ my $self = shift;
+ if (@_) {
+ $self->{ReplaceNAMEwithSection} = shift;
+ }
+ return $self->{ReplaceNAMEwithSection};
+}
+
+=item B<StartWithNewPage>
+
+If true, each pod translation will begin with a C<latex>
+C<\clearpage>.
+
+ $parser->StartWithNewPage(1);
+ $newpage = $parser->StartWithNewPage;
+
+Default is false.
+
+=cut
+
+sub StartWithNewPage {
+ my $self = shift;
+ if (@_) {
+ $self->{StartWithNewPage} = shift;
+ }
+ return $self->{StartWithNewPage};
+}
+
+=item B<TableOfContents>
+
+If true, a table of contents will be created.
+Irrelevant if C<AddPreamble> is false or C<UserPreamble>
+is set.
+
+ $toc = $parser->TableOfContents;
+ $parser->TableOfContents(1);
+
+Default is false.
+
+=cut
+
+sub TableOfContents {
+ my $self = shift;
+ if (@_) {
+ $self->{TableOfContents} = shift;
+ }
+ return $self->{TableOfContents};
+}
+
+=item B<UniqueLabels>
+
+If true, the translator will attempt to make sure that
+each C<latex> label or index entry will be uniquely identified
+by prefixing the contents of C<Label>. This allows
+multiple documents to be combined without clashing
+common labels such as C<DESCRIPTION> and C<SYNOPSIS>
+
+ $parser->UniqueLabels(1);
+ $unq = $parser->UniqueLabels;
+
+Default is true.
+
+=cut
+
+sub UniqueLabels {
+ my $self = shift;
+ if (@_) {
+ $self->{UniqueLabels} = shift;
+ }
+ return $self->{UniqueLabels};
+}
+
+=item B<UserPreamble>
+
+User supplied C<latex> preamble. Added before the pod translation
+data.
+
+If set, the contents will be prepended to the output file before the translated
+data regardless of the value of C<AddPreamble>.
+C<MakeIndex> and C<TableOfContents> will also be ignored.
+
+=cut
+
+sub UserPreamble {
+ my $self = shift;
+ if (@_) {
+ $self->{UserPreamble} = shift;
+ }
+ return $self->{UserPreamble};
+}
+
+=item B<UserPostamble>
+
+User supplied C<latex> postamble. Added after the pod translation
+data.
+
+If set, the contents will be prepended to the output file after the translated
+data regardless of the value of C<AddPostamble>.
+C<MakeIndex> will also be ignored.
+
+=cut
+
+sub UserPostamble {
+ my $self = shift;
+ if (@_) {
+ $self->{UserPostamble} = shift;
+ }
+ return $self->{UserPostamble};
+}
+
+=begin __PRIVATE__
+
+=item B<Lists>
+
+Contains details of the currently active lists.
+ The array contains C<Pod::List> objects. A new C<Pod::List>
+object is created each time a list is encountered and it is
+pushed onto this stack. When the list context ends, it
+is popped from the stack. The array will be empty if no
+lists are active.
+
+Returns array of list information in list context
+Returns array ref in scalar context
+
+=cut
+
+
+
+sub lists {
+ my $self = shift;
+ return @{ $self->{_Lists} } if wantarray();
+ return $self->{_Lists};
+}
+
+=end __PRIVATE__
+
+=back
+
+=begin __PRIVATE__
+
+=head2 Subclassed methods
+
+The following methods override methods provided in the C<Pod::Select>
+base class. See C<Pod::Parser> and C<Pod::Select> for more information
+on what these methods require.
+
+=over 4
+
+=cut
+
+######### END ACCESSORS ###################
+
+# Opening pod
+
+=item B<begin_pod>
+
+Writes the C<latex> preamble if requested. Only writes something
+if AddPreamble is true. Writes a standard header unless a UserPreamble
+is defined.
+
+=cut
+
+sub begin_pod {
+ my $self = shift;
+
+ # Get the pod identification
+ # This should really come from the '=head1 NAME' paragraph
+
+ my $infile = $self->input_file;
+ my $class = ref($self);
+ my $date = gmtime(time);
+
+ # Comment message to say where this came from
+ my $comment = << "__TEX_COMMENT__";
+%% Latex generated from POD in document $infile
+%% Using the perl module $class
+%% Converted on $date
+__TEX_COMMENT__
+
+ # Write the preamble
+ # If the caller has supplied one then we just use that
+
+ my $preamble = '';
+
+ if ($self->AddPreamble) {
+
+ if (defined $self->UserPreamble) {
+
+ $preamble = $self->UserPreamble;
+
+ # Add the description of where this came from
+ $preamble .= "\n$comment\n%% Preamble supplied by user.\n\n";
+
+ } else {
+
+ # Write our own preamble
+
+ # Code to initialise index making
+ # Use an array so that we can prepend comment if required
+ my @makeidx = (
+ '\usepackage{makeidx}',
+ '\makeindex',
+ );
+
+ unless ($self->MakeIndex) {
+ foreach (@makeidx) {
+ $_ = '%% ' . $_;
+ }
+ }
+ my $makeindex = join("\n", at makeidx) . "\n";
+
+ # Table of contents
+ my $tableofcontents = '\tableofcontents';
+
+ $tableofcontents = '%% ' . $tableofcontents
+ unless $self->TableOfContents;
+
+ # Roll our own
+ $preamble = << "__TEX_HEADER__";
+\\documentclass{article}
+\\usepackage[T1]{fontenc}
+\\usepackage{textcomp}
+
+$comment
+
+$makeindex
+
+\\begin{document}
+
+$tableofcontents
+
+__TEX_HEADER__
+
+ }
+ }
+
+ # Write the header (blank if none)
+ $self->_output($preamble);
+
+ # Start on new page if requested
+ $self->_output("\\clearpage\n") if $self->StartWithNewPage;
+
+}
+
+
+=item B<end_pod>
+
+Write the closing C<latex> code. Only writes something if AddPostamble
+is true. Writes a standard header unless a UserPostamble is defined.
+
+=cut
+
+sub end_pod {
+ my $self = shift;
+
+ # End string
+ my $end = '';
+
+ # Use the user version of the postamble if defined
+ if ($self->AddPostamble) {
+
+ if (defined $self->UserPostamble) {
+ $end = $self->UserPostamble;
+
+ } else {
+
+ # Check for index
+ my $makeindex = '\printindex';
+
+ $makeindex = '%% '. $makeindex unless $self->MakeIndex;
+
+ $end = "$makeindex\n\n\\end{document}\n";
+ }
+ }
+
+ $self->_output($end);
+
+}
+
+=item B<command>
+
+Process basic pod commands.
+
+=cut
+
+sub command {
+ my $self = shift;
+ my ($command, $paragraph, $line_num, $parobj) = @_;
+
+ # return if we dont care
+ return if $command eq 'pod';
+
+ # Store a copy of the raw text in case we are in a =for
+ # block and need to preserve the existing latex
+ my $rawpara = $paragraph;
+
+ # Do the latex escapes
+ $paragraph = $self->_replace_special_chars($paragraph);
+
+ # Interpolate pod sequences in paragraph
+ $paragraph = $self->interpolate($paragraph, $line_num);
+ $paragraph =~ s/\s+$//;
+
+ # Replace characters that can only be done after
+ # interpolation of interior sequences
+ $paragraph = $self->_replace_special_chars_late($paragraph);
+
+ # Now run the command
+ if ($command eq 'over') {
+
+ $self->begin_list($paragraph, $line_num);
+
+ } elsif ($command eq 'item') {
+
+ $self->add_item($paragraph, $line_num);
+
+ } elsif ($command eq 'back') {
+
+ $self->end_list($line_num);
+
+ } elsif ($command eq 'head1') {
+
+ # Store the name of the section
+ $self->{_CURRENT_HEAD1} = $paragraph;
+
+ # Print it
+ $self->head(1, $paragraph, $parobj);
+
+ } elsif ($command eq 'head2') {
+
+ $self->head(2, $paragraph, $parobj);
+
+ } elsif ($command eq 'head3') {
+
+ $self->head(3, $paragraph, $parobj);
+
+ } elsif ($command eq 'head4') {
+
+ $self->head(4, $paragraph, $parobj);
+
+ } elsif ($command eq 'head5') {
+
+ $self->head(5, $paragraph, $parobj);
+
+ } elsif ($command eq 'head6') {
+
+ $self->head(6, $paragraph, $parobj);
+
+ } elsif ($command eq 'begin') {
+
+ # pass through if latex
+ if ($paragraph =~ /^latex/i) {
+ # Make sure that subsequent paragraphs are not modfied before printing
+ $self->{_dont_modify_any_para} = 1;
+
+ } else {
+ # Suppress all subsequent paragraphs unless
+ # it is explcitly intended for latex
+ $self->{_suppress_all_para} = 1;
+ }
+
+ } elsif ($command eq 'for') {
+
+ # =for latex
+ # some latex
+
+ # With =for we will get the text for the full paragraph
+ # as well as the format name.
+ # We do not get an additional paragraph later on. The next
+ # paragraph is not governed by the =for
+
+ # The first line contains the format and the rest is the
+ # raw code.
+ my ($format, $chunk) = split(/\n/, $rawpara, 2);
+
+ # If we have got some latex code print it out immediately
+ # unmodified. Else do nothing.
+ if ($format =~ /^latex/i) {
+ # Make sure that next paragraph is not modfied before printing
+ $self->_output( $chunk );
+
+ }
+
+ } elsif ($command eq 'end') {
+
+ # Reset suppression
+ $self->{_suppress_all_para} = 0;
+ $self->{_dont_modify_any_para} = 0;
+
+ } elsif ($command eq 'pod') {
+
+ # Do nothing
+
+ } else {
+ carp "Command $command not recognised at line $line_num\n";
+ }
+
+}
+
+=item B<verbatim>
+
+Verbatim text
+
+=cut
+
+sub verbatim {
+ my $self = shift;
+ my ($paragraph, $line_num, $parobj) = @_;
+
+ # Expand paragraph unless in =begin block
+ if ($self->{_dont_modify_any_para}) {
+ # Just print as is
+ $self->_output($paragraph);
+
+ } else {
+
+ return if $paragraph =~ /^\s+$/;
+
+ # Clean trailing space
+ $paragraph =~ s/\s+$//;
+
+ # Clean tabs. Routine taken from Tabs.pm
+ # by David Muir Sharnoff muir at idiom.com,
+ # slightly modified by hsmyers at sdragons.com 10/22/01
+ my @l = split("\n",$paragraph);
+ foreach (@l) {
+ 1 while s/(^|\n)([^\t\n]*)(\t+)/
+ $1. $2 . (" " x
+ (8 * length($3)
+ - (length($2) % 8)))
+ /sex;
+ }
+ $paragraph = join("\n", at l);
+ # End of change.
+
+
+
+ $self->_output('\begin{verbatim}' . "\n$paragraph\n". '\end{verbatim}'."\n");
+ }
+}
+
+=item B<textblock>
+
+Plain text paragraph.
+
+=cut
+
+sub textblock {
+ my $self = shift;
+ my ($paragraph, $line_num, $parobj) = @_;
+
+ # print Dumper($self);
+
+ # Expand paragraph unless in =begin block
+ if ($self->{_dont_modify_any_para}) {
+ # Just print as is
+ $self->_output($paragraph);
+
+ return;
+ }
+
+
+ # Escape latex special characters
+ $paragraph = $self->_replace_special_chars($paragraph);
+
+ # Interpolate interior sequences
+ my $expansion = $self->interpolate($paragraph, $line_num);
+ $expansion =~ s/\s+$//;
+
+ # Escape special characters that can not be done earlier
+ $expansion = $self->_replace_special_chars_late($expansion);
+
+ # If we are replacing 'head1 NAME' with a section
+ # we need to look in the paragraph and rewrite things
+ # Need to make sure this is called only on the first paragraph
+ # following 'head1 NAME' and not on subsequent paragraphs that may be
+ # present.
+ if ($self->{_CURRENT_HEAD1} =~ /^NAME/i && $self->ReplaceNAMEwithSection()) {
+
+ # Strip white space from start and end
+ $paragraph =~ s/^\s+//;
+ $paragraph =~ s/\s$//;
+
+ # Split the string into 2 parts
+ my ($name, $purpose) = split(/\s+-\s+/, $expansion,2);
+
+ # Now prevent this from triggering until a new head1 NAME is set
+ $self->{_CURRENT_HEAD1} = '_NAME';
+
+ # Might want to clear the Label() before doing this (CHECK)
+
+ # Print the heading
+ $self->head(1, $name, $parobj);
+
+ # Set the labeling in case we want unique names later
+ $self->Label( $self->_create_label( $name, 1 ) );
+
+ # Raise the Head1Level by one so that subsequent =head1 appear
+ # as subsections of the main name section unless we are already
+ # at maximum [Head1Level() could check this itself - CHECK]
+ $self->Head1Level( $self->Head1Level() + 1)
+ unless $self->Head1Level == $#LatexSections;
+
+ # Now write out the new latex paragraph
+ $purpose = ucfirst($purpose);
+ $self->_output("\n\n$purpose\n\n");
+
+ } else {
+ # Just write the output
+ $self->_output("\n\n$expansion\n\n");
+ }
+
+}
+
+=item B<interior_sequence>
+
+Interior sequence expansion
+
+=cut
+
+sub interior_sequence {
+ my $self = shift;
+
+ my ($seq_command, $seq_argument, $pod_seq) = @_;
+
+ if ($seq_command eq 'B') {
+ return "\\textbf{$seq_argument}";
+
+ } elsif ($seq_command eq 'I') {
+ return "\\textit{$seq_argument}";
+
+ } elsif ($seq_command eq 'E') {
+
+ # If it is simply a number
+ if ($seq_argument =~ /^\d+$/) {
+ return chr($seq_argument);
+ # Look up escape in hash table
+ } elsif (exists $HTML_Escapes{$seq_argument}) {
+ return $HTML_Escapes{$seq_argument};
+
+ } else {
+ my ($file, $line) = $pod_seq->file_line();
+ warn "Escape sequence $seq_argument not recognised at line $line of file $file\n";
+ return;
+ }
+
+ } elsif ($seq_command eq 'Z') {
+
+ # Zero width space
+ return '{}';
+
+ } elsif ($seq_command eq 'C') {
+ return "\\texttt{$seq_argument}";
+
+ } elsif ($seq_command eq 'F') {
+ return "\\emph{$seq_argument}";
+
+ } elsif ($seq_command eq 'S') {
+ # non breakable spaces
+ my $nbsp = '~';
+
+ $seq_argument =~ s/\s/$nbsp/g;
+ return $seq_argument;
+
+ } elsif ($seq_command eq 'L') {
+ my $link = new Pod::Hyperlink($seq_argument);
+
+ # undef on failure
+ unless (defined $link) {
+ carp $@;
+ return;
+ }
+
+ # Handle internal links differently
+ my $type = $link->type;
+ my $page = $link->page;
+
+ if ($type eq 'section' && $page eq '') {
+ # Use internal latex reference
+ my $node = $link->node;
+
+ # Convert to a label
+ $node = $self->_create_label($node);
+
+ return "\\S\\ref{$node}";
+
+ } else {
+ # Use default markup for external references
+ # (although Starlink would use \xlabel)
+ my $markup = $link->markup;
+ my ($file, $line) = $pod_seq->file_line();
+
+ return $self->interpolate($link->markup, $line);
+ }
+
+
+
+ } elsif ($seq_command eq 'P') {
+ # Special markup for Pod::Hyperlink
+ # Replace :: with / - but not sure if I want to do this
+ # any more.
+ my $link = $seq_argument;
+ $link =~ s|::|/|g;
+
+ my $ref = "\\emph{$seq_argument}";
+ return $ref;
+
+ } elsif ($seq_command eq 'Q') {
+ # Special markup for Pod::Hyperlink
+ return "\\textsf{$seq_argument}";
+
+ } elsif ($seq_command eq 'X') {
+ # Index entries
+
+ # use \index command
+ # I will let '!' go through for now
+ # not sure how sub categories are handled in X<>
+ my $index = $self->_create_index($seq_argument);
+ return "\\index{$index}\n";
+
+ } else {
+ carp "Unknown sequence $seq_command<$seq_argument>";
+ }
+
+}
+
+=back
+
+=head2 List Methods
+
+Methods used to handle lists.
+
+=over 4
+
+=item B<begin_list>
+
+Called when a new list is found (via the C<over> directive).
+Creates a new C<Pod::List> object and stores it on the
+list stack.
+
+ $parser->begin_list($indent, $line_num);
+
+=cut
+
+sub begin_list {
+ my $self = shift;
+ my $indent = shift;
+ my $line_num = shift;
+
+ # Indicate that a list should be started for the next item
+ # need to do this to work out the type of list
+ push ( @{$self->lists}, new Pod::List(-indent => $indent,
+ -start => $line_num,
+ -file => $self->input_file,
+ )
+ );
+
+}
+
+=item B<end_list>
+
+Called when the end of a list is found (the C<back> directive).
+Pops the C<Pod::List> object off the stack of lists and writes
+the C<latex> code required to close a list.
+
+ $parser->end_list($line_num);
+
+=cut
+
+sub end_list {
+ my $self = shift;
+ my $line_num = shift;
+
+ unless (defined $self->lists->[-1]) {
+ my $file = $self->input_file;
+ warn "No list is active at line $line_num (file=$file). Missing =over?\n";
+ return;
+ }
+
+ # What to write depends on list type
+ my $type = $self->lists->[-1]->type;
+
+ # Dont write anything if the list type is not set
+ # iomplying that a list was created but no entries were
+ # placed in it (eg because of a =begin/=end combination)
+ $self->_output("\\end{$type}\n")
+ if (defined $type && length($type) > 0);
+
+ # Clear list
+ pop(@{ $self->lists});
+
+}
+
+=item B<add_item>
+
+Add items to the list. The first time an item is encountered
+(determined from the state of the current C<Pod::List> object)
+the type of list is determined (ordered, unnumbered or description)
+and the relevant latex code issued.
+
+ $parser->add_item($paragraph, $line_num);
+
+=cut
+
+sub add_item {
+ my $self = shift;
+ my $paragraph = shift;
+ my $line_num = shift;
+
+ unless (defined $self->lists->[-1]) {
+ my $file = $self->input_file;
+ warn "List has already ended by line $line_num of file $file. Missing =over?\n";
+ # Replace special chars
+# $paragraph = $self->_replace_special_chars($paragraph);
+ $self->_output("$paragraph\n\n");
+ return;
+ }
+
+ # If paragraphs printing is turned off via =begin/=end or whatver
+ # simply return immediately
+ return if $self->{_suppress_all_para};
+
+ # Check to see whether we are starting a new lists
+ if (scalar($self->lists->[-1]->item) == 0) {
+
+ # Examine the paragraph to determine what type of list
+ # we have
+ $paragraph =~ s/\s+$//;
+ $paragraph =~ s/^\s+//;
+
+ my $type;
+ if (substr($paragraph, 0,1) eq '*') {
+ $type = 'itemize';
+ } elsif ($paragraph =~ /^\d/) {
+ $type = 'enumerate';
+ } else {
+ $type = 'description';
+ }
+ $self->lists->[-1]->type($type);
+
+ $self->_output("\\begin{$type}\n");
+
+ }
+
+ my $type = $self->lists->[-1]->type;
+
+ if ($type eq 'description') {
+ # Handle long items - long items do not wrap
+ # If the string is longer than 40 characters we split
+ # it into a real item header and some bold text.
+ my $maxlen = 40;
+ my ($hunk1, $hunk2) = $self->_split_delimited( $paragraph, $maxlen );
+
+ # Print the first hunk
+ $self->_output("\n\\item[{$hunk1}] ");
+
+ # and the second hunk if it is defined
+ if ($hunk2) {
+ $self->_output("\\textbf{$hunk2}");
+ } else {
+ # Not there so make sure we have a new line
+ $self->_output("\\mbox{}");
+ }
+
+ } else {
+ # If the item was '* Something' or '\d+ something' we still need to write
+ # out the something. Also allow 1) and 1.
+ my $extra_info = $paragraph;
+ $extra_info =~ s/^(\*|\d+[\.\)]?)\s*//;
+ $self->_output("\n\\item $extra_info");
+ }
+
+ # Store the item name in the object. Required so that
+ # we can tell if the list is new or not
+ $self->lists->[-1]->item($paragraph);
+
+}
+
+=back
+
+=head2 Methods for headings
+
+=over 4
+
+=item B<head>
+
+Print a heading of the required level.
+
+ $parser->head($level, $paragraph, $parobj);
+
+The first argument is the pod heading level. The second argument
+is the contents of the heading. The 3rd argument is a Pod::Paragraph
+object so that the line number can be extracted.
+
+=cut
+
+sub head {
+ my $self = shift;
+ my $num = shift;
+ my $paragraph = shift;
+ my $parobj = shift;
+
+ # If we are replace 'head1 NAME' with a section
+ # we return immediately if we get it
+ return
+ if ($self->{_CURRENT_HEAD1} =~ /^NAME/i && $self->ReplaceNAMEwithSection());
+
+ # Create a label
+ my $label = $self->_create_label($paragraph);
+
+ # Create an index entry
+ my $index = $self->_create_index($paragraph);
+
+ # Work out position in the above array taking into account
+ # that =head1 is equivalent to $self->Head1Level
+
+ my $level = $self->Head1Level() - 1 + $num;
+
+ # Warn if heading to large
+ if ($num > $#LatexSections) {
+ my $line = $parobj->file_line;
+ my $file = $self->input_file;
+ warn "Heading level too large ($level) for LaTeX at line $line of file $file\n";
+ $level = $#LatexSections;
+ }
+
+ # Check to see whether section should be unnumbered
+ my $star = ($level >= $self->LevelNoNum ? '*' : '');
+
+ # Section
+ $self->_output("\\" .$LatexSections[$level] .$star ."{$paragraph\\label{".$label ."}\\index{".$index."}}\n");
+
+}
+
+
+=back
+
+=end __PRIVATE__
+
+=begin __PRIVATE__
+
+=head2 Internal methods
+
+Internal routines are described in this section. They do not form part of the
+public interface. All private methods start with an underscore.
+
+=over 4
+
+=item B<_output>
+
+Output text to the output filehandle. This method must be always be called
+to output parsed text.
+
+ $parser->_output($text);
+
+Does not write anything if a =begin is active that should be
+ignored.
+
+=cut
+
+sub _output {
+ my $self = shift;
+ my $text = shift;
+
+ print { $self->output_handle } $text
+ unless $self->{_suppress_all_para};
+
+}
+
+
+=item B<_replace_special_chars>
+
+Subroutine to replace characters that are special in C<latex>
+with the escaped forms
+
+ $escaped = $parser->_replace_special_chars($paragraph);
+
+Need to call this routine before interior_sequences are munged but not
+if verbatim. It must be called before interpolation of interior
+sequences so that curly brackets and special latex characters inserted
+during interpolation are not themselves escaped. This means that < and
+> can not be modified here since the text still contains interior
+sequences.
+
+Special characters and the C<latex> equivalents are:
+
+ } \}
+ { \{
+ _ \_
+ $ \$
+ % \%
+ & \&
+ \ $\backslash$
+ ^ \^{}
+ ~ \~{}
+ # \#
+
+=cut
+
+sub _replace_special_chars {
+ my $self = shift;
+ my $paragraph = shift;
+
+ # Replace a \ with $\backslash$
+ # This is made more complicated because the dollars will be escaped
+ # by the subsequent replacement. Easiest to add \backslash
+ # now and then add the dollars
+ $paragraph =~ s/\\/\\backslash/g;
+
+ # Must be done after escape of \ since this command adds latex escapes
+ # Replace characters that can be escaped
+ $paragraph =~ s/([\$\#&%_{}])/\\$1/g;
+
+ # Replace ^ characters with \^{} so that $^F works okay
+ $paragraph =~ s/(\^)/\\$1\{\}/g;
+
+ # Replace tilde (~) with \texttt{\~{}}
+ $paragraph =~ s/~/\\texttt\{\\~\{\}\}/g;
+
+ # Now add the dollars around each \backslash
+ $paragraph =~ s/(\\backslash)/\$$1\$/g;
+ return $paragraph;
+}
+
+=item B<_replace_special_chars_late>
+
+Replace special characters that can not be replaced before interior
+sequence interpolation. See C<_replace_special_chars> for a routine
+to replace special characters prior to interpolation of interior
+sequences.
+
+Does the following transformation:
+
+ < $<$
+ > $>$
+ | $|$
+
+
+=cut
+
+sub _replace_special_chars_late {
+ my $self = shift;
+ my $paragraph = shift;
+
+ # < and >
+ $paragraph =~ s/(<|>)/\$$1\$/g;
+
+ # Replace | with $|$
+ $paragraph =~ s'\|'$|$'g;
+
+
+ return $paragraph;
+}
+
+
+=item B<_create_label>
+
+Return a string that can be used as an internal reference
+in a C<latex> document (i.e. accepted by the C<\label> command)
+
+ $label = $parser->_create_label($string)
+
+If UniqueLabels is true returns a label prefixed by Label()
+This can be suppressed with an optional second argument.
+
+ $label = $parser->_create_label($string, $suppress);
+
+If a second argument is supplied (of any value including undef)
+the Label() is never prefixed. This means that this routine can
+be called to create a Label() without prefixing a previous setting.
+
+=cut
+
+sub _create_label {
+ my $self = shift;
+ my $paragraph = shift;
+ my $suppress = (@_ ? 1 : 0 );
+
+ # Remove latex commands
+ $paragraph = $self->_clean_latex_commands($paragraph);
+
+ # Remove non alphanumerics from the label and replace with underscores
+ # want to protect '-' though so use negated character classes
+ $paragraph =~ s/[^-:\w]/_/g;
+
+ # Multiple underscores will look unsightly so remove repeats
+ # This will also have the advantage of tidying up the end and
+ # start of string
+ $paragraph =~ s/_+/_/g;
+
+ # If required need to make sure that the label is unique
+ # since it is possible to have multiple pods in a single
+ # document
+ if (!$suppress && $self->UniqueLabels() && defined $self->Label) {
+ $paragraph = $self->Label() .'_'. $paragraph;
+ }
+
+ return $paragraph;
+}
+
+
+=item B<_create_index>
+
+Similar to C<_create_label> except an index entry is created.
+If C<UniqueLabels> is true, the index entry is prefixed by
+the current C<Label> and an exclamation mark.
+
+ $ind = $parser->_create_index($paragraph);
+
+An exclamation mark is used by C<makeindex> to generate
+sub-entries in an index.
+
+=cut
+
+sub _create_index {
+ my $self = shift;
+ my $paragraph = shift;
+ my $suppress = (@_ ? 1 : 0 );
+
+ # Remove latex commands
+ $paragraph = $self->_clean_latex_commands($paragraph);
+
+ # If required need to make sure that the index entry is unique
+ # since it is possible to have multiple pods in a single
+ # document
+ if (!$suppress && $self->UniqueLabels() && defined $self->Label) {
+ $paragraph = $self->Label() .'!'. $paragraph;
+ }
+
+ # Need to replace _ with space
+ $paragraph =~ s/_/ /g;
+
+ return $paragraph;
+
+}
+
+=item B<_clean_latex_commands>
+
+Removes latex commands from text. The latex command is assumed to be of the
+form C<\command{ text }>. "C<text>" is retained
+
+ $clean = $parser->_clean_latex_commands($text);
+
+=cut
+
+sub _clean_latex_commands {
+ my $self = shift;
+ my $paragraph = shift;
+
+ # Remove latex commands of the form \text{ }
+ # and replace with the contents of the { }
+ # need to make this non-greedy so that it can handle
+ # "\text{a} and \text2{b}"
+ # without converting it to
+ # "a} and \text2{b"
+ # This match will still get into trouble if \} is present
+ # This is not vital since the subsequent replacement of non-alphanumeric
+ # characters will tidy it up anyway
+ $paragraph =~ s/\\\w+{(.*?)}/$1/g;
+
+ return $paragraph
+}
+
+=item B<_split_delimited>
+
+Split the supplied string into two parts at approximately the
+specified word boundary. Special care is made to make sure that it
+does not split in the middle of some curly brackets.
+
+e.g. "this text is \textbf{very bold}" would not be split into
+"this text is \textbf{very" and " bold".
+
+ ($hunk1, $hunk2) = $self->_split_delimited( $para, $length);
+
+The length indicates the maximum length of hunk1.
+
+=cut
+
+# initially Supplied by hsmyers at sdragons.com
+# 10/25/01, utility to split \hbox
+# busting lines. Reformatted by TimJ to match module style.
+sub _split_delimited {
+ my $self = shift;
+ my $input = shift;
+ my $limit = shift;
+
+ # Return immediately if already small
+ return ($input, '') if length($input) < $limit;
+
+ my @output;
+ my $s = '';
+ my $t = '';
+ my $depth = 0;
+ my $token;
+
+ $input =~ s/\n/ /gm;
+ $input .= ' ';
+ foreach ( split ( //, $input ) ) {
+ $token .= $_;
+ if (/\{/) {
+ $depth++;
+ } elsif ( /}/ ) {
+ $depth--;
+ } elsif ( / / and $depth == 0) {
+ push @output, $token if ( $token and $token ne ' ' );
+ $token = '';
+ }
+ }
+
+ foreach (@output) {
+ if (length($s) < $limit) {
+ $s .= $_;
+ } else {
+ $t .= $_;
+ }
+ }
+
+ # Tidy up
+ $s =~ s/\s+$//;
+ $t =~ s/\s+$//;
+ return ($s,$t);
+}
+
+=back
+
+=end __PRIVATE__
+
+=head1 NOTES
+
+Compatible with C<latex2e> only. Can not be used with C<latex> v2.09
+or earlier.
+
+A subclass of C<Pod::Select> so that specific pod sections can be
+converted to C<latex> by using the C<select> method.
+
+Some HTML escapes are missing and many have not been tested.
+
+=head1 SEE ALSO
+
+L<Pod::Parser>, L<Pod::Select>, L<pod2latex>
+
+=head1 AUTHORS
+
+Tim Jenness E<lt>tjenness at cpan.orgE<gt>
+
+Bug fixes and improvements have been received from: Simon Cozens
+E<lt>simon at cozens.netE<gt>, Mark A. Hershberger
+E<lt>mah at everybody.orgE<gt>, Marcel Grunauer
+E<lt>marcel at codewerk.comE<gt>, Hugh S Myers
+E<lt>hsmyers at sdragons.comE<gt>, Peter J Acklam
+E<lt>jacklam at math.uio.noE<gt>, Sudhi Herle E<lt>sudhi at herle.netE<gt>,
+Ariel Scolnicov E<lt>ariels at compugen.co.ilE<gt>,
+Adriano Rodrigues Ferreira E<lt>ferreira at triang.com.brE<gt> and
+R. de Vries E<lt>r.de.vries at dutchspace.nlE<gt>.
+
+
+=head1 COPYRIGHT
+
+Copyright (C) 2000-2004 Tim Jenness. All Rights Reserved.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=begin __PRIVATE__
+
+=head1 REVISION
+
+$Id: LaTeX.pm,v 1.1.1.2 2011-02-17 12:49:41 laffer1 Exp $
+
+=end __PRIVATE__
+
+=cut
+
+1;
Copied: trunk/contrib/perl/lib/Pod/Man.pm (from rev 6437, vendor/perl/5.18.1/lib/Pod/Man.pm)
===================================================================
--- trunk/contrib/perl/lib/Pod/Man.pm (rev 0)
+++ trunk/contrib/perl/lib/Pod/Man.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,1747 @@
+# Pod::Man -- Convert POD data to formatted *roff input.
+#
+# Copyright 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+# Russ Allbery <rra at stanford.edu>
+# Substantial contributions by Sean Burke <sburke at cpan.org>
+#
+# This program is free software; you may redistribute it and/or modify it
+# under the same terms as Perl itself.
+#
+# This module translates POD documentation into *roff markup using the man
+# macro set, and is intended for converting POD documents written as Unix
+# manual pages to manual pages that can be read by the man(1) command. It is
+# a replacement for the pod2man command distributed with versions of Perl
+# prior to 5.6.
+#
+# Perl core hackers, please note that this module is also separately
+# maintained outside of the Perl core as part of the podlators. Please send
+# me any patches at the address above in addition to sending them to the
+# standard Perl mailing lists.
+
+##############################################################################
+# Modules and declarations
+##############################################################################
+
+package Pod::Man;
+
+require 5.005;
+
+use strict;
+use subs qw(makespace);
+use vars qw(@ISA %ESCAPES $PREAMBLE $VERSION);
+
+use Carp qw(croak);
+use Pod::Simple ();
+use POSIX qw(strftime);
+
+ at ISA = qw(Pod::Simple);
+
+$VERSION = '2.22';
+
+# Set the debugging level. If someone has inserted a debug function into this
+# class already, use that. Otherwise, use any Pod::Simple debug function
+# that's defined, and failing that, define a debug level of 10.
+BEGIN {
+ my $parent = defined (&Pod::Simple::DEBUG) ? \&Pod::Simple::DEBUG : undef;
+ unless (defined &DEBUG) {
+ *DEBUG = $parent || sub () { 10 };
+ }
+}
+
+# Import the ASCII constant from Pod::Simple. This is true iff we're in an
+# ASCII-based universe (including such things as ISO 8859-1 and UTF-8), and is
+# generally only false for EBCDIC.
+BEGIN { *ASCII = \&Pod::Simple::ASCII }
+
+# Pretty-print a data structure. Only used for debugging.
+BEGIN { *pretty = \&Pod::Simple::pretty }
+
+##############################################################################
+# Object initialization
+##############################################################################
+
+# Initialize the object and set various Pod::Simple options that we need.
+# Here, we also process any additional options passed to the constructor or
+# set up defaults if none were given. Note that all internal object keys are
+# in all-caps, reserving all lower-case object keys for Pod::Simple and user
+# arguments.
+sub new {
+ my $class = shift;
+ my $self = $class->SUPER::new;
+
+ # Tell Pod::Simple not to handle S<> by automatically inserting .
+ $self->nbsp_for_S (1);
+
+ # Tell Pod::Simple to keep whitespace whenever possible.
+ if ($self->can ('preserve_whitespace')) {
+ $self->preserve_whitespace (1);
+ } else {
+ $self->fullstop_space_harden (1);
+ }
+
+ # The =for and =begin targets that we accept.
+ $self->accept_targets (qw/man MAN roff ROFF/);
+
+ # Ensure that contiguous blocks of code are merged together. Otherwise,
+ # some of the guesswork heuristics don't work right.
+ $self->merge_text (1);
+
+ # Pod::Simple doesn't do anything useful with our arguments, but we want
+ # to put them in our object as hash keys and values. This could cause
+ # problems if we ever clash with Pod::Simple's own internal class
+ # variables.
+ %$self = (%$self, @_);
+
+ # Send errors to stderr if requested.
+ if ($$self{stderr}) {
+ $self->no_errata_section (1);
+ $self->complain_stderr (1);
+ delete $$self{stderr};
+ }
+
+ # Initialize various other internal constants based on our arguments.
+ $self->init_fonts;
+ $self->init_quotes;
+ $self->init_page;
+
+ # For right now, default to turning on all of the magic.
+ $$self{MAGIC_CPP} = 1;
+ $$self{MAGIC_EMDASH} = 1;
+ $$self{MAGIC_FUNC} = 1;
+ $$self{MAGIC_MANREF} = 1;
+ $$self{MAGIC_SMALLCAPS} = 1;
+ $$self{MAGIC_VARS} = 1;
+
+ return $self;
+}
+
+# Translate a font string into an escape.
+sub toescape { (length ($_[0]) > 1 ? '\f(' : '\f') . $_[0] }
+
+# Determine which fonts the user wishes to use and store them in the object.
+# Regular, italic, bold, and bold-italic are constants, but the fixed width
+# fonts may be set by the user. Sets the internal hash key FONTS which is
+# used to map our internal font escapes to actual *roff sequences later.
+sub init_fonts {
+ my ($self) = @_;
+
+ # Figure out the fixed-width font. If user-supplied, make sure that they
+ # are the right length.
+ for (qw/fixed fixedbold fixeditalic fixedbolditalic/) {
+ my $font = $$self{$_};
+ if (defined ($font) && (length ($font) < 1 || length ($font) > 2)) {
+ croak qq(roff font should be 1 or 2 chars, not "$font");
+ }
+ }
+
+ # Set the default fonts. We can't be sure portably across different
+ # implementations what fixed bold-italic may be called (if it's even
+ # available), so default to just bold.
+ $$self{fixed} ||= 'CW';
+ $$self{fixedbold} ||= 'CB';
+ $$self{fixeditalic} ||= 'CI';
+ $$self{fixedbolditalic} ||= 'CB';
+
+ # Set up a table of font escapes. First number is fixed-width, second is
+ # bold, third is italic.
+ $$self{FONTS} = { '000' => '\fR', '001' => '\fI',
+ '010' => '\fB', '011' => '\f(BI',
+ '100' => toescape ($$self{fixed}),
+ '101' => toescape ($$self{fixeditalic}),
+ '110' => toescape ($$self{fixedbold}),
+ '111' => toescape ($$self{fixedbolditalic}) };
+}
+
+# Initialize the quotes that we'll be using for C<> text. This requires some
+# special handling, both to parse the user parameter if given and to make sure
+# that the quotes will be safe against *roff. Sets the internal hash keys
+# LQUOTE and RQUOTE.
+sub init_quotes {
+ my ($self) = (@_);
+
+ $$self{quotes} ||= '"';
+ if ($$self{quotes} eq 'none') {
+ $$self{LQUOTE} = $$self{RQUOTE} = '';
+ } elsif (length ($$self{quotes}) == 1) {
+ $$self{LQUOTE} = $$self{RQUOTE} = $$self{quotes};
+ } elsif ($$self{quotes} =~ /^(.)(.)$/
+ || $$self{quotes} =~ /^(..)(..)$/) {
+ $$self{LQUOTE} = $1;
+ $$self{RQUOTE} = $2;
+ } else {
+ croak(qq(Invalid quote specification "$$self{quotes}"))
+ }
+
+ # Double the first quote; note that this should not be s///g as two double
+ # quotes is represented in *roff as three double quotes, not four. Weird,
+ # I know.
+ $$self{LQUOTE} =~ s/\"/\"\"/;
+ $$self{RQUOTE} =~ s/\"/\"\"/;
+}
+
+# Initialize the page title information and indentation from our arguments.
+sub init_page {
+ my ($self) = @_;
+
+ # We used to try first to get the version number from a local binary, but
+ # we shouldn't need that any more. Get the version from the running Perl.
+ # Work a little magic to handle subversions correctly under both the
+ # pre-5.6 and the post-5.6 version numbering schemes.
+ my @version = ($] =~ /^(\d+)\.(\d{3})(\d{0,3})$/);
+ $version[2] ||= 0;
+ $version[2] *= 10 ** (3 - length $version[2]);
+ for (@version) { $_ += 0 }
+ my $version = join ('.', @version);
+
+ # Set the defaults for page titles and indentation if the user didn't
+ # override anything.
+ $$self{center} = 'User Contributed Perl Documentation'
+ unless defined $$self{center};
+ $$self{release} = 'perl v' . $version
+ unless defined $$self{release};
+ $$self{indent} = 4
+ unless defined $$self{indent};
+
+ # Double quotes in things that will be quoted.
+ for (qw/center release/) {
+ $$self{$_} =~ s/\"/\"\"/g if $$self{$_};
+ }
+}
+
+##############################################################################
+# Core parsing
+##############################################################################
+
+# This is the glue that connects the code below with Pod::Simple itself. The
+# goal is to convert the event stream coming from the POD parser into method
+# calls to handlers once the complete content of a tag has been seen. Each
+# paragraph or POD command will have textual content associated with it, and
+# as soon as all of a paragraph or POD command has been seen, that content
+# will be passed in to the corresponding method for handling that type of
+# object. The exceptions are handlers for lists, which have opening tag
+# handlers and closing tag handlers that will be called right away.
+#
+# The internal hash key PENDING is used to store the contents of a tag until
+# all of it has been seen. It holds a stack of open tags, each one
+# represented by a tuple of the attributes hash for the tag, formatting
+# options for the tag (which are inherited), and the contents of the tag.
+
+# Add a block of text to the contents of the current node, formatting it
+# according to the current formatting instructions as we do.
+sub _handle_text {
+ my ($self, $text) = @_;
+ DEBUG > 3 and print "== $text\n";
+ my $tag = $$self{PENDING}[-1];
+ $$tag[2] .= $self->format_text ($$tag[1], $text);
+}
+
+# Given an element name, get the corresponding method name.
+sub method_for_element {
+ my ($self, $element) = @_;
+ $element =~ tr/-/_/;
+ $element =~ tr/A-Z/a-z/;
+ $element =~ tr/_a-z0-9//cd;
+ return $element;
+}
+
+# Handle the start of a new element. If cmd_element is defined, assume that
+# we need to collect the entire tree for this element before passing it to the
+# element method, and create a new tree into which we'll collect blocks of
+# text and nested elements. Otherwise, if start_element is defined, call it.
+sub _handle_element_start {
+ my ($self, $element, $attrs) = @_;
+ DEBUG > 3 and print "++ $element (<", join ('> <', %$attrs), ">)\n";
+ my $method = $self->method_for_element ($element);
+
+ # If we have a command handler, we need to accumulate the contents of the
+ # tag before calling it. Turn off IN_NAME for any command other than
+ # <Para> so that IN_NAME isn't still set for the first heading after the
+ # NAME heading.
+ if ($self->can ("cmd_$method")) {
+ DEBUG > 2 and print "<$element> starts saving a tag\n";
+ $$self{IN_NAME} = 0 if ($element ne 'Para');
+
+ # How we're going to format embedded text blocks depends on the tag
+ # and also depends on our parent tags. Thankfully, inside tags that
+ # turn off guesswork and reformatting, nothing else can turn it back
+ # on, so this can be strictly inherited.
+ my $formatting = $$self{PENDING}[-1][1];
+ $formatting = $self->formatting ($formatting, $element);
+ push (@{ $$self{PENDING} }, [ $attrs, $formatting, '' ]);
+ DEBUG > 4 and print "Pending: [", pretty ($$self{PENDING}), "]\n";
+ } elsif ($self->can ("start_$method")) {
+ my $method = 'start_' . $method;
+ $self->$method ($attrs, '');
+ } else {
+ DEBUG > 2 and print "No $method start method, skipping\n";
+ }
+}
+
+# Handle the end of an element. If we had a cmd_ method for this element,
+# this is where we pass along the tree that we built. Otherwise, if we have
+# an end_ method for the element, call that.
+sub _handle_element_end {
+ my ($self, $element) = @_;
+ DEBUG > 3 and print "-- $element\n";
+ my $method = $self->method_for_element ($element);
+
+ # If we have a command handler, pull off the pending text and pass it to
+ # the handler along with the saved attribute hash.
+ if ($self->can ("cmd_$method")) {
+ DEBUG > 2 and print "</$element> stops saving a tag\n";
+ my $tag = pop @{ $$self{PENDING} };
+ DEBUG > 4 and print "Popped: [", pretty ($tag), "]\n";
+ DEBUG > 4 and print "Pending: [", pretty ($$self{PENDING}), "]\n";
+ my $method = 'cmd_' . $method;
+ my $text = $self->$method ($$tag[0], $$tag[2]);
+ if (defined $text) {
+ if (@{ $$self{PENDING} } > 1) {
+ $$self{PENDING}[-1][2] .= $text;
+ } else {
+ $self->output ($text);
+ }
+ }
+ } elsif ($self->can ("end_$method")) {
+ my $method = 'end_' . $method;
+ $self->$method ();
+ } else {
+ DEBUG > 2 and print "No $method end method, skipping\n";
+ }
+}
+
+##############################################################################
+# General formatting
+##############################################################################
+
+# Return formatting instructions for a new block. Takes the current
+# formatting and the new element. Formatting inherits negatively, in the
+# sense that if the parent has turned off guesswork, all child elements should
+# leave it off. We therefore return a copy of the same formatting
+# instructions but possibly with more things turned off depending on the
+# element.
+sub formatting {
+ my ($self, $current, $element) = @_;
+ my %options;
+ if ($current) {
+ %options = %$current;
+ } else {
+ %options = (guesswork => 1, cleanup => 1, convert => 1);
+ }
+ if ($element eq 'Data') {
+ $options{guesswork} = 0;
+ $options{cleanup} = 0;
+ $options{convert} = 0;
+ } elsif ($element eq 'X') {
+ $options{guesswork} = 0;
+ $options{cleanup} = 0;
+ } elsif ($element eq 'Verbatim' || $element eq 'C') {
+ $options{guesswork} = 0;
+ $options{literal} = 1;
+ }
+ return \%options;
+}
+
+# Format a text block. Takes a hash of formatting options and the text to
+# format. Currently, the only formatting options are guesswork, cleanup, and
+# convert, all of which are boolean.
+sub format_text {
+ my ($self, $options, $text) = @_;
+ my $guesswork = $$options{guesswork} && !$$self{IN_NAME};
+ my $cleanup = $$options{cleanup};
+ my $convert = $$options{convert};
+ my $literal = $$options{literal};
+
+ # Cleanup just tidies up a few things, telling *roff that the hyphens are
+ # hard, putting a bit of space between consecutive underscores, and
+ # escaping backslashes. Be careful not to mangle our character
+ # translations by doing this before processing character translation.
+ if ($cleanup) {
+ $text =~ s/\\/\\e/g;
+ $text =~ s/-/\\-/g;
+ $text =~ s/_(?=_)/_\\|/g;
+ }
+
+ # Normally we do character translation, but we won't even do that in
+ # <Data> blocks or if UTF-8 output is desired.
+ if ($convert && !$$self{utf8} && ASCII) {
+ $text =~ s/([^\x00-\x7F])/$ESCAPES{ord ($1)} || "X"/eg;
+ }
+
+ # Ensure that *roff doesn't convert literal quotes to UTF-8 single quotes,
+ # but don't mess up our accept escapes.
+ if ($literal) {
+ $text =~ s/(?<!\\\*)\'/\\*\(Aq/g;
+ $text =~ s/(?<!\\\*)\`/\\\`/g;
+ }
+
+ # If guesswork is asked for, do that. This involves more substantial
+ # formatting based on various heuristics that may only be appropriate for
+ # particular documents.
+ if ($guesswork) {
+ $text = $self->guesswork ($text);
+ }
+
+ return $text;
+}
+
+# Handles C<> text, deciding whether to put \*C` around it or not. This is a
+# whole bunch of messy heuristics to try to avoid overquoting, originally from
+# Barrie Slaymaker. This largely duplicates similar code in Pod::Text.
+sub quote_literal {
+ my $self = shift;
+ local $_ = shift;
+
+ # A regex that matches the portion of a variable reference that's the
+ # array or hash index, separated out just because we want to use it in
+ # several places in the following regex.
+ my $index = '(?: \[.*\] | \{.*\} )?';
+
+ # Check for things that we don't want to quote, and if we find any of
+ # them, return the string with just a font change and no quoting.
+ m{
+ ^\s*
+ (?:
+ ( [\'\`\"] ) .* \1 # already quoted
+ | \\\*\(Aq .* \\\*\(Aq # quoted and escaped
+ | \\?\` .* ( \' | \\\*\(Aq ) # `quoted'
+ | \$+ [\#^]? \S $index # special ($^Foo, $")
+ | [\$\@%&*]+ \#? [:\'\w]+ $index # plain var or func
+ | [\$\@%&*]* [:\'\w]+ (?: -> )? \(\s*[^\s,]\s*\) # 0/1-arg func call
+ | [-+]? ( \d[\d.]* | \.\d+ ) (?: [eE][-+]?\d+ )? # a number
+ | 0x [a-fA-F\d]+ # a hex constant
+ )
+ \s*\z
+ }xso and return '\f(FS' . $_ . '\f(FE';
+
+ # If we didn't return, go ahead and quote the text.
+ return '\f(FS\*(C`' . $_ . "\\*(C'\\f(FE";
+}
+
+# Takes a text block to perform guesswork on. Returns the text block with
+# formatting codes added. This is the code that marks up various Perl
+# constructs and things commonly used in man pages without requiring the user
+# to add any explicit markup, and is applied to all non-literal text. We're
+# guaranteed that the text we're applying guesswork to does not contain any
+# *roff formatting codes. Note that the inserted font sequences must be
+# treated later with mapfonts or textmapfonts.
+#
+# This method is very fragile, both in the regular expressions it uses and in
+# the ordering of those modifications. Care and testing is required when
+# modifying it.
+sub guesswork {
+ my $self = shift;
+ local $_ = shift;
+ DEBUG > 5 and print " Guesswork called on [$_]\n";
+
+ # By the time we reach this point, all hypens will be escaped by adding a
+ # backslash. We want to undo that escaping if they're part of regular
+ # words and there's only a single dash, since that's a real hyphen that
+ # *roff gets to consider a possible break point. Make sure that a dash
+ # after the first character of a word stays non-breaking, however.
+ #
+ # Note that this is not user-controllable; we pretty much have to do this
+ # transformation or *roff will mangle the output in unacceptable ways.
+ s{
+ ( (?:\G|^|\s) [\(\"]* [a-zA-Z] ) ( \\- )?
+ ( (?: [a-zA-Z\']+ \\-)+ )
+ ( [a-zA-Z\']+ ) (?= [\)\".?!,;:]* (?:\s|\Z|\\\ ) )
+ \b
+ } {
+ my ($prefix, $hyphen, $main, $suffix) = ($1, $2, $3, $4);
+ $hyphen ||= '';
+ $main =~ s/\\-/-/g;
+ $prefix . $hyphen . $main . $suffix;
+ }egx;
+
+ # Translate "--" into a real em-dash if it's used like one. This means
+ # that it's either surrounded by whitespace, it follows a regular word, or
+ # it occurs between two regular words.
+ if ($$self{MAGIC_EMDASH}) {
+ s{ (\s) \\-\\- (\s) } { $1 . '\*(--' . $2 }egx;
+ s{ (\b[a-zA-Z]+) \\-\\- (\s|\Z|[a-zA-Z]+\b) } { $1 . '\*(--' . $2 }egx;
+ }
+
+ # Make words in all-caps a little bit smaller; they look better that way.
+ # However, we don't want to change Perl code (like @ARGV), nor do we want
+ # to fix the MIME in MIME-Version since it looks weird with the
+ # full-height V.
+ #
+ # We change only a string of all caps (2) either at the beginning of the
+ # line or following regular punctuation (like quotes) or whitespace (1),
+ # and followed by either similar punctuation, an em-dash, or the end of
+ # the line (3).
+ if ($$self{MAGIC_SMALLCAPS}) {
+ s{
+ ( ^ | [\s\(\"\'\`\[\{<>] | \\\ ) # (1)
+ ( [A-Z] [A-Z] (?: [/A-Z+:\d_\$&] | \\- )* ) # (2)
+ (?= [\s>\}\]\(\)\'\".?!,;] | \\*\(-- | \\\ | $ ) # (3)
+ } {
+ $1 . '\s-1' . $2 . '\s0'
+ }egx;
+ }
+
+ # Note that from this point forward, we have to adjust for \s-1 and \s-0
+ # strings inserted around things that we've made small-caps if later
+ # transforms should work on those strings.
+
+ # Italize functions in the form func(), including functions that are in
+ # all capitals, but don't italize if there's anything between the parens.
+ # The function must start with an alphabetic character or underscore and
+ # then consist of word characters or colons.
+ if ($$self{MAGIC_FUNC}) {
+ s{
+ ( \b | \\s-1 )
+ ( [A-Za-z_] ([:\w] | \\s-?[01])+ \(\) )
+ } {
+ $1 . '\f(IS' . $2 . '\f(IE'
+ }egx;
+ }
+
+ # Change references to manual pages to put the page name in italics but
+ # the number in the regular font, with a thin space between the name and
+ # the number. Only recognize func(n) where func starts with an alphabetic
+ # character or underscore and contains only word characters, periods (for
+ # configuration file man pages), or colons, and n is a single digit,
+ # optionally followed by some number of lowercase letters. Note that this
+ # does not recognize man page references like perl(l) or socket(3SOCKET).
+ if ($$self{MAGIC_MANREF}) {
+ s{
+ ( \b | \\s-1 )
+ ( [A-Za-z_] (?:[.:\w] | \\- | \\s-?[01])+ )
+ ( \( \d [a-z]* \) )
+ } {
+ $1 . '\f(IS' . $2 . '\f(IE\|' . $3
+ }egx;
+ }
+
+ # Convert simple Perl variable references to a fixed-width font. Be
+ # careful not to convert functions, though; there are too many subtleties
+ # with them to want to perform this transformation.
+ if ($$self{MAGIC_VARS}) {
+ s{
+ ( ^ | \s+ )
+ ( [\$\@%] [\w:]+ )
+ (?! \( )
+ } {
+ $1 . '\f(FS' . $2 . '\f(FE'
+ }egx;
+ }
+
+ # Fix up double quotes. Unfortunately, we miss this transformation if the
+ # quoted text contains any code with formatting codes and there's not much
+ # we can effectively do about that, which makes it somewhat unclear if
+ # this is really a good idea.
+ s{ \" ([^\"]+) \" } { '\*(L"' . $1 . '\*(R"' }egx;
+
+ # Make C++ into \*(C+, which is a squinched version.
+ if ($$self{MAGIC_CPP}) {
+ s{ \b C\+\+ } {\\*\(C+}gx;
+ }
+
+ # Done.
+ DEBUG > 5 and print " Guesswork returning [$_]\n";
+ return $_;
+}
+
+##############################################################################
+# Output
+##############################################################################
+
+# When building up the *roff code, we don't use real *roff fonts. Instead, we
+# embed font codes of the form \f(<font>[SE] where <font> is one of B, I, or
+# F, S stands for start, and E stands for end. This method turns these into
+# the right start and end codes.
+#
+# We add this level of complexity because the old pod2man didn't get code like
+# B<someI<thing> else> right; after I<> it switched back to normal text rather
+# than bold. We take care of this by using variables that state whether bold,
+# italic, or fixed are turned on as a combined pointer to our current font
+# sequence, and set each to the number of current nestings of start tags for
+# that font.
+#
+# \fP changes to the previous font, but only one previous font is kept. We
+# don't know what the outside level font is; normally it's R, but if we're
+# inside a heading it could be something else. So arrange things so that the
+# outside font is always the "previous" font and end with \fP instead of \fR.
+# Idea from Zack Weinberg.
+sub mapfonts {
+ my ($self, $text) = @_;
+ my ($fixed, $bold, $italic) = (0, 0, 0);
+ my %magic = (F => \$fixed, B => \$bold, I => \$italic);
+ my $last = '\fR';
+ $text =~ s<
+ \\f\((.)(.)
+ > <
+ my $sequence = '';
+ my $f;
+ if ($last ne '\fR') { $sequence = '\fP' }
+ ${ $magic{$1} } += ($2 eq 'S') ? 1 : -1;
+ $f = $$self{FONTS}{ ($fixed && 1) . ($bold && 1) . ($italic && 1) };
+ if ($f eq $last) {
+ '';
+ } else {
+ if ($f ne '\fR') { $sequence .= $f }
+ $last = $f;
+ $sequence;
+ }
+ >gxe;
+ return $text;
+}
+
+# Unfortunately, there is a bug in Solaris 2.6 nroff (not present in GNU
+# groff) where the sequence \fB\fP\f(CW\fP leaves the font set to B rather
+# than R, presumably because \f(CW doesn't actually do a font change. To work
+# around this, use a separate textmapfonts for text blocks where the default
+# font is always R and only use the smart mapfonts for headings.
+sub textmapfonts {
+ my ($self, $text) = @_;
+ my ($fixed, $bold, $italic) = (0, 0, 0);
+ my %magic = (F => \$fixed, B => \$bold, I => \$italic);
+ $text =~ s<
+ \\f\((.)(.)
+ > <
+ ${ $magic{$1} } += ($2 eq 'S') ? 1 : -1;
+ $$self{FONTS}{ ($fixed && 1) . ($bold && 1) . ($italic && 1) };
+ >gxe;
+ return $text;
+}
+
+# Given a command and a single argument that may or may not contain double
+# quotes, handle double-quote formatting for it. If there are no double
+# quotes, just return the command followed by the argument in double quotes.
+# If there are double quotes, use an if statement to test for nroff, and for
+# nroff output the command followed by the argument in double quotes with
+# embedded double quotes doubled. For other formatters, remap paired double
+# quotes to LQUOTE and RQUOTE.
+sub switchquotes {
+ my ($self, $command, $text, $extra) = @_;
+ $text =~ s/\\\*\([LR]\"/\"/g;
+
+ # We also have to deal with \*C` and \*C', which are used to add the
+ # quotes around C<> text, since they may expand to " and if they do this
+ # confuses the .SH macros and the like no end. Expand them ourselves.
+ # Also separate troff from nroff if there are any fixed-width fonts in use
+ # to work around problems with Solaris nroff.
+ my $c_is_quote = ($$self{LQUOTE} =~ /\"/) || ($$self{RQUOTE} =~ /\"/);
+ my $fixedpat = join '|', @{ $$self{FONTS} }{'100', '101', '110', '111'};
+ $fixedpat =~ s/\\/\\\\/g;
+ $fixedpat =~ s/\(/\\\(/g;
+ if ($text =~ m/\"/ || $text =~ m/$fixedpat/) {
+ $text =~ s/\"/\"\"/g;
+ my $nroff = $text;
+ my $troff = $text;
+ $troff =~ s/\"\"([^\"]*)\"\"/\`\`$1\'\'/g;
+ if ($c_is_quote and $text =~ m/\\\*\(C[\'\`]/) {
+ $nroff =~ s/\\\*\(C\`/$$self{LQUOTE}/g;
+ $nroff =~ s/\\\*\(C\'/$$self{RQUOTE}/g;
+ $troff =~ s/\\\*\(C[\'\`]//g;
+ }
+ $nroff = qq("$nroff") . ($extra ? " $extra" : '');
+ $troff = qq("$troff") . ($extra ? " $extra" : '');
+
+ # Work around the Solaris nroff bug where \f(CW\fP leaves the font set
+ # to Roman rather than the actual previous font when used in headings.
+ # troff output may still be broken, but at least we can fix nroff by
+ # just switching the font changes to the non-fixed versions.
+ $nroff =~ s/\Q$$self{FONTS}{100}\E(.*?)\\f[PR]/$1/g;
+ $nroff =~ s/\Q$$self{FONTS}{101}\E(.*?)\\f([PR])/\\fI$1\\f$2/g;
+ $nroff =~ s/\Q$$self{FONTS}{110}\E(.*?)\\f([PR])/\\fB$1\\f$2/g;
+ $nroff =~ s/\Q$$self{FONTS}{111}\E(.*?)\\f([PR])/\\f\(BI$1\\f$2/g;
+
+ # Now finally output the command. Bother with .ie only if the nroff
+ # and troff output aren't the same.
+ if ($nroff ne $troff) {
+ return ".ie n $command $nroff\n.el $command $troff\n";
+ } else {
+ return "$command $nroff\n";
+ }
+ } else {
+ $text = qq("$text") . ($extra ? " $extra" : '');
+ return "$command $text\n";
+ }
+}
+
+# Protect leading quotes and periods against interpretation as commands. Also
+# protect anything starting with a backslash, since it could expand or hide
+# something that *roff would interpret as a command. This is overkill, but
+# it's much simpler than trying to parse *roff here.
+sub protect {
+ my ($self, $text) = @_;
+ $text =~ s/^([.\'\\])/\\&$1/mg;
+ return $text;
+}
+
+# Make vertical whitespace if NEEDSPACE is set, appropriate to the indentation
+# level the situation. This function is needed since in *roff one has to
+# create vertical whitespace after paragraphs and between some things, but
+# other macros create their own whitespace. Also close out a sequence of
+# repeated =items, since calling makespace means we're about to begin the item
+# body.
+sub makespace {
+ my ($self) = @_;
+ $self->output (".PD\n") if $$self{ITEMS} > 1;
+ $$self{ITEMS} = 0;
+ $self->output ($$self{INDENT} > 0 ? ".Sp\n" : ".PP\n")
+ if $$self{NEEDSPACE};
+}
+
+# Output any pending index entries, and optionally an index entry given as an
+# argument. Support multiple index entries in X<> separated by slashes, and
+# strip special escapes from index entries.
+sub outindex {
+ my ($self, $section, $index) = @_;
+ my @entries = map { split m%\s*/\s*% } @{ $$self{INDEX} };
+ return unless ($section || @entries);
+
+ # We're about to output all pending entries, so clear our pending queue.
+ $$self{INDEX} = [];
+
+ # Build the output. Regular index entries are marked Xref, and headings
+ # pass in their own section. Undo some *roff formatting on headings.
+ my @output;
+ if (@entries) {
+ push @output, [ 'Xref', join (' ', @entries) ];
+ }
+ if ($section) {
+ $index =~ s/\\-/-/g;
+ $index =~ s/\\(?:s-?\d|.\(..|.)//g;
+ push @output, [ $section, $index ];
+ }
+
+ # Print out the .IX commands.
+ for (@output) {
+ my ($type, $entry) = @$_;
+ $entry =~ s/\"/\"\"/g;
+ $self->output (".IX $type " . '"' . $entry . '"' . "\n");
+ }
+}
+
+# Output some text, without any additional changes.
+sub output {
+ my ($self, @text) = @_;
+ print { $$self{output_fh} } @text;
+}
+
+##############################################################################
+# Document initialization
+##############################################################################
+
+# Handle the start of the document. Here we handle empty documents, as well
+# as setting up our basic macros in a preamble and building the page title.
+sub start_document {
+ my ($self, $attrs) = @_;
+ if ($$attrs{contentless} && !$$self{ALWAYS_EMIT_SOMETHING}) {
+ DEBUG and print "Document is contentless\n";
+ $$self{CONTENTLESS} = 1;
+ return;
+ }
+
+ # If we were given the utf8 option, set an output encoding on our file
+ # handle. Wrap in an eval in case we're using a version of Perl too old
+ # to understand this.
+ #
+ # This is evil because it changes the global state of a file handle that
+ # we may not own. However, we can't just blindly encode all output, since
+ # there may be a pre-applied output encoding (such as from PERL_UNICODE)
+ # and then we would double-encode. This seems to be the least bad
+ # approach.
+ if ($$self{utf8}) {
+ eval { binmode ($$self{output_fh}, ':encoding(UTF-8)') };
+ }
+
+ # Determine information for the preamble and then output it.
+ my ($name, $section);
+ if (defined $$self{name}) {
+ $name = $$self{name};
+ $section = $$self{section} || 1;
+ } else {
+ ($name, $section) = $self->devise_title;
+ }
+ my $date = $$self{date} || $self->devise_date;
+ $self->preamble ($name, $section, $date)
+ unless $self->bare_output or DEBUG > 9;
+
+ # Initialize a few per-document variables.
+ $$self{INDENT} = 0; # Current indentation level.
+ $$self{INDENTS} = []; # Stack of indentations.
+ $$self{INDEX} = []; # Index keys waiting to be printed.
+ $$self{IN_NAME} = 0; # Whether processing the NAME section.
+ $$self{ITEMS} = 0; # The number of consecutive =items.
+ $$self{ITEMTYPES} = []; # Stack of =item types, one per list.
+ $$self{SHIFTWAIT} = 0; # Whether there is a shift waiting.
+ $$self{SHIFTS} = []; # Stack of .RS shifts.
+ $$self{PENDING} = [[]]; # Pending output.
+}
+
+# Handle the end of the document. This does nothing but print out a final
+# comment at the end of the document under debugging.
+sub end_document {
+ my ($self) = @_;
+ return if $self->bare_output;
+ return if ($$self{CONTENTLESS} && !$$self{ALWAYS_EMIT_SOMETHING});
+ $self->output (q(.\" [End document]) . "\n") if DEBUG;
+}
+
+# Try to figure out the name and section from the file name and return them as
+# a list, returning an empty name and section 1 if we can't find any better
+# information. Uses File::Basename and File::Spec as necessary.
+sub devise_title {
+ my ($self) = @_;
+ my $name = $self->source_filename || '';
+ my $section = $$self{section} || 1;
+ $section = 3 if (!$$self{section} && $name =~ /\.pm\z/i);
+ $name =~ s/\.p(od|[lm])\z//i;
+
+ # If the section isn't 3, then the name defaults to just the basename of
+ # the file. Otherwise, assume we're dealing with a module. We want to
+ # figure out the full module name from the path to the file, but we don't
+ # want to include too much of the path into the module name. Lose
+ # anything up to the first off:
+ #
+ # */lib/*perl*/ standard or site_perl module
+ # */*perl*/lib/ from -Dprefix=/opt/perl
+ # */*perl*/ random module hierarchy
+ #
+ # which works. Also strip off a leading site, site_perl, or vendor_perl
+ # component, any OS-specific component, and any version number component,
+ # and strip off an initial component of "lib" or "blib/lib" since that's
+ # what ExtUtils::MakeMaker creates. splitdir requires at least File::Spec
+ # 0.8.
+ if ($section !~ /^3/) {
+ require File::Basename;
+ $name = uc File::Basename::basename ($name);
+ } else {
+ require File::Spec;
+ my ($volume, $dirs, $file) = File::Spec->splitpath ($name);
+ my @dirs = File::Spec->splitdir ($dirs);
+ my $cut = 0;
+ my $i;
+ for ($i = 0; $i < @dirs; $i++) {
+ if ($dirs[$i] =~ /perl/) {
+ $cut = $i + 1;
+ $cut++ if ($dirs[$i + 1] && $dirs[$i + 1] eq 'lib');
+ last;
+ }
+ }
+ if ($cut > 0) {
+ splice (@dirs, 0, $cut);
+ shift @dirs if ($dirs[0] =~ /^(site|vendor)(_perl)?$/);
+ shift @dirs if ($dirs[0] =~ /^[\d.]+$/);
+ shift @dirs if ($dirs[0] =~ /^(.*-$^O|$^O-.*|$^O)$/);
+ }
+ shift @dirs if $dirs[0] eq 'lib';
+ splice (@dirs, 0, 2) if ($dirs[0] eq 'blib' && $dirs[1] eq 'lib');
+
+ # Remove empty directories when building the module name; they
+ # occur too easily on Unix by doubling slashes.
+ $name = join ('::', (grep { $_ ? $_ : () } @dirs), $file);
+ }
+ return ($name, $section);
+}
+
+# Determine the modification date and return that, properly formatted in ISO
+# format. If we can't get the modification date of the input, instead use the
+# current time. Pod::Simple returns a completely unuseful stringified file
+# handle as the source_filename for input from a file handle, so we have to
+# deal with that as well.
+sub devise_date {
+ my ($self) = @_;
+ my $input = $self->source_filename;
+ my $time;
+ if ($input) {
+ $time = (stat $input)[9] || time;
+ } else {
+ $time = time;
+ }
+ return strftime ('%Y-%m-%d', localtime $time);
+}
+
+# Print out the preamble and the title. The meaning of the arguments to .TH
+# unfortunately vary by system; some systems consider the fourth argument to
+# be a "source" and others use it as a version number. Generally it's just
+# presented as the left-side footer, though, so it doesn't matter too much if
+# a particular system gives it another interpretation.
+#
+# The order of date and release used to be reversed in older versions of this
+# module, but this order is correct for both Solaris and Linux.
+sub preamble {
+ my ($self, $name, $section, $date) = @_;
+ my $preamble = $self->preamble_template (!$$self{utf8});
+
+ # Build the index line and make sure that it will be syntactically valid.
+ my $index = "$name $section";
+ $index =~ s/\"/\"\"/g;
+
+ # If name or section contain spaces, quote them (section really never
+ # should, but we may as well be cautious).
+ for ($name, $section) {
+ if (/\s/) {
+ s/\"/\"\"/g;
+ $_ = '"' . $_ . '"';
+ }
+ }
+
+ # Double quotes in date, since it will be quoted.
+ $date =~ s/\"/\"\"/g;
+
+ # Substitute into the preamble the configuration options.
+ $preamble =~ s/\@CFONT\@/$$self{fixed}/;
+ $preamble =~ s/\@LQUOTE\@/$$self{LQUOTE}/;
+ $preamble =~ s/\@RQUOTE\@/$$self{RQUOTE}/;
+ chomp $preamble;
+
+ # Get the version information.
+ my $version = $self->version_report;
+
+ # Finally output everything.
+ $self->output (<<"----END OF HEADER----");
+.\\" Automatically generated by $version
+.\\"
+.\\" Standard preamble:
+.\\" ========================================================================
+$preamble
+.\\" ========================================================================
+.\\"
+.IX Title "$index"
+.TH $name $section "$date" "$$self{release}" "$$self{center}"
+.\\" For nroff, turn off justification. Always turn off hyphenation; it makes
+.\\" way too many mistakes in technical documents.
+.if n .ad l
+.nh
+----END OF HEADER----
+ $self->output (".\\\" [End of preamble]\n") if DEBUG;
+}
+
+##############################################################################
+# Text blocks
+##############################################################################
+
+# Handle a basic block of text. The only tricky part of this is if this is
+# the first paragraph of text after an =over, in which case we have to change
+# indentations for *roff.
+sub cmd_para {
+ my ($self, $attrs, $text) = @_;
+ my $line = $$attrs{start_line};
+
+ # Output the paragraph. We also have to handle =over without =item. If
+ # there's an =over without =item, SHIFTWAIT will be set, and we need to
+ # handle creation of the indent here. Add the shift to SHIFTS so that it
+ # will be cleaned up on =back.
+ $self->makespace;
+ if ($$self{SHIFTWAIT}) {
+ $self->output (".RS $$self{INDENT}\n");
+ push (@{ $$self{SHIFTS} }, $$self{INDENT});
+ $$self{SHIFTWAIT} = 0;
+ }
+
+ # Add the line number for debugging, but not in the NAME section just in
+ # case the comment would confuse apropos.
+ $self->output (".\\\" [At source line $line]\n")
+ if defined ($line) && DEBUG && !$$self{IN_NAME};
+
+ # Force exactly one newline at the end and strip unwanted trailing
+ # whitespace at the end.
+ $text =~ s/\s*$/\n/;
+
+ # Output the paragraph.
+ $self->output ($self->protect ($self->textmapfonts ($text)));
+ $self->outindex;
+ $$self{NEEDSPACE} = 1;
+ return '';
+}
+
+# Handle a verbatim paragraph. Put a null token at the beginning of each line
+# to protect against commands and wrap in .Vb/.Ve (which we define in our
+# prelude).
+sub cmd_verbatim {
+ my ($self, $attrs, $text) = @_;
+
+ # Ignore an empty verbatim paragraph.
+ return unless $text =~ /\S/;
+
+ # Force exactly one newline at the end and strip unwanted trailing
+ # whitespace at the end.
+ $text =~ s/\s*$/\n/;
+
+ # Get a count of the number of lines before the first blank line, which
+ # we'll pass to .Vb as its parameter. This tells *roff to keep that many
+ # lines together. We don't want to tell *roff to keep huge blocks
+ # together.
+ my @lines = split (/\n/, $text);
+ my $unbroken = 0;
+ for (@lines) {
+ last if /^\s*$/;
+ $unbroken++;
+ }
+ $unbroken = 10 if ($unbroken > 12 && !$$self{MAGIC_VNOPAGEBREAK_LIMIT});
+
+ # Prepend a null token to each line.
+ $text =~ s/^/\\&/gm;
+
+ # Output the results.
+ $self->makespace;
+ $self->output (".Vb $unbroken\n$text.Ve\n");
+ $$self{NEEDSPACE} = 1;
+ return '';
+}
+
+# Handle literal text (produced by =for and similar constructs). Just output
+# it with the minimum of changes.
+sub cmd_data {
+ my ($self, $attrs, $text) = @_;
+ $text =~ s/^\n+//;
+ $text =~ s/\n{0,2}$/\n/;
+ $self->output ($text);
+ return '';
+}
+
+##############################################################################
+# Headings
+##############################################################################
+
+# Common code for all headings. This is called before the actual heading is
+# output. It returns the cleaned up heading text (putting the heading all on
+# one line) and may do other things, like closing bad =item blocks.
+sub heading_common {
+ my ($self, $text, $line) = @_;
+ $text =~ s/\s+$//;
+ $text =~ s/\s*\n\s*/ /g;
+
+ # This should never happen; it means that we have a heading after =item
+ # without an intervening =back. But just in case, handle it anyway.
+ if ($$self{ITEMS} > 1) {
+ $$self{ITEMS} = 0;
+ $self->output (".PD\n");
+ }
+
+ # Output the current source line.
+ $self->output ( ".\\\" [At source line $line]\n" )
+ if defined ($line) && DEBUG;
+ return $text;
+}
+
+# First level heading. We can't output .IX in the NAME section due to a bug
+# in some versions of catman, so don't output a .IX for that section. .SH
+# already uses small caps, so remove \s0 and \s-1. Maintain IN_NAME as
+# appropriate.
+sub cmd_head1 {
+ my ($self, $attrs, $text) = @_;
+ $text =~ s/\\s-?\d//g;
+ $text = $self->heading_common ($text, $$attrs{start_line});
+ my $isname = ($text eq 'NAME' || $text =~ /\(NAME\)/);
+ $self->output ($self->switchquotes ('.SH', $self->mapfonts ($text)));
+ $self->outindex ('Header', $text) unless $isname;
+ $$self{NEEDSPACE} = 0;
+ $$self{IN_NAME} = $isname;
+ return '';
+}
+
+# Second level heading.
+sub cmd_head2 {
+ my ($self, $attrs, $text) = @_;
+ $text = $self->heading_common ($text, $$attrs{start_line});
+ $self->output ($self->switchquotes ('.SS', $self->mapfonts ($text)));
+ $self->outindex ('Subsection', $text);
+ $$self{NEEDSPACE} = 0;
+ return '';
+}
+
+# Third level heading. *roff doesn't have this concept, so just put the
+# heading in italics as a normal paragraph.
+sub cmd_head3 {
+ my ($self, $attrs, $text) = @_;
+ $text = $self->heading_common ($text, $$attrs{start_line});
+ $self->makespace;
+ $self->output ($self->textmapfonts ('\f(IS' . $text . '\f(IE') . "\n");
+ $self->outindex ('Subsection', $text);
+ $$self{NEEDSPACE} = 1;
+ return '';
+}
+
+# Fourth level heading. *roff doesn't have this concept, so just put the
+# heading as a normal paragraph.
+sub cmd_head4 {
+ my ($self, $attrs, $text) = @_;
+ $text = $self->heading_common ($text, $$attrs{start_line});
+ $self->makespace;
+ $self->output ($self->textmapfonts ($text) . "\n");
+ $self->outindex ('Subsection', $text);
+ $$self{NEEDSPACE} = 1;
+ return '';
+}
+
+##############################################################################
+# Formatting codes
+##############################################################################
+
+# All of the formatting codes that aren't handled internally by the parser,
+# other than L<> and X<>.
+sub cmd_b { return '\f(BS' . $_[2] . '\f(BE' }
+sub cmd_i { return '\f(IS' . $_[2] . '\f(IE' }
+sub cmd_f { return '\f(IS' . $_[2] . '\f(IE' }
+sub cmd_c { return $_[0]->quote_literal ($_[2]) }
+
+# Index entries are just added to the pending entries.
+sub cmd_x {
+ my ($self, $attrs, $text) = @_;
+ push (@{ $$self{INDEX} }, $text);
+ return '';
+}
+
+# Links reduce to the text that we're given, wrapped in angle brackets if it's
+# a URL.
+sub cmd_l {
+ my ($self, $attrs, $text) = @_;
+ return $$attrs{type} eq 'url' ? "<$text>" : $text;
+}
+
+##############################################################################
+# List handling
+##############################################################################
+
+# Handle the beginning of an =over block. Takes the type of the block as the
+# first argument, and then the attr hash. This is called by the handlers for
+# the four different types of lists (bullet, number, text, and block).
+sub over_common_start {
+ my ($self, $type, $attrs) = @_;
+ my $line = $$attrs{start_line};
+ my $indent = $$attrs{indent};
+ DEBUG > 3 and print " Starting =over $type (line $line, indent ",
+ ($indent || '?'), "\n";
+
+ # Find the indentation level.
+ unless (defined ($indent) && $indent =~ /^[-+]?\d{1,4}\s*$/) {
+ $indent = $$self{indent};
+ }
+
+ # If we've gotten multiple indentations in a row, we need to emit the
+ # pending indentation for the last level that we saw and haven't acted on
+ # yet. SHIFTS is the stack of indentations that we've actually emitted
+ # code for.
+ if (@{ $$self{SHIFTS} } < @{ $$self{INDENTS} }) {
+ $self->output (".RS $$self{INDENT}\n");
+ push (@{ $$self{SHIFTS} }, $$self{INDENT});
+ }
+
+ # Now, do record-keeping. INDENTS is a stack of indentations that we've
+ # seen so far, and INDENT is the current level of indentation. ITEMTYPES
+ # is a stack of list types that we've seen.
+ push (@{ $$self{INDENTS} }, $$self{INDENT});
+ push (@{ $$self{ITEMTYPES} }, $type);
+ $$self{INDENT} = $indent + 0;
+ $$self{SHIFTWAIT} = 1;
+}
+
+# End an =over block. Takes no options other than the class pointer.
+# Normally, once we close a block and therefore remove something from INDENTS,
+# INDENTS will now be longer than SHIFTS, indicating that we also need to emit
+# *roff code to close the indent. This isn't *always* true, depending on the
+# circumstance. If we're still inside an indentation, we need to emit another
+# .RE and then a new .RS to unconfuse *roff.
+sub over_common_end {
+ my ($self) = @_;
+ DEBUG > 3 and print " Ending =over\n";
+ $$self{INDENT} = pop @{ $$self{INDENTS} };
+ pop @{ $$self{ITEMTYPES} };
+
+ # If we emitted code for that indentation, end it.
+ if (@{ $$self{SHIFTS} } > @{ $$self{INDENTS} }) {
+ $self->output (".RE\n");
+ pop @{ $$self{SHIFTS} };
+ }
+
+ # If we're still in an indentation, *roff will have now lost track of the
+ # right depth of that indentation, so fix that.
+ if (@{ $$self{INDENTS} } > 0) {
+ $self->output (".RE\n");
+ $self->output (".RS $$self{INDENT}\n");
+ }
+ $$self{NEEDSPACE} = 1;
+ $$self{SHIFTWAIT} = 0;
+}
+
+# Dispatch the start and end calls as appropriate.
+sub start_over_bullet { my $s = shift; $s->over_common_start ('bullet', @_) }
+sub start_over_number { my $s = shift; $s->over_common_start ('number', @_) }
+sub start_over_text { my $s = shift; $s->over_common_start ('text', @_) }
+sub start_over_block { my $s = shift; $s->over_common_start ('block', @_) }
+sub end_over_bullet { $_[0]->over_common_end }
+sub end_over_number { $_[0]->over_common_end }
+sub end_over_text { $_[0]->over_common_end }
+sub end_over_block { $_[0]->over_common_end }
+
+# The common handler for all item commands. Takes the type of the item, the
+# attributes, and then the text of the item.
+#
+# Emit an index entry for anything that's interesting, but don't emit index
+# entries for things like bullets and numbers. Newlines in an item title are
+# turned into spaces since *roff can't handle them embedded.
+sub item_common {
+ my ($self, $type, $attrs, $text) = @_;
+ my $line = $$attrs{start_line};
+ DEBUG > 3 and print " $type item (line $line): $text\n";
+
+ # Clean up the text. We want to end up with two variables, one ($text)
+ # which contains any body text after taking out the item portion, and
+ # another ($item) which contains the actual item text.
+ $text =~ s/\s+$//;
+ my ($item, $index);
+ if ($type eq 'bullet') {
+ $item = "\\\(bu";
+ $text =~ s/\n*$/\n/;
+ } elsif ($type eq 'number') {
+ $item = $$attrs{number} . '.';
+ } else {
+ $item = $text;
+ $item =~ s/\s*\n\s*/ /g;
+ $text = '';
+ $index = $item if ($item =~ /\w/);
+ }
+
+ # Take care of the indentation. If shifts and indents are equal, close
+ # the top shift, since we're about to create an indentation with .IP.
+ # Also output .PD 0 to turn off spacing between items if this item is
+ # directly following another one. We only have to do that once for a
+ # whole chain of items so do it for the second item in the change. Note
+ # that makespace is what undoes this.
+ if (@{ $$self{SHIFTS} } == @{ $$self{INDENTS} }) {
+ $self->output (".RE\n");
+ pop @{ $$self{SHIFTS} };
+ }
+ $self->output (".PD 0\n") if ($$self{ITEMS} == 1);
+
+ # Now, output the item tag itself.
+ $item = $self->textmapfonts ($item);
+ $self->output ($self->switchquotes ('.IP', $item, $$self{INDENT}));
+ $$self{NEEDSPACE} = 0;
+ $$self{ITEMS}++;
+ $$self{SHIFTWAIT} = 0;
+
+ # If body text for this item was included, go ahead and output that now.
+ if ($text) {
+ $text =~ s/\s*$/\n/;
+ $self->makespace;
+ $self->output ($self->protect ($self->textmapfonts ($text)));
+ $$self{NEEDSPACE} = 1;
+ }
+ $self->outindex ($index ? ('Item', $index) : ());
+}
+
+# Dispatch the item commands to the appropriate place.
+sub cmd_item_bullet { my $self = shift; $self->item_common ('bullet', @_) }
+sub cmd_item_number { my $self = shift; $self->item_common ('number', @_) }
+sub cmd_item_text { my $self = shift; $self->item_common ('text', @_) }
+sub cmd_item_block { my $self = shift; $self->item_common ('block', @_) }
+
+##############################################################################
+# Backward compatibility
+##############################################################################
+
+# Reset the underlying Pod::Simple object between calls to parse_from_file so
+# that the same object can be reused to convert multiple pages.
+sub parse_from_file {
+ my $self = shift;
+ $self->reinit;
+
+ # Fake the old cutting option to Pod::Parser. This fiddings with internal
+ # Pod::Simple state and is quite ugly; we need a better approach.
+ if (ref ($_[0]) eq 'HASH') {
+ my $opts = shift @_;
+ if (defined ($$opts{-cutting}) && !$$opts{-cutting}) {
+ $$self{in_pod} = 1;
+ $$self{last_was_blank} = 1;
+ }
+ }
+
+ # Do the work.
+ my $retval = $self->SUPER::parse_from_file (@_);
+
+ # Flush output, since Pod::Simple doesn't do this. Ideally we should also
+ # close the file descriptor if we had to open one, but we can't easily
+ # figure this out.
+ my $fh = $self->output_fh ();
+ my $oldfh = select $fh;
+ my $oldflush = $|;
+ $| = 1;
+ print $fh '';
+ $| = $oldflush;
+ select $oldfh;
+ return $retval;
+}
+
+# Pod::Simple failed to provide this backward compatibility function, so
+# implement it ourselves. File handles are one of the inputs that
+# parse_from_file supports.
+sub parse_from_filehandle {
+ my $self = shift;
+ $self->parse_from_file (@_);
+}
+
+##############################################################################
+# Translation tables
+##############################################################################
+
+# The following table is adapted from Tom Christiansen's pod2man. It assumes
+# that the standard preamble has already been printed, since that's what
+# defines all of the accent marks. We really want to do something better than
+# this when *roff actually supports other character sets itself, since these
+# results are pretty poor.
+#
+# This only works in an ASCII world. What to do in a non-ASCII world is very
+# unclear -- hopefully we can assume UTF-8 and just leave well enough alone.
+ at ESCAPES{0xA0 .. 0xFF} = (
+ "\\ ", undef, undef, undef, undef, undef, undef, undef,
+ undef, undef, undef, undef, undef, "\\%", undef, undef,
+
+ undef, undef, undef, undef, undef, undef, undef, undef,
+ undef, undef, undef, undef, undef, undef, undef, undef,
+
+ "A\\*`", "A\\*'", "A\\*^", "A\\*~", "A\\*:", "A\\*o", "\\*(AE", "C\\*,",
+ "E\\*`", "E\\*'", "E\\*^", "E\\*:", "I\\*`", "I\\*'", "I\\*^", "I\\*:",
+
+ "\\*(D-", "N\\*~", "O\\*`", "O\\*'", "O\\*^", "O\\*~", "O\\*:", undef,
+ "O\\*/", "U\\*`", "U\\*'", "U\\*^", "U\\*:", "Y\\*'", "\\*(Th", "\\*8",
+
+ "a\\*`", "a\\*'", "a\\*^", "a\\*~", "a\\*:", "a\\*o", "\\*(ae", "c\\*,",
+ "e\\*`", "e\\*'", "e\\*^", "e\\*:", "i\\*`", "i\\*'", "i\\*^", "i\\*:",
+
+ "\\*(d-", "n\\*~", "o\\*`", "o\\*'", "o\\*^", "o\\*~", "o\\*:", undef,
+ "o\\*/" , "u\\*`", "u\\*'", "u\\*^", "u\\*:", "y\\*'", "\\*(th", "y\\*:",
+) if ASCII;
+
+##############################################################################
+# Premable
+##############################################################################
+
+# The following is the static preamble which starts all *roff output we
+# generate. Most is static except for the font to use as a fixed-width font,
+# which is designed by @CFONT@, and the left and right quotes to use for C<>
+# text, designated by @LQOUTE@ and @RQUOTE at . However, the second part, which
+# defines the accent marks, is only used if $escapes is set to true.
+sub preamble_template {
+ my ($self, $accents) = @_;
+ my $preamble = <<'----END OF PREAMBLE----';
+.de Sp \" Vertical space (when we can't use .PP)
+.if t .sp .5v
+.if n .sp
+..
+.de Vb \" Begin verbatim text
+.ft @CFONT@
+.nf
+.ne \\$1
+..
+.de Ve \" End verbatim text
+.ft R
+.fi
+..
+.\" Set up some character translations and predefined strings. \*(-- will
+.\" give an unbreakable dash, \*(PI will give pi, \*(L" will give a left
+.\" double quote, and \*(R" will give a right double quote. \*(C+ will
+.\" give a nicer C++. Capital omega is used to do unbreakable dashes and
+.\" therefore won't be available. \*(C` and \*(C' expand to `' in nroff,
+.\" nothing in troff, for use with C<>.
+.tr \(*W-
+.ds C+ C\v'-.1v'\h'-1p'\s-2+\h'-1p'+\s0\v'.1v'\h'-1p'
+.ie n \{\
+. ds -- \(*W-
+. ds PI pi
+. if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch
+. if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch
+. ds L" ""
+. ds R" ""
+. ds C` @LQUOTE@
+. ds C' @RQUOTE@
+'br\}
+.el\{\
+. ds -- \|\(em\|
+. ds PI \(*p
+. ds L" ``
+. ds R" ''
+'br\}
+.\"
+.\" Escape single quotes in literal strings from groff's Unicode transform.
+.ie \n(.g .ds Aq \(aq
+.el .ds Aq '
+.\"
+.\" If the F register is turned on, we'll generate index entries on stderr for
+.\" titles (.TH), headers (.SH), subsections (.SS), items (.Ip), and index
+.\" entries marked with X<> in POD. Of course, you'll have to process the
+.\" output yourself in some meaningful fashion.
+.ie \nF \{\
+. de IX
+. tm Index:\\$1\t\\n%\t"\\$2"
+..
+. nr % 0
+. rr F
+.\}
+.el \{\
+. de IX
+..
+.\}
+----END OF PREAMBLE----
+
+ if ($accents) {
+ $preamble .= <<'----END OF PREAMBLE----'
+.\"
+.\" Accent mark definitions (@(#)ms.acc 1.5 88/02/08 SMI; from UCB 4.2).
+.\" Fear. Run. Save yourself. No user-serviceable parts.
+. \" fudge factors for nroff and troff
+.if n \{\
+. ds #H 0
+. ds #V .8m
+. ds #F .3m
+. ds #[ \f1
+. ds #] \fP
+.\}
+.if t \{\
+. ds #H ((1u-(\\\\n(.fu%2u))*.13m)
+. ds #V .6m
+. ds #F 0
+. ds #[ \&
+. ds #] \&
+.\}
+. \" simple accents for nroff and troff
+.if n \{\
+. ds ' \&
+. ds ` \&
+. ds ^ \&
+. ds , \&
+. ds ~ ~
+. ds /
+.\}
+.if t \{\
+. ds ' \\k:\h'-(\\n(.wu*8/10-\*(#H)'\'\h"|\\n:u"
+. ds ` \\k:\h'-(\\n(.wu*8/10-\*(#H)'\`\h'|\\n:u'
+. ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'^\h'|\\n:u'
+. ds , \\k:\h'-(\\n(.wu*8/10)',\h'|\\n:u'
+. ds ~ \\k:\h'-(\\n(.wu-\*(#H-.1m)'~\h'|\\n:u'
+. ds / \\k:\h'-(\\n(.wu*8/10-\*(#H)'\z\(sl\h'|\\n:u'
+.\}
+. \" troff and (daisy-wheel) nroff accents
+.ds : \\k:\h'-(\\n(.wu*8/10-\*(#H+.1m+\*(#F)'\v'-\*(#V'\z.\h'.2m+\*(#F'.\h'|\\n:u'\v'\*(#V'
+.ds 8 \h'\*(#H'\(*b\h'-\*(#H'
+.ds o \\k:\h'-(\\n(.wu+\w'\(de'u-\*(#H)/2u'\v'-.3n'\*(#[\z\(de\v'.3n'\h'|\\n:u'\*(#]
+.ds d- \h'\*(#H'\(pd\h'-\w'~'u'\v'-.25m'\f2\(hy\fP\v'.25m'\h'-\*(#H'
+.ds D- D\\k:\h'-\w'D'u'\v'-.11m'\z\(hy\v'.11m'\h'|\\n:u'
+.ds th \*(#[\v'.3m'\s+1I\s-1\v'-.3m'\h'-(\w'I'u*2/3)'\s-1o\s+1\*(#]
+.ds Th \*(#[\s+2I\s-2\h'-\w'I'u*3/5'\v'-.3m'o\v'.3m'\*(#]
+.ds ae a\h'-(\w'a'u*4/10)'e
+.ds Ae A\h'-(\w'A'u*4/10)'E
+. \" corrections for vroff
+.if v .ds ~ \\k:\h'-(\\n(.wu*9/10-\*(#H)'\s-2\u~\d\s+2\h'|\\n:u'
+.if v .ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'\v'-.4m'^\v'.4m'\h'|\\n:u'
+. \" for low resolution devices (crt and lpr)
+.if \n(.H>23 .if \n(.V>19 \
+\{\
+. ds : e
+. ds 8 ss
+. ds o a
+. ds d- d\h'-1'\(ga
+. ds D- D\h'-1'\(hy
+. ds th \o'bp'
+. ds Th \o'LP'
+. ds ae ae
+. ds Ae AE
+.\}
+.rm #[ #] #H #V #F C
+----END OF PREAMBLE----
+#`# for cperl-mode
+ }
+ return $preamble;
+}
+
+##############################################################################
+# Module return value and documentation
+##############################################################################
+
+1;
+__END__
+
+=head1 NAME
+
+Pod::Man - Convert POD data to formatted *roff input
+
+=for stopwords
+en em ALLCAPS teeny fixedbold fixeditalic fixedbolditalic stderr utf8
+UTF-8 Allbery Sean Burke Ossanna Solaris formatters troff uppercased
+Christiansen
+
+=head1 SYNOPSIS
+
+ use Pod::Man;
+ my $parser = Pod::Man->new (release => $VERSION, section => 8);
+
+ # Read POD from STDIN and write to STDOUT.
+ $parser->parse_file (\*STDIN);
+
+ # Read POD from file.pod and write to file.1.
+ $parser->parse_from_file ('file.pod', 'file.1');
+
+=head1 DESCRIPTION
+
+Pod::Man is a module to convert documentation in the POD format (the
+preferred language for documenting Perl) into *roff input using the man
+macro set. The resulting *roff code is suitable for display on a terminal
+using L<nroff(1)>, normally via L<man(1)>, or printing using L<troff(1)>.
+It is conventionally invoked using the driver script B<pod2man>, but it can
+also be used directly.
+
+As a derived class from Pod::Simple, Pod::Man supports the same methods and
+interfaces. See L<Pod::Simple> for all the details.
+
+new() can take options, in the form of key/value pairs that control the
+behavior of the parser. See below for details.
+
+If no options are given, Pod::Man uses the name of the input file with any
+trailing C<.pod>, C<.pm>, or C<.pl> stripped as the man page title, to
+section 1 unless the file ended in C<.pm> in which case it defaults to
+section 3, to a centered title of "User Contributed Perl Documentation", to
+a centered footer of the Perl version it is run with, and to a left-hand
+footer of the modification date of its input (or the current date if given
+C<STDIN> for input).
+
+Pod::Man assumes that your *roff formatters have a fixed-width font named
+C<CW>. If yours is called something else (like C<CR>), use the C<fixed>
+option to specify it. This generally only matters for troff output for
+printing. Similarly, you can set the fonts used for bold, italic, and
+bold italic fixed-width output.
+
+Besides the obvious pod conversions, Pod::Man also takes care of
+formatting func(), func(3), and simple variable references like $foo or
+ at bar so you don't have to use code escapes for them; complex expressions
+like C<$fred{'stuff'}> will still need to be escaped, though. It also
+translates dashes that aren't used as hyphens into en dashes, makes long
+dashes--like this--into proper em dashes, fixes "paired quotes," makes C++
+look right, puts a little space between double underscores, makes ALLCAPS
+a teeny bit smaller in B<troff>, and escapes stuff that *roff treats as
+special so that you don't have to.
+
+The recognized options to new() are as follows. All options take a single
+argument.
+
+=over 4
+
+=item center
+
+Sets the centered page header to use instead of "User Contributed Perl
+Documentation".
+
+=item date
+
+Sets the left-hand footer. By default, the modification date of the input
+file will be used, or the current date if stat() can't find that file (the
+case if the input is from C<STDIN>), and the date will be formatted as
+C<YYYY-MM-DD>.
+
+=item fixed
+
+The fixed-width font to use for verbatim text and code. Defaults to
+C<CW>. Some systems may want C<CR> instead. Only matters for B<troff>
+output.
+
+=item fixedbold
+
+Bold version of the fixed-width font. Defaults to C<CB>. Only matters
+for B<troff> output.
+
+=item fixeditalic
+
+Italic version of the fixed-width font (actually, something of a misnomer,
+since most fixed-width fonts only have an oblique version, not an italic
+version). Defaults to C<CI>. Only matters for B<troff> output.
+
+=item fixedbolditalic
+
+Bold italic (probably actually oblique) version of the fixed-width font.
+Pod::Man doesn't assume you have this, and defaults to C<CB>. Some
+systems (such as Solaris) have this font available as C<CX>. Only matters
+for B<troff> output.
+
+=item name
+
+Set the name of the manual page. Without this option, the manual name is
+set to the uppercased base name of the file being converted unless the
+manual section is 3, in which case the path is parsed to see if it is a Perl
+module path. If it is, a path like C<.../lib/Pod/Man.pm> is converted into
+a name like C<Pod::Man>. This option, if given, overrides any automatic
+determination of the name.
+
+=item quotes
+
+Sets the quote marks used to surround CE<lt>> text. If the value is a
+single character, it is used as both the left and right quote; if it is two
+characters, the first character is used as the left quote and the second as
+the right quoted; and if it is four characters, the first two are used as
+the left quote and the second two as the right quote.
+
+This may also be set to the special value C<none>, in which case no quote
+marks are added around CE<lt>> text (but the font is still changed for troff
+output).
+
+=item release
+
+Set the centered footer. By default, this is the version of Perl you run
+Pod::Man under. Note that some system an macro sets assume that the
+centered footer will be a modification date and will prepend something like
+"Last modified: "; if this is the case, you may want to set C<release> to
+the last modified date and C<date> to the version number.
+
+=item section
+
+Set the section for the C<.TH> macro. The standard section numbering
+convention is to use 1 for user commands, 2 for system calls, 3 for
+functions, 4 for devices, 5 for file formats, 6 for games, 7 for
+miscellaneous information, and 8 for administrator commands. There is a lot
+of variation here, however; some systems (like Solaris) use 4 for file
+formats, 5 for miscellaneous information, and 7 for devices. Still others
+use 1m instead of 8, or some mix of both. About the only section numbers
+that are reliably consistent are 1, 2, and 3.
+
+By default, section 1 will be used unless the file ends in C<.pm> in which
+case section 3 will be selected.
+
+=item stderr
+
+Send error messages about invalid POD to standard error instead of
+appending a POD ERRORS section to the generated *roff output.
+
+=item utf8
+
+By default, Pod::Man produces the most conservative possible *roff output
+to try to ensure that it will work with as many different *roff
+implementations as possible. Many *roff implementations cannot handle
+non-ASCII characters, so this means all non-ASCII characters are converted
+either to a *roff escape sequence that tries to create a properly accented
+character (at least for troff output) or to C<X>.
+
+If this option is set, Pod::Man will instead output UTF-8. If your *roff
+implementation can handle it, this is the best output format to use and
+avoids corruption of documents containing non-ASCII characters. However,
+be warned that *roff source with literal UTF-8 characters is not supported
+by many implementations and may even result in segfaults and other bad
+behavior.
+
+Be aware that, when using this option, the input encoding of your POD
+source must be properly declared unless it is US-ASCII or Latin-1. POD
+input without an C<=encoding> command will be assumed to be in Latin-1,
+and if it's actually in UTF-8, the output will be double-encoded. See
+L<perlpod(1)> for more information on the C<=encoding> command.
+
+=back
+
+The standard Pod::Simple method parse_file() takes one argument naming the
+POD file to read from. By default, the output is sent to C<STDOUT>, but
+this can be changed with the output_fd() method.
+
+The standard Pod::Simple method parse_from_file() takes up to two
+arguments, the first being the input file to read POD from and the second
+being the file to write the formatted output to.
+
+You can also call parse_lines() to parse an array of lines or
+parse_string_document() to parse a document already in memory. To put the
+output into a string instead of a file handle, call the output_string()
+method. See L<Pod::Simple> for the specific details.
+
+=head1 DIAGNOSTICS
+
+=over 4
+
+=item roff font should be 1 or 2 chars, not "%s"
+
+(F) You specified a *roff font (using C<fixed>, C<fixedbold>, etc.) that
+wasn't either one or two characters. Pod::Man doesn't support *roff fonts
+longer than two characters, although some *roff extensions do (the canonical
+versions of B<nroff> and B<troff> don't either).
+
+=item Invalid quote specification "%s"
+
+(F) The quote specification given (the quotes option to the constructor) was
+invalid. A quote specification must be one, two, or four characters long.
+
+=back
+
+=head1 BUGS
+
+Encoding handling assumes that PerlIO is available and does not work
+properly if it isn't. The C<utf8> option is therefore not supported
+unless Perl is built with PerlIO support.
+
+There is currently no way to turn off the guesswork that tries to format
+unmarked text appropriately, and sometimes it isn't wanted (particularly
+when using POD to document something other than Perl). Most of the work
+toward fixing this has now been done, however, and all that's still needed
+is a user interface.
+
+The NAME section should be recognized specially and index entries emitted
+for everything in that section. This would have to be deferred until the
+next section, since extraneous things in NAME tends to confuse various man
+page processors. Currently, no index entries are emitted for anything in
+NAME.
+
+Pod::Man doesn't handle font names longer than two characters. Neither do
+most B<troff> implementations, but GNU troff does as an extension. It would
+be nice to support as an option for those who want to use it.
+
+The preamble added to each output file is rather verbose, and most of it
+is only necessary in the presence of non-ASCII characters. It would
+ideally be nice if all of those definitions were only output if needed,
+perhaps on the fly as the characters are used.
+
+Pod::Man is excessively slow.
+
+=head1 CAVEATS
+
+If Pod::Man is given the C<utf8> option, the encoding of its output file
+handle will be forced to UTF-8 if possible, overriding any existing
+encoding. This will be done even if the file handle is not created by
+Pod::Man and was passed in from outside. This maintains consistency
+regardless of PERL_UNICODE and other settings.
+
+The handling of hyphens and em dashes is somewhat fragile, and one may get
+the wrong one under some circumstances. This should only matter for
+B<troff> output.
+
+When and whether to use small caps is somewhat tricky, and Pod::Man doesn't
+necessarily get it right.
+
+Converting neutral double quotes to properly matched double quotes doesn't
+work unless there are no formatting codes between the quote marks. This
+only matters for troff output.
+
+=head1 AUTHOR
+
+Russ Allbery <rra at stanford.edu>, based I<very> heavily on the original
+B<pod2man> by Tom Christiansen <tchrist at mox.perl.com>. The modifications to
+work with Pod::Simple instead of Pod::Parser were originally contributed by
+Sean Burke (but I've since hacked them beyond recognition and all bugs are
+mine).
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+Russ Allbery <rra at stanford.edu>.
+
+This program is free software; you may redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<Pod::Simple>, L<perlpod(1)>, L<pod2man(1)>, L<nroff(1)>, L<troff(1)>,
+L<man(1)>, L<man(7)>
+
+Ossanna, Joseph F., and Brian W. Kernighan. "Troff User's Manual,"
+Computing Science Technical Report No. 54, AT&T Bell Laboratories. This is
+the best documentation of standard B<nroff> and B<troff>. At the time of
+this writing, it's available at
+L<http://www.cs.bell-labs.com/cm/cs/cstr.html>.
+
+The man page documenting the man macro set may be L<man(5)> instead of
+L<man(7)> on your system. Also, please see L<pod2man(1)> for extensive
+documentation on writing manual pages if you've not done it before and
+aren't familiar with the conventions.
+
+The current version of this module is always available from its web site at
+L<http://www.eyrie.org/~eagle/software/podlators/>. It is also part of the
+Perl core distribution as of 5.6.0.
+
+=cut
Copied: trunk/contrib/perl/lib/Pod/ParseLink.pm (from rev 6437, vendor/perl/5.18.1/lib/Pod/ParseLink.pm)
===================================================================
--- trunk/contrib/perl/lib/Pod/ParseLink.pm (rev 0)
+++ trunk/contrib/perl/lib/Pod/ParseLink.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,182 @@
+# Pod::ParseLink -- Parse an L<> formatting code in POD text.
+#
+# Copyright 2001, 2008 by Russ Allbery <rra at stanford.edu>
+#
+# This program is free software; you may redistribute it and/or modify it
+# under the same terms as Perl itself.
+#
+# This module implements parsing of the text of an L<> formatting code as
+# defined in perlpodspec. It should be suitable for any POD formatter. It
+# exports only one function, parselink(), which returns the five-item parse
+# defined in perlpodspec.
+#
+# Perl core hackers, please note that this module is also separately
+# maintained outside of the Perl core as part of the podlators. Please send
+# me any patches at the address above in addition to sending them to the
+# standard Perl mailing lists.
+
+##############################################################################
+# Modules and declarations
+##############################################################################
+
+package Pod::ParseLink;
+
+require 5.004;
+
+use strict;
+use vars qw(@EXPORT @ISA $VERSION);
+
+use Exporter;
+ at ISA = qw(Exporter);
+ at EXPORT = qw(parselink);
+
+$VERSION = '1.09';
+
+##############################################################################
+# Implementation
+##############################################################################
+
+# Parse the name and section portion of a link into a name and section.
+sub _parse_section {
+ my ($link) = @_;
+ $link =~ s/^\s+//;
+ $link =~ s/\s+$//;
+
+ # If the whole link is enclosed in quotes, interpret it all as a section
+ # even if it contains a slash.
+ return (undef, $1) if ($link =~ /^"\s*(.*?)\s*"$/);
+
+ # Split into page and section on slash, and then clean up quoting in the
+ # section. If there is no section and the name contains spaces, also
+ # guess that it's an old section link.
+ my ($page, $section) = split (/\s*\/\s*/, $link, 2);
+ $section =~ s/^"\s*(.*?)\s*"$/$1/ if $section;
+ if ($page && $page =~ / / && !defined ($section)) {
+ $section = $page;
+ $page = undef;
+ } else {
+ $page = undef unless $page;
+ $section = undef unless $section;
+ }
+ return ($page, $section);
+}
+
+# Infer link text from the page and section.
+sub _infer_text {
+ my ($page, $section) = @_;
+ my $inferred;
+ if ($page && !$section) {
+ $inferred = $page;
+ } elsif (!$page && $section) {
+ $inferred = '"' . $section . '"';
+ } elsif ($page && $section) {
+ $inferred = '"' . $section . '" in ' . $page;
+ }
+ return $inferred;
+}
+
+# Given the contents of an L<> formatting code, parse it into the link text,
+# the possibly inferred link text, the name or URL, the section, and the type
+# of link (pod, man, or url).
+sub parselink {
+ my ($link) = @_;
+ $link =~ s/\s+/ /g;
+ if ($link =~ /\A\w+:[^:\s]\S*\Z/) {
+ return (undef, $link, $link, undef, 'url');
+ } else {
+ my $text;
+ if ($link =~ /\|/) {
+ ($text, $link) = split (/\|/, $link, 2);
+ }
+ my ($name, $section) = _parse_section ($link);
+ my $inferred = $text || _infer_text ($name, $section);
+ my $type = ($name && $name =~ /\(\S*\)/) ? 'man' : 'pod';
+ return ($text, $inferred, $name, $section, $type);
+ }
+}
+
+##############################################################################
+# Module return value and documentation
+##############################################################################
+
+# Ensure we evaluate to true.
+1;
+__END__
+
+=head1 NAME
+
+Pod::ParseLink - Parse an LE<lt>E<gt> formatting code in POD text
+
+=for stopwords
+markup Allbery URL
+
+=head1 SYNOPSIS
+
+ use Pod::ParseLink;
+ my ($text, $inferred, $name, $section, $type) = parselink ($link);
+
+=head1 DESCRIPTION
+
+This module only provides a single function, parselink(), which takes the
+text of an LE<lt>E<gt> formatting code and parses it. It returns the
+anchor text for the link (if any was given), the anchor text possibly
+inferred from the name and section, the name or URL, the section if any,
+and the type of link. The type will be one of C<url>, C<pod>, or C<man>,
+indicating a URL, a link to a POD page, or a link to a Unix manual page.
+
+Parsing is implemented per L<perlpodspec>. For backward compatibility,
+links where there is no section and name contains spaces, or links where the
+entirety of the link (except for the anchor text if given) is enclosed in
+double-quotes are interpreted as links to a section (LE<lt>/sectionE<gt>).
+
+The inferred anchor text is implemented per L<perlpodspec>:
+
+ L<name> => L<name|name>
+ L</section> => L<"section"|/section>
+ L<name/section> => L<"section" in name|name/section>
+
+The name may contain embedded EE<lt>E<gt> and ZE<lt>E<gt> formatting codes,
+and the section, anchor text, and inferred anchor text may contain any
+formatting codes. Any double quotes around the section are removed as part
+of the parsing, as is any leading or trailing whitespace.
+
+If the text of the LE<lt>E<gt> escape is entirely enclosed in double
+quotes, it's interpreted as a link to a section for backward
+compatibility.
+
+No attempt is made to resolve formatting codes. This must be done after
+calling parselink() (since EE<lt>E<gt> formatting codes can be used to
+escape characters that would otherwise be significant to the parser and
+resolving them before parsing would result in an incorrect parse of a
+formatting code like:
+
+ L<verticalE<verbar>barE<sol>slash>
+
+which should be interpreted as a link to the C<vertical|bar/slash> POD page
+and not as a link to the C<slash> section of the C<bar> POD page with an
+anchor text of C<vertical>. Note that not only the anchor text will need to
+have formatting codes expanded, but so will the target of the link (to deal
+with EE<lt>E<gt> and ZE<lt>E<gt> formatting codes), and special handling of
+the section may be necessary depending on whether the translator wants to
+consider markup in sections to be significant when resolving links. See
+L<perlpodspec> for more information.
+
+=head1 SEE ALSO
+
+L<Pod::Parser>
+
+The current version of this module is always available from its web site at
+L<http://www.eyrie.org/~eagle/software/podlators/>.
+
+=head1 AUTHOR
+
+Russ Allbery <rra at stanford.edu>.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2001, 2008 Russ Allbery <rra at stanford.edu>.
+
+This program is free software; you may redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
Copied: trunk/contrib/perl/lib/Pod/ParseUtils.pm (from rev 6437, vendor/perl/5.18.1/lib/Pod/ParseUtils.pm)
===================================================================
--- trunk/contrib/perl/lib/Pod/ParseUtils.pm (rev 0)
+++ trunk/contrib/perl/lib/Pod/ParseUtils.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,855 @@
+#############################################################################
+# Pod/ParseUtils.pm -- helpers for POD parsing and conversion
+#
+# Copyright (C) 1999-2000 by Marek Rouchal. All rights reserved.
+# This file is part of "PodParser". PodParser is free software;
+# you can redistribute it and/or modify it under the same terms
+# as Perl itself.
+#############################################################################
+
+package Pod::ParseUtils;
+use strict;
+
+use vars qw($VERSION);
+$VERSION = '1.36'; ## Current version of this package
+require 5.005; ## requires this Perl version or later
+
+=head1 NAME
+
+Pod::ParseUtils - helpers for POD parsing and conversion
+
+=head1 SYNOPSIS
+
+ use Pod::ParseUtils;
+
+ my $list = new Pod::List;
+ my $link = Pod::Hyperlink->new('Pod::Parser');
+
+=head1 DESCRIPTION
+
+B<Pod::ParseUtils> contains a few object-oriented helper packages for
+POD parsing and processing (i.e. in POD formatters and translators).
+
+=cut
+
+#-----------------------------------------------------------------------------
+# Pod::List
+#
+# class to hold POD list info (=over, =item, =back)
+#-----------------------------------------------------------------------------
+
+package Pod::List;
+
+use Carp;
+
+=head2 Pod::List
+
+B<Pod::List> can be used to hold information about POD lists
+(written as =over ... =item ... =back) for further processing.
+The following methods are available:
+
+=over 4
+
+=item Pod::List-E<gt>new()
+
+Create a new list object. Properties may be specified through a hash
+reference like this:
+
+ my $list = Pod::List->new({ -start => $., -indent => 4 });
+
+See the individual methods/properties for details.
+
+=cut
+
+sub new {
+ my $this = shift;
+ my $class = ref($this) || $this;
+ my %params = @_;
+ my $self = {%params};
+ bless $self, $class;
+ $self->initialize();
+ return $self;
+}
+
+sub initialize {
+ my $self = shift;
+ $self->{-file} ||= 'unknown';
+ $self->{-start} ||= 'unknown';
+ $self->{-indent} ||= 4; # perlpod: "should be the default"
+ $self->{_items} = [];
+ $self->{-type} ||= '';
+}
+
+=item $list-E<gt>file()
+
+Without argument, retrieves the file name the list is in. This must
+have been set before by either specifying B<-file> in the B<new()>
+method or by calling the B<file()> method with a scalar argument.
+
+=cut
+
+# The POD file name the list appears in
+sub file {
+ return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file};
+}
+
+=item $list-E<gt>start()
+
+Without argument, retrieves the line number where the list started.
+This must have been set before by either specifying B<-start> in the
+B<new()> method or by calling the B<start()> method with a scalar
+argument.
+
+=cut
+
+# The line in the file the node appears
+sub start {
+ return (@_ > 1) ? ($_[0]->{-start} = $_[1]) : $_[0]->{-start};
+}
+
+=item $list-E<gt>indent()
+
+Without argument, retrieves the indent level of the list as specified
+in C<=over n>. This must have been set before by either specifying
+B<-indent> in the B<new()> method or by calling the B<indent()> method
+with a scalar argument.
+
+=cut
+
+# indent level
+sub indent {
+ return (@_ > 1) ? ($_[0]->{-indent} = $_[1]) : $_[0]->{-indent};
+}
+
+=item $list-E<gt>type()
+
+Without argument, retrieves the list type, which can be an arbitrary value,
+e.g. C<OL>, C<UL>, ... when thinking the HTML way.
+This must have been set before by either specifying
+B<-type> in the B<new()> method or by calling the B<type()> method
+with a scalar argument.
+
+=cut
+
+# The type of the list (UL, OL, ...)
+sub type {
+ return (@_ > 1) ? ($_[0]->{-type} = $_[1]) : $_[0]->{-type};
+}
+
+=item $list-E<gt>rx()
+
+Without argument, retrieves a regular expression for simplifying the
+individual item strings once the list type has been determined. Usage:
+E.g. when converting to HTML, one might strip the leading number in
+an ordered list as C<E<lt>OLE<gt>> already prints numbers itself.
+This must have been set before by either specifying
+B<-rx> in the B<new()> method or by calling the B<rx()> method
+with a scalar argument.
+
+=cut
+
+# The regular expression to simplify the items
+sub rx {
+ return (@_ > 1) ? ($_[0]->{-rx} = $_[1]) : $_[0]->{-rx};
+}
+
+=item $list-E<gt>item()
+
+Without argument, retrieves the array of the items in this list.
+The items may be represented by any scalar.
+If an argument has been given, it is pushed on the list of items.
+
+=cut
+
+# The individual =items of this list
+sub item {
+ my ($self,$item) = @_;
+ if(defined $item) {
+ push(@{$self->{_items}}, $item);
+ return $item;
+ }
+ else {
+ return @{$self->{_items}};
+ }
+}
+
+=item $list-E<gt>parent()
+
+Without argument, retrieves information about the parent holding this
+list, which is represented as an arbitrary scalar.
+This must have been set before by either specifying
+B<-parent> in the B<new()> method or by calling the B<parent()> method
+with a scalar argument.
+
+=cut
+
+# possibility for parsers/translators to store information about the
+# lists's parent object
+sub parent {
+ return (@_ > 1) ? ($_[0]->{-parent} = $_[1]) : $_[0]->{-parent};
+}
+
+=item $list-E<gt>tag()
+
+Without argument, retrieves information about the list tag, which can be
+any scalar.
+This must have been set before by either specifying
+B<-tag> in the B<new()> method or by calling the B<tag()> method
+with a scalar argument.
+
+=back
+
+=cut
+
+# possibility for parsers/translators to store information about the
+# list's object
+sub tag {
+ return (@_ > 1) ? ($_[0]->{-tag} = $_[1]) : $_[0]->{-tag};
+}
+
+#-----------------------------------------------------------------------------
+# Pod::Hyperlink
+#
+# class to manipulate POD hyperlinks (L<>)
+#-----------------------------------------------------------------------------
+
+package Pod::Hyperlink;
+
+=head2 Pod::Hyperlink
+
+B<Pod::Hyperlink> is a class for manipulation of POD hyperlinks. Usage:
+
+ my $link = Pod::Hyperlink->new('alternative text|page/"section in page"');
+
+The B<Pod::Hyperlink> class is mainly designed to parse the contents of the
+C<LE<lt>...E<gt>> sequence, providing a simple interface for accessing the
+different parts of a POD hyperlink for further processing. It can also be
+used to construct hyperlinks.
+
+=over 4
+
+=item Pod::Hyperlink-E<gt>new()
+
+The B<new()> method can either be passed a set of key/value pairs or a single
+scalar value, namely the contents of a C<LE<lt>...E<gt>> sequence. An object
+of the class C<Pod::Hyperlink> is returned. The value C<undef> indicates a
+failure, the error message is stored in C<$@>.
+
+=cut
+
+use Carp;
+
+sub new {
+ my $this = shift;
+ my $class = ref($this) || $this;
+ my $self = +{};
+ bless $self, $class;
+ $self->initialize();
+ if(defined $_[0]) {
+ if(ref($_[0])) {
+ # called with a list of parameters
+ %$self = %{$_[0]};
+ $self->_construct_text();
+ }
+ else {
+ # called with L<> contents
+ return unless($self->parse($_[0]));
+ }
+ }
+ return $self;
+}
+
+sub initialize {
+ my $self = shift;
+ $self->{-line} ||= 'undef';
+ $self->{-file} ||= 'undef';
+ $self->{-page} ||= '';
+ $self->{-node} ||= '';
+ $self->{-alttext} ||= '';
+ $self->{-type} ||= 'undef';
+ $self->{_warnings} = [];
+}
+
+=item $link-E<gt>parse($string)
+
+This method can be used to (re)parse a (new) hyperlink, i.e. the contents
+of a C<LE<lt>...E<gt>> sequence. The result is stored in the current object.
+Warnings are stored in the B<warnings> property.
+E.g. sections like C<LE<lt>open(2)E<gt>> are deprecated, as they do not point
+to Perl documents. C<LE<lt>DBI::foo(3p)E<gt>> is wrong as well, the manpage
+section can simply be dropped.
+
+=cut
+
+sub parse {
+ my $self = shift;
+ local($_) = $_[0];
+ # syntax check the link and extract destination
+ my ($alttext,$page,$node,$type,$quoted) = (undef,'','','',0);
+
+ $self->{_warnings} = [];
+
+ # collapse newlines with whitespace
+ s/\s*\n+\s*/ /g;
+
+ # strip leading/trailing whitespace
+ if(s/^[\s\n]+//) {
+ $self->warning('ignoring leading whitespace in link');
+ }
+ if(s/[\s\n]+$//) {
+ $self->warning('ignoring trailing whitespace in link');
+ }
+ unless(length($_)) {
+ _invalid_link('empty link');
+ return;
+ }
+
+ ## Check for different possibilities. This is tedious and error-prone
+ # we match all possibilities (alttext, page, section/item)
+ #warn "DEBUG: link=$_\n";
+
+ # only page
+ # problem: a lot of people use (), or (1) or the like to indicate
+ # man page sections. But this collides with L<func()> that is supposed
+ # to point to an internal funtion...
+ my $page_rx = '[\w.-]+(?:::[\w.-]+)*(?:[(](?:\d\w*|)[)]|)';
+ # page name only
+ if(/^($page_rx)$/o) {
+ $page = $1;
+ $type = 'page';
+ }
+ # alttext, page and "section"
+ elsif(m{^(.*?)\s*[|]\s*($page_rx)\s*/\s*"(.+)"$}o) {
+ ($alttext, $page, $node) = ($1, $2, $3);
+ $type = 'section';
+ $quoted = 1; #... therefore | and / are allowed
+ }
+ # alttext and page
+ elsif(/^(.*?)\s*[|]\s*($page_rx)$/o) {
+ ($alttext, $page) = ($1, $2);
+ $type = 'page';
+ }
+ # alttext and "section"
+ elsif(m{^(.*?)\s*[|]\s*(?:/\s*|)"(.+)"$}) {
+ ($alttext, $node) = ($1,$2);
+ $type = 'section';
+ $quoted = 1;
+ }
+ # page and "section"
+ elsif(m{^($page_rx)\s*/\s*"(.+)"$}o) {
+ ($page, $node) = ($1, $2);
+ $type = 'section';
+ $quoted = 1;
+ }
+ # page and item
+ elsif(m{^($page_rx)\s*/\s*(.+)$}o) {
+ ($page, $node) = ($1, $2);
+ $type = 'item';
+ }
+ # only "section"
+ elsif(m{^/?"(.+)"$}) {
+ $node = $1;
+ $type = 'section';
+ $quoted = 1;
+ }
+ # only item
+ elsif(m{^\s*/(.+)$}) {
+ $node = $1;
+ $type = 'item';
+ }
+
+ # non-standard: Hyperlink with alt-text - doesn't remove protocol prefix, maybe it should?
+ elsif(/^ \s* (.*?) \s* [|] \s* (\w+:[^:\s] [^\s|]*?) \s* $/ix) {
+ ($alttext,$node) = ($1,$2);
+ $type = 'hyperlink';
+ }
+
+ # non-standard: Hyperlink
+ elsif(/^(\w+:[^:\s]\S*)$/i) {
+ $node = $1;
+ $type = 'hyperlink';
+ }
+ # alttext, page and item
+ elsif(m{^(.*?)\s*[|]\s*($page_rx)\s*/\s*(.+)$}o) {
+ ($alttext, $page, $node) = ($1, $2, $3);
+ $type = 'item';
+ }
+ # alttext and item
+ elsif(m{^(.*?)\s*[|]\s*/(.+)$}) {
+ ($alttext, $node) = ($1,$2);
+ }
+ # must be an item or a "malformed" section (without "")
+ else {
+ $node = $_;
+ $type = 'item';
+ }
+ # collapse whitespace in nodes
+ $node =~ s/\s+/ /gs;
+
+ # empty alternative text expands to node name
+ if(defined $alttext) {
+ if(!length($alttext)) {
+ $alttext = $node || $page;
+ }
+ }
+ else {
+ $alttext = '';
+ }
+
+ if($page =~ /[(]\w*[)]$/) {
+ $self->warning("(section) in '$page' deprecated");
+ }
+ if(!$quoted && $node =~ m{[|/]} && $type ne 'hyperlink') {
+ $self->warning("node '$node' contains non-escaped | or /");
+ }
+ if($alttext =~ m{[|/]}) {
+ $self->warning("alternative text '$node' contains non-escaped | or /");
+ }
+ $self->{-page} = $page;
+ $self->{-node} = $node;
+ $self->{-alttext} = $alttext;
+ #warn "DEBUG: page=$page section=$section item=$item alttext=$alttext\n";
+ $self->{-type} = $type;
+ $self->_construct_text();
+ 1;
+}
+
+sub _construct_text {
+ my $self = shift;
+ my $alttext = $self->alttext();
+ my $type = $self->type();
+ my $section = $self->node();
+ my $page = $self->page();
+ my $page_ext = '';
+ $page =~ s/([(]\w*[)])$// && ($page_ext = $1);
+ if($alttext) {
+ $self->{_text} = $alttext;
+ }
+ elsif($type eq 'hyperlink') {
+ $self->{_text} = $section;
+ }
+ else {
+ $self->{_text} = ($section || '') .
+ (($page && $section) ? ' in ' : '') .
+ "$page$page_ext";
+ }
+ # for being marked up later
+ # use the non-standard markers P<> and Q<>, so that the resulting
+ # text can be parsed by the translators. It's their job to put
+ # the correct hypertext around the linktext
+ if($alttext) {
+ $self->{_markup} = "Q<$alttext>";
+ }
+ elsif($type eq 'hyperlink') {
+ $self->{_markup} = "Q<$section>";
+ }
+ else {
+ $self->{_markup} = (!$section ? '' : "Q<$section>") .
+ ($page ? ($section ? ' in ':'') . "P<$page>$page_ext" : '');
+ }
+}
+
+=item $link-E<gt>markup($string)
+
+Set/retrieve the textual value of the link. This string contains special
+markers C<PE<lt>E<gt>> and C<QE<lt>E<gt>> that should be expanded by the
+translator's interior sequence expansion engine to the
+formatter-specific code to highlight/activate the hyperlink. The details
+have to be implemented in the translator.
+
+=cut
+
+#' retrieve/set markuped text
+sub markup {
+ return (@_ > 1) ? ($_[0]->{_markup} = $_[1]) : $_[0]->{_markup};
+}
+
+=item $link-E<gt>text()
+
+This method returns the textual representation of the hyperlink as above,
+but without markers (read only). Depending on the link type this is one of
+the following alternatives (the + and * denote the portions of the text
+that are marked up):
+
+ +perl+ L<perl>
+ *$|* in +perlvar+ L<perlvar/$|>
+ *OPTIONS* in +perldoc+ L<perldoc/"OPTIONS">
+ *DESCRIPTION* L<"DESCRIPTION">
+
+=cut
+
+# The complete link's text
+sub text {
+ return $_[0]->{_text};
+}
+
+=item $link-E<gt>warning()
+
+After parsing, this method returns any warnings encountered during the
+parsing process.
+
+=cut
+
+# Set/retrieve warnings
+sub warning {
+ my $self = shift;
+ if(@_) {
+ push(@{$self->{_warnings}}, @_);
+ return @_;
+ }
+ return @{$self->{_warnings}};
+}
+
+=item $link-E<gt>file()
+
+=item $link-E<gt>line()
+
+Just simple slots for storing information about the line and the file
+the link was encountered in. Has to be filled in manually.
+
+=cut
+
+# The line in the file the link appears
+sub line {
+ return (@_ > 1) ? ($_[0]->{-line} = $_[1]) : $_[0]->{-line};
+}
+
+# The POD file name the link appears in
+sub file {
+ return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file};
+}
+
+=item $link-E<gt>page()
+
+This method sets or returns the POD page this link points to.
+
+=cut
+
+# The POD page the link appears on
+sub page {
+ if (@_ > 1) {
+ $_[0]->{-page} = $_[1];
+ $_[0]->_construct_text();
+ }
+ return $_[0]->{-page};
+}
+
+=item $link-E<gt>node()
+
+As above, but the destination node text of the link.
+
+=cut
+
+# The link destination
+sub node {
+ if (@_ > 1) {
+ $_[0]->{-node} = $_[1];
+ $_[0]->_construct_text();
+ }
+ return $_[0]->{-node};
+}
+
+=item $link-E<gt>alttext()
+
+Sets or returns an alternative text specified in the link.
+
+=cut
+
+# Potential alternative text
+sub alttext {
+ if (@_ > 1) {
+ $_[0]->{-alttext} = $_[1];
+ $_[0]->_construct_text();
+ }
+ return $_[0]->{-alttext};
+}
+
+=item $link-E<gt>type()
+
+The node type, either C<section> or C<item>. As an unofficial type,
+there is also C<hyperlink>, derived from e.g. C<LE<lt>http://perl.comE<gt>>
+
+=cut
+
+# The type: item or headn
+sub type {
+ return (@_ > 1) ? ($_[0]->{-type} = $_[1]) : $_[0]->{-type};
+}
+
+=item $link-E<gt>link()
+
+Returns the link as contents of C<LE<lt>E<gt>>. Reciprocal to B<parse()>.
+
+=back
+
+=cut
+
+# The link itself
+sub link {
+ my $self = shift;
+ my $link = $self->page() || '';
+ if($self->node()) {
+ my $node = $self->node();
+ $node =~ s/\|/E<verbar>/g;
+ $node =~ s{/}{E<sol>}g;
+ if($self->type() eq 'section') {
+ $link .= ($link ? '/' : '') . '"' . $node . '"';
+ }
+ elsif($self->type() eq 'hyperlink') {
+ $link = $self->node();
+ }
+ else { # item
+ $link .= '/' . $node;
+ }
+ }
+ if($self->alttext()) {
+ my $text = $self->alttext();
+ $text =~ s/\|/E<verbar>/g;
+ $text =~ s{/}{E<sol>}g;
+ $link = "$text|$link";
+ }
+ return $link;
+}
+
+sub _invalid_link {
+ my ($msg) = @_;
+ # this sets @_
+ #eval { die "$msg\n" };
+ #chomp $@;
+ $@ = $msg; # this seems to work, too!
+ return;
+}
+
+#-----------------------------------------------------------------------------
+# Pod::Cache
+#
+# class to hold POD page details
+#-----------------------------------------------------------------------------
+
+package Pod::Cache;
+
+=head2 Pod::Cache
+
+B<Pod::Cache> holds information about a set of POD documents,
+especially the nodes for hyperlinks.
+The following methods are available:
+
+=over 4
+
+=item Pod::Cache-E<gt>new()
+
+Create a new cache object. This object can hold an arbitrary number of
+POD documents of class Pod::Cache::Item.
+
+=cut
+
+sub new {
+ my $this = shift;
+ my $class = ref($this) || $this;
+ my $self = [];
+ bless $self, $class;
+ return $self;
+}
+
+=item $cache-E<gt>item()
+
+Add a new item to the cache. Without arguments, this method returns a
+list of all cache elements.
+
+=cut
+
+sub item {
+ my ($self,%param) = @_;
+ if(%param) {
+ my $item = Pod::Cache::Item->new(%param);
+ push(@$self, $item);
+ return $item;
+ }
+ else {
+ return @{$self};
+ }
+}
+
+=item $cache-E<gt>find_page($name)
+
+Look for a POD document named C<$name> in the cache. Returns the
+reference to the corresponding Pod::Cache::Item object or undef if
+not found.
+
+=back
+
+=cut
+
+sub find_page {
+ my ($self,$page) = @_;
+ foreach(@$self) {
+ if($_->page() eq $page) {
+ return $_;
+ }
+ }
+ return;
+}
+
+package Pod::Cache::Item;
+
+=head2 Pod::Cache::Item
+
+B<Pod::Cache::Item> holds information about individual POD documents,
+that can be grouped in a Pod::Cache object.
+It is intended to hold information about the hyperlink nodes of POD
+documents.
+The following methods are available:
+
+=over 4
+
+=item Pod::Cache::Item-E<gt>new()
+
+Create a new object.
+
+=cut
+
+sub new {
+ my $this = shift;
+ my $class = ref($this) || $this;
+ my %params = @_;
+ my $self = {%params};
+ bless $self, $class;
+ $self->initialize();
+ return $self;
+}
+
+sub initialize {
+ my $self = shift;
+ $self->{-nodes} = [] unless(defined $self->{-nodes});
+}
+
+=item $cacheitem-E<gt>page()
+
+Set/retrieve the POD document name (e.g. "Pod::Parser").
+
+=cut
+
+# The POD page
+sub page {
+ return (@_ > 1) ? ($_[0]->{-page} = $_[1]) : $_[0]->{-page};
+}
+
+=item $cacheitem-E<gt>description()
+
+Set/retrieve the POD short description as found in the C<=head1 NAME>
+section.
+
+=cut
+
+# The POD description, taken out of NAME if present
+sub description {
+ return (@_ > 1) ? ($_[0]->{-description} = $_[1]) : $_[0]->{-description};
+}
+
+=item $cacheitem-E<gt>path()
+
+Set/retrieve the POD file storage path.
+
+=cut
+
+# The file path
+sub path {
+ return (@_ > 1) ? ($_[0]->{-path} = $_[1]) : $_[0]->{-path};
+}
+
+=item $cacheitem-E<gt>file()
+
+Set/retrieve the POD file name.
+
+=cut
+
+# The POD file name
+sub file {
+ return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file};
+}
+
+=item $cacheitem-E<gt>nodes()
+
+Add a node (or a list of nodes) to the document's node list. Note that
+the order is kept, i.e. start with the first node and end with the last.
+If no argument is given, the current list of nodes is returned in the
+same order the nodes have been added.
+A node can be any scalar, but usually is a pair of node string and
+unique id for the C<find_node> method to work correctly.
+
+=cut
+
+# The POD nodes
+sub nodes {
+ my ($self, at nodes) = @_;
+ if(@nodes) {
+ push(@{$self->{-nodes}}, @nodes);
+ return @nodes;
+ }
+ else {
+ return @{$self->{-nodes}};
+ }
+}
+
+=item $cacheitem-E<gt>find_node($name)
+
+Look for a node or index entry named C<$name> in the object.
+Returns the unique id of the node (i.e. the second element of the array
+stored in the node array) or undef if not found.
+
+=cut
+
+sub find_node {
+ my ($self,$node) = @_;
+ my @search;
+ push(@search, @{$self->{-nodes}}) if($self->{-nodes});
+ push(@search, @{$self->{-idx}}) if($self->{-idx});
+ foreach(@search) {
+ if($_->[0] eq $node) {
+ return $_->[1]; # id
+ }
+ }
+ return;
+}
+
+=item $cacheitem-E<gt>idx()
+
+Add an index entry (or a list of them) to the document's index list. Note that
+the order is kept, i.e. start with the first node and end with the last.
+If no argument is given, the current list of index entries is returned in the
+same order the entries have been added.
+An index entry can be any scalar, but usually is a pair of string and
+unique id.
+
+=back
+
+=cut
+
+# The POD index entries
+sub idx {
+ my ($self, at idx) = @_;
+ if(@idx) {
+ push(@{$self->{-idx}}, @idx);
+ return @idx;
+ }
+ else {
+ return @{$self->{-idx}};
+ }
+}
+
+=head1 AUTHOR
+
+Please report bugs using L<http://rt.cpan.org>.
+
+Marek Rouchal E<lt>marekr at cpan.orgE<gt>, borrowing
+a lot of things from L<pod2man> and L<pod2roff> as well as other POD
+processing tools by Tom Christiansen, Brad Appleton and Russ Allbery.
+
+=head1 SEE ALSO
+
+L<pod2man>, L<pod2roff>, L<Pod::Parser>, L<Pod::Checker>,
+L<pod2html>
+
+=cut
+
+1;
Copied: trunk/contrib/perl/lib/Pod/Parser.pm (from rev 6437, vendor/perl/5.18.1/lib/Pod/Parser.pm)
===================================================================
--- trunk/contrib/perl/lib/Pod/Parser.pm (rev 0)
+++ trunk/contrib/perl/lib/Pod/Parser.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,1829 @@
+#############################################################################
+# Pod/Parser.pm -- package which defines a base class for parsing POD docs.
+#
+# Copyright (C) 1996-2000 by Bradford Appleton. All rights reserved.
+# This file is part of "PodParser". PodParser is free software;
+# you can redistribute it and/or modify it under the same terms
+# as Perl itself.
+#############################################################################
+
+package Pod::Parser;
+use strict;
+
+## These "variables" are used as local "glob aliases" for performance
+use vars qw($VERSION @ISA %myData %myOpts @input_stack);
+$VERSION = '1.37'; ## Current version of this package
+require 5.005; ## requires this Perl version or later
+
+#############################################################################
+
+=head1 NAME
+
+Pod::Parser - base class for creating POD filters and translators
+
+=head1 SYNOPSIS
+
+ use Pod::Parser;
+
+ package MyParser;
+ @ISA = qw(Pod::Parser);
+
+ sub command {
+ my ($parser, $command, $paragraph, $line_num) = @_;
+ ## Interpret the command and its text; sample actions might be:
+ if ($command eq 'head1') { ... }
+ elsif ($command eq 'head2') { ... }
+ ## ... other commands and their actions
+ my $out_fh = $parser->output_handle();
+ my $expansion = $parser->interpolate($paragraph, $line_num);
+ print $out_fh $expansion;
+ }
+
+ sub verbatim {
+ my ($parser, $paragraph, $line_num) = @_;
+ ## Format verbatim paragraph; sample actions might be:
+ my $out_fh = $parser->output_handle();
+ print $out_fh $paragraph;
+ }
+
+ sub textblock {
+ my ($parser, $paragraph, $line_num) = @_;
+ ## Translate/Format this block of text; sample actions might be:
+ my $out_fh = $parser->output_handle();
+ my $expansion = $parser->interpolate($paragraph, $line_num);
+ print $out_fh $expansion;
+ }
+
+ sub interior_sequence {
+ my ($parser, $seq_command, $seq_argument) = @_;
+ ## Expand an interior sequence; sample actions might be:
+ return "*$seq_argument*" if ($seq_command eq 'B');
+ return "`$seq_argument'" if ($seq_command eq 'C');
+ return "_${seq_argument}_'" if ($seq_command eq 'I');
+ ## ... other sequence commands and their resulting text
+ }
+
+ package main;
+
+ ## Create a parser object and have it parse file whose name was
+ ## given on the command-line (use STDIN if no files were given).
+ $parser = new MyParser();
+ $parser->parse_from_filehandle(\*STDIN) if (@ARGV == 0);
+ for (@ARGV) { $parser->parse_from_file($_); }
+
+=head1 REQUIRES
+
+perl5.005, Pod::InputObjects, Exporter, Symbol, Carp
+
+=head1 EXPORTS
+
+Nothing.
+
+=head1 DESCRIPTION
+
+B<Pod::Parser> is a base class for creating POD filters and translators.
+It handles most of the effort involved with parsing the POD sections
+from an input stream, leaving subclasses free to be concerned only with
+performing the actual translation of text.
+
+B<Pod::Parser> parses PODs, and makes method calls to handle the various
+components of the POD. Subclasses of B<Pod::Parser> override these methods
+to translate the POD into whatever output format they desire.
+
+=head1 QUICK OVERVIEW
+
+To create a POD filter for translating POD documentation into some other
+format, you create a subclass of B<Pod::Parser> which typically overrides
+just the base class implementation for the following methods:
+
+=over 2
+
+=item *
+
+B<command()>
+
+=item *
+
+B<verbatim()>
+
+=item *
+
+B<textblock()>
+
+=item *
+
+B<interior_sequence()>
+
+=back
+
+You may also want to override the B<begin_input()> and B<end_input()>
+methods for your subclass (to perform any needed per-file and/or
+per-document initialization or cleanup).
+
+If you need to perform any preprocessing of input before it is parsed
+you may want to override one or more of B<preprocess_line()> and/or
+B<preprocess_paragraph()>.
+
+Sometimes it may be necessary to make more than one pass over the input
+files. If this is the case you have several options. You can make the
+first pass using B<Pod::Parser> and override your methods to store the
+intermediate results in memory somewhere for the B<end_pod()> method to
+process. You could use B<Pod::Parser> for several passes with an
+appropriate state variable to control the operation for each pass. If
+your input source can't be reset to start at the beginning, you can
+store it in some other structure as a string or an array and have that
+structure implement a B<getline()> method (which is all that
+B<parse_from_filehandle()> uses to read input).
+
+Feel free to add any member data fields you need to keep track of things
+like current font, indentation, horizontal or vertical position, or
+whatever else you like. Be sure to read L<"PRIVATE METHODS AND DATA">
+to avoid name collisions.
+
+For the most part, the B<Pod::Parser> base class should be able to
+do most of the input parsing for you and leave you free to worry about
+how to interpret the commands and translate the result.
+
+Note that all we have described here in this quick overview is the
+simplest most straightforward use of B<Pod::Parser> to do stream-based
+parsing. It is also possible to use the B<Pod::Parser::parse_text> function
+to do more sophisticated tree-based parsing. See L<"TREE-BASED PARSING">.
+
+=head1 PARSING OPTIONS
+
+A I<parse-option> is simply a named option of B<Pod::Parser> with a
+value that corresponds to a certain specified behavior. These various
+behaviors of B<Pod::Parser> may be enabled/disabled by setting
+or unsetting one or more I<parse-options> using the B<parseopts()> method.
+The set of currently accepted parse-options is as follows:
+
+=over 3
+
+=item B<-want_nonPODs> (default: unset)
+
+Normally (by default) B<Pod::Parser> will only provide access to
+the POD sections of the input. Input paragraphs that are not part
+of the POD-format documentation are not made available to the caller
+(not even using B<preprocess_paragraph()>). Setting this option to a
+non-empty, non-zero value will allow B<preprocess_paragraph()> to see
+non-POD sections of the input as well as POD sections. The B<cutting()>
+method can be used to determine if the corresponding paragraph is a POD
+paragraph, or some other input paragraph.
+
+=item B<-process_cut_cmd> (default: unset)
+
+Normally (by default) B<Pod::Parser> handles the C<=cut> POD directive
+by itself and does not pass it on to the caller for processing. Setting
+this option to a non-empty, non-zero value will cause B<Pod::Parser> to
+pass the C<=cut> directive to the caller just like any other POD command
+(and hence it may be processed by the B<command()> method).
+
+B<Pod::Parser> will still interpret the C<=cut> directive to mean that
+"cutting mode" has been (re)entered, but the caller will get a chance
+to capture the actual C<=cut> paragraph itself for whatever purpose
+it desires.
+
+=item B<-warnings> (default: unset)
+
+Normally (by default) B<Pod::Parser> recognizes a bare minimum of
+pod syntax errors and warnings and issues diagnostic messages
+for errors, but not for warnings. (Use B<Pod::Checker> to do more
+thorough checking of POD syntax.) Setting this option to a non-empty,
+non-zero value will cause B<Pod::Parser> to issue diagnostics for
+the few warnings it recognizes as well as the errors.
+
+=back
+
+Please see L<"parseopts()"> for a complete description of the interface
+for the setting and unsetting of parse-options.
+
+=cut
+
+#############################################################################
+
+#use diagnostics;
+use Pod::InputObjects;
+use Carp;
+use Exporter;
+BEGIN {
+ if ($] < 5.006) {
+ require Symbol;
+ import Symbol;
+ }
+}
+ at ISA = qw(Exporter);
+
+#############################################################################
+
+=head1 RECOMMENDED SUBROUTINE/METHOD OVERRIDES
+
+B<Pod::Parser> provides several methods which most subclasses will probably
+want to override. These methods are as follows:
+
+=cut
+
+##---------------------------------------------------------------------------
+
+=head1 B<command()>
+
+ $parser->command($cmd,$text,$line_num,$pod_para);
+
+This method should be overridden by subclasses to take the appropriate
+action when a POD command paragraph (denoted by a line beginning with
+"=") is encountered. When such a POD directive is seen in the input,
+this method is called and is passed:
+
+=over 3
+
+=item C<$cmd>
+
+the name of the command for this POD paragraph
+
+=item C<$text>
+
+the paragraph text for the given POD paragraph command.
+
+=item C<$line_num>
+
+the line-number of the beginning of the paragraph
+
+=item C<$pod_para>
+
+a reference to a C<Pod::Paragraph> object which contains further
+information about the paragraph command (see L<Pod::InputObjects>
+for details).
+
+=back
+
+B<Note> that this method I<is> called for C<=pod> paragraphs.
+
+The base class implementation of this method simply treats the raw POD
+command as normal block of paragraph text (invoking the B<textblock()>
+method with the command paragraph).
+
+=cut
+
+sub command {
+ my ($self, $cmd, $text, $line_num, $pod_para) = @_;
+ ## Just treat this like a textblock
+ $self->textblock($pod_para->raw_text(), $line_num, $pod_para);
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<verbatim()>
+
+ $parser->verbatim($text,$line_num,$pod_para);
+
+This method may be overridden by subclasses to take the appropriate
+action when a block of verbatim text is encountered. It is passed the
+following parameters:
+
+=over 3
+
+=item C<$text>
+
+the block of text for the verbatim paragraph
+
+=item C<$line_num>
+
+the line-number of the beginning of the paragraph
+
+=item C<$pod_para>
+
+a reference to a C<Pod::Paragraph> object which contains further
+information about the paragraph (see L<Pod::InputObjects>
+for details).
+
+=back
+
+The base class implementation of this method simply prints the textblock
+(unmodified) to the output filehandle.
+
+=cut
+
+sub verbatim {
+ my ($self, $text, $line_num, $pod_para) = @_;
+ my $out_fh = $self->{_OUTPUT};
+ print $out_fh $text;
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<textblock()>
+
+ $parser->textblock($text,$line_num,$pod_para);
+
+This method may be overridden by subclasses to take the appropriate
+action when a normal block of POD text is encountered (although the base
+class method will usually do what you want). It is passed the following
+parameters:
+
+=over 3
+
+=item C<$text>
+
+the block of text for the a POD paragraph
+
+=item C<$line_num>
+
+the line-number of the beginning of the paragraph
+
+=item C<$pod_para>
+
+a reference to a C<Pod::Paragraph> object which contains further
+information about the paragraph (see L<Pod::InputObjects>
+for details).
+
+=back
+
+In order to process interior sequences, subclasses implementations of
+this method will probably want to invoke either B<interpolate()> or
+B<parse_text()>, passing it the text block C<$text>, and the corresponding
+line number in C<$line_num>, and then perform any desired processing upon
+the returned result.
+
+The base class implementation of this method simply prints the text block
+as it occurred in the input stream).
+
+=cut
+
+sub textblock {
+ my ($self, $text, $line_num, $pod_para) = @_;
+ my $out_fh = $self->{_OUTPUT};
+ print $out_fh $self->interpolate($text, $line_num);
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<interior_sequence()>
+
+ $parser->interior_sequence($seq_cmd,$seq_arg,$pod_seq);
+
+This method should be overridden by subclasses to take the appropriate
+action when an interior sequence is encountered. An interior sequence is
+an embedded command within a block of text which appears as a command
+name (usually a single uppercase character) followed immediately by a
+string of text which is enclosed in angle brackets. This method is
+passed the sequence command C<$seq_cmd> and the corresponding text
+C<$seq_arg>. It is invoked by the B<interpolate()> method for each interior
+sequence that occurs in the string that it is passed. It should return
+the desired text string to be used in place of the interior sequence.
+The C<$pod_seq> argument is a reference to a C<Pod::InteriorSequence>
+object which contains further information about the interior sequence.
+Please see L<Pod::InputObjects> for details if you need to access this
+additional information.
+
+Subclass implementations of this method may wish to invoke the
+B<nested()> method of C<$pod_seq> to see if it is nested inside
+some other interior-sequence (and if so, which kind).
+
+The base class implementation of the B<interior_sequence()> method
+simply returns the raw text of the interior sequence (as it occurred
+in the input) to the caller.
+
+=cut
+
+sub interior_sequence {
+ my ($self, $seq_cmd, $seq_arg, $pod_seq) = @_;
+ ## Just return the raw text of the interior sequence
+ return $pod_seq->raw_text();
+}
+
+#############################################################################
+
+=head1 OPTIONAL SUBROUTINE/METHOD OVERRIDES
+
+B<Pod::Parser> provides several methods which subclasses may want to override
+to perform any special pre/post-processing. These methods do I<not> have to
+be overridden, but it may be useful for subclasses to take advantage of them.
+
+=cut
+
+##---------------------------------------------------------------------------
+
+=head1 B<new()>
+
+ my $parser = Pod::Parser->new();
+
+This is the constructor for B<Pod::Parser> and its subclasses. You
+I<do not> need to override this method! It is capable of constructing
+subclass objects as well as base class objects, provided you use
+any of the following constructor invocation styles:
+
+ my $parser1 = MyParser->new();
+ my $parser2 = new MyParser();
+ my $parser3 = $parser2->new();
+
+where C<MyParser> is some subclass of B<Pod::Parser>.
+
+Using the syntax C<MyParser::new()> to invoke the constructor is I<not>
+recommended, but if you insist on being able to do this, then the
+subclass I<will> need to override the B<new()> constructor method. If
+you do override the constructor, you I<must> be sure to invoke the
+B<initialize()> method of the newly blessed object.
+
+Using any of the above invocations, the first argument to the
+constructor is always the corresponding package name (or object
+reference). No other arguments are required, but if desired, an
+associative array (or hash-table) my be passed to the B<new()>
+constructor, as in:
+
+ my $parser1 = MyParser->new( MYDATA => $value1, MOREDATA => $value2 );
+ my $parser2 = new MyParser( -myflag => 1 );
+
+All arguments passed to the B<new()> constructor will be treated as
+key/value pairs in a hash-table. The newly constructed object will be
+initialized by copying the contents of the given hash-table (which may
+have been empty). The B<new()> constructor for this class and all of its
+subclasses returns a blessed reference to the initialized object (hash-table).
+
+=cut
+
+sub new {
+ ## Determine if we were called via an object-ref or a classname
+ my ($this,%params) = @_;
+ my $class = ref($this) || $this;
+ ## Any remaining arguments are treated as initial values for the
+ ## hash that is used to represent this object.
+ my $self = { %params };
+ ## Bless ourselves into the desired class and perform any initialization
+ bless $self, $class;
+ $self->initialize();
+ return $self;
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<initialize()>
+
+ $parser->initialize();
+
+This method performs any necessary object initialization. It takes no
+arguments (other than the object instance of course, which is typically
+copied to a local variable named C<$self>). If subclasses override this
+method then they I<must> be sure to invoke C<$self-E<gt>SUPER::initialize()>.
+
+=cut
+
+sub initialize {
+ #my $self = shift;
+ #return;
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<begin_pod()>
+
+ $parser->begin_pod();
+
+This method is invoked at the beginning of processing for each POD
+document that is encountered in the input. Subclasses should override
+this method to perform any per-document initialization.
+
+=cut
+
+sub begin_pod {
+ #my $self = shift;
+ #return;
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<begin_input()>
+
+ $parser->begin_input();
+
+This method is invoked by B<parse_from_filehandle()> immediately I<before>
+processing input from a filehandle. The base class implementation does
+nothing, however, subclasses may override it to perform any per-file
+initializations.
+
+Note that if multiple files are parsed for a single POD document
+(perhaps the result of some future C<=include> directive) this method
+is invoked for every file that is parsed. If you wish to perform certain
+initializations once per document, then you should use B<begin_pod()>.
+
+=cut
+
+sub begin_input {
+ #my $self = shift;
+ #return;
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<end_input()>
+
+ $parser->end_input();
+
+This method is invoked by B<parse_from_filehandle()> immediately I<after>
+processing input from a filehandle. The base class implementation does
+nothing, however, subclasses may override it to perform any per-file
+cleanup actions.
+
+Please note that if multiple files are parsed for a single POD document
+(perhaps the result of some kind of C<=include> directive) this method
+is invoked for every file that is parsed. If you wish to perform certain
+cleanup actions once per document, then you should use B<end_pod()>.
+
+=cut
+
+sub end_input {
+ #my $self = shift;
+ #return;
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<end_pod()>
+
+ $parser->end_pod();
+
+This method is invoked at the end of processing for each POD document
+that is encountered in the input. Subclasses should override this method
+to perform any per-document finalization.
+
+=cut
+
+sub end_pod {
+ #my $self = shift;
+ #return;
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<preprocess_line()>
+
+ $textline = $parser->preprocess_line($text, $line_num);
+
+This method should be overridden by subclasses that wish to perform
+any kind of preprocessing for each I<line> of input (I<before> it has
+been determined whether or not it is part of a POD paragraph). The
+parameter C<$text> is the input line; and the parameter C<$line_num> is
+the line number of the corresponding text line.
+
+The value returned should correspond to the new text to use in its
+place. If the empty string or an undefined value is returned then no
+further processing will be performed for this line.
+
+Please note that the B<preprocess_line()> method is invoked I<before>
+the B<preprocess_paragraph()> method. After all (possibly preprocessed)
+lines in a paragraph have been assembled together and it has been
+determined that the paragraph is part of the POD documentation from one
+of the selected sections, then B<preprocess_paragraph()> is invoked.
+
+The base class implementation of this method returns the given text.
+
+=cut
+
+sub preprocess_line {
+ my ($self, $text, $line_num) = @_;
+ return $text;
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<preprocess_paragraph()>
+
+ $textblock = $parser->preprocess_paragraph($text, $line_num);
+
+This method should be overridden by subclasses that wish to perform any
+kind of preprocessing for each block (paragraph) of POD documentation
+that appears in the input stream. The parameter C<$text> is the POD
+paragraph from the input file; and the parameter C<$line_num> is the
+line number for the beginning of the corresponding paragraph.
+
+The value returned should correspond to the new text to use in its
+place If the empty string is returned or an undefined value is
+returned, then the given C<$text> is ignored (not processed).
+
+This method is invoked after gathering up all the lines in a paragraph
+and after determining the cutting state of the paragraph,
+but before trying to further parse or interpret them. After
+B<preprocess_paragraph()> returns, the current cutting state (which
+is returned by C<$self-E<gt>cutting()>) is examined. If it evaluates
+to true then input text (including the given C<$text>) is cut (not
+processed) until the next POD directive is encountered.
+
+Please note that the B<preprocess_line()> method is invoked I<before>
+the B<preprocess_paragraph()> method. After all (possibly preprocessed)
+lines in a paragraph have been assembled together and either it has been
+determined that the paragraph is part of the POD documentation from one
+of the selected sections or the C<-want_nonPODs> option is true,
+then B<preprocess_paragraph()> is invoked.
+
+The base class implementation of this method returns the given text.
+
+=cut
+
+sub preprocess_paragraph {
+ my ($self, $text, $line_num) = @_;
+ return $text;
+}
+
+#############################################################################
+
+=head1 METHODS FOR PARSING AND PROCESSING
+
+B<Pod::Parser> provides several methods to process input text. These
+methods typically won't need to be overridden (and in some cases they
+can't be overridden), but subclasses may want to invoke them to exploit
+their functionality.
+
+=cut
+
+##---------------------------------------------------------------------------
+
+=head1 B<parse_text()>
+
+ $ptree1 = $parser->parse_text($text, $line_num);
+ $ptree2 = $parser->parse_text({%opts}, $text, $line_num);
+ $ptree3 = $parser->parse_text(\%opts, $text, $line_num);
+
+This method is useful if you need to perform your own interpolation
+of interior sequences and can't rely upon B<interpolate> to expand
+them in simple bottom-up order.
+
+The parameter C<$text> is a string or block of text to be parsed
+for interior sequences; and the parameter C<$line_num> is the
+line number corresponding to the beginning of C<$text>.
+
+B<parse_text()> will parse the given text into a parse-tree of "nodes."
+and interior-sequences. Each "node" in the parse tree is either a
+text-string, or a B<Pod::InteriorSequence>. The result returned is a
+parse-tree of type B<Pod::ParseTree>. Please see L<Pod::InputObjects>
+for more information about B<Pod::InteriorSequence> and B<Pod::ParseTree>.
+
+If desired, an optional hash-ref may be specified as the first argument
+to customize certain aspects of the parse-tree that is created and
+returned. The set of recognized option keywords are:
+
+=over 3
+
+=item B<-expand_seq> =E<gt> I<code-ref>|I<method-name>
+
+Normally, the parse-tree returned by B<parse_text()> will contain an
+unexpanded C<Pod::InteriorSequence> object for each interior-sequence
+encountered. Specifying B<-expand_seq> tells B<parse_text()> to "expand"
+every interior-sequence it sees by invoking the referenced function
+(or named method of the parser object) and using the return value as the
+expanded result.
+
+If a subroutine reference was given, it is invoked as:
+
+ &$code_ref( $parser, $sequence )
+
+and if a method-name was given, it is invoked as:
+
+ $parser->method_name( $sequence )
+
+where C<$parser> is a reference to the parser object, and C<$sequence>
+is a reference to the interior-sequence object.
+[I<NOTE>: If the B<interior_sequence()> method is specified, then it is
+invoked according to the interface specified in L<"interior_sequence()">].
+
+=item B<-expand_text> =E<gt> I<code-ref>|I<method-name>
+
+Normally, the parse-tree returned by B<parse_text()> will contain a
+text-string for each contiguous sequence of characters outside of an
+interior-sequence. Specifying B<-expand_text> tells B<parse_text()> to
+"preprocess" every such text-string it sees by invoking the referenced
+function (or named method of the parser object) and using the return value
+as the preprocessed (or "expanded") result. [Note that if the result is
+an interior-sequence, then it will I<not> be expanded as specified by the
+B<-expand_seq> option; Any such recursive expansion needs to be handled by
+the specified callback routine.]
+
+If a subroutine reference was given, it is invoked as:
+
+ &$code_ref( $parser, $text, $ptree_node )
+
+and if a method-name was given, it is invoked as:
+
+ $parser->method_name( $text, $ptree_node )
+
+where C<$parser> is a reference to the parser object, C<$text> is the
+text-string encountered, and C<$ptree_node> is a reference to the current
+node in the parse-tree (usually an interior-sequence object or else the
+top-level node of the parse-tree).
+
+=item B<-expand_ptree> =E<gt> I<code-ref>|I<method-name>
+
+Rather than returning a C<Pod::ParseTree>, pass the parse-tree as an
+argument to the referenced subroutine (or named method of the parser
+object) and return the result instead of the parse-tree object.
+
+If a subroutine reference was given, it is invoked as:
+
+ &$code_ref( $parser, $ptree )
+
+and if a method-name was given, it is invoked as:
+
+ $parser->method_name( $ptree )
+
+where C<$parser> is a reference to the parser object, and C<$ptree>
+is a reference to the parse-tree object.
+
+=back
+
+=cut
+
+sub parse_text {
+ my $self = shift;
+ local $_ = '';
+
+ ## Get options and set any defaults
+ my %opts = (ref $_[0]) ? %{ shift() } : ();
+ my $expand_seq = $opts{'-expand_seq'} || undef;
+ my $expand_text = $opts{'-expand_text'} || undef;
+ my $expand_ptree = $opts{'-expand_ptree'} || undef;
+
+ my $text = shift;
+ my $line = shift;
+ my $file = $self->input_file();
+ my $cmd = "";
+
+ ## Convert method calls into closures, for our convenience
+ my $xseq_sub = $expand_seq;
+ my $xtext_sub = $expand_text;
+ my $xptree_sub = $expand_ptree;
+ if (defined $expand_seq and $expand_seq eq 'interior_sequence') {
+ ## If 'interior_sequence' is the method to use, we have to pass
+ ## more than just the sequence object, we also need to pass the
+ ## sequence name and text.
+ $xseq_sub = sub {
+ my ($sself, $iseq) = @_;
+ my $args = join('', $iseq->parse_tree->children);
+ return $sself->interior_sequence($iseq->name, $args, $iseq);
+ };
+ }
+ ref $xseq_sub or $xseq_sub = sub { shift()->$expand_seq(@_) };
+ ref $xtext_sub or $xtext_sub = sub { shift()->$expand_text(@_) };
+ ref $xptree_sub or $xptree_sub = sub { shift()->$expand_ptree(@_) };
+
+ ## Keep track of the "current" interior sequence, and maintain a stack
+ ## of "in progress" sequences.
+ ##
+ ## NOTE that we push our own "accumulator" at the very beginning of the
+ ## stack. It's really a parse-tree, not a sequence; but it implements
+ ## the methods we need so we can use it to gather-up all the sequences
+ ## and strings we parse. Thus, by the end of our parsing, it should be
+ ## the only thing left on our stack and all we have to do is return it!
+ ##
+ my $seq = Pod::ParseTree->new();
+ my @seq_stack = ($seq);
+ my ($ldelim, $rdelim) = ('', '');
+
+ ## Iterate over all sequence starts text (NOTE: split with
+ ## capturing parens keeps the delimiters)
+ $_ = $text;
+ my @tokens = split /([A-Z]<(?:<+\s)?)/;
+ while ( @tokens ) {
+ $_ = shift @tokens;
+ ## Look for the beginning of a sequence
+ if ( /^([A-Z])(<(?:<+\s)?)$/ ) {
+ ## Push a new sequence onto the stack of those "in-progress"
+ my $ldelim_orig;
+ ($cmd, $ldelim_orig) = ($1, $2);
+ ($ldelim = $ldelim_orig) =~ s/\s+$//;
+ ($rdelim = $ldelim) =~ tr/</>/;
+ $seq = Pod::InteriorSequence->new(
+ -name => $cmd,
+ -ldelim => $ldelim_orig, -rdelim => $rdelim,
+ -file => $file, -line => $line
+ );
+ (@seq_stack > 1) and $seq->nested($seq_stack[-1]);
+ push @seq_stack, $seq;
+ }
+ ## Look for sequence ending
+ elsif ( @seq_stack > 1 ) {
+ ## Make sure we match the right kind of closing delimiter
+ my ($seq_end, $post_seq) = ('', '');
+ if ( ($ldelim eq '<' and /\A(.*?)(>)/s)
+ or /\A(.*?)(\s+$rdelim)/s )
+ {
+ ## Found end-of-sequence, capture the interior and the
+ ## closing the delimiter, and put the rest back on the
+ ## token-list
+ $post_seq = substr($_, length($1) + length($2));
+ ($_, $seq_end) = ($1, $2);
+ (length $post_seq) and unshift @tokens, $post_seq;
+ }
+ if (length) {
+ ## In the middle of a sequence, append this text to it, and
+ ## dont forget to "expand" it if that's what the caller wanted
+ $seq->append($expand_text ? &$xtext_sub($self,$_,$seq) : $_);
+ $_ .= $seq_end;
+ }
+ if (length $seq_end) {
+ ## End of current sequence, record terminating delimiter
+ $seq->rdelim($seq_end);
+ ## Pop it off the stack of "in progress" sequences
+ pop @seq_stack;
+ ## Append result to its parent in current parse tree
+ $seq_stack[-1]->append($expand_seq ? &$xseq_sub($self,$seq)
+ : $seq);
+ ## Remember the current cmd-name and left-delimiter
+ if(@seq_stack > 1) {
+ $cmd = $seq_stack[-1]->name;
+ $ldelim = $seq_stack[-1]->ldelim;
+ $rdelim = $seq_stack[-1]->rdelim;
+ } else {
+ $cmd = $ldelim = $rdelim = '';
+ }
+ }
+ }
+ elsif (length) {
+ ## In the middle of a sequence, append this text to it, and
+ ## dont forget to "expand" it if that's what the caller wanted
+ $seq->append($expand_text ? &$xtext_sub($self,$_,$seq) : $_);
+ }
+ ## Keep track of line count
+ $line += s/\r*\n//;
+ ## Remember the "current" sequence
+ $seq = $seq_stack[-1];
+ }
+
+ ## Handle unterminated sequences
+ my $errorsub = (@seq_stack > 1) ? $self->errorsub() : undef;
+ while (@seq_stack > 1) {
+ ($cmd, $file, $line) = ($seq->name, $seq->file_line);
+ $ldelim = $seq->ldelim;
+ ($rdelim = $ldelim) =~ tr/</>/;
+ $rdelim =~ s/^(\S+)(\s*)$/$2$1/;
+ pop @seq_stack;
+ my $errmsg = "*** ERROR: unterminated ${cmd}${ldelim}...${rdelim}".
+ " at line $line in file $file\n";
+ (ref $errorsub) and &{$errorsub}($errmsg)
+ or (defined $errorsub) and $self->$errorsub($errmsg)
+ or carp($errmsg);
+ $seq_stack[-1]->append($expand_seq ? &$xseq_sub($self,$seq) : $seq);
+ $seq = $seq_stack[-1];
+ }
+
+ ## Return the resulting parse-tree
+ my $ptree = (pop @seq_stack)->parse_tree;
+ return $expand_ptree ? &$xptree_sub($self, $ptree) : $ptree;
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<interpolate()>
+
+ $textblock = $parser->interpolate($text, $line_num);
+
+This method translates all text (including any embedded interior sequences)
+in the given text string C<$text> and returns the interpolated result. The
+parameter C<$line_num> is the line number corresponding to the beginning
+of C<$text>.
+
+B<interpolate()> merely invokes a private method to recursively expand
+nested interior sequences in bottom-up order (innermost sequences are
+expanded first). If there is a need to expand nested sequences in
+some alternate order, use B<parse_text> instead.
+
+=cut
+
+sub interpolate {
+ my($self, $text, $line_num) = @_;
+ my %parse_opts = ( -expand_seq => 'interior_sequence' );
+ my $ptree = $self->parse_text( \%parse_opts, $text, $line_num );
+ return join '', $ptree->children();
+}
+
+##---------------------------------------------------------------------------
+
+=begin __PRIVATE__
+
+=head1 B<parse_paragraph()>
+
+ $parser->parse_paragraph($text, $line_num);
+
+This method takes the text of a POD paragraph to be processed, along
+with its corresponding line number, and invokes the appropriate method
+(one of B<command()>, B<verbatim()>, or B<textblock()>).
+
+For performance reasons, this method is invoked directly without any
+dynamic lookup; Hence subclasses may I<not> override it!
+
+=end __PRIVATE__
+
+=cut
+
+sub parse_paragraph {
+ my ($self, $text, $line_num) = @_;
+ local *myData = $self; ## alias to avoid deref-ing overhead
+ local *myOpts = ($myData{_PARSEOPTS} ||= {}); ## get parse-options
+ local $_;
+
+ ## See if we want to preprocess nonPOD paragraphs as well as POD ones.
+ my $wantNonPods = $myOpts{'-want_nonPODs'};
+
+ ## Update cutting status
+ $myData{_CUTTING} = 0 if $text =~ /^={1,2}\S/;
+
+ ## Perform any desired preprocessing if we wanted it this early
+ $wantNonPods and $text = $self->preprocess_paragraph($text, $line_num);
+
+ ## Ignore up until next POD directive if we are cutting
+ return if $myData{_CUTTING};
+
+ ## Now we know this is block of text in a POD section!
+
+ ##-----------------------------------------------------------------
+ ## This is a hook (hack ;-) for Pod::Select to do its thing without
+ ## having to override methods, but also without Pod::Parser assuming
+ ## $self is an instance of Pod::Select (if the _SELECTED_SECTIONS
+ ## field exists then we assume there is an is_selected() method for
+ ## us to invoke (calling $self->can('is_selected') could verify this
+ ## but that is more overhead than I want to incur)
+ ##-----------------------------------------------------------------
+
+ ## Ignore this block if it isnt in one of the selected sections
+ if (exists $myData{_SELECTED_SECTIONS}) {
+ $self->is_selected($text) or return ($myData{_CUTTING} = 1);
+ }
+
+ ## If we havent already, perform any desired preprocessing and
+ ## then re-check the "cutting" state
+ unless ($wantNonPods) {
+ $text = $self->preprocess_paragraph($text, $line_num);
+ return 1 unless ((defined $text) and (length $text));
+ return 1 if ($myData{_CUTTING});
+ }
+
+ ## Look for one of the three types of paragraphs
+ my ($pfx, $cmd, $arg, $sep) = ('', '', '', '');
+ my $pod_para = undef;
+ if ($text =~ /^(={1,2})(?=\S)/) {
+ ## Looks like a command paragraph. Capture the command prefix used
+ ## ("=" or "=="), as well as the command-name, its paragraph text,
+ ## and whatever sequence of characters was used to separate them
+ $pfx = $1;
+ $_ = substr($text, length $pfx);
+ ($cmd, $sep, $text) = split /(\s+)/, $_, 2;
+ ## If this is a "cut" directive then we dont need to do anything
+ ## except return to "cutting" mode.
+ if ($cmd eq 'cut') {
+ $myData{_CUTTING} = 1;
+ return unless $myOpts{'-process_cut_cmd'};
+ }
+ }
+ ## Save the attributes indicating how the command was specified.
+ $pod_para = new Pod::Paragraph(
+ -name => $cmd,
+ -text => $text,
+ -prefix => $pfx,
+ -separator => $sep,
+ -file => $myData{_INFILE},
+ -line => $line_num
+ );
+ # ## Invoke appropriate callbacks
+ # if (exists $myData{_CALLBACKS}) {
+ # ## Look through the callback list, invoke callbacks,
+ # ## then see if we need to do the default actions
+ # ## (invoke_callbacks will return true if we do).
+ # return 1 unless $self->invoke_callbacks($cmd, $text, $line_num, $pod_para);
+ # }
+
+ # If the last paragraph ended in whitespace, and we're not between verbatim blocks, carp
+ if ($myData{_WHITESPACE} and $myOpts{'-warnings'}
+ and not ($text =~ /^\s+/ and ($myData{_PREVIOUS}||"") eq "verbatim")) {
+ my $errorsub = $self->errorsub();
+ my $line = $line_num - 1;
+ my $errmsg = "*** WARNING: line containing nothing but whitespace".
+ " in paragraph at line $line in file $myData{_INFILE}\n";
+ (ref $errorsub) and &{$errorsub}($errmsg)
+ or (defined $errorsub) and $self->$errorsub($errmsg)
+ or carp($errmsg);
+ }
+
+ if (length $cmd) {
+ ## A command paragraph
+ $self->command($cmd, $text, $line_num, $pod_para);
+ $myData{_PREVIOUS} = $cmd;
+ }
+ elsif ($text =~ /^\s+/) {
+ ## Indented text - must be a verbatim paragraph
+ $self->verbatim($text, $line_num, $pod_para);
+ $myData{_PREVIOUS} = "verbatim";
+ }
+ else {
+ ## Looks like an ordinary block of text
+ $self->textblock($text, $line_num, $pod_para);
+ $myData{_PREVIOUS} = "textblock";
+ }
+
+ # Update the whitespace for the next time around
+ $myData{_WHITESPACE} = $text =~ /^[^\S\r\n]+\Z/m ? 1 : 0;
+
+ return 1;
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<parse_from_filehandle()>
+
+ $parser->parse_from_filehandle($in_fh,$out_fh);
+
+This method takes an input filehandle (which is assumed to already be
+opened for reading) and reads the entire input stream looking for blocks
+(paragraphs) of POD documentation to be processed. If no first argument
+is given the default input filehandle C<STDIN> is used.
+
+The C<$in_fh> parameter may be any object that provides a B<getline()>
+method to retrieve a single line of input text (hence, an appropriate
+wrapper object could be used to parse PODs from a single string or an
+array of strings).
+
+Using C<$in_fh-E<gt>getline()>, input is read line-by-line and assembled
+into paragraphs or "blocks" (which are separated by lines containing
+nothing but whitespace). For each block of POD documentation
+encountered it will invoke a method to parse the given paragraph.
+
+If a second argument is given then it should correspond to a filehandle where
+output should be sent (otherwise the default output filehandle is
+C<STDOUT> if no output filehandle is currently in use).
+
+B<NOTE:> For performance reasons, this method caches the input stream at
+the top of the stack in a local variable. Any attempts by clients to
+change the stack contents during processing when in the midst executing
+of this method I<will not affect> the input stream used by the current
+invocation of this method.
+
+This method does I<not> usually need to be overridden by subclasses.
+
+=cut
+
+sub parse_from_filehandle {
+ my $self = shift;
+ my %opts = (ref $_[0] eq 'HASH') ? %{ shift() } : ();
+ my ($in_fh, $out_fh) = @_;
+ $in_fh = \*STDIN unless ($in_fh);
+ local *myData = $self; ## alias to avoid deref-ing overhead
+ local *myOpts = ($myData{_PARSEOPTS} ||= {}); ## get parse-options
+ local $_;
+
+ ## Put this stream at the top of the stack and do beginning-of-input
+ ## processing. NOTE that $in_fh might be reset during this process.
+ my $topstream = $self->_push_input_stream($in_fh, $out_fh);
+ (exists $opts{-cutting}) and $self->cutting( $opts{-cutting} );
+
+ ## Initialize line/paragraph
+ my ($textline, $paragraph) = ('', '');
+ my ($nlines, $plines) = (0, 0);
+
+ ## Use <$fh> instead of $fh->getline where possible (for speed)
+ $_ = ref $in_fh;
+ my $tied_fh = (/^(?:GLOB|FileHandle|IO::\w+)$/ or tied $in_fh);
+
+ ## Read paragraphs line-by-line
+ while (defined ($textline = $tied_fh ? <$in_fh> : $in_fh->getline)) {
+ $textline = $self->preprocess_line($textline, ++$nlines);
+ next unless ((defined $textline) && (length $textline));
+
+ if ((! length $paragraph) && ($textline =~ /^==/)) {
+ ## '==' denotes a one-line command paragraph
+ $paragraph = $textline;
+ $plines = 1;
+ $textline = '';
+ } else {
+ ## Append this line to the current paragraph
+ $paragraph .= $textline;
+ ++$plines;
+ }
+
+ ## See if this line is blank and ends the current paragraph.
+ ## If it isnt, then keep iterating until it is.
+ next unless (($textline =~ /^([^\S\r\n]*)[\r\n]*$/)
+ && (length $paragraph));
+
+ ## Now process the paragraph
+ parse_paragraph($self, $paragraph, ($nlines - $plines) + 1);
+ $paragraph = '';
+ $plines = 0;
+ }
+ ## Dont forget about the last paragraph in the file
+ if (length $paragraph) {
+ parse_paragraph($self, $paragraph, ($nlines - $plines) + 1)
+ }
+
+ ## Now pop the input stream off the top of the input stack.
+ $self->_pop_input_stream();
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<parse_from_file()>
+
+ $parser->parse_from_file($filename,$outfile);
+
+This method takes a filename and does the following:
+
+=over 2
+
+=item *
+
+opens the input and output files for reading
+(creating the appropriate filehandles)
+
+=item *
+
+invokes the B<parse_from_filehandle()> method passing it the
+corresponding input and output filehandles.
+
+=item *
+
+closes the input and output files.
+
+=back
+
+If the special input filename "-" or "<&STDIN" is given then the STDIN
+filehandle is used for input (and no open or close is performed). If no
+input filename is specified then "-" is implied. Filehandle references,
+or objects that support the regular IO operations (like C<E<lt>$fhE<gt>>
+or C<$fh-<Egt>getline>) are also accepted; the handles must already be
+opened.
+
+If a second argument is given then it should be the name of the desired
+output file. If the special output filename "-" or ">&STDOUT" is given
+then the STDOUT filehandle is used for output (and no open or close is
+performed). If the special output filename ">&STDERR" is given then the
+STDERR filehandle is used for output (and no open or close is
+performed). If no output filehandle is currently in use and no output
+filename is specified, then "-" is implied.
+Alternatively, filehandle references or objects that support the regular
+IO operations (like C<print>, e.g. L<IO::String>) are also accepted;
+the object must already be opened.
+
+This method does I<not> usually need to be overridden by subclasses.
+
+=cut
+
+sub parse_from_file {
+ my $self = shift;
+ my %opts = (ref $_[0] eq 'HASH') ? %{ shift() } : ();
+ my ($infile, $outfile) = @_;
+ my ($in_fh, $out_fh);
+ if ($] < 5.006) {
+ ($in_fh, $out_fh) = (gensym(), gensym());
+ }
+ my ($close_input, $close_output) = (0, 0);
+ local *myData = $self;
+ local *_;
+
+ ## Is $infile a filename or a (possibly implied) filehandle
+ if (defined $infile && ref $infile) {
+ if (ref($infile) =~ /^(SCALAR|ARRAY|HASH|CODE|REF)$/) {
+ croak "Input from $1 reference not supported!\n";
+ }
+ ## Must be a filehandle-ref (or else assume its a ref to an object
+ ## that supports the common IO read operations).
+ $myData{_INFILE} = ${$infile};
+ $in_fh = $infile;
+ }
+ elsif (!defined($infile) || !length($infile) || ($infile eq '-')
+ || ($infile =~ /^<&(?:STDIN|0)$/i))
+ {
+ ## Not a filename, just a string implying STDIN
+ $infile ||= '-';
+ $myData{_INFILE} = '<standard input>';
+ $in_fh = \*STDIN;
+ }
+ else {
+ ## We have a filename, open it for reading
+ $myData{_INFILE} = $infile;
+ open($in_fh, "< $infile") or
+ croak "Can't open $infile for reading: $!\n";
+ $close_input = 1;
+ }
+
+ ## NOTE: we need to be *very* careful when "defaulting" the output
+ ## file. We only want to use a default if this is the beginning of
+ ## the entire document (but *not* if this is an included file). We
+ ## determine this by seeing if the input stream stack has been set-up
+ ## already
+
+ ## Is $outfile a filename, a (possibly implied) filehandle, maybe a ref?
+ if (ref $outfile) {
+ ## we need to check for ref() first, as other checks involve reading
+ if (ref($outfile) =~ /^(ARRAY|HASH|CODE)$/) {
+ croak "Output to $1 reference not supported!\n";
+ }
+ elsif (ref($outfile) eq 'SCALAR') {
+# # NOTE: IO::String isn't a part of the perl distribution,
+# # so probably we shouldn't support this case...
+# require IO::String;
+# $myData{_OUTFILE} = "$outfile";
+# $out_fh = IO::String->new($outfile);
+ croak "Output to SCALAR reference not supported!\n";
+ }
+ else {
+ ## Must be a filehandle-ref (or else assume its a ref to an
+ ## object that supports the common IO write operations).
+ $myData{_OUTFILE} = ${$outfile};
+ $out_fh = $outfile;
+ }
+ }
+ elsif (!defined($outfile) || !length($outfile) || ($outfile eq '-')
+ || ($outfile =~ /^>&?(?:STDOUT|1)$/i))
+ {
+ if (defined $myData{_TOP_STREAM}) {
+ $out_fh = $myData{_OUTPUT};
+ }
+ else {
+ ## Not a filename, just a string implying STDOUT
+ $outfile ||= '-';
+ $myData{_OUTFILE} = '<standard output>';
+ $out_fh = \*STDOUT;
+ }
+ }
+ elsif ($outfile =~ /^>&(STDERR|2)$/i) {
+ ## Not a filename, just a string implying STDERR
+ $myData{_OUTFILE} = '<standard error>';
+ $out_fh = \*STDERR;
+ }
+ else {
+ ## We have a filename, open it for writing
+ $myData{_OUTFILE} = $outfile;
+ (-d $outfile) and croak "$outfile is a directory, not POD input!\n";
+ open($out_fh, "> $outfile") or
+ croak "Can't open $outfile for writing: $!\n";
+ $close_output = 1;
+ }
+
+ ## Whew! That was a lot of work to set up reasonably/robust behavior
+ ## in the case of a non-filename for reading and writing. Now we just
+ ## have to parse the input and close the handles when we're finished.
+ $self->parse_from_filehandle(\%opts, $in_fh, $out_fh);
+
+ $close_input and
+ close($in_fh) || croak "Can't close $infile after reading: $!\n";
+ $close_output and
+ close($out_fh) || croak "Can't close $outfile after writing: $!\n";
+}
+
+#############################################################################
+
+=head1 ACCESSOR METHODS
+
+Clients of B<Pod::Parser> should use the following methods to access
+instance data fields:
+
+=cut
+
+##---------------------------------------------------------------------------
+
+=head1 B<errorsub()>
+
+ $parser->errorsub("method_name");
+ $parser->errorsub(\&warn_user);
+ $parser->errorsub(sub { print STDERR, @_ });
+
+Specifies the method or subroutine to use when printing error messages
+about POD syntax. The supplied method/subroutine I<must> return TRUE upon
+successful printing of the message. If C<undef> is given, then the B<carp>
+builtin is used to issue error messages (this is the default behavior).
+
+ my $errorsub = $parser->errorsub()
+ my $errmsg = "This is an error message!\n"
+ (ref $errorsub) and &{$errorsub}($errmsg)
+ or (defined $errorsub) and $parser->$errorsub($errmsg)
+ or carp($errmsg);
+
+Returns a method name, or else a reference to the user-supplied subroutine
+used to print error messages. Returns C<undef> if the B<carp> builtin
+is used to issue error messages (this is the default behavior).
+
+=cut
+
+sub errorsub {
+ return (@_ > 1) ? ($_[0]->{_ERRORSUB} = $_[1]) : $_[0]->{_ERRORSUB};
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<cutting()>
+
+ $boolean = $parser->cutting();
+
+Returns the current C<cutting> state: a boolean-valued scalar which
+evaluates to true if text from the input file is currently being "cut"
+(meaning it is I<not> considered part of the POD document).
+
+ $parser->cutting($boolean);
+
+Sets the current C<cutting> state to the given value and returns the
+result.
+
+=cut
+
+sub cutting {
+ return (@_ > 1) ? ($_[0]->{_CUTTING} = $_[1]) : $_[0]->{_CUTTING};
+}
+
+##---------------------------------------------------------------------------
+
+##---------------------------------------------------------------------------
+
+=head1 B<parseopts()>
+
+When invoked with no additional arguments, B<parseopts> returns a hashtable
+of all the current parsing options.
+
+ ## See if we are parsing non-POD sections as well as POD ones
+ my %opts = $parser->parseopts();
+ $opts{'-want_nonPODs}' and print "-want_nonPODs\n";
+
+When invoked using a single string, B<parseopts> treats the string as the
+name of a parse-option and returns its corresponding value if it exists
+(returns C<undef> if it doesn't).
+
+ ## Did we ask to see '=cut' paragraphs?
+ my $want_cut = $parser->parseopts('-process_cut_cmd');
+ $want_cut and print "-process_cut_cmd\n";
+
+When invoked with multiple arguments, B<parseopts> treats them as
+key/value pairs and the specified parse-option names are set to the
+given values. Any unspecified parse-options are unaffected.
+
+ ## Set them back to the default
+ $parser->parseopts(-warnings => 0);
+
+When passed a single hash-ref, B<parseopts> uses that hash to completely
+reset the existing parse-options, all previous parse-option values
+are lost.
+
+ ## Reset all options to default
+ $parser->parseopts( { } );
+
+See L<"PARSING OPTIONS"> for more information on the name and meaning of each
+parse-option currently recognized.
+
+=cut
+
+sub parseopts {
+ local *myData = shift;
+ local *myOpts = ($myData{_PARSEOPTS} ||= {});
+ return %myOpts if (@_ == 0);
+ if (@_ == 1) {
+ local $_ = shift;
+ return ref($_) ? $myData{_PARSEOPTS} = $_ : $myOpts{$_};
+ }
+ my @newOpts = (%myOpts, @_);
+ $myData{_PARSEOPTS} = { @newOpts };
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<output_file()>
+
+ $fname = $parser->output_file();
+
+Returns the name of the output file being written.
+
+=cut
+
+sub output_file {
+ return $_[0]->{_OUTFILE};
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<output_handle()>
+
+ $fhandle = $parser->output_handle();
+
+Returns the output filehandle object.
+
+=cut
+
+sub output_handle {
+ return $_[0]->{_OUTPUT};
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<input_file()>
+
+ $fname = $parser->input_file();
+
+Returns the name of the input file being read.
+
+=cut
+
+sub input_file {
+ return $_[0]->{_INFILE};
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<input_handle()>
+
+ $fhandle = $parser->input_handle();
+
+Returns the current input filehandle object.
+
+=cut
+
+sub input_handle {
+ return $_[0]->{_INPUT};
+}
+
+##---------------------------------------------------------------------------
+
+=begin __PRIVATE__
+
+=head1 B<input_streams()>
+
+ $listref = $parser->input_streams();
+
+Returns a reference to an array which corresponds to the stack of all
+the input streams that are currently in the middle of being parsed.
+
+While parsing an input stream, it is possible to invoke
+B<parse_from_file()> or B<parse_from_filehandle()> to parse a new input
+stream and then return to parsing the previous input stream. Each input
+stream to be parsed is pushed onto the end of this input stack
+before any of its input is read. The input stream that is currently
+being parsed is always at the end (or top) of the input stack. When an
+input stream has been exhausted, it is popped off the end of the
+input stack.
+
+Each element on this input stack is a reference to C<Pod::InputSource>
+object. Please see L<Pod::InputObjects> for more details.
+
+This method might be invoked when printing diagnostic messages, for example,
+to obtain the name and line number of the all input files that are currently
+being processed.
+
+=end __PRIVATE__
+
+=cut
+
+sub input_streams {
+ return $_[0]->{_INPUT_STREAMS};
+}
+
+##---------------------------------------------------------------------------
+
+=begin __PRIVATE__
+
+=head1 B<top_stream()>
+
+ $hashref = $parser->top_stream();
+
+Returns a reference to the hash-table that represents the element
+that is currently at the top (end) of the input stream stack
+(see L<"input_streams()">). The return value will be the C<undef>
+if the input stack is empty.
+
+This method might be used when printing diagnostic messages, for example,
+to obtain the name and line number of the current input file.
+
+=end __PRIVATE__
+
+=cut
+
+sub top_stream {
+ return $_[0]->{_TOP_STREAM} || undef;
+}
+
+#############################################################################
+
+=head1 PRIVATE METHODS AND DATA
+
+B<Pod::Parser> makes use of several internal methods and data fields
+which clients should not need to see or use. For the sake of avoiding
+name collisions for client data and methods, these methods and fields
+are briefly discussed here. Determined hackers may obtain further
+information about them by reading the B<Pod::Parser> source code.
+
+Private data fields are stored in the hash-object whose reference is
+returned by the B<new()> constructor for this class. The names of all
+private methods and data-fields used by B<Pod::Parser> begin with a
+prefix of "_" and match the regular expression C</^_\w+$/>.
+
+=cut
+
+##---------------------------------------------------------------------------
+
+=begin _PRIVATE_
+
+=head1 B<_push_input_stream()>
+
+ $hashref = $parser->_push_input_stream($in_fh,$out_fh);
+
+This method will push the given input stream on the input stack and
+perform any necessary beginning-of-document or beginning-of-file
+processing. The argument C<$in_fh> is the input stream filehandle to
+push, and C<$out_fh> is the corresponding output filehandle to use (if
+it is not given or is undefined, then the current output stream is used,
+which defaults to standard output if it doesnt exist yet).
+
+The value returned will be reference to the hash-table that represents
+the new top of the input stream stack. I<Please Note> that it is
+possible for this method to use default values for the input and output
+file handles. If this happens, you will need to look at the C<INPUT>
+and C<OUTPUT> instance data members to determine their new values.
+
+=end _PRIVATE_
+
+=cut
+
+sub _push_input_stream {
+ my ($self, $in_fh, $out_fh) = @_;
+ local *myData = $self;
+
+ ## Initialize stuff for the entire document if this is *not*
+ ## an included file.
+ ##
+ ## NOTE: we need to be *very* careful when "defaulting" the output
+ ## filehandle. We only want to use a default value if this is the
+ ## beginning of the entire document (but *not* if this is an included
+ ## file).
+ unless (defined $myData{_TOP_STREAM}) {
+ $out_fh = \*STDOUT unless (defined $out_fh);
+ $myData{_CUTTING} = 1; ## current "cutting" state
+ $myData{_INPUT_STREAMS} = []; ## stack of all input streams
+ }
+
+ ## Initialize input indicators
+ $myData{_OUTFILE} = '(unknown)' unless (defined $myData{_OUTFILE});
+ $myData{_OUTPUT} = $out_fh if (defined $out_fh);
+ $in_fh = \*STDIN unless (defined $in_fh);
+ $myData{_INFILE} = '(unknown)' unless (defined $myData{_INFILE});
+ $myData{_INPUT} = $in_fh;
+ my $input_top = $myData{_TOP_STREAM}
+ = new Pod::InputSource(
+ -name => $myData{_INFILE},
+ -handle => $in_fh,
+ -was_cutting => $myData{_CUTTING}
+ );
+ local *input_stack = $myData{_INPUT_STREAMS};
+ push(@input_stack, $input_top);
+
+ ## Perform beginning-of-document and/or beginning-of-input processing
+ $self->begin_pod() if (@input_stack == 1);
+ $self->begin_input();
+
+ return $input_top;
+}
+
+##---------------------------------------------------------------------------
+
+=begin _PRIVATE_
+
+=head1 B<_pop_input_stream()>
+
+ $hashref = $parser->_pop_input_stream();
+
+This takes no arguments. It will perform any necessary end-of-file or
+end-of-document processing and then pop the current input stream from
+the top of the input stack.
+
+The value returned will be reference to the hash-table that represents
+the new top of the input stream stack.
+
+=end _PRIVATE_
+
+=cut
+
+sub _pop_input_stream {
+ my ($self) = @_;
+ local *myData = $self;
+ local *input_stack = $myData{_INPUT_STREAMS};
+
+ ## Perform end-of-input and/or end-of-document processing
+ $self->end_input() if (@input_stack > 0);
+ $self->end_pod() if (@input_stack == 1);
+
+ ## Restore cutting state to whatever it was before we started
+ ## parsing this file.
+ my $old_top = pop(@input_stack);
+ $myData{_CUTTING} = $old_top->was_cutting();
+
+ ## Dont forget to reset the input indicators
+ my $input_top = undef;
+ if (@input_stack > 0) {
+ $input_top = $myData{_TOP_STREAM} = $input_stack[-1];
+ $myData{_INFILE} = $input_top->name();
+ $myData{_INPUT} = $input_top->handle();
+ } else {
+ delete $myData{_TOP_STREAM};
+ delete $myData{_INPUT_STREAMS};
+ }
+
+ return $input_top;
+}
+
+#############################################################################
+
+=head1 TREE-BASED PARSING
+
+If straightforward stream-based parsing wont meet your needs (as is
+likely the case for tasks such as translating PODs into structured
+markup languages like HTML and XML) then you may need to take the
+tree-based approach. Rather than doing everything in one pass and
+calling the B<interpolate()> method to expand sequences into text, it
+may be desirable to instead create a parse-tree using the B<parse_text()>
+method to return a tree-like structure which may contain an ordered
+list of children (each of which may be a text-string, or a similar
+tree-like structure).
+
+Pay special attention to L<"METHODS FOR PARSING AND PROCESSING"> and
+to the objects described in L<Pod::InputObjects>. The former describes
+the gory details and parameters for how to customize and extend the
+parsing behavior of B<Pod::Parser>. B<Pod::InputObjects> provides
+several objects that may all be used interchangeably as parse-trees. The
+most obvious one is the B<Pod::ParseTree> object. It defines the basic
+interface and functionality that all things trying to be a POD parse-tree
+should do. A B<Pod::ParseTree> is defined such that each "node" may be a
+text-string, or a reference to another parse-tree. Each B<Pod::Paragraph>
+object and each B<Pod::InteriorSequence> object also supports the basic
+parse-tree interface.
+
+The B<parse_text()> method takes a given paragraph of text, and
+returns a parse-tree that contains one or more children, each of which
+may be a text-string, or an InteriorSequence object. There are also
+callback-options that may be passed to B<parse_text()> to customize
+the way it expands or transforms interior-sequences, as well as the
+returned result. These callbacks can be used to create a parse-tree
+with custom-made objects (which may or may not support the parse-tree
+interface, depending on how you choose to do it).
+
+If you wish to turn an entire POD document into a parse-tree, that process
+is fairly straightforward. The B<parse_text()> method is the key to doing
+this successfully. Every paragraph-callback (i.e. the polymorphic methods
+for B<command()>, B<verbatim()>, and B<textblock()> paragraphs) takes
+a B<Pod::Paragraph> object as an argument. Each paragraph object has a
+B<parse_tree()> method that can be used to get or set a corresponding
+parse-tree. So for each of those paragraph-callback methods, simply call
+B<parse_text()> with the options you desire, and then use the returned
+parse-tree to assign to the given paragraph object.
+
+That gives you a parse-tree for each paragraph - so now all you need is
+an ordered list of paragraphs. You can maintain that yourself as a data
+element in the object/hash. The most straightforward way would be simply
+to use an array-ref, with the desired set of custom "options" for each
+invocation of B<parse_text>. Let's assume the desired option-set is
+given by the hash C<%options>. Then we might do something like the
+following:
+
+ package MyPodParserTree;
+
+ @ISA = qw( Pod::Parser );
+
+ ...
+
+ sub begin_pod {
+ my $self = shift;
+ $self->{'-paragraphs'} = []; ## initialize paragraph list
+ }
+
+ sub command {
+ my ($parser, $command, $paragraph, $line_num, $pod_para) = @_;
+ my $ptree = $parser->parse_text({%options}, $paragraph, ...);
+ $pod_para->parse_tree( $ptree );
+ push @{ $self->{'-paragraphs'} }, $pod_para;
+ }
+
+ sub verbatim {
+ my ($parser, $paragraph, $line_num, $pod_para) = @_;
+ push @{ $self->{'-paragraphs'} }, $pod_para;
+ }
+
+ sub textblock {
+ my ($parser, $paragraph, $line_num, $pod_para) = @_;
+ my $ptree = $parser->parse_text({%options}, $paragraph, ...);
+ $pod_para->parse_tree( $ptree );
+ push @{ $self->{'-paragraphs'} }, $pod_para;
+ }
+
+ ...
+
+ package main;
+ ...
+ my $parser = new MyPodParserTree(...);
+ $parser->parse_from_file(...);
+ my $paragraphs_ref = $parser->{'-paragraphs'};
+
+Of course, in this module-author's humble opinion, I'd be more inclined to
+use the existing B<Pod::ParseTree> object than a simple array. That way
+everything in it, paragraphs and sequences, all respond to the same core
+interface for all parse-tree nodes. The result would look something like:
+
+ package MyPodParserTree2;
+
+ ...
+
+ sub begin_pod {
+ my $self = shift;
+ $self->{'-ptree'} = new Pod::ParseTree; ## initialize parse-tree
+ }
+
+ sub parse_tree {
+ ## convenience method to get/set the parse-tree for the entire POD
+ (@_ > 1) and $_[0]->{'-ptree'} = $_[1];
+ return $_[0]->{'-ptree'};
+ }
+
+ sub command {
+ my ($parser, $command, $paragraph, $line_num, $pod_para) = @_;
+ my $ptree = $parser->parse_text({<<options>>}, $paragraph, ...);
+ $pod_para->parse_tree( $ptree );
+ $parser->parse_tree()->append( $pod_para );
+ }
+
+ sub verbatim {
+ my ($parser, $paragraph, $line_num, $pod_para) = @_;
+ $parser->parse_tree()->append( $pod_para );
+ }
+
+ sub textblock {
+ my ($parser, $paragraph, $line_num, $pod_para) = @_;
+ my $ptree = $parser->parse_text({<<options>>}, $paragraph, ...);
+ $pod_para->parse_tree( $ptree );
+ $parser->parse_tree()->append( $pod_para );
+ }
+
+ ...
+
+ package main;
+ ...
+ my $parser = new MyPodParserTree2(...);
+ $parser->parse_from_file(...);
+ my $ptree = $parser->parse_tree;
+ ...
+
+Now you have the entire POD document as one great big parse-tree. You
+can even use the B<-expand_seq> option to B<parse_text> to insert
+whole different kinds of objects. Just don't expect B<Pod::Parser>
+to know what to do with them after that. That will need to be in your
+code. Or, alternatively, you can insert any object you like so long as
+it conforms to the B<Pod::ParseTree> interface.
+
+One could use this to create subclasses of B<Pod::Paragraphs> and
+B<Pod::InteriorSequences> for specific commands (or to create your own
+custom node-types in the parse-tree) and add some kind of B<emit()>
+method to each custom node/subclass object in the tree. Then all you'd
+need to do is recursively walk the tree in the desired order, processing
+the children (most likely from left to right) by formatting them if
+they are text-strings, or by calling their B<emit()> method if they
+are objects/references.
+
+=head1 CAVEATS
+
+Please note that POD has the notion of "paragraphs": this is something
+starting I<after> a blank (read: empty) line, with the single exception
+of the file start, which is also starting a paragraph. That means that
+especially a command (e.g. C<=head1>) I<must> be preceded with a blank
+line; C<__END__> is I<not> a blank line.
+
+=head1 SEE ALSO
+
+L<Pod::InputObjects>, L<Pod::Select>
+
+B<Pod::InputObjects> defines POD input objects corresponding to
+command paragraphs, parse-trees, and interior-sequences.
+
+B<Pod::Select> is a subclass of B<Pod::Parser> which provides the ability
+to selectively include and/or exclude sections of a POD document from being
+translated based upon the current heading, subheading, subsubheading, etc.
+
+=for __PRIVATE__
+B<Pod::Callbacks> is a subclass of B<Pod::Parser> which gives its users
+the ability the employ I<callback functions> instead of, or in addition
+to, overriding methods of the base class.
+
+=for __PRIVATE__
+B<Pod::Select> and B<Pod::Callbacks> do not override any
+methods nor do they define any new methods with the same name. Because
+of this, they may I<both> be used (in combination) as a base class of
+the same subclass in order to combine their functionality without
+causing any namespace clashes due to multiple inheritance.
+
+=head1 AUTHOR
+
+Please report bugs using L<http://rt.cpan.org>.
+
+Brad Appleton E<lt>bradapp at enteract.comE<gt>
+
+Based on code for B<Pod::Text> written by
+Tom Christiansen E<lt>tchrist at mox.perl.comE<gt>
+
+=head1 LICENSE
+
+Pod-Parser is free software; you can redistribute it and/or modify it
+under the terms of the Artistic License distributed with Perl version
+5.000 or (at your option) any later version. Please refer to the
+Artistic License that came with your Perl distribution for more
+details. If your version of Perl was not distributed under the
+terms of the Artistic License, than you may distribute PodParser
+under the same terms as Perl itself.
+
+=cut
+
+1;
+# vim: ts=4 sw=4 et
Copied: trunk/contrib/perl/lib/Pod/Perldoc.pm (from rev 6437, vendor/perl/5.18.1/lib/Pod/Perldoc.pm)
===================================================================
--- trunk/contrib/perl/lib/Pod/Perldoc.pm (rev 0)
+++ trunk/contrib/perl/lib/Pod/Perldoc.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,1828 @@
+
+require 5;
+use 5.006; # we use some open(X, "<", $y) syntax
+package Pod::Perldoc;
+use strict;
+use warnings;
+use Config '%Config';
+
+use Fcntl; # for sysopen
+use File::Spec::Functions qw(catfile catdir splitdir);
+
+use vars qw($VERSION @Pagers $Bindir $Pod2man
+ $Temp_Files_Created $Temp_File_Lifetime
+);
+$VERSION = '3.14_04';
+#..........................................................................
+
+BEGIN { # Make a DEBUG constant very first thing...
+ unless(defined &DEBUG) {
+ if(($ENV{'PERLDOCDEBUG'} || '') =~ m/^(\d+)/) { # untaint
+ eval("sub DEBUG () {$1}");
+ die "WHAT? Couldn't eval-up a DEBUG constant!? $@" if $@;
+ } else {
+ *DEBUG = sub () {0};
+ }
+ }
+}
+
+use Pod::Perldoc::GetOptsOO; # uses the DEBUG.
+
+#..........................................................................
+
+sub TRUE () {1}
+sub FALSE () {return}
+
+BEGIN {
+ *IS_VMS = $^O eq 'VMS' ? \&TRUE : \&FALSE unless defined &IS_VMS;
+ *IS_MSWin32 = $^O eq 'MSWin32' ? \&TRUE : \&FALSE unless defined &IS_MSWin32;
+ *IS_Dos = $^O eq 'dos' ? \&TRUE : \&FALSE unless defined &IS_Dos;
+ *IS_OS2 = $^O eq 'os2' ? \&TRUE : \&FALSE unless defined &IS_OS2;
+ *IS_Cygwin = $^O eq 'cygwin' ? \&TRUE : \&FALSE unless defined &IS_Cygwin;
+ *IS_Linux = $^O eq 'linux' ? \&TRUE : \&FALSE unless defined &IS_Linux;
+ *IS_HPUX = $^O =~ m/hpux/ ? \&TRUE : \&FALSE unless defined &IS_HPUX;
+}
+
+$Temp_File_Lifetime ||= 60 * 60 * 24 * 5;
+ # If it's older than five days, it's quite unlikely
+ # that anyone's still looking at it!!
+ # (Currently used only by the MSWin cleanup routine)
+
+
+#..........................................................................
+{ my $pager = $Config{'pager'};
+ push @Pagers, $pager if -x (split /\s+/, $pager)[0] or IS_VMS;
+}
+$Bindir = $Config{'scriptdirexp'};
+$Pod2man = "pod2man" . ( $Config{'versiononly'} ? $Config{'version'} : '' );
+
+# End of class-init stuff
+#
+###########################################################################
+#
+# Option accessors...
+
+foreach my $subname (map "opt_$_", split '', q{mhlvriFfXqnTdUL}) {
+ no strict 'refs';
+ *$subname = do{ use strict 'refs'; sub () { shift->_elem($subname, @_) } };
+}
+
+# And these are so that GetOptsOO knows they take options:
+sub opt_f_with { shift->_elem('opt_f', @_) }
+sub opt_q_with { shift->_elem('opt_q', @_) }
+sub opt_d_with { shift->_elem('opt_d', @_) }
+sub opt_L_with { shift->_elem('opt_L', @_) }
+
+sub opt_w_with { # Specify an option for the formatter subclass
+ my($self, $value) = @_;
+ if($value =~ m/^([-_a-zA-Z][-_a-zA-Z0-9]*)(?:[=\:](.*?))?$/s) {
+ my $option = $1;
+ my $option_value = defined($2) ? $2 : "TRUE";
+ $option =~ tr/\-/_/s; # tolerate "foo-bar" for "foo_bar"
+ $self->add_formatter_option( $option, $option_value );
+ } else {
+ warn "\"$value\" isn't a good formatter option name. I'm ignoring it!\n";
+ }
+ return;
+}
+
+sub opt_M_with { # specify formatter class name(s)
+ my($self, $classes) = @_;
+ return unless defined $classes and length $classes;
+ DEBUG > 4 and print "Considering new formatter classes -M$classes\n";
+ my @classes_to_add;
+ foreach my $classname (split m/[,;]+/s, $classes) {
+ next unless $classname =~ m/\S/;
+ if( $classname =~ m/^(\w+(::\w+)+)$/s ) {
+ # A mildly restrictive concept of what modulenames are valid.
+ push @classes_to_add, $1; # untaint
+ } else {
+ warn "\"$classname\" isn't a valid classname. Ignoring.\n";
+ }
+ }
+
+ unshift @{ $self->{'formatter_classes'} }, @classes_to_add;
+
+ DEBUG > 3 and print(
+ "Adding @classes_to_add to the list of formatter classes, "
+ . "making them @{ $self->{'formatter_classes'} }.\n"
+ );
+
+ return;
+}
+
+sub opt_V { # report version and exit
+ print join '',
+ "Perldoc v$VERSION, under perl v$] for $^O",
+
+ (defined(&Win32::BuildNumber) and defined &Win32::BuildNumber())
+ ? (" (win32 build ", &Win32::BuildNumber(), ")") : (),
+
+ (chr(65) eq 'A') ? () : " (non-ASCII)",
+
+ "\n",
+ ;
+ exit;
+}
+
+sub opt_t { # choose plaintext as output format
+ my $self = shift;
+ $self->opt_o_with('text') if @_ and $_[0];
+ return $self->_elem('opt_t', @_);
+}
+
+sub opt_u { # choose raw pod as output format
+ my $self = shift;
+ $self->opt_o_with('pod') if @_ and $_[0];
+ return $self->_elem('opt_u', @_);
+}
+
+sub opt_n_with {
+ # choose man as the output format, and specify the proggy to run
+ my $self = shift;
+ $self->opt_o_with('man') if @_ and $_[0];
+ $self->_elem('opt_n', @_);
+}
+
+sub opt_o_with { # "o" for output format
+ my($self, $rest) = @_;
+ return unless defined $rest and length $rest;
+ if($rest =~ m/^(\w+)$/s) {
+ $rest = $1; #untaint
+ } else {
+ warn "\"$rest\" isn't a valid output format. Skipping.\n";
+ return;
+ }
+
+ $self->aside("Noting \"$rest\" as desired output format...\n");
+
+ # Figure out what class(es) that could actually mean...
+
+ my @classes;
+ foreach my $prefix ("Pod::Perldoc::To", "Pod::Simple::", "Pod::") {
+ # Messy but smart:
+ foreach my $stem (
+ $rest, # Yes, try it first with the given capitalization
+ "\L$rest", "\L\u$rest", "\U$rest" # And then try variations
+
+ ) {
+ push @classes, $prefix . $stem;
+ #print "Considering $prefix$stem\n";
+ }
+
+ # Tidier, but misses too much:
+ #push @classes, $prefix . ucfirst(lc($rest));
+ }
+ $self->opt_M_with( join ";", @classes );
+ return;
+}
+
+###########################################################################
+# % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
+
+sub run { # to be called by the "perldoc" executable
+ my $class = shift;
+ if(DEBUG > 3) {
+ print "Parameters to $class\->run:\n";
+ my @x = @_;
+ while(@x) {
+ $x[1] = '<undef>' unless defined $x[1];
+ $x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY';
+ print " [$x[0]] => [$x[1]]\n";
+ splice @x,0,2;
+ }
+ print "\n";
+ }
+ return $class -> new(@_) -> process() || 0;
+}
+
+# % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
+###########################################################################
+
+sub new { # yeah, nothing fancy
+ my $class = shift;
+ my $new = bless {@_}, (ref($class) || $class);
+ DEBUG > 1 and print "New $class object $new\n";
+ $new->init();
+ $new;
+}
+
+#..........................................................................
+
+sub aside { # If we're in -v or DEBUG mode, say this.
+ my $self = shift;
+ if( DEBUG or $self->opt_v ) {
+ my $out = join( '',
+ DEBUG ? do {
+ my $callsub = (caller(1))[3];
+ my $package = quotemeta(__PACKAGE__ . '::');
+ $callsub =~ s/^$package/'/os;
+ # the o is justified, as $package really won't change.
+ $callsub . ": ";
+ } : '',
+ @_,
+ );
+ if(DEBUG) { print $out } else { print STDERR $out }
+ }
+ return;
+}
+
+#..........................................................................
+
+sub usage {
+ my $self = shift;
+ warn "@_\n" if @_;
+
+ # Erase evidence of previous errors (if any), so exit status is simple.
+ $! = 0;
+
+ die <<EOF;
+perldoc [options] PageName|ModuleName|ProgramName...
+perldoc [options] -f BuiltinFunction
+perldoc [options] -q FAQRegex
+
+Options:
+ -h Display this help message
+ -V report version
+ -r Recursive search (slow)
+ -i Ignore case
+ -t Display pod using pod2text instead of pod2man and nroff
+ (-t is the default on win32 unless -n is specified)
+ -u Display unformatted pod text
+ -m Display module's file in its entirety
+ -n Specify replacement for nroff
+ -l Display the module's file name
+ -F Arguments are file names, not modules
+ -v Verbosely describe what's going on
+ -T Send output to STDOUT without any pager
+ -d output_filename_to_send_to
+ -o output_format_name
+ -M FormatterModuleNameToUse
+ -w formatter_option:option_value
+ -L translation_code Choose doc translation (if any)
+ -X use index if present (looks for pod.idx at $Config{archlib})
+ -q Search the text of questions (not answers) in perlfaq[1-9]
+
+PageName|ModuleName...
+ is the name of a piece of documentation that you want to look at. You
+ may either give a descriptive name of the page (as in the case of
+ `perlfunc') the name of a module, either like `Term::Info' or like
+ `Term/Info', or the name of a program, like `perldoc'.
+
+BuiltinFunction
+ is the name of a perl function. Will extract documentation from
+ `perlfunc'.
+
+FAQRegex
+ is a regex. Will search perlfaq[1-9] for and extract any
+ questions that match.
+
+Any switches in the PERLDOC environment variable will be used before the
+command line arguments. The optional pod index file contains a list of
+filenames, one per line.
+ [Perldoc v$VERSION]
+EOF
+
+}
+
+#..........................................................................
+
+sub usage_brief {
+ my $me = $0; # Editing $0 is unportable
+
+ $me =~ s,.*[/\\],,; # get basename
+
+ die <<"EOUSAGE";
+Usage: $me [-h] [-V] [-r] [-i] [-v] [-t] [-u] [-m] [-n nroffer_program] [-l] [-T] [-d output_filename] [-o output_format] [-M FormatterModuleNameToUse] [-w formatter_option:option_value] [-L translation_code] [-F] [-X] PageName|ModuleName|ProgramName
+ $me -f PerlFunc
+ $me -q FAQKeywords
+
+The -h option prints more help. Also try "perldoc perldoc" to get
+acquainted with the system. [Perldoc v$VERSION]
+EOUSAGE
+
+}
+
+#..........................................................................
+
+sub pagers { @{ shift->{'pagers'} } }
+
+#..........................................................................
+
+sub _elem { # handy scalar meta-accessor: shift->_elem("foo", @_)
+ if(@_ > 2) { return $_[0]{ $_[1] } = $_[2] }
+ else { return $_[0]{ $_[1] } }
+}
+#..........................................................................
+###########################################################################
+#
+# Init formatter switches, and start it off with __bindir and all that
+# other stuff that ToMan.pm needs.
+#
+
+sub init {
+ my $self = shift;
+
+ # Make sure creat()s are neither too much nor too little
+ eval { umask(0077) }; # doubtless someone has no mask
+
+ $self->{'args'} ||= \@ARGV;
+ $self->{'found'} ||= [];
+ $self->{'temp_file_list'} ||= [];
+
+
+ $self->{'target'} = undef;
+
+ $self->init_formatter_class_list;
+
+ $self->{'pagers' } = [@Pagers] unless exists $self->{'pagers'};
+ $self->{'bindir' } = $Bindir unless exists $self->{'bindir'};
+ $self->{'pod2man'} = $Pod2man unless exists $self->{'pod2man'};
+
+ push @{ $self->{'formatter_switches'} = [] }, (
+ # Yeah, we could use a hashref, but maybe there's some class where options
+ # have to be ordered; so we'll use an arrayref.
+
+ [ '__bindir' => $self->{'bindir' } ],
+ [ '__pod2man' => $self->{'pod2man'} ],
+ );
+
+ DEBUG > 3 and printf "Formatter switches now: [%s]\n",
+ join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
+
+ $self->{'translators'} = [];
+ $self->{'extra_search_dirs'} = [];
+
+ return;
+}
+
+#..........................................................................
+
+sub init_formatter_class_list {
+ my $self = shift;
+ $self->{'formatter_classes'} ||= [];
+
+ # Remember, no switches have been read yet, when
+ # we've started this routine.
+
+ $self->opt_M_with('Pod::Perldoc::ToPod'); # the always-there fallthru
+ $self->opt_o_with('text');
+ $self->opt_o_with('man') unless IS_MSWin32 || IS_Dos
+ || !($ENV{TERM} && (
+ ($ENV{TERM} || '') !~ /dumb|emacs|none|unknown/i
+ ));
+
+ return;
+}
+
+#..........................................................................
+
+sub process {
+ # if this ever returns, its retval will be used for exit(RETVAL)
+
+ my $self = shift;
+ DEBUG > 1 and print " Beginning process.\n";
+ DEBUG > 1 and print " Args: @{$self->{'args'}}\n\n";
+ if(DEBUG > 3) {
+ print "Object contents:\n";
+ my @x = %$self;
+ while(@x) {
+ $x[1] = '<undef>' unless defined $x[1];
+ $x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY';
+ print " [$x[0]] => [$x[1]]\n";
+ splice @x,0,2;
+ }
+ print "\n";
+ }
+
+ # TODO: make it deal with being invoked as various different things
+ # such as perlfaq".
+
+ return $self->usage_brief unless @{ $self->{'args'} };
+ $self->pagers_guessing;
+ $self->options_reading;
+ $self->aside(sprintf "$0 => %s v%s\n", ref($self), $self->VERSION);
+ $self->drop_privs_maybe;
+ $self->options_processing;
+
+ # Hm, we have @pages and @found, but we only really act on one
+ # file per call, with the exception of the opt_q hack, and with
+ # -l things
+
+ $self->aside("\n");
+
+ my @pages;
+ $self->{'pages'} = \@pages;
+ if( $self->opt_f) { @pages = ("perlfunc") }
+ elsif( $self->opt_q) { @pages = ("perlfaq1" .. "perlfaq9") }
+ else { @pages = @{$self->{'args'}};
+ # @pages = __FILE__
+ # if @pages == 1 and $pages[0] eq 'perldoc';
+ }
+
+ return $self->usage_brief unless @pages;
+
+ $self->find_good_formatter_class();
+ $self->formatter_sanity_check();
+
+ $self->maybe_diddle_INC();
+ # for when we're apparently in a module or extension directory
+
+ my @found = $self->grand_search_init(\@pages);
+ exit (IS_VMS ? 98962 : 1) unless @found;
+
+ if ($self->opt_l) {
+ DEBUG and print "We're in -l mode, so byebye after this:\n";
+ print join("\n", @found), "\n";
+ return;
+ }
+
+ $self->tweak_found_pathnames(\@found);
+ $self->assert_closing_stdout;
+ return $self->page_module_file(@found) if $self->opt_m;
+ DEBUG > 2 and print "Found: [@found]\n";
+
+ return $self->render_and_page(\@found);
+}
+
+#..........................................................................
+{
+
+my( %class_seen, %class_loaded );
+sub find_good_formatter_class {
+ my $self = $_[0];
+ my @class_list = @{ $self->{'formatter_classes'} || [] };
+ die "WHAT? Nothing in the formatter class list!?" unless @class_list;
+
+ my $good_class_found;
+ foreach my $c (@class_list) {
+ DEBUG > 4 and print "Trying to load $c...\n";
+ if($class_loaded{$c}) {
+ DEBUG > 4 and print "OK, the already-loaded $c it is!\n";
+ $good_class_found = $c;
+ last;
+ }
+
+ if($class_seen{$c}) {
+ DEBUG > 4 and print
+ "I've tried $c before, and it's no good. Skipping.\n";
+ next;
+ }
+
+ $class_seen{$c} = 1;
+
+ if( $c->can('parse_from_file') ) {
+ DEBUG > 4 and print
+ "Interesting, the formatter class $c is already loaded!\n";
+
+ } elsif(
+ (IS_VMS or IS_MSWin32 or IS_Dos or IS_OS2)
+ # the alway case-insensitive fs's
+ and $class_seen{lc("~$c")}++
+ ) {
+ DEBUG > 4 and print
+ "We already used something quite like \"\L$c\E\", so no point using $c\n";
+ # This avoids redefining the package.
+ } else {
+ DEBUG > 4 and print "Trying to eval 'require $c'...\n";
+
+ local $^W = $^W;
+ if(DEBUG() or $self->opt_v) {
+ # feh, let 'em see it
+ } else {
+ $^W = 0;
+ # The average user just has no reason to be seeing
+ # $^W-suppressable warnings from the the require!
+ }
+
+ eval "require $c";
+ if($@) {
+ DEBUG > 4 and print "Couldn't load $c: $!\n";
+ next;
+ }
+ }
+
+ if( $c->can('parse_from_file') ) {
+ DEBUG > 4 and print "Settling on $c\n";
+ my $v = $c->VERSION;
+ $v = ( defined $v and length $v ) ? " version $v" : '';
+ $self->aside("Formatter class $c$v successfully loaded!\n");
+ $good_class_found = $c;
+ last;
+ } else {
+ DEBUG > 4 and print "Class $c isn't a formatter?! Skipping.\n";
+ }
+ }
+
+ die "Can't find any loadable formatter class in @class_list?!\nAborting"
+ unless $good_class_found;
+
+ $self->{'formatter_class'} = $good_class_found;
+ $self->aside("Will format with the class $good_class_found\n");
+
+ return;
+}
+
+}
+#..........................................................................
+
+sub formatter_sanity_check {
+ my $self = shift;
+ my $formatter_class = $self->{'formatter_class'}
+ || die "NO FORMATTER CLASS YET!?";
+
+ if(!$self->opt_T # so -T can FORCE sending to STDOUT
+ and $formatter_class->can('is_pageable')
+ and !$formatter_class->is_pageable
+ and !$formatter_class->can('page_for_perldoc')
+ ) {
+ my $ext =
+ ($formatter_class->can('output_extension')
+ && $formatter_class->output_extension
+ ) || '';
+ $ext = ".$ext" if length $ext;
+
+ die
+ "When using Perldoc to format with $formatter_class, you have to\n"
+ . "specify -T or -dsomefile$ext\n"
+ . "See `perldoc perldoc' for more information on those switches.\n"
+ ;
+ }
+}
+
+#..........................................................................
+
+sub render_and_page {
+ my($self, $found_list) = @_;
+
+ $self->maybe_generate_dynamic_pod($found_list);
+
+ my($out, $formatter) = $self->render_findings($found_list);
+
+ if($self->opt_d) {
+ printf "Perldoc (%s) output saved to %s\n",
+ $self->{'formatter_class'} || ref($self),
+ $out;
+ print "But notice that it's 0 bytes long!\n" unless -s $out;
+
+
+ } elsif( # Allow the formatter to "page" itself, if it wants.
+ $formatter->can('page_for_perldoc')
+ and do {
+ $self->aside("Going to call $formatter\->page_for_perldoc(\"$out\")\n");
+ if( $formatter->page_for_perldoc($out, $self) ) {
+ $self->aside("page_for_perldoc returned true, so NOT paging with $self.\n");
+ 1;
+ } else {
+ $self->aside("page_for_perldoc returned false, so paging with $self instead.\n");
+ '';
+ }
+ }
+ ) {
+ # Do nothing, since the formatter has "paged" it for itself.
+
+ } else {
+ # Page it normally (internally)
+
+ if( -s $out ) { # Usual case:
+ $self->page($out, $self->{'output_to_stdout'}, $self->pagers);
+
+ } else {
+ # Odd case:
+ $self->aside("Skipping $out (from $$found_list[0] "
+ . "via $$self{'formatter_class'}) as it is 0-length.\n");
+
+ push @{ $self->{'temp_file_list'} }, $out;
+ $self->unlink_if_temp_file($out);
+ }
+ }
+
+ $self->after_rendering(); # any extra cleanup or whatever
+
+ return;
+}
+
+#..........................................................................
+
+sub options_reading {
+ my $self = shift;
+
+ if( defined $ENV{"PERLDOC"} and length $ENV{"PERLDOC"} ) {
+ require Text::ParseWords;
+ $self->aside("Noting env PERLDOC setting of $ENV{'PERLDOC'}\n");
+ # Yes, appends to the beginning
+ unshift @{ $self->{'args'} },
+ Text::ParseWords::shellwords( $ENV{"PERLDOC"} )
+ ;
+ DEBUG > 1 and print " Args now: @{$self->{'args'}}\n\n";
+ } else {
+ DEBUG > 1 and print " Okay, no PERLDOC setting in ENV.\n";
+ }
+
+ DEBUG > 1
+ and print " Args right before switch processing: @{$self->{'args'}}\n";
+
+ Pod::Perldoc::GetOptsOO::getopts( $self, $self->{'args'}, 'YES' )
+ or return $self->usage;
+
+ DEBUG > 1
+ and print " Args after switch processing: @{$self->{'args'}}\n";
+
+ return $self->usage if $self->opt_h;
+
+ return;
+}
+
+#..........................................................................
+
+sub options_processing {
+ my $self = shift;
+
+ if ($self->opt_X) {
+ my $podidx = "$Config{'archlib'}/pod.idx";
+ $podidx = "" unless -f $podidx && -r _ && -M _ <= 7;
+ $self->{'podidx'} = $podidx;
+ }
+
+ $self->{'output_to_stdout'} = 1 if $self->opt_T or ! -t STDOUT;
+
+ $self->options_sanity;
+
+ $self->opt_n("nroff") unless $self->opt_n;
+ $self->add_formatter_option( '__nroffer' => $self->opt_n );
+
+ # Adjust for using translation packages
+ $self->add_translator($self->opt_L) if $self->opt_L;
+
+ return;
+}
+
+#..........................................................................
+
+sub options_sanity {
+ my $self = shift;
+
+ # The opts-counting stuff interacts quite badly with
+ # the $ENV{"PERLDOC"} stuff. I.e., if I have $ENV{"PERLDOC"}
+ # set to -t, and I specify -u on the command line, I don't want
+ # to be hectored at that -u and -t don't make sense together.
+
+ #my $opts = grep $_ && 1, # yes, the count of the set ones
+ # $self->opt_t, $self->opt_u, $self->opt_m, $self->opt_l
+ #;
+ #
+ #$self->usage("only one of -t, -u, -m or -l") if $opts > 1;
+
+
+ # Any sanity-checking need doing here?
+
+ # But does not make sense to set either -f or -q in $ENV{"PERLDOC"}
+ if( $self->opt_f or $self->opt_q ) {
+ $self->usage("Only one of -f -or -q") if $self->opt_f and $self->opt_q;
+ warn
+ "Perldoc is only really meant for reading one word at a time.\n",
+ "So these parameters are being ignored: ",
+ join(' ', @{$self->{'args'}}),
+ "\n"
+ if @{$self->{'args'}}
+ }
+ return;
+}
+
+#..........................................................................
+
+sub grand_search_init {
+ my($self, $pages, @found) = @_;
+
+ foreach (@$pages) {
+ if ($self->{'podidx'} && open(PODIDX, $self->{'podidx'})) {
+ my $searchfor = catfile split '::', $_;
+ $self->aside( "Searching for '$searchfor' in $self->{'podidx'}\n" );
+ local $_;
+ while (<PODIDX>) {
+ chomp;
+ push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?\z,i;
+ }
+ close(PODIDX) or die "Can't close $$self{'podidx'}: $!";
+ next;
+ }
+
+ $self->aside( "Searching for $_\n" );
+
+ if ($self->opt_F) {
+ next unless -r;
+ push @found, $_ if $self->opt_m or $self->containspod($_);
+ next;
+ }
+
+ my @searchdirs;
+
+ # prepend extra search directories (including language specific)
+ push @searchdirs, @{ $self->{'extra_search_dirs'} };
+
+ # We must look both in @INC for library modules and in $bindir
+ # for executables, like h2xs or perldoc itself.
+ push @searchdirs, ($self->{'bindir'}, @INC);
+ unless ($self->opt_m) {
+ if (IS_VMS) {
+ my($i,$trn);
+ for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) {
+ push(@searchdirs,$trn);
+ }
+ push(@searchdirs,'perl_root:[lib.pod]') # installed pods
+ }
+ else {
+ push(@searchdirs, grep(-d, split($Config{path_sep},
+ $ENV{'PATH'})));
+ }
+ }
+ my @files = $self->searchfor(0,$_, at searchdirs);
+ if (@files) {
+ $self->aside( "Found as @files\n" );
+ }
+ else {
+ # no match, try recursive search
+ @searchdirs = grep(!/^\.\z/s, at INC);
+ @files= $self->searchfor(1,$_, at searchdirs) if $self->opt_r;
+ if (@files) {
+ $self->aside( "Loosely found as @files\n" );
+ }
+ else {
+ print STDERR "No " .
+ ($self->opt_m ? "module" : "documentation") . " found for \"$_\".\n";
+ if ( @{ $self->{'found'} } ) {
+ print STDERR "However, try\n";
+ for my $dir (@{ $self->{'found'} }) {
+ opendir(DIR, $dir) or die "opendir $dir: $!";
+ while (my $file = readdir(DIR)) {
+ next if ($file =~ /^\./s);
+ $file =~ s/\.(pm|pod)\z//; # XXX: badfs
+ print STDERR "\tperldoc $_\::$file\n";
+ }
+ closedir(DIR) or die "closedir $dir: $!";
+ }
+ }
+ }
+ }
+ push(@found, at files);
+ }
+ return @found;
+}
+
+#..........................................................................
+
+sub maybe_generate_dynamic_pod {
+ my($self, $found_things) = @_;
+ my @dynamic_pod;
+
+ $self->search_perlfunc($found_things, \@dynamic_pod) if $self->opt_f;
+
+ $self->search_perlfaqs($found_things, \@dynamic_pod) if $self->opt_q;
+
+ if( ! $self->opt_f and ! $self->opt_q ) {
+ DEBUG > 4 and print "That's a non-dynamic pod search.\n";
+ } elsif ( @dynamic_pod ) {
+ $self->aside("Hm, I found some Pod from that search!\n");
+ my ($buffd, $buffer) = $self->new_tempfile('pod', 'dyn');
+
+ push @{ $self->{'temp_file_list'} }, $buffer;
+ # I.e., it MIGHT be deleted at the end.
+
+ my $in_list = $self->opt_f;
+
+ print $buffd "=over 8\n\n" if $in_list;
+ print $buffd @dynamic_pod or die "Can't print $buffer: $!";
+ print $buffd "=back\n" if $in_list;
+
+ close $buffd or die "Can't close $buffer: $!";
+
+ @$found_things = $buffer;
+ # Yes, so found_things never has more than one thing in
+ # it, by time we leave here
+
+ $self->add_formatter_option('__filter_nroff' => 1);
+
+ } else {
+ @$found_things = ();
+ $self->aside("I found no Pod from that search!\n");
+ }
+
+ return;
+}
+
+#..........................................................................
+
+sub add_formatter_option { # $self->add_formatter_option('key' => 'value');
+ my $self = shift;
+ push @{ $self->{'formatter_switches'} }, [ @_ ] if @_;
+
+ DEBUG > 3 and printf "Formatter switches now: [%s]\n",
+ join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
+
+ return;
+}
+
+#.........................................................................
+
+sub new_translator { # $tr = $self->new_translator($lang);
+ my $self = shift;
+ my $lang = shift;
+
+ my $pack = 'POD2::' . uc($lang);
+ eval "require $pack";
+ if ( !$@ && $pack->can('new') ) {
+ return $pack->new();
+ }
+
+ eval { require POD2::Base };
+ return if $@;
+
+ return POD2::Base->new({ lang => $lang });
+}
+
+#.........................................................................
+
+sub add_translator { # $self->add_translator($lang);
+ my $self = shift;
+ for my $lang (@_) {
+ my $tr = $self->new_translator($lang);
+ if ( defined $tr ) {
+ push @{ $self->{'translators'} }, $tr;
+ push @{ $self->{'extra_search_dirs'} }, $tr->pod_dirs;
+
+ $self->aside( "translator for '$lang' loaded\n" );
+ } else {
+ # non-installed or bad translator package
+ warn "Perldoc cannot load translator package for '$lang': ignored\n";
+ }
+
+ }
+ return;
+}
+
+#..........................................................................
+
+sub search_perlfunc {
+ my($self, $found_things, $pod) = @_;
+
+ DEBUG > 2 and print "Search: @$found_things\n";
+
+ my $perlfunc = shift @$found_things;
+ open(PFUNC, "<", $perlfunc) # "Funk is its own reward"
+ or die("Can't open $perlfunc: $!");
+
+ # Functions like -r, -e, etc. are listed under `-X'.
+ my $search_re = ($self->opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/)
+ ? '(?:I<)?-X' : quotemeta($self->opt_f) ;
+
+ DEBUG > 2 and
+ print "Going to perlfunc-scan for $search_re in $perlfunc\n";
+
+ my $re = 'Alphabetical Listing of Perl Functions';
+ if ( $self->opt_L ) {
+ my $tr = $self->{'translators'}->[0];
+ $re = $tr->search_perlfunc_re if $tr->can('search_perlfunc_re');
+ }
+
+ # Skip introduction
+ local $_;
+ while (<PFUNC>) {
+ last if /^=head2 $re/;
+ }
+
+ # Look for our function
+ my $found = 0;
+ my $inlist = 0;
+ while (<PFUNC>) { # "The Mothership Connection is here!"
+ if ( m/^=item\s+$search_re\b/ ) {
+ $found = 1;
+ }
+ elsif (/^=item/) {
+ last if $found > 1 and not $inlist;
+ }
+ next unless $found;
+ if (/^=over/) {
+ ++$inlist;
+ }
+ elsif (/^=back/) {
+ --$inlist;
+ }
+ push @$pod, $_;
+ ++$found if /^\w/; # found descriptive text
+ }
+ if (!@$pod) {
+ die sprintf
+ "No documentation for perl function `%s' found\n",
+ $self->opt_f
+ ;
+ }
+ close PFUNC or die "Can't open $perlfunc: $!";
+
+ return;
+}
+
+#..........................................................................
+
+sub search_perlfaqs {
+ my( $self, $found_things, $pod) = @_;
+
+ my $found = 0;
+ my %found_in;
+ my $search_key = $self->opt_q;
+
+ my $rx = eval { qr/$search_key/ }
+ or die <<EOD;
+Invalid regular expression '$search_key' given as -q pattern:
+$@
+Did you mean \\Q$search_key ?
+
+EOD
+
+ local $_;
+ foreach my $file (@$found_things) {
+ die "invalid file spec: $!" if $file =~ /[<>|]/;
+ open(INFAQ, "<", $file) # XXX 5.6ism
+ or die "Can't read-open $file: $!\nAborting";
+ while (<INFAQ>) {
+ if ( m/^=head2\s+.*(?:$search_key)/i ) {
+ $found = 1;
+ push @$pod, "=head1 Found in $file\n\n" unless $found_in{$file}++;
+ }
+ elsif (/^=head[12]/) {
+ $found = 0;
+ }
+ next unless $found;
+ push @$pod, $_;
+ }
+ close(INFAQ);
+ }
+ die("No documentation for perl FAQ keyword `$search_key' found\n")
+ unless @$pod;
+
+ return;
+}
+
+
+#..........................................................................
+
+sub render_findings {
+ # Return the filename to open
+
+ my($self, $found_things) = @_;
+
+ my $formatter_class = $self->{'formatter_class'}
+ || die "No formatter class set!?";
+ my $formatter = $formatter_class->can('new')
+ ? $formatter_class->new
+ : $formatter_class
+ ;
+
+ if(! @$found_things) {
+ die "Nothing found?!";
+ # should have been caught before here
+ } elsif(@$found_things > 1) {
+ warn
+ "Perldoc is only really meant for reading one document at a time.\n",
+ "So these parameters are being ignored: ",
+ join(' ', @$found_things[1 .. $#$found_things] ),
+ "\n"
+ }
+
+ my $file = $found_things->[0];
+
+ DEBUG > 3 and printf "Formatter switches now: [%s]\n",
+ join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
+
+ # Set formatter options:
+ if( ref $formatter ) {
+ foreach my $f (@{ $self->{'formatter_switches'} || [] }) {
+ my($switch, $value, $silent_fail) = @$f;
+ if( $formatter->can($switch) ) {
+ eval { $formatter->$switch( defined($value) ? $value : () ) };
+ warn "Got an error when setting $formatter_class\->$switch:\n$@\n"
+ if $@;
+ } else {
+ if( $silent_fail or $switch =~ m/^__/s ) {
+ DEBUG > 2 and print "Formatter $formatter_class doesn't support $switch\n";
+ } else {
+ warn "$formatter_class doesn't recognize the $switch switch.\n";
+ }
+ }
+ }
+ }
+
+ $self->{'output_is_binary'} =
+ $formatter->can('write_with_binmode') && $formatter->write_with_binmode;
+
+ my ($out_fh, $out) = $self->new_output_file(
+ ( $formatter->can('output_extension') && $formatter->output_extension )
+ || undef,
+ $self->useful_filename_bit,
+ );
+
+ # Now, finally, do the formatting!
+ {
+ local $^W = $^W;
+ if(DEBUG() or $self->opt_v) {
+ # feh, let 'em see it
+ } else {
+ $^W = 0;
+ # The average user just has no reason to be seeing
+ # $^W-suppressable warnings from the formatting!
+ }
+
+ eval { $formatter->parse_from_file( $file, $out_fh ) };
+ }
+
+ warn "Error while formatting with $formatter_class:\n $@\n" if $@;
+ DEBUG > 2 and print "Back from formatting with $formatter_class\n";
+
+ close $out_fh
+ or warn "Can't close $out: $!\n(Did $formatter already close it?)";
+ sleep 0; sleep 0; sleep 0;
+ # Give the system a few timeslices to meditate on the fact
+ # that the output file does in fact exist and is closed.
+
+ $self->unlink_if_temp_file($file);
+
+ unless( -s $out ) {
+ if( $formatter->can( 'if_zero_length' ) ) {
+ # Basically this is just a hook for Pod::Simple::Checker; since
+ # what other class could /happily/ format an input file with Pod
+ # as a 0-length output file?
+ $formatter->if_zero_length( $file, $out, $out_fh );
+ } else {
+ warn "Got a 0-length file from $$found_things[0] via $formatter_class!?\n"
+ }
+ }
+
+ DEBUG and print "Finished writing to $out.\n";
+ return($out, $formatter) if wantarray;
+ return $out;
+}
+
+#..........................................................................
+
+sub unlink_if_temp_file {
+ # Unlink the specified file IFF it's in the list of temp files.
+ # Really only used in the case of -f / -q things when we can
+ # throw away the dynamically generated source pod file once
+ # we've formatted it.
+ #
+ my($self, $file) = @_;
+ return unless defined $file and length $file;
+
+ my $temp_file_list = $self->{'temp_file_list'} || return;
+ if(grep $_ eq $file, @$temp_file_list) {
+ $self->aside("Unlinking $file\n");
+ unlink($file) or warn "Odd, couldn't unlink $file: $!";
+ } else {
+ DEBUG > 1 and print "$file isn't a temp file, so not unlinking.\n";
+ }
+ return;
+}
+
+#..........................................................................
+
+sub MSWin_temp_cleanup {
+
+ # Nothing particularly MSWin-specific in here, but I don't know if any
+ # other OS needs its temp dir policed like MSWin does!
+
+ my $self = shift;
+
+ my $tempdir = $ENV{'TEMP'};
+ return unless defined $tempdir and length $tempdir
+ and -e $tempdir and -d _ and -w _;
+
+ $self->aside(
+ "Considering whether any old files of mine in $tempdir need unlinking.\n"
+ );
+
+ opendir(TMPDIR, $tempdir) || return;
+ my @to_unlink;
+
+ my $limit = time() - $Temp_File_Lifetime;
+
+ DEBUG > 5 and printf "Looking for things pre-dating %s (%x)\n",
+ ($limit) x 2;
+
+ my $filespec;
+
+ while(defined($filespec = readdir(TMPDIR))) {
+ if(
+ $filespec =~ m{^perldoc_[a-zA-Z0-9]+_T([a-fA-F0-9]{7,})_[a-fA-F0-9]{3,}}s
+ ) {
+ if( hex($1) < $limit ) {
+ push @to_unlink, "$tempdir/$filespec";
+ $self->aside( "Will unlink my old temp file $to_unlink[-1]\n" );
+ } else {
+ DEBUG > 5 and
+ printf " $tempdir/$filespec is too recent (after %x)\n", $limit;
+ }
+ } else {
+ DEBUG > 5 and
+ print " $tempdir/$filespec doesn't look like a perldoc temp file.\n";
+ }
+ }
+ closedir(TMPDIR);
+ $self->aside(sprintf "Unlinked %s items of mine in %s\n",
+ scalar(unlink(@to_unlink)),
+ $tempdir
+ );
+ return;
+}
+
+# . . . . . . . . . . . . . . . . . . . . . . . . .
+
+sub MSWin_perldoc_tempfile {
+ my($self, $suffix, $infix) = @_;
+
+ my $tempdir = $ENV{'TEMP'};
+ return unless defined $tempdir and length $tempdir
+ and -e $tempdir and -d _ and -w _;
+
+ my $spec;
+
+ do {
+ $spec = sprintf "%s\\perldoc_%s_T%x_%x%02x.%s", # used also in MSWin_temp_cleanup
+ # Yes, we embed the create-time in the filename!
+ $tempdir,
+ $infix || 'x',
+ time(),
+ $$,
+ defined( &Win32::GetTickCount )
+ ? (Win32::GetTickCount() & 0xff)
+ : int(rand 256)
+ # Under MSWin, $$ values get reused quickly! So if we ran
+ # perldoc foo and then perldoc bar before there was time for
+ # time() to increment time."_$$" would likely be the same
+ # for each process! So we tack on the tick count's lower
+ # bits (or, in a pinch, rand)
+ ,
+ $suffix || 'txt';
+ ;
+ } while( -e $spec );
+
+ my $counter = 0;
+
+ while($counter < 50) {
+ my $fh;
+ # If we are running before perl5.6.0, we can't autovivify
+ if ($] < 5.006) {
+ require Symbol;
+ $fh = Symbol::gensym();
+ }
+ DEBUG > 3 and print "About to try making temp file $spec\n";
+ return($fh, $spec) if open($fh, ">", $spec); # XXX 5.6ism
+ $self->aside("Can't create temp file $spec: $!\n");
+ }
+
+ $self->aside("Giving up on making a temp file!\n");
+ die "Can't make a tempfile!?";
+}
+
+#..........................................................................
+
+
+sub after_rendering {
+ my $self = $_[0];
+ $self->after_rendering_VMS if IS_VMS;
+ $self->after_rendering_MSWin32 if IS_MSWin32;
+ $self->after_rendering_Dos if IS_Dos;
+ $self->after_rendering_OS2 if IS_OS2;
+ return;
+}
+
+sub after_rendering_VMS { return }
+sub after_rendering_Dos { return }
+sub after_rendering_OS2 { return }
+
+sub after_rendering_MSWin32 {
+ shift->MSWin_temp_cleanup() if $Temp_Files_Created;
+}
+
+#..........................................................................
+# : : : : : : : : :
+#..........................................................................
+
+
+sub minus_f_nocase { # i.e., do like -f, but without regard to case
+
+ my($self, $dir, $file) = @_;
+ my $path = catfile($dir,$file);
+ return $path if -f $path and -r _;
+
+ if(!$self->opt_i
+ or IS_VMS or IS_MSWin32
+ or IS_Dos or IS_OS2
+ ) {
+ # On a case-forgiving file system, or if case is important,
+ # that is it, all we can do.
+ warn "Ignored $path: unreadable\n" if -f _;
+ return '';
+ }
+
+ local *DIR;
+ my @p = ($dir);
+ my($p,$cip);
+ foreach $p (splitdir $file){
+ my $try = catfile @p, $p;
+ $self->aside("Scrutinizing $try...\n");
+ stat $try;
+ if (-d _) {
+ push @p, $p;
+ if ( $p eq $self->{'target'} ) {
+ my $tmp_path = catfile @p;
+ my $path_f = 0;
+ for (@{ $self->{'found'} }) {
+ $path_f = 1 if $_ eq $tmp_path;
+ }
+ push (@{ $self->{'found'} }, $tmp_path) unless $path_f;
+ $self->aside( "Found as $tmp_path but directory\n" );
+ }
+ }
+ elsif (-f _ && -r _) {
+ return $try;
+ }
+ elsif (-f _) {
+ warn "Ignored $try: unreadable\n";
+ }
+ elsif (-d catdir(@p)) { # at least we see the containing directory!
+ my $found = 0;
+ my $lcp = lc $p;
+ my $p_dirspec = catdir(@p);
+ opendir DIR, $p_dirspec or die "opendir $p_dirspec: $!";
+ while(defined( $cip = readdir(DIR) )) {
+ if (lc $cip eq $lcp){
+ $found++;
+ last; # XXX stop at the first? what if there's others?
+ }
+ }
+ closedir DIR or die "closedir $p_dirspec: $!";
+ return "" unless $found;
+
+ push @p, $cip;
+ my $p_filespec = catfile(@p);
+ return $p_filespec if -f $p_filespec and -r _;
+ warn "Ignored $p_filespec: unreadable\n" if -f _;
+ }
+ }
+ return "";
+}
+
+#..........................................................................
+
+sub pagers_guessing {
+ my $self = shift;
+
+ my @pagers;
+ push @pagers, $self->pagers;
+ $self->{'pagers'} = \@pagers;
+
+ if (IS_MSWin32) {
+ push @pagers, qw( more< less notepad );
+ unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
+ }
+ elsif (IS_VMS) {
+ push @pagers, qw( most more less type/page );
+ }
+ elsif (IS_Dos) {
+ push @pagers, qw( less.exe more.com< );
+ unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
+ }
+ else {
+ if (IS_OS2) {
+ unshift @pagers, 'less', 'cmd /c more <';
+ }
+ push @pagers, qw( more less pg view cat );
+ unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
+ }
+
+ if (IS_Cygwin) {
+ if (($pagers[0] eq 'less') || ($pagers[0] eq '/usr/bin/less')) {
+ unshift @pagers, '/usr/bin/less -isrR';
+ }
+ }
+
+ unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER};
+
+ return;
+}
+
+#..........................................................................
+
+sub page_module_file {
+ my($self, @found) = @_;
+
+ # Security note:
+ # Don't ever just pass this off to anything like MSWin's "start.exe",
+ # since we might be calling on a .pl file, and we wouldn't want that
+ # to actually /execute/ the file that we just want to page thru!
+ # Also a consideration if one were to use a web browser as a pager;
+ # doing so could trigger the browser's MIME mapping for whatever
+ # it thinks .pm/.pl/whatever is. Probably just a (useless and
+ # annoying) "Save as..." dialog, but potentially executing the file
+ # in question -- particularly in the case of MSIE and it's, ahem,
+ # occasionally hazy distinction between OS-local extension
+ # associations, and browser-specific MIME mappings.
+
+ if ($self->{'output_to_stdout'}) {
+ $self->aside("Sending unpaged output to STDOUT.\n");
+ local $_;
+ my $any_error = 0;
+ foreach my $output (@found) {
+ unless( open(TMP, "<", $output) ) { # XXX 5.6ism
+ warn("Can't open $output: $!");
+ $any_error = 1;
+ next;
+ }
+ while (<TMP>) {
+ print or die "Can't print to stdout: $!";
+ }
+ close TMP or die "Can't close while $output: $!";
+ $self->unlink_if_temp_file($output);
+ }
+ return $any_error; # successful
+ }
+
+ foreach my $pager ( $self->pagers ) {
+ $self->aside("About to try calling $pager @found\n");
+ if (system($pager, @found) == 0) {
+ $self->aside("Yay, it worked.\n");
+ return 0;
+ }
+ $self->aside("That didn't work.\n");
+
+ # Odd -- when it fails, under Win32, this seems to neither
+ # return with a fail nor return with a success!!
+ # That's discouraging!
+ }
+
+ $self->aside(
+ sprintf "Can't manage to find a way to page [%s] via pagers [%s]\n",
+ join(' ', @found),
+ join(' ', $self->pagers),
+ );
+
+ if (IS_VMS) {
+ DEBUG > 1 and print "Bailing out in a VMSish way.\n";
+ eval q{
+ use vmsish qw(status exit);
+ exit $?;
+ 1;
+ } or die;
+ }
+
+ return 1;
+ # i.e., an UNSUCCESSFUL return value!
+}
+
+#..........................................................................
+
+sub check_file {
+ my($self, $dir, $file) = @_;
+
+ unless( ref $self ) {
+ # Should never get called:
+ $Carp::Verbose = 1;
+ require Carp;
+ Carp::croak( join '',
+ "Crazy ", __PACKAGE__, " error:\n",
+ "check_file must be an object_method!\n",
+ "Aborting"
+ );
+ }
+
+ if(length $dir and not -d $dir) {
+ DEBUG > 3 and print " No dir $dir -- skipping.\n";
+ return "";
+ }
+
+ if ($self->opt_m) {
+ return $self->minus_f_nocase($dir,$file);
+ }
+
+ else {
+ my $path = $self->minus_f_nocase($dir,$file);
+ if( length $path and $self->containspod($path) ) {
+ DEBUG > 3 and print
+ " The file $path indeed looks promising!\n";
+ return $path;
+ }
+ }
+ DEBUG > 3 and print " No good: $file in $dir\n";
+
+ return "";
+}
+
+#..........................................................................
+
+sub containspod {
+ my($self, $file, $readit) = @_;
+ return 1 if !$readit && $file =~ /\.pod\z/i;
+
+
+ # Under cygwin the /usr/bin/perl is legal executable, but
+ # you cannot open a file with that name. It must be spelled
+ # out as "/usr/bin/perl.exe".
+ #
+ # The following if-case under cygwin prevents error
+ #
+ # $ perldoc perl
+ # Cannot open /usr/bin/perl: no such file or directory
+ #
+ # This would work though
+ #
+ # $ perldoc perl.pod
+
+ if ( IS_Cygwin and -x $file and -f "$file.exe" )
+ {
+ warn "Cygwin $file.exe search skipped\n" if DEBUG or $self->opt_v;
+ return 0;
+ }
+
+ local($_);
+ open(TEST,"<", $file) or die "Can't open $file: $!"; # XXX 5.6ism
+ while (<TEST>) {
+ if (/^=head/) {
+ close(TEST) or die "Can't close $file: $!";
+ return 1;
+ }
+ }
+ close(TEST) or die "Can't close $file: $!";
+ return 0;
+}
+
+#..........................................................................
+
+sub maybe_diddle_INC {
+ my $self = shift;
+
+ # Does this look like a module or extension directory?
+
+ if (-f "Makefile.PL" || -f "Build.PL") {
+
+ # Add "." and "lib" to @INC (if they exist)
+ eval q{ use lib qw(. lib); 1; } or die;
+
+ # don't add if superuser
+ if ($< && $> && -d "blib") { # don't be looking too hard now!
+ eval q{ use blib; 1 };
+ warn $@ if $@ && $self->opt_v;
+ }
+ }
+
+ return;
+}
+
+#..........................................................................
+
+sub new_output_file {
+ my $self = shift;
+ my $outspec = $self->opt_d; # Yes, -d overrides all else!
+ # So don't call this twice per format-job!
+
+ return $self->new_tempfile(@_) unless defined $outspec and length $outspec;
+
+ # Otherwise open a write-handle on opt_d!f
+
+ my $fh;
+ # If we are running before perl5.6.0, we can't autovivify
+ if ($] < 5.006) {
+ require Symbol;
+ $fh = Symbol::gensym();
+ }
+ DEBUG > 3 and print "About to try writing to specified output file $outspec\n";
+ die "Can't write-open $outspec: $!"
+ unless open($fh, ">", $outspec); # XXX 5.6ism
+
+ DEBUG > 3 and print "Successfully opened $outspec\n";
+ binmode($fh) if $self->{'output_is_binary'};
+ return($fh, $outspec);
+}
+
+#..........................................................................
+
+sub useful_filename_bit {
+ # This tries to provide a meaningful bit of text to do with the query,
+ # such as can be used in naming the file -- since if we're going to be
+ # opening windows on temp files (as a "pager" may well do!) then it's
+ # better if the temp file's name (which may well be used as the window
+ # title) isn't ALL just random garbage!
+ # In other words "perldoc_LWPSimple_2371981429" is a better temp file
+ # name than "perldoc_2371981429". So this routine is what tries to
+ # provide the "LWPSimple" bit.
+ #
+ my $self = shift;
+ my $pages = $self->{'pages'} || return undef;
+ return undef unless @$pages;
+
+ my $chunk = $pages->[0];
+ return undef unless defined $chunk;
+ $chunk =~ s/:://g;
+ $chunk =~ s/\.\w+$//g; # strip any extension
+ if( $chunk =~ m/([^\#\\:\/\$]+)$/s ) { # get basename, if it's a file
+ $chunk = $1;
+ } else {
+ return undef;
+ }
+ $chunk =~ s/[^a-zA-Z0-9]+//g; # leave ONLY a-zA-Z0-9 things!
+ $chunk = substr($chunk, -10) if length($chunk) > 10;
+ return $chunk;
+}
+
+#..........................................................................
+
+sub new_tempfile { # $self->new_tempfile( [$suffix, [$infix] ] )
+ my $self = shift;
+
+ ++$Temp_Files_Created;
+
+ if( IS_MSWin32 ) {
+ my @out = $self->MSWin_perldoc_tempfile(@_);
+ return @out if @out;
+ # otherwise fall thru to the normal stuff below...
+ }
+
+ require File::Temp;
+ return File::Temp::tempfile(UNLINK => 1);
+}
+
+#..........................................................................
+
+sub page { # apply a pager to the output file
+ my ($self, $output, $output_to_stdout, @pagers) = @_;
+ if ($output_to_stdout) {
+ $self->aside("Sending unpaged output to STDOUT.\n");
+ open(TMP, "<", $output) or die "Can't open $output: $!"; # XXX 5.6ism
+ local $_;
+ while (<TMP>) {
+ print or die "Can't print to stdout: $!";
+ }
+ close TMP or die "Can't close while $output: $!";
+ $self->unlink_if_temp_file($output);
+ } else {
+ # On VMS, quoting prevents logical expansion, and temp files with no
+ # extension get the wrong default extension (such as .LIS for TYPE)
+
+ $output = VMS::Filespec::rmsexpand($output, '.') if IS_VMS;
+
+ $output =~ s{/}{\\}g if IS_MSWin32 || IS_Dos;
+ # Altho "/" under MSWin is in theory good as a pathsep,
+ # many many corners of the OS don't like it. So we
+ # have to force it to be "\" to make everyone happy.
+
+ foreach my $pager (@pagers) {
+ $self->aside("About to try calling $pager $output\n");
+ if (IS_VMS) {
+ last if system("$pager $output") == 0;
+ } else {
+ last if system("$pager \"$output\"") == 0;
+ }
+ }
+ }
+ return;
+}
+
+#..........................................................................
+
+sub searchfor {
+ my($self, $recurse,$s, at dirs) = @_;
+ $s =~ s!::!/!g;
+ $s = VMS::Filespec::unixify($s) if IS_VMS;
+ return $s if -f $s && $self->containspod($s);
+ $self->aside( "Looking for $s in @dirs\n" );
+ my $ret;
+ my $i;
+ my $dir;
+ $self->{'target'} = (splitdir $s)[-1]; # XXX: why not use File::Basename?
+ for ($i=0; $i<@dirs; $i++) {
+ $dir = $dirs[$i];
+ next unless -d $dir;
+ ($dir = VMS::Filespec::unixpath($dir)) =~ s!/\z!! if IS_VMS;
+ if ( (! $self->opt_m && ( $ret = $self->check_file($dir,"$s.pod")))
+ or ( $ret = $self->check_file($dir,"$s.pm"))
+ or ( $ret = $self->check_file($dir,$s))
+ or ( IS_VMS and
+ $ret = $self->check_file($dir,"$s.com"))
+ or ( IS_OS2 and
+ $ret = $self->check_file($dir,"$s.cmd"))
+ or ( (IS_MSWin32 or IS_Dos or IS_OS2) and
+ $ret = $self->check_file($dir,"$s.bat"))
+ or ( $ret = $self->check_file("$dir/pod","$s.pod"))
+ or ( $ret = $self->check_file("$dir/pod",$s))
+ or ( $ret = $self->check_file("$dir/pods","$s.pod"))
+ or ( $ret = $self->check_file("$dir/pods",$s))
+ ) {
+ DEBUG > 1 and print " Found $ret\n";
+ return $ret;
+ }
+
+ if ($recurse) {
+ opendir(D,$dir) or die "Can't opendir $dir: $!";
+ my @newdirs = map catfile($dir, $_), grep {
+ not /^\.\.?\z/s and
+ not /^auto\z/s and # save time! don't search auto dirs
+ -d catfile($dir, $_)
+ } readdir D;
+ closedir(D) or die "Can't closedir $dir: $!";
+ next unless @newdirs;
+ # what a wicked map!
+ @newdirs = map((s/\.dir\z//,$_)[1], at newdirs) if IS_VMS;
+ $self->aside( "Also looking in @newdirs\n" );
+ push(@dirs, at newdirs);
+ }
+ }
+ return ();
+}
+
+#..........................................................................
+{
+ my $already_asserted;
+ sub assert_closing_stdout {
+ my $self = shift;
+
+ return if $already_asserted;
+
+ eval q~ END { close(STDOUT) || die "Can't close STDOUT: $!" } ~;
+ # What for? to let the pager know that nothing more will come?
+
+ die $@ if $@;
+ $already_asserted = 1;
+ return;
+ }
+}
+
+#..........................................................................
+
+sub tweak_found_pathnames {
+ my($self, $found) = @_;
+ if (IS_MSWin32) {
+ foreach (@$found) { s,/,\\,g }
+ }
+ return;
+}
+
+#..........................................................................
+# : : : : : : : : :
+#..........................................................................
+
+sub am_taint_checking {
+ my $self = shift;
+ die "NO ENVIRONMENT?!?!" unless keys %ENV; # reset iterator along the way
+ my($k,$v) = each %ENV;
+ return is_tainted($v);
+}
+
+#..........................................................................
+
+sub is_tainted { # just a function
+ my $arg = shift;
+ my $nada = substr($arg, 0, 0); # zero-length!
+ local $@; # preserve the caller's version of $@
+ eval { eval "# $nada" };
+ return length($@) != 0;
+}
+
+#..........................................................................
+
+sub drop_privs_maybe {
+ my $self = shift;
+
+ # Attempt to drop privs if we should be tainting and aren't
+ if (!(IS_VMS || IS_MSWin32 || IS_Dos
+ || IS_OS2
+ )
+ && ($> == 0 || $< == 0)
+ && !$self->am_taint_checking()
+ ) {
+ my $id = eval { getpwnam("nobody") };
+ $id = eval { getpwnam("nouser") } unless defined $id;
+ $id = -2 unless defined $id;
+ #
+ # According to Stevens' APUE and various
+ # (BSD, Solaris, HP-UX) man pages, setting
+ # the real uid first and effective uid second
+ # is the way to go if one wants to drop privileges,
+ # because if one changes into an effective uid of
+ # non-zero, one cannot change the real uid any more.
+ #
+ # Actually, it gets even messier. There is
+ # a third uid, called the saved uid, and as
+ # long as that is zero, one can get back to
+ # uid of zero. Setting the real-effective *twice*
+ # helps in *most* systems (FreeBSD and Solaris)
+ # but apparently in HP-UX even this doesn't help:
+ # the saved uid stays zero (apparently the only way
+ # in HP-UX to change saved uid is to call setuid()
+ # when the effective uid is zero).
+ #
+ eval {
+ $< = $id; # real uid
+ $> = $id; # effective uid
+ $< = $id; # real uid
+ $> = $id; # effective uid
+ };
+ if( !$@ && $< && $> ) {
+ DEBUG and print "OK, I dropped privileges.\n";
+ } elsif( $self->opt_U ) {
+ DEBUG and print "Couldn't drop privileges, but in -U mode, so feh."
+ } else {
+ DEBUG and print "Hm, couldn't drop privileges. Ah well.\n";
+ # We used to die here; but that seemed pointless.
+ }
+ }
+ return;
+}
+
+#..........................................................................
+
+1;
+
+__END__
+
+# See "perldoc perldoc" for basic details.
+#
+# Perldoc -- look up a piece of documentation in .pod format that
+# is embedded in the perl installation tree.
+#
+#~~~~~~
+#
+# See ChangeLog in CPAN dist for Pod::Perldoc for later notes.
+#
+# Version 3.01: Sun Nov 10 21:38:09 MST 2002
+# Sean M. Burke <sburke at cpan.org>
+# Massive refactoring and code-tidying.
+# Now it's a module(-family)!
+# Formatter-specific stuff pulled out into Pod::Perldoc::To(Whatever).pm
+# Added -T, -d, -o, -M, -w.
+# Added some improved MSWin funk.
+#
+#~~~~~~
+#
+# Version 2.05: Sat Oct 12 16:09:00 CEST 2002
+# Hugo van der Sanden <hv at crypt.org>
+# Made -U the default, based on patch from Simon Cozens
+# Version 2.04: Sun Aug 18 13:27:12 BST 2002
+# Randy W. Sims <RandyS at ThePierianSpring.org>
+# allow -n to enable nroff under Win32
+# Version 2.03: Sun Apr 23 16:56:34 BST 2000
+# Hugo van der Sanden <hv at crypt.org>
+# don't die when 'use blib' fails
+# Version 2.02: Mon Mar 13 18:03:04 MST 2000
+# Tom Christiansen <tchrist at perl.com>
+# Added -U insecurity option
+# Version 2.01: Sat Mar 11 15:22:33 MST 2000
+# Tom Christiansen <tchrist at perl.com>, querulously.
+# Security and correctness patches.
+# What a twisted bit of distasteful spaghetti code.
+# Version 2.0: ????
+#
+#~~~~~~
+#
+# Version 1.15: Tue Aug 24 01:50:20 EST 1999
+# Charles Wilson <cwilson at ece.gatech.edu>
+# changed /pod/ directory to /pods/ for cygwin
+# to support cygwin/win32
+# Version 1.14: Wed Jul 15 01:50:20 EST 1998
+# Robin Barker <rmb1 at cise.npl.co.uk>
+# -strict, -w cleanups
+# Version 1.13: Fri Feb 27 16:20:50 EST 1997
+# Gurusamy Sarathy <gsar at activestate.com>
+# -doc tweaks for -F and -X options
+# Version 1.12: Sat Apr 12 22:41:09 EST 1997
+# Gurusamy Sarathy <gsar at activestate.com>
+# -various fixes for win32
+# Version 1.11: Tue Dec 26 09:54:33 EST 1995
+# Kenneth Albanowski <kjahds at kjahds.com>
+# -added Charles Bailey's further VMS patches, and -u switch
+# -added -t switch, with pod2text support
+#
+# Version 1.10: Thu Nov 9 07:23:47 EST 1995
+# Kenneth Albanowski <kjahds at kjahds.com>
+# -added VMS support
+# -added better error recognition (on no found pages, just exit. On
+# missing nroff/pod2man, just display raw pod.)
+# -added recursive/case-insensitive matching (thanks, Andreas). This
+# slows things down a bit, unfortunately. Give a precise name, and
+# it'll run faster.
+#
+# Version 1.01: Tue May 30 14:47:34 EDT 1995
+# Andy Dougherty <doughera at lafcol.lafayette.edu>
+# -added pod documentation.
+# -added PATH searching.
+# -added searching pod/ subdirectory (mainly to pick up perlfunc.pod
+# and friends.
+#
+#~~~~~~~
+#
+# TODO:
+#
+# Cache the directories read during sloppy match
+# (To disk, or just in-memory?)
+#
+# Backport this to perl 5.005?
+#
+# Implement at least part of the "perlman" interface described
+# in Programming Perl 3e?
Copied: trunk/contrib/perl/lib/Pod/PlainText.pm (from rev 6437, vendor/perl/5.18.1/lib/Pod/PlainText.pm)
===================================================================
--- trunk/contrib/perl/lib/Pod/PlainText.pm (rev 0)
+++ trunk/contrib/perl/lib/Pod/PlainText.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,738 @@
+# Pod::PlainText -- Convert POD data to formatted ASCII text.
+# $Id: PlainText.pm,v 1.1.1.2 2011-02-17 12:49:41 laffer1 Exp $
+#
+# Copyright 1999-2000 by Russ Allbery <rra at stanford.edu>
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the same terms as Perl itself.
+#
+# This module is intended to be a replacement for Pod::Text, and attempts to
+# match its output except for some specific circumstances where other
+# decisions seemed to produce better output. It uses Pod::Parser and is
+# designed to be very easy to subclass.
+
+############################################################################
+# Modules and declarations
+############################################################################
+
+package Pod::PlainText;
+use strict;
+
+require 5.005;
+
+use Carp qw(carp croak);
+use Pod::Select ();
+
+use vars qw(@ISA %ESCAPES $VERSION);
+
+# We inherit from Pod::Select instead of Pod::Parser so that we can be used
+# by Pod::Usage.
+ at ISA = qw(Pod::Select);
+
+$VERSION = '2.04';
+
+BEGIN {
+ if ($] < 5.006) {
+ require Symbol;
+ import Symbol;
+ }
+}
+
+############################################################################
+# Table of supported E<> escapes
+############################################################################
+
+# This table is taken near verbatim from Pod::PlainText in Pod::Parser,
+# which got it near verbatim from the original Pod::Text. It is therefore
+# credited to Tom Christiansen, and I'm glad I didn't have to write it. :)
+%ESCAPES = (
+ 'amp' => '&', # ampersand
+ 'lt' => '<', # left chevron, less-than
+ 'gt' => '>', # right chevron, greater-than
+ 'quot' => '"', # double quote
+
+ "Aacute" => "\xC1", # capital A, acute accent
+ "aacute" => "\xE1", # small a, acute accent
+ "Acirc" => "\xC2", # capital A, circumflex accent
+ "acirc" => "\xE2", # small a, circumflex accent
+ "AElig" => "\xC6", # capital AE diphthong (ligature)
+ "aelig" => "\xE6", # small ae diphthong (ligature)
+ "Agrave" => "\xC0", # capital A, grave accent
+ "agrave" => "\xE0", # small a, grave accent
+ "Aring" => "\xC5", # capital A, ring
+ "aring" => "\xE5", # small a, ring
+ "Atilde" => "\xC3", # capital A, tilde
+ "atilde" => "\xE3", # small a, tilde
+ "Auml" => "\xC4", # capital A, dieresis or umlaut mark
+ "auml" => "\xE4", # small a, dieresis or umlaut mark
+ "Ccedil" => "\xC7", # capital C, cedilla
+ "ccedil" => "\xE7", # small c, cedilla
+ "Eacute" => "\xC9", # capital E, acute accent
+ "eacute" => "\xE9", # small e, acute accent
+ "Ecirc" => "\xCA", # capital E, circumflex accent
+ "ecirc" => "\xEA", # small e, circumflex accent
+ "Egrave" => "\xC8", # capital E, grave accent
+ "egrave" => "\xE8", # small e, grave accent
+ "ETH" => "\xD0", # capital Eth, Icelandic
+ "eth" => "\xF0", # small eth, Icelandic
+ "Euml" => "\xCB", # capital E, dieresis or umlaut mark
+ "euml" => "\xEB", # small e, dieresis or umlaut mark
+ "Iacute" => "\xCD", # capital I, acute accent
+ "iacute" => "\xED", # small i, acute accent
+ "Icirc" => "\xCE", # capital I, circumflex accent
+ "icirc" => "\xEE", # small i, circumflex accent
+ "Igrave" => "\xCD", # capital I, grave accent
+ "igrave" => "\xED", # small i, grave accent
+ "Iuml" => "\xCF", # capital I, dieresis or umlaut mark
+ "iuml" => "\xEF", # small i, dieresis or umlaut mark
+ "Ntilde" => "\xD1", # capital N, tilde
+ "ntilde" => "\xF1", # small n, tilde
+ "Oacute" => "\xD3", # capital O, acute accent
+ "oacute" => "\xF3", # small o, acute accent
+ "Ocirc" => "\xD4", # capital O, circumflex accent
+ "ocirc" => "\xF4", # small o, circumflex accent
+ "Ograve" => "\xD2", # capital O, grave accent
+ "ograve" => "\xF2", # small o, grave accent
+ "Oslash" => "\xD8", # capital O, slash
+ "oslash" => "\xF8", # small o, slash
+ "Otilde" => "\xD5", # capital O, tilde
+ "otilde" => "\xF5", # small o, tilde
+ "Ouml" => "\xD6", # capital O, dieresis or umlaut mark
+ "ouml" => "\xF6", # small o, dieresis or umlaut mark
+ "szlig" => "\xDF", # small sharp s, German (sz ligature)
+ "THORN" => "\xDE", # capital THORN, Icelandic
+ "thorn" => "\xFE", # small thorn, Icelandic
+ "Uacute" => "\xDA", # capital U, acute accent
+ "uacute" => "\xFA", # small u, acute accent
+ "Ucirc" => "\xDB", # capital U, circumflex accent
+ "ucirc" => "\xFB", # small u, circumflex accent
+ "Ugrave" => "\xD9", # capital U, grave accent
+ "ugrave" => "\xF9", # small u, grave accent
+ "Uuml" => "\xDC", # capital U, dieresis or umlaut mark
+ "uuml" => "\xFC", # small u, dieresis or umlaut mark
+ "Yacute" => "\xDD", # capital Y, acute accent
+ "yacute" => "\xFD", # small y, acute accent
+ "yuml" => "\xFF", # small y, dieresis or umlaut mark
+
+ "lchevron" => "\xAB", # left chevron (double less than)
+ "rchevron" => "\xBB", # right chevron (double greater than)
+);
+
+
+############################################################################
+# Initialization
+############################################################################
+
+# Initialize the object. Must be sure to call our parent initializer.
+sub initialize {
+ my $self = shift;
+
+ $$self{alt} = 0 unless defined $$self{alt};
+ $$self{indent} = 4 unless defined $$self{indent};
+ $$self{loose} = 0 unless defined $$self{loose};
+ $$self{sentence} = 0 unless defined $$self{sentence};
+ $$self{width} = 76 unless defined $$self{width};
+
+ $$self{INDENTS} = []; # Stack of indentations.
+ $$self{MARGIN} = $$self{indent}; # Current left margin in spaces.
+
+ return $self->SUPER::initialize;
+}
+
+
+############################################################################
+# Core overrides
+############################################################################
+
+# Called for each command paragraph. Gets the command, the associated
+# paragraph, the line number, and a Pod::Paragraph object. Just dispatches
+# the command to a method named the same as the command. =cut is handled
+# internally by Pod::Parser.
+sub command {
+ my $self = shift;
+ my $command = shift;
+ return if $command eq 'pod';
+ return if ($$self{EXCLUDE} && $command ne 'end');
+ if (defined $$self{ITEM}) {
+ $self->item ("\n");
+ local $_ = "\n";
+ $self->output($_) if($command eq 'back');
+ }
+ $command = 'cmd_' . $command;
+ return $self->$command (@_);
+}
+
+# Called for a verbatim paragraph. Gets the paragraph, the line number, and
+# a Pod::Paragraph object. Just output it verbatim, but with tabs converted
+# to spaces.
+sub verbatim {
+ my $self = shift;
+ return if $$self{EXCLUDE};
+ $self->item if defined $$self{ITEM};
+ local $_ = shift;
+ return if /^\s*$/;
+ s/^(\s*\S+)/(' ' x $$self{MARGIN}) . $1/gme;
+ return $self->output($_);
+}
+
+# Called for a regular text block. Gets the paragraph, the line number, and
+# a Pod::Paragraph object. Perform interpolation and output the results.
+sub textblock {
+ my $self = shift;
+ return if $$self{EXCLUDE};
+ if($$self{VERBATIM}) {
+ $self->output($_[0]);
+ return;
+ }
+ local $_ = shift;
+ my $line = shift;
+
+ # Perform a little magic to collapse multiple L<> references. This is
+ # here mostly for backwards-compatibility. We'll just rewrite the whole
+ # thing into actual text at this part, bypassing the whole internal
+ # sequence parsing thing.
+ s{
+ (
+ L< # A link of the form L</something>.
+ /
+ (
+ [:\w]+ # The item has to be a simple word...
+ (\(\))? # ...or simple function.
+ )
+ >
+ (
+ ,?\s+(and\s+)? # Allow lots of them, conjuncted.
+ L<
+ /
+ (
+ [:\w]+
+ (\(\))?
+ )
+ >
+ )+
+ )
+ } {
+ local $_ = $1;
+ s%L</([^>]+)>%$1%g;
+ my @items = split /(?:,?\s+(?:and\s+)?)/;
+ my $string = "the ";
+ my $i;
+ for ($i = 0; $i < @items; $i++) {
+ $string .= $items[$i];
+ $string .= ", " if @items > 2 && $i != $#items;
+ $string .= " and " if ($i == $#items - 1);
+ }
+ $string .= " entries elsewhere in this document";
+ $string;
+ }gex;
+
+ # Now actually interpolate and output the paragraph.
+ $_ = $self->interpolate ($_, $line);
+ s/\s*$/\n/s;
+ if (defined $$self{ITEM}) {
+ $self->item ($_ . "\n");
+ } else {
+ $self->output ($self->reformat ($_ . "\n"));
+ }
+}
+
+# Called for an interior sequence. Gets the command, argument, and a
+# Pod::InteriorSequence object and is expected to return the resulting text.
+# Calls code, bold, italic, file, and link to handle those types of
+# sequences, and handles S<>, E<>, X<>, and Z<> directly.
+sub interior_sequence {
+ my $self = shift;
+ my $command = shift;
+ local $_ = shift;
+ return '' if ($command eq 'X' || $command eq 'Z');
+
+ # Expand escapes into the actual character now, carping if invalid.
+ if ($command eq 'E') {
+ return $ESCAPES{$_} if defined $ESCAPES{$_};
+ carp "Unknown escape: E<$_>";
+ return "E<$_>";
+ }
+
+ # For all the other sequences, empty content produces no output.
+ return if $_ eq '';
+
+ # For S<>, compress all internal whitespace and then map spaces to \01.
+ # When we output the text, we'll map this back.
+ if ($command eq 'S') {
+ s/\s{2,}/ /g;
+ tr/ /\01/;
+ return $_;
+ }
+
+ # Anything else needs to get dispatched to another method.
+ if ($command eq 'B') { return $self->seq_b ($_) }
+ elsif ($command eq 'C') { return $self->seq_c ($_) }
+ elsif ($command eq 'F') { return $self->seq_f ($_) }
+ elsif ($command eq 'I') { return $self->seq_i ($_) }
+ elsif ($command eq 'L') { return $self->seq_l ($_) }
+ else { carp "Unknown sequence $command<$_>" }
+}
+
+# Called for each paragraph that's actually part of the POD. We take
+# advantage of this opportunity to untabify the input.
+sub preprocess_paragraph {
+ my $self = shift;
+ local $_ = shift;
+ 1 while s/^(.*?)(\t+)/$1 . ' ' x (length ($2) * 8 - length ($1) % 8)/me;
+ return $_;
+}
+
+
+############################################################################
+# Command paragraphs
+############################################################################
+
+# All command paragraphs take the paragraph and the line number.
+
+# First level heading.
+sub cmd_head1 {
+ my $self = shift;
+ local $_ = shift;
+ s/\s+$//s;
+ $_ = $self->interpolate ($_, shift);
+ if ($$self{alt}) {
+ $self->output ("\n==== $_ ====\n\n");
+ } else {
+ $_ .= "\n" if $$self{loose};
+ $self->output ($_ . "\n");
+ }
+}
+
+# Second level heading.
+sub cmd_head2 {
+ my $self = shift;
+ local $_ = shift;
+ s/\s+$//s;
+ $_ = $self->interpolate ($_, shift);
+ if ($$self{alt}) {
+ $self->output ("\n== $_ ==\n\n");
+ } else {
+ $_ .= "\n" if $$self{loose};
+ $self->output (' ' x ($$self{indent} / 2) . $_ . "\n");
+ }
+}
+
+# third level heading - not strictly perlpodspec compliant
+sub cmd_head3 {
+ my $self = shift;
+ local $_ = shift;
+ s/\s+$//s;
+ $_ = $self->interpolate ($_, shift);
+ if ($$self{alt}) {
+ $self->output ("\n= $_ =\n");
+ } else {
+ $_ .= "\n" if $$self{loose};
+ $self->output (' ' x ($$self{indent}) . $_ . "\n");
+ }
+}
+
+# fourth level heading - not strictly perlpodspec compliant
+# just like head3
+*cmd_head4 = \&cmd_head3;
+
+# Start a list.
+sub cmd_over {
+ my $self = shift;
+ local $_ = shift;
+ unless (/^[-+]?\d+\s+$/) { $_ = $$self{indent} }
+ push (@{ $$self{INDENTS} }, $$self{MARGIN});
+ $$self{MARGIN} += ($_ + 0);
+}
+
+# End a list.
+sub cmd_back {
+ my $self = shift;
+ $$self{MARGIN} = pop @{ $$self{INDENTS} };
+ unless (defined $$self{MARGIN}) {
+ carp 'Unmatched =back';
+ $$self{MARGIN} = $$self{indent};
+ }
+}
+
+# An individual list item.
+sub cmd_item {
+ my $self = shift;
+ if (defined $$self{ITEM}) { $self->item }
+ local $_ = shift;
+ s/\s+$//s;
+ $$self{ITEM} = $self->interpolate ($_);
+}
+
+# Begin a block for a particular translator. Setting VERBATIM triggers
+# special handling in textblock().
+sub cmd_begin {
+ my $self = shift;
+ local $_ = shift;
+ my ($kind) = /^(\S+)/ or return;
+ if ($kind eq 'text') {
+ $$self{VERBATIM} = 1;
+ } else {
+ $$self{EXCLUDE} = 1;
+ }
+}
+
+# End a block for a particular translator. We assume that all =begin/=end
+# pairs are properly closed.
+sub cmd_end {
+ my $self = shift;
+ $$self{EXCLUDE} = 0;
+ $$self{VERBATIM} = 0;
+}
+
+# One paragraph for a particular translator. Ignore it unless it's intended
+# for text, in which case we treat it as a verbatim text block.
+sub cmd_for {
+ my $self = shift;
+ local $_ = shift;
+ my $line = shift;
+ return unless s/^text\b[ \t]*\n?//;
+ $self->verbatim ($_, $line);
+}
+
+
+############################################################################
+# Interior sequences
+############################################################################
+
+# The simple formatting ones. These are here mostly so that subclasses can
+# override them and do more complicated things.
+sub seq_b { return $_[0]{alt} ? "``$_[1]''" : $_[1] }
+sub seq_c { return $_[0]{alt} ? "``$_[1]''" : "`$_[1]'" }
+sub seq_f { return $_[0]{alt} ? "\"$_[1]\"" : $_[1] }
+sub seq_i { return '*' . $_[1] . '*' }
+
+# The complicated one. Handle links. Since this is plain text, we can't
+# actually make any real links, so this is all to figure out what text we
+# print out.
+sub seq_l {
+ my $self = shift;
+ local $_ = shift;
+
+ # Smash whitespace in case we were split across multiple lines.
+ s/\s+/ /g;
+
+ # If we were given any explicit text, just output it.
+ if (/^([^|]+)\|/) { return $1 }
+
+ # Okay, leading and trailing whitespace isn't important; get rid of it.
+ s/^\s+//;
+ s/\s+$//;
+
+ # Default to using the whole content of the link entry as a section
+ # name. Note that L<manpage/> forces a manpage interpretation, as does
+ # something looking like L<manpage(section)>. The latter is an
+ # enhancement over the original Pod::Text.
+ my ($manpage, $section) = ('', $_);
+ if (/^(?:https?|ftp|news):/) {
+ # a URL
+ return $_;
+ } elsif (/^"\s*(.*?)\s*"$/) {
+ $section = '"' . $1 . '"';
+ } elsif (m/^[-:.\w]+(?:\(\S+\))?$/) {
+ ($manpage, $section) = ($_, '');
+ } elsif (m{/}) {
+ ($manpage, $section) = split (/\s*\/\s*/, $_, 2);
+ }
+
+ my $text = '';
+ # Now build the actual output text.
+ if (!length $section) {
+ $text = "the $manpage manpage" if length $manpage;
+ } elsif ($section =~ /^[:\w]+(?:\(\))?/) {
+ $text .= 'the ' . $section . ' entry';
+ $text .= (length $manpage) ? " in the $manpage manpage"
+ : ' elsewhere in this document';
+ } else {
+ $section =~ s/^\"\s*//;
+ $section =~ s/\s*\"$//;
+ $text .= 'the section on "' . $section . '"';
+ $text .= " in the $manpage manpage" if length $manpage;
+ }
+ return $text;
+}
+
+
+############################################################################
+# List handling
+############################################################################
+
+# This method is called whenever an =item command is complete (in other
+# words, we've seen its associated paragraph or know for certain that it
+# doesn't have one). It gets the paragraph associated with the item as an
+# argument. If that argument is empty, just output the item tag; if it
+# contains a newline, output the item tag followed by the newline.
+# Otherwise, see if there's enough room for us to output the item tag in the
+# margin of the text or if we have to put it on a separate line.
+sub item {
+ my $self = shift;
+ local $_ = shift;
+ my $tag = $$self{ITEM};
+ unless (defined $tag) {
+ carp 'item called without tag';
+ return;
+ }
+ undef $$self{ITEM};
+ my $indent = $$self{INDENTS}[-1];
+ unless (defined $indent) { $indent = $$self{indent} }
+ my $space = ' ' x $indent;
+ $space =~ s/^ /:/ if $$self{alt};
+ if (!$_ || /^\s+$/ || ($$self{MARGIN} - $indent < length ($tag) + 1)) {
+ my $margin = $$self{MARGIN};
+ $$self{MARGIN} = $indent;
+ my $output = $self->reformat ($tag);
+ $output =~ s/\n*$/\n/;
+ $self->output ($output);
+ $$self{MARGIN} = $margin;
+ $self->output ($self->reformat ($_)) if /\S/;
+ } else {
+ $_ = $self->reformat ($_);
+ s/^ /:/ if ($$self{alt} && $indent > 0);
+ my $tagspace = ' ' x length $tag;
+ s/^($space)$tagspace/$1$tag/ or carp 'Bizarre space in item';
+ $self->output ($_);
+ }
+}
+
+
+############################################################################
+# Output formatting
+############################################################################
+
+# Wrap a line, indenting by the current left margin. We can't use
+# Text::Wrap because it plays games with tabs. We can't use formline, even
+# though we'd really like to, because it screws up non-printing characters.
+# So we have to do the wrapping ourselves.
+sub wrap {
+ my $self = shift;
+ local $_ = shift;
+ my $output = '';
+ my $spaces = ' ' x $$self{MARGIN};
+ my $width = $$self{width} - $$self{MARGIN};
+ while (length > $width) {
+ if (s/^([^\n]{0,$width})\s+// || s/^([^\n]{$width})//) {
+ $output .= $spaces . $1 . "\n";
+ } else {
+ last;
+ }
+ }
+ $output .= $spaces . $_;
+ $output =~ s/\s+$/\n\n/;
+ return $output;
+}
+
+# Reformat a paragraph of text for the current margin. Takes the text to
+# reformat and returns the formatted text.
+sub reformat {
+ my $self = shift;
+ local $_ = shift;
+
+ # If we're trying to preserve two spaces after sentences, do some
+ # munging to support that. Otherwise, smash all repeated whitespace.
+ if ($$self{sentence}) {
+ s/ +$//mg;
+ s/\.\n/. \n/g;
+ s/\n/ /g;
+ s/ +/ /g;
+ } else {
+ s/\s+/ /g;
+ }
+ return $self->wrap($_);
+}
+
+# Output text to the output device.
+sub output { $_[1] =~ tr/\01/ /; print { $_[0]->output_handle } $_[1] }
+
+
+############################################################################
+# Backwards compatibility
+############################################################################
+
+# The old Pod::Text module did everything in a pod2text() function. This
+# tries to provide the same interface for legacy applications.
+sub pod2text {
+ my @args;
+
+ # This is really ugly; I hate doing option parsing in the middle of a
+ # module. But the old Pod::Text module supported passing flags to its
+ # entry function, so handle -a and -<number>.
+ while ($_[0] =~ /^-/) {
+ my $flag = shift;
+ if ($flag eq '-a') { push (@args, alt => 1) }
+ elsif ($flag =~ /^-(\d+)$/) { push (@args, width => $1) }
+ else {
+ unshift (@_, $flag);
+ last;
+ }
+ }
+
+ # Now that we know what arguments we're using, create the parser.
+ my $parser = Pod::PlainText->new (@args);
+
+ # If two arguments were given, the second argument is going to be a file
+ # handle. That means we want to call parse_from_filehandle(), which
+ # means we need to turn the first argument into a file handle. Magic
+ # open will handle the <&STDIN case automagically.
+ if (defined $_[1]) {
+ my $infh;
+ if ($] < 5.006) {
+ $infh = gensym();
+ }
+ unless (open ($infh, $_[0])) {
+ croak ("Can't open $_[0] for reading: $!\n");
+ }
+ $_[0] = $infh;
+ return $parser->parse_from_filehandle (@_);
+ } else {
+ return $parser->parse_from_file (@_);
+ }
+}
+
+
+############################################################################
+# Module return value and documentation
+############################################################################
+
+1;
+__END__
+
+=head1 NAME
+
+Pod::PlainText - Convert POD data to formatted ASCII text
+
+=head1 SYNOPSIS
+
+ use Pod::PlainText;
+ my $parser = Pod::PlainText->new (sentence => 0, width => 78);
+
+ # Read POD from STDIN and write to STDOUT.
+ $parser->parse_from_filehandle;
+
+ # Read POD from file.pod and write to file.txt.
+ $parser->parse_from_file ('file.pod', 'file.txt');
+
+=head1 DESCRIPTION
+
+Pod::PlainText is a module that can convert documentation in the POD format (the
+preferred language for documenting Perl) into formatted ASCII. It uses no
+special formatting controls or codes whatsoever, and its output is therefore
+suitable for nearly any device.
+
+As a derived class from Pod::Parser, Pod::PlainText supports the same methods and
+interfaces. See L<Pod::Parser> for all the details; briefly, one creates a
+new parser with C<Pod::PlainText-E<gt>new()> and then calls either
+parse_from_filehandle() or parse_from_file().
+
+new() can take options, in the form of key/value pairs, that control the
+behavior of the parser. The currently recognized options are:
+
+=over 4
+
+=item alt
+
+If set to a true value, selects an alternate output format that, among other
+things, uses a different heading style and marks C<=item> entries with a
+colon in the left margin. Defaults to false.
+
+=item indent
+
+The number of spaces to indent regular text, and the default indentation for
+C<=over> blocks. Defaults to 4.
+
+=item loose
+
+If set to a true value, a blank line is printed after a C<=headN> headings.
+If set to false (the default), no blank line is printed after C<=headN>.
+This is the default because it's the expected formatting for manual pages;
+if you're formatting arbitrary text documents, setting this to true may
+result in more pleasing output.
+
+=item sentence
+
+If set to a true value, Pod::PlainText will assume that each sentence ends in two
+spaces, and will try to preserve that spacing. If set to false, all
+consecutive whitespace in non-verbatim paragraphs is compressed into a
+single space. Defaults to true.
+
+=item width
+
+The column at which to wrap text on the right-hand side. Defaults to 76.
+
+=back
+
+The standard Pod::Parser method parse_from_filehandle() takes up to two
+arguments, the first being the file handle to read POD from and the second
+being the file handle to write the formatted output to. The first defaults
+to STDIN if not given, and the second defaults to STDOUT. The method
+parse_from_file() is almost identical, except that its two arguments are the
+input and output disk files instead. See L<Pod::Parser> for the specific
+details.
+
+=head1 DIAGNOSTICS
+
+=over 4
+
+=item Bizarre space in item
+
+(W) Something has gone wrong in internal C<=item> processing. This message
+indicates a bug in Pod::PlainText; you should never see it.
+
+=item Can't open %s for reading: %s
+
+(F) Pod::PlainText was invoked via the compatibility mode pod2text() interface
+and the input file it was given could not be opened.
+
+=item Unknown escape: %s
+
+(W) The POD source contained an C<EE<lt>E<gt>> escape that Pod::PlainText didn't
+know about.
+
+=item Unknown sequence: %s
+
+(W) The POD source contained a non-standard internal sequence (something of
+the form C<XE<lt>E<gt>>) that Pod::PlainText didn't know about.
+
+=item Unmatched =back
+
+(W) Pod::PlainText encountered a C<=back> command that didn't correspond to an
+C<=over> command.
+
+=back
+
+=head1 RESTRICTIONS
+
+Embedded Ctrl-As (octal 001) in the input will be mapped to spaces on
+output, due to an internal implementation detail.
+
+=head1 NOTES
+
+This is a replacement for an earlier Pod::Text module written by Tom
+Christiansen. It has a revamped interface, since it now uses Pod::Parser,
+but an interface roughly compatible with the old Pod::Text::pod2text()
+function is still available. Please change to the new calling convention,
+though.
+
+The original Pod::Text contained code to do formatting via termcap
+sequences, although it wasn't turned on by default and it was problematic to
+get it to work at all. This rewrite doesn't even try to do that, but a
+subclass of it does. Look for L<Pod::Text::Termcap|Pod::Text::Termcap>.
+
+=head1 SEE ALSO
+
+L<Pod::Parser|Pod::Parser>, L<Pod::Text::Termcap|Pod::Text::Termcap>,
+pod2text(1)
+
+=head1 AUTHOR
+
+Please report bugs using L<http://rt.cpan.org>.
+
+Russ Allbery E<lt>rra at stanford.eduE<gt>, based I<very> heavily on the
+original Pod::Text by Tom Christiansen E<lt>tchrist at mox.perl.comE<gt> and
+its conversion to Pod::Parser by Brad Appleton
+E<lt>bradapp at enteract.comE<gt>.
+
+=cut
Copied: trunk/contrib/perl/lib/Pod/Plainer.pm (from rev 6437, vendor/perl/5.18.1/lib/Pod/Plainer.pm)
===================================================================
--- trunk/contrib/perl/lib/Pod/Plainer.pm (rev 0)
+++ trunk/contrib/perl/lib/Pod/Plainer.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,69 @@
+package Pod::Plainer;
+use strict;
+use Pod::Parser;
+our @ISA = qw(Pod::Parser);
+our $VERSION = '0.01';
+
+our %E = qw( < lt > gt );
+
+sub escape_ltgt {
+ (undef, my $text) = @_;
+ $text =~ s/([<>])/E<$E{$1}>/g;
+ $text
+}
+
+sub simple_delimiters {
+ (undef, my $seq) = @_;
+ $seq -> left_delimiter( '<' );
+ $seq -> right_delimiter( '>' );
+ $seq;
+}
+
+sub textblock {
+ my($parser,$text,$line) = @_;
+ print {$parser->output_handle()}
+ $parser->parse_text(
+ { -expand_text => q(escape_ltgt),
+ -expand_seq => q(simple_delimiters) },
+ $text, $line ) -> raw_text();
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Pod::Plainer - Perl extension for converting Pod to old style Pod.
+
+=head1 SYNOPSIS
+
+ use Pod::Plainer;
+
+ my $parser = Pod::Plainer -> new ();
+ $parser -> parse_from_filehandle(\*STDIN);
+
+=head1 DESCRIPTION
+
+Pod::Plainer uses Pod::Parser which takes Pod with the (new)
+'CE<lt>E<lt> .. E<gt>E<gt>' constructs
+and returns the old(er) style with just 'CE<lt>E<gt>';
+'<' and '>' are replaced by 'EE<lt>ltE<gt>' and 'EE<lt>gtE<gt>'.
+
+This can be used to pre-process Pod before using tools which do not
+recognise the new style Pods.
+
+=head2 EXPORT
+
+None by default.
+
+=head1 AUTHOR
+
+Robin Barker, rmb1 at cise.npl.co.uk
+
+=head1 SEE ALSO
+
+See L<Pod::Parser>.
+
+=cut
+
Copied: trunk/contrib/perl/lib/Pod/Select.pm (from rev 6437, vendor/perl/5.18.1/lib/Pod/Select.pm)
===================================================================
--- trunk/contrib/perl/lib/Pod/Select.pm (rev 0)
+++ trunk/contrib/perl/lib/Pod/Select.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,746 @@
+#############################################################################
+# Pod/Select.pm -- function to select portions of POD docs
+#
+# Copyright (C) 1996-2000 by Bradford Appleton. All rights reserved.
+# This file is part of "PodParser". PodParser is free software;
+# you can redistribute it and/or modify it under the same terms
+# as Perl itself.
+#############################################################################
+
+package Pod::Select;
+use strict;
+
+use vars qw($VERSION @ISA @EXPORT $MAX_HEADING_LEVEL %myData @section_headings @selected_sections);
+$VERSION = '1.36'; ## Current version of this package
+require 5.005; ## requires this Perl version or later
+
+#############################################################################
+
+=head1 NAME
+
+Pod::Select, podselect() - extract selected sections of POD from input
+
+=head1 SYNOPSIS
+
+ use Pod::Select;
+
+ ## Select all the POD sections for each file in @filelist
+ ## and print the result on standard output.
+ podselect(@filelist);
+
+ ## Same as above, but write to tmp.out
+ podselect({-output => "tmp.out"}, @filelist):
+
+ ## Select from the given filelist, only those POD sections that are
+ ## within a 1st level section named any of: NAME, SYNOPSIS, OPTIONS.
+ podselect({-sections => ["NAME|SYNOPSIS", "OPTIONS"]}, @filelist):
+
+ ## Select the "DESCRIPTION" section of the PODs from STDIN and write
+ ## the result to STDERR.
+ podselect({-output => ">&STDERR", -sections => ["DESCRIPTION"]}, \*STDIN);
+
+or
+
+ use Pod::Select;
+
+ ## Create a parser object for selecting POD sections from the input
+ $parser = new Pod::Select();
+
+ ## Select all the POD sections for each file in @filelist
+ ## and print the result to tmp.out.
+ $parser->parse_from_file("<&STDIN", "tmp.out");
+
+ ## Select from the given filelist, only those POD sections that are
+ ## within a 1st level section named any of: NAME, SYNOPSIS, OPTIONS.
+ $parser->select("NAME|SYNOPSIS", "OPTIONS");
+ for (@filelist) { $parser->parse_from_file($_); }
+
+ ## Select the "DESCRIPTION" and "SEE ALSO" sections of the PODs from
+ ## STDIN and write the result to STDERR.
+ $parser->select("DESCRIPTION");
+ $parser->add_selection("SEE ALSO");
+ $parser->parse_from_filehandle(\*STDIN, \*STDERR);
+
+=head1 REQUIRES
+
+perl5.005, Pod::Parser, Exporter, Carp
+
+=head1 EXPORTS
+
+podselect()
+
+=head1 DESCRIPTION
+
+B<podselect()> is a function which will extract specified sections of
+pod documentation from an input stream. This ability is provided by the
+B<Pod::Select> module which is a subclass of B<Pod::Parser>.
+B<Pod::Select> provides a method named B<select()> to specify the set of
+POD sections to select for processing/printing. B<podselect()> merely
+creates a B<Pod::Select> object and then invokes the B<podselect()>
+followed by B<parse_from_file()>.
+
+=head1 SECTION SPECIFICATIONS
+
+B<podselect()> and B<Pod::Select::select()> may be given one or more
+"section specifications" to restrict the text processed to only the
+desired set of sections and their corresponding subsections. A section
+specification is a string containing one or more Perl-style regular
+expressions separated by forward slashes ("/"). If you need to use a
+forward slash literally within a section title you can escape it with a
+backslash ("\/").
+
+The formal syntax of a section specification is:
+
+=over 4
+
+=item *
+
+I<head1-title-regex>/I<head2-title-regex>/...
+
+=back
+
+Any omitted or empty regular expressions will default to ".*".
+Please note that each regular expression given is implicitly
+anchored by adding "^" and "$" to the beginning and end. Also, if a
+given regular expression starts with a "!" character, then the
+expression is I<negated> (so C<!foo> would match anything I<except>
+C<foo>).
+
+Some example section specifications follow.
+
+=over 4
+
+=item *
+
+Match the C<NAME> and C<SYNOPSIS> sections and all of their subsections:
+
+C<NAME|SYNOPSIS>
+
+=item *
+
+Match only the C<Question> and C<Answer> subsections of the C<DESCRIPTION>
+section:
+
+C<DESCRIPTION/Question|Answer>
+
+=item *
+
+Match the C<Comments> subsection of I<all> sections:
+
+C</Comments>
+
+=item *
+
+Match all subsections of C<DESCRIPTION> I<except> for C<Comments>:
+
+C<DESCRIPTION/!Comments>
+
+=item *
+
+Match the C<DESCRIPTION> section but do I<not> match any of its subsections:
+
+C<DESCRIPTION/!.+>
+
+=item *
+
+Match all top level sections but none of their subsections:
+
+C</!.+>
+
+=back
+
+=begin _NOT_IMPLEMENTED_
+
+=head1 RANGE SPECIFICATIONS
+
+B<podselect()> and B<Pod::Select::select()> may be given one or more
+"range specifications" to restrict the text processed to only the
+desired ranges of paragraphs in the desired set of sections. A range
+specification is a string containing a single Perl-style regular
+expression (a regex), or else two Perl-style regular expressions
+(regexs) separated by a ".." (Perl's "range" operator is "..").
+The regexs in a range specification are delimited by forward slashes
+("/"). If you need to use a forward slash literally within a regex you
+can escape it with a backslash ("\/").
+
+The formal syntax of a range specification is:
+
+=over 4
+
+=item *
+
+/I<start-range-regex>/[../I<end-range-regex>/]
+
+=back
+
+Where each the item inside square brackets (the ".." followed by the
+end-range-regex) is optional. Each "range-regex" is of the form:
+
+ =cmd-expr text-expr
+
+Where I<cmd-expr> is intended to match the name of one or more POD
+commands, and I<text-expr> is intended to match the paragraph text for
+the command. If a range-regex is supposed to match a POD command, then
+the first character of the regex (the one after the initial '/')
+absolutely I<must> be a single '=' character; it may not be anything
+else (not even a regex meta-character) if it is supposed to match
+against the name of a POD command.
+
+If no I<=cmd-expr> is given then the text-expr will be matched against
+plain textblocks unless it is preceded by a space, in which case it is
+matched against verbatim text-blocks. If no I<text-expr> is given then
+only the command-portion of the paragraph is matched against.
+
+Note that these two expressions are each implicitly anchored. This
+means that when matching against the command-name, there will be an
+implicit '^' and '$' around the given I<=cmd-expr>; and when matching
+against the paragraph text there will be an implicit '\A' and '\Z'
+around the given I<text-expr>.
+
+Unlike with section-specs, the '!' character does I<not> have any special
+meaning (negation or otherwise) at the beginning of a range-spec!
+
+Some example range specifications follow.
+
+=over 4
+
+=item
+Match all C<=for html> paragraphs:
+
+C</=for html/>
+
+=item
+Match all paragraphs between C<=begin html> and C<=end html>
+(note that this will I<not> work correctly if such sections
+are nested):
+
+C</=begin html/../=end html/>
+
+=item
+Match all paragraphs between the given C<=item> name until the end of the
+current section:
+
+C</=item mine/../=head\d/>
+
+=item
+Match all paragraphs between the given C<=item> until the next item, or
+until the end of the itemized list (note that this will I<not> work as
+desired if the item contains an itemized list nested within it):
+
+C</=item mine/../=(item|back)/>
+
+=back
+
+=end _NOT_IMPLEMENTED_
+
+=cut
+
+#############################################################################
+
+#use diagnostics;
+use Carp;
+use Pod::Parser 1.04;
+
+ at ISA = qw(Pod::Parser);
+ at EXPORT = qw(&podselect);
+
+## Maximum number of heading levels supported for '=headN' directives
+*MAX_HEADING_LEVEL = \3;
+
+#############################################################################
+
+=head1 OBJECT METHODS
+
+The following methods are provided in this module. Each one takes a
+reference to the object itself as an implicit first parameter.
+
+=cut
+
+##---------------------------------------------------------------------------
+
+## =begin _PRIVATE_
+##
+## =head1 B<_init_headings()>
+##
+## Initialize the current set of active section headings.
+##
+## =cut
+##
+## =end _PRIVATE_
+
+sub _init_headings {
+ my $self = shift;
+ local *myData = $self;
+
+ ## Initialize current section heading titles if necessary
+ unless (defined $myData{_SECTION_HEADINGS}) {
+ local *section_headings = $myData{_SECTION_HEADINGS} = [];
+ for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) {
+ $section_headings[$i] = '';
+ }
+ }
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<curr_headings()>
+
+ ($head1, $head2, $head3, ...) = $parser->curr_headings();
+ $head1 = $parser->curr_headings(1);
+
+This method returns a list of the currently active section headings and
+subheadings in the document being parsed. The list of headings returned
+corresponds to the most recently parsed paragraph of the input.
+
+If an argument is given, it must correspond to the desired section
+heading number, in which case only the specified section heading is
+returned. If there is no current section heading at the specified
+level, then C<undef> is returned.
+
+=cut
+
+sub curr_headings {
+ my $self = shift;
+ $self->_init_headings() unless (defined $self->{_SECTION_HEADINGS});
+ my @headings = @{ $self->{_SECTION_HEADINGS} };
+ return (@_ > 0 and $_[0] =~ /^\d+$/) ? $headings[$_[0] - 1] : @headings;
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<select()>
+
+ $parser->select($section_spec1,$section_spec2,...);
+
+This method is used to select the particular sections and subsections of
+POD documentation that are to be printed and/or processed. The existing
+set of selected sections is I<replaced> with the given set of sections.
+See B<add_selection()> for adding to the current set of selected
+sections.
+
+Each of the C<$section_spec> arguments should be a section specification
+as described in L<"SECTION SPECIFICATIONS">. The section specifications
+are parsed by this method and the resulting regular expressions are
+stored in the invoking object.
+
+If no C<$section_spec> arguments are given, then the existing set of
+selected sections is cleared out (which means C<all> sections will be
+processed).
+
+This method should I<not> normally be overridden by subclasses.
+
+=cut
+
+sub select {
+ my ($self, @sections) = @_;
+ local *myData = $self;
+ local $_;
+
+### NEED TO DISCERN A SECTION-SPEC FROM A RANGE-SPEC (look for m{^/.+/$}?)
+
+ ##---------------------------------------------------------------------
+ ## The following is a blatant hack for backward compatibility, and for
+ ## implementing add_selection(). If the *first* *argument* is the
+ ## string "+", then the remaining section specifications are *added*
+ ## to the current set of selections; otherwise the given section
+ ## specifications will *replace* the current set of selections.
+ ##
+ ## This should probably be fixed someday, but for the present time,
+ ## it seems incredibly unlikely that "+" would ever correspond to
+ ## a legitimate section heading
+ ##---------------------------------------------------------------------
+ my $add = ($sections[0] eq '+') ? shift(@sections) : '';
+
+ ## Reset the set of sections to use
+ unless (@sections) {
+ delete $myData{_SELECTED_SECTIONS} unless ($add);
+ return;
+ }
+ $myData{_SELECTED_SECTIONS} = []
+ unless ($add && exists $myData{_SELECTED_SECTIONS});
+ local *selected_sections = $myData{_SELECTED_SECTIONS};
+
+ ## Compile each spec
+ for my $spec (@sections) {
+ if ( defined($_ = _compile_section_spec($spec)) ) {
+ ## Store them in our sections array
+ push(@selected_sections, $_);
+ }
+ else {
+ carp qq{Ignoring section spec "$spec"!\n};
+ }
+ }
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<add_selection()>
+
+ $parser->add_selection($section_spec1,$section_spec2,...);
+
+This method is used to add to the currently selected sections and
+subsections of POD documentation that are to be printed and/or
+processed. See <select()> for replacing the currently selected sections.
+
+Each of the C<$section_spec> arguments should be a section specification
+as described in L<"SECTION SPECIFICATIONS">. The section specifications
+are parsed by this method and the resulting regular expressions are
+stored in the invoking object.
+
+This method should I<not> normally be overridden by subclasses.
+
+=cut
+
+sub add_selection {
+ my $self = shift;
+ return $self->select('+', @_);
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<clear_selections()>
+
+ $parser->clear_selections();
+
+This method takes no arguments, it has the exact same effect as invoking
+<select()> with no arguments.
+
+=cut
+
+sub clear_selections {
+ my $self = shift;
+ return $self->select();
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<match_section()>
+
+ $boolean = $parser->match_section($heading1,$heading2,...);
+
+Returns a value of true if the given section and subsection heading
+titles match any of the currently selected section specifications in
+effect from prior calls to B<select()> and B<add_selection()> (or if
+there are no explicitly selected/deselected sections).
+
+The arguments C<$heading1>, C<$heading2>, etc. are the heading titles of
+the corresponding sections, subsections, etc. to try and match. If
+C<$headingN> is omitted then it defaults to the current corresponding
+section heading title in the input.
+
+This method should I<not> normally be overridden by subclasses.
+
+=cut
+
+sub match_section {
+ my $self = shift;
+ my (@headings) = @_;
+ local *myData = $self;
+
+ ## Return true if no restrictions were explicitly specified
+ my $selections = (exists $myData{_SELECTED_SECTIONS})
+ ? $myData{_SELECTED_SECTIONS} : undef;
+ return 1 unless ((defined $selections) && @{$selections});
+
+ ## Default any unspecified sections to the current one
+ my @current_headings = $self->curr_headings();
+ for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) {
+ (defined $headings[$i]) or $headings[$i] = $current_headings[$i];
+ }
+
+ ## Look for a match against the specified section expressions
+ for my $section_spec ( @{$selections} ) {
+ ##------------------------------------------------------
+ ## Each portion of this spec must match in order for
+ ## the spec to be matched. So we will start with a
+ ## match-value of 'true' and logically 'and' it with
+ ## the results of matching a given element of the spec.
+ ##------------------------------------------------------
+ my $match = 1;
+ for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) {
+ my $regex = $section_spec->[$i];
+ my $negated = ($regex =~ s/^\!//);
+ $match &= ($negated ? ($headings[$i] !~ /${regex}/)
+ : ($headings[$i] =~ /${regex}/));
+ last unless ($match);
+ }
+ return 1 if ($match);
+ }
+ return 0; ## no match
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<is_selected()>
+
+ $boolean = $parser->is_selected($paragraph);
+
+This method is used to determine if the block of text given in
+C<$paragraph> falls within the currently selected set of POD sections
+and subsections to be printed or processed. This method is also
+responsible for keeping track of the current input section and
+subsections. It is assumed that C<$paragraph> is the most recently read
+(but not yet processed) input paragraph.
+
+The value returned will be true if the C<$paragraph> and the rest of the
+text in the same section as C<$paragraph> should be selected (included)
+for processing; otherwise a false value is returned.
+
+=cut
+
+sub is_selected {
+ my ($self, $paragraph) = @_;
+ local $_;
+ local *myData = $self;
+
+ $self->_init_headings() unless (defined $myData{_SECTION_HEADINGS});
+
+ ## Keep track of current sections levels and headings
+ $_ = $paragraph;
+ if (/^=((?:sub)*)(?:head(?:ing)?|sec(?:tion)?)(\d*)\s+(.*?)\s*$/)
+ {
+ ## This is a section heading command
+ my ($level, $heading) = ($2, $3);
+ $level = 1 + (length($1) / 3) if ((! length $level) || (length $1));
+ ## Reset the current section heading at this level
+ $myData{_SECTION_HEADINGS}->[$level - 1] = $heading;
+ ## Reset subsection headings of this one to empty
+ for (my $i = $level; $i < $MAX_HEADING_LEVEL; ++$i) {
+ $myData{_SECTION_HEADINGS}->[$i] = '';
+ }
+ }
+
+ return $self->match_section();
+}
+
+#############################################################################
+
+=head1 EXPORTED FUNCTIONS
+
+The following functions are exported by this module. Please note that
+these are functions (not methods) and therefore C<do not> take an
+implicit first argument.
+
+=cut
+
+##---------------------------------------------------------------------------
+
+=head1 B<podselect()>
+
+ podselect(\%options, at filelist);
+
+B<podselect> will print the raw (untranslated) POD paragraphs of all
+POD sections in the given input files specified by C<@filelist>
+according to the given options.
+
+If any argument to B<podselect> is a reference to a hash
+(associative array) then the values with the following keys are
+processed as follows:
+
+=over 4
+
+=item B<-output>
+
+A string corresponding to the desired output file (or ">&STDOUT"
+or ">&STDERR"). The default is to use standard output.
+
+=item B<-sections>
+
+A reference to an array of sections specifications (as described in
+L<"SECTION SPECIFICATIONS">) which indicate the desired set of POD
+sections and subsections to be selected from input. If no section
+specifications are given, then all sections of the PODs are used.
+
+=begin _NOT_IMPLEMENTED_
+
+=item B<-ranges>
+
+A reference to an array of range specifications (as described in
+L<"RANGE SPECIFICATIONS">) which indicate the desired range of POD
+paragraphs to be selected from the desired input sections. If no range
+specifications are given, then all paragraphs of the desired sections
+are used.
+
+=end _NOT_IMPLEMENTED_
+
+=back
+
+All other arguments should correspond to the names of input files
+containing POD sections. A file name of "-" or "<&STDIN" will
+be interpreted to mean standard input (which is the default if no
+filenames are given).
+
+=cut
+
+sub podselect {
+ my(@argv) = @_;
+ my %defaults = ();
+ my $pod_parser = new Pod::Select(%defaults);
+ my $num_inputs = 0;
+ my $output = '>&STDOUT';
+ my %opts;
+ local $_;
+ for (@argv) {
+ if (ref($_)) {
+ next unless (ref($_) eq 'HASH');
+ %opts = (%defaults, %{$_});
+
+ ##-------------------------------------------------------------
+ ## Need this for backward compatibility since we formerly used
+ ## options that were all uppercase words rather than ones that
+ ## looked like Unix command-line options.
+ ## to be uppercase keywords)
+ ##-------------------------------------------------------------
+ %opts = map {
+ my ($key, $val) = (lc $_, $opts{$_});
+ $key =~ s/^(?=\w)/-/;
+ $key =~ /^-se[cl]/ and $key = '-sections';
+ #! $key eq '-range' and $key .= 's';
+ ($key => $val);
+ } (keys %opts);
+
+ ## Process the options
+ (exists $opts{'-output'}) and $output = $opts{'-output'};
+
+ ## Select the desired sections
+ $pod_parser->select(@{ $opts{'-sections'} })
+ if ( (defined $opts{'-sections'})
+ && ((ref $opts{'-sections'}) eq 'ARRAY') );
+
+ #! ## Select the desired paragraph ranges
+ #! $pod_parser->select(@{ $opts{'-ranges'} })
+ #! if ( (defined $opts{'-ranges'})
+ #! && ((ref $opts{'-ranges'}) eq 'ARRAY') );
+ }
+ else {
+ $pod_parser->parse_from_file($_, $output);
+ ++$num_inputs;
+ }
+ }
+ $pod_parser->parse_from_file('-') unless ($num_inputs > 0);
+}
+
+#############################################################################
+
+=head1 PRIVATE METHODS AND DATA
+
+B<Pod::Select> makes uses a number of internal methods and data fields
+which clients should not need to see or use. For the sake of avoiding
+name collisions with client data and methods, these methods and fields
+are briefly discussed here. Determined hackers may obtain further
+information about them by reading the B<Pod::Select> source code.
+
+Private data fields are stored in the hash-object whose reference is
+returned by the B<new()> constructor for this class. The names of all
+private methods and data-fields used by B<Pod::Select> begin with a
+prefix of "_" and match the regular expression C</^_\w+$/>.
+
+=cut
+
+##---------------------------------------------------------------------------
+
+=begin _PRIVATE_
+
+=head1 B<_compile_section_spec()>
+
+ $listref = $parser->_compile_section_spec($section_spec);
+
+This function (note it is a function and I<not> a method) takes a
+section specification (as described in L<"SECTION SPECIFICATIONS">)
+given in C<$section_sepc>, and compiles it into a list of regular
+expressions. If C<$section_spec> has no syntax errors, then a reference
+to the list (array) of corresponding regular expressions is returned;
+otherwise C<undef> is returned and an error message is printed (using
+B<carp>) for each invalid regex.
+
+=end _PRIVATE_
+
+=cut
+
+sub _compile_section_spec {
+ my ($section_spec) = @_;
+ my (@regexs, $negated);
+
+ ## Compile the spec into a list of regexs
+ local $_ = $section_spec;
+ s{\\\\}{\001}g; ## handle escaped backward slashes
+ s{\\/}{\002}g; ## handle escaped forward slashes
+
+ ## Parse the regexs for the heading titles
+ @regexs = split(/\//, $_, $MAX_HEADING_LEVEL);
+
+ ## Set default regex for ommitted levels
+ for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) {
+ $regexs[$i] = '.*' unless ((defined $regexs[$i])
+ && (length $regexs[$i]));
+ }
+ ## Modify the regexs as needed and validate their syntax
+ my $bad_regexs = 0;
+ for (@regexs) {
+ $_ .= '.+' if ($_ eq '!');
+ s{\001}{\\\\}g; ## restore escaped backward slashes
+ s{\002}{\\/}g; ## restore escaped forward slashes
+ $negated = s/^\!//; ## check for negation
+ eval "m{$_}"; ## check regex syntax
+ if ($@) {
+ ++$bad_regexs;
+ carp qq{Bad regular expression /$_/ in "$section_spec": $@\n};
+ }
+ else {
+ ## Add the forward and rear anchors (and put the negator back)
+ $_ = '^' . $_ unless (/^\^/);
+ $_ = $_ . '$' unless (/\$$/);
+ $_ = '!' . $_ if ($negated);
+ }
+ }
+ return (! $bad_regexs) ? [ @regexs ] : undef;
+}
+
+##---------------------------------------------------------------------------
+
+=begin _PRIVATE_
+
+=head2 $self->{_SECTION_HEADINGS}
+
+A reference to an array of the current section heading titles for each
+heading level (note that the first heading level title is at index 0).
+
+=end _PRIVATE_
+
+=cut
+
+##---------------------------------------------------------------------------
+
+=begin _PRIVATE_
+
+=head2 $self->{_SELECTED_SECTIONS}
+
+A reference to an array of references to arrays. Each subarray is a list
+of anchored regular expressions (preceded by a "!" if the expression is to
+be negated). The index of the expression in the subarray should correspond
+to the index of the heading title in C<$self-E<gt>{_SECTION_HEADINGS}>
+that it is to be matched against.
+
+=end _PRIVATE_
+
+=cut
+
+#############################################################################
+
+=head1 SEE ALSO
+
+L<Pod::Parser>
+
+=head1 AUTHOR
+
+Please report bugs using L<http://rt.cpan.org>.
+
+Brad Appleton E<lt>bradapp at enteract.comE<gt>
+
+Based on code for B<pod2text> written by
+Tom Christiansen E<lt>tchrist at mox.perl.comE<gt>
+
+=cut
+
+1;
+# vim: ts=4 sw=4 et
Copied: trunk/contrib/perl/lib/Pod/Simple.pm (from rev 6437, vendor/perl/5.18.1/lib/Pod/Simple.pm)
===================================================================
--- trunk/contrib/perl/lib/Pod/Simple.pm (rev 0)
+++ trunk/contrib/perl/lib/Pod/Simple.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,1536 @@
+
+require 5;
+package Pod::Simple;
+use strict;
+use Carp ();
+BEGIN { *DEBUG = sub () {0} unless defined &DEBUG }
+use integer;
+use Pod::Escapes 1.03 ();
+use Pod::Simple::LinkSection ();
+use Pod::Simple::BlackBox ();
+#use utf8;
+
+use vars qw(
+ $VERSION @ISA
+ @Known_formatting_codes @Known_directives
+ %Known_formatting_codes %Known_directives
+ $NL
+);
+
+ at ISA = ('Pod::Simple::BlackBox');
+$VERSION = '3.07';
+
+ at Known_formatting_codes = qw(I B C L E F S X Z);
+%Known_formatting_codes = map(($_=>1), @Known_formatting_codes);
+ at Known_directives = qw(head1 head2 head3 head4 item over back);
+%Known_directives = map(($_=>'Plain'), @Known_directives);
+$NL = $/ unless defined $NL;
+
+#-----------------------------------------------------------------------------
+# Set up some constants:
+
+BEGIN {
+ if(defined &ASCII) { }
+ elsif(chr(65) eq 'A') { *ASCII = sub () {1} }
+ else { *ASCII = sub () {''} }
+
+ unless(defined &MANY_LINES) { *MANY_LINES = sub () {20} }
+ DEBUG > 4 and print "MANY_LINES is ", MANY_LINES(), "\n";
+ unless(MANY_LINES() >= 1) {
+ die "MANY_LINES is too small (", MANY_LINES(), ")!\nAborting";
+ }
+ if(defined &UNICODE) { }
+ elsif($] >= 5.008) { *UNICODE = sub() {1} }
+ else { *UNICODE = sub() {''} }
+}
+if(DEBUG > 2) {
+ print "# We are ", ASCII ? '' : 'not ', "in ASCII-land\n";
+ print "# We are under a Unicode-safe Perl.\n";
+}
+
+# Design note:
+# This is a parser for Pod. It is not a parser for the set of Pod-like
+# languages which happens to contain Pod -- it is just for Pod, plus possibly
+# some extensions.
+
+# @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @
+#@ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+
+__PACKAGE__->_accessorize(
+ 'nbsp_for_S', # Whether to map S<...>'s to \xA0 characters
+ 'source_filename', # Filename of the source, for use in warnings
+ 'source_dead', # Whether to consider this parser's source dead
+
+ 'output_fh', # The filehandle we're writing to, if applicable.
+ # Used only in some derived classes.
+
+ 'hide_line_numbers', # For some dumping subclasses: whether to pointedly
+ # suppress the start_line attribute
+
+ 'line_count', # the current line number
+ 'pod_para_count', # count of pod paragraphs seen so far
+
+ 'no_whining', # whether to suppress whining
+ 'no_errata_section', # whether to suppress the errata section
+ 'complain_stderr', # whether to complain to stderr
+
+ 'doc_has_started', # whether we've fired the open-Document event yet
+
+ 'bare_output', # For some subclasses: whether to prepend
+ # header-code and postpend footer-code
+
+ 'fullstop_space_harden', # Whether to turn ". " into ".[nbsp] ";
+
+ 'nix_X_codes', # whether to ignore X<...> codes
+ 'merge_text', # whether to avoid breaking a single piece of
+ # text up into several events
+
+ 'preserve_whitespace', # whether to try to keep whitespace as-is
+
+ 'content_seen', # whether we've seen any real Pod content
+ 'errors_seen', # TODO: document. whether we've seen any errors (fatal or not)
+
+ 'codes_in_verbatim', # for PseudoPod extensions
+
+ 'code_handler', # coderef to call when a code (non-pod) line is seen
+ 'cut_handler', # coderef to call when a =cut line is seen
+ #Called like:
+ # $code_handler->($line, $self->{'line_count'}, $self) if $code_handler;
+ # $cut_handler->($line, $self->{'line_count'}, $self) if $cut_handler;
+
+);
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+
+sub any_errata_seen { # good for using as an exit() value...
+ return shift->{'errors_seen'} || 0;
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+# Pull in some functions that, for some reason, I expect to see here too:
+BEGIN {
+ *pretty = \&Pod::Simple::BlackBox::pretty;
+ *stringify_lol = \&Pod::Simple::BlackBox::stringify_lol;
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+
+sub version_report {
+ my $class = ref($_[0]) || $_[0];
+ if($class eq __PACKAGE__) {
+ return "$class $VERSION";
+ } else {
+ my $v = $class->VERSION;
+ return "$class $v (" . __PACKAGE__ . " $VERSION)";
+ }
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+
+#sub curr_open { # read-only list accessor
+# return @{ $_[0]{'curr_open'} || return() };
+#}
+#sub _curr_open_listref { $_[0]{'curr_open'} ||= [] }
+
+
+sub output_string {
+ # Works by faking out output_fh. Simplifies our code.
+ #
+ my $this = shift;
+ return $this->{'output_string'} unless @_; # GET.
+
+ require Pod::Simple::TiedOutFH;
+ my $x = (defined($_[0]) and ref($_[0])) ? $_[0] : \( $_[0] );
+ $$x = '' unless defined $$x;
+ DEBUG > 4 and print "# Output string set to $x ($$x)\n";
+ $this->{'output_fh'} = Pod::Simple::TiedOutFH->handle_on($_[0]);
+ return
+ $this->{'output_string'} = $_[0];
+ #${ ${ $this->{'output_fh'} } };
+}
+
+sub abandon_output_string { $_[0]->abandon_output_fh; delete $_[0]{'output_string'} }
+sub abandon_output_fh { $_[0]->output_fh(undef) }
+# These don't delete the string or close the FH -- they just delete our
+# references to it/them.
+# TODO: document these
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+
+sub new {
+ # takes no parameters
+ my $class = ref($_[0]) || $_[0];
+ #Carp::croak(__PACKAGE__ . " is a virtual base class -- see perldoc "
+ # . __PACKAGE__ );
+ return bless {
+ 'accept_codes' => { map( ($_=>$_), @Known_formatting_codes ) },
+ 'accept_directives' => { %Known_directives },
+ 'accept_targets' => {},
+ }, $class;
+}
+
+
+
+# TODO: an option for whether to interpolate E<...>'s, or just resolve to codes.
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+
+sub _handle_element_start { # OVERRIDE IN DERIVED CLASS
+ my($self, $element_name, $attr_hash_r) = @_;
+ return;
+}
+
+sub _handle_element_end { # OVERRIDE IN DERIVED CLASS
+ my($self, $element_name) = @_;
+ return;
+}
+
+sub _handle_text { # OVERRIDE IN DERIVED CLASS
+ my($self, $text) = @_;
+ return;
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+#
+# And now directives (not targets)
+
+sub accept_directive_as_verbatim { shift->_accept_directives('Verbatim', @_) }
+sub accept_directive_as_data { shift->_accept_directives('Data', @_) }
+sub accept_directive_as_processed { shift->_accept_directives('Plain', @_) }
+
+sub _accept_directives {
+ my($this, $type) = splice @_,0,2;
+ foreach my $d (@_) {
+ next unless defined $d and length $d;
+ Carp::croak "\"$d\" isn't a valid directive name"
+ unless $d =~ m/^[a-zA-Z][a-zA-Z0-9]*$/s;
+ Carp::croak "\"$d\" is already a reserved Pod directive name"
+ if exists $Known_directives{$d};
+ $this->{'accept_directives'}{$d} = $type;
+ DEBUG > 2 and print "Learning to accept \"=$d\" as directive of type $type\n";
+ }
+ DEBUG > 6 and print "$this\'s accept_directives : ",
+ pretty($this->{'accept_directives'}), "\n";
+
+ return sort keys %{ $this->{'accept_directives'} } if wantarray;
+ return;
+}
+
+#--------------------------------------------------------------------------
+# TODO: document these:
+
+sub unaccept_directive { shift->unaccept_directives(@_) };
+
+sub unaccept_directives {
+ my $this = shift;
+ foreach my $d (@_) {
+ next unless defined $d and length $d;
+ Carp::croak "\"$d\" isn't a valid directive name"
+ unless $d =~ m/^[a-zA-Z][a-zA-Z0-9]*$/s;
+ Carp::croak "But you must accept \"$d\" directives -- it's a builtin!"
+ if exists $Known_directives{$d};
+ delete $this->{'accept_directives'}{$d};
+ DEBUG > 2 and print "OK, won't accept \"=$d\" as directive.\n";
+ }
+ return sort keys %{ $this->{'accept_directives'} } if wantarray;
+ return
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+#
+# And now targets (not directives)
+
+sub accept_target { shift->accept_targets(@_) } # alias
+sub accept_target_as_text { shift->accept_targets_as_text(@_) } # alias
+
+
+sub accept_targets { shift->_accept_targets('1', @_) }
+
+sub accept_targets_as_text { shift->_accept_targets('force_resolve', @_) }
+ # forces them to be processed, even when there's no ":".
+
+sub _accept_targets {
+ my($this, $type) = splice @_,0,2;
+ foreach my $t (@_) {
+ next unless defined $t and length $t;
+ # TODO: enforce some limitations on what a target name can be?
+ $this->{'accept_targets'}{$t} = $type;
+ DEBUG > 2 and print "Learning to accept \"$t\" as target of type $type\n";
+ }
+ return sort keys %{ $this->{'accept_targets'} } if wantarray;
+ return;
+}
+
+#--------------------------------------------------------------------------
+sub unaccept_target { shift->unaccept_targets(@_) }
+
+sub unaccept_targets {
+ my $this = shift;
+ foreach my $t (@_) {
+ next unless defined $t and length $t;
+ # TODO: enforce some limitations on what a target name can be?
+ delete $this->{'accept_targets'}{$t};
+ DEBUG > 2 and print "OK, won't accept \"$t\" as target.\n";
+ }
+ return sort keys %{ $this->{'accept_targets'} } if wantarray;
+ return;
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+#
+# And now codes (not targets or directives)
+
+sub accept_code { shift->accept_codes(@_) } # alias
+
+sub accept_codes { # Add some codes
+ my $this = shift;
+
+ foreach my $new_code (@_) {
+ next unless defined $new_code and length $new_code;
+ if(ASCII) {
+ # A good-enough check that it's good as an XML Name symbol:
+ Carp::croak "\"$new_code\" isn't a valid element name"
+ if $new_code =~
+ m/[\x00-\x2C\x2F\x39\x3B-\x40\x5B-\x5E\x60\x7B-\x7F]/
+ # Characters under 0x80 that aren't legal in an XML Name.
+ or $new_code =~ m/^[-\.0-9]/s
+ or $new_code =~ m/:[-\.0-9]/s;
+ # The legal under-0x80 Name characters that
+ # an XML Name still can't start with.
+ }
+
+ $this->{'accept_codes'}{$new_code} = $new_code;
+
+ # Yes, map to itself -- just so that when we
+ # see "=extend W [whatever] thatelementname", we say that W maps
+ # to whatever $this->{accept_codes}{thatelementname} is,
+ # i.e., "thatelementname". Then when we go re-mapping,
+ # a "W" in the treelet turns into "thatelementname". We only
+ # remap once.
+ # If we say we accept "W", then a "W" in the treelet simply turns
+ # into "W".
+ }
+
+ return;
+}
+
+#--------------------------------------------------------------------------
+sub unaccept_code { shift->unaccept_codes(@_) }
+
+sub unaccept_codes { # remove some codes
+ my $this = shift;
+
+ foreach my $new_code (@_) {
+ next unless defined $new_code and length $new_code;
+ if(ASCII) {
+ # A good-enough check that it's good as an XML Name symbol:
+ Carp::croak "\"$new_code\" isn't a valid element name"
+ if $new_code =~
+ m/[\x00-\x2C\x2F\x39\x3B-\x40\x5B-\x5E\x60\x7B-\x7F]/
+ # Characters under 0x80 that aren't legal in an XML Name.
+ or $new_code =~ m/^[-\.0-9]/s
+ or $new_code =~ m/:[-\.0-9]/s;
+ # The legal under-0x80 Name characters that
+ # an XML Name still can't start with.
+ }
+
+ Carp::croak "But you must accept \"$new_code\" codes -- it's a builtin!"
+ if grep $new_code eq $_, @Known_formatting_codes;
+
+ delete $this->{'accept_codes'}{$new_code};
+
+ DEBUG > 2 and print "OK, won't accept the code $new_code<...>.\n";
+ }
+
+ return;
+}
+
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+
+sub parse_string_document {
+ my $self = shift;
+ my @lines;
+ foreach my $line_group (@_) {
+ next unless defined $line_group and length $line_group;
+ pos($line_group) = 0;
+ while($line_group =~
+ m/([^\n\r]*)((?:\r?\n)?)/g
+ ) {
+ #print(">> $1\n"),
+ $self->parse_lines($1)
+ if length($1) or length($2)
+ or pos($line_group) != length($line_group);
+ # I.e., unless it's a zero-length "empty line" at the very
+ # end of "foo\nbar\n" (i.e., between the \n and the EOS).
+ }
+ }
+ $self->parse_lines(undef); # to signal EOF
+ return $self;
+}
+
+sub _init_fh_source {
+ my($self, $source) = @_;
+
+ #DEBUG > 1 and print "Declaring $source as :raw for starters\n";
+ #$self->_apply_binmode($source, ':raw');
+ #binmode($source, ":raw");
+
+ return;
+}
+
+#:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.
+#
+
+sub parse_file {
+ my($self, $source) = (@_);
+
+ if(!defined $source) {
+ Carp::croak("Can't use empty-string as a source for parse_file");
+ } elsif(ref(\$source) eq 'GLOB') {
+ $self->{'source_filename'} = '' . ($source);
+ } elsif(ref $source) {
+ $self->{'source_filename'} = '' . ($source);
+ } elsif(!length $source) {
+ Carp::croak("Can't use empty-string as a source for parse_file");
+ } else {
+ {
+ local *PODSOURCE;
+ open(PODSOURCE, "<$source") || Carp::croak("Can't open $source: $!");
+ $self->{'source_filename'} = $source;
+ $source = *PODSOURCE{IO};
+ }
+ $self->_init_fh_source($source);
+ }
+ # By here, $source is a FH.
+
+ $self->{'source_fh'} = $source;
+
+ my($i, @lines);
+ until( $self->{'source_dead'} ) {
+ splice @lines;
+ for($i = MANY_LINES; $i--;) { # read those many lines at a time
+ local $/ = $NL;
+ push @lines, scalar(<$source>); # readline
+ last unless defined $lines[-1];
+ # but pass thru the undef, which will set source_dead to true
+ }
+ $self->parse_lines(@lines);
+ }
+ delete($self->{'source_fh'}); # so it can be GC'd
+ return $self;
+}
+
+#:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.
+
+sub parse_from_file {
+ # An emulation of Pod::Parser's interface, for the sake of Perldoc.
+ # Basically just a wrapper around parse_file.
+
+ my($self, $source, $to) = @_;
+ $self = $self->new unless ref($self); # so we tolerate being a class method
+
+ if(!defined $source) { $source = *STDIN{IO}
+ } elsif(ref(\$source) eq 'GLOB') { # stet
+ } elsif(ref($source) ) { # stet
+ } elsif(!length $source
+ or $source eq '-' or $source =~ m/^<&(STDIN|0)$/i
+ ) {
+ $source = *STDIN{IO};
+ }
+
+ if(!defined $to) { $self->output_fh( *STDOUT{IO} );
+ } elsif(ref(\$to) eq 'GLOB') { $self->output_fh( $to );
+ } elsif(ref($to)) { $self->output_fh( $to );
+ } elsif(!length $to
+ or $to eq '-' or $to =~ m/^>&?(?:STDOUT|1)$/i
+ ) {
+ $self->output_fh( *STDOUT{IO} );
+ } else {
+ require Symbol;
+ my $out_fh = Symbol::gensym();
+ DEBUG and print "Write-opening to $to\n";
+ open($out_fh, ">$to") or Carp::croak "Can't write-open $to: $!";
+ binmode($out_fh)
+ if $self->can('write_with_binmode') and $self->write_with_binmode;
+ $self->output_fh($out_fh);
+ }
+
+ return $self->parse_file($source);
+}
+
+#-----------------------------------------------------------------------------
+
+sub whine {
+ #my($self,$line,$complaint) = @_;
+ my $self = shift(@_);
+ ++$self->{'errors_seen'};
+ if($self->{'no_whining'}) {
+ DEBUG > 9 and print "Discarding complaint (at line $_[0]) $_[1]\n because no_whining is on.\n";
+ return;
+ }
+ return $self->_complain_warn(@_) if $self->{'complain_stderr'};
+ return $self->_complain_errata(@_);
+}
+
+sub scream { # like whine, but not suppressable
+ #my($self,$line,$complaint) = @_;
+ my $self = shift(@_);
+ ++$self->{'errors_seen'};
+ return $self->_complain_warn(@_) if $self->{'complain_stderr'};
+ return $self->_complain_errata(@_);
+}
+
+sub _complain_warn {
+ my($self,$line,$complaint) = @_;
+ return printf STDERR "%s around line %s: %s\n",
+ $self->{'source_filename'} || 'Pod input', $line, $complaint;
+}
+
+sub _complain_errata {
+ my($self,$line,$complaint) = @_;
+ if( $self->{'no_errata_section'} ) {
+ DEBUG > 9 and print "Discarding erratum (at line $line) $complaint\n because no_errata_section is on.\n";
+ } else {
+ DEBUG > 9 and print "Queuing erratum (at line $line) $complaint\n";
+ push @{$self->{'errata'}{$line}}, $complaint
+ # for a report to be generated later!
+ }
+ return 1;
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+
+sub _get_initial_item_type {
+ # A hack-wrapper here for when you have like "=over\n\n=item 456\n\n"
+ my($self, $para) = @_;
+ return $para->[1]{'~type'} if $para->[1]{'~type'};
+
+ return $para->[1]{'~type'} = 'text'
+ if join("\n", @{$para}[2 .. $#$para]) =~ m/^\s*(\d+)\.?\s*$/s and $1 ne '1';
+ # Else fall thru to the general case:
+ return $self->_get_item_type($para);
+}
+
+
+
+sub _get_item_type { # mutates the item!!
+ my($self, $para) = @_;
+ return $para->[1]{'~type'} if $para->[1]{'~type'};
+
+
+ # Otherwise we haven't yet been to this node. Maybe alter it...
+
+ my $content = join "\n", @{$para}[2 .. $#$para];
+
+ if($content =~ m/^\s*\*\s*$/s or $content =~ m/^\s*$/s) {
+ # Like: "=item *", "=item * ", "=item"
+ splice @$para, 2; # so it ends up just being ['=item', { attrhash } ]
+ $para->[1]{'~orig_content'} = $content;
+ return $para->[1]{'~type'} = 'bullet';
+
+ } elsif($content =~ m/^\s*\*\s+(.+)/s) { # tolerance
+
+ # Like: "=item * Foo bar baz";
+ $para->[1]{'~orig_content'} = $content;
+ $para->[1]{'~_freaky_para_hack'} = $1;
+ DEBUG > 2 and print " Tolerating $$para[2] as =item *\\n\\n$1\n";
+ splice @$para, 2; # so it ends up just being ['=item', { attrhash } ]
+ return $para->[1]{'~type'} = 'bullet';
+
+ } elsif($content =~ m/^\s*(\d+)\.?\s*$/s) {
+ # Like: "=item 1.", "=item 123412"
+
+ $para->[1]{'~orig_content'} = $content;
+ $para->[1]{'number'} = $1; # Yes, stores the number there!
+
+ splice @$para, 2; # so it ends up just being ['=item', { attrhash } ]
+ return $para->[1]{'~type'} = 'number';
+
+ } else {
+ # It's anything else.
+ return $para->[1]{'~type'} = 'text';
+
+ }
+}
+
+#-----------------------------------------------------------------------------
+
+sub _make_treelet {
+ my $self = shift; # and ($para, $start_line)
+ my $treelet;
+ if(!@_) {
+ return [''];
+ } if(ref $_[0] and ref $_[0][0] and $_[0][0][0] eq '~Top') {
+ # Hack so we can pass in fake-o pre-cooked paragraphs:
+ # just have the first line be a reference to a ['~Top', {}, ...]
+ # We use this feechure in gen_errata and stuff.
+
+ DEBUG and print "Applying precooked treelet hack to $_[0][0]\n";
+ $treelet = $_[0][0];
+ splice @$treelet, 0, 2; # lop the top off
+ return $treelet;
+ } else {
+ $treelet = $self->_treelet_from_formatting_codes(@_);
+ }
+
+ if( $self->_remap_sequences($treelet) ) {
+ $self->_treat_Zs($treelet); # Might as well nix these first
+ $self->_treat_Ls($treelet); # L has to precede E and S
+ $self->_treat_Es($treelet);
+ $self->_treat_Ss($treelet); # S has to come after E
+
+ $self->_wrap_up($treelet); # Nix X's and merge texties
+
+ } else {
+ DEBUG and print "Formatless treelet gets fast-tracked.\n";
+ # Very common case!
+ }
+
+ splice @$treelet, 0, 2; # lop the top off
+
+ return $treelet;
+}
+
+#:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.
+
+sub _wrap_up {
+ my($self, @stack) = @_;
+ my $nixx = $self->{'nix_X_codes'};
+ my $merge = $self->{'merge_text' };
+ return unless $nixx or $merge;
+
+ DEBUG > 2 and print "\nStarting _wrap_up traversal.\n",
+ $merge ? (" Merge mode on\n") : (),
+ $nixx ? (" Nix-X mode on\n") : (),
+ ;
+
+
+ my($i, $treelet);
+ while($treelet = shift @stack) {
+ DEBUG > 3 and print " Considering children of this $treelet->[0] node...\n";
+ for($i = 2; $i < @$treelet; ++$i) { # iterate over children
+ DEBUG > 3 and print " Considering child at $i ", pretty($treelet->[$i]), "\n";
+ if($nixx and ref $treelet->[$i] and $treelet->[$i][0] eq 'X') {
+ DEBUG > 3 and print " Nixing X node at $i\n";
+ splice(@$treelet, $i, 1); # just nix this node (and its descendants)
+ # no need to back-update the counter just yet
+ redo;
+
+ } elsif($merge and $i != 2 and # non-initial
+ !ref $treelet->[$i] and !ref $treelet->[$i - 1]
+ ) {
+ DEBUG > 3 and print " Merging ", $i-1,
+ ":[$treelet->[$i-1]] and $i\:[$treelet->[$i]]\n";
+ $treelet->[$i-1] .= ( splice(@$treelet, $i, 1) )[0];
+ DEBUG > 4 and print " Now: ", $i-1, ":[$treelet->[$i-1]]\n";
+ --$i;
+ next;
+ # since we just pulled the possibly last node out from under
+ # ourselves, we can't just redo()
+
+ } elsif( ref $treelet->[$i] ) {
+ DEBUG > 4 and print " Enqueuing ", pretty($treelet->[$i]), " for traversal.\n";
+ push @stack, $treelet->[$i];
+
+ if($treelet->[$i][0] eq 'L') {
+ my $thing;
+ foreach my $attrname ('section', 'to') {
+ if(defined($thing = $treelet->[$i][1]{$attrname}) and ref $thing) {
+ unshift @stack, $thing;
+ DEBUG > 4 and print " +Enqueuing ",
+ pretty( $treelet->[$i][1]{$attrname} ),
+ " as an attribute value to tweak.\n";
+ }
+ }
+ }
+ }
+ }
+ }
+ DEBUG > 2 and print "End of _wrap_up traversal.\n\n";
+
+ return;
+}
+
+#:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.
+
+sub _remap_sequences {
+ my($self, at stack) = @_;
+
+ if(@stack == 1 and @{ $stack[0] } == 3 and !ref $stack[0][2]) {
+ # VERY common case: abort it.
+ DEBUG and print "Skipping _remap_sequences: formatless treelet.\n";
+ return 0;
+ }
+
+ my $map = ($self->{'accept_codes'} || die "NO accept_codes in $self?!?");
+
+ my $start_line = $stack[0][1]{'start_line'};
+ DEBUG > 2 and printf
+ "\nAbout to start _remap_sequences on treelet from line %s.\n",
+ $start_line || '[?]'
+ ;
+ DEBUG > 3 and print " Map: ",
+ join('; ', map "$_=" . (
+ ref($map->{$_}) ? join(",", @{$map->{$_}}) : $map->{$_}
+ ),
+ sort keys %$map ),
+ ("B~C~E~F~I~L~S~X~Z" eq join '~', sort keys %$map)
+ ? " (all normal)\n" : "\n"
+ ;
+
+ # A recursive algorithm implemented iteratively! Whee!
+
+ my($is, $was, $i, $treelet); # scratch
+ while($treelet = shift @stack) {
+ DEBUG > 3 and print " Considering children of this $treelet->[0] node...\n";
+ for($i = 2; $i < @$treelet; ++$i) { # iterate over children
+ next unless ref $treelet->[$i]; # text nodes are uninteresting
+
+ DEBUG > 4 and print " Noting child $i : $treelet->[$i][0]<...>\n";
+
+ $is = $treelet->[$i][0] = $map->{ $was = $treelet->[$i][0] };
+ if( DEBUG > 3 ) {
+ if(!defined $is) {
+ print " Code $was<> is UNKNOWN!\n";
+ } elsif($is eq $was) {
+ DEBUG > 4 and print " Code $was<> stays the same.\n";
+ } else {
+ print " Code $was<> maps to ",
+ ref($is)
+ ? ( "tags ", map("$_<", @$is), '...', map('>', @$is), "\n" )
+ : "tag $is<...>.\n";
+ }
+ }
+
+ if(!defined $is) {
+ $self->whine($start_line, "Deleting unknown formatting code $was<>");
+ $is = $treelet->[$i][0] = '1'; # But saving the children!
+ # I could also insert a leading "$was<" and tailing ">" as
+ # children of this node, but something about that seems icky.
+ }
+ if(ref $is) {
+ my @dynasty = @$is;
+ DEBUG > 4 and print " Renaming $was node to $dynasty[-1]\n";
+ $treelet->[$i][0] = pop @dynasty;
+ my $nugget;
+ while(@dynasty) {
+ DEBUG > 4 and printf
+ " Grafting a new %s node between %s and %s\n",
+ $dynasty[-1], $treelet->[0], $treelet->[$i][0],
+ ;
+
+ #$nugget = ;
+ splice @$treelet, $i, 1, [pop(@dynasty), {}, $treelet->[$i]];
+ # relace node with a new parent
+ }
+ } elsif($is eq '0') {
+ splice(@$treelet, $i, 1); # just nix this node (and its descendants)
+ --$i; # back-update the counter
+ } elsif($is eq '1') {
+ splice(@$treelet, $i, 1 # replace this node with its children!
+ => splice @{ $treelet->[$i] },2
+ # (not catching its first two (non-child) items)
+ );
+ --$i; # back up for new stuff
+ } else {
+ # otherwise it's unremarkable
+ unshift @stack, $treelet->[$i]; # just recurse
+ }
+ }
+ }
+
+ DEBUG > 2 and print "End of _remap_sequences traversal.\n\n";
+
+ if(@_ == 2 and @{ $_[1] } == 3 and !ref $_[1][2]) {
+ DEBUG and print "Noting that the treelet is now formatless.\n";
+ return 0;
+ }
+ return 1;
+}
+
+# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
+
+sub _ponder_extend {
+
+ # "Go to an extreme, move back to a more comfortable place"
+ # -- /Oblique Strategies/, Brian Eno and Peter Schmidt
+
+ my($self, $para) = @_;
+ my $content = join ' ', splice @$para, 2;
+ $content =~ s/^\s+//s;
+ $content =~ s/\s+$//s;
+
+ DEBUG > 2 and print "Ogling extensor: =extend $content\n";
+
+ if($content =~
+ m/^
+ (\S+) # 1 : new item
+ \s+
+ (\S+) # 2 : fallback(s)
+ (?:\s+(\S+))? # 3 : element name(s)
+ \s*
+ $
+ /xs
+ ) {
+ my $new_letter = $1;
+ my $fallbacks_one = $2;
+ my $elements_one;
+ $elements_one = defined($3) ? $3 : $1;
+
+ DEBUG > 2 and print "Extensor has good syntax.\n";
+
+ unless($new_letter =~ m/^[A-Z]$/s or $new_letter) {
+ DEBUG > 2 and print " $new_letter isn't a valid thing to entend.\n";
+ $self->whine(
+ $para->[1]{'start_line'},
+ "You can extend only formatting codes A-Z, not like \"$new_letter\""
+ );
+ return;
+ }
+
+ if(grep $new_letter eq $_, @Known_formatting_codes) {
+ DEBUG > 2 and print " $new_letter isn't a good thing to extend, because known.\n";
+ $self->whine(
+ $para->[1]{'start_line'},
+ "You can't extend an established code like \"$new_letter\""
+ );
+
+ #TODO: or allow if last bit is same?
+
+ return;
+ }
+
+ unless($fallbacks_one =~ m/^[A-Z](,[A-Z])*$/s # like "B", "M,I", etc.
+ or $fallbacks_one eq '0' or $fallbacks_one eq '1'
+ ) {
+ $self->whine(
+ $para->[1]{'start_line'},
+ "Format for second =extend parameter must be like"
+ . " M or 1 or 0 or M,N or M,N,O but you have it like "
+ . $fallbacks_one
+ );
+ return;
+ }
+
+ unless($elements_one =~ m/^[^ ,]+(,[^ ,]+)*$/s) { # like "B", "M,I", etc.
+ $self->whine(
+ $para->[1]{'start_line'},
+ "Format for third =extend parameter: like foo or bar,Baz,qu:ux but not like "
+ . $elements_one
+ );
+ return;
+ }
+
+ my @fallbacks = split ',', $fallbacks_one, -1;
+ my @elements = split ',', $elements_one, -1;
+
+ foreach my $f (@fallbacks) {
+ next if exists $Known_formatting_codes{$f} or $f eq '0' or $f eq '1';
+ DEBUG > 2 and print " Can't fall back on unknown code $f\n";
+ $self->whine(
+ $para->[1]{'start_line'},
+ "Can't use unknown formatting code '$f' as a fallback for '$new_letter'"
+ );
+ return;
+ }
+
+ DEBUG > 3 and printf "Extensor: Fallbacks <%s> Elements <%s>.\n",
+ @fallbacks, @elements;
+
+ my $canonical_form;
+ foreach my $e (@elements) {
+ if(exists $self->{'accept_codes'}{$e}) {
+ DEBUG > 1 and print " Mapping '$new_letter' to known extension '$e'\n";
+ $canonical_form = $e;
+ last; # first acceptable elementname wins!
+ } else {
+ DEBUG > 1 and print " Can't map '$new_letter' to unknown extension '$e'\n";
+ }
+ }
+
+
+ if( defined $canonical_form ) {
+ # We found a good N => elementname mapping
+ $self->{'accept_codes'}{$new_letter} = $canonical_form;
+ DEBUG > 2 and print
+ "Extensor maps $new_letter => known element $canonical_form.\n";
+ } else {
+ # We have to use the fallback(s), which might be '0', or '1'.
+ $self->{'accept_codes'}{$new_letter}
+ = (@fallbacks == 1) ? $fallbacks[0] : \@fallbacks;
+ DEBUG > 2 and print
+ "Extensor maps $new_letter => fallbacks @fallbacks.\n";
+ }
+
+ } else {
+ DEBUG > 2 and print "Extensor has bad syntax.\n";
+ $self->whine(
+ $para->[1]{'start_line'},
+ "Unknown =extend syntax: $content"
+ )
+ }
+ return;
+}
+
+
+#:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.
+
+sub _treat_Zs { # Nix Z<...>'s
+ my($self, at stack) = @_;
+
+ my($i, $treelet);
+ my $start_line = $stack[0][1]{'start_line'};
+
+ # A recursive algorithm implemented iteratively! Whee!
+
+ while($treelet = shift @stack) {
+ for($i = 2; $i < @$treelet; ++$i) { # iterate over children
+ next unless ref $treelet->[$i]; # text nodes are uninteresting
+ unless($treelet->[$i][0] eq 'Z') {
+ unshift @stack, $treelet->[$i]; # recurse
+ next;
+ }
+
+ DEBUG > 1 and print "Nixing Z node @{$treelet->[$i]}\n";
+
+ # bitch UNLESS it's empty
+ unless( @{$treelet->[$i]} == 2
+ or (@{$treelet->[$i]} == 3 and $treelet->[$i][2] eq '')
+ ) {
+ $self->whine( $start_line, "A non-empty Z<>" );
+ } # but kill it anyway
+
+ splice(@$treelet, $i, 1); # thereby just nix this node.
+ --$i;
+
+ }
+ }
+
+ return;
+}
+
+# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
+
+# Quoting perlpodspec:
+
+# In parsing an L<...> code, Pod parsers must distinguish at least four
+# attributes:
+
+############# Not used. Expressed via the element children plus
+############# the value of the "content-implicit" flag.
+# First:
+# The link-text. If there is none, this must be undef. (E.g., in "L<Perl
+# Functions|perlfunc>", the link-text is "Perl Functions". In
+# "L<Time::HiRes>" and even "L<|Time::HiRes>", there is no link text. Note
+# that link text may contain formatting.)
+#
+
+############# The element children
+# Second:
+# The possibly inferred link-text -- i.e., if there was no real link text,
+# then this is the text that we'll infer in its place. (E.g., for
+# "L<Getopt::Std>", the inferred link text is "Getopt::Std".)
+#
+
+############# The "to" attribute (which might be text, or a treelet)
+# Third:
+# The name or URL, or undef if none. (E.g., in "L<Perl
+# Functions|perlfunc>", the name -- also sometimes called the page -- is
+# "perlfunc". In "L</CAVEATS>", the name is undef.)
+#
+
+############# The "section" attribute (which might be next, or a treelet)
+# Fourth:
+# The section (AKA "item" in older perlpods), or undef if none. E.g., in
+# Getopt::Std/DESCRIPTION, "DESCRIPTION" is the section. (Note that this
+# is not the same as a manpage section like the "5" in "man 5 crontab".
+# "Section Foo" in the Pod sense means the part of the text that's
+# introduced by the heading or item whose text is "Foo".)
+#
+# Pod parsers may also note additional attributes including:
+#
+
+############# The "type" attribute.
+# Fifth:
+# A flag for whether item 3 (if present) is a URL (like
+# "http://lists.perl.org" is), in which case there should be no section
+# attribute; a Pod name (like "perldoc" and "Getopt::Std" are); or
+# possibly a man page name (like "crontab(5)" is).
+#
+
+############# Not implemented, I guess.
+# Sixth:
+# The raw original L<...> content, before text is split on "|", "/", etc,
+# and before E<...> codes are expanded.
+
+
+# For L<...> codes without a "name|" part, only E<...> and Z<> codes may
+# occur -- no other formatting codes. That is, authors should not use
+# "L<B<Foo::Bar>>".
+#
+# Note, however, that formatting codes and Z<>'s can occur in any and all
+# parts of an L<...> (i.e., in name, section, text, and url).
+
+sub _treat_Ls { # Process our dear dear friends, the L<...> sequences
+
+ # L<name>
+ # L<name/"sec"> or L<name/sec>
+ # L</"sec"> or L</sec> or L<"sec">
+ # L<text|name>
+ # L<text|name/"sec"> or L<text|name/sec>
+ # L<text|/"sec"> or L<text|/sec> or L<text|"sec">
+ # L<scheme:...>
+ # Ltext|scheme:...>
+
+ my($self, at stack) = @_;
+
+ my($i, $treelet);
+ my $start_line = $stack[0][1]{'start_line'};
+
+ # A recursive algorithm implemented iteratively! Whee!
+
+ while($treelet = shift @stack) {
+ for(my $i = 2; $i < @$treelet; ++$i) {
+ # iterate over children of current tree node
+ next unless ref $treelet->[$i]; # text nodes are uninteresting
+ unless($treelet->[$i][0] eq 'L') {
+ unshift @stack, $treelet->[$i]; # recurse
+ next;
+ }
+
+
+ # By here, $treelet->[$i] is definitely an L node
+ my $ell = $treelet->[$i];
+ DEBUG > 1 and print "Ogling L node $ell\n";
+
+ # bitch if it's empty
+ if( @{$ell} == 2
+ or (@{$ell} == 3 and $ell->[2] eq '')
+ ) {
+ $self->whine( $start_line, "An empty L<>" );
+ $treelet->[$i] = 'L<>'; # just make it a text node
+ next; # and move on
+ }
+
+ # Catch URLs:
+
+ # there are a number of possible cases:
+ # 1) text node containing url: http://foo.com
+ # -> [ 'http://foo.com' ]
+ # 2) text node containing url and text: foo|http://foo.com
+ # -> [ 'foo|http://foo.com' ]
+ # 3) text node containing url start: mailto:xE<at>foo.com
+ # -> [ 'mailto:x', [ E ... ], 'foo.com' ]
+ # 4) text node containing url start and text: foo|mailto:xE<at>foo.com
+ # -> [ 'foo|mailto:x', [ E ... ], 'foo.com' ]
+ # 5) other nodes containing text and url start: OE<39>Malley|http://foo.com
+ # -> [ 'O', [ E ... ], 'Malley', '|http://foo.com' ]
+ # ... etc.
+
+ # anything before the url is part of the text.
+ # anything after it is part of the url.
+ # the url text node itself may contain parts of both.
+
+ if (my ($url_index, $text_part, $url_part) =
+ # grep is no good here; we want to bail out immediately so that we can
+ # use $1, $2, etc. without having to do the match twice.
+ sub {
+ for (2..$#$ell) {
+ next if ref $ell->[$_];
+ next unless $ell->[$_] =~ m/^(?:([^|]*)\|)?(\w+:[^:\s]\S*)$/s;
+ return ($_, $1, $2);
+ }
+ return;
+ }->()
+ ) {
+ $ell->[1]{'type'} = 'url';
+
+ my @text = @{$ell}[2..$url_index-1];
+ push @text, $text_part if defined $text_part;
+
+ my @url = @{$ell}[$url_index+1..$#$ell];
+ unshift @url, $url_part;
+
+ unless (@text) {
+ $ell->[1]{'content-implicit'} = 'yes';
+ @text = @url;
+ }
+
+ $ell->[1]{to} = Pod::Simple::LinkSection->new(
+ @url == 1
+ ? $url[0]
+ : [ '', {}, @url ],
+ );
+
+ splice @$ell, 2, $#$ell, @text;
+
+ next;
+ }
+
+ # Catch some very simple and/or common cases
+ if(@{$ell} == 3 and ! ref $ell->[2]) {
+ my $it = $ell->[2];
+ if($it =~ m/^[-a-zA-Z0-9]+\([-a-zA-Z0-9]+\)$/s) { # man sections
+ # Hopefully neither too broad nor too restrictive a RE
+ DEBUG > 1 and print "Catching \"$it\" as manpage link.\n";
+ $ell->[1]{'type'} = 'man';
+ # This's the only place where man links can get made.
+ $ell->[1]{'content-implicit'} = 'yes';
+ $ell->[1]{'to' } =
+ Pod::Simple::LinkSection->new( $it ); # treelet!
+
+ next;
+ }
+ if($it =~ m/^[^\/\|,\$\%\@\ \"\<\>\:\#\&\*\{\}\[\]\(\)]+(\:\:[^\/\|,\$\%\@\ \"\<\>\:\#\&\*\{\}\[\]\(\)]+)*$/s) {
+ # Extremely forgiving idea of what constitutes a bare
+ # modulename link like L<Foo::Bar> or even L<Thing::1.0::Docs::Tralala>
+ DEBUG > 1 and print "Catching \"$it\" as ho-hum L<Modulename> link.\n";
+ $ell->[1]{'type'} = 'pod';
+ $ell->[1]{'content-implicit'} = 'yes';
+ $ell->[1]{'to' } =
+ Pod::Simple::LinkSection->new( $it ); # treelet!
+ next;
+ }
+ # else fall thru...
+ }
+
+
+
+ # ...Uhoh, here's the real L<...> parsing stuff...
+ # "With the ill behavior, with the ill behavior, with the ill behavior..."
+
+ DEBUG > 1 and print "Running a real parse on this non-trivial L\n";
+
+
+ my $link_text; # set to an arrayref if found
+ my @ell_content = @$ell;
+ splice @ell_content,0,2; # Knock off the 'L' and {} bits
+
+ DEBUG > 3 and print " Ell content to start: ",
+ pretty(@ell_content), "\n";
+
+
+ # Look for the "|" -- only in CHILDREN (not all underlings!)
+ # Like L<I like the strictness|strict>
+ DEBUG > 3 and
+ print " Peering at L content for a '|' ...\n";
+ for(my $j = 0; $j < @ell_content; ++$j) {
+ next if ref $ell_content[$j];
+ DEBUG > 3 and
+ print " Peering at L-content text bit \"$ell_content[$j]\" for a '|'.\n";
+
+ if($ell_content[$j] =~ m/^([^\|]*)\|(.*)$/s) {
+ my @link_text = ($1); # might be 0-length
+ $ell_content[$j] = $2; # might be 0-length
+
+ DEBUG > 3 and
+ print " FOUND a '|' in it. Splitting into [$1] + [$2]\n";
+
+ unshift @link_text, splice @ell_content, 0, $j;
+ # leaving only things at J and after
+ @ell_content = grep ref($_)||length($_), @ell_content ;
+ $link_text = [grep ref($_)||length($_), @link_text ];
+ DEBUG > 3 and printf
+ " So link text is %s\n and remaining ell content is %s\n",
+ pretty($link_text), pretty(@ell_content);
+ last;
+ }
+ }
+
+
+ # Now look for the "/" -- only in CHILDREN (not all underlings!)
+ # And afterward, anything left in @ell_content will be the raw name
+ # Like L<Foo::Bar/Object Methods>
+ my $section_name; # set to arrayref if found
+ DEBUG > 3 and print " Peering at L-content for a '/' ...\n";
+ for(my $j = 0; $j < @ell_content; ++$j) {
+ next if ref $ell_content[$j];
+ DEBUG > 3 and
+ print " Peering at L-content text bit \"$ell_content[$j]\" for a '/'.\n";
+
+ if($ell_content[$j] =~ m/^([^\/]*)\/(.*)$/s) {
+ my @section_name = ($2); # might be 0-length
+ $ell_content[$j] = $1; # might be 0-length
+
+ DEBUG > 3 and
+ print " FOUND a '/' in it.",
+ " Splitting to page [...$1] + section [$2...]\n";
+
+ push @section_name, splice @ell_content, 1+$j;
+ # leaving only things before and including J
+
+ @ell_content = grep ref($_)||length($_), @ell_content ;
+ @section_name = grep ref($_)||length($_), @section_name ;
+
+ # Turn L<.../"foo"> into L<.../foo>
+ if(@section_name
+ and !ref($section_name[0]) and !ref($section_name[-1])
+ and $section_name[ 0] =~ m/^\"/s
+ and $section_name[-1] =~ m/\"$/s
+ and !( # catch weird degenerate case of L<"> !
+ @section_name == 1 and $section_name[0] eq '"'
+ )
+ ) {
+ $section_name[ 0] =~ s/^\"//s;
+ $section_name[-1] =~ s/\"$//s;
+ DEBUG > 3 and
+ print " Quotes removed: ", pretty(@section_name), "\n";
+ } else {
+ DEBUG > 3 and
+ print " No need to remove quotes in ", pretty(@section_name), "\n";
+ }
+
+ $section_name = \@section_name;
+ last;
+ }
+ }
+
+ # Turn L<"Foo Bar"> into L</Foo Bar>
+ if(!$section_name and @ell_content
+ and !ref($ell_content[0]) and !ref($ell_content[-1])
+ and $ell_content[ 0] =~ m/^\"/s
+ and $ell_content[-1] =~ m/\"$/s
+ and !( # catch weird degenerate case of L<"> !
+ @ell_content == 1 and $ell_content[0] eq '"'
+ )
+ ) {
+ $section_name = [splice @ell_content];
+ $section_name->[ 0] =~ s/^\"//s;
+ $section_name->[-1] =~ s/\"$//s;
+ }
+
+ # Turn L<Foo Bar> into L</Foo Bar>.
+ if(!$section_name and !$link_text and @ell_content
+ and grep !ref($_) && m/ /s, @ell_content
+ ) {
+ $section_name = [splice @ell_content];
+ # That's support for the now-deprecated syntax.
+ # (Maybe generate a warning eventually?)
+ # Note that it deliberately won't work on L<...|Foo Bar>
+ }
+
+
+ # Now make up the link_text
+ # L<Foo> -> L<Foo|Foo>
+ # L</Bar> -> L<"Bar"|Bar>
+ # L<Foo/Bar> -> L<"Bar" in Foo/Foo>
+ unless($link_text) {
+ $ell->[1]{'content-implicit'} = 'yes';
+ $link_text = [];
+ push @$link_text, '"', @$section_name, '"' if $section_name;
+
+ if(@ell_content) {
+ $link_text->[-1] .= ' in ' if $section_name;
+ push @$link_text, @ell_content;
+ }
+ }
+
+
+ # And the E resolver will have to deal with all our treeletty things:
+
+ if(@ell_content == 1 and !ref($ell_content[0])
+ and $ell_content[0] =~ m/^[-a-zA-Z0-9]+\([-a-zA-Z0-9]+\)$/s
+ ) {
+ $ell->[1]{'type'} = 'man';
+ DEBUG > 3 and print "Considering this ($ell_content[0]) a man link.\n";
+ } else {
+ $ell->[1]{'type'} = 'pod';
+ DEBUG > 3 and print "Considering this a pod link (not man or url).\n";
+ }
+
+ if( defined $section_name ) {
+ $ell->[1]{'section'} = Pod::Simple::LinkSection->new(
+ ['', {}, @$section_name]
+ );
+ DEBUG > 3 and print "L-section content: ", pretty($ell->[1]{'section'}), "\n";
+ }
+
+ if( @ell_content ) {
+ $ell->[1]{'to'} = Pod::Simple::LinkSection->new(
+ ['', {}, @ell_content]
+ );
+ DEBUG > 3 and print "L-to content: ", pretty($ell->[1]{'to'}), "\n";
+ }
+
+ # And update children to be the link-text:
+ @$ell = (@$ell[0,1], defined($link_text) ? splice(@$link_text) : '');
+
+ DEBUG > 2 and print "End of L-parsing for this node $treelet->[$i]\n";
+
+ unshift @stack, $treelet->[$i]; # might as well recurse
+ }
+ }
+
+ return;
+}
+
+# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
+
+sub _treat_Es {
+ my($self, at stack) = @_;
+
+ my($i, $treelet, $content, $replacer, $charnum);
+ my $start_line = $stack[0][1]{'start_line'};
+
+ # A recursive algorithm implemented iteratively! Whee!
+
+
+ # Has frightening side effects on L nodes' attributes.
+
+ #my @ells_to_tweak;
+
+ while($treelet = shift @stack) {
+ for(my $i = 2; $i < @$treelet; ++$i) { # iterate over children
+ next unless ref $treelet->[$i]; # text nodes are uninteresting
+ if($treelet->[$i][0] eq 'L') {
+ # SPECIAL STUFF for semi-processed L<>'s
+
+ my $thing;
+ foreach my $attrname ('section', 'to') {
+ if(defined($thing = $treelet->[$i][1]{$attrname}) and ref $thing) {
+ unshift @stack, $thing;
+ DEBUG > 2 and print " Enqueuing ",
+ pretty( $treelet->[$i][1]{$attrname} ),
+ " as an attribute value to tweak.\n";
+ }
+ }
+
+ unshift @stack, $treelet->[$i]; # recurse
+ next;
+ } elsif($treelet->[$i][0] ne 'E') {
+ unshift @stack, $treelet->[$i]; # recurse
+ next;
+ }
+
+ DEBUG > 1 and print "Ogling E node ", pretty($treelet->[$i]), "\n";
+
+ # bitch if it's empty
+ if( @{$treelet->[$i]} == 2
+ or (@{$treelet->[$i]} == 3 and $treelet->[$i][2] eq '')
+ ) {
+ $self->whine( $start_line, "An empty E<>" );
+ $treelet->[$i] = 'E<>'; # splice in a literal
+ next;
+ }
+
+ # bitch if content is weird
+ unless(@{$treelet->[$i]} == 3 and !ref($content = $treelet->[$i][2])) {
+ $self->whine( $start_line, "An E<...> surrounding strange content" );
+ $replacer = $treelet->[$i]; # scratch
+ splice(@$treelet, $i, 1, # fake out a literal
+ 'E<',
+ splice(@$replacer,2), # promote its content
+ '>'
+ );
+ # Don't need to do --$i, as the 'E<' we just added isn't interesting.
+ next;
+ }
+
+ DEBUG > 1 and print "Ogling E<$content>\n";
+
+ $charnum = Pod::Escapes::e2charnum($content);
+ DEBUG > 1 and print " Considering E<$content> with char ",
+ defined($charnum) ? $charnum : "undef", ".\n";
+
+ if(!defined( $charnum )) {
+ DEBUG > 1 and print "I don't know how to deal with E<$content>.\n";
+ $self->whine( $start_line, "Unknown E content in E<$content>" );
+ $replacer = "E<$content>"; # better than nothing
+ } elsif($charnum >= 255 and !UNICODE) {
+ $replacer = ASCII ? "\xA4" : "?";
+ DEBUG > 1 and print "This Perl version can't handle ",
+ "E<$content> (chr $charnum), so replacing with $replacer\n";
+ } else {
+ $replacer = Pod::Escapes::e2char($content);
+ DEBUG > 1 and print " Replacing E<$content> with $replacer\n";
+ }
+
+ splice(@$treelet, $i, 1, $replacer); # no need to back up $i, tho
+ }
+ }
+
+ return;
+}
+
+
+# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
+
+sub _treat_Ss {
+ my($self,$treelet) = @_;
+
+ _change_S_to_nbsp($treelet,0) if $self->{'nbsp_for_S'};
+
+ # TODO: or a change_nbsp_to_S
+ # Normalizing nbsp's to S is harder: for each text node, make S content
+ # out of anything matching m/([^ \xA0]*(?:\xA0+[^ \xA0]*)+)/
+
+
+ return;
+}
+
+
+sub _change_S_to_nbsp { # a recursive function
+ # Sanely assumes that the top node in the excursion won't be an S node.
+ my($treelet, $in_s) = @_;
+
+ my $is_s = ('S' eq $treelet->[0]);
+ $in_s ||= $is_s; # So in_s is on either by this being an S element,
+ # or by an ancestor being an S element.
+
+ for(my $i = 2; $i < @$treelet; ++$i) {
+ if(ref $treelet->[$i]) {
+ if( _change_S_to_nbsp( $treelet->[$i], $in_s ) ) {
+ my $to_pull_up = $treelet->[$i];
+ splice @$to_pull_up,0,2; # ...leaving just its content
+ splice @$treelet, $i, 1, @$to_pull_up; # Pull up content
+ $i += @$to_pull_up - 1; # Make $i skip the pulled-up stuff
+ }
+ } else {
+ $treelet->[$i] =~ s/\s/\xA0/g if ASCII and $in_s;
+ # (If not in ASCIIland, we can't assume that \xA0 == nbsp.)
+
+ # Note that if you apply nbsp_for_S to text, and so turn
+ # "foo S<bar baz> quux" into "foo bar faz quux", you
+ # end up with something that fails to say "and don't hyphenate
+ # any part of 'bar baz'". However, hyphenation is such a vexing
+ # problem anyway, that most Pod renderers just don't render it
+ # at all. But if you do want to implement hyphenation, I guess
+ # that you'd better have nbsp_for_S off.
+ }
+ }
+
+ return $is_s;
+}
+
+#-----------------------------------------------------------------------------
+
+sub _accessorize { # A simple-minded method-maker
+ no strict 'refs';
+ foreach my $attrname (@_) {
+ next if $attrname =~ m/::/; # a hack
+ *{caller() . '::' . $attrname} = sub {
+ use strict;
+ $Carp::CarpLevel = 1, Carp::croak(
+ "Accessor usage: \$obj->$attrname() or \$obj->$attrname(\$new_value)"
+ ) unless (@_ == 1 or @_ == 2) and ref $_[0];
+ (@_ == 1) ? $_[0]->{$attrname}
+ : ($_[0]->{$attrname} = $_[1]);
+ };
+ }
+ # Ya know, they say accessories make the ensemble!
+ return;
+}
+
+# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
+# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
+#=============================================================================
+
+sub filter {
+ my($class, $source) = @_;
+ my $new = $class->new;
+ $new->output_fh(*STDOUT{IO});
+
+ if(ref($source || '') eq 'SCALAR') {
+ $new->parse_string_document( $$source );
+ } elsif(ref($source)) { # it's a file handle
+ $new->parse_file($source);
+ } else { # it's a filename
+ $new->parse_file($source);
+ }
+
+ return $new;
+}
+
+
+#-----------------------------------------------------------------------------
+
+sub _out {
+ # For use in testing: Class->_out($source)
+ # returns the transformation of $source
+
+ my $class = shift(@_);
+
+ my $mutor = shift(@_) if @_ and ref($_[0] || '') eq 'CODE';
+
+ DEBUG and print "\n\n", '#' x 76,
+ "\nAbout to parse source: {{\n$_[0]\n}}\n\n";
+
+
+ my $parser = ref $class && $class->isa(__PACKAGE__) ? $class : $class->new;
+ $parser->hide_line_numbers(1);
+
+ my $out = '';
+ $parser->output_string( \$out );
+ DEBUG and print " _out to ", \$out, "\n";
+
+ $mutor->($parser) if $mutor;
+
+ $parser->parse_string_document( $_[0] );
+ # use Data::Dumper; print Dumper($parser), "\n";
+ return $out;
+}
+
+
+sub _duo {
+ # For use in testing: Class->_duo($source1, $source2)
+ # returns the parse trees of $source1 and $source2.
+ # Good in things like: &ok( Class->duo(... , ...) );
+
+ my $class = shift(@_);
+
+ Carp::croak "But $class->_duo is useful only in list context!"
+ unless wantarray;
+
+ my $mutor = shift(@_) if @_ and ref($_[0] || '') eq 'CODE';
+
+ Carp::croak "But $class->_duo takes two parameters, not: @_"
+ unless @_ == 2;
+
+ my(@out);
+
+ while( @_ ) {
+ my $parser = $class->new;
+
+ push @out, '';
+ $parser->output_string( \( $out[-1] ) );
+
+ DEBUG and print " _duo out to ", $parser->output_string(),
+ " = $parser->{'output_string'}\n";
+
+ $parser->hide_line_numbers(1);
+ $mutor->($parser) if $mutor;
+ $parser->parse_string_document( shift( @_ ) );
+ # use Data::Dumper; print Dumper($parser), "\n";
+ }
+
+ return @out;
+}
+
+
+
+#-----------------------------------------------------------------------------
+1;
+__END__
+
+TODO:
+A start_formatting_code and end_formatting_code methods, which in the
+base class call start_L, end_L, start_C, end_C, etc., if they are
+defined.
+
+have the POD FORMATTING ERRORS section note the localtime, and the
+version of Pod::Simple.
+
+option to delete all E<shy>s?
+option to scream if under-0x20 literals are found in the input, or
+under-E<32> E codes are found in the tree. And ditto \x7f-\x9f
+
+Option to turn highbit characters into their compromised form? (applies
+to E parsing too)
+
+TODO: BOM/encoding things.
+
+TODO: ascii-compat things in the XML classes?
+
Copied: trunk/contrib/perl/lib/Pod/Simple.pod (from rev 6437, vendor/perl/5.18.1/lib/Pod/Simple.pod)
===================================================================
--- trunk/contrib/perl/lib/Pod/Simple.pod (rev 0)
+++ trunk/contrib/perl/lib/Pod/Simple.pod 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,226 @@
+
+=head1 NAME
+
+Pod::Simple - framework for parsing Pod
+
+=head1 SYNOPSIS
+
+ TODO
+
+=head1 DESCRIPTION
+
+Pod::Simple is a Perl library for parsing text in the Pod ("plain old
+documentation") markup language that is typically used for writing
+documentation for Perl and for Perl modules. The Pod format is explained
+in the L<perlpod|perlpod> man page; the most common formatter is called
+"perldoc".
+
+Pod formatters can use Pod::Simple to parse Pod documents into produce
+renderings of them in plain ASCII, in HTML, or in any number of other
+formats. Typically, such formatters will be subclasses of Pod::Simple,
+and so they will inherit its methods, like C<parse_file>.
+
+If you're reading this document just because you have a Pod-processing
+subclass that you want to use, this document (plus the documentation for
+the subclass) is probably all you'll need to read.
+
+If you're reading this document because you want to write a formatter
+subclass, continue reading this document, and then read
+L<Pod::Simple::Subclassing>, and then possibly even read L<perlpodspec>
+(some of which is for parser-writers, but much of which is notes to
+formatter-writers).
+
+
+=head1 MAIN METHODS
+
+
+
+=over
+
+=item C<< $parser = I<SomeClass>->new(); >>
+
+This returns a new parser object, where I<C<SomeClass>> is a subclass
+of Pod::Simple.
+
+=item C<< $parser->output_fh( *OUT ); >>
+
+This sets the filehandle that C<$parser>'s output will be written to.
+You can pass C<*STDOUT>, otherwise you should probably do something
+like this:
+
+ my $outfile = "output.txt";
+ open TXTOUT, ">$outfile" or die "Can't write to $outfile: $!";
+ $parser->output_fh(*TXTOUT);
+
+...before you call one of the C<< $parser->parse_I<whatever> >> methods.
+
+=item C<< $parser->output_string( \$somestring ); >>
+
+This sets the string that C<$parser>'s output will be sent to,
+instead of any filehandle.
+
+
+=item C<< $parser->parse_file( I<$some_filename> ); >>
+
+=item C<< $parser->parse_file( *INPUT_FH ); >>
+
+This reads the Pod content of the file (or filehandle) that you specify,
+and processes it with that C<$parser> object, according to however
+C<$parser>'s class works, and according to whatever parser options you
+have set up for this C<$parser> object.
+
+=item C<< $parser->parse_string_document( I<$all_content> ); >>
+
+This works just like C<parse_file> except that it reads the Pod
+content not from a file, but from a string that you have already
+in memory.
+
+=item C<< $parser->parse_lines( I<... at lines...>, undef ); >>
+
+This processes the lines in C<@lines> (where each list item must be a
+defined value, and must contain exactly one line of content -- so no
+items like C<"foo\nbar"> are allowed). The final C<undef> is used to
+indicate the end of document being parsed.
+
+The other C<parser_I<whatever>> methods are meant to be called only once
+per C<$parser> object; but C<parse_lines> can be called as many times per
+C<$parser> object as you want, as long as the last call (and only
+the last call) ends with an C<undef> value.
+
+
+=item C<< $parser->content_seen >>
+
+This returns true only if there has been any real content seen
+for this document.
+
+
+=item C<< I<SomeClass>->filter( I<$filename> ); >>
+
+=item C<< I<SomeClass>->filter( I<*INPUT_FH> ); >>
+
+=item C<< I<SomeClass>->filter( I<\$document_content> ); >>
+
+This is a shortcut method for creating a new parser object, setting the
+output handle to STDOUT, and then processing the specified file (or
+filehandle, or in-memory document). This is handy for one-liners like
+this:
+
+ perl -MPod::Simple::Text -e "Pod::Simple::Text->filter('thingy.pod')"
+
+=back
+
+
+
+=head1 SECONDARY METHODS
+
+Some of these methods might be of interest to general users, as
+well as of interest to formatter-writers.
+
+Note that the general pattern here is that the accessor-methods
+read the attribute's value with C<< $value = $parser->I<attribute> >>
+and set the attribute's value with
+C<< $parser->I<attribute>(I<newvalue>) >>. For each accessor, I typically
+only mention one syntax or another, based on which I think you are actually
+most likely to use.
+
+
+=over
+
+=item C<< $parser->no_whining( I<SOMEVALUE> ) >>
+
+If you set this attribute to a true value, you will suppress the
+parser's complaints about irregularities in the Pod coding. By default,
+this attribute's value is false, meaning that irregularities will
+be reported.
+
+Note that turning this attribute to true won't suppress one or two kinds
+of complaints about rarely occurring unrecoverable errors.
+
+
+=item C<< $parser->no_errata_section( I<SOMEVALUE> ) >>
+
+If you set this attribute to a true value, you will stop the parser from
+generating a "POD ERRORS" section at the end of the document. By
+default, this attribute's value is false, meaning that an errata section
+will be generated, as necessary.
+
+
+=item C<< $parser->complain_stderr( I<SOMEVALUE> ) >>
+
+If you set this attribute to a true value, it will send reports of
+parsing errors to STDERR. By default, this attribute's value is false,
+meaning that no output is sent to STDERR.
+
+Note that errors can be noted in an errata section, or sent to STDERR,
+or both, or neither. So don't think that turning on C<complain_stderr>
+will turn off C<no_errata_section> or vice versa -- these are
+independent attributes.
+
+
+=item C<< $parser->source_filename >>
+
+This returns the filename that this parser object was set to read from.
+
+
+=item C<< $parser->doc_has_started >>
+
+This returns true if C<$parser> has read from a source, and has seen
+Pod content in it.
+
+
+=item C<< $parser->source_dead >>
+
+This returns true if C<$parser> has read from a source, and come to the
+end of that source.
+
+=back
+
+
+=head1 CAVEATS
+
+This is just a beta release -- there are a good number of things still
+left to do. Notably, support for EBCDIC platforms is still half-done,
+an untested.
+
+
+=head1 SEE ALSO
+
+L<Pod::Simple::Subclassing>
+
+L<perlpod|perlpod>
+
+L<perlpodspec|perlpodspec>
+
+L<Pod::Escapes|Pod::Escapes>
+
+L<perldoc>
+
+
+=head1 COPYRIGHT AND DISCLAIMERS
+
+Copyright (c) 2002 Sean M. Burke. All rights reserved.
+
+This library is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+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.
+
+=head1 AUTHOR
+
+Original author: Sean M. Burke C<sburke at cpan.org>
+
+Maintained by:
+
+=over
+
+=item * Allison Randal C<allison at perl.org>
+
+=item * Hans Dieter Pearcey C<hdp at cpan.org>
+
+=back
+
+=cut
+
+
Copied: trunk/contrib/perl/lib/Pod/Text.pm (from rev 6437, vendor/perl/5.18.1/lib/Pod/Text.pm)
===================================================================
--- trunk/contrib/perl/lib/Pod/Text.pm (rev 0)
+++ trunk/contrib/perl/lib/Pod/Text.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,861 @@
+# Pod::Text -- Convert POD data to formatted ASCII text.
+#
+# Copyright 1999, 2000, 2001, 2002, 2004, 2006, 2008
+# Russ Allbery <rra at stanford.edu>
+#
+# This program is free software; you may redistribute it and/or modify it
+# under the same terms as Perl itself.
+#
+# This module converts POD to formatted text. It replaces the old Pod::Text
+# module that came with versions of Perl prior to 5.6.0 and attempts to match
+# its output except for some specific circumstances where other decisions
+# seemed to produce better output. It uses Pod::Parser and is designed to be
+# very easy to subclass.
+#
+# Perl core hackers, please note that this module is also separately
+# maintained outside of the Perl core as part of the podlators. Please send
+# me any patches at the address above in addition to sending them to the
+# standard Perl mailing lists.
+
+##############################################################################
+# Modules and declarations
+##############################################################################
+
+package Pod::Text;
+
+require 5.004;
+
+use strict;
+use vars qw(@ISA @EXPORT %ESCAPES $VERSION);
+
+use Carp qw(carp croak);
+use Exporter ();
+use Pod::Simple ();
+
+ at ISA = qw(Pod::Simple Exporter);
+
+# We have to export pod2text for backward compatibility.
+ at EXPORT = qw(pod2text);
+
+$VERSION = '3.13';
+
+##############################################################################
+# Initialization
+##############################################################################
+
+# This function handles code blocks. It's registered as a callback to
+# Pod::Simple and therefore doesn't work as a regular method call, but all it
+# does is call output_code with the line.
+sub handle_code {
+ my ($line, $number, $parser) = @_;
+ $parser->output_code ($line . "\n");
+}
+
+# Initialize the object and set various Pod::Simple options that we need.
+# Here, we also process any additional options passed to the constructor or
+# set up defaults if none were given. Note that all internal object keys are
+# in all-caps, reserving all lower-case object keys for Pod::Simple and user
+# arguments.
+sub new {
+ my $class = shift;
+ my $self = $class->SUPER::new;
+
+ # Tell Pod::Simple to handle S<> by automatically inserting .
+ $self->nbsp_for_S (1);
+
+ # Tell Pod::Simple to keep whitespace whenever possible.
+ if ($self->can ('preserve_whitespace')) {
+ $self->preserve_whitespace (1);
+ } else {
+ $self->fullstop_space_harden (1);
+ }
+
+ # The =for and =begin targets that we accept.
+ $self->accept_targets (qw/text TEXT/);
+
+ # Ensure that contiguous blocks of code are merged together. Otherwise,
+ # some of the guesswork heuristics don't work right.
+ $self->merge_text (1);
+
+ # Pod::Simple doesn't do anything useful with our arguments, but we want
+ # to put them in our object as hash keys and values. This could cause
+ # problems if we ever clash with Pod::Simple's own internal class
+ # variables.
+ my %opts = @_;
+ my @opts = map { ("opt_$_", $opts{$_}) } keys %opts;
+ %$self = (%$self, @opts);
+
+ # Send errors to stderr if requested.
+ if ($$self{opt_stderr}) {
+ $self->no_errata_section (1);
+ $self->complain_stderr (1);
+ delete $$self{opt_stderr};
+ }
+
+ # Initialize various things from our parameters.
+ $$self{opt_alt} = 0 unless defined $$self{opt_alt};
+ $$self{opt_indent} = 4 unless defined $$self{opt_indent};
+ $$self{opt_margin} = 0 unless defined $$self{opt_margin};
+ $$self{opt_loose} = 0 unless defined $$self{opt_loose};
+ $$self{opt_sentence} = 0 unless defined $$self{opt_sentence};
+ $$self{opt_width} = 76 unless defined $$self{opt_width};
+
+ # Figure out what quotes we'll be using for C<> text.
+ $$self{opt_quotes} ||= '"';
+ if ($$self{opt_quotes} eq 'none') {
+ $$self{LQUOTE} = $$self{RQUOTE} = '';
+ } elsif (length ($$self{opt_quotes}) == 1) {
+ $$self{LQUOTE} = $$self{RQUOTE} = $$self{opt_quotes};
+ } elsif ($$self{opt_quotes} =~ /^(.)(.)$/
+ || $$self{opt_quotes} =~ /^(..)(..)$/) {
+ $$self{LQUOTE} = $1;
+ $$self{RQUOTE} = $2;
+ } else {
+ croak qq(Invalid quote specification "$$self{opt_quotes}");
+ }
+
+ # If requested, do something with the non-POD text.
+ $self->code_handler (\&handle_code) if $$self{opt_code};
+
+ # Return the created object.
+ return $self;
+}
+
+##############################################################################
+# Core parsing
+##############################################################################
+
+# This is the glue that connects the code below with Pod::Simple itself. The
+# goal is to convert the event stream coming from the POD parser into method
+# calls to handlers once the complete content of a tag has been seen. Each
+# paragraph or POD command will have textual content associated with it, and
+# as soon as all of a paragraph or POD command has been seen, that content
+# will be passed in to the corresponding method for handling that type of
+# object. The exceptions are handlers for lists, which have opening tag
+# handlers and closing tag handlers that will be called right away.
+#
+# The internal hash key PENDING is used to store the contents of a tag until
+# all of it has been seen. It holds a stack of open tags, each one
+# represented by a tuple of the attributes hash for the tag and the contents
+# of the tag.
+
+# Add a block of text to the contents of the current node, formatting it
+# according to the current formatting instructions as we do.
+sub _handle_text {
+ my ($self, $text) = @_;
+ my $tag = $$self{PENDING}[-1];
+ $$tag[1] .= $text;
+}
+
+# Given an element name, get the corresponding method name.
+sub method_for_element {
+ my ($self, $element) = @_;
+ $element =~ tr/-/_/;
+ $element =~ tr/A-Z/a-z/;
+ $element =~ tr/_a-z0-9//cd;
+ return $element;
+}
+
+# Handle the start of a new element. If cmd_element is defined, assume that
+# we need to collect the entire tree for this element before passing it to the
+# element method, and create a new tree into which we'll collect blocks of
+# text and nested elements. Otherwise, if start_element is defined, call it.
+sub _handle_element_start {
+ my ($self, $element, $attrs) = @_;
+ my $method = $self->method_for_element ($element);
+
+ # If we have a command handler, we need to accumulate the contents of the
+ # tag before calling it.
+ if ($self->can ("cmd_$method")) {
+ push (@{ $$self{PENDING} }, [ $attrs, '' ]);
+ } elsif ($self->can ("start_$method")) {
+ my $method = 'start_' . $method;
+ $self->$method ($attrs, '');
+ }
+}
+
+# Handle the end of an element. If we had a cmd_ method for this element,
+# this is where we pass along the text that we've accumulated. Otherwise, if
+# we have an end_ method for the element, call that.
+sub _handle_element_end {
+ my ($self, $element) = @_;
+ my $method = $self->method_for_element ($element);
+
+ # If we have a command handler, pull off the pending text and pass it to
+ # the handler along with the saved attribute hash.
+ if ($self->can ("cmd_$method")) {
+ my $tag = pop @{ $$self{PENDING} };
+ my $method = 'cmd_' . $method;
+ my $text = $self->$method (@$tag);
+ if (defined $text) {
+ if (@{ $$self{PENDING} } > 1) {
+ $$self{PENDING}[-1][1] .= $text;
+ } else {
+ $self->output ($text);
+ }
+ }
+ } elsif ($self->can ("end_$method")) {
+ my $method = 'end_' . $method;
+ $self->$method ();
+ }
+}
+
+##############################################################################
+# Output formatting
+##############################################################################
+
+# Wrap a line, indenting by the current left margin. We can't use Text::Wrap
+# because it plays games with tabs. We can't use formline, even though we'd
+# really like to, because it screws up non-printing characters. So we have to
+# do the wrapping ourselves.
+sub wrap {
+ my $self = shift;
+ local $_ = shift;
+ my $output = '';
+ my $spaces = ' ' x $$self{MARGIN};
+ my $width = $$self{opt_width} - $$self{MARGIN};
+ while (length > $width) {
+ if (s/^([^\n]{0,$width})\s+// || s/^([^\n]{$width})//) {
+ $output .= $spaces . $1 . "\n";
+ } else {
+ last;
+ }
+ }
+ $output .= $spaces . $_;
+ $output =~ s/\s+$/\n\n/;
+ return $output;
+}
+
+# Reformat a paragraph of text for the current margin. Takes the text to
+# reformat and returns the formatted text.
+sub reformat {
+ my $self = shift;
+ local $_ = shift;
+
+ # If we're trying to preserve two spaces after sentences, do some munging
+ # to support that. Otherwise, smash all repeated whitespace.
+ if ($$self{opt_sentence}) {
+ s/ +$//mg;
+ s/\.\n/. \n/g;
+ s/\n/ /g;
+ s/ +/ /g;
+ } else {
+ s/\s+/ /g;
+ }
+ return $self->wrap ($_);
+}
+
+# Output text to the output device. Replace non-breaking spaces with spaces
+# and soft hyphens with nothing, and then try to fix the output encoding if
+# necessary to match the input encoding unless UTF-8 output is forced. This
+# preserves the traditional pass-through behavior of Pod::Text.
+sub output {
+ my ($self, $text) = @_;
+ $text =~ tr/\240\255/ /d;
+ unless ($$self{opt_utf8} || $$self{CHECKED_ENCODING}) {
+ my $encoding = $$self{encoding} || '';
+ if ($encoding) {
+ eval { binmode ($$self{output_fh}, ":encoding($encoding)") };
+ }
+ $$self{CHECKED_ENCODING} = 1;
+ }
+ print { $$self{output_fh} } $text;
+}
+
+# Output a block of code (something that isn't part of the POD text). Called
+# by preprocess_paragraph only if we were given the code option. Exists here
+# only so that it can be overridden by subclasses.
+sub output_code { $_[0]->output ($_[1]) }
+
+##############################################################################
+# Document initialization
+##############################################################################
+
+# Set up various things that have to be initialized on a per-document basis.
+sub start_document {
+ my $self = shift;
+ my $margin = $$self{opt_indent} + $$self{opt_margin};
+
+ # Initialize a few per-document variables.
+ $$self{INDENTS} = []; # Stack of indentations.
+ $$self{MARGIN} = $margin; # Default left margin.
+ $$self{PENDING} = [[]]; # Pending output.
+
+ # We have to redo encoding handling for each document.
+ delete $$self{CHECKED_ENCODING};
+
+ # If we were given the utf8 option, set an output encoding on our file
+ # handle. Wrap in an eval in case we're using a version of Perl too old
+ # to understand this.
+ #
+ # This is evil because it changes the global state of a file handle that
+ # we may not own. However, we can't just blindly encode all output, since
+ # there may be a pre-applied output encoding (such as from PERL_UNICODE)
+ # and then we would double-encode. This seems to be the least bad
+ # approach.
+ if ($$self{opt_utf8}) {
+ eval { binmode ($$self{output_fh}, ':encoding(UTF-8)') };
+ }
+
+ return '';
+}
+
+##############################################################################
+# Text blocks
+##############################################################################
+
+# This method is called whenever an =item command is complete (in other words,
+# we've seen its associated paragraph or know for certain that it doesn't have
+# one). It gets the paragraph associated with the item as an argument. If
+# that argument is empty, just output the item tag; if it contains a newline,
+# output the item tag followed by the newline. Otherwise, see if there's
+# enough room for us to output the item tag in the margin of the text or if we
+# have to put it on a separate line.
+sub item {
+ my ($self, $text) = @_;
+ my $tag = $$self{ITEM};
+ unless (defined $tag) {
+ carp "Item called without tag";
+ return;
+ }
+ undef $$self{ITEM};
+
+ # Calculate the indentation and margin. $fits is set to true if the tag
+ # will fit into the margin of the paragraph given our indentation level.
+ my $indent = $$self{INDENTS}[-1];
+ $indent = $$self{opt_indent} unless defined $indent;
+ my $margin = ' ' x $$self{opt_margin};
+ my $fits = ($$self{MARGIN} - $indent >= length ($tag) + 1);
+
+ # If the tag doesn't fit, or if we have no associated text, print out the
+ # tag separately. Otherwise, put the tag in the margin of the paragraph.
+ if (!$text || $text =~ /^\s+$/ || !$fits) {
+ my $realindent = $$self{MARGIN};
+ $$self{MARGIN} = $indent;
+ my $output = $self->reformat ($tag);
+ $output =~ s/^$margin /$margin:/ if ($$self{opt_alt} && $indent > 0);
+ $output =~ s/\n*$/\n/;
+
+ # If the text is just whitespace, we have an empty item paragraph;
+ # this can result from =over/=item/=back without any intermixed
+ # paragraphs. Insert some whitespace to keep the =item from merging
+ # into the next paragraph.
+ $output .= "\n" if $text && $text =~ /^\s*$/;
+
+ $self->output ($output);
+ $$self{MARGIN} = $realindent;
+ $self->output ($self->reformat ($text)) if ($text && $text =~ /\S/);
+ } else {
+ my $space = ' ' x $indent;
+ $space =~ s/^$margin /$margin:/ if $$self{opt_alt};
+ $text = $self->reformat ($text);
+ $text =~ s/^$margin /$margin:/ if ($$self{opt_alt} && $indent > 0);
+ my $tagspace = ' ' x length $tag;
+ $text =~ s/^($space)$tagspace/$1$tag/ or warn "Bizarre space in item";
+ $self->output ($text);
+ }
+}
+
+# Handle a basic block of text. The only tricky thing here is that if there
+# is a pending item tag, we need to format this as an item paragraph.
+sub cmd_para {
+ my ($self, $attrs, $text) = @_;
+ $text =~ s/\s+$/\n/;
+ if (defined $$self{ITEM}) {
+ $self->item ($text . "\n");
+ } else {
+ $self->output ($self->reformat ($text . "\n"));
+ }
+ return '';
+}
+
+# Handle a verbatim paragraph. Just print it out, but indent it according to
+# our margin.
+sub cmd_verbatim {
+ my ($self, $attrs, $text) = @_;
+ $self->item if defined $$self{ITEM};
+ return if $text =~ /^\s*$/;
+ $text =~ s/^(\n*)([ \t]*\S+)/$1 . (' ' x $$self{MARGIN}) . $2/gme;
+ $text =~ s/\s*$/\n\n/;
+ $self->output ($text);
+ return '';
+}
+
+# Handle literal text (produced by =for and similar constructs). Just output
+# it with the minimum of changes.
+sub cmd_data {
+ my ($self, $attrs, $text) = @_;
+ $text =~ s/^\n+//;
+ $text =~ s/\n{0,2}$/\n/;
+ $self->output ($text);
+ return '';
+}
+
+##############################################################################
+# Headings
+##############################################################################
+
+# The common code for handling all headers. Takes the header text, the
+# indentation, and the surrounding marker for the alt formatting method.
+sub heading {
+ my ($self, $text, $indent, $marker) = @_;
+ $self->item ("\n\n") if defined $$self{ITEM};
+ $text =~ s/\s+$//;
+ if ($$self{opt_alt}) {
+ my $closemark = reverse (split (//, $marker));
+ my $margin = ' ' x $$self{opt_margin};
+ $self->output ("\n" . "$margin$marker $text $closemark" . "\n\n");
+ } else {
+ $text .= "\n" if $$self{opt_loose};
+ my $margin = ' ' x ($$self{opt_margin} + $indent);
+ $self->output ($margin . $text . "\n");
+ }
+ return '';
+}
+
+# First level heading.
+sub cmd_head1 {
+ my ($self, $attrs, $text) = @_;
+ $self->heading ($text, 0, '====');
+}
+
+# Second level heading.
+sub cmd_head2 {
+ my ($self, $attrs, $text) = @_;
+ $self->heading ($text, $$self{opt_indent} / 2, '== ');
+}
+
+# Third level heading.
+sub cmd_head3 {
+ my ($self, $attrs, $text) = @_;
+ $self->heading ($text, $$self{opt_indent} * 2 / 3 + 0.5, '= ');
+}
+
+# Fourth level heading.
+sub cmd_head4 {
+ my ($self, $attrs, $text) = @_;
+ $self->heading ($text, $$self{opt_indent} * 3 / 4 + 0.5, '- ');
+}
+
+##############################################################################
+# List handling
+##############################################################################
+
+# Handle the beginning of an =over block. Takes the type of the block as the
+# first argument, and then the attr hash. This is called by the handlers for
+# the four different types of lists (bullet, number, text, and block).
+sub over_common_start {
+ my ($self, $attrs) = @_;
+ $self->item ("\n\n") if defined $$self{ITEM};
+
+ # Find the indentation level.
+ my $indent = $$attrs{indent};
+ unless (defined ($indent) && $indent =~ /^\s*[-+]?\d{1,4}\s*$/) {
+ $indent = $$self{opt_indent};
+ }
+
+ # Add this to our stack of indents and increase our current margin.
+ push (@{ $$self{INDENTS} }, $$self{MARGIN});
+ $$self{MARGIN} += ($indent + 0);
+ return '';
+}
+
+# End an =over block. Takes no options other than the class pointer. Output
+# any pending items and then pop one level of indentation.
+sub over_common_end {
+ my ($self) = @_;
+ $self->item ("\n\n") if defined $$self{ITEM};
+ $$self{MARGIN} = pop @{ $$self{INDENTS} };
+ return '';
+}
+
+# Dispatch the start and end calls as appropriate.
+sub start_over_bullet { $_[0]->over_common_start ($_[1]) }
+sub start_over_number { $_[0]->over_common_start ($_[1]) }
+sub start_over_text { $_[0]->over_common_start ($_[1]) }
+sub start_over_block { $_[0]->over_common_start ($_[1]) }
+sub end_over_bullet { $_[0]->over_common_end }
+sub end_over_number { $_[0]->over_common_end }
+sub end_over_text { $_[0]->over_common_end }
+sub end_over_block { $_[0]->over_common_end }
+
+# The common handler for all item commands. Takes the type of the item, the
+# attributes, and then the text of the item.
+sub item_common {
+ my ($self, $type, $attrs, $text) = @_;
+ $self->item if defined $$self{ITEM};
+
+ # Clean up the text. We want to end up with two variables, one ($text)
+ # which contains any body text after taking out the item portion, and
+ # another ($item) which contains the actual item text. Note the use of
+ # the internal Pod::Simple attribute here; that's a potential land mine.
+ $text =~ s/\s+$//;
+ my ($item, $index);
+ if ($type eq 'bullet') {
+ $item = '*';
+ } elsif ($type eq 'number') {
+ $item = $$attrs{'~orig_content'};
+ } else {
+ $item = $text;
+ $item =~ s/\s*\n\s*/ /g;
+ $text = '';
+ }
+ $$self{ITEM} = $item;
+
+ # If body text for this item was included, go ahead and output that now.
+ if ($text) {
+ $text =~ s/\s*$/\n/;
+ $self->item ($text);
+ }
+ return '';
+}
+
+# Dispatch the item commands to the appropriate place.
+sub cmd_item_bullet { my $self = shift; $self->item_common ('bullet', @_) }
+sub cmd_item_number { my $self = shift; $self->item_common ('number', @_) }
+sub cmd_item_text { my $self = shift; $self->item_common ('text', @_) }
+sub cmd_item_block { my $self = shift; $self->item_common ('block', @_) }
+
+##############################################################################
+# Formatting codes
+##############################################################################
+
+# The simple ones.
+sub cmd_b { return $_[0]{alt} ? "``$_[2]''" : $_[2] }
+sub cmd_f { return $_[0]{alt} ? "\"$_[2]\"" : $_[2] }
+sub cmd_i { return '*' . $_[2] . '*' }
+sub cmd_x { return '' }
+
+# Apply a whole bunch of messy heuristics to not quote things that don't
+# benefit from being quoted. These originally come from Barrie Slaymaker and
+# largely duplicate code in Pod::Man.
+sub cmd_c {
+ my ($self, $attrs, $text) = @_;
+
+ # A regex that matches the portion of a variable reference that's the
+ # array or hash index, separated out just because we want to use it in
+ # several places in the following regex.
+ my $index = '(?: \[.*\] | \{.*\} )?';
+
+ # Check for things that we don't want to quote, and if we find any of
+ # them, return the string with just a font change and no quoting.
+ $text =~ m{
+ ^\s*
+ (?:
+ ( [\'\`\"] ) .* \1 # already quoted
+ | \` .* \' # `quoted'
+ | \$+ [\#^]? \S $index # special ($^Foo, $")
+ | [\$\@%&*]+ \#? [:\'\w]+ $index # plain var or func
+ | [\$\@%&*]* [:\'\w]+ (?: -> )? \(\s*[^\s,]\s*\) # 0/1-arg func call
+ | [+-]? ( \d[\d.]* | \.\d+ ) (?: [eE][+-]?\d+ )? # a number
+ | 0x [a-fA-F\d]+ # a hex constant
+ )
+ \s*\z
+ }xo && return $text;
+
+ # If we didn't return, go ahead and quote the text.
+ return $$self{opt_alt}
+ ? "``$text''"
+ : "$$self{LQUOTE}$text$$self{RQUOTE}";
+}
+
+# Links reduce to the text that we're given, wrapped in angle brackets if it's
+# a URL.
+sub cmd_l {
+ my ($self, $attrs, $text) = @_;
+ return $$attrs{type} eq 'url' ? "<$text>" : $text;
+}
+
+##############################################################################
+# Backwards compatibility
+##############################################################################
+
+# The old Pod::Text module did everything in a pod2text() function. This
+# tries to provide the same interface for legacy applications.
+sub pod2text {
+ my @args;
+
+ # This is really ugly; I hate doing option parsing in the middle of a
+ # module. But the old Pod::Text module supported passing flags to its
+ # entry function, so handle -a and -<number>.
+ while ($_[0] =~ /^-/) {
+ my $flag = shift;
+ if ($flag eq '-a') { push (@args, alt => 1) }
+ elsif ($flag =~ /^-(\d+)$/) { push (@args, width => $1) }
+ else {
+ unshift (@_, $flag);
+ last;
+ }
+ }
+
+ # Now that we know what arguments we're using, create the parser.
+ my $parser = Pod::Text->new (@args);
+
+ # If two arguments were given, the second argument is going to be a file
+ # handle. That means we want to call parse_from_filehandle(), which means
+ # we need to turn the first argument into a file handle. Magic open will
+ # handle the <&STDIN case automagically.
+ if (defined $_[1]) {
+ my @fhs = @_;
+ local *IN;
+ unless (open (IN, $fhs[0])) {
+ croak ("Can't open $fhs[0] for reading: $!\n");
+ return;
+ }
+ $fhs[0] = \*IN;
+ $parser->output_fh ($fhs[1]);
+ my $retval = $parser->parse_file ($fhs[0]);
+ my $fh = $parser->output_fh ();
+ close $fh;
+ return $retval;
+ } else {
+ $parser->output_fh (\*STDOUT);
+ return $parser->parse_file (@_);
+ }
+}
+
+# Reset the underlying Pod::Simple object between calls to parse_from_file so
+# that the same object can be reused to convert multiple pages.
+sub parse_from_file {
+ my $self = shift;
+ $self->reinit;
+
+ # Fake the old cutting option to Pod::Parser. This fiddings with internal
+ # Pod::Simple state and is quite ugly; we need a better approach.
+ if (ref ($_[0]) eq 'HASH') {
+ my $opts = shift @_;
+ if (defined ($$opts{-cutting}) && !$$opts{-cutting}) {
+ $$self{in_pod} = 1;
+ $$self{last_was_blank} = 1;
+ }
+ }
+
+ # Do the work.
+ my $retval = $self->Pod::Simple::parse_from_file (@_);
+
+ # Flush output, since Pod::Simple doesn't do this. Ideally we should also
+ # close the file descriptor if we had to open one, but we can't easily
+ # figure this out.
+ my $fh = $self->output_fh ();
+ my $oldfh = select $fh;
+ my $oldflush = $|;
+ $| = 1;
+ print $fh '';
+ $| = $oldflush;
+ select $oldfh;
+ return $retval;
+}
+
+# Pod::Simple failed to provide this backward compatibility function, so
+# implement it ourselves. File handles are one of the inputs that
+# parse_from_file supports.
+sub parse_from_filehandle {
+ my $self = shift;
+ $self->parse_from_file (@_);
+}
+
+##############################################################################
+# Module return value and documentation
+##############################################################################
+
+1;
+__END__
+
+=head1 NAME
+
+Pod::Text - Convert POD data to formatted ASCII text
+
+=for stopwords
+alt stderr Allbery Sean Burke's Christiansen UTF-8 pre-Unicode utf8
+
+=head1 SYNOPSIS
+
+ use Pod::Text;
+ my $parser = Pod::Text->new (sentence => 0, width => 78);
+
+ # Read POD from STDIN and write to STDOUT.
+ $parser->parse_from_filehandle;
+
+ # Read POD from file.pod and write to file.txt.
+ $parser->parse_from_file ('file.pod', 'file.txt');
+
+=head1 DESCRIPTION
+
+Pod::Text is a module that can convert documentation in the POD format (the
+preferred language for documenting Perl) into formatted ASCII. It uses no
+special formatting controls or codes whatsoever, and its output is therefore
+suitable for nearly any device.
+
+As a derived class from Pod::Simple, Pod::Text supports the same methods and
+interfaces. See L<Pod::Simple> for all the details; briefly, one creates a
+new parser with C<< Pod::Text->new() >> and then normally calls parse_file().
+
+new() can take options, in the form of key/value pairs, that control the
+behavior of the parser. The currently recognized options are:
+
+=over 4
+
+=item alt
+
+If set to a true value, selects an alternate output format that, among other
+things, uses a different heading style and marks C<=item> entries with a
+colon in the left margin. Defaults to false.
+
+=item code
+
+If set to a true value, the non-POD parts of the input file will be included
+in the output. Useful for viewing code documented with POD blocks with the
+POD rendered and the code left intact.
+
+=item indent
+
+The number of spaces to indent regular text, and the default indentation for
+C<=over> blocks. Defaults to 4.
+
+=item loose
+
+If set to a true value, a blank line is printed after a C<=head1> heading.
+If set to false (the default), no blank line is printed after C<=head1>,
+although one is still printed after C<=head2>. This is the default because
+it's the expected formatting for manual pages; if you're formatting
+arbitrary text documents, setting this to true may result in more pleasing
+output.
+
+=item margin
+
+The width of the left margin in spaces. Defaults to 0. This is the margin
+for all text, including headings, not the amount by which regular text is
+indented; for the latter, see the I<indent> option. To set the right
+margin, see the I<width> option.
+
+=item quotes
+
+Sets the quote marks used to surround CE<lt>> text. If the value is a
+single character, it is used as both the left and right quote; if it is two
+characters, the first character is used as the left quote and the second as
+the right quoted; and if it is four characters, the first two are used as
+the left quote and the second two as the right quote.
+
+This may also be set to the special value C<none>, in which case no quote
+marks are added around CE<lt>> text.
+
+=item sentence
+
+If set to a true value, Pod::Text will assume that each sentence ends in two
+spaces, and will try to preserve that spacing. If set to false, all
+consecutive whitespace in non-verbatim paragraphs is compressed into a
+single space. Defaults to true.
+
+=item stderr
+
+Send error messages about invalid POD to standard error instead of
+appending a POD ERRORS section to the generated output.
+
+=item utf8
+
+By default, Pod::Text uses the same output encoding as the input encoding
+of the POD source (provided that Perl was built with PerlIO; otherwise, it
+doesn't encode its output). If this option is given, the output encoding
+is forced to UTF-8.
+
+Be aware that, when using this option, the input encoding of your POD
+source must be properly declared unless it is US-ASCII or Latin-1. POD
+input without an C<=encoding> command will be assumed to be in Latin-1,
+and if it's actually in UTF-8, the output will be double-encoded. See
+L<perlpod(1)> for more information on the C<=encoding> command.
+
+=item width
+
+The column at which to wrap text on the right-hand side. Defaults to 76.
+
+=back
+
+The standard Pod::Simple method parse_file() takes one argument, the file or
+file handle to read from, and writes output to standard output unless that
+has been changed with the output_fh() method. See L<Pod::Simple> for the
+specific details and for other alternative interfaces.
+
+=head1 DIAGNOSTICS
+
+=over 4
+
+=item Bizarre space in item
+
+=item Item called without tag
+
+(W) Something has gone wrong in internal C<=item> processing. These
+messages indicate a bug in Pod::Text; you should never see them.
+
+=item Can't open %s for reading: %s
+
+(F) Pod::Text was invoked via the compatibility mode pod2text() interface
+and the input file it was given could not be opened.
+
+=item Invalid quote specification "%s"
+
+(F) The quote specification given (the quotes option to the constructor) was
+invalid. A quote specification must be one, two, or four characters long.
+
+=back
+
+=head1 BUGS
+
+Encoding handling assumes that PerlIO is available and does not work
+properly if it isn't. The C<utf8> option is therefore not supported
+unless Perl is built with PerlIO support.
+
+=head1 CAVEATS
+
+If Pod::Text is given the C<utf8> option, the encoding of its output file
+handle will be forced to UTF-8 if possible, overriding any existing
+encoding. This will be done even if the file handle is not created by
+Pod::Text and was passed in from outside. This maintains consistency
+regardless of PERL_UNICODE and other settings.
+
+If the C<utf8> option is not given, the encoding of its output file handle
+will be forced to the detected encoding of the input POD, which preserves
+whatever the input text is. This ensures backward compatibility with
+earlier, pre-Unicode versions of this module, without large numbers of
+Perl warnings.
+
+This is not ideal, but it seems to be the best compromise. If it doesn't
+work for you, please let me know the details of how it broke.
+
+=head1 NOTES
+
+This is a replacement for an earlier Pod::Text module written by Tom
+Christiansen. It has a revamped interface, since it now uses Pod::Simple,
+but an interface roughly compatible with the old Pod::Text::pod2text()
+function is still available. Please change to the new calling convention,
+though.
+
+The original Pod::Text contained code to do formatting via termcap
+sequences, although it wasn't turned on by default and it was problematic to
+get it to work at all. This rewrite doesn't even try to do that, but a
+subclass of it does. Look for L<Pod::Text::Termcap>.
+
+=head1 SEE ALSO
+
+L<Pod::Simple>, L<Pod::Text::Termcap>, L<perlpod(1)>, L<pod2text(1)>
+
+The current version of this module is always available from its web site at
+L<http://www.eyrie.org/~eagle/software/podlators/>. It is also part of the
+Perl core distribution as of 5.6.0.
+
+=head1 AUTHOR
+
+Russ Allbery <rra at stanford.edu>, based I<very> heavily on the original
+Pod::Text by Tom Christiansen <tchrist at mox.perl.com> and its conversion to
+Pod::Parser by Brad Appleton <bradapp at enteract.com>. Sean Burke's initial
+conversion of Pod::Man to use Pod::Simple provided much-needed guidance on
+how to use Pod::Simple.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 1999, 2000, 2001, 2002, 2004, 2006, 2008 Russ Allbery
+<rra at stanford.edu>.
+
+This program is free software; you may redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
Copied: trunk/contrib/perl/lib/Pod/Usage.pm (from rev 6437, vendor/perl/5.18.1/lib/Pod/Usage.pm)
===================================================================
--- trunk/contrib/perl/lib/Pod/Usage.pm (rev 0)
+++ trunk/contrib/perl/lib/Pod/Usage.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,730 @@
+#############################################################################
+# Pod/Usage.pm -- print usage messages for the running script.
+#
+# Copyright (C) 1996-2000 by Bradford Appleton. All rights reserved.
+# This file is part of "PodParser". PodParser is free software;
+# you can redistribute it and/or modify it under the same terms
+# as Perl itself.
+#############################################################################
+
+package Pod::Usage;
+use strict;
+
+use vars qw($VERSION @ISA @EXPORT);
+$VERSION = '1.36'; ## Current version of this package
+require 5.005; ## requires this Perl version or later
+
+=head1 NAME
+
+Pod::Usage, pod2usage() - print a usage message from embedded pod documentation
+
+=head1 SYNOPSIS
+
+ use Pod::Usage
+
+ my $message_text = "This text precedes the usage message.";
+ my $exit_status = 2; ## The exit status to use
+ my $verbose_level = 0; ## The verbose level to use
+ my $filehandle = \*STDERR; ## The filehandle to write to
+
+ pod2usage($message_text);
+
+ pod2usage($exit_status);
+
+ pod2usage( { -message => $message_text ,
+ -exitval => $exit_status ,
+ -verbose => $verbose_level,
+ -output => $filehandle } );
+
+ pod2usage( -msg => $message_text ,
+ -exitval => $exit_status ,
+ -verbose => $verbose_level,
+ -output => $filehandle );
+
+ pod2usage( -verbose => 2,
+ -noperldoc => 1 )
+
+=head1 ARGUMENTS
+
+B<pod2usage> should be given either a single argument, or a list of
+arguments corresponding to an associative array (a "hash"). When a single
+argument is given, it should correspond to exactly one of the following:
+
+=over 4
+
+=item *
+
+A string containing the text of a message to print I<before> printing
+the usage message
+
+=item *
+
+A numeric value corresponding to the desired exit status
+
+=item *
+
+A reference to a hash
+
+=back
+
+If more than one argument is given then the entire argument list is
+assumed to be a hash. If a hash is supplied (either as a reference or
+as a list) it should contain one or more elements with the following
+keys:
+
+=over 4
+
+=item C<-message>
+
+=item C<-msg>
+
+The text of a message to print immediately prior to printing the
+program's usage message.
+
+=item C<-exitval>
+
+The desired exit status to pass to the B<exit()> function.
+This should be an integer, or else the string "NOEXIT" to
+indicate that control should simply be returned without
+terminating the invoking process.
+
+=item C<-verbose>
+
+The desired level of "verboseness" to use when printing the usage
+message. If the corresponding value is 0, then only the "SYNOPSIS"
+section of the pod documentation is printed. If the corresponding value
+is 1, then the "SYNOPSIS" section, along with any section entitled
+"OPTIONS", "ARGUMENTS", or "OPTIONS AND ARGUMENTS" is printed. If the
+corresponding value is 2 or more then the entire manpage is printed.
+
+The special verbosity level 99 requires to also specify the -sections
+parameter; then these sections are extracted (see L<Pod::Select>)
+and printed.
+
+=item C<-sections>
+
+A string representing a selection list for sections to be printed
+when -verbose is set to 99, e.g. C<"NAME|SYNOPSIS|DESCRIPTION|VERSION">.
+
+Alternatively, an array reference of section specifications can be used:
+
+ pod2usage(-verbose => 99,
+ -sections => [ qw(fred fred/subsection) ] );
+
+=item C<-output>
+
+A reference to a filehandle, or the pathname of a file to which the
+usage message should be written. The default is C<\*STDERR> unless the
+exit value is less than 2 (in which case the default is C<\*STDOUT>).
+
+=item C<-input>
+
+A reference to a filehandle, or the pathname of a file from which the
+invoking script's pod documentation should be read. It defaults to the
+file indicated by C<$0> (C<$PROGRAM_NAME> for users of F<English.pm>).
+
+If you are calling B<pod2usage()> from a module and want to display
+that module's POD, you can use this:
+
+ use Pod::Find qw(pod_where);
+ pod2usage( -input => pod_where({-inc => 1}, __PACKAGE__) );
+
+=item C<-pathlist>
+
+A list of directory paths. If the input file does not exist, then it
+will be searched for in the given directory list (in the order the
+directories appear in the list). It defaults to the list of directories
+implied by C<$ENV{PATH}>. The list may be specified either by a reference
+to an array, or by a string of directory paths which use the same path
+separator as C<$ENV{PATH}> on your system (e.g., C<:> for Unix, C<;> for
+MSWin32 and DOS).
+
+=item C<-noperldoc>
+
+By default, Pod::Usage will call L<perldoc> when -verbose >= 2 is
+specified. This does not work well e.g. if the script was packed
+with L<PAR>. The -noperldoc option suppresses the external call to
+L<perldoc> and uses the simple text formatter (L<Pod::Text>) to
+output the POD.
+
+=back
+
+=head1 DESCRIPTION
+
+B<pod2usage> will print a usage message for the invoking script (using
+its embedded pod documentation) and then exit the script with the
+desired exit status. The usage message printed may have any one of three
+levels of "verboseness": If the verbose level is 0, then only a synopsis
+is printed. If the verbose level is 1, then the synopsis is printed
+along with a description (if present) of the command line options and
+arguments. If the verbose level is 2, then the entire manual page is
+printed.
+
+Unless they are explicitly specified, the default values for the exit
+status, verbose level, and output stream to use are determined as
+follows:
+
+=over 4
+
+=item *
+
+If neither the exit status nor the verbose level is specified, then the
+default is to use an exit status of 2 with a verbose level of 0.
+
+=item *
+
+If an exit status I<is> specified but the verbose level is I<not>, then the
+verbose level will default to 1 if the exit status is less than 2 and
+will default to 0 otherwise.
+
+=item *
+
+If an exit status is I<not> specified but verbose level I<is> given, then
+the exit status will default to 2 if the verbose level is 0 and will
+default to 1 otherwise.
+
+=item *
+
+If the exit status used is less than 2, then output is printed on
+C<STDOUT>. Otherwise output is printed on C<STDERR>.
+
+=back
+
+Although the above may seem a bit confusing at first, it generally does
+"the right thing" in most situations. This determination of the default
+values to use is based upon the following typical Unix conventions:
+
+=over 4
+
+=item *
+
+An exit status of 0 implies "success". For example, B<diff(1)> exits
+with a status of 0 if the two files have the same contents.
+
+=item *
+
+An exit status of 1 implies possibly abnormal, but non-defective, program
+termination. For example, B<grep(1)> exits with a status of 1 if
+it did I<not> find a matching line for the given regular expression.
+
+=item *
+
+An exit status of 2 or more implies a fatal error. For example, B<ls(1)>
+exits with a status of 2 if you specify an illegal (unknown) option on
+the command line.
+
+=item *
+
+Usage messages issued as a result of bad command-line syntax should go
+to C<STDERR>. However, usage messages issued due to an explicit request
+to print usage (like specifying B<-help> on the command line) should go
+to C<STDOUT>, just in case the user wants to pipe the output to a pager
+(such as B<more(1)>).
+
+=item *
+
+If program usage has been explicitly requested by the user, it is often
+desirable to exit with a status of 1 (as opposed to 0) after issuing
+the user-requested usage message. It is also desirable to give a
+more verbose description of program usage in this case.
+
+=back
+
+B<pod2usage> doesn't force the above conventions upon you, but it will
+use them by default if you don't expressly tell it to do otherwise. The
+ability of B<pod2usage()> to accept a single number or a string makes it
+convenient to use as an innocent looking error message handling function:
+
+ use Pod::Usage;
+ use Getopt::Long;
+
+ ## Parse options
+ GetOptions("help", "man", "flag1") || pod2usage(2);
+ pod2usage(1) if ($opt_help);
+ pod2usage(-verbose => 2) if ($opt_man);
+
+ ## Check for too many filenames
+ pod2usage("$0: Too many files given.\n") if (@ARGV > 1);
+
+Some user's however may feel that the above "economy of expression" is
+not particularly readable nor consistent and may instead choose to do
+something more like the following:
+
+ use Pod::Usage;
+ use Getopt::Long;
+
+ ## Parse options
+ GetOptions("help", "man", "flag1") || pod2usage(-verbose => 0);
+ pod2usage(-verbose => 1) if ($opt_help);
+ pod2usage(-verbose => 2) if ($opt_man);
+
+ ## Check for too many filenames
+ pod2usage(-verbose => 2, -message => "$0: Too many files given.\n")
+ if (@ARGV > 1);
+
+As with all things in Perl, I<there's more than one way to do it>, and
+B<pod2usage()> adheres to this philosophy. If you are interested in
+seeing a number of different ways to invoke B<pod2usage> (although by no
+means exhaustive), please refer to L<"EXAMPLES">.
+
+=head1 EXAMPLES
+
+Each of the following invocations of C<pod2usage()> will print just the
+"SYNOPSIS" section to C<STDERR> and will exit with a status of 2:
+
+ pod2usage();
+
+ pod2usage(2);
+
+ pod2usage(-verbose => 0);
+
+ pod2usage(-exitval => 2);
+
+ pod2usage({-exitval => 2, -output => \*STDERR});
+
+ pod2usage({-verbose => 0, -output => \*STDERR});
+
+ pod2usage(-exitval => 2, -verbose => 0);
+
+ pod2usage(-exitval => 2, -verbose => 0, -output => \*STDERR);
+
+Each of the following invocations of C<pod2usage()> will print a message
+of "Syntax error." (followed by a newline) to C<STDERR>, immediately
+followed by just the "SYNOPSIS" section (also printed to C<STDERR>) and
+will exit with a status of 2:
+
+ pod2usage("Syntax error.");
+
+ pod2usage(-message => "Syntax error.", -verbose => 0);
+
+ pod2usage(-msg => "Syntax error.", -exitval => 2);
+
+ pod2usage({-msg => "Syntax error.", -exitval => 2, -output => \*STDERR});
+
+ pod2usage({-msg => "Syntax error.", -verbose => 0, -output => \*STDERR});
+
+ pod2usage(-msg => "Syntax error.", -exitval => 2, -verbose => 0);
+
+ pod2usage(-message => "Syntax error.",
+ -exitval => 2,
+ -verbose => 0,
+ -output => \*STDERR);
+
+Each of the following invocations of C<pod2usage()> will print the
+"SYNOPSIS" section and any "OPTIONS" and/or "ARGUMENTS" sections to
+C<STDOUT> and will exit with a status of 1:
+
+ pod2usage(1);
+
+ pod2usage(-verbose => 1);
+
+ pod2usage(-exitval => 1);
+
+ pod2usage({-exitval => 1, -output => \*STDOUT});
+
+ pod2usage({-verbose => 1, -output => \*STDOUT});
+
+ pod2usage(-exitval => 1, -verbose => 1);
+
+ pod2usage(-exitval => 1, -verbose => 1, -output => \*STDOUT});
+
+Each of the following invocations of C<pod2usage()> will print the
+entire manual page to C<STDOUT> and will exit with a status of 1:
+
+ pod2usage(-verbose => 2);
+
+ pod2usage({-verbose => 2, -output => \*STDOUT});
+
+ pod2usage(-exitval => 1, -verbose => 2);
+
+ pod2usage({-exitval => 1, -verbose => 2, -output => \*STDOUT});
+
+=head2 Recommended Use
+
+Most scripts should print some type of usage message to C<STDERR> when a
+command line syntax error is detected. They should also provide an
+option (usually C<-H> or C<-help>) to print a (possibly more verbose)
+usage message to C<STDOUT>. Some scripts may even wish to go so far as to
+provide a means of printing their complete documentation to C<STDOUT>
+(perhaps by allowing a C<-man> option). The following complete example
+uses B<Pod::Usage> in combination with B<Getopt::Long> to do all of these
+things:
+
+ use Getopt::Long;
+ use Pod::Usage;
+
+ my $man = 0;
+ my $help = 0;
+ ## Parse options and print usage if there is a syntax error,
+ ## or if usage was explicitly requested.
+ GetOptions('help|?' => \$help, man => \$man) or pod2usage(2);
+ pod2usage(1) if $help;
+ pod2usage(-verbose => 2) if $man;
+
+ ## If no arguments were given, then allow STDIN to be used only
+ ## if it's not connected to a terminal (otherwise print usage)
+ pod2usage("$0: No files given.") if ((@ARGV == 0) && (-t STDIN));
+ __END__
+
+ =head1 NAME
+
+ sample - Using GetOpt::Long and Pod::Usage
+
+ =head1 SYNOPSIS
+
+ sample [options] [file ...]
+
+ Options:
+ -help brief help message
+ -man full documentation
+
+ =head1 OPTIONS
+
+ =over 8
+
+ =item B<-help>
+
+ Print a brief help message and exits.
+
+ =item B<-man>
+
+ Prints the manual page and exits.
+
+ =back
+
+ =head1 DESCRIPTION
+
+ B<This program> will read the given input file(s) and do something
+ useful with the contents thereof.
+
+ =cut
+
+=head1 CAVEATS
+
+By default, B<pod2usage()> will use C<$0> as the path to the pod input
+file. Unfortunately, not all systems on which Perl runs will set C<$0>
+properly (although if C<$0> isn't found, B<pod2usage()> will search
+C<$ENV{PATH}> or else the list specified by the C<-pathlist> option).
+If this is the case for your system, you may need to explicitly specify
+the path to the pod docs for the invoking script using something
+similar to the following:
+
+ pod2usage(-exitval => 2, -input => "/path/to/your/pod/docs");
+
+In the pathological case that a script is called via a relative path
+I<and> the script itself changes the current working directory
+(see L<perlfunc/chdir>) I<before> calling pod2usage, Pod::Usage will
+fail even on robust platforms. Don't do that.
+
+=head1 AUTHOR
+
+Please report bugs using L<http://rt.cpan.org>.
+
+Marek Rouchal E<lt>marekr at cpan.orgE<gt>
+
+Brad Appleton E<lt>bradapp at enteract.comE<gt>
+
+Based on code for B<Pod::Text::pod2text()> written by
+Tom Christiansen E<lt>tchrist at mox.perl.comE<gt>
+
+=head1 ACKNOWLEDGMENTS
+
+Steven McDougall E<lt>swmcd at world.std.comE<gt> for his help and patience
+with re-writing this manpage.
+
+=head1 SEE ALSO
+
+L<Pod::Parser>, L<Getopt::Long>, L<Pod::Find>
+
+=cut
+
+#############################################################################
+
+#use diagnostics;
+use Carp;
+use Config;
+use Exporter;
+use File::Spec;
+
+ at EXPORT = qw(&pod2usage);
+BEGIN {
+ if ( $] >= 5.005_58 ) {
+ require Pod::Text;
+ @ISA = qw( Pod::Text );
+ }
+ else {
+ require Pod::PlainText;
+ @ISA = qw( Pod::PlainText );
+ }
+}
+
+require Pod::Select;
+
+##---------------------------------------------------------------------------
+
+##---------------------------------
+## Function definitions begin here
+##---------------------------------
+
+sub pod2usage {
+ local($_) = shift;
+ my %opts;
+ ## Collect arguments
+ if (@_ > 0) {
+ ## Too many arguments - assume that this is a hash and
+ ## the user forgot to pass a reference to it.
+ %opts = ($_, @_);
+ }
+ elsif (!defined $_) {
+ $_ = '';
+ }
+ elsif (ref $_) {
+ ## User passed a ref to a hash
+ %opts = %{$_} if (ref($_) eq 'HASH');
+ }
+ elsif (/^[-+]?\d+$/) {
+ ## User passed in the exit value to use
+ $opts{'-exitval'} = $_;
+ }
+ else {
+ ## User passed in a message to print before issuing usage.
+ $_ and $opts{'-message'} = $_;
+ }
+
+ ## Need this for backward compatibility since we formerly used
+ ## options that were all uppercase words rather than ones that
+ ## looked like Unix command-line options.
+ ## to be uppercase keywords)
+ %opts = map {
+ my ($key, $val) = ($_, $opts{$_});
+ $key =~ s/^(?=\w)/-/;
+ $key =~ /^-msg/i and $key = '-message';
+ $key =~ /^-exit/i and $key = '-exitval';
+ lc($key) => $val;
+ } (keys %opts);
+
+ ## Now determine default -exitval and -verbose values to use
+ if ((! defined $opts{'-exitval'}) && (! defined $opts{'-verbose'})) {
+ $opts{'-exitval'} = 2;
+ $opts{'-verbose'} = 0;
+ }
+ elsif (! defined $opts{'-exitval'}) {
+ $opts{'-exitval'} = ($opts{'-verbose'} > 0) ? 1 : 2;
+ }
+ elsif (! defined $opts{'-verbose'}) {
+ $opts{'-verbose'} = (lc($opts{'-exitval'}) eq 'noexit' ||
+ $opts{'-exitval'} < 2);
+ }
+
+ ## Default the output file
+ $opts{'-output'} = (lc($opts{'-exitval'}) eq 'noexit' ||
+ $opts{'-exitval'} < 2) ? \*STDOUT : \*STDERR
+ unless (defined $opts{'-output'});
+ ## Default the input file
+ $opts{'-input'} = $0 unless (defined $opts{'-input'});
+
+ ## Look up input file in path if it doesnt exist.
+ unless ((ref $opts{'-input'}) || (-e $opts{'-input'})) {
+ my $basename = $opts{'-input'};
+ my $pathsep = ($^O =~ /^(?:dos|os2|MSWin32)$/i) ? ';'
+ : (($^O eq 'MacOS' || $^O eq 'VMS') ? ',' : ':');
+ my $pathspec = $opts{'-pathlist'} || $ENV{PATH} || $ENV{PERL5LIB};
+
+ my @paths = (ref $pathspec) ? @$pathspec : split($pathsep, $pathspec);
+ for my $dirname (@paths) {
+ $_ = File::Spec->catfile($dirname, $basename) if length;
+ last if (-e $_) && ($opts{'-input'} = $_);
+ }
+ }
+
+ ## Now create a pod reader and constrain it to the desired sections.
+ my $parser = new Pod::Usage(USAGE_OPTIONS => \%opts);
+ if ($opts{'-verbose'} == 0) {
+ $parser->select('(?:SYNOPSIS|USAGE)\s*');
+ }
+ elsif ($opts{'-verbose'} == 1) {
+ my $opt_re = '(?i)' .
+ '(?:OPTIONS|ARGUMENTS)' .
+ '(?:\s*(?:AND|\/)\s*(?:OPTIONS|ARGUMENTS))?';
+ $parser->select( '(?:SYNOPSIS|USAGE)\s*', $opt_re, "DESCRIPTION/$opt_re" );
+ }
+ elsif ($opts{'-verbose'} >= 2 && $opts{'-verbose'} != 99) {
+ $parser->select('.*');
+ }
+ elsif ($opts{'-verbose'} == 99) {
+ my $sections = $opts{'-sections'};
+ $parser->select( (ref $sections) ? @$sections : $sections );
+ $opts{'-verbose'} = 1;
+ }
+
+ ## Now translate the pod document and then exit with the desired status
+ if ( !$opts{'-noperldoc'}
+ and $opts{'-verbose'} >= 2
+ and !ref($opts{'-input'})
+ and $opts{'-output'} == \*STDOUT )
+ {
+ ## spit out the entire PODs. Might as well invoke perldoc
+ my $progpath = File::Spec->catfile($Config{scriptdir}, 'perldoc');
+ print { $opts{'-output'} } ($opts{'-message'}, "\n") if($opts{'-message'});
+ if(defined $opts{-input} && $opts{-input} =~ /^\s*(\S.*?)\s*$/) {
+ # the perldocs back to 5.005 should all have -F
+ # without -F there are warnings in -T scripts
+ system($progpath, '-F', $1);
+ if($?) {
+ # RT16091: fall back to more if perldoc failed
+ system(($Config{pager} || $ENV{PAGER} || '/bin/more'), $1);
+ }
+ } else {
+ croak "Unspecified input file or insecure argument.\n";
+ }
+ }
+ else {
+ $parser->parse_from_file($opts{'-input'}, $opts{'-output'});
+ }
+
+ exit($opts{'-exitval'}) unless (lc($opts{'-exitval'}) eq 'noexit');
+}
+
+##---------------------------------------------------------------------------
+
+##-------------------------------
+## Method definitions begin here
+##-------------------------------
+
+sub new {
+ my $this = shift;
+ my $class = ref($this) || $this;
+ my %params = @_;
+ my $self = {%params};
+ bless $self, $class;
+ if ($self->can('initialize')) {
+ $self->initialize();
+ } else {
+ $self = $self->SUPER::new();
+ %$self = (%$self, %params);
+ }
+ return $self;
+}
+
+sub select {
+ my ($self, @sections) = @_;
+ if ($ISA[0]->can('select')) {
+ $self->SUPER::select(@sections);
+ } else {
+ # we're using Pod::Simple - need to mimic the behavior of Pod::Select
+ my $add = ($sections[0] eq '+') ? shift(@sections) : '';
+ ## Reset the set of sections to use
+ unless (@sections) {
+ delete $self->{USAGE_SELECT} unless ($add);
+ return;
+ }
+ $self->{USAGE_SELECT} = []
+ unless ($add && $self->{USAGE_SELECT});
+ my $sref = $self->{USAGE_SELECT};
+ ## Compile each spec
+ for my $spec (@sections) {
+ my $cs = Pod::Select::_compile_section_spec($spec);
+ if ( defined $cs ) {
+ ## Store them in our sections array
+ push(@$sref, $cs);
+ } else {
+ carp qq{Ignoring section spec "$spec"!\n};
+ }
+ }
+ }
+}
+
+# Override Pod::Text->seq_i to return just "arg", not "*arg*".
+sub seq_i { return $_[1] }
+
+# This overrides the Pod::Text method to do something very akin to what
+# Pod::Select did as well as the work done below by preprocess_paragraph.
+# Note that the below is very, very specific to Pod::Text.
+sub _handle_element_end {
+ my ($self, $element) = @_;
+ if ($element eq 'head1') {
+ $self->{USAGE_HEADINGS} = [ $$self{PENDING}[-1][1] ];
+ if ($self->{USAGE_OPTIONS}->{-verbose} < 2) {
+ $$self{PENDING}[-1][1] =~ s/^\s*SYNOPSIS\s*$/USAGE/;
+ }
+ } elsif ($element =~ /^head(\d+)$/ && $1) { # avoid 0
+ my $idx = $1 - 1;
+ $self->{USAGE_HEADINGS} = [] unless($self->{USAGE_HEADINGS});
+ $self->{USAGE_HEADINGS}->[$idx] = $$self{PENDING}[-1][1];
+ }
+ if ($element =~ /^head\d+$/) {
+ $$self{USAGE_SKIPPING} = 1;
+ if (!$$self{USAGE_SELECT} || !@{ $$self{USAGE_SELECT} }) {
+ $$self{USAGE_SKIPPING} = 0;
+ } else {
+ my @headings = @{$$self{USAGE_HEADINGS}};
+ for my $section_spec ( @{$$self{USAGE_SELECT}} ) {
+ my $match = 1;
+ for (my $i = 0; $i < $Pod::Select::MAX_HEADING_LEVEL; ++$i) {
+ $headings[$i] = '' unless defined $headings[$i];
+ my $regex = $section_spec->[$i];
+ my $negated = ($regex =~ s/^\!//);
+ $match &= ($negated ? ($headings[$i] !~ /${regex}/)
+ : ($headings[$i] =~ /${regex}/));
+ last unless ($match);
+ } # end heading levels
+ if ($match) {
+ $$self{USAGE_SKIPPING} = 0;
+ last;
+ }
+ } # end sections
+ }
+
+ # Try to do some lowercasing instead of all-caps in headings, and use
+ # a colon to end all headings.
+ if($self->{USAGE_OPTIONS}->{-verbose} < 2) {
+ local $_ = $$self{PENDING}[-1][1];
+ s{([A-Z])([A-Z]+)}{((length($2) > 2) ? $1 : lc($1)) . lc($2)}ge;
+ s/\s*$/:/ unless (/:\s*$/);
+ $_ .= "\n";
+ $$self{PENDING}[-1][1] = $_;
+ }
+ }
+ if ($$self{USAGE_SKIPPING} && $element !~ m/^over-/) {
+ pop @{ $$self{PENDING} };
+ } else {
+ $self->SUPER::_handle_element_end($element);
+ }
+}
+
+# required for Pod::Simple API
+sub start_document {
+ my $self = shift;
+ $self->SUPER::start_document();
+ my $msg = $self->{USAGE_OPTIONS}->{-message} or return 1;
+ my $out_fh = $self->output_fh();
+ print $out_fh "$msg\n";
+}
+
+# required for old Pod::Parser API
+sub begin_pod {
+ my $self = shift;
+ $self->SUPER::begin_pod(); ## Have to call superclass
+ my $msg = $self->{USAGE_OPTIONS}->{-message} or return 1;
+ my $out_fh = $self->output_handle();
+ print $out_fh "$msg\n";
+}
+
+sub preprocess_paragraph {
+ my $self = shift;
+ local $_ = shift;
+ my $line = shift;
+ ## See if this is a heading and we arent printing the entire manpage.
+ if (($self->{USAGE_OPTIONS}->{-verbose} < 2) && /^=head/) {
+ ## Change the title of the SYNOPSIS section to USAGE
+ s/^=head1\s+SYNOPSIS\s*$/=head1 USAGE/;
+ ## Try to do some lowercasing instead of all-caps in headings
+ s{([A-Z])([A-Z]+)}{((length($2) > 2) ? $1 : lc($1)) . lc($2)}ge;
+ ## Use a colon to end all headings
+ s/\s*$/:/ unless (/:\s*$/);
+ $_ .= "\n";
+ }
+ return $self->SUPER::preprocess_paragraph($_);
+}
+
+1; # keep require happy
Index: trunk/contrib/perl/lib/Pod/t/Functions.t
===================================================================
--- trunk/contrib/perl/lib/Pod/t/Functions.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Pod/t/Functions.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Pod/t/Functions.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/Pod/t/InputObjects.t
===================================================================
--- trunk/contrib/perl/lib/Pod/t/InputObjects.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Pod/t/InputObjects.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Pod/t/InputObjects.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/Pod/t/Select.t
===================================================================
--- trunk/contrib/perl/lib/Pod/t/Select.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Pod/t/Select.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Pod/t/Select.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/Pod/t/Usage.t
===================================================================
--- trunk/contrib/perl/lib/Pod/t/Usage.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Pod/t/Usage.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Pod/t/Usage.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/lib/Pod/t/basic.cap (from rev 6437, vendor/perl/5.18.1/lib/Pod/t/basic.cap)
===================================================================
--- trunk/contrib/perl/lib/Pod/t/basic.cap (rev 0)
+++ trunk/contrib/perl/lib/Pod/t/basic.cap 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,268 @@
+[1mNAME[m
+ basic.pod - Test of various basic POD features in translators.
+
+[1mHEADINGS[m
+ Try a few different levels of headings, with embedded formatting codes and
+ other interesting bits.
+
+[1mThis "is" a "level 1" heading[m
+ [1m``Level'' "2 [4mheading[m[m
+ Level 3 [1mheading [4mwith "weird stuff "" (double quote)"[m[m
+ Level "4 "heading"
+ Now try again with [1mintermixed[m text.
+
+[1mThis "is" a "level 1" heading[m
+ Text.
+
+ [1m``Level'' 2 [4mheading[m[m
+ Text.
+
+ Level 3 [1mheading [4mwith "weird stuff"[m[m
+ Text.
+
+ Level "4 "heading"
+ Text.
+
+[1mLINKS[m
+ These are all taken from the Pod::Parser tests.
+
+ Try out [4mLOTS[m of different ways of specifying references:
+
+ Reference the "section" in manpage
+
+ Reference the "section" in "manpage"
+
+ Reference the "section" in manpage
+
+ Now try it using the new "|" stuff ...
+
+ Reference the thistext|
+
+ Reference the thistext |
+
+ Reference the thistext|
+
+ Reference the thistext |
+
+ Reference the thistext|
+
+ Reference the thistext|
+
+ And then throw in a few new ones of my own.
+
+ foo
+
+ foo
+
+ "bar" in foo
+
+ "baz boo" in foo
+
+ "bar"
+
+ "baz boo"
+
+ "baz boo"
+
+ "baz boo" in foo bar
+
+ "boo var baz"
+
+ "bar baz"
+
+ "boo", "bar", and "baz"
+
+ foobar
+
+ Testing [4mitalics[m
+
+ "[4mItalic[m text" in foo
+
+ "Section "with" [4m[1mother[m markup[m" in foo|bar
+
+ Nested <http://www.perl.org/>
+
+[1mOVER AND ITEMS[m
+ Taken from Pod::Parser tests, this is a test to ensure that multiline
+ =item paragraphs get indented appropriately.
+
+ This is a test.
+
+ There should be whitespace now before this line.
+
+ Taken from Pod::Parser tests, this is a test to ensure the nested =item
+ paragraphs get indented appropriately.
+
+ 1 First section.
+
+ a this is item a
+
+ b this is item b
+
+ 2 Second section.
+
+ a this is item a
+
+ b this is item b
+
+ c
+ d This is item c & d.
+
+ Now some additional weirdness of our own. Make sure that multiple tags for
+ one paragraph are properly compacted.
+
+ "foo"
+ [1mbar[m
+ "baz"
+ There shouldn't be any spaces between any of these item tags; this
+ idiom is used in perlfunc.
+
+ Some longer item text
+ Just to make sure that we test paragraphs where the item text doesn't
+ fit in the margin of the paragraph (and make sure that this paragraph
+ fills a few lines).
+
+ Let's also make it multiple paragraphs to be sure that works.
+
+ Test use of =over without =item as a block "quote" or block paragraph.
+
+ This should be indented four spaces but otherwise formatted the same
+ as any other regular text paragraph. Make sure it's long enough to see
+ the results of the formatting.....
+
+ Now try the same thing nested, and make sure that the indentation is reset
+ back properly.
+
+ This paragraph should be doubly indented.
+
+ This paragraph should only be singly indented.
+
+ * This is an item in the middle of a block-quote, which should be
+ allowed.
+
+ * We're also testing tagless item commands.
+
+ Should be back to the single level of indentation.
+
+ Should be back to regular indentation.
+
+ Now also check the transformation of * into real bullets for man pages.
+
+ * An item. We're also testing using =over without a number, and making
+ sure that item text wraps properly.
+
+ * Another item.
+
+ and now test the numbering of item blocks.
+
+ 1. First item.
+
+ 2. Second item.
+
+[1mFORMATTING CODES[m
+ Another test taken from Pod::Parser.
+
+ This is a test to see if I can do not only $self and "method()", but also
+ "$self->method()" and "$self->{FIELDNAME}" and "$Foo <=> $Bar" without
+ resorting to escape sequences. If I want to refer to the right-shift
+ operator I can do something like "$x >> 3" or even "$y >> 5".
+
+ Now for the grand finale of "$self->method()->{FIELDNAME} = {FOO=>BAR}".
+ And I also want to make sure that newlines work like this "$self->{FOOBAR}
+ >> 3 and [$b => $a]->[$a <=> $b]"
+
+ Of course I should still be able to do all this [4mwith[m escape sequences too:
+ "$self->method()" and "$self->{FIELDNAME}" and "{FOO=>BAR}".
+
+ Dont forget "$self->method()->{FIELDNAME} = {FOO=>BAR}".
+
+ And make sure that 0 works too!
+
+ Now, if I use << or >> as my delimiters, then I have to use whitespace. So
+ things like "<$self-"method()>> and "<$self-"{FIELDNAME}>> wont end up
+ doing what you might expect since the first > will still terminate the
+ first < seen.
+
+ Lets make sure these work for empty ones too, like "" and ">>" (just to be
+ obnoxious)
+
+ The statement: "This is dog kind's [4mfinest[m hour!" is a parody of a
+ quotation from Winston Churchill.
+
+ The following tests are added to those:
+
+ Make sure that a few other odd [4mthings[m still work. This should be a
+ vertical bar: |. Here's a test of a few more special escapes that have to
+ be supported:
+
+ & An ampersand.
+
+ ' An apostrophe.
+
+ < A less-than sign.
+
+ > A greater-than sign.
+
+ " A double quotation mark.
+
+ / A forward slash.
+
+ Try to get this bit of text over towards the edge so
+ |that all of this text inside S<> won't| be wrapped. Also test the
+ |same thing with non-breaking spaces.|
+
+ There is a soft hyphen in hyphen at hy-phen.
+
+ This is a test of an index entry.
+
+[1mVERBATIM[m
+ Throw in a few verbatim paragraphs.
+
+ use Term::ANSIColor;
+ print color 'bold blue';
+ print "This text is bold blue.\n";
+ print color 'reset';
+ print "This text is normal.\n";
+ print colored ("Yellow on magenta.\n", 'yellow on_magenta');
+ print "This text is normal.\n";
+ print colored ['yellow on_magenta'], "Yellow on magenta.\n";
+
+ use Term::ANSIColor qw(uncolor);
+ print uncolor '01;31', "\n";
+
+ But this isn't verbatim (make sure it wraps properly), and the next
+ paragraph is again:
+
+ use Term::ANSIColor qw(:constants);
+ print BOLD, BLUE, "This text is in bold blue.\n", RESET;
+
+ use Term::ANSIColor qw(:constants); $Term::ANSIColor::AUTORESET = 1; print BOLD BLUE "This text is in bold blue.\n"; print "This text is normal.\n";
+
+ (Ugh, that's obnoxiously long.) Try different spacing:
+
+ Starting with a tab.
+ Not
+ starting
+ with
+ a
+ tab. But this should still be verbatim.
+ As should this.
+
+ This isn't.
+
+ This is. And this: is an internal tab. It should be:
+ |--| <= lined up with that.
+
+ (Tricky, but tabs should be expanded before the translator starts in on
+ the text since otherwise text with mixed tabs and spaces will get messed
+ up.)
+
+ And now we test verbatim paragraphs right before a heading. Older
+ versions of Pod::Man generated two spaces between paragraphs like this
+ and the heading. (In order to properly test this, one may have to
+ visually inspect the nroff output when run on the generated *roff
+ text, unfortunately.)
+
+[1mCONCLUSION[m
+ That's all, folks!
+
Copied: trunk/contrib/perl/lib/Pod/t/basic.clr (from rev 6437, vendor/perl/5.18.1/lib/Pod/t/basic.clr)
===================================================================
--- trunk/contrib/perl/lib/Pod/t/basic.clr (rev 0)
+++ trunk/contrib/perl/lib/Pod/t/basic.clr 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,269 @@
+[1mNAME[0m
+ basic.pod - Test of various basic POD features in translators.
+
+[1mHEADINGS[0m
+ Try a few different levels of headings, with embedded formatting codes
+ and other interesting bits.
+
+[1mThis "is" a "level 1" heading[0m
+ [1m``Level'' "2 [33mheading[0m[0m
+ Level 3 [1mheading [33mwith "weird [36mstuff "" (double quote)[0m"[0m[0m
+ Level "4 "heading"
+ Now try again with [1mintermixed[0m [36mtext[0m.
+
+[1mThis "is" a "level 1" heading[0m
+ Text.
+
+ [1m``Level'' 2 [33mheading[0m[0m
+ Text.
+
+ Level 3 [1mheading [33mwith "weird [36mstuff[0m"[0m[0m
+ Text.
+
+ Level "4 "heading"
+ Text.
+
+[1mLINKS[0m
+ These are all taken from the Pod::Parser tests.
+
+ Try out [33mLOTS[0m of different ways of specifying references:
+
+ Reference the "section" in manpage
+
+ Reference the "section" in "manpage"
+
+ Reference the "section" in manpage
+
+ Now try it using the new "|" stuff ...
+
+ Reference the thistext|
+
+ Reference the thistext |
+
+ Reference the thistext|
+
+ Reference the thistext |
+
+ Reference the thistext|
+
+ Reference the thistext|
+
+ And then throw in a few new ones of my own.
+
+ foo
+
+ foo
+
+ "bar" in foo
+
+ "baz boo" in foo
+
+ "bar"
+
+ "baz boo"
+
+ "baz boo"
+
+ "baz boo" in foo bar
+
+ "boo var baz"
+
+ "bar baz"
+
+ "boo", "bar", and "baz"
+
+ foobar
+
+ Testing [33mitalics[0m
+
+ "[33mItalic[0m text" in foo
+
+ "Section "with" [33m[1mother[0m markup[0m" in foo|bar
+
+ Nested <http://www.perl.org/>
+
+[1mOVER AND ITEMS[0m
+ Taken from Pod::Parser tests, this is a test to ensure that multiline
+ =item paragraphs get indented appropriately.
+
+ This is a test.
+
+ There should be whitespace now before this line.
+
+ Taken from Pod::Parser tests, this is a test to ensure the nested =item
+ paragraphs get indented appropriately.
+
+ 1 First section.
+
+ a this is item a
+
+ b this is item b
+
+ 2 Second section.
+
+ a this is item a
+
+ b this is item b
+
+ c
+ d This is item c & d.
+
+ Now some additional weirdness of our own. Make sure that multiple tags
+ for one paragraph are properly compacted.
+
+ "foo"
+ [1mbar[0m
+ "baz"
+ There shouldn't be any spaces between any of these item tags; this
+ idiom is used in perlfunc.
+
+ Some longer item text
+ Just to make sure that we test paragraphs where the item text
+ doesn't fit in the margin of the paragraph (and make sure that this
+ paragraph fills a few lines).
+
+ Let's also make it multiple paragraphs to be sure that works.
+
+ Test use of =over without =item as a block "quote" or block paragraph.
+
+ This should be indented four spaces but otherwise formatted the same
+ as any other regular text paragraph. Make sure it's long enough to
+ see the results of the formatting.....
+
+ Now try the same thing nested, and make sure that the indentation is
+ reset back properly.
+
+ This paragraph should be doubly indented.
+
+ This paragraph should only be singly indented.
+
+ * This is an item in the middle of a block-quote, which should be
+ allowed.
+
+ * We're also testing tagless item commands.
+
+ Should be back to the single level of indentation.
+
+ Should be back to regular indentation.
+
+ Now also check the transformation of * into real bullets for man pages.
+
+ * An item. We're also testing using =over without a number, and making
+ sure that item text wraps properly.
+
+ * Another item.
+
+ and now test the numbering of item blocks.
+
+ 1. First item.
+
+ 2. Second item.
+
+[1mFORMATTING CODES[0m
+ Another test taken from Pod::Parser.
+
+ This is a test to see if I can do not only $self and "method()", but
+ also "$self->method()" and "$self->{FIELDNAME}" and "$Foo <=> $Bar"
+ without resorting to escape sequences. If I want to refer to the
+ right-shift operator I can do something like "$x >> 3" or even "$y >>
+ 5".
+
+ Now for the grand finale of "$self->method()->{FIELDNAME} = {FOO=>BAR}".
+ And I also want to make sure that newlines work like this
+ "$self->{FOOBAR} >> 3 and [$b => $a]->[$a <=> $b]"
+
+ Of course I should still be able to do all this [33mwith[0m escape sequences
+ too: "$self->method()" and "$self->{FIELDNAME}" and "{FOO=>BAR}".
+
+ Dont forget "$self->method()->{FIELDNAME} = {FOO=>BAR}".
+
+ And make sure that 0 works too!
+
+ Now, if I use << or >> as my delimiters, then I have to use whitespace.
+ So things like "<$self-"method()>> and "<$self-"{FIELDNAME}>> wont end
+ up doing what you might expect since the first > will still terminate
+ the first < seen.
+
+ Lets make sure these work for empty ones too, like "" and ">>" (just to
+ be obnoxious)
+
+ The statement: "This is dog kind's [33mfinest[0m hour!" is a parody of a
+ quotation from Winston Churchill.
+
+ The following tests are added to those:
+
+ Make sure that a few other odd [33mthings[0m still work. This should be a
+ vertical bar: |. Here's a test of a few more special escapes that have
+ to be supported:
+
+ & An ampersand.
+
+ ' An apostrophe.
+
+ < A less-than sign.
+
+ > A greater-than sign.
+
+ " A double quotation mark.
+
+ / A forward slash.
+
+ Try to get this bit of text over towards the edge so
+ |that all of this text inside S<> won't| be wrapped. Also test the
+ |same thing with non-breaking spaces.|
+
+ There is a soft hyphen in hyphen at hy-phen.
+
+ This is a test of an index entry.
+
+[1mVERBATIM[0m
+ Throw in a few verbatim paragraphs.
+
+ use Term::ANSIColor;
+ print color 'bold blue';
+ print "This text is bold blue.\n";
+ print color 'reset';
+ print "This text is normal.\n";
+ print colored ("Yellow on magenta.\n", 'yellow on_magenta');
+ print "This text is normal.\n";
+ print colored ['yellow on_magenta'], "Yellow on magenta.\n";
+
+ use Term::ANSIColor qw(uncolor);
+ print uncolor '01;31', "\n";
+
+ But this isn't verbatim (make sure it wraps properly), and the next
+ paragraph is again:
+
+ use Term::ANSIColor qw(:constants);
+ print BOLD, BLUE, "This text is in bold blue.\n", RESET;
+
+ use Term::ANSIColor qw(:constants); $Term::ANSIColor::AUTORESET = 1; print BOLD BLUE "This text is in bold blue.\n"; print "This text is normal.\n";
+
+ (Ugh, that's obnoxiously long.) Try different spacing:
+
+ Starting with a tab.
+ Not
+ starting
+ with
+ a
+ tab. But this should still be verbatim.
+ As should this.
+
+ This isn't.
+
+ This is. And this: is an internal tab. It should be:
+ |--| <= lined up with that.
+
+ (Tricky, but tabs should be expanded before the translator starts in on
+ the text since otherwise text with mixed tabs and spaces will get messed
+ up.)
+
+ And now we test verbatim paragraphs right before a heading. Older
+ versions of Pod::Man generated two spaces between paragraphs like this
+ and the heading. (In order to properly test this, one may have to
+ visually inspect the nroff output when run on the generated *roff
+ text, unfortunately.)
+
+[1mCONCLUSION[0m
+ That's all, folks!
+
Copied: trunk/contrib/perl/lib/Pod/t/basic.man (from rev 6437, vendor/perl/5.18.1/lib/Pod/t/basic.man)
===================================================================
--- trunk/contrib/perl/lib/Pod/t/basic.man (rev 0)
+++ trunk/contrib/perl/lib/Pod/t/basic.man 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,321 @@
+.SH "NAME"
+basic.pod \- Test of various basic POD features in translators.
+.SH "HEADINGS"
+.IX Header "HEADINGS"
+Try a few different levels of headings, with embedded formatting codes and
+other interesting bits.
+.ie n .SH "This ""is"" a ""level 1"" heading"
+.el .SH "This \f(CWis\fP a ``level 1'' heading"
+.IX Header "This is a level 1 heading"
+.SS "``Level'' ""2 \fIheading\fP"
+.IX Subsection "``Level'' ""2 heading"
+\fILevel 3 \f(BIheading \f(BIwith \f(CB\*(C`weird \f(CBstuff "" (double quote)\f(CB\*(C'\f(BI\f(BI\fI\fR
+.IX Subsection "Level 3 heading with weird stuff """" (double quote)"
+.PP
+Level "4 \f(CW\*(C`heading\*(C'\fR
+.IX Subsection "Level ""4 heading"
+.PP
+Now try again with \fBintermixed\fR \fItext\fR.
+.ie n .SH "This ""is"" a ""level 1"" heading"
+.el .SH "This \f(CWis\fP a ``level 1'' heading"
+.IX Header "This is a level 1 heading"
+Text.
+.SS "``Level'' 2 \fIheading\fP"
+.IX Subsection "``Level'' 2 heading"
+Text.
+.PP
+\fILevel 3 \f(BIheading \f(BIwith \f(CB\*(C`weird \f(CBstuff\f(CB\*(C'\f(BI\f(BI\fI\fR
+.IX Subsection "Level 3 heading with weird stuff"
+.PP
+Text.
+.PP
+Level "4 \f(CW\*(C`heading\*(C'\fR
+.IX Subsection "Level ""4 heading"
+.PP
+Text.
+.SH "LINKS"
+.IX Header "LINKS"
+These are all taken from the Pod::Parser tests.
+.PP
+Try out \fI\s-1LOTS\s0\fR of different ways of specifying references:
+.PP
+Reference the \*(L"section\*(R" in manpage
+.PP
+Reference the \*(L"section\*(R" in \*(L"manpage\*(R"
+.PP
+Reference the \*(L"section\*(R" in manpage
+.PP
+Now try it using the new \*(L"|\*(R" stuff ...
+.PP
+Reference the thistext|
+.PP
+Reference the thistext |
+.PP
+Reference the thistext|
+.PP
+Reference the thistext |
+.PP
+Reference the thistext|
+.PP
+Reference the thistext|
+.PP
+And then throw in a few new ones of my own.
+.PP
+foo
+.PP
+foo
+.PP
+\&\*(L"bar\*(R" in foo
+.PP
+\&\*(L"baz boo\*(R" in foo
+.PP
+\&\*(L"bar\*(R"
+.PP
+\&\*(L"baz boo\*(R"
+.PP
+\&\*(L"baz boo\*(R"
+.PP
+\&\*(L"baz boo\*(R" in foo bar
+.PP
+\&\*(L"boo var baz\*(R"
+.PP
+\&\*(L"bar baz\*(R"
+.PP
+\&\*(L"boo\*(R", \*(L"bar\*(R", and \*(L"baz\*(R"
+.PP
+foobar
+.PP
+Testing \fIitalics\fR
+.PP
+"\fIItalic\fR text" in foo
+.PP
+"Section \f(CW\*(C`with\*(C'\fR \fI\f(BIother\fI markup\fR" in foo|bar
+.PP
+Nested <http://www.perl.org/>
+.SH "OVER AND ITEMS"
+.IX Header "OVER AND ITEMS"
+Taken from Pod::Parser tests, this is a test to ensure that multiline
+=item paragraphs get indented appropriately.
+.IP "This is a test." 4
+.IX Item "This is a test."
+.PP
+There should be whitespace now before this line.
+.PP
+Taken from Pod::Parser tests, this is a test to ensure the nested =item
+paragraphs get indented appropriately.
+.IP "1." 2
+First section.
+.RS 2
+.IP "a" 2
+.IX Item "a"
+this is item a
+.IP "b" 2
+.IX Item "b"
+this is item b
+.RE
+.RS 2
+.RE
+.IP "2." 2
+Second section.
+.RS 2
+.IP "a" 2
+.IX Item "a"
+this is item a
+.IP "b" 2
+.IX Item "b"
+this is item b
+.IP "c" 2
+.IX Item "c"
+.PD 0
+.IP "d" 2
+.IX Item "d"
+.PD
+This is item c & d.
+.RE
+.RS 2
+.RE
+.PP
+Now some additional weirdness of our own. Make sure that multiple tags
+for one paragraph are properly compacted.
+.ie n .IP """foo""" 4
+.el .IP "``foo''" 4
+.IX Item "foo"
+.PD 0
+.IP "\fBbar\fR" 4
+.IX Item "bar"
+.ie n .IP """baz""" 4
+.el .IP "\f(CWbaz\fR" 4
+.IX Item "baz"
+.PD
+There shouldn't be any spaces between any of these item tags; this idiom
+is used in perlfunc.
+.IP "Some longer item text" 4
+.IX Item "Some longer item text"
+Just to make sure that we test paragraphs where the item text doesn't fit
+in the margin of the paragraph (and make sure that this paragraph fills a
+few lines).
+.Sp
+Let's also make it multiple paragraphs to be sure that works.
+.PP
+Test use of =over without =item as a block \*(L"quote\*(R" or block paragraph.
+.Sp
+.RS 4
+This should be indented four spaces but otherwise formatted the same as
+any other regular text paragraph. Make sure it's long enough to see the
+results of the formatting.....
+.RE
+.PP
+Now try the same thing nested, and make sure that the indentation is reset
+back properly.
+.RS 4
+.Sp
+.RS 4
+This paragraph should be doubly indented.
+.RE
+.RE
+.RS 4
+.Sp
+This paragraph should only be singly indented.
+.IP "\(bu" 4
+This is an item in the middle of a block-quote, which should be allowed.
+.IP "\(bu" 4
+We're also testing tagless item commands.
+.RE
+.RS 4
+.Sp
+Should be back to the single level of indentation.
+.RE
+.PP
+Should be back to regular indentation.
+.PP
+Now also check the transformation of * into real bullets for man pages.
+.IP "\(bu" 4
+An item. We're also testing using =over without a number, and making sure
+that item text wraps properly.
+.IP "\(bu" 4
+Another item.
+.PP
+and now test the numbering of item blocks.
+.IP "1." 4
+First item.
+.IP "2." 4
+Second item.
+.SH "FORMATTING CODES"
+.IX Header "FORMATTING CODES"
+Another test taken from Pod::Parser.
+.PP
+This is a test to see if I can do not only \f(CW$self\fR and \f(CW\*(C`method()\*(C'\fR, but
+also \f(CW\*(C`$self\->method()\*(C'\fR and \f(CW\*(C`$self\->{FIELDNAME}\*(C'\fR and
+\&\f(CW\*(C`$Foo <=> $Bar\*(C'\fR without resorting to escape sequences. If
+I want to refer to the right-shift operator I can do something
+like \f(CW\*(C`$x >> 3\*(C'\fR or even \f(CW\*(C`$y >> 5\*(C'\fR.
+.PP
+Now for the grand finale of \f(CW\*(C`$self\->method()\->{FIELDNAME} = {FOO=>BAR}\*(C'\fR.
+And I also want to make sure that newlines work like this
+\&\f(CW\*(C`$self\->{FOOBAR} >> 3 and [$b => $a]\->[$a <=> $b]\*(C'\fR
+.PP
+Of course I should still be able to do all this \fIwith\fR escape sequences
+too: \f(CW\*(C`$self\->method()\*(C'\fR and \f(CW\*(C`$self\->{FIELDNAME}\*(C'\fR and
+\&\f(CW\*(C`{FOO=>BAR}\*(C'\fR.
+.PP
+Dont forget \f(CW\*(C`$self\->method()\->{FIELDNAME} = {FOO=>BAR}\*(C'\fR.
+.PP
+And make sure that \f(CW0\fR works too!
+.PP
+Now, if I use << or >> as my delimiters, then I have to use whitespace.
+So things like \f(CW\*(C`<$self\-\*(C'\fR\fImethod()\fR>> and \f(CW\*(C`<$self\-\*(C'\fR{\s-1FIELDNAME\s0}>> wont end
+up doing what you might expect since the first > will still terminate
+the first < seen.
+.PP
+Lets make sure these work for empty ones too, like \f(CW\*(C`\*(C'\fR and \f(CW\*(C`>>\*(C'\fR
+(just to be obnoxious)
+.PP
+The statement: \f(CW\*(C`This is dog kind\*(Aqs \f(CIfinest\f(CW hour!\*(C'\fR is a parody of a
+quotation from Winston Churchill.
+.PP
+The following tests are added to those:
+.PP
+Make sure that a few other odd \fIthings\fR still work. This should be
+a vertical bar: |. Here's a test of a few more special escapes
+that have to be supported:
+.IP "&" 3
+An ampersand.
+.IP "'" 3
+An apostrophe.
+.IP "<" 3
+A less-than sign.
+.IP ">" 3
+A greater-than sign.
+.IP """" 3
+A double quotation mark.
+.IP "/" 3
+A forward slash.
+.PP
+Try to get this bit of text over towards the edge so |that\ all\ of\ this\ text\ inside\ S<>\ won't| be wrapped. Also test the
+|same\ thing\ with\ non-breaking\ spaces.|
+.PP
+There is a soft hy\%phen in hyphen at hy-phen.
+.PP
+This is a test of an index entry.
+.IX Xref "index entry"
+.SH "VERBATIM"
+.IX Header "VERBATIM"
+Throw in a few verbatim paragraphs.
+.PP
+.Vb 8
+\& use Term::ANSIColor;
+\& print color \*(Aqbold blue\*(Aq;
+\& print "This text is bold blue.\en";
+\& print color \*(Aqreset\*(Aq;
+\& print "This text is normal.\en";
+\& print colored ("Yellow on magenta.\en", \*(Aqyellow on_magenta\*(Aq);
+\& print "This text is normal.\en";
+\& print colored [\*(Aqyellow on_magenta\*(Aq], "Yellow on magenta.\en";
+\&
+\& use Term::ANSIColor qw(uncolor);
+\& print uncolor \*(Aq01;31\*(Aq, "\en";
+.Ve
+.PP
+But this isn't verbatim (make sure it wraps properly), and the next
+paragraph is again:
+.PP
+.Vb 2
+\& use Term::ANSIColor qw(:constants);
+\& print BOLD, BLUE, "This text is in bold blue.\en", RESET;
+\&
+\& use Term::ANSIColor qw(:constants); $Term::ANSIColor::AUTORESET = 1; print BOLD BLUE "This text is in bold blue.\en"; print "This text is normal.\en";
+.Ve
+.PP
+(Ugh, that's obnoxiously long.) Try different spacing:
+.PP
+.Vb 7
+\& Starting with a tab.
+\&Not
+\&starting
+\&with
+\&a
+\&tab. But this should still be verbatim.
+\& As should this.
+.Ve
+.PP
+This isn't.
+.PP
+.Vb 2
+\& This is. And this: is an internal tab. It should be:
+\& |\-\-| <= lined up with that.
+.Ve
+.PP
+(Tricky, but tabs should be expanded before the translator starts in on
+the text since otherwise text with mixed tabs and spaces will get messed
+up.)
+.PP
+.Vb 5
+\& And now we test verbatim paragraphs right before a heading. Older
+\& versions of Pod::Man generated two spaces between paragraphs like this
+\& and the heading. (In order to properly test this, one may have to
+\& visually inspect the nroff output when run on the generated *roff
+\& text, unfortunately.)
+.Ve
+.SH "CONCLUSION"
+.IX Header "CONCLUSION"
+That's all, folks!
Copied: trunk/contrib/perl/lib/Pod/t/basic.ovr (from rev 6437, vendor/perl/5.18.1/lib/Pod/t/basic.ovr)
===================================================================
--- trunk/contrib/perl/lib/Pod/t/basic.ovr (rev 0)
+++ trunk/contrib/perl/lib/Pod/t/basic.ovr 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,269 @@
+NNAAMMEE
+ basic.pod - Test of various basic POD features in translators.
+
+HHEEAADDIINNGGSS
+ Try a few different levels of headings, with embedded formatting codes
+ and other interesting bits.
+
+TThhiiss ""iiss"" aa ""lleevveell 11"" hheeaaddiinngg
+ ````LLeevveell'''' ""22 hheeaaddiinngg
+ _L_e_v_e_l_ _3_ _h_e_a_d_i_n_g_ _w_i_t_h_ _"_w_e_i_r_d_ _s_t_u_f_f_ _"_"_ _(_d_o_u_b_l_e_ _q_u_o_t_e_)_"
+ _L_e_v_e_l_ _"_4_ _"_h_e_a_d_i_n_g_"
+ Now try again with iinntteerrmmiixxeedd _t_e_x_t.
+
+TThhiiss ""iiss"" aa ""lleevveell 11"" hheeaaddiinngg
+ Text.
+
+ ````LLeevveell'''' 22 hheeaaddiinngg
+ Text.
+
+ _L_e_v_e_l_ _3_ _h_e_a_d_i_n_g_ _w_i_t_h_ _"_w_e_i_r_d_ _s_t_u_f_f_"
+ Text.
+
+ _L_e_v_e_l_ _"_4_ _"_h_e_a_d_i_n_g_"
+ Text.
+
+LLIINNKKSS
+ These are all taken from the Pod::Parser tests.
+
+ Try out _L_O_T_S of different ways of specifying references:
+
+ Reference the "section" in manpage
+
+ Reference the "section" in "manpage"
+
+ Reference the "section" in manpage
+
+ Now try it using the new "|" stuff ...
+
+ Reference the thistext|
+
+ Reference the thistext |
+
+ Reference the thistext|
+
+ Reference the thistext |
+
+ Reference the thistext|
+
+ Reference the thistext|
+
+ And then throw in a few new ones of my own.
+
+ foo
+
+ foo
+
+ "bar" in foo
+
+ "baz boo" in foo
+
+ "bar"
+
+ "baz boo"
+
+ "baz boo"
+
+ "baz boo" in foo bar
+
+ "boo var baz"
+
+ "bar baz"
+
+ "boo", "bar", and "baz"
+
+ foobar
+
+ Testing _i_t_a_l_i_c_s
+
+ "_I_t_a_l_i_c text" in foo
+
+ "Section "with" _o_t_h_e_r_ _m_a_r_k_u_p" in foo|bar
+
+ Nested <http://www.perl.org/>
+
+OOVVEERR AANNDD IITTEEMMSS
+ Taken from Pod::Parser tests, this is a test to ensure that multiline
+ =item paragraphs get indented appropriately.
+
+ This is a test.
+
+ There should be whitespace now before this line.
+
+ Taken from Pod::Parser tests, this is a test to ensure the nested =item
+ paragraphs get indented appropriately.
+
+ 1 First section.
+
+ a this is item a
+
+ b this is item b
+
+ 2 Second section.
+
+ a this is item a
+
+ b this is item b
+
+ c
+ d This is item c & d.
+
+ Now some additional weirdness of our own. Make sure that multiple tags
+ for one paragraph are properly compacted.
+
+ "foo"
+ bbaarr
+ "baz"
+ There shouldn't be any spaces between any of these item tags; this
+ idiom is used in perlfunc.
+
+ Some longer item text
+ Just to make sure that we test paragraphs where the item text
+ doesn't fit in the margin of the paragraph (and make sure that this
+ paragraph fills a few lines).
+
+ Let's also make it multiple paragraphs to be sure that works.
+
+ Test use of =over without =item as a block "quote" or block paragraph.
+
+ This should be indented four spaces but otherwise formatted the same
+ as any other regular text paragraph. Make sure it's long enough to
+ see the results of the formatting.....
+
+ Now try the same thing nested, and make sure that the indentation is
+ reset back properly.
+
+ This paragraph should be doubly indented.
+
+ This paragraph should only be singly indented.
+
+ * This is an item in the middle of a block-quote, which should be
+ allowed.
+
+ * We're also testing tagless item commands.
+
+ Should be back to the single level of indentation.
+
+ Should be back to regular indentation.
+
+ Now also check the transformation of * into real bullets for man pages.
+
+ * An item. We're also testing using =over without a number, and making
+ sure that item text wraps properly.
+
+ * Another item.
+
+ and now test the numbering of item blocks.
+
+ 1. First item.
+
+ 2. Second item.
+
+FFOORRMMAATTTTIINNGG CCOODDEESS
+ Another test taken from Pod::Parser.
+
+ This is a test to see if I can do not only $self and "method()", but
+ also "$self->method()" and "$self->{FIELDNAME}" and "$Foo <=> $Bar"
+ without resorting to escape sequences. If I want to refer to the
+ right-shift operator I can do something like "$x >> 3" or even "$y >>
+ 5".
+
+ Now for the grand finale of "$self->method()->{FIELDNAME} = {FOO=>BAR}".
+ And I also want to make sure that newlines work like this
+ "$self->{FOOBAR} >> 3 and [$b => $a]->[$a <=> $b]"
+
+ Of course I should still be able to do all this _w_i_t_h escape sequences
+ too: "$self->method()" and "$self->{FIELDNAME}" and "{FOO=>BAR}".
+
+ Dont forget "$self->method()->{FIELDNAME} = {FOO=>BAR}".
+
+ And make sure that 0 works too!
+
+ Now, if I use << or >> as my delimiters, then I have to use whitespace.
+ So things like "<$self-"method()>> and "<$self-"{FIELDNAME}>> wont end
+ up doing what you might expect since the first > will still terminate
+ the first < seen.
+
+ Lets make sure these work for empty ones too, like "" and ">>" (just to
+ be obnoxious)
+
+ The statement: "This is dog kind's _f_i_n_e_s_t hour!" is a parody of a
+ quotation from Winston Churchill.
+
+ The following tests are added to those:
+
+ Make sure that a few other odd _t_h_i_n_g_s still work. This should be a
+ vertical bar: |. Here's a test of a few more special escapes that have
+ to be supported:
+
+ & An ampersand.
+
+ ' An apostrophe.
+
+ < A less-than sign.
+
+ > A greater-than sign.
+
+ " A double quotation mark.
+
+ / A forward slash.
+
+ Try to get this bit of text over towards the edge so
+ |that all of this text inside S<> won't| be wrapped. Also test the
+ |same thing with non-breaking spaces.|
+
+ There is a soft hyphen in hyphen at hy-phen.
+
+ This is a test of an index entry.
+
+VVEERRBBAATTIIMM
+ Throw in a few verbatim paragraphs.
+
+ use Term::ANSIColor;
+ print color 'bold blue';
+ print "This text is bold blue.\n";
+ print color 'reset';
+ print "This text is normal.\n";
+ print colored ("Yellow on magenta.\n", 'yellow on_magenta');
+ print "This text is normal.\n";
+ print colored ['yellow on_magenta'], "Yellow on magenta.\n";
+
+ use Term::ANSIColor qw(uncolor);
+ print uncolor '01;31', "\n";
+
+ But this isn't verbatim (make sure it wraps properly), and the next
+ paragraph is again:
+
+ use Term::ANSIColor qw(:constants);
+ print BOLD, BLUE, "This text is in bold blue.\n", RESET;
+
+ use Term::ANSIColor qw(:constants); $Term::ANSIColor::AUTORESET = 1; print BOLD BLUE "This text is in bold blue.\n"; print "This text is normal.\n";
+
+ (Ugh, that's obnoxiously long.) Try different spacing:
+
+ Starting with a tab.
+ Not
+ starting
+ with
+ a
+ tab. But this should still be verbatim.
+ As should this.
+
+ This isn't.
+
+ This is. And this: is an internal tab. It should be:
+ |--| <= lined up with that.
+
+ (Tricky, but tabs should be expanded before the translator starts in on
+ the text since otherwise text with mixed tabs and spaces will get messed
+ up.)
+
+ And now we test verbatim paragraphs right before a heading. Older
+ versions of Pod::Man generated two spaces between paragraphs like this
+ and the heading. (In order to properly test this, one may have to
+ visually inspect the nroff output when run on the generated *roff
+ text, unfortunately.)
+
+CCOONNCCLLUUSSIIOONN
+ That's all, folks!
+
Copied: trunk/contrib/perl/lib/Pod/t/basic.pod (from rev 6437, vendor/perl/5.18.1/lib/Pod/t/basic.pod)
===================================================================
--- trunk/contrib/perl/lib/Pod/t/basic.pod (rev 0)
+++ trunk/contrib/perl/lib/Pod/t/basic.pod 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,383 @@
+=head1 NAME
+
+basic.pod - Test of various basic POD features in translators.
+
+=head1 HEADINGS
+
+Try a few different levels of headings, with embedded formatting codes and
+other interesting bits.
+
+=head1 This C<is> a "level 1" heading
+
+=head2 ``Level'' "2 I<heading>
+
+=head3 Level 3 B<heading I<with C<weird F<stuff "" (double quote)>>>>
+
+=head4 Level "4 C<heading>
+
+Now try again with B<intermixed> F<text>.
+
+=head1 This C<is> a "level 1" heading
+
+Text.
+
+=head2 ``Level'' 2 I<heading>
+
+Text.
+
+=head3 Level 3 B<heading I<with C<weird F<stuff>>>>
+
+Text.
+
+=head4 Level "4 C<heading>
+
+Text.
+
+=head1 LINKS
+
+These are all taken from the Pod::Parser tests.
+
+Try out I<LOTS> of different ways of specifying references:
+
+Reference the L<manpage/section>
+
+Reference the L<"manpage"/section>
+
+Reference the L<manpage/"section">
+
+Now try it using the new "|" stuff ...
+
+Reference the L<thistext|manpage/section>|
+
+Reference the L<thistext | manpage / section>|
+
+Reference the L<thistext| manpage/ section>|
+
+Reference the L<thistext |manpage /section>|
+
+Reference the L<thistext|manpage/"section">|
+
+Reference the L<thistext|
+manpage/
+section>|
+
+And then throw in a few new ones of my own.
+
+L<foo>
+
+L<foo|bar>
+
+L<foo/bar>
+
+L<foo/"baz boo">
+
+L</bar>
+
+L</"baz boo">
+
+L</baz boo>
+
+L<foo bar/baz boo>
+
+L<"boo var baz">
+
+L<bar baz>
+
+L</boo>, L</bar>, and L</baz>
+
+L<fooZ<>bar>
+
+L<Testing I<italics>|foo/bar>
+
+L<foo/I<Italic> text>
+
+L<fooE<verbar>barZ<>/Section C<with> I<B<other> markup>>
+
+L<Nested L<http://www.perl.org/>|fooE<sol>bar>
+
+=head1 OVER AND ITEMS
+
+Taken from Pod::Parser tests, this is a test to ensure that multiline
+=item paragraphs get indented appropriately.
+
+=over 4
+
+=item This
+is
+a
+test.
+
+=back
+
+There should be whitespace now before this line.
+
+Taken from Pod::Parser tests, this is a test to ensure the nested =item
+paragraphs get indented appropriately.
+
+=over 2
+
+=item 1
+
+First section.
+
+=over 2
+
+=item a
+
+this is item a
+
+=item b
+
+this is item b
+
+=back
+
+=item 2
+
+Second section.
+
+=over 2
+
+=item a
+
+this is item a
+
+=item b
+
+this is item b
+
+=item c
+
+=item d
+
+This is item c & d.
+
+=back
+
+=back
+
+Now some additional weirdness of our own. Make sure that multiple tags
+for one paragraph are properly compacted.
+
+=over 4
+
+=item "foo"
+
+=item B<bar>
+
+=item C<baz>
+
+There shouldn't be any spaces between any of these item tags; this idiom
+is used in perlfunc.
+
+=item Some longer item text
+
+Just to make sure that we test paragraphs where the item text doesn't fit
+in the margin of the paragraph (and make sure that this paragraph fills a
+few lines).
+
+Let's also make it multiple paragraphs to be sure that works.
+
+=back
+
+Test use of =over without =item as a block "quote" or block paragraph.
+
+=over 4
+
+This should be indented four spaces but otherwise formatted the same as
+any other regular text paragraph. Make sure it's long enough to see the
+results of the formatting.....
+
+=back
+
+Now try the same thing nested, and make sure that the indentation is reset
+back properly.
+
+=over 4
+
+=over 4
+
+This paragraph should be doubly indented.
+
+=back
+
+This paragraph should only be singly indented.
+
+=over 4
+
+=item
+
+This is an item in the middle of a block-quote, which should be allowed.
+
+=item
+
+We're also testing tagless item commands.
+
+=back
+
+Should be back to the single level of indentation.
+
+=back
+
+Should be back to regular indentation.
+
+Now also check the transformation of * into real bullets for man pages.
+
+=over
+
+=item *
+
+An item. We're also testing using =over without a number, and making sure
+that item text wraps properly.
+
+=item *
+
+Another item.
+
+=back
+
+and now test the numbering of item blocks.
+
+=over 4
+
+=item 1.
+
+First item.
+
+=item 2.
+
+Second item.
+
+=back
+
+=head1 FORMATTING CODES
+
+Another test taken from Pod::Parser.
+
+This is a test to see if I can do not only C<$self> and C<method()>, but
+also C<< $self->method() >> and C<< $self->{FIELDNAME} >> and
+C<< $Foo <=> $Bar >> without resorting to escape sequences. If
+I want to refer to the right-shift operator I can do something
+like C<<< $x >> 3 >>> or even C<<<< $y >> 5 >>>>.
+
+Now for the grand finale of C<< $self->method()->{FIELDNAME} = {FOO=>BAR} >>.
+And I also want to make sure that newlines work like this
+C<<<
+$self->{FOOBAR} >> 3 and [$b => $a]->[$a <=> $b]
+>>>
+
+Of course I should still be able to do all this I<with> escape sequences
+too: C<$self-E<gt>method()> and C<$self-E<gt>{FIELDNAME}> and
+C<{FOO=E<gt>BAR}>.
+
+Dont forget C<$self-E<gt>method()-E<gt>{FIELDNAME} = {FOO=E<gt>BAR}>.
+
+And make sure that C<0> works too!
+
+Now, if I use << or >> as my delimiters, then I have to use whitespace.
+So things like C<<$self->method()>> and C<<$self->{FIELDNAME}>> wont end
+up doing what you might expect since the first > will still terminate
+the first < seen.
+
+Lets make sure these work for empty ones too, like C<< >> and C<< >> >>
+(just to be obnoxious)
+
+The statement: C<This is dog kind's I<finest> hour!> is a parody of a
+quotation from Winston Churchill.
+
+The following tests are added to those:
+
+Make sure that a few othZ<>er odd I<Z<>things> still work. This should be
+a vertical bar: E<verbar>. Here's a test of a few more special escapes
+that have to be supported:
+
+=over 3
+
+=item E<amp>
+
+An ampersand.
+
+=item E<apos>
+
+An apostrophe.
+
+=item E<lt>
+
+A less-than sign.
+
+=item E<gt>
+
+A greater-than sign.
+
+=item E<quot>
+
+A double quotation mark.
+
+=item E<sol>
+
+A forward slash.
+
+=back
+
+Try to get this bit of text over towards the edge so S<|that all of this
+text inside SE<lt>E<gt> won't|> be wrapped. Also test the
+|sameE<nbsp>thingE<nbsp>withE<nbsp>non-breakingS< spaces>.|
+
+There is a soft hyE<shy>phen in hyphen at hy-phen.
+
+This is a test of an X<index entry>index entry.
+
+=head1 VERBATIM
+
+Throw in a few verbatim paragraphs.
+
+ use Term::ANSIColor;
+ print color 'bold blue';
+ print "This text is bold blue.\n";
+ print color 'reset';
+ print "This text is normal.\n";
+ print colored ("Yellow on magenta.\n", 'yellow on_magenta');
+ print "This text is normal.\n";
+ print colored ['yellow on_magenta'], "Yellow on magenta.\n";
+
+ use Term::ANSIColor qw(uncolor);
+ print uncolor '01;31', "\n";
+
+But this isn't verbatim (make sure it wraps properly), and the next
+paragraph is again:
+
+ use Term::ANSIColor qw(:constants);
+ print BOLD, BLUE, "This text is in bold blue.\n", RESET;
+
+ use Term::ANSIColor qw(:constants); $Term::ANSIColor::AUTORESET = 1; print BOLD BLUE "This text is in bold blue.\n"; print "This text is normal.\n";
+
+(Ugh, that's obnoxiously long.) Try different spacing:
+
+ Starting with a tab.
+Not
+starting
+with
+a
+tab. But this should still be verbatim.
+ As should this.
+
+This isn't.
+
+ This is. And this: is an internal tab. It should be:
+ |--| <= lined up with that.
+
+(Tricky, but tabs should be expanded before the translator starts in on
+the text since otherwise text with mixed tabs and spaces will get messed
+up.)
+
+ And now we test verbatim paragraphs right before a heading. Older
+ versions of Pod::Man generated two spaces between paragraphs like this
+ and the heading. (In order to properly test this, one may have to
+ visually inspect the nroff output when run on the generated *roff
+ text, unfortunately.)
+
+=head1 CONCLUSION
+
+That's all, folks!
+
+=cut
Copied: trunk/contrib/perl/lib/Pod/t/basic.t (from rev 6437, vendor/perl/5.18.1/lib/Pod/t/basic.t)
===================================================================
--- trunk/contrib/perl/lib/Pod/t/basic.t (rev 0)
+++ trunk/contrib/perl/lib/Pod/t/basic.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,127 @@
+#!/usr/bin/perl -w
+#
+# basic.t -- Basic tests for podlators.
+#
+# Copyright 2001, 2002, 2004, 2006 by Russ Allbery <rra at stanford.edu>
+#
+# This program is free software; you may redistribute it and/or modify it
+# under the same terms as Perl itself.
+
+BEGIN {
+ chdir 't' if -d 't';
+ if ($ENV{PERL_CORE}) {
+ @INC = '../lib';
+ } else {
+ unshift (@INC, '../blib/lib');
+ }
+ unshift (@INC, '../blib/lib');
+ $| = 1;
+ print "1..11\n";
+}
+
+END {
+ print "not ok 1\n" unless $loaded;
+}
+
+use Pod::Man;
+use Pod::Text;
+use Pod::Text::Overstrike;
+use Pod::Text::Termcap;
+
+# Find the path to the test source files. This requires some fiddling when
+# these tests are run as part of Perl core.
+sub source_path {
+ my $file = shift;
+ if ($ENV{PERL_CORE}) {
+ require File::Spec;
+ my $updir = File::Spec->updir;
+ my $dir = File::Spec->catdir ($updir, 'lib', 'Pod', 't');
+ return File::Spec->catfile ($dir, $file);
+ } else {
+ return $file;
+ }
+}
+
+$loaded = 1;
+print "ok 1\n";
+
+# Hard-code a few values to try to get reproducible results.
+$ENV{COLUMNS} = 80;
+$ENV{TERM} = 'xterm';
+$ENV{TERMCAP} = 'xterm:co=80:do=^J:md=\E[1m:us=\E[4m:me=\E[m';
+
+# Map of translators to file extensions to find the formatted output to
+# compare against.
+my %translators = ('Pod::Man' => 'man',
+ 'Pod::Text' => 'txt',
+ 'Pod::Text::Color' => 'clr',
+ 'Pod::Text::Overstrike' => 'ovr',
+ 'Pod::Text::Termcap' => 'cap');
+
+# Set default options to match those of pod2man and pod2text.
+%options = (sentence => 0);
+
+my $n = 2;
+for (sort keys %translators) {
+ if ($_ eq 'Pod::Text::Color') {
+ eval { require Term::ANSIColor };
+ if ($@) {
+ print "ok $n # skip\n";
+ $n++;
+ print "ok $n # skip\n";
+ $n++;
+ next;
+ }
+ require Pod::Text::Color;
+ }
+ my $parser = $_->new (%options);
+ print (($parser && ref ($parser) eq $_) ? "ok $n\n" : "not ok $n\n");
+ $n++;
+
+ # For Pod::Man, strip out the autogenerated header up to the .TH title
+ # line. That means that we don't check those things; oh well. The header
+ # changes with each version change or touch of the input file.
+ open (OUT, '> out.tmp') or die "Cannot create out.tmp: $!\n";
+ $parser->parse_from_file (source_path ('basic.pod'), \*OUT);
+ close OUT;
+ if ($_ eq 'Pod::Man') {
+ open (TMP, 'out.tmp') or die "Cannot open out.tmp: $!\n";
+ open (OUTPUT, "> out.$translators{$_}")
+ or die "Cannot create out.$translators{$_}: $!\n";
+ local $_;
+ while (<TMP>) { last if /^\.nh/ }
+ print OUTPUT while <TMP>;
+ close OUTPUT;
+ close TMP;
+ unlink 'out.tmp';
+ } else {
+ rename ('out.tmp', "out.$translators{$_}")
+ or die "Cannot rename out.tmp: $!\n";
+ }
+ {
+ local $/;
+ open (MASTER, source_path ("basic.$translators{$_}"))
+ or die "Cannot open basic.$translators{$_}: $!\n";
+ open (OUTPUT, "out.$translators{$_}")
+ or die "Cannot open out.$translators{$_}: $!\n";
+ my $master = <MASTER>;
+ my $output = <OUTPUT>;
+ close MASTER;
+ close OUTPUT;
+
+ # OS/390 is EBCDIC, which uses a different character for ESC
+ # apparently. Try to convert so that the test still works.
+ if ($^O eq 'os390' && $_ eq 'Pod::Text::Termcap') {
+ $output =~ tr/\033/\047/;
+ }
+
+ if ($master eq $output) {
+ print "ok $n\n";
+ unlink "out.$translators{$_}";
+ } else {
+ print "not ok $n\n";
+ print "# Non-matching output left in out.$translators{$_}\n";
+ }
+ }
+ $n++;
+}
Copied: trunk/contrib/perl/lib/Pod/t/basic.txt (from rev 6437, vendor/perl/5.18.1/lib/Pod/t/basic.txt)
===================================================================
--- trunk/contrib/perl/lib/Pod/t/basic.txt (rev 0)
+++ trunk/contrib/perl/lib/Pod/t/basic.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,269 @@
+NAME
+ basic.pod - Test of various basic POD features in translators.
+
+HEADINGS
+ Try a few different levels of headings, with embedded formatting codes
+ and other interesting bits.
+
+This "is" a "level 1" heading
+ ``Level'' "2 *heading*
+ Level 3 heading *with "weird stuff "" (double quote)"*
+ Level "4 "heading"
+ Now try again with intermixed text.
+
+This "is" a "level 1" heading
+ Text.
+
+ ``Level'' 2 *heading*
+ Text.
+
+ Level 3 heading *with "weird stuff"*
+ Text.
+
+ Level "4 "heading"
+ Text.
+
+LINKS
+ These are all taken from the Pod::Parser tests.
+
+ Try out *LOTS* of different ways of specifying references:
+
+ Reference the "section" in manpage
+
+ Reference the "section" in "manpage"
+
+ Reference the "section" in manpage
+
+ Now try it using the new "|" stuff ...
+
+ Reference the thistext|
+
+ Reference the thistext |
+
+ Reference the thistext|
+
+ Reference the thistext |
+
+ Reference the thistext|
+
+ Reference the thistext|
+
+ And then throw in a few new ones of my own.
+
+ foo
+
+ foo
+
+ "bar" in foo
+
+ "baz boo" in foo
+
+ "bar"
+
+ "baz boo"
+
+ "baz boo"
+
+ "baz boo" in foo bar
+
+ "boo var baz"
+
+ "bar baz"
+
+ "boo", "bar", and "baz"
+
+ foobar
+
+ Testing *italics*
+
+ "*Italic* text" in foo
+
+ "Section "with" *other markup*" in foo|bar
+
+ Nested <http://www.perl.org/>
+
+OVER AND ITEMS
+ Taken from Pod::Parser tests, this is a test to ensure that multiline
+ =item paragraphs get indented appropriately.
+
+ This is a test.
+
+ There should be whitespace now before this line.
+
+ Taken from Pod::Parser tests, this is a test to ensure the nested =item
+ paragraphs get indented appropriately.
+
+ 1 First section.
+
+ a this is item a
+
+ b this is item b
+
+ 2 Second section.
+
+ a this is item a
+
+ b this is item b
+
+ c
+ d This is item c & d.
+
+ Now some additional weirdness of our own. Make sure that multiple tags
+ for one paragraph are properly compacted.
+
+ "foo"
+ bar
+ "baz"
+ There shouldn't be any spaces between any of these item tags; this
+ idiom is used in perlfunc.
+
+ Some longer item text
+ Just to make sure that we test paragraphs where the item text
+ doesn't fit in the margin of the paragraph (and make sure that this
+ paragraph fills a few lines).
+
+ Let's also make it multiple paragraphs to be sure that works.
+
+ Test use of =over without =item as a block "quote" or block paragraph.
+
+ This should be indented four spaces but otherwise formatted the same
+ as any other regular text paragraph. Make sure it's long enough to
+ see the results of the formatting.....
+
+ Now try the same thing nested, and make sure that the indentation is
+ reset back properly.
+
+ This paragraph should be doubly indented.
+
+ This paragraph should only be singly indented.
+
+ * This is an item in the middle of a block-quote, which should be
+ allowed.
+
+ * We're also testing tagless item commands.
+
+ Should be back to the single level of indentation.
+
+ Should be back to regular indentation.
+
+ Now also check the transformation of * into real bullets for man pages.
+
+ * An item. We're also testing using =over without a number, and making
+ sure that item text wraps properly.
+
+ * Another item.
+
+ and now test the numbering of item blocks.
+
+ 1. First item.
+
+ 2. Second item.
+
+FORMATTING CODES
+ Another test taken from Pod::Parser.
+
+ This is a test to see if I can do not only $self and "method()", but
+ also "$self->method()" and "$self->{FIELDNAME}" and "$Foo <=> $Bar"
+ without resorting to escape sequences. If I want to refer to the
+ right-shift operator I can do something like "$x >> 3" or even "$y >>
+ 5".
+
+ Now for the grand finale of "$self->method()->{FIELDNAME} = {FOO=>BAR}".
+ And I also want to make sure that newlines work like this
+ "$self->{FOOBAR} >> 3 and [$b => $a]->[$a <=> $b]"
+
+ Of course I should still be able to do all this *with* escape sequences
+ too: "$self->method()" and "$self->{FIELDNAME}" and "{FOO=>BAR}".
+
+ Dont forget "$self->method()->{FIELDNAME} = {FOO=>BAR}".
+
+ And make sure that 0 works too!
+
+ Now, if I use << or >> as my delimiters, then I have to use whitespace.
+ So things like "<$self-"method()>> and "<$self-"{FIELDNAME}>> wont end
+ up doing what you might expect since the first > will still terminate
+ the first < seen.
+
+ Lets make sure these work for empty ones too, like "" and ">>" (just to
+ be obnoxious)
+
+ The statement: "This is dog kind's *finest* hour!" is a parody of a
+ quotation from Winston Churchill.
+
+ The following tests are added to those:
+
+ Make sure that a few other odd *things* still work. This should be a
+ vertical bar: |. Here's a test of a few more special escapes that have
+ to be supported:
+
+ & An ampersand.
+
+ ' An apostrophe.
+
+ < A less-than sign.
+
+ > A greater-than sign.
+
+ " A double quotation mark.
+
+ / A forward slash.
+
+ Try to get this bit of text over towards the edge so
+ |that all of this text inside S<> won't| be wrapped. Also test the
+ |same thing with non-breaking spaces.|
+
+ There is a soft hyphen in hyphen at hy-phen.
+
+ This is a test of an index entry.
+
+VERBATIM
+ Throw in a few verbatim paragraphs.
+
+ use Term::ANSIColor;
+ print color 'bold blue';
+ print "This text is bold blue.\n";
+ print color 'reset';
+ print "This text is normal.\n";
+ print colored ("Yellow on magenta.\n", 'yellow on_magenta');
+ print "This text is normal.\n";
+ print colored ['yellow on_magenta'], "Yellow on magenta.\n";
+
+ use Term::ANSIColor qw(uncolor);
+ print uncolor '01;31', "\n";
+
+ But this isn't verbatim (make sure it wraps properly), and the next
+ paragraph is again:
+
+ use Term::ANSIColor qw(:constants);
+ print BOLD, BLUE, "This text is in bold blue.\n", RESET;
+
+ use Term::ANSIColor qw(:constants); $Term::ANSIColor::AUTORESET = 1; print BOLD BLUE "This text is in bold blue.\n"; print "This text is normal.\n";
+
+ (Ugh, that's obnoxiously long.) Try different spacing:
+
+ Starting with a tab.
+ Not
+ starting
+ with
+ a
+ tab. But this should still be verbatim.
+ As should this.
+
+ This isn't.
+
+ This is. And this: is an internal tab. It should be:
+ |--| <= lined up with that.
+
+ (Tricky, but tabs should be expanded before the translator starts in on
+ the text since otherwise text with mixed tabs and spaces will get messed
+ up.)
+
+ And now we test verbatim paragraphs right before a heading. Older
+ versions of Pod::Man generated two spaces between paragraphs like this
+ and the heading. (In order to properly test this, one may have to
+ visually inspect the nroff output when run on the generated *roff
+ text, unfortunately.)
+
+CONCLUSION
+ That's all, folks!
+
Copied: trunk/contrib/perl/lib/Pod/t/color.t (from rev 6437, vendor/perl/5.18.1/lib/Pod/t/color.t)
===================================================================
--- trunk/contrib/perl/lib/Pod/t/color.t (rev 0)
+++ trunk/contrib/perl/lib/Pod/t/color.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,88 @@
+#!/usr/bin/perl -w
+#
+# color.t -- Additional specialized tests for Pod::Text::Color.
+#
+# Copyright 2002, 2004, 2006 by Russ Allbery <rra at stanford.edu>
+#
+# This program is free software; you may redistribute it and/or modify it
+# under the same terms as Perl itself.
+
+BEGIN {
+ chdir 't' if -d 't';
+ if ($ENV{PERL_CORE}) {
+ @INC = '../lib';
+ } else {
+ unshift (@INC, '../blib/lib');
+ }
+ unshift (@INC, '../blib/lib');
+ $| = 1;
+ print "1..2\n";
+}
+
+END {
+ print "not ok 1\n" unless $loaded;
+}
+
+eval { require Term::ANSIColor };
+if ($@) {
+ for (1..2) {
+ print "ok $_ # skip\n";
+ }
+ $loaded = 1;
+ exit;
+}
+require Pod::Text::Color;
+
+$loaded = 1;
+print "ok 1\n";
+
+my $parser = Pod::Text::Color->new or die "Cannot create parser\n";
+my $n = 2;
+while (<DATA>) {
+ next until $_ eq "###\n";
+ open (TMP, '> tmp.pod') or die "Cannot create tmp.pod: $!\n";
+ while (<DATA>) {
+ last if $_ eq "###\n";
+ print TMP $_;
+ }
+ close TMP;
+ open (OUT, '> out.tmp') or die "Cannot create out.tmp: $!\n";
+ $parser->parse_from_file ('tmp.pod', \*OUT);
+ close OUT;
+ open (TMP, 'out.tmp') or die "Cannot open out.tmp: $!\n";
+ my $output;
+ {
+ local $/;
+ $output = <TMP>;
+ }
+ close TMP;
+ unlink ('tmp.pod', 'out.tmp');
+ my $expected = '';
+ while (<DATA>) {
+ last if $_ eq "###\n";
+ $expected .= $_;
+ }
+ if ($output eq $expected) {
+ print "ok $n\n";
+ } else {
+ print "not ok $n\n";
+ print "Expected\n========\n$expected\nOutput\n======\n$output\n";
+ }
+ $n++;
+}
+
+# Below the marker are bits of POD and corresponding expected output. This is
+# used to test specific features or problems with Pod::Text::Termcap. The
+# input and output are separated by lines containing only ###.
+
+__DATA__
+
+###
+=head1 WRAPPING
+
+B<I<Do>> I<B<not>> B<I<include>> B<I<formatting codes when>> B<I<wrapping>>.
+###
+[1mWRAPPING[0m
+ [1m[33mDo[0m[0m [33m[1mnot[0m[0m [1m[33minclude[0m[0m [1m[33mformatting codes when[0m[0m [1m[33mwrapping[0m[0m.
+
+###
Copied: trunk/contrib/perl/lib/Pod/t/contains_pod.t (from rev 6437, vendor/perl/5.18.1/lib/Pod/t/contains_pod.t)
===================================================================
--- trunk/contrib/perl/lib/Pod/t/contains_pod.t (rev 0)
+++ trunk/contrib/perl/lib/Pod/t/contains_pod.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,27 @@
+#!/usr/bin/env perl
+
+# Copyright (C) 2005 Joshua Hoblitt
+#
+# $Id: contains_pod.t,v 1.1.1.2 2011-02-17 12:49:41 laffer1 Exp $
+
+use strict;
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
+ } else {
+ use lib qw( ./lib );
+ }
+}
+
+use Test::More tests => 2;
+
+use Pod::Find qw( contains_pod );
+
+{
+ ok(contains_pod('lib/contains_pod.xr'), "contains pod");
+}
+
+{
+ ok(contains_pod('lib/contains_bad_pod.xr'), "contains bad pod");
+}
Index: trunk/contrib/perl/lib/Pod/t/eol.t
===================================================================
--- trunk/contrib/perl/lib/Pod/t/eol.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Pod/t/eol.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Pod/t/eol.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/lib/Pod/t/filehandle.t (from rev 6437, vendor/perl/5.18.1/lib/Pod/t/filehandle.t)
===================================================================
--- trunk/contrib/perl/lib/Pod/t/filehandle.t (rev 0)
+++ trunk/contrib/perl/lib/Pod/t/filehandle.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,121 @@
+#!/usr/bin/perl -w
+#
+# filehandle.t -- Test the parse_from_filehandle interface.
+#
+# Copyright 2006 by Russ Allbery <rra at stanford.edu>
+#
+# This program is free software; you may redistribute it and/or modify it
+# under the same terms as Perl itself.
+
+BEGIN {
+ chdir 't' if -d 't';
+ if ($ENV{PERL_CORE}) {
+ @INC = '../lib';
+ } else {
+ unshift (@INC, '../blib/lib');
+ }
+ unshift (@INC, '../blib/lib');
+ $| = 1;
+ print "1..3\n";
+}
+
+END {
+ print "not ok 1\n" unless $loaded;
+}
+
+use Pod::Man;
+use Pod::Text;
+
+$loaded = 1;
+print "ok 1\n";
+
+my $man = Pod::Man->new or die "Cannot create parser\n";
+my $text = Pod::Text->new or die "Cannot create parser\n";
+my $n = 2;
+while (<DATA>) {
+ next until $_ eq "###\n";
+ open (TMP, '> tmp.pod') or die "Cannot create tmp.pod: $!\n";
+ while (<DATA>) {
+ last if $_ eq "###\n";
+ print TMP $_;
+ }
+ close TMP;
+ open (IN, '< tmp.pod') or die "Cannot open tmp.pod: $!\n";
+ open (OUT, '> out.tmp') or die "Cannot create out.tmp: $!\n";
+ $man->parse_from_filehandle (\*IN, \*OUT);
+ close IN;
+ close OUT;
+ open (OUT, 'out.tmp') or die "Cannot open out.tmp: $!\n";
+ while (<OUT>) { last if /^\.nh/ }
+ my $output;
+ {
+ local $/;
+ $output = <OUT>;
+ }
+ close OUT;
+ my $expected = '';
+ while (<DATA>) {
+ last if $_ eq "###\n";
+ $expected .= $_;
+ }
+ if ($output eq $expected) {
+ print "ok $n\n";
+ } else {
+ print "not ok $n\n";
+ print "Expected\n========\n$expected\nOutput\n======\n$output\n";
+ }
+ $n++;
+ open (IN, '< tmp.pod') or die "Cannot open tmp.pod: $!\n";
+ open (OUT, '> out.tmp') or die "Cannot create out.tmp: $!\n";
+ $text->parse_from_filehandle (\*IN, \*OUT);
+ close IN;
+ close OUT;
+ open (OUT, 'out.tmp') or die "Cannot open out.tmp: $!\n";
+ {
+ local $/;
+ $output = <OUT>;
+ }
+ close OUT;
+ unlink ('tmp.pod', 'out.tmp');
+ $expected = '';
+ while (<DATA>) {
+ last if $_ eq "###\n";
+ $expected .= $_;
+ }
+ if ($output eq $expected) {
+ print "ok $n\n";
+ } else {
+ print "not ok $n\n";
+ print "Expected\n========\n$expected\nOutput\n======\n$output\n";
+ }
+ $n++;
+}
+
+# Below the marker are bits of POD, corresponding expected nroff output, and
+# corresponding expected text output. The input and output are separated by
+# lines containing only ###.
+
+__DATA__
+
+###
+=head1 NAME
+
+gcc - GNU project C and C++ compiler
+
+=head1 C++ NOTES
+
+Other mentions of C++.
+###
+.SH "NAME"
+gcc \- GNU project C and C++ compiler
+.SH "\*(C+ NOTES"
+.IX Header " NOTES"
+Other mentions of \*(C+.
+###
+NAME
+ gcc - GNU project C and C++ compiler
+
+C++ NOTES
+ Other mentions of C++.
+
+###
Copied: trunk/contrib/perl/lib/Pod/t/htmlescp.pod (from rev 6437, vendor/perl/5.18.1/lib/Pod/t/htmlescp.pod)
===================================================================
--- trunk/contrib/perl/lib/Pod/t/htmlescp.pod (rev 0)
+++ trunk/contrib/perl/lib/Pod/t/htmlescp.pod 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,14 @@
+=head1 NAME
+
+Escape Sequences Test
+
+=head1 DESCRIPTION
+
+I am a stupid fool who puts naked < & > characters in my POD
+instead of escaping them as E<lt> and E<gt>.
+
+Here is some B<bold> text, some I<italic> plus F</etc/fstab>
+file and something that looks like an E<lt>htmlE<gt> tag.
+This is some C<$code($arg1)>.
+
+=cut
Copied: trunk/contrib/perl/lib/Pod/t/htmlescp.t (from rev 6437, vendor/perl/5.18.1/lib/Pod/t/htmlescp.t)
===================================================================
--- trunk/contrib/perl/lib/Pod/t/htmlescp.t (rev 0)
+++ trunk/contrib/perl/lib/Pod/t/htmlescp.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,58 @@
+#!/usr/bin/perl -w # -*- perl -*-
+
+BEGIN {
+ chdir 't' if -d 't';
+ unshift @INC, '../lib';
+ unshift @INC, '../lib/Pod/t';
+ require "pod2html-lib.pl";
+}
+
+use strict;
+use Test::More tests => 1;
+
+convert_n_test("htmlescp", "html escape");
+
+__DATA__
+<?xml version="1.0" ?>
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml">
+<head>
+<title>NAME</title>
+<meta http-equiv="content-type" content="text/html; charset=utf-8" />
+<link rev="made" href="mailto:[PERLADMIN]" />
+</head>
+
+<body style="background-color: white">
+
+
+<!-- INDEX BEGIN -->
+<div name="index">
+<p><a name="__index__"></a></p>
+
+<ul>
+
+ <li><a href="#name">NAME</a></li>
+ <li><a href="#description">DESCRIPTION</a></li>
+</ul>
+
+<hr name="index" />
+</div>
+<!-- INDEX END -->
+
+<p>
+</p>
+<h1><a name="name">NAME</a></h1>
+<p>Escape Sequences Test</p>
+<p>
+</p>
+<hr />
+<h1><a name="description">DESCRIPTION</a></h1>
+<p>I am a stupid fool who puts naked < & > characters in my POD
+instead of escaping them as < and >.</p>
+<p>Here is some <strong>bold</strong> text, some <em>italic</em> plus <em class="file">/etc/fstab</em>
+file and something that looks like an <html> tag.
+This is some <code>$code($arg1)</code>.</p>
+
+</body>
+
+</html>
Copied: trunk/contrib/perl/lib/Pod/t/htmllink.pod (from rev 6437, vendor/perl/5.18.1/lib/Pod/t/htmllink.pod)
===================================================================
--- trunk/contrib/perl/lib/Pod/t/htmllink.pod (rev 0)
+++ trunk/contrib/perl/lib/Pod/t/htmllink.pod 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,109 @@
+=head1 NAME
+
+htmllink - Test HTML links
+
+=head1 LINKS
+
+L</"section1">
+
+L</"section 2">
+
+L</"section three">
+
+L</"item1">
+
+L</"item 2">
+
+L</"item three">
+
+L</section1>
+
+L</section 2>
+
+L</section three>
+
+L</item1>
+
+L</item 2>
+
+L</item three>
+
+L<"section1">
+
+L<"section 2">
+
+L<"section three">
+
+L<"item1">
+
+L<"item 2">
+
+L<"item three">
+
+L<text|/"section1">
+
+L<text|/"section 2">
+
+L<text|/"section three">
+
+L<text|/"item1">
+
+L<text|/"item 2">
+
+L<text|/"item three">
+
+L<text|/section1>
+
+L<text|/section 2>
+
+L<text|/section three>
+
+L<text|/item1>
+
+L<text|/item 2>
+
+L<text|/item three>
+
+L<text|"section1">
+
+L<text|"section 2">
+
+L<text|"section three">
+
+L<text|"item1">
+
+L<text|"item 2">
+
+L<text|"item three">
+
+=head1 TARGETS
+
+=head2 section1
+
+This is section one.
+
+=head2 section 2
+
+This is section two.
+
+=head2 section three
+
+This is section three.
+
+=over 4
+
+=item item1 X<item> X<one>
+
+This is item one.
+
+=item item 2
+X<item> X<two>
+
+This is item two.
+
+=item item three X<item>
+X<three>
+
+This is item three.
+
+=back
Copied: trunk/contrib/perl/lib/Pod/t/htmllink.t (from rev 6437, vendor/perl/5.18.1/lib/Pod/t/htmllink.t)
===================================================================
--- trunk/contrib/perl/lib/Pod/t/htmllink.t (rev 0)
+++ trunk/contrib/perl/lib/Pod/t/htmllink.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,130 @@
+#!/usr/bin/perl -w # -*- perl -*-
+
+BEGIN {
+ chdir 't' if -d 't';
+ unshift @INC, '../lib';
+ unshift @INC, '../lib/Pod/t';
+ require "pod2html-lib.pl";
+}
+
+use strict;
+use Test::More tests => 1;
+
+convert_n_test("htmllink", "html links");
+
+__DATA__
+<?xml version="1.0" ?>
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml">
+<head>
+<title>htmllink - Test HTML links</title>
+<meta http-equiv="content-type" content="text/html; charset=utf-8" />
+<link rev="made" href="mailto:[PERLADMIN]" />
+</head>
+
+<body style="background-color: white">
+
+
+<!-- INDEX BEGIN -->
+<div name="index">
+<p><a name="__index__"></a></p>
+
+<ul>
+
+ <li><a href="#name">NAME</a></li>
+ <li><a href="#links">LINKS</a></li>
+ <li><a href="#targets">TARGETS</a></li>
+ <ul>
+
+ <li><a href="#section1">section1</a></li>
+ <li><a href="#section_2">section 2</a></li>
+ <li><a href="#section_three">section three</a></li>
+ </ul>
+
+</ul>
+
+<hr name="index" />
+</div>
+<!-- INDEX END -->
+
+<p>
+</p>
+<h1><a name="name">NAME</a></h1>
+<p>htmllink - Test HTML links</p>
+<p>
+</p>
+<hr />
+<h1><a name="links">LINKS</a></h1>
+<p><a href="#section1">section1</a></p>
+<p><a href="#section_2">section 2</a></p>
+<p><a href="#section_three">section three</a></p>
+<p><a href="#item1">item1</a></p>
+<p><a href="#item_2">item 2</a></p>
+<p><a href="#item_three">item three</a></p>
+<p><a href="#section1">section1</a></p>
+<p><a href="#section_2">section 2</a></p>
+<p><a href="#section_three">section three</a></p>
+<p><a href="#item1">item1</a></p>
+<p><a href="#item_2">item 2</a></p>
+<p><a href="#item_three">item three</a></p>
+<p><a href="#section1">section1</a></p>
+<p><a href="#section_2">section 2</a></p>
+<p><a href="#section_three">section three</a></p>
+<p><a href="#item1">item1</a></p>
+<p><a href="#item_2">item 2</a></p>
+<p><a href="#item_three">item three</a></p>
+<p><a href="#section1">text</a></p>
+<p><a href="#section_2">text</a></p>
+<p><a href="#section_three">text</a></p>
+<p><a href="#item1">text</a></p>
+<p><a href="#item_2">text</a></p>
+<p><a href="#item_three">text</a></p>
+<p><a href="#section1">text</a></p>
+<p><a href="#section_2">text</a></p>
+<p><a href="#section_three">text</a></p>
+<p><a href="#item1">text</a></p>
+<p><a href="#item_2">text</a></p>
+<p><a href="#item_three">text</a></p>
+<p><a href="#section1">text</a></p>
+<p><a href="#section_2">text</a></p>
+<p><a href="#section_three">text</a></p>
+<p><a href="#item1">text</a></p>
+<p><a href="#item_2">text</a></p>
+<p><a href="#item_three">text</a></p>
+<p>
+</p>
+<hr />
+<h1><a name="targets">TARGETS</a></h1>
+<p>
+</p>
+<h2><a name="section1">section1</a></h2>
+<p>This is section one.</p>
+<p>
+</p>
+<h2><a name="section_2">section 2</a></h2>
+<p>This is section two.</p>
+<p>
+</p>
+<h2><a name="section_three">section three</a></h2>
+<p>This is section three.</p>
+<dl>
+<dt><strong><a name="item1" class="item">item1</a></strong></dt>
+
+<dd>
+<p>This is item one.</p>
+</dd>
+<dt><strong><a name="item_2" class="item">item 2</a></strong></dt>
+
+<dd>
+<p>This is item two.</p>
+</dd>
+<dt><strong><a name="item_three" class="item">item three</a></strong></dt>
+
+<dd>
+<p>This is item three.</p>
+</dd>
+</dl>
+
+</body>
+
+</html>
Copied: trunk/contrib/perl/lib/Pod/t/htmlview.pod (from rev 6437, vendor/perl/5.18.1/lib/Pod/t/htmlview.pod)
===================================================================
--- trunk/contrib/perl/lib/Pod/t/htmlview.pod (rev 0)
+++ trunk/contrib/perl/lib/Pod/t/htmlview.pod 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,146 @@
+=head1 NAME
+
+Test HTML Rendering
+
+=head1 SYNOPSIS
+
+ use My::Module;
+
+ my $module = My::Module->new();
+
+=head1 DESCRIPTION
+
+This is the description.
+
+ Here is a verbatim section.
+
+This is some more regular text.
+
+Here is some B<bold> text, some I<italic> and something that looks
+like an E<lt>htmlE<gt> tag. This is some C<$code($arg1)>.
+
+This C<text contains embedded B<bold> and I<italic> tags>. These can
+be nested, allowing B<bold and I<bold E<amp> italic> text>. The module also
+supports the extended B<< syntax >> and permits I<< nested tags E<amp>
+other B<<< cool >>> stuff >>
+
+=head1 METHODS =E<gt> OTHER STUFF
+
+Here is a list of methods
+
+=head2 new()
+
+Constructor method. Accepts the following config options:
+
+=over 4
+
+=item foo
+
+The foo item.
+
+=item bar
+
+The bar item.
+
+=over 4
+
+This is a list within a list
+
+=item *
+
+The wiz item.
+
+=item *
+
+The waz item.
+
+=back
+
+=item baz
+
+The baz item.
+
+=back
+
+Title on the same line as the =item + * bullets
+
+=over
+
+=item * C<Black> Cat
+
+=item * Sat S<I<on> the>
+
+=item * MatE<lt>!E<gt>
+
+=back
+
+Title on the same line as the =item + numerical bullets
+
+=over
+
+=item 1 Cat
+
+=item 2 Sat
+
+=item 3 Mat
+
+=back
+
+No bullets, no title
+
+=over
+
+=item
+
+Cat
+
+=item
+
+Sat
+
+=item
+
+Mat
+
+=back
+
+=head2 old()
+
+Destructor method
+
+=head1 TESTING FOR AND BEGIN
+
+=for html <br />
+<p>
+blah blah
+</p>
+
+intermediate text
+
+=begin html
+
+<more>
+HTML
+</more>
+
+some text
+
+=end html
+
+=head1 TESTING URLs hyperlinking
+
+This is an href link1: http://example.com
+
+This is an href link2: http://example.com/foo/bar.html
+
+This is an email link: mailto:foo at bar.com
+
+ This is a link in a verbatim block <a href="http://perl.org"> Perl </a>
+
+=head1 SEE ALSO
+
+See also L<Test Page 2|htmlescp>, the L<Your::Module> and L<Their::Module>
+manpages and the other interesting file F</usr/local/my/module/rocks>
+as well.
+
+=cut
Copied: trunk/contrib/perl/lib/Pod/t/htmlview.t (from rev 6437, vendor/perl/5.18.1/lib/Pod/t/htmlview.t)
===================================================================
--- trunk/contrib/perl/lib/Pod/t/htmlview.t (rev 0)
+++ trunk/contrib/perl/lib/Pod/t/htmlview.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,186 @@
+#!/usr/bin/perl -w # -*- perl -*-
+
+BEGIN {
+ chdir 't' if -d 't';
+ unshift @INC, '../lib';
+ unshift @INC, '../lib/Pod/t';
+ require "pod2html-lib.pl";
+}
+
+use strict;
+use Test::More tests => 1;
+
+convert_n_test("htmlview", "html rendering");
+
+__DATA__
+<?xml version="1.0" ?>
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml">
+<head>
+<title>NAME</title>
+<meta http-equiv="content-type" content="text/html; charset=utf-8" />
+<link rev="made" href="mailto:[PERLADMIN]" />
+</head>
+
+<body style="background-color: white">
+
+
+<!-- INDEX BEGIN -->
+<div name="index">
+<p><a name="__index__"></a></p>
+
+<ul>
+
+ <li><a href="#name">NAME</a></li>
+ <li><a href="#synopsis">SYNOPSIS</a></li>
+ <li><a href="#description">DESCRIPTION</a></li>
+ <li><a href="#methods____other_stuff">METHODS => OTHER STUFF</a></li>
+ <ul>
+
+ <li><a href="#new__"><code>new()</code></a></li>
+ <li><a href="#old__"><code>old()</code></a></li>
+ </ul>
+
+ <li><a href="#testing_for_and_begin">TESTING FOR AND BEGIN</a></li>
+ <li><a href="#testing_urls_hyperlinking">TESTING URLs hyperlinking</a></li>
+ <li><a href="#see_also">SEE ALSO</a></li>
+</ul>
+
+<hr name="index" />
+</div>
+<!-- INDEX END -->
+
+<p>
+</p>
+<h1><a name="name">NAME</a></h1>
+<p>Test HTML Rendering</p>
+<p>
+</p>
+<hr />
+<h1><a name="synopsis">SYNOPSIS</a></h1>
+<pre>
+ use My::Module;</pre>
+<pre>
+ my $module = My::Module->new();</pre>
+<p>
+</p>
+<hr />
+<h1><a name="description">DESCRIPTION</a></h1>
+<p>This is the description.</p>
+<pre>
+ Here is a verbatim section.</pre>
+<p>This is some more regular text.</p>
+<p>Here is some <strong>bold</strong> text, some <em>italic</em> and something that looks
+like an <html> tag. This is some <code>$code($arg1)</code>.</p>
+<p>This <code>text contains embedded bold and italic tags</code>. These can
+be nested, allowing <strong>bold and <em>bold & italic</em> text</strong>. The module also
+supports the extended <strong>syntax </strong>> and permits <em>nested tags &
+other <strong>cool </strong></em>> stuff >></p>
+<p>
+</p>
+<hr />
+<h1><a name="methods____other_stuff">METHODS => OTHER STUFF</a></h1>
+<p>Here is a list of methods</p>
+<p>
+</p>
+<h2><a name="new__"><code>new()</code></a></h2>
+<p>Constructor method. Accepts the following config options:</p>
+<dl>
+<dt><strong><a name="foo" class="item">foo</a></strong></dt>
+
+<dd>
+<p>The foo item.</p>
+</dd>
+<dt><strong><a name="bar" class="item">bar</a></strong></dt>
+
+<dd>
+<p>The bar item.</p>
+<p>This is a list within a list</p>
+<ul>
+<li>
+<p>The wiz item.</p>
+</li>
+<li>
+<p>The waz item.</p>
+</li>
+</ul>
+</dd>
+<dt><strong><a name="baz" class="item">baz</a></strong></dt>
+
+<dd>
+<p>The baz item.</p>
+</dd>
+</dl>
+<p>Title on the same line as the =item + * bullets</p>
+<ul>
+<li><strong><a name="black_cat" class="item"><code>Black</code> Cat</a></strong>
+
+</li>
+<li><strong><a name="sat_on_the" class="item">Sat <em>on</em> the</a></strong>
+
+</li>
+<li><strong><a name="mat" class="item">Mat<!></a></strong>
+
+</li>
+</ul>
+<p>Title on the same line as the =item + numerical bullets</p>
+<ol>
+<li><strong><a name="cat" class="item">Cat</a></strong>
+
+</li>
+<li><strong><a name="sat" class="item">Sat</a></strong>
+
+</li>
+<li><strong><a name="mat2" class="item">Mat</a></strong>
+
+</li>
+</ol>
+<p>No bullets, no title</p>
+<dl>
+<dt>
+<dd>
+<p>Cat</p>
+</dd>
+<dt>
+<dd>
+<p>Sat</p>
+</dd>
+<dt>
+<dd>
+<p>Mat</p>
+</dd>
+</dl>
+<p>
+</p>
+<h2><a name="old__"><code>old()</code></a></h2>
+<p>Destructor method</p>
+<p>
+</p>
+<hr />
+<h1><a name="testing_for_and_begin">TESTING FOR AND BEGIN</a></h1>
+<br />
+<p>
+blah blah
+</p><p>intermediate text</p>
+<more>
+HTML
+</more>some text<p>
+</p>
+<hr />
+<h1><a name="testing_urls_hyperlinking">TESTING URLs hyperlinking</a></h1>
+<p>This is an href link1: <a href="http://example.com">http://example.com</a></p>
+<p>This is an href link2: <a href="http://example.com/foo/bar.html">http://example.com/foo/bar.html</a></p>
+<p>This is an email link: <a href="mailto:mailto:foo at bar.com">mailto:foo at bar.com</a></p>
+<pre>
+ This is a link in a verbatim block <a href="<a href="http://perl.org">http://perl.org</a>"> Perl </a></pre>
+<p>
+</p>
+<hr />
+<h1><a name="see_also">SEE ALSO</a></h1>
+<p>See also <a href="/t/htmlescp.html">Test Page 2</a>, the <a href="/Your/Module.html">the Your::Module manpage</a> and <a href="/Their/Module.html">the Their::Module manpage</a>
+manpages and the other interesting file <em class="file">/usr/local/my/module/rocks</em>
+as well.</p>
+
+</body>
+
+</html>
Copied: trunk/contrib/perl/lib/Pod/t/man-options.t (from rev 6437, vendor/perl/5.18.1/lib/Pod/t/man-options.t)
===================================================================
--- trunk/contrib/perl/lib/Pod/t/man-options.t (rev 0)
+++ trunk/contrib/perl/lib/Pod/t/man-options.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,175 @@
+#!/usr/bin/perl -w
+#
+# man-options.t -- Additional tests for Pod::Man options.
+#
+# Copyright 2002, 2004, 2006, 2008 Russ Allbery <rra at stanford.edu>
+#
+# This program is free software; you may redistribute it and/or modify it
+# under the same terms as Perl itself.
+
+BEGIN {
+ chdir 't' if -d 't';
+ if ($ENV{PERL_CORE}) {
+ @INC = '../lib';
+ } else {
+ unshift (@INC, '../blib/lib');
+ }
+ unshift (@INC, '../blib/lib');
+ $| = 1;
+ print "1..7\n";
+}
+
+END {
+ print "not ok 1\n" unless $loaded;
+}
+
+use Pod::Man;
+
+# Redirect stderr to a file.
+sub stderr_save {
+ open (OLDERR, '>&STDERR') or die "Can't dup STDERR: $!\n";
+ open (STDERR, '> out.err') or die "Can't redirect STDERR: $!\n";
+}
+
+# Restore stderr.
+sub stderr_restore {
+ close STDERR;
+ open (STDERR, '>&OLDERR') or die "Can't dup STDERR: $!\n";
+ close OLDERR;
+}
+
+$loaded = 1;
+print "ok 1\n";
+
+my $n = 2;
+while (<DATA>) {
+ my %options;
+ next until $_ eq "###\n";
+ while (<DATA>) {
+ last if $_ eq "###\n";
+ my ($option, $value) = split;
+ $options{$option} = $value;
+ }
+ open (TMP, '> tmp.pod') or die "Cannot create tmp.pod: $!\n";
+ while (<DATA>) {
+ last if $_ eq "###\n";
+ print TMP $_;
+ }
+ close TMP;
+ my $parser = Pod::Man->new (%options) or die "Cannot create parser\n";
+ open (OUT, '> out.tmp') or die "Cannot create out.tmp: $!\n";
+ stderr_save;
+ $parser->parse_from_file ('tmp.pod', \*OUT);
+ stderr_restore;
+ close OUT;
+ my $accents = 0;
+ open (TMP, 'out.tmp') or die "Cannot open out.tmp: $!\n";
+ while (<TMP>) {
+ last if /^\.nh/;
+ }
+ my $output;
+ {
+ local $/;
+ $output = <TMP>;
+ }
+ close TMP;
+ unlink ('tmp.pod', 'out.tmp');
+ my $expected = '';
+ while (<DATA>) {
+ last if $_ eq "###\n";
+ $expected .= $_;
+ }
+ if ($output eq $expected) {
+ print "ok $n\n";
+ } else {
+ print "not ok $n\n";
+ print "Expected\n========\n$expected\nOutput\n======\n$output\n";
+ }
+ $n++;
+ open (ERR, 'out.err') or die "Cannot open out.err: $!\n";
+ my $errors;
+ {
+ local $/;
+ $errors = <ERR>;
+ }
+ close ERR;
+ unlink ('out.err');
+ $expected = '';
+ while (<DATA>) {
+ last if $_ eq "###\n";
+ $expected .= $_;
+ }
+ if ($errors eq $expected) {
+ print "ok $n\n";
+ } else {
+ print "not ok $n\n";
+ print "Expected errors:\n ${expected}Errors:\n $errors";
+ }
+ $n++;
+}
+
+# Below the marker are bits of POD and corresponding expected text output.
+# This is used to test specific features or problems with Pod::Man. The
+# input and output are separated by lines containing only ###.
+
+__DATA__
+
+###
+fixed CR
+fixedbold CY
+fixeditalic CW
+fixedbolditalic CX
+###
+=head1 FIXED FONTS
+
+C<foo B<bar I<baz>> I<bay>>
+###
+.SH "FIXED FONTS"
+.IX Header "FIXED FONTS"
+\&\f(CR\*(C`foo \f(CYbar \f(CXbaz\f(CY\f(CR \f(CWbay\f(CR\*(C'\fR
+###
+###
+
+###
+###
+=over 4
+
+=item Foo
+
+Bar.
+
+=head1 NEXT
+###
+.IP "Foo" 4
+.IX Item "Foo"
+Bar.
+.SH "NEXT"
+.IX Header "NEXT"
+.SH "POD ERRORS"
+.IX Header "POD ERRORS"
+Hey! \fBThe above document had some coding errors, which are explained below:\fR
+.IP "Around line 7:" 4
+.IX Item "Around line 7:"
+You forgot a '=back' before '=head1'
+###
+###
+
+###
+stderr 1
+###
+=over 4
+
+=item Foo
+
+Bar.
+
+=head1 NEXT
+###
+.IP "Foo" 4
+.IX Item "Foo"
+Bar.
+.SH "NEXT"
+.IX Header "NEXT"
+###
+tmp.pod around line 7: You forgot a '=back' before '=head1'
+###
Copied: trunk/contrib/perl/lib/Pod/t/man-utf8.t (from rev 6437, vendor/perl/5.18.1/lib/Pod/t/man-utf8.t)
===================================================================
--- trunk/contrib/perl/lib/Pod/t/man-utf8.t (rev 0)
+++ trunk/contrib/perl/lib/Pod/t/man-utf8.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,141 @@
+#!/usr/bin/perl -w
+#
+# man-options.t -- Additional tests for Pod::Man options.
+#
+# Copyright 2002, 2004, 2006, 2008 Russ Allbery <rra at stanford.edu>
+#
+# This program is free software; you may redistribute it and/or modify it
+# under the same terms as Perl itself.
+
+BEGIN {
+ chdir 't' if -d 't';
+ if ($ENV{PERL_CORE}) {
+ @INC = '../lib';
+ } else {
+ unshift (@INC, '../blib/lib');
+ }
+ unshift (@INC, '../blib/lib');
+ $| = 1;
+ print "1..5\n";
+
+ # UTF-8 support requires Perl 5.8 or later.
+ if ($] < 5.008) {
+ my $n;
+ for $n (1..5) {
+ print "ok $n # skip -- Perl 5.8 required for UTF-8 support\n";
+ }
+ exit;
+ }
+}
+
+END {
+ print "not ok 1\n" unless $loaded;
+}
+
+use Pod::Man;
+
+$loaded = 1;
+print "ok 1\n";
+
+my $n = 2;
+eval { binmode (\*DATA, ':encoding(utf-8)') };
+eval { binmode (\*STDOUT, ':encoding(utf-8)') };
+while (<DATA>) {
+ my %options;
+ next until $_ eq "###\n";
+ while (<DATA>) {
+ last if $_ eq "###\n";
+ my ($option, $value) = split;
+ $options{$option} = $value;
+ }
+ open (TMP, '> tmp.pod') or die "Cannot create tmp.pod: $!\n";
+ eval { binmode (\*TMP, ':encoding(utf-8)') };
+ print TMP "=encoding utf-8\n\n";
+ while (<DATA>) {
+ last if $_ eq "###\n";
+ print TMP $_;
+ }
+ close TMP;
+ my $parser = Pod::Man->new (%options) or die "Cannot create parser\n";
+ open (OUT, '> out.tmp') or die "Cannot create out.tmp: $!\n";
+ $parser->parse_from_file ('tmp.pod', \*OUT);
+ close OUT;
+ my $accents = 0;
+ open (TMP, 'out.tmp') or die "Cannot open out.tmp: $!\n";
+ eval { binmode (\*TMP, ':encoding(utf-8)') };
+ while (<TMP>) {
+ $accents = 1 if /Accent mark definitions/;
+ last if /^\.nh/;
+ }
+ my $output;
+ {
+ local $/;
+ $output = <TMP>;
+ }
+ close TMP;
+ unlink ('tmp.pod', 'out.tmp');
+ if (($options{utf8} && !$accents) || (!$options{utf8} && $accents)) {
+ print "ok $n\n";
+ } else {
+ print "not ok $n\n";
+ print ($accents ? "Saw accents\n" : "Saw no accents\n");
+ print ($options{utf8} ? "Wanted no accents\n" : "Wanted accents\n");
+ }
+ $n++;
+ my $expected = '';
+ while (<DATA>) {
+ last if $_ eq "###\n";
+ $expected .= $_;
+ }
+ if ($output eq $expected) {
+ print "ok $n\n";
+ } else {
+ print "not ok $n\n";
+ print "Expected\n========\n$expected\nOutput\n======\n$output\n";
+ }
+ $n++;
+}
+
+# Below the marker are bits of POD and corresponding expected text output.
+# This is used to test specific features or problems with Pod::Man. The
+# input and output are separated by lines containing only ###.
+
+__DATA__
+
+###
+utf8 1
+###
+=head1 BEYONCÉ
+
+Beyoncé! Beyoncé! Beyoncé!!
+
+ Beyoncé! Beyoncé!
+ Beyoncé! Beyoncé!
+ Beyoncé! Beyoncé!
+
+Older versions did not convert Beyoncé in verbatim.
+###
+.SH "BEYONCÉ"
+.IX Header "BEYONCÉ"
+Beyoncé! Beyoncé! Beyoncé!!
+.PP
+.Vb 3
+\& Beyoncé! Beyoncé!
+\& Beyoncé! Beyoncé!
+\& Beyoncé! Beyoncé!
+.Ve
+.PP
+Older versions did not convert Beyoncé in verbatim.
+###
+
+###
+utf8 1
+###
+=head1 SE<lt>E<gt> output with UTF-8
+
+This is S<non-breaking output>.
+###
+.SH "S<> output with UTF\-8"
+.IX Header "S<> output with UTF-8"
+This is non-breaking output.
+###
Copied: trunk/contrib/perl/lib/Pod/t/man.t (from rev 6437, vendor/perl/5.18.1/lib/Pod/t/man.t)
===================================================================
--- trunk/contrib/perl/lib/Pod/t/man.t (rev 0)
+++ trunk/contrib/perl/lib/Pod/t/man.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,484 @@
+#!/usr/bin/perl -w
+#
+# man.t -- Additional specialized tests for Pod::Man.
+#
+# Copyright 2002, 2003, 2004, 2006, 2007, 2008
+# Russ Allbery <rra at stanford.edu>
+#
+# This program is free software; you may redistribute it and/or modify it
+# under the same terms as Perl itself.
+
+BEGIN {
+ chdir 't' if -d 't';
+ if ($ENV{PERL_CORE}) {
+ @INC = '../lib';
+ } else {
+ unshift (@INC, '../blib/lib');
+ }
+ unshift (@INC, '../blib/lib');
+ $| = 1;
+ print "1..25\n";
+}
+
+END {
+ print "not ok 1\n" unless $loaded;
+}
+
+use Pod::Man;
+
+$loaded = 1;
+print "ok 1\n";
+
+# Test whether we can use binmode to set encoding.
+my $have_encoding = (eval { require PerlIO::encoding; 1 } and not $@);
+
+my $parser = Pod::Man->new or die "Cannot create parser\n";
+my $n = 2;
+while (<DATA>) {
+ next until $_ eq "###\n";
+ open (TMP, '> tmp.pod') or die "Cannot create tmp.pod: $!\n";
+
+ # We have a test in ISO 8859-1 encoding. Make sure that nothing strange
+ # happens if Perl thinks the world is Unicode. Wrap this in eval so that
+ # older versions of Perl don't croak.
+ eval { binmode (\*TMP, ':encoding(iso-8859-1)') if $have_encoding };
+
+ while (<DATA>) {
+ last if $_ eq "###\n";
+ print TMP $_;
+ }
+ close TMP;
+ open (OUT, '> out.tmp') or die "Cannot create out.tmp: $!\n";
+ $parser->parse_from_file ('tmp.pod', \*OUT);
+ close OUT;
+ open (OUT, 'out.tmp') or die "Cannot open out.tmp: $!\n";
+ while (<OUT>) { last if /^\.nh/ }
+ my $output;
+ {
+ local $/;
+ $output = <OUT>;
+ }
+ close OUT;
+ unlink ('tmp.pod', 'out.tmp');
+ my $expected = '';
+ while (<DATA>) {
+ last if $_ eq "###\n";
+ $expected .= $_;
+ }
+ if ($output eq $expected) {
+ print "ok $n\n";
+ } else {
+ print "not ok $n\n";
+ print "Expected\n========\n$expected\nOutput\n======\n$output\n";
+ }
+ $n++;
+}
+
+# Below the marker are bits of POD and corresponding expected nroff output.
+# This is used to test specific features or problems with Pod::Man. The input
+# and output are separated by lines containing only ###.
+
+__DATA__
+
+###
+=head1 NAME
+
+gcc - GNU project C and C++ compiler
+
+=head1 C++ NOTES
+
+Other mentions of C++.
+###
+.SH "NAME"
+gcc \- GNU project C and C++ compiler
+.SH "\*(C+ NOTES"
+.IX Header " NOTES"
+Other mentions of \*(C+.
+###
+
+###
+=head1 PERIODS
+
+This C<.> should be quoted.
+###
+.SH "PERIODS"
+.IX Header "PERIODS"
+This \f(CW\*(C`.\*(C'\fR should be quoted.
+###
+
+###
+=over 4
+
+=item *
+
+A bullet.
+
+=item *
+
+Another bullet.
+
+=item * Also a bullet.
+
+=back
+###
+.IP "\(bu" 4
+A bullet.
+.IP "\(bu" 4
+Another bullet.
+.IP "\(bu" 4
+Also a bullet.
+###
+
+###
+=over 4
+
+=item foo
+
+Not a bullet.
+
+=item *
+
+Also not a bullet.
+
+=back
+###
+.IP "foo" 4
+.IX Item "foo"
+Not a bullet.
+.IP "*" 4
+Also not a bullet.
+###
+
+###
+=encoding iso-8859-1
+
+=head1 ACCENTS
+
+Beyonc\xE9! Beyonc\xE9! Beyonc\xE9!!
+
+ Beyonc\xE9! Beyonc\xE9!
+ Beyonc\xE9! Beyonc\xE9!
+ Beyonc\xE9! Beyonc\xE9!
+
+Older versions didn't convert Beyonc\xE9 in verbatim.
+###
+.SH "ACCENTS"
+.IX Header "ACCENTS"
+Beyonce\*'! Beyonce\*'! Beyonce\*'!!
+.PP
+.Vb 3
+\& Beyonce\*'! Beyonce\*'!
+\& Beyonce\*'! Beyonce\*'!
+\& Beyonce\*'! Beyonce\*'!
+.Ve
+.PP
+Older versions didn't convert Beyonce\*' in verbatim.
+###
+
+###
+=over 4
+
+=item 1. Not a number
+
+=item 2. Spaced right
+
+=back
+
+=over 2
+
+=item 1 Not a number
+
+=item 2 Spaced right
+
+=back
+###
+.IP "1. Not a number" 4
+.IX Item "1. Not a number"
+.PD 0
+.IP "2. Spaced right" 4
+.IX Item "2. Spaced right"
+.IP "1 Not a number" 2
+.IX Item "1 Not a number"
+.IP "2 Spaced right" 2
+.IX Item "2 Spaced right"
+###
+
+###
+=over 4
+
+=item Z<>*
+
+Not bullet.
+
+=back
+###
+.IP "*" 4
+Not bullet.
+###
+
+###
+=head1 SEQS
+
+"=over ... Z<>=back"
+
+"SE<lt>...E<gt>"
+
+The quotes should be converted in the above to paired quotes.
+###
+.SH "SEQS"
+.IX Header "SEQS"
+\&\*(L"=over ... =back\*(R"
+.PP
+\&\*(L"S<...>\*(R"
+.PP
+The quotes should be converted in the above to paired quotes.
+###
+
+###
+=head1 YEN
+
+It cost me E<165>12345! That should be an X.
+###
+.SH "YEN"
+.IX Header "YEN"
+It cost me X12345! That should be an X.
+###
+
+###
+=head1 agrave
+
+Open E<agrave> la shell. Previous versions mapped it wrong.
+###
+.SH "agrave"
+.IX Header "agrave"
+Open a\*` la shell. Previous versions mapped it wrong.
+###
+
+###
+=over
+
+=item First level
+
+Blah blah blah....
+
+=over
+
+=item *
+
+Should be a bullet.
+
+=back
+
+=back
+###
+.IP "First level" 4
+.IX Item "First level"
+Blah blah blah....
+.RS 4
+.IP "\(bu" 4
+Should be a bullet.
+.RE
+.RS 4
+.RE
+###
+
+###
+=over 4
+
+=item 1. Check fonts in @CARP_NOT test.
+
+=back
+###
+.ie n .IP "1. Check fonts in @CARP_NOT test." 4
+.el .IP "1. Check fonts in \f(CW at CARP_NOT\fR test." 4
+.IX Item "1. Check fonts in @CARP_NOT test."
+###
+
+###
+=head1 LINK QUOTING
+
+There should not be double quotes: L<C<< (?>pattern) >>>.
+###
+.SH "LINK QUOTING"
+.IX Header "LINK QUOTING"
+There should not be double quotes: \f(CW\*(C`(?>pattern)\*(C'\fR.
+###
+
+###
+=head1 SE<lt>E<gt> MAGIC
+
+Magic should be applied S<RISC OS> to that.
+###
+.SH "S<> MAGIC"
+.IX Header "S<> MAGIC"
+Magic should be applied \s-1RISC\s0\ \s-1OS\s0 to that.
+###
+
+###
+=head1 MAGIC MONEY
+
+These should be identical.
+
+Bippity boppity boo "The
+price is $Z<>100."
+
+Bippity boppity boo "The
+price is $100."
+###
+.SH "MAGIC MONEY"
+.IX Header "MAGIC MONEY"
+These should be identical.
+.PP
+Bippity boppity boo \*(L"The
+price is \f(CW$100\fR.\*(R"
+.PP
+Bippity boppity boo \*(L"The
+price is \f(CW$100\fR.\*(R"
+###
+
+###
+=head1 NAME
+
+"Stuff" (no guesswork)
+
+=head2 THINGS
+
+Oboy, is this C++ "fun" yet! (guesswork)
+###
+.SH "NAME"
+"Stuff" (no guesswork)
+.SS "\s-1THINGS\s0"
+.IX Subsection "THINGS"
+Oboy, is this \*(C+ \*(L"fun\*(R" yet! (guesswork)
+###
+
+###
+=head1 Newline C Quote Weirdness
+
+Blorp C<'
+''>. Yes.
+###
+.SH "Newline C Quote Weirdness"
+.IX Header "Newline C Quote Weirdness"
+Blorp \f(CW\*(Aq
+\&\*(Aq\*(Aq\fR. Yes.
+###
+
+###
+=head1 Soft Hypen Testing
+
+sigE<shy>action
+manuE<shy>script
+JarkE<shy>ko HieE<shy>taE<shy>nieE<shy>mi
+
+And again:
+
+sigE<173>action
+manuE<173>script
+JarkE<173>ko HieE<173>taE<173>nieE<173>mi
+
+And one more time:
+
+sigE<0x00AD>action
+manuE<0x00AD>script
+JarkE<0x00AD>ko HieE<0x00AD>taE<0x00AD>nieE<0x00AD>mi
+###
+.SH "Soft Hypen Testing"
+.IX Header "Soft Hypen Testing"
+sig\%action
+manu\%script
+Jark\%ko Hie\%ta\%nie\%mi
+.PP
+And again:
+.PP
+sig\%action
+manu\%script
+Jark\%ko Hie\%ta\%nie\%mi
+.PP
+And one more time:
+.PP
+sig\%action
+manu\%script
+Jark\%ko Hie\%ta\%nie\%mi
+###
+
+###
+=head1 XE<lt>E<gt> Whitespace
+
+Blorpy L<B<prok>|blap> X<bivav> wugga chachacha.
+###
+.SH "X<> Whitespace"
+.IX Header "X<> Whitespace"
+Blorpy \fBprok\fR wugga chachacha.
+.IX Xref "bivav"
+###
+
+###
+=head1 Hyphen in SE<lt>E<gt>
+
+Don't S<transform even-this hyphen>. This "one's-fine!", as well. However,
+$-0.13 should have a real hyphen.
+###
+.SH "Hyphen in S<>"
+.IX Header "Hyphen in S<>"
+Don't transform\ even-this\ hyphen. This \*(L"one's-fine!\*(R", as well. However,
+$\-0.13 should have a real hyphen.
+###
+
+###
+=head1 Quote escaping
+
+Don't escape `this' but do escape C<`this'> (and don't surround it in quotes).
+###
+.SH "Quote escaping"
+.IX Header "Quote escaping"
+Don't escape `this' but do escape \f(CW\`this\*(Aq\fR (and don't surround it in quotes).
+###
+
+###
+=pod
+
+E<eth>
+###
+.PP
+\&\*(d-
+###
+
+###
+=head1 C<one> and C<two>
+###
+.ie n .SH """one"" and ""two"""
+.el .SH "\f(CWone\fP and \f(CWtwo\fP"
+.IX Header "one and two"
+###
+
+###
+=pod
+
+Some text.
+
+=for man
+Some raw nroff.
+
+=for roff \fBBold text.\fP
+
+=for html
+Stuff that's hidden.
+
+=for MAN \fIItalic text.\fP
+
+=for ROFF
+.PP
+\&A paragraph.
+
+More text.
+###
+Some text.
+Some raw nroff.
+\fBBold text.\fP
+\fIItalic text.\fP
+.PP
+\&A paragraph.
+.PP
+More text.
+###
Copied: trunk/contrib/perl/lib/Pod/t/parselink.t (from rev 6437, vendor/perl/5.18.1/lib/Pod/t/parselink.t)
===================================================================
--- trunk/contrib/perl/lib/Pod/t/parselink.t (rev 0)
+++ trunk/contrib/perl/lib/Pod/t/parselink.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,132 @@
+#!/usr/bin/perl -w
+#
+# parselink.t -- Tests for Pod::ParseLink.
+#
+# Copyright 2001 by Russ Allbery <rra at stanford.edu>
+#
+# This program is free software; you may redistribute it and/or modify it
+# under the same terms as Perl itself.
+
+# The format of each entry in this array is the L<> text followed by the
+# five-element parse returned by parselink. When adding a new test, also
+# increment the test count in the BEGIN block below. We don't use any of the
+# fancy test modules intentionally for backward compatibility to older
+# versions of Perl.
+ at TESTS = (
+ [ 'foo',
+ undef, 'foo', 'foo', undef, 'pod' ],
+
+ [ 'foo|bar',
+ 'foo', 'foo', 'bar', undef, 'pod' ],
+
+ [ 'foo/bar',
+ undef, '"bar" in foo', 'foo', 'bar', 'pod' ],
+
+ [ 'foo/"baz boo"',
+ undef, '"baz boo" in foo', 'foo', 'baz boo', 'pod' ],
+
+ [ '/bar',
+ undef, '"bar"', undef, 'bar', 'pod' ],
+
+ [ '/"baz boo"',
+ undef, '"baz boo"', undef, 'baz boo', 'pod' ],
+
+ [ '/baz boo',
+ undef, '"baz boo"', undef, 'baz boo', 'pod' ],
+
+ [ 'foo bar/baz boo',
+ undef, '"baz boo" in foo bar', 'foo bar', 'baz boo', 'pod' ],
+
+ [ 'foo bar / baz boo',
+ undef, '"baz boo" in foo bar', 'foo bar', 'baz boo', 'pod' ],
+
+ [ "foo\nbar\nbaz\n/\nboo",
+ undef, '"boo" in foo bar baz', 'foo bar baz', 'boo', 'pod' ],
+
+ [ 'anchor|name/section',
+ 'anchor', 'anchor', 'name', 'section', 'pod' ],
+
+ [ '"boo var baz"',
+ undef, '"boo var baz"', undef, 'boo var baz', 'pod' ],
+
+ [ 'bar baz',
+ undef, '"bar baz"', undef, 'bar baz', 'pod' ],
+
+ [ '"boo bar baz / baz boo"',
+ undef, '"boo bar baz / baz boo"', undef, 'boo bar baz / baz boo',
+ 'pod' ],
+
+ [ 'fooZ<>bar',
+ undef, 'fooZ<>bar', 'fooZ<>bar', undef, 'pod' ],
+
+ [ 'Testing I<italics>|foo/bar',
+ 'Testing I<italics>', 'Testing I<italics>', 'foo', 'bar', 'pod' ],
+
+ [ 'foo/I<Italic> text',
+ undef, '"I<Italic> text" in foo', 'foo', 'I<Italic> text', 'pod' ],
+
+ [ 'fooE<verbar>barZ<>/Section C<with> I<B<other> markup',
+ undef, '"Section C<with> I<B<other> markup" in fooE<verbar>barZ<>',
+ 'fooE<verbar>barZ<>', 'Section C<with> I<B<other> markup', 'pod' ],
+
+ [ 'Nested L<http://www.perl.org/>|fooE<sol>bar',
+ 'Nested L<http://www.perl.org/>', 'Nested L<http://www.perl.org/>',
+ 'fooE<sol>bar', undef, 'pod' ],
+
+ [ 'ls(1)',
+ undef, 'ls(1)', 'ls(1)', undef, 'man' ],
+
+ [ ' perlfunc(1)/open ',
+ undef, '"open" in perlfunc(1)', 'perlfunc(1)', 'open', 'man' ],
+
+ [ 'some manual page|perl(1)',
+ 'some manual page', 'some manual page', 'perl(1)', undef, 'man' ],
+
+ [ 'http://www.perl.org/',
+ undef, 'http://www.perl.org/', 'http://www.perl.org/', undef, 'url' ],
+
+ [ 'news:yld72axzc8.fsf at windlord.stanford.edu',
+ undef, 'news:yld72axzc8.fsf at windlord.stanford.edu',
+ 'news:yld72axzc8.fsf at windlord.stanford.edu', undef, 'url' ]
+);
+
+BEGIN {
+ chdir 't' if -d 't';
+ unshift (@INC, '../blib/lib');
+ $| = 1;
+ print "1..25\n";
+}
+
+END {
+ print "not ok 1\n" unless $loaded;
+}
+
+use Pod::ParseLink;
+$loaded = 1;
+print "ok 1\n";
+
+# Used for reporting test failures.
+my @names = qw(text inferred name section type);
+
+my $n = 2;
+for (@TESTS) {
+ my @expected = @$_;
+ my $link = shift @expected;
+ my @results = parselink ($link);
+ my $okay = 1;
+ for (0..4) {
+ # Make sure to check undef explicitly; we don't want undef to match
+ # the empty string because they're semantically different.
+ unless ((!defined ($results[$_]) && !defined ($expected[$_]))
+ || (defined ($results[$_]) && defined ($expected[$_])
+ && $results[$_] eq $expected[$_])) {
+ print "not ok $n\n" if $okay;
+ print "# Incorrect $names[$_]:\n";
+ print "# expected: $expected[$_]\n";
+ print "# seen: $results[$_]\n";
+ $okay = 0;
+ }
+ }
+ print "ok $n\n" if $okay;
+ $n++;
+}
Copied: trunk/contrib/perl/lib/Pod/t/pod-parser.t (from rev 6437, vendor/perl/5.18.1/lib/Pod/t/pod-parser.t)
===================================================================
--- trunk/contrib/perl/lib/Pod/t/pod-parser.t (rev 0)
+++ trunk/contrib/perl/lib/Pod/t/pod-parser.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,102 @@
+#!/usr/bin/perl -w
+#
+# pod-parser.t -- Tests for backward compatibility with Pod::Parser.
+#
+# Copyright 2006, 2008 by Russ Allbery <rra at stanford.edu>
+#
+# This program is free software; you may redistribute it and/or modify it
+# under the same terms as Perl itself.
+
+BEGIN {
+ chdir 't' if -d 't';
+ if ($ENV{PERL_CORE}) {
+ @INC = '../lib';
+ } else {
+ unshift (@INC, '../blib/lib');
+ }
+ unshift (@INC, '../blib/lib');
+ $| = 1;
+ print "1..4\n";
+}
+
+my $loaded;
+
+END {
+ print "not ok 1\n" unless $loaded;
+}
+
+use Pod::Man;
+use Pod::Text;
+use strict;
+
+$loaded = 1;
+print "ok 1\n";
+
+my $parser = Pod::Man->new or die "Cannot create parser\n";
+open (TMP, '> tmp.pod') or die "Cannot create tmp.pod: $!\n";
+print TMP "Some random B<text>.\n";
+close TMP;
+open (OUT, '> out.tmp') or die "Cannot create out.tmp: $!\n";
+$parser->parse_from_file ({ -cutting => 0 }, 'tmp.pod', \*OUT);
+close OUT;
+open (OUT, 'out.tmp') or die "Cannot open out.tmp: $!\n";
+while (<OUT>) { last if /^\.nh/ }
+my $output;
+{
+ local $/;
+ $output = <OUT>;
+}
+close OUT;
+if ($output eq "Some random \\fBtext\\fR.\n") {
+ print "ok 2\n";
+} else {
+ print "not ok 2\n";
+ print "Expected\n========\nSome random \\fBtext\\fR.\n\n";
+ print "Output\n======\n$output\n";
+}
+
+$parser = Pod::Text->new or die "Cannot create parser\n";
+open (OUT, '> out.tmp') or die "Cannot create out.tmp: $!\n";
+$parser->parse_from_file ({ -cutting => 0 }, 'tmp.pod', \*OUT);
+close OUT;
+open (OUT, 'out.tmp') or die "Cannot open out.tmp: $!\n";
+{
+ local $/;
+ $output = <OUT>;
+}
+close OUT;
+if ($output eq " Some random text.\n\n") {
+ print "ok 3\n";
+} else {
+ print "not ok 3\n";
+ print "Expected\n========\n Some random text.\n\n\n";
+ print "Output\n======\n$output\n";
+}
+
+# Test the pod2text function, particularly with only one argument.
+open (TMP, '> tmp.pod') or die "Cannot create tmp.pod: $!\n";
+print TMP "=pod\n\nSome random B<text>.\n";
+close TMP;
+open (OUT, '> out.tmp') or die "Cannot create out.tmp: $!\n";
+open (SAVE, '>&STDOUT') or die "Cannot dup stdout: $!\n";
+open (STDOUT, '>&OUT') or die "Cannot replace stdout: $!\n";
+pod2text ('tmp.pod');
+close OUT;
+open (STDOUT, '>&SAVE') or die "Cannot fix stdout: $!\n";
+close SAVE;
+open (OUT, 'out.tmp') or die "Cannot open out.tmp: $!\n";
+{
+ local $/;
+ $output = <OUT>;
+}
+close OUT;
+if ($output eq " Some random text.\n\n") {
+ print "ok 4\n";
+} else {
+ print "not ok 4\n";
+ print "Expected\n========\n Some random text.\n\n\n";
+ print "Output\n======\n$output\n";
+}
+
+unlink ('tmp.pod', 'out.tmp');
+exit 0;
Copied: trunk/contrib/perl/lib/Pod/t/pod-spelling.t (from rev 6437, vendor/perl/5.18.1/lib/Pod/t/pod-spelling.t)
===================================================================
--- trunk/contrib/perl/lib/Pod/t/pod-spelling.t (rev 0)
+++ trunk/contrib/perl/lib/Pod/t/pod-spelling.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,76 @@
+#!/usr/bin/perl
+#
+# t/pod-spelling.t -- Test POD spelling.
+#
+# Copyright 2008 Russ Allbery <rra at stanford.edu>
+#
+# This program is free software; you may redistribute it and/or modify it
+# under the same terms as Perl itself.
+
+# Called to skip all tests with a reason.
+sub skip_all {
+ print "1..0 # Skipped: @_\n";
+ exit;
+}
+
+# Skip all spelling tests unless flagged to run maintainer tests.
+skip_all "Spelling tests only run for maintainer"
+ unless $ENV{RRA_MAINTAINER_TESTS};
+
+# Make sure we have prerequisites. hunspell is currently not supported due to
+# lack of support for contractions.
+eval 'use Test::Pod 1.00';
+skip_all "Test::Pod 1.00 required for testing POD" if $@;
+eval 'use Pod::Spell';
+skip_all "Pod::Spell required to test POD spelling" if $@;
+my @spell;
+my %options = (aspell => [ qw(-d en_US --home-dir=./ list) ],
+ ispell => [ qw(-d american -l -p /dev/null) ]);
+SEARCH: for my $program (qw/aspell ispell/) {
+ for my $dir (split ':', $ENV{PATH}) {
+ if (-x "$dir/$program") {
+ @spell = ("$dir/$program", @{ $options{$program} });
+ }
+ last SEARCH if @spell;
+ }
+}
+skip_all "aspell or ispell required to test POD spelling" unless @spell;
+
+# Run the test, one for each POD file.
+$| = 1;
+my @pod = all_pod_files ();
+my $count = scalar @pod;
+print "1..$count\n";
+my $n = 1;
+for my $pod (@pod) {
+ my $child = open (CHILD, '-|');
+ if (not defined $child) {
+ die "Cannot fork: $!\n";
+ } elsif ($child == 0) {
+ my $pid = open (SPELL, '|-', @spell)
+ or die "Cannot run @spell: $!\n";
+ open (POD, '<', $pod) or die "Cannot open $pod: $!\n";
+ my $parser = Pod::Spell->new;
+ $parser->parse_from_filehandle (\*POD, \*SPELL);
+ close POD;
+ close SPELL;
+ exit ($? >> 8);
+ } else {
+ my @words = <CHILD>;
+ close CHILD;
+ if ($? != 0) {
+ print "ok $n # skip - @spell failed: $?\n";
+ } elsif (@words) {
+ for (@words) {
+ s/^\s+//;
+ s/\s+$//;
+ }
+ print "not ok $n\n";
+ print " - Misspelled words found in $pod\n";
+ print " @words\n";
+ } else {
+ print "ok $n\n";
+ }
+ $n++;
+ }
+}
Copied: trunk/contrib/perl/lib/Pod/t/pod.t (from rev 6437, vendor/perl/5.18.1/lib/Pod/t/pod.t)
===================================================================
--- trunk/contrib/perl/lib/Pod/t/pod.t (rev 0)
+++ trunk/contrib/perl/lib/Pod/t/pod.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,11 @@
+#!/usr/bin/perl
+#
+# t/pod.t -- Test POD formatting.
+
+eval 'use Test::Pod 1.00';
+if ($@) {
+ print "1..1\n";
+ print "ok 1 # skip - Test::Pod 1.00 required for testing POD\n";
+ exit;
+}
+all_pod_files_ok ();
Copied: trunk/contrib/perl/lib/Pod/t/pod2html-lib.pl (from rev 6437, vendor/perl/5.18.1/lib/Pod/t/pod2html-lib.pl)
===================================================================
--- trunk/contrib/perl/lib/Pod/t/pod2html-lib.pl (rev 0)
+++ trunk/contrib/perl/lib/Pod/t/pod2html-lib.pl 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,62 @@
+require Cwd;
+require Pod::Html;
+require Config;
+use File::Spec::Functions;
+
+sub convert_n_test {
+ my($podfile, $testname) = @_;
+
+ my $cwd = Cwd::cwd();
+ my $base_dir = catdir $cwd, updir(), "lib", "Pod";
+ my $new_dir = catdir $base_dir, "t";
+ my $infile = catfile $new_dir, "$podfile.pod";
+ my $outfile = catfile $new_dir, "$podfile.html";
+
+ Pod::Html::pod2html(
+ "--podpath=t",
+ "--podroot=$base_dir",
+ "--htmlroot=/",
+ "--infile=$infile",
+ "--outfile=$outfile"
+ );
+
+
+ my ($expect, $result);
+ {
+ local $/;
+ # expected
+ $expect = <DATA>;
+ $expect =~ s/\[PERLADMIN\]/$Config::Config{perladmin}/;
+ if (ord("A") == 193) { # EBCDIC.
+ $expect =~ s/item_mat_3c_21_3e/item_mat_4c_5a_6e/;
+ }
+
+ # result
+ open my $in, $outfile or die "cannot open $outfile: $!";
+ $result = <$in>;
+ close $in;
+ }
+
+ ok($expect eq $result, $testname) or do {
+ my $diff = '/bin/diff';
+ -x $diff or $diff = '/usr/bin/diff';
+ if (-x $diff) {
+ my $expectfile = "pod2html-lib.tmp";
+ open my $tmpfile, ">", $expectfile or die $!;
+ print $tmpfile $expect;
+ close $tmpfile;
+ my $diffopt = $^O eq 'linux' ? 'u' : 'c';
+ open my $diff, "diff -$diffopt $expectfile $outfile |" or die $!;
+ print "# $_" while <$diff>;
+ close $diff;
+ unlink $expectfile;
+ }
+ };
+
+ # pod2html creates these
+ 1 while unlink $outfile;
+ 1 while unlink "pod2htmd.tmp";
+ 1 while unlink "pod2htmi.tmp";
+}
+
+1;
Copied: trunk/contrib/perl/lib/Pod/t/pod2latex.t (from rev 6437, vendor/perl/5.18.1/lib/Pod/t/pod2latex.t)
===================================================================
--- trunk/contrib/perl/lib/Pod/t/pod2latex.t (rev 0)
+++ trunk/contrib/perl/lib/Pod/t/pod2latex.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,401 @@
+#!perl
+# Test that Pod::LaTeX works
+# This test relies on the DATA filehandle
+# DATA contains the latex that is used for comparison
+# and the pod that was used to generate it. The two
+# are separated by '=pod'
+# Note that if the translator is adjusted the output tex
+# will probably not match what is currently there. You
+# will need to adjust it to match (assuming it is correct).
+
+use Test;
+use strict;
+
+BEGIN { plan tests => 177 }
+
+use Pod::LaTeX;
+
+# The link parsing changed between v0.22 and v0.30 of Pod::ParseUtils
+use Pod::ParseUtils;
+my $linkver = $Pod::ParseUtils::VERSION;
+
+# Set up an END block to remove the test output file
+END {
+ unlink "test.tex";
+};
+
+ok(1);
+
+# First thing to do is to read the expected output from
+# the DATA filehandle and store it in a scalar.
+# Do this until we read an =pod
+my @reference;
+while (my $line = <DATA>) {
+ last if $line =~ /^=pod/;
+ push(@reference,$line);
+}
+
+# Create a new parser
+my $parser = Pod::LaTeX->new;
+ok($parser);
+$parser->Head1Level(1);
+# Add the preamble but remember not to compare the timestamps
+$parser->AddPreamble(1);
+$parser->AddPostamble(1);
+
+# For a laugh add a table of contents
+$parser->TableOfContents(1);
+
+# Create an output file
+open(OUTFH, "> test.tex" ) or die "Unable to open test tex file: $!\n";
+
+# Read from the DATA filehandle and write to a new output file
+# Really want to write this to a scalar
+$parser->parse_from_filehandle(\*DATA,\*OUTFH);
+
+close(OUTFH) or die "Error closing OUTFH test.tex: $!\n";
+
+# Now read in OUTFH and compare
+open(INFH, "< test.tex") or die "Unable to read test tex file: $!\n";
+my @output = <INFH>;
+
+ok(@output, @reference);
+for my $i (0..$#reference) {
+ next if $reference[$i] =~ /^%%/; # skip timestamp comments
+
+ # if we are running a new version of Pod::ParseUtils we need
+ # to change the link text. This is a kluge until we drop support
+ # for older versions of Pod::ParseUtils
+ if ($linkver < 0.29 && $output[$i] =~ /manpage/) {
+ # convert our expectations from new to old new format
+ $reference[$i] =~ s/Standard link: \\emph\{Pod::LaTeX\}/Standard link: the \\emph\{Pod::LaTeX\} manpage/;
+ $reference[$i] =~ s/\\textsf\{sec\} in \\emph\{Pod::LaTeX\}/the section on \\textsf\{sec\} in the \\emph\{Pod::LaTeX\} manpage/;
+ }
+ ok($output[$i], $reference[$i]);
+}
+
+close(INFH) or die "Error closing INFH test.tex: $!\n";
+
+
+__DATA__
+\documentclass{article}
+\usepackage[T1]{fontenc}
+\usepackage{textcomp}
+
+%% Latex generated from POD in document (unknown)
+%% Using the perl module Pod::LaTeX
+%% Converted on Sat Apr 5 21:16:02 2003
+
+
+\usepackage{makeidx}
+\makeindex
+
+
+\begin{document}
+
+\tableofcontents
+
+\section{Introduction\label{Introduction}\index{Introduction}}
+\begin{itemize}
+
+\item
+
+Always check the return codes of system calls. Good error messages should
+go to STDERR, include which program caused the problem, what the failed
+system call and arguments were, and (\textbf{very important}) should contain
+the standard system error message for what went wrong. Here's a simple
+but sufficient example:
+
+\begin{verbatim}
+ opendir(D, $dir) or die "can't opendir $dir: $!";
+\end{verbatim}
+
+\item
+
+Line up your transliterations when it makes sense:
+
+\begin{verbatim}
+ tr [abc]
+ [xyz];
+\end{verbatim}
+
+
+The above should be aligned since it includes an embedded tab.
+
+
+\item
+
+Think about reusability. Why waste brainpower on a one-shot when you
+might want to do something like it again? Consider generalizing your
+code. Consider writing a module or object class. Consider making your
+code run cleanly with \texttt{use strict} and \texttt{-w} (or \texttt{use warnings} in
+Perl 5.6) in effect. Consider giving away your code. Consider changing
+your whole world view. Consider... oh, never mind.
+
+
+\item
+
+Be consistent.
+
+
+\item
+
+Be nice.
+
+\end{itemize}
+\section{Links\label{Links}\index{Links}}
+
+
+This link should just include one word: \textsf{Pod::LaTeX}
+
+
+
+This link should include the text \texttt{test} even though
+it refers to \texttt{Pod::LaTeX}: \textsf{test}.
+
+
+
+Standard link: \emph{Pod::LaTeX}.
+
+
+
+Now refer to an external section: \textsf{sec} in \emph{Pod::LaTeX}
+
+\section{Lists\label{Lists}\index{Lists}}
+
+
+Test description list with long lines
+
+\begin{description}
+
+\item[{Some short text}] \mbox{}
+
+Some additional para.
+
+\begin{itemize}
+
+\item
+
+Nested itemized list
+
+
+\item
+
+Second item
+
+\end{itemize}
+
+\item[{some longer text than that}] \mbox{}
+
+and again.
+
+
+\item[{this text is even longer and greater than}] \textbf{40 characters}
+
+Some more content for the item.
+
+
+\item[{this is some text with \textit{something across}}] \textbf{the 40 char boundary}
+
+This is item content.
+
+
+\item[{square [ bracket in item}] \mbox{}
+
+Square bracket content
+
+\end{description}
+
+
+And this should be an enumerated list without any cruft after the numbers or additional numbers at all.
+
+\begin{enumerate}
+
+\item
+
+item 1
+
+
+\item
+
+item 2
+
+\end{enumerate}
+\section{Escapes\label{Escapes}\index{Escapes}}
+
+
+Test some normal escapes such as $<$ (lt) and $>$ (gt) and $|$ (verbar) and
+\texttt{\~{}} (tilde) and \& (amp) as well as $<$ (Esc lt) and $|$ (Esc
+verbar) and \textfractionsolidus{} (Esc sol) and $>$ (Esc gt) and \& (Esc amp)
+and " (Esc quot) and even $\alpha$ (Esc alpha).
+
+\section{For blocks\label{For_blocks}\index{For blocks}}
+ Some latex code \textbf{here}.
+
+
+
+Some text that should appear.
+
+
+
+Some more text that should appear
+
+Some latex in a \textsf{begin block}
+
+and some more
+
+\begin{equation}
+a = \frac{3}{2}
+\end{equation}
+
+
+
+Back to pod.
+
+\printindex
+
+\end{document}
+=pod
+
+=head1 Introduction
+
+=over 4
+
+=item *
+
+Always check the return codes of system calls. Good error messages should
+go to STDERR, include which program caused the problem, what the failed
+system call and arguments were, and (B<very important>) should contain
+the standard system error message for what went wrong. Here's a simple
+but sufficient example:
+
+ opendir(D, $dir) or die "can't opendir $dir: $!";
+
+=item *
+
+Line up your transliterations when it makes sense:
+
+ tr [abc]
+ [xyz];
+
+The above should be aligned since it includes an embedded tab.
+
+=item *
+
+Think about reusability. Why waste brainpower on a one-shot when you
+might want to do something like it again? Consider generalizing your
+code. Consider writing a module or object class. Consider making your
+code run cleanly with C<use strict> and C<-w> (or C<use warnings> in
+Perl 5.6) in effect. Consider giving away your code. Consider changing
+your whole world view. Consider... oh, never mind.
+
+=item *
+
+Be consistent.
+
+=item *
+
+Be nice.
+
+=back
+
+=head1 Links
+
+This link should just include one word: L<Pod::LaTeX|Pod::LaTeX>
+
+This link should include the text C<test> even though
+it refers to C<Pod::LaTeX>: L<test|Pod::LaTeX>.
+
+Standard link: L<Pod::LaTeX>.
+
+Now refer to an external section: L<Pod::LaTeX/"sec">
+
+
+=head1 Lists
+
+Test description list with long lines
+
+=over 4
+
+=item Some short text
+
+Some additional para.
+
+=over 4
+
+=item *
+
+Nested itemized list
+
+=item *
+
+Second item
+
+=back
+
+=item some longer text than that
+
+and again.
+
+=item this text is even longer and greater than 40 characters
+
+Some more content for the item.
+
+=item this is some text with I<something across> the 40 char boundary
+
+This is item content.
+
+=item square [ bracket in item
+
+Square bracket content
+
+=back
+
+And this should be an enumerated list without any cruft after the numbers or additional numbers at all.
+
+=over 4
+
+=item 1)
+
+item 1
+
+=item 2.
+
+item 2
+
+=back
+
+=head1 Escapes
+
+Test some normal escapes such as < (lt) and > (gt) and | (verbar) and
+~ (tilde) and & (amp) as well as E<lt> (Esc lt) and E<verbar> (Esc
+verbar) and E<sol> (Esc sol) and E<gt> (Esc gt) and E<amp> (Esc amp)
+and E<quot> (Esc quot) and even E<alpha> (Esc alpha).
+
+=head1 For blocks
+
+=for latex
+ Some latex code \textbf{here}.
+
+Some text that should appear.
+
+=for comment
+ Should not print anything
+
+Some more text that should appear
+
+=begin latex
+
+Some latex in a \textsf{begin block}
+
+and some more
+
+\begin{equation}
+a = \frac{3}{2}
+\end{equation}
+
+=end latex
+
+Back to pod.
+
+=cut
Copied: trunk/contrib/perl/lib/Pod/t/termcap.t (from rev 6437, vendor/perl/5.18.1/lib/Pod/t/termcap.t)
===================================================================
--- trunk/contrib/perl/lib/Pod/t/termcap.t (rev 0)
+++ trunk/contrib/perl/lib/Pod/t/termcap.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,85 @@
+#!/usr/bin/perl -w
+#
+# termcap.t -- Additional specialized tests for Pod::Text::Termcap.
+#
+# Copyright 2002, 2004, 2006 by Russ Allbery <rra at stanford.edu>
+#
+# This program is free software; you may redistribute it and/or modify it
+# under the same terms as Perl itself.
+
+BEGIN {
+ chdir 't' if -d 't';
+ if ($ENV{PERL_CORE}) {
+ @INC = '../lib';
+ } else {
+ unshift (@INC, '../blib/lib');
+ }
+ unshift (@INC, '../blib/lib');
+ $| = 1;
+ print "1..2\n";
+}
+
+END {
+ print "not ok 1\n" unless $loaded;
+}
+
+# Hard-code a few values to try to get reproducible results.
+$ENV{COLUMNS} = 80;
+$ENV{TERM} = 'xterm';
+$ENV{TERMCAP} = 'xterm:co=80:do=^J:md=\E[1m:us=\E[4m:me=\E[m';
+
+use Pod::Text::Termcap;
+
+$loaded = 1;
+print "ok 1\n";
+
+my $parser = Pod::Text::Termcap->new or die "Cannot create parser\n";
+my $n = 2;
+while (<DATA>) {
+ next until $_ eq "###\n";
+ open (TMP, '> tmp.pod') or die "Cannot create tmp.pod: $!\n";
+ while (<DATA>) {
+ last if $_ eq "###\n";
+ print TMP $_;
+ }
+ close TMP;
+ open (OUT, '> out.tmp') or die "Cannot create out.tmp: $!\n";
+ $parser->parse_from_file ('tmp.pod', \*OUT);
+ close OUT;
+ open (TMP, 'out.tmp') or die "Cannot open out.tmp: $!\n";
+ my $output;
+ {
+ local $/;
+ $output = <TMP>;
+ }
+ close TMP;
+ unlink ('tmp.pod', 'out.tmp');
+ my $expected = '';
+ while (<DATA>) {
+ last if $_ eq "###\n";
+ $expected .= $_;
+ }
+ if ($output eq $expected) {
+ print "ok $n\n";
+ } else {
+ print "not ok $n\n";
+ print "Expected\n========\n$expected\nOutput\n======\n$output\n";
+ }
+ $n++;
+}
+
+# Below the marker are bits of POD and corresponding expected output. This is
+# used to test specific features or problems with Pod::Text::Termcap. The
+# input and output are separated by lines containing only ###.
+
+__DATA__
+
+###
+=head1 WRAPPING
+
+B<I<Do>> I<B<not>> B<I<include>> B<I<formatting codes when>> B<I<wrapping>>.
+###
+[1mWRAPPING[m
+ [1m[4mDo[m[m [4m[1mnot[m[m [1m[4minclude[m[m [1m[4mformatting codes when[m[m [1m[4mwrapping[m[m.
+
+###
Copied: trunk/contrib/perl/lib/Pod/t/text-encoding.t (from rev 6437, vendor/perl/5.18.1/lib/Pod/t/text-encoding.t)
===================================================================
--- trunk/contrib/perl/lib/Pod/t/text-encoding.t (rev 0)
+++ trunk/contrib/perl/lib/Pod/t/text-encoding.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,142 @@
+#!/usr/bin/perl -w
+#
+# text-encoding.t -- Test Pod::Text with various weird encoding combinations.
+#
+# Copyright 2002, 2004, 2006, 2007, 2008 by Russ Allbery <rra at stanford.edu>
+#
+# This program is free software; you may redistribute it and/or modify it
+# under the same terms as Perl itself.
+
+BEGIN {
+ chdir 't' if -d 't';
+ if ($ENV{PERL_CORE}) {
+ @INC = '../lib';
+ } else {
+ unshift (@INC, '../blib/lib');
+ }
+ unshift (@INC, '../blib/lib');
+ $| = 1;
+ print "1..4\n";
+
+ # PerlIO encoding support requires Perl 5.8 or later.
+ if ($] < 5.008) {
+ my $n;
+ for $n (1..4) {
+ print "ok $n # skip -- Perl 5.8 required for UTF-8 support\n";
+ }
+ exit;
+ }
+}
+
+END {
+ print "not ok 1\n" unless $loaded;
+}
+
+use Pod::Text;
+
+$loaded = 1;
+print "ok 1\n";
+
+my $n = 2;
+eval { binmode (\*DATA, ':raw') };
+eval { binmode (\*STDOUT, ':raw') };
+while (<DATA>) {
+ my %opts;
+ $opts{utf8} = 1 if $n == 4;
+ my $parser = Pod::Text->new (%opts) or die "Cannot create parser\n";
+ next until $_ eq "###\n";
+ open (TMP, '> tmp.pod') or die "Cannot create tmp.pod: $!\n";
+ eval { binmode (\*TMP, ':raw') };
+ while (<DATA>) {
+ last if $_ eq "###\n";
+ print TMP $_;
+ }
+ close TMP;
+ open (OUT, '> out.tmp') or die "Cannot create out.tmp: $!\n";
+ eval { binmode (\*OUT, ':raw') };
+ $parser->parse_from_file ('tmp.pod', \*OUT);
+ close OUT;
+ open (TMP, 'out.tmp') or die "Cannot open out.tmp: $!\n";
+ eval { binmode (\*TMP, ':raw') };
+ my $output;
+ {
+ local $/;
+ $output = <TMP>;
+ }
+ close TMP;
+ unlink ('tmp.pod', 'out.tmp');
+ my $expected = '';
+ while (<DATA>) {
+ last if $_ eq "###\n";
+ $expected .= $_;
+ }
+ if ($output eq $expected) {
+ print "ok $n\n";
+ } else {
+ print "not ok $n\n";
+ print "Expected\n========\n$expected\nOutput\n======\n$output\n";
+ }
+ $n++;
+}
+
+# Below the marker are bits of POD and corresponding expected text output.
+# This is used to test specific features or problems with Pod::Text. The
+# input and output are separated by lines containing only ###.
+
+__DATA__
+
+###
+=head1 Test of SE<lt>E<gt>
+
+This is S<some whitespace>.
+###
+Test of S<>
+ This is some whitespace.
+
+###
+
+###
+=encoding utf-8
+
+=head1 I can eat glass
+
+=over 4
+
+=item Esperanto
+
+Mi povas manÄi vitron, Äi ne damaÄas min.
+
+=item Braille
+
+⠊⠀⠉â â ⠀⠑â ⠞⠀⠛⠇â â Žâ Žâ €â â ⠙⠀⠊⠞⠀⠙⠕⠑⠎â ⠞⠀⠓⠥⠗⠞⠀â â ‘
+
+=item Hindi
+
+मैं काà¤à¤š खा सकता हूठऔर मà¥à¤à¥‡ उससे कोई चोट नहीं पहà¥à¤‚चती.
+
+=back
+
+See L<http://www.columbia.edu/kermit/utf8.html>
+###
+I can eat glass
+ Esperanto
+ Mi povas manÄi vitron, Äi ne damaÄas min.
+
+ Braille
+ ⠊⠀⠉â â ⠀⠑â ⠞⠀⠛⠇â â Žâ Žâ €â â ⠙⠀⠊⠞â
+ €â ™â •â ‘â Žâ ⠞⠀⠓⠥⠗⠞⠀â â ‘
+
+ Hindi
+ मैं काà¤à¤š खा सकता हूठऔर
+ मà¥à¤à¥‡ उससे कोई चोट नहीं
+ पहà¥à¤‚चती.
+
+ See <http://www.columbia.edu/kermit/utf8.html>
+
+###
+
+###
+=head1 Beyoncé
+###
+Beyoncé
+###
Copied: trunk/contrib/perl/lib/Pod/t/text-options.t (from rev 6437, vendor/perl/5.18.1/lib/Pod/t/text-options.t)
===================================================================
--- trunk/contrib/perl/lib/Pod/t/text-options.t (rev 0)
+++ trunk/contrib/perl/lib/Pod/t/text-options.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,271 @@
+#!/usr/bin/perl -w
+#
+# text-options.t -- Additional tests for Pod::Text options.
+#
+# Copyright 2002, 2004, 2006, 2008 by Russ Allbery <rra at stanford.edu>
+#
+# This program is free software; you may redistribute it and/or modify it
+# under the same terms as Perl itself.
+
+BEGIN {
+ chdir 't' if -d 't';
+ if ($ENV{PERL_CORE}) {
+ @INC = '../lib';
+ } else {
+ unshift (@INC, '../blib/lib');
+ }
+ unshift (@INC, '../blib/lib');
+ $| = 1;
+ print "1..13\n";
+}
+
+END {
+ print "not ok 1\n" unless $loaded;
+}
+
+use Pod::Text;
+
+# Redirect stderr to a file.
+sub stderr_save {
+ open (OLDERR, '>&STDERR') or die "Can't dup STDERR: $!\n";
+ open (STDERR, '> out.err') or die "Can't redirect STDERR: $!\n";
+}
+
+# Restore stderr.
+sub stderr_restore {
+ close STDERR;
+ open (STDERR, '>&OLDERR') or die "Can't dup STDERR: $!\n";
+ close OLDERR;
+}
+
+$loaded = 1;
+print "ok 1\n";
+
+my $n = 2;
+while (<DATA>) {
+ my %options;
+ next until $_ eq "###\n";
+ while (<DATA>) {
+ last if $_ eq "###\n";
+ my ($option, $value) = split;
+ $options{$option} = $value;
+ }
+ open (TMP, '> tmp.pod') or die "Cannot create tmp.pod: $!\n";
+ while (<DATA>) {
+ last if $_ eq "###\n";
+ print TMP $_;
+ }
+ close TMP;
+ my $parser = Pod::Text->new (%options) or die "Cannot create parser\n";
+ open (OUT, '> out.tmp') or die "Cannot create out.tmp: $!\n";
+ stderr_save;
+ $parser->parse_from_file ('tmp.pod', \*OUT);
+ stderr_restore;
+ close OUT;
+ open (TMP, 'out.tmp') or die "Cannot open out.tmp: $!\n";
+ my $output;
+ {
+ local $/;
+ $output = <TMP>;
+ }
+ close TMP;
+ 1 while unlink ('tmp.pod', 'out.tmp');
+ my $expected = '';
+ while (<DATA>) {
+ last if $_ eq "###\n";
+ $expected .= $_;
+ }
+ if ($output eq $expected) {
+ print "ok $n\n";
+ } else {
+ print "not ok $n\n";
+ print "Expected\n========\n$expected\nOutput\n======\n$output\n";
+ }
+ $n++;
+ open (ERR, 'out.err') or die "Cannot open out.err: $!\n";
+ my $errors;
+ {
+ local $/;
+ $errors = <ERR>;
+ }
+ close ERR;
+ unlink ('out.err');
+ $expected = '';
+ while (<DATA>) {
+ last if $_ eq "###\n";
+ $expected .= $_;
+ }
+ if ($errors eq $expected) {
+ print "ok $n\n";
+ } else {
+ print "not ok $n\n";
+ print "Expected errors:\n ${expected}Errors:\n $errors";
+ }
+ $n++;
+}
+
+# Below the marker are bits of POD and corresponding expected text output.
+# This is used to test specific features or problems with Pod::Text. The
+# input and output are separated by lines containing only ###.
+
+__DATA__
+
+###
+alt 1
+###
+=head1 SAMPLE
+
+=over 4
+
+=item F
+
+Paragraph.
+
+=item Bar
+
+=item B
+
+Paragraph.
+
+=item Longer
+
+Paragraph.
+
+=back
+
+###
+
+==== SAMPLE ====
+
+: F Paragraph.
+
+: Bar
+: B Paragraph.
+
+: Longer
+ Paragraph.
+
+###
+###
+
+###
+margin 4
+###
+=head1 SAMPLE
+
+This is some body text that is long enough to be a paragraph that wraps,
+thereby testing margins with wrapped paragraphs.
+
+ This is some verbatim text.
+
+=over 6
+
+=item Test
+
+This is a test of an indented paragraph.
+
+This is another indented paragraph.
+
+=back
+###
+ SAMPLE
+ This is some body text that is long enough to be a paragraph that
+ wraps, thereby testing margins with wrapped paragraphs.
+
+ This is some verbatim text.
+
+ Test This is a test of an indented paragraph.
+
+ This is another indented paragraph.
+
+###
+###
+
+###
+code 1
+###
+This is some random text.
+This is more random text.
+
+This is some random text.
+This is more random text.
+
+=head1 SAMPLE
+
+This is POD.
+
+=cut
+
+This is more random text.
+###
+This is some random text.
+This is more random text.
+
+This is some random text.
+This is more random text.
+
+SAMPLE
+ This is POD.
+
+
+This is more random text.
+###
+###
+
+###
+sentence 1
+###
+=head1 EXAMPLE
+
+Whitespace around C<< this. >> must be ignored per perlpodspec. >>
+needs to eat all of the space in front of it.
+
+=cut
+###
+EXAMPLE
+ Whitespace around "this." must be ignored per perlpodspec. >> needs to
+ eat all of the space in front of it.
+
+###
+###
+
+###
+###
+=over 4
+
+=item Foo
+
+Bar.
+
+=head1 NEXT
+###
+ Foo Bar.
+
+NEXT
+POD ERRORS
+ Hey! The above document had some coding errors, which are explained
+ below:
+
+ Around line 7:
+ You forgot a '=back' before '=head1'
+
+###
+###
+
+###
+stderr 1
+###
+=over 4
+
+=item Foo
+
+Bar.
+
+=head1 NEXT
+###
+ Foo Bar.
+
+NEXT
+###
+tmp.pod around line 7: You forgot a '=back' before '=head1'
+###
Copied: trunk/contrib/perl/lib/Pod/t/text-utf8.t (from rev 6437, vendor/perl/5.18.1/lib/Pod/t/text-utf8.t)
===================================================================
--- trunk/contrib/perl/lib/Pod/t/text-utf8.t (rev 0)
+++ trunk/contrib/perl/lib/Pod/t/text-utf8.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,129 @@
+#!/usr/bin/perl -w
+#
+# text-utf8.t -- Test Pod::Text with UTF-8 input.
+#
+# Copyright 2002, 2004, 2006, 2007, 2008 by Russ Allbery <rra at stanford.edu>
+#
+# This program is free software; you may redistribute it and/or modify it
+# under the same terms as Perl itself.
+
+BEGIN {
+ chdir 't' if -d 't';
+ if ($ENV{PERL_CORE}) {
+ @INC = '../lib';
+ } else {
+ unshift (@INC, '../blib/lib');
+ }
+ unshift (@INC, '../blib/lib');
+ $| = 1;
+ print "1..3\n";
+
+ # UTF-8 support requires Perl 5.8 or later.
+ if ($] < 5.008) {
+ my $n;
+ for $n (1..3) {
+ print "ok $n # skip -- Perl 5.8 required for UTF-8 support\n";
+ }
+ exit;
+ }
+}
+
+END {
+ print "not ok 1\n" unless $loaded;
+}
+
+use Pod::Text;
+
+$loaded = 1;
+print "ok 1\n";
+
+my $parser = Pod::Text->new or die "Cannot create parser\n";
+my $n = 2;
+eval { binmode (\*DATA, ':encoding(utf-8)') };
+eval { binmode (\*STDOUT, ':encoding(utf-8)') };
+while (<DATA>) {
+ next until $_ eq "###\n";
+ open (TMP, '> tmp.pod') or die "Cannot create tmp.pod: $!\n";
+ eval { binmode (\*TMP, ':encoding(utf-8)') };
+ print TMP "=encoding UTF-8\n\n";
+ while (<DATA>) {
+ last if $_ eq "###\n";
+ print TMP $_;
+ }
+ close TMP;
+ open (OUT, '> out.tmp') or die "Cannot create out.tmp: $!\n";
+ $parser->parse_from_file ('tmp.pod', \*OUT);
+ close OUT;
+ open (TMP, 'out.tmp') or die "Cannot open out.tmp: $!\n";
+ eval { binmode (\*TMP, ':encoding(utf-8)') };
+ my $output;
+ {
+ local $/;
+ $output = <TMP>;
+ }
+ close TMP;
+ unlink ('tmp.pod', 'out.tmp');
+ my $expected = '';
+ while (<DATA>) {
+ last if $_ eq "###\n";
+ $expected .= $_;
+ }
+ if ($output eq $expected) {
+ print "ok $n\n";
+ } else {
+ print "not ok $n\n";
+ print "Expected\n========\n$expected\nOutput\n======\n$output\n";
+ }
+ $n++;
+}
+
+# Below the marker are bits of POD and corresponding expected text output.
+# This is used to test specific features or problems with Pod::Text. The
+# input and output are separated by lines containing only ###.
+
+__DATA__
+
+###
+=head1 Test of SE<lt>E<gt>
+
+This is S<some whitespace>.
+###
+Test of S<>
+ This is some whitespace.
+
+###
+
+###
+=head1 I can eat glass
+
+=over 4
+
+=item Esperanto
+
+Mi povas manĝi vitron, ĝi ne damaĝas min.
+
+=item Braille
+
+⠊⠀⠉⠁⠝⠀⠑⠁⠞⠀⠛⠇⠁⠎⠎⠀⠁⠝⠙⠀⠊⠞⠀⠙⠕⠑⠎⠝⠞⠀⠓⠥⠗⠞⠀⠍⠑
+
+=item Hindi
+
+मैं काँच खा सकता हूँ और मुझे उससे कोई चोट नहीं पहुंचती.
+
+=back
+
+See L<http://www.columbia.edu/kermit/utf8.html>
+###
+I can eat glass
+ Esperanto
+ Mi povas manĝi vitron, ĝi ne damaĝas min.
+
+ Braille
+ ⠊⠀⠉⠁⠝⠀⠑⠁⠞⠀⠛⠇⠁⠎⠎⠀⠁⠝⠙⠀⠊⠞⠀⠙⠕⠑⠎⠝⠞⠀⠓⠥⠗⠞⠀⠍⠑
+
+ Hindi
+ मैं काँच खा सकता हूँ और मुझे उससे कोई चोट नहीं पहुंचती.
+
+ See <http://www.columbia.edu/kermit/utf8.html>
+
+###
Copied: trunk/contrib/perl/lib/Pod/t/text.t (from rev 6437, vendor/perl/5.18.1/lib/Pod/t/text.t)
===================================================================
--- trunk/contrib/perl/lib/Pod/t/text.t (rev 0)
+++ trunk/contrib/perl/lib/Pod/t/text.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,147 @@
+#!/usr/bin/perl -w
+#
+# text.t -- Additional specialized tests for Pod::Text.
+#
+# Copyright 2002, 2004, 2006, 2007, 2008, 2009 Russ Allbery <rra at stanford.edu>
+#
+# This program is free software; you may redistribute it and/or modify it
+# under the same terms as Perl itself.
+
+BEGIN {
+ chdir 't' if -d 't';
+ if ($ENV{PERL_CORE}) {
+ @INC = '../lib';
+ } else {
+ unshift (@INC, '../blib/lib');
+ }
+ unshift (@INC, '../blib/lib');
+ $| = 1;
+ print "1..6\n";
+}
+
+END {
+ print "not ok 1\n" unless $loaded;
+}
+
+use Pod::Text;
+use Pod::Simple;
+
+$loaded = 1;
+print "ok 1\n";
+
+my $parser = Pod::Text->new or die "Cannot create parser\n";
+my $n = 2;
+while (<DATA>) {
+ next until $_ eq "###\n";
+ open (TMP, '> tmp.pod') or die "Cannot create tmp.pod: $!\n";
+ while (<DATA>) {
+ last if $_ eq "###\n";
+ print TMP $_;
+ }
+ close TMP;
+ open (OUT, '> out.tmp') or die "Cannot create out.tmp: $!\n";
+ $parser->parse_from_file ('tmp.pod', \*OUT);
+ close OUT;
+ open (TMP, 'out.tmp') or die "Cannot open out.tmp: $!\n";
+ my $output;
+ {
+ local $/;
+ $output = <TMP>;
+ }
+ close TMP;
+ unlink ('tmp.pod', 'out.tmp');
+ my $expected = '';
+ while (<DATA>) {
+ last if $_ eq "###\n";
+ $expected .= $_;
+ }
+ if ($output eq $expected) {
+ print "ok $n\n";
+ } elsif ($n == 4 && $Pod::Simple::VERSION < 3.06) {
+ print "ok $n # skip Pod::Simple S<> parsing bug\n";
+ } else {
+ print "not ok $n\n";
+ print "Expected\n========\n$expected\nOutput\n======\n$output\n";
+ }
+ $n++;
+}
+
+# Below the marker are bits of POD and corresponding expected text output.
+# This is used to test specific features or problems with Pod::Text. The
+# input and output are separated by lines containing only ###.
+
+__DATA__
+
+###
+=head1 PERIODS
+
+This C<.> should be quoted.
+###
+PERIODS
+ This "." should be quoted.
+
+###
+
+###
+=head1 CE<lt>E<gt> WITH SPACES
+
+What does C<< this. >> end up looking like?
+###
+C<> WITH SPACES
+ What does "this." end up looking like?
+
+###
+
+###
+=head1 Test of SE<lt>E<gt>
+
+This is some S< > whitespace.
+###
+Test of S<>
+ This is some whitespace.
+
+###
+
+###
+=head1 Test of =for
+
+=for comment
+This won't be seen.
+
+Yes.
+
+=for text
+This should be seen.
+
+=for TEXT As should this.
+
+=for man
+But this shouldn't.
+
+Some more text.
+###
+Test of =for
+ Yes.
+
+This should be seen.
+As should this.
+ Some more text.
+
+###
+
+###
+=pod
+
+text
+
+ line1
+
+ line3
+###
+ text
+
+ line1
+
+ line3
+
+###
Copied: trunk/contrib/perl/lib/Pod/t/user.t (from rev 6437, vendor/perl/5.18.1/lib/Pod/t/user.t)
===================================================================
--- trunk/contrib/perl/lib/Pod/t/user.t (rev 0)
+++ trunk/contrib/perl/lib/Pod/t/user.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,104 @@
+#!perl
+
+# Purpose: test UserPreamble and UserPostamble
+# It's a minor variation of 'pod2latex.t',
+# subject to the same limitations.
+# Variant provided by
+# Adriano Rodrigues Ferreira <ferreira at triang.com.br>
+
+use Test;
+use strict;
+
+BEGIN { plan tests => 17 }
+
+use Pod::LaTeX;
+
+# The link parsing changed between v0.22 and v0.30 of Pod::ParseUtils
+use Pod::ParseUtils;
+my $linkver = $Pod::ParseUtils::VERSION;
+
+# Set up an END block to remove the test output file
+END {
+ unlink "test.tex";
+};
+
+ok(1);
+
+# First thing to do is to read the expected output from
+# the DATA filehandle and store it in a scalar.
+# Do this until we read an =pod
+my @reference;
+while (my $line = <DATA>) {
+ last if $line =~ /^=pod/;
+ push(@reference,$line);
+}
+
+my $user_preamble = <<PRE;
+
+\\documentclass{article}
+
+\\begin{document}
+PRE
+
+my $user_postamble = <<POST;
+\\end{document}
+
+POST
+
+# Create a new parser
+my %params = (
+ UserPreamble => $user_preamble,
+ UserPostamble => $user_postamble
+);
+
+my $parser = Pod::LaTeX->new(%params);
+ok($parser);
+
+# Create an output file
+open(OUTFH, "> test.tex" ) or die "Unable to open test tex file: $!\n";
+
+# Read from the DATA filehandle and write to a new output file
+# Really want to write this to a scalar
+$parser->parse_from_filehandle(\*DATA,\*OUTFH);
+
+close(OUTFH) or die "Error closing OUTFH test.tex: $!\n";
+
+# Now read in OUTFH and compare
+open(INFH, "< test.tex") or die "Unable to read test tex file: $!\n";
+my @output = <INFH>;
+
+ok(@output, @reference);
+
+for my $i (0..$#reference) {
+ next if $reference[$i] =~ /^%%/; # skip timestamp comments
+ ok($output[$i], $reference[$i]);
+}
+
+close(INFH) or die "Error closing INFH test.tex: $!\n";
+
+
+__DATA__
+
+\documentclass{article}
+
+\begin{document}
+
+%% Latex generated from POD in document (unknown)
+%% Using the perl module Pod::LaTeX
+%% Converted on Wed Jan 14 19:04:22 2004
+
+%% Preamble supplied by user.
+
+\section{POD\label{POD}\index{POD}}
+
+
+This is a POD file, very simple. \textit{Bye}.
+
+\end{document}
+
+=pod
+
+=head1 POD
+
+This is a POD file, very simple. I<Bye>.
+
Index: trunk/contrib/perl/lib/Pod/t/utils.t
===================================================================
--- trunk/contrib/perl/lib/Pod/t/utils.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Pod/t/utils.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Pod/t/utils.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/Search/Dict.pm
===================================================================
--- trunk/contrib/perl/lib/Search/Dict.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Search/Dict.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Search/Dict.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/Search/Dict.t
===================================================================
--- trunk/contrib/perl/lib/Search/Dict.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Search/Dict.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Search/Dict.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/SelectSaver.pm
===================================================================
--- trunk/contrib/perl/lib/SelectSaver.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/SelectSaver.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/SelectSaver.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/SelectSaver.t
===================================================================
--- trunk/contrib/perl/lib/SelectSaver.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/SelectSaver.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/SelectSaver.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/lib/SelfLoader-buggy.t (from rev 6437, vendor/perl/5.18.1/lib/SelfLoader-buggy.t)
===================================================================
--- trunk/contrib/perl/lib/SelfLoader-buggy.t (rev 0)
+++ trunk/contrib/perl/lib/SelfLoader-buggy.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,48 @@
+#!./perl
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+}
+
+use SelfLoader;
+print "1..1\n";
+
+# this script checks that errors on self-loaded
+# subroutines that affect $@ are reported
+
+eval { buggy(); };
+unless ($@ =~ /^syntax error/) {
+ print "not ";
+}
+print "ok 1 - syntax errors are reported\n";
+
+__END__
+
+sub buggy
+{
+ +>*;
+}
+
+
+# RT 40216
+#
+# by Bo Lindbergh <blgl at hagernas.com>, at Aug 22, 2006 5:42 PM
+#
+# In the example below, there's a syntax error in the selfloaded
+# code for main::buggy. When the eval fails, SelfLoader::AUTOLOAD
+# tries to report this with "croak $@;". Unfortunately,
+# SelfLoader::croak does "require Carp;" without protecting $@,
+# which gets clobbered. The program then dies with the
+# uninformative message " at ./example line 3".
+#
+# #! /usr/local/bin/perl
+# use SelfLoader;
+# buggy();
+# __END__
+# sub buggy
+# {
+# +>*;
+# }
Copied: trunk/contrib/perl/lib/SelfLoader.pm (from rev 6437, vendor/perl/5.18.1/lib/SelfLoader.pm)
===================================================================
--- trunk/contrib/perl/lib/SelfLoader.pm (rev 0)
+++ trunk/contrib/perl/lib/SelfLoader.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,435 @@
+package SelfLoader;
+use 5.008;
+use strict;
+our $VERSION = "1.17";
+
+# The following bit of eval-magic is necessary to make this work on
+# perls < 5.009005.
+use vars qw/$AttrList/;
+BEGIN {
+ if ($] > 5.009004) {
+ eval <<'NEWERPERL';
+use 5.009005; # due to new regexp features
+# allow checking for valid ': attrlist' attachments
+# see also AutoSplit
+$AttrList = qr{
+ \s* : \s*
+ (?:
+ # one attribute
+ (?> # no backtrack
+ (?! \d) \w+
+ (?<nested> \( (?: [^()]++ | (?&nested)++ )*+ \) ) ?
+ )
+ (?: \s* : \s* | \s+ (?! :) )
+ )*
+}x;
+
+NEWERPERL
+ }
+ else {
+ eval <<'OLDERPERL';
+# allow checking for valid ': attrlist' attachments
+# (we use 'our' rather than 'my' here, due to the rather complex and buggy
+# behaviour of lexicals with qr// and (??{$lex}) )
+our $nested;
+$nested = qr{ \( (?: (?> [^()]+ ) | (??{ $nested }) )* \) }x;
+our $one_attr = qr{ (?> (?! \d) \w+ (?:$nested)? ) (?:\s*\:\s*|\s+(?!\:)) }x;
+$AttrList = qr{ \s* : \s* (?: $one_attr )* }x;
+OLDERPERL
+ }
+}
+use Exporter;
+our @ISA = qw(Exporter);
+our @EXPORT = qw(AUTOLOAD);
+sub Version {$VERSION}
+sub DEBUG () { 0 }
+
+my %Cache; # private cache for all SelfLoader's client packages
+
+# in croak and carp, protect $@ from "require Carp;" RT #40216
+
+sub croak { { local $@; require Carp; } goto &Carp::croak }
+sub carp { { local $@; require Carp; } goto &Carp::carp }
+
+AUTOLOAD {
+ our $AUTOLOAD;
+ print STDERR "SelfLoader::AUTOLOAD for $AUTOLOAD\n" if DEBUG;
+ my $SL_code = $Cache{$AUTOLOAD};
+ my $save = $@; # evals in both AUTOLOAD and _load_stubs can corrupt $@
+ unless ($SL_code) {
+ # Maybe this pack had stubs before __DATA__, and never initialized.
+ # Or, this maybe an automatic DESTROY method call when none exists.
+ $AUTOLOAD =~ m/^(.*)::/;
+ SelfLoader->_load_stubs($1) unless exists $Cache{"${1}::<DATA"};
+ $SL_code = $Cache{$AUTOLOAD};
+ $SL_code = "sub $AUTOLOAD { }"
+ if (!$SL_code and $AUTOLOAD =~ m/::DESTROY$/);
+ croak "Undefined subroutine $AUTOLOAD" unless $SL_code;
+ }
+ print STDERR "SelfLoader::AUTOLOAD eval: $SL_code\n" if DEBUG;
+
+ {
+ no strict;
+ eval $SL_code;
+ }
+ if ($@) {
+ $@ =~ s/ at .*\n//;
+ croak $@;
+ }
+ $@ = $save;
+ defined(&$AUTOLOAD) || die "SelfLoader inconsistency error";
+ delete $Cache{$AUTOLOAD};
+ goto &$AUTOLOAD
+}
+
+sub load_stubs { shift->_load_stubs((caller)[0]) }
+
+sub _load_stubs {
+ # $endlines is used by Devel::SelfStubber to capture lines after __END__
+ my($self, $callpack, $endlines) = @_;
+ no strict "refs";
+ my $fh = \*{"${callpack}::DATA"};
+ use strict;
+ my $currpack = $callpack;
+ my($line,$name, at lines, @stubs, $protoype);
+
+ print STDERR "SelfLoader::load_stubs($callpack)\n" if DEBUG;
+ croak("$callpack doesn't contain an __DATA__ token")
+ unless defined fileno($fh);
+ # Protect: fork() shares the file pointer between the parent and the kid
+ if(sysseek($fh, tell($fh), 0)) {
+ open my $nfh, '<&', $fh or croak "reopen: $!";# dup() the fd
+ close $fh or die "close: $!"; # autocloses, but be paranoid
+ open $fh, '<&', $nfh or croak "reopen2: $!"; # dup() the fd "back"
+ close $nfh or die "close after reopen: $!"; # autocloses, but be paranoid
+ }
+ $Cache{"${currpack}::<DATA"} = 1; # indicate package is cached
+
+ local($/) = "\n";
+ while(defined($line = <$fh>) and $line !~ m/^__END__/) {
+ if ($line =~ m/^\s*sub\s+([\w:]+)\s*((?:\([\\\$\@\%\&\*\;]*\))?(?:$AttrList)?)/) {
+ push(@stubs, $self->_add_to_cache($name, $currpack, \@lines, $protoype));
+ $protoype = $2;
+ @lines = ($line);
+ if (index($1,'::') == -1) { # simple sub name
+ $name = "${currpack}::$1";
+ } else { # sub name with package
+ $name = $1;
+ $name =~ m/^(.*)::/;
+ if (defined(&{"${1}::AUTOLOAD"})) {
+ \&{"${1}::AUTOLOAD"} == \&SelfLoader::AUTOLOAD ||
+ die 'SelfLoader Error: attempt to specify Selfloading',
+ " sub $name in non-selfloading module $1";
+ } else {
+ $self->export($1,'AUTOLOAD');
+ }
+ }
+ } elsif ($line =~ m/^package\s+([\w:]+)/) { # A package declared
+ push(@stubs, $self->_add_to_cache($name, $currpack, \@lines, $protoype));
+ $self->_package_defined($line);
+ $name = '';
+ @lines = ();
+ $currpack = $1;
+ $Cache{"${currpack}::<DATA"} = 1; # indicate package is cached
+ if (defined(&{"${1}::AUTOLOAD"})) {
+ \&{"${1}::AUTOLOAD"} == \&SelfLoader::AUTOLOAD ||
+ die 'SelfLoader Error: attempt to specify Selfloading',
+ " package $currpack which already has AUTOLOAD";
+ } else {
+ $self->export($currpack,'AUTOLOAD');
+ }
+ } else {
+ push(@lines,$line);
+ }
+ }
+ if (defined($line) && $line =~ /^__END__/) { # __END__
+ unless ($line =~ /^__END__\s*DATA/) {
+ if ($endlines) {
+ # Devel::SelfStubber would like us to capture the lines after
+ # __END__ so it can write out the entire file
+ @$endlines = <$fh>;
+ }
+ close($fh);
+ }
+ }
+ push(@stubs, $self->_add_to_cache($name, $currpack, \@lines, $protoype));
+ no strict;
+ eval join('', @stubs) if @stubs;
+}
+
+
+sub _add_to_cache {
+ my($self,$fullname,$pack,$lines, $protoype) = @_;
+ return () unless $fullname;
+ carp("Redefining sub $fullname")
+ if exists $Cache{$fullname};
+ $Cache{$fullname} = join('', "\n\#line 1 \"sub $fullname\"\npackage $pack; ", @$lines);
+ #$Cache{$fullname} = join('', "package $pack; ",@$lines);
+ print STDERR "SelfLoader cached $fullname: $Cache{$fullname}" if DEBUG;
+ # return stub to be eval'd
+ defined($protoype) ? "sub $fullname $protoype;" : "sub $fullname;"
+}
+
+sub _package_defined {}
+
+1;
+__END__
+
+=head1 NAME
+
+SelfLoader - load functions only on demand
+
+=head1 SYNOPSIS
+
+ package FOOBAR;
+ use SelfLoader;
+
+ ... (initializing code)
+
+ __DATA__
+ sub {....
+
+
+=head1 DESCRIPTION
+
+This module tells its users that functions in the FOOBAR package are to be
+autoloaded from after the C<__DATA__> token. See also
+L<perlsub/"Autoloading">.
+
+=head2 The __DATA__ token
+
+The C<__DATA__> token tells the perl compiler that the perl code
+for compilation is finished. Everything after the C<__DATA__> token
+is available for reading via the filehandle FOOBAR::DATA,
+where FOOBAR is the name of the current package when the C<__DATA__>
+token is reached. This works just the same as C<__END__> does in
+package 'main', but for other modules data after C<__END__> is not
+automatically retrievable, whereas data after C<__DATA__> is.
+The C<__DATA__> token is not recognized in versions of perl prior to
+5.001m.
+
+Note that it is possible to have C<__DATA__> tokens in the same package
+in multiple files, and that the last C<__DATA__> token in a given
+package that is encountered by the compiler is the one accessible
+by the filehandle. This also applies to C<__END__> and main, i.e. if
+the 'main' program has an C<__END__>, but a module 'require'd (_not_ 'use'd)
+by that program has a 'package main;' declaration followed by an 'C<__DATA__>',
+then the C<DATA> filehandle is set to access the data after the C<__DATA__>
+in the module, _not_ the data after the C<__END__> token in the 'main'
+program, since the compiler encounters the 'require'd file later.
+
+=head2 SelfLoader autoloading
+
+The B<SelfLoader> works by the user placing the C<__DATA__>
+token I<after> perl code which needs to be compiled and
+run at 'require' time, but I<before> subroutine declarations
+that can be loaded in later - usually because they may never
+be called.
+
+The B<SelfLoader> will read from the FOOBAR::DATA filehandle to
+load in the data after C<__DATA__>, and load in any subroutine
+when it is called. The costs are the one-time parsing of the
+data after C<__DATA__>, and a load delay for the _first_
+call of any autoloaded function. The benefits (hopefully)
+are a speeded up compilation phase, with no need to load
+functions which are never used.
+
+The B<SelfLoader> will stop reading from C<__DATA__> if
+it encounters the C<__END__> token - just as you would expect.
+If the C<__END__> token is present, and is followed by the
+token DATA, then the B<SelfLoader> leaves the FOOBAR::DATA
+filehandle open on the line after that token.
+
+The B<SelfLoader> exports the C<AUTOLOAD> subroutine to the
+package using the B<SelfLoader>, and this loads the called
+subroutine when it is first called.
+
+There is no advantage to putting subroutines which will _always_
+be called after the C<__DATA__> token.
+
+=head2 Autoloading and package lexicals
+
+A 'my $pack_lexical' statement makes the variable $pack_lexical
+local _only_ to the file up to the C<__DATA__> token. Subroutines
+declared elsewhere _cannot_ see these types of variables,
+just as if you declared subroutines in the package but in another
+file, they cannot see these variables.
+
+So specifically, autoloaded functions cannot see package
+lexicals (this applies to both the B<SelfLoader> and the Autoloader).
+The C<vars> pragma provides an alternative to defining package-level
+globals that will be visible to autoloaded routines. See the documentation
+on B<vars> in the pragma section of L<perlmod>.
+
+=head2 SelfLoader and AutoLoader
+
+The B<SelfLoader> can replace the AutoLoader - just change 'use AutoLoader'
+to 'use SelfLoader' (though note that the B<SelfLoader> exports
+the AUTOLOAD function - but if you have your own AUTOLOAD and
+are using the AutoLoader too, you probably know what you're doing),
+and the C<__END__> token to C<__DATA__>. You will need perl version 5.001m
+or later to use this (version 5.001 with all patches up to patch m).
+
+There is no need to inherit from the B<SelfLoader>.
+
+The B<SelfLoader> works similarly to the AutoLoader, but picks up the
+subs from after the C<__DATA__> instead of in the 'lib/auto' directory.
+There is a maintenance gain in not needing to run AutoSplit on the module
+at installation, and a runtime gain in not needing to keep opening and
+closing files to load subs. There is a runtime loss in needing
+to parse the code after the C<__DATA__>. Details of the B<AutoLoader> and
+another view of these distinctions can be found in that module's
+documentation.
+
+=head2 __DATA__, __END__, and the FOOBAR::DATA filehandle.
+
+This section is only relevant if you want to use
+the C<FOOBAR::DATA> together with the B<SelfLoader>.
+
+Data after the C<__DATA__> token in a module is read using the
+FOOBAR::DATA filehandle. C<__END__> can still be used to denote the end
+of the C<__DATA__> section if followed by the token DATA - this is supported
+by the B<SelfLoader>. The C<FOOBAR::DATA> filehandle is left open if an
+C<__END__> followed by a DATA is found, with the filehandle positioned at
+the start of the line after the C<__END__> token. If no C<__END__> token is
+present, or an C<__END__> token with no DATA token on the same line, then
+the filehandle is closed.
+
+The B<SelfLoader> reads from wherever the current
+position of the C<FOOBAR::DATA> filehandle is, until the
+EOF or C<__END__>. This means that if you want to use
+that filehandle (and ONLY if you want to), you should either
+
+1. Put all your subroutine declarations immediately after
+the C<__DATA__> token and put your own data after those
+declarations, using the C<__END__> token to mark the end
+of subroutine declarations. You must also ensure that the B<SelfLoader>
+reads first by calling 'SelfLoader-E<gt>load_stubs();', or by using a
+function which is selfloaded;
+
+or
+
+2. You should read the C<FOOBAR::DATA> filehandle first, leaving
+the handle open and positioned at the first line of subroutine
+declarations.
+
+You could conceivably do both.
+
+=head2 Classes and inherited methods.
+
+For modules which are not classes, this section is not relevant.
+This section is only relevant if you have methods which could
+be inherited.
+
+A subroutine stub (or forward declaration) looks like
+
+ sub stub;
+
+i.e. it is a subroutine declaration without the body of the
+subroutine. For modules which are not classes, there is no real
+need for stubs as far as autoloading is concerned.
+
+For modules which ARE classes, and need to handle inherited methods,
+stubs are needed to ensure that the method inheritance mechanism works
+properly. You can load the stubs into the module at 'require' time, by
+adding the statement 'SelfLoader-E<gt>load_stubs();' to the module to do
+this.
+
+The alternative is to put the stubs in before the C<__DATA__> token BEFORE
+releasing the module, and for this purpose the C<Devel::SelfStubber>
+module is available. However this does require the extra step of ensuring
+that the stubs are in the module. If this is done I strongly recommend
+that this is done BEFORE releasing the module - it should NOT be done
+at install time in general.
+
+=head1 Multiple packages and fully qualified subroutine names
+
+Subroutines in multiple packages within the same file are supported - but you
+should note that this requires exporting the C<SelfLoader::AUTOLOAD> to
+every package which requires it. This is done automatically by the
+B<SelfLoader> when it first loads the subs into the cache, but you should
+really specify it in the initialization before the C<__DATA__> by putting
+a 'use SelfLoader' statement in each package.
+
+Fully qualified subroutine names are also supported. For example,
+
+ __DATA__
+ sub foo::bar {23}
+ package baz;
+ sub dob {32}
+
+will all be loaded correctly by the B<SelfLoader>, and the B<SelfLoader>
+will ensure that the packages 'foo' and 'baz' correctly have the
+B<SelfLoader> C<AUTOLOAD> method when the data after C<__DATA__> is first
+parsed.
+
+=head1 AUTHOR
+
+C<SelfLoader> is maintained by the perl5-porters. Please direct
+any questions to the canonical mailing list. Anything that
+is applicable to the CPAN release can be sent to its maintainer,
+though.
+
+Author and Maintainer: The Perl5-Porters <perl5-porters at perl.org>
+
+Maintainer of the CPAN release: Steffen Mueller <smueller at cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This package has been part of the perl core since the first release
+of perl5. It has been released separately to CPAN so older installations
+can benefit from bug fixes.
+
+This package has the same copyright and license as the perl core:
+
+ Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ 2000, 2001, 2002, 2003, 2004, 2005, 2006 by Larry Wall and others
+
+ All rights reserved.
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of either:
+
+ a) the GNU General Public License as published by the Free
+ Software Foundation; either version 1, or (at your option) any
+ later version, or
+
+ b) the "Artistic License" which comes with this Kit.
+
+ 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 either
+ the GNU General Public License or the Artistic License for more details.
+
+ You should have received a copy of the Artistic License with this
+ Kit, in the file named "Artistic". If not, I'll be glad to provide one.
+
+ You should also have received a copy of the GNU General Public License
+ along with this program in the file named "Copying". If not, write to the
+ Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+ 02111-1307, USA or visit their web page on the internet at
+ http://www.gnu.org/copyleft/gpl.html.
+
+ For those of you that choose to use the GNU General Public License,
+ my interpretation of the GNU General Public License is that no Perl
+ script falls under the terms of the GPL unless you explicitly put
+ said script under the terms of the GPL yourself. Furthermore, any
+ object code linked with perl does not automatically fall under the
+ terms of the GPL, provided such object code only adds definitions
+ of subroutines and variables, and does not otherwise impair the
+ resulting interpreter from executing any standard Perl script. I
+ consider linking in C subroutines in this manner to be the moral
+ equivalent of defining subroutines in the Perl language itself. You
+ may sell such an object file as proprietary provided that you provide
+ or offer to provide the Perl source, as specified by the GNU General
+ Public License. (This is merely an alternate way of specifying input
+ to the program.) You may also sell a binary produced by the dumping of
+ a running Perl script that belongs to you, provided that you provide or
+ offer to provide the Perl source as specified by the GPL. (The
+ fact that a Perl interpreter and your code are in the same binary file
+ is, in this case, a form of mere aggregation.) This is my interpretation
+ of the GPL. If you still have concerns or difficulties understanding
+ my intent, feel free to contact me. Of course, the Artistic License
+ spells all this out for your protection, so you may prefer to use that.
+
+=cut
Copied: trunk/contrib/perl/lib/SelfLoader.t (from rev 6437, vendor/perl/5.18.1/lib/SelfLoader.t)
===================================================================
--- trunk/contrib/perl/lib/SelfLoader.t (rev 0)
+++ trunk/contrib/perl/lib/SelfLoader.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,208 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ $dir = "self-$$";
+ $sep = "/";
+
+ if ($^O eq 'MacOS') {
+ $dir = ":" . $dir;
+ $sep = ":";
+ }
+
+ @INC = $dir;
+ push @INC, '../lib';
+
+ print "1..19\n";
+
+ # First we must set up some selfloader files
+ mkdir $dir, 0755 or die "Can't mkdir $dir: $!";
+
+ open(FOO, ">$dir${sep}Foo.pm") or die;
+ print FOO <<'EOT';
+package Foo;
+use SelfLoader;
+
+sub new { bless {}, shift }
+sub foo;
+sub bar;
+sub bazmarkhianish;
+sub a;
+sub never; # declared but definition should never be read
+1;
+__DATA__
+
+sub foo { shift; shift || "foo" };
+
+sub bar { shift; shift || "bar" }
+
+sub bazmarkhianish { shift; shift || "baz" }
+
+package sheep;
+sub bleat { shift; shift || "baa" }
+
+__END__
+sub never { die "D'oh" }
+EOT
+
+ close(FOO);
+
+ open(BAR, ">$dir${sep}Bar.pm") or die;
+ print BAR <<'EOT';
+package Bar;
+use SelfLoader;
+
+ at ISA = 'Baz';
+
+sub new { bless {}, shift }
+sub a;
+
+1;
+__DATA__
+
+sub a { 'a Bar'; }
+sub b { 'b Bar' }
+
+__END__ DATA
+sub never { die "D'oh" }
+EOT
+
+ close(BAR);
+};
+
+
+package Baz;
+
+sub a { 'a Baz' }
+sub b { 'b Baz' }
+sub c { 'c Baz' }
+
+
+package main;
+use Foo;
+use Bar;
+
+$foo = new Foo;
+
+print "not " unless $foo->foo eq 'foo'; # selfloaded first time
+print "ok 1\n";
+
+print "not " unless $foo->foo eq 'foo'; # regular call
+print "ok 2\n";
+
+# Try an undefined method
+eval {
+ $foo->will_fail;
+};
+if ($@ =~ /^Undefined subroutine/) {
+ print "ok 3\n";
+} else {
+ print "not ok 3 $@\n";
+}
+
+# Used to be trouble with this
+eval {
+ my $foo = new Foo;
+ die "oops";
+};
+if ($@ =~ /oops/) {
+ print "ok 4\n";
+} else {
+ print "not ok 4 $@\n";
+}
+
+# Pass regular expression variable to autoloaded function. This used
+# to go wrong in AutoLoader because it used regular expressions to generate
+# autoloaded filename.
+"foo" =~ /(\w+)/;
+print "not " unless $1 eq 'foo';
+print "ok 5\n";
+
+print "not " unless $foo->bar($1) eq 'foo';
+print "ok 6\n";
+
+print "not " unless $foo->bar($1) eq 'foo';
+print "ok 7\n";
+
+print "not " unless $foo->bazmarkhianish($1) eq 'foo';
+print "ok 8\n";
+
+print "not " unless $foo->bazmarkhianish($1) eq 'foo';
+print "ok 9\n";
+
+# Check nested packages inside __DATA__
+print "not " unless sheep::bleat() eq 'baa';
+print "ok 10\n";
+
+# Now check inheritance:
+
+$bar = new Bar;
+
+# Before anything is SelfLoaded there is no declaration of Foo::b so we should
+# get Baz::b
+print "not " unless $bar->b() eq 'b Baz';
+print "ok 11\n";
+
+# There is no Bar::c so we should get Baz::c
+print "not " unless $bar->c() eq 'c Baz';
+print "ok 12\n";
+
+# This selfloads Bar::a because it is stubbed. It also stubs Bar::b as a side
+# effect
+print "not " unless $bar->a() eq 'a Bar';
+print "ok 13\n";
+
+print "not " unless $bar->b() eq 'b Bar';
+print "ok 14\n";
+
+print "not " unless $bar->c() eq 'c Baz';
+print "ok 15\n";
+
+
+
+# Check that __END__ is honoured
+# Try an subroutine that should never be noticed by selfloader
+eval {
+ $foo->never;
+};
+if ($@ =~ /^Undefined subroutine/) {
+ print "ok 16\n";
+} else {
+ print "not ok 16 $@\n";
+}
+
+# Try to read from the data file handle
+my $foodata = <Foo::DATA>;
+close Foo::DATA;
+if (defined $foodata) {
+ print "not ok 17 # $foodata\n";
+} else {
+ print "ok 17\n";
+}
+
+# Check that __END__ DATA is honoured
+# Try an subroutine that should never be noticed by selfloader
+eval {
+ $bar->never;
+};
+if ($@ =~ /^Undefined subroutine/) {
+ print "ok 18\n";
+} else {
+ print "not ok 18 $@\n";
+}
+
+# Try to read from the data file handle
+my $bardata = <Bar::DATA>;
+close Bar::DATA;
+if ($bardata ne "sub never { die \"D'oh\" }\n") {
+ print "not ok 19 # $bardata\n";
+} else {
+ print "ok 19\n";
+}
+
+# cleanup
+END {
+return unless $dir && -d $dir;
+unlink "$dir${sep}Foo.pm", "$dir${sep}Bar.pm";
+rmdir "$dir";
+}
Copied: trunk/contrib/perl/lib/Shell.pm (from rev 6437, vendor/perl/5.18.1/lib/Shell.pm)
===================================================================
--- trunk/contrib/perl/lib/Shell.pm (rev 0)
+++ trunk/contrib/perl/lib/Shell.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,270 @@
+package Shell;
+use 5.006_001;
+use strict;
+use warnings;
+use File::Spec::Functions;
+
+our($capture_stderr, $raw, $VERSION, $AUTOLOAD);
+
+$VERSION = '0.72_01';
+$VERSION = eval $VERSION;
+
+sub new { bless \my $foo, shift }
+sub DESTROY { }
+
+sub import {
+ my $self = shift;
+ my ($callpack, $callfile, $callline) = caller;
+ my @EXPORT;
+ if (@_) {
+ @EXPORT = @_;
+ } else {
+ @EXPORT = 'AUTOLOAD';
+ }
+ foreach my $sym (@EXPORT) {
+ no strict 'refs';
+ *{"${callpack}::$sym"} = \&{"Shell::$sym"};
+ }
+}
+
+# NOTE: this is used to enable constant folding in
+# expressions like (OS eq 'MSWin32') and
+# (OS eq 'os2') just like it happened in 0.6 version
+# which used eval "string" to install subs on the fly.
+use constant OS => $^O;
+
+=begin private
+
+=item B<_make_cmd>
+
+ $sub = _make_cmd($cmd);
+ $sub = $shell->_make_cmd($cmd);
+
+Creates a closure which invokes the system command C<$cmd>.
+
+=end private
+
+=cut
+
+sub _make_cmd {
+ shift if ref $_[0] && $_[0]->isa( 'Shell' );
+ my $cmd = shift;
+ my $null = File::Spec::Functions::devnull();
+ $Shell::capture_stderr ||= 0;
+ # closing over $^O, $cmd, and $null
+ return sub {
+ shift if ref $_[0] && $_[0]->isa( 'Shell' );
+ if (@_ < 1) {
+ $Shell::capture_stderr == 1 ? `$cmd 2>&1` :
+ $Shell::capture_stderr == -1 ? `$cmd 2>$null` :
+ `$cmd`;
+ } elsif (OS eq 'os2') {
+ local(*SAVEOUT, *READ, *WRITE);
+
+ open SAVEOUT, '>&STDOUT' or die;
+ pipe READ, WRITE or die;
+ open STDOUT, '>&WRITE' or die;
+ close WRITE;
+
+ my $pid = system(1, $cmd, @_);
+ die "Can't execute $cmd: $!\n" if $pid < 0;
+
+ open STDOUT, '>&SAVEOUT' or die;
+ close SAVEOUT;
+
+ if (wantarray) {
+ my @ret = <READ>;
+ close READ;
+ waitpid $pid, 0;
+ @ret;
+ } else {
+ local($/) = undef;
+ my $ret = <READ>;
+ close READ;
+ waitpid $pid, 0;
+ $ret;
+ }
+ } else {
+ my $a;
+ my @arr = @_;
+ unless( $Shell::raw ){
+ if (OS eq 'MSWin32') {
+ # XXX this special-casing should not be needed
+ # if we do quoting right on Windows. :-(
+ #
+ # First, escape all quotes. Cover the case where we
+ # want to pass along a quote preceded by a backslash
+ # (i.e., C<"param \""" end">).
+ # Ugly, yup? You know, windoze.
+ # Enclose in quotes only the parameters that need it:
+ # try this: c:> dir "/w"
+ # and this: c:> dir /w
+ for (@arr) {
+ s/"/\\"/g;
+ s/\\\\"/\\\\"""/g;
+ $_ = qq["$_"] if /\s/;
+ }
+ } else {
+ for (@arr) {
+ s/(['\\])/\\$1/g;
+ $_ = $_;
+ }
+ }
+ }
+ push @arr, '2>&1' if $Shell::capture_stderr == 1;
+ push @arr, '2>$null' if $Shell::capture_stderr == -1;
+ open(SUBPROC, join(' ', $cmd, @arr, '|'))
+ or die "Can't exec $cmd: $!\n";
+ if (wantarray) {
+ my @ret = <SUBPROC>;
+ close SUBPROC; # XXX Oughta use a destructor.
+ @ret;
+ } else {
+ local($/) = undef;
+ my $ret = <SUBPROC>;
+ close SUBPROC;
+ $ret;
+ }
+ }
+ };
+ }
+
+sub AUTOLOAD {
+ shift if ref $_[0] && $_[0]->isa( 'Shell' );
+ my $cmd = $AUTOLOAD;
+ $cmd =~ s/^.*:://;
+ no strict 'refs';
+ *$AUTOLOAD = _make_cmd($cmd);
+ goto &$AUTOLOAD;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Shell - run shell commands transparently within perl
+
+=head1 SYNOPSIS
+
+ use Shell qw(cat ps cp);
+ $passwd = cat('</etc/passwd');
+ @pslines = ps('-ww'),
+ cp("/etc/passwd", "/tmp/passwd");
+
+ # object oriented
+ my $sh = Shell->new;
+ print $sh->ls('-l');
+
+=head1 DESCRIPTION
+
+=head2 Caveats
+
+This package is included as a show case, illustrating a few Perl features.
+It shouldn't be used for production programs. Although it does provide a
+simple interface for obtaining the standard output of arbitrary commands,
+there may be better ways of achieving what you need.
+
+Running shell commands while obtaining standard output can be done with the
+C<qx/STRING/> operator, or by calling C<open> with a filename expression that
+ends with C<|>, giving you the option to process one line at a time.
+If you don't need to process standard output at all, you might use C<system>
+(in preference of doing a print with the collected standard output).
+
+Since Shell.pm and all of the aforementioned techniques use your system's
+shell to call some local command, none of them is portable across different
+systems. Note, however, that there are several built in functions and
+library packages providing portable implementations of functions operating
+on files, such as: C<glob>, C<link> and C<unlink>, C<mkdir> and C<rmdir>,
+C<rename>, C<File::Compare>, C<File::Copy>, C<File::Find> etc.
+
+Using Shell.pm while importing C<foo> creates a subroutine C<foo> in the
+namespace of the importing package. Calling C<foo> with arguments C<arg1>,
+C<arg2>,... results in a shell command C<foo arg1 arg2...>, where the
+function name and the arguments are joined with a blank. (See the subsection
+on Escaping magic characters.) Since the result is essentially a command
+line to be passed to the shell, your notion of arguments to the Perl
+function is not necessarily identical to what the shell treats as a
+command line token, to be passed as an individual argument to the program.
+Furthermore, note that this implies that C<foo> is callable by file name
+only, which frequently depends on the setting of the program's environment.
+
+Creating a Shell object gives you the opportunity to call any command
+in the usual OO notation without requiring you to announce it in the
+C<use Shell> statement. Don't assume any additional semantics being
+associated with a Shell object: in no way is it similar to a shell
+process with its environment or current working directory or any
+other setting.
+
+=head2 Escaping Magic Characters
+
+It is, in general, impossible to take care of quoting the shell's
+magic characters. For some obscure reason, however, Shell.pm quotes
+apostrophes (C<'>) and backslashes (C<\>) on UNIX, and spaces and
+quotes (C<">) on Windows.
+
+=head2 Configuration
+
+If you set $Shell::capture_stderr to 1, the module will attempt to
+capture the standard error output of the process as well. This is
+done by adding C<2E<gt>&1> to the command line, so don't try this on
+a system not supporting this redirection.
+
+Setting $Shell::capture_stderr to -1 will send standard error to the
+bit bucket (i.e., the equivalent of adding C<2E<gt>/dev/null> to the
+command line). The same caveat regarding redirection applies.
+
+If you set $Shell::raw to true no quoting whatsoever is done.
+
+=head1 BUGS
+
+Quoting should be off by default.
+
+It isn't possible to call shell built in commands, but it can be
+done by using a workaround, e.g. shell( '-c', 'set' ).
+
+Capturing standard error does not work on some systems (e.g. VMS).
+
+=head1 AUTHOR
+
+ Date: Thu, 22 Sep 94 16:18:16 -0700
+ Message-Id: <9409222318.AA17072 at scalpel.netlabs.com>
+ To: perl5-porters at isu.edu
+ From: Larry Wall <lwall at scalpel.netlabs.com>
+ Subject: a new module I just wrote
+
+Here's one that'll whack your mind a little out.
+
+ #!/usr/bin/perl
+
+ use Shell;
+
+ $foo = echo("howdy", "<funny>", "world");
+ print $foo;
+
+ $passwd = cat("</etc/passwd");
+ print $passwd;
+
+ sub ps;
+ print ps -ww;
+
+ cp("/etc/passwd", "/etc/passwd.orig");
+
+That's maybe too gonzo. It actually exports an AUTOLOAD to the current
+package (and uncovered a bug in Beta 3, by the way). Maybe the usual
+usage should be
+
+ use Shell qw(echo cat ps cp);
+
+Larry Wall
+
+Changes by Jenda at Krynicky.cz and Dave Cottle <d.cottle at csc.canterbury.ac.nz>.
+
+Changes for OO syntax and bug fixes by Casey West <casey at geeknest.com>.
+
+C<$Shell::raw> and pod rewrite by Wolfgang Laun.
+
+Rewritten to use closures rather than C<eval "string"> by Adriano Ferreira.
+
+=cut
Copied: trunk/contrib/perl/lib/Shell.t (from rev 6437, vendor/perl/5.18.1/lib/Shell.t)
===================================================================
--- trunk/contrib/perl/lib/Shell.t (rev 0)
+++ trunk/contrib/perl/lib/Shell.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,84 @@
+#!./perl
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+}
+
+use Test::More tests => 7;
+
+BEGIN { use_ok('Shell'); }
+
+my $so = Shell->new;
+ok($so, 'Shell->new');
+
+my $Is_VMS = $^O eq 'VMS';
+my $Is_MSWin32 = $^O eq 'MSWin32';
+my $Is_NetWare = $^O eq 'NetWare';
+
+$Shell::capture_stderr = 1;
+
+# Now test that that works ..
+
+my $tmpfile = 'sht0001';
+while ( -f $tmpfile ) {
+ $tmpfile++;
+}
+END { -f $tmpfile && (open STDERR, '>&SAVERR' and unlink $tmpfile) }
+
+no warnings 'once';
+# no false warning about Name "main::SAVERR" used only once: possible typo
+
+open(SAVERR, ">&STDERR");
+open(STDERR, ">$tmpfile");
+
+xXx_not_there(); # Ok someone could have a program called this :(
+
+# On os2 the warning is on by default...
+ok(($^O eq 'os2' xor !(-s $tmpfile)), '$Shell::capture_stderr');
+
+$Shell::capture_stderr = 0;
+
+# Trying to do two repeated C<ls>s in t in core and expecting the same output
+# is a race condition when tests are running in parallel, and using it as a
+# temporary directory. So go somewhere quieter.
+if ($ENV{PERL_CORE} && -d 'uni') {
+ chdir 'uni';
+ $chdir++;
+}
+
+# someone will have to fill in the blanks for other platforms
+
+if ($Is_VMS) {
+ ok(directory(), 'Execute command');
+ my @files = directory('*.*');
+ ok(@files, 'Quoted arguments');
+
+ ok(eq_array(\@files, [$so->directory('*.*')]), 'object method');
+ eval { $so->directory };
+ ok(!$@, '2 methods calls');
+} elsif ($Is_MSWin32) {
+ ok(dir(), 'Execute command');
+ my @files = dir('*.*');
+ ok(@files, 'Quoted arguments');
+
+ ok(eq_array(\@files, [$so->dir('*.*')]), 'object method');
+ eval { $so->dir };
+ ok(!$@, '2 methods calls');
+} else {
+ ok(ls(), 'Execute command');
+ my @files = ls('*');
+ ok(@files, 'Quoted arguments');
+
+ ok(eq_array(\@files, [$so->ls('*')]), 'object method');
+ eval { $so->ls };
+ ok(!$@, '2 methods calls');
+
+}
+open(STDERR, ">&SAVERR") ;
+
+if ($chdir) {
+ chdir "..";
+}
Copied: trunk/contrib/perl/lib/Switch.pm (from rev 6437, vendor/perl/5.18.1/lib/Switch.pm)
===================================================================
--- trunk/contrib/perl/lib/Switch.pm (rev 0)
+++ trunk/contrib/perl/lib/Switch.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,878 @@
+package Switch;
+
+use strict;
+use vars qw($VERSION);
+use Carp;
+
+$VERSION = '2.14';
+
+
+# LOAD FILTERING MODULE...
+use Filter::Util::Call;
+
+sub __();
+
+# CATCH ATTEMPTS TO CALL case OUTSIDE THE SCOPE OF ANY switch
+
+$::_S_W_I_T_C_H = sub { croak "case/when statement not in switch/given block" };
+
+my $offset;
+my $fallthrough;
+my ($Perl5, $Perl6) = (0,0);
+
+sub import
+{
+ $fallthrough = grep /\bfallthrough\b/, @_;
+ $offset = (caller)[2]+1;
+ filter_add({}) unless @_>1 && $_[1] eq 'noimport';
+ my $pkg = caller;
+ no strict 'refs';
+ for ( qw( on_defined on_exists ) )
+ {
+ *{"${pkg}::$_"} = \&$_;
+ }
+ *{"${pkg}::__"} = \&__ if grep /__/, @_;
+ $Perl6 = 1 if grep(/Perl\s*6/i, @_);
+ $Perl5 = 1 if grep(/Perl\s*5/i, @_) || !grep(/Perl\s*6/i, @_);
+ 1;
+}
+
+sub unimport
+{
+ filter_del()
+}
+
+sub filter
+{
+ my($self) = @_ ;
+ local $Switch::file = (caller)[1];
+
+ my $status = 1;
+ $status = filter_read(1_000_000);
+ return $status if $status<0;
+ $_ = filter_blocks($_,$offset);
+ $_ = "# line $offset\n" . $_ if $offset; undef $offset;
+ return $status;
+}
+
+use Text::Balanced ':ALL';
+
+sub line
+{
+ my ($pretext,$offset) = @_;
+ ($pretext=~tr/\n/\n/)+($offset||0);
+}
+
+sub is_block
+{
+ local $SIG{__WARN__}=sub{die$@};
+ local $^W=1;
+ my $ishash = defined eval 'my $hr='.$_[0];
+ undef $@;
+ return !$ishash;
+}
+
+my $pod_or_DATA = qr/ ^=[A-Za-z] .*? ^=cut (?![A-Za-z]) .*? $
+ | ^__(DATA|END)__\n.*
+ /smx;
+
+my $casecounter = 1;
+sub filter_blocks
+{
+ my ($source, $line) = @_;
+ return $source unless $Perl5 && $source =~ /case|switch/
+ || $Perl6 && $source =~ /when|given|default/;
+ pos $source = 0;
+ my $text = "";
+ component: while (pos $source < length $source)
+ {
+ if ($source =~ m/(\G\s*use\s+Switch\b)/gc)
+ {
+ $text .= q{use Switch 'noimport'};
+ next component;
+ }
+ my @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,0);
+ if (defined $pos[0])
+ {
+ my $pre = substr($source,$pos[0],$pos[1]); # matched prefix
+ my $iEol;
+ if( substr($source,$pos[4],$pos[5]) eq '/' && # 1st delimiter
+ substr($source,$pos[2],$pos[3]) eq '' && # no op like 'm'
+ index( substr($source,$pos[16],$pos[17]), 'x' ) == -1 && # no //x
+ ($iEol = index( $source, "\n", $pos[4] )) > 0 &&
+ $iEol < $pos[8] ){ # embedded newlines
+ # If this is a pattern, it isn't compatible with Switch. Backup past 1st '/'.
+ pos( $source ) = $pos[6];
+ $text .= $pre . substr($source,$pos[2],$pos[6]-$pos[2]);
+ } else {
+ $text .= $pre . substr($source,$pos[2],$pos[18]-$pos[2]);
+ }
+ next component;
+ }
+ if ($source =~ m/(\G\s*$pod_or_DATA)/gc) {
+ $text .= $1;
+ next component;
+ }
+ @pos = Text::Balanced::_match_variable(\$source,qr/\s*/);
+ if (defined $pos[0])
+ {
+ $text .= " " if $pos[0] < $pos[2];
+ $text .= substr($source,$pos[0],$pos[4]-$pos[0]);
+ next component;
+ }
+
+ if ($Perl5 && $source =~ m/\G(\n*)(\s*)(switch)\b(?=\s*[(])/gc
+ || $Perl6 && $source =~ m/\G(\n*)(\s*)(given)\b(?=\s*[(])/gc
+ || $Perl6 && $source =~ m/\G(\n*)(\s*)(given)\b(.*)(?=\{)/gc)
+ {
+ my $keyword = $3;
+ my $arg = $4;
+ $text .= $1.$2.'S_W_I_T_C_H: while (1) ';
+ unless ($arg) {
+ @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\(/,qr/\)/,qr/[[{(<]/,qr/[]})>]/,undef)
+ or do {
+ die "Bad $keyword statement (problem in the parentheses?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
+ };
+ $arg = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
+ }
+ $arg =~ s {^\s*[(]\s*%} { ( \\\%} ||
+ $arg =~ s {^\s*[(]\s*m\b} { ( qr} ||
+ $arg =~ s {^\s*[(]\s*/} { ( qr/} ||
+ $arg =~ s {^\s*[(]\s*qw} { ( \\qw};
+ @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)
+ or do {
+ die "Bad $keyword statement (problem in the code block?) near $Switch::file line ", line(substr($source,0, pos $source), $line), "\n";
+ };
+ my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
+ $code =~ s/{/{ local \$::_S_W_I_T_C_H; Switch::switch $arg;/;
+ $text .= $code . 'continue {last}';
+ next component;
+ }
+ elsif ($Perl5 && $source =~ m/\G(\s*)(case\b)(?!\s*=>)/gc
+ || $Perl6 && $source =~ m/\G(\s*)(when\b)(?!\s*=>)/gc
+ || $Perl6 && $source =~ m/\G(\s*)(default\b)(?=\s*\{)/gc)
+ {
+ my $keyword = $2;
+ $text .= $1 . ($keyword eq "default"
+ ? "if (1)"
+ : "if (Switch::case");
+
+ if ($keyword eq "default") {
+ # Nothing to do
+ }
+ elsif (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)) {
+ my $code = substr($source,$pos[0],$pos[4]-$pos[0]);
+ $text .= " " if $pos[0] < $pos[2];
+ $text .= "sub " if is_block $code;
+ $text .= filter_blocks($code,line(substr($source,0,$pos[0]),$line)) . ")";
+ }
+ elsif (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/[[(]/,qr/[])]/,qr/[[({]/,qr/[])}]/,undef)) {
+ my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
+ $code =~ s {^\s*[(]\s*%} { ( \\\%} ||
+ $code =~ s {^\s*[(]\s*m\b} { ( qr} ||
+ $code =~ s {^\s*[(]\s*/} { ( qr/} ||
+ $code =~ s {^\s*[(]\s*qw} { ( \\qw};
+ $text .= " " if $pos[0] < $pos[2];
+ $text .= "$code)";
+ }
+ elsif ($Perl6 && do{@pos = Text::Balanced::_match_variable(\$source,qr/\s*/)}) {
+ my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
+ $code =~ s {^\s*%} { \%} ||
+ $code =~ s {^\s*@} { \@};
+ $text .= " " if $pos[0] < $pos[2];
+ $text .= "$code)";
+ }
+ elsif ( @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,0)) {
+ my $code = substr($source,$pos[2],$pos[18]-$pos[2]);
+ $code = filter_blocks($code,line(substr($source,0,$pos[2]),$line));
+ $code =~ s {^\s*m} { qr} ||
+ $code =~ s {^\s*/} { qr/} ||
+ $code =~ s {^\s*qw} { \\qw};
+ $text .= " " if $pos[0] < $pos[2];
+ $text .= "$code)";
+ }
+ elsif ($Perl5 && $source =~ m/\G\s*(([^\$\@{])[^\$\@{]*)(?=\s*{)/gc
+ || $Perl6 && $source =~ m/\G\s*([^;{]*)()/gc) {
+ my $code = filter_blocks($1,line(substr($source,0,pos $source),$line));
+ $text .= ' \\' if $2 eq '%';
+ $text .= " $code)";
+ }
+ else {
+ die "Bad $keyword statement (invalid $keyword value?) near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n";
+ }
+
+ die "Missing opening brace or semi-colon after 'when' value near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n"
+ unless !$Perl6 || $source =~ m/\G(\s*)(?=;|\{)/gc;
+
+ do{@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)}
+ or do {
+ if ($source =~ m/\G\s*(?=([};]|\Z))/gc) {
+ $casecounter++;
+ next component;
+ }
+ die "Bad $keyword statement (problem in the code block?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
+ };
+ my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
+ $code =~ s/}(?=\s*\Z)/;last S_W_I_T_C_H }/
+ unless $fallthrough;
+ $text .= "{ while (1) $code continue { goto C_A_S_E_$casecounter } last S_W_I_T_C_H; C_A_S_E_$casecounter: }";
+ $casecounter++;
+ next component;
+ }
+
+ $source =~ m/\G(\s*(-[sm]\s+|\w+|#.*\n|\W))/gc;
+ $text .= $1;
+ }
+ $text;
+}
+
+
+
+sub in
+{
+ my ($x,$y) = @_;
+ my @numy;
+ for my $nextx ( @$x )
+ {
+ my $numx = ref($nextx) || defined $nextx && (~$nextx&$nextx) eq 0;
+ for my $j ( 0..$#$y )
+ {
+ my $nexty = $y->[$j];
+ push @numy, ref($nexty) || defined $nexty && (~$nexty&$nexty) eq 0
+ if @numy <= $j;
+ return 1 if $numx && $numy[$j] && $nextx==$nexty
+ || $nextx eq $nexty;
+
+ }
+ }
+ return "";
+}
+
+sub on_exists
+{
+ my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
+ [ keys %$ref ]
+}
+
+sub on_defined
+{
+ my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
+ [ grep { defined $ref->{$_} } keys %$ref ]
+}
+
+sub switch(;$)
+{
+ my ($s_val) = @_ ? $_[0] : $_;
+ my $s_ref = ref $s_val;
+
+ if ($s_ref eq 'CODE')
+ {
+ $::_S_W_I_T_C_H =
+ sub { my $c_val = $_[0];
+ return $s_val == $c_val if ref $c_val eq 'CODE';
+ return $s_val->(@$c_val) if ref $c_val eq 'ARRAY';
+ return $s_val->($c_val);
+ };
+ }
+ elsif ($s_ref eq "" && defined $s_val && (~$s_val&$s_val) eq 0) # NUMERIC SCALAR
+ {
+ $::_S_W_I_T_C_H =
+ sub { my $c_val = $_[0];
+ my $c_ref = ref $c_val;
+ return $s_val == $c_val if $c_ref eq ""
+ && defined $c_val
+ && (~$c_val&$c_val) eq 0;
+ return $s_val eq $c_val if $c_ref eq "";
+ return in([$s_val],$c_val) if $c_ref eq 'ARRAY';
+ return $c_val->($s_val) if $c_ref eq 'CODE';
+ return $c_val->call($s_val) if $c_ref eq 'Switch';
+ return scalar $s_val=~/$c_val/
+ if $c_ref eq 'Regexp';
+ return scalar $c_val->{$s_val}
+ if $c_ref eq 'HASH';
+ return;
+ };
+ }
+ elsif ($s_ref eq "") # STRING SCALAR
+ {
+ $::_S_W_I_T_C_H =
+ sub { my $c_val = $_[0];
+ my $c_ref = ref $c_val;
+ return $s_val eq $c_val if $c_ref eq "";
+ return in([$s_val],$c_val) if $c_ref eq 'ARRAY';
+ return $c_val->($s_val) if $c_ref eq 'CODE';
+ return $c_val->call($s_val) if $c_ref eq 'Switch';
+ return scalar $s_val=~/$c_val/
+ if $c_ref eq 'Regexp';
+ return scalar $c_val->{$s_val}
+ if $c_ref eq 'HASH';
+ return;
+ };
+ }
+ elsif ($s_ref eq 'ARRAY')
+ {
+ $::_S_W_I_T_C_H =
+ sub { my $c_val = $_[0];
+ my $c_ref = ref $c_val;
+ return in($s_val,[$c_val]) if $c_ref eq "";
+ return in($s_val,$c_val) if $c_ref eq 'ARRAY';
+ return $c_val->(@$s_val) if $c_ref eq 'CODE';
+ return $c_val->call(@$s_val)
+ if $c_ref eq 'Switch';
+ return scalar grep {$_=~/$c_val/} @$s_val
+ if $c_ref eq 'Regexp';
+ return scalar grep {$c_val->{$_}} @$s_val
+ if $c_ref eq 'HASH';
+ return;
+ };
+ }
+ elsif ($s_ref eq 'Regexp')
+ {
+ $::_S_W_I_T_C_H =
+ sub { my $c_val = $_[0];
+ my $c_ref = ref $c_val;
+ return $c_val=~/s_val/ if $c_ref eq "";
+ return scalar grep {$_=~/s_val/} @$c_val
+ if $c_ref eq 'ARRAY';
+ return $c_val->($s_val) if $c_ref eq 'CODE';
+ return $c_val->call($s_val) if $c_ref eq 'Switch';
+ return $s_val eq $c_val if $c_ref eq 'Regexp';
+ return grep {$_=~/$s_val/ && $c_val->{$_}} keys %$c_val
+ if $c_ref eq 'HASH';
+ return;
+ };
+ }
+ elsif ($s_ref eq 'HASH')
+ {
+ $::_S_W_I_T_C_H =
+ sub { my $c_val = $_[0];
+ my $c_ref = ref $c_val;
+ return $s_val->{$c_val} if $c_ref eq "";
+ return scalar grep {$s_val->{$_}} @$c_val
+ if $c_ref eq 'ARRAY';
+ return $c_val->($s_val) if $c_ref eq 'CODE';
+ return $c_val->call($s_val) if $c_ref eq 'Switch';
+ return grep {$_=~/$c_val/ && $s_val->{"$_"}} keys %$s_val
+ if $c_ref eq 'Regexp';
+ return $s_val==$c_val if $c_ref eq 'HASH';
+ return;
+ };
+ }
+ elsif ($s_ref eq 'Switch')
+ {
+ $::_S_W_I_T_C_H =
+ sub { my $c_val = $_[0];
+ return $s_val == $c_val if ref $c_val eq 'Switch';
+ return $s_val->call(@$c_val)
+ if ref $c_val eq 'ARRAY';
+ return $s_val->call($c_val);
+ };
+ }
+ else
+ {
+ croak "Cannot switch on $s_ref";
+ }
+ return 1;
+}
+
+sub case($) { local $SIG{__WARN__} = \&carp;
+ $::_S_W_I_T_C_H->(@_); }
+
+# IMPLEMENT __
+
+my $placeholder = bless { arity=>1, impl=>sub{$_[1+$_[0]]} };
+
+sub __() { $placeholder }
+
+sub __arg($)
+{
+ my $index = $_[0]+1;
+ bless { arity=>0, impl=>sub{$_[$index]} };
+}
+
+sub hosub(&@)
+{
+ # WRITE THIS
+}
+
+sub call
+{
+ my ($self, at args) = @_;
+ return $self->{impl}->(0, at args);
+}
+
+sub meta_bop(&)
+{
+ my ($op) = @_;
+ sub
+ {
+ my ($left, $right, $reversed) = @_;
+ ($right,$left) = @_ if $reversed;
+
+ my $rop = ref $right eq 'Switch'
+ ? $right
+ : bless { arity=>0, impl=>sub{$right} };
+
+ my $lop = ref $left eq 'Switch'
+ ? $left
+ : bless { arity=>0, impl=>sub{$left} };
+
+ my $arity = $lop->{arity} + $rop->{arity};
+
+ return bless {
+ arity => $arity,
+ impl => sub { my $start = shift;
+ return $op->($lop->{impl}->($start, at _),
+ $rop->{impl}->($start+$lop->{arity}, at _));
+ }
+ };
+ };
+}
+
+sub meta_uop(&)
+{
+ my ($op) = @_;
+ sub
+ {
+ my ($left) = @_;
+
+ my $lop = ref $left eq 'Switch'
+ ? $left
+ : bless { arity=>0, impl=>sub{$left} };
+
+ my $arity = $lop->{arity};
+
+ return bless {
+ arity => $arity,
+ impl => sub { $op->($lop->{impl}->(@_)) }
+ };
+ };
+}
+
+
+use overload
+ "+" => meta_bop {$_[0] + $_[1]},
+ "-" => meta_bop {$_[0] - $_[1]},
+ "*" => meta_bop {$_[0] * $_[1]},
+ "/" => meta_bop {$_[0] / $_[1]},
+ "%" => meta_bop {$_[0] % $_[1]},
+ "**" => meta_bop {$_[0] ** $_[1]},
+ "<<" => meta_bop {$_[0] << $_[1]},
+ ">>" => meta_bop {$_[0] >> $_[1]},
+ "x" => meta_bop {$_[0] x $_[1]},
+ "." => meta_bop {$_[0] . $_[1]},
+ "<" => meta_bop {$_[0] < $_[1]},
+ "<=" => meta_bop {$_[0] <= $_[1]},
+ ">" => meta_bop {$_[0] > $_[1]},
+ ">=" => meta_bop {$_[0] >= $_[1]},
+ "==" => meta_bop {$_[0] == $_[1]},
+ "!=" => meta_bop {$_[0] != $_[1]},
+ "<=>" => meta_bop {$_[0] <=> $_[1]},
+ "lt" => meta_bop {$_[0] lt $_[1]},
+ "le" => meta_bop {$_[0] le $_[1]},
+ "gt" => meta_bop {$_[0] gt $_[1]},
+ "ge" => meta_bop {$_[0] ge $_[1]},
+ "eq" => meta_bop {$_[0] eq $_[1]},
+ "ne" => meta_bop {$_[0] ne $_[1]},
+ "cmp" => meta_bop {$_[0] cmp $_[1]},
+ "\&" => meta_bop {$_[0] & $_[1]},
+ "^" => meta_bop {$_[0] ^ $_[1]},
+ "|" => meta_bop {$_[0] | $_[1]},
+ "atan2" => meta_bop {atan2 $_[0], $_[1]},
+
+ "neg" => meta_uop {-$_[0]},
+ "!" => meta_uop {!$_[0]},
+ "~" => meta_uop {~$_[0]},
+ "cos" => meta_uop {cos $_[0]},
+ "sin" => meta_uop {sin $_[0]},
+ "exp" => meta_uop {exp $_[0]},
+ "abs" => meta_uop {abs $_[0]},
+ "log" => meta_uop {log $_[0]},
+ "sqrt" => meta_uop {sqrt $_[0]},
+ "bool" => sub { croak "Can't use && or || in expression containing __" },
+
+ # "&()" => sub { $_[0]->{impl} },
+
+ # "||" => meta_bop {$_[0] || $_[1]},
+ # "&&" => meta_bop {$_[0] && $_[1]},
+ # fallback => 1,
+ ;
+1;
+
+__END__
+
+
+=head1 NAME
+
+Switch - A switch statement for Perl
+
+=head1 VERSION
+
+This document describes version 2.14 of Switch,
+released Dec 29, 2008.
+
+=head1 SYNOPSIS
+
+ use Switch;
+
+ switch ($val) {
+ case 1 { print "number 1" }
+ case "a" { print "string a" }
+ case [1..10,42] { print "number in list" }
+ case (\@array) { print "number in list" }
+ case /\w+/ { print "pattern" }
+ case qr/\w+/ { print "pattern" }
+ case (\%hash) { print "entry in hash" }
+ case (\&sub) { print "arg to subroutine" }
+ else { print "previous case not true" }
+ }
+
+=head1 BACKGROUND
+
+[Skip ahead to L<"DESCRIPTION"> if you don't care about the whys
+and wherefores of this control structure]
+
+In seeking to devise a "Swiss Army" case mechanism suitable for Perl,
+it is useful to generalize this notion of distributed conditional
+testing as far as possible. Specifically, the concept of "matching"
+between the switch value and the various case values need not be
+restricted to numeric (or string or referential) equality, as it is in other
+languages. Indeed, as Table 1 illustrates, Perl
+offers at least eighteen different ways in which two values could
+generate a match.
+
+ Table 1: Matching a switch value ($s) with a case value ($c)
+
+ Switch Case Type of Match Implied Matching Code
+ Value Value
+ ====== ===== ===================== =============
+
+ number same numeric or referential match if $s == $c;
+ or ref equality
+
+ object method result of method call match if $s->$c();
+ ref name match if defined $s->$c();
+ or ref
+
+ other other string equality match if $s eq $c;
+ non-ref non-ref
+ scalar scalar
+
+ string regexp pattern match match if $s =~ /$c/;
+
+ array scalar array entry existence match if 0<=$c && $c<@$s;
+ ref array entry definition match if defined $s->[$c];
+ array entry truth match if $s->[$c];
+
+ array array array intersection match if intersects(@$s, @$c);
+ ref ref (apply this table to
+ all pairs of elements
+ $s->[$i] and
+ $c->[$j])
+
+ array regexp array grep match if grep /$c/, @$s;
+ ref
+
+ hash scalar hash entry existence match if exists $s->{$c};
+ ref hash entry definition match if defined $s->{$c};
+ hash entry truth match if $s->{$c};
+
+ hash regexp hash grep match if grep /$c/, keys %$s;
+ ref
+
+ sub scalar return value defn match if defined $s->($c);
+ ref return value truth match if $s->($c);
+
+ sub array return value defn match if defined $s->(@$c);
+ ref ref return value truth match if $s->(@$c);
+
+
+In reality, Table 1 covers 31 alternatives, because only the equality and
+intersection tests are commutative; in all other cases, the roles of
+the C<$s> and C<$c> variables could be reversed to produce a
+different test. For example, instead of testing a single hash for
+the existence of a series of keys (C<match if exists $s-E<gt>{$c}>),
+one could test for the existence of a single key in a series of hashes
+(C<match if exists $c-E<gt>{$s}>).
+
+=head1 DESCRIPTION
+
+The Switch.pm module implements a generalized case mechanism that covers
+most (but not all) of the numerous possible combinations of switch and case
+values described above.
+
+The module augments the standard Perl syntax with two new control
+statements: C<switch> and C<case>. The C<switch> statement takes a
+single scalar argument of any type, specified in parentheses.
+C<switch> stores this value as the
+current switch value in a (localized) control variable.
+The value is followed by a block which may contain one or more
+Perl statements (including the C<case> statement described below).
+The block is unconditionally executed once the switch value has
+been cached.
+
+A C<case> statement takes a single scalar argument (in mandatory
+parentheses if it's a variable; otherwise the parens are optional) and
+selects the appropriate type of matching between that argument and the
+current switch value. The type of matching used is determined by the
+respective types of the switch value and the C<case> argument, as
+specified in Table 1. If the match is successful, the mandatory
+block associated with the C<case> statement is executed.
+
+In most other respects, the C<case> statement is semantically identical
+to an C<if> statement. For example, it can be followed by an C<else>
+clause, and can be used as a postfix statement qualifier.
+
+However, when a C<case> block has been executed control is automatically
+transferred to the statement after the immediately enclosing C<switch>
+block, rather than to the next statement within the block. In other
+words, the success of any C<case> statement prevents other cases in the
+same scope from executing. But see L<"Allowing fall-through"> below.
+
+Together these two new statements provide a fully generalized case
+mechanism:
+
+ use Switch;
+
+ # AND LATER...
+
+ %special = ( woohoo => 1, d'oh => 1 );
+
+ while (<>) {
+ chomp;
+ switch ($_) {
+ case (%special) { print "homer\n"; } # if $special{$_}
+ case /[a-z]/i { print "alpha\n"; } # if $_ =~ /a-z/i
+ case [1..9] { print "small num\n"; } # if $_ in [1..9]
+ case { $_[0] >= 10 } { print "big num\n"; } # if $_ >= 10
+ print "must be punctuation\n" case /\W/; # if $_ ~= /\W/
+ }
+ }
+
+Note that C<switch>es can be nested within C<case> (or any other) blocks,
+and a series of C<case> statements can try different types of matches
+-- hash membership, pattern match, array intersection, simple equality,
+etc. -- against the same switch value.
+
+The use of intersection tests against an array reference is particularly
+useful for aggregating integral cases:
+
+ sub classify_digit
+ {
+ switch ($_[0]) { case 0 { return 'zero' }
+ case [2,4,6,8] { return 'even' }
+ case [1,3,5,7,9] { return 'odd' }
+ case /[A-F]/i { return 'hex' }
+ }
+ }
+
+
+=head2 Allowing fall-through
+
+Fall-though (trying another case after one has already succeeded)
+is usually a Bad Idea in a switch statement. However, this
+is Perl, not a police state, so there I<is> a way to do it, if you must.
+
+If a C<case> block executes an untargeted C<next>, control is
+immediately transferred to the statement I<after> the C<case> statement
+(i.e. usually another case), rather than out of the surrounding
+C<switch> block.
+
+For example:
+
+ switch ($val) {
+ case 1 { handle_num_1(); next } # and try next case...
+ case "1" { handle_str_1(); next } # and try next case...
+ case [0..9] { handle_num_any(); } # and we're done
+ case /\d/ { handle_dig_any(); next } # and try next case...
+ case /.*/ { handle_str_any(); next } # and try next case...
+ }
+
+If $val held the number C<1>, the above C<switch> block would call the
+first three C<handle_...> subroutines, jumping to the next case test
+each time it encountered a C<next>. After the third C<case> block
+was executed, control would jump to the end of the enclosing
+C<switch> block.
+
+On the other hand, if $val held C<10>, then only the last two C<handle_...>
+subroutines would be called.
+
+Note that this mechanism allows the notion of I<conditional fall-through>.
+For example:
+
+ switch ($val) {
+ case [0..9] { handle_num_any(); next if $val < 7; }
+ case /\d/ { handle_dig_any(); }
+ }
+
+If an untargeted C<last> statement is executed in a case block, this
+immediately transfers control out of the enclosing C<switch> block
+(in other words, there is an implicit C<last> at the end of each
+normal C<case> block). Thus the previous example could also have been
+written:
+
+ switch ($val) {
+ case [0..9] { handle_num_any(); last if $val >= 7; next; }
+ case /\d/ { handle_dig_any(); }
+ }
+
+
+=head2 Automating fall-through
+
+In situations where case fall-through should be the norm, rather than an
+exception, an endless succession of terminal C<next>s is tedious and ugly.
+Hence, it is possible to reverse the default behaviour by specifying
+the string "fallthrough" when importing the module. For example, the
+following code is equivalent to the first example in L<"Allowing fall-through">:
+
+ use Switch 'fallthrough';
+
+ switch ($val) {
+ case 1 { handle_num_1(); }
+ case "1" { handle_str_1(); }
+ case [0..9] { handle_num_any(); last }
+ case /\d/ { handle_dig_any(); }
+ case /.*/ { handle_str_any(); }
+ }
+
+Note the explicit use of a C<last> to preserve the non-fall-through
+behaviour of the third case.
+
+
+
+=head2 Alternative syntax
+
+Perl 6 will provide a built-in switch statement with essentially the
+same semantics as those offered by Switch.pm, but with a different
+pair of keywords. In Perl 6 C<switch> will be spelled C<given>, and
+C<case> will be pronounced C<when>. In addition, the C<when> statement
+will not require switch or case values to be parenthesized.
+
+This future syntax is also (largely) available via the Switch.pm module, by
+importing it with the argument C<"Perl6">. For example:
+
+ use Switch 'Perl6';
+
+ given ($val) {
+ when 1 { handle_num_1(); }
+ when ($str1) { handle_str_1(); }
+ when [0..9] { handle_num_any(); last }
+ when /\d/ { handle_dig_any(); }
+ when /.*/ { handle_str_any(); }
+ default { handle anything else; }
+ }
+
+Note that scalars still need to be parenthesized, since they would be
+ambiguous in Perl 5.
+
+Note too that you can mix and match both syntaxes by importing the module
+with:
+
+ use Switch 'Perl5', 'Perl6';
+
+
+=head2 Higher-order Operations
+
+One situation in which C<switch> and C<case> do not provide a good
+substitute for a cascaded C<if>, is where a switch value needs to
+be tested against a series of conditions. For example:
+
+ sub beverage {
+ switch (shift) {
+ case { $_[0] < 10 } { return 'milk' }
+ case { $_[0] < 20 } { return 'coke' }
+ case { $_[0] < 30 } { return 'beer' }
+ case { $_[0] < 40 } { return 'wine' }
+ case { $_[0] < 50 } { return 'malt' }
+ case { $_[0] < 60 } { return 'Moet' }
+ else { return 'milk' }
+ }
+ }
+
+(This is equivalent to writing C<case (sub { $_[0] < 10 })>, etc.; C<$_[0]>
+is the argument to the anonymous subroutine.)
+
+The need to specify each condition as a subroutine block is tiresome. To
+overcome this, when importing Switch.pm, a special "placeholder"
+subroutine named C<__> [sic] may also be imported. This subroutine
+converts (almost) any expression in which it appears to a reference to a
+higher-order function. That is, the expression:
+
+ use Switch '__';
+
+ __ < 2
+
+is equivalent to:
+
+ sub { $_[0] < 2 }
+
+With C<__>, the previous ugly case statements can be rewritten:
+
+ case __ < 10 { return 'milk' }
+ case __ < 20 { return 'coke' }
+ case __ < 30 { return 'beer' }
+ case __ < 40 { return 'wine' }
+ case __ < 50 { return 'malt' }
+ case __ < 60 { return 'Moet' }
+ else { return 'milk' }
+
+The C<__> subroutine makes extensive use of operator overloading to
+perform its magic. All operations involving __ are overloaded to
+produce an anonymous subroutine that implements a lazy version
+of the original operation.
+
+The only problem is that operator overloading does not allow the
+boolean operators C<&&> and C<||> to be overloaded. So a case statement
+like this:
+
+ case 0 <= __ && __ < 10 { return 'digit' }
+
+doesn't act as expected, because when it is
+executed, it constructs two higher order subroutines
+and then treats the two resulting references as arguments to C<&&>:
+
+ sub { 0 <= $_[0] } && sub { $_[0] < 10 }
+
+This boolean expression is inevitably true, since both references are
+non-false. Fortunately, the overloaded C<'bool'> operator catches this
+situation and flags it as an error.
+
+=head1 DEPENDENCIES
+
+The module is implemented using Filter::Util::Call and Text::Balanced
+and requires both these modules to be installed.
+
+=head1 AUTHOR
+
+Damian Conway (damian at conway.org). This module is now maintained by Rafael
+Garcia-Suarez (rgarciasuarez at gmail.com) and more generally by the Perl 5
+Porters (perl5-porters at perl.org), as part of the Perl core.
+
+=head1 BUGS
+
+There are undoubtedly serious bugs lurking somewhere in code this funky :-)
+Bug reports and other feedback are most welcome.
+
+=head1 LIMITATIONS
+
+Due to the heuristic nature of Switch.pm's source parsing, the presence of
+regexes with embedded newlines that are specified with raw C</.../>
+delimiters and don't have a modifier C<//x> are indistinguishable from
+code chunks beginning with the division operator C</>. As a workaround
+you must use C<m/.../> or C<m?...?> for such patterns. Also, the presence
+of regexes specified with raw C<?...?> delimiters may cause mysterious
+errors. The workaround is to use C<m?...?> instead.
+
+Due to the way source filters work in Perl, you can't use Switch inside
+an string C<eval>.
+
+If your source file is longer then 1 million characters and you have a
+switch statement that crosses the 1 million (or 2 million, etc.)
+character boundary you will get mysterious errors. The workaround is to
+use smaller source files.
+
+=head1 COPYRIGHT
+
+ Copyright (c) 1997-2008, Damian Conway. All Rights Reserved.
+ This module is free software. It may be used, redistributed
+ and/or modified under the same terms as Perl itself.
Index: trunk/contrib/perl/lib/Symbol.pm
===================================================================
--- trunk/contrib/perl/lib/Symbol.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Symbol.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Symbol.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/Symbol.t
===================================================================
--- trunk/contrib/perl/lib/Symbol.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Symbol.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Symbol.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/lib/Term/ANSIColor.pm (from rev 6437, vendor/perl/5.18.1/lib/Term/ANSIColor.pm)
===================================================================
--- trunk/contrib/perl/lib/Term/ANSIColor.pm (rev 0)
+++ trunk/contrib/perl/lib/Term/ANSIColor.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,565 @@
+# Term::ANSIColor -- Color screen output using ANSI escape sequences.
+#
+# Copyright 1996, 1997, 1998, 2000, 2001, 2002, 2005, 2006, 2008, 2009
+# Russ Allbery <rra at stanford.edu> and Zenin
+# PUSH/POP support submitted 2007 by openmethods.com voice solutions
+#
+# This program is free software; you may redistribute it and/or modify it
+# under the same terms as Perl itself.
+#
+# Ah, September, when the sysadmins turn colors and fall off the trees....
+# -- Dave Van Domelen
+
+##############################################################################
+# Modules and declarations
+##############################################################################
+
+package Term::ANSIColor;
+require 5.001;
+
+$VERSION = '2.00';
+
+use strict;
+use vars qw($AUTOLOAD $AUTOLOCAL $AUTORESET @COLORLIST @COLORSTACK $EACHLINE
+ @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION %ATTRIBUTES
+ %ATTRIBUTES_R);
+
+use Exporter ();
+BEGIN {
+ @COLORLIST = qw(CLEAR RESET BOLD DARK UNDERLINE UNDERSCORE BLINK REVERSE
+ CONCEALED BLACK RED GREEN YELLOW BLUE MAGENTA CYAN WHITE
+ ON_BLACK ON_RED ON_GREEN ON_YELLOW ON_BLUE ON_MAGENTA
+ ON_CYAN ON_WHITE);
+ @ISA = qw(Exporter);
+ @EXPORT = qw(color colored);
+ @EXPORT_OK = qw(uncolor);
+ %EXPORT_TAGS = (constants => \@COLORLIST,
+ pushpop => [ @COLORLIST,
+ qw(PUSHCOLOR POPCOLOR LOCALCOLOR) ]);
+ Exporter::export_ok_tags ('pushpop');
+}
+
+##############################################################################
+# Internal data structures
+##############################################################################
+
+%ATTRIBUTES = ('clear' => 0,
+ 'reset' => 0,
+ 'bold' => 1,
+ 'dark' => 2,
+ 'faint' => 2,
+ 'underline' => 4,
+ 'underscore' => 4,
+ 'blink' => 5,
+ 'reverse' => 7,
+ 'concealed' => 8,
+
+ 'black' => 30, 'on_black' => 40,
+ 'red' => 31, 'on_red' => 41,
+ 'green' => 32, 'on_green' => 42,
+ 'yellow' => 33, 'on_yellow' => 43,
+ 'blue' => 34, 'on_blue' => 44,
+ 'magenta' => 35, 'on_magenta' => 45,
+ 'cyan' => 36, 'on_cyan' => 46,
+ 'white' => 37, 'on_white' => 47);
+
+# Reverse lookup. Alphabetically first name for a sequence is preferred.
+for (reverse sort keys %ATTRIBUTES) {
+ $ATTRIBUTES_R{$ATTRIBUTES{$_}} = $_;
+}
+
+##############################################################################
+# Implementation (constant form)
+##############################################################################
+
+# Time to have fun! We now want to define the constant subs, which are named
+# the same as the attributes above but in all caps. Each constant sub needs
+# to act differently depending on whether $AUTORESET is set. Without
+# autoreset:
+#
+# BLUE "text\n" ==> "\e[34mtext\n"
+#
+# If $AUTORESET is set, we should instead get:
+#
+# BLUE "text\n" ==> "\e[34mtext\n\e[0m"
+#
+# The sub also needs to handle the case where it has no arguments correctly.
+# Maintaining all of this as separate subs would be a major nightmare, as well
+# as duplicate the %ATTRIBUTES hash, so instead we define an AUTOLOAD sub to
+# define the constant subs on demand. To do that, we check the name of the
+# called sub against the list of attributes, and if it's an all-caps version
+# of one of them, we define the sub on the fly and then run it.
+#
+# If the environment variable ANSI_COLORS_DISABLED is set, just return the
+# arguments without adding any escape sequences. This is to make it easier to
+# write scripts that also work on systems without any ANSI support, like
+# Windows consoles.
+sub AUTOLOAD {
+ if (defined $ENV{ANSI_COLORS_DISABLED}) {
+ return join ('', @_);
+ }
+ my $sub;
+ ($sub = $AUTOLOAD) =~ s/^.*:://;
+ my $attr = $ATTRIBUTES{lc $sub};
+ if ($sub =~ /^[A-Z_]+$/ && defined $attr) {
+ $attr = "\e[" . $attr . 'm';
+ eval qq {
+ sub $AUTOLOAD {
+ if (\$AUTORESET && \@_) {
+ return '$attr' . join ('', \@_) . "\e[0m";
+ } elsif (\$AUTOLOCAL && \@_) {
+ return PUSHCOLOR ('$attr') . join ('', \@_) . POPCOLOR;
+ } else {
+ return '$attr' . join ('', \@_);
+ }
+ }
+ };
+ goto &$AUTOLOAD;
+ } else {
+ require Carp;
+ Carp::croak ("undefined subroutine &$AUTOLOAD called");
+ }
+}
+
+# Append a new color to the top of the color stack and return the top of
+# the stack.
+sub PUSHCOLOR {
+ my ($text) = @_;
+ my ($color) = ($text =~ m/^((?:\e\[[\d;]+m)+)/);
+ if (@COLORSTACK) {
+ $color = $COLORSTACK[-1] . $color;
+ }
+ push (@COLORSTACK, $color);
+ return $text;
+}
+
+# Pop the color stack and return the new top of the stack (or reset, if
+# the stack is empty).
+sub POPCOLOR {
+ pop @COLORSTACK;
+ if (@COLORSTACK) {
+ return $COLORSTACK[-1] . join ('', @_);
+ } else {
+ return RESET (@_);
+ }
+}
+
+# Surround arguments with a push and a pop.
+sub LOCALCOLOR {
+ return PUSHCOLOR (join ('', @_)) . POPCOLOR ();
+}
+
+##############################################################################
+# Implementation (attribute string form)
+##############################################################################
+
+# Return the escape code for a given set of color attributes.
+sub color {
+ return '' if defined $ENV{ANSI_COLORS_DISABLED};
+ my @codes = map { split } @_;
+ my $attribute = '';
+ foreach (@codes) {
+ $_ = lc $_;
+ unless (defined $ATTRIBUTES{$_}) {
+ require Carp;
+ Carp::croak ("Invalid attribute name $_");
+ }
+ $attribute .= $ATTRIBUTES{$_} . ';';
+ }
+ chop $attribute;
+ return ($attribute ne '') ? "\e[${attribute}m" : undef;
+}
+
+# Return a list of named color attributes for a given set of escape codes.
+# Escape sequences can be given with or without enclosing "\e[" and "m". The
+# empty escape sequence '' or "\e[m" gives an empty list of attrs.
+sub uncolor {
+ my (@nums, @result);
+ for (@_) {
+ my $escape = $_;
+ $escape =~ s/^\e\[//;
+ $escape =~ s/m$//;
+ unless ($escape =~ /^((?:\d+;)*\d*)$/) {
+ require Carp;
+ Carp::croak ("Bad escape sequence $_");
+ }
+ push (@nums, split (/;/, $1));
+ }
+ for (@nums) {
+ $_ += 0; # Strip leading zeroes
+ my $name = $ATTRIBUTES_R{$_};
+ if (!defined $name) {
+ require Carp;
+ Carp::croak ("No name for escape sequence $_" );
+ }
+ push (@result, $name);
+ }
+ return @result;
+}
+
+# Given a string and a set of attributes, returns the string surrounded by
+# escape codes to set those attributes and then clear them at the end of the
+# string. The attributes can be given either as an array ref as the first
+# argument or as a list as the second and subsequent arguments. If $EACHLINE
+# is set, insert a reset before each occurrence of the string $EACHLINE and
+# the starting attribute code after the string $EACHLINE, so that no attribute
+# crosses line delimiters (this is often desirable if the output is to be
+# piped to a pager or some other program).
+sub colored {
+ my ($string, @codes);
+ if (ref $_[0]) {
+ @codes = @{+shift};
+ $string = join ('', @_);
+ } else {
+ $string = shift;
+ @codes = @_;
+ }
+ return $string if defined $ENV{ANSI_COLORS_DISABLED};
+ if (defined $EACHLINE) {
+ my $attr = color (@codes);
+ return join '',
+ map { ($_ ne $EACHLINE) ? $attr . $_ . "\e[0m" : $_ }
+ grep { length ($_) > 0 }
+ split (/(\Q$EACHLINE\E)/, $string);
+ } else {
+ return color (@codes) . $string . "\e[0m";
+ }
+}
+
+##############################################################################
+# Module return value and documentation
+##############################################################################
+
+# Ensure we evaluate to true.
+1;
+__END__
+
+=head1 NAME
+
+Term::ANSIColor - Color screen output using ANSI escape sequences
+
+=for stopwords
+cyan colorize namespace runtime TMTOWTDI cmd.exe 4nt.exe command.com NT
+ESC Delvare SSH OpenSSH aixterm ECMA-048 Fraktur overlining Zenin
+reimplemented Allbery PUSHCOLOR POPCOLOR LOCALCOLOR openmethods.com
+
+=head1 SYNOPSIS
+
+ use Term::ANSIColor;
+ print color 'bold blue';
+ print "This text is bold blue.\n";
+ print color 'reset';
+ print "This text is normal.\n";
+ print colored ("Yellow on magenta.", 'yellow on_magenta'), "\n";
+ print "This text is normal.\n";
+ print colored ['yellow on_magenta'], 'Yellow on magenta.';
+ print "\n";
+
+ use Term::ANSIColor qw(uncolor);
+ print uncolor '01;31', "\n";
+
+ use Term::ANSIColor qw(:constants);
+ print BOLD, BLUE, "This text is in bold blue.\n", RESET;
+
+ use Term::ANSIColor qw(:constants);
+ {
+ local $Term::ANSIColor::AUTORESET = 1;
+ print BOLD BLUE "This text is in bold blue.\n";
+ print "This text is normal.\n";
+ }
+
+ use Term::ANSIColor qw(:pushpop);
+ print PUSHCOLOR RED ON_GREEN "This text is red on green.\n";
+ print PUSHCOLOR BLUE "This text is blue on green.\n";
+ print RESET BLUE "This text is just blue.\n";
+ print POPCOLOR "Back to red on green.\n";
+ print LOCALCOLOR GREEN ON_BLUE "This text is green on blue.\n";
+ print "This text is red on green.\n";
+ {
+ local $Term::ANSIColor::AUTOLOCAL = 1;
+ print ON_BLUE "This text is red on blue.\n";
+ print "This text is red on green.\n";
+ }
+ print POPCOLOR "Back to whatever we started as.\n";
+
+=head1 DESCRIPTION
+
+This module has two interfaces, one through color() and colored() and the
+other through constants. It also offers the utility function uncolor(),
+which has to be explicitly imported to be used (see L</SYNOPSIS>).
+
+color() takes any number of strings as arguments and considers them to be
+space-separated lists of attributes. It then forms and returns the escape
+sequence to set those attributes. It doesn't print it out, just returns
+it, so you'll have to print it yourself if you want to (this is so that
+you can save it as a string, pass it to something else, send it to a file
+handle, or do anything else with it that you might care to).
+
+uncolor() performs the opposite translation, turning escape sequences
+into a list of strings.
+
+The recognized non-color attributes are clear, reset, bold, dark, faint,
+underline, underscore, blink, reverse, and concealed. Clear and reset
+(reset to default attributes), dark and faint (dim and saturated), and
+underline and underscore are equivalent, so use whichever is the most
+intuitive to you. The recognized foreground color attributes are black,
+red, green, yellow, blue, magenta, cyan, and white. The recognized
+background color attributes are on_black, on_red, on_green, on_yellow,
+on_blue, on_magenta, on_cyan, and on_white. Case is not significant.
+
+Note that not all attributes are supported by all terminal types, and some
+terminals may not support any of these sequences. Dark and faint, blink,
+and concealed in particular are frequently not implemented.
+
+Attributes, once set, last until they are unset (by sending the attribute
+C<clear> or C<reset>). Be careful to do this, or otherwise your attribute
+will last after your script is done running, and people get very annoyed
+at having their prompt and typing changed to weird colors.
+
+As an aid to help with this, colored() takes a scalar as the first
+argument and any number of attribute strings as the second argument and
+returns the scalar wrapped in escape codes so that the attributes will be
+set as requested before the string and reset to normal after the string.
+Alternately, you can pass a reference to an array as the first argument,
+and then the contents of that array will be taken as attributes and color
+codes and the remainder of the arguments as text to colorize.
+
+Normally, colored() just puts attribute codes at the beginning and end of
+the string, but if you set $Term::ANSIColor::EACHLINE to some string, that
+string will be considered the line delimiter and the attribute will be set
+at the beginning of each line of the passed string and reset at the end of
+each line. This is often desirable if the output contains newlines and
+you're using background colors, since a background color that persists
+across a newline is often interpreted by the terminal as providing the
+default background color for the next line. Programs like pagers can also
+be confused by attributes that span lines. Normally you'll want to set
+$Term::ANSIColor::EACHLINE to C<"\n"> to use this feature.
+
+Alternately, if you import C<:constants>, you can use the constants CLEAR,
+RESET, BOLD, DARK, UNDERLINE, UNDERSCORE, BLINK, REVERSE, CONCEALED,
+BLACK, RED, GREEN, YELLOW, BLUE, MAGENTA, CYAN, WHITE, ON_BLACK, ON_RED,
+ON_GREEN, ON_YELLOW, ON_BLUE, ON_MAGENTA, ON_CYAN, and ON_WHITE directly.
+These are the same as color('attribute') and can be used if you prefer
+typing:
+
+ print BOLD BLUE ON_WHITE "Text", RESET, "\n";
+
+to
+
+ print colored ("Text", 'bold blue on_white'), "\n";
+
+(Note that the newline is kept separate to avoid confusing the terminal as
+described above since a background color is being used.)
+
+When using the constants, if you don't want to have to remember to add the
+C<, RESET> at the end of each print line, you can set
+$Term::ANSIColor::AUTORESET to a true value. Then, the display mode will
+automatically be reset if there is no comma after the constant. In other
+words, with that variable set:
+
+ print BOLD BLUE "Text\n";
+
+will reset the display mode afterward, whereas:
+
+ print BOLD, BLUE, "Text\n";
+
+will not. If you are using background colors, you will probably want to
+print the newline with a separate print statement to avoid confusing the
+terminal.
+
+The subroutine interface has the advantage over the constants interface in
+that only two subroutines are exported into your namespace, versus
+twenty-two in the constants interface. On the flip side, the constants
+interface has the advantage of better compile time error checking, since
+misspelled names of colors or attributes in calls to color() and colored()
+won't be caught until runtime whereas misspelled names of constants will
+be caught at compile time. So, pollute your namespace with almost two
+dozen subroutines that you may not even use that often, or risk a silly
+bug by mistyping an attribute. Your choice, TMTOWTDI after all.
+
+As of Term::ANSIColor 2.0, you can import C<:pushpop> and maintain a stack
+of colors using PUSHCOLOR, POPCOLOR, and LOCALCOLOR. PUSHCOLOR takes the
+attribute string that starts its argument and pushes it onto a stack of
+attributes. POPCOLOR removes the top of the stack and restores the
+previous attributes set by the argument of a prior PUSHCOLOR. LOCALCOLOR
+surrounds its argument in a PUSHCOLOR and POPCOLOR so that the color
+resets afterward.
+
+When using PUSHCOLOR, POPCOLOR, and LOCALCOLOR, it's particularly
+important to not put commas between the constants.
+
+ print PUSHCOLOR BLUE "Text\n";
+
+will correctly push BLUE onto the top of the stack.
+
+ print PUSHCOLOR, BLUE, "Text\n"; # wrong!
+
+will not, and a subsequent pop won't restore the correct attributes.
+PUSHCOLOR pushes the attributes set by its argument, which is normally a
+string of color constants. It can't ask the terminal what the current
+attributes are.
+
+=head1 DIAGNOSTICS
+
+=over 4
+
+=item Bad escape sequence %s
+
+(F) You passed an invalid ANSI escape sequence to uncolor().
+
+=item Bareword "%s" not allowed while "strict subs" in use
+
+(F) You probably mistyped a constant color name such as:
+
+ $Foobar = FOOBAR . "This line should be blue\n";
+
+or:
+
+ @Foobar = FOOBAR, "This line should be blue\n";
+
+This will only show up under use strict (another good reason to run under
+use strict).
+
+=item Invalid attribute name %s
+
+(F) You passed an invalid attribute name to either color() or colored().
+
+=item Name "%s" used only once: possible typo
+
+(W) You probably mistyped a constant color name such as:
+
+ print FOOBAR "This text is color FOOBAR\n";
+
+It's probably better to always use commas after constant names in order to
+force the next error.
+
+=item No comma allowed after filehandle
+
+(F) You probably mistyped a constant color name such as:
+
+ print FOOBAR, "This text is color FOOBAR\n";
+
+Generating this fatal compile error is one of the main advantages of using
+the constants interface, since you'll immediately know if you mistype a
+color name.
+
+=item No name for escape sequence %s
+
+(F) The ANSI escape sequence passed to uncolor() contains escapes which
+aren't recognized and can't be translated to names.
+
+=back
+
+=head1 ENVIRONMENT
+
+=over 4
+
+=item ANSI_COLORS_DISABLED
+
+If this environment variable is set, all of the functions defined by this
+module (color(), colored(), and all of the constants not previously used
+in the program) will not output any escape sequences and instead will just
+return the empty string or pass through the original text as appropriate.
+This is intended to support easy use of scripts using this module on
+platforms that don't support ANSI escape sequences.
+
+For it to have its proper effect, this environment variable must be set
+before any color constants are used in the program.
+
+=back
+
+=head1 RESTRICTIONS
+
+It would be nice if one could leave off the commas around the constants
+entirely and just say:
+
+ print BOLD BLUE ON_WHITE "Text\n" RESET;
+
+but the syntax of Perl doesn't allow this. You need a comma after the
+string. (Of course, you may consider it a bug that commas between all the
+constants aren't required, in which case you may feel free to insert
+commas unless you're using $Term::ANSIColor::AUTORESET or
+PUSHCOLOR/POPCOLOR.)
+
+For easier debugging, you may prefer to always use the commas when not
+setting $Term::ANSIColor::AUTORESET or PUSHCOLOR/POPCOLOR so that you'll
+get a fatal compile error rather than a warning.
+
+=head1 NOTES
+
+The codes generated by this module are standard terminal control codes,
+complying with ECMA-048 and ISO 6429 (generally referred to as "ANSI
+color" for the color codes). The non-color control codes (bold, dark,
+italic, underline, and reverse) are part of the earlier ANSI X3.64
+standard for control sequences for video terminals and peripherals.
+
+Note that not all displays are ISO 6429-compliant, or even X3.64-compliant
+(or are even attempting to be so). This module will not work as expected
+on displays that do not honor these escape sequences, such as cmd.exe,
+4nt.exe, and command.com under either Windows NT or Windows 2000. They
+may just be ignored, or they may display as an ESC character followed by
+some apparent garbage.
+
+Jean Delvare provided the following table of different common terminal
+emulators and their support for the various attributes and others have
+helped me flesh it out:
+
+ clear bold faint under blink reverse conceal
+ ------------------------------------------------------------------------
+ xterm yes yes no yes bold yes yes
+ linux yes yes yes bold yes yes no
+ rxvt yes yes no yes bold/black yes no
+ dtterm yes yes yes yes reverse yes yes
+ teraterm yes reverse no yes rev/red yes no
+ aixterm kinda normal no yes no yes yes
+ PuTTY yes color no yes no yes no
+ Windows yes no no no no yes no
+ Cygwin SSH yes yes no color color color yes
+ Mac Terminal yes yes no yes yes yes yes
+
+Windows is Windows telnet, Cygwin SSH is the OpenSSH implementation under
+Cygwin on Windows NT, and Mac Terminal is the Terminal application in Mac
+OS X. Where the entry is other than yes or no, that emulator displays the
+given attribute as something else instead. Note that on an aixterm, clear
+doesn't reset colors; you have to explicitly set the colors back to what
+you want. More entries in this table are welcome.
+
+Note that codes 3 (italic), 6 (rapid blink), and 9 (strike-through) are
+specified in ANSI X3.64 and ECMA-048 but are not commonly supported by
+most displays and emulators and therefore aren't supported by this module
+at the present time. ECMA-048 also specifies a large number of other
+attributes, including a sequence of attributes for font changes, Fraktur
+characters, double-underlining, framing, circling, and overlining. As
+none of these attributes are widely supported or useful, they also aren't
+currently supported by this module.
+
+=head1 SEE ALSO
+
+ECMA-048 is available on-line (at least at the time of this writing) at
+L<http://www.ecma-international.org/publications/standards/ECMA-048.HTM>.
+
+ISO 6429 is available from ISO for a charge; the author of this module
+does not own a copy of it. Since the source material for ISO 6429 was
+ECMA-048 and the latter is available for free, there seems little reason
+to obtain the ISO standard.
+
+The current version of this module is always available from its web site
+at L<http://www.eyrie.org/~eagle/software/ansicolor/>. It is also part of
+the Perl core distribution as of 5.6.0.
+
+=head1 AUTHORS
+
+Original idea (using constants) by Zenin, reimplemented using subs by Russ
+Allbery <rra at stanford.edu>, and then combined with the original idea by
+Russ with input from Zenin. Russ Allbery now maintains this module.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 1996, 1997, 1998, 2000, 2001, 2002, 2005, 2006, 2008, 2009 Russ
+Allbery <rra at stanford.edu> and Zenin. This program is free software; you
+may redistribute it and/or modify it under the same terms as Perl itself.
+
+PUSHCOLOR, POPCOLOR, and LOCALCOLOR were contributed by openmethods.com
+voice solutions.
+
+=cut
Copied: trunk/contrib/perl/lib/Term/Cap.pm (from rev 6437, vendor/perl/5.18.1/lib/Term/Cap.pm)
===================================================================
--- trunk/contrib/perl/lib/Term/Cap.pm (rev 0)
+++ trunk/contrib/perl/lib/Term/Cap.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,799 @@
+package Term::Cap;
+
+# Since the debugger uses Term::ReadLine which uses Term::Cap, we want
+# to load as few modules as possible. This includes Carp.pm.
+sub carp
+{
+ require Carp;
+ goto &Carp::carp;
+}
+
+sub croak
+{
+ require Carp;
+ goto &Carp::croak;
+}
+
+use strict;
+
+use vars qw($VERSION $VMS_TERMCAP);
+use vars qw($termpat $state $first $entry);
+
+$VERSION = '1.12';
+
+# Version undef: Thu Dec 14 20:02:42 CST 1995 by sanders at bsdi.com
+# Version 1.00: Thu Nov 30 23:34:29 EST 2000 by schwern at pobox.com
+# [PATCH] $VERSION crusade, strict, tests, etc... all over lib/
+# Version 1.01: Wed May 23 00:00:00 CST 2001 by d-lewart at uiuc.edu
+# Avoid warnings in Tgetent and Tputs
+# Version 1.02: Sat Nov 17 13:50:39 GMT 2001 by jns at gellyfish.com
+# Altered layout of the POD
+# Added Test::More to PREREQ_PM in Makefile.PL
+# Fixed no argument Tgetent()
+# Version 1.03: Wed Nov 28 10:09:38 GMT 2001
+# VMS Support from Charles Lane <lane at DUPHY4.Physics.Drexel.Edu>
+# Version 1.04: Thu Nov 29 16:22:03 GMT 2001
+# Fixed warnings in test
+# Version 1.05: Mon Dec 3 15:33:49 GMT 2001
+# Don't try to fall back on infocmp if it's not there. From chromatic.
+# Version 1.06: Thu Dec 6 18:43:22 GMT 2001
+# Preload the default VMS termcap from Charles Lane
+# Don't carp at setting OSPEED unless warnings are on.
+# Version 1.07: Wed Jan 2 21:35:09 GMT 2002
+# Sanity check on infocmp output from Norton Allen
+# Repaired INSTALLDIRS thanks to Michael Schwern
+# Version 1.08: Sat Sep 28 11:33:15 BST 2002
+# Late loading of 'Carp' as per Michael Schwern
+# Version 1.09: Tue Apr 20 12:06:51 BST 2004
+# Merged in changes from and to Core
+# Core (Fri Aug 30 14:15:55 CEST 2002):
+# Cope with comments lines from 'infocmp' from Brendan O'Dea
+# Allow for EBCDIC in Tgoto magic test.
+# Version 1.10: Thu Oct 18 16:52:20 BST 2007
+# Don't use try to use $ENV{HOME} if it doesn't exist
+# Give Win32 'dumb' if TERM isn't set
+# Provide fallback 'dumb' termcap entry as last resort
+# Version 1.11: Thu Oct 25 09:33:07 BST 2007
+# EBDIC fixes from Chun Bing Ge <gecb at cn.ibm.com>
+# Version 1.12: Sat Dec 8 00:10:21 GMT 2007
+# QNX test fix from Matt Kraai <kraai at ftbfs.org>
+#
+# TODO:
+# support Berkeley DB termcaps
+# force $FH into callers package?
+# keep $FH in object at Tgetent time?
+
+=head1 NAME
+
+Term::Cap - Perl termcap interface
+
+=head1 SYNOPSIS
+
+ require Term::Cap;
+ $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
+ $terminal->Trequire(qw/ce ku kd/);
+ $terminal->Tgoto('cm', $col, $row, $FH);
+ $terminal->Tputs('dl', $count, $FH);
+ $terminal->Tpad($string, $count, $FH);
+
+=head1 DESCRIPTION
+
+These are low-level functions to extract and use capabilities from
+a terminal capability (termcap) database.
+
+More information on the terminal capabilities will be found in the
+termcap manpage on most Unix-like systems.
+
+=head2 METHODS
+
+=over 4
+
+The output strings for B<Tputs> are cached for counts of 1 for performance.
+B<Tgoto> and B<Tpad> do not cache. C<$self-E<gt>{_xx}> is the raw termcap
+data and C<$self-E<gt>{xx}> is the cached version.
+
+ print $terminal->Tpad($self->{_xx}, 1);
+
+B<Tgoto>, B<Tputs>, and B<Tpad> return the string and will also
+output the string to $FH if specified.
+
+
+=cut
+
+# Preload the default VMS termcap.
+# If a different termcap is required then the text of one can be supplied
+# in $Term::Cap::VMS_TERMCAP before Tgetent is called.
+
+if ( $^O eq 'VMS' )
+{
+ chomp( my @entry = <DATA> );
+ $VMS_TERMCAP = join '', @entry;
+}
+
+# Returns a list of termcap files to check.
+
+sub termcap_path
+{ ## private
+ my @termcap_path;
+
+ # $TERMCAP, if it's a filespec
+ push( @termcap_path, $ENV{TERMCAP} )
+ if (
+ ( exists $ENV{TERMCAP} )
+ && (
+ ( $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos' )
+ ? $ENV{TERMCAP} =~ /^[a-z]:[\\\/]/is
+ : $ENV{TERMCAP} =~ /^\//s
+ )
+ );
+ if ( ( exists $ENV{TERMPATH} ) && ( $ENV{TERMPATH} ) )
+ {
+
+ # Add the users $TERMPATH
+ push( @termcap_path, split( /(:|\s+)/, $ENV{TERMPATH} ) );
+ }
+ else
+ {
+
+ # Defaults
+ push( @termcap_path,
+ exists $ENV{'HOME'} ? $ENV{'HOME'} . '/.termcap' : undef,
+ '/etc/termcap', '/usr/share/misc/termcap', );
+ }
+
+ # return the list of those termcaps that exist
+ return grep { defined $_ && -f $_ } @termcap_path;
+}
+
+=item B<Tgetent>
+
+Returns a blessed object reference which the user can
+then use to send the control strings to the terminal using B<Tputs>
+and B<Tgoto>.
+
+The function extracts the entry of the specified terminal
+type I<TERM> (defaults to the environment variable I<TERM>) from the
+database.
+
+It will look in the environment for a I<TERMCAP> variable. If
+found, and the value does not begin with a slash, and the terminal
+type name is the same as the environment string I<TERM>, the
+I<TERMCAP> string is used instead of reading a termcap file. If
+it does begin with a slash, the string is used as a path name of
+the termcap file to search. If I<TERMCAP> does not begin with a
+slash and name is different from I<TERM>, B<Tgetent> searches the
+files F<$HOME/.termcap>, F</etc/termcap>, and F</usr/share/misc/termcap>,
+in that order, unless the environment variable I<TERMPATH> exists,
+in which case it specifies a list of file pathnames (separated by
+spaces or colons) to be searched B<instead>. Whenever multiple
+files are searched and a tc field occurs in the requested entry,
+the entry it names must be found in the same file or one of the
+succeeding files. If there is a C<:tc=...:> in the I<TERMCAP>
+environment variable string it will continue the search in the
+files as above.
+
+The extracted termcap entry is available in the object
+as C<$self-E<gt>{TERMCAP}>.
+
+It takes a hash reference as an argument with two optional keys:
+
+=over 2
+
+=item OSPEED
+
+The terminal output bit rate (often mistakenly called the baud rate)
+for this terminal - if not set a warning will be generated
+and it will be defaulted to 9600. I<OSPEED> can be be specified as
+either a POSIX termios/SYSV termio speeds (where 9600 equals 9600) or
+an old DSD-style speed ( where 13 equals 9600).
+
+
+=item TERM
+
+The terminal type whose termcap entry will be used - if not supplied it will
+default to $ENV{TERM}: if that is not set then B<Tgetent> will croak.
+
+=back
+
+It calls C<croak> on failure.
+
+=cut
+
+sub Tgetent
+{ ## public -- static method
+ my $class = shift;
+ my ($self) = @_;
+
+ $self = {} unless defined $self;
+ bless $self, $class;
+
+ my ( $term, $cap, $search, $field, $max, $tmp_term, $TERMCAP );
+ local ( $termpat, $state, $first, $entry ); # used inside eval
+ local $_;
+
+ # Compute PADDING factor from OSPEED (to be used by Tpad)
+ if ( !$self->{OSPEED} )
+ {
+ if ($^W)
+ {
+ carp "OSPEED was not set, defaulting to 9600";
+ }
+ $self->{OSPEED} = 9600;
+ }
+ if ( $self->{OSPEED} < 16 )
+ {
+
+ # delays for old style speeds
+ my @pad = (
+ 0, 200, 133.3, 90.9, 74.3, 66.7, 50, 33.3,
+ 16.7, 8.3, 5.5, 4.1, 2, 1, .5, .2
+ );
+ $self->{PADDING} = $pad[ $self->{OSPEED} ];
+ }
+ else
+ {
+ $self->{PADDING} = 10000 / $self->{OSPEED};
+ }
+
+ unless ( $self->{TERM} )
+ {
+ if ( $ENV{TERM} )
+ {
+ $self->{TERM} = $ENV{TERM} ;
+ }
+ else
+ {
+ if ( $^O eq 'Win32' )
+ {
+ $self->{TERM} = 'dumb';
+ }
+ else
+ {
+ croak "TERM not set";
+ }
+ }
+ }
+
+ $term = $self->{TERM}; # $term is the term type we are looking for
+
+ # $tmp_term is always the next term (possibly :tc=...:) we are looking for
+ $tmp_term = $self->{TERM};
+
+ # protect any pattern metacharacters in $tmp_term
+ $termpat = $tmp_term;
+ $termpat =~ s/(\W)/\\$1/g;
+
+ my $foo = ( exists $ENV{TERMCAP} ? $ENV{TERMCAP} : '' );
+
+ # $entry is the extracted termcap entry
+ if ( ( $foo !~ m:^/:s ) && ( $foo =~ m/(^|\|)${termpat}[:|]/s ) )
+ {
+ $entry = $foo;
+ }
+
+ my @termcap_path = termcap_path();
+
+ unless ( @termcap_path || $entry )
+ {
+
+ # last resort--fake up a termcap from terminfo
+ local $ENV{TERM} = $term;
+
+ if ( $^O eq 'VMS' )
+ {
+ $entry = $VMS_TERMCAP;
+ }
+ else
+ {
+ if ( grep { -x "$_/infocmp" } split /:/, $ENV{PATH} )
+ {
+ eval {
+ my $tmp = `infocmp -C 2>/dev/null`;
+ $tmp =~ s/^#.*\n//gm; # remove comments
+ if ( ( $tmp !~ m%^/%s )
+ && ( $tmp =~ /(^|\|)${termpat}[:|]/s ) )
+ {
+ $entry = $tmp;
+ }
+ };
+ }
+ else
+ {
+ # this is getting desperate now
+ if ( $self->{TERM} eq 'dumb' )
+ {
+ $entry = 'dumb|80-column dumb tty::am::co#80::bl=^G:cr=^M:do=^J:sf=^J:';
+ }
+ }
+ }
+ }
+
+ croak "Can't find a valid termcap file" unless @termcap_path || $entry;
+
+ $state = 1; # 0 == finished
+ # 1 == next file
+ # 2 == search again
+
+ $first = 0; # first entry (keeps term name)
+
+ $max = 32; # max :tc=...:'s
+
+ if ($entry)
+ {
+
+ # ok, we're starting with $TERMCAP
+ $first++; # we're the first entry
+ # do we need to continue?
+ if ( $entry =~ s/:tc=([^:]+):/:/ )
+ {
+ $tmp_term = $1;
+
+ # protect any pattern metacharacters in $tmp_term
+ $termpat = $tmp_term;
+ $termpat =~ s/(\W)/\\$1/g;
+ }
+ else
+ {
+ $state = 0; # we're already finished
+ }
+ }
+
+ # This is eval'ed inside the while loop for each file
+ $search = q{
+ while (<TERMCAP>) {
+ next if /^\\t/ || /^#/;
+ if ($_ =~ m/(^|\\|)${termpat}[:|]/o) {
+ chomp;
+ s/^[^:]*:// if $first++;
+ $state = 0;
+ while ($_ =~ s/\\\\$//) {
+ defined(my $x = <TERMCAP>) or last;
+ $_ .= $x; chomp;
+ }
+ last;
+ }
+ }
+ defined $entry or $entry = '';
+ $entry .= $_ if $_;
+ };
+
+ while ( $state != 0 )
+ {
+ if ( $state == 1 )
+ {
+
+ # get the next TERMCAP
+ $TERMCAP = shift @termcap_path
+ || croak "failed termcap lookup on $tmp_term";
+ }
+ else
+ {
+
+ # do the same file again
+ # prevent endless recursion
+ $max-- || croak "failed termcap loop at $tmp_term";
+ $state = 1; # ok, maybe do a new file next time
+ }
+
+ open( TERMCAP, "< $TERMCAP\0" ) || croak "open $TERMCAP: $!";
+ eval $search;
+ die $@ if $@;
+ close TERMCAP;
+
+ # If :tc=...: found then search this file again
+ $entry =~ s/:tc=([^:]+):/:/ && ( $tmp_term = $1, $state = 2 );
+
+ # protect any pattern metacharacters in $tmp_term
+ $termpat = $tmp_term;
+ $termpat =~ s/(\W)/\\$1/g;
+ }
+
+ croak "Can't find $term" if $entry eq '';
+ $entry =~ s/:+\s*:+/:/g; # cleanup $entry
+ $entry =~ s/:+/:/g; # cleanup $entry
+ $self->{TERMCAP} = $entry; # save it
+ # print STDERR "DEBUG: $entry = ", $entry, "\n";
+
+ # Precompile $entry into the object
+ $entry =~ s/^[^:]*://;
+ foreach $field ( split( /:[\s:\\]*/, $entry ) )
+ {
+ if ( defined $field && $field =~ /^(\w\w)$/ )
+ {
+ $self->{ '_' . $field } = 1 unless defined $self->{ '_' . $1 };
+
+ # print STDERR "DEBUG: flag $1\n";
+ }
+ elsif ( defined $field && $field =~ /^(\w\w)\@/ )
+ {
+ $self->{ '_' . $1 } = "";
+
+ # print STDERR "DEBUG: unset $1\n";
+ }
+ elsif ( defined $field && $field =~ /^(\w\w)#(.*)/ )
+ {
+ $self->{ '_' . $1 } = $2 unless defined $self->{ '_' . $1 };
+
+ # print STDERR "DEBUG: numeric $1 = $2\n";
+ }
+ elsif ( defined $field && $field =~ /^(\w\w)=(.*)/ )
+ {
+
+ # print STDERR "DEBUG: string $1 = $2\n";
+ next if defined $self->{ '_' . ( $cap = $1 ) };
+ $_ = $2;
+ if ( ord('A') == 193 )
+ {
+ s/\\E/\047/g;
+ s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg;
+ s/\\n/\n/g;
+ s/\\r/\r/g;
+ s/\\t/\t/g;
+ s/\\b/\b/g;
+ s/\\f/\f/g;
+ s/\\\^/\337/g;
+ s/\^\?/\007/g;
+ s/\^(.)/pack('c',ord($1) & 31)/eg;
+ s/\\(.)/$1/g;
+ s/\337/^/g;
+ }
+ else
+ {
+ s/\\E/\033/g;
+ s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg;
+ s/\\n/\n/g;
+ s/\\r/\r/g;
+ s/\\t/\t/g;
+ s/\\b/\b/g;
+ s/\\f/\f/g;
+ s/\\\^/\377/g;
+ s/\^\?/\177/g;
+ s/\^(.)/pack('c',ord($1) & 31)/eg;
+ s/\\(.)/$1/g;
+ s/\377/^/g;
+ }
+ $self->{ '_' . $cap } = $_;
+ }
+
+ # else { carp "junk in $term ignored: $field"; }
+ }
+ $self->{'_pc'} = "\0" unless defined $self->{'_pc'};
+ $self->{'_bc'} = "\b" unless defined $self->{'_bc'};
+ $self;
+}
+
+# $terminal->Tpad($string, $cnt, $FH);
+
+=item B<Tpad>
+
+Outputs a literal string with appropriate padding for the current terminal.
+
+It takes three arguments:
+
+=over 2
+
+=item B<$string>
+
+The literal string to be output. If it starts with a number and an optional
+'*' then the padding will be increased by an amount relative to this number,
+if the '*' is present then this amount will me multiplied by $cnt. This part
+of $string is removed before output/
+
+=item B<$cnt>
+
+Will be used to modify the padding applied to string as described above.
+
+=item B<$FH>
+
+An optional filehandle (or IO::Handle ) that output will be printed to.
+
+=back
+
+The padded $string is returned.
+
+=cut
+
+sub Tpad
+{ ## public
+ my $self = shift;
+ my ( $string, $cnt, $FH ) = @_;
+ my ( $decr, $ms );
+
+ if ( defined $string && $string =~ /(^[\d.]+)(\*?)(.*)$/ )
+ {
+ $ms = $1;
+ $ms *= $cnt if $2;
+ $string = $3;
+ $decr = $self->{PADDING};
+ if ( $decr > .1 )
+ {
+ $ms += $decr / 2;
+ $string .= $self->{'_pc'} x ( $ms / $decr );
+ }
+ }
+ print $FH $string if $FH;
+ $string;
+}
+
+# $terminal->Tputs($cap, $cnt, $FH);
+
+=item B<Tputs>
+
+Output the string for the given capability padded as appropriate without
+any parameter substitution.
+
+It takes three arguments:
+
+=over 2
+
+=item B<$cap>
+
+The capability whose string is to be output.
+
+=item B<$cnt>
+
+A count passed to Tpad to modify the padding applied to the output string.
+If $cnt is zero or one then the resulting string will be cached.
+
+=item B<$FH>
+
+An optional filehandle (or IO::Handle ) that output will be printed to.
+
+=back
+
+The appropriate string for the capability will be returned.
+
+=cut
+
+sub Tputs
+{ ## public
+ my $self = shift;
+ my ( $cap, $cnt, $FH ) = @_;
+ my $string;
+
+ $cnt = 0 unless $cnt;
+
+ if ( $cnt > 1 )
+ {
+ $string = Tpad( $self, $self->{ '_' . $cap }, $cnt );
+ }
+ else
+ {
+
+ # cache result because Tpad can be slow
+ unless ( exists $self->{$cap} )
+ {
+ $self->{$cap} =
+ exists $self->{"_$cap"}
+ ? Tpad( $self, $self->{"_$cap"}, 1 )
+ : undef;
+ }
+ $string = $self->{$cap};
+ }
+ print $FH $string if $FH;
+ $string;
+}
+
+# $terminal->Tgoto($cap, $col, $row, $FH);
+
+=item B<Tgoto>
+
+B<Tgoto> decodes a cursor addressing string with the given parameters.
+
+There are four arguments:
+
+=over 2
+
+=item B<$cap>
+
+The name of the capability to be output.
+
+=item B<$col>
+
+The first value to be substituted in the output string ( usually the column
+in a cursor addressing capability )
+
+=item B<$row>
+
+The second value to be substituted in the output string (usually the row
+in cursor addressing capabilities)
+
+=item B<$FH>
+
+An optional filehandle (or IO::Handle ) to which the output string will be
+printed.
+
+=back
+
+Substitutions are made with $col and $row in the output string with the
+following sprintf() line formats:
+
+ %% output `%'
+ %d output value as in printf %d
+ %2 output value as in printf %2d
+ %3 output value as in printf %3d
+ %. output value as in printf %c
+ %+x add x to value, then do %.
+
+ %>xy if value > x then add y, no output
+ %r reverse order of two parameters, no output
+ %i increment by one, no output
+ %B BCD (16*(value/10)) + (value%10), no output
+
+ %n exclusive-or all parameters with 0140 (Datamedia 2500)
+ %D Reverse coding (value - 2*(value%16)), no output (Delta Data)
+
+The output string will be returned.
+
+=cut
+
+sub Tgoto
+{ ## public
+ my $self = shift;
+ my ( $cap, $code, $tmp, $FH ) = @_;
+ my $string = $self->{ '_' . $cap };
+ my $result = '';
+ my $after = '';
+ my $online = 0;
+ my @tmp = ( $tmp, $code );
+ my $cnt = $code;
+
+ while ( $string =~ /^([^%]*)%(.)(.*)/ )
+ {
+ $result .= $1;
+ $code = $2;
+ $string = $3;
+ if ( $code eq 'd' )
+ {
+ $result .= sprintf( "%d", shift(@tmp) );
+ }
+ elsif ( $code eq '.' )
+ {
+ $tmp = shift(@tmp);
+ if ( $tmp == 0 || $tmp == 4 || $tmp == 10 )
+ {
+ if ($online)
+ {
+ ++$tmp, $after .= $self->{'_up'} if $self->{'_up'};
+ }
+ else
+ {
+ ++$tmp, $after .= $self->{'_bc'};
+ }
+ }
+ $result .= sprintf( "%c", $tmp );
+ $online = !$online;
+ }
+ elsif ( $code eq '+' )
+ {
+ $result .= sprintf( "%c", shift(@tmp) + ord($string) );
+ $string = substr( $string, 1, 99 );
+ $online = !$online;
+ }
+ elsif ( $code eq 'r' )
+ {
+ ( $code, $tmp ) = @tmp;
+ @tmp = ( $tmp, $code );
+ $online = !$online;
+ }
+ elsif ( $code eq '>' )
+ {
+ ( $code, $tmp, $string ) = unpack( "CCa99", $string );
+ if ( $tmp[$[] > $code )
+ {
+ $tmp[$[] += $tmp;
+ }
+ }
+ elsif ( $code eq '2' )
+ {
+ $result .= sprintf( "%02d", shift(@tmp) );
+ $online = !$online;
+ }
+ elsif ( $code eq '3' )
+ {
+ $result .= sprintf( "%03d", shift(@tmp) );
+ $online = !$online;
+ }
+ elsif ( $code eq 'i' )
+ {
+ ( $code, $tmp ) = @tmp;
+ @tmp = ( $code + 1, $tmp + 1 );
+ }
+ else
+ {
+ return "OOPS";
+ }
+ }
+ $string = Tpad( $self, $result . $string . $after, $cnt );
+ print $FH $string if $FH;
+ $string;
+}
+
+# $terminal->Trequire(qw/ce ku kd/);
+
+=item B<Trequire>
+
+Takes a list of capabilities as an argument and will croak if one is not
+found.
+
+=cut
+
+sub Trequire
+{ ## public
+ my $self = shift;
+ my ( $cap, @undefined );
+ foreach $cap (@_)
+ {
+ push( @undefined, $cap )
+ unless defined $self->{ '_' . $cap } && $self->{ '_' . $cap };
+ }
+ croak "Terminal does not support: (@undefined)" if @undefined;
+}
+
+=back
+
+=head1 EXAMPLES
+
+ use Term::Cap;
+
+ # Get terminal output speed
+ require POSIX;
+ my $termios = new POSIX::Termios;
+ $termios->getattr;
+ my $ospeed = $termios->getospeed;
+
+ # Old-style ioctl code to get ospeed:
+ # require 'ioctl.pl';
+ # ioctl(TTY,$TIOCGETP,$sgtty);
+ # ($ispeed,$ospeed) = unpack('cc',$sgtty);
+
+ # allocate and initialize a terminal structure
+ $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
+
+ # require certain capabilities to be available
+ $terminal->Trequire(qw/ce ku kd/);
+
+ # Output Routines, if $FH is undefined these just return the string
+
+ # Tgoto does the % expansion stuff with the given args
+ $terminal->Tgoto('cm', $col, $row, $FH);
+
+ # Tputs doesn't do any % expansion.
+ $terminal->Tputs('dl', $count = 1, $FH);
+
+=head1 COPYRIGHT AND LICENSE
+
+Please see the README file in distribution.
+
+=head1 AUTHOR
+
+This module is part of the core Perl distribution and is also maintained
+for CPAN by Jonathan Stowe <jns at gellyfish.com>.
+
+=head1 SEE ALSO
+
+termcap(5)
+
+=cut
+
+# Below is a default entry for systems where there are terminals but no
+# termcap
+1;
+__DATA__
+vt220|vt200|DEC VT220 in vt100 emulation mode:
+am:mi:xn:xo:
+co#80:li#24:
+RA=\E[?7l:SA=\E[?7h:
+ac=kkllmmjjnnwwqquuttvvxx:ae=\E(B:al=\E[L:as=\E(0:
+bl=^G:cd=\E[J:ce=\E[K:cl=\E[H\E[2J:cm=\E[%i%d;%dH:
+cr=^M:cs=\E[%i%d;%dr:dc=\E[P:dl=\E[M:do=\E[B:
+ei=\E[4l:ho=\E[H:im=\E[4h:
+is=\E[1;24r\E[24;1H:
+nd=\E[C:
+kd=\E[B::kl=\E[D:kr=\E[C:ku=\E[A:le=^H:
+mb=\E[5m:md=\E[1m:me=\E[m:mr=\E[7m:
+kb=\0177:
+r2=\E>\E[24;1H\E[?3l\E[?4l\E[?5l\E[?7h\E[?8h\E=:rc=\E8:
+sc=\E7:se=\E[27m:sf=\ED:so=\E[7m:sr=\EM:ta=^I:
+ue=\E[24m:up=\E[A:us=\E[4m:ve=\E[?25h:vi=\E[?25l:
+
Copied: trunk/contrib/perl/lib/Term/Cap.t (from rev 6437, vendor/perl/5.18.1/lib/Term/Cap.t)
===================================================================
--- trunk/contrib/perl/lib/Term/Cap.t (rev 0)
+++ trunk/contrib/perl/lib/Term/Cap.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,240 @@
+#!./perl
+
+my $file;
+
+BEGIN {
+ $file = $0;
+ chdir 't' if -d 't';
+
+ if ( $ENV{PERL_CORE} ) {
+ @INC = '../lib';
+ }
+}
+
+END {
+ # let VMS whack all versions
+ 1 while unlink('tcout');
+}
+
+use Test::More;
+
+# these names are hardcoded in Term::Cap
+my $files = join '',
+ grep { -f $_ }
+ ( $ENV{HOME} . '/.termcap', # we assume pretty UNIXy system anyway
+ '/etc/termcap',
+ '/usr/share/misc/termcap' );
+unless( $files || $^O eq 'VMS' ) {
+ plan skip_all => 'no termcap available to test';
+}
+else {
+ plan tests => 45;
+}
+
+use_ok( 'Term::Cap' );
+
+local (*TCOUT, *OUT);
+my $out = tie *OUT, 'TieOut';
+my $writable = 1;
+
+if (open(TCOUT, ">tcout")) {
+ print TCOUT <DATA>;
+ close TCOUT;
+} else {
+ $writable = 0;
+}
+
+# termcap_path -- the names are hardcoded in Term::Cap
+$ENV{TERMCAP} = '';
+my $path = join '', Term::Cap::termcap_path();
+is( $path, $files, 'termcap_path() should find default files' );
+
+SKIP: {
+ # this is ugly, but -f $0 really *ought* to work
+ skip("-f $file fails, some tests difficult now", 2) unless -f $file;
+
+ $ENV{TERMCAP} = $ENV{TERMPATH} = $file;
+ ok( grep($file, Term::Cap::termcap_path()),
+ 'termcap_path() should find file from $ENV{TERMCAP}' );
+
+ $ENV{TERMCAP} = '/';
+ ok( grep($file, Term::Cap::termcap_path()),
+ 'termcap_path() should find file from $ENV{TERMPATH}' );
+}
+
+# make a Term::Cap "object"
+my $t = {
+ PADDING => 1,
+ _pc => 'pc',
+};
+bless($t, 'Term::Cap' );
+
+# see if Tpad() works
+is( $t->Tpad(), undef, 'Tpad() should return undef with no arguments' );
+is( $t->Tpad('x'), 'x', 'Tpad() should return strings verbatim with no match' );
+is( $t->Tpad( '1*a', 2 ), 'apcpc', 'Tpad() should pad paddable strings' );
+
+$t->{PADDING} = 2;
+is( $t->Tpad( '1*a', 3, *OUT ), 'apcpc', 'Tpad() should perform pad math' );
+is( $out->read(), 'apcpc', 'Tpad() should write to filehandle when passed' );
+
+is( $t->Tputs('PADDING'), 2, 'Tputs() should return existing value' );
+is( $t->Tputs('pc', 2), 'pc', 'Tputs() should delegate to Tpad()' );
+$t->Tputs('pc', 1, *OUT);
+is( $t->{pc}, 'pc', 'Tputs() should cache pc value when asked' );
+is( $out->read(), 'pc', 'Tputs() should write to filehandle when passed' );
+
+eval { $t->Trequire( 'pc' ) };
+is( $@, '', 'Trequire() should finds existing cap' );
+eval { $t->Trequire( 'nonsense' ) };
+like( $@, qr/support: \(nonsense\)/,
+ 'Trequire() should croak with unsupported cap' );
+
+my $warn;
+local $SIG{__WARN__} = sub {
+ $warn = $_[0];
+};
+
+# test the first few features by forcing Tgetent() to croak (line 156)
+undef $ENV{TERM};
+my $vals = {};
+eval { local $^W = 1; $t = Term::Cap->Tgetent($vals) };
+like( $@, qr/TERM not set/, 'Tgetent() should croaks without TERM' );
+like( $warn, qr/OSPEED was not set/, 'Tgetent() should set default OSPEED' );
+
+is( $vals->{PADDING}, 10000/9600, 'Default OSPEED implies default PADDING' );
+
+$warn = 'xxxx';
+eval { local $^W = 0; $t = Term::Cap->Tgetent($vals) };
+is($warn,'xxxx',"Tgetent() doesn't carp() without warnings on");
+
+# check values for very slow speeds
+$vals->{OSPEED} = 1;
+$warn = '';
+eval { $t = Term::Cap->Tgetent($vals) };
+is( $warn, '', 'Tgetent() should not work if OSPEED is provided' );
+is( $vals->{PADDING}, 200, 'Tgetent() should set slow PADDING when needed' );
+
+
+SKIP: {
+ skip('Tgetent() bad termcap test, since using a fixed termcap',1)
+ if $^O eq 'VMS';
+ # now see if lines 177 or 180 will fail
+ $ENV{TERM} = 'foo';
+ $ENV{TERMPATH} = '!';
+ $ENV{TERMCAP} = '';
+ eval { $t = Term::Cap->Tgetent($vals) };
+ isn't( $@, '', 'Tgetent() should catch bad termcap file' );
+}
+
+SKIP: {
+ skip( "Can't write 'tcout' file for tests", 9 ) unless $writable;
+
+ # it won't find the termtype in this fake file, so it should croak
+ $vals->{TERM} = 'quux';
+ $ENV{TERMPATH} = 'tcout';
+ eval { $t = Term::Cap->Tgetent($vals) };
+ like( $@, qr/failed termcap/, 'Tgetent() should die with bad termcap' );
+
+ # it shouldn't try to read one file more than 32(!) times
+ # see __END__ for a really awful termcap example
+ $ENV{TERMPATH} = join(' ', ('tcout') x 33);
+ $vals->{TERM} = 'bar';
+ eval { $t = Term::Cap->Tgetent($vals) };
+ like( $@, qr/failed termcap loop/, 'Tgetent() should catch deep recursion');
+
+ # now let it read a fake termcap file, and see if it sets properties
+ $ENV{TERMPATH} = 'tcout';
+ $vals->{TERM} = 'baz';
+ $t = Term::Cap->Tgetent($vals);
+ is( $t->{_f1}, 1, 'Tgetent() should set a single field correctly' );
+ is( $t->{_f2}, 1, 'Tgetent() should set another field on the same line' );
+ is( $t->{_no}, '', 'Tgetent() should set a blank field correctly' );
+ is( $t->{_k1}, 'v1', 'Tgetent() should set a key value pair correctly' );
+ like( $t->{_k2}, qr/v2\\\n2/, 'Tgetent() should set and translate pairs' );
+
+ # and it should have set these two fields
+ is( $t->{_pc}, "\0", 'should set _pc field correctly' );
+ is( $t->{_bc}, "\b", 'should set _bc field correctly' );
+}
+
+# Windows hack
+SKIP:
+{
+ skip("QNX's termcap database does not contain an entry for dumb terminals",
+ 1) if $^O eq 'nto';
+
+ local *^O;
+ local *ENV;
+ delete $ENV{TERM};
+ $^O = 'Win32';
+
+ my $foo = Term::Cap->Tgetent();
+ is($foo->{TERM} ,'dumb','Windows gets "dumb" by default');
+}
+
+# Tgoto has comments on the expected formats
+$t->{_test} = "a%d";
+is( $t->Tgoto('test', '', 1, *OUT), 'a1', 'Tgoto() should handle %d code' );
+is( $out->read(), 'a1', 'Tgoto() should print to filehandle if passed' );
+
+$t->{_test} = "a%.";
+like( $t->Tgoto('test', '', 1), qr/^a\x01/, 'Tgoto() should handle %.' );
+if (ord('A') == 193) { # EBCDIC platform
+ like( $t->Tgoto('test', '', 0), qr/\x81\x01\x16/,
+ 'Tgoto() should handle %. and magic' );
+ } else { # ASCII platform
+ like( $t->Tgoto('test', '', 0), qr/\x61\x01\x08/,
+ 'Tgoto() should handle %. and magic' );
+ }
+
+$t->{_test} = 'a%+';
+like( $t->Tgoto('test', '', 1), qr/a\x01/, 'Tgoto() should handle %+' );
+$t->{_test} = 'a%+a';
+is( $t->Tgoto('test', '', 1), 'ab', 'Tgoto() should handle %+char' );
+$t->{_test} .= 'a' x 99;
+like( $t->Tgoto('test', '', 1), qr/ba{98}/,
+ 'Tgoto() should substr()s %+ if needed' );
+
+$t->{_test} = '%ra%d';
+is( $t->Tgoto('test', 1, ''), 'a1', 'Tgoto() should swaps params with %r' );
+
+$t->{_test} = 'a%>11bc';
+is( $t->Tgoto('test', '', 1), 'abc', 'Tgoto() should unpack args with %>' );
+
+$t->{_test} = 'a%21';
+is( $t->Tgoto('test'), 'a001', 'Tgoto() should format with %2' );
+
+$t->{_test} = 'a%31';
+is( $t->Tgoto('test'), 'a0001', 'Tgoto() should also formats with %3' );
+
+$t->{_test} = '%ia%21';
+is( $t->Tgoto('test', '', 1), 'a021', 'Tgoto() should increment args with %i' );
+
+$t->{_test} = '%z';
+is( $t->Tgoto('test'), 'OOPS', 'Tgoto() should catch invalid args' );
+
+# and this is pretty standard
+package TieOut;
+
+sub TIEHANDLE {
+ bless( \(my $self), $_[0] );
+}
+
+sub PRINT {
+ my $self = shift;
+ $$self .= join('', @_);
+}
+
+sub read {
+ my $self = shift;
+ substr( $$self, 0, length($$self), '' );
+}
+
+__END__
+bar: :tc=bar: \
+baz: \
+:f1: :f2: \
+:no@ \
+:k1#v1\
+:k2=v2\\n2
Index: trunk/contrib/perl/lib/Term/Complete.pm
===================================================================
--- trunk/contrib/perl/lib/Term/Complete.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Term/Complete.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Term/Complete.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/Term/Complete.t
===================================================================
--- trunk/contrib/perl/lib/Term/Complete.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Term/Complete.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Term/Complete.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/Term/ReadLine.pm
===================================================================
--- trunk/contrib/perl/lib/Term/ReadLine.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Term/ReadLine.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Term/ReadLine.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/lib/Term/ReadLine.t
===================================================================
--- trunk/contrib/perl/lib/Term/ReadLine.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Term/ReadLine.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Term/ReadLine.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/lib/Term/UI.pm (from rev 6437, vendor/perl/5.18.1/lib/Term/UI.pm)
===================================================================
--- trunk/contrib/perl/lib/Term/UI.pm (rev 0)
+++ trunk/contrib/perl/lib/Term/UI.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,620 @@
+package Term::UI;
+
+use Carp;
+use Params::Check qw[check allow];
+use Term::ReadLine;
+use Locale::Maketext::Simple Style => 'gettext';
+use Term::UI::History;
+
+use strict;
+
+BEGIN {
+ use vars qw[$VERSION $AUTOREPLY $VERBOSE $INVALID];
+ $VERBOSE = 1;
+ $VERSION = '0.20';
+ $INVALID = loc('Invalid selection, please try again: ');
+}
+
+push @Term::ReadLine::Stub::ISA, __PACKAGE__
+ unless grep { $_ eq __PACKAGE__ } @Term::ReadLine::Stub::ISA;
+
+
+=pod
+
+=head1 NAME
+
+Term::UI - Term::ReadLine UI made easy
+
+=head1 SYNOPSIS
+
+ use Term::UI;
+ use Term::ReadLine;
+
+ my $term = Term::ReadLine->new('brand');
+
+ my $reply = $term->get_reply(
+ prompt => 'What is your favourite colour?',
+ choices => [qw|blue red green|],
+ default => blue,
+ );
+
+ my $bool = $term->ask_yn(
+ prompt => 'Do you like cookies?',
+ default => 'y',
+ );
+
+
+ my $string = q[some_command -option --no-foo --quux='this thing'];
+
+ my ($options,$munged_input) = $term->parse_options($string);
+
+
+ ### don't have Term::UI issue warnings -- default is '1'
+ $Term::UI::VERBOSE = 0;
+
+ ### always pick the default (good for non-interactive terms)
+ ### -- default is '0'
+ $Term::UI::AUTOREPLY = 1;
+
+ ### Retrieve the entire session as a printable string:
+ $hist = Term::UI::History->history_as_string;
+ $hist = $term->history_as_string;
+
+=head1 DESCRIPTION
+
+C<Term::UI> is a transparent way of eliminating the overhead of having
+to format a question and then validate the reply, informing the user
+if the answer was not proper and re-issuing the question.
+
+Simply give it the question you want to ask, optionally with choices
+the user can pick from and a default and C<Term::UI> will DWYM.
+
+For asking a yes or no question, there's even a shortcut.
+
+=head1 HOW IT WORKS
+
+C<Term::UI> places itself at the back of the C<Term::ReadLine>
+C<@ISA> array, so you can call its functions through your term object.
+
+C<Term::UI> uses C<Term::UI::History> to record all interactions
+with the commandline. You can retrieve this history, or alter
+the filehandle the interaction is printed to. See the
+C<Term::UI::History> manpage or the C<SYNOPSIS> for details.
+
+=head1 METHODS
+
+=head2 $reply = $term->get_reply( prompt => 'question?', [choices => \@list, default => $list[0], multi => BOOL, print_me => "extra text to print & record", allow => $ref] );
+
+C<get_reply> asks a user a question, and then returns the reply to the
+caller. If the answer is invalid (more on that below), the question will
+be reposed, until a satisfactory answer has been entered.
+
+You have the option of providing a list of choices the user can pick from
+using the C<choices> argument. If the answer is not in the list of choices
+presented, the question will be reposed.
+
+If you provide a C<default> answer, this will be returned when either
+C<$AUTOREPLY> is set to true, (see the C<GLOBAL VARIABLES> section further
+below), or when the user just hits C<enter>.
+
+You can indicate that the user is allowed to enter multiple answers by
+toggling the C<multi> flag. Note that a list of answers will then be
+returned to you, rather than a simple string.
+
+By specifying an C<allow> hander, you can yourself validate the answer
+a user gives. This can be any of the types that the Params::Check C<allow>
+function allows, so please refer to that manpage for details.
+
+Finally, you have the option of adding a C<print_me> argument, which is
+simply printed before the prompt. It's printed to the same file handle
+as the rest of the questions, so you can use this to keep track of a
+full session of Q&A with the user, and retrieve it later using the
+C<< Term::UI->history_as_string >> function.
+
+See the C<EXAMPLES> section for samples of how to use this function.
+
+=cut
+
+sub get_reply {
+ my $term = shift;
+ my %hash = @_;
+
+ my $tmpl = {
+ default => { default => undef, strict_type => 1 },
+ prompt => { default => '', strict_type => 1, required => 1 },
+ choices => { default => [], strict_type => 1 },
+ multi => { default => 0, allow => [0, 1] },
+ allow => { default => qr/.*/ },
+ print_me => { default => '', strict_type => 1 },
+ };
+
+ my $args = check( $tmpl, \%hash, $VERBOSE )
+ or ( carp( loc(q[Could not parse arguments]) ), return );
+
+
+ ### add this to the prompt to indicate the default
+ ### answer to the question if there is one.
+ my $prompt_add;
+
+ ### if you supplied several choices to pick from,
+ ### we'll print them seperately before the prompt
+ if( @{$args->{choices}} ) {
+ my $i;
+
+ for my $choice ( @{$args->{choices}} ) {
+ $i++; # the answer counter -- but humans start counting
+ # at 1 :D
+
+ ### so this choice is the default? add it to 'prompt_add'
+ ### so we can construct a "foo? [DIGIT]" type prompt
+ $prompt_add = $i if (defined $args->{default} and $choice eq $args->{default});
+
+ ### create a "DIGIT> choice" type line
+ $args->{print_me} .= sprintf "\n%3s> %-s", $i, $choice;
+ }
+
+ ### we listed some choices -- add another newline for
+ ### pretty printing
+ $args->{print_me} .= "\n" if $i;
+
+ ### allowable answers are now equal to the choices listed
+ $args->{allow} = $args->{choices};
+
+ ### no choices, but a default? set 'prompt_add' to the default
+ ### to construct a 'foo? [DEFAULT]' type prompt
+ } elsif ( defined $args->{default} ) {
+ $prompt_add = $args->{default};
+ }
+
+ ### we set up the defaults, prompts etc, dispatch to the readline call
+ return $term->_tt_readline( %$args, prompt_add => $prompt_add );
+
+}
+
+=head2 $bool = $term->ask_yn( prompt => "your question", [default => (y|1,n|0), print_me => "extra text to print & record"] )
+
+Asks a simple C<yes> or C<no> question to the user, returning a boolean
+indicating C<true> or C<false> to the caller.
+
+The C<default> answer will automatically returned, if the user hits
+C<enter> or if C<$AUTOREPLY> is set to true. See the C<GLOBAL VARIABLES>
+section further below.
+
+Also, you have the option of adding a C<print_me> argument, which is
+simply printed before the prompt. It's printed to the same file handle
+as the rest of the questions, so you can use this to keep track of a
+full session of Q&A with the user, and retrieve it later using the
+C<< Term::UI->history_as_string >> function.
+
+
+See the C<EXAMPLES> section for samples of how to use this function.
+
+=cut
+
+sub ask_yn {
+ my $term = shift;
+ my %hash = @_;
+
+ my $tmpl = {
+ default => { default => undef, allow => [qw|0 1 y n|],
+ strict_type => 1 },
+ prompt => { default => '', required => 1, strict_type => 1 },
+ print_me => { default => '', strict_type => 1 },
+ multi => { default => 0, no_override => 1 },
+ choices => { default => [qw|y n|], no_override => 1 },
+ allow => { default => [qr/^y(?:es)?$/i, qr/^n(?:o)?$/i],
+ no_override => 1
+ },
+ };
+
+ my $args = check( $tmpl, \%hash, $VERBOSE ) or return undef;
+
+ ### uppercase the default choice, if there is one, to be added
+ ### to the prompt in a 'foo? [Y/n]' type style.
+ my $prompt_add;
+ { my @list = @{$args->{choices}};
+ if( defined $args->{default} ) {
+
+ ### if you supplied the default as a boolean, rather than y/n
+ ### transform it to a y/n now
+ $args->{default} = $args->{default} =~ /\d/
+ ? { 0 => 'n', 1 => 'y' }->{ $args->{default} }
+ : $args->{default};
+
+ @list = map { lc $args->{default} eq lc $_
+ ? uc $args->{default}
+ : $_
+ } @list;
+ }
+
+ $prompt_add .= join("/", @list);
+ }
+
+ my $rv = $term->_tt_readline( %$args, prompt_add => $prompt_add );
+
+ return $rv =~ /^y/i ? 1 : 0;
+}
+
+
+
+sub _tt_readline {
+ my $term = shift;
+ my %hash = @_;
+
+ local $Params::Check::VERBOSE = 0; # why is this?
+ local $| = 1; # print ASAP
+
+
+ my ($default, $prompt, $choices, $multi, $allow, $prompt_add, $print_me);
+ my $tmpl = {
+ default => { default => undef, strict_type => 1,
+ store => \$default },
+ prompt => { default => '', strict_type => 1, required => 1,
+ store => \$prompt },
+ choices => { default => [], strict_type => 1,
+ store => \$choices },
+ multi => { default => 0, allow => [0, 1], store => \$multi },
+ allow => { default => qr/.*/, store => \$allow, },
+ prompt_add => { default => '', store => \$prompt_add },
+ print_me => { default => '', store => \$print_me },
+ };
+
+ check( $tmpl, \%hash, $VERBOSE ) or return;
+
+ ### prompts for Term::ReadLine can't be longer than one line, or
+ ### it can display wonky on some terminals.
+ history( $print_me ) if $print_me;
+
+
+ ### we might have to add a default value to the prompt, to
+ ### show the user what will be picked by default:
+ $prompt .= " [$prompt_add]: " if $prompt_add;
+
+
+ ### are we in autoreply mode?
+ if ($AUTOREPLY) {
+
+ ### you used autoreply, but didnt provide a default!
+ carp loc(
+ q[You have '%1' set to true, but did not provide a default!],
+ '$AUTOREPLY'
+ ) if( !defined $default && $VERBOSE);
+
+ ### print it out for visual feedback
+ history( join ' ', grep { defined } $prompt, $default );
+
+ ### and return the default
+ return $default;
+ }
+
+
+ ### so, no AUTOREPLY, let's see what the user will answer
+ LOOP: {
+
+ ### annoying bug in T::R::Perl that mucks up lines with a \n
+ ### in them; So split by \n, save the last line as the prompt
+ ### and just print the rest
+ { my @lines = split "\n", $prompt;
+ $prompt = pop @lines;
+
+ history( "$_\n" ) for @lines;
+ }
+
+ ### pose the question
+ my $answer = $term->readline($prompt);
+ $answer = $default unless length $answer;
+
+ $term->addhistory( $answer ) if length $answer;
+
+ ### add both prompt and answer to the history
+ history( "$prompt $answer", 0 );
+
+ ### if we're allowed to give multiple answers, split
+ ### the answer on whitespace
+ my @answers = $multi ? split(/\s+/, $answer) : $answer;
+
+ ### the return value list
+ my @rv;
+
+ if( @$choices ) {
+
+ for my $answer (@answers) {
+
+ ### a digit implies a multiple choice question,
+ ### a non-digit is an open answer
+ if( $answer =~ /\D/ ) {
+ push @rv, $answer if allow( $answer, $allow );
+ } else {
+
+ ### remember, the answer digits are +1 compared to
+ ### the choices, because humans want to start counting
+ ### at 1, not at 0
+ push @rv, $choices->[ $answer - 1 ]
+ if $answer > 0 && defined $choices->[ $answer - 1];
+ }
+ }
+
+ ### no fixed list of choices.. just check if the answers
+ ### (or otherwise the default!) pass the allow handler
+ } else {
+ push @rv, grep { allow( $_, $allow ) }
+ scalar @answers ? @answers : ($default);
+ }
+
+ ### if not all the answers made it to the return value list,
+ ### at least one of them was an invalid answer -- make the
+ ### user do it again
+ if( (@rv != @answers) or
+ (scalar(@$choices) and not scalar(@answers))
+ ) {
+ $prompt = $INVALID;
+ $prompt .= "[$prompt_add] " if $prompt_add;
+ redo LOOP;
+
+ ### otherwise just return the answer, or answers, depending
+ ### on the multi setting
+ } else {
+ return $multi ? @rv : $rv[0];
+ }
+ }
+}
+
+=head2 ($opts, $munged) = $term->parse_options( STRING );
+
+C<parse_options> will convert all options given from an input string
+to a hash reference. If called in list context it will also return
+the part of the input string that it found no options in.
+
+Consider this example:
+
+ my $str = q[command --no-foo --baz --bar=0 --quux=bleh ] .
+ q[--option="some'thing" -one-dash -single=blah' arg];
+
+ my ($options,$munged) = $term->parse_options($str);
+
+ ### $options would contain: ###
+ $options = {
+ 'foo' => 0,
+ 'bar' => 0,
+ 'one-dash' => 1,
+ 'baz' => 1,
+ 'quux' => 'bleh',
+ 'single' => 'blah\'',
+ 'option' => 'some\'thing'
+ };
+
+ ### and this is the munged version of the input string,
+ ### ie what's left of the input minus the options
+ $munged = 'command arg';
+
+As you can see, you can either use a single or a double C<-> to
+indicate an option.
+If you prefix an option with C<no-> and do not give it a value, it
+will be set to 0.
+If it has no prefix and no value, it will be set to 1.
+Otherwise, it will be set to its value. Note also that it can deal
+fine with single/double quoting issues.
+
+=cut
+
+sub parse_options {
+ my $term = shift;
+ my $input = shift;
+
+ my $return = {};
+
+ ### there's probably a more elegant way to do this... ###
+ while ( $input =~ s/(?:^|\s+)--?([-\w]+=("|').+?\2)(?=\Z|\s+)// or
+ $input =~ s/(?:^|\s+)--?([-\w]+=\S+)(?=\Z|\s+)// or
+ $input =~ s/(?:^|\s+)--?([-\w]+)(?=\Z|\s+)//
+ ) {
+ my $match = $1;
+
+ if( $match =~ /^([-\w]+)=("|')(.+?)\2$/ ) {
+ $return->{$1} = $3;
+
+ } elsif( $match =~ /^([-\w]+)=(\S+)$/ ) {
+ $return->{$1} = $2;
+
+ } elsif( $match =~ /^no-?([-\w]+)$/i ) {
+ $return->{$1} = 0;
+
+ } elsif ( $match =~ /^([-\w]+)$/ ) {
+ $return->{$1} = 1;
+
+ } else {
+ carp(loc(q[I do not understand option "%1"\n], $match)) if $VERBOSE;
+ }
+ }
+
+ return wantarray ? ($return,$input) : $return;
+}
+
+=head2 $str = $term->history_as_string
+
+Convenience wrapper around C<< Term::UI::History->history_as_string >>.
+
+Consult the C<Term::UI::History> man page for details.
+
+=cut
+
+sub history_as_string { return Term::UI::History->history_as_string };
+
+1;
+
+=head1 GLOBAL VARIABLES
+
+The behaviour of Term::UI can be altered by changing the following
+global variables:
+
+=head2 $Term::UI::VERBOSE
+
+This controls whether Term::UI will issue warnings and explanations
+as to why certain things may have failed. If you set it to 0,
+Term::UI will not output any warnings.
+The default is 1;
+
+=head2 $Term::UI::AUTOREPLY
+
+This will make every question be answered by the default, and warn if
+there was no default provided. This is particularly useful if your
+program is run in non-interactive mode.
+The default is 0;
+
+=head2 $Term::UI::INVALID
+
+This holds the string that will be printed when the user makes an
+invalid choice.
+You can override this string from your program if you, for example,
+wish to do localization.
+The default is C<Invalid selection, please try again: >
+
+=head2 $Term::UI::History::HISTORY_FH
+
+This is the filehandle all the print statements from this module
+are being sent to. Please consult the C<Term::UI::History> manpage
+for details.
+
+This defaults to C<*STDOUT>.
+
+=head1 EXAMPLES
+
+=head2 Basic get_reply sample
+
+ ### ask a user (with an open question) for their favourite colour
+ $reply = $term->get_reply( prompt => 'Your favourite colour? );
+
+which would look like:
+
+ Your favourite colour?
+
+and C<$reply> would hold the text the user typed.
+
+=head2 get_reply with choices
+
+ ### now provide a list of choices, so the user has to pick one
+ $reply = $term->get_reply(
+ prompt => 'Your favourite colour?',
+ choices => [qw|red green blue|] );
+
+which would look like:
+
+ 1> red
+ 2> green
+ 3> blue
+
+ Your favourite colour?
+
+C<$reply> will hold one of the choices presented. C<Term::UI> will repose
+the question if the user attempts to enter an answer that's not in the
+list of choices. The string presented is held in the C<$Term::UI::INVALID>
+variable (see the C<GLOBAL VARIABLES> section for details.
+
+=head2 get_reply with choices and default
+
+ ### provide a sensible default option -- everyone loves blue!
+ $reply = $term->get_reply(
+ prompt => 'Your favourite colour?',
+ choices => [qw|red green blue|],
+ default => 'blue' );
+
+which would look like:
+
+ 1> red
+ 2> green
+ 3> blue
+
+ Your favourite colour? [3]:
+
+Note the default answer after the prompt. A user can now just hit C<enter>
+(or set C<$Term::UI::AUTOREPLY> -- see the C<GLOBAL VARIABLES> section) and
+the sensible answer 'blue' will be returned.
+
+=head2 get_reply using print_me & multi
+
+ ### allow the user to pick more than one colour and add an
+ ### introduction text
+ @reply = $term->get_reply(
+ print_me => 'Tell us what colours you like',
+ prompt => 'Your favourite colours?',
+ choices => [qw|red green blue|],
+ multi => 1 );
+
+which would look like:
+
+ Tell us what colours you like
+ 1> red
+ 2> green
+ 3> blue
+
+ Your favourite colours?
+
+An answer of C<3 2 1> would fill C<@reply> with C<blue green red>
+
+=head2 get_reply & allow
+
+ ### pose an open question, but do a custom verification on
+ ### the answer, which will only exit the question loop, if
+ ### the answer matches the allow handler.
+ $reply = $term->get_reply(
+ prompt => "What is the magic number?",
+ allow => 42 );
+
+Unless the user now enters C<42>, the question will be reposed over
+and over again. You can use more sophisticated C<allow> handlers (even
+subroutines can be used). The C<allow> handler is implemented using
+C<Params::Check>'s C<allow> function. Check its manpage for details.
+
+=head2 an elaborate ask_yn sample
+
+ ### ask a user if he likes cookies. Default to a sensible 'yes'
+ ### and inform him first what cookies are.
+ $bool = $term->ask_yn( prompt => 'Do you like cookies?',
+ default => 'y',
+ print_me => 'Cookies are LOVELY!!!' );
+
+would print:
+
+ Cookies are LOVELY!!!
+ Do you like cookies? [Y/n]:
+
+If a user then simply hits C<enter>, agreeing with the default,
+C<$bool> would be set to C<true>. (Simply hitting 'y' would also
+return C<true>. Hitting 'n' would return C<false>)
+
+We could later retrieve this interaction by printing out the Q&A
+history as follows:
+
+ print $term->history_as_string;
+
+which would then print:
+
+ Cookies are LOVELY!!!
+ Do you like cookies? [Y/n]: y
+
+There's a chance we're doing this non-interactively, because a console
+is missing, the user indicated he just wanted the defaults, etc.
+
+In this case, simply setting C<$Term::UI::AUTOREPLY> to true, will
+return from every question with the default answer set for the question.
+Do note that if C<AUTOREPLY> is true, and no default is set, C<Term::UI>
+will warn about this and return C<undef>.
+
+=head1 See Also
+
+C<Params::Check>, C<Term::ReadLine>, C<Term::UI::History>
+
+=head1 BUG REPORTS
+
+Please report bugs or other issues to E<lt>bug-term-ui at rt.cpan.org<gt>.
+
+=head1 AUTHOR
+
+This module by Jos Boumans E<lt>kane at cpan.orgE<gt>.
+
+=head1 COPYRIGHT
+
+This library is free software; you may redistribute and/or modify it
+under the same terms as Perl itself.
+
+=cut
Copied: trunk/contrib/perl/lib/Test.pm (from rev 6437, vendor/perl/5.18.1/lib/Test.pm)
===================================================================
--- trunk/contrib/perl/lib/Test.pm (rev 0)
+++ trunk/contrib/perl/lib/Test.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,954 @@
+
+require 5.004;
+package Test;
+
+use strict;
+
+use Carp;
+use vars (qw($VERSION @ISA @EXPORT @EXPORT_OK $ntest $TestLevel), #public-ish
+ qw($TESTOUT $TESTERR %Program_Lines $told_about_diff
+ $ONFAIL %todo %history $planned @FAILDETAIL) #private-ish
+ );
+
+# In case a test is run in a persistent environment.
+sub _reset_globals {
+ %todo = ();
+ %history = ();
+ @FAILDETAIL = ();
+ $ntest = 1;
+ $TestLevel = 0; # how many extra stack frames to skip
+ $planned = 0;
+}
+
+$VERSION = '1.25_02';
+require Exporter;
+ at ISA=('Exporter');
+
+ at EXPORT = qw(&plan &ok &skip);
+ at EXPORT_OK = qw($ntest $TESTOUT $TESTERR);
+
+$|=1;
+$TESTOUT = *STDOUT{IO};
+$TESTERR = *STDERR{IO};
+
+# Use of this variable is strongly discouraged. It is set mainly to
+# help test coverage analyzers know which test is running.
+$ENV{REGRESSION_TEST} = $0;
+
+
+=head1 NAME
+
+Test - provides a simple framework for writing test scripts
+
+=head1 SYNOPSIS
+
+ use strict;
+ use Test;
+
+ # use a BEGIN block so we print our plan before MyModule is loaded
+ BEGIN { plan tests => 14, todo => [3,4] }
+
+ # load your module...
+ use MyModule;
+
+ # Helpful notes. All note-lines must start with a "#".
+ print "# I'm testing MyModule version $MyModule::VERSION\n";
+
+ ok(0); # failure
+ ok(1); # success
+
+ ok(0); # ok, expected failure (see todo list, above)
+ ok(1); # surprise success!
+
+ ok(0,1); # failure: '0' ne '1'
+ ok('broke','fixed'); # failure: 'broke' ne 'fixed'
+ ok('fixed','fixed'); # success: 'fixed' eq 'fixed'
+ ok('fixed',qr/x/); # success: 'fixed' =~ qr/x/
+
+ ok(sub { 1+1 }, 2); # success: '2' eq '2'
+ ok(sub { 1+1 }, 3); # failure: '2' ne '3'
+
+ my @list = (0,0);
+ ok @list, 3, "\@list=".join(',', at list); #extra notes
+ ok 'segmentation fault', '/(?i)success/'; #regex match
+
+ skip(
+ $^O =~ m/MSWin/ ? "Skip if MSWin" : 0, # whether to skip
+ $foo, $bar # arguments just like for ok(...)
+ );
+ skip(
+ $^O =~ m/MSWin/ ? 0 : "Skip unless MSWin", # whether to skip
+ $foo, $bar # arguments just like for ok(...)
+ );
+
+=head1 DESCRIPTION
+
+This module simplifies the task of writing test files for Perl modules,
+such that their output is in the format that
+L<Test::Harness|Test::Harness> expects to see.
+
+=head1 QUICK START GUIDE
+
+To write a test for your new (and probably not even done) module, create
+a new file called F<t/test.t> (in a new F<t> directory). If you have
+multiple test files, to test the "foo", "bar", and "baz" feature sets,
+then feel free to call your files F<t/foo.t>, F<t/bar.t>, and
+F<t/baz.t>
+
+=head2 Functions
+
+This module defines three public functions, C<plan(...)>, C<ok(...)>,
+and C<skip(...)>. By default, all three are exported by
+the C<use Test;> statement.
+
+=over 4
+
+=item C<plan(...)>
+
+ BEGIN { plan %theplan; }
+
+This should be the first thing you call in your test script. It
+declares your testing plan, how many there will be, if any of them
+should be allowed to fail, and so on.
+
+Typical usage is just:
+
+ use Test;
+ BEGIN { plan tests => 23 }
+
+These are the things that you can put in the parameters to plan:
+
+=over
+
+=item C<tests =E<gt> I<number>>
+
+The number of tests in your script.
+This means all ok() and skip() calls.
+
+=item C<todo =E<gt> [I<1,5,14>]>
+
+A reference to a list of tests which are allowed to fail.
+See L</TODO TESTS>.
+
+=item C<onfail =E<gt> sub { ... }>
+
+=item C<onfail =E<gt> \&some_sub>
+
+A subroutine reference to be run at the end of the test script, if
+any of the tests fail. See L</ONFAIL>.
+
+=back
+
+You must call C<plan(...)> once and only once. You should call it
+in a C<BEGIN {...}> block, like so:
+
+ BEGIN { plan tests => 23 }
+
+=cut
+
+sub plan {
+ croak "Test::plan(%args): odd number of arguments" if @_ & 1;
+ croak "Test::plan(): should not be called more than once" if $planned;
+
+ local($\, $,); # guard against -l and other things that screw with
+ # print
+
+ _reset_globals();
+
+ _read_program( (caller)[1] );
+
+ my $max=0;
+ while (@_) {
+ my ($k,$v) = splice(@_, 0, 2);
+ if ($k =~ /^test(s)?$/) { $max = $v; }
+ elsif ($k eq 'todo' or
+ $k eq 'failok') { for (@$v) { $todo{$_}=1; }; }
+ elsif ($k eq 'onfail') {
+ ref $v eq 'CODE' or croak "Test::plan(onfail => $v): must be CODE";
+ $ONFAIL = $v;
+ }
+ else { carp "Test::plan(): skipping unrecognized directive '$k'" }
+ }
+ my @todo = sort { $a <=> $b } keys %todo;
+ if (@todo) {
+ print $TESTOUT "1..$max todo ".join(' ', @todo).";\n";
+ } else {
+ print $TESTOUT "1..$max\n";
+ }
+ ++$planned;
+ print $TESTOUT "# Running under perl version $] for $^O",
+ (chr(65) eq 'A') ? "\n" : " in a non-ASCII world\n";
+
+ print $TESTOUT "# Win32::BuildNumber ", &Win32::BuildNumber(), "\n"
+ if defined(&Win32::BuildNumber) and defined &Win32::BuildNumber();
+
+ print $TESTOUT "# MacPerl version $MacPerl::Version\n"
+ if defined $MacPerl::Version;
+
+ printf $TESTOUT
+ "# Current time local: %s\n# Current time GMT: %s\n",
+ scalar(localtime($^T)), scalar(gmtime($^T));
+
+ print $TESTOUT "# Using Test.pm version $VERSION\n";
+
+ # Retval never used:
+ return undef;
+}
+
+sub _read_program {
+ my($file) = shift;
+ return unless defined $file and length $file
+ and -e $file and -f _ and -r _;
+ open(SOURCEFILE, "<$file") || return;
+ $Program_Lines{$file} = [<SOURCEFILE>];
+ close(SOURCEFILE);
+
+ foreach my $x (@{$Program_Lines{$file}})
+ { $x =~ tr/\cm\cj\n\r//d }
+
+ unshift @{$Program_Lines{$file}}, '';
+ return 1;
+}
+
+=begin _private
+
+=item B<_to_value>
+
+ my $value = _to_value($input);
+
+Converts an C<ok> parameter to its value. Typically this just means
+running it, if it's a code reference. You should run all inputted
+values through this.
+
+=cut
+
+sub _to_value {
+ my ($v) = @_;
+ return ref $v eq 'CODE' ? $v->() : $v;
+}
+
+sub _quote {
+ my $str = $_[0];
+ return "<UNDEF>" unless defined $str;
+ $str =~ s/\\/\\\\/g;
+ $str =~ s/"/\\"/g;
+ $str =~ s/\a/\\a/g;
+ $str =~ s/[\b]/\\b/g;
+ $str =~ s/\e/\\e/g;
+ $str =~ s/\f/\\f/g;
+ $str =~ s/\n/\\n/g;
+ $str =~ s/\r/\\r/g;
+ $str =~ s/\t/\\t/g;
+ $str =~ s/([\0-\037])(?!\d)/sprintf('\\%o',ord($1))/eg;
+ $str =~ s/([\0-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg;
+ $str =~ s/([^\0-\176])/sprintf('\\x{%X}',ord($1))/eg;
+ #if( $_[1] ) {
+ # substr( $str , 218-3 ) = "..."
+ # if length($str) >= 218 and !$ENV{PERL_TEST_NO_TRUNC};
+ #}
+ return qq("$str");
+}
+
+
+=end _private
+
+=item C<ok(...)>
+
+ ok(1 + 1 == 2);
+ ok($have, $expect);
+ ok($have, $expect, $diagnostics);
+
+This function is the reason for C<Test>'s existence. It's
+the basic function that
+handles printing "C<ok>" or "C<not ok>", along with the
+current test number. (That's what C<Test::Harness> wants to see.)
+
+In its most basic usage, C<ok(...)> simply takes a single scalar
+expression. If its value is true, the test passes; if false,
+the test fails. Examples:
+
+ # Examples of ok(scalar)
+
+ ok( 1 + 1 == 2 ); # ok if 1 + 1 == 2
+ ok( $foo =~ /bar/ ); # ok if $foo contains 'bar'
+ ok( baz($x + $y) eq 'Armondo' ); # ok if baz($x + $y) returns
+ # 'Armondo'
+ ok( @a == @b ); # ok if @a and @b are the same length
+
+The expression is evaluated in scalar context. So the following will
+work:
+
+ ok( @stuff ); # ok if @stuff has any elements
+ ok( !grep !defined $_, @stuff ); # ok if everything in @stuff is
+ # defined.
+
+A special case is if the expression is a subroutine reference (in either
+C<sub {...}> syntax or C<\&foo> syntax). In
+that case, it is executed and its value (true or false) determines if
+the test passes or fails. For example,
+
+ ok( sub { # See whether sleep works at least passably
+ my $start_time = time;
+ sleep 5;
+ time() - $start_time >= 4
+ });
+
+In its two-argument form, C<ok(I<arg1>, I<arg2>)> compares the two
+scalar values to see if they match. They match if both are undefined,
+or if I<arg2> is a regex that matches I<arg1>, or if they compare equal
+with C<eq>.
+
+ # Example of ok(scalar, scalar)
+
+ ok( "this", "that" ); # not ok, 'this' ne 'that'
+ ok( "", undef ); # not ok, "" is defined
+
+The second argument is considered a regex if it is either a regex
+object or a string that looks like a regex. Regex objects are
+constructed with the qr// operator in recent versions of perl. A
+string is considered to look like a regex if its first and last
+characters are "/", or if the first character is "m"
+and its second and last characters are both the
+same non-alphanumeric non-whitespace character. These regexp
+
+Regex examples:
+
+ ok( 'JaffO', '/Jaff/' ); # ok, 'JaffO' =~ /Jaff/
+ ok( 'JaffO', 'm|Jaff|' ); # ok, 'JaffO' =~ m|Jaff|
+ ok( 'JaffO', qr/Jaff/ ); # ok, 'JaffO' =~ qr/Jaff/;
+ ok( 'JaffO', '/(?i)jaff/ ); # ok, 'JaffO' =~ /jaff/i;
+
+If either (or both!) is a subroutine reference, it is run and used
+as the value for comparing. For example:
+
+ ok sub {
+ open(OUT, ">x.dat") || die $!;
+ print OUT "\x{e000}";
+ close OUT;
+ my $bytecount = -s 'x.dat';
+ unlink 'x.dat' or warn "Can't unlink : $!";
+ return $bytecount;
+ },
+ 4
+ ;
+
+The above test passes two values to C<ok(arg1, arg2)> -- the first
+a coderef, and the second is the number 4. Before C<ok> compares them,
+it calls the coderef, and uses its return value as the real value of
+this parameter. Assuming that C<$bytecount> returns 4, C<ok> ends up
+testing C<4 eq 4>. Since that's true, this test passes.
+
+Finally, you can append an optional third argument, in
+C<ok(I<arg1>,I<arg2>, I<note>)>, where I<note> is a string value that
+will be printed if the test fails. This should be some useful
+information about the test, pertaining to why it failed, and/or
+a description of the test. For example:
+
+ ok( grep($_ eq 'something unique', @stuff), 1,
+ "Something that should be unique isn't!\n".
+ '@stuff = '.join ', ', @stuff
+ );
+
+Unfortunately, a note cannot be used with the single argument
+style of C<ok()>. That is, if you try C<ok(I<arg1>, I<note>)>, then
+C<Test> will interpret this as C<ok(I<arg1>, I<arg2>)>, and probably
+end up testing C<I<arg1> eq I<arg2>> -- and that's not what you want!
+
+All of the above special cases can occasionally cause some
+problems. See L</BUGS and CAVEATS>.
+
+=cut
+
+# A past maintainer of this module said:
+# <<ok(...)'s special handling of subroutine references is an unfortunate
+# "feature" that can't be removed due to compatibility.>>
+#
+
+sub ok ($;$$) {
+ croak "ok: plan before you test!" if !$planned;
+
+ local($\,$,); # guard against -l and other things that screw with
+ # print
+
+ my ($pkg,$file,$line) = caller($TestLevel);
+ my $repetition = ++$history{"$file:$line"};
+ my $context = ("$file at line $line".
+ ($repetition > 1 ? " fail \#$repetition" : ''));
+
+ # Are we comparing two values?
+ my $compare = 0;
+
+ my $ok=0;
+ my $result = _to_value(shift);
+ my ($expected, $isregex, $regex);
+ if (@_ == 0) {
+ $ok = $result;
+ } else {
+ $compare = 1;
+ $expected = _to_value(shift);
+ if (!defined $expected) {
+ $ok = !defined $result;
+ } elsif (!defined $result) {
+ $ok = 0;
+ } elsif (ref($expected) eq 'Regexp') {
+ $ok = $result =~ /$expected/;
+ $regex = $expected;
+ } elsif (($regex) = ($expected =~ m,^ / (.+) / $,sx) or
+ (undef, $regex) = ($expected =~ m,^ m([^\w\s]) (.+) \1 $,sx)) {
+ $ok = $result =~ /$regex/;
+ } else {
+ $ok = $result eq $expected;
+ }
+ }
+ my $todo = $todo{$ntest};
+ if ($todo and $ok) {
+ $context .= ' TODO?!' if $todo;
+ print $TESTOUT "ok $ntest # ($context)\n";
+ } else {
+ # Issuing two seperate prints() causes problems on VMS.
+ if (!$ok) {
+ print $TESTOUT "not ok $ntest\n";
+ }
+ else {
+ print $TESTOUT "ok $ntest\n";
+ }
+
+ $ok or _complain($result, $expected,
+ {
+ 'repetition' => $repetition, 'package' => $pkg,
+ 'result' => $result, 'todo' => $todo,
+ 'file' => $file, 'line' => $line,
+ 'context' => $context, 'compare' => $compare,
+ @_ ? ('diagnostic' => _to_value(shift)) : (),
+ });
+
+ }
+ ++ $ntest;
+ $ok;
+}
+
+
+sub _complain {
+ my($result, $expected, $detail) = @_;
+ $$detail{expected} = $expected if defined $expected;
+
+ # Get the user's diagnostic, protecting against multi-line
+ # diagnostics.
+ my $diag = $$detail{diagnostic};
+ $diag =~ s/\n/\n#/g if defined $diag;
+
+ $$detail{context} .= ' *TODO*' if $$detail{todo};
+ if (!$$detail{compare}) {
+ if (!$diag) {
+ print $TESTERR "# Failed test $ntest in $$detail{context}\n";
+ } else {
+ print $TESTERR "# Failed test $ntest in $$detail{context}: $diag\n";
+ }
+ } else {
+ my $prefix = "Test $ntest";
+
+ print $TESTERR "# $prefix got: " . _quote($result) .
+ " ($$detail{context})\n";
+ $prefix = ' ' x (length($prefix) - 5);
+ my $expected_quoted = (defined $$detail{regex})
+ ? 'qr{'.($$detail{regex}).'}' : _quote($expected);
+
+ print $TESTERR "# $prefix Expected: $expected_quoted",
+ $diag ? " ($diag)" : (), "\n";
+
+ _diff_complain( $result, $expected, $detail, $prefix )
+ if defined($expected) and 2 < ($expected =~ tr/\n//);
+ }
+
+ if(defined $Program_Lines{ $$detail{file} }[ $$detail{line} ]) {
+ print $TESTERR
+ "# $$detail{file} line $$detail{line} is: $Program_Lines{ $$detail{file} }[ $$detail{line} ]\n"
+ if $Program_Lines{ $$detail{file} }[ $$detail{line} ]
+ =~ m/[^\s\#\(\)\{\}\[\]\;]/; # Otherwise it's uninformative
+
+ undef $Program_Lines{ $$detail{file} }[ $$detail{line} ];
+ # So we won't repeat it.
+ }
+
+ push @FAILDETAIL, $detail;
+ return;
+}
+
+
+
+sub _diff_complain {
+ my($result, $expected, $detail, $prefix) = @_;
+ return _diff_complain_external(@_) if $ENV{PERL_TEST_DIFF};
+ return _diff_complain_algdiff(@_)
+ if eval { require Algorithm::Diff; Algorithm::Diff->VERSION(1.15); 1; };
+
+ $told_about_diff++ or print $TESTERR <<"EOT";
+# $prefix (Install the Algorithm::Diff module to have differences in multiline
+# $prefix output explained. You might also set the PERL_TEST_DIFF environment
+# $prefix variable to run a diff program on the output.)
+EOT
+ ;
+ return;
+}
+
+
+
+sub _diff_complain_external {
+ my($result, $expected, $detail, $prefix) = @_;
+ my $diff = $ENV{PERL_TEST_DIFF} || die "WHAAAA?";
+
+ require File::Temp;
+ my($got_fh, $got_filename) = File::Temp::tempfile("test-got-XXXXX");
+ my($exp_fh, $exp_filename) = File::Temp::tempfile("test-exp-XXXXX");
+ unless ($got_fh && $exp_fh) {
+ warn "Can't get tempfiles";
+ return;
+ }
+
+ print $got_fh $result;
+ print $exp_fh $expected;
+ if (close($got_fh) && close($exp_fh)) {
+ my $diff_cmd = "$diff $exp_filename $got_filename";
+ print $TESTERR "#\n# $prefix $diff_cmd\n";
+ if (open(DIFF, "$diff_cmd |")) {
+ local $_;
+ while (<DIFF>) {
+ print $TESTERR "# $prefix $_";
+ }
+ close(DIFF);
+ }
+ else {
+ warn "Can't run diff: $!";
+ }
+ } else {
+ warn "Can't write to tempfiles: $!";
+ }
+ unlink($got_filename);
+ unlink($exp_filename);
+ return;
+}
+
+
+
+sub _diff_complain_algdiff {
+ my($result, $expected, $detail, $prefix) = @_;
+
+ my @got = split(/^/, $result);
+ my @exp = split(/^/, $expected);
+
+ my $diff_kind;
+ my @diff_lines;
+
+ my $diff_flush = sub {
+ return unless $diff_kind;
+
+ my $count_lines = @diff_lines;
+ my $s = $count_lines == 1 ? "" : "s";
+ my $first_line = $diff_lines[0][0] + 1;
+
+ print $TESTERR "# $prefix ";
+ if ($diff_kind eq "GOT") {
+ print $TESTERR "Got $count_lines extra line$s at line $first_line:\n";
+ for my $i (@diff_lines) {
+ print $TESTERR "# $prefix + " . _quote($got[$i->[0]]) . "\n";
+ }
+ } elsif ($diff_kind eq "EXP") {
+ if ($count_lines > 1) {
+ my $last_line = $diff_lines[-1][0] + 1;
+ print $TESTERR "Lines $first_line-$last_line are";
+ }
+ else {
+ print $TESTERR "Line $first_line is";
+ }
+ print $TESTERR " missing:\n";
+ for my $i (@diff_lines) {
+ print $TESTERR "# $prefix - " . _quote($exp[$i->[1]]) . "\n";
+ }
+ } elsif ($diff_kind eq "CH") {
+ if ($count_lines > 1) {
+ my $last_line = $diff_lines[-1][0] + 1;
+ print $TESTERR "Lines $first_line-$last_line are";
+ }
+ else {
+ print $TESTERR "Line $first_line is";
+ }
+ print $TESTERR " changed:\n";
+ for my $i (@diff_lines) {
+ print $TESTERR "# $prefix - " . _quote($exp[$i->[1]]) . "\n";
+ print $TESTERR "# $prefix + " . _quote($got[$i->[0]]) . "\n";
+ }
+ }
+
+ # reset
+ $diff_kind = undef;
+ @diff_lines = ();
+ };
+
+ my $diff_collect = sub {
+ my $kind = shift;
+ &$diff_flush() if $diff_kind && $diff_kind ne $kind;
+ $diff_kind = $kind;
+ push(@diff_lines, [@_]);
+ };
+
+
+ Algorithm::Diff::traverse_balanced(
+ \@got, \@exp,
+ {
+ DISCARD_A => sub { &$diff_collect("GOT", @_) },
+ DISCARD_B => sub { &$diff_collect("EXP", @_) },
+ CHANGE => sub { &$diff_collect("CH", @_) },
+ MATCH => sub { &$diff_flush() },
+ },
+ );
+ &$diff_flush();
+
+ return;
+}
+
+
+
+
+#~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~
+
+
+=item C<skip(I<skip_if_true>, I<args...>)>
+
+This is used for tests that under some conditions can be skipped. It's
+basically equivalent to:
+
+ if( $skip_if_true ) {
+ ok(1);
+ } else {
+ ok( args... );
+ }
+
+...except that the C<ok(1)> emits not just "C<ok I<testnum>>" but
+actually "C<ok I<testnum> # I<skip_if_true_value>>".
+
+The arguments after the I<skip_if_true> are what is fed to C<ok(...)> if
+this test isn't skipped.
+
+Example usage:
+
+ my $if_MSWin =
+ $^O =~ m/MSWin/ ? 'Skip if under MSWin' : '';
+
+ # A test to be skipped if under MSWin (i.e., run except under MSWin)
+ skip($if_MSWin, thing($foo), thing($bar) );
+
+Or, going the other way:
+
+ my $unless_MSWin =
+ $^O =~ m/MSWin/ ? '' : 'Skip unless under MSWin';
+
+ # A test to be skipped unless under MSWin (i.e., run only under MSWin)
+ skip($unless_MSWin, thing($foo), thing($bar) );
+
+The tricky thing to remember is that the first parameter is true if
+you want to I<skip> the test, not I<run> it; and it also doubles as a
+note about why it's being skipped. So in the first codeblock above, read
+the code as "skip if MSWin -- (otherwise) test whether C<thing($foo)> is
+C<thing($bar)>" or for the second case, "skip unless MSWin...".
+
+Also, when your I<skip_if_reason> string is true, it really should (for
+backwards compatibility with older Test.pm versions) start with the
+string "Skip", as shown in the above examples.
+
+Note that in the above cases, C<thing($foo)> and C<thing($bar)>
+I<are> evaluated -- but as long as the C<skip_if_true> is true,
+then we C<skip(...)> just tosses out their value (i.e., not
+bothering to treat them like values to C<ok(...)>. But if
+you need to I<not> eval the arguments when skipping the
+test, use
+this format:
+
+ skip( $unless_MSWin,
+ sub {
+ # This code returns true if the test passes.
+ # (But it doesn't even get called if the test is skipped.)
+ thing($foo) eq thing($bar)
+ }
+ );
+
+or even this, which is basically equivalent:
+
+ skip( $unless_MSWin,
+ sub { thing($foo) }, sub { thing($bar) }
+ );
+
+That is, both are like this:
+
+ if( $unless_MSWin ) {
+ ok(1); # but it actually appends "# $unless_MSWin"
+ # so that Test::Harness can tell it's a skip
+ } else {
+ # Not skipping, so actually call and evaluate...
+ ok( sub { thing($foo) }, sub { thing($bar) } );
+ }
+
+=cut
+
+sub skip ($;$$$) {
+ local($\, $,); # guard against -l and other things that screw with
+ # print
+
+ my $whyskip = _to_value(shift);
+ if (!@_ or $whyskip) {
+ $whyskip = '' if $whyskip =~ m/^\d+$/;
+ $whyskip =~ s/^[Ss]kip(?:\s+|$)//; # backwards compatibility, old
+ # versions required the reason
+ # to start with 'skip'
+ # We print in one shot for VMSy reasons.
+ my $ok = "ok $ntest # skip";
+ $ok .= " $whyskip" if length $whyskip;
+ $ok .= "\n";
+ print $TESTOUT $ok;
+ ++ $ntest;
+ return 1;
+ } else {
+ # backwards compatibility (I think). skip() used to be
+ # called like ok(), which is weird. I haven't decided what to do with
+ # this yet.
+# warn <<WARN if $^W;
+#This looks like a skip() using the very old interface. Please upgrade to
+#the documented interface as this has been deprecated.
+#WARN
+
+ local($TestLevel) = $TestLevel+1; #to ignore this stack frame
+ return &ok(@_);
+ }
+}
+
+=back
+
+=cut
+
+END {
+ $ONFAIL->(\@FAILDETAIL) if @FAILDETAIL && $ONFAIL;
+}
+
+1;
+__END__
+
+=head1 TEST TYPES
+
+=over 4
+
+=item * NORMAL TESTS
+
+These tests are expected to succeed. Usually, most or all of your tests
+are in this category. If a normal test doesn't succeed, then that
+means that something is I<wrong>.
+
+=item * SKIPPED TESTS
+
+The C<skip(...)> function is for tests that might or might not be
+possible to run, depending
+on the availability of platform-specific features. The first argument
+should evaluate to true (think "yes, please skip") if the required
+feature is I<not> available. After the first argument, C<skip(...)> works
+exactly the same way as C<ok(...)> does.
+
+=item * TODO TESTS
+
+TODO tests are designed for maintaining an B<executable TODO list>.
+These tests are I<expected to fail.> If a TODO test does succeed,
+then the feature in question shouldn't be on the TODO list, now
+should it?
+
+Packages should NOT be released with succeeding TODO tests. As soon
+as a TODO test starts working, it should be promoted to a normal test,
+and the newly working feature should be documented in the release
+notes or in the change log.
+
+=back
+
+=head1 ONFAIL
+
+ BEGIN { plan test => 4, onfail => sub { warn "CALL 911!" } }
+
+Although test failures should be enough, extra diagnostics can be
+triggered at the end of a test run. C<onfail> is passed an array ref
+of hash refs that describe each test failure. Each hash will contain
+at least the following fields: C<package>, C<repetition>, and
+C<result>. (You shouldn't rely on any other fields being present.) If the test
+had an expected value or a diagnostic (or "note") string, these will also be
+included.
+
+The I<optional> C<onfail> hook might be used simply to print out the
+version of your package and/or how to report problems. It might also
+be used to generate extremely sophisticated diagnostics for a
+particularly bizarre test failure. However it's not a panacea. Core
+dumps or other unrecoverable errors prevent the C<onfail> hook from
+running. (It is run inside an C<END> block.) Besides, C<onfail> is
+probably over-kill in most cases. (Your test code should be simpler
+than the code it is testing, yes?)
+
+
+=head1 BUGS and CAVEATS
+
+=over
+
+=item *
+
+C<ok(...)>'s special handing of strings which look like they might be
+regexes can also cause unexpected behavior. An innocent:
+
+ ok( $fileglob, '/path/to/some/*stuff/' );
+
+will fail, since Test.pm considers the second argument to be a regex!
+The best bet is to use the one-argument form:
+
+ ok( $fileglob eq '/path/to/some/*stuff/' );
+
+=item *
+
+C<ok(...)>'s use of string C<eq> can sometimes cause odd problems
+when comparing
+numbers, especially if you're casting a string to a number:
+
+ $foo = "1.0";
+ ok( $foo, 1 ); # not ok, "1.0" ne 1
+
+Your best bet is to use the single argument form:
+
+ ok( $foo == 1 ); # ok "1.0" == 1
+
+=item *
+
+As you may have inferred from the above documentation and examples,
+C<ok>'s prototype is C<($;$$)> (and, incidentally, C<skip>'s is
+C<($;$$$)>). This means, for example, that you can do C<ok @foo, @bar>
+to compare the I<size> of the two arrays. But don't be fooled into
+thinking that C<ok @foo, @bar> means a comparison of the contents of two
+arrays -- you're comparing I<just> the number of elements of each. It's
+so easy to make that mistake in reading C<ok @foo, @bar> that you might
+want to be very explicit about it, and instead write C<ok scalar(@foo),
+scalar(@bar)>.
+
+=item *
+
+This almost definitely doesn't do what you expect:
+
+ ok $thingy->can('some_method');
+
+Why? Because C<can> returns a coderef to mean "yes it can (and the
+method is this...)", and then C<ok> sees a coderef and thinks you're
+passing a function that you want it to call and consider the truth of
+the result of! I.e., just like:
+
+ ok $thingy->can('some_method')->();
+
+What you probably want instead is this:
+
+ ok $thingy->can('some_method') && 1;
+
+If the C<can> returns false, then that is passed to C<ok>. If it
+returns true, then the larger expression S<< C<<
+$thingy->can('some_method') && 1 >> >> returns 1, which C<ok> sees as
+a simple signal of success, as you would expect.
+
+
+=item *
+
+The syntax for C<skip> is about the only way it can be, but it's still
+quite confusing. Just start with the above examples and you'll
+be okay.
+
+Moreover, users may expect this:
+
+ skip $unless_mswin, foo($bar), baz($quux);
+
+to not evaluate C<foo($bar)> and C<baz($quux)> when the test is being
+skipped. But in reality, they I<are> evaluated, but C<skip> just won't
+bother comparing them if C<$unless_mswin> is true.
+
+You could do this:
+
+ skip $unless_mswin, sub{foo($bar)}, sub{baz($quux)};
+
+But that's not terribly pretty. You may find it simpler or clearer in
+the long run to just do things like this:
+
+ if( $^O =~ m/MSWin/ ) {
+ print "# Yay, we're under $^O\n";
+ ok foo($bar), baz($quux);
+ ok thing($whatever), baz($stuff);
+ ok blorp($quux, $whatever);
+ ok foo($barzbarz), thang($quux);
+ } else {
+ print "# Feh, we're under $^O. Watch me skip some tests...\n";
+ for(1 .. 4) { skip "Skip unless under MSWin" }
+ }
+
+But be quite sure that C<ok> is called exactly as many times in the
+first block as C<skip> is called in the second block.
+
+=back
+
+
+=head1 ENVIRONMENT
+
+If C<PERL_TEST_DIFF> environment variable is set, it will be used as a
+command for comparing unexpected multiline results. If you have GNU
+diff installed, you might want to set C<PERL_TEST_DIFF> to C<diff -u>.
+If you don't have a suitable program, you might install the
+C<Text::Diff> module and then set C<PERL_TEST_DIFF> to be C<perl
+-MText::Diff -e 'print diff(@ARGV)'>. If C<PERL_TEST_DIFF> isn't set
+but the C<Algorithm::Diff> module is available, then it will be used
+to show the differences in multiline results.
+
+=for comment
+If C<PERL_TEST_NO_TRUNC> is set, then the initial "Got 'something' but
+expected 'something_else'" readings for long multiline output values aren't
+truncated at about the 230th column, as they normally could be in some
+cases. Normally you won't need to use this, unless you were carefully
+parsing the output of your test programs.
+
+
+=head1 NOTE
+
+A past developer of this module once said that it was no longer being
+actively developed. However, rumors of its demise were greatly
+exaggerated. Feedback and suggestions are quite welcome.
+
+Be aware that the main value of this module is its simplicity. Note
+that there are already more ambitious modules out there, such as
+L<Test::More> and L<Test::Unit>.
+
+Some earlier versions of this module had docs with some confusing
+typos in the description of C<skip(...)>.
+
+
+=head1 SEE ALSO
+
+L<Test::Harness>
+
+L<Test::Simple>, L<Test::More>, L<Devel::Cover>
+
+L<Test::Builder> for building your own testing library.
+
+L<Test::Unit> is an interesting XUnit-style testing library.
+
+L<Test::Inline> and L<SelfTest> let you embed tests in code.
+
+
+=head1 AUTHOR
+
+Copyright (c) 1998-2000 Joshua Nathaniel Pritikin.
+
+Copyright (c) 2001-2002 Michael G. Schwern.
+
+Copyright (c) 2002-2004 Sean M. Burke.
+
+Current maintainer: Jesse Vincent. E<lt>jesse at bestpractical.comE<gt>
+
+This package is free software and is provided "as is" without express
+or implied warranty. It may be used, redistributed and/or modified
+under the same terms as Perl itself.
+
+=cut
+
+# "Your mistake was a hidden intention."
+# -- /Oblique Strategies/, Brian Eno and Peter Schmidt
Index: trunk/contrib/perl/lib/Text/Abbrev.pm
===================================================================
--- trunk/contrib/perl/lib/Text/Abbrev.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Text/Abbrev.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Text/Abbrev.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/Text/Abbrev.t
===================================================================
--- trunk/contrib/perl/lib/Text/Abbrev.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Text/Abbrev.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Text/Abbrev.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/lib/Text/Balanced.pm (from rev 6437, vendor/perl/5.18.1/lib/Text/Balanced.pm)
===================================================================
--- trunk/contrib/perl/lib/Text/Balanced.pm (rev 0)
+++ trunk/contrib/perl/lib/Text/Balanced.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,2306 @@
+# EXTRACT VARIOUSLY DELIMITED TEXT SEQUENCES FROM STRINGS.
+# FOR FULL DOCUMENTATION SEE Balanced.pod
+
+use 5.005;
+use strict;
+
+package Text::Balanced;
+
+use Exporter;
+use SelfLoader;
+use vars qw { $VERSION @ISA %EXPORT_TAGS };
+
+use version; $VERSION = qv('2.0.0');
+ at ISA = qw ( Exporter );
+
+%EXPORT_TAGS = ( ALL => [ qw(
+ &extract_delimited
+ &extract_bracketed
+ &extract_quotelike
+ &extract_codeblock
+ &extract_variable
+ &extract_tagged
+ &extract_multiple
+
+ &gen_delimited_pat
+ &gen_extract_tagged
+
+ &delimited_pat
+ ) ] );
+
+Exporter::export_ok_tags('ALL');
+
+# PROTOTYPES
+
+sub _match_bracketed($$$$$$);
+sub _match_variable($$);
+sub _match_codeblock($$$$$$$);
+sub _match_quotelike($$$$);
+
+# HANDLE RETURN VALUES IN VARIOUS CONTEXTS
+
+sub _failmsg {
+ my ($message, $pos) = @_;
+ $@ = bless { error=>$message, pos=>$pos }, "Text::Balanced::ErrorMsg";
+}
+
+sub _fail
+{
+ my ($wantarray, $textref, $message, $pos) = @_;
+ _failmsg $message, $pos if $message;
+ return (undef,$$textref,undef) if $wantarray;
+ return undef;
+}
+
+sub _succeed
+{
+ $@ = undef;
+ my ($wantarray,$textref) = splice @_, 0, 2;
+ my ($extrapos, $extralen) = @_>18 ? splice(@_, -2, 2) : (0,0);
+ my ($startlen, $oppos) = @_[5,6];
+ my $remainderpos = $_[2];
+ if ($wantarray)
+ {
+ my @res;
+ while (my ($from, $len) = splice @_, 0, 2)
+ {
+ push @res, substr($$textref,$from,$len);
+ }
+ if ($extralen) { # CORRECT FILLET
+ my $extra = substr($res[0], $extrapos-$oppos, $extralen, "\n");
+ $res[1] = "$extra$res[1]";
+ eval { substr($$textref,$remainderpos,0) = $extra;
+ substr($$textref,$extrapos,$extralen,"\n")} ;
+ #REARRANGE HERE DOC AND FILLET IF POSSIBLE
+ pos($$textref) = $remainderpos-$extralen+1; # RESET \G
+ }
+ else {
+ pos($$textref) = $remainderpos; # RESET \G
+ }
+ return @res;
+ }
+ else
+ {
+ my $match = substr($$textref,$_[0],$_[1]);
+ substr($match,$extrapos-$_[0]-$startlen,$extralen,"") if $extralen;
+ my $extra = $extralen
+ ? substr($$textref, $extrapos, $extralen)."\n" : "";
+ eval {substr($$textref,$_[4],$_[1]+$_[5])=$extra} ; #CHOP OUT PREFIX & MATCH, IF POSSIBLE
+ pos($$textref) = $_[4]; # RESET \G
+ return $match;
+ }
+}
+
+# BUILD A PATTERN MATCHING A SIMPLE DELIMITED STRING
+
+sub gen_delimited_pat($;$) # ($delimiters;$escapes)
+{
+ my ($dels, $escs) = @_;
+ return "" unless $dels =~ /\S/;
+ $escs = '\\' unless $escs;
+ $escs .= substr($escs,-1) x (length($dels)-length($escs));
+ my @pat = ();
+ my $i;
+ for ($i=0; $i<length $dels; $i++)
+ {
+ my $del = quotemeta substr($dels,$i,1);
+ my $esc = quotemeta substr($escs,$i,1);
+ if ($del eq $esc)
+ {
+ push @pat, "$del(?:[^$del]*(?:(?:$del$del)[^$del]*)*)$del";
+ }
+ else
+ {
+ push @pat, "$del(?:[^$esc$del]*(?:$esc.[^$esc$del]*)*)$del";
+ }
+ }
+ my $pat = join '|', @pat;
+ return "(?:$pat)";
+}
+
+*delimited_pat = \&gen_delimited_pat;
+
+
+# THE EXTRACTION FUNCTIONS
+
+sub extract_delimited (;$$$$)
+{
+ my $textref = defined $_[0] ? \$_[0] : \$_;
+ my $wantarray = wantarray;
+ my $del = defined $_[1] ? $_[1] : qq{\'\"\`};
+ my $pre = defined $_[2] ? $_[2] : '\s*';
+ my $esc = defined $_[3] ? $_[3] : qq{\\};
+ my $pat = gen_delimited_pat($del, $esc);
+ my $startpos = pos $$textref || 0;
+ return _fail($wantarray, $textref, "Not a delimited pattern", 0)
+ unless $$textref =~ m/\G($pre)($pat)/gc;
+ my $prelen = length($1);
+ my $matchpos = $startpos+$prelen;
+ my $endpos = pos $$textref;
+ return _succeed $wantarray, $textref,
+ $matchpos, $endpos-$matchpos, # MATCH
+ $endpos, length($$textref)-$endpos, # REMAINDER
+ $startpos, $prelen; # PREFIX
+}
+
+sub extract_bracketed (;$$$)
+{
+ my $textref = defined $_[0] ? \$_[0] : \$_;
+ my $ldel = defined $_[1] ? $_[1] : '{([<';
+ my $pre = defined $_[2] ? $_[2] : '\s*';
+ my $wantarray = wantarray;
+ my $qdel = "";
+ my $quotelike;
+ $ldel =~ s/'//g and $qdel .= q{'};
+ $ldel =~ s/"//g and $qdel .= q{"};
+ $ldel =~ s/`//g and $qdel .= q{`};
+ $ldel =~ s/q//g and $quotelike = 1;
+ $ldel =~ tr/[](){}<>\0-\377/[[(({{<</ds;
+ my $rdel = $ldel;
+ unless ($rdel =~ tr/[({</])}>/)
+ {
+ return _fail $wantarray, $textref,
+ "Did not find a suitable bracket in delimiter: \"$_[1]\"",
+ 0;
+ }
+ my $posbug = pos;
+ $ldel = join('|', map { quotemeta $_ } split('', $ldel));
+ $rdel = join('|', map { quotemeta $_ } split('', $rdel));
+ pos = $posbug;
+
+ my $startpos = pos $$textref || 0;
+ my @match = _match_bracketed($textref,$pre, $ldel, $qdel, $quotelike, $rdel);
+
+ return _fail ($wantarray, $textref) unless @match;
+
+ return _succeed ( $wantarray, $textref,
+ $match[2], $match[5]+2, # MATCH
+ @match[8,9], # REMAINDER
+ @match[0,1], # PREFIX
+ );
+}
+
+sub _match_bracketed($$$$$$) # $textref, $pre, $ldel, $qdel, $quotelike, $rdel
+{
+ my ($textref, $pre, $ldel, $qdel, $quotelike, $rdel) = @_;
+ my ($startpos, $ldelpos, $endpos) = (pos $$textref = pos $$textref||0);
+ unless ($$textref =~ m/\G$pre/gc)
+ {
+ _failmsg "Did not find prefix: /$pre/", $startpos;
+ return;
+ }
+
+ $ldelpos = pos $$textref;
+
+ unless ($$textref =~ m/\G($ldel)/gc)
+ {
+ _failmsg "Did not find opening bracket after prefix: \"$pre\"",
+ pos $$textref;
+ pos $$textref = $startpos;
+ return;
+ }
+
+ my @nesting = ( $1 );
+ my $textlen = length $$textref;
+ while (pos $$textref < $textlen)
+ {
+ next if $$textref =~ m/\G\\./gcs;
+
+ if ($$textref =~ m/\G($ldel)/gc)
+ {
+ push @nesting, $1;
+ }
+ elsif ($$textref =~ m/\G($rdel)/gc)
+ {
+ my ($found, $brackettype) = ($1, $1);
+ if ($#nesting < 0)
+ {
+ _failmsg "Unmatched closing bracket: \"$found\"",
+ pos $$textref;
+ pos $$textref = $startpos;
+ return;
+ }
+ my $expected = pop(@nesting);
+ $expected =~ tr/({[</)}]>/;
+ if ($expected ne $brackettype)
+ {
+ _failmsg qq{Mismatched closing bracket: expected "$expected" but found "$found"},
+ pos $$textref;
+ pos $$textref = $startpos;
+ return;
+ }
+ last if $#nesting < 0;
+ }
+ elsif ($qdel && $$textref =~ m/\G([$qdel])/gc)
+ {
+ $$textref =~ m/\G[^\\$1]*(?:\\.[^\\$1]*)*(\Q$1\E)/gsc and next;
+ _failmsg "Unmatched embedded quote ($1)",
+ pos $$textref;
+ pos $$textref = $startpos;
+ return;
+ }
+ elsif ($quotelike && _match_quotelike($textref,"",1,0))
+ {
+ next;
+ }
+
+ else { $$textref =~ m/\G(?:[a-zA-Z0-9]+|.)/gcs }
+ }
+ if ($#nesting>=0)
+ {
+ _failmsg "Unmatched opening bracket(s): "
+ . join("..", at nesting)."..",
+ pos $$textref;
+ pos $$textref = $startpos;
+ return;
+ }
+
+ $endpos = pos $$textref;
+
+ return (
+ $startpos, $ldelpos-$startpos, # PREFIX
+ $ldelpos, 1, # OPENING BRACKET
+ $ldelpos+1, $endpos-$ldelpos-2, # CONTENTS
+ $endpos-1, 1, # CLOSING BRACKET
+ $endpos, length($$textref)-$endpos, # REMAINDER
+ );
+}
+
+sub _revbracket($)
+{
+ my $brack = reverse $_[0];
+ $brack =~ tr/[({</])}>/;
+ return $brack;
+}
+
+my $XMLNAME = q{[a-zA-Z_:][a-zA-Z0-9_:.-]*};
+
+sub extract_tagged (;$$$$$) # ($text, $opentag, $closetag, $pre, \%options)
+{
+ my $textref = defined $_[0] ? \$_[0] : \$_;
+ my $ldel = $_[1];
+ my $rdel = $_[2];
+ my $pre = defined $_[3] ? $_[3] : '\s*';
+ my %options = defined $_[4] ? %{$_[4]} : ();
+ my $omode = defined $options{fail} ? $options{fail} : '';
+ my $bad = ref($options{reject}) eq 'ARRAY' ? join('|', @{$options{reject}})
+ : defined($options{reject}) ? $options{reject}
+ : ''
+ ;
+ my $ignore = ref($options{ignore}) eq 'ARRAY' ? join('|', @{$options{ignore}})
+ : defined($options{ignore}) ? $options{ignore}
+ : ''
+ ;
+
+ if (!defined $ldel) { $ldel = '<\w+(?:' . gen_delimited_pat(q{'"}) . '|[^>])*>'; }
+ $@ = undef;
+
+ my @match = _match_tagged($textref, $pre, $ldel, $rdel, $omode, $bad, $ignore);
+
+ return _fail(wantarray, $textref) unless @match;
+ return _succeed wantarray, $textref,
+ $match[2], $match[3]+$match[5]+$match[7], # MATCH
+ @match[8..9,0..1,2..7]; # REM, PRE, BITS
+}
+
+sub _match_tagged # ($$$$$$$)
+{
+ my ($textref, $pre, $ldel, $rdel, $omode, $bad, $ignore) = @_;
+ my $rdelspec;
+
+ my ($startpos, $opentagpos, $textpos, $parapos, $closetagpos, $endpos) = ( pos($$textref) = pos($$textref)||0 );
+
+ unless ($$textref =~ m/\G($pre)/gc)
+ {
+ _failmsg "Did not find prefix: /$pre/", pos $$textref;
+ goto failed;
+ }
+
+ $opentagpos = pos($$textref);
+
+ unless ($$textref =~ m/\G$ldel/gc)
+ {
+ _failmsg "Did not find opening tag: /$ldel/", pos $$textref;
+ goto failed;
+ }
+
+ $textpos = pos($$textref);
+
+ if (!defined $rdel)
+ {
+ $rdelspec = substr($$textref, $-[0], $+[0] - $-[0]);
+ unless ($rdelspec =~ s/\A([[(<{]+)($XMLNAME).*/ quotemeta "$1\/$2". _revbracket($1) /oes)
+ {
+ _failmsg "Unable to construct closing tag to match: $rdel",
+ pos $$textref;
+ goto failed;
+ }
+ }
+ else
+ {
+ $rdelspec = eval "qq{$rdel}" || do {
+ my $del;
+ for (qw,~ ! ^ & * ) _ + - = } ] : " ; ' > . ? / | ',)
+ { next if $rdel =~ /\Q$_/; $del = $_; last }
+ unless ($del) {
+ use Carp;
+ croak "Can't interpolate right delimiter $rdel"
+ }
+ eval "qq$del$rdel$del";
+ };
+ }
+
+ while (pos($$textref) < length($$textref))
+ {
+ next if $$textref =~ m/\G\\./gc;
+
+ if ($$textref =~ m/\G(\n[ \t]*\n)/gc )
+ {
+ $parapos = pos($$textref) - length($1)
+ unless defined $parapos;
+ }
+ elsif ($$textref =~ m/\G($rdelspec)/gc )
+ {
+ $closetagpos = pos($$textref)-length($1);
+ goto matched;
+ }
+ elsif ($ignore && $$textref =~ m/\G(?:$ignore)/gc)
+ {
+ next;
+ }
+ elsif ($bad && $$textref =~ m/\G($bad)/gcs)
+ {
+ pos($$textref) -= length($1); # CUT OFF WHATEVER CAUSED THE SHORTNESS
+ goto short if ($omode eq 'PARA' || $omode eq 'MAX');
+ _failmsg "Found invalid nested tag: $1", pos $$textref;
+ goto failed;
+ }
+ elsif ($$textref =~ m/\G($ldel)/gc)
+ {
+ my $tag = $1;
+ pos($$textref) -= length($tag); # REWIND TO NESTED TAG
+ unless (_match_tagged(@_)) # MATCH NESTED TAG
+ {
+ goto short if $omode eq 'PARA' || $omode eq 'MAX';
+ _failmsg "Found unbalanced nested tag: $tag",
+ pos $$textref;
+ goto failed;
+ }
+ }
+ else { $$textref =~ m/./gcs }
+ }
+
+short:
+ $closetagpos = pos($$textref);
+ goto matched if $omode eq 'MAX';
+ goto failed unless $omode eq 'PARA';
+
+ if (defined $parapos) { pos($$textref) = $parapos }
+ else { $parapos = pos($$textref) }
+
+ return (
+ $startpos, $opentagpos-$startpos, # PREFIX
+ $opentagpos, $textpos-$opentagpos, # OPENING TAG
+ $textpos, $parapos-$textpos, # TEXT
+ $parapos, 0, # NO CLOSING TAG
+ $parapos, length($$textref)-$parapos, # REMAINDER
+ );
+
+matched:
+ $endpos = pos($$textref);
+ return (
+ $startpos, $opentagpos-$startpos, # PREFIX
+ $opentagpos, $textpos-$opentagpos, # OPENING TAG
+ $textpos, $closetagpos-$textpos, # TEXT
+ $closetagpos, $endpos-$closetagpos, # CLOSING TAG
+ $endpos, length($$textref)-$endpos, # REMAINDER
+ );
+
+failed:
+ _failmsg "Did not find closing tag", pos $$textref unless $@;
+ pos($$textref) = $startpos;
+ return;
+}
+
+sub extract_variable (;$$)
+{
+ my $textref = defined $_[0] ? \$_[0] : \$_;
+ return ("","","") unless defined $$textref;
+ my $pre = defined $_[1] ? $_[1] : '\s*';
+
+ my @match = _match_variable($textref,$pre);
+
+ return _fail wantarray, $textref unless @match;
+
+ return _succeed wantarray, $textref,
+ @match[2..3,4..5,0..1]; # MATCH, REMAINDER, PREFIX
+}
+
+sub _match_variable($$)
+{
+# $#
+# $^
+# $$
+ my ($textref, $pre) = @_;
+ my $startpos = pos($$textref) = pos($$textref)||0;
+ unless ($$textref =~ m/\G($pre)/gc)
+ {
+ _failmsg "Did not find prefix: /$pre/", pos $$textref;
+ return;
+ }
+ my $varpos = pos($$textref);
+ unless ($$textref =~ m{\G\$\s*(?!::)(\d+|[][&`'+*./|,";%=~:?!\@<>()-]|\^[a-z]?)}gci)
+ {
+ unless ($$textref =~ m/\G((\$#?|[*\@\%]|\\&)+)/gc)
+ {
+ _failmsg "Did not find leading dereferencer", pos $$textref;
+ pos $$textref = $startpos;
+ return;
+ }
+ my $deref = $1;
+
+ unless ($$textref =~ m/\G\s*(?:::|')?(?:[_a-z]\w*(?:::|'))*[_a-z]\w*/gci
+ or _match_codeblock($textref, "", '\{', '\}', '\{', '\}', 0)
+ or $deref eq '$#' or $deref eq '$$' )
+ {
+ _failmsg "Bad identifier after dereferencer", pos $$textref;
+ pos $$textref = $startpos;
+ return;
+ }
+ }
+
+ while (1)
+ {
+ next if $$textref =~ m/\G\s*(?:->)?\s*[{]\w+[}]/gc;
+ next if _match_codeblock($textref,
+ qr/\s*->\s*(?:[_a-zA-Z]\w+\s*)?/,
+ qr/[({[]/, qr/[)}\]]/,
+ qr/[({[]/, qr/[)}\]]/, 0);
+ next if _match_codeblock($textref,
+ qr/\s*/, qr/[{[]/, qr/[}\]]/,
+ qr/[{[]/, qr/[}\]]/, 0);
+ next if _match_variable($textref,'\s*->\s*');
+ next if $$textref =~ m/\G\s*->\s*\w+(?![{([])/gc;
+ last;
+ }
+
+ my $endpos = pos($$textref);
+ return ($startpos, $varpos-$startpos,
+ $varpos, $endpos-$varpos,
+ $endpos, length($$textref)-$endpos
+ );
+}
+
+sub extract_codeblock (;$$$$$)
+{
+ my $textref = defined $_[0] ? \$_[0] : \$_;
+ my $wantarray = wantarray;
+ my $ldel_inner = defined $_[1] ? $_[1] : '{';
+ my $pre = defined $_[2] ? $_[2] : '\s*';
+ my $ldel_outer = defined $_[3] ? $_[3] : $ldel_inner;
+ my $rd = $_[4];
+ my $rdel_inner = $ldel_inner;
+ my $rdel_outer = $ldel_outer;
+ my $posbug = pos;
+ for ($ldel_inner, $ldel_outer) { tr/[]()<>{}\0-\377/[[((<<{{/ds }
+ for ($rdel_inner, $rdel_outer) { tr/[]()<>{}\0-\377/]]))>>}}/ds }
+ for ($ldel_inner, $ldel_outer, $rdel_inner, $rdel_outer)
+ {
+ $_ = '('.join('|',map { quotemeta $_ } split('',$_)).')'
+ }
+ pos = $posbug;
+
+ my @match = _match_codeblock($textref, $pre,
+ $ldel_outer, $rdel_outer,
+ $ldel_inner, $rdel_inner,
+ $rd);
+ return _fail($wantarray, $textref) unless @match;
+ return _succeed($wantarray, $textref,
+ @match[2..3,4..5,0..1] # MATCH, REMAINDER, PREFIX
+ );
+
+}
+
+sub _match_codeblock($$$$$$$)
+{
+ my ($textref, $pre, $ldel_outer, $rdel_outer, $ldel_inner, $rdel_inner, $rd) = @_;
+ my $startpos = pos($$textref) = pos($$textref) || 0;
+ unless ($$textref =~ m/\G($pre)/gc)
+ {
+ _failmsg qq{Did not match prefix /$pre/ at"} .
+ substr($$textref,pos($$textref),20) .
+ q{..."},
+ pos $$textref;
+ return;
+ }
+ my $codepos = pos($$textref);
+ unless ($$textref =~ m/\G($ldel_outer)/gc) # OUTERMOST DELIMITER
+ {
+ _failmsg qq{Did not find expected opening bracket at "} .
+ substr($$textref,pos($$textref),20) .
+ q{..."},
+ pos $$textref;
+ pos $$textref = $startpos;
+ return;
+ }
+ my $closing = $1;
+ $closing =~ tr/([<{/)]>}/;
+ my $matched;
+ my $patvalid = 1;
+ while (pos($$textref) < length($$textref))
+ {
+ $matched = '';
+ if ($rd && $$textref =~ m#\G(\Q(?)\E|\Q(s?)\E|\Q(s)\E)#gc)
+ {
+ $patvalid = 0;
+ next;
+ }
+
+ if ($$textref =~ m/\G\s*#.*/gc)
+ {
+ next;
+ }
+
+ if ($$textref =~ m/\G\s*($rdel_outer)/gc)
+ {
+ unless ($matched = ($closing && $1 eq $closing) )
+ {
+ next if $1 eq '>'; # MIGHT BE A "LESS THAN"
+ _failmsg q{Mismatched closing bracket at "} .
+ substr($$textref,pos($$textref),20) .
+ qq{...". Expected '$closing'},
+ pos $$textref;
+ }
+ last;
+ }
+
+ if (_match_variable($textref,'\s*') ||
+ _match_quotelike($textref,'\s*',$patvalid,$patvalid) )
+ {
+ $patvalid = 0;
+ next;
+ }
+
+
+ # NEED TO COVER MANY MORE CASES HERE!!!
+ if ($$textref =~ m#\G\s*(?!$ldel_inner)
+ ( [-+*x/%^&|.]=?
+ | [!=]~
+ | =(?!>)
+ | (\*\*|&&|\|\||<<|>>)=?
+ | split|grep|map|return
+ | [([]
+ )#gcx)
+ {
+ $patvalid = 1;
+ next;
+ }
+
+ if ( _match_codeblock($textref, '\s*', $ldel_inner, $rdel_inner, $ldel_inner, $rdel_inner, $rd) )
+ {
+ $patvalid = 1;
+ next;
+ }
+
+ if ($$textref =~ m/\G\s*$ldel_outer/gc)
+ {
+ _failmsg q{Improperly nested codeblock at "} .
+ substr($$textref,pos($$textref),20) .
+ q{..."},
+ pos $$textref;
+ last;
+ }
+
+ $patvalid = 0;
+ $$textref =~ m/\G\s*(\w+|[-=>]>|.|\Z)/gc;
+ }
+ continue { $@ = undef }
+
+ unless ($matched)
+ {
+ _failmsg 'No match found for opening bracket', pos $$textref
+ unless $@;
+ return;
+ }
+
+ my $endpos = pos($$textref);
+ return ( $startpos, $codepos-$startpos,
+ $codepos, $endpos-$codepos,
+ $endpos, length($$textref)-$endpos,
+ );
+}
+
+
+my %mods = (
+ 'none' => '[cgimsox]*',
+ 'm' => '[cgimsox]*',
+ 's' => '[cegimsox]*',
+ 'tr' => '[cds]*',
+ 'y' => '[cds]*',
+ 'qq' => '',
+ 'qx' => '',
+ 'qw' => '',
+ 'qr' => '[imsx]*',
+ 'q' => '',
+ );
+
+sub extract_quotelike (;$$)
+{
+ my $textref = $_[0] ? \$_[0] : \$_;
+ my $wantarray = wantarray;
+ my $pre = defined $_[1] ? $_[1] : '\s*';
+
+ my @match = _match_quotelike($textref,$pre,1,0);
+ return _fail($wantarray, $textref) unless @match;
+ return _succeed($wantarray, $textref,
+ $match[2], $match[18]-$match[2], # MATCH
+ @match[18,19], # REMAINDER
+ @match[0,1], # PREFIX
+ @match[2..17], # THE BITS
+ @match[20,21], # ANY FILLET?
+ );
+};
+
+sub _match_quotelike($$$$) # ($textref, $prepat, $allow_raw_match)
+{
+ my ($textref, $pre, $rawmatch, $qmark) = @_;
+
+ my ($textlen,$startpos,
+ $oppos,
+ $preld1pos,$ld1pos,$str1pos,$rd1pos,
+ $preld2pos,$ld2pos,$str2pos,$rd2pos,
+ $modpos) = ( length($$textref), pos($$textref) = pos($$textref) || 0 );
+
+ unless ($$textref =~ m/\G($pre)/gc)
+ {
+ _failmsg qq{Did not find prefix /$pre/ at "} .
+ substr($$textref, pos($$textref), 20) .
+ q{..."},
+ pos $$textref;
+ return;
+ }
+ $oppos = pos($$textref);
+
+ my $initial = substr($$textref,$oppos,1);
+
+ if ($initial && $initial =~ m|^[\"\'\`]|
+ || $rawmatch && $initial =~ m|^/|
+ || $qmark && $initial =~ m|^\?|)
+ {
+ unless ($$textref =~ m/ \Q$initial\E [^\\$initial]* (\\.[^\\$initial]*)* \Q$initial\E /gcsx)
+ {
+ _failmsg qq{Did not find closing delimiter to match '$initial' at "} .
+ substr($$textref, $oppos, 20) .
+ q{..."},
+ pos $$textref;
+ pos $$textref = $startpos;
+ return;
+ }
+ $modpos= pos($$textref);
+ $rd1pos = $modpos-1;
+
+ if ($initial eq '/' || $initial eq '?')
+ {
+ $$textref =~ m/\G$mods{none}/gc
+ }
+
+ my $endpos = pos($$textref);
+ return (
+ $startpos, $oppos-$startpos, # PREFIX
+ $oppos, 0, # NO OPERATOR
+ $oppos, 1, # LEFT DEL
+ $oppos+1, $rd1pos-$oppos-1, # STR/PAT
+ $rd1pos, 1, # RIGHT DEL
+ $modpos, 0, # NO 2ND LDEL
+ $modpos, 0, # NO 2ND STR
+ $modpos, 0, # NO 2ND RDEL
+ $modpos, $endpos-$modpos, # MODIFIERS
+ $endpos, $textlen-$endpos, # REMAINDER
+ );
+ }
+
+ unless ($$textref =~ m{\G(\b(?:m|s|qq|qx|qw|q|qr|tr|y)\b(?=\s*\S)|<<)}gc)
+ {
+ _failmsg q{No quotelike operator found after prefix at "} .
+ substr($$textref, pos($$textref), 20) .
+ q{..."},
+ pos $$textref;
+ pos $$textref = $startpos;
+ return;
+ }
+
+ my $op = $1;
+ $preld1pos = pos($$textref);
+ if ($op eq '<<') {
+ $ld1pos = pos($$textref);
+ my $label;
+ if ($$textref =~ m{\G([A-Za-z_]\w*)}gc) {
+ $label = $1;
+ }
+ elsif ($$textref =~ m{ \G ' ([^'\\]* (?:\\.[^'\\]*)*) '
+ | \G " ([^"\\]* (?:\\.[^"\\]*)*) "
+ | \G ` ([^`\\]* (?:\\.[^`\\]*)*) `
+ }gcsx) {
+ $label = $+;
+ }
+ else {
+ $label = "";
+ }
+ my $extrapos = pos($$textref);
+ $$textref =~ m{.*\n}gc;
+ $str1pos = pos($$textref)--;
+ unless ($$textref =~ m{.*?\n(?=\Q$label\E\n)}gc) {
+ _failmsg qq{Missing here doc terminator ('$label') after "} .
+ substr($$textref, $startpos, 20) .
+ q{..."},
+ pos $$textref;
+ pos $$textref = $startpos;
+ return;
+ }
+ $rd1pos = pos($$textref);
+ $$textref =~ m{\Q$label\E\n}gc;
+ $ld2pos = pos($$textref);
+ return (
+ $startpos, $oppos-$startpos, # PREFIX
+ $oppos, length($op), # OPERATOR
+ $ld1pos, $extrapos-$ld1pos, # LEFT DEL
+ $str1pos, $rd1pos-$str1pos, # STR/PAT
+ $rd1pos, $ld2pos-$rd1pos, # RIGHT DEL
+ $ld2pos, 0, # NO 2ND LDEL
+ $ld2pos, 0, # NO 2ND STR
+ $ld2pos, 0, # NO 2ND RDEL
+ $ld2pos, 0, # NO MODIFIERS
+ $ld2pos, $textlen-$ld2pos, # REMAINDER
+ $extrapos, $str1pos-$extrapos, # FILLETED BIT
+ );
+ }
+
+ $$textref =~ m/\G\s*/gc;
+ $ld1pos = pos($$textref);
+ $str1pos = $ld1pos+1;
+
+ unless ($$textref =~ m/\G(\S)/gc) # SHOULD USE LOOKAHEAD
+ {
+ _failmsg "No block delimiter found after quotelike $op",
+ pos $$textref;
+ pos $$textref = $startpos;
+ return;
+ }
+ pos($$textref) = $ld1pos; # HAVE TO DO THIS BECAUSE LOOKAHEAD BROKEN
+ my ($ldel1, $rdel1) = ("\Q$1","\Q$1");
+ if ($ldel1 =~ /[[(<{]/)
+ {
+ $rdel1 =~ tr/[({</])}>/;
+ defined(_match_bracketed($textref,"",$ldel1,"","",$rdel1))
+ || do { pos $$textref = $startpos; return };
+ $ld2pos = pos($$textref);
+ $rd1pos = $ld2pos-1;
+ }
+ else
+ {
+ $$textref =~ /\G$ldel1[^\\$ldel1]*(\\.[^\\$ldel1]*)*$ldel1/gcs
+ || do { pos $$textref = $startpos; return };
+ $ld2pos = $rd1pos = pos($$textref)-1;
+ }
+
+ my $second_arg = $op =~ /s|tr|y/ ? 1 : 0;
+ if ($second_arg)
+ {
+ my ($ldel2, $rdel2);
+ if ($ldel1 =~ /[[(<{]/)
+ {
+ unless ($$textref =~ /\G\s*(\S)/gc) # SHOULD USE LOOKAHEAD
+ {
+ _failmsg "Missing second block for quotelike $op",
+ pos $$textref;
+ pos $$textref = $startpos;
+ return;
+ }
+ $ldel2 = $rdel2 = "\Q$1";
+ $rdel2 =~ tr/[({</])}>/;
+ }
+ else
+ {
+ $ldel2 = $rdel2 = $ldel1;
+ }
+ $str2pos = $ld2pos+1;
+
+ if ($ldel2 =~ /[[(<{]/)
+ {
+ pos($$textref)--; # OVERCOME BROKEN LOOKAHEAD
+ defined(_match_bracketed($textref,"",$ldel2,"","",$rdel2))
+ || do { pos $$textref = $startpos; return };
+ }
+ else
+ {
+ $$textref =~ /[^\\$ldel2]*(\\.[^\\$ldel2]*)*$ldel2/gcs
+ || do { pos $$textref = $startpos; return };
+ }
+ $rd2pos = pos($$textref)-1;
+ }
+ else
+ {
+ $ld2pos = $str2pos = $rd2pos = $rd1pos;
+ }
+
+ $modpos = pos $$textref;
+
+ $$textref =~ m/\G($mods{$op})/gc;
+ my $endpos = pos $$textref;
+
+ return (
+ $startpos, $oppos-$startpos, # PREFIX
+ $oppos, length($op), # OPERATOR
+ $ld1pos, 1, # LEFT DEL
+ $str1pos, $rd1pos-$str1pos, # STR/PAT
+ $rd1pos, 1, # RIGHT DEL
+ $ld2pos, $second_arg, # 2ND LDEL (MAYBE)
+ $str2pos, $rd2pos-$str2pos, # 2ND STR (MAYBE)
+ $rd2pos, $second_arg, # 2ND RDEL (MAYBE)
+ $modpos, $endpos-$modpos, # MODIFIERS
+ $endpos, $textlen-$endpos, # REMAINDER
+ );
+}
+
+my $def_func =
+[
+ sub { extract_variable($_[0], '') },
+ sub { extract_quotelike($_[0],'') },
+ sub { extract_codeblock($_[0],'{}','') },
+];
+
+sub extract_multiple (;$$$$) # ($text, $functions_ref, $max_fields, $ignoreunknown)
+{
+ my $textref = defined($_[0]) ? \$_[0] : \$_;
+ my $posbug = pos;
+ my ($lastpos, $firstpos);
+ my @fields = ();
+
+ #for ($$textref)
+ {
+ my @func = defined $_[1] ? @{$_[1]} : @{$def_func};
+ my $max = defined $_[2] && $_[2]>0 ? $_[2] : 1_000_000_000;
+ my $igunk = $_[3];
+
+ pos $$textref ||= 0;
+
+ unless (wantarray)
+ {
+ use Carp;
+ carp "extract_multiple reset maximal count to 1 in scalar context"
+ if $^W && defined($_[2]) && $max > 1;
+ $max = 1
+ }
+
+ my $unkpos;
+ my $func;
+ my $class;
+
+ my @class;
+ foreach $func ( @func )
+ {
+ if (ref($func) eq 'HASH')
+ {
+ push @class, (keys %$func)[0];
+ $func = (values %$func)[0];
+ }
+ else
+ {
+ push @class, undef;
+ }
+ }
+
+ FIELD: while (pos($$textref) < length($$textref))
+ {
+ my ($field, $rem);
+ my @bits;
+ foreach my $i ( 0..$#func )
+ {
+ my $pref;
+ $func = $func[$i];
+ $class = $class[$i];
+ $lastpos = pos $$textref;
+ if (ref($func) eq 'CODE')
+ { ($field,$rem,$pref) = @bits = $func->($$textref) }
+ elsif (ref($func) eq 'Text::Balanced::Extractor')
+ { @bits = $field = $func->extract($$textref) }
+ elsif( $$textref =~ m/\G$func/gc )
+ { @bits = $field = defined($1)
+ ? $1
+ : substr($$textref, $-[0], $+[0] - $-[0])
+ }
+ $pref ||= "";
+ if (defined($field) && length($field))
+ {
+ if (!$igunk) {
+ $unkpos = $lastpos
+ if length($pref) && !defined($unkpos);
+ if (defined $unkpos)
+ {
+ push @fields, substr($$textref, $unkpos, $lastpos-$unkpos).$pref;
+ $firstpos = $unkpos unless defined $firstpos;
+ undef $unkpos;
+ last FIELD if @fields == $max;
+ }
+ }
+ push @fields, $class
+ ? bless (\$field, $class)
+ : $field;
+ $firstpos = $lastpos unless defined $firstpos;
+ $lastpos = pos $$textref;
+ last FIELD if @fields == $max;
+ next FIELD;
+ }
+ }
+ if ($$textref =~ /\G(.)/gcs)
+ {
+ $unkpos = pos($$textref)-1
+ unless $igunk || defined $unkpos;
+ }
+ }
+
+ if (defined $unkpos)
+ {
+ push @fields, substr($$textref, $unkpos);
+ $firstpos = $unkpos unless defined $firstpos;
+ $lastpos = length $$textref;
+ }
+ last;
+ }
+
+ pos $$textref = $lastpos;
+ return @fields if wantarray;
+
+ $firstpos ||= 0;
+ eval { substr($$textref,$firstpos,$lastpos-$firstpos)="";
+ pos $$textref = $firstpos };
+ return $fields[0];
+}
+
+
+sub gen_extract_tagged # ($opentag, $closetag, $pre, \%options)
+{
+ my $ldel = $_[0];
+ my $rdel = $_[1];
+ my $pre = defined $_[2] ? $_[2] : '\s*';
+ my %options = defined $_[3] ? %{$_[3]} : ();
+ my $omode = defined $options{fail} ? $options{fail} : '';
+ my $bad = ref($options{reject}) eq 'ARRAY' ? join('|', @{$options{reject}})
+ : defined($options{reject}) ? $options{reject}
+ : ''
+ ;
+ my $ignore = ref($options{ignore}) eq 'ARRAY' ? join('|', @{$options{ignore}})
+ : defined($options{ignore}) ? $options{ignore}
+ : ''
+ ;
+
+ if (!defined $ldel) { $ldel = '<\w+(?:' . gen_delimited_pat(q{'"}) . '|[^>])*>'; }
+
+ my $posbug = pos;
+ for ($ldel, $pre, $bad, $ignore) { $_ = qr/$_/ if $_ }
+ pos = $posbug;
+
+ my $closure = sub
+ {
+ my $textref = defined $_[0] ? \$_[0] : \$_;
+ my @match = Text::Balanced::_match_tagged($textref, $pre, $ldel, $rdel, $omode, $bad, $ignore);
+
+ return _fail(wantarray, $textref) unless @match;
+ return _succeed wantarray, $textref,
+ $match[2], $match[3]+$match[5]+$match[7], # MATCH
+ @match[8..9,0..1,2..7]; # REM, PRE, BITS
+ };
+
+ bless $closure, 'Text::Balanced::Extractor';
+}
+
+package Text::Balanced::Extractor;
+
+sub extract($$) # ($self, $text)
+{
+ &{$_[0]}($_[1]);
+}
+
+package Text::Balanced::ErrorMsg;
+
+use overload '""' => sub { "$_[0]->{error}, detected at offset $_[0]->{pos}" };
+
+1;
+
+__END__
+
+=head1 NAME
+
+Text::Balanced - Extract delimited text sequences from strings.
+
+
+=head1 SYNOPSIS
+
+ use Text::Balanced qw (
+ extract_delimited
+ extract_bracketed
+ extract_quotelike
+ extract_codeblock
+ extract_variable
+ extract_tagged
+ extract_multiple
+
+ gen_delimited_pat
+ gen_extract_tagged
+ );
+
+ # Extract the initial substring of $text that is delimited by
+ # two (unescaped) instances of the first character in $delim.
+
+ ($extracted, $remainder) = extract_delimited($text,$delim);
+
+
+ # Extract the initial substring of $text that is bracketed
+ # with a delimiter(s) specified by $delim (where the string
+ # in $delim contains one or more of '(){}[]<>').
+
+ ($extracted, $remainder) = extract_bracketed($text,$delim);
+
+
+ # Extract the initial substring of $text that is bounded by
+ # an XML tag.
+
+ ($extracted, $remainder) = extract_tagged($text);
+
+
+ # Extract the initial substring of $text that is bounded by
+ # a C<BEGIN>...C<END> pair. Don't allow nested C<BEGIN> tags
+
+ ($extracted, $remainder) =
+ extract_tagged($text,"BEGIN","END",undef,{bad=>["BEGIN"]});
+
+
+ # Extract the initial substring of $text that represents a
+ # Perl "quote or quote-like operation"
+
+ ($extracted, $remainder) = extract_quotelike($text);
+
+
+ # Extract the initial substring of $text that represents a block
+ # of Perl code, bracketed by any of character(s) specified by $delim
+ # (where the string $delim contains one or more of '(){}[]<>').
+
+ ($extracted, $remainder) = extract_codeblock($text,$delim);
+
+
+ # Extract the initial substrings of $text that would be extracted by
+ # one or more sequential applications of the specified functions
+ # or regular expressions
+
+ @extracted = extract_multiple($text,
+ [ \&extract_bracketed,
+ \&extract_quotelike,
+ \&some_other_extractor_sub,
+ qr/[xyz]*/,
+ 'literal',
+ ]);
+
+# Create a string representing an optimized pattern (a la Friedl)
+# that matches a substring delimited by any of the specified characters
+# (in this case: any type of quote or a slash)
+
+ $patstring = gen_delimited_pat(q{'"`/});
+
+
+# Generate a reference to an anonymous sub that is just like extract_tagged
+# but pre-compiled and optimized for a specific pair of tags, and consequently
+# much faster (i.e. 3 times faster). It uses qr// for better performance on
+# repeated calls, so it only works under Perl 5.005 or later.
+
+ $extract_head = gen_extract_tagged('<HEAD>','</HEAD>');
+
+ ($extracted, $remainder) = $extract_head->($text);
+
+
+=head1 DESCRIPTION
+
+The various C<extract_...> subroutines may be used to
+extract a delimited substring, possibly after skipping a
+specified prefix string. By default, that prefix is
+optional whitespace (C</\s*/>), but you can change it to whatever
+you wish (see below).
+
+The substring to be extracted must appear at the
+current C<pos> location of the string's variable
+(or at index zero, if no C<pos> position is defined).
+In other words, the C<extract_...> subroutines I<don't>
+extract the first occurrence of a substring anywhere
+in a string (like an unanchored regex would). Rather,
+they extract an occurrence of the substring appearing
+immediately at the current matching position in the
+string (like a C<\G>-anchored regex would).
+
+
+
+=head2 General behaviour in list contexts
+
+In a list context, all the subroutines return a list, the first three
+elements of which are always:
+
+=over 4
+
+=item [0]
+
+The extracted string, including the specified delimiters.
+If the extraction fails C<undef> is returned.
+
+=item [1]
+
+The remainder of the input string (i.e. the characters after the
+extracted string). On failure, the entire string is returned.
+
+=item [2]
+
+The skipped prefix (i.e. the characters before the extracted string).
+On failure, C<undef> is returned.
+
+=back
+
+Note that in a list context, the contents of the original input text (the first
+argument) are not modified in any way.
+
+However, if the input text was passed in a variable, that variable's
+C<pos> value is updated to point at the first character after the
+extracted text. That means that in a list context the various
+subroutines can be used much like regular expressions. For example:
+
+ while ( $next = (extract_quotelike($text))[0] )
+ {
+ # process next quote-like (in $next)
+ }
+
+
+=head2 General behaviour in scalar and void contexts
+
+In a scalar context, the extracted string is returned, having first been
+removed from the input text. Thus, the following code also processes
+each quote-like operation, but actually removes them from $text:
+
+ while ( $next = extract_quotelike($text) )
+ {
+ # process next quote-like (in $next)
+ }
+
+Note that if the input text is a read-only string (i.e. a literal),
+no attempt is made to remove the extracted text.
+
+In a void context the behaviour of the extraction subroutines is
+exactly the same as in a scalar context, except (of course) that the
+extracted substring is not returned.
+
+=head2 A note about prefixes
+
+Prefix patterns are matched without any trailing modifiers (C</gimsox> etc.)
+This can bite you if you're expecting a prefix specification like
+'.*?(?=<H1>)' to skip everything up to the first <H1> tag. Such a prefix
+pattern will only succeed if the <H1> tag is on the current line, since
+. normally doesn't match newlines.
+
+To overcome this limitation, you need to turn on /s matching within
+the prefix pattern, using the C<(?s)> directive: '(?s).*?(?=<H1>)'
+
+
+=head2 C<extract_delimited>
+
+The C<extract_delimited> function formalizes the common idiom
+of extracting a single-character-delimited substring from the start of
+a string. For example, to extract a single-quote delimited string, the
+following code is typically used:
+
+ ($remainder = $text) =~ s/\A('(\\.|[^'])*')//s;
+ $extracted = $1;
+
+but with C<extract_delimited> it can be simplified to:
+
+ ($extracted,$remainder) = extract_delimited($text, "'");
+
+C<extract_delimited> takes up to four scalars (the input text, the
+delimiters, a prefix pattern to be skipped, and any escape characters)
+and extracts the initial substring of the text that
+is appropriately delimited. If the delimiter string has multiple
+characters, the first one encountered in the text is taken to delimit
+the substring.
+The third argument specifies a prefix pattern that is to be skipped
+(but must be present!) before the substring is extracted.
+The final argument specifies the escape character to be used for each
+delimiter.
+
+All arguments are optional. If the escape characters are not specified,
+every delimiter is escaped with a backslash (C<\>).
+If the prefix is not specified, the
+pattern C<'\s*'> - optional whitespace - is used. If the delimiter set
+is also not specified, the set C</["'`]/> is used. If the text to be processed
+is not specified either, C<$_> is used.
+
+In list context, C<extract_delimited> returns a array of three
+elements, the extracted substring (I<including the surrounding
+delimiters>), the remainder of the text, and the skipped prefix (if
+any). If a suitable delimited substring is not found, the first
+element of the array is the empty string, the second is the complete
+original text, and the prefix returned in the third element is an
+empty string.
+
+In a scalar context, just the extracted substring is returned. In
+a void context, the extracted substring (and any prefix) are simply
+removed from the beginning of the first argument.
+
+Examples:
+
+ # Remove a single-quoted substring from the very beginning of $text:
+
+ $substring = extract_delimited($text, "'", '');
+
+ # Remove a single-quoted Pascalish substring (i.e. one in which
+ # doubling the quote character escapes it) from the very
+ # beginning of $text:
+
+ $substring = extract_delimited($text, "'", '', "'");
+
+ # Extract a single- or double- quoted substring from the
+ # beginning of $text, optionally after some whitespace
+ # (note the list context to protect $text from modification):
+
+ ($substring) = extract_delimited $text, q{"'};
+
+
+ # Delete the substring delimited by the first '/' in $text:
+
+ $text = join '', (extract_delimited($text,'/','[^/]*')[2,1];
+
+Note that this last example is I<not> the same as deleting the first
+quote-like pattern. For instance, if C<$text> contained the string:
+
+ "if ('./cmd' =~ m/$UNIXCMD/s) { $cmd = $1; }"
+
+then after the deletion it would contain:
+
+ "if ('.$UNIXCMD/s) { $cmd = $1; }"
+
+not:
+
+ "if ('./cmd' =~ ms) { $cmd = $1; }"
+
+
+See L<"extract_quotelike"> for a (partial) solution to this problem.
+
+
+=head2 C<extract_bracketed>
+
+Like C<"extract_delimited">, the C<extract_bracketed> function takes
+up to three optional scalar arguments: a string to extract from, a delimiter
+specifier, and a prefix pattern. As before, a missing prefix defaults to
+optional whitespace and a missing text defaults to C<$_>. However, a missing
+delimiter specifier defaults to C<'{}()[]E<lt>E<gt>'> (see below).
+
+C<extract_bracketed> extracts a balanced-bracket-delimited
+substring (using any one (or more) of the user-specified delimiter
+brackets: '(..)', '{..}', '[..]', or '<..>'). Optionally it will also
+respect quoted unbalanced brackets (see below).
+
+A "delimiter bracket" is a bracket in list of delimiters passed as
+C<extract_bracketed>'s second argument. Delimiter brackets are
+specified by giving either the left or right (or both!) versions
+of the required bracket(s). Note that the order in which
+two or more delimiter brackets are specified is not significant.
+
+A "balanced-bracket-delimited substring" is a substring bounded by
+matched brackets, such that any other (left or right) delimiter
+bracket I<within> the substring is also matched by an opposite
+(right or left) delimiter bracket I<at the same level of nesting>. Any
+type of bracket not in the delimiter list is treated as an ordinary
+character.
+
+In other words, each type of bracket specified as a delimiter must be
+balanced and correctly nested within the substring, and any other kind of
+("non-delimiter") bracket in the substring is ignored.
+
+For example, given the string:
+
+ $text = "{ an '[irregularly :-(] {} parenthesized >:-)' string }";
+
+then a call to C<extract_bracketed> in a list context:
+
+ @result = extract_bracketed( $text, '{}' );
+
+would return:
+
+ ( "{ an '[irregularly :-(] {} parenthesized >:-)' string }" , "" , "" )
+
+since both sets of C<'{..}'> brackets are properly nested and evenly balanced.
+(In a scalar context just the first element of the array would be returned. In
+a void context, C<$text> would be replaced by an empty string.)
+
+Likewise the call in:
+
+ @result = extract_bracketed( $text, '{[' );
+
+would return the same result, since all sets of both types of specified
+delimiter brackets are correctly nested and balanced.
+
+However, the call in:
+
+ @result = extract_bracketed( $text, '{([<' );
+
+would fail, returning:
+
+ ( undef , "{ an '[irregularly :-(] {} parenthesized >:-)' string }" );
+
+because the embedded pairs of C<'(..)'>s and C<'[..]'>s are "cross-nested" and
+the embedded C<'E<gt>'> is unbalanced. (In a scalar context, this call would
+return an empty string. In a void context, C<$text> would be unchanged.)
+
+Note that the embedded single-quotes in the string don't help in this
+case, since they have not been specified as acceptable delimiters and are
+therefore treated as non-delimiter characters (and ignored).
+
+However, if a particular species of quote character is included in the
+delimiter specification, then that type of quote will be correctly handled.
+for example, if C<$text> is:
+
+ $text = '<A HREF=">>>>">link</A>';
+
+then
+
+ @result = extract_bracketed( $text, '<">' );
+
+returns:
+
+ ( '<A HREF=">>>>">', 'link</A>', "" )
+
+as expected. Without the specification of C<"> as an embedded quoter:
+
+ @result = extract_bracketed( $text, '<>' );
+
+the result would be:
+
+ ( '<A HREF=">', '>>>">link</A>', "" )
+
+In addition to the quote delimiters C<'>, C<">, and C<`>, full Perl quote-like
+quoting (i.e. q{string}, qq{string}, etc) can be specified by including the
+letter 'q' as a delimiter. Hence:
+
+ @result = extract_bracketed( $text, '<q>' );
+
+would correctly match something like this:
+
+ $text = '<leftop: conj /and/ conj>';
+
+See also: C<"extract_quotelike"> and C<"extract_codeblock">.
+
+
+=head2 C<extract_variable>
+
+C<extract_variable> extracts any valid Perl variable or
+variable-involved expression, including scalars, arrays, hashes, array
+accesses, hash look-ups, method calls through objects, subroutine calls
+through subroutine references, etc.
+
+The subroutine takes up to two optional arguments:
+
+=over 4
+
+=item 1.
+
+A string to be processed (C<$_> if the string is omitted or C<undef>)
+
+=item 2.
+
+A string specifying a pattern to be matched as a prefix (which is to be
+skipped). If omitted, optional whitespace is skipped.
+
+=back
+
+On success in a list context, an array of 3 elements is returned. The
+elements are:
+
+=over 4
+
+=item [0]
+
+the extracted variable, or variablish expression
+
+=item [1]
+
+the remainder of the input text,
+
+=item [2]
+
+the prefix substring (if any),
+
+=back
+
+On failure, all of these values (except the remaining text) are C<undef>.
+
+In a scalar context, C<extract_variable> returns just the complete
+substring that matched a variablish expression. C<undef> is returned on
+failure. In addition, the original input text has the returned substring
+(and any prefix) removed from it.
+
+In a void context, the input text just has the matched substring (and
+any specified prefix) removed.
+
+
+=head2 C<extract_tagged>
+
+C<extract_tagged> extracts and segments text between (balanced)
+specified tags.
+
+The subroutine takes up to five optional arguments:
+
+=over 4
+
+=item 1.
+
+A string to be processed (C<$_> if the string is omitted or C<undef>)
+
+=item 2.
+
+A string specifying a pattern to be matched as the opening tag.
+If the pattern string is omitted (or C<undef>) then a pattern
+that matches any standard XML tag is used.
+
+=item 3.
+
+A string specifying a pattern to be matched at the closing tag.
+If the pattern string is omitted (or C<undef>) then the closing
+tag is constructed by inserting a C</> after any leading bracket
+characters in the actual opening tag that was matched (I<not> the pattern
+that matched the tag). For example, if the opening tag pattern
+is specified as C<'{{\w+}}'> and actually matched the opening tag
+C<"{{DATA}}">, then the constructed closing tag would be C<"{{/DATA}}">.
+
+=item 4.
+
+A string specifying a pattern to be matched as a prefix (which is to be
+skipped). If omitted, optional whitespace is skipped.
+
+=item 5.
+
+A hash reference containing various parsing options (see below)
+
+=back
+
+The various options that can be specified are:
+
+=over 4
+
+=item C<reject =E<gt> $listref>
+
+The list reference contains one or more strings specifying patterns
+that must I<not> appear within the tagged text.
+
+For example, to extract
+an HTML link (which should not contain nested links) use:
+
+ extract_tagged($text, '<A>', '</A>', undef, {reject => ['<A>']} );
+
+=item C<ignore =E<gt> $listref>
+
+The list reference contains one or more strings specifying patterns
+that are I<not> be be treated as nested tags within the tagged text
+(even if they would match the start tag pattern).
+
+For example, to extract an arbitrary XML tag, but ignore "empty" elements:
+
+ extract_tagged($text, undef, undef, undef, {ignore => ['<[^>]*/>']} );
+
+(also see L<"gen_delimited_pat"> below).
+
+
+=item C<fail =E<gt> $str>
+
+The C<fail> option indicates the action to be taken if a matching end
+tag is not encountered (i.e. before the end of the string or some
+C<reject> pattern matches). By default, a failure to match a closing
+tag causes C<extract_tagged> to immediately fail.
+
+However, if the string value associated with <reject> is "MAX", then
+C<extract_tagged> returns the complete text up to the point of failure.
+If the string is "PARA", C<extract_tagged> returns only the first paragraph
+after the tag (up to the first line that is either empty or contains
+only whitespace characters).
+If the string is "", the the default behaviour (i.e. failure) is reinstated.
+
+For example, suppose the start tag "/para" introduces a paragraph, which then
+continues until the next "/endpara" tag or until another "/para" tag is
+encountered:
+
+ $text = "/para line 1\n\nline 3\n/para line 4";
+
+ extract_tagged($text, '/para', '/endpara', undef,
+ {reject => '/para', fail => MAX );
+
+ # EXTRACTED: "/para line 1\n\nline 3\n"
+
+Suppose instead, that if no matching "/endpara" tag is found, the "/para"
+tag refers only to the immediately following paragraph:
+
+ $text = "/para line 1\n\nline 3\n/para line 4";
+
+ extract_tagged($text, '/para', '/endpara', undef,
+ {reject => '/para', fail => MAX );
+
+ # EXTRACTED: "/para line 1\n"
+
+Note that the specified C<fail> behaviour applies to nested tags as well.
+
+=back
+
+On success in a list context, an array of 6 elements is returned. The elements are:
+
+=over 4
+
+=item [0]
+
+the extracted tagged substring (including the outermost tags),
+
+=item [1]
+
+the remainder of the input text,
+
+=item [2]
+
+the prefix substring (if any),
+
+=item [3]
+
+the opening tag
+
+=item [4]
+
+the text between the opening and closing tags
+
+=item [5]
+
+the closing tag (or "" if no closing tag was found)
+
+=back
+
+On failure, all of these values (except the remaining text) are C<undef>.
+
+In a scalar context, C<extract_tagged> returns just the complete
+substring that matched a tagged text (including the start and end
+tags). C<undef> is returned on failure. In addition, the original input
+text has the returned substring (and any prefix) removed from it.
+
+In a void context, the input text just has the matched substring (and
+any specified prefix) removed.
+
+
+=head2 C<gen_extract_tagged>
+
+(Note: This subroutine is only available under Perl5.005)
+
+C<gen_extract_tagged> generates a new anonymous subroutine which
+extracts text between (balanced) specified tags. In other words,
+it generates a function identical in function to C<extract_tagged>.
+
+The difference between C<extract_tagged> and the anonymous
+subroutines generated by
+C<gen_extract_tagged>, is that those generated subroutines:
+
+=over 4
+
+=item *
+
+do not have to reparse tag specification or parsing options every time
+they are called (whereas C<extract_tagged> has to effectively rebuild
+its tag parser on every call);
+
+=item *
+
+make use of the new qr// construct to pre-compile the regexes they use
+(whereas C<extract_tagged> uses standard string variable interpolation
+to create tag-matching patterns).
+
+=back
+
+The subroutine takes up to four optional arguments (the same set as
+C<extract_tagged> except for the string to be processed). It returns
+a reference to a subroutine which in turn takes a single argument (the text to
+be extracted from).
+
+In other words, the implementation of C<extract_tagged> is exactly
+equivalent to:
+
+ sub extract_tagged
+ {
+ my $text = shift;
+ $extractor = gen_extract_tagged(@_);
+ return $extractor->($text);
+ }
+
+(although C<extract_tagged> is not currently implemented that way, in order
+to preserve pre-5.005 compatibility).
+
+Using C<gen_extract_tagged> to create extraction functions for specific tags
+is a good idea if those functions are going to be called more than once, since
+their performance is typically twice as good as the more general-purpose
+C<extract_tagged>.
+
+
+=head2 C<extract_quotelike>
+
+C<extract_quotelike> attempts to recognize, extract, and segment any
+one of the various Perl quotes and quotelike operators (see
+L<perlop(3)>) Nested backslashed delimiters, embedded balanced bracket
+delimiters (for the quotelike operators), and trailing modifiers are
+all caught. For example, in:
+
+ extract_quotelike 'q # an octothorpe: \# (not the end of the q!) #'
+
+ extract_quotelike ' "You said, \"Use sed\"." '
+
+ extract_quotelike ' s{([A-Z]{1,8}\.[A-Z]{3})} /\L$1\E/; '
+
+ extract_quotelike ' tr/\\\/\\\\/\\\//ds; '
+
+the full Perl quotelike operations are all extracted correctly.
+
+Note too that, when using the /x modifier on a regex, any comment
+containing the current pattern delimiter will cause the regex to be
+immediately terminated. In other words:
+
+ 'm /
+ (?i) # CASE INSENSITIVE
+ [a-z_] # LEADING ALPHABETIC/UNDERSCORE
+ [a-z0-9]* # FOLLOWED BY ANY NUMBER OF ALPHANUMERICS
+ /x'
+
+will be extracted as if it were:
+
+ 'm /
+ (?i) # CASE INSENSITIVE
+ [a-z_] # LEADING ALPHABETIC/'
+
+This behaviour is identical to that of the actual compiler.
+
+C<extract_quotelike> takes two arguments: the text to be processed and
+a prefix to be matched at the very beginning of the text. If no prefix
+is specified, optional whitespace is the default. If no text is given,
+C<$_> is used.
+
+In a list context, an array of 11 elements is returned. The elements are:
+
+=over 4
+
+=item [0]
+
+the extracted quotelike substring (including trailing modifiers),
+
+=item [1]
+
+the remainder of the input text,
+
+=item [2]
+
+the prefix substring (if any),
+
+=item [3]
+
+the name of the quotelike operator (if any),
+
+=item [4]
+
+the left delimiter of the first block of the operation,
+
+=item [5]
+
+the text of the first block of the operation
+(that is, the contents of
+a quote, the regex of a match or substitution or the target list of a
+translation),
+
+=item [6]
+
+the right delimiter of the first block of the operation,
+
+=item [7]
+
+the left delimiter of the second block of the operation
+(that is, if it is a C<s>, C<tr>, or C<y>),
+
+=item [8]
+
+the text of the second block of the operation
+(that is, the replacement of a substitution or the translation list
+of a translation),
+
+=item [9]
+
+the right delimiter of the second block of the operation (if any),
+
+=item [10]
+
+the trailing modifiers on the operation (if any).
+
+=back
+
+For each of the fields marked "(if any)" the default value on success is
+an empty string.
+On failure, all of these values (except the remaining text) are C<undef>.
+
+
+In a scalar context, C<extract_quotelike> returns just the complete substring
+that matched a quotelike operation (or C<undef> on failure). In a scalar or
+void context, the input text has the same substring (and any specified
+prefix) removed.
+
+Examples:
+
+ # Remove the first quotelike literal that appears in text
+
+ $quotelike = extract_quotelike($text,'.*?');
+
+ # Replace one or more leading whitespace-separated quotelike
+ # literals in $_ with "<QLL>"
+
+ do { $_ = join '<QLL>', (extract_quotelike)[2,1] } until $@;
+
+
+ # Isolate the search pattern in a quotelike operation from $text
+
+ ($op,$pat) = (extract_quotelike $text)[3,5];
+ if ($op =~ /[ms]/)
+ {
+ print "search pattern: $pat\n";
+ }
+ else
+ {
+ print "$op is not a pattern matching operation\n";
+ }
+
+
+=head2 C<extract_quotelike> and "here documents"
+
+C<extract_quotelike> can successfully extract "here documents" from an input
+string, but with an important caveat in list contexts.
+
+Unlike other types of quote-like literals, a here document is rarely
+a contiguous substring. For example, a typical piece of code using
+here document might look like this:
+
+ <<'EOMSG' || die;
+ This is the message.
+ EOMSG
+ exit;
+
+Given this as an input string in a scalar context, C<extract_quotelike>
+would correctly return the string "<<'EOMSG'\nThis is the message.\nEOMSG",
+leaving the string " || die;\nexit;" in the original variable. In other words,
+the two separate pieces of the here document are successfully extracted and
+concatenated.
+
+In a list context, C<extract_quotelike> would return the list
+
+=over 4
+
+=item [0]
+
+"<<'EOMSG'\nThis is the message.\nEOMSG\n" (i.e. the full extracted here document,
+including fore and aft delimiters),
+
+=item [1]
+
+" || die;\nexit;" (i.e. the remainder of the input text, concatenated),
+
+=item [2]
+
+"" (i.e. the prefix substring -- trivial in this case),
+
+=item [3]
+
+"<<" (i.e. the "name" of the quotelike operator)
+
+=item [4]
+
+"'EOMSG'" (i.e. the left delimiter of the here document, including any quotes),
+
+=item [5]
+
+"This is the message.\n" (i.e. the text of the here document),
+
+=item [6]
+
+"EOMSG" (i.e. the right delimiter of the here document),
+
+=item [7..10]
+
+"" (a here document has no second left delimiter, second text, second right
+delimiter, or trailing modifiers).
+
+=back
+
+However, the matching position of the input variable would be set to
+"exit;" (i.e. I<after> the closing delimiter of the here document),
+which would cause the earlier " || die;\nexit;" to be skipped in any
+sequence of code fragment extractions.
+
+To avoid this problem, when it encounters a here document whilst
+extracting from a modifiable string, C<extract_quotelike> silently
+rearranges the string to an equivalent piece of Perl:
+
+ <<'EOMSG'
+ This is the message.
+ EOMSG
+ || die;
+ exit;
+
+in which the here document I<is> contiguous. It still leaves the
+matching position after the here document, but now the rest of the line
+on which the here document starts is not skipped.
+
+To prevent <extract_quotelike> from mucking about with the input in this way
+(this is the only case where a list-context C<extract_quotelike> does so),
+you can pass the input variable as an interpolated literal:
+
+ $quotelike = extract_quotelike("$var");
+
+
+=head2 C<extract_codeblock>
+
+C<extract_codeblock> attempts to recognize and extract a balanced
+bracket delimited substring that may contain unbalanced brackets
+inside Perl quotes or quotelike operations. That is, C<extract_codeblock>
+is like a combination of C<"extract_bracketed"> and
+C<"extract_quotelike">.
+
+C<extract_codeblock> takes the same initial three parameters as C<extract_bracketed>:
+a text to process, a set of delimiter brackets to look for, and a prefix to
+match first. It also takes an optional fourth parameter, which allows the
+outermost delimiter brackets to be specified separately (see below).
+
+Omitting the first argument (input text) means process C<$_> instead.
+Omitting the second argument (delimiter brackets) indicates that only C<'{'> is to be used.
+Omitting the third argument (prefix argument) implies optional whitespace at the start.
+Omitting the fourth argument (outermost delimiter brackets) indicates that the
+value of the second argument is to be used for the outermost delimiters.
+
+Once the prefix an dthe outermost opening delimiter bracket have been
+recognized, code blocks are extracted by stepping through the input text and
+trying the following alternatives in sequence:
+
+=over 4
+
+=item 1.
+
+Try and match a closing delimiter bracket. If the bracket was the same
+species as the last opening bracket, return the substring to that
+point. If the bracket was mismatched, return an error.
+
+=item 2.
+
+Try to match a quote or quotelike operator. If found, call
+C<extract_quotelike> to eat it. If C<extract_quotelike> fails, return
+the error it returned. Otherwise go back to step 1.
+
+=item 3.
+
+Try to match an opening delimiter bracket. If found, call
+C<extract_codeblock> recursively to eat the embedded block. If the
+recursive call fails, return an error. Otherwise, go back to step 1.
+
+=item 4.
+
+Unconditionally match a bareword or any other single character, and
+then go back to step 1.
+
+=back
+
+
+Examples:
+
+ # Find a while loop in the text
+
+ if ($text =~ s/.*?while\s*\{/{/)
+ {
+ $loop = "while " . extract_codeblock($text);
+ }
+
+ # Remove the first round-bracketed list (which may include
+ # round- or curly-bracketed code blocks or quotelike operators)
+
+ extract_codeblock $text, "(){}", '[^(]*';
+
+
+The ability to specify a different outermost delimiter bracket is useful
+in some circumstances. For example, in the Parse::RecDescent module,
+parser actions which are to be performed only on a successful parse
+are specified using a C<E<lt>defer:...E<gt>> directive. For example:
+
+ sentence: subject verb object
+ <defer: {$::theVerb = $item{verb}} >
+
+Parse::RecDescent uses C<extract_codeblock($text, '{}E<lt>E<gt>')> to extract the code
+within the C<E<lt>defer:...E<gt>> directive, but there's a problem.
+
+A deferred action like this:
+
+ <defer: {if ($count>10) {$count--}} >
+
+will be incorrectly parsed as:
+
+ <defer: {if ($count>
+
+because the "less than" operator is interpreted as a closing delimiter.
+
+But, by extracting the directive using
+S<C<extract_codeblock($text, '{}', undef, 'E<lt>E<gt>')>>
+the '>' character is only treated as a delimited at the outermost
+level of the code block, so the directive is parsed correctly.
+
+=head2 C<extract_multiple>
+
+The C<extract_multiple> subroutine takes a string to be processed and a
+list of extractors (subroutines or regular expressions) to apply to that string.
+
+In an array context C<extract_multiple> returns an array of substrings
+of the original string, as extracted by the specified extractors.
+In a scalar context, C<extract_multiple> returns the first
+substring successfully extracted from the original string. In both
+scalar and void contexts the original string has the first successfully
+extracted substring removed from it. In all contexts
+C<extract_multiple> starts at the current C<pos> of the string, and
+sets that C<pos> appropriately after it matches.
+
+Hence, the aim of of a call to C<extract_multiple> in a list context
+is to split the processed string into as many non-overlapping fields as
+possible, by repeatedly applying each of the specified extractors
+to the remainder of the string. Thus C<extract_multiple> is
+a generalized form of Perl's C<split> subroutine.
+
+The subroutine takes up to four optional arguments:
+
+=over 4
+
+=item 1.
+
+A string to be processed (C<$_> if the string is omitted or C<undef>)
+
+=item 2.
+
+A reference to a list of subroutine references and/or qr// objects and/or
+literal strings and/or hash references, specifying the extractors
+to be used to split the string. If this argument is omitted (or
+C<undef>) the list:
+
+ [
+ sub { extract_variable($_[0], '') },
+ sub { extract_quotelike($_[0],'') },
+ sub { extract_codeblock($_[0],'{}','') },
+ ]
+
+is used.
+
+
+=item 3.
+
+An number specifying the maximum number of fields to return. If this
+argument is omitted (or C<undef>), split continues as long as possible.
+
+If the third argument is I<N>, then extraction continues until I<N> fields
+have been successfully extracted, or until the string has been completely
+processed.
+
+Note that in scalar and void contexts the value of this argument is
+automatically reset to 1 (under C<-w>, a warning is issued if the argument
+has to be reset).
+
+=item 4.
+
+A value indicating whether unmatched substrings (see below) within the
+text should be skipped or returned as fields. If the value is true,
+such substrings are skipped. Otherwise, they are returned.
+
+=back
+
+The extraction process works by applying each extractor in
+sequence to the text string.
+
+If the extractor is a subroutine it is called in a list context and is
+expected to return a list of a single element, namely the extracted
+text. It may optionally also return two further arguments: a string
+representing the text left after extraction (like $' for a pattern
+match), and a string representing any prefix skipped before the
+extraction (like $` in a pattern match). Note that this is designed
+to facilitate the use of other Text::Balanced subroutines with
+C<extract_multiple>. Note too that the value returned by an extractor
+subroutine need not bear any relationship to the corresponding substring
+of the original text (see examples below).
+
+If the extractor is a precompiled regular expression or a string,
+it is matched against the text in a scalar context with a leading
+'\G' and the gc modifiers enabled. The extracted value is either
+$1 if that variable is defined after the match, or else the
+complete match (i.e. $&).
+
+If the extractor is a hash reference, it must contain exactly one element.
+The value of that element is one of the
+above extractor types (subroutine reference, regular expression, or string).
+The key of that element is the name of a class into which the successful
+return value of the extractor will be blessed.
+
+If an extractor returns a defined value, that value is immediately
+treated as the next extracted field and pushed onto the list of fields.
+If the extractor was specified in a hash reference, the field is also
+blessed into the appropriate class,
+
+If the extractor fails to match (in the case of a regex extractor), or returns an empty list or an undefined value (in the case of a subroutine extractor), it is
+assumed to have failed to extract.
+If none of the extractor subroutines succeeds, then one
+character is extracted from the start of the text and the extraction
+subroutines reapplied. Characters which are thus removed are accumulated and
+eventually become the next field (unless the fourth argument is true, in which
+case they are discarded).
+
+For example, the following extracts substrings that are valid Perl variables:
+
+ @fields = extract_multiple($text,
+ [ sub { extract_variable($_[0]) } ],
+ undef, 1);
+
+This example separates a text into fields which are quote delimited,
+curly bracketed, and anything else. The delimited and bracketed
+parts are also blessed to identify them (the "anything else" is unblessed):
+
+ @fields = extract_multiple($text,
+ [
+ { Delim => sub { extract_delimited($_[0],q{'"}) } },
+ { Brack => sub { extract_bracketed($_[0],'{}') } },
+ ]);
+
+This call extracts the next single substring that is a valid Perl quotelike
+operator (and removes it from $text):
+
+ $quotelike = extract_multiple($text,
+ [
+ sub { extract_quotelike($_[0]) },
+ ], undef, 1);
+
+Finally, here is yet another way to do comma-separated value parsing:
+
+ @fields = extract_multiple($csv_text,
+ [
+ sub { extract_delimited($_[0],q{'"}) },
+ qr/([^,]+)(.*)/,
+ ],
+ undef,1);
+
+The list in the second argument means:
+I<"Try and extract a ' or " delimited string, otherwise extract anything up to a comma...">.
+The undef third argument means:
+I<"...as many times as possible...">,
+and the true value in the fourth argument means
+I<"...discarding anything else that appears (i.e. the commas)">.
+
+If you wanted the commas preserved as separate fields (i.e. like split
+does if your split pattern has capturing parentheses), you would
+just make the last parameter undefined (or remove it).
+
+
+=head2 C<gen_delimited_pat>
+
+The C<gen_delimited_pat> subroutine takes a single (string) argument and
+ > builds a Friedl-style optimized regex that matches a string delimited
+by any one of the characters in the single argument. For example:
+
+ gen_delimited_pat(q{'"})
+
+returns the regex:
+
+ (?:\"(?:\\\"|(?!\").)*\"|\'(?:\\\'|(?!\').)*\')
+
+Note that the specified delimiters are automatically quotemeta'd.
+
+A typical use of C<gen_delimited_pat> would be to build special purpose tags
+for C<extract_tagged>. For example, to properly ignore "empty" XML elements
+(which might contain quoted strings):
+
+ my $empty_tag = '<(' . gen_delimited_pat(q{'"}) . '|.)+/>';
+
+ extract_tagged($text, undef, undef, undef, {ignore => [$empty_tag]} );
+
+
+C<gen_delimited_pat> may also be called with an optional second argument,
+which specifies the "escape" character(s) to be used for each delimiter.
+For example to match a Pascal-style string (where ' is the delimiter
+and '' is a literal ' within the string):
+
+ gen_delimited_pat(q{'},q{'});
+
+Different escape characters can be specified for different delimiters.
+For example, to specify that '/' is the escape for single quotes
+and '%' is the escape for double quotes:
+
+ gen_delimited_pat(q{'"},q{/%});
+
+If more delimiters than escape chars are specified, the last escape char
+is used for the remaining delimiters.
+If no escape char is specified for a given specified delimiter, '\' is used.
+
+=head2 C<delimited_pat>
+
+Note that C<gen_delimited_pat> was previously called C<delimited_pat>.
+That name may still be used, but is now deprecated.
+
+
+=head1 DIAGNOSTICS
+
+In a list context, all the functions return C<(undef,$original_text)>
+on failure. In a scalar context, failure is indicated by returning C<undef>
+(in this case the input text is not modified in any way).
+
+In addition, on failure in I<any> context, the C<$@> variable is set.
+Accessing C<$@-E<gt>{error}> returns one of the error diagnostics listed
+below.
+Accessing C<$@-E<gt>{pos}> returns the offset into the original string at
+which the error was detected (although not necessarily where it occurred!)
+Printing C<$@> directly produces the error message, with the offset appended.
+On success, the C<$@> variable is guaranteed to be C<undef>.
+
+The available diagnostics are:
+
+=over 4
+
+=item C<Did not find a suitable bracket: "%s">
+
+The delimiter provided to C<extract_bracketed> was not one of
+C<'()[]E<lt>E<gt>{}'>.
+
+=item C<Did not find prefix: /%s/>
+
+A non-optional prefix was specified but wasn't found at the start of the text.
+
+=item C<Did not find opening bracket after prefix: "%s">
+
+C<extract_bracketed> or C<extract_codeblock> was expecting a
+particular kind of bracket at the start of the text, and didn't find it.
+
+=item C<No quotelike operator found after prefix: "%s">
+
+C<extract_quotelike> didn't find one of the quotelike operators C<q>,
+C<qq>, C<qw>, C<qx>, C<s>, C<tr> or C<y> at the start of the substring
+it was extracting.
+
+=item C<Unmatched closing bracket: "%c">
+
+C<extract_bracketed>, C<extract_quotelike> or C<extract_codeblock> encountered
+a closing bracket where none was expected.
+
+=item C<Unmatched opening bracket(s): "%s">
+
+C<extract_bracketed>, C<extract_quotelike> or C<extract_codeblock> ran
+out of characters in the text before closing one or more levels of nested
+brackets.
+
+=item C<Unmatched embedded quote (%s)>
+
+C<extract_bracketed> attempted to match an embedded quoted substring, but
+failed to find a closing quote to match it.
+
+=item C<Did not find closing delimiter to match '%s'>
+
+C<extract_quotelike> was unable to find a closing delimiter to match the
+one that opened the quote-like operation.
+
+=item C<Mismatched closing bracket: expected "%c" but found "%s">
+
+C<extract_bracketed>, C<extract_quotelike> or C<extract_codeblock> found
+a valid bracket delimiter, but it was the wrong species. This usually
+indicates a nesting error, but may indicate incorrect quoting or escaping.
+
+=item C<No block delimiter found after quotelike "%s">
+
+C<extract_quotelike> or C<extract_codeblock> found one of the
+quotelike operators C<q>, C<qq>, C<qw>, C<qx>, C<s>, C<tr> or C<y>
+without a suitable block after it.
+
+=item C<Did not find leading dereferencer>
+
+C<extract_variable> was expecting one of '$', '@', or '%' at the start of
+a variable, but didn't find any of them.
+
+=item C<Bad identifier after dereferencer>
+
+C<extract_variable> found a '$', '@', or '%' indicating a variable, but that
+character was not followed by a legal Perl identifier.
+
+=item C<Did not find expected opening bracket at %s>
+
+C<extract_codeblock> failed to find any of the outermost opening brackets
+that were specified.
+
+=item C<Improperly nested codeblock at %s>
+
+A nested code block was found that started with a delimiter that was specified
+as being only to be used as an outermost bracket.
+
+=item C<Missing second block for quotelike "%s">
+
+C<extract_codeblock> or C<extract_quotelike> found one of the
+quotelike operators C<s>, C<tr> or C<y> followed by only one block.
+
+=item C<No match found for opening bracket>
+
+C<extract_codeblock> failed to find a closing bracket to match the outermost
+opening bracket.
+
+=item C<Did not find opening tag: /%s/>
+
+C<extract_tagged> did not find a suitable opening tag (after any specified
+prefix was removed).
+
+=item C<Unable to construct closing tag to match: /%s/>
+
+C<extract_tagged> matched the specified opening tag and tried to
+modify the matched text to produce a matching closing tag (because
+none was specified). It failed to generate the closing tag, almost
+certainly because the opening tag did not start with a
+bracket of some kind.
+
+=item C<Found invalid nested tag: %s>
+
+C<extract_tagged> found a nested tag that appeared in the "reject" list
+(and the failure mode was not "MAX" or "PARA").
+
+=item C<Found unbalanced nested tag: %s>
+
+C<extract_tagged> found a nested opening tag that was not matched by a
+corresponding nested closing tag (and the failure mode was not "MAX" or "PARA").
+
+=item C<Did not find closing tag>
+
+C<extract_tagged> reached the end of the text without finding a closing tag
+to match the original opening tag (and the failure mode was not
+"MAX" or "PARA").
+
+
+
+
+=back
+
+
+=head1 AUTHOR
+
+Damian Conway (damian at conway.org)
+
+
+=head1 BUGS AND IRRITATIONS
+
+There are undoubtedly serious bugs lurking somewhere in this code, if
+only because parts of it give the impression of understanding a great deal
+more about Perl than they really do.
+
+Bug reports and other feedback are most welcome.
+
+
+=head1 COPYRIGHT
+
+ Copyright (c) 1997-2001, Damian Conway. All Rights Reserved.
+ This module is free software. It may be used, redistributed
+ and/or modified under the same terms as Perl itself.
Copied: trunk/contrib/perl/lib/Text/ParseWords.pm (from rev 6437, vendor/perl/5.18.1/lib/Text/ParseWords.pm)
===================================================================
--- trunk/contrib/perl/lib/Text/ParseWords.pm (rev 0)
+++ trunk/contrib/perl/lib/Text/ParseWords.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,294 @@
+package Text::ParseWords;
+
+use strict;
+require 5.006;
+our $VERSION = "3.27";
+
+
+use Exporter;
+our @ISA = qw(Exporter);
+our @EXPORT = qw(shellwords quotewords nested_quotewords parse_line);
+our @EXPORT_OK = qw(old_shellwords);
+our $PERL_SINGLE_QUOTE;
+
+
+sub shellwords {
+ my (@lines) = @_;
+ my @allwords;
+
+ foreach my $line (@lines) {
+ $line =~ s/^\s+//;
+ my @words = parse_line('\s+', 0, $line);
+ pop @words if (@words and !defined $words[-1]);
+ return() unless (@words || !length($line));
+ push(@allwords, @words);
+ }
+ return(@allwords);
+}
+
+
+
+sub quotewords {
+ my($delim, $keep, @lines) = @_;
+ my($line, @words, @allwords);
+
+ foreach $line (@lines) {
+ @words = parse_line($delim, $keep, $line);
+ return() unless (@words || !length($line));
+ push(@allwords, @words);
+ }
+ return(@allwords);
+}
+
+
+
+sub nested_quotewords {
+ my($delim, $keep, @lines) = @_;
+ my($i, @allwords);
+
+ for ($i = 0; $i < @lines; $i++) {
+ @{$allwords[$i]} = parse_line($delim, $keep, $lines[$i]);
+ return() unless (@{$allwords[$i]} || !length($lines[$i]));
+ }
+ return(@allwords);
+}
+
+
+
+sub parse_line {
+ my($delimiter, $keep, $line) = @_;
+ my($word, @pieces);
+
+ no warnings 'uninitialized'; # we will be testing undef strings
+
+ while (length($line)) {
+ # This pattern is optimised to be stack conservative on older perls.
+ # Do not refactor without being careful and testing it on very long strings.
+ # See Perl bug #42980 for an example of a stack busting input.
+ $line =~ s/^
+ (?:
+ # double quoted string
+ (") # $quote
+ ((?>[^\\"]*(?:\\.[^\\"]*)*))" # $quoted
+ | # --OR--
+ # singe quoted string
+ (') # $quote
+ ((?>[^\\']*(?:\\.[^\\']*)*))' # $quoted
+ | # --OR--
+ # unquoted string
+ ( # $unquoted
+ (?:\\.|[^\\"'])*?
+ )
+ # followed by
+ ( # $delim
+ \Z(?!\n) # EOL
+ | # --OR--
+ (?-x:$delimiter) # delimiter
+ | # --OR--
+ (?!^)(?=["']) # a quote
+ )
+ )//xs or return; # extended layout
+ my ($quote, $quoted, $unquoted, $delim) = (($1 ? ($1,$2) : ($3,$4)), $5, $6);
+
+
+ return() unless( defined($quote) || length($unquoted) || length($delim));
+
+ if ($keep) {
+ $quoted = "$quote$quoted$quote";
+ }
+ else {
+ $unquoted =~ s/\\(.)/$1/sg;
+ if (defined $quote) {
+ $quoted =~ s/\\(.)/$1/sg if ($quote eq '"');
+ $quoted =~ s/\\([\\'])/$1/g if ( $PERL_SINGLE_QUOTE && $quote eq "'");
+ }
+ }
+ $word .= substr($line, 0, 0); # leave results tainted
+ $word .= defined $quote ? $quoted : $unquoted;
+
+ if (length($delim)) {
+ push(@pieces, $word);
+ push(@pieces, $delim) if ($keep eq 'delimiters');
+ undef $word;
+ }
+ if (!length($line)) {
+ push(@pieces, $word);
+ }
+ }
+ return(@pieces);
+}
+
+
+
+sub old_shellwords {
+
+ # Usage:
+ # use ParseWords;
+ # @words = old_shellwords($line);
+ # or
+ # @words = old_shellwords(@lines);
+ # or
+ # @words = old_shellwords(); # defaults to $_ (and clobbers it)
+
+ no warnings 'uninitialized'; # we will be testing undef strings
+ local *_ = \join('', @_) if @_;
+ my (@words, $snippet);
+
+ s/\A\s+//;
+ while ($_ ne '') {
+ my $field = substr($_, 0, 0); # leave results tainted
+ for (;;) {
+ if (s/\A"(([^"\\]|\\.)*)"//s) {
+ ($snippet = $1) =~ s#\\(.)#$1#sg;
+ }
+ elsif (/\A"/) {
+ require Carp;
+ Carp::carp("Unmatched double quote: $_");
+ return();
+ }
+ elsif (s/\A'(([^'\\]|\\.)*)'//s) {
+ ($snippet = $1) =~ s#\\(.)#$1#sg;
+ }
+ elsif (/\A'/) {
+ require Carp;
+ Carp::carp("Unmatched single quote: $_");
+ return();
+ }
+ elsif (s/\A\\(.?)//s) {
+ $snippet = $1;
+ }
+ elsif (s/\A([^\s\\'"]+)//) {
+ $snippet = $1;
+ }
+ else {
+ s/\A\s+//;
+ last;
+ }
+ $field .= $snippet;
+ }
+ push(@words, $field);
+ }
+ return @words;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Text::ParseWords - parse text into an array of tokens or array of arrays
+
+=head1 SYNOPSIS
+
+ use Text::ParseWords;
+ @lists = nested_quotewords($delim, $keep, @lines);
+ @words = quotewords($delim, $keep, @lines);
+ @words = shellwords(@lines);
+ @words = parse_line($delim, $keep, $line);
+ @words = old_shellwords(@lines); # DEPRECATED!
+
+=head1 DESCRIPTION
+
+The &nested_quotewords() and "ewords() functions accept a delimiter
+(which can be a regular expression)
+and a list of lines and then breaks those lines up into a list of
+words ignoring delimiters that appear inside quotes. "ewords()
+returns all of the tokens in a single long list, while &nested_quotewords()
+returns a list of token lists corresponding to the elements of @lines.
+&parse_line() does tokenizing on a single string. The &*quotewords()
+functions simply call &parse_line(), so if you're only splitting
+one line you can call &parse_line() directly and save a function
+call.
+
+The $keep argument is a boolean flag. If true, then the tokens are
+split on the specified delimiter, but all other characters (quotes,
+backslashes, etc.) are kept in the tokens. If $keep is false then the
+&*quotewords() functions remove all quotes and backslashes that are
+not themselves backslash-escaped or inside of single quotes (i.e.,
+"ewords() tries to interpret these characters just like the Bourne
+shell). NB: these semantics are significantly different from the
+original version of this module shipped with Perl 5.000 through 5.004.
+As an additional feature, $keep may be the keyword "delimiters" which
+causes the functions to preserve the delimiters in each string as
+tokens in the token lists, in addition to preserving quote and
+backslash characters.
+
+&shellwords() is written as a special case of "ewords(), and it
+does token parsing with whitespace as a delimiter-- similar to most
+Unix shells.
+
+=head1 EXAMPLES
+
+The sample program:
+
+ use Text::ParseWords;
+ @words = quotewords('\s+', 0, q{this is "a test" of\ quotewords \"for you});
+ $i = 0;
+ foreach (@words) {
+ print "$i: <$_>\n";
+ $i++;
+ }
+
+produces:
+
+ 0: <this>
+ 1: <is>
+ 2: <a test>
+ 3: <of quotewords>
+ 4: <"for>
+ 5: <you>
+
+demonstrating:
+
+=over 4
+
+=item 0
+
+a simple word
+
+=item 1
+
+multiple spaces are skipped because of our $delim
+
+=item 2
+
+use of quotes to include a space in a word
+
+=item 3
+
+use of a backslash to include a space in a word
+
+=item 4
+
+use of a backslash to remove the special meaning of a double-quote
+
+=item 5
+
+another simple word (note the lack of effect of the
+backslashed double-quote)
+
+=back
+
+Replacing C<quotewords('\s+', 0, q{this is...})>
+with C<shellwords(q{this is...})>
+is a simpler way to accomplish the same thing.
+
+=head1 AUTHORS
+
+Maintainer: Alexandr Ciornii <alexchornyATgmail.com>.
+
+Previous maintainer: Hal Pomeranz <pomeranz at netcom.com>, 1994-1997 (Original
+author unknown). Much of the code for &parse_line() (including the
+primary regexp) from Joerk Behrends <jbehrends at multimediaproduzenten.de>.
+
+Examples section another documentation provided by John Heidemann
+<johnh at ISI.EDU>
+
+Bug reports, patches, and nagging provided by lots of folks-- thanks
+everybody! Special thanks to Michael Schwern <schwern at envirolink.org>
+for assuring me that a &nested_quotewords() would be useful, and to
+Jeff Friedl <jfriedl at yahoo-inc.com> for telling me not to worry about
+error-checking (sort of-- you had to be there).
+
+=cut
Copied: trunk/contrib/perl/lib/Text/ParseWords.t (from rev 6437, vendor/perl/5.18.1/lib/Text/ParseWords.t)
===================================================================
--- trunk/contrib/perl/lib/Text/ParseWords.t (rev 0)
+++ trunk/contrib/perl/lib/Text/ParseWords.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,129 @@
+#!./perl
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+}
+
+use warnings;
+use Text::ParseWords;
+use Test::More tests => 27;
+
+ at words = shellwords(qq(foo "bar quiz" zoo));
+is($words[0], 'foo');
+is($words[1], 'bar quiz');
+is($words[2], 'zoo');
+
+{
+ # Gonna get some undefined things back
+ no warnings 'uninitialized' ;
+
+ # Test quotewords() with other parameters and null last field
+ @words = quotewords(':+', 1, 'foo:::"bar:foo":zoo zoo:');
+ is(join(";", @words), qq(foo;"bar:foo";zoo zoo;));
+}
+
+# Test $keep eq 'delimiters' and last field zero
+ at words = quotewords('\s+', 'delimiters', '4 3 2 1 0');
+is(join(";", @words), qq(4; ;3; ;2; ;1; ;0));
+
+# Big ol' nasty test (thanks, Joerk!)
+$string = 'aaaa"bbbbb" cc\\ cc \\\\\\"dddd" eee\\\\\\"ffff" "gg"';
+
+# First with $keep == 1
+$result = join('|', parse_line('\s+', 1, $string));
+is($result, 'aaaa"bbbbb"|cc\\ cc|\\\\\\"dddd" eee\\\\\\"ffff"|"gg"');
+
+# Now, $keep == 0
+$result = join('|', parse_line('\s+', 0, $string));
+is($result, 'aaaabbbbb|cc cc|\\"dddd eee\\"ffff|gg');
+
+# Now test single quote behavior
+$string = 'aaaa"bbbbb" cc\\ cc \\\\\\"dddd\' eee\\\\\\"ffff\' gg';
+$result = join('|', parse_line('\s+', 0, $string));
+is($result, 'aaaabbbbb|cc cc|\\"dddd eee\\\\\\"ffff|gg');
+
+# Make sure @nested_quotewords does the right thing
+ at lists = nested_quotewords('\s+', 0, 'a b c', '1 2 3', 'x y z');
+is (@lists, 3);
+is (@{$lists[0]}, 3);
+is (@{$lists[1]}, 3);
+is (@{$lists[2]}, 3);
+
+# Now test error return
+$string = 'foo bar baz"bach blech boop';
+
+ at words = shellwords($string);
+is(@words, 0);
+
+ at words = parse_line('s+', 0, $string);
+is(@words, 0);
+
+ at words = quotewords('s+', 0, $string);
+is(@words, 0);
+
+{
+ # Gonna get some more undefined things back
+ no warnings 'uninitialized' ;
+
+ @words = nested_quotewords('s+', 0, $string);
+ is(@words, 0);
+
+ # Now test empty fields
+ $result = join('|', parse_line(':', 0, 'foo::0:"":::'));
+ is($result, 'foo||0||||');
+
+ # Test for 0 in quotes without $keep
+ $result = join('|', parse_line(':', 0, ':"0":'));
+ is($result, '|0|');
+
+ # Test for \001 in quoted string
+ $result = join('|', parse_line(':', 0, ':"' . "\001" . '":'));
+ is($result, "|\1|");
+
+}
+
+# Now test perlish single quote behavior
+$Text::ParseWords::PERL_SINGLE_QUOTE = 1;
+$string = 'aaaa"bbbbb" cc\ cc \\\\\"dddd\' eee\\\\\"\\\'ffff\' gg';
+$result = join('|', parse_line('\s+', 0, $string));
+is($result, 'aaaabbbbb|cc cc|\"dddd eee\\\\"\'ffff|gg');
+
+# test whitespace in the delimiters
+ at words = quotewords(' ', 1, '4 3 2 1 0');
+is(join(";", @words), qq(4;3;2;1;0));
+
+# [perl #30442] Text::ParseWords does not handle backslashed newline inside quoted text
+$string = qq{"field1" "field2\\\nstill field2" "field3"};
+
+$result = join('|', parse_line("\t", 1, $string));
+is($result, qq{"field1"|"field2\\\nstill field2"|"field3"});
+
+$result = join('|', parse_line("\t", 0, $string));
+is($result, "field1|field2\nstill field2|field3");
+
+SKIP: { # unicode
+ skip "No unicode",1 if $]<5.008;
+ $string = qq{"field1"\x{1234}"field2\\\x{1234}still field2"\x{1234}"field3"};
+ $result = join('|', parse_line("\x{1234}", 0, $string));
+ is($result, "field1|field2\x{1234}still field2|field3",'Unicode');
+}
+
+# missing quote after matching regex used to hang after change #22997
+"1234" =~ /(1)(2)(3)(4)/;
+$string = qq{"missing quote};
+$result = join('|', shellwords($string));
+is($result, "");
+
+# make sure shellwords strips out leading whitespace and trailng undefs
+# from parse_line, so it's behavior is more like /bin/sh
+$result = join('|', shellwords(" aa \\ \\ bb ", " \\ ", "cc dd ee\\ "));
+is($result, "aa| | bb| |cc|dd|ee ");
+
+$SIG{ALRM} = sub {die "Timeout!"};
+alarm(3);
+ at words = Text::ParseWords::old_shellwords("foo\\");
+is(@words, 1);
+alarm(0);
Copied: trunk/contrib/perl/lib/Text/Tabs.pm (from rev 6437, vendor/perl/5.18.1/lib/Text/Tabs.pm)
===================================================================
--- trunk/contrib/perl/lib/Text/Tabs.pm (rev 0)
+++ trunk/contrib/perl/lib/Text/Tabs.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,136 @@
+
+package Text::Tabs;
+
+require Exporter;
+
+ at ISA = (Exporter);
+ at EXPORT = qw(expand unexpand $tabstop);
+
+use vars qw($VERSION $tabstop $debug);
+$VERSION = 2009.0305;
+
+use strict;
+
+BEGIN {
+ $tabstop = 8;
+ $debug = 0;
+}
+
+sub expand {
+ my @l;
+ my $pad;
+ for ( @_ ) {
+ my $s = '';
+ for (split(/^/m, $_, -1)) {
+ my $offs = 0;
+ s{\t}{
+ $pad = $tabstop - (pos() + $offs) % $tabstop;
+ $offs += $pad - 1;
+ " " x $pad;
+ }eg;
+ $s .= $_;
+ }
+ push(@l, $s);
+ }
+ return @l if wantarray;
+ return $l[0];
+}
+
+sub unexpand
+{
+ my (@l) = @_;
+ my @e;
+ my $x;
+ my $line;
+ my @lines;
+ my $lastbit;
+ my $ts_as_space = " "x$tabstop;
+ for $x (@l) {
+ @lines = split("\n", $x, -1);
+ for $line (@lines) {
+ $line = expand($line);
+ @e = split(/(.{$tabstop})/,$line,-1);
+ $lastbit = pop(@e);
+ $lastbit = ''
+ unless defined $lastbit;
+ $lastbit = "\t"
+ if $lastbit eq $ts_as_space;
+ for $_ (@e) {
+ if ($debug) {
+ my $x = $_;
+ $x =~ s/\t/^I\t/gs;
+ print "sub on '$x'\n";
+ }
+ s/ +$/\t/;
+ }
+ $line = join('', at e, $lastbit);
+ }
+ $x = join("\n", @lines);
+ }
+ return @l if wantarray;
+ return $l[0];
+}
+
+1;
+__END__
+
+sub expand
+{
+ my (@l) = @_;
+ for $_ (@l) {
+ 1 while s/(^|\n)([^\t\n]*)(\t+)/
+ $1. $2 . (" " x
+ ($tabstop * length($3)
+ - (length($2) % $tabstop)))
+ /sex;
+ }
+ return @l if wantarray;
+ return $l[0];
+}
+
+
+=head1 NAME
+
+Text::Tabs -- expand and unexpand tabs per the unix expand(1) and unexpand(1)
+
+=head1 SYNOPSIS
+
+ use Text::Tabs;
+
+ $tabstop = 4; # default = 8
+ @lines_without_tabs = expand(@lines_with_tabs);
+ @lines_with_tabs = unexpand(@lines_without_tabs);
+
+=head1 DESCRIPTION
+
+Text::Tabs does about what the unix utilities expand(1) and unexpand(1)
+do. Given a line with tabs in it, expand will replace the tabs with
+the appropriate number of spaces. Given a line with or without tabs in
+it, unexpand will add tabs when it can save bytes by doing so (just
+like C<unexpand -a>). Invisible compression with plain ASCII!
+
+=head1 EXAMPLE
+
+ #!perl
+ # unexpand -a
+ use Text::Tabs;
+
+ while (<>) {
+ print unexpand $_;
+ }
+
+Instead of the C<expand> comand, use:
+
+ perl -MText::Tabs -n -e 'print expand $_'
+
+Instead of the C<unexpand -a> command, use:
+
+ perl -MText::Tabs -n -e 'print unexpand $_'
+
+=head1 LICENSE
+
+Copyright (C) 1996-2002,2005,2006 David Muir Sharnoff.
+Copyright (C) 2005 Aristotle Pagaltzis
+This module may be modified, used, copied, and redistributed at your own risk.
+Publicly redistributed modified versions must use a different name.
+
Copied: trunk/contrib/perl/lib/Text/Wrap.pm (from rev 6437, vendor/perl/5.18.1/lib/Text/Wrap.pm)
===================================================================
--- trunk/contrib/perl/lib/Text/Wrap.pm (rev 0)
+++ trunk/contrib/perl/lib/Text/Wrap.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,265 @@
+package Text::Wrap;
+
+use warnings::register;
+require Exporter;
+
+ at ISA = qw(Exporter);
+ at EXPORT = qw(wrap fill);
+ at EXPORT_OK = qw($columns $break $huge);
+
+$VERSION = 2009.0305;
+
+use vars qw($VERSION $columns $debug $break $huge $unexpand $tabstop
+ $separator $separator2);
+use strict;
+
+BEGIN {
+ $columns = 76; # <= screen width
+ $debug = 0;
+ $break = '\s';
+ $huge = 'wrap'; # alternatively: 'die' or 'overflow'
+ $unexpand = 1;
+ $tabstop = 8;
+ $separator = "\n";
+ $separator2 = undef;
+}
+
+use Text::Tabs qw(expand unexpand);
+
+sub wrap
+{
+ my ($ip, $xp, @t) = @_;
+
+ local($Text::Tabs::tabstop) = $tabstop;
+ my $r = "";
+ my $tail = pop(@t);
+ my $t = expand(join("", (map { /\s+\z/ ? ( $_ ) : ($_, ' ') } @t), $tail));
+ my $lead = $ip;
+ my $nll = $columns - length(expand($xp)) - 1;
+ if ($nll <= 0 && $xp ne '') {
+ my $nc = length(expand($xp)) + 2;
+ warnings::warnif "Increasing \$Text::Wrap::columns from $columns to $nc to accommodate length of subsequent tab";
+ $columns = $nc;
+ $nll = 1;
+ }
+ my $ll = $columns - length(expand($ip)) - 1;
+ $ll = 0 if $ll < 0;
+ my $nl = "";
+ my $remainder = "";
+
+ use re 'taint';
+
+ pos($t) = 0;
+ while ($t !~ /\G(?:$break)*\Z/gc) {
+ if ($t =~ /\G([^\n]{0,$ll})($break|\n+|\z)/xmgc) {
+ $r .= $unexpand
+ ? unexpand($nl . $lead . $1)
+ : $nl . $lead . $1;
+ $remainder = $2;
+ } elsif ($huge eq 'wrap' && $t =~ /\G([^\n]{$ll})/gc) {
+ $r .= $unexpand
+ ? unexpand($nl . $lead . $1)
+ : $nl . $lead . $1;
+ $remainder = defined($separator2) ? $separator2 : $separator;
+ } elsif ($huge eq 'overflow' && $t =~ /\G([^\n]*?)($break|\n+|\z)/xmgc) {
+ $r .= $unexpand
+ ? unexpand($nl . $lead . $1)
+ : $nl . $lead . $1;
+ $remainder = $2;
+ } elsif ($huge eq 'die') {
+ die "couldn't wrap '$t'";
+ } elsif ($columns < 2) {
+ warnings::warnif "Increasing \$Text::Wrap::columns from $columns to 2";
+ $columns = 2;
+ return ($ip, $xp, @t);
+ } else {
+ die "This shouldn't happen";
+ }
+
+ $lead = $xp;
+ $ll = $nll;
+ $nl = defined($separator2)
+ ? ($remainder eq "\n"
+ ? "\n"
+ : $separator2)
+ : $separator;
+ }
+ $r .= $remainder;
+
+ print "-----------$r---------\n" if $debug;
+
+ print "Finish up with '$lead'\n" if $debug;
+
+ $r .= $lead . substr($t, pos($t), length($t)-pos($t))
+ if pos($t) ne length($t);
+
+ print "-----------$r---------\n" if $debug;;
+
+ return $r;
+}
+
+sub fill
+{
+ my ($ip, $xp, @raw) = @_;
+ my @para;
+ my $pp;
+
+ for $pp (split(/\n\s+/, join("\n", at raw))) {
+ $pp =~ s/\s+/ /g;
+ my $x = wrap($ip, $xp, $pp);
+ push(@para, $x);
+ }
+
+ # if paragraph_indent is the same as line_indent,
+ # separate paragraphs with blank lines
+
+ my $ps = ($ip eq $xp) ? "\n\n" : "\n";
+ return join ($ps, @para);
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Text::Wrap - line wrapping to form simple paragraphs
+
+=head1 SYNOPSIS
+
+B<Example 1>
+
+ use Text::Wrap;
+
+ $initial_tab = "\t"; # Tab before first line
+ $subsequent_tab = ""; # All other lines flush left
+
+ print wrap($initial_tab, $subsequent_tab, @text);
+ print fill($initial_tab, $subsequent_tab, @text);
+
+ $lines = wrap($initial_tab, $subsequent_tab, @text);
+
+ @paragraphs = fill($initial_tab, $subsequent_tab, @text);
+
+B<Example 2>
+
+ use Text::Wrap qw(wrap $columns $huge);
+
+ $columns = 132; # Wrap at 132 characters
+ $huge = 'die';
+ $huge = 'wrap';
+ $huge = 'overflow';
+
+B<Example 3>
+
+ use Text::Wrap;
+
+ $Text::Wrap::columns = 72;
+ print wrap('', '', @text);
+
+=head1 DESCRIPTION
+
+C<Text::Wrap::wrap()> is a very simple paragraph formatter. It formats a
+single paragraph at a time by breaking lines at word boundaries.
+Indentation is controlled for the first line (C<$initial_tab>) and
+all subsequent lines (C<$subsequent_tab>) independently. Please note:
+C<$initial_tab> and C<$subsequent_tab> are the literal strings that will
+be used: it is unlikely you would want to pass in a number.
+
+Text::Wrap::fill() is a simple multi-paragraph formatter. It formats
+each paragraph separately and then joins them together when it's done. It
+will destroy any whitespace in the original text. It breaks text into
+paragraphs by looking for whitespace after a newline. In other respects
+it acts like wrap().
+
+Both C<wrap()> and C<fill()> return a single string.
+
+=head1 OVERRIDES
+
+C<Text::Wrap::wrap()> has a number of variables that control its behavior.
+Because other modules might be using C<Text::Wrap::wrap()> it is suggested
+that you leave these variables alone! If you can't do that, then
+use C<local($Text::Wrap::VARIABLE) = YOURVALUE> when you change the
+values so that the original value is restored. This C<local()> trick
+will not work if you import the variable into your own namespace.
+
+Lines are wrapped at C<$Text::Wrap::columns> columns (default value: 76).
+C<$Text::Wrap::columns> should be set to the full width of your output
+device. In fact, every resulting line will have length of no more than
+C<$columns - 1>.
+
+It is possible to control which characters terminate words by
+modifying C<$Text::Wrap::break>. Set this to a string such as
+C<'[\s:]'> (to break before spaces or colons) or a pre-compiled regexp
+such as C<qr/[\s']/> (to break before spaces or apostrophes). The
+default is simply C<'\s'>; that is, words are terminated by spaces.
+(This means, among other things, that trailing punctuation such as
+full stops or commas stay with the word they are "attached" to.)
+Setting C<$Text::Wrap::break> to a regular expression that doesn't
+eat any characters (perhaps just a forward look-ahead assertion) will
+cause warnings.
+
+Beginner note: In example 2, above C<$columns> is imported into
+the local namespace, and set locally. In example 3,
+C<$Text::Wrap::columns> is set in its own namespace without importing it.
+
+C<Text::Wrap::wrap()> starts its work by expanding all the tabs in its
+input into spaces. The last thing it does it to turn spaces back
+into tabs. If you do not want tabs in your results, set
+C<$Text::Wrap::unexpand> to a false value. Likewise if you do not
+want to use 8-character tabstops, set C<$Text::Wrap::tabstop> to
+the number of characters you do want for your tabstops.
+
+If you want to separate your lines with something other than C<\n>
+then set C<$Text::Wrap::separator> to your preference. This replaces
+all newlines with C<$Text::Wrap::separator>. If you just want to
+preserve existing newlines but add new breaks with something else, set
+C<$Text::Wrap::separator2> instead.
+
+When words that are longer than C<$columns> are encountered, they
+are broken up. C<wrap()> adds a C<"\n"> at column C<$columns>.
+This behavior can be overridden by setting C<$huge> to
+'die' or to 'overflow'. When set to 'die', large words will cause
+C<die()> to be called. When set to 'overflow', large words will be
+left intact.
+
+Historical notes: 'die' used to be the default value of
+C<$huge>. Now, 'wrap' is the default value.
+
+=head1 EXAMPLES
+
+Code:
+
+ print wrap("\t","",<<END);
+ This is a bit of text that forms
+ a normal book-style indented paragraph
+ END
+
+Result:
+
+ " This is a bit of text that forms
+ a normal book-style indented paragraph
+ "
+
+Code:
+
+ $Text::Wrap::columns=20;
+ $Text::Wrap::separator="|";
+ print wrap("","","This is a bit of text that forms a normal book-style paragraph");
+
+Result:
+
+ "This is a bit of|text that forms a|normal book-style|paragraph"
+
+=head1 SEE ALSO
+
+For wrapping multi-byte characters: L<Text::WrapI18N>.
+For more detailed controls: L<Text::Format>.
+
+=head1 LICENSE
+
+David Muir Sharnoff <muir at idiom.org> with help from Tim Pierce and
+many many others. Copyright (C) 1996-2009 David Muir Sharnoff.
+This module may be modified, used, copied, and redistributed at
+your own risk. Publicly redistributed versions that are modified
+must use a different name.
+
Index: trunk/contrib/perl/lib/Thread.pm
===================================================================
--- trunk/contrib/perl/lib/Thread.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Thread.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Thread.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/Thread.t
===================================================================
--- trunk/contrib/perl/lib/Thread.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Thread.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Thread.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/Tie/Array/push.t
===================================================================
--- trunk/contrib/perl/lib/Tie/Array/push.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Tie/Array/push.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Tie/Array/push.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/Tie/Array/splice.t
===================================================================
--- trunk/contrib/perl/lib/Tie/Array/splice.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Tie/Array/splice.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Tie/Array/splice.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/Tie/Array/std.t
===================================================================
--- trunk/contrib/perl/lib/Tie/Array/std.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Tie/Array/std.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Tie/Array/std.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/Tie/Array/stdpush.t
===================================================================
--- trunk/contrib/perl/lib/Tie/Array/stdpush.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Tie/Array/stdpush.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Tie/Array/stdpush.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/lib/Tie/Array.pm
===================================================================
--- trunk/contrib/perl/lib/Tie/Array.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Tie/Array.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -3,7 +3,7 @@
use 5.006_001;
use strict;
use Carp;
-our $VERSION = '1.04';
+our $VERSION = '1.05';
# Pod documentation after __END__ below.
@@ -277,9 +277,6 @@
between magic entries needed to notice setting of @ISA, and those needed to
implement 'tie'.
-Very little consideration has been given to the behaviour of tied arrays
-when C<$[> is not default value of zero.
-
=head1 AUTHOR
Nick Ing-Simmons E<lt>nik at tiuk.ti.comE<gt>
Property changes on: trunk/contrib/perl/lib/Tie/Array.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/Tie/ExtraHash.t
===================================================================
--- trunk/contrib/perl/lib/Tie/ExtraHash.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Tie/ExtraHash.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Tie/ExtraHash.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/lib/Tie/File.pm (from rev 6437, vendor/perl/5.18.1/lib/Tie/File.pm)
===================================================================
--- trunk/contrib/perl/lib/Tie/File.pm (rev 0)
+++ trunk/contrib/perl/lib/Tie/File.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,2632 @@
+
+package Tie::File;
+require 5.005;
+use Carp ':DEFAULT', 'confess';
+use POSIX 'SEEK_SET';
+use Fcntl 'O_CREAT', 'O_RDWR', 'LOCK_EX', 'LOCK_SH', 'O_WRONLY', 'O_RDONLY';
+sub O_ACCMODE () { O_RDONLY | O_RDWR | O_WRONLY }
+
+
+$VERSION = "0.97_02";
+my $DEFAULT_MEMORY_SIZE = 1<<21; # 2 megabytes
+my $DEFAULT_AUTODEFER_THRESHHOLD = 3; # 3 records
+my $DEFAULT_AUTODEFER_FILELEN_THRESHHOLD = 65536; # 16 disk blocksful
+
+my %good_opt = map {$_ => 1, "-$_" => 1}
+ qw(memory dw_size mode recsep discipline
+ autodefer autochomp autodefer_threshhold concurrent);
+
+sub TIEARRAY {
+ if (@_ % 2 != 0) {
+ croak "usage: tie \@array, $_[0], filename, [option => value]...";
+ }
+ my ($pack, $file, %opts) = @_;
+
+ # transform '-foo' keys into 'foo' keys
+ for my $key (keys %opts) {
+ unless ($good_opt{$key}) {
+ croak("$pack: Unrecognized option '$key'\n");
+ }
+ my $okey = $key;
+ if ($key =~ s/^-+//) {
+ $opts{$key} = delete $opts{$okey};
+ }
+ }
+
+ if ($opts{concurrent}) {
+ croak("$pack: concurrent access not supported yet\n");
+ }
+
+ unless (defined $opts{memory}) {
+ # default is the larger of the default cache size and the
+ # deferred-write buffer size (if specified)
+ $opts{memory} = $DEFAULT_MEMORY_SIZE;
+ $opts{memory} = $opts{dw_size}
+ if defined $opts{dw_size} && $opts{dw_size} > $DEFAULT_MEMORY_SIZE;
+ # Dora Winifred Read
+ }
+ $opts{dw_size} = $opts{memory} unless defined $opts{dw_size};
+ if ($opts{dw_size} > $opts{memory}) {
+ croak("$pack: dw_size may not be larger than total memory allocation\n");
+ }
+ # are we in deferred-write mode?
+ $opts{defer} = 0 unless defined $opts{defer};
+ $opts{deferred} = {}; # no records are presently deferred
+ $opts{deferred_s} = 0; # count of total bytes in ->{deferred}
+ $opts{deferred_max} = -1; # empty
+
+ # What's a good way to arrange that this class can be overridden?
+ $opts{cache} = Tie::File::Cache->new($opts{memory});
+
+ # autodeferment is enabled by default
+ $opts{autodefer} = 1 unless defined $opts{autodefer};
+ $opts{autodeferring} = 0; # but is not initially active
+ $opts{ad_history} = [];
+ $opts{autodefer_threshhold} = $DEFAULT_AUTODEFER_THRESHHOLD
+ unless defined $opts{autodefer_threshhold};
+ $opts{autodefer_filelen_threshhold} = $DEFAULT_AUTODEFER_FILELEN_THRESHHOLD
+ unless defined $opts{autodefer_filelen_threshhold};
+
+ $opts{offsets} = [0];
+ $opts{filename} = $file;
+ unless (defined $opts{recsep}) {
+ $opts{recsep} = _default_recsep();
+ }
+ $opts{recseplen} = length($opts{recsep});
+ if ($opts{recseplen} == 0) {
+ croak "Empty record separator not supported by $pack";
+ }
+
+ $opts{autochomp} = 1 unless defined $opts{autochomp};
+
+ $opts{mode} = O_CREAT|O_RDWR unless defined $opts{mode};
+ $opts{rdonly} = (($opts{mode} & O_ACCMODE) == O_RDONLY);
+ $opts{sawlastrec} = undef;
+
+ my $fh;
+
+ if (UNIVERSAL::isa($file, 'GLOB')) {
+ # We use 1 here on the theory that some systems
+ # may not indicate failure if we use 0.
+ # MSWin32 does not indicate failure with 0, but I don't know if
+ # it will indicate failure with 1 or not.
+ unless (seek $file, 1, SEEK_SET) {
+ croak "$pack: your filehandle does not appear to be seekable";
+ }
+ seek $file, 0, SEEK_SET; # put it back
+ $fh = $file; # setting binmode is the user's problem
+ } elsif (ref $file) {
+ croak "usage: tie \@array, $pack, filename, [option => value]...";
+ } else {
+ # $fh = \do { local *FH }; # XXX this is buggy
+ if ($] < 5.006) {
+ # perl 5.005 and earlier don't autovivify filehandles
+ require Symbol;
+ $fh = Symbol::gensym();
+ }
+ sysopen $fh, $file, $opts{mode}, 0666 or return;
+ binmode $fh;
+ ++$opts{ourfh};
+ }
+ { my $ofh = select $fh; $| = 1; select $ofh } # autoflush on write
+ if (defined $opts{discipline} && $] >= 5.006) {
+ # This avoids a compile-time warning under 5.005
+ eval 'binmode($fh, $opts{discipline})';
+ croak $@ if $@ =~ /unknown discipline/i;
+ die if $@;
+ }
+ $opts{fh} = $fh;
+
+ bless \%opts => $pack;
+}
+
+sub FETCH {
+ my ($self, $n) = @_;
+ my $rec;
+
+ # check the defer buffer
+ $rec = $self->{deferred}{$n} if exists $self->{deferred}{$n};
+ $rec = $self->_fetch($n) unless defined $rec;
+
+ # inlined _chomp1
+ substr($rec, - $self->{recseplen}) = ""
+ if defined $rec && $self->{autochomp};
+ $rec;
+}
+
+# Chomp many records in-place; return nothing useful
+sub _chomp {
+ my $self = shift;
+ return unless $self->{autochomp};
+ if ($self->{autochomp}) {
+ for (@_) {
+ next unless defined;
+ substr($_, - $self->{recseplen}) = "";
+ }
+ }
+}
+
+# Chomp one record in-place; return modified record
+sub _chomp1 {
+ my ($self, $rec) = @_;
+ return $rec unless $self->{autochomp};
+ return unless defined $rec;
+ substr($rec, - $self->{recseplen}) = "";
+ $rec;
+}
+
+sub _fetch {
+ my ($self, $n) = @_;
+
+ # check the record cache
+ { my $cached = $self->{cache}->lookup($n);
+ return $cached if defined $cached;
+ }
+
+ if ($#{$self->{offsets}} < $n) {
+ return if $self->{eof}; # request for record beyond end of file
+ my $o = $self->_fill_offsets_to($n);
+ # If it's still undefined, there is no such record, so return 'undef'
+ return unless defined $o;
+ }
+
+ my $fh = $self->{FH};
+ $self->_seek($n); # we can do this now that offsets is populated
+ my $rec = $self->_read_record;
+
+# If we happen to have just read the first record, check to see if
+# the length of the record matches what 'tell' says. If not, Tie::File
+# won't work, and should drop dead.
+#
+# if ($n == 0 && defined($rec) && tell($self->{fh}) != length($rec)) {
+# if (defined $self->{discipline}) {
+# croak "I/O discipline $self->{discipline} not supported";
+# } else {
+# croak "File encoding not supported";
+# }
+# }
+
+ $self->{cache}->insert($n, $rec) if defined $rec && not $self->{flushing};
+ $rec;
+}
+
+sub STORE {
+ my ($self, $n, $rec) = @_;
+ die "STORE called from _check_integrity!" if $DIAGNOSTIC;
+
+ $self->_fixrecs($rec);
+
+ if ($self->{autodefer}) {
+ $self->_annotate_ad_history($n);
+ }
+
+ return $self->_store_deferred($n, $rec) if $self->_is_deferring;
+
+
+ # We need this to decide whether the new record will fit
+ # It incidentally populates the offsets table
+ # Note we have to do this before we alter the cache
+ # 20020324 Wait, but this DOES alter the cache. TODO BUG?
+ my $oldrec = $self->_fetch($n);
+
+ if (not defined $oldrec) {
+ # We're storing a record beyond the end of the file
+ $self->_extend_file_to($n+1);
+ $oldrec = $self->{recsep};
+ }
+# return if $oldrec eq $rec; # don't bother
+ my $len_diff = length($rec) - length($oldrec);
+
+ # length($oldrec) here is not consistent with text mode TODO XXX BUG
+ $self->_mtwrite($rec, $self->{offsets}[$n], length($oldrec));
+ $self->_oadjust([$n, 1, $rec]);
+ $self->{cache}->update($n, $rec);
+}
+
+sub _store_deferred {
+ my ($self, $n, $rec) = @_;
+ $self->{cache}->remove($n);
+ my $old_deferred = $self->{deferred}{$n};
+
+ if (defined $self->{deferred_max} && $n > $self->{deferred_max}) {
+ $self->{deferred_max} = $n;
+ }
+ $self->{deferred}{$n} = $rec;
+
+ my $len_diff = length($rec);
+ $len_diff -= length($old_deferred) if defined $old_deferred;
+ $self->{deferred_s} += $len_diff;
+ $self->{cache}->adj_limit(-$len_diff);
+ if ($self->{deferred_s} > $self->{dw_size}) {
+ $self->_flush;
+ } elsif ($self->_cache_too_full) {
+ $self->_cache_flush;
+ }
+}
+
+# Remove a single record from the deferred-write buffer without writing it
+# The record need not be present
+sub _delete_deferred {
+ my ($self, $n) = @_;
+ my $rec = delete $self->{deferred}{$n};
+ return unless defined $rec;
+
+ if (defined $self->{deferred_max}
+ && $n == $self->{deferred_max}) {
+ undef $self->{deferred_max};
+ }
+
+ $self->{deferred_s} -= length $rec;
+ $self->{cache}->adj_limit(length $rec);
+}
+
+sub FETCHSIZE {
+ my $self = shift;
+ my $n = $self->{eof} ? $#{$self->{offsets}} : $self->_fill_offsets;
+
+ my $top_deferred = $self->_defer_max;
+ $n = $top_deferred+1 if defined $top_deferred && $n < $top_deferred+1;
+ $n;
+}
+
+sub STORESIZE {
+ my ($self, $len) = @_;
+
+ if ($self->{autodefer}) {
+ $self->_annotate_ad_history('STORESIZE');
+ }
+
+ my $olen = $self->FETCHSIZE;
+ return if $len == $olen; # Woo-hoo!
+
+ # file gets longer
+ if ($len > $olen) {
+ if ($self->_is_deferring) {
+ for ($olen .. $len-1) {
+ $self->_store_deferred($_, $self->{recsep});
+ }
+ } else {
+ $self->_extend_file_to($len);
+ }
+ return;
+ }
+
+ # file gets shorter
+ if ($self->_is_deferring) {
+ # TODO maybe replace this with map-plus-assignment?
+ for (grep $_ >= $len, keys %{$self->{deferred}}) {
+ $self->_delete_deferred($_);
+ }
+ $self->{deferred_max} = $len-1;
+ }
+
+ $self->_seek($len);
+ $self->_chop_file;
+ $#{$self->{offsets}} = $len;
+# $self->{offsets}[0] = 0; # in case we just chopped this
+
+ $self->{cache}->remove(grep $_ >= $len, $self->{cache}->ckeys);
+}
+
+### OPTIMIZE ME
+### It should not be necessary to do FETCHSIZE
+### Just seek to the end of the file.
+sub PUSH {
+ my $self = shift;
+ $self->SPLICE($self->FETCHSIZE, scalar(@_), @_);
+
+ # No need to return:
+ # $self->FETCHSIZE; # because av.c takes care of this for me
+}
+
+sub POP {
+ my $self = shift;
+ my $size = $self->FETCHSIZE;
+ return if $size == 0;
+# print STDERR "# POPPITY POP POP POP\n";
+ scalar $self->SPLICE($size-1, 1);
+}
+
+sub SHIFT {
+ my $self = shift;
+ scalar $self->SPLICE(0, 1);
+}
+
+sub UNSHIFT {
+ my $self = shift;
+ $self->SPLICE(0, 0, @_);
+ # $self->FETCHSIZE; # av.c takes care of this for me
+}
+
+sub CLEAR {
+ my $self = shift;
+
+ if ($self->{autodefer}) {
+ $self->_annotate_ad_history('CLEAR');
+ }
+
+ $self->_seekb(0);
+ $self->_chop_file;
+ $self->{cache}->set_limit($self->{memory});
+ $self->{cache}->empty;
+ @{$self->{offsets}} = (0);
+ %{$self->{deferred}}= ();
+ $self->{deferred_s} = 0;
+ $self->{deferred_max} = -1;
+}
+
+sub EXTEND {
+ my ($self, $n) = @_;
+
+ # No need to pre-extend anything in this case
+ return if $self->_is_deferring;
+
+ $self->_fill_offsets_to($n);
+ $self->_extend_file_to($n);
+}
+
+sub DELETE {
+ my ($self, $n) = @_;
+
+ if ($self->{autodefer}) {
+ $self->_annotate_ad_history('DELETE');
+ }
+
+ my $lastrec = $self->FETCHSIZE-1;
+ my $rec = $self->FETCH($n);
+ $self->_delete_deferred($n) if $self->_is_deferring;
+ if ($n == $lastrec) {
+ $self->_seek($n);
+ $self->_chop_file;
+ $#{$self->{offsets}}--;
+ $self->{cache}->remove($n);
+ # perhaps in this case I should also remove trailing null records?
+ # 20020316
+ # Note that delete @a[-3..-1] deletes the records in the wrong order,
+ # so we only chop the very last one out of the file. We could repair this
+ # by tracking deleted records inside the object.
+ } elsif ($n < $lastrec) {
+ $self->STORE($n, "");
+ }
+ $rec;
+}
+
+sub EXISTS {
+ my ($self, $n) = @_;
+ return 1 if exists $self->{deferred}{$n};
+ $n < $self->FETCHSIZE;
+}
+
+sub SPLICE {
+ my $self = shift;
+
+ if ($self->{autodefer}) {
+ $self->_annotate_ad_history('SPLICE');
+ }
+
+ $self->_flush if $self->_is_deferring; # move this up?
+ if (wantarray) {
+ $self->_chomp(my @a = $self->_splice(@_));
+ @a;
+ } else {
+ $self->_chomp1(scalar $self->_splice(@_));
+ }
+}
+
+sub DESTROY {
+ my $self = shift;
+ $self->flush if $self->_is_deferring;
+ $self->{cache}->delink if defined $self->{cache}; # break circular link
+ if ($self->{fh} and $self->{ourfh}) {
+ delete $self->{ourfh};
+ close delete $self->{fh};
+ }
+}
+
+sub _splice {
+ my ($self, $pos, $nrecs, @data) = @_;
+ my @result;
+
+ $pos = 0 unless defined $pos;
+
+ # Deal with negative and other out-of-range positions
+ # Also set default for $nrecs
+ {
+ my $oldsize = $self->FETCHSIZE;
+ $nrecs = $oldsize unless defined $nrecs;
+ my $oldpos = $pos;
+
+ if ($pos < 0) {
+ $pos += $oldsize;
+ if ($pos < 0) {
+ croak "Modification of non-creatable array value attempted, subscript $oldpos";
+ }
+ }
+
+ if ($pos > $oldsize) {
+ return unless @data;
+ $pos = $oldsize; # This is what perl does for normal arrays
+ }
+
+ # The manual is very unclear here
+ if ($nrecs < 0) {
+ $nrecs = $oldsize - $pos + $nrecs;
+ $nrecs = 0 if $nrecs < 0;
+ }
+
+ # nrecs is too big---it really means "until the end"
+ # 20030507
+ if ($nrecs + $pos > $oldsize) {
+ $nrecs = $oldsize - $pos;
+ }
+ }
+
+ $self->_fixrecs(@data);
+ my $data = join '', @data;
+ my $datalen = length $data;
+ my $oldlen = 0;
+
+ # compute length of data being removed
+ for ($pos .. $pos+$nrecs-1) {
+ last unless defined $self->_fill_offsets_to($_);
+ my $rec = $self->_fetch($_);
+ last unless defined $rec;
+ push @result, $rec;
+
+ # Why don't we just use length($rec) here?
+ # Because that record might have come from the cache. _splice
+ # might have been called to flush out the deferred-write records,
+ # and in this case length($rec) is the length of the record to be
+ # *written*, not the length of the actual record in the file. But
+ # the offsets are still true. 20020322
+ $oldlen += $self->{offsets}[$_+1] - $self->{offsets}[$_]
+ if defined $self->{offsets}[$_+1];
+ }
+ $self->_fill_offsets_to($pos+$nrecs);
+
+ # Modify the file
+ $self->_mtwrite($data, $self->{offsets}[$pos], $oldlen);
+ # Adjust the offsets table
+ $self->_oadjust([$pos, $nrecs, @data]);
+
+ { # Take this read cache stuff out into a separate function
+ # You made a half-attempt to put it into _oadjust.
+ # Finish something like that up eventually.
+ # STORE also needs to do something similarish
+
+ # update the read cache, part 1
+ # modified records
+ for ($pos .. $pos+$nrecs-1) {
+ my $new = $data[$_-$pos];
+ if (defined $new) {
+ $self->{cache}->update($_, $new);
+ } else {
+ $self->{cache}->remove($_);
+ }
+ }
+
+ # update the read cache, part 2
+ # moved records - records past the site of the change
+ # need to be renumbered
+ # Maybe merge this with the previous block?
+ {
+ my @oldkeys = grep $_ >= $pos + $nrecs, $self->{cache}->ckeys;
+ my @newkeys = map $_-$nrecs+ at data, @oldkeys;
+ $self->{cache}->rekey(\@oldkeys, \@newkeys);
+ }
+
+ # Now there might be too much data in the cache, if we spliced out
+ # some short records and spliced in some long ones. If so, flush
+ # the cache.
+ $self->_cache_flush;
+ }
+
+ # Yes, the return value of 'splice' *is* actually this complicated
+ wantarray ? @result : @result ? $result[-1] : undef;
+}
+
+
+# write data into the file
+# $data is the data to be written.
+# it should be written at position $pos, and should overwrite
+# exactly $len of the following bytes.
+# Note that if length($data) > $len, the subsequent bytes will have to
+# be moved up, and if length($data) < $len, they will have to
+# be moved down
+sub _twrite {
+ my ($self, $data, $pos, $len) = @_;
+
+ unless (defined $pos) {
+ die "\$pos was undefined in _twrite";
+ }
+
+ my $len_diff = length($data) - $len;
+
+ if ($len_diff == 0) { # Woo-hoo!
+ my $fh = $self->{fh};
+ $self->_seekb($pos);
+ $self->_write_record($data);
+ return; # well, that was easy.
+ }
+
+ # the two records are of different lengths
+ # our strategy here: rewrite the tail of the file,
+ # reading ahead one buffer at a time
+ # $bufsize is required to be at least as large as the data we're overwriting
+ my $bufsize = _bufsize($len_diff);
+ my ($writepos, $readpos) = ($pos, $pos+$len);
+ my $next_block;
+ my $more_data;
+
+ # Seems like there ought to be a way to avoid the repeated code
+ # and the special case here. The read(1) is also a little weird.
+ # Think about this.
+ do {
+ $self->_seekb($readpos);
+ my $br = read $self->{fh}, $next_block, $bufsize;
+ $more_data = read $self->{fh}, my($dummy), 1;
+ $self->_seekb($writepos);
+ $self->_write_record($data);
+ $readpos += $br;
+ $writepos += length $data;
+ $data = $next_block;
+ } while $more_data;
+ $self->_seekb($writepos);
+ $self->_write_record($next_block);
+
+ # There might be leftover data at the end of the file
+ $self->_chop_file if $len_diff < 0;
+}
+
+# _iwrite(D, S, E)
+# Insert text D at position S.
+# Let C = E-S-|D|. If C < 0; die.
+# Data in [S,S+C) is copied to [S+D,S+D+C) = [S+D,E).
+# Data in [S+C = E-D, E) is returned. Data in [E, oo) is untouched.
+#
+# In a later version, don't read the entire intervening area into
+# memory at once; do the copying block by block.
+sub _iwrite {
+ my $self = shift;
+ my ($D, $s, $e) = @_;
+ my $d = length $D;
+ my $c = $e-$s-$d;
+ local *FH = $self->{fh};
+ confess "Not enough space to insert $d bytes between $s and $e"
+ if $c < 0;
+ confess "[$s,$e) is an invalid insertion range" if $e < $s;
+
+ $self->_seekb($s);
+ read FH, my $buf, $e-$s;
+
+ $D .= substr($buf, 0, $c, "");
+
+ $self->_seekb($s);
+ $self->_write_record($D);
+
+ return $buf;
+}
+
+# Like _twrite, but the data-pos-len triple may be repeated; you may
+# write several chunks. All the writing will be done in
+# one pass. Chunks SHALL be in ascending order and SHALL NOT overlap.
+sub _mtwrite {
+ my $self = shift;
+ my $unwritten = "";
+ my $delta = 0;
+
+ @_ % 3 == 0
+ or die "Arguments to _mtwrite did not come in groups of three";
+
+ while (@_) {
+ my ($data, $pos, $len) = splice @_, 0, 3;
+ my $end = $pos + $len; # The OLD end of the segment to be replaced
+ $data = $unwritten . $data;
+ $delta -= length($unwritten);
+ $unwritten = "";
+ $pos += $delta; # This is where the data goes now
+ my $dlen = length $data;
+ $self->_seekb($pos);
+ if ($len >= $dlen) { # the data will fit
+ $self->_write_record($data);
+ $delta += ($dlen - $len); # everything following moves down by this much
+ $data = ""; # All the data in the buffer has been written
+ } else { # won't fit
+ my $writable = substr($data, 0, $len - $delta, "");
+ $self->_write_record($writable);
+ $delta += ($dlen - $len); # everything following moves down by this much
+ }
+
+ # At this point we've written some but maybe not all of the data.
+ # There might be a gap to close up, or $data might still contain a
+ # bunch of unwritten data that didn't fit.
+ my $ndlen = length $data;
+ if ($delta == 0) {
+ $self->_write_record($data);
+ } elsif ($delta < 0) {
+ # upcopy (close up gap)
+ if (@_) {
+ $self->_upcopy($end, $end + $delta, $_[1] - $end);
+ } else {
+ $self->_upcopy($end, $end + $delta);
+ }
+ } else {
+ # downcopy (insert data that didn't fit; replace this data in memory
+ # with _later_ data that doesn't fit)
+ if (@_) {
+ $unwritten = $self->_downcopy($data, $end, $_[1] - $end);
+ } else {
+ # Make the file longer to accommodate the last segment that doesn'
+ $unwritten = $self->_downcopy($data, $end);
+ }
+ }
+ }
+}
+
+# Copy block of data of length $len from position $spos to position $dpos
+# $dpos must be <= $spos
+#
+# If $len is undefined, go all the way to the end of the file
+# and then truncate it ($spos - $dpos bytes will be removed)
+sub _upcopy {
+ my $blocksize = 8192;
+ my ($self, $spos, $dpos, $len) = @_;
+ if ($dpos > $spos) {
+ die "source ($spos) was upstream of destination ($dpos) in _upcopy";
+ } elsif ($dpos == $spos) {
+ return;
+ }
+
+ while (! defined ($len) || $len > 0) {
+ my $readsize = ! defined($len) ? $blocksize
+ : $len > $blocksize ? $blocksize
+ : $len;
+
+ my $fh = $self->{fh};
+ $self->_seekb($spos);
+ my $bytes_read = read $fh, my($data), $readsize;
+ $self->_seekb($dpos);
+ if ($data eq "") {
+ $self->_chop_file;
+ last;
+ }
+ $self->_write_record($data);
+ $spos += $bytes_read;
+ $dpos += $bytes_read;
+ $len -= $bytes_read if defined $len;
+ }
+}
+
+# Write $data into a block of length $len at position $pos,
+# moving everything in the block forwards to make room.
+# Instead of writing the last length($data) bytes from the block
+# (because there isn't room for them any longer) return them.
+#
+# Undefined $len means 'until the end of the file'
+sub _downcopy {
+ my $blocksize = 8192;
+ my ($self, $data, $pos, $len) = @_;
+ my $fh = $self->{fh};
+
+ while (! defined $len || $len > 0) {
+ my $readsize = ! defined($len) ? $blocksize
+ : $len > $blocksize? $blocksize : $len;
+ $self->_seekb($pos);
+ read $fh, my($old), $readsize;
+ my $last_read_was_short = length($old) < $readsize;
+ $data .= $old;
+ my $writable;
+ if ($last_read_was_short) {
+ # If last read was short, then $data now contains the entire rest
+ # of the file, so there's no need to write only one block of it
+ $writable = $data;
+ $data = "";
+ } else {
+ $writable = substr($data, 0, $readsize, "");
+ }
+ last if $writable eq "";
+ $self->_seekb($pos);
+ $self->_write_record($writable);
+ last if $last_read_was_short && $data eq "";
+ $len -= $readsize if defined $len;
+ $pos += $readsize;
+ }
+ return $data;
+}
+
+# Adjust the object data structures following an '_mtwrite'
+# Arguments are
+# [$pos, $nrecs, @length] items
+# indicating that $nrecs records were removed at $recpos (a record offset)
+# and replaced with records of length @length...
+# Arguments guarantee that $recpos is strictly increasing.
+# No return value
+sub _oadjust {
+ my $self = shift;
+ my $delta = 0;
+ my $delta_recs = 0;
+ my $prev_end = -1;
+ my %newkeys;
+
+ for (@_) {
+ my ($pos, $nrecs, @data) = @$_;
+ $pos += $delta_recs;
+
+ # Adjust the offsets of the records after the previous batch up
+ # to the first new one of this batch
+ for my $i ($prev_end+2 .. $pos - 1) {
+ $self->{offsets}[$i] += $delta;
+ $newkey{$i} = $i + $delta_recs;
+ }
+
+ $prev_end = $pos + @data - 1; # last record moved on this pass
+
+ # Remove the offsets for the removed records;
+ # replace with the offsets for the inserted records
+ my @newoff = ($self->{offsets}[$pos] + $delta);
+ for my $i (0 .. $#data) {
+ my $newlen = length $data[$i];
+ push @newoff, $newoff[$i] + $newlen;
+ $delta += $newlen;
+ }
+
+ for my $i ($pos .. $pos+$nrecs-1) {
+ last if $i+1 > $#{$self->{offsets}};
+ my $oldlen = $self->{offsets}[$i+1] - $self->{offsets}[$i];
+ $delta -= $oldlen;
+ }
+
+# # also this data has changed, so update it in the cache
+# for (0 .. $#data) {
+# $self->{cache}->update($pos + $_, $data[$_]);
+# }
+# if ($delta_recs) {
+# my @oldkeys = grep $_ >= $pos + @data, $self->{cache}->ckeys;
+# my @newkeys = map $_ + $delta_recs, @oldkeys;
+# $self->{cache}->rekey(\@oldkeys, \@newkeys);
+# }
+
+ # replace old offsets with new
+ splice @{$self->{offsets}}, $pos, $nrecs+1, @newoff;
+ # What if we just spliced out the end of the offsets table?
+ # shouldn't we clear $self->{eof}? Test for this XXX BUG TODO
+
+ $delta_recs += @data - $nrecs; # net change in total number of records
+ }
+
+ # The trailing records at the very end of the file
+ if ($delta) {
+ for my $i ($prev_end+2 .. $#{$self->{offsets}}) {
+ $self->{offsets}[$i] += $delta;
+ }
+ }
+
+ # If we scrubbed out all known offsets, regenerate the trivial table
+ # that knows that the file does indeed start at 0.
+ $self->{offsets}[0] = 0 unless @{$self->{offsets}};
+ # If the file got longer, the offsets table is no longer complete
+ # $self->{eof} = 0 if $delta_recs > 0;
+
+ # Now there might be too much data in the cache, if we spliced out
+ # some short records and spliced in some long ones. If so, flush
+ # the cache.
+ $self->_cache_flush;
+}
+
+# If a record does not already end with the appropriate terminator
+# string, append one.
+sub _fixrecs {
+ my $self = shift;
+ for (@_) {
+ $_ = "" unless defined $_;
+ $_ .= $self->{recsep}
+ unless substr($_, - $self->{recseplen}) eq $self->{recsep};
+ }
+}
+
+
+################################################################
+#
+# Basic read, write, and seek
+#
+
+# seek to the beginning of record #$n
+# Assumes that the offsets table is already correctly populated
+#
+# Note that $n=-1 has a special meaning here: It means the start of
+# the last known record; this may or may not be the very last record
+# in the file, depending on whether the offsets table is fully populated.
+#
+sub _seek {
+ my ($self, $n) = @_;
+ my $o = $self->{offsets}[$n];
+ defined($o)
+ or confess("logic error: undefined offset for record $n");
+ seek $self->{fh}, $o, SEEK_SET
+ or confess "Couldn't seek filehandle: $!"; # "Should never happen."
+}
+
+# seek to byte $b in the file
+sub _seekb {
+ my ($self, $b) = @_;
+ seek $self->{fh}, $b, SEEK_SET
+ or die "Couldn't seek filehandle: $!"; # "Should never happen."
+}
+
+# populate the offsets table up to the beginning of record $n
+# return the offset of record $n
+sub _fill_offsets_to {
+ my ($self, $n) = @_;
+
+ return $self->{offsets}[$n] if $self->{eof};
+
+ my $fh = $self->{fh};
+ local *OFF = $self->{offsets};
+ my $rec;
+
+ until ($#OFF >= $n) {
+ $self->_seek(-1); # tricky -- see comment at _seek
+ $rec = $self->_read_record;
+ if (defined $rec) {
+ push @OFF, int(tell $fh); # Tels says that int() saves memory here
+ } else {
+ $self->{eof} = 1;
+ return; # It turns out there is no such record
+ }
+ }
+
+ # we have now read all the records up to record n-1,
+ # so we can return the offset of record n
+ $OFF[$n];
+}
+
+sub _fill_offsets {
+ my ($self) = @_;
+
+ my $fh = $self->{fh};
+ local *OFF = $self->{offsets};
+
+ $self->_seek(-1); # tricky -- see comment at _seek
+
+ # Tels says that inlining read_record() would make this loop
+ # five times faster. 20030508
+ while ( defined $self->_read_record()) {
+ # int() saves us memory here
+ push @OFF, int(tell $fh);
+ }
+
+ $self->{eof} = 1;
+ $#OFF;
+}
+
+# assumes that $rec is already suitably terminated
+sub _write_record {
+ my ($self, $rec) = @_;
+ my $fh = $self->{fh};
+ local $\ = "";
+ print $fh $rec
+ or die "Couldn't write record: $!"; # "Should never happen."
+# $self->{_written} += length($rec);
+}
+
+sub _read_record {
+ my $self = shift;
+ my $rec;
+ { local $/ = $self->{recsep};
+ my $fh = $self->{fh};
+ $rec = <$fh>;
+ }
+ return unless defined $rec;
+ if (substr($rec, -$self->{recseplen}) ne $self->{recsep}) {
+ # improperly terminated final record --- quietly fix it.
+# my $ac = substr($rec, -$self->{recseplen});
+# $ac =~ s/\n/\\n/g;
+ $self->{sawlastrec} = 1;
+ unless ($self->{rdonly}) {
+ local $\ = "";
+ my $fh = $self->{fh};
+ print $fh $self->{recsep};
+ }
+ $rec .= $self->{recsep};
+ }
+# $self->{_read} += length($rec) if defined $rec;
+ $rec;
+}
+
+sub _rw_stats {
+ my $self = shift;
+ @{$self}{'_read', '_written'};
+}
+
+################################################################
+#
+# Read cache management
+
+sub _cache_flush {
+ my ($self) = @_;
+ $self->{cache}->reduce_size_to($self->{memory} - $self->{deferred_s});
+}
+
+sub _cache_too_full {
+ my $self = shift;
+ $self->{cache}->bytes + $self->{deferred_s} >= $self->{memory};
+}
+
+################################################################
+#
+# File custodial services
+#
+
+
+# We have read to the end of the file and have the offsets table
+# entirely populated. Now we need to write a new record beyond
+# the end of the file. We prepare for this by writing
+# empty records into the file up to the position we want
+#
+# assumes that the offsets table already contains the offset of record $n,
+# if it exists, and extends to the end of the file if not.
+sub _extend_file_to {
+ my ($self, $n) = @_;
+ $self->_seek(-1); # position after the end of the last record
+ my $pos = $self->{offsets}[-1];
+
+ # the offsets table has one entry more than the total number of records
+ my $extras = $n - $#{$self->{offsets}};
+
+ # Todo : just use $self->{recsep} x $extras here?
+ while ($extras-- > 0) {
+ $self->_write_record($self->{recsep});
+ push @{$self->{offsets}}, int(tell $self->{fh});
+ }
+}
+
+# Truncate the file at the current position
+sub _chop_file {
+ my $self = shift;
+ truncate $self->{fh}, tell($self->{fh});
+}
+
+
+# compute the size of a buffer suitable for moving
+# all the data in a file forward $n bytes
+# ($n may be negative)
+# The result should be at least $n.
+sub _bufsize {
+ my $n = shift;
+ return 8192 if $n <= 0;
+ my $b = $n & ~8191;
+ $b += 8192 if $n & 8191;
+ $b;
+}
+
+################################################################
+#
+# Miscellaneous public methods
+#
+
+# Lock the file
+sub flock {
+ my ($self, $op) = @_;
+ unless (@_ <= 3) {
+ my $pack = ref $self;
+ croak "Usage: $pack\->flock([OPERATION])";
+ }
+ my $fh = $self->{fh};
+ $op = LOCK_EX unless defined $op;
+ my $locked = flock $fh, $op;
+
+ if ($locked && ($op & (LOCK_EX | LOCK_SH))) {
+ # If you're locking the file, then presumably it's because
+ # there might have been a write access by another process.
+ # In that case, the read cache contents and the offsets table
+ # might be invalid, so discard them. 20030508
+ $self->{offsets} = [0];
+ $self->{cache}->empty;
+ }
+
+ $locked;
+}
+
+# Get/set autochomp option
+sub autochomp {
+ my $self = shift;
+ if (@_) {
+ my $old = $self->{autochomp};
+ $self->{autochomp} = shift;
+ $old;
+ } else {
+ $self->{autochomp};
+ }
+}
+
+# Get offset table entries; returns offset of nth record
+sub offset {
+ my ($self, $n) = @_;
+
+ if ($#{$self->{offsets}} < $n) {
+ return if $self->{eof}; # request for record beyond the end of file
+ my $o = $self->_fill_offsets_to($n);
+ # If it's still undefined, there is no such record, so return 'undef'
+ return unless defined $o;
+ }
+
+ $self->{offsets}[$n];
+}
+
+sub discard_offsets {
+ my $self = shift;
+ $self->{offsets} = [0];
+}
+
+################################################################
+#
+# Matters related to deferred writing
+#
+
+# Defer writes
+sub defer {
+ my $self = shift;
+ $self->_stop_autodeferring;
+ @{$self->{ad_history}} = ();
+ $self->{defer} = 1;
+}
+
+# Flush deferred writes
+#
+# This could be better optimized to write the file in one pass, instead
+# of one pass per block of records. But that will require modifications
+# to _twrite, so I should have a good _twrite test suite first.
+sub flush {
+ my $self = shift;
+
+ $self->_flush;
+ $self->{defer} = 0;
+}
+
+sub _old_flush {
+ my $self = shift;
+ my @writable = sort {$a<=>$b} (keys %{$self->{deferred}});
+
+ while (@writable) {
+ # gather all consecutive records from the front of @writable
+ my $first_rec = shift @writable;
+ my $last_rec = $first_rec+1;
+ ++$last_rec, shift @writable while @writable && $last_rec == $writable[0];
+ --$last_rec;
+ $self->_fill_offsets_to($last_rec);
+ $self->_extend_file_to($last_rec);
+ $self->_splice($first_rec, $last_rec-$first_rec+1,
+ @{$self->{deferred}}{$first_rec .. $last_rec});
+ }
+
+ $self->_discard; # clear out defered-write-cache
+}
+
+sub _flush {
+ my $self = shift;
+ my @writable = sort {$a<=>$b} (keys %{$self->{deferred}});
+ my @args;
+ my @adjust;
+
+ while (@writable) {
+ # gather all consecutive records from the front of @writable
+ my $first_rec = shift @writable;
+ my $last_rec = $first_rec+1;
+ ++$last_rec, shift @writable while @writable && $last_rec == $writable[0];
+ --$last_rec;
+ my $end = $self->_fill_offsets_to($last_rec+1);
+ if (not defined $end) {
+ $self->_extend_file_to($last_rec);
+ $end = $self->{offsets}[$last_rec];
+ }
+ my ($start) = $self->{offsets}[$first_rec];
+ push @args,
+ join("", @{$self->{deferred}}{$first_rec .. $last_rec}), # data
+ $start, # position
+ $end-$start; # length
+ push @adjust, [$first_rec, # starting at this position...
+ $last_rec-$first_rec+1, # this many records...
+ # are replaced with these...
+ @{$self->{deferred}}{$first_rec .. $last_rec},
+ ];
+ }
+
+ $self->_mtwrite(@args); # write multiple record groups
+ $self->_discard; # clear out defered-write-cache
+ $self->_oadjust(@adjust);
+}
+
+# Discard deferred writes and disable future deferred writes
+sub discard {
+ my $self = shift;
+ $self->_discard;
+ $self->{defer} = 0;
+}
+
+# Discard deferred writes, but retain old deferred writing mode
+sub _discard {
+ my $self = shift;
+ %{$self->{deferred}} = ();
+ $self->{deferred_s} = 0;
+ $self->{deferred_max} = -1;
+ $self->{cache}->set_limit($self->{memory});
+}
+
+# Deferred writing is enabled, either explicitly ($self->{defer})
+# or automatically ($self->{autodeferring})
+sub _is_deferring {
+ my $self = shift;
+ $self->{defer} || $self->{autodeferring};
+}
+
+# The largest record number of any deferred record
+sub _defer_max {
+ my $self = shift;
+ return $self->{deferred_max} if defined $self->{deferred_max};
+ my $max = -1;
+ for my $key (keys %{$self->{deferred}}) {
+ $max = $key if $key > $max;
+ }
+ $self->{deferred_max} = $max;
+ $max;
+}
+
+################################################################
+#
+# Matters related to autodeferment
+#
+
+# Get/set autodefer option
+sub autodefer {
+ my $self = shift;
+ if (@_) {
+ my $old = $self->{autodefer};
+ $self->{autodefer} = shift;
+ if ($old) {
+ $self->_stop_autodeferring;
+ @{$self->{ad_history}} = ();
+ }
+ $old;
+ } else {
+ $self->{autodefer};
+ }
+}
+
+# The user is trying to store record #$n Record that in the history,
+# and then enable (or disable) autodeferment if that seems useful.
+# Note that it's OK for $n to be a non-number, as long as the function
+# is prepared to deal with that. Nobody else looks at the ad_history.
+#
+# Now, what does the ad_history mean, and what is this function doing?
+# Essentially, the idea is to enable autodeferring when we see that the
+# user has made three consecutive STORE calls to three consecutive records.
+# ("Three" is actually ->{autodefer_threshhold}.)
+# A STORE call for record #$n inserts $n into the autodefer history,
+# and if the history contains three consecutive records, we enable
+# autodeferment. An ad_history of [X, Y] means that the most recent
+# STOREs were for records X, X+1, ..., Y, in that order.
+#
+# Inserting a nonconsecutive number erases the history and starts over.
+#
+# Performing a special operation like SPLICE erases the history.
+#
+# There's one special case: CLEAR means that CLEAR was just called.
+# In this case, we prime the history with [-2, -1] so that if the next
+# write is for record 0, autodeferring goes on immediately. This is for
+# the common special case of "@a = (...)".
+#
+sub _annotate_ad_history {
+ my ($self, $n) = @_;
+ return unless $self->{autodefer}; # feature is disabled
+ return if $self->{defer}; # already in explicit defer mode
+ return unless $self->{offsets}[-1] >= $self->{autodefer_filelen_threshhold};
+
+ local *H = $self->{ad_history};
+ if ($n eq 'CLEAR') {
+ @H = (-2, -1); # prime the history with fake records
+ $self->_stop_autodeferring;
+ } elsif ($n =~ /^\d+$/) {
+ if (@H == 0) {
+ @H = ($n, $n);
+ } else { # @H == 2
+ if ($H[1] == $n-1) { # another consecutive record
+ $H[1]++;
+ if ($H[1] - $H[0] + 1 >= $self->{autodefer_threshhold}) {
+ $self->{autodeferring} = 1;
+ }
+ } else { # nonconsecutive- erase and start over
+ @H = ($n, $n);
+ $self->_stop_autodeferring;
+ }
+ }
+ } else { # SPLICE or STORESIZE or some such
+ @H = ();
+ $self->_stop_autodeferring;
+ }
+}
+
+# If autodeferring was enabled, cut it out and discard the history
+sub _stop_autodeferring {
+ my $self = shift;
+ if ($self->{autodeferring}) {
+ $self->_flush;
+ }
+ $self->{autodeferring} = 0;
+}
+
+################################################################
+
+
+# This is NOT a method. It is here for two reasons:
+# 1. To factor a fairly complicated block out of the constructor
+# 2. To provide access for the test suite, which need to be sure
+# files are being written properly.
+sub _default_recsep {
+ my $recsep = $/;
+ if ($^O eq 'MSWin32') { # Dos too?
+ # Windows users expect files to be terminated with \r\n
+ # But $/ is set to \n instead
+ # Note that this also transforms \n\n into \r\n\r\n.
+ # That is a feature.
+ $recsep =~ s/\n/\r\n/g;
+ }
+ $recsep;
+}
+
+# Utility function for _check_integrity
+sub _ci_warn {
+ my $msg = shift;
+ $msg =~ s/\n/\\n/g;
+ $msg =~ s/\r/\\r/g;
+ print "# $msg\n";
+}
+
+# Given a file, make sure the cache is consistent with the
+# file contents and the internal data structures are consistent with
+# each other. Returns true if everything checks out, false if not
+#
+# The $file argument is no longer used. It is retained for compatibility
+# with the existing test suite.
+sub _check_integrity {
+ my ($self, $file, $warn) = @_;
+ my $rsl = $self->{recseplen};
+ my $rs = $self->{recsep};
+ my $good = 1;
+ local *_; # local $_ does not work here
+ local $DIAGNOSTIC = 1;
+
+ if (not defined $rs) {
+ _ci_warn("recsep is undef!");
+ $good = 0;
+ } elsif ($rs eq "") {
+ _ci_warn("recsep is empty!");
+ $good = 0;
+ } elsif ($rsl != length $rs) {
+ my $ln = length $rs;
+ _ci_warn("recsep <$rs> has length $ln, should be $rsl");
+ $good = 0;
+ }
+
+ if (not defined $self->{offsets}[0]) {
+ _ci_warn("offset 0 is missing!");
+ $good = 0;
+
+ } elsif ($self->{offsets}[0] != 0) {
+ _ci_warn("rec 0: offset <$self->{offsets}[0]> s/b 0!");
+ $good = 0;
+ }
+
+ my $cached = 0;
+ {
+ local *F = $self->{fh};
+ seek F, 0, SEEK_SET;
+ local $. = 0;
+ local $/ = $rs;
+
+ while (<F>) {
+ my $n = $. - 1;
+ my $cached = $self->{cache}->_produce($n);
+ my $offset = $self->{offsets}[$.];
+ my $ao = tell F;
+ if (defined $offset && $offset != $ao) {
+ _ci_warn("rec $n: offset <$offset> actual <$ao>");
+ $good = 0;
+ }
+ if (defined $cached && $_ ne $cached && ! $self->{deferred}{$n}) {
+ $good = 0;
+ _ci_warn("rec $n: cached <$cached> actual <$_>");
+ }
+ if (defined $cached && substr($cached, -$rsl) ne $rs) {
+ $good = 0;
+ _ci_warn("rec $n in the cache is missing the record separator");
+ }
+ if (! defined $offset && $self->{eof}) {
+ $good = 0;
+ _ci_warn("The offset table was marked complete, but it is missing element $.");
+ }
+ }
+ if (@{$self->{offsets}} > $.+1) {
+ $good = 0;
+ my $n = @{$self->{offsets}};
+ _ci_warn("The offset table has $n items, but the file has only $.");
+ }
+
+ my $deferring = $self->_is_deferring;
+ for my $n ($self->{cache}->ckeys) {
+ my $r = $self->{cache}->_produce($n);
+ $cached += length($r);
+ next if $n+1 <= $.; # checked this already
+ _ci_warn("spurious caching of record $n");
+ $good = 0;
+ }
+ my $b = $self->{cache}->bytes;
+ if ($cached != $b) {
+ _ci_warn("cache size is $b, should be $cached");
+ $good = 0;
+ }
+ }
+
+ # That cache has its own set of tests
+ $good = 0 unless $self->{cache}->_check_integrity;
+
+ # Now let's check the deferbuffer
+ # Unless deferred writing is enabled, it should be empty
+ if (! $self->_is_deferring && %{$self->{deferred}}) {
+ _ci_warn("deferred writing disabled, but deferbuffer nonempty");
+ $good = 0;
+ }
+
+ # Any record in the deferbuffer should *not* be present in the readcache
+ my $deferred_s = 0;
+ while (my ($n, $r) = each %{$self->{deferred}}) {
+ $deferred_s += length($r);
+ if (defined $self->{cache}->_produce($n)) {
+ _ci_warn("record $n is in the deferbuffer *and* the readcache");
+ $good = 0;
+ }
+ if (substr($r, -$rsl) ne $rs) {
+ _ci_warn("rec $n in the deferbuffer is missing the record separator");
+ $good = 0;
+ }
+ }
+
+ # Total size of deferbuffer should match internal total
+ if ($deferred_s != $self->{deferred_s}) {
+ _ci_warn("buffer size is $self->{deferred_s}, should be $deferred_s");
+ $good = 0;
+ }
+
+ # Total size of deferbuffer should not exceed the specified limit
+ if ($deferred_s > $self->{dw_size}) {
+ _ci_warn("buffer size is $self->{deferred_s} which exceeds the limit of $self->{dw_size}");
+ $good = 0;
+ }
+
+ # Total size of cached data should not exceed the specified limit
+ if ($deferred_s + $cached > $self->{memory}) {
+ my $total = $deferred_s + $cached;
+ _ci_warn("total stored data size is $total which exceeds the limit of $self->{memory}");
+ $good = 0;
+ }
+
+ # Stuff related to autodeferment
+ if (!$self->{autodefer} && @{$self->{ad_history}}) {
+ _ci_warn("autodefer is disabled, but ad_history is nonempty");
+ $good = 0;
+ }
+ if ($self->{autodeferring} && $self->{defer}) {
+ _ci_warn("both autodeferring and explicit deferring are active");
+ $good = 0;
+ }
+ if (@{$self->{ad_history}} == 0) {
+ # That's OK, no additional tests required
+ } elsif (@{$self->{ad_history}} == 2) {
+ my @non_number = grep !/^-?\d+$/, @{$self->{ad_history}};
+ if (@non_number) {
+ my $msg;
+ { local $" = ')(';
+ $msg = "ad_history contains non-numbers (@{$self->{ad_history}})";
+ }
+ _ci_warn($msg);
+ $good = 0;
+ } elsif ($self->{ad_history}[1] < $self->{ad_history}[0]) {
+ _ci_warn("ad_history has nonsensical values @{$self->{ad_history}}");
+ $good = 0;
+ }
+ } else {
+ _ci_warn("ad_history has bad length <@{$self->{ad_history}}>");
+ $good = 0;
+ }
+
+ $good;
+}
+
+################################################################
+#
+# Tie::File::Cache
+#
+# Read cache
+
+package Tie::File::Cache;
+$Tie::File::Cache::VERSION = $Tie::File::VERSION;
+use Carp ':DEFAULT', 'confess';
+
+sub HEAP () { 0 }
+sub HASH () { 1 }
+sub MAX () { 2 }
+sub BYTES() { 3 }
+#sub STAT () { 4 } # Array with request statistics for each record
+#sub MISS () { 5 } # Total number of cache misses
+#sub REQ () { 6 } # Total number of cache requests
+use strict 'vars';
+
+sub new {
+ my ($pack, $max) = @_;
+ local *_;
+ croak "missing argument to ->new" unless defined $max;
+ my $self = [];
+ bless $self => $pack;
+ @$self = (Tie::File::Heap->new($self), {}, $max, 0);
+ $self;
+}
+
+sub adj_limit {
+ my ($self, $n) = @_;
+ $self->[MAX] += $n;
+}
+
+sub set_limit {
+ my ($self, $n) = @_;
+ $self->[MAX] = $n;
+}
+
+# For internal use only
+# Will be called by the heap structure to notify us that a certain
+# piece of data has moved from one heap element to another.
+# $k is the hash key of the item
+# $n is the new index into the heap at which it is stored
+# If $n is undefined, the item has been removed from the heap.
+sub _heap_move {
+ my ($self, $k, $n) = @_;
+ if (defined $n) {
+ $self->[HASH]{$k} = $n;
+ } else {
+ delete $self->[HASH]{$k};
+ }
+}
+
+sub insert {
+ my ($self, $key, $val) = @_;
+ local *_;
+ croak "missing argument to ->insert" unless defined $key;
+ unless (defined $self->[MAX]) {
+ confess "undefined max" ;
+ }
+ confess "undefined val" unless defined $val;
+ return if length($val) > $self->[MAX];
+
+# if ($self->[STAT]) {
+# $self->[STAT][$key] = 1;
+# return;
+# }
+
+ my $oldnode = $self->[HASH]{$key};
+ if (defined $oldnode) {
+ my $oldval = $self->[HEAP]->set_val($oldnode, $val);
+ $self->[BYTES] -= length($oldval);
+ } else {
+ $self->[HEAP]->insert($key, $val);
+ }
+ $self->[BYTES] += length($val);
+ $self->flush if $self->[BYTES] > $self->[MAX];
+}
+
+sub expire {
+ my $self = shift;
+ my $old_data = $self->[HEAP]->popheap;
+ return unless defined $old_data;
+ $self->[BYTES] -= length $old_data;
+ $old_data;
+}
+
+sub remove {
+ my ($self, @keys) = @_;
+ my @result;
+
+# if ($self->[STAT]) {
+# for my $key (@keys) {
+# $self->[STAT][$key] = 0;
+# }
+# return;
+# }
+
+ for my $key (@keys) {
+ next unless exists $self->[HASH]{$key};
+ my $old_data = $self->[HEAP]->remove($self->[HASH]{$key});
+ $self->[BYTES] -= length $old_data;
+ push @result, $old_data;
+ }
+ @result;
+}
+
+sub lookup {
+ my ($self, $key) = @_;
+ local *_;
+ croak "missing argument to ->lookup" unless defined $key;
+
+# if ($self->[STAT]) {
+# $self->[MISS]++ if $self->[STAT][$key]++ == 0;
+# $self->[REQ]++;
+# my $hit_rate = 1 - $self->[MISS] / $self->[REQ];
+# # Do some testing to determine this threshhold
+# $#$self = STAT - 1 if $hit_rate > 0.20;
+# }
+
+ if (exists $self->[HASH]{$key}) {
+ $self->[HEAP]->lookup($self->[HASH]{$key});
+ } else {
+ return;
+ }
+}
+
+# For internal use only
+sub _produce {
+ my ($self, $key) = @_;
+ my $loc = $self->[HASH]{$key};
+ return unless defined $loc;
+ $self->[HEAP][$loc][2];
+}
+
+# For internal use only
+sub _promote {
+ my ($self, $key) = @_;
+ $self->[HEAP]->promote($self->[HASH]{$key});
+}
+
+sub empty {
+ my ($self) = @_;
+ %{$self->[HASH]} = ();
+ $self->[BYTES] = 0;
+ $self->[HEAP]->empty;
+# @{$self->[STAT]} = ();
+# $self->[MISS] = 0;
+# $self->[REQ] = 0;
+}
+
+sub is_empty {
+ my ($self) = @_;
+ keys %{$self->[HASH]} == 0;
+}
+
+sub update {
+ my ($self, $key, $val) = @_;
+ local *_;
+ croak "missing argument to ->update" unless defined $key;
+ if (length($val) > $self->[MAX]) {
+ my ($oldval) = $self->remove($key);
+ $self->[BYTES] -= length($oldval) if defined $oldval;
+ } elsif (exists $self->[HASH]{$key}) {
+ my $oldval = $self->[HEAP]->set_val($self->[HASH]{$key}, $val);
+ $self->[BYTES] += length($val);
+ $self->[BYTES] -= length($oldval) if defined $oldval;
+ } else {
+ $self->[HEAP]->insert($key, $val);
+ $self->[BYTES] += length($val);
+ }
+ $self->flush;
+}
+
+sub rekey {
+ my ($self, $okeys, $nkeys) = @_;
+ local *_;
+ my %map;
+ @map{@$okeys} = @$nkeys;
+ croak "missing argument to ->rekey" unless defined $nkeys;
+ croak "length mismatch in ->rekey arguments" unless @$nkeys == @$okeys;
+ my %adjusted; # map new keys to heap indices
+ # You should be able to cut this to one loop TODO XXX
+ for (0 .. $#$okeys) {
+ $adjusted{$nkeys->[$_]} = delete $self->[HASH]{$okeys->[$_]};
+ }
+ while (my ($nk, $ix) = each %adjusted) {
+ # @{$self->[HASH]}{keys %adjusted} = values %adjusted;
+ $self->[HEAP]->rekey($ix, $nk);
+ $self->[HASH]{$nk} = $ix;
+ }
+}
+
+sub ckeys {
+ my $self = shift;
+ my @a = keys %{$self->[HASH]};
+ @a;
+}
+
+# Return total amount of cached data
+sub bytes {
+ my $self = shift;
+ $self->[BYTES];
+}
+
+# Expire oldest item from cache until cache size is smaller than $max
+sub reduce_size_to {
+ my ($self, $max) = @_;
+ until ($self->[BYTES] <= $max) {
+ # Note that Tie::File::Cache::expire has been inlined here
+ my $old_data = $self->[HEAP]->popheap;
+ return unless defined $old_data;
+ $self->[BYTES] -= length $old_data;
+ }
+}
+
+# Why not just $self->reduce_size_to($self->[MAX])?
+# Try this when things stabilize TODO XXX
+# If the cache is too full, expire the oldest records
+sub flush {
+ my $self = shift;
+ $self->reduce_size_to($self->[MAX]) if $self->[BYTES] > $self->[MAX];
+}
+
+# For internal use only
+sub _produce_lru {
+ my $self = shift;
+ $self->[HEAP]->expire_order;
+}
+
+BEGIN { *_ci_warn = \&Tie::File::_ci_warn }
+
+sub _check_integrity { # For CACHE
+ my $self = shift;
+ my $good = 1;
+
+ # Test HEAP
+ $self->[HEAP]->_check_integrity or $good = 0;
+
+ # Test HASH
+ my $bytes = 0;
+ for my $k (keys %{$self->[HASH]}) {
+ if ($k ne '0' && $k !~ /^[1-9][0-9]*$/) {
+ $good = 0;
+ _ci_warn "Cache hash key <$k> is non-numeric";
+ }
+
+ my $h = $self->[HASH]{$k};
+ if (! defined $h) {
+ $good = 0;
+ _ci_warn "Heap index number for key $k is undefined";
+ } elsif ($h == 0) {
+ $good = 0;
+ _ci_warn "Heap index number for key $k is zero";
+ } else {
+ my $j = $self->[HEAP][$h];
+ if (! defined $j) {
+ $good = 0;
+ _ci_warn "Heap contents key $k (=> $h) are undefined";
+ } else {
+ $bytes += length($j->[2]);
+ if ($k ne $j->[1]) {
+ $good = 0;
+ _ci_warn "Heap contents key $k (=> $h) is $j->[1], should be $k";
+ }
+ }
+ }
+ }
+
+ # Test BYTES
+ if ($bytes != $self->[BYTES]) {
+ $good = 0;
+ _ci_warn "Total data in cache is $bytes, expected $self->[BYTES]";
+ }
+
+ # Test MAX
+ if ($bytes > $self->[MAX]) {
+ $good = 0;
+ _ci_warn "Total data in cache is $bytes, exceeds maximum $self->[MAX]";
+ }
+
+ return $good;
+}
+
+sub delink {
+ my $self = shift;
+ $self->[HEAP] = undef; # Bye bye heap
+}
+
+################################################################
+#
+# Tie::File::Heap
+#
+# Heap data structure for use by cache LRU routines
+
+package Tie::File::Heap;
+use Carp ':DEFAULT', 'confess';
+$Tie::File::Heap::VERSION = $Tie::File::Cache::VERSION;
+sub SEQ () { 0 };
+sub KEY () { 1 };
+sub DAT () { 2 };
+
+sub new {
+ my ($pack, $cache) = @_;
+ die "$pack: Parent cache object $cache does not support _heap_move method"
+ unless eval { $cache->can('_heap_move') };
+ my $self = [[0,$cache,0]];
+ bless $self => $pack;
+}
+
+# Allocate a new sequence number, larger than all previously allocated numbers
+sub _nseq {
+ my $self = shift;
+ $self->[0][0]++;
+}
+
+sub _cache {
+ my $self = shift;
+ $self->[0][1];
+}
+
+sub _nelts {
+ my $self = shift;
+ $self->[0][2];
+}
+
+sub _nelts_inc {
+ my $self = shift;
+ ++$self->[0][2];
+}
+
+sub _nelts_dec {
+ my $self = shift;
+ --$self->[0][2];
+}
+
+sub is_empty {
+ my $self = shift;
+ $self->_nelts == 0;
+}
+
+sub empty {
+ my $self = shift;
+ $#$self = 0;
+ $self->[0][2] = 0;
+ $self->[0][0] = 0; # might as well reset the sequence numbers
+}
+
+# notify the parent cache object that we moved something
+sub _heap_move {
+ my $self = shift;
+ $self->_cache->_heap_move(@_);
+}
+
+# Insert a piece of data into the heap with the indicated sequence number.
+# The item with the smallest sequence number is always at the top.
+# If no sequence number is specified, allocate a new one and insert the
+# item at the bottom.
+sub insert {
+ my ($self, $key, $data, $seq) = @_;
+ $seq = $self->_nseq unless defined $seq;
+ $self->_insert_new([$seq, $key, $data]);
+}
+
+# Insert a new, fresh item at the bottom of the heap
+sub _insert_new {
+ my ($self, $item) = @_;
+ my $i = @$self;
+ $i = int($i/2) until defined $self->[$i/2];
+ $self->[$i] = $item;
+ $self->[0][1]->_heap_move($self->[$i][KEY], $i);
+ $self->_nelts_inc;
+}
+
+# Insert [$data, $seq] pair at or below item $i in the heap.
+# If $i is omitted, default to 1 (the top element.)
+sub _insert {
+ my ($self, $item, $i) = @_;
+# $self->_check_loc($i) if defined $i;
+ $i = 1 unless defined $i;
+ until (! defined $self->[$i]) {
+ if ($self->[$i][SEQ] > $item->[SEQ]) { # inserted item is older
+ ($self->[$i], $item) = ($item, $self->[$i]);
+ $self->[0][1]->_heap_move($self->[$i][KEY], $i);
+ }
+ # If either is undefined, go that way. Otherwise, choose at random
+ my $dir;
+ $dir = 0 if !defined $self->[2*$i];
+ $dir = 1 if !defined $self->[2*$i+1];
+ $dir = int(rand(2)) unless defined $dir;
+ $i = 2*$i + $dir;
+ }
+ $self->[$i] = $item;
+ $self->[0][1]->_heap_move($self->[$i][KEY], $i);
+ $self->_nelts_inc;
+}
+
+# Remove the item at node $i from the heap, moving child items upwards.
+# The item with the smallest sequence number is always at the top.
+# Moving items upwards maintains this condition.
+# Return the removed item. Return undef if there was no item at node $i.
+sub remove {
+ my ($self, $i) = @_;
+ $i = 1 unless defined $i;
+ my $top = $self->[$i];
+ return unless defined $top;
+ while (1) {
+ my $ii;
+ my ($L, $R) = (2*$i, 2*$i+1);
+
+ # If either is undefined, go the other way.
+ # Otherwise, go towards the smallest.
+ last unless defined $self->[$L] || defined $self->[$R];
+ $ii = $R if not defined $self->[$L];
+ $ii = $L if not defined $self->[$R];
+ unless (defined $ii) {
+ $ii = $self->[$L][SEQ] < $self->[$R][SEQ] ? $L : $R;
+ }
+
+ $self->[$i] = $self->[$ii]; # Promote child to fill vacated spot
+ $self->[0][1]->_heap_move($self->[$i][KEY], $i);
+ $i = $ii; # Fill new vacated spot
+ }
+ $self->[0][1]->_heap_move($top->[KEY], undef);
+ undef $self->[$i];
+ $self->_nelts_dec;
+ return $top->[DAT];
+}
+
+sub popheap {
+ my $self = shift;
+ $self->remove(1);
+}
+
+# set the sequence number of the indicated item to a higher number
+# than any other item in the heap, and bubble the item down to the
+# bottom.
+sub promote {
+ my ($self, $n) = @_;
+# $self->_check_loc($n);
+ $self->[$n][SEQ] = $self->_nseq;
+ my $i = $n;
+ while (1) {
+ my ($L, $R) = (2*$i, 2*$i+1);
+ my $dir;
+ last unless defined $self->[$L] || defined $self->[$R];
+ $dir = $R unless defined $self->[$L];
+ $dir = $L unless defined $self->[$R];
+ unless (defined $dir) {
+ $dir = $self->[$L][SEQ] < $self->[$R][SEQ] ? $L : $R;
+ }
+ @{$self}[$i, $dir] = @{$self}[$dir, $i];
+ for ($i, $dir) {
+ $self->[0][1]->_heap_move($self->[$_][KEY], $_) if defined $self->[$_];
+ }
+ $i = $dir;
+ }
+}
+
+# Return item $n from the heap, promoting its LRU status
+sub lookup {
+ my ($self, $n) = @_;
+# $self->_check_loc($n);
+ my $val = $self->[$n];
+ $self->promote($n);
+ $val->[DAT];
+}
+
+
+# Assign a new value for node $n, promoting it to the bottom of the heap
+sub set_val {
+ my ($self, $n, $val) = @_;
+# $self->_check_loc($n);
+ my $oval = $self->[$n][DAT];
+ $self->[$n][DAT] = $val;
+ $self->promote($n);
+ return $oval;
+}
+
+# The hask key has changed for an item;
+# alter the heap's record of the hash key
+sub rekey {
+ my ($self, $n, $new_key) = @_;
+# $self->_check_loc($n);
+ $self->[$n][KEY] = $new_key;
+}
+
+sub _check_loc {
+ my ($self, $n) = @_;
+ unless (1 || defined $self->[$n]) {
+ confess "_check_loc($n) failed";
+ }
+}
+
+BEGIN { *_ci_warn = \&Tie::File::_ci_warn }
+
+sub _check_integrity {
+ my $self = shift;
+ my $good = 1;
+ my %seq;
+
+ unless (eval {$self->[0][1]->isa("Tie::File::Cache")}) {
+ _ci_warn "Element 0 of heap corrupt";
+ $good = 0;
+ }
+ $good = 0 unless $self->_satisfies_heap_condition(1);
+ for my $i (2 .. $#{$self}) {
+ my $p = int($i/2); # index of parent node
+ if (defined $self->[$i] && ! defined $self->[$p]) {
+ _ci_warn "Element $i of heap defined, but parent $p isn't";
+ $good = 0;
+ }
+
+ if (defined $self->[$i]) {
+ if ($seq{$self->[$i][SEQ]}) {
+ my $seq = $self->[$i][SEQ];
+ _ci_warn "Nodes $i and $seq{$seq} both have SEQ=$seq";
+ $good = 0;
+ } else {
+ $seq{$self->[$i][SEQ]} = $i;
+ }
+ }
+ }
+
+ return $good;
+}
+
+sub _satisfies_heap_condition {
+ my $self = shift;
+ my $n = shift || 1;
+ my $good = 1;
+ for (0, 1) {
+ my $c = $n*2 + $_;
+ next unless defined $self->[$c];
+ if ($self->[$n][SEQ] >= $self->[$c]) {
+ _ci_warn "Node $n of heap does not predate node $c";
+ $good = 0 ;
+ }
+ $good = 0 unless $self->_satisfies_heap_condition($c);
+ }
+ return $good;
+}
+
+# Return a list of all the values, sorted by expiration order
+sub expire_order {
+ my $self = shift;
+ my @nodes = sort {$a->[SEQ] <=> $b->[SEQ]} $self->_nodes;
+ map { $_->[KEY] } @nodes;
+}
+
+sub _nodes {
+ my $self = shift;
+ my $i = shift || 1;
+ return unless defined $self->[$i];
+ ($self->[$i], $self->_nodes($i*2), $self->_nodes($i*2+1));
+}
+
+"Cogito, ergo sum."; # don't forget to return a true value from the file
+
+__END__
+
+=head1 NAME
+
+Tie::File - Access the lines of a disk file via a Perl array
+
+=head1 SYNOPSIS
+
+ # This file documents Tie::File version 0.97
+ use Tie::File;
+
+ tie @array, 'Tie::File', filename or die ...;
+
+ $array[13] = 'blah'; # line 13 of the file is now 'blah'
+ print $array[42]; # display line 42 of the file
+
+ $n_recs = @array; # how many records are in the file?
+ $#array -= 2; # chop two records off the end
+
+
+ for (@array) {
+ s/PERL/Perl/g; # Replace PERL with Perl everywhere in the file
+ }
+
+ # These are just like regular push, pop, unshift, shift, and splice
+ # Except that they modify the file in the way you would expect
+
+ push @array, new recs...;
+ my $r1 = pop @array;
+ unshift @array, new recs...;
+ my $r2 = shift @array;
+ @old_recs = splice @array, 3, 7, new recs...;
+
+ untie @array; # all finished
+
+
+=head1 DESCRIPTION
+
+C<Tie::File> represents a regular text file as a Perl array. Each
+element in the array corresponds to a record in the file. The first
+line of the file is element 0 of the array; the second line is element
+1, and so on.
+
+The file is I<not> loaded into memory, so this will work even for
+gigantic files.
+
+Changes to the array are reflected in the file immediately.
+
+Lazy people and beginners may now stop reading the manual.
+
+=head2 C<recsep>
+
+What is a 'record'? By default, the meaning is the same as for the
+C<E<lt>...E<gt>> operator: It's a string terminated by C<$/>, which is
+probably C<"\n">. (Minor exception: on DOS and Win32 systems, a
+'record' is a string terminated by C<"\r\n">.) You may change the
+definition of "record" by supplying the C<recsep> option in the C<tie>
+call:
+
+ tie @array, 'Tie::File', $file, recsep => 'es';
+
+This says that records are delimited by the string C<es>. If the file
+contained the following data:
+
+ Curse these pesky flies!\n
+
+then the C<@array> would appear to have four elements:
+
+ "Curse th"
+ "e p"
+ "ky fli"
+ "!\n"
+
+An undefined value is not permitted as a record separator. Perl's
+special "paragraph mode" semantics (E<agrave> la C<$/ = "">) are not
+emulated.
+
+Records read from the tied array do not have the record separator
+string on the end; this is to allow
+
+ $array[17] .= "extra";
+
+to work as expected.
+
+(See L<"autochomp">, below.) Records stored into the array will have
+the record separator string appended before they are written to the
+file, if they don't have one already. For example, if the record
+separator string is C<"\n">, then the following two lines do exactly
+the same thing:
+
+ $array[17] = "Cherry pie";
+ $array[17] = "Cherry pie\n";
+
+The result is that the contents of line 17 of the file will be
+replaced with "Cherry pie"; a newline character will separate line 17
+from line 18. This means that this code will do nothing:
+
+ chomp $array[17];
+
+Because the C<chomp>ed value will have the separator reattached when
+it is written back to the file. There is no way to create a file
+whose trailing record separator string is missing.
+
+Inserting records that I<contain> the record separator string is not
+supported by this module. It will probably produce a reasonable
+result, but what this result will be may change in a future version.
+Use 'splice' to insert records or to replace one record with several.
+
+=head2 C<autochomp>
+
+Normally, array elements have the record separator removed, so that if
+the file contains the text
+
+ Gold
+ Frankincense
+ Myrrh
+
+the tied array will appear to contain C<("Gold", "Frankincense",
+"Myrrh")>. If you set C<autochomp> to a false value, the record
+separator will not be removed. If the file above was tied with
+
+ tie @gifts, "Tie::File", $gifts, autochomp => 0;
+
+then the array C<@gifts> would appear to contain C<("Gold\n",
+"Frankincense\n", "Myrrh\n")>, or (on Win32 systems) C<("Gold\r\n",
+"Frankincense\r\n", "Myrrh\r\n")>.
+
+=head2 C<mode>
+
+Normally, the specified file will be opened for read and write access,
+and will be created if it does not exist. (That is, the flags
+C<O_RDWR | O_CREAT> are supplied in the C<open> call.) If you want to
+change this, you may supply alternative flags in the C<mode> option.
+See L<Fcntl> for a listing of available flags.
+For example:
+
+ # open the file if it exists, but fail if it does not exist
+ use Fcntl 'O_RDWR';
+ tie @array, 'Tie::File', $file, mode => O_RDWR;
+
+ # create the file if it does not exist
+ use Fcntl 'O_RDWR', 'O_CREAT';
+ tie @array, 'Tie::File', $file, mode => O_RDWR | O_CREAT;
+
+ # open an existing file in read-only mode
+ use Fcntl 'O_RDONLY';
+ tie @array, 'Tie::File', $file, mode => O_RDONLY;
+
+Opening the data file in write-only or append mode is not supported.
+
+=head2 C<memory>
+
+This is an upper limit on the amount of memory that C<Tie::File> will
+consume at any time while managing the file. This is used for two
+things: managing the I<read cache> and managing the I<deferred write
+buffer>.
+
+Records read in from the file are cached, to avoid having to re-read
+them repeatedly. If you read the same record twice, the first time it
+will be stored in memory, and the second time it will be fetched from
+the I<read cache>. The amount of data in the read cache will not
+exceed the value you specified for C<memory>. If C<Tie::File> wants
+to cache a new record, but the read cache is full, it will make room
+by expiring the least-recently visited records from the read cache.
+
+The default memory limit is 2Mib. You can adjust the maximum read
+cache size by supplying the C<memory> option. The argument is the
+desired cache size, in bytes.
+
+ # I have a lot of memory, so use a large cache to speed up access
+ tie @array, 'Tie::File', $file, memory => 20_000_000;
+
+Setting the memory limit to 0 will inhibit caching; records will be
+fetched from disk every time you examine them.
+
+The C<memory> value is not an absolute or exact limit on the memory
+used. C<Tie::File> objects contains some structures besides the read
+cache and the deferred write buffer, whose sizes are not charged
+against C<memory>.
+
+The cache itself consumes about 310 bytes per cached record, so if
+your file has many short records, you may want to decrease the cache
+memory limit, or else the cache overhead may exceed the size of the
+cached data.
+
+
+=head2 C<dw_size>
+
+(This is an advanced feature. Skip this section on first reading.)
+
+If you use deferred writing (See L<"Deferred Writing">, below) then
+data you write into the array will not be written directly to the
+file; instead, it will be saved in the I<deferred write buffer> to be
+written out later. Data in the deferred write buffer is also charged
+against the memory limit you set with the C<memory> option.
+
+You may set the C<dw_size> option to limit the amount of data that can
+be saved in the deferred write buffer. This limit may not exceed the
+total memory limit. For example, if you set C<dw_size> to 1000 and
+C<memory> to 2500, that means that no more than 1000 bytes of deferred
+writes will be saved up. The space available for the read cache will
+vary, but it will always be at least 1500 bytes (if the deferred write
+buffer is full) and it could grow as large as 2500 bytes (if the
+deferred write buffer is empty.)
+
+If you don't specify a C<dw_size>, it defaults to the entire memory
+limit.
+
+=head2 Option Format
+
+C<-mode> is a synonym for C<mode>. C<-recsep> is a synonym for
+C<recsep>. C<-memory> is a synonym for C<memory>. You get the
+idea.
+
+=head1 Public Methods
+
+The C<tie> call returns an object, say C<$o>. You may call
+
+ $rec = $o->FETCH($n);
+ $o->STORE($n, $rec);
+
+to fetch or store the record at line C<$n>, respectively; similarly
+the other tied array methods. (See L<perltie> for details.) You may
+also call the following methods on this object:
+
+=head2 C<flock>
+
+ $o->flock(MODE)
+
+will lock the tied file. C<MODE> has the same meaning as the second
+argument to the Perl built-in C<flock> function; for example
+C<LOCK_SH> or C<LOCK_EX | LOCK_NB>. (These constants are provided by
+the C<use Fcntl ':flock'> declaration.)
+
+C<MODE> is optional; the default is C<LOCK_EX>.
+
+C<Tie::File> maintains an internal table of the byte offset of each
+record it has seen in the file.
+
+When you use C<flock> to lock the file, C<Tie::File> assumes that the
+read cache is no longer trustworthy, because another process might
+have modified the file since the last time it was read. Therefore, a
+successful call to C<flock> discards the contents of the read cache
+and the internal record offset table.
+
+C<Tie::File> promises that the following sequence of operations will
+be safe:
+
+ my $o = tie @array, "Tie::File", $filename;
+ $o->flock;
+
+In particular, C<Tie::File> will I<not> read or write the file during
+the C<tie> call. (Exception: Using C<mode =E<gt> O_TRUNC> will, of
+course, erase the file during the C<tie> call. If you want to do this
+safely, then open the file without C<O_TRUNC>, lock the file, and use
+C<@array = ()>.)
+
+The best way to unlock a file is to discard the object and untie the
+array. It is probably unsafe to unlock the file without also untying
+it, because if you do, changes may remain unwritten inside the object.
+That is why there is no shortcut for unlocking. If you really want to
+unlock the file prematurely, you know what to do; if you don't know
+what to do, then don't do it.
+
+All the usual warnings about file locking apply here. In particular,
+note that file locking in Perl is B<advisory>, which means that
+holding a lock will not prevent anyone else from reading, writing, or
+erasing the file; it only prevents them from getting another lock at
+the same time. Locks are analogous to green traffic lights: If you
+have a green light, that does not prevent the idiot coming the other
+way from plowing into you sideways; it merely guarantees to you that
+the idiot does not also have a green light at the same time.
+
+=head2 C<autochomp>
+
+ my $old_value = $o->autochomp(0); # disable autochomp option
+ my $old_value = $o->autochomp(1); # enable autochomp option
+
+ my $ac = $o->autochomp(); # recover current value
+
+See L<"autochomp">, above.
+
+=head2 C<defer>, C<flush>, C<discard>, and C<autodefer>
+
+See L<"Deferred Writing">, below.
+
+=head2 C<offset>
+
+ $off = $o->offset($n);
+
+This method returns the byte offset of the start of the C<$n>th record
+in the file. If there is no such record, it returns an undefined
+value.
+
+=head1 Tying to an already-opened filehandle
+
+If C<$fh> is a filehandle, such as is returned by C<IO::File> or one
+of the other C<IO> modules, you may use:
+
+ tie @array, 'Tie::File', $fh, ...;
+
+Similarly if you opened that handle C<FH> with regular C<open> or
+C<sysopen>, you may use:
+
+ tie @array, 'Tie::File', \*FH, ...;
+
+Handles that were opened write-only won't work. Handles that were
+opened read-only will work as long as you don't try to modify the
+array. Handles must be attached to seekable sources of data---that
+means no pipes or sockets. If C<Tie::File> can detect that you
+supplied a non-seekable handle, the C<tie> call will throw an
+exception. (On Unix systems, it can detect this.)
+
+Note that Tie::File will only close any filehandles that it opened
+internally. If you passed it a filehandle as above, you "own" the
+filehandle, and are responsible for closing it after you have untied
+the @array.
+
+=head1 Deferred Writing
+
+(This is an advanced feature. Skip this section on first reading.)
+
+Normally, modifying a C<Tie::File> array writes to the underlying file
+immediately. Every assignment like C<$a[3] = ...> rewrites as much of
+the file as is necessary; typically, everything from line 3 through
+the end will need to be rewritten. This is the simplest and most
+transparent behavior. Performance even for large files is reasonably
+good.
+
+However, under some circumstances, this behavior may be excessively
+slow. For example, suppose you have a million-record file, and you
+want to do:
+
+ for (@FILE) {
+ $_ = "> $_";
+ }
+
+The first time through the loop, you will rewrite the entire file,
+from line 0 through the end. The second time through the loop, you
+will rewrite the entire file from line 1 through the end. The third
+time through the loop, you will rewrite the entire file from line 2 to
+the end. And so on.
+
+If the performance in such cases is unacceptable, you may defer the
+actual writing, and then have it done all at once. The following loop
+will perform much better for large files:
+
+ (tied @a)->defer;
+ for (@a) {
+ $_ = "> $_";
+ }
+ (tied @a)->flush;
+
+If C<Tie::File>'s memory limit is large enough, all the writing will
+done in memory. Then, when you call C<-E<gt>flush>, the entire file
+will be rewritten in a single pass.
+
+(Actually, the preceding discussion is something of a fib. You don't
+need to enable deferred writing to get good performance for this
+common case, because C<Tie::File> will do it for you automatically
+unless you specifically tell it not to. See L<"autodeferring">,
+below.)
+
+Calling C<-E<gt>flush> returns the array to immediate-write mode. If
+you wish to discard the deferred writes, you may call C<-E<gt>discard>
+instead of C<-E<gt>flush>. Note that in some cases, some of the data
+will have been written already, and it will be too late for
+C<-E<gt>discard> to discard all the changes. Support for
+C<-E<gt>discard> may be withdrawn in a future version of C<Tie::File>.
+
+Deferred writes are cached in memory up to the limit specified by the
+C<dw_size> option (see above). If the deferred-write buffer is full
+and you try to write still more deferred data, the buffer will be
+flushed. All buffered data will be written immediately, the buffer
+will be emptied, and the now-empty space will be used for future
+deferred writes.
+
+If the deferred-write buffer isn't yet full, but the total size of the
+buffer and the read cache would exceed the C<memory> limit, the oldest
+records will be expired from the read cache until the total size is
+under the limit.
+
+C<push>, C<pop>, C<shift>, C<unshift>, and C<splice> cannot be
+deferred. When you perform one of these operations, any deferred data
+is written to the file and the operation is performed immediately.
+This may change in a future version.
+
+If you resize the array with deferred writing enabled, the file will
+be resized immediately, but deferred records will not be written.
+This has a surprising consequence: C<@a = (...)> erases the file
+immediately, but the writing of the actual data is deferred. This
+might be a bug. If it is a bug, it will be fixed in a future version.
+
+=head2 Autodeferring
+
+C<Tie::File> tries to guess when deferred writing might be helpful,
+and to turn it on and off automatically.
+
+ for (@a) {
+ $_ = "> $_";
+ }
+
+In this example, only the first two assignments will be done
+immediately; after this, all the changes to the file will be deferred
+up to the user-specified memory limit.
+
+You should usually be able to ignore this and just use the module
+without thinking about deferring. However, special applications may
+require fine control over which writes are deferred, or may require
+that all writes be immediate. To disable the autodeferment feature,
+use
+
+ (tied @o)->autodefer(0);
+
+or
+
+ tie @array, 'Tie::File', $file, autodefer => 0;
+
+
+Similarly, C<-E<gt>autodefer(1)> re-enables autodeferment, and
+C<-E<gt>autodefer()> recovers the current value of the autodefer setting.
+
+
+=head1 CONCURRENT ACCESS TO FILES
+
+Caching and deferred writing are inappropriate if you want the same
+file to be accessed simultaneously from more than one process. Other
+optimizations performed internally by this module are also
+incompatible with concurrent access. A future version of this module will
+support a C<concurrent =E<gt> 1> option that enables safe concurrent access.
+
+Previous versions of this documentation suggested using C<memory
+=E<gt> 0> for safe concurrent access. This was mistaken. Tie::File
+will not support safe concurrent access before version 0.98.
+
+=head1 CAVEATS
+
+(That's Latin for 'warnings'.)
+
+=over 4
+
+=item *
+
+Reasonable effort was made to make this module efficient. Nevertheless,
+changing the size of a record in the middle of a large file will
+always be fairly slow, because everything after the new record must be
+moved.
+
+=item *
+
+The behavior of tied arrays is not precisely the same as for regular
+arrays. For example:
+
+ # This DOES print "How unusual!"
+ undef $a[10]; print "How unusual!\n" if defined $a[10];
+
+C<undef>-ing a C<Tie::File> array element just blanks out the
+corresponding record in the file. When you read it back again, you'll
+get the empty string, so the supposedly-C<undef>'ed value will be
+defined. Similarly, if you have C<autochomp> disabled, then
+
+ # This DOES print "How unusual!" if 'autochomp' is disabled
+ undef $a[10];
+ print "How unusual!\n" if $a[10];
+
+Because when C<autochomp> is disabled, C<$a[10]> will read back as
+C<"\n"> (or whatever the record separator string is.)
+
+There are other minor differences, particularly regarding C<exists>
+and C<delete>, but in general, the correspondence is extremely close.
+
+=item *
+
+I have supposed that since this module is concerned with file I/O,
+almost all normal use of it will be heavily I/O bound. This means
+that the time to maintain complicated data structures inside the
+module will be dominated by the time to actually perform the I/O.
+When there was an opportunity to spend CPU time to avoid doing I/O, I
+usually tried to take it.
+
+=item *
+
+You might be tempted to think that deferred writing is like
+transactions, with C<flush> as C<commit> and C<discard> as
+C<rollback>, but it isn't, so don't.
+
+=item *
+
+There is a large memory overhead for each record offset and for each
+cache entry: about 310 bytes per cached data record, and about 21 bytes per offset table entry.
+
+The per-record overhead will limit the maximum number of records you
+can access per file. Note that I<accessing> the length of the array
+via C<$x = scalar @tied_file> accesses B<all> records and stores their
+offsets. The same for C<foreach (@tied_file)>, even if you exit the
+loop early.
+
+=back
+
+=head1 SUBCLASSING
+
+This version promises absolutely nothing about the internals, which
+may change without notice. A future version of the module will have a
+well-defined and stable subclassing API.
+
+=head1 WHAT ABOUT C<DB_File>?
+
+People sometimes point out that L<DB_File> will do something similar,
+and ask why C<Tie::File> module is necessary.
+
+There are a number of reasons that you might prefer C<Tie::File>.
+A list is available at C<http://perl.plover.com/TieFile/why-not-DB_File>.
+
+=head1 AUTHOR
+
+Mark Jason Dominus
+
+To contact the author, send email to: C<mjd-perl-tiefile+ at plover.com>
+
+To receive an announcement whenever a new version of this module is
+released, send a blank email message to
+C<mjd-perl-tiefile-subscribe at plover.com>.
+
+The most recent version of this module, including documentation and
+any news of importance, will be available at
+
+ http://perl.plover.com/TieFile/
+
+
+=head1 LICENSE
+
+C<Tie::File> version 0.97 is copyright (C) 2003 Mark Jason Dominus.
+
+This library is free software; you may redistribute it and/or modify
+it under the same terms as Perl itself.
+
+These terms are your choice of any of (1) the Perl Artistic Licence,
+or (2) version 2 of the GNU General Public License as published by the
+Free Software Foundation, or (3) any later version of the GNU General
+Public License.
+
+This library 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 library program; it should be in the file C<COPYING>.
+If not, write to the Free Software Foundation, Inc., 51 Franklin Street,
+Fifth Floor, Boston, MA 02110-1301, USA
+
+For licensing inquiries, contact the author at:
+
+ Mark Jason Dominus
+ 255 S. Warnock St.
+ Philadelphia, PA 19107
+
+=head1 WARRANTY
+
+C<Tie::File> version 0.97 comes with ABSOLUTELY NO WARRANTY.
+For details, see the license.
+
+=head1 THANKS
+
+Gigantic thanks to Jarkko Hietaniemi, for agreeing to put this in the
+core when I hadn't written it yet, and for generally being helpful,
+supportive, and competent. (Usually the rule is "choose any one.")
+Also big thanks to Abhijit Menon-Sen for all of the same things.
+
+Special thanks to Craig Berry and Peter Prymmer (for VMS portability
+help), Randy Kobes (for Win32 portability help), Clinton Pierce and
+Autrijus Tang (for heroic eleventh-hour Win32 testing above and beyond
+the call of duty), Michael G Schwern (for testing advice), and the
+rest of the CPAN testers (for testing generally).
+
+Special thanks to Tels for suggesting several speed and memory
+optimizations.
+
+Additional thanks to:
+Edward Avis /
+Mattia Barbon /
+Tom Christiansen /
+Gerrit Haase /
+Gurusamy Sarathy /
+Jarkko Hietaniemi (again) /
+Nikola Knezevic /
+John Kominetz /
+Nick Ing-Simmons /
+Tassilo von Parseval /
+H. Dieter Pearcey /
+Slaven Rezic /
+Eric Roode /
+Peter Scott /
+Peter Somu /
+Autrijus Tang (again) /
+Tels (again) /
+Juerd Waalboer
+
+=head1 TODO
+
+More tests. (Stuff I didn't think of yet.)
+
+Paragraph mode?
+
+Fixed-length mode. Leave-blanks mode.
+
+Maybe an autolocking mode?
+
+For many common uses of the module, the read cache is a liability.
+For example, a program that inserts a single record, or that scans the
+file once, will have a cache hit rate of zero. This suggests a major
+optimization: The cache should be initially disabled. Here's a hybrid
+approach: Initially, the cache is disabled, but the cache code
+maintains statistics about how high the hit rate would be *if* it were
+enabled. When it sees the hit rate get high enough, it enables
+itself. The STAT comments in this code are the beginning of an
+implementation of this.
+
+Record locking with fcntl()? Then the module might support an undo
+log and get real transactions. What a tour de force that would be.
+
+Keeping track of the highest cached record. This would allow reads-in-a-row
+to skip the cache lookup faster (if reading from 1..N with empty cache at
+start, the last cached value will be always N-1).
+
+More tests.
+
+=cut
+
Modified: trunk/contrib/perl/lib/Tie/Handle/stdhandle.t
===================================================================
--- trunk/contrib/perl/lib/Tie/Handle/stdhandle.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Tie/Handle/stdhandle.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -10,7 +10,7 @@
$f = 'tst';
-print "1..13\n";
+print "1..14\n";
# my $file tests
@@ -42,6 +42,10 @@
$b = <$f>;
print "not " unless eof($f);
print "ok 12\n";
+seek($f,0,0);
+read($f,($b='scrinches'),4,4); # with offset
+print "'$b' not " unless $b eq 'scriSome';
+print "ok 13\n";
print "not " unless close($f);
-print "ok 13\n";
+print "ok 14\n";
unlink("afile");
Property changes on: trunk/contrib/perl/lib/Tie/Handle/stdhandle.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/Tie/Handle/stdhandle_from_handle.t
===================================================================
--- trunk/contrib/perl/lib/Tie/Handle/stdhandle_from_handle.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Tie/Handle/stdhandle_from_handle.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Tie/Handle/stdhandle_from_handle.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/Tie/Handle.pm
===================================================================
--- trunk/contrib/perl/lib/Tie/Handle.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Tie/Handle.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Tie/Handle.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/Tie/Hash.pm
===================================================================
--- trunk/contrib/perl/lib/Tie/Hash.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Tie/Hash.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Tie/Hash.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/lib/Tie/Hash.t
===================================================================
--- trunk/contrib/perl/lib/Tie/Hash.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Tie/Hash.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Tie/Hash.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/lib/Tie/Memoize.pm (from rev 6437, vendor/perl/5.18.1/lib/Tie/Memoize.pm)
===================================================================
--- trunk/contrib/perl/lib/Tie/Memoize.pm (rev 0)
+++ trunk/contrib/perl/lib/Tie/Memoize.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,128 @@
+use strict;
+package Tie::Memoize;
+use Tie::Hash;
+our @ISA = 'Tie::ExtraHash';
+our $VERSION = '1.1';
+
+our $exists_token = \undef;
+
+sub croak {require Carp; goto &Carp::croak}
+
+# Format: [0: STORAGE, 1: EXISTS-CACHE, 2: FETCH_function;
+# 3: EXISTS_function, 4: DATA, 5: EXISTS_different ]
+
+sub FETCH {
+ my ($h,$key) = ($_[0][0], $_[1]);
+ my $res = $h->{$key};
+ return $res if defined $res; # Shortcut if accessible
+ return $res if exists $h->{$key}; # Accessible, but undef
+ my $cache = $_[0][1]{$key};
+ return if defined $cache and not $cache; # Known to not exist
+ my @res = $_[0][2]->($key, $_[0][4]); # Autoload
+ $_[0][1]{$key} = 0, return unless @res; # Cache non-existence
+ delete $_[0][1]{$key}; # Clear existence cache, not needed any more
+ $_[0][0]{$key} = $res[0]; # Store data and return
+}
+
+sub EXISTS {
+ my ($a,$key) = (shift, shift);
+ return 1 if exists $a->[0]{$key}; # Have data
+ my $cache = $a->[1]{$key};
+ return $cache if defined $cache; # Existence cache
+ my @res = $a->[3]($key,$a->[4]);
+ $a->[1]{$key} = 0, return unless @res; # Cache non-existence
+ # Now we know it exists
+ return ($a->[1]{$key} = 1) if $a->[5]; # Only existence reported
+ # Now know the value
+ $a->[0]{$key} = $res[0]; # Store data
+ return 1
+}
+
+sub TIEHASH {
+ croak 'syntax: tie %hash, \'Tie::AutoLoad\', \&fetch_subr' if @_ < 2;
+ croak 'syntax: tie %hash, \'Tie::AutoLoad\', \&fetch_subr, $data, \&exists_subr, \%data_cache, \%existence_cache' if @_ > 6;
+ push @_, undef if @_ < 3; # Data
+ push @_, $_[1] if @_ < 4; # exists
+ push @_, {} while @_ < 6; # initial value and caches
+ bless [ @_[4,5,1,3,2], $_[1] ne $_[3]], $_[0]
+}
+
+1;
+
+=head1 NAME
+
+Tie::Memoize - add data to hash when needed
+
+=head1 SYNOPSIS
+
+ require Tie::Memoize;
+ tie %hash, 'Tie::Memoize',
+ \&fetch, # The rest is optional
+ $DATA, \&exists,
+ {%ini_value}, {%ini_existence};
+
+=head1 DESCRIPTION
+
+This package allows a tied hash to autoload its values on the first access,
+and to use the cached value on the following accesses.
+
+Only read-accesses (via fetching the value or C<exists>) result in calls to
+the functions; the modify-accesses are performed as on a normal hash.
+
+The required arguments during C<tie> are the hash, the package, and
+the reference to the C<FETCH>ing function. The optional arguments are
+an arbitrary scalar $data, the reference to the C<EXISTS> function,
+and initial values of the hash and of the existence cache.
+
+Both the C<FETCH>ing function and the C<EXISTS> functions have the
+same signature: the arguments are C<$key, $data>; $data is the same
+value as given as argument during tie()ing. Both functions should
+return an empty list if the value does not exist. If C<EXISTS>
+function is different from the C<FETCH>ing function, it should return
+a TRUE value on success. The C<FETCH>ing function should return the
+intended value if the key is valid.
+
+=head1 Inheriting from B<Tie::Memoize>
+
+The structure of the tied() data is an array reference with elements
+
+ 0: cache of known values
+ 1: cache of known existence of keys
+ 2: FETCH function
+ 3: EXISTS function
+ 4: $data
+
+The rest is for internal usage of this package. In particular, if
+TIEHASH is overwritten, it should call SUPER::TIEHASH.
+
+=head1 EXAMPLE
+
+ sub slurp {
+ my ($key, $dir) = shift;
+ open my $h, '<', "$dir/$key" or return;
+ local $/; <$h> # slurp it all
+ }
+ sub exists { my ($key, $dir) = shift; return -f "$dir/$key" }
+
+ tie %hash, 'Tie::Memoize', \&slurp, $directory, \&exists,
+ { fake_file1 => $content1, fake_file2 => $content2 },
+ { pretend_does_not_exists => 0, known_to_exist => 1 };
+
+This example treats the slightly modified contents of $directory as a
+hash. The modifications are that the keys F<fake_file1> and
+F<fake_file2> fetch values $content1 and $content2, and
+F<pretend_does_not_exists> will never be accessed. Additionally, the
+existence of F<known_to_exist> is never checked (so if it does not
+exists when its content is needed, the user of %hash may be confused).
+
+=head1 BUGS
+
+FIRSTKEY and NEXTKEY methods go through the keys which were already read,
+not all the possible keys of the hash.
+
+=head1 AUTHOR
+
+Ilya Zakharevich L<mailto:perl-module-hash-memoize at ilyaz.org>.
+
+=cut
+
Copied: trunk/contrib/perl/lib/Tie/Memoize.t (from rev 6437, vendor/perl/5.18.1/lib/Tie/Memoize.t)
===================================================================
--- trunk/contrib/perl/lib/Tie/Memoize.t (rev 0)
+++ trunk/contrib/perl/lib/Tie/Memoize.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,61 @@
+#!./perl -w
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use strict;
+use Tie::Memoize;
+use Test::More tests => 28;
+use File::Spec;
+
+sub slurp {
+ my ($key, $dir) = @_;
+ open my $h, '<', File::Spec->catfile($dir, $key) or return;
+ local $/;
+ <$h> # slurp it all
+}
+sub exists { my ($key, $dir) = @_; return -f File::Spec->catfile($dir, $key) }
+
+my $directory = File::Spec->catdir(File::Spec->updir, 'lib');
+
+tie my %hash, 'Tie::Memoize', \&slurp, $directory, \&exists,
+ { fake_file1 => 123, fake_file2 => 45678 },
+ { 'strict.pm' => 0, known_to_exist => 1 };
+
+ok(not exists $hash{'strict.pm'});
+ok(exists $hash{known_to_exist});
+ok($hash{fake_file2} eq 45678);
+ok($hash{fake_file1} eq 123);
+ok(exists $hash{known_to_exist});
+ok(not exists $hash{'strict.pm'});
+ok(not defined $hash{fake_file3});
+ok(not defined $hash{known_to_exist});
+ok(not exists $hash{known_to_exist});
+ok(not exists $hash{'strict.pm'});
+my $c = slurp('constant.pm', $directory);
+ok($c);
+ok($hash{'constant.pm'} eq $c);
+ok($hash{'constant.pm'} eq $c);
+ok(not exists $hash{'strict.pm'});
+ok(exists $hash{'blib.pm'});
+
+untie %hash;
+
+tie %hash, 'Tie::Memoize', \&slurp, $directory;
+
+ok(exists $hash{'strict.pm'}, 'existing file');
+ok(not exists $hash{fake_file2});
+ok(not exists $hash{fake_file1});
+ok(not exists $hash{known_to_exist});
+ok(exists $hash{'strict.pm'}, 'existing file again');
+ok(not defined $hash{fake_file3});
+ok(not defined $hash{known_to_exist});
+ok(not exists $hash{known_to_exist});
+ok(exists $hash{'strict.pm'}, 'existing file again');
+ok($hash{'constant.pm'} eq $c);
+ok($hash{'constant.pm'} eq $c);
+ok(exists $hash{'strict.pm'}, 'existing file again');
+ok(exists $hash{'blib.pm'}, 'another existing file');
+
Copied: trunk/contrib/perl/lib/Tie/RefHash.pm (from rev 6437, vendor/perl/5.18.1/lib/Tie/RefHash.pm)
===================================================================
--- trunk/contrib/perl/lib/Tie/RefHash.pm (rev 0)
+++ trunk/contrib/perl/lib/Tie/RefHash.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,274 @@
+package Tie::RefHash;
+
+use vars qw/$VERSION/;
+
+$VERSION = "1.38";
+
+use 5.005;
+
+=head1 NAME
+
+Tie::RefHash - use references as hash keys
+
+=head1 SYNOPSIS
+
+ require 5.004;
+ use Tie::RefHash;
+ tie HASHVARIABLE, 'Tie::RefHash', LIST;
+ tie HASHVARIABLE, 'Tie::RefHash::Nestable', LIST;
+
+ untie HASHVARIABLE;
+
+=head1 DESCRIPTION
+
+This module provides the ability to use references as hash keys if you
+first C<tie> the hash variable to this module. Normally, only the
+keys of the tied hash itself are preserved as references; to use
+references as keys in hashes-of-hashes, use Tie::RefHash::Nestable,
+included as part of Tie::RefHash.
+
+It is implemented using the standard perl TIEHASH interface. Please
+see the C<tie> entry in perlfunc(1) and perltie(1) for more information.
+
+The Nestable version works by looking for hash references being stored
+and converting them to tied hashes so that they too can have
+references as keys. This will happen without warning whenever you
+store a reference to one of your own hashes in the tied hash.
+
+=head1 EXAMPLE
+
+ use Tie::RefHash;
+ tie %h, 'Tie::RefHash';
+ $a = [];
+ $b = {};
+ $c = \*main;
+ $d = \"gunk";
+ $e = sub { 'foo' };
+ %h = ($a => 1, $b => 2, $c => 3, $d => 4, $e => 5);
+ $a->[0] = 'foo';
+ $b->{foo} = 'bar';
+ for (keys %h) {
+ print ref($_), "\n";
+ }
+
+ tie %h, 'Tie::RefHash::Nestable';
+ $h{$a}->{$b} = 1;
+ for (keys %h, keys %{$h{$a}}) {
+ print ref($_), "\n";
+ }
+
+=head1 THREAD SUPPORT
+
+L<Tie::RefHash> fully supports threading using the C<CLONE> method.
+
+=head1 STORABLE SUPPORT
+
+L<Storable> hooks are provided for semantically correct serialization and
+cloning of tied refhashes.
+
+=head1 RELIC SUPPORT
+
+This version of Tie::RefHash seems to no longer work with 5.004. This has not
+been throughly investigated. Patches welcome ;-)
+
+=head1 MAINTAINER
+
+Yuval Kogman E<lt>nothingmuch at woobling.orgE<gt>
+
+=head1 AUTHOR
+
+Gurusamy Sarathy gsar at activestate.com
+
+'Nestable' by Ed Avis ed at membled.com
+
+=head1 SEE ALSO
+
+perl(1), perlfunc(1), perltie(1)
+
+=cut
+
+use Tie::Hash;
+use vars '@ISA';
+ at ISA = qw(Tie::Hash);
+use strict;
+use Carp qw/croak/;
+
+BEGIN {
+ local $@;
+ # determine whether we need to take care of threads
+ use Config ();
+ my $usethreads = $Config::Config{usethreads}; # && exists $INC{"threads.pm"}
+ *_HAS_THREADS = $usethreads ? sub () { 1 } : sub () { 0 };
+ *_HAS_SCALAR_UTIL = eval { require Scalar::Util; 1 } ? sub () { 1 } : sub () { 0 };
+ *_HAS_WEAKEN = defined(&Scalar::Util::weaken) ? sub () { 1 } : sub () { 0 };
+}
+
+BEGIN {
+ # create a refaddr function
+
+ local $@;
+
+ if ( _HAS_SCALAR_UTIL ) {
+ Scalar::Util->import("refaddr");
+ } else {
+ require overload;
+
+ *refaddr = sub {
+ if ( overload::StrVal($_[0]) =~ /\( 0x ([a-zA-Z0-9]+) \)$/x) {
+ return $1;
+ } else {
+ die "couldn't parse StrVal: " . overload::StrVal($_[0]);
+ }
+ };
+ }
+}
+
+my (@thread_object_registry, $count); # used by the CLONE method to rehash the keys after their refaddr changed
+
+sub TIEHASH {
+ my $c = shift;
+ my $s = [];
+ bless $s, $c;
+ while (@_) {
+ $s->STORE(shift, shift);
+ }
+
+ if (_HAS_THREADS ) {
+
+ if ( _HAS_WEAKEN ) {
+ # remember the object so that we can rekey it on CLONE
+ push @thread_object_registry, $s;
+ # but make this a weak reference, so that there are no leaks
+ Scalar::Util::weaken( $thread_object_registry[-1] );
+
+ if ( ++$count > 1000 ) {
+ # this ensures we don't fill up with a huge array dead weakrefs
+ @thread_object_registry = grep { defined } @thread_object_registry;
+ $count = 0;
+ }
+ } else {
+ $count++; # used in the warning
+ }
+ }
+
+ return $s;
+}
+
+my $storable_format_version = join("/", __PACKAGE__, "0.01");
+
+sub STORABLE_freeze {
+ my ( $self, $is_cloning ) = @_;
+ my ( $refs, $reg ) = @$self;
+ return ( $storable_format_version, [ values %$refs ], $reg );
+}
+
+sub STORABLE_thaw {
+ my ( $self, $is_cloning, $version, $refs, $reg ) = @_;
+ croak "incompatible versions of Tie::RefHash between freeze and thaw"
+ unless $version eq $storable_format_version;
+
+ @$self = ( {}, $reg );
+ $self->_reindex_keys( $refs );
+}
+
+sub CLONE {
+ my $pkg = shift;
+
+ if ( $count and not _HAS_WEAKEN ) {
+ warn "Tie::RefHash is not threadsafe without Scalar::Util::weaken";
+ }
+
+ # when the thread has been cloned all the objects need to be updated.
+ # dead weakrefs are undefined, so we filter them out
+ @thread_object_registry = grep { defined && do { $_->_reindex_keys; 1 } } @thread_object_registry;
+ $count = 0; # we just cleaned up
+}
+
+sub _reindex_keys {
+ my ( $self, $extra_keys ) = @_;
+ # rehash all the ref keys based on their new StrVal
+ %{ $self->[0] } = map { refaddr($_->[0]) => $_ } (values(%{ $self->[0] }), @{ $extra_keys || [] });
+}
+
+sub FETCH {
+ my($s, $k) = @_;
+ if (ref $k) {
+ my $kstr = refaddr($k);
+ if (defined $s->[0]{$kstr}) {
+ $s->[0]{$kstr}[1];
+ }
+ else {
+ undef;
+ }
+ }
+ else {
+ $s->[1]{$k};
+ }
+}
+
+sub STORE {
+ my($s, $k, $v) = @_;
+ if (ref $k) {
+ $s->[0]{refaddr($k)} = [$k, $v];
+ }
+ else {
+ $s->[1]{$k} = $v;
+ }
+ $v;
+}
+
+sub DELETE {
+ my($s, $k) = @_;
+ (ref $k)
+ ? (delete($s->[0]{refaddr($k)}) || [])->[1]
+ : delete($s->[1]{$k});
+}
+
+sub EXISTS {
+ my($s, $k) = @_;
+ (ref $k) ? exists($s->[0]{refaddr($k)}) : exists($s->[1]{$k});
+}
+
+sub FIRSTKEY {
+ my $s = shift;
+ keys %{$s->[0]}; # reset iterator
+ keys %{$s->[1]}; # reset iterator
+ $s->[2] = 0; # flag for iteration, see NEXTKEY
+ $s->NEXTKEY;
+}
+
+sub NEXTKEY {
+ my $s = shift;
+ my ($k, $v);
+ if (!$s->[2]) {
+ if (($k, $v) = each %{$s->[0]}) {
+ return $v->[0];
+ }
+ else {
+ $s->[2] = 1;
+ }
+ }
+ return each %{$s->[1]};
+}
+
+sub CLEAR {
+ my $s = shift;
+ $s->[2] = 0;
+ %{$s->[0]} = ();
+ %{$s->[1]} = ();
+}
+
+package Tie::RefHash::Nestable;
+use vars '@ISA';
+ at ISA = 'Tie::RefHash';
+
+sub STORE {
+ my($s, $k, $v) = @_;
+ if (ref($v) eq 'HASH' and not tied %$v) {
+ my @elems = %$v;
+ tie %$v, ref($s), @elems;
+ }
+ $s->SUPER::STORE($k, $v);
+}
+
+1;
Index: trunk/contrib/perl/lib/Tie/Scalar.pm
===================================================================
--- trunk/contrib/perl/lib/Tie/Scalar.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Tie/Scalar.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Tie/Scalar.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/lib/Tie/Scalar.t
===================================================================
--- trunk/contrib/perl/lib/Tie/Scalar.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Tie/Scalar.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Tie/Scalar.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/lib/Tie/StdHandle.pm
===================================================================
--- trunk/contrib/perl/lib/Tie/StdHandle.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Tie/StdHandle.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -5,7 +5,7 @@
use Tie::Handle;
use vars qw(@ISA $VERSION);
@ISA = 'Tie::Handle';
-$VERSION = '4.2';
+$VERSION = '4.3';
=head1 NAME
@@ -57,7 +57,7 @@
@_ == 2 ? open($_[0], $_[1]) : open($_[0], $_[1], $_[2]);
}
-sub READ { read($_[0],$_[1],$_[2]) }
+sub READ { &CORE::read(shift, \shift, @_) }
sub READLINE { my $fh = $_[0]; <$fh> }
sub GETC { getc($_[0]) }
Property changes on: trunk/contrib/perl/lib/Tie/StdHandle.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/Tie/SubstrHash.pm
===================================================================
--- trunk/contrib/perl/lib/Tie/SubstrHash.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Tie/SubstrHash.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Tie/SubstrHash.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/Tie/SubstrHash.t
===================================================================
--- trunk/contrib/perl/lib/Tie/SubstrHash.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Tie/SubstrHash.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Tie/SubstrHash.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/lib/Time/Local.pm (from rev 6437, vendor/perl/5.18.1/lib/Time/Local.pm)
===================================================================
--- trunk/contrib/perl/lib/Time/Local.pm (rev 0)
+++ trunk/contrib/perl/lib/Time/Local.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,371 @@
+package Time::Local;
+
+require Exporter;
+use Carp;
+use Config;
+use strict;
+use integer;
+
+use vars qw( $VERSION @ISA @EXPORT @EXPORT_OK );
+$VERSION = '1.1901';
+
+ at ISA = qw( Exporter );
+ at EXPORT = qw( timegm timelocal );
+ at EXPORT_OK = qw( timegm_nocheck timelocal_nocheck );
+
+my @MonthDays = ( 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 );
+
+# Determine breakpoint for rolling century
+my $ThisYear = ( localtime() )[5];
+my $Breakpoint = ( $ThisYear + 50 ) % 100;
+my $NextCentury = $ThisYear - $ThisYear % 100;
+$NextCentury += 100 if $Breakpoint < 50;
+my $Century = $NextCentury - 100;
+my $SecOff = 0;
+
+my ( %Options, %Cheat );
+
+use constant SECS_PER_MINUTE => 60;
+use constant SECS_PER_HOUR => 3600;
+use constant SECS_PER_DAY => 86400;
+
+my $MaxInt;
+if ( $^O eq 'MacOS' ) {
+ # time_t is unsigned...
+ $MaxInt = ( 1 << ( 8 * $Config{ivsize} ) ) - 1;
+}
+else {
+ $MaxInt = ( ( 1 << ( 8 * $Config{ivsize} - 2 ) ) - 1 ) * 2 + 1;
+}
+
+my $MaxDay = int( ( $MaxInt - ( SECS_PER_DAY / 2 ) ) / SECS_PER_DAY ) - 1;
+
+# Determine the EPOC day for this machine
+my $Epoc = 0;
+if ( $^O eq 'vos' ) {
+ # work around posix-977 -- VOS doesn't handle dates in the range
+ # 1970-1980.
+ $Epoc = _daygm( 0, 0, 0, 1, 0, 70, 4, 0 );
+}
+elsif ( $^O eq 'MacOS' ) {
+ $MaxDay *=2 if $^O eq 'MacOS'; # time_t unsigned ... quick hack?
+ # MacOS time() is seconds since 1 Jan 1904, localtime
+ # so we need to calculate an offset to apply later
+ $Epoc = 693901;
+ $SecOff = timelocal( localtime(0)) - timelocal( gmtime(0) ) ;
+ $Epoc += _daygm( gmtime(0) );
+}
+else {
+ $Epoc = _daygm( gmtime(0) );
+}
+
+%Cheat = (); # clear the cache as epoc has changed
+
+sub _daygm {
+
+ # This is written in such a byzantine way in order to avoid
+ # lexical variables and sub calls, for speed
+ return $_[3] + (
+ $Cheat{ pack( 'ss', @_[ 4, 5 ] ) } ||= do {
+ my $month = ( $_[4] + 10 ) % 12;
+ my $year = ( $_[5] + 1900 ) - ( $month / 10 );
+
+ ( ( 365 * $year )
+ + ( $year / 4 )
+ - ( $year / 100 )
+ + ( $year / 400 )
+ + ( ( ( $month * 306 ) + 5 ) / 10 )
+ )
+ - $Epoc;
+ }
+ );
+}
+
+sub _timegm {
+ my $sec =
+ $SecOff + $_[0] + ( SECS_PER_MINUTE * $_[1] ) + ( SECS_PER_HOUR * $_[2] );
+
+ return $sec + ( SECS_PER_DAY * &_daygm );
+}
+
+sub timegm {
+ my ( $sec, $min, $hour, $mday, $month, $year ) = @_;
+
+ if ( $year >= 1000 ) {
+ $year -= 1900;
+ }
+ elsif ( $year < 100 and $year >= 0 ) {
+ $year += ( $year > $Breakpoint ) ? $Century : $NextCentury;
+ }
+
+ unless ( $Options{no_range_check} ) {
+ croak "Month '$month' out of range 0..11"
+ if $month > 11
+ or $month < 0;
+
+ my $md = $MonthDays[$month];
+ ++$md
+ if $month == 1 && _is_leap_year( $year + 1900 );
+
+ croak "Day '$mday' out of range 1..$md" if $mday > $md or $mday < 1;
+ croak "Hour '$hour' out of range 0..23" if $hour > 23 or $hour < 0;
+ croak "Minute '$min' out of range 0..59" if $min > 59 or $min < 0;
+ croak "Second '$sec' out of range 0..59" if $sec > 59 or $sec < 0;
+ }
+
+ my $days = _daygm( undef, undef, undef, $mday, $month, $year );
+
+ unless ($Options{no_range_check} or abs($days) < $MaxDay) {
+ my $msg = '';
+ $msg .= "Day too big - $days > $MaxDay\n" if $days > $MaxDay;
+
+ $year += 1900;
+ $msg .= "Cannot handle date ($sec, $min, $hour, $mday, $month, $year)";
+
+ croak $msg;
+ }
+
+ return $sec
+ + $SecOff
+ + ( SECS_PER_MINUTE * $min )
+ + ( SECS_PER_HOUR * $hour )
+ + ( SECS_PER_DAY * $days );
+}
+
+sub _is_leap_year {
+ return 0 if $_[0] % 4;
+ return 1 if $_[0] % 100;
+ return 0 if $_[0] % 400;
+
+ return 1;
+}
+
+sub timegm_nocheck {
+ local $Options{no_range_check} = 1;
+ return &timegm;
+}
+
+sub timelocal {
+ my $ref_t = &timegm;
+ my $loc_for_ref_t = _timegm( localtime($ref_t) );
+
+ my $zone_off = $loc_for_ref_t - $ref_t
+ or return $loc_for_ref_t;
+
+ # Adjust for timezone
+ my $loc_t = $ref_t - $zone_off;
+
+ # Are we close to a DST change or are we done
+ my $dst_off = $ref_t - _timegm( localtime($loc_t) );
+
+ # If this evaluates to true, it means that the value in $loc_t is
+ # the _second_ hour after a DST change where the local time moves
+ # backward.
+ if ( ! $dst_off &&
+ ( ( $ref_t - SECS_PER_HOUR ) - _timegm( localtime( $loc_t - SECS_PER_HOUR ) ) < 0 )
+ ) {
+ return $loc_t - SECS_PER_HOUR;
+ }
+
+ # Adjust for DST change
+ $loc_t += $dst_off;
+
+ return $loc_t if $dst_off > 0;
+
+ # If the original date was a non-extent gap in a forward DST jump,
+ # we should now have the wrong answer - undo the DST adjustment
+ my ( $s, $m, $h ) = localtime($loc_t);
+ $loc_t -= $dst_off if $s != $_[0] || $m != $_[1] || $h != $_[2];
+
+ return $loc_t;
+}
+
+sub timelocal_nocheck {
+ local $Options{no_range_check} = 1;
+ return &timelocal;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Time::Local - efficiently compute time from local and GMT time
+
+=head1 SYNOPSIS
+
+ $time = timelocal($sec,$min,$hour,$mday,$mon,$year);
+ $time = timegm($sec,$min,$hour,$mday,$mon,$year);
+
+=head1 DESCRIPTION
+
+This module provides functions that are the inverse of built-in perl
+functions C<localtime()> and C<gmtime()>. They accept a date as a
+six-element array, and return the corresponding C<time(2)> value in
+seconds since the system epoch (Midnight, January 1, 1970 GMT on Unix,
+for example). This value can be positive or negative, though POSIX
+only requires support for positive values, so dates before the
+system's epoch may not work on all operating systems.
+
+It is worth drawing particular attention to the expected ranges for
+the values provided. The value for the day of the month is the actual
+day (ie 1..31), while the month is the number of months since January
+(0..11). This is consistent with the values returned from
+C<localtime()> and C<gmtime()>.
+
+=head1 FUNCTIONS
+
+=head2 C<timelocal()> and C<timegm()>
+
+This module exports two functions by default, C<timelocal()> and
+C<timegm()>.
+
+The C<timelocal()> and C<timegm()> functions perform range checking on
+the input $sec, $min, $hour, $mday, and $mon values by default.
+
+=head2 C<timelocal_nocheck()> and C<timegm_nocheck()>
+
+If you are working with data you know to be valid, you can speed your
+code up by using the "nocheck" variants, C<timelocal_nocheck()> and
+C<timegm_nocheck()>. These variants must be explicitly imported.
+
+ use Time::Local 'timelocal_nocheck';
+
+ # The 365th day of 1999
+ print scalar localtime timelocal_nocheck 0,0,0,365,0,99;
+
+If you supply data which is not valid (month 27, second 1,000) the
+results will be unpredictable (so don't do that).
+
+=head2 Year Value Interpretation
+
+Strictly speaking, the year should be specified in a form consistent
+with C<localtime()>, i.e. the offset from 1900. In order to make the
+interpretation of the year easier for humans, however, who are more
+accustomed to seeing years as two-digit or four-digit values, the
+following conventions are followed:
+
+=over 4
+
+=item *
+
+Years greater than 999 are interpreted as being the actual year,
+rather than the offset from 1900. Thus, 1964 would indicate the year
+Martin Luther King won the Nobel prize, not the year 3864.
+
+=item *
+
+Years in the range 100..999 are interpreted as offset from 1900, so
+that 112 indicates 2012. This rule also applies to years less than
+zero (but see note below regarding date range).
+
+=item *
+
+Years in the range 0..99 are interpreted as shorthand for years in the
+rolling "current century," defined as 50 years on either side of the
+current year. Thus, today, in 1999, 0 would refer to 2000, and 45 to
+2045, but 55 would refer to 1955. Twenty years from now, 55 would
+instead refer to 2055. This is messy, but matches the way people
+currently think about two digit dates. Whenever possible, use an
+absolute four digit year instead.
+
+=back
+
+The scheme above allows interpretation of a wide range of dates,
+particularly if 4-digit years are used.
+
+=head2 Limits of time_t
+
+The range of dates that can be actually be handled depends on the size
+of C<time_t> (usually a signed integer) on the given
+platform. Currently, this is 32 bits for most systems, yielding an
+approximate range from Dec 1901 to Jan 2038.
+
+Both C<timelocal()> and C<timegm()> croak if given dates outside the
+supported range.
+
+=head2 Ambiguous Local Times (DST)
+
+Because of DST changes, there are many time zones where the same local
+time occurs for two different GMT times on the same day. For example,
+in the "Europe/Paris" time zone, the local time of 2001-10-28 02:30:00
+can represent either 2001-10-28 00:30:00 GMT, B<or> 2001-10-28
+01:30:00 GMT.
+
+When given an ambiguous local time, the timelocal() function should
+always return the epoch for the I<earlier> of the two possible GMT
+times.
+
+=head2 Non-Existent Local Times (DST)
+
+When a DST change causes a locale clock to skip one hour forward,
+there will be an hour's worth of local times that don't exist. Again,
+for the "Europe/Paris" time zone, the local clock jumped from
+2001-03-25 01:59:59 to 2001-03-25 03:00:00.
+
+If the C<timelocal()> function is given a non-existent local time, it
+will simply return an epoch value for the time one hour later.
+
+=head2 Negative Epoch Values
+
+Negative epoch (C<time_t>) values are not officially supported by the
+POSIX standards, so this module's tests do not test them. On some
+systems, they are known not to work. These include MacOS (pre-OSX) and
+Win32.
+
+On systems which do support negative epoch values, this module should
+be able to cope with dates before the start of the epoch, down the
+minimum value of time_t for the system.
+
+=head1 IMPLEMENTATION
+
+These routines are quite efficient and yet are always guaranteed to
+agree with C<localtime()> and C<gmtime()>. We manage this by caching
+the start times of any months we've seen before. If we know the start
+time of the month, we can always calculate any time within the month.
+The start times are calculated using a mathematical formula. Unlike
+other algorithms that do multiple calls to C<gmtime()>.
+
+The C<timelocal()> function is implemented using the same cache. We
+just assume that we're translating a GMT time, and then fudge it when
+we're done for the timezone and daylight savings arguments. Note that
+the timezone is evaluated for each date because countries occasionally
+change their official timezones. Assuming that C<localtime()> corrects
+for these changes, this routine will also be correct.
+
+=head1 BUGS
+
+The whole scheme for interpreting two-digit years can be considered a
+bug.
+
+=head1 SUPPORT
+
+Support for this module is provided via the datetime at perl.org email
+list. See http://lists.perl.org/ for more details.
+
+Please submit bugs to the CPAN RT system at
+http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Time-Local or via email
+at bug-time-local at rt.cpan.org.
+
+=head1 COPYRIGHT
+
+Copyright (c) 1997-2003 Graham Barr, 2003-2007 David Rolsky. All
+rights reserved. This program is free software; you can redistribute
+it and/or modify it under the same terms as Perl itself.
+
+The full text of the license can be found in the LICENSE file included
+with this module.
+
+=head1 AUTHOR
+
+This module is based on a Perl 4 library, timelocal.pl, that was
+included with Perl 4.036, and was most likely written by Tom
+Christiansen.
+
+The current version was written by Graham Barr.
+
+It is now being maintained separately from the Perl core by Dave
+Rolsky, <autarch at urth.org>.
+
+=cut
Copied: trunk/contrib/perl/lib/Time/Local.t (from rev 6437, vendor/perl/5.18.1/lib/Time/Local.t)
===================================================================
--- trunk/contrib/perl/lib/Time/Local.t (rev 0)
+++ trunk/contrib/perl/lib/Time/Local.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,283 @@
+#!./perl
+
+BEGIN {
+ if ($ENV{PERL_CORE}){
+ chdir('t') if -d 't';
+ @INC = ('.', '../lib');
+ }
+}
+
+use strict;
+
+use Config;
+use Test::More;
+use Time::Local;
+
+# Set up time values to test
+my @time =
+ (
+ #year,mon,day,hour,min,sec
+ [1970, 1, 2, 00, 00, 00],
+ [1980, 2, 28, 12, 00, 00],
+ [1980, 2, 29, 12, 00, 00],
+ [1999, 12, 31, 23, 59, 59],
+ [2000, 1, 1, 00, 00, 00],
+ [2010, 10, 12, 14, 13, 12],
+ # leap day
+ [2020, 2, 29, 12, 59, 59],
+ [2030, 7, 4, 17, 07, 06],
+# The following test fails on a surprising number of systems
+# so it is commented out. The end of the Epoch for a 32-bit signed
+# implementation of time_t should be Jan 19, 2038 03:14:07 UTC.
+# [2038, 1, 17, 23, 59, 59], # last full day in any tz
+ );
+
+my @bad_time =
+ (
+ # month too large
+ [1995, 13, 01, 01, 01, 01],
+ # day too large
+ [1995, 02, 30, 01, 01, 01],
+ # hour too large
+ [1995, 02, 10, 25, 01, 01],
+ # minute too large
+ [1995, 02, 10, 01, 60, 01],
+ # second too large
+ [1995, 02, 10, 01, 01, 60],
+ );
+
+my @neg_time =
+ (
+ # test negative epochs for systems that handle it
+ [ 1969, 12, 31, 16, 59, 59 ],
+ [ 1950, 04, 12, 9, 30, 31 ],
+ );
+
+# Leap year tests
+my @years =
+ (
+ [ 1900 => 0 ],
+ [ 1947 => 0 ],
+ [ 1996 => 1 ],
+ [ 2000 => 1 ],
+ [ 2100 => 0 ],
+ );
+
+# Use 3 days before the start of the epoch because with Borland on
+# Win32 it will work for -3600 _if_ your time zone is +01:00 (or
+# greater).
+my $neg_epoch_ok = defined ((localtime(-259200))[0]) ? 1 : 0;
+
+# use vmsish 'time' makes for oddness around the Unix epoch
+if ($^O eq 'VMS') {
+ $time[0][2]++;
+ $neg_epoch_ok = 0; # time_t is unsigned
+}
+
+my $epoch_is_64 = eval { $Config{ivsize} == 8 && ( gmtime 2**40 )[5] == 34912 };
+
+my $tests = (@time * 12);
+$tests += @neg_time * 12;
+$tests += @bad_time;
+$tests += @years;
+$tests += 23;
+
+plan tests => $tests;
+
+for (@time, @neg_time) {
+ my($year, $mon, $mday, $hour, $min, $sec) = @$_;
+ $year -= 1900;
+ $mon--;
+
+ SKIP: {
+ skip '1970 test on VOS fails.', 12
+ if $^O eq 'vos' && $year == 70;
+ skip 'this platform does not support negative epochs.', 12
+ if $year < 70 && ! $neg_epoch_ok;
+
+ {
+ my $year_in = $year < 70 ? $year + 1900 : $year;
+ my $time = timelocal($sec,$min,$hour,$mday,$mon,$year_in);
+
+ my($s,$m,$h,$D,$M,$Y) = localtime($time);
+
+ is($s, $sec, "timelocal second for @$_");
+ is($m, $min, "timelocal minute for @$_");
+ is($h, $hour, "timelocal hour for @$_");
+ is($D, $mday, "timelocal day for @$_");
+ is($M, $mon, "timelocal month for @$_");
+ is($Y, $year, "timelocal year for @$_");
+ }
+
+ {
+ my $year_in = $year < 70 ? $year + 1900 : $year;
+ my $time = timegm($sec,$min,$hour,$mday,$mon,$year_in);
+
+ my($s,$m,$h,$D,$M,$Y) = gmtime($time);
+
+ is($s, $sec, "timegm second for @$_");
+ is($m, $min, "timegm minute for @$_");
+ is($h, $hour, "timegm hour for @$_");
+ is($D, $mday, "timegm day for @$_");
+ is($M, $mon, "timegm month for @$_");
+ is($Y, $year, "timegm year for @$_");
+ }
+ }
+}
+
+for (@bad_time) {
+ my($year, $mon, $mday, $hour, $min, $sec) = @$_;
+ $year -= 1900;
+ $mon--;
+
+ eval { timegm($sec,$min,$hour,$mday,$mon,$year) };
+
+ like($@, qr/.*out of range.*/, 'invalid time caused an error');
+}
+
+{
+ is(timelocal(0,0,1,1,0,90) - timelocal(0,0,0,1,0,90), 3600,
+ 'one hour difference between two calls to timelocal');
+
+ is(timelocal(1,2,3,1,0,100) - timelocal(1,2,3,31,11,99), 24 * 3600,
+ 'one day difference between two calls to timelocal');
+
+ # Diff beween Jan 1, 1980 and Mar 1, 1980 = (31 + 29 = 60 days)
+ is(timegm(0,0,0, 1, 2, 80) - timegm(0,0,0, 1, 0, 80), 60 * 24 * 3600,
+ '60 day difference between two calls to timegm');
+}
+
+# bugid #19393
+# At a DST transition, the clock skips forward, eg from 01:59:59 to
+# 03:00:00. In this case, 02:00:00 is an invalid time, and should be
+# treated like 03:00:00 rather than 01:00:00 - negative zone offsets used
+# to do the latter
+{
+ my $hour = (localtime(timelocal(0, 0, 2, 7, 3, 102)))[2];
+ # testers in US/Pacific should get 3,
+ # other testers should get 2
+ ok($hour == 2 || $hour == 3, 'hour should be 2 or 3');
+}
+
+for my $p (@years) {
+ my ( $year, $is_leap_year ) = @$p;
+
+ my $string = $is_leap_year ? 'is' : 'is not';
+ is( Time::Local::_is_leap_year($year), $is_leap_year,
+ "$year $string a leap year" );
+}
+
+SKIP:
+{
+ skip 'this platform does not support negative epochs.', 6
+ unless $neg_epoch_ok;
+
+ eval { timegm(0,0,0,29,1,1900) };
+ like($@, qr/Day '29' out of range 1\.\.28/,
+ 'does not accept leap day in 1900');
+
+ eval { timegm(0,0,0,29,1,200) };
+ like($@, qr/Day '29' out of range 1\.\.28/,
+ 'does not accept leap day in 2100 (year passed as 200)');
+
+ eval { timegm(0,0,0,29,1,0) };
+ is($@, '', 'no error with leap day of 2000 (year passed as 0)');
+
+ eval { timegm(0,0,0,29,1,1904) };
+ is($@, '', 'no error with leap day of 1904');
+
+ eval { timegm(0,0,0,29,1,4) };
+ is($@, '', 'no error with leap day of 2004 (year passed as 4)');
+
+ eval { timegm(0,0,0,29,1,96) };
+ is($@, '', 'no error with leap day of 1996 (year passed as 96)');
+}
+
+SKIP:
+{
+ skip 'These tests require a system with 64-bit time_t.', 3
+ unless $epoch_is_64;
+
+ is( timegm( 8, 14, 3, 19, 0, ( 1900 + 138 ) ), 2**31,
+ 'can call timegm for 2**31 epoch seconds' );
+ is( timegm( 16, 28, 6, 7, 1, ( 1900 + 206 ) ), 2**32,
+ 'can call timegm for 2**32 epoch seconds (on a 64-bit system)' );
+ is( timegm( 16, 36, 0, 20, 1, ( 34912 + 1900 ) ), 2**40,
+ 'can call timegm for 2**40 epoch seconds (on a 64-bit system)' );
+}
+
+SKIP:
+{
+ skip 'These tests only run for the package maintainer.', 8
+ unless $ENV{MAINTAINER};
+
+ require POSIX;
+
+ local $ENV{TZ} = 'Europe/Vienna';
+ POSIX::tzset();
+
+ # 2001-10-28 02:30:00 - could be either summer or standard time,
+ # prefer earlier of the two, in this case summer
+ my $time = timelocal(0, 30, 2, 28, 9, 101);
+ is($time, 1004229000,
+ 'timelocal prefers earlier epoch in the presence of a DST change');
+
+ local $ENV{TZ} = 'America/Chicago';
+ POSIX::tzset();
+
+ # Same local time in America/Chicago. There is a transition here
+ # as well.
+ $time = timelocal(0, 30, 1, 28, 9, 101);
+ is($time, 1004250600,
+ 'timelocal prefers earlier epoch in the presence of a DST change');
+
+ $time = timelocal(0, 30, 2, 1, 3, 101);
+ is($time, 986113800,
+ 'timelocal for non-existent time gives you the time one hour later');
+
+ local $ENV{TZ} = 'Australia/Sydney';
+ POSIX::tzset();
+ # 2001-03-25 02:30:00 in Australia/Sydney. This is the transition
+ # _to_ summer time. The southern hemisphere transitions are
+ # opposite those of the northern.
+ $time = timelocal(0, 30, 2, 25, 2, 101);
+ is($time, 985447800,
+ 'timelocal prefers earlier epoch in the presence of a DST change');
+
+ $time = timelocal(0, 30, 2, 28, 9, 101);
+ is($time, 1004200200,
+ 'timelocal for non-existent time gives you the time one hour later');
+
+ local $ENV{TZ} = 'Europe/London';
+ POSIX::tzset();
+ $time = timelocal( localtime(1111917720) );
+ is($time, 1111917720,
+ 'timelocal for round trip bug on date of DST change for Europe/London');
+
+ # There is no 1:00 AM on this date, as it leaps forward to
+ # 2:00 on the DST change - this should return 2:00 per the
+ # docs.
+ is( ( localtime( timelocal( 0, 0, 1, 27, 2, 2005 ) ) )[2], 2,
+ 'hour is 2 when given 1:00 AM on Europe/London date change' );
+
+ is( ( localtime( timelocal( 0, 0, 2, 27, 2, 2005 ) ) )[2], 2,
+ 'hour is 2 when given 2:00 AM on Europe/London date change' );
+}
+
+SKIP:
+{
+ skip 'These tests are only run when $ENV{PERL_CORE} is true.', 2
+ unless $ENV{PERL_CORE};
+
+ {
+ package test;
+ require 'timelocal.pl';
+
+ # need to get ok() from main package
+ ::is(timegm(0,0,0,1,0,80), main::timegm(0,0,0,1,0,80),
+ 'timegm in timelocal.pl');
+
+ ::is(timelocal(1,2,3,4,5,88), main::timelocal(1,2,3,4,5,88),
+ 'timelocal in timelocal.pl');
+ }
+}
Index: trunk/contrib/perl/lib/Time/gmtime.pm
===================================================================
--- trunk/contrib/perl/lib/Time/gmtime.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Time/gmtime.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Time/gmtime.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/Time/gmtime.t
===================================================================
--- trunk/contrib/perl/lib/Time/gmtime.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Time/gmtime.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Time/gmtime.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/Time/localtime.pm
===================================================================
--- trunk/contrib/perl/lib/Time/localtime.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Time/localtime.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Time/localtime.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/Time/localtime.t
===================================================================
--- trunk/contrib/perl/lib/Time/localtime.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Time/localtime.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Time/localtime.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/Time/tm.pm
===================================================================
--- trunk/contrib/perl/lib/Time/tm.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Time/tm.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Time/tm.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/lib/UNIVERSAL.pm
===================================================================
--- trunk/contrib/perl/lib/UNIVERSAL.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/UNIVERSAL.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,6 +1,6 @@
package UNIVERSAL;
-our $VERSION = '1.08';
+our $VERSION = '1.11';
# UNIVERSAL should not contain any extra subs/methods beyond those
# that it exists to define. The use of Exporter below is a historical
@@ -103,7 +103,7 @@
use Scalar::Util 'blessed';
- if ( blessed( $obj ) && $obj->isa("Some::Class") {
+ if ( blessed( $obj ) && $obj->isa("Some::Class") ) {
...
}
@@ -165,10 +165,14 @@
C<VERSION> will return the value of the variable C<$VERSION> in the
package the object is blessed into. If C<REQUIRE> is given then
it will do a comparison and die if the package version is not
-greater than or equal to C<REQUIRE>. Both C<$VERSION> or C<REQUIRE>
-must be "lax" version numbers (as defined by the L<version> module)
-or C<VERSION> will die with an error.
+greater than or equal to C<REQUIRE>, or if either C<$VERSION> or C<REQUIRE>
+is not a "lax" version number (as defined by the L<version> module).
+The return from C<VERSION> will actually be the stringified version object
+using the package C<$VERSION> scalar, which is guaranteed to be equivalent
+but may not be precisely the contents of the C<$VERSION> scalar. If you want
+the actual contents of C<$VERSION>, use C<$CLASS::VERSION> instead.
+
C<VERSION> can be called as either a class (static) method or an object
method.
Property changes on: trunk/contrib/perl/lib/UNIVERSAL.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Copied: trunk/contrib/perl/lib/Unicode/Collate.pm (from rev 6437, vendor/perl/5.18.1/lib/Unicode/Collate.pm)
===================================================================
--- trunk/contrib/perl/lib/Unicode/Collate.pm (rev 0)
+++ trunk/contrib/perl/lib/Unicode/Collate.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,1877 @@
+package Unicode::Collate;
+
+BEGIN {
+ unless ("A" eq pack('U', 0x41)) {
+ die "Unicode::Collate cannot stringify a Unicode code point\n";
+ }
+}
+
+use 5.006;
+use strict;
+use warnings;
+use Carp;
+use File::Spec;
+
+no warnings 'utf8';
+
+our $VERSION = '0.52';
+our $PACKAGE = __PACKAGE__;
+
+my @Path = qw(Unicode Collate);
+my $KeyFile = "allkeys.txt";
+
+# Perl's boolean
+use constant TRUE => 1;
+use constant FALSE => "";
+use constant NOMATCHPOS => -1;
+
+# A coderef to get combining class imported from Unicode::Normalize
+# (i.e. \&Unicode::Normalize::getCombinClass).
+# This is also used as a HAS_UNICODE_NORMALIZE flag.
+my $CVgetCombinClass;
+
+# Supported Levels
+use constant MinLevel => 1;
+use constant MaxLevel => 4;
+
+# Minimum weights at level 2 and 3, respectively
+use constant Min2Wt => 0x20;
+use constant Min3Wt => 0x02;
+
+# Shifted weight at 4th level
+use constant Shift4Wt => 0xFFFF;
+
+# A boolean for Variable and 16-bit weights at 4 levels of Collation Element
+# PROBLEM: The Default Unicode Collation Element Table
+# has weights over 0xFFFF at the 4th level.
+# The tie-breaking in the variable weights
+# other than "shift" (as well as "shift-trimmed") is unreliable.
+use constant VCE_TEMPLATE => 'Cn4';
+
+# A sort key: 16-bit weights
+# See also the PROBLEM on VCE_TEMPLATE above.
+use constant KEY_TEMPLATE => 'n*';
+
+# Level separator in a sort key:
+# i.e. pack(KEY_TEMPLATE, 0)
+use constant LEVEL_SEP => "\0\0";
+
+# As Unicode code point separator for hash keys.
+# A joined code point string (denoted by JCPS below)
+# like "65;768" is used for internal processing
+# instead of Perl's Unicode string like "\x41\x{300}",
+# as the native code point is different from the Unicode code point
+# on EBCDIC platform.
+# This character must not be included in any stringified
+# representation of an integer.
+use constant CODE_SEP => ';';
+
+# boolean values of variable weights
+use constant NON_VAR => 0; # Non-Variable character
+use constant VAR => 1; # Variable character
+
+# specific code points
+use constant Hangul_LBase => 0x1100;
+use constant Hangul_LIni => 0x1100;
+use constant Hangul_LFin => 0x1159;
+use constant Hangul_LFill => 0x115F;
+use constant Hangul_VBase => 0x1161;
+use constant Hangul_VIni => 0x1160; # from Vowel Filler
+use constant Hangul_VFin => 0x11A2;
+use constant Hangul_TBase => 0x11A7; # from "no-final" codepoint
+use constant Hangul_TIni => 0x11A8;
+use constant Hangul_TFin => 0x11F9;
+use constant Hangul_TCount => 28;
+use constant Hangul_NCount => 588;
+use constant Hangul_SBase => 0xAC00;
+use constant Hangul_SIni => 0xAC00;
+use constant Hangul_SFin => 0xD7A3;
+use constant CJK_UidIni => 0x4E00;
+use constant CJK_UidFin => 0x9FA5;
+use constant CJK_UidF41 => 0x9FBB;
+use constant CJK_ExtAIni => 0x3400;
+use constant CJK_ExtAFin => 0x4DB5;
+use constant CJK_ExtBIni => 0x20000;
+use constant CJK_ExtBFin => 0x2A6D6;
+use constant BMP_Max => 0xFFFF;
+
+# Logical_Order_Exception in PropList.txt
+my $DefaultRearrange = [ 0x0E40..0x0E44, 0x0EC0..0x0EC4 ];
+
+sub UCA_Version { "14" }
+
+sub Base_Unicode_Version { "4.1.0" }
+
+######
+
+sub pack_U {
+ return pack('U*', @_);
+}
+
+sub unpack_U {
+ return unpack('U*', shift(@_).pack('U*'));
+}
+
+######
+
+my (%VariableOK);
+ at VariableOK{ qw/
+ blanked non-ignorable shifted shift-trimmed
+ / } = (); # keys lowercased
+
+our @ChangeOK = qw/
+ alternate backwards level normalization rearrange
+ katakana_before_hiragana upper_before_lower
+ overrideHangul overrideCJK preprocess UCA_Version
+ hangul_terminator variable
+ /;
+
+our @ChangeNG = qw/
+ entry mapping table maxlength
+ ignoreChar ignoreName undefChar undefName variableTable
+ versionTable alternateTable backwardsTable forwardsTable rearrangeTable
+ derivCode normCode rearrangeHash
+ backwardsFlag
+ /;
+# The hash key 'ignored' is deleted at v 0.21.
+# The hash key 'isShift' is deleted at v 0.23.
+# The hash key 'combining' is deleted at v 0.24.
+# The hash key 'entries' is deleted at v 0.30.
+# The hash key 'L3_ignorable' is deleted at v 0.40.
+
+sub version {
+ my $self = shift;
+ return $self->{versionTable} || 'unknown';
+}
+
+my (%ChangeOK, %ChangeNG);
+ at ChangeOK{ @ChangeOK } = ();
+ at ChangeNG{ @ChangeNG } = ();
+
+sub change {
+ my $self = shift;
+ my %hash = @_;
+ my %old;
+ if (exists $hash{variable} && exists $hash{alternate}) {
+ delete $hash{alternate};
+ }
+ elsif (!exists $hash{variable} && exists $hash{alternate}) {
+ $hash{variable} = $hash{alternate};
+ }
+ foreach my $k (keys %hash) {
+ if (exists $ChangeOK{$k}) {
+ $old{$k} = $self->{$k};
+ $self->{$k} = $hash{$k};
+ }
+ elsif (exists $ChangeNG{$k}) {
+ croak "change of $k via change() is not allowed!";
+ }
+ # else => ignored
+ }
+ $self->checkCollator();
+ return wantarray ? %old : $self;
+}
+
+sub _checkLevel {
+ my $level = shift;
+ my $key = shift; # 'level' or 'backwards'
+ MinLevel <= $level or croak sprintf
+ "Illegal level %d (in value for key '%s') lower than %d.",
+ $level, $key, MinLevel;
+ $level <= MaxLevel or croak sprintf
+ "Unsupported level %d (in value for key '%s') higher than %d.",
+ $level, $key, MaxLevel;
+}
+
+my %DerivCode = (
+ 8 => \&_derivCE_8,
+ 9 => \&_derivCE_9,
+ 11 => \&_derivCE_9, # 11 == 9
+ 14 => \&_derivCE_14,
+);
+
+sub checkCollator {
+ my $self = shift;
+ _checkLevel($self->{level}, "level");
+
+ $self->{derivCode} = $DerivCode{ $self->{UCA_Version} }
+ or croak "Illegal UCA version (passed $self->{UCA_Version}).";
+
+ $self->{variable} ||= $self->{alternate} || $self->{variableTable} ||
+ $self->{alternateTable} || 'shifted';
+ $self->{variable} = $self->{alternate} = lc($self->{variable});
+ exists $VariableOK{ $self->{variable} }
+ or croak "$PACKAGE unknown variable parameter name: $self->{variable}";
+
+ if (! defined $self->{backwards}) {
+ $self->{backwardsFlag} = 0;
+ }
+ elsif (! ref $self->{backwards}) {
+ _checkLevel($self->{backwards}, "backwards");
+ $self->{backwardsFlag} = 1 << $self->{backwards};
+ }
+ else {
+ my %level;
+ $self->{backwardsFlag} = 0;
+ for my $b (@{ $self->{backwards} }) {
+ _checkLevel($b, "backwards");
+ $level{$b} = 1;
+ }
+ for my $v (sort keys %level) {
+ $self->{backwardsFlag} += 1 << $v;
+ }
+ }
+
+ defined $self->{rearrange} or $self->{rearrange} = [];
+ ref $self->{rearrange}
+ or croak "$PACKAGE: list for rearrangement must be store in ARRAYREF";
+
+ # keys of $self->{rearrangeHash} are $self->{rearrange}.
+ $self->{rearrangeHash} = undef;
+
+ if (@{ $self->{rearrange} }) {
+ @{ $self->{rearrangeHash} }{ @{ $self->{rearrange} } } = ();
+ }
+
+ $self->{normCode} = undef;
+
+ if (defined $self->{normalization}) {
+ eval { require Unicode::Normalize };
+ $@ and croak "Unicode::Normalize is required to normalize strings";
+
+ $CVgetCombinClass ||= \&Unicode::Normalize::getCombinClass;
+
+ if ($self->{normalization} =~ /^(?:NF)D\z/) { # tweak for default
+ $self->{normCode} = \&Unicode::Normalize::NFD;
+ }
+ elsif ($self->{normalization} ne 'prenormalized') {
+ my $norm = $self->{normalization};
+ $self->{normCode} = sub {
+ Unicode::Normalize::normalize($norm, shift);
+ };
+ eval { $self->{normCode}->("") }; # try
+ $@ and croak "$PACKAGE unknown normalization form name: $norm";
+ }
+ }
+ return;
+}
+
+sub new
+{
+ my $class = shift;
+ my $self = bless { @_ }, $class;
+
+ # If undef is passed explicitly, no file is read.
+ $self->{table} = $KeyFile if ! exists $self->{table};
+ $self->read_table() if defined $self->{table};
+
+ if ($self->{entry}) {
+ while ($self->{entry} =~ /([^\n]+)/g) {
+ $self->parseEntry($1);
+ }
+ }
+
+ $self->{level} ||= MaxLevel;
+ $self->{UCA_Version} ||= UCA_Version();
+
+ $self->{overrideHangul} = FALSE
+ if ! exists $self->{overrideHangul};
+ $self->{overrideCJK} = FALSE
+ if ! exists $self->{overrideCJK};
+ $self->{normalization} = 'NFD'
+ if ! exists $self->{normalization};
+ $self->{rearrange} = $self->{rearrangeTable} ||
+ ($self->{UCA_Version} <= 11 ? $DefaultRearrange : [])
+ if ! exists $self->{rearrange};
+ $self->{backwards} = $self->{backwardsTable}
+ if ! exists $self->{backwards};
+
+ $self->checkCollator();
+
+ return $self;
+}
+
+sub read_table {
+ my $self = shift;
+
+ my($f, $fh);
+ foreach my $d (@INC) {
+ $f = File::Spec->catfile($d, @Path, $self->{table});
+ last if open($fh, $f);
+ $f = undef;
+ }
+ if (!defined $f) {
+ $f = File::Spec->catfile(@Path, $self->{table});
+ croak("$PACKAGE: Can't locate $f in \@INC (\@INC contains: @INC)");
+ }
+
+ while (my $line = <$fh>) {
+ next if $line =~ /^\s*#/;
+ unless ($line =~ s/^\s*\@//) {
+ $self->parseEntry($line);
+ next;
+ }
+
+ # matched ^\s*\@
+ if ($line =~ /^version\s*(\S*)/) {
+ $self->{versionTable} ||= $1;
+ }
+ elsif ($line =~ /^variable\s+(\S*)/) { # since UTS #10-9
+ $self->{variableTable} ||= $1;
+ }
+ elsif ($line =~ /^alternate\s+(\S*)/) { # till UTS #10-8
+ $self->{alternateTable} ||= $1;
+ }
+ elsif ($line =~ /^backwards\s+(\S*)/) {
+ push @{ $self->{backwardsTable} }, $1;
+ }
+ elsif ($line =~ /^forwards\s+(\S*)/) { # parhaps no use
+ push @{ $self->{forwardsTable} }, $1;
+ }
+ elsif ($line =~ /^rearrange\s+(.*)/) { # (\S*) is NG
+ push @{ $self->{rearrangeTable} }, _getHexArray($1);
+ }
+ }
+ close $fh;
+}
+
+
+##
+## get $line, parse it, and write an entry in $self
+##
+sub parseEntry
+{
+ my $self = shift;
+ my $line = shift;
+ my($name, $entry, @uv, @key);
+
+ return if $line !~ /^\s*[0-9A-Fa-f]/;
+
+ # removes comment and gets name
+ $name = $1
+ if $line =~ s/[#%]\s*(.*)//;
+ return if defined $self->{undefName} && $name =~ /$self->{undefName}/;
+
+ # gets element
+ my($e, $k) = split /;/, $line;
+ croak "Wrong Entry: <charList> must be separated by ';' from <collElement>"
+ if ! $k;
+
+ @uv = _getHexArray($e);
+ return if !@uv;
+
+ $entry = join(CODE_SEP, @uv); # in JCPS
+
+ if (defined $self->{undefChar} || defined $self->{ignoreChar}) {
+ my $ele = pack_U(@uv);
+
+ # regarded as if it were not entried in the table
+ return
+ if defined $self->{undefChar} && $ele =~ /$self->{undefChar}/;
+
+ # replaced as completely ignorable
+ $k = '[.0000.0000.0000.0000]'
+ if defined $self->{ignoreChar} && $ele =~ /$self->{ignoreChar}/;
+ }
+
+ # replaced as completely ignorable
+ $k = '[.0000.0000.0000.0000]'
+ if defined $self->{ignoreName} && $name =~ /$self->{ignoreName}/;
+
+ my $is_L3_ignorable = TRUE;
+
+ foreach my $arr ($k =~ /\[([^\[\]]+)\]/g) { # SPACEs allowed
+ my $var = $arr =~ /\*/; # exactly /^\*/ but be lenient.
+ my @wt = _getHexArray($arr);
+ push @key, pack(VCE_TEMPLATE, $var, @wt);
+ $is_L3_ignorable = FALSE
+ if $wt[0] || $wt[1] || $wt[2];
+ # Conformance Test for 3.1.1 and 4.0.0 shows Level 3 ignorable
+ # is completely ignorable.
+ # For expansion, an entry $is_L3_ignorable
+ # if and only if "all" CEs are [.0000.0000.0000].
+ }
+
+ $self->{mapping}{$entry} = $is_L3_ignorable ? [] : \@key;
+
+ if (@uv > 1) {
+ (!$self->{maxlength}{$uv[0]} || $self->{maxlength}{$uv[0]} < @uv)
+ and $self->{maxlength}{$uv[0]} = @uv;
+ }
+}
+
+
+##
+## VCE = _varCE(variable term, VCE)
+##
+sub _varCE
+{
+ my $vbl = shift;
+ my $vce = shift;
+ if ($vbl eq 'non-ignorable') {
+ return $vce;
+ }
+ my ($var, @wt) = unpack VCE_TEMPLATE, $vce;
+
+ if ($var) {
+ return pack(VCE_TEMPLATE, $var, 0, 0, 0,
+ $vbl eq 'blanked' ? $wt[3] : $wt[0]);
+ }
+ elsif ($vbl eq 'blanked') {
+ return $vce;
+ }
+ else {
+ return pack(VCE_TEMPLATE, $var, @wt[0..2],
+ $vbl eq 'shifted' && $wt[0]+$wt[1]+$wt[2] ? Shift4Wt : 0);
+ }
+}
+
+sub viewSortKey
+{
+ my $self = shift;
+ $self->visualizeSortKey($self->getSortKey(@_));
+}
+
+sub visualizeSortKey
+{
+ my $self = shift;
+ my $view = join " ", map sprintf("%04X", $_), unpack(KEY_TEMPLATE, shift);
+
+ if ($self->{UCA_Version} <= 8) {
+ $view =~ s/ ?0000 ?/|/g;
+ } else {
+ $view =~ s/\b0000\b/|/g;
+ }
+ return "[$view]";
+}
+
+
+##
+## arrayref of JCPS = splitEnt(string to be collated)
+## arrayref of arrayref[JCPS, ini_pos, fin_pos] = splitEnt(string, true)
+##
+sub splitEnt
+{
+ my $self = shift;
+ my $wLen = $_[1];
+
+ my $code = $self->{preprocess};
+ my $norm = $self->{normCode};
+ my $map = $self->{mapping};
+ my $max = $self->{maxlength};
+ my $reH = $self->{rearrangeHash};
+ my $ver9 = $self->{UCA_Version} >= 9 && $self->{UCA_Version} <= 11;
+
+ my ($str, @buf);
+
+ if ($wLen) {
+ $code and croak "Preprocess breaks character positions. "
+ . "Don't use with index(), match(), etc.";
+ $norm and croak "Normalization breaks character positions. "
+ . "Don't use with index(), match(), etc.";
+ $str = $_[0];
+ }
+ else {
+ $str = $_[0];
+ $str = &$code($str) if ref $code;
+ $str = &$norm($str) if ref $norm;
+ }
+
+ # get array of Unicode code point of string.
+ my @src = unpack_U($str);
+
+ # rearrangement:
+ # Character positions are not kept if rearranged,
+ # then neglected if $wLen is true.
+ if ($reH && ! $wLen) {
+ for (my $i = 0; $i < @src; $i++) {
+ if (exists $reH->{ $src[$i] } && $i + 1 < @src) {
+ ($src[$i], $src[$i+1]) = ($src[$i+1], $src[$i]);
+ $i++;
+ }
+ }
+ }
+
+ # remove a code point marked as a completely ignorable.
+ for (my $i = 0; $i < @src; $i++) {
+ $src[$i] = undef
+ if _isIllegal($src[$i]) || ($ver9 &&
+ $map->{ $src[$i] } && @{ $map->{ $src[$i] } } == 0);
+ }
+
+ for (my $i = 0; $i < @src; $i++) {
+ my $jcps = $src[$i];
+
+ # skip removed code point
+ if (! defined $jcps) {
+ if ($wLen && @buf) {
+ $buf[-1][2] = $i + 1;
+ }
+ next;
+ }
+
+ my $i_orig = $i;
+
+ # find contraction
+ if ($max->{$jcps}) {
+ my $temp_jcps = $jcps;
+ my $jcpsLen = 1;
+ my $maxLen = $max->{$jcps};
+
+ for (my $p = $i + 1; $jcpsLen < $maxLen && $p < @src; $p++) {
+ next if ! defined $src[$p];
+ $temp_jcps .= CODE_SEP . $src[$p];
+ $jcpsLen++;
+ if ($map->{$temp_jcps}) {
+ $jcps = $temp_jcps;
+ $i = $p;
+ }
+ }
+
+ # not-contiguous contraction with Combining Char (cf. UTS#10, S2.1).
+ # This process requires Unicode::Normalize.
+ # If "normalization" is undef, here should be skipped *always*
+ # (in spite of bool value of $CVgetCombinClass),
+ # since canonical ordering cannot be expected.
+ # Blocked combining character should not be contracted.
+
+ if ($self->{normalization})
+ # $self->{normCode} is false in the case of "prenormalized".
+ {
+ my $preCC = 0;
+ my $curCC = 0;
+
+ for (my $p = $i + 1; $p < @src; $p++) {
+ next if ! defined $src[$p];
+ $curCC = $CVgetCombinClass->($src[$p]);
+ last unless $curCC;
+ my $tail = CODE_SEP . $src[$p];
+ if ($preCC != $curCC && $map->{$jcps.$tail}) {
+ $jcps .= $tail;
+ $src[$p] = undef;
+ } else {
+ $preCC = $curCC;
+ }
+ }
+ }
+ }
+
+ # skip completely ignorable
+ if ($map->{$jcps} && @{ $map->{$jcps} } == 0) {
+ if ($wLen && @buf) {
+ $buf[-1][2] = $i + 1;
+ }
+ next;
+ }
+
+ push @buf, $wLen ? [$jcps, $i_orig, $i + 1] : $jcps;
+ }
+ return \@buf;
+}
+
+
+##
+## list of VCE = getWt(JCPS)
+##
+sub getWt
+{
+ my $self = shift;
+ my $u = shift;
+ my $vbl = $self->{variable};
+ my $map = $self->{mapping};
+ my $der = $self->{derivCode};
+
+ return if !defined $u;
+ return map(_varCE($vbl, $_), @{ $map->{$u} })
+ if $map->{$u};
+
+ # JCPS must not be a contraction, then it's a code point.
+ if (Hangul_SIni <= $u && $u <= Hangul_SFin) {
+ my $hang = $self->{overrideHangul};
+ my @hangulCE;
+ if ($hang) {
+ @hangulCE = map(pack(VCE_TEMPLATE, NON_VAR, @$_), &$hang($u));
+ }
+ elsif (!defined $hang) {
+ @hangulCE = $der->($u);
+ }
+ else {
+ my $max = $self->{maxlength};
+ my @decH = _decompHangul($u);
+
+ if (@decH == 2) {
+ my $contract = join(CODE_SEP, @decH);
+ @decH = ($contract) if $map->{$contract};
+ } else { # must be <@decH == 3>
+ if ($max->{$decH[0]}) {
+ my $contract = join(CODE_SEP, @decH);
+ if ($map->{$contract}) {
+ @decH = ($contract);
+ } else {
+ $contract = join(CODE_SEP, @decH[0,1]);
+ $map->{$contract} and @decH = ($contract, $decH[2]);
+ }
+ # even if V's ignorable, LT contraction is not supported.
+ # If such a situatution were required, NFD should be used.
+ }
+ if (@decH == 3 && $max->{$decH[1]}) {
+ my $contract = join(CODE_SEP, @decH[1,2]);
+ $map->{$contract} and @decH = ($decH[0], $contract);
+ }
+ }
+
+ @hangulCE = map({
+ $map->{$_} ? @{ $map->{$_} } : $der->($_);
+ } @decH);
+ }
+ return map _varCE($vbl, $_), @hangulCE;
+ }
+ elsif (_isUIdeo($u, $self->{UCA_Version})) {
+ my $cjk = $self->{overrideCJK};
+ return map _varCE($vbl, $_),
+ $cjk
+ ? map(pack(VCE_TEMPLATE, NON_VAR, @$_), &$cjk($u))
+ : defined $cjk && $self->{UCA_Version} <= 8 && $u < 0x10000
+ ? _uideoCE_8($u)
+ : $der->($u);
+ }
+ else {
+ return map _varCE($vbl, $_), $der->($u);
+ }
+}
+
+
+##
+## string sortkey = getSortKey(string arg)
+##
+sub getSortKey
+{
+ my $self = shift;
+ my $lev = $self->{level};
+ my $rEnt = $self->splitEnt(shift); # get an arrayref of JCPS
+ my $v2i = $self->{UCA_Version} >= 9 &&
+ $self->{variable} ne 'non-ignorable';
+
+ my @buf; # weight arrays
+ if ($self->{hangul_terminator}) {
+ my $preHST = '';
+ foreach my $jcps (@$rEnt) {
+ # weird things like VL, TL-contraction are not considered!
+ my $curHST = '';
+ foreach my $u (split /;/, $jcps) {
+ $curHST .= getHST($u);
+ }
+ if ($preHST && !$curHST || # hangul before non-hangul
+ $preHST =~ /L\z/ && $curHST =~ /^T/ ||
+ $preHST =~ /V\z/ && $curHST =~ /^L/ ||
+ $preHST =~ /T\z/ && $curHST =~ /^[LV]/) {
+
+ push @buf, $self->getWtHangulTerm();
+ }
+ $preHST = $curHST;
+
+ push @buf, $self->getWt($jcps);
+ }
+ $preHST # end at hangul
+ and push @buf, $self->getWtHangulTerm();
+ }
+ else {
+ foreach my $jcps (@$rEnt) {
+ push @buf, $self->getWt($jcps);
+ }
+ }
+
+ # make sort key
+ my @ret = ([],[],[],[]);
+ my $last_is_variable;
+
+ foreach my $vwt (@buf) {
+ my($var, @wt) = unpack(VCE_TEMPLATE, $vwt);
+
+ # "Ignorable (L1, L2) after Variable" since track. v. 9
+ if ($v2i) {
+ if ($var) {
+ $last_is_variable = TRUE;
+ }
+ elsif (!$wt[0]) { # ignorable
+ next if $last_is_variable;
+ }
+ else {
+ $last_is_variable = FALSE;
+ }
+ }
+ foreach my $v (0..$lev-1) {
+ 0 < $wt[$v] and push @{ $ret[$v] }, $wt[$v];
+ }
+ }
+
+ # modification of tertiary weights
+ if ($self->{upper_before_lower}) {
+ foreach my $w (@{ $ret[2] }) {
+ if (0x8 <= $w && $w <= 0xC) { $w -= 6 } # lower
+ elsif (0x2 <= $w && $w <= 0x6) { $w += 6 } # upper
+ elsif ($w == 0x1C) { $w += 1 } # square upper
+ elsif ($w == 0x1D) { $w -= 1 } # square lower
+ }
+ }
+ if ($self->{katakana_before_hiragana}) {
+ foreach my $w (@{ $ret[2] }) {
+ if (0x0F <= $w && $w <= 0x13) { $w -= 2 } # katakana
+ elsif (0x0D <= $w && $w <= 0x0E) { $w += 5 } # hiragana
+ }
+ }
+
+ if ($self->{backwardsFlag}) {
+ for (my $v = MinLevel; $v <= MaxLevel; $v++) {
+ if ($self->{backwardsFlag} & (1 << $v)) {
+ @{ $ret[$v-1] } = reverse @{ $ret[$v-1] };
+ }
+ }
+ }
+
+ join LEVEL_SEP, map pack(KEY_TEMPLATE, @$_), @ret;
+}
+
+
+##
+## int compare = cmp(string a, string b)
+##
+sub cmp { $_[0]->getSortKey($_[1]) cmp $_[0]->getSortKey($_[2]) }
+sub eq { $_[0]->getSortKey($_[1]) eq $_[0]->getSortKey($_[2]) }
+sub ne { $_[0]->getSortKey($_[1]) ne $_[0]->getSortKey($_[2]) }
+sub lt { $_[0]->getSortKey($_[1]) lt $_[0]->getSortKey($_[2]) }
+sub le { $_[0]->getSortKey($_[1]) le $_[0]->getSortKey($_[2]) }
+sub gt { $_[0]->getSortKey($_[1]) gt $_[0]->getSortKey($_[2]) }
+sub ge { $_[0]->getSortKey($_[1]) ge $_[0]->getSortKey($_[2]) }
+
+##
+## list[strings] sorted = sort(list[strings] arg)
+##
+sub sort {
+ my $obj = shift;
+ return
+ map { $_->[1] }
+ sort{ $a->[0] cmp $b->[0] }
+ map [ $obj->getSortKey($_), $_ ], @_;
+}
+
+
+sub _derivCE_14 {
+ my $u = shift;
+ my $base =
+ (CJK_UidIni <= $u && $u <= CJK_UidF41)
+ ? 0xFB40 : # CJK
+ (CJK_ExtAIni <= $u && $u <= CJK_ExtAFin ||
+ CJK_ExtBIni <= $u && $u <= CJK_ExtBFin)
+ ? 0xFB80 # CJK ext.
+ : 0xFBC0; # others
+
+ my $aaaa = $base + ($u >> 15);
+ my $bbbb = ($u & 0x7FFF) | 0x8000;
+ return
+ pack(VCE_TEMPLATE, NON_VAR, $aaaa, Min2Wt, Min3Wt, $u),
+ pack(VCE_TEMPLATE, NON_VAR, $bbbb, 0, 0, $u);
+}
+
+sub _derivCE_9 {
+ my $u = shift;
+ my $base =
+ (CJK_UidIni <= $u && $u <= CJK_UidFin)
+ ? 0xFB40 : # CJK
+ (CJK_ExtAIni <= $u && $u <= CJK_ExtAFin ||
+ CJK_ExtBIni <= $u && $u <= CJK_ExtBFin)
+ ? 0xFB80 # CJK ext.
+ : 0xFBC0; # others
+
+ my $aaaa = $base + ($u >> 15);
+ my $bbbb = ($u & 0x7FFF) | 0x8000;
+ return
+ pack(VCE_TEMPLATE, NON_VAR, $aaaa, Min2Wt, Min3Wt, $u),
+ pack(VCE_TEMPLATE, NON_VAR, $bbbb, 0, 0, $u);
+}
+
+sub _derivCE_8 {
+ my $code = shift;
+ my $aaaa = 0xFF80 + ($code >> 15);
+ my $bbbb = ($code & 0x7FFF) | 0x8000;
+ return
+ pack(VCE_TEMPLATE, NON_VAR, $aaaa, 2, 1, $code),
+ pack(VCE_TEMPLATE, NON_VAR, $bbbb, 0, 0, $code);
+}
+
+sub _uideoCE_8 {
+ my $u = shift;
+ return pack(VCE_TEMPLATE, NON_VAR, $u, Min2Wt, Min3Wt, $u);
+}
+
+sub _isUIdeo {
+ my ($u, $uca_vers) = @_;
+ return(
+ (CJK_UidIni <= $u &&
+ ($uca_vers >= 14 ? ( $u <= CJK_UidF41) : ($u <= CJK_UidFin)))
+ ||
+ (CJK_ExtAIni <= $u && $u <= CJK_ExtAFin)
+ ||
+ (CJK_ExtBIni <= $u && $u <= CJK_ExtBFin)
+ );
+}
+
+
+sub getWtHangulTerm {
+ my $self = shift;
+ return _varCE($self->{variable},
+ pack(VCE_TEMPLATE, NON_VAR, $self->{hangul_terminator}, 0,0,0));
+}
+
+
+##
+## "hhhh hhhh hhhh" to (dddd, dddd, dddd)
+##
+sub _getHexArray { map hex, $_[0] =~ /([0-9a-fA-F]+)/g }
+
+#
+# $code *must* be in Hangul syllable.
+# Check it before you enter here.
+#
+sub _decompHangul {
+ my $code = shift;
+ my $si = $code - Hangul_SBase;
+ my $li = int( $si / Hangul_NCount);
+ my $vi = int(($si % Hangul_NCount) / Hangul_TCount);
+ my $ti = $si % Hangul_TCount;
+ return (
+ Hangul_LBase + $li,
+ Hangul_VBase + $vi,
+ $ti ? (Hangul_TBase + $ti) : (),
+ );
+}
+
+sub _isIllegal {
+ my $code = shift;
+ return ! defined $code # removed
+ || ($code < 0 || 0x10FFFF < $code) # out of range
+ || (($code & 0xFFFE) == 0xFFFE) # ??FFF[EF] (cf. utf8.c)
+ || (0xD800 <= $code && $code <= 0xDFFF) # unpaired surrogates
+ || (0xFDD0 <= $code && $code <= 0xFDEF) # other non-characters
+ ;
+}
+
+# Hangul Syllable Type
+sub getHST {
+ my $u = shift;
+ return
+ Hangul_LIni <= $u && $u <= Hangul_LFin || $u == Hangul_LFill ? "L" :
+ Hangul_VIni <= $u && $u <= Hangul_VFin ? "V" :
+ Hangul_TIni <= $u && $u <= Hangul_TFin ? "T" :
+ Hangul_SIni <= $u && $u <= Hangul_SFin ?
+ ($u - Hangul_SBase) % Hangul_TCount ? "LVT" : "LV" : "";
+}
+
+
+##
+## bool _nonIgnorAtLevel(arrayref weights, int level)
+##
+sub _nonIgnorAtLevel($$)
+{
+ my $wt = shift;
+ return if ! defined $wt;
+ my $lv = shift;
+ return grep($wt->[$_-1] != 0, MinLevel..$lv) ? TRUE : FALSE;
+}
+
+##
+## bool _eqArray(
+## arrayref of arrayref[weights] source,
+## arrayref of arrayref[weights] substr,
+## int level)
+## * comparison of graphemes vs graphemes.
+## @$source >= @$substr must be true (check it before call this);
+##
+sub _eqArray($$$)
+{
+ my $source = shift;
+ my $substr = shift;
+ my $lev = shift;
+
+ for my $g (0..@$substr-1){
+ # Do the $g'th graphemes have the same number of AV weigths?
+ return if @{ $source->[$g] } != @{ $substr->[$g] };
+
+ for my $w (0..@{ $substr->[$g] }-1) {
+ for my $v (0..$lev-1) {
+ return if $source->[$g][$w][$v] != $substr->[$g][$w][$v];
+ }
+ }
+ }
+ return 1;
+}
+
+##
+## (int position, int length)
+## int position = index(string, substring, position, [undoc'ed grobal])
+##
+## With "grobal" (only for the list context),
+## returns list of arrayref[position, length].
+##
+sub index
+{
+ my $self = shift;
+ my $str = shift;
+ my $len = length($str);
+ my $subE = $self->splitEnt(shift);
+ my $pos = @_ ? shift : 0;
+ $pos = 0 if $pos < 0;
+ my $grob = shift;
+
+ my $lev = $self->{level};
+ my $v2i = $self->{UCA_Version} >= 9 &&
+ $self->{variable} ne 'non-ignorable';
+
+ if (! @$subE) {
+ my $temp = $pos <= 0 ? 0 : $len <= $pos ? $len : $pos;
+ return $grob
+ ? map([$_, 0], $temp..$len)
+ : wantarray ? ($temp,0) : $temp;
+ }
+ $len < $pos
+ and return wantarray ? () : NOMATCHPOS;
+ my $strE = $self->splitEnt($pos ? substr($str, $pos) : $str, TRUE);
+ @$strE
+ or return wantarray ? () : NOMATCHPOS;
+
+ my(@strWt, @iniPos, @finPos, @subWt, @g_ret);
+
+ my $last_is_variable;
+ for my $vwt (map $self->getWt($_), @$subE) {
+ my($var, @wt) = unpack(VCE_TEMPLATE, $vwt);
+ my $to_be_pushed = _nonIgnorAtLevel(\@wt,$lev);
+
+ # "Ignorable (L1, L2) after Variable" since track. v. 9
+ if ($v2i) {
+ if ($var) {
+ $last_is_variable = TRUE;
+ }
+ elsif (!$wt[0]) { # ignorable
+ $to_be_pushed = FALSE if $last_is_variable;
+ }
+ else {
+ $last_is_variable = FALSE;
+ }
+ }
+
+ if (@subWt && !$var && !$wt[0]) {
+ push @{ $subWt[-1] }, \@wt if $to_be_pushed;
+ } else {
+ push @subWt, [ \@wt ];
+ }
+ }
+
+ my $count = 0;
+ my $end = @$strE - 1;
+
+ $last_is_variable = FALSE; # reuse
+ for (my $i = 0; $i <= $end; ) { # no $i++
+ my $found_base = 0;
+
+ # fetch a grapheme
+ while ($i <= $end && $found_base == 0) {
+ for my $vwt ($self->getWt($strE->[$i][0])) {
+ my($var, @wt) = unpack(VCE_TEMPLATE, $vwt);
+ my $to_be_pushed = _nonIgnorAtLevel(\@wt,$lev);
+
+ # "Ignorable (L1, L2) after Variable" since track. v. 9
+ if ($v2i) {
+ if ($var) {
+ $last_is_variable = TRUE;
+ }
+ elsif (!$wt[0]) { # ignorable
+ $to_be_pushed = FALSE if $last_is_variable;
+ }
+ else {
+ $last_is_variable = FALSE;
+ }
+ }
+
+ if (@strWt && !$var && !$wt[0]) {
+ push @{ $strWt[-1] }, \@wt if $to_be_pushed;
+ $finPos[-1] = $strE->[$i][2];
+ } elsif ($to_be_pushed) {
+ push @strWt, [ \@wt ];
+ push @iniPos, $found_base ? NOMATCHPOS : $strE->[$i][1];
+ $finPos[-1] = NOMATCHPOS if $found_base;
+ push @finPos, $strE->[$i][2];
+ $found_base++;
+ }
+ # else ===> no-op
+ }
+ $i++;
+ }
+
+ # try to match
+ while ( @strWt > @subWt || (@strWt == @subWt && $i > $end) ) {
+ if ($iniPos[0] != NOMATCHPOS &&
+ $finPos[$#subWt] != NOMATCHPOS &&
+ _eqArray(\@strWt, \@subWt, $lev)) {
+ my $temp = $iniPos[0] + $pos;
+
+ if ($grob) {
+ push @g_ret, [$temp, $finPos[$#subWt] - $iniPos[0]];
+ splice @strWt, 0, $#subWt;
+ splice @iniPos, 0, $#subWt;
+ splice @finPos, 0, $#subWt;
+ }
+ else {
+ return wantarray
+ ? ($temp, $finPos[$#subWt] - $iniPos[0])
+ : $temp;
+ }
+ }
+ shift @strWt;
+ shift @iniPos;
+ shift @finPos;
+ }
+ }
+
+ return $grob
+ ? @g_ret
+ : wantarray ? () : NOMATCHPOS;
+}
+
+##
+## scalarref to matching part = match(string, substring)
+##
+sub match
+{
+ my $self = shift;
+ if (my($pos,$len) = $self->index($_[0], $_[1])) {
+ my $temp = substr($_[0], $pos, $len);
+ return wantarray ? $temp : \$temp;
+ # An lvalue ref \substr should be avoided,
+ # since its value is affected by modification of its referent.
+ }
+ else {
+ return;
+ }
+}
+
+##
+## arrayref matching parts = gmatch(string, substring)
+##
+sub gmatch
+{
+ my $self = shift;
+ my $str = shift;
+ my $sub = shift;
+ return map substr($str, $_->[0], $_->[1]),
+ $self->index($str, $sub, 0, 'g');
+}
+
+##
+## bool subst'ed = subst(string, substring, replace)
+##
+sub subst
+{
+ my $self = shift;
+ my $code = ref $_[2] eq 'CODE' ? $_[2] : FALSE;
+
+ if (my($pos,$len) = $self->index($_[0], $_[1])) {
+ if ($code) {
+ my $mat = substr($_[0], $pos, $len);
+ substr($_[0], $pos, $len, $code->($mat));
+ } else {
+ substr($_[0], $pos, $len, $_[2]);
+ }
+ return TRUE;
+ }
+ else {
+ return FALSE;
+ }
+}
+
+##
+## int count = gsubst(string, substring, replace)
+##
+sub gsubst
+{
+ my $self = shift;
+ my $code = ref $_[2] eq 'CODE' ? $_[2] : FALSE;
+ my $cnt = 0;
+
+ # Replacement is carried out from the end, then use reverse.
+ for my $pos_len (reverse $self->index($_[0], $_[1], 0, 'g')) {
+ if ($code) {
+ my $mat = substr($_[0], $pos_len->[0], $pos_len->[1]);
+ substr($_[0], $pos_len->[0], $pos_len->[1], $code->($mat));
+ } else {
+ substr($_[0], $pos_len->[0], $pos_len->[1], $_[2]);
+ }
+ $cnt++;
+ }
+ return $cnt;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Unicode::Collate - Unicode Collation Algorithm
+
+=head1 SYNOPSIS
+
+ use Unicode::Collate;
+
+ #construct
+ $Collator = Unicode::Collate->new(%tailoring);
+
+ #sort
+ @sorted = $Collator->sort(@not_sorted);
+
+ #compare
+ $result = $Collator->cmp($a, $b); # returns 1, 0, or -1.
+
+ # If %tailoring is false (i.e. empty),
+ # $Collator should do the default collation.
+
+=head1 DESCRIPTION
+
+This module is an implementation of Unicode Technical Standard #10
+(a.k.a. UTS #10) - Unicode Collation Algorithm (a.k.a. UCA).
+
+=head2 Constructor and Tailoring
+
+The C<new> method returns a collator object.
+
+ $Collator = Unicode::Collate->new(
+ UCA_Version => $UCA_Version,
+ alternate => $alternate, # deprecated: use of 'variable' is recommended.
+ backwards => $levelNumber, # or \@levelNumbers
+ entry => $element,
+ hangul_terminator => $term_primary_weight,
+ ignoreName => qr/$ignoreName/,
+ ignoreChar => qr/$ignoreChar/,
+ katakana_before_hiragana => $bool,
+ level => $collationLevel,
+ normalization => $normalization_form,
+ overrideCJK => \&overrideCJK,
+ overrideHangul => \&overrideHangul,
+ preprocess => \&preprocess,
+ rearrange => \@charList,
+ table => $filename,
+ undefName => qr/$undefName/,
+ undefChar => qr/$undefChar/,
+ upper_before_lower => $bool,
+ variable => $variable,
+ );
+
+=over 4
+
+=item UCA_Version
+
+If the tracking version number of UCA is given,
+behavior of that tracking version is emulated on collating.
+If omitted, the return value of C<UCA_Version()> is used.
+C<UCA_Version()> should return the latest tracking version supported.
+
+The supported tracking version: 8, 9, 11, or 14.
+
+ UCA Unicode Standard DUCET (@version)
+ ---------------------------------------------------
+ 8 3.1 3.0.1 (3.0.1d9)
+ 9 3.1 with Corrigendum 3 3.1.1 (3.1.1)
+ 11 4.0 4.0.0 (4.0.0)
+ 14 4.1.0 4.1.0 (4.1.0)
+
+Note: Recent UTS #10 renames "Tracking Version" to "Revision."
+
+=item alternate
+
+-- see 3.2.2 Alternate Weighting, version 8 of UTS #10
+
+For backward compatibility, C<alternate> (old name) can be used
+as an alias for C<variable>.
+
+=item backwards
+
+-- see 3.1.2 French Accents, UTS #10.
+
+ backwards => $levelNumber or \@levelNumbers
+
+Weights in reverse order; ex. level 2 (diacritic ordering) in French.
+If omitted, forwards at all the levels.
+
+=item entry
+
+-- see 3.1 Linguistic Features; 3.2.1 File Format, UTS #10.
+
+If the same character (or a sequence of characters) exists
+in the collation element table through C<table>,
+mapping to collation elements is overrided.
+If it does not exist, the mapping is defined additionally.
+
+ entry => <<'ENTRY', # for DUCET v4.0.0 (allkeys-4.0.0.txt)
+0063 0068 ; [.0E6A.0020.0002.0063] # ch
+0043 0068 ; [.0E6A.0020.0007.0043] # Ch
+0043 0048 ; [.0E6A.0020.0008.0043] # CH
+006C 006C ; [.0F4C.0020.0002.006C] # ll
+004C 006C ; [.0F4C.0020.0007.004C] # Ll
+004C 004C ; [.0F4C.0020.0008.004C] # LL
+00F1 ; [.0F7B.0020.0002.00F1] # n-tilde
+006E 0303 ; [.0F7B.0020.0002.00F1] # n-tilde
+00D1 ; [.0F7B.0020.0008.00D1] # N-tilde
+004E 0303 ; [.0F7B.0020.0008.00D1] # N-tilde
+ENTRY
+
+ entry => <<'ENTRY', # for DUCET v4.0.0 (allkeys-4.0.0.txt)
+00E6 ; [.0E33.0020.0002.00E6][.0E8B.0020.0002.00E6] # ae ligature as <a><e>
+00C6 ; [.0E33.0020.0008.00C6][.0E8B.0020.0008.00C6] # AE ligature as <A><E>
+ENTRY
+
+B<NOTE:> The code point in the UCA file format (before C<';'>)
+B<must> be a Unicode code point (defined as hexadecimal),
+but not a native code point.
+So C<0063> must always denote C<U+0063>,
+but not a character of C<"\x63">.
+
+Weighting may vary depending on collation element table.
+So ensure the weights defined in C<entry> will be consistent with
+those in the collation element table loaded via C<table>.
+
+In DUCET v4.0.0, primary weight of C<C> is C<0E60>
+and that of C<D> is C<0E6D>. So setting primary weight of C<CH> to C<0E6A>
+(as a value between C<0E60> and C<0E6D>)
+makes ordering as C<C E<lt> CH E<lt> D>.
+Exactly speaking DUCET already has some characters between C<C> and C<D>:
+C<small capital C> (C<U+1D04>) with primary weight C<0E64>,
+C<c-hook/C-hook> (C<U+0188/U+0187>) with C<0E65>,
+and C<c-curl> (C<U+0255>) with C<0E69>.
+Then primary weight C<0E6A> for C<CH> makes C<CH>
+ordered between C<c-curl> and C<D>.
+
+=item hangul_terminator
+
+-- see 7.1.4 Trailing Weights, UTS #10.
+
+If a true value is given (non-zero but should be positive),
+it will be added as a terminator primary weight to the end of
+every standard Hangul syllable. Secondary and any higher weights
+for terminator are set to zero.
+If the value is false or C<hangul_terminator> key does not exist,
+insertion of terminator weights will not be performed.
+
+Boundaries of Hangul syllables are determined
+according to conjoining Jamo behavior in F<the Unicode Standard>
+and F<HangulSyllableType.txt>.
+
+B<Implementation Note:>
+(1) For expansion mapping (Unicode character mapped
+to a sequence of collation elements), a terminator will not be added
+between collation elements, even if Hangul syllable boundary exists there.
+Addition of terminator is restricted to the next position
+to the last collation element.
+
+(2) Non-conjoining Hangul letters
+(Compatibility Jamo, halfwidth Jamo, and enclosed letters) are not
+automatically terminated with a terminator primary weight.
+These characters may need terminator included in a collation element
+table beforehand.
+
+=item ignoreChar
+
+=item ignoreName
+
+-- see 3.2.2 Variable Weighting, UTS #10.
+
+Makes the entry in the table completely ignorable;
+i.e. as if the weights were zero at all level.
+
+Through C<ignoreChar>, any character matching C<qr/$ignoreChar/>
+will be ignored. Through C<ignoreName>, any character whose name
+(given in the C<table> file as a comment) matches C<qr/$ignoreName/>
+will be ignored.
+
+E.g. when 'a' and 'e' are ignorable,
+'element' is equal to 'lament' (or 'lmnt').
+
+=item katakana_before_hiragana
+
+-- see 7.3.1 Tertiary Weight Table, UTS #10.
+
+By default, hiragana is before katakana.
+If the parameter is made true, this is reversed.
+
+B<NOTE>: This parameter simplemindedly assumes that any hiragana/katakana
+distinctions must occur in level 3, and their weights at level 3 must be
+same as those mentioned in 7.3.1, UTS #10.
+If you define your collation elements which violate this requirement,
+this parameter does not work validly.
+
+=item level
+
+-- see 4.3 Form Sort Key, UTS #10.
+
+Set the maximum level.
+Any higher levels than the specified one are ignored.
+
+ Level 1: alphabetic ordering
+ Level 2: diacritic ordering
+ Level 3: case ordering
+ Level 4: tie-breaking (e.g. in the case when variable is 'shifted')
+
+ ex.level => 2,
+
+If omitted, the maximum is the 4th.
+
+=item normalization
+
+-- see 4.1 Normalize, UTS #10.
+
+If specified, strings are normalized before preparation of sort keys
+(the normalization is executed after preprocess).
+
+A form name C<Unicode::Normalize::normalize()> accepts will be applied
+as C<$normalization_form>.
+Acceptable names include C<'NFD'>, C<'NFC'>, C<'NFKD'>, and C<'NFKC'>.
+See C<Unicode::Normalize::normalize()> for detail.
+If omitted, C<'NFD'> is used.
+
+C<normalization> is performed after C<preprocess> (if defined).
+
+Furthermore, special values, C<undef> and C<"prenormalized">, can be used,
+though they are not concerned with C<Unicode::Normalize::normalize()>.
+
+If C<undef> (not a string C<"undef">) is passed explicitly
+as the value for this key,
+any normalization is not carried out (this may make tailoring easier
+if any normalization is not desired). Under C<(normalization =E<gt> undef)>,
+only contiguous contractions are resolved;
+e.g. even if C<A-ring> (and C<A-ring-cedilla>) is ordered after C<Z>,
+C<A-cedilla-ring> would be primary equal to C<A>.
+In this point,
+C<(normalization =E<gt> undef, preprocess =E<gt> sub { NFD(shift) })>
+B<is not> equivalent to C<(normalization =E<gt> 'NFD')>.
+
+In the case of C<(normalization =E<gt> "prenormalized")>,
+any normalization is not performed, but
+non-contiguous contractions with combining characters are performed.
+Therefore
+C<(normalization =E<gt> 'prenormalized', preprocess =E<gt> sub { NFD(shift) })>
+B<is> equivalent to C<(normalization =E<gt> 'NFD')>.
+If source strings are finely prenormalized,
+C<(normalization =E<gt> 'prenormalized')> may save time for normalization.
+
+Except C<(normalization =E<gt> undef)>,
+B<Unicode::Normalize> is required (see also B<CAVEAT>).
+
+=item overrideCJK
+
+-- see 7.1 Derived Collation Elements, UTS #10.
+
+By default, CJK Unified Ideographs are ordered in Unicode codepoint order
+but C<CJK Unified Ideographs> (if C<UCA_Version> is 8 to 11, its range is
+C<U+4E00..U+9FA5>; if C<UCA_Version> is 14, its range is C<U+4E00..U+9FBB>)
+are lesser than C<CJK Unified Ideographs Extension> (its range is
+C<U+3400..U+4DB5> and C<U+20000..U+2A6D6>).
+
+Through C<overrideCJK>, ordering of CJK Unified Ideographs can be overrided.
+
+ex. CJK Unified Ideographs in the JIS code point order.
+
+ overrideCJK => sub {
+ my $u = shift; # get a Unicode codepoint
+ my $b = pack('n', $u); # to UTF-16BE
+ my $s = your_unicode_to_sjis_converter($b); # convert
+ my $n = unpack('n', $s); # convert sjis to short
+ [ $n, 0x20, 0x2, $u ]; # return the collation element
+ },
+
+ex. ignores all CJK Unified Ideographs.
+
+ overrideCJK => sub {()}, # CODEREF returning empty list
+
+ # where ->eq("Pe\x{4E00}rl", "Perl") is true
+ # as U+4E00 is a CJK Unified Ideograph and to be ignorable.
+
+If C<undef> is passed explicitly as the value for this key,
+weights for CJK Unified Ideographs are treated as undefined.
+But assignment of weight for CJK Unified Ideographs
+in table or C<entry> is still valid.
+
+=item overrideHangul
+
+-- see 7.1 Derived Collation Elements, UTS #10.
+
+By default, Hangul Syllables are decomposed into Hangul Jamo,
+even if C<(normalization =E<gt> undef)>.
+But the mapping of Hangul Syllables may be overrided.
+
+This parameter works like C<overrideCJK>, so see there for examples.
+
+If you want to override the mapping of Hangul Syllables,
+NFD, NFKD, and FCD are not appropriate,
+since they will decompose Hangul Syllables before overriding.
+
+If C<undef> is passed explicitly as the value for this key,
+weight for Hangul Syllables is treated as undefined
+without decomposition into Hangul Jamo.
+But definition of weight for Hangul Syllables
+in table or C<entry> is still valid.
+
+=item preprocess
+
+-- see 5.1 Preprocessing, UTS #10.
+
+If specified, the coderef is used to preprocess
+before the formation of sort keys.
+
+ex. dropping English articles, such as "a" or "the".
+Then, "the pen" is before "a pencil".
+
+ preprocess => sub {
+ my $str = shift;
+ $str =~ s/\b(?:an?|the)\s+//gi;
+ return $str;
+ },
+
+C<preprocess> is performed before C<normalization> (if defined).
+
+=item rearrange
+
+-- see 3.1.3 Rearrangement, UTS #10.
+
+Characters that are not coded in logical order and to be rearranged.
+If C<UCA_Version> is equal to or lesser than 11, default is:
+
+ rearrange => [ 0x0E40..0x0E44, 0x0EC0..0x0EC4 ],
+
+If you want to disallow any rearrangement, pass C<undef> or C<[]>
+(a reference to empty list) as the value for this key.
+
+If C<UCA_Version> is equal to 14, default is C<[]> (i.e. no rearrangement).
+
+B<According to the version 9 of UCA, this parameter shall not be used;
+but it is not warned at present.>
+
+=item table
+
+-- see 3.2 Default Unicode Collation Element Table, UTS #10.
+
+You can use another collation element table if desired.
+
+The table file should locate in the F<Unicode/Collate> directory
+on C<@INC>. Say, if the filename is F<Foo.txt>,
+the table file is searched as F<Unicode/Collate/Foo.txt> in C<@INC>.
+
+By default, F<allkeys.txt> (as the filename of DUCET) is used.
+If you will prepare your own table file, any name other than F<allkeys.txt>
+may be better to avoid namespace conflict.
+
+If C<undef> is passed explicitly as the value for this key,
+no file is read (but you can define collation elements via C<entry>).
+
+A typical way to define a collation element table
+without any file of table:
+
+ $onlyABC = Unicode::Collate->new(
+ table => undef,
+ entry => << 'ENTRIES',
+0061 ; [.0101.0020.0002.0061] # LATIN SMALL LETTER A
+0041 ; [.0101.0020.0008.0041] # LATIN CAPITAL LETTER A
+0062 ; [.0102.0020.0002.0062] # LATIN SMALL LETTER B
+0042 ; [.0102.0020.0008.0042] # LATIN CAPITAL LETTER B
+0063 ; [.0103.0020.0002.0063] # LATIN SMALL LETTER C
+0043 ; [.0103.0020.0008.0043] # LATIN CAPITAL LETTER C
+ENTRIES
+ );
+
+If C<ignoreName> or C<undefName> is used, character names should be
+specified as a comment (following C<#>) on each line.
+
+=item undefChar
+
+=item undefName
+
+-- see 6.3.4 Reducing the Repertoire, UTS #10.
+
+Undefines the collation element as if it were unassigned in the table.
+This reduces the size of the table.
+If an unassigned character appears in the string to be collated,
+the sort key is made from its codepoint
+as a single-character collation element,
+as it is greater than any other assigned collation elements
+(in the codepoint order among the unassigned characters).
+But, it'd be better to ignore characters
+unfamiliar to you and maybe never used.
+
+Through C<undefChar>, any character matching C<qr/$undefChar/>
+will be undefined. Through C<undefName>, any character whose name
+(given in the C<table> file as a comment) matches C<qr/$undefName/>
+will be undefined.
+
+ex. Collation weights for beyond-BMP characters are not stored in object:
+
+ undefChar => qr/[^\0-\x{fffd}]/,
+
+=item upper_before_lower
+
+-- see 6.6 Case Comparisons, UTS #10.
+
+By default, lowercase is before uppercase.
+If the parameter is made true, this is reversed.
+
+B<NOTE>: This parameter simplemindedly assumes that any lowercase/uppercase
+distinctions must occur in level 3, and their weights at level 3 must be
+same as those mentioned in 7.3.1, UTS #10.
+If you define your collation elements which differs from this requirement,
+this parameter doesn't work validly.
+
+=item variable
+
+-- see 3.2.2 Variable Weighting, UTS #10.
+
+This key allows to variable weighting for variable collation elements,
+which are marked with an ASTERISK in the table
+(NOTE: Many punction marks and symbols are variable in F<allkeys.txt>).
+
+ variable => 'blanked', 'non-ignorable', 'shifted', or 'shift-trimmed'.
+
+These names are case-insensitive.
+By default (if specification is omitted), 'shifted' is adopted.
+
+ 'Blanked' Variable elements are made ignorable at levels 1 through 3;
+ considered at the 4th level.
+
+ 'Non-Ignorable' Variable elements are not reset to ignorable.
+
+ 'Shifted' Variable elements are made ignorable at levels 1 through 3
+ their level 4 weight is replaced by the old level 1 weight.
+ Level 4 weight for Non-Variable elements is 0xFFFF.
+
+ 'Shift-Trimmed' Same as 'shifted', but all FFFF's at the 4th level
+ are trimmed.
+
+=back
+
+=head2 Methods for Collation
+
+=over 4
+
+=item C<@sorted = $Collator-E<gt>sort(@not_sorted)>
+
+Sorts a list of strings.
+
+=item C<$result = $Collator-E<gt>cmp($a, $b)>
+
+Returns 1 (when C<$a> is greater than C<$b>)
+or 0 (when C<$a> is equal to C<$b>)
+or -1 (when C<$a> is lesser than C<$b>).
+
+=item C<$result = $Collator-E<gt>eq($a, $b)>
+
+=item C<$result = $Collator-E<gt>ne($a, $b)>
+
+=item C<$result = $Collator-E<gt>lt($a, $b)>
+
+=item C<$result = $Collator-E<gt>le($a, $b)>
+
+=item C<$result = $Collator-E<gt>gt($a, $b)>
+
+=item C<$result = $Collator-E<gt>ge($a, $b)>
+
+They works like the same name operators as theirs.
+
+ eq : whether $a is equal to $b.
+ ne : whether $a is not equal to $b.
+ lt : whether $a is lesser than $b.
+ le : whether $a is lesser than $b or equal to $b.
+ gt : whether $a is greater than $b.
+ ge : whether $a is greater than $b or equal to $b.
+
+=item C<$sortKey = $Collator-E<gt>getSortKey($string)>
+
+-- see 4.3 Form Sort Key, UTS #10.
+
+Returns a sort key.
+
+You compare the sort keys using a binary comparison
+and get the result of the comparison of the strings using UCA.
+
+ $Collator->getSortKey($a) cmp $Collator->getSortKey($b)
+
+ is equivalent to
+
+ $Collator->cmp($a, $b)
+
+=item C<$sortKeyForm = $Collator-E<gt>viewSortKey($string)>
+
+Converts a sorting key into its representation form.
+If C<UCA_Version> is 8, the output is slightly different.
+
+ use Unicode::Collate;
+ my $c = Unicode::Collate->new();
+ print $c->viewSortKey("Perl"),"\n";
+
+ # output:
+ # [0B67 0A65 0B7F 0B03 | 0020 0020 0020 0020 | 0008 0002 0002 0002 | FFFF FFFF FFFF FFFF]
+ # Level 1 Level 2 Level 3 Level 4
+
+=back
+
+=head2 Methods for Searching
+
+B<DISCLAIMER:> If C<preprocess> or C<normalization> parameter is true
+for C<$Collator>, calling these methods (C<index>, C<match>, C<gmatch>,
+C<subst>, C<gsubst>) is croaked,
+as the position and the length might differ
+from those on the specified string.
+(And C<rearrange> and C<hangul_terminator> parameters are neglected.)
+
+The C<match>, C<gmatch>, C<subst>, C<gsubst> methods work
+like C<m//>, C<m//g>, C<s///>, C<s///g>, respectively,
+but they are not aware of any pattern, but only a literal substring.
+
+=over 4
+
+=item C<$position = $Collator-E<gt>index($string, $substring[, $position])>
+
+=item C<($position, $length) = $Collator-E<gt>index($string, $substring[, $position])>
+
+If C<$substring> matches a part of C<$string>, returns
+the position of the first occurrence of the matching part in scalar context;
+in list context, returns a two-element list of
+the position and the length of the matching part.
+
+If C<$substring> does not match any part of C<$string>,
+returns C<-1> in scalar context and
+an empty list in list context.
+
+e.g. you say
+
+ my $Collator = Unicode::Collate->new( normalization => undef, level => 1 );
+ # (normalization => undef) is REQUIRED.
+ my $str = "Ich mu\xDF studieren Perl.";
+ my $sub = "M\xDCSS";
+ my $match;
+ if (my($pos,$len) = $Collator->index($str, $sub)) {
+ $match = substr($str, $pos, $len);
+ }
+
+and get C<"mu\xDF"> in C<$match> since C<"mu\xDF">
+is primary equal to C<"M\xDCSS">.
+
+=item C<$match_ref = $Collator-E<gt>match($string, $substring)>
+
+=item C<($match) = $Collator-E<gt>match($string, $substring)>
+
+If C<$substring> matches a part of C<$string>, in scalar context, returns
+B<a reference to> the first occurrence of the matching part
+(C<$match_ref> is always true if matches,
+since every reference is B<true>);
+in list context, returns the first occurrence of the matching part.
+
+If C<$substring> does not match any part of C<$string>,
+returns C<undef> in scalar context and
+an empty list in list context.
+
+e.g.
+
+ if ($match_ref = $Collator->match($str, $sub)) { # scalar context
+ print "matches [$$match_ref].\n";
+ } else {
+ print "doesn't match.\n";
+ }
+
+ or
+
+ if (($match) = $Collator->match($str, $sub)) { # list context
+ print "matches [$match].\n";
+ } else {
+ print "doesn't match.\n";
+ }
+
+=item C<@match = $Collator-E<gt>gmatch($string, $substring)>
+
+If C<$substring> matches a part of C<$string>, returns
+all the matching parts (or matching count in scalar context).
+
+If C<$substring> does not match any part of C<$string>,
+returns an empty list.
+
+=item C<$count = $Collator-E<gt>subst($string, $substring, $replacement)>
+
+If C<$substring> matches a part of C<$string>,
+the first occurrence of the matching part is replaced by C<$replacement>
+(C<$string> is modified) and return C<$count> (always equals to C<1>).
+
+C<$replacement> can be a C<CODEREF>,
+taking the matching part as an argument,
+and returning a string to replace the matching part
+(a bit similar to C<s/(..)/$coderef-E<gt>($1)/e>).
+
+=item C<$count = $Collator-E<gt>gsubst($string, $substring, $replacement)>
+
+If C<$substring> matches a part of C<$string>,
+all the occurrences of the matching part is replaced by C<$replacement>
+(C<$string> is modified) and return C<$count>.
+
+C<$replacement> can be a C<CODEREF>,
+taking the matching part as an argument,
+and returning a string to replace the matching part
+(a bit similar to C<s/(..)/$coderef-E<gt>($1)/eg>).
+
+e.g.
+
+ my $Collator = Unicode::Collate->new( normalization => undef, level => 1 );
+ # (normalization => undef) is REQUIRED.
+ my $str = "Camel donkey zebra came\x{301}l CAMEL horse cAm\0E\0L...";
+ $Collator->gsubst($str, "camel", sub { "<b>$_[0]</b>" });
+
+ # now $str is "<b>Camel</b> donkey zebra <b>came\x{301}l</b> <b>CAMEL</b> horse <b>cAm\0E\0L</b>...";
+ # i.e., all the camels are made bold-faced.
+
+=back
+
+=head2 Other Methods
+
+=over 4
+
+=item C<%old_tailoring = $Collator-E<gt>change(%new_tailoring)>
+
+Change the value of specified keys and returns the changed part.
+
+ $Collator = Unicode::Collate->new(level => 4);
+
+ $Collator->eq("perl", "PERL"); # false
+
+ %old = $Collator->change(level => 2); # returns (level => 4).
+
+ $Collator->eq("perl", "PERL"); # true
+
+ $Collator->change(%old); # returns (level => 2).
+
+ $Collator->eq("perl", "PERL"); # false
+
+Not all C<(key,value)>s are allowed to be changed.
+See also C<@Unicode::Collate::ChangeOK> and C<@Unicode::Collate::ChangeNG>.
+
+In the scalar context, returns the modified collator
+(but it is B<not> a clone from the original).
+
+ $Collator->change(level => 2)->eq("perl", "PERL"); # true
+
+ $Collator->eq("perl", "PERL"); # true; now max level is 2nd.
+
+ $Collator->change(level => 4)->eq("perl", "PERL"); # false
+
+=item C<$version = $Collator-E<gt>version()>
+
+Returns the version number (a string) of the Unicode Standard
+which the C<table> file used by the collator object is based on.
+If the table does not include a version line (starting with C<@version>),
+returns C<"unknown">.
+
+=item C<UCA_Version()>
+
+Returns the tracking version number of UTS #10 this module consults.
+
+=item C<Base_Unicode_Version()>
+
+Returns the version number of UTS #10 this module consults.
+
+=back
+
+=head1 EXPORT
+
+No method will be exported.
+
+=head1 INSTALL
+
+Though this module can be used without any C<table> file,
+to use this module easily, it is recommended to install a table file
+in the UCA format, by copying it under the directory
+<a place in @INC>/Unicode/Collate.
+
+The most preferable one is "The Default Unicode Collation Element Table"
+(aka DUCET), available from the Unicode Consortium's website:
+
+ http://www.unicode.org/Public/UCA/
+
+ http://www.unicode.org/Public/UCA/latest/allkeys.txt (latest version)
+
+If DUCET is not installed, it is recommended to copy the file
+from http://www.unicode.org/Public/UCA/latest/allkeys.txt
+to <a place in @INC>/Unicode/Collate/allkeys.txt
+manually.
+
+=head1 CAVEATS
+
+=over 4
+
+=item Normalization
+
+Use of the C<normalization> parameter requires the B<Unicode::Normalize>
+module (see L<Unicode::Normalize>).
+
+If you need not it (say, in the case when you need not
+handle any combining characters),
+assign C<normalization =E<gt> undef> explicitly.
+
+-- see 6.5 Avoiding Normalization, UTS #10.
+
+=item Conformance Test
+
+The Conformance Test for the UCA is available
+under L<http://www.unicode.org/Public/UCA/>.
+
+For F<CollationTest_SHIFTED.txt>,
+a collator via C<Unicode::Collate-E<gt>new( )> should be used;
+for F<CollationTest_NON_IGNORABLE.txt>, a collator via
+C<Unicode::Collate-E<gt>new(variable =E<gt> "non-ignorable", level =E<gt> 3)>.
+
+B<Unicode::Normalize is required to try The Conformance Test.>
+
+=back
+
+=head1 AUTHOR, COPYRIGHT AND LICENSE
+
+The Unicode::Collate module for perl was written by SADAHIRO Tomoyuki,
+<SADAHIRO at cpan.org>. This module is Copyright(C) 2001-2005,
+SADAHIRO Tomoyuki. Japan. All rights reserved.
+
+This module is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+The file Unicode/Collate/allkeys.txt was copied directly
+from L<http://www.unicode.org/Public/UCA/4.1.0/allkeys.txt>.
+This file is Copyright (c) 1991-2005 Unicode, Inc. All rights reserved.
+Distributed under the Terms of Use in L<http://www.unicode.org/copyright.html>.
+
+=head1 SEE ALSO
+
+=over 4
+
+=item Unicode Collation Algorithm - UTS #10
+
+L<http://www.unicode.org/reports/tr10/>
+
+=item The Default Unicode Collation Element Table (DUCET)
+
+L<http://www.unicode.org/Public/UCA/latest/allkeys.txt>
+
+=item The conformance test for the UCA
+
+L<http://www.unicode.org/Public/UCA/latest/CollationTest.html>
+
+L<http://www.unicode.org/Public/UCA/latest/CollationTest.zip>
+
+=item Hangul Syllable Type
+
+L<http://www.unicode.org/Public/UNIDATA/HangulSyllableType.txt>
+
+=item Unicode Normalization Forms - UAX #15
+
+L<http://www.unicode.org/reports/tr15/>
+
+=back
+
+=cut
Index: trunk/contrib/perl/lib/Unicode/README
===================================================================
--- trunk/contrib/perl/lib/Unicode/README 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Unicode/README 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/Unicode/README
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/lib/Unicode/UCD.pm
===================================================================
--- trunk/contrib/perl/lib/Unicode/UCD.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Unicode/UCD.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -4,12 +4,9 @@
use warnings;
no warnings 'surrogate'; # surrogates can be inputs to this
use charnames ();
-use Unicode::Normalize qw(getCombinClass NFKD);
-our $VERSION = '0.32';
+our $VERSION = '0.51';
-use Storable qw(dclone);
-
require Exporter;
our @ISA = qw(Exporter);
@@ -20,9 +17,14 @@
charinrange
general_categories bidi_types
compexcl
- casefold casespec
+ casefold all_casefolds casespec
namedseq
num
+ prop_aliases
+ prop_value_aliases
+ prop_invlist
+ prop_invmap
+ MAX_CP
);
use Carp;
@@ -39,6 +41,9 @@
use Unicode::UCD 'casefold';
my $casefold = casefold(0xFB00);
+ use Unicode::UCD 'all_casefolds';
+ my $all_casefolds_ref = all_casefolds();
+
use Unicode::UCD 'casespec';
my $casespec = casespec(0xFB00);
@@ -62,6 +67,19 @@
my $categories = general_categories();
my $types = bidi_types();
+ use Unicode::UCD 'prop_aliases';
+ my @space_names = prop_aliases("space");
+
+ use Unicode::UCD 'prop_value_aliases';
+ my @gc_punct_names = prop_value_aliases("Gc", "Punct");
+
+ use Unicode::UCD 'prop_invlist';
+ my @puncts = prop_invlist("gc=punctuation");
+
+ use Unicode::UCD 'prop_invmap';
+ my ($list_ref, $map_ref, $format, $missing)
+ = prop_invmap("General Category");
+
use Unicode::UCD 'compexcl';
my $compexcl = compexcl($codepoint);
@@ -71,7 +89,7 @@
my $unicode_version = Unicode::UCD::UnicodeVersion();
my $convert_to_numeric =
- Unicode::UCD::num("\N{RUMI DIGIT ONE}\N{RUMI DIGIT TWO}");
+ Unicode::UCD::num("\N{RUMI DIGIT ONE}\N{RUMI DIGIT TWO}");
=head1 DESCRIPTION
@@ -86,8 +104,17 @@
followed by hexadecimals designating a Unicode code point. In other words, if
you want a code point to be interpreted as a hexadecimal number, you must
prefix it with either C<0x> or C<U+>, because a string like e.g. C<123> will be
-interpreted as a decimal code point. Note that the largest code point in
-Unicode is U+10FFFF.
+interpreted as a decimal code point.
+
+Examples:
+
+ 223 # Decimal 223
+ 0223 # Hexadecimal 223 (= 547 decimal)
+ 0xDF # Hexadecimal DF (= 223 decimal
+ U+DF # Hexadecimal DF
+
+Note that the largest code point in Unicode is U+10FFFF.
+
=cut
my $BLOCKSFH;
@@ -95,6 +122,7 @@
my $CASEFOLDFH;
my $CASESPECFH;
my $NAMEDSEQFH;
+my $v_unicode_version; # v-string.
sub openunicode {
my ($rfh, @path) = @_;
@@ -113,6 +141,35 @@
return $f;
}
+sub _dclone ($) { # Use Storable::dclone if available; otherwise emulate it.
+
+ use if defined &DynaLoader::boot_DynaLoader, Storable => qw(dclone);
+
+ return dclone(shift) if defined &dclone;
+
+ my $arg = shift;
+ my $type = ref $arg;
+ return $arg unless $type; # No deep cloning needed for scalars
+
+ if ($type eq 'ARRAY') {
+ my @return;
+ foreach my $element (@$arg) {
+ push @return, &_dclone($element);
+ }
+ return \@return;
+ }
+ elsif ($type eq 'HASH') {
+ my %return;
+ foreach my $key (keys %$arg) {
+ $return{$key} = &_dclone($arg->{$key});
+ }
+ return \%return;
+ }
+ else {
+ croak "_dclone can't handle " . $type;
+ }
+}
+
=head2 B<charinfo()>
use Unicode::UCD 'charinfo';
@@ -125,7 +182,7 @@
(i.e., has the general category C<Cn> meaning C<Unassigned>)
or is a non-character (meaning it is guaranteed to never be assigned in
the standard),
-B<undef> is returned.
+C<undef> is returned.
Fields that aren't applicable to the particular code point argument exist in the
returned hash, and are empty.
@@ -154,6 +211,9 @@
The short name of the general category of I<code>.
This will match one of the keys in the hash returned by L</general_categories()>.
+The L</prop_value_aliases()> function can be used to get all the synonyms
+of the category name.
+
=item B<combining>
the combining class number for I<code> used in the Canonical Ordering Algorithm.
@@ -161,15 +221,21 @@
available at
L<http://www.unicode.org/versions/Unicode5.1.0/>
+The L</prop_value_aliases()> function can be used to get all the synonyms
+of the combining class number.
+
=item B<bidi>
bidirectional type of I<code>.
This will match one of the keys in the hash returned by L</bidi_types()>.
+The L</prop_value_aliases()> function can be used to get all the synonyms
+of the bidi type name.
+
=item B<decomposition>
is empty if I<code> has no decomposition; or is one or more codes
-(separated by spaces) that taken in order represent a decomposition for
+(separated by spaces) that, taken in order, represent a decomposition for
I<code>. Each has at least four hexdigits.
The codes may be preceded by a word enclosed in angle brackets then a space,
like C<E<lt>compatE<gt> >, giving the type of decomposition
@@ -233,13 +299,13 @@
=item B<block>
-block I<code> belongs to (used in C<\p{Blk=...}>).
+the block I<code> belongs to (used in C<\p{Blk=...}>).
See L</Blocks versus Scripts>.
=item B<script>
-script I<code> belongs to.
+the script I<code> belongs to.
See L</Blocks versus Scripts>.
=back
@@ -271,35 +337,12 @@
my @CATEGORIES;
my @DECOMPOSITIONS;
my @NUMERIC_TYPES;
-my @SIMPLE_LOWER;
-my @SIMPLE_TITLE;
-my @SIMPLE_UPPER;
-my @UNICODE_1_NAMES;
+my %SIMPLE_LOWER;
+my %SIMPLE_TITLE;
+my %SIMPLE_UPPER;
+my %UNICODE_1_NAMES;
+my %ISO_COMMENT;
-sub _charinfo_case {
-
- # Returns the value to set into one of the case fields in the charinfo
- # structure.
- # $char is the character,
- # $cased is the case-changed character
- # $file is the file in lib/unicore/To/$file that contains the data
- # needed for this, in the form that _search() understands.
- # $array_ref points to the array holding the contents of $file. It will
- # be populated if empty.
- # By using the 'uc', etc. functions, we avoid loading more files into
- # memory except for those rare cases where the simple casing (which has
- # been what charinfo() has always returned, is different than the full
- # casing.
- my ($char, $cased, $file, $array_ref) = @_;
-
- return "" if $cased eq $char;
-
- return sprintf("%04X", ord $cased) if length($cased) == 1;
-
- @$array_ref =_read_table("unicore/To/$file") unless @$array_ref;
- return _search($array_ref, 0, $#$array_ref, ord $char) // "";
-}
-
sub charinfo {
# This function has traditionally mimicked what is in UnicodeData.txt,
@@ -311,6 +354,9 @@
use feature 'unicode_strings';
+ # Will fail if called under minitest
+ use if defined &DynaLoader::boot_DynaLoader, "Unicode::Normalize" => qw(getCombinClass NFD);
+
my $arg = shift;
my $code = _getcode($arg);
croak __PACKAGE__, "::charinfo: unknown code '$arg'" unless defined $code;
@@ -321,7 +367,7 @@
my %prop;
my $char = chr($code);
- @CATEGORIES =_read_table("unicore/To/Gc.pl") unless @CATEGORIES;
+ @CATEGORIES =_read_table("To/Gc.pl") unless @CATEGORIES;
$prop{'category'} = _search(\@CATEGORIES, 0, $#CATEGORIES, $code)
// $utf8::SwashInfo{'ToGc'}{'missing'};
@@ -333,7 +379,7 @@
$prop{'combining'} = getCombinClass($code);
- @BIDIS =_read_table("unicore/To/Bc.pl") unless @BIDIS;
+ @BIDIS =_read_table("To/Bc.pl") unless @BIDIS;
$prop{'bidi'} = _search(\@BIDIS, 0, $#BIDIS, $code)
// $utf8::SwashInfo{'ToBc'}{'missing'};
@@ -340,22 +386,24 @@
# For most code points, we can just read in "unicore/Decomposition.pl", as
# its contents are exactly what should be output. But that file doesn't
# contain the data for the Hangul syllable decompositions, which can be
- # algorithmically computed, and NFKD() does that, so we call NFKD() for
- # those. We can't use NFKD() for everything, as it does a complete
+ # algorithmically computed, and NFD() does that, so we call NFD() for
+ # those. We can't use NFD() for everything, as it does a complete
# recursive decomposition, and what this function has always done is to
- # return what's in UnicodeData.txt which doesn't have the recursivenss
- # specified.
- # in the decomposition types. No decomposition implies an empty field;
- # otherwise, all but "Canonical" imply a compatible decomposition, and
- # the type is prefixed to that, as it is in UnicodeData.txt
- if ($char =~ /\p{Block=Hangul_Syllables}/) {
+ # return what's in UnicodeData.txt which doesn't show that recursiveness.
+ # Fortunately, the NFD() of the Hanguls doesn't have any recursion
+ # issues.
+ # Having no decomposition implies an empty field; otherwise, all but
+ # "Canonical" imply a compatible decomposition, and the type is prefixed
+ # to that, as it is in UnicodeData.txt
+ UnicodeVersion() unless defined $v_unicode_version;
+ if ($v_unicode_version ge v2.0.0 && $char =~ /\p{Block=Hangul_Syllables}/) {
# The code points of the decomposition are output in standard Unicode
# hex format, separated by blanks.
$prop{'decomposition'} = join " ", map { sprintf("%04X", $_)}
- unpack "U*", NFKD($char);
+ unpack "U*", NFD($char);
}
else {
- @DECOMPOSITIONS = _read_table("unicore/Decomposition.pl")
+ @DECOMPOSITIONS = _read_table("Decomposition.pl")
unless @DECOMPOSITIONS;
$prop{'decomposition'} = _search(\@DECOMPOSITIONS, 0, $#DECOMPOSITIONS,
$code) // "";
@@ -377,8 +425,7 @@
# e.g., TAMIL NUMBER TEN.
$prop{'decimal'} = "";
- @NUMERIC_TYPES =_read_table("unicore/To/Nt.pl")
- unless @NUMERIC_TYPES;
+ @NUMERIC_TYPES =_read_table("To/Nt.pl") unless @NUMERIC_TYPES;
if ((_search(\@NUMERIC_TYPES, 0, $#NUMERIC_TYPES, $code) // "")
eq 'Digit')
{
@@ -393,19 +440,35 @@
$prop{'mirrored'} = ($char =~ /\p{Bidi_Mirrored}/) ? 'Y' : 'N';
- @UNICODE_1_NAMES =_read_table("unicore/To/Na1.pl") unless @UNICODE_1_NAMES;
- $prop{'unicode10'} = _search(\@UNICODE_1_NAMES, 0, $#UNICODE_1_NAMES, $code)
- // "";
+ %UNICODE_1_NAMES =_read_table("To/Na1.pl", "use_hash") unless %UNICODE_1_NAMES;
+ $prop{'unicode10'} = $UNICODE_1_NAMES{$code} // "";
- # This is true starting in 6.0, but, num() also requires 6.0, so
- # don't need to test for version again here.
- $prop{'comment'} = "";
+ UnicodeVersion() unless defined $v_unicode_version;
+ if ($v_unicode_version ge v6.0.0) {
+ $prop{'comment'} = "";
+ }
+ else {
+ %ISO_COMMENT = _read_table("To/Isc.pl", "use_hash") unless %ISO_COMMENT;
+ $prop{'comment'} = (defined $ISO_COMMENT{$code})
+ ? $ISO_COMMENT{$code}
+ : "";
+ }
- $prop{'upper'} = _charinfo_case($char, uc $char, '_suc.pl', \@SIMPLE_UPPER);
- $prop{'lower'} = _charinfo_case($char, lc $char, '_slc.pl', \@SIMPLE_LOWER);
- $prop{'title'} = _charinfo_case($char, ucfirst $char, '_stc.pl',
- \@SIMPLE_TITLE);
+ %SIMPLE_UPPER = _read_table("To/Uc.pl", "use_hash") unless %SIMPLE_UPPER;
+ $prop{'upper'} = (defined $SIMPLE_UPPER{$code})
+ ? sprintf("%04X", $SIMPLE_UPPER{$code})
+ : "";
+ %SIMPLE_LOWER = _read_table("To/Lc.pl", "use_hash") unless %SIMPLE_LOWER;
+ $prop{'lower'} = (defined $SIMPLE_LOWER{$code})
+ ? sprintf("%04X", $SIMPLE_LOWER{$code})
+ : "";
+
+ %SIMPLE_TITLE = _read_table("To/Tc.pl", "use_hash") unless %SIMPLE_TITLE;
+ $prop{'title'} = (defined $SIMPLE_TITLE{$code})
+ ? sprintf("%04X", $SIMPLE_TITLE{$code})
+ : "";
+
$prop{block} = charblock($code);
$prop{script} = charscript($code);
return \%prop;
@@ -431,14 +494,20 @@
}
}
-sub _read_table {
+sub _read_table ($;$) {
# Returns the contents of the mktables generated table file located at $1
- # in the form of an array of arrays. Each outer array denotes a range
- # with [0] the start point of that range; [1] the end point; and [2] the
- # value that every code point in the range has.
+ # in the form of either an array of arrays or a hash, depending on if the
+ # optional second parameter is true (for hash return) or not. In the case
+ # of a hash return, each key is a code point, and its corresponding value
+ # is what the table gives as the code point's corresponding value. In the
+ # case of an array return, each outer array denotes a range with [0] the
+ # start point of that range; [1] the end point; and [2] the value that
+ # every code point in the range has. The hash return is useful for fast
+ # lookup when the table contains only single code point ranges. The array
+ # return takes much less memory when there are large ranges.
#
- # This has the side effect of setting
+ # This function has the side effect of setting
# $utf8::SwashInfo{$property}{'format'} to be the mktables format of the
# table; and
# $utf8::SwashInfo{$property}{'missing'} to be the value for all entries
@@ -451,17 +520,47 @@
# 00AA Latin
my $table = shift;
+ my $return_hash = shift;
+ $return_hash = 0 unless defined $return_hash;
my @return;
+ my %return;
local $_;
+ my $list = do "unicore/$table";
- for (split /^/m, do $table) {
+ # Look up if this property requires adjustments, which we do below if it
+ # does.
+ require "unicore/Heavy.pl";
+ my $property = $table =~ s/\.pl//r;
+ $property = $utf8::file_to_swash_name{$property};
+ my $to_adjust = defined $property
+ && $utf8::SwashInfo{$property}{'format'} eq 'a';
+
+ for (split /^/m, $list) {
my ($start, $end, $value) = / ^ (.+?) \t (.*?) \t (.+?)
\s* ( \# .* )? # Optional comment
$ /x;
- $end = $start if $end eq "";
- push @return, [ hex $start, hex $end, $value ];
+ my $decimal_start = hex $start;
+ my $decimal_end = ($end eq "") ? $decimal_start : hex $end;
+ if ($return_hash) {
+ foreach my $i ($decimal_start .. $decimal_end) {
+ $return{$i} = ($to_adjust)
+ ? $value + $i - $decimal_start
+ : $value;
+ }
+ }
+ elsif (! $to_adjust
+ && @return
+ && $return[-1][1] == $decimal_start - 1
+ && $return[-1][2] eq $value)
+ {
+ # If this is merely extending the previous range, do just that.
+ $return[-1]->[1] = $decimal_end;
+ }
+ else {
+ push @return, [ $decimal_start, $decimal_end, $value ];
+ }
}
- return @return;
+ return ($return_hash) ? %return : @return;
}
sub charinrange {
@@ -484,18 +583,25 @@
my $range = charblock('Armenian');
With a L</code point argument> charblock() returns the I<block> the code point
-belongs to, e.g. C<Basic Latin>.
+belongs to, e.g. C<Basic Latin>. The old-style block name is returned (see
+L</Old-style versus new-style block names>).
If the code point is unassigned, this returns the block it would belong to if
-it were assigned (which it may in future versions of the Unicode Standard).
+it were assigned. (If the Unicode version being used is so early as to not
+have blocks, all code points are considered to be in C<No_Block>.)
See also L</Blocks versus Scripts>.
-If supplied with an argument that can't be a code point, charblock() tries
-to do the opposite and interpret the argument as a code point block. The
-return value is a I<range>: an anonymous list of lists that contain
-I<start-of-range>, I<end-of-range> code point pairs. You can test whether
-a code point is in a range using the L</charinrange()> function. If the
-argument is not a known code point block, B<undef> is returned.
+If supplied with an argument that can't be a code point, charblock() tries to
+do the opposite and interpret the argument as an old-style block name. The
+return value
+is a I<range set> with one range: an anonymous list with a single element that
+consists of another anonymous list whose first element is the first code point
+in the block, and whose second (and final) element is the final code point in
+the block. (The extra list consisting of just one element is so that the same
+program logic can be used to handle both this return, and the return from
+L</charscript()> which can have multiple ranges.) You can test whether a code
+point is in a range using the L</charinrange()> function. If the argument is
+not a known block, C<undef> is returned.
=cut
@@ -507,8 +613,15 @@
# Can't read from the mktables table because it loses the hyphens in the
# original.
unless (@BLOCKS) {
- if (openunicode(\$BLOCKSFH, "Blocks.txt")) {
+ UnicodeVersion() unless defined $v_unicode_version;
+ if ($v_unicode_version lt v2.0.0) {
+ my $subrange = [ 0, 0x10FFFF, 'No_Block' ];
+ push @BLOCKS, $subrange;
+ push @{$BLOCKS{'No_Block'}}, $subrange;
+ }
+ elsif (openunicode(\$BLOCKSFH, "Blocks.txt")) {
local $_;
+ local $/ = "\n";
while (<$BLOCKSFH>) {
if (/^([0-9A-F]+)\.\.([0-9A-F]+);\s+(.+)/) {
my ($lo, $hi) = (hex($1), hex($2));
@@ -535,7 +648,7 @@
return 'No_Block';
}
elsif (exists $BLOCKS{$arg}) {
- return dclone $BLOCKS{$arg};
+ return _dclone $BLOCKS{$arg};
}
}
@@ -551,14 +664,15 @@
With a L</code point argument> charscript() returns the I<script> the
code point belongs to, e.g. C<Latin>, C<Greek>, C<Han>.
-If the code point is unassigned, it returns B<undef>
+If the code point is unassigned or the Unicode version being used is so early
+that it doesn't have scripts, this function returns C<"Unknown">.
If supplied with an argument that can't be a code point, charscript() tries
-to do the opposite and interpret the argument as a code point script. The
-return value is a I<range>: an anonymous list of lists that contain
+to do the opposite and interpret the argument as a script name. The
+return value is a I<range set>: an anonymous list of lists that contain
I<start-of-range>, I<end-of-range> code point pairs. You can test whether a
-code point is in a range using the L</charinrange()> function. If the
-argument is not a known code point script, B<undef> is returned.
+code point is in a range set using the L</charinrange()> function. If the
+argument is not a known script, C<undef> is returned.
See also L</Blocks versus Scripts>.
@@ -568,7 +682,15 @@
my %SCRIPTS;
sub _charscripts {
- @SCRIPTS =_read_table("unicore/To/Sc.pl") unless @SCRIPTS;
+ unless (@SCRIPTS) {
+ UnicodeVersion() unless defined $v_unicode_version;
+ if ($v_unicode_version lt v3.1.0) {
+ push @SCRIPTS, [ 0, 0x10FFFF, 'Unknown' ];
+ }
+ else {
+ @SCRIPTS =_read_table("To/Sc.pl");
+ }
+ }
foreach my $entry (@SCRIPTS) {
$entry->[2] =~ s/(_\w)/\L$1/g; # Preserve old-style casing
push @{$SCRIPTS{$entry->[2]}}, $entry;
@@ -587,7 +709,7 @@
return $result if defined $result;
return $utf8::SwashInfo{'ToSc'}{'missing'};
} elsif (exists $SCRIPTS{$arg}) {
- return dclone $SCRIPTS{$arg};
+ return _dclone $SCRIPTS{$arg};
}
return;
@@ -602,6 +724,12 @@
charblocks() returns a reference to a hash with the known block names
as the keys, and the code point ranges (see L</charblock()>) as the values.
+The names are in the old-style (see L</Old-style versus new-style block
+names>).
+
+L<prop_invmap("block")|/prop_invmap()> can be used to get this same data in a
+different type of data structure.
+
See also L</Blocks versus Scripts>.
=cut
@@ -608,7 +736,7 @@
sub charblocks {
_charblocks() unless %BLOCKS;
- return dclone \%BLOCKS;
+ return _dclone \%BLOCKS;
}
=head2 B<charscripts()>
@@ -621,6 +749,9 @@
names as the keys, and the code point ranges (see L</charscript()>) as
the values.
+L<prop_invmap("script")|/prop_invmap()> can be used to get this same data in a
+different type of data structure.
+
See also L</Blocks versus Scripts>.
=cut
@@ -627,7 +758,7 @@
sub charscripts {
_charscripts() unless %SCRIPTS;
- return dclone \%SCRIPTS;
+ return _dclone \%SCRIPTS;
}
=head2 B<charinrange()>
@@ -687,7 +818,7 @@
);
sub general_categories {
- return dclone \%GENERAL_CATEGORIES;
+ return _dclone \%GENERAL_CATEGORIES;
}
=head2 B<general_categories()>
@@ -704,6 +835,9 @@
one returned from
L</charinfo()> under the C<category> key.
+The L</prop_value_aliases()> function can be used to get all the synonyms of
+the category name.
+
=cut
my %BIDI_TYPES =
@@ -746,10 +880,13 @@
L<http://www.unicode.org/reports/tr9/>
(as of Unicode 5.0.0)
+The L</prop_value_aliases()> function can be used to get all the synonyms of
+the bidi type name.
+
=cut
sub bidi_types {
- return dclone \%BIDI_TYPES;
+ return _dclone \%BIDI_TYPES;
}
=head2 B<compexcl()>
@@ -758,7 +895,9 @@
my $compexcl = compexcl(0x09dc);
-This routine is included for backwards compatibility, but as of Perl 5.12, for
+This routine returns C<undef> if the Unicode version being used is so early
+that it doesn't have this property. It is included for backwards
+compatibility, but as of Perl 5.12 and more modern Unicode versions, for
most purposes it is probably more convenient to use one of the following
instead:
@@ -771,9 +910,9 @@
my $compexcl = chr(0x09dc) =~ /\p{Composition_Exclusion};
The first two forms return B<true> if the L</code point argument> should not
-be produced by composition normalization. The final two forms
-additionally require that this fact not otherwise be determinable from
-the Unicode data base for them to return B<true>.
+be produced by composition normalization. For the final two forms to return
+B<true>, it is additionally required that this fact not otherwise be
+determinable from the Unicode data base.
This routine behaves identically to the final two forms. That is,
it does not return B<true> if the code point has a decomposition
@@ -793,6 +932,9 @@
croak __PACKAGE__, "::compexcl: unknown code '$arg'"
unless defined $code;
+ UnicodeVersion() unless defined $v_unicode_version;
+ return if $v_unicode_version lt v3.0.0;
+
no warnings "non_unicode"; # So works on non-Unicode code points
return chr($code) =~ /\p{Composition_Exclusion}/;
}
@@ -819,9 +961,11 @@
}
This returns the (almost) locale-independent case folding of the
-character specified by the L</code point argument>.
+character specified by the L</code point argument>. (Starting in Perl v5.16,
+the core function C<fc()> returns the C<full> mapping (described below)
+faster than this does, and for entire strings.)
-If there is no case folding for that code point, B<undef> is returned.
+If there is no case folding for the input code point, C<undef> is returned.
If there is a case folding for that code point, a reference to a hash
with the following fields is returned:
@@ -835,7 +979,7 @@
=item B<full>
-one or more codes (separated by spaces) that taken in order give the
+one or more codes (separated by spaces) that, taken in order, give the
code points for the case folding for I<code>.
Each has at least four hexdigits.
@@ -859,25 +1003,25 @@
is C<C> (for C<common>) if the best possible fold is a single code point
(I<simple> equals I<full> equals I<mapping>). It is C<S> if there are distinct
folds, I<simple> and I<full> (I<mapping> equals I<simple>). And it is C<F> if
-there only a I<full> fold (I<mapping> equals I<full>; I<simple> is empty). Note
-that this
+there is only a I<full> fold (I<mapping> equals I<full>; I<simple> is empty).
+Note that this
describes the contents of I<mapping>. It is defined primarily for backwards
compatibility.
-On versions 3.1 and earlier of Unicode, I<status> can also be
+For Unicode versions between 3.1 and 3.1.1 inclusive, I<status> can also be
C<I> which is the same as C<C> but is a special case for dotted uppercase I and
dotless lowercase i:
=over
-=item B<*>
+=item Z<>B<*> If you use this C<I> mapping
-If you use this C<I> mapping, the result is case-insensitive,
+the result is case-insensitive,
but dotless and dotted I's are not distinguished
-=item B<*>
+=item Z<>B<*> If you exclude this C<I> mapping
-If you exclude this C<I> mapping, the result is not fully case-insensitive, but
+the result is not fully case-insensitive, but
dotless and dotted I's are distinguished
=back
@@ -887,13 +1031,14 @@
contains any special folding for Turkic languages. For versions of Unicode
starting with 3.2, this field is empty unless I<code> has a different folding
in Turkic languages, in which case it is one or more codes (separated by
-spaces) that taken in order give the code points for the case folding for
+spaces) that, taken in order, give the code points for the case folding for
I<code> in those languages.
Each code has at least four hexdigits.
Note that this folding does not maintain canonical equivalence without
additional processing.
-For versions of Unicode 3.1 and earlier, this field is empty unless there is a
+For Unicode versions between 3.1 and 3.1.1 inclusive, this field is empty unless
+there is a
special folding for Turkic languages, in which case I<status> is C<I>, and
I<mapping>, I<full>, I<simple>, and I<turkic> are all equal.
@@ -923,53 +1068,88 @@
my %CASEFOLD;
sub _casefold {
- unless (%CASEFOLD) {
- if (openunicode(\$CASEFOLDFH, "CaseFolding.txt")) {
- local $_;
- while (<$CASEFOLDFH>) {
- if (/^([0-9A-F]+); ([CFIST]); ([0-9A-F]+(?: [0-9A-F]+)*);/) {
- my $code = hex($1);
- $CASEFOLD{$code}{'code'} = $1;
- $CASEFOLD{$code}{'turkic'} = "" unless
- defined $CASEFOLD{$code}{'turkic'};
- if ($2 eq 'C' || $2 eq 'I') { # 'I' is only on 3.1 and
- # earlier Unicodes
- # Both entries there (I
- # only checked 3.1) are
- # the same as C, and
- # there are no other
- # entries for those
- # codepoints, so treat
- # as if C, but override
- # the turkic one for
- # 'I'.
- $CASEFOLD{$code}{'status'} = $2;
- $CASEFOLD{$code}{'full'} = $CASEFOLD{$code}{'simple'} =
- $CASEFOLD{$code}{'mapping'} = $3;
- $CASEFOLD{$code}{'turkic'} = $3 if $2 eq 'I';
- } elsif ($2 eq 'F') {
- $CASEFOLD{$code}{'full'} = $3;
- unless (defined $CASEFOLD{$code}{'simple'}) {
- $CASEFOLD{$code}{'simple'} = "";
- $CASEFOLD{$code}{'mapping'} = $3;
- $CASEFOLD{$code}{'status'} = $2;
- }
- } elsif ($2 eq 'S') {
+ unless (%CASEFOLD) { # Populate the hash
+ my ($full_invlist_ref, $full_invmap_ref, undef, $default)
+ = prop_invmap('Case_Folding');
+ # Use the recipe given in the prop_invmap() pod to convert the
+ # inversion map into the hash.
+ for my $i (0 .. @$full_invlist_ref - 1 - 1) {
+ next if $full_invmap_ref->[$i] == $default;
+ my $adjust = -1;
+ for my $j ($full_invlist_ref->[$i] .. $full_invlist_ref->[$i+1] -1) {
+ $adjust++;
+ if (! ref $full_invmap_ref->[$i]) {
- # There can't be a simple without a full, and simple
- # overrides all but full
+ # This is a single character mapping
+ $CASEFOLD{$j}{'status'} = 'C';
+ $CASEFOLD{$j}{'simple'}
+ = $CASEFOLD{$j}{'full'}
+ = $CASEFOLD{$j}{'mapping'}
+ = sprintf("%04X", $full_invmap_ref->[$i] + $adjust);
+ $CASEFOLD{$j}{'code'} = sprintf("%04X", $j);
+ $CASEFOLD{$j}{'turkic'} = "";
+ }
+ else { # prop_invmap ensures that $adjust is 0 for a ref
+ $CASEFOLD{$j}{'status'} = 'F';
+ $CASEFOLD{$j}{'full'}
+ = $CASEFOLD{$j}{'mapping'}
+ = join " ", map { sprintf "%04X", $_ }
+ @{$full_invmap_ref->[$i]};
+ $CASEFOLD{$j}{'simple'} = "";
+ $CASEFOLD{$j}{'code'} = sprintf("%04X", $j);
+ $CASEFOLD{$j}{'turkic'} = "";
+ }
+ }
+ }
- $CASEFOLD{$code}{'simple'} = $3;
- $CASEFOLD{$code}{'mapping'} = $3;
- $CASEFOLD{$code}{'status'} = $2;
- } elsif ($2 eq 'T') {
- $CASEFOLD{$code}{'turkic'} = $3;
- } # else can't happen because only [CIFST] are possible
- }
- }
- close($CASEFOLDFH);
- }
+ # We have filled in the full mappings above, assuming there were no
+ # simple ones for the ones with multi-character maps. Now, we find
+ # and fix the cases where that assumption was false.
+ (my ($simple_invlist_ref, $simple_invmap_ref, undef), $default)
+ = prop_invmap('Simple_Case_Folding');
+ for my $i (0 .. @$simple_invlist_ref - 1 - 1) {
+ next if $simple_invmap_ref->[$i] == $default;
+ my $adjust = -1;
+ for my $j ($simple_invlist_ref->[$i]
+ .. $simple_invlist_ref->[$i+1] -1)
+ {
+ $adjust++;
+ next if $CASEFOLD{$j}{'status'} eq 'C';
+ $CASEFOLD{$j}{'status'} = 'S';
+ $CASEFOLD{$j}{'simple'}
+ = $CASEFOLD{$j}{'mapping'}
+ = sprintf("%04X", $simple_invmap_ref->[$i] + $adjust);
+ $CASEFOLD{$j}{'code'} = sprintf("%04X", $j);
+ $CASEFOLD{$j}{'turkic'} = "";
+ }
+ }
+
+ # We hard-code in the turkish rules
+ UnicodeVersion() unless defined $v_unicode_version;
+ if ($v_unicode_version ge v3.2.0) {
+
+ # These two code points should already have regular entries, so
+ # just fill in the turkish fields
+ $CASEFOLD{ord('I')}{'turkic'} = '0131';
+ $CASEFOLD{0x130}{'turkic'} = sprintf "%04X", ord('i');
+ }
+ elsif ($v_unicode_version ge v3.1.0) {
+
+ # These two code points don't have entries otherwise.
+ $CASEFOLD{0x130}{'code'} = '0130';
+ $CASEFOLD{0x131}{'code'} = '0131';
+ $CASEFOLD{0x130}{'status'} = $CASEFOLD{0x131}{'status'} = 'I';
+ $CASEFOLD{0x130}{'turkic'}
+ = $CASEFOLD{0x130}{'mapping'}
+ = $CASEFOLD{0x130}{'full'}
+ = $CASEFOLD{0x130}{'simple'}
+ = $CASEFOLD{0x131}{'turkic'}
+ = $CASEFOLD{0x131}{'mapping'}
+ = $CASEFOLD{0x131}{'full'}
+ = $CASEFOLD{0x131}{'simple'}
+ = sprintf "%04X", ord('i');
+ }
}
}
@@ -984,6 +1164,55 @@
return $CASEFOLD{$code};
}
+=head2 B<all_casefolds()>
+
+
+ use Unicode::UCD 'all_casefolds';
+
+ my $all_folds_ref = all_casefolds();
+ foreach my $char_with_casefold (sort { $a <=> $b }
+ keys %$all_folds_ref)
+ {
+ printf "%04X:", $char_with_casefold;
+ my $casefold = $all_folds_ref->{$char_with_casefold};
+
+ # Get folds for $char_with_casefold
+
+ my @full_fold_hex = split / /, $casefold->{'full'};
+ my $full_fold_string =
+ join "", map {chr(hex($_))} @full_fold_hex;
+ print " full=", join " ", @full_fold_hex;
+ my @turkic_fold_hex =
+ split / /, ($casefold->{'turkic'} ne "")
+ ? $casefold->{'turkic'}
+ : $casefold->{'full'};
+ my $turkic_fold_string =
+ join "", map {chr(hex($_))} @turkic_fold_hex;
+ print "; turkic=", join " ", @turkic_fold_hex;
+ if (defined $casefold && $casefold->{'simple'} ne "") {
+ my $simple_fold_hex = $casefold->{'simple'};
+ my $simple_fold_string = chr(hex($simple_fold_hex));
+ print "; simple=$simple_fold_hex";
+ }
+ print "\n";
+ }
+
+This returns all the case foldings in the current version of Unicode in the
+form of a reference to a hash. Each key to the hash is the decimal
+representation of a Unicode character that has a casefold to other than
+itself. The casefold of a semi-colon is itself, so it isn't in the hash;
+likewise for a lowercase "a", but there is an entry for a capital "A". The
+hash value for each key is another hash, identical to what is returned by
+L</casefold()> if called with that code point as its argument. So the value
+C<< all_casefolds()->{ord("A")}' >> is equivalent to C<casefold(ord("A"))>;
+
+=cut
+
+sub all_casefolds () {
+ _casefold() unless %CASEFOLD;
+ return _dclone \%CASEFOLD;
+}
+
=head2 B<casespec()>
use Unicode::UCD 'casespec';
@@ -996,7 +1225,7 @@
If there are no case mappings for the L</code point argument>, or if all three
possible mappings (I<lower>, I<title> and I<upper>) result in single code
-points and are locale independent and unconditional, B<undef> is returned
+points and are locale independent and unconditional, C<undef> is returned
(which means that the case mappings, if any, for the code point are those
returned by L</charinfo()>).
@@ -1015,19 +1244,19 @@
=item B<lower>
-one or more codes (separated by spaces) that taken in order give the
+one or more codes (separated by spaces) that, taken in order, give the
code points for the lower case of I<code>.
Each has at least four hexdigits.
=item B<title>
-one or more codes (separated by spaces) that taken in order give the
+one or more codes (separated by spaces) that, taken in order, give the
code points for the title case of I<code>.
Each has at least four hexdigits.
=item B<upper>
-one or more codes (separated by spaces) that taken in order give the
+one or more codes (separated by spaces) that, taken in order, give the
code points for the upper case of I<code>.
Each has at least four hexdigits.
@@ -1034,7 +1263,7 @@
=item B<condition>
the conditions for the mappings to be valid.
-If B<undef>, the mappings are always valid.
+If C<undef>, the mappings are always valid.
When defined, this field is a list of conditions,
all of which must be true for the mappings to be valid.
The list consists of one or more
@@ -1054,7 +1283,7 @@
=back
The hash described above is returned for locale-independent casing, where
-at least one of the mappings has length longer than one. If B<undef> is
+at least one of the mappings has length longer than one. If C<undef> is
returned, the code point may have mappings, but if so, all are length one,
and are returned by L</charinfo()>.
Note that when this function does return a value, it will be for the complete
@@ -1086,14 +1315,25 @@
sub _casespec {
unless (%CASESPEC) {
- if (openunicode(\$CASESPECFH, "SpecialCasing.txt")) {
+ UnicodeVersion() unless defined $v_unicode_version;
+ if ($v_unicode_version lt v2.1.8) {
+ %CASESPEC = {};
+ }
+ elsif (openunicode(\$CASESPECFH, "SpecialCasing.txt")) {
local $_;
+ local $/ = "\n";
while (<$CASESPECFH>) {
if (/^([0-9A-F]+); ([0-9A-F]+(?: [0-9A-F]+)*)?; ([0-9A-F]+(?: [0-9A-F]+)*)?; ([0-9A-F]+(?: [0-9A-F]+)*)?; (\w+(?: \w+)*)?/) {
+
my ($hexcode, $lower, $title, $upper, $condition) =
($1, $2, $3, $4, $5);
my $code = hex($hexcode);
- if (exists $CASESPEC{$code}) {
+
+ # In 2.1.8, there were duplicate entries; ignore all but
+ # the first one -- there were no conditions in the file
+ # anyway.
+ if (exists $CASESPEC{$code} && $v_unicode_version ne v2.1.8)
+ {
if (exists $CASESPEC{$code}->{code}) {
my ($oldlower,
$oldtitle,
@@ -1146,7 +1386,7 @@
_casespec() unless %CASESPEC;
- return ref $CASESPEC{$code} ? dclone $CASESPEC{$code} : $CASESPEC{$code};
+ return ref $CASESPEC{$code} ? _dclone $CASESPEC{$code} : $CASESPEC{$code};
}
=head2 B<namedseq()>
@@ -1158,13 +1398,13 @@
my %namedseq = namedseq();
If used with a single argument in a scalar context, returns the string
-consisting of the code points of the named sequence, or B<undef> if no
+consisting of the code points of the named sequence, or C<undef> if no
named sequence by that name exists. If used with a single argument in
a list context, it returns the list of the ordinals of the code points. If used
with no
arguments in a list context, returns a hash with the names of the
named sequences as the keys and the named sequences as strings as
-the values. Otherwise, it returns B<undef> or an empty list depending
+the values. Otherwise, it returns C<undef> or an empty list depending
on the context.
This function only operates on officially approved (not provisional) named
@@ -1184,6 +1424,7 @@
unless (%NAMEDSEQ) {
if (openunicode(\$NAMEDSEQFH, "Name.pl")) {
local $_;
+ local $/ = "\n";
while (<$NAMEDSEQFH>) {
if (/^ [0-9A-F]+ \ /x) {
chomp;
@@ -1230,17 +1471,7 @@
my %NUMERIC;
sub _numeric {
-
- # Unicode 6.0 instituted the rule that only digits in a consecutive
- # block of 10 would be considered decimal digits. Before that, the only
- # problematic code point that I'm (khw) aware of is U+019DA, NEW TAI LUE
- # THAM DIGIT ONE, which is an alternate form of U+019D1, NEW TAI LUE DIGIT
- # ONE. The code could be modified to handle that, but not bothering, as
- # in TUS 6.0, U+19DA was changed to Nt=Di.
- if ((pack "C*", split /\./, UnicodeVersion()) lt 6.0.0) {
- croak __PACKAGE__, "::num requires Unicode 6.0 or greater"
- }
- my @numbers = _read_table("unicore/To/Nv.pl");
+ my @numbers = _read_table("To/Nv.pl");
foreach my $entry (@numbers) {
my ($start, $end, $value) = @$entry;
@@ -1250,11 +1481,18 @@
my $real = $rational[0] / $rational[1];
$real_to_rational{$real} = $value;
$value = $real;
- }
- for my $i ($start .. $end) {
- $NUMERIC{$i} = $value;
+ # Should only be single element, but just in case...
+ for my $i ($start .. $end) {
+ $NUMERIC{$i} = $value;
+ }
}
+ else {
+ # The values require adjusting, as is in 'a' format
+ for my $i ($start .. $end) {
+ $NUMERIC{$i} = $value + $i - $start;
+ }
+ }
}
# Decided unsafe to use these that aren't officially part of the Unicode
@@ -1274,8 +1512,13 @@
=pod
-=head2 num
+=head2 B<num()>
+ use Unicode::UCD 'num';
+
+ my $val = num("123");
+ my $one_quarter = num("\N{VULGAR FRACTION 1/4}");
+
C<num> returns the numeric value of the input Unicode string; or C<undef> if it
doesn't think the entire string has a completely valid, safe numeric value.
@@ -1297,7 +1540,7 @@
=pod
If the string is more than one character, C<undef> is returned unless
-all its characters are decimal digits (that is they would match C<\d+>),
+all its characters are decimal digits (that is, they would match C<\d+>),
from the same script. For example if you have an ASCII '0' and a Bengali
'3', mixed together, they aren't considered a valid number, and C<undef>
is returned. A further restriction is that the digits all have to be of
@@ -1338,19 +1581,1945 @@
return if $string =~ /\D/;
my $first_ord = ord(substr($string, 0, 1));
my $value = $NUMERIC{$first_ord};
+
+ # To be a valid decimal number, it should be in a block of 10 consecutive
+ # characters, whose values are 0, 1, 2, ... 9. Therefore this digit's
+ # value is its offset in that block from the character that means zero.
my $zero_ord = $first_ord - $value;
+ # Unicode 6.0 instituted the rule that only digits in a consecutive
+ # block of 10 would be considered decimal digits. If this is an earlier
+ # release, we verify that this first character is a member of such a
+ # block. That is, that the block of characters surrounding this one
+ # consists of all \d characters whose numeric values are the expected
+ # ones.
+ UnicodeVersion() unless defined $v_unicode_version;
+ if ($v_unicode_version lt v6.0.0) {
+ for my $i (0 .. 9) {
+ my $ord = $zero_ord + $i;
+ return unless chr($ord) =~ /\d/;
+ my $numeric = $NUMERIC{$ord};
+ return unless defined $numeric;
+ return unless $numeric == $i;
+ }
+ }
+
for my $i (1 .. $length -1) {
+
+ # Here we know either by verifying, or by fact of the first character
+ # being a \d in Unicode 6.0 or later, that any character between the
+ # character that means 0, and 9 positions above it must be \d, and
+ # must have its value correspond to its offset from the zero. Any
+ # characters outside these 10 do not form a legal number for this
+ # function.
my $ord = ord(substr($string, $i, 1));
my $digit = $ord - $zero_ord;
return unless $digit >= 0 && $digit <= 9;
$value = $value * 10 + $digit;
}
+
return $value;
}
+=pod
+=head2 B<prop_aliases()>
+ use Unicode::UCD 'prop_aliases';
+
+ my ($short_name, $full_name, @other_names) = prop_aliases("space");
+ my $same_full_name = prop_aliases("Space"); # Scalar context
+ my ($same_short_name) = prop_aliases("Space"); # gets 0th element
+ print "The full name is $full_name\n";
+ print "The short name is $short_name\n";
+ print "The other aliases are: ", join(", ", @other_names), "\n";
+
+ prints:
+ The full name is White_Space
+ The short name is WSpace
+ The other aliases are: Space
+
+Most Unicode properties have several synonymous names. Typically, there is at
+least a short name, convenient to type, and a long name that more fully
+describes the property, and hence is more easily understood.
+
+If you know one name for a Unicode property, you can use C<prop_aliases> to find
+either the long name (when called in scalar context), or a list of all of the
+names, somewhat ordered so that the short name is in the 0th element, the long
+name in the next element, and any other synonyms are in the remaining
+elements, in no particular order.
+
+The long name is returned in a form nicely capitalized, suitable for printing.
+
+The input parameter name is loosely matched, which means that white space,
+hyphens, and underscores are ignored (except for the trailing underscore in
+the old_form grandfathered-in C<"L_">, which is better written as C<"LC">, and
+both of which mean C<General_Category=Cased Letter>).
+
+If the name is unknown, C<undef> is returned (or an empty list in list
+context). Note that Perl typically recognizes property names in regular
+expressions with an optional C<"Is_>" (with or without the underscore)
+prefixed to them, such as C<\p{isgc=punct}>. This function does not recognize
+those in the input, returning C<undef>. Nor are they included in the output
+as possible synonyms.
+
+C<prop_aliases> does know about the Perl extensions to Unicode properties,
+such as C<Any> and C<XPosixAlpha>, and the single form equivalents to Unicode
+properties such as C<XDigit>, C<Greek>, C<In_Greek>, and C<Is_Greek>. The
+final example demonstrates that the C<"Is_"> prefix is recognized for these
+extensions; it is needed to resolve ambiguities. For example,
+C<prop_aliases('lc')> returns the list C<(lc, Lowercase_Mapping)>, but
+C<prop_aliases('islc')> returns C<(Is_LC, Cased_Letter)>. This is
+because C<islc> is a Perl extension which is short for
+C<General_Category=Cased Letter>. The lists returned for the Perl extensions
+will not include the C<"Is_"> prefix (whether or not the input had it) unless
+needed to resolve ambiguities, as shown in the C<"islc"> example, where the
+returned list had one element containing C<"Is_">, and the other without.
+
+It is also possible for the reverse to happen: C<prop_aliases('isc')> returns
+the list C<(isc, ISO_Comment)>; whereas C<prop_aliases('c')> returns
+C<(C, Other)> (the latter being a Perl extension meaning
+C<General_Category=Other>.
+L<perluniprops/Properties accessible through Unicode::UCD> lists the available
+forms, including which ones are discouraged from use.
+
+Those discouraged forms are accepted as input to C<prop_aliases>, but are not
+returned in the lists. C<prop_aliases('isL&')> and C<prop_aliases('isL_')>,
+which are old synonyms for C<"Is_LC"> and should not be used in new code, are
+examples of this. These both return C<(Is_LC, Cased_Letter)>. Thus this
+function allows you to take a discourarged form, and find its acceptable
+alternatives. The same goes with single-form Block property equivalences.
+Only the forms that begin with C<"In_"> are not discouraged; if you pass
+C<prop_aliases> a discouraged form, you will get back the equivalent ones that
+begin with C<"In_">. It will otherwise look like a new-style block name (see.
+L</Old-style versus new-style block names>).
+
+C<prop_aliases> does not know about any user-defined properties, and will
+return C<undef> if called with one of those. Likewise for Perl internal
+properties, with the exception of "Perl_Decimal_Digit" which it does know
+about (and which is documented below in L</prop_invmap()>).
+
+=cut
+
+# It may be that there are use cases where the discouraged forms should be
+# returned. If that comes up, an optional boolean second parameter to the
+# function could be created, for example.
+
+# These are created by mktables for this routine and stored in unicore/UCD.pl
+# where their structures are described.
+our %string_property_loose_to_name;
+our %ambiguous_names;
+our %loose_perlprop_to_name;
+our %prop_aliases;
+
+sub prop_aliases ($) {
+ my $prop = $_[0];
+ return unless defined $prop;
+
+ require "unicore/UCD.pl";
+ require "unicore/Heavy.pl";
+ require "utf8_heavy.pl";
+
+ # The property name may be loosely or strictly matched; we don't know yet.
+ # But both types use lower-case.
+ $prop = lc $prop;
+
+ # It is loosely matched if its lower case isn't known to be strict.
+ my $list_ref;
+ if (! exists $utf8::stricter_to_file_of{$prop}) {
+ my $loose = utf8::_loose_name($prop);
+
+ # There is a hash that converts from any loose name to its standard
+ # form, mapping all synonyms for a name to one name that can be used
+ # as a key into another hash. The whole concept is for memory
+ # savings, as the second hash doesn't have to have all the
+ # combinations. Actually, there are two hashes that do the
+ # converstion. One is used in utf8_heavy.pl (stored in Heavy.pl) for
+ # looking up properties matchable in regexes. This function needs to
+ # access string properties, which aren't available in regexes, so a
+ # second conversion hash is made for them (stored in UCD.pl). Look in
+ # the string one now, as the rest can have an optional 'is' prefix,
+ # which these don't.
+ if (exists $string_property_loose_to_name{$loose}) {
+
+ # Convert to its standard loose name.
+ $prop = $string_property_loose_to_name{$loose};
+ }
+ else {
+ my $retrying = 0; # bool. ? Has an initial 'is' been stripped
+ RETRY:
+ if (exists $utf8::loose_property_name_of{$loose}
+ && (! $retrying
+ || ! exists $ambiguous_names{$loose}))
+ {
+ # Found an entry giving the standard form. We don't get here
+ # (in the test above) when we've stripped off an
+ # 'is' and the result is an ambiguous name. That is because
+ # these are official Unicode properties (though Perl can have
+ # an optional 'is' prefix meaning the official property), and
+ # all ambiguous cases involve a Perl single-form extension
+ # for the gc, script, or block properties, and the stripped
+ # 'is' means that they mean one of those, and not one of
+ # these
+ $prop = $utf8::loose_property_name_of{$loose};
+ }
+ elsif (exists $loose_perlprop_to_name{$loose}) {
+
+ # This hash is specifically for this function to list Perl
+ # extensions that aren't in the earlier hashes. If there is
+ # only one element, the short and long names are identical.
+ # Otherwise the form is already in the same form as
+ # %prop_aliases, which is handled at the end of the function.
+ $list_ref = $loose_perlprop_to_name{$loose};
+ if (@$list_ref == 1) {
+ my @list = ($list_ref->[0], $list_ref->[0]);
+ $list_ref = \@list;
+ }
+ }
+ elsif (! exists $utf8::loose_to_file_of{$loose}) {
+
+ # loose_to_file_of is a complete list of loose names. If not
+ # there, the input is unknown.
+ return;
+ }
+ else {
+
+ # Here we found the name but not its aliases, so it has to
+ # exist. This means it must be one of the Perl single-form
+ # extensions. First see if it is for a property-value
+ # combination in one of the following properties.
+ my @list;
+ foreach my $property ("gc", "script") {
+ @list = prop_value_aliases($property, $loose);
+ last if @list;
+ }
+ if (@list) {
+
+ # Here, it is one of those property-value combination
+ # single-form synonyms. There are ambiguities with some
+ # of these. Check against the list for these, and adjust
+ # if necessary.
+ for my $i (0 .. @list -1) {
+ if (exists $ambiguous_names
+ {utf8::_loose_name(lc $list[$i])})
+ {
+ # The ambiguity is resolved by toggling whether or
+ # not it has an 'is' prefix
+ $list[$i] =~ s/^Is_// or $list[$i] =~ s/^/Is_/;
+ }
+ }
+ return @list;
+ }
+
+ # Here, it wasn't one of the gc or script single-form
+ # extensions. It could be a block property single-form
+ # extension. An 'in' prefix definitely means that, and should
+ # be looked up without the prefix. However, starting in
+ # Unicode 6.1, we have to special case 'indic...', as there
+ # is a property that begins with that name. We shouldn't
+ # strip the 'in' from that. I'm (khw) generalizing this to
+ # 'indic' instead of the single property, because I suspect
+ # that others of this class may come along in the future.
+ # However, this could backfire and a block created whose name
+ # begins with 'dic...', and we would want to strip the 'in'.
+ # At which point this would have to be tweaked.
+ my $began_with_in = $loose =~ s/^in(?!dic)//;
+ @list = prop_value_aliases("block", $loose);
+ if (@list) {
+ map { $_ =~ s/^/In_/ } @list;
+ return @list;
+ }
+
+ # Here still haven't found it. The last opportunity for it
+ # being valid is only if it began with 'is'. We retry without
+ # the 'is', setting a flag to that effect so that we don't
+ # accept things that begin with 'isis...'
+ if (! $retrying && ! $began_with_in && $loose =~ s/^is//) {
+ $retrying = 1;
+ goto RETRY;
+ }
+
+ # Here, didn't find it. Since it was in %loose_to_file_of, we
+ # should have been able to find it.
+ carp __PACKAGE__, "::prop_aliases: Unexpectedly could not find '$prop'. Send bug report to perlbug\@perl.org";
+ return;
+ }
+ }
+ }
+
+ if (! $list_ref) {
+ # Here, we have set $prop to a standard form name of the input. Look
+ # it up in the structure created by mktables for this purpose, which
+ # contains both strict and loosely matched properties. Avoid
+ # autovivifying.
+ $list_ref = $prop_aliases{$prop} if exists $prop_aliases{$prop};
+ return unless $list_ref;
+ }
+
+ # The full name is in element 1.
+ return $list_ref->[1] unless wantarray;
+
+ return @{_dclone $list_ref};
+}
+
+=pod
+
+=head2 B<prop_value_aliases()>
+
+ use Unicode::UCD 'prop_value_aliases';
+
+ my ($short_name, $full_name, @other_names)
+ = prop_value_aliases("Gc", "Punct");
+ my $same_full_name = prop_value_aliases("Gc", "P"); # Scalar cntxt
+ my ($same_short_name) = prop_value_aliases("Gc", "P"); # gets 0th
+ # element
+ print "The full name is $full_name\n";
+ print "The short name is $short_name\n";
+ print "The other aliases are: ", join(", ", @other_names), "\n";
+
+ prints:
+ The full name is Punctuation
+ The short name is P
+ The other aliases are: Punct
+
+Some Unicode properties have a restricted set of legal values. For example,
+all binary properties are restricted to just C<true> or C<false>; and there
+are only a few dozen possible General Categories.
+
+For such properties, there are usually several synonyms for each possible
+value. For example, in binary properties, I<truth> can be represented by any of
+the strings "Y", "Yes", "T", or "True"; and the General Category
+"Punctuation" by that string, or "Punct", or simply "P".
+
+Like property names, there is typically at least a short name for each such
+property-value, and a long name. If you know any name of the property-value,
+you can use C<prop_value_aliases>() to get the long name (when called in
+scalar context), or a list of all the names, with the short name in the 0th
+element, the long name in the next element, and any other synonyms in the
+remaining elements, in no particular order, except that any all-numeric
+synonyms will be last.
+
+The long name is returned in a form nicely capitalized, suitable for printing.
+
+Case, white space, hyphens, and underscores are ignored in the input parameters
+(except for the trailing underscore in the old-form grandfathered-in general
+category property value C<"L_">, which is better written as C<"LC">).
+
+If either name is unknown, C<undef> is returned. Note that Perl typically
+recognizes property names in regular expressions with an optional C<"Is_>"
+(with or without the underscore) prefixed to them, such as C<\p{isgc=punct}>.
+This function does not recognize those in the property parameter, returning
+C<undef>.
+
+If called with a property that doesn't have synonyms for its values, it
+returns the input value, possibly normalized with capitalization and
+underscores.
+
+For the block property, new-style block names are returned (see
+L</Old-style versus new-style block names>).
+
+To find the synonyms for single-forms, such as C<\p{Any}>, use
+L</prop_aliases()> instead.
+
+C<prop_value_aliases> does not know about any user-defined properties, and
+will return C<undef> if called with one of those.
+
+=cut
+
+# These are created by mktables for this routine and stored in unicore/UCD.pl
+# where their structures are described.
+our %loose_to_standard_value;
+our %prop_value_aliases;
+
+sub prop_value_aliases ($$) {
+ my ($prop, $value) = @_;
+ return unless defined $prop && defined $value;
+
+ require "unicore/UCD.pl";
+ require "utf8_heavy.pl";
+
+ # Find the property name synonym that's used as the key in other hashes,
+ # which is element 0 in the returned list.
+ ($prop) = prop_aliases($prop);
+ return if ! $prop;
+ $prop = utf8::_loose_name(lc $prop);
+
+ # Here is a legal property, but the hash below (created by mktables for
+ # this purpose) only knows about the properties that have a very finite
+ # number of potential values, that is not ones whose value could be
+ # anything, like most (if not all) string properties. These don't have
+ # synonyms anyway. Simply return the input. For example, there is no
+ # synonym for ('Uppercase_Mapping', A').
+ return $value if ! exists $prop_value_aliases{$prop};
+
+ # The value name may be loosely or strictly matched; we don't know yet.
+ # But both types use lower-case.
+ $value = lc $value;
+
+ # If the name isn't found under loose matching, it certainly won't be
+ # found under strict
+ my $loose_value = utf8::_loose_name($value);
+ return unless exists $loose_to_standard_value{"$prop=$loose_value"};
+
+ # Similarly if the combination under loose matching doesn't exist, it
+ # won't exist under strict.
+ my $standard_value = $loose_to_standard_value{"$prop=$loose_value"};
+ return unless exists $prop_value_aliases{$prop}{$standard_value};
+
+ # Here we did find a combination under loose matching rules. But it could
+ # be that is a strict property match that shouldn't have matched.
+ # %prop_value_aliases is set up so that the strict matches will appear as
+ # if they were in loose form. Thus, if the non-loose version is legal,
+ # we're ok, can skip the further check.
+ if (! exists $utf8::stricter_to_file_of{"$prop=$value"}
+
+ # We're also ok and skip the further check if value loosely matches.
+ # mktables has verified that no strict name under loose rules maps to
+ # an existing loose name. This code relies on the very limited
+ # circumstances that strict names can be here. Strict name matching
+ # happens under two conditions:
+ # 1) when the name begins with an underscore. But this function
+ # doesn't accept those, and %prop_value_aliases doesn't have
+ # them.
+ # 2) When the values are numeric, in which case we need to look
+ # further, but their squeezed-out loose values will be in
+ # %stricter_to_file_of
+ && exists $utf8::stricter_to_file_of{"$prop=$loose_value"})
+ {
+ # The only thing that's legal loosely under strict is that can have an
+ # underscore between digit pairs XXX
+ while ($value =~ s/(\d)_(\d)/$1$2/g) {}
+ return unless exists $utf8::stricter_to_file_of{"$prop=$value"};
+ }
+
+ # Here, we know that the combination exists. Return it.
+ my $list_ref = $prop_value_aliases{$prop}{$standard_value};
+ if (@$list_ref > 1) {
+ # The full name is in element 1.
+ return $list_ref->[1] unless wantarray;
+
+ return @{_dclone $list_ref};
+ }
+
+ return $list_ref->[0] unless wantarray;
+
+ # Only 1 element means that it repeats
+ return ( $list_ref->[0], $list_ref->[0] );
+}
+
+# All 1 bits is the largest possible UV.
+$Unicode::UCD::MAX_CP = ~0;
+
+=pod
+
+=head2 B<prop_invlist()>
+
+C<prop_invlist> returns an inversion list (described below) that defines all the
+code points for the binary Unicode property (or "property=value" pair) given
+by the input parameter string:
+
+ use feature 'say';
+ use Unicode::UCD 'prop_invlist';
+ say join ", ", prop_invlist("Any");
+
+ prints:
+ 0, 1114112
+
+If the input is unknown C<undef> is returned in scalar context; an empty-list
+in list context. If the input is known, the number of elements in
+the list is returned if called in scalar context.
+
+L<perluniprops|perluniprops/Properties accessible through \p{} and \P{}> gives
+the list of properties that this function accepts, as well as all the possible
+forms for them (including with the optional "Is_" prefixes). (Except this
+function doesn't accept any Perl-internal properties, some of which are listed
+there.) This function uses the same loose or tighter matching rules for
+resolving the input property's name as is done for regular expressions. These
+are also specified in L<perluniprops|perluniprops/Properties accessible
+through \p{} and \P{}>. Examples of using the "property=value" form are:
+
+ say join ", ", prop_invlist("Script=Shavian");
+
+ prints:
+ 66640, 66688
+
+ say join ", ", prop_invlist("ASCII_Hex_Digit=No");
+
+ prints:
+ 0, 48, 58, 65, 71, 97, 103
+
+ say join ", ", prop_invlist("ASCII_Hex_Digit=Yes");
+
+ prints:
+ 48, 58, 65, 71, 97, 103
+
+Inversion lists are a compact way of specifying Unicode property-value
+definitions. The 0th item in the list is the lowest code point that has the
+property-value. The next item (item [1]) is the lowest code point beyond that
+one that does NOT have the property-value. And the next item beyond that
+([2]) is the lowest code point beyond that one that does have the
+property-value, and so on. Put another way, each element in the list gives
+the beginning of a range that has the property-value (for even numbered
+elements), or doesn't have the property-value (for odd numbered elements).
+The name for this data structure stems from the fact that each element in the
+list toggles (or inverts) whether the corresponding range is or isn't on the
+list.
+
+In the final example above, the first ASCII Hex digit is code point 48, the
+character "0", and all code points from it through 57 (a "9") are ASCII hex
+digits. Code points 58 through 64 aren't, but 65 (an "A") through 70 (an "F")
+are, as are 97 ("a") through 102 ("f"). 103 starts a range of code points
+that aren't ASCII hex digits. That range extends to infinity, which on your
+computer can be found in the variable C<$Unicode::UCD::MAX_CP>. (This
+variable is as close to infinity as Perl can get on your platform, and may be
+too high for some operations to work; you may wish to use a smaller number for
+your purposes.)
+
+Note that the inversion lists returned by this function can possibly include
+non-Unicode code points, that is anything above 0x10FFFF. This is in
+contrast to Perl regular expression matches on those code points, in which a
+non-Unicode code point always fails to match. For example, both of these have
+the same result:
+
+ chr(0x110000) =~ \p{ASCII_Hex_Digit=True} # Fails.
+ chr(0x110000) =~ \p{ASCII_Hex_Digit=False} # Fails!
+
+And both raise a warning that a Unicode property is being used on a
+non-Unicode code point. It is arguable as to which is the correct thing to do
+here. This function has chosen the way opposite to the Perl regular
+expression behavior. This allows you to easily flip to to the Perl regular
+expression way (for you to go in the other direction would be far harder).
+Simply add 0x110000 at the end of the non-empty returned list if it isn't
+already that value; and pop that value if it is; like:
+
+ my @list = prop_invlist("foo");
+ if (@list) {
+ if ($list[-1] == 0x110000) {
+ pop @list; # Defeat the turning on for above Unicode
+ }
+ else {
+ push @list, 0x110000; # Turn off for above Unicode
+ }
+ }
+
+It is a simple matter to expand out an inversion list to a full list of all
+code points that have the property-value:
+
+ my @invlist = prop_invlist($property_name);
+ die "empty" unless @invlist;
+ my @full_list;
+ for (my $i = 0; $i < @invlist; $i += 2) {
+ my $upper = ($i + 1) < @invlist
+ ? $invlist[$i+1] - 1 # In range
+ : $Unicode::UCD::MAX_CP; # To infinity. You may want
+ # to stop much much earlier;
+ # going this high may expose
+ # perl deficiencies with very
+ # large numbers.
+ for my $j ($invlist[$i] .. $upper) {
+ push @full_list, $j;
+ }
+ }
+
+C<prop_invlist> does not know about any user-defined nor Perl internal-only
+properties, and will return C<undef> if called with one of those.
+
+=cut
+
+# User-defined properties could be handled with some changes to utf8_heavy.pl;
+# and implementing here of dealing with EXTRAS. If done, consideration should
+# be given to the fact that the user subroutine could return different results
+# with each call; security issues need to be thought about.
+
+# These are created by mktables for this routine and stored in unicore/UCD.pl
+# where their structures are described.
+our %loose_defaults;
+our $MAX_UNICODE_CODEPOINT;
+
+sub prop_invlist ($;$) {
+ my $prop = $_[0];
+
+ # Undocumented way to get at Perl internal properties
+ my $internal_ok = defined $_[1] && $_[1] eq '_perl_core_internal_ok';
+
+ return if ! defined $prop;
+
+ require "utf8_heavy.pl";
+
+ # Warnings for these are only for regexes, so not applicable to us
+ no warnings 'deprecated';
+
+ # Get the swash definition of the property-value.
+ my $swash = utf8::SWASHNEW(__PACKAGE__, $prop, undef, 1, 0);
+
+ # Fail if not found, or isn't a boolean property-value, or is a
+ # user-defined property, or is internal-only.
+ return if ! $swash
+ || ref $swash eq ""
+ || $swash->{'BITS'} != 1
+ || $swash->{'USER_DEFINED'}
+ || (! $internal_ok && $prop =~ /^\s*_/);
+
+ if ($swash->{'EXTRAS'}) {
+ carp __PACKAGE__, "::prop_invlist: swash returned for $prop unexpectedly has EXTRAS magic";
+ return;
+ }
+ if ($swash->{'SPECIALS'}) {
+ carp __PACKAGE__, "::prop_invlist: swash returned for $prop unexpectedly has SPECIALS magic";
+ return;
+ }
+
+ my @invlist;
+
+ # The input lines look like:
+ # 0041\t005A # [26]
+ # 005F
+
+ # Split into lines, stripped of trailing comments
+ foreach my $range (split "\n",
+ $swash->{'LIST'} =~ s/ \s* (?: \# .* )? $ //xmgr)
+ {
+ # And find the beginning and end of the range on the line
+ my ($hex_begin, $hex_end) = split "\t", $range;
+ my $begin = hex $hex_begin;
+
+ # If the new range merely extends the old, we remove the marker
+ # created the last time through the loop for the old's end, which
+ # causes the new one's end to be used instead.
+ if (@invlist && $begin == $invlist[-1]) {
+ pop @invlist;
+ }
+ else {
+ # Add the beginning of the range
+ push @invlist, $begin;
+ }
+
+ if (defined $hex_end) { # The next item starts with the code point 1
+ # beyond the end of the range.
+ push @invlist, hex($hex_end) + 1;
+ }
+ else { # No end of range, is a single code point.
+ push @invlist, $begin + 1;
+ }
+ }
+
+ require "unicore/UCD.pl";
+ my $FIRST_NON_UNICODE = $MAX_UNICODE_CODEPOINT + 1;
+
+ # Could need to be inverted: add or subtract a 0 at the beginning of the
+ # list. And to keep it from matching non-Unicode, add or subtract the
+ # first non-unicode code point.
+ if ($swash->{'INVERT_IT'}) {
+ if (@invlist && $invlist[0] == 0) {
+ shift @invlist;
+ }
+ else {
+ unshift @invlist, 0;
+ }
+ if (@invlist && $invlist[-1] == $FIRST_NON_UNICODE) {
+ pop @invlist;
+ }
+ else {
+ push @invlist, $FIRST_NON_UNICODE;
+ }
+ }
+
+ # Here, the list is set up to include only Unicode code points. But, if
+ # the table is the default one for the property, it should contain all
+ # non-Unicode code points. First calculate the loose name for the
+ # property. This is done even for strict-name properties, as the data
+ # structure that mktables generates for us is set up so that we don't have
+ # to worry about that. The property-value needs to be split if compound,
+ # as the loose rules need to be independently calculated on each part. We
+ # know that it is syntactically valid, or SWASHNEW would have failed.
+
+ $prop = lc $prop;
+ my ($prop_only, $table) = split /\s*[:=]\s*/, $prop;
+ if ($table) {
+
+ # May have optional prefixed 'is'
+ $prop = utf8::_loose_name($prop_only) =~ s/^is//r;
+ $prop = $utf8::loose_property_name_of{$prop};
+ $prop .= "=" . utf8::_loose_name($table);
+ }
+ else {
+ $prop = utf8::_loose_name($prop);
+ }
+ if (exists $loose_defaults{$prop}) {
+
+ # Here, is the default table. If a range ended with 10ffff, instead
+ # continue that range to infinity, by popping the 110000; otherwise,
+ # add the range from 11000 to infinity
+ if (! @invlist || $invlist[-1] != $FIRST_NON_UNICODE) {
+ push @invlist, $FIRST_NON_UNICODE;
+ }
+ else {
+ pop @invlist;
+ }
+ }
+
+ return @invlist;
+}
+
+sub _search_invlist {
+ # Find the range in the inversion list which contains a code point; that
+ # is, find i such that l[i] <= code_point < l[i+1]. Returns undef if no
+ # such i.
+
+ # If this is ever made public, could use to speed up .t specials. Would
+ # need to use code point argument, as in other functions in this pm
+
+ my $list_ref = shift;
+ my $code_point = shift;
+ # Verify non-neg numeric XXX
+
+ my $max_element = @$list_ref - 1;
+
+ # Return undef if list is empty or requested item is before the first element.
+ return if $max_element < 0;
+ return if $code_point < $list_ref->[0];
+
+ # Short cut something at the far-end of the table. This also allows us to
+ # refer to element [$i+1] without fear of being out-of-bounds in the loop
+ # below.
+ return $max_element if $code_point >= $list_ref->[$max_element];
+
+ use integer; # want integer division
+
+ my $i = $max_element / 2;
+
+ my $lower = 0;
+ my $upper = $max_element;
+ while (1) {
+
+ if ($code_point >= $list_ref->[$i]) {
+
+ # Here we have met the lower constraint. We can quit if we
+ # also meet the upper one.
+ last if $code_point < $list_ref->[$i+1];
+
+ $lower = $i; # Still too low.
+
+ }
+ else {
+
+ # Here, $code_point < $list_ref[$i], so look lower down.
+ $upper = $i;
+ }
+
+ # Split search domain in half to try again.
+ my $temp = ($upper + $lower) / 2;
+
+ # No point in continuing unless $i changes for next time
+ # in the loop.
+ return $i if $temp == $i;
+ $i = $temp;
+ } # End of while loop
+
+ # Here we have found the offset
+ return $i;
+}
+
+=pod
+
+=head2 B<prop_invmap()>
+
+ use Unicode::UCD 'prop_invmap';
+ my ($list_ref, $map_ref, $format, $missing)
+ = prop_invmap("General Category");
+
+C<prop_invmap> is used to get the complete mapping definition for a property,
+in the form of an inversion map. An inversion map consists of two parallel
+arrays. One is an ordered list of code points that mark range beginnings, and
+the other gives the value (or mapping) that all code points in the
+corresponding range have.
+
+C<prop_invmap> is called with the name of the desired property. The name is
+loosely matched, meaning that differences in case, white-space, hyphens, and
+underscores are not meaningful (except for the trailing underscore in the
+old-form grandfathered-in property C<"L_">, which is better written as C<"LC">,
+or even better, C<"Gc=LC">).
+
+Many Unicode properties have more than one name (or alias). C<prop_invmap>
+understands all of these, including Perl extensions to them. Ambiguities are
+resolved as described above for L</prop_aliases()>. The Perl internal
+property "Perl_Decimal_Digit, described below, is also accepted. C<undef> is
+returned if the property name is unknown.
+See L<perluniprops/Properties accessible through Unicode::UCD> for the
+properties acceptable as inputs to this function.
+
+It is a fatal error to call this function except in list context.
+
+In addition to the the two arrays that form the inversion map, C<prop_invmap>
+returns two other values; one is a scalar that gives some details as to the
+format of the entries of the map array; the other is used for specialized
+purposes, described at the end of this section.
+
+This means that C<prop_invmap> returns a 4 element list. For example,
+
+ my ($blocks_ranges_ref, $blocks_maps_ref, $format, $default)
+ = prop_invmap("Block");
+
+In this call, the two arrays will be populated as shown below (for Unicode
+6.0):
+
+ Index @blocks_ranges @blocks_maps
+ 0 0x0000 Basic Latin
+ 1 0x0080 Latin-1 Supplement
+ 2 0x0100 Latin Extended-A
+ 3 0x0180 Latin Extended-B
+ 4 0x0250 IPA Extensions
+ 5 0x02B0 Spacing Modifier Letters
+ 6 0x0300 Combining Diacritical Marks
+ 7 0x0370 Greek and Coptic
+ 8 0x0400 Cyrillic
+ ...
+ 233 0x2B820 No_Block
+ 234 0x2F800 CJK Compatibility Ideographs Supplement
+ 235 0x2FA20 No_Block
+ 236 0xE0000 Tags
+ 237 0xE0080 No_Block
+ 238 0xE0100 Variation Selectors Supplement
+ 239 0xE01F0 No_Block
+ 240 0xF0000 Supplementary Private Use Area-A
+ 241 0x100000 Supplementary Private Use Area-B
+ 242 0x110000 No_Block
+
+The first line (with Index [0]) means that the value for code point 0 is "Basic
+Latin". The entry "0x0080" in the @blocks_ranges column in the second line
+means that the value from the first line, "Basic Latin", extends to all code
+points in the range from 0 up to but not including 0x0080, that is, through
+127. In other words, the code points from 0 to 127 are all in the "Basic
+Latin" block. Similarly, all code points in the range from 0x0080 up to (but
+not including) 0x0100 are in the block named "Latin-1 Supplement", etc.
+(Notice that the return is the old-style block names; see L</Old-style versus
+new-style block names>).
+
+The final line (with Index [242]) means that the value for all code points above
+the legal Unicode maximum code point have the value "No_Block", which is the
+term Unicode uses for a non-existing block.
+
+The arrays completely specify the mappings for all possible code points.
+The final element in an inversion map returned by this function will always be
+for the range that consists of all the code points that aren't legal Unicode,
+but that are expressible on the platform. (That is, it starts with code point
+0x110000, the first code point above the legal Unicode maximum, and extends to
+infinity.) The value for that range will be the same that any typical
+unassigned code point has for the specified property. (Certain unassigned
+code points are not "typical"; for example the non-character code points, or
+those in blocks that are to be written right-to-left. The above-Unicode
+range's value is not based on these atypical code points.) It could be argued
+that, instead of treating these as unassigned Unicode code points, the value
+for this range should be C<undef>. If you wish, you can change the returned
+arrays accordingly.
+
+The maps are almost always simple scalars that should be interpreted as-is.
+These values are those given in the Unicode-supplied data files, which may be
+inconsistent as to capitalization and as to which synonym for a property-value
+is given. The results may be normalized by using the L</prop_value_aliases()>
+function.
+
+There are exceptions to the simple scalar maps. Some properties have some
+elements in their map list that are themselves lists of scalars; and some
+special strings are returned that are not to be interpreted as-is. Element
+[2] (placed into C<$format> in the example above) of the returned four element
+list tells you if the map has any of these special elements or not, as follows:
+
+=over
+
+=item B<C<s>>
+
+means all the elements of the map array are simple scalars, with no special
+elements. Almost all properties are like this, like the C<block> example
+above.
+
+=item B<C<sl>>
+
+means that some of the map array elements have the form given by C<"s">, and
+the rest are lists of scalars. For example, here is a portion of the output
+of calling C<prop_invmap>() with the "Script Extensions" property:
+
+ @scripts_ranges @scripts_maps
+ ...
+ 0x0953 Devanagari
+ 0x0964 [ Bengali, Devanagari, Gurumukhi, Oriya ]
+ 0x0966 Devanagari
+ 0x0970 Common
+
+Here, the code points 0x964 and 0x965 are both used in Bengali,
+Devanagari, Gurmukhi, and Oriya, but no other scripts.
+
+The Name_Alias property is also of this form. But each scalar consists of two
+components: 1) the name, and 2) the type of alias this is. They are
+separated by a colon and a space. In Unicode 6.1, there are several alias types:
+
+=over
+
+=item C<correction>
+
+indicates that the name is a corrected form for the
+original name (which remains valid) for the same code point.
+
+=item C<control>
+
+adds a new name for a control character.
+
+=item C<alternate>
+
+is an alternate name for a character
+
+=item C<figment>
+
+is a name for a character that has been documented but was never in any
+actual standard.
+
+=item C<abbreviation>
+
+is a common abbreviation for a character
+
+=back
+
+The lists are ordered (roughly) so the most preferred names come before less
+preferred ones.
+
+For example,
+
+ @aliases_ranges @alias_maps
+ ...
+ 0x009E [ 'PRIVACY MESSAGE: control', 'PM: abbreviation' ]
+ 0x009F [ 'APPLICATION PROGRAM COMMAND: control',
+ 'APC: abbreviation'
+ ]
+ 0x00A0 'NBSP: abbreviation'
+ 0x00A1 ""
+ 0x00AD 'SHY: abbreviation'
+ 0x00AE ""
+ 0x01A2 'LATIN CAPITAL LETTER GHA: correction'
+ 0x01A3 'LATIN SMALL LETTER GHA: correction'
+ 0x01A4 ""
+ ...
+
+A map to the empty string means that there is no alias defined for the code
+point.
+
+=item B<C<a>>
+
+is like C<"s"> in that all the map array elements are scalars, but here they are
+restricted to all being integers, and some have to be adjusted (hence the name
+C<"a">) to get the correct result. For example, in:
+
+ my ($uppers_ranges_ref, $uppers_maps_ref, $format)
+ = prop_invmap("Simple_Uppercase_Mapping");
+
+the returned arrays look like this:
+
+ @$uppers_ranges_ref @$uppers_maps_ref Note
+ 0 0
+ 97 65 'a' maps to 'A', b => B ...
+ 123 0
+ 181 924 MICRO SIGN => Greek Cap MU
+ 182 0
+ ...
+
+Let's start with the second line. It says that the uppercase of code point 97
+is 65; or C<uc("a")> == "A". But the line is for the entire range of code
+points 97 through 122. To get the mapping for any code point in a range, you
+take the offset it has from the beginning code point of the range, and add
+that to the mapping for that first code point. So, the mapping for 122 ("z")
+is derived by taking the offset of 122 from 97 (=25) and adding that to 65,
+yielding 90 ("z"). Likewise for everything in between.
+
+The first line works the same way. The first map in a range is always the
+correct value for its code point (because the adjustment is 0). Thus the
+C<uc(chr(0))> is just itself. Also, C<uc(chr(1))> is also itself, as the
+adjustment is 0+1-0 .. C<uc(chr(96))> is 96.
+
+Requiring this simple adjustment allows the returned arrays to be
+significantly smaller than otherwise, up to a factor of 10, speeding up
+searching through them.
+
+=item B<C<al>>
+
+means that some of the map array elements have the form given by C<"a">, and
+the rest are ordered lists of code points.
+For example, in:
+
+ my ($uppers_ranges_ref, $uppers_maps_ref, $format)
+ = prop_invmap("Uppercase_Mapping");
+
+the returned arrays look like this:
+
+ @$uppers_ranges_ref @$uppers_maps_ref
+ 0 0
+ 97 65
+ 123 0
+ 181 924
+ 182 0
+ ...
+ 0x0149 [ 0x02BC 0x004E ]
+ 0x014A 0
+ 0x014B 330
+ ...
+
+This is the full Uppercase_Mapping property (as opposed to the
+Simple_Uppercase_Mapping given in the example for format C<"a">). The only
+difference between the two in the ranges shown is that the code point at
+0x0149 (LATIN SMALL LETTER N PRECEDED BY APOSTROPHE) maps to a string of two
+characters, 0x02BC (MODIFIER LETTER APOSTROPHE) followed by 0x004E (LATIN
+CAPITAL LETTER N).
+
+No adjustments are needed to entries that are references to arrays; each such
+entry will have exactly one element in its range, so the offset is always 0.
+
+=item B<C<ae>>
+
+This is like C<"a">, but some elements are the empty string, and should not be
+adjusted.
+The one internal Perl property accessible by C<prop_invmap> is of this type:
+"Perl_Decimal_Digit" returns an inversion map which gives the numeric values
+that are represented by the Unicode decimal digit characters. Characters that
+don't represent decimal digits map to the empty string, like so:
+
+ @digits @values
+ 0x0000 ""
+ 0x0030 0
+ 0x003A: ""
+ 0x0660: 0
+ 0x066A: ""
+ 0x06F0: 0
+ 0x06FA: ""
+ 0x07C0: 0
+ 0x07CA: ""
+ 0x0966: 0
+ ...
+
+This means that the code points from 0 to 0x2F do not represent decimal digits;
+the code point 0x30 (DIGIT ZERO) represents 0; code point 0x31, (DIGIT ONE),
+represents 0+1-0 = 1; ... code point 0x39, (DIGIT NINE), represents 0+9-0 = 9;
+... code points 0x3A through 0x65F do not represent decimal digits; 0x660
+(ARABIC-INDIC DIGIT ZERO), represents 0; ... 0x07C1 (NKO DIGIT ONE),
+represents 0+1-0 = 1 ...
+
+=item B<C<ale>>
+
+is a combination of the C<"al"> type and the C<"ae"> type. Some of
+the map array elements have the forms given by C<"al">, and
+the rest are the empty string. The property C<NFKC_Casefold> has this form.
+An example slice is:
+
+ @$ranges_ref @$maps_ref Note
+ ...
+ 0x00AA 97 FEMININE ORDINAL INDICATOR => 'a'
+ 0x00AB 0
+ 0x00AD SOFT HYPHEN => ""
+ 0x00AE 0
+ 0x00AF [ 0x0020, 0x0304 ] MACRON => SPACE . COMBINING MACRON
+ 0x00B0 0
+ ...
+
+=item B<C<ar>>
+
+means that all the elements of the map array are either rational numbers or
+the string C<"NaN">, meaning "Not a Number". A rational number is either an
+integer, or two integers separated by a solidus (C<"/">). The second integer
+represents the denominator of the division implied by the solidus, and is
+actually always positive, so it is guaranteed not to be 0 and to not be
+signed. When the element is a plain integer (without the
+solidus), it may need to be adjusted to get the correct value by adding the
+offset, just as other C<"a"> properties. No adjustment is needed for
+fractions, as the range is guaranteed to have just a single element, and so
+the offset is always 0.
+
+If you want to convert the returned map to entirely scalar numbers, you
+can use something like this:
+
+ my ($invlist_ref, $invmap_ref, $format) = prop_invmap($property);
+ if ($format && $format eq "ar") {
+ map { $_ = eval $_ if $_ ne 'NaN' } @$map_ref;
+ }
+
+Here's some entries from the output of the property "Nv", which has format
+C<"ar">.
+
+ @numerics_ranges @numerics_maps Note
+ 0x00 "NaN"
+ 0x30 0 DIGIT 0 .. DIGIT 9
+ 0x3A "NaN"
+ 0xB2 2 SUPERSCRIPTs 2 and 3
+ 0xB4 "NaN"
+ 0xB9 1 SUPERSCRIPT 1
+ 0xBA "NaN"
+ 0xBC 1/4 VULGAR FRACTION 1/4
+ 0xBD 1/2 VULGAR FRACTION 1/2
+ 0xBE 3/4 VULGAR FRACTION 3/4
+ 0xBF "NaN"
+ 0x660 0 ARABIC-INDIC DIGIT ZERO .. NINE
+ 0x66A "NaN"
+
+=item B<C<n>>
+
+means the Name property. All the elements of the map array are simple
+scalars, but some of them contain special strings that require more work to
+get the actual name.
+
+Entries such as:
+
+ CJK UNIFIED IDEOGRAPH-<code point>
+
+mean that the name for the code point is "CJK UNIFIED IDEOGRAPH-"
+with the code point (expressed in hexadecimal) appended to it, like "CJK
+UNIFIED IDEOGRAPH-3403" (similarly for S<C<CJK COMPATIBILITY IDEOGRAPH-E<lt>code
+pointE<gt>>>).
+
+Also, entries like
+
+ <hangul syllable>
+
+means that the name is algorithmically calculated. This is easily done by
+the function L<charnames/charnames::viacode(code)>.
+
+Note that for control characters (C<Gc=cc>), Unicode's data files have the
+string "C<E<lt>controlE<gt>>", but the real name of each of these characters is the empty
+string. This function returns that real name, the empty string. (There are
+names for these characters, but they are considered aliases, not the Name
+property name, and are contained in the C<Name_Alias> property.)
+
+=item B<C<ad>>
+
+means the Decomposition_Mapping property. This property is like C<"al">
+properties, except that one of the scalar elements is of the form:
+
+ <hangul syllable>
+
+This signifies that this entry should be replaced by the decompositions for
+all the code points whose decomposition is algorithmically calculated. (All
+of them are currently in one range and no others outisde the range are likely
+to ever be added to Unicode; the C<"n"> format
+has this same entry.) These can be generated via the function
+L<Unicode::Normalize::NFD()|Unicode::Normalize>.
+
+Note that the mapping is the one that is specified in the Unicode data files,
+and to get the final decomposition, it may need to be applied recursively.
+
+=back
+
+Note that a format begins with the letter "a" if and only the property it is
+for requires adjustments by adding the offsets in multi-element ranges. For
+all these properties, an entry should be adjusted only if the map is a scalar
+which is an integer. That is, it must match the regular expression:
+
+ / ^ -? \d+ $ /xa
+
+Further, the first element in a range never needs adjustment, as the
+adjustment would be just adding 0.
+
+A binary search can be used to quickly find a code point in the inversion
+list, and hence its corresponding mapping.
+
+The final element (index [3], assigned to C<$default> in the "block" example) in
+the four element list returned by this function may be useful for applications
+that wish to convert the returned inversion map data structure into some
+other, such as a hash. It gives the mapping that most code points map to
+under the property. If you establish the convention that any code point not
+explicitly listed in your data structure maps to this value, you can
+potentially make your data structure much smaller. As you construct your data
+structure from the one returned by this function, simply ignore those ranges
+that map to this value, generally called the "default" value. For example, to
+convert to the data structure searchable by L</charinrange()>, you can follow
+this recipe for properties that don't require adjustments:
+
+ my ($list_ref, $map_ref, $format, $missing) = prop_invmap($property);
+ my @range_list;
+
+ # Look at each element in the list, but the -2 is needed because we
+ # look at $i+1 in the loop, and the final element is guaranteed to map
+ # to $missing by prop_invmap(), so we would skip it anyway.
+ for my $i (0 .. @$list_ref - 2) {
+ next if $map_ref->[$i] eq $missing;
+ push @range_list, [ $list_ref->[$i],
+ $list_ref->[$i+1],
+ $map_ref->[$i]
+ ];
+ }
+
+ print charinrange(\@range_list, $code_point), "\n";
+
+With this, C<charinrange()> will return C<undef> if its input code point maps
+to C<$missing>. You can avoid this by omitting the C<next> statement, and adding
+a line after the loop to handle the final element of the inversion map.
+
+Similarly, this recipe can be used for properties that do require adjustments:
+
+ for my $i (0 .. @$list_ref - 2) {
+ next if $map_ref->[$i] eq $missing;
+
+ # prop_invmap() guarantees that if the mapping is to an array, the
+ # range has just one element, so no need to worry about adjustments.
+ if (ref $map_ref->[$i]) {
+ push @range_list,
+ [ $list_ref->[$i], $list_ref->[$i], $map_ref->[$i] ];
+ }
+ else { # Otherwise each element is actually mapped to a separate
+ # value, so the range has to be split into single code point
+ # ranges.
+
+ my $adjustment = 0;
+
+ # For each code point that gets mapped to something...
+ for my $j ($list_ref->[$i] .. $list_ref->[$i+1] -1 ) {
+
+ # ... add a range consisting of just it mapping to the
+ # original plus the adjustment, which is incremented for the
+ # next time through the loop, as the offset increases by 1
+ # for each element in the range
+ push @range_list,
+ [ $j, $j, $map_ref->[$i] + $adjustment++ ];
+ }
+ }
+ }
+
+Note that the inversion maps returned for the C<Case_Folding> and
+C<Simple_Case_Folding> properties do not include the Turkic-locale mappings.
+Use L</casefold()> for these.
+
+C<prop_invmap> does not know about any user-defined properties, and will
+return C<undef> if called with one of those.
+
+=cut
+
+# User-defined properties could be handled with some changes to utf8_heavy.pl;
+# if done, consideration should be given to the fact that the user subroutine
+# could return different results with each call, which could lead to some
+# security issues.
+
+# One could store things in memory so they don't have to be recalculated, but
+# it is unlikely this will be called often, and some properties would take up
+# significant memory.
+
+# These are created by mktables for this routine and stored in unicore/UCD.pl
+# where their structures are described.
+our @algorithmic_named_code_points;
+our $HANGUL_BEGIN;
+our $HANGUL_COUNT;
+
+sub prop_invmap ($) {
+
+ croak __PACKAGE__, "::prop_invmap: must be called in list context" unless wantarray;
+
+ my $prop = $_[0];
+ return unless defined $prop;
+
+ # Fail internal properties
+ return if $prop =~ /^_/;
+
+ # The values returned by this function.
+ my (@invlist, @invmap, $format, $missing);
+
+ # The swash has two components we look at, the base list, and a hash,
+ # named 'SPECIALS', containing any additional members whose mappings don't
+ # fit into the the base list scheme of things. These generally 'override'
+ # any value in the base list for the same code point.
+ my $overrides;
+
+ require "utf8_heavy.pl";
+ require "unicore/UCD.pl";
+
+RETRY:
+
+ # If there are multiple entries for a single code point
+ my $has_multiples = 0;
+
+ # Try to get the map swash for the property. They have 'To' prepended to
+ # the property name, and 32 means we will accept 32 bit return values.
+ # The 0 means we aren't calling this from tr///.
+ my $swash = utf8::SWASHNEW(__PACKAGE__, "To$prop", undef, 32, 0);
+
+ # If didn't find it, could be because needs a proxy. And if was the
+ # 'Block' or 'Name' property, use a proxy even if did find it. Finding it
+ # in these cases would be the result of the installation changing mktables
+ # to output the Block or Name tables. The Block table gives block names
+ # in the new-style, and this routine is supposed to return old-style block
+ # names. The Name table is valid, but we need to execute the special code
+ # below to add in the algorithmic-defined name entries.
+ # And NFKCCF needs conversion, so handle that here too.
+ if (ref $swash eq ""
+ || $swash->{'TYPE'} =~ / ^ To (?: Blk | Na | NFKCCF ) $ /x)
+ {
+
+ # Get the short name of the input property, in standard form
+ my ($second_try) = prop_aliases($prop);
+ return unless $second_try;
+ $second_try = utf8::_loose_name(lc $second_try);
+
+ if ($second_try eq "in") {
+
+ # This property is identical to age for inversion map purposes
+ $prop = "age";
+ goto RETRY;
+ }
+ elsif ($second_try =~ / ^ s ( cf | fc | [ltu] c ) $ /x) {
+
+ # These properties use just the LIST part of the full mapping,
+ # which includes the simple maps that are otherwise overridden by
+ # the SPECIALS. So all we need do is to not look at the SPECIALS;
+ # set $overrides to indicate that
+ $overrides = -1;
+
+ # The full name is the simple name stripped of its initial 's'
+ $prop = $1;
+
+ # .. except for this case
+ $prop = 'cf' if $prop eq 'fc';
+
+ goto RETRY;
+ }
+ elsif ($second_try eq "blk") {
+
+ # We use the old block names. Just create a fake swash from its
+ # data.
+ _charblocks();
+ my %blocks;
+ $blocks{'LIST'} = "";
+ $blocks{'TYPE'} = "ToBlk";
+ $utf8::SwashInfo{ToBlk}{'missing'} = "No_Block";
+ $utf8::SwashInfo{ToBlk}{'format'} = "s";
+
+ foreach my $block (@BLOCKS) {
+ $blocks{'LIST'} .= sprintf "%x\t%x\t%s\n",
+ $block->[0],
+ $block->[1],
+ $block->[2];
+ }
+ $swash = \%blocks;
+ }
+ elsif ($second_try eq "na") {
+
+ # Use the combo file that has all the Name-type properties in it,
+ # extracting just the ones that are for the actual 'Name'
+ # property. And create a fake swash from it.
+ my %names;
+ $names{'LIST'} = "";
+ my $original = do "unicore/Name.pl";
+ my $algorithm_names = \@algorithmic_named_code_points;
+
+ # We need to remove the names from it that are aliases. For that
+ # we need to also read in that table. Create a hash with the keys
+ # being the code points, and the values being a list of the
+ # aliases for the code point key.
+ my ($aliases_code_points, $aliases_maps, undef, undef) =
+ &prop_invmap('Name_Alias');
+ my %aliases;
+ for (my $i = 0; $i < @$aliases_code_points; $i++) {
+ my $code_point = $aliases_code_points->[$i];
+ $aliases{$code_point} = $aliases_maps->[$i];
+
+ # If not already a list, make it into one, so that later we
+ # can treat things uniformly
+ if (! ref $aliases{$code_point}) {
+ $aliases{$code_point} = [ $aliases{$code_point} ];
+ }
+
+ # Remove the alias type from the entry, retaining just the
+ # name.
+ map { s/:.*// } @{$aliases{$code_point}};
+ }
+
+ my $i = 0;
+ foreach my $line (split "\n", $original) {
+ my ($hex_code_point, $name) = split "\t", $line;
+
+ # Weeds out all comments, blank lines, and named sequences
+ next if $hex_code_point =~ /[^[:xdigit:]]/a;
+
+ my $code_point = hex $hex_code_point;
+
+ # The name of all controls is the default: the empty string.
+ # The set of controls is immutable, so these hard-coded
+ # constants work.
+ next if $code_point <= 0x9F
+ && ($code_point <= 0x1F || $code_point >= 0x7F);
+
+ # If this is a name_alias, it isn't a name
+ next if grep { $_ eq $name } @{$aliases{$code_point}};
+
+ # If we are beyond where one of the special lines needs to
+ # be inserted ...
+ while ($i < @$algorithm_names
+ && $code_point > $algorithm_names->[$i]->{'low'})
+ {
+
+ # ... then insert it, ahead of what we were about to
+ # output
+ $names{'LIST'} .= sprintf "%x\t%x\t%s\n",
+ $algorithm_names->[$i]->{'low'},
+ $algorithm_names->[$i]->{'high'},
+ $algorithm_names->[$i]->{'name'};
+
+ # Done with this range.
+ $i++;
+
+ # We loop until all special lines that precede the next
+ # regular one are output.
+ }
+
+ # Here, is a normal name.
+ $names{'LIST'} .= sprintf "%x\t\t%s\n", $code_point, $name;
+ } # End of loop through all the names
+
+ $names{'TYPE'} = "ToNa";
+ $utf8::SwashInfo{ToNa}{'missing'} = "";
+ $utf8::SwashInfo{ToNa}{'format'} = "n";
+ $swash = \%names;
+ }
+ elsif ($second_try =~ / ^ ( d [mt] ) $ /x) {
+
+ # The file is a combination of dt and dm properties. Create a
+ # fake swash from the portion that we want.
+ my $original = do "unicore/Decomposition.pl";
+ my %decomps;
+
+ if ($second_try eq 'dt') {
+ $decomps{'TYPE'} = "ToDt";
+ $utf8::SwashInfo{'ToDt'}{'missing'} = "None";
+ $utf8::SwashInfo{'ToDt'}{'format'} = "s";
+ } # 'dm' is handled below, with 'nfkccf'
+
+ $decomps{'LIST'} = "";
+
+ # This property has one special range not in the file: for the
+ # hangul syllables. But not in Unicode version 1.
+ UnicodeVersion() unless defined $v_unicode_version;
+ my $done_hangul = ($v_unicode_version lt v2.0.0)
+ ? 1
+ : 0; # Have we done the hangul range ?
+ foreach my $line (split "\n", $original) {
+ my ($hex_lower, $hex_upper, $type_and_map) = split "\t", $line;
+ my $code_point = hex $hex_lower;
+ my $value;
+ my $redo = 0;
+
+ # The type, enclosed in <...>, precedes the mapping separated
+ # by blanks
+ if ($type_and_map =~ / ^ < ( .* ) > \s+ (.*) $ /x) {
+ $value = ($second_try eq 'dt') ? $1 : $2
+ }
+ else { # If there is no type specified, it's canonical
+ $value = ($second_try eq 'dt')
+ ? "Canonical" :
+ $type_and_map;
+ }
+
+ # Insert the hangul range at the appropriate spot.
+ if (! $done_hangul && $code_point > $HANGUL_BEGIN) {
+ $done_hangul = 1;
+ $decomps{'LIST'} .=
+ sprintf "%x\t%x\t%s\n",
+ $HANGUL_BEGIN,
+ $HANGUL_BEGIN + $HANGUL_COUNT - 1,
+ ($second_try eq 'dt')
+ ? "Canonical"
+ : "<hangul syllable>";
+ }
+
+ if ($value =~ / / && $hex_upper ne "" && $hex_upper ne $hex_lower) {
+ $line = sprintf("%04X\t%s\t%s", hex($hex_lower) + 1, $hex_upper, $value);
+ $hex_upper = "";
+ $redo = 1;
+ }
+
+ # And append this to our constructed LIST.
+ $decomps{'LIST'} .= "$hex_lower\t$hex_upper\t$value\n";
+
+ redo if $redo;
+ }
+ $swash = \%decomps;
+ }
+ elsif ($second_try ne 'nfkccf') { # Don't know this property. Fail.
+ return;
+ }
+
+ if ($second_try eq 'nfkccf' || $second_try eq 'dm') {
+
+ # The 'nfkccf' property is stored in the old format for backwards
+ # compatibility for any applications that has read its file
+ # directly before prop_invmap() existed.
+ # And the code above has extracted the 'dm' property from its file
+ # yielding the same format. So here we convert them to adjusted
+ # format for compatibility with the other properties similar to
+ # them.
+ my %revised_swash;
+
+ # We construct a new converted list.
+ my $list = "";
+
+ my @ranges = split "\n", $swash->{'LIST'};
+ for (my $i = 0; $i < @ranges; $i++) {
+ my ($hex_begin, $hex_end, $map) = split "\t", $ranges[$i];
+
+ # The dm property has maps that are space separated sequences
+ # of code points, as well as the special entry "<hangul
+ # syllable>, which also contains a blank.
+ my @map = split " ", $map;
+ if (@map > 1) {
+
+ # If it's just the special entry, append as-is.
+ if ($map eq '<hangul syllable>') {
+ $list .= "$ranges[$i]\n";
+ }
+ else {
+
+ # These should all be single-element ranges.
+ croak __PACKAGE__, "::prop_invmap: Not expecting a mapping with multiple code points in a multi-element range, $ranges[$i]" if $hex_end ne "" && $hex_end ne $hex_begin;
+
+ # Convert them to decimal, as that's what's expected.
+ $list .= "$hex_begin\t\t"
+ . join(" ", map { hex } @map)
+ . "\n";
+ }
+ next;
+ }
+
+ # Here, the mapping doesn't have a blank, is for a single code
+ # point.
+ my $begin = hex $hex_begin;
+ my $end = (defined $hex_end && $hex_end ne "")
+ ? hex $hex_end
+ : $begin;
+
+ # Again, the output is to be in decimal.
+ my $decimal_map = hex $map;
+
+ # We know that multi-element ranges with the same mapping
+ # should not be adjusted, as after the adjustment
+ # multi-element ranges are for consecutive increasing code
+ # points. Further, the final element in the list won't be
+ # adjusted, as there is nothing after it to include in the
+ # adjustment
+ if ($begin != $end || $i == @ranges -1) {
+
+ # So just convert these to single-element ranges
+ foreach my $code_point ($begin .. $end) {
+ $list .= sprintf("%04X\t\t%d\n",
+ $code_point, $decimal_map);
+ }
+ }
+ else {
+
+ # Here, we have a candidate for adjusting. What we do is
+ # look through the subsequent adjacent elements in the
+ # input. If the map to the next one differs by 1 from the
+ # one before, then we combine into a larger range with the
+ # initial map. Loop doing this until we find one that
+ # can't be combined.
+
+ my $offset = 0; # How far away are we from the initial
+ # map
+ my $squished = 0; # ? Did we squish at least two
+ # elements together into one range
+ for ( ; $i < @ranges; $i++) {
+ my ($next_hex_begin, $next_hex_end, $next_map)
+ = split "\t", $ranges[$i+1];
+
+ # In the case of 'dm', the map may be a sequence of
+ # multiple code points, which are never combined with
+ # another range
+ last if $next_map =~ / /;
+
+ $offset++;
+ my $next_decimal_map = hex $next_map;
+
+ # If the next map is not next in sequence, it
+ # shouldn't be combined.
+ last if $next_decimal_map != $decimal_map + $offset;
+
+ my $next_begin = hex $next_hex_begin;
+
+ # Likewise, if the next element isn't adjacent to the
+ # previous one, it shouldn't be combined.
+ last if $next_begin != $begin + $offset;
+
+ my $next_end = (defined $next_hex_end
+ && $next_hex_end ne "")
+ ? hex $next_hex_end
+ : $next_begin;
+
+ # And finally, if the next element is a multi-element
+ # range, it shouldn't be combined.
+ last if $next_end != $next_begin;
+
+ # Here, we will combine. Loop to see if we should
+ # combine the next element too.
+ $squished = 1;
+ }
+
+ if ($squished) {
+
+ # Here, 'i' is the element number of the last element to
+ # be combined, and the range is single-element, or we
+ # wouldn't be combining. Get it's code point.
+ my ($hex_end, undef, undef) = split "\t", $ranges[$i];
+ $list .= "$hex_begin\t$hex_end\t$decimal_map\n";
+ } else {
+
+ # Here, no combining done. Just appen the initial
+ # (and current) values.
+ $list .= "$hex_begin\t\t$decimal_map\n";
+ }
+ }
+ } # End of loop constructing the converted list
+
+ # Finish up the data structure for our converted swash
+ my $type = ($second_try eq 'nfkccf') ? 'ToNFKCCF' : 'ToDm';
+ $revised_swash{'LIST'} = $list;
+ $revised_swash{'TYPE'} = $type;
+ $revised_swash{'SPECIALS'} = $swash->{'SPECIALS'};
+ $swash = \%revised_swash;
+
+ $utf8::SwashInfo{$type}{'missing'} = 0;
+ $utf8::SwashInfo{$type}{'format'} = 'a';
+ }
+ }
+
+ if ($swash->{'EXTRAS'}) {
+ carp __PACKAGE__, "::prop_invmap: swash returned for $prop unexpectedly has EXTRAS magic";
+ return;
+ }
+
+ # Here, have a valid swash return. Examine it.
+ my $returned_prop = $swash->{'TYPE'};
+
+ # All properties but binary ones should have 'missing' and 'format'
+ # entries
+ $missing = $utf8::SwashInfo{$returned_prop}{'missing'};
+ $missing = 'N' unless defined $missing;
+
+ $format = $utf8::SwashInfo{$returned_prop}{'format'};
+ $format = 'b' unless defined $format;
+
+ my $requires_adjustment = $format =~ /^a/;
+
+ # The LIST input lines look like:
+ # ...
+ # 0374\t\tCommon
+ # 0375\t0377\tGreek # [3]
+ # 037A\t037D\tGreek # [4]
+ # 037E\t\tCommon
+ # 0384\t\tGreek
+ # ...
+ #
+ # Convert them to like
+ # 0374 => Common
+ # 0375 => Greek
+ # 0378 => $missing
+ # 037A => Greek
+ # 037E => Common
+ # 037F => $missing
+ # 0384 => Greek
+ #
+ # For binary properties, the final non-comment column is absent, and
+ # assumed to be 'Y'.
+
+ foreach my $range (split "\n", $swash->{'LIST'}) {
+ $range =~ s/ \s* (?: \# .* )? $ //xg; # rmv trailing space, comments
+
+ # Find the beginning and end of the range on the line
+ my ($hex_begin, $hex_end, $map) = split "\t", $range;
+ my $begin = hex $hex_begin;
+ my $end = (defined $hex_end && $hex_end ne "")
+ ? hex $hex_end
+ : $begin;
+
+ # Each time through the loop (after the first):
+ # $invlist[-2] contains the beginning of the previous range processed
+ # $invlist[-1] contains the end+1 of the previous range processed
+ # $invmap[-2] contains the value of the previous range processed
+ # $invmap[-1] contains the default value for missing ranges ($missing)
+ #
+ # Thus, things are set up for the typical case of a new non-adjacent
+ # range of non-missings to be added. But, if the new range is
+ # adjacent, it needs to replace the [-1] element; and if the new
+ # range is a multiple value of the previous one, it needs to be added
+ # to the [-2] map element.
+
+ # The first time through, everything will be empty. If the property
+ # doesn't have a range that begins at 0, add one that maps to $missing
+ if (! @invlist) {
+ if ($begin != 0) {
+ push @invlist, 0;
+ push @invmap, $missing;
+ }
+ }
+ elsif (@invlist > 1 && $invlist[-2] == $begin) {
+
+ # Here we handle the case where the input has multiple entries for
+ # each code point. mktables should have made sure that each such
+ # range contains only one code point. At this point, $invlist[-1]
+ # is the $missing that was added at the end of the last loop
+ # iteration, and [-2] is the last real input code point, and that
+ # code point is the same as the one we are adding now, making the
+ # new one a multiple entry. Add it to the existing entry, either
+ # by pushing it to the existing list of multiple entries, or
+ # converting the single current entry into a list with both on it.
+ # This is all we need do for this iteration.
+
+ if ($end != $begin) {
+ croak __PACKAGE__, ":prop_invmap: Multiple maps per code point in '$prop' require single-element ranges: begin=$begin, end=$end, map=$map";
+ }
+ if (! ref $invmap[-2]) {
+ $invmap[-2] = [ $invmap[-2], $map ];
+ }
+ else {
+ push @{$invmap[-2]}, $map;
+ }
+ $has_multiples = 1;
+ next;
+ }
+ elsif ($invlist[-1] == $begin) {
+
+ # If the input isn't in the most compact form, so that there are
+ # two adjacent ranges that map to the same thing, they should be
+ # combined (EXCEPT where the arrays require adjustments, in which
+ # case everything is already set up correctly). This happens in
+ # our constructed dt mapping, as Element [-2] is the map for the
+ # latest range so far processed. Just set the beginning point of
+ # the map to $missing (in invlist[-1]) to 1 beyond where this
+ # range ends. For example, in
+ # 12\t13\tXYZ
+ # 14\t17\tXYZ
+ # we have set it up so that it looks like
+ # 12 => XYZ
+ # 14 => $missing
+ #
+ # We now see that it should be
+ # 12 => XYZ
+ # 18 => $missing
+ if (! $requires_adjustment && @invlist > 1 && ( (defined $map)
+ ? $invmap[-2] eq $map
+ : $invmap[-2] eq 'Y'))
+ {
+ $invlist[-1] = $end + 1;
+ next;
+ }
+
+ # Here, the range started in the previous iteration that maps to
+ # $missing starts at the same code point as this range. That
+ # means there is no gap to fill that that range was intended for,
+ # so we just pop it off the parallel arrays.
+ pop @invlist;
+ pop @invmap;
+ }
+
+ # Add the range beginning, and the range's map.
+ push @invlist, $begin;
+ if ($returned_prop eq 'ToDm') {
+
+ # The decomposition maps are either a line like <hangul syllable>
+ # which are to be taken as is; or a sequence of code points in hex
+ # and separated by blanks. Convert them to decimal, and if there
+ # is more than one, use an anonymous array as the map.
+ if ($map =~ /^ < /x) {
+ push @invmap, $map;
+ }
+ else {
+ my @map = split " ", $map;
+ if (@map == 1) {
+ push @invmap, $map[0];
+ }
+ else {
+ push @invmap, \@map;
+ }
+ }
+ }
+ else {
+
+ # Otherwise, convert hex formatted list entries to decimal; add a
+ # 'Y' map for the missing value in binary properties, or
+ # otherwise, use the input map unchanged.
+ $map = ($format eq 'x')
+ ? hex $map
+ : $format eq 'b'
+ ? 'Y'
+ : $map;
+ push @invmap, $map;
+ }
+
+ # We just started a range. It ends with $end. The gap between it and
+ # the next element in the list must be filled with a range that maps
+ # to the default value. If there is no gap, the next iteration will
+ # pop this, unless there is no next iteration, and we have filled all
+ # of the Unicode code space, so check for that and skip.
+ if ($end < $MAX_UNICODE_CODEPOINT) {
+ push @invlist, $end + 1;
+ push @invmap, $missing;
+ }
+ }
+
+ # If the property is empty, make all code points use the value for missing
+ # ones.
+ if (! @invlist) {
+ push @invlist, 0;
+ push @invmap, $missing;
+ }
+
+ # And add in standard element that all non-Unicode code points map to:
+ # $missing
+ push @invlist, $MAX_UNICODE_CODEPOINT + 1;
+ push @invmap, $missing;
+
+ # The second component of the map are those values that require
+ # non-standard specification, stored in SPECIALS. These override any
+ # duplicate code points in LIST. If we are using a proxy, we may have
+ # already set $overrides based on the proxy.
+ $overrides = $swash->{'SPECIALS'} unless defined $overrides;
+ if ($overrides) {
+
+ # A negative $overrides implies that the SPECIALS should be ignored,
+ # and a simple 'a' list is the value.
+ if ($overrides < 0) {
+ $format = 'a';
+ }
+ else {
+
+ # Currently, all overrides are for properties that normally map to
+ # single code points, but now some will map to lists of code
+ # points (but there is an exception case handled below).
+ $format = 'al';
+
+ # Look through the overrides.
+ foreach my $cp_maybe_utf8 (keys %$overrides) {
+ my $cp;
+ my @map;
+
+ # If the overrides came from SPECIALS, the code point keys are
+ # packed UTF-8.
+ if ($overrides == $swash->{'SPECIALS'}) {
+ $cp = unpack("C0U", $cp_maybe_utf8);
+ @map = unpack "U0U*", $swash->{'SPECIALS'}{$cp_maybe_utf8};
+
+ # The empty string will show up unpacked as an empty
+ # array.
+ $format = 'ale' if @map == 0;
+ }
+ else {
+
+ # But if we generated the overrides, we didn't bother to
+ # pack them, and we, so far, do this only for properties
+ # that are 'a' ones.
+ $cp = $cp_maybe_utf8;
+ @map = hex $overrides->{$cp};
+ $format = 'a';
+ }
+
+ # Find the range that the override applies to.
+ my $i = _search_invlist(\@invlist, $cp);
+ if ($cp < $invlist[$i] || $cp >= $invlist[$i + 1]) {
+ croak __PACKAGE__, "::prop_invmap: wrong_range, cp=$cp; i=$i, current=$invlist[$i]; next=$invlist[$i + 1]"
+ }
+
+ # And what that range currently maps to
+ my $cur_map = $invmap[$i];
+
+ # If there is a gap between the next range and the code point
+ # we are overriding, we have to add elements to both arrays to
+ # fill that gap, using the map that applies to it, which is
+ # $cur_map, since it is part of the current range.
+ if ($invlist[$i + 1] > $cp + 1) {
+ #use feature 'say';
+ #say "Before splice:";
+ #say 'i-2=[', $i-2, ']', sprintf("%04X maps to %s", $invlist[$i-2], $invmap[$i-2]) if $i >= 2;
+ #say 'i-1=[', $i-1, ']', sprintf("%04X maps to %s", $invlist[$i-1], $invmap[$i-1]) if $i >= 1;
+ #say 'i =[', $i, ']', sprintf("%04X maps to %s", $invlist[$i], $invmap[$i]);
+ #say 'i+1=[', $i+1, ']', sprintf("%04X maps to %s", $invlist[$i+1], $invmap[$i+1]) if $i < @invlist + 1;
+ #say 'i+2=[', $i+2, ']', sprintf("%04X maps to %s", $invlist[$i+2], $invmap[$i+2]) if $i < @invlist + 2;
+
+ splice @invlist, $i + 1, 0, $cp + 1;
+ splice @invmap, $i + 1, 0, $cur_map;
+
+ #say "After splice:";
+ #say 'i-2=[', $i-2, ']', sprintf("%04X maps to %s", $invlist[$i-2], $invmap[$i-2]) if $i >= 2;
+ #say 'i-1=[', $i-1, ']', sprintf("%04X maps to %s", $invlist[$i-1], $invmap[$i-1]) if $i >= 1;
+ #say 'i =[', $i, ']', sprintf("%04X maps to %s", $invlist[$i], $invmap[$i]);
+ #say 'i+1=[', $i+1, ']', sprintf("%04X maps to %s", $invlist[$i+1], $invmap[$i+1]) if $i < @invlist + 1;
+ #say 'i+2=[', $i+2, ']', sprintf("%04X maps to %s", $invlist[$i+2], $invmap[$i+2]) if $i < @invlist + 2;
+ }
+
+ # If the remaining portion of the range is multiple code
+ # points (ending with the one we are replacing, guaranteed by
+ # the earlier splice). We must split it into two
+ if ($invlist[$i] < $cp) {
+ $i++; # Compensate for the new element
+
+ #use feature 'say';
+ #say "Before splice:";
+ #say 'i-2=[', $i-2, ']', sprintf("%04X maps to %s", $invlist[$i-2], $invmap[$i-2]) if $i >= 2;
+ #say 'i-1=[', $i-1, ']', sprintf("%04X maps to %s", $invlist[$i-1], $invmap[$i-1]) if $i >= 1;
+ #say 'i =[', $i, ']', sprintf("%04X maps to %s", $invlist[$i], $invmap[$i]);
+ #say 'i+1=[', $i+1, ']', sprintf("%04X maps to %s", $invlist[$i+1], $invmap[$i+1]) if $i < @invlist + 1;
+ #say 'i+2=[', $i+2, ']', sprintf("%04X maps to %s", $invlist[$i+2], $invmap[$i+2]) if $i < @invlist + 2;
+
+ splice @invlist, $i, 0, $cp;
+ splice @invmap, $i, 0, 'dummy';
+
+ #say "After splice:";
+ #say 'i-2=[', $i-2, ']', sprintf("%04X maps to %s", $invlist[$i-2], $invmap[$i-2]) if $i >= 2;
+ #say 'i-1=[', $i-1, ']', sprintf("%04X maps to %s", $invlist[$i-1], $invmap[$i-1]) if $i >= 1;
+ #say 'i =[', $i, ']', sprintf("%04X maps to %s", $invlist[$i], $invmap[$i]);
+ #say 'i+1=[', $i+1, ']', sprintf("%04X maps to %s", $invlist[$i+1], $invmap[$i+1]) if $i < @invlist + 1;
+ #say 'i+2=[', $i+2, ']', sprintf("%04X maps to %s", $invlist[$i+2], $invmap[$i+2]) if $i < @invlist + 2;
+ }
+
+ # Here, the range we are overriding contains a single code
+ # point. The result could be the empty string, a single
+ # value, or a list. If the last case, we use an anonymous
+ # array.
+ $invmap[$i] = (scalar @map == 0)
+ ? ""
+ : (scalar @map > 1)
+ ? \@map
+ : $map[0];
+ }
+ }
+ }
+ elsif ($format eq 'x') {
+
+ # All hex-valued properties are really to code points, and have been
+ # converted to decimal.
+ $format = 's';
+ }
+ elsif ($returned_prop eq 'ToDm') {
+ $format = 'ad';
+ }
+ elsif ($format eq 'sw') { # blank-separated elements to form a list.
+ map { $_ = [ split " ", $_ ] if $_ =~ / / } @invmap;
+ $format = 'sl';
+ }
+ elsif ($returned_prop eq 'ToNameAlias') {
+
+ # This property currently doesn't have any lists, but theoretically
+ # could
+ $format = 'sl';
+ }
+ elsif ($returned_prop eq 'ToPerlDecimalDigit') {
+ $format = 'ae';
+ }
+ elsif ($returned_prop eq 'ToNv') {
+
+ # The one property that has this format is stored as a delta, so needs
+ # to indicate that need to add code point to it.
+ $format = 'ar';
+ }
+ elsif ($format ne 'n' && $format ne 'a') {
+
+ # All others are simple scalars
+ $format = 's';
+ }
+ if ($has_multiples && $format !~ /l/) {
+ croak __PACKAGE__, "::prop_invmap: Wrong format '$format' for prop_invmap('$prop'); should indicate has lists";
+ }
+
+ return (\@invlist, \@invmap, $format, $missing);
+}
+
=head2 Unicode::UCD::UnicodeVersion
This returns the version of the Unicode Character Database, in other words, the
@@ -1364,11 +3533,13 @@
sub UnicodeVersion {
unless (defined $UNICODEVERSION) {
openunicode(\$VERSIONFH, "version");
+ local $/ = "\n";
chomp($UNICODEVERSION = <$VERSIONFH>);
close($VERSIONFH);
croak __PACKAGE__, "::VERSION: strange version '$UNICODEVERSION'"
unless $UNICODEVERSION =~ /^\d+(?:\.\d+)+$/;
}
+ $v_unicode_version = pack "C*", split /\./, $UNICODEVERSION;
return $UNICODEVERSION;
}
@@ -1377,7 +3548,8 @@
The difference between a block and a script is that scripts are closer
to the linguistic notion of a set of code points required to present
languages, while block is more of an artifact of the Unicode code point
-numbering and separation into blocks of (mostly) 256 code points.
+numbering and separation into blocks of consecutive code points (so far the
+size of a block is some multiple of 16, like 128 or 256).
For example the Latin B<script> is spread over several B<blocks>, such
as C<Basic Latin>, C<Latin 1 Supplement>, C<Latin Extended-A>, and
@@ -1397,14 +3569,41 @@
while C<\p{Blk=...}> is used for blocks (e.g. C<\p{Blk=Tibetan}> matches
any of the 256 code points in the Tibetan block).
+=head2 Old-style versus new-style block names
-=head2 Implementation Note
+Unicode publishes the names of blocks in two different styles, though the two
+are equivalent under Unicode's loose matching rules.
-The first use of charinfo() opens a read-only filehandle to the Unicode
-Character Database (the database is included in the Perl distribution).
-The filehandle is then kept open for further queries. In other words,
-if you are wondering where one of your filehandles went, that's where.
+The original style uses blanks and hyphens in the block names (except for
+C<No_Block>), like so:
+ Miscellaneous Mathematical Symbols-B
+
+The newer style replaces these with underscores, like this:
+
+ Miscellaneous_Mathematical_Symbols_B
+
+This newer style is consistent with the values of other Unicode properties.
+To preserve backward compatibility, all the functions in Unicode::UCD that
+return block names (except one) return the old-style ones. That one function,
+L</prop_value_aliases()> can be used to convert from old-style to new-style:
+
+ my $new_style = prop_values_aliases("block", $old_style);
+
+Perl also has single-form extensions that refer to blocks, C<In_Cyrillic>,
+meaning C<Block=Cyrillic>. These have always been written in the new style.
+
+To convert from new-style to old-style, follow this recipe:
+
+ $old_style = charblock((prop_invlist("block=$new_style"))[0]);
+
+(which finds the range of code points in the block using C<prop_invlist>,
+gets the lower end of the range (0th element) and then looks up the old name
+for its block using C<charblock>).
+
+Note that starting in Unicode 6.1, many of the block names have shorter
+synonyms. These are always given in the new style.
+
=head1 BUGS
Does not yet support EBCDIC platforms.
@@ -1411,7 +3610,7 @@
=head1 AUTHOR
-Jarkko Hietaniemi
+Jarkko Hietaniemi. Now maintained by perl5 porters.
=cut
Property changes on: trunk/contrib/perl/lib/Unicode/UCD.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/Unicode/UCD.t
===================================================================
--- trunk/contrib/perl/lib/Unicode/UCD.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/Unicode/UCD.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -17,10 +17,11 @@
use Unicode::UCD;
use Test::More;
-BEGIN { plan tests => 271 };
-
use Unicode::UCD 'charinfo';
+my $input_record_separator = 7; # Make sure Unicode::UCD isn't affected by
+$/ = $input_record_separator; # setting this.
+
my $charinfo;
is(charinfo(0x110000), undef, "Verify charinfo() of non-unicode is undef");
@@ -241,6 +242,50 @@
is($charinfo->{block}, 'Latin-1 Supplement');
is($charinfo->{script}, 'Common');
+# This is to test a case where both simple and full lowercases exist and
+# differ
+$charinfo = charinfo(0x130);
+
+is($charinfo->{code}, '0130', 'LATIN CAPITAL LETTER I WITH DOT ABOVE');
+is($charinfo->{name}, 'LATIN CAPITAL LETTER I WITH DOT ABOVE');
+is($charinfo->{category}, 'Lu');
+is($charinfo->{combining}, '0');
+is($charinfo->{bidi}, 'L');
+is($charinfo->{decomposition}, '0049 0307');
+is($charinfo->{decimal}, '');
+is($charinfo->{digit}, '');
+is($charinfo->{numeric}, '');
+is($charinfo->{mirrored}, 'N');
+is($charinfo->{unicode10}, 'LATIN CAPITAL LETTER I DOT');
+is($charinfo->{comment}, '');
+is($charinfo->{upper}, '');
+is($charinfo->{lower}, '0069');
+is($charinfo->{title}, '');
+is($charinfo->{block}, 'Latin Extended-A');
+is($charinfo->{script}, 'Latin');
+
+# This is to test a case where both simple and full uppercases exist and
+# differ
+$charinfo = charinfo(0x1F80);
+
+is($charinfo->{code}, '1F80', 'GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI');
+is($charinfo->{name}, 'GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI');
+is($charinfo->{category}, 'Ll');
+is($charinfo->{combining}, '0');
+is($charinfo->{bidi}, 'L');
+is($charinfo->{decomposition}, '1F00 0345');
+is($charinfo->{decimal}, '');
+is($charinfo->{digit}, '');
+is($charinfo->{numeric}, '');
+is($charinfo->{mirrored}, 'N');
+is($charinfo->{unicode10}, '');
+is($charinfo->{comment}, '');
+is($charinfo->{upper}, '1F88');
+is($charinfo->{lower}, '');
+is($charinfo->{title}, '1F88');
+is($charinfo->{block}, 'Greek Extended');
+is($charinfo->{script}, 'Greek');
+
use Unicode::UCD qw(charblocks charscripts);
my $charblocks = charblocks();
@@ -298,7 +343,7 @@
# If this fails, then maybe one should look at the Unicode changes to see
# what else might need to be updated.
-is(Unicode::UCD::UnicodeVersion, '6.0.0', 'UnicodeVersion');
+is(Unicode::UCD::UnicodeVersion, '6.2.0', 'UnicodeVersion');
use Unicode::UCD qw(compexcl);
@@ -329,9 +374,9 @@
is($casefold->{simple}, "", 'casefold 0xDF simple');
is($casefold->{turkic}, "", 'casefold 0xDF turkic');
-# Do different tests depending on if version <= 3.1, or not.
-(my $version = Unicode::UCD::UnicodeVersion) =~ /^(\d+)\.(\d+)/;
-if (defined $1 && ($1 <= 2 || $1 == 3 && defined $2 && $2 <= 1)) {
+# Do different tests depending on if version < 3.2, or not.
+my $v_unicode_version = pack "C*", split /\./, Unicode::UCD::UnicodeVersion();
+if ($v_unicode_version lt v3.2.0) {
$casefold = casefold(0x130);
is($casefold->{code}, '0130', 'casefold 0x130 code');
@@ -425,11 +470,13 @@
{
my $r1 = charscript('Latin');
- my $n1 = @$r1;
- is($n1, 30, "number of ranges in Latin script (Unicode 6.0.0)");
- shift @$r1 while @$r1;
- my $r2 = charscript('Latin');
- is(@$r2, $n1, "modifying results should not mess up internal caches");
+ if (ok(defined $r1, "Found Latin script")) {
+ my $n1 = @$r1;
+ is($n1, 30, "number of ranges in Latin script (Unicode 6.1.0)");
+ shift @$r1 while @$r1;
+ my $r2 = charscript('Latin');
+ is(@$r2, $n1, "modifying results should not mess up internal caches");
+ }
}
{
@@ -457,8 +504,8 @@
is(num("0"), 0, 'Verify num("0") == 0');
is(num("98765"), 98765, 'Verify num("98765") == 98765');
ok(! defined num("98765\N{FULLWIDTH DIGIT FOUR}"), 'Verify num("98765\N{FULLWIDTH DIGIT FOUR}") isnt defined');
-is(num("\N{NEW TAI LUE DIGIT TWO}\N{NEW TAI LUE DIGIT ONE}"), 21, 'Verify \N{NEW TAI LUE DIGIT TWO}\N{NEW TAI LUE DIGIT ONE}" == 21');
-ok(! defined num("\N{NEW TAI LUE DIGIT TWO}\N{NEW TAI LUE THAM DIGIT ONE}"), 'Verify \N{NEW TAI LUE DIGIT TWO}\N{NEW TAI LUE THAM DIGIT ONE}" isnt defined');
+is(num("\N{NEW TAI LUE DIGIT TWO}\N{NEW TAI LUE DIGIT ONE}"), 21, 'Verify num("\N{NEW TAI LUE DIGIT TWO}\N{NEW TAI LUE DIGIT ONE}") == 21');
+ok(! defined num("\N{NEW TAI LUE DIGIT TWO}\N{NEW TAI LUE THAM DIGIT ONE}"), 'Verify num("\N{NEW TAI LUE DIGIT TWO}\N{NEW TAI LUE THAM DIGIT ONE}") isnt defined');
is(num("\N{CHAM DIGIT ZERO}\N{CHAM DIGIT THREE}"), 3, 'Verify num("\N{CHAM DIGIT ZERO}\N{CHAM DIGIT THREE}") == 3');
ok(! defined num("\N{CHAM DIGIT ZERO}\N{JAVANESE DIGIT NINE}"), 'Verify num("\N{CHAM DIGIT ZERO}\N{JAVANESE DIGIT NINE}") isnt defined');
is(num("\N{SUPERSCRIPT TWO}"), 2, 'Verify num("\N{SUPERSCRIPT TWO} == 2');
@@ -465,3 +512,1519 @@
is(num("\N{ETHIOPIC NUMBER TEN THOUSAND}"), 10000, 'Verify num("\N{ETHIOPIC NUMBER TEN THOUSAND}") == 10000');
is(num("\N{NORTH INDIC FRACTION ONE HALF}"), .5, 'Verify num("\N{NORTH INDIC FRACTION ONE HALF}") == .5');
is(num("\N{U+12448}"), 9, 'Verify num("\N{U+12448}") == 9');
+is(num("\N{U+5146}"), 1000000000000, 'Verify num("\N{U+5146}") == 1000000000000');
+
+# Create a user-defined property
+sub InKana {<<'END'}
+3040 309F
+30A0 30FF
+END
+
+use Unicode::UCD qw(prop_aliases);
+
+is(prop_aliases(undef), undef, "prop_aliases(undef) returns <undef>");
+is(prop_aliases("unknown property"), undef,
+ "prop_aliases(<unknown property>) returns <undef>");
+is(prop_aliases("InKana"), undef,
+ "prop_aliases(<user-defined property>) returns <undef>");
+is(prop_aliases("Perl_Decomposition_Mapping"), undef, "prop_aliases('Perl_Decomposition_Mapping') returns <undef> since internal-Perl-only");
+is(prop_aliases("Perl_Charnames"), undef,
+ "prop_aliases('Perl_Charnames') returns <undef> since internal-Perl-only");
+is(prop_aliases("isgc"), undef,
+ "prop_aliases('isgc') returns <undef> since is not covered Perl extension");
+is(prop_aliases("Is_Is_Any"), undef,
+ "prop_aliases('Is_Is_Any') returns <undef> since two is's");
+
+require 'utf8_heavy.pl';
+require "unicore/Heavy.pl";
+
+# Keys are lists of properties. Values are defined if have been tested.
+my %props;
+
+# To test for loose matching, add in the characters that are ignored there.
+my $extra_chars = "-_ ";
+
+# The one internal property we accept
+$props{'Perl_Decimal_Digit'} = 1;
+my @list = prop_aliases("perldecimaldigit");
+is_deeply(\@list,
+ [ "Perl_Decimal_Digit",
+ "Perl_Decimal_Digit"
+ ], "prop_aliases('perldecimaldigit') returns Perl_Decimal_Digit as both short and full names");
+
+# Get the official Unicode property name synonyms and test them.
+
+SKIP: {
+skip "PropertyAliases.txt is not in this Unicode version", 1 if $v_unicode_version lt v3.2.0;
+open my $props, "<", "../lib/unicore/PropertyAliases.txt"
+ or die "Can't open Unicode PropertyAliases.txt";
+local $/ = "\n";
+while (<$props>) {
+ s/\s*#.*//; # Remove comments
+ next if /^\s* $/x; # Ignore empty and comment lines
+
+ chomp;
+ local $/ = $input_record_separator;
+ my $count = 0; # 0th field in line is short name; 1th is long name
+ my $short_name;
+ my $full_name;
+ my @names_via_short;
+ foreach my $alias (split /\s*;\s*/) { # Fields are separated by
+ # semi-colons
+ # Add in the characters that are supposed to be ignored, to test loose
+ # matching, which the tested function does on all inputs.
+ my $mod_name = "$extra_chars$alias";
+
+ my $loose = &utf8::_loose_name(lc $alias);
+
+ # Indicate we have tested this.
+ $props{$loose} = 1;
+
+ my @all_names = prop_aliases($mod_name);
+ if (grep { $_ eq $loose } @Unicode::UCD::suppressed_properties) {
+ is(@all_names, 0, "prop_aliases('$mod_name') returns undef since $alias is not installed");
+ next;
+ }
+ elsif (! @all_names) {
+ fail("prop_aliases('$mod_name')");
+ diag("'$alias' is unknown to prop_aliases()");
+ next;
+ }
+
+ if ($count == 0) { # Is short name
+
+ @names_via_short = prop_aliases($mod_name);
+
+ # If the 0th test fails, no sense in continuing with the others
+ last unless is($names_via_short[0], $alias,
+ "prop_aliases: '$alias' is the short name for '$mod_name'");
+ $short_name = $alias;
+ }
+ elsif ($count == 1) { # Is full name
+
+ # Some properties have the same short and full name; no sense
+ # repeating the test if the same.
+ if ($alias ne $short_name) {
+ my @names_via_full = prop_aliases($mod_name);
+ is_deeply(\@names_via_full, \@names_via_short, "prop_aliases() returns the same list for both '$short_name' and '$mod_name'");
+ }
+
+ # Tests scalar context
+ is(prop_aliases($short_name), $alias,
+ "prop_aliases: '$alias' is the long name for '$short_name'");
+ }
+ else { # Is another alias
+ is_deeply(\@all_names, \@names_via_short, "prop_aliases() returns the same list for both '$short_name' and '$mod_name'");
+ ok((grep { $_ =~ /^$alias$/i } @all_names),
+ "prop_aliases: '$alias' is listed as an alias for '$mod_name'");
+ }
+
+ $count++;
+ }
+}
+} # End of SKIP block
+
+# Now test anything we can find that wasn't covered by the tests of the
+# official properties. We have no way of knowing if mktables omitted a Perl
+# extension or not, but we do the best we can from its generated lists
+
+foreach my $alias (keys %utf8::loose_to_file_of) {
+ next if $alias =~ /=/;
+ my $lc_name = lc $alias;
+ my $loose = &utf8::_loose_name($lc_name);
+ next if exists $props{$loose}; # Skip if already tested
+ $props{$loose} = 1;
+ my $mod_name = "$extra_chars$alias"; # Tests loose matching
+ my @aliases = prop_aliases($mod_name);
+ my $found_it = grep { &utf8::_loose_name(lc $_) eq $lc_name } @aliases;
+ if ($found_it) {
+ pass("prop_aliases: '$lc_name' is listed as an alias for '$mod_name'");
+ }
+ elsif ($lc_name =~ /l[_&]$/) {
+
+ # These two names are special in that they don't appear in the
+ # returned list because they are discouraged from use. Verify
+ # that they return the same list as a non-discouraged version.
+ my @LC = prop_aliases('Is_LC');
+ is_deeply(\@aliases, \@LC, "prop_aliases: '$lc_name' returns the same list as 'Is_LC'");
+ }
+ else {
+ my $stripped = $lc_name =~ s/^is//;
+
+ # Could be that the input includes a prefix 'is', which is rarely
+ # returned as an alias, so having successfully stripped it off above,
+ # try again.
+ if ($stripped) {
+ $found_it = grep { &utf8::_loose_name(lc $_) eq $lc_name } @aliases;
+ }
+
+ # If that didn't work, it could be that it's a block, which is always
+ # returned with a leading 'In_' to avoid ambiguity. Try comparing
+ # with that stripped off.
+ if (! $found_it) {
+ $found_it = grep { &utf8::_loose_name(s/^In_(.*)/\L$1/r) eq $lc_name }
+ @aliases;
+ # Could check that is a real block, but tests for invmap will
+ # likely pickup any errors, since this will be tested there.
+ $lc_name = "in$lc_name" if $found_it; # Change for message below
+ }
+ my $message = "prop_aliases: '$lc_name' is listed as an alias for '$mod_name'";
+ ($found_it) ? pass($message) : fail($message);
+ }
+}
+
+my $done_equals = 0;
+foreach my $alias (keys %utf8::stricter_to_file_of) {
+ if ($alias =~ /=/) { # Only test one case where there is an equals
+ next if $done_equals;
+ $done_equals = 1;
+ }
+ my $lc_name = lc $alias;
+ my @list = prop_aliases($alias);
+ if ($alias =~ /^_/) {
+ is(@list, 0, "prop_aliases: '$lc_name' returns an empty list since it is internal_only");
+ }
+ elsif ($alias =~ /=/) {
+ is(@list, 0, "prop_aliases: '$lc_name' returns an empty list since is illegal property name");
+ }
+ else {
+ ok((grep { lc $_ eq $lc_name } @list),
+ "prop_aliases: '$lc_name' is listed as an alias for '$alias'");
+ }
+}
+
+use Unicode::UCD qw(prop_value_aliases);
+
+is(prop_value_aliases("unknown property", "unknown value"), undef,
+ "prop_value_aliases(<unknown property>, <unknown value>) returns <undef>");
+is(prop_value_aliases(undef, undef), undef,
+ "prop_value_aliases(undef, undef) returns <undef>");
+is((prop_value_aliases("na", "A")), "A", "test that prop_value_aliases returns its input for properties that don't have synonyms");
+is(prop_value_aliases("isgc", "C"), undef, "prop_value_aliases('isgc', 'C') returns <undef> since is not covered Perl extension");
+is(prop_value_aliases("gc", "isC"), undef, "prop_value_aliases('gc', 'isC') returns <undef> since is not covered Perl extension");
+
+# We have no way of knowing if mktables omitted a Perl extension that it
+# shouldn't have, but we can check if it omitted an official Unicode property
+# name synonym. And for those, we can check if the short and full names are
+# correct.
+
+my %pva_tested; # List of things already tested.
+
+SKIP: {
+skip "PropValueAliases.txt is not in this Unicode version", 1 if $v_unicode_version lt v3.2.0;
+open my $propvalues, "<", "../lib/unicore/PropValueAliases.txt"
+ or die "Can't open Unicode PropValueAliases.txt";
+local $/ = "\n";
+while (<$propvalues>) {
+ s/\s*#.*//; # Remove comments
+ next if /^\s* $/x; # Ignore empty and comment lines
+ chomp;
+ local $/ = $input_record_separator;
+
+ # Fix typo in official input file
+ s/CCC133/CCC132/g if $v_unicode_version eq v6.1.0;
+
+ my @fields = split /\s*;\s*/; # Fields are separated by semi-colons
+ my $prop = shift @fields; # 0th field is the property,
+ my $count = 0; # 0th field in line (after shifting off the property) is
+ # short name; 1th is long name
+ my $short_name;
+ my @names_via_short; # Saves the values between iterations
+
+ # The property on the lhs of the = is always loosely matched. Add in
+ # characters that are ignored under loose matching to test that
+ my $mod_prop = "$extra_chars$prop";
+
+ if ($fields[0] eq 'n/a') { # See comments in input file, essentially
+ # means full name and short name are identical
+ $fields[0] = $fields[1];
+ }
+ elsif ($fields[0] ne $fields[1]
+ && &utf8::_loose_name(lc $fields[0])
+ eq &utf8::_loose_name(lc $fields[1])
+ && $fields[1] !~ /[[:upper:]]/)
+ {
+ # Also, there is a bug in the file in which "n/a" is omitted, and
+ # the two fields are identical except for case, and the full name
+ # is all lower case. Copy the "short" name unto the full one to
+ # give it some upper case.
+
+ $fields[1] = $fields[0];
+ }
+
+ # The ccc property in the file is special; has an extra numeric field
+ # (0th), which should go at the end, since we use the next two fields as
+ # the short and full names, respectively. See comments in input file.
+ splice (@fields, 0, 0, splice(@fields, 1, 2)) if $prop eq 'ccc';
+
+ my $loose_prop = &utf8::_loose_name(lc $prop);
+ my $suppressed = grep { $_ eq $loose_prop }
+ @Unicode::UCD::suppressed_properties;
+ foreach my $value (@fields) {
+ if ($suppressed) {
+ is(prop_value_aliases($prop, $value), undef, "prop_value_aliases('$prop', '$value') returns undef for suppressed property $prop");
+ next;
+ }
+ elsif (grep { $_ eq ("$loose_prop=" . &utf8::_loose_name(lc $value)) } @Unicode::UCD::suppressed_properties) {
+ is(prop_value_aliases($prop, $value), undef, "prop_value_aliases('$prop', '$value') returns undef for suppressed property $prop=$value");
+ next;
+ }
+
+ # Add in test for loose matching.
+ my $mod_value = "$extra_chars$value";
+
+ # If the value is a number, optionally negative, including a floating
+ # point or rational numer, it should be only strictly matched, so the
+ # loose matching should fail.
+ if ($value =~ / ^ -? \d+ (?: [\/.] \d+ )? $ /x) {
+ is(prop_value_aliases($mod_prop, $mod_value), undef, "prop_value_aliases('$mod_prop', '$mod_value') returns undef because '$mod_value' should be strictly matched");
+
+ # And reset so below tests just the strict matching.
+ $mod_value = $value;
+ }
+
+ if ($count == 0) {
+
+ @names_via_short = prop_value_aliases($mod_prop, $mod_value);
+
+ # If the 0th test fails, no sense in continuing with the others
+ last unless is($names_via_short[0], $value, "prop_value_aliases: In '$prop', '$value' is the short name for '$mod_value'");
+ $short_name = $value;
+ }
+ elsif ($count == 1) {
+
+ # Some properties have the same short and full name; no sense
+ # repeating the test if the same.
+ if ($value ne $short_name) {
+ my @names_via_full =
+ prop_value_aliases($mod_prop, $mod_value);
+ is_deeply(\@names_via_full, \@names_via_short, "In '$prop', prop_value_aliases() returns the same list for both '$short_name' and '$mod_value'");
+ }
+
+ # Tests scalar context
+ is(prop_value_aliases($prop, $short_name), $value, "'$value' is the long name for prop_value_aliases('$prop', '$short_name')");
+ }
+ else {
+ my @all_names = prop_value_aliases($mod_prop, $mod_value);
+ is_deeply(\@all_names, \@names_via_short, "In '$prop', prop_value_aliases() returns the same list for both '$short_name' and '$mod_value'");
+ ok((grep { &utf8::_loose_name(lc $_) eq &utf8::_loose_name(lc $value) } prop_value_aliases($prop, $short_name)), "'$value' is listed as an alias for prop_value_aliases('$prop', '$short_name')");
+ }
+
+ $pva_tested{&utf8::_loose_name(lc $prop) . "=" . &utf8::_loose_name(lc $value)} = 1;
+ $count++;
+ }
+}
+} # End of SKIP block
+
+# And test as best we can, the non-official pva's that mktables generates.
+foreach my $hash (\%utf8::loose_to_file_of, \%utf8::stricter_to_file_of) {
+ foreach my $test (keys %$hash) {
+ next if exists $pva_tested{$test}; # Skip if already tested
+
+ my ($prop, $value) = split "=", $test;
+ next unless defined $value; # prop_value_aliases() requires an input
+ # 'value'
+ my $mod_value;
+ if ($hash == \%utf8::loose_to_file_of) {
+
+ # Add extra characters to test loose-match rhs value
+ $mod_value = "$extra_chars$value";
+ }
+ else { # Here value is strictly matched.
+
+ # Extra elements are added by mktables to this hash so that
+ # something like "age=6.0" has a synonym of "age=6". It's not
+ # clear to me (khw) if we should be encouraging those synonyms, so
+ # don't test for them.
+ next if $value !~ /\D/ && exists $hash->{"$prop=$value.0"};
+
+ # Verify that loose matching fails when only strict is called for.
+ next unless is(prop_value_aliases($prop, "$extra_chars$value"), undef,
+ "prop_value_aliases('$prop', '$extra_chars$value') returns undef since '$value' should be strictly matched"),
+
+ # Strict matching does allow for underscores between digits. Test
+ # for that.
+ $mod_value = $value;
+ while ($mod_value =~ s/(\d)(\d)/$1_$2/g) {}
+ }
+
+ # The lhs property is always loosely matched, so add in extra
+ # characters to test that.
+ my $mod_prop = "$extra_chars$prop";
+
+ if ($prop eq 'gc' && $value =~ /l[_&]$/) {
+ # These two names are special in that they don't appear in the
+ # returned list because they are discouraged from use. Verify
+ # that they return the same list as a non-discouraged version.
+ my @LC = prop_value_aliases('gc', 'lc');
+ my @l_ = prop_value_aliases($mod_prop, $mod_value);
+ is_deeply(\@l_, \@LC, "prop_value_aliases('$mod_prop', '$mod_value) returns the same list as prop_value_aliases('gc', 'lc')");
+ }
+ else {
+ ok((grep { &utf8::_loose_name(lc $_) eq &utf8::_loose_name(lc $value) }
+ prop_value_aliases($mod_prop, $mod_value)),
+ "'$value' is listed as an alias for prop_value_aliases('$mod_prop', '$mod_value')");
+ }
+ }
+}
+
+undef %pva_tested;
+
+no warnings 'once'; # We use some values once from 'required' modules.
+
+use Unicode::UCD qw(prop_invlist prop_invmap MAX_CP);
+
+# There were some problems with caching interfering with prop_invlist() vs
+# prop_invmap() on binary properties, and also between the 3 properties where
+# Perl used the same 'To' name as another property (see utf8_heavy.pl).
+# So, before testing all of prop_invlist(),
+# 1) call prop_invmap() to try both orders of these name issues. This uses
+# up two of the 3 properties; the third will be left so that invlist()
+# on it gets called before invmap()
+# 2) call prop_invmap() on a generic binary property, ahead of invlist().
+# This should test that the caching works in both directions.
+
+# These properties are not stable between Unicode versions, but the first few
+# elements are; just look at the first element to see if are getting the
+# distinction right. The general inversion map testing below will test the
+# whole thing.
+my $prop = "uc";
+my ($invlist_ref, $invmap_ref, $format, $missing) = prop_invmap($prop);
+is($format, 'al', "prop_invmap() format of '$prop' is 'al'");
+is($missing, '0', "prop_invmap() missing of '$prop' is '0'");
+is($invlist_ref->[1], 0x61, "prop_invmap('$prop') list[1] is 0x61");
+is($invmap_ref->[1], 0x41, "prop_invmap('$prop') map[1] is 0x41");
+
+$prop = "upper";
+($invlist_ref, $invmap_ref, $format, $missing) = prop_invmap($prop);
+is($format, 's', "prop_invmap() format of '$prop' is 's");
+is($missing, 'N', "prop_invmap() missing of '$prop' is 'N'");
+is($invlist_ref->[1], 0x41, "prop_invmap('$prop') list[1] is 0x41");
+is($invmap_ref->[1], 'Y', "prop_invmap('$prop') map[1] is 'Y'");
+
+$prop = "lower";
+($invlist_ref, $invmap_ref, $format, $missing) = prop_invmap($prop);
+is($format, 's', "prop_invmap() format of '$prop' is 's'");
+is($missing, 'N', "prop_invmap() missing of '$prop' is 'N'");
+is($invlist_ref->[1], 0x61, "prop_invmap('$prop') list[1] is 0x61");
+is($invmap_ref->[1], 'Y', "prop_invmap('$prop') map[1] is 'Y'");
+
+$prop = "lc";
+($invlist_ref, $invmap_ref, $format, $missing) = prop_invmap($prop);
+is($format, 'al', "prop_invmap() format of '$prop' is 'al'");
+is($missing, '0', "prop_invmap() missing of '$prop' is '0'");
+is($invlist_ref->[1], 0x41, "prop_invmap('$prop') list[1] is 0x41");
+is($invmap_ref->[1], 0x61, "prop_invmap('$prop') map[1] is 0x61");
+
+# This property is stable and small, so can test all of it
+$prop = "ASCII_Hex_Digit";
+($invlist_ref, $invmap_ref, $format, $missing) = prop_invmap($prop);
+is($format, 's', "prop_invmap() format of '$prop' is 's'");
+is($missing, 'N', "prop_invmap() missing of '$prop' is 'N'");
+is_deeply($invlist_ref, [ 0x0000, 0x0030, 0x003A, 0x0041,
+ 0x0047, 0x0061, 0x0067, 0x110000 ],
+ "prop_invmap('$prop') code point list is correct");
+is_deeply($invmap_ref, [ 'N', 'Y', 'N', 'Y', 'N', 'Y', 'N', 'N' ] ,
+ "prop_invmap('$prop') map list is correct");
+
+is(prop_invlist("Unknown property"), undef, "prop_invlist(<Unknown property>) returns undef");
+is(prop_invlist(undef), undef, "prop_invlist(undef) returns undef");
+is(prop_invlist("Any"), 2, "prop_invlist('Any') returns the number of elements in scalar context");
+my @invlist = prop_invlist("Is_Any");
+is_deeply(\@invlist, [ 0, 0x110000 ], "prop_invlist works on 'Is_' prefixes");
+is(prop_invlist("Is_Is_Any"), undef, "prop_invlist('Is_Is_Any') returns <undef> since two is's");
+
+use Storable qw(dclone);
+
+is(prop_invlist("InKana"), undef, "prop_invlist(<user-defined property returns undef>)");
+
+# The way both the tests for invlist and invmap work is that they take the
+# lists returned by the functions and construct from them what the original
+# file should look like, which are then compared with the file. If they are
+# identical, the test passes. What this tests isn't that the results are
+# correct, but that invlist and invmap haven't introduced errors beyond what
+# are there in the files. As a small hedge against that, test some
+# prop_invlist() tables fully with the known correct result. We choose
+# ASCII_Hex_Digit again, as it is stable.
+ at invlist = prop_invlist("AHex");
+is_deeply(\@invlist, [ 0x0030, 0x003A, 0x0041,
+ 0x0047, 0x0061, 0x0067 ],
+ "prop_invlist('AHex') is exactly the expected set of points");
+ at invlist = prop_invlist("AHex=f");
+is_deeply(\@invlist, [ 0x0000, 0x0030, 0x003A, 0x0041,
+ 0x0047, 0x0061, 0x0067 ],
+ "prop_invlist('AHex=f') is exactly the expected set of points");
+
+sub fail_with_diff ($$$$) {
+ # For use below to output better messages
+ my ($prop, $official, $constructed, $tested_function_name) = @_;
+
+ is($constructed, $official, "$tested_function_name('$prop')");
+ diag("Comment out lines " . (__LINE__ - 1) . " through " . (__LINE__ + 1) . " in '$0' on Un*x-like systems to see just the differences. Uses the 'diff' first in your \$PATH");
+ return;
+
+ fail("$tested_function_name('$prop')");
+
+ require File::Temp;
+ my $off = File::Temp->new();
+ local $/ = "\n";
+ chomp $official;
+ print $off $official, "\n";
+ close $off || die "Can't close official";
+
+ chomp $constructed;
+ my $gend = File::Temp->new();
+ print $gend $constructed, "\n";
+ close $gend || die "Can't close gend";
+
+ my $diff = File::Temp->new();
+ system("diff $off $gend > $diff");
+
+ open my $fh, "<", $diff || die "Can't open $diff";
+ my @diffs = <$fh>;
+ diag("In the diff output below '<' marks lines from the filesystem tables;\n'>' are from $tested_function_name()");
+ diag(@diffs);
+}
+
+my %tested_invlist;
+
+# Look at everything we think that mktables tells us exists, both loose and
+# strict
+foreach my $set_of_tables (\%utf8::stricter_to_file_of, \%utf8::loose_to_file_of)
+{
+ foreach my $table (keys %$set_of_tables) {
+
+ my $mod_table;
+ my ($prop_only, $value) = split "=", $table;
+ if (defined $value) {
+
+ # If this is to be loose matched, add in characters to test that.
+ if ($set_of_tables == \%utf8::loose_to_file_of) {
+ $value = "$extra_chars$value";
+ }
+ else { # Strict match
+
+ # Verify that loose matching fails when only strict is called
+ # for.
+ next unless is(prop_invlist("$prop_only=$extra_chars$value"), undef, "prop_invlist('$prop_only=$extra_chars$value') returns undef since should be strictly matched");
+
+ # Strict matching does allow for underscores between digits.
+ # Test for that.
+ while ($value =~ s/(\d)(\d)/$1_$2/g) {}
+ }
+
+ # The property portion in compound form specifications always
+ # matches loosely
+ $mod_table = "$extra_chars$prop_only = $value";
+ }
+ else { # Single-form.
+
+ # Like above, use looose if required, and insert underscores
+ # between digits if strict.
+ if ($set_of_tables == \%utf8::loose_to_file_of) {
+ $mod_table = "$extra_chars$table";
+ }
+ else {
+ $mod_table = $table;
+ while ($mod_table =~ s/(\d)(\d)/$1_$2/g) {}
+ }
+ }
+
+ my @tested = prop_invlist($mod_table);
+ if ($table =~ /^_/) {
+ is(@tested, 0, "prop_invlist('$mod_table') returns an empty list since is internal-only");
+ next;
+ }
+
+ # If we have already tested a property that uses the same file, this
+ # list should be identical to the one that was tested, and can bypass
+ # everything else.
+ my $file = $set_of_tables->{$table};
+ if (exists $tested_invlist{$file}) {
+ is_deeply(\@tested, $tested_invlist{$file}, "prop_invlist('$mod_table') gave same results as its name synonym");
+ next;
+ }
+ $tested_invlist{$file} = dclone \@tested;
+
+ # A leading '!' in the file name means that it is to be inverted.
+ my $invert = $file =~ s/^!//;
+ my $official = do "unicore/lib/$file.pl";
+
+ # Get rid of any trailing space and comments in the file.
+ $official =~ s/\s*(#.*)?$//mg;
+ local $/ = "\n";
+ chomp $official;
+ $/ = $input_record_separator;
+
+ # If we are to test against an inverted file, it is easier to invert
+ # our array than the file.
+ # The file only is valid for Unicode code points, while the inversion
+ # list is valid for all possible code points. Therefore, we must test
+ # just the Unicode part against the file. Later we will test for
+ # the non-Unicode part.
+
+ my $before_invert; # Saves the pre-inverted table.
+ if ($invert) {
+ $before_invert = dclone \@tested;
+ if (@tested && $tested[0] == 0) {
+ shift @tested;
+ } else {
+ unshift @tested, 0;
+ }
+ if (@tested && $tested[-1] == 0x110000) {
+ pop @tested;
+ }
+ else {
+ push @tested, 0x110000;
+ }
+ }
+
+ # Now construct a string from the list that should match the file.
+ # The file gives ranges of code points with starting and ending values
+ # in hex, like this:
+ # 0041\t005A
+ # 0061\t007A
+ # 00AA
+ # Our list has even numbered elements start ranges that are in the
+ # list, and odd ones that aren't in the list. Therefore the odd
+ # numbered ones are one beyond the end of the previous range, but
+ # otherwise don't get reflected in the file.
+ my $tested = "";
+ my $i = 0;
+ for (; $i < @tested - 1; $i += 2) {
+ my $start = $tested[$i];
+ my $end = $tested[$i+1] - 1;
+ if ($start == $end) {
+ $tested .= sprintf("%04X\n", $start);
+ }
+ else {
+ $tested .= sprintf "%04X\t%04X\n", $start, $end;
+ }
+ }
+
+ # As mentioned earlier, the disk files only go up through Unicode,
+ # whereas the prop_invlist() ones go as high as necessary. The
+ # comparison is only valid through max Unicode.
+ if ($i == @tested - 1 && $tested[$i] <= 0x10FFFF) {
+ $tested .= sprintf("%04X\t10FFFF\n", $tested[$i]);
+ }
+ local $/ = "\n";
+ chomp $tested;
+ $/ = $input_record_separator;
+ if ($tested ne $official) {
+ fail_with_diff($mod_table, $official, $tested, "prop_invlist");
+ next;
+ }
+
+ # Here, it matched the table. Now need to check for if it is correct
+ # for beyond Unicode. First, calculate if is the default table or
+ # not. This is the same algorithm as used internally in
+ # prop_invlist(), so if it is wrong there, this test won't catch it.
+ my $prop = lc $table;
+ ($prop_only, $table) = split /\s*[:=]\s*/, $prop;
+ if (defined $table) {
+
+ # May have optional prefixed 'is'
+ $prop = &utf8::_loose_name($prop_only) =~ s/^is//r;
+ $prop = $utf8::loose_property_name_of{$prop};
+ $prop .= "=" . &utf8::_loose_name($table);
+ }
+ else {
+ $prop = &utf8::_loose_name($prop);
+ }
+ my $is_default = exists $Unicode::UCD::loose_defaults{$prop};
+
+ @tested = @$before_invert if $invert; # Use the original
+ if (@tested % 2 == 0) {
+
+ # If there are an even number of elements, the final one starts a
+ # range (going to infinity) of code points that are not in the
+ # list.
+ if ($is_default) {
+ fail("prop_invlist('$mod_table')");
+ diag("default table doesn't goto infinity");
+ use Data::Dumper;
+ diag Dumper \@tested;
+ next;
+ }
+ }
+ else {
+ # An odd number of elements means the final one starts a range
+ # (going to infinity of code points that are in the list.
+ if (! $is_default) {
+ fail("prop_invlist('$mod_table')");
+ diag("non-default table needs to stop in the Unicode range");
+ use Data::Dumper;
+ diag Dumper \@tested;
+ next;
+ }
+ }
+
+ pass("prop_invlist('$mod_table')");
+ }
+}
+
+# Now test prop_invmap().
+
+ at list = prop_invmap("Unknown property");
+is (@list, 0, "prop_invmap(<Unknown property>) returns an empty list");
+ at list = prop_invmap(undef);
+is (@list, 0, "prop_invmap(undef) returns an empty list");
+ok (! eval "prop_invmap('gc')" && $@ ne "",
+ "prop_invmap('gc') dies in scalar context");
+ at list = prop_invmap("_X_Begin");
+is (@list, 0, "prop_invmap(<internal property>) returns an empty list");
+ at list = prop_invmap("InKana");
+is(@list, 0, "prop_invmap(<user-defined property returns undef>)");
+ at list = prop_invmap("Perl_Decomposition_Mapping"), undef,
+is(@list, 0, "prop_invmap('Perl_Decomposition_Mapping') returns <undef> since internal-Perl-only");
+ at list = prop_invmap("Perl_Charnames"), undef,
+is(@list, 0, "prop_invmap('Perl_Charnames') returns <undef> since internal-Perl-only");
+ at list = prop_invmap("Is_Is_Any");
+is(@list, 0, "prop_invmap('Is_Is_Any') returns <undef> since two is's");
+
+# The set of properties to test on has already been compiled into %props by
+# the prop_aliases() tests.
+
+my %tested_invmaps;
+
+# Like prop_invlist(), prop_invmap() is tested by comparing the results
+# returned by the function with the tables that mktables generates. Some of
+# these tables are directly stored as files on disk, in either the unicore or
+# unicore/To directories, and most should be listed in the mktables generated
+# hash %utf8::loose_property_to_file_of, with a few additional ones that this
+# handles specially. For these, the files are read in directly, massaged, and
+# compared with what invmap() returns. The SPECIALS hash in some of these
+# files overrides values in the main part of the file.
+#
+# The other properties are tested indirectly by generating all the possible
+# inversion lists for the property, and seeing if those match the inversion
+# lists returned by prop_invlist(), which has already been tested.
+
+PROPERTY:
+foreach my $prop (keys %props) {
+ my $loose_prop = &utf8::_loose_name(lc $prop);
+ my $suppressed = grep { $_ eq $loose_prop }
+ @Unicode::UCD::suppressed_properties;
+
+ # Find the short and full names that this property goes by
+ my ($name, $full_name) = prop_aliases($prop);
+ if (! $name) {
+ if (! $suppressed) {
+ fail("prop_invmap('$prop')");
+ diag("is unknown to prop_aliases(), and we need it in order to test prop_invmap");
+ }
+ next PROPERTY;
+ }
+
+ # Normalize the short name, as it is stored in the hashes under the
+ # normalized version.
+ $name = &utf8::_loose_name(lc $name);
+
+ # Add in the characters that are supposed to be ignored to test loose
+ # matching, which the tested function applies to all properties
+ my $mod_prop = "$extra_chars$prop";
+
+ my ($invlist_ref, $invmap_ref, $format, $missing) = prop_invmap($mod_prop);
+ my $return_ref = [ $invlist_ref, $invmap_ref, $format, $missing ];
+
+ # If have already tested this property under a different name, merely
+ # compare the return from now with the saved one from before.
+ if (exists $tested_invmaps{$name}) {
+ is_deeply($return_ref, $tested_invmaps{$name}, "prop_invmap('$mod_prop') gave same results as its synonym, '$name'");
+ next PROPERTY;
+ }
+ $tested_invmaps{$name} = dclone $return_ref;
+
+ # If prop_invmap() returned nothing, is ok iff is a property whose file is
+ # not generated.
+ if ($suppressed) {
+ if (defined $format) {
+ fail("prop_invmap('$mod_prop')");
+ diag("did not return undef for suppressed property $prop");
+ }
+ next PROPERTY;
+ }
+ elsif (!defined $format) {
+ fail("prop_invmap('$mod_prop')");
+ diag("'$prop' is unknown to prop_invmap()");
+ next PROPERTY;
+ }
+
+ # The two parallel arrays must have the same number of elements.
+ if (@$invlist_ref != @$invmap_ref) {
+ fail("prop_invmap('$mod_prop')");
+ diag("invlist has "
+ . scalar @$invlist_ref
+ . " while invmap has "
+ . scalar @$invmap_ref
+ . " elements");
+ next PROPERTY;
+ }
+
+ # The last element must be for the above-Unicode code points, and must be
+ # for the default value.
+ if ($invlist_ref->[-1] != 0x110000) {
+ fail("prop_invmap('$mod_prop')");
+ diag("The last inversion list element is not 0x110000");
+ next PROPERTY;
+ }
+ if ($invmap_ref->[-1] ne $missing) {
+ fail("prop_invmap('$mod_prop')");
+ diag("The last inversion list element is '$invmap_ref->[-1]', and should be '$missing'");
+ next PROPERTY;
+ }
+
+ if ($name eq 'bmg') { # This one has an atypical $missing
+ if ($missing ne "") {
+ fail("prop_invmap('$mod_prop')");
+ diag("The missings should be \"\"; got '$missing'");
+ next PROPERTY;
+ }
+ }
+ elsif ($format =~ /^ a (?!r) /x) {
+ if ($full_name eq 'Perl_Decimal_Digit') {
+ if ($missing ne "") {
+ fail("prop_invmap('$mod_prop')");
+ diag("The missings should be \"\"; got '$missing'");
+ next PROPERTY;
+ }
+ }
+ elsif ($missing ne "0") {
+ fail("prop_invmap('$mod_prop')");
+ diag("The missings should be '0'; got '$missing'");
+ next PROPERTY;
+ }
+ }
+ elsif ($missing =~ /[<>]/) {
+ fail("prop_invmap('$mod_prop')");
+ diag("The missings should NOT be something with <...>'");
+ next PROPERTY;
+
+ # I don't want to hard code in what all the missings should be, so
+ # those don't get fully tested.
+ }
+
+ # Certain properties don't have their own files, but must be constructed
+ # using proxies.
+ my $proxy_prop = $name;
+ if ($full_name eq 'Present_In') {
+ $proxy_prop = "age"; # The maps for these two props are identical
+ }
+ elsif ($full_name eq 'Simple_Case_Folding'
+ || $full_name =~ /Simple_ (.) .*? case_Mapping /x)
+ {
+ if ($full_name eq 'Simple_Case_Folding') {
+ $proxy_prop = 'cf';
+ }
+ else {
+ # We captured the U, L, or T, leading to uc, lc, or tc.
+ $proxy_prop = lc $1 . "c";
+ }
+ if ($format ne "a") {
+ fail("prop_invmap('$mod_prop')");
+ diag("The format should be 'a'; got '$format'");
+ next PROPERTY;
+ }
+ }
+
+ if ($format !~ / ^ (?: a [der]? | ale? | n | sl? ) $ /x) {
+ fail("prop_invmap('$mod_prop')");
+ diag("Unknown format '$format'");
+ next PROPERTY;
+ }
+
+ my $base_file;
+ my $official;
+
+ # Handle the properties that have full disk files for them (except the
+ # Name property which is structurally enough different that it is handled
+ # separately below.)
+ if ($name ne 'na'
+ && ($name eq 'blk'
+ || defined
+ ($base_file = $utf8::loose_property_to_file_of{$proxy_prop})
+ || exists $utf8::loose_to_file_of{$proxy_prop}
+ || $name eq "dm"))
+ {
+ # In the above, blk is done unconditionally, as we need to test that
+ # the old-style block names are returned, even if mktables has
+ # generated a file for the new-style; the test for dm comes afterward,
+ # so that if a file has been generated for it explicitly, we use that
+ # file (which is valid, unlike blk) instead of the combo
+ # Decomposition.pl files.
+ my $file;
+ my $is_binary = 0;
+ if ($name eq 'blk') {
+
+ # The blk property is special. The original file with old block
+ # names is retained, and the default is to not write out a
+ # new-name file. What we do is get the old names into a data
+ # structure, and from that create what the new file would look
+ # like. $base_file is needed to be defined, just to avoid a
+ # message below.
+ $base_file = "This is a dummy name";
+ my $blocks_ref = charblocks();
+ $official = "";
+ for my $range (sort { $a->[0][0] <=> $b->[0][0] }
+ values %$blocks_ref)
+ {
+ # Translate the charblocks() data structure to what the file
+ # would like.
+ $official .= sprintf"%04X\t%04X\t%s\n",
+ $range->[0][0],
+ $range->[0][1],
+ $range->[0][2];
+ }
+ }
+ else {
+ $base_file = "Decomposition" if $format eq 'ad';
+
+ # Above leaves $base_file undefined only if it came from the hash
+ # below. This should happen only when it is a binary property
+ # (and are accessing via a single-form name, like 'In_Latin1'),
+ # and so it is stored in a different directory than the To ones.
+ # XXX Currently, the only cases where it is complemented are the
+ # ones that have no code points. And it works out for these that
+ # 1) complementing them, and then 2) adding or subtracting the
+ # initial 0 and final 110000 cancel each other out. But further
+ # work would be needed in the unlikely event that an inverted
+ # property comes along without these characteristics
+ if (!defined $base_file) {
+ $base_file = $utf8::loose_to_file_of{$proxy_prop};
+ $is_binary = ($base_file =~ s/^!//) ? -1 : 1;
+ $base_file = "lib/$base_file";
+ }
+
+ # Read in the file
+ $file = "unicore/$base_file.pl";
+ $official = do $file;
+
+ # Get rid of any trailing space and comments in the file.
+ $official =~ s/\s*(#.*)?$//mg;
+
+ if ($format eq 'ad') {
+ my @official = split /\n/, $official;
+ $official = "";
+ foreach my $line (@official) {
+ my ($start, $end, $value)
+ = $line =~ / ^ (.+?) \t (.*?) \t (.+?)
+ \s* ( \# .* )? $ /x;
+ # Decomposition.pl also has the <compatible> types in it,
+ # which should be removed.
+ $value =~ s/<.*?> //;
+ $official .= "$start\t\t$value\n";
+
+ # If this is a multi-char range, we turn it into as many
+ # single character ranges as necessary. This makes things
+ # easier below.
+ if ($end ne "") {
+ for my $i (hex($start) + 1 .. hex $end) {
+ $official .= sprintf "%04X\t\t%s\n", $i, $value;
+ }
+ }
+ }
+ }
+ }
+ local $/ = "\n";
+ chomp $official;
+ $/ = $input_record_separator;
+
+ # Get the format for the file, and if there are any special elements,
+ # get a reference to them.
+ my $swash_name = $utf8::file_to_swash_name{$base_file};
+ my $specials_ref;
+ my $file_format;
+ if ($swash_name) {
+ $specials_ref = $utf8::SwashInfo{$swash_name}{'specials_name'};
+ if ($specials_ref) {
+
+ # Convert from the name to the actual reference.
+ no strict 'refs';
+ $specials_ref = \%{$specials_ref};
+ }
+
+ $file_format = $utf8::SwashInfo{$swash_name}{'format'};
+ }
+
+ # Certain of the proxy properties have to be adjusted to match the
+ # real ones.
+ if ($full_name =~ /^(Case_Folding|(Lower|Title|Upper)case_Mapping)/) {
+
+ # Here we have either
+ # 1) Case_Folding; or
+ # 2) a proxy that is a full mapping, which means that what the
+ # real property is is the equivalent simple mapping.
+ # In both cases, the file will have a standard list containing
+ # simple mappings (to a single code point), and a specials hash
+ # which contains all the mappings that are to multiple code
+ # points. First, extract a list containing all the file's simple
+ # mappings.
+ my @list;
+ for (split "\n", $official) {
+ my ($start, $end, $value) = / ^ (.+?) \t (.*?) \t (.+?)
+ \s* ( \# .* )? $ /x;
+ $end = $start if $end eq "";
+ push @list, [ hex $start, hex $end, $value ];
+ }
+
+ # For these mappings, the file contains all the simple mappings,
+ # including the ones that are overridden by the specials. These
+ # need to be removed as the list is for just the full ones.
+
+ # Go through any special mappings one by one. They are packed.
+ my $i = 0;
+ foreach my $utf8_cp (sort keys %$specials_ref) {
+ my $cp = unpack("C0U", $utf8_cp);
+
+ # Find the spot in the @list of simple mappings that this
+ # special applies to; uses a linear search.
+ while ($i < @list -1 ) {
+ last if $cp <= $list[$i][1];
+ $i++;
+ }
+
+ # Here $i is such that it points to the first range which ends
+ # at or above cp, and hence is the only range that could
+ # possibly contain it.
+
+ # If not in this range, no range contains it: nothing to
+ # remove.
+ next if $cp < $list[$i][0];
+
+ # Otherwise, remove the existing entry. If it is the first
+ # element of the range...
+ if ($cp == $list[$i][0]) {
+
+ # ... and there are other elements in the range, just shorten
+ # the range to exclude this code point.
+ if ($list[$i][1] > $list[$i][0]) {
+ $list[$i][0]++;
+ }
+
+ # ... but if it is the only element in the range, remove
+ # it entirely.
+ else {
+ splice @list, $i, 1;
+ }
+ }
+ else { # Is somewhere in the middle of the range
+ # Split the range into two, excluding this one in the
+ # middle
+ splice @list, $i, 1,
+ [ $list[$i][0], $cp - 1, $list[$i][2] ],
+ [ $cp + 1, $list[$i][1], $list[$i][2] ];
+ }
+ }
+
+ # Here, have gone through all the specials, modifying @list as
+ # needed. Turn it back into what the file should look like.
+ $official = "";
+ for my $element (@list) {
+ $official .= "\n" if $official;
+ if ($element->[1] == $element->[0]) {
+ $official .= sprintf "%04X\t\t%s", $element->[0], $element->[2];
+ }
+ else {
+ $official .= sprintf "%04X\t%04X\t%s", $element->[0], $element->[1], $element->[2];
+ }
+ }
+ }
+ elsif ($full_name =~ /Simple_(Case_Folding|(Lower|Title|Upper)case_Mapping)/)
+ {
+
+ # These properties have everything in the regular array, and the
+ # specials are superfluous.
+ undef $specials_ref;
+ }
+ elsif ($format !~ /^a/ && defined $file_format && $file_format eq 'x') {
+
+ # For these properties the file is output using hex notation for the
+ # map. Convert from hex to decimal.
+ my @lines = split "\n", $official;
+ foreach my $line (@lines) {
+ my ($lower, $upper, $map) = split "\t", $line;
+ $line = "$lower\t$upper\t" . hex $map;
+ }
+ $official = join "\n", @lines;
+ }
+
+ # Here, in $official, we have what the file looks like, or should like
+ # if we've had to fix it up. Now take the invmap() output and reverse
+ # engineer from that what the file should look like. Each iteration
+ # appends the next line to the running string.
+ my $tested_map = "";
+
+ # Create a copy of the file's specials hash. (It has been undef'd if
+ # we know it isn't relevant to this property, so if it exists, it's an
+ # error or is relevant). As we go along, we delete from that copy.
+ # If a delete fails, or something is left over after we are done,
+ # it's an error
+ my %specials = %$specials_ref if $specials_ref;
+
+ # The extra -1 is because the final element has been tested above to
+ # be for anything above Unicode. The file doesn't go that high.
+ for (my $i = 0; $i < @$invlist_ref - 1; $i++) {
+
+ # If the map element is a reference, have to stringify it (but
+ # don't do so if the format doesn't allow references, so that an
+ # improper format will generate an error.
+ if (ref $invmap_ref->[$i]
+ && ($format eq 'ad' || $format =~ /^ . l /x))
+ {
+ # The stringification depends on the format.
+ if ($format eq 'sl') {
+
+ # At the time of this writing, there are two types of 'sl'
+ # format One, in Name_Alias, has multiple separate entries
+ # for each code point; the other, in Script_Extension, is space
+ # separated. Assume the latter for non-Name_Alias.
+ if ($full_name ne 'Name_Alias') {
+ $invmap_ref->[$i] = join " ", @{$invmap_ref->[$i]};
+ }
+ else {
+ # For Name_Alias, we emulate the file. Entries with
+ # just one value don't need any changes, but we
+ # convert the list entries into a series of lines for
+ # the file, starting with the first name. The
+ # succeeding entries are on separate lines, with the
+ # code point repeated for each one and then two tabs,
+ # then the value. Code at the end of the loop will
+ # set up the first line with its code point and two
+ # tabs before the value, just as it does for every
+ # other property; thus the special handling of the
+ # first line.
+ if (ref $invmap_ref->[$i]) {
+ my $hex_cp = sprintf("%04X", $invlist_ref->[$i]);
+ my $concatenated = $invmap_ref->[$i][0];
+ for (my $j = 1; $j < @{$invmap_ref->[$i]}; $j++) {
+ $concatenated .= "\n$hex_cp\t\t" . $invmap_ref->[$i][$j];
+ }
+ $invmap_ref->[$i] = $concatenated;
+ }
+ }
+ }
+ elsif ($format =~ / ^ al e? $/x) {
+
+ # For a al property, the stringified result should be in
+ # the specials hash. The key is the packed code point,
+ # and the value is the packed map.
+ my $value;
+ if (! defined ($value = delete $specials{pack("C0U", $invlist_ref->[$i]) })) {
+ fail("prop_invmap('$mod_prop')");
+ diag(sprintf "There was no specials element for %04X", $invlist_ref->[$i]);
+ next PROPERTY;
+ }
+ my $packed = pack "U*", @{$invmap_ref->[$i]};
+ if ($value ne $packed) {
+ fail("prop_invmap('$mod_prop')");
+ diag(sprintf "For %04X, expected the mapping to be '$packed', but got '$value'");
+ next PROPERTY;
+ }
+
+ # As this doesn't get tested when we later compare with
+ # the actual file, it could be out of order and we
+ # wouldn't know it.
+ if (($i > 0 && $invlist_ref->[$i] <= $invlist_ref->[$i-1])
+ || $invlist_ref->[$i] >= $invlist_ref->[$i+1])
+ {
+ fail("prop_invmap('$mod_prop')");
+ diag(sprintf "Range beginning at %04X is out-of-order.", $invlist_ref->[$i]);
+ next PROPERTY;
+ }
+ next;
+ }
+ elsif ($format eq 'ad') {
+
+ # The decomposition mapping file has the code points as
+ # a string of space-separated hex constants.
+ $invmap_ref->[$i] = join " ", map { sprintf "%04X", $_ } @{$invmap_ref->[$i]};
+ }
+ else {
+ fail("prop_invmap('$mod_prop')");
+ diag("Can't handle format '$format'");
+ next PROPERTY;
+ }
+ }
+ elsif ($format eq 'ad' || $format eq 'ale') {
+
+ # The numerics in the returned map are stored as adjusted
+ # decimal integers. The defaults are 0, and don't appear in
+ # $official, and are excluded later, but the elements must be
+ # converted back to their hex values before comparing with
+ # $official, as these files, for backwards compatibility, are
+ # not stored as adjusted. (There currently is only one ale
+ # property, nfkccf. If that changed this would also have to.)
+ if ($invmap_ref->[$i] =~ / ^ -? \d+ $ /x
+ && $invmap_ref->[$i] != 0)
+ {
+ my $next = $invmap_ref->[$i] + 1;
+ $invmap_ref->[$i] = sprintf("%04X", $invmap_ref->[$i]);
+
+ # If there are other elements in this range they need to
+ # be adjusted; they must individually be re-mapped. Do
+ # this by splicing in a new element into the list and the
+ # map containing the remainder of the range. Next time
+ # through we will look at that (possibly splicing again
+ # until the whole range is processed).
+ if ($invlist_ref->[$i+1] > $invlist_ref->[$i] + 1) {
+ splice @$invlist_ref, $i+1, 0,
+ $invlist_ref->[$i] + 1;
+ splice @$invmap_ref, $i+1, 0, $next;
+ }
+ }
+ if ($format eq 'ale' && $invmap_ref->[$i] eq "") {
+
+ # ale properties have maps to the empty string that also
+ # should be in the specials hash, with the key the packed
+ # code point, and the map just empty.
+ my $value;
+ if (! defined ($value = delete $specials{pack("C0U", $invlist_ref->[$i]) })) {
+ fail("prop_invmap('$mod_prop')");
+ diag(sprintf "There was no specials element for %04X", $invlist_ref->[$i]);
+ next PROPERTY;
+ }
+ if ($value ne "") {
+ fail("prop_invmap('$mod_prop')");
+ diag(sprintf "For %04X, expected the mapping to be \"\", but got '$value'", $invlist_ref->[$i]);
+ next PROPERTY;
+ }
+
+ # As this doesn't get tested when we later compare with
+ # the actual file, it could be out of order and we
+ # wouldn't know it.
+ if (($i > 0 && $invlist_ref->[$i] <= $invlist_ref->[$i-1])
+ || $invlist_ref->[$i] >= $invlist_ref->[$i+1])
+ {
+ fail("prop_invmap('$mod_prop')");
+ diag(sprintf "Range beginning at %04X is out-of-order.", $invlist_ref->[$i]);
+ next PROPERTY;
+ }
+ next;
+ }
+ }
+ elsif ($is_binary) { # These binary files don't have an explicit Y
+ $invmap_ref->[$i] =~ s/Y//;
+ }
+
+ # The file doesn't include entries that map to $missing, so don't
+ # include it in the built-up string. But make sure that it is in
+ # the correct order in the input.
+ if ($invmap_ref->[$i] eq $missing) {
+ if (($i > 0 && $invlist_ref->[$i] <= $invlist_ref->[$i-1])
+ || $invlist_ref->[$i] >= $invlist_ref->[$i+1])
+ {
+ fail("prop_invmap('$mod_prop')");
+ diag(sprintf "Range beginning at %04X is out-of-order.", $invlist_ref->[$i]);
+ next PROPERTY;
+ }
+ next;
+ }
+
+ # The ad property has one entry which isn't in the file.
+ # Ignore it, but make sure it is in order.
+ if ($format eq 'ad'
+ && $invmap_ref->[$i] eq '<hangul syllable>'
+ && $invlist_ref->[$i] == 0xAC00)
+ {
+ if (($i > 0 && $invlist_ref->[$i] <= $invlist_ref->[$i-1])
+ || $invlist_ref->[$i] >= $invlist_ref->[$i+1])
+ {
+ fail("prop_invmap('$mod_prop')");
+ diag(sprintf "Range beginning at %04X is out-of-order.", $invlist_ref->[$i]);
+ next PROPERTY;
+ }
+ next;
+ }
+
+ # Finally have figured out what the map column in the file should
+ # be. Append the line to the running string.
+ my $start = $invlist_ref->[$i];
+ my $end = $invlist_ref->[$i+1] - 1;
+ $end = ($start == $end) ? "" : sprintf("%04X", $end);
+ if ($invmap_ref->[$i] ne "") {
+ $tested_map .= sprintf "%04X\t%s\t%s\n", $start, $end, $invmap_ref->[$i];
+ }
+ elsif ($end ne "") {
+ $tested_map .= sprintf "%04X\t%s\n", $start, $end;
+ }
+ else {
+ $tested_map .= sprintf "%04X\n", $start;
+ }
+ } # End of looping over all elements.
+
+ # Here are done with generating what the file should look like
+
+ local $/ = "\n";
+ chomp $tested_map;
+ $/ = $input_record_separator;
+
+ # And compare.
+ if ($tested_map ne $official) {
+ fail_with_diff($mod_prop, $official, $tested_map, "prop_invmap");
+ next PROPERTY;
+ }
+
+ # There shouldn't be any specials unaccounted for.
+ if (keys %specials) {
+ fail("prop_invmap('$mod_prop')");
+ diag("Unexpected specials: " . join ", ", keys %specials);
+ next PROPERTY;
+ }
+ }
+ elsif ($format eq 'n') {
+
+ # Handle the Name property similar to the above. But the file is
+ # sufficiently different that it is more convenient to make a special
+ # case for it. It is a combination of the Name, Unicode1_Name, and
+ # Name_Alias properties, and named sequences. We need to remove all
+ # but the Name in order to do the comparison.
+
+ if ($missing ne "") {
+ fail("prop_invmap('$mod_prop')");
+ diag("The missings should be \"\"; got \"missing\"");
+ next PROPERTY;
+ }
+
+ $official = do "unicore/Name.pl";
+
+ # Get rid of the named sequences portion of the file. These don't
+ # have a tab before the first blank on a line.
+ $official =~ s/ ^ [^\t]+ \ .*? \n //xmg;
+
+ # And get rid of the controls. These are named in the file, but
+ # shouldn't be in the property. This gets rid of the two ranges in
+ # one fell swoop, and also all the Unicode1_Name values that may not
+ # be in Name_Alias.
+ $official =~ s/ 00000 \t .* 0001F .*? \n//xs;
+ $official =~ s/ 0007F \t .* 0009F .*? \n//xs;
+
+ # And remove the aliases. We read in the Name_Alias property, and go
+ # through them one by one.
+ my ($aliases_code_points, $aliases_maps, undef, undef)
+ = &prop_invmap('Name_Alias');
+ for (my $i = 0; $i < @$aliases_code_points; $i++) {
+ my $code_point = $aliases_code_points->[$i];
+
+ # Already removed these above.
+ next if $code_point <= 0x1F
+ || ($code_point >= 0x7F && $code_point <= 0x9F);
+
+ my $hex_code_point = sprintf "%05X", $code_point;
+
+ # Convert to a list if not already to make the following loop
+ # control uniform.
+ $aliases_maps->[$i] = [ $aliases_maps->[$i] ]
+ if ! ref $aliases_maps->[$i];
+
+ # Remove each alias for this code point from the file
+ foreach my $alias (@{$aliases_maps->[$i]}) {
+
+ # Remove the alias type from the entry, retaining just the name.
+ $alias =~ s/:.*//;
+
+ $alias = quotemeta($alias);
+ $official =~ s/$hex_code_point \t $alias \n //x;
+ }
+ }
+ local $/ = "\n";
+ chomp $official;
+ $/ = $input_record_separator;
+
+ # Here have adjusted the file. We also have to adjust the returned
+ # inversion map by checking and deleting all the lines in it that
+ # won't be in the file. These are the lines that have generated
+ # things, like <hangul syllable>.
+ my $tested_map = ""; # Current running string
+ my @code_point_in_names =
+ @Unicode::UCD::code_points_ending_in_code_point;
+
+ for my $i (0 .. @$invlist_ref - 1 - 1) {
+ my $start = $invlist_ref->[$i];
+ my $end = $invlist_ref->[$i+1] - 1;
+ if ($invmap_ref->[$i] eq $missing) {
+ if (($i > 0 && $invlist_ref->[$i] <= $invlist_ref->[$i-1])
+ || $invlist_ref->[$i] >= $invlist_ref->[$i+1])
+ {
+ fail("prop_invmap('$mod_prop')");
+ diag(sprintf "Range beginning at %04X is out-of-order.", $invlist_ref->[$i]);
+ next PROPERTY;
+ }
+ next;
+ }
+ if ($invmap_ref->[$i] =~ / (.*) ( < .*? > )/x) {
+ my $name = $1;
+ my $type = $2;
+ if (($i > 0 && $invlist_ref->[$i] <= $invlist_ref->[$i-1])
+ || $invlist_ref->[$i] >= $invlist_ref->[$i+1])
+ {
+ fail("prop_invmap('$mod_prop')");
+ diag(sprintf "Range beginning at %04X is out-of-order.", $invlist_ref->[$i]);
+ next PROPERTY;
+ }
+ if ($type eq "<hangul syllable>") {
+ if ($name ne "") {
+ fail("prop_invmap('$mod_prop')");
+ diag("Unexpected text in $invmap_ref->[$i]");
+ next PROPERTY;
+ }
+ if ($start != 0xAC00) {
+ fail("prop_invmap('$mod_prop')");
+ diag(sprintf("<hangul syllables> should begin at 0xAC00, got %04X", $start));
+ next PROPERTY;
+ }
+ if ($end != $start + 11172 - 1) {
+ fail("prop_invmap('$mod_prop')");
+ diag(sprintf("<hangul syllables> should end at %04X, got %04X", $start + 11172 -1, $end));
+ next PROPERTY;
+ }
+ }
+ elsif ($type ne "<code point>") {
+ fail("prop_invmap('$mod_prop')");
+ diag("Unexpected text '$type' in $invmap_ref->[$i]");
+ next PROPERTY;
+ }
+ else {
+
+ # Look through the array of names that end in code points,
+ # and look for this start and end. If not found is an
+ # error. If found, delete it, and at the end, make sure
+ # have deleted everything.
+ for my $i (0 .. @code_point_in_names - 1) {
+ my $hash = $code_point_in_names[$i];
+ if ($hash->{'low'} == $start
+ && $hash->{'high'} == $end
+ && "$hash->{'name'}-" eq $name)
+ {
+ splice @code_point_in_names, $i, 1;
+ last;
+ }
+ else {
+ fail("prop_invmap('$mod_prop')");
+ diag("Unexpected code-point-in-name line '$invmap_ref->[$i]'");
+ next PROPERTY;
+ }
+ }
+ }
+
+ next;
+ }
+
+ # Have adjusted the map, as needed. Append to running string.
+ $end = ($start == $end) ? "" : sprintf("%05X", $end);
+ $tested_map .= sprintf "%05X\t%s\n", $start, $invmap_ref->[$i];
+ }
+
+ # Finished creating the string from the inversion map. Can compare
+ # with what the file is.
+ local $/ = "\n";
+ chomp $tested_map;
+ $/ = $input_record_separator;
+ if ($tested_map ne $official) {
+ fail_with_diff($mod_prop, $official, $tested_map, "prop_invmap");
+ next PROPERTY;
+ }
+ if (@code_point_in_names) {
+ fail("prop_invmap('$mod_prop')");
+ use Data::Dumper;
+ diag("Missing code-point-in-name line(s)" . Dumper \@code_point_in_names);
+ next PROPERTY;
+ }
+ }
+ elsif ($format eq 's') {
+
+ # Here the map is not more or less directly from a file stored on
+ # disk. We try a different tack. These should all be properties that
+ # have just a few possible values (most of them are binary). We go
+ # through the map list, sorting each range into buckets, one for each
+ # map value. Thus for binary properties there will be a bucket for Y
+ # and one for N. The buckets are inversion lists. We compare each
+ # constructed inversion list with what we would get for it using
+ # prop_invlist(), which has already been tested. If they all match,
+ # the whole map must have matched.
+ my %maps;
+ my $previous_map;
+
+ # (The extra -1 is to not look at the final element in the loop, which
+ # we know is the one that starts just beyond Unicode and goes to
+ # infinity.)
+ for my $i (0 .. @$invlist_ref - 1 - 1) {
+ my $range_start = $invlist_ref->[$i];
+
+ # Because we are sorting into buckets, things could be
+ # out-of-order here, and still be in the correct order in the
+ # bucket, and hence wouldn't show up as an error; so have to
+ # check.
+ if (($i > 0 && $range_start <= $invlist_ref->[$i-1])
+ || $range_start >= $invlist_ref->[$i+1])
+ {
+ fail("prop_invmap('$mod_prop')");
+ diag(sprintf "Range beginning at %04X is out-of-order.", $invlist_ref->[$i]);
+ next PROPERTY;
+ }
+
+ # This new range closes out the range started in the previous
+ # iteration.
+ push @{$maps{$previous_map}}, $range_start if defined $previous_map;
+
+ # And starts a range which will be closed in the next iteration.
+ $previous_map = $invmap_ref->[$i];
+ push @{$maps{$previous_map}}, $range_start;
+ }
+
+ # The range we just started hasn't been closed, and we didn't look at
+ # the final element of the loop. If that range is for the default
+ # value, it shouldn't be closed, as it is to extend to infinity. But
+ # otherwise, it should end at the final Unicode code point, and the
+ # list that maps to the default value should have another element that
+ # does go to infinity for every above Unicode code point.
+
+ if (@$invlist_ref > 1) {
+ my $penultimate_map = $invmap_ref->[-2];
+ if ($penultimate_map ne $missing) {
+
+ # The -1th element contains the first non-Unicode code point.
+ push @{$maps{$penultimate_map}}, $invlist_ref->[-1];
+ push @{$maps{$missing}}, $invlist_ref->[-1];
+ }
+ }
+
+ # Here, we have the buckets (inversion lists) all constructed. Go
+ # through each and verify that matches what prop_invlist() returns.
+ # We could use is_deeply() for the comparison, but would get multiple
+ # messages for each $prop.
+ foreach my $map (keys %maps) {
+ my @off_invlist = prop_invlist("$prop = $map");
+ my $min = (@off_invlist >= @{$maps{$map}})
+ ? @off_invlist
+ : @{$maps{$map}};
+ for my $i (0 .. $min- 1) {
+ if ($i > @off_invlist - 1) {
+ fail("prop_invmap('$mod_prop')");
+ diag("There is no element [$i] for $prop=$map from prop_invlist(), while [$i] in the implicit one constructed from prop_invmap() is '$maps{$map}[$i]'");
+ next PROPERTY;
+ }
+ elsif ($i > @{$maps{$map}} - 1) {
+ fail("prop_invmap('$mod_prop')");
+ diag("There is no element [$i] from the implicit $prop=$map constructed from prop_invmap(), while [$i] in the one from prop_invlist() is '$off_invlist[$i]'");
+ next PROPERTY;
+ }
+ elsif ($maps{$map}[$i] ne $off_invlist[$i]) {
+ fail("prop_invmap('$mod_prop')");
+ diag("Element [$i] of the implicit $prop=$map constructed from prop_invmap() is '$maps{$map}[$i]', and the one from prop_invlist() is '$off_invlist[$i]'");
+ next PROPERTY;
+ }
+ }
+ }
+ }
+ else { # Don't know this property nor format.
+
+ fail("prop_invmap('$mod_prop')");
+ diag("Unknown format '$format'");
+ }
+
+ pass("prop_invmap('$mod_prop')");
+}
+
+ok($/ eq $input_record_separator, "The record separator didn't get overridden");
+done_testing();
Property changes on: trunk/contrib/perl/lib/Unicode/UCD.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/lib/User/grent.pm
===================================================================
--- trunk/contrib/perl/lib/User/grent.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/User/grent.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/User/grent.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/User/grent.t
===================================================================
--- trunk/contrib/perl/lib/User/grent.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/User/grent.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/User/grent.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/User/pwent.pm
===================================================================
--- trunk/contrib/perl/lib/User/pwent.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/User/pwent.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/User/pwent.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/User/pwent.t
===================================================================
--- trunk/contrib/perl/lib/User/pwent.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/User/pwent.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/User/pwent.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/lib/_charnames.pm (from rev 6437, vendor/perl/5.18.1/lib/_charnames.pm)
===================================================================
--- trunk/contrib/perl/lib/_charnames.pm (rev 0)
+++ trunk/contrib/perl/lib/_charnames.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,793 @@
+# !!!!!!! INTERNAL PERL USE ONLY !!!!!!!
+# This helper module is for internal use by core Perl only. This module is
+# subject to change or removal at any time without notice. Don't use it
+# directly. Use the public <charnames> module instead.
+
+package _charnames;
+use strict;
+use warnings;
+use File::Spec;
+our $VERSION = '1.36';
+use unicore::Name; # mktables-generated algorithmically-defined names
+
+use bytes (); # for $bytes::hint_bits
+use re "/aa"; # Everything in here should be ASCII
+
+$Carp::Internal{ (__PACKAGE__) } = 1;
+
+# Translate between Unicode character names and their code points. This is a
+# submodule of package <charnames>, used to allow \N{...} to be autoloaded,
+# but it was decided not to autoload the various functions in charnames; the
+# splitting allows this behavior.
+#
+# The official names with their code points are stored in a table in
+# lib/unicore/Name.pl which is read in as a large string (almost 3/4 Mb in
+# Unicode 6.0). Each code point/name combination is separated by a \n in the
+# string. (Some of the CJK and the Hangul syllable names are determined
+# instead algorithmically via subroutines stored instead in
+# lib/unicore/Name.pm). Because of the large size of this table, it isn't
+# converted into hashes for faster lookup.
+#
+# But, user defined aliases are stored in their own hashes, as are Perl
+# extensions to the official names. These are checked first before looking at
+# the official table.
+#
+# Basically, the table is grepped for the input code point (viacode()) or
+# name (the other functions), and the corresponding value on the same line is
+# returned. The grepping is done by turning the input into a regular
+# expression. Thus, the same table does double duty, used by both name and
+# code point lookup. (If we were to have hashes, we would need two, one for
+# each lookup direction.)
+#
+# For loose name matching, the logical thing would be to have a table
+# with all the ignorable characters squeezed out, and then grep it with the
+# similiarly-squeezed input name. (And this is in fact how the lookups are
+# done with the small Perl extension hashes.) But since we need to be able to
+# go from code point to official name, the original table would still need to
+# exist. Due to the large size of the table, it was decided to not read
+# another very large string into memory for a second table. Instead, the
+# regular expression of the input name is modified to have optional spaces and
+# dashes between characters. For example, in strict matching, the regular
+# expression would be:
+# qr/\tDIGIT ONE$/m
+# Under loose matching, the blank would be squeezed out, and the re would be:
+# qr/\tD[- ]?I[- ]?G[- ]?I[- ]?T[- ]?O[- ]?N[- ]?E$/m
+# which matches a blank or dash between any characters in the official table.
+#
+# This is also how script lookup is done. Basically the re looks like
+# qr/ (?:LATIN|GREEK|CYRILLIC) (?:SMALL )?LETTER $name/
+# where $name is the loose or strict regex for the remainder of the name.
+
+# The hashes are stored as utf8 strings. This makes it easier to deal with
+# sequences. I (khw) also tried making Name.pl utf8, but it slowed things
+# down by a factor of 7. I then tried making Name.pl store the ut8
+# equivalents but not calling them utf8. That led to similar speed as leaving
+# it alone, but since that is harder for a human to parse, I left it as-is.
+
+my %system_aliases = (
+
+ 'SINGLE-SHIFT 2' => pack("U", 0x8E),
+ 'SINGLE-SHIFT 3' => pack("U", 0x8F),
+ 'PRIVATE USE 1' => pack("U", 0x91),
+ 'PRIVATE USE 2' => pack("U", 0x92),
+);
+
+# These are the aliases above that differ under :loose and :full matching
+# because the :full versions have blanks or hyphens in them.
+#my %loose_system_aliases = (
+#);
+
+#my %deprecated_aliases;
+#$deprecated_aliases{'BELL'} = pack("U", 0x07) if $^V lt v5.17.0;
+
+#my %loose_deprecated_aliases = (
+#);
+
+# These are special cased in :loose matching, differing only in a medial
+# hyphen
+my $HANGUL_JUNGSEONG_O_E_utf8 = pack("U", 0x1180);
+my $HANGUL_JUNGSEONG_OE_utf8 = pack("U", 0x116C);
+
+
+my $txt; # The table of official character names
+
+my %full_names_cache; # Holds already-looked-up names, so don't have to
+# re-look them up again. The previous versions of charnames had scoping
+# bugs. For example if we use script A in one scope and find and cache
+# what Z resolves to, we can't use that cache in a different scope that
+# uses script B instead of A, as Z might be an entirely different letter
+# there; or there might be different aliases in effect in different
+# scopes, or :short may be in effect or not effect in different scopes,
+# or various combinations thereof. This was solved in this version
+# mostly by moving things to %^H. But some things couldn't be moved
+# there. One of them was the cache of runtime looked-up names, in part
+# because %^H is read-only at runtime. I (khw) don't know why the cache
+# was run-time only in the previous versions: perhaps oversight; perhaps
+# that compile time looking doesn't happen in a loop so didn't think it
+# was worthwhile; perhaps not wanting to make the cache too large. But
+# I decided to make it compile time as well; this could easily be
+# changed.
+# Anyway, this hash is not scoped, and is added to at runtime. It
+# doesn't have scoping problems because the data in it is restricted to
+# official names, which are always invariant, and we only set it and
+# look at it at during :full lookups, so is unaffected by any other
+# scoped options. I put this in to maintain parity with the older
+# version. If desired, a %short_names cache could also be made, as well
+# as one for each script, say in %script_names_cache, with each key
+# being a hash for a script named in a 'use charnames' statement. I
+# decided not to do that for now, just because it's added complication,
+# and because I'm just trying to maintain parity, not extend it.
+
+# Like %full_names_cache, but for use when :loose is in effect. There needs
+# to be two caches because :loose may not be in effect for a scope, and a
+# loose name could inappropriately be returned when only exact matching is
+# called for.
+my %loose_names_cache;
+
+# Designed so that test decimal first, and then hex. Leading zeros
+# imply non-decimal, as do non-[0-9]
+my $decimal_qr = qr/^[1-9]\d*$/;
+
+# Returns the hex number in $1.
+my $hex_qr = qr/^(?:[Uu]\+|0[xX])?([[:xdigit:]]+)$/;
+
+sub croak
+{
+ require Carp; goto &Carp::croak;
+} # croak
+
+sub carp
+{
+ require Carp; goto &Carp::carp;
+} # carp
+
+sub alias (@) # Set up a single alias
+{
+ my @errors;
+
+ my $alias = ref $_[0] ? $_[0] : { @_ };
+ foreach my $name (sort keys %$alias) { # Sort only because it helps having
+ # deterministic output for
+ # t/lib/charnames/alias
+ my $value = $alias->{$name};
+ next unless defined $value; # Omit if screwed up.
+
+ # Is slightly slower to just after this statement see if it is
+ # decimal, since we already know it is after having converted from
+ # hex, but makes the code easier to maintain, and is called
+ # infrequently, only at compile-time
+ if ($value !~ $decimal_qr && $value =~ $hex_qr) {
+ $value = CORE::hex $1;
+ }
+ if ($value =~ $decimal_qr) {
+ no warnings qw(non_unicode surrogate nonchar); # Allow any of these
+ $^H{charnames_ord_aliases}{$name} = pack("U", $value);
+
+ # Use a canonical form.
+ $^H{charnames_inverse_ords}{sprintf("%05X", $value)} = $name;
+ }
+ else {
+ # This regex needs to be sync'd with the code in toke.c that checks
+ # for the same thing
+ if ($name !~ / ^
+ \p{_Perl_Charname_Begin}
+ \p{_Perl_Charname_Continue}*
+ $ /x) {
+
+ push @errors, $name;
+ }
+ else {
+ $^H{charnames_name_aliases}{$name} = $value;
+
+ if (warnings::enabled('deprecated')) {
+ if ($name =~ / ( .* \s ) ( \s* ) $ /x) {
+ carp "Trailing white-space in a charnames alias definition is deprecated; marked by <-- HERE in '$1 <-- HERE " . $2 . "'";
+ }
+
+ # Use '+' instead of '*' in this regex, because any trailing
+ # blanks have already been warned about.
+ if ($name =~ / ( .*? \s{2} ) ( .+ ) /x) {
+ carp "A sequence of multiple spaces in a charnames alias definition is deprecated; marked by <-- HERE in '$1 <-- HERE " . $2 . "'";
+ }
+ }
+ }
+ }
+ }
+
+ # We find and output all errors from this :alias definition, rather than
+ # failing on the first one, so fewer runs are needed to get it to compile
+ if (@errors) {
+ foreach my $name (@errors) {
+ my $ok = "";
+ $ok = $1 if $name =~ / ^ ( \p{Alpha} [-\p{XPosixWord} ():\xa0]* ) /x;
+ my $first_bad = substr($name, length($ok), 1);
+ $name = "Invalid character in charnames alias definition; marked by <-- HERE in '$ok$first_bad<-- HERE " . substr($name, length($ok) + 1) . "'";
+ }
+ croak join "\n", @errors;
+ }
+
+ return;
+} # alias
+
+sub not_legal_use_bytes_msg {
+ my ($name, $utf8) = @_;
+ my $return;
+
+ if (length($utf8) == 1) {
+ $return = sprintf("Character 0x%04x with name '%s' is", ord $utf8, $name);
+ } else {
+ $return = sprintf("String with name '%s' (and ordinals %s) contains character(s)", $name, join(" ", map { sprintf "0x%04X", ord $_ } split(//, $utf8)));
+ }
+ return $return . " above 0xFF with 'use bytes' in effect";
+}
+
+sub alias_file ($) # Reads a file containing alias definitions
+{
+ my ($arg, $file) = @_;
+ if (-f $arg && File::Spec->file_name_is_absolute ($arg)) {
+ $file = $arg;
+ }
+ elsif ($arg =~ m/ ^ \p{_Perl_IDStart} \p{_Perl_IDCont}* $/x) {
+ $file = "unicore/${arg}_alias.pl";
+ }
+ else {
+ croak "Charnames alias file names can only have identifier characters";
+ }
+ if (my @alias = do $file) {
+ @alias == 1 && !defined $alias[0] and
+ croak "$file cannot be used as alias file for charnames";
+ @alias % 2 and
+ croak "$file did not return a (valid) list of alias pairs";
+ alias (@alias);
+ return (1);
+ }
+ 0;
+} # alias_file
+
+# For use when don't import anything. This structure must be kept in
+# sync with the one that import() fills up.
+my %dummy_H = (
+ charnames_stringified_names => "",
+ charnames_stringified_ords => "",
+ charnames_scripts => "",
+ charnames_full => 1,
+ charnames_loose => 0,
+ charnames_short => 0,
+ );
+
+
+sub lookup_name ($$$) {
+ my ($name, $wants_ord, $runtime) = @_;
+
+ # Lookup the name or sequence $name in the tables. If $wants_ord is false,
+ # returns the string equivalent of $name; if true, returns the ordinal value
+ # instead, but in this case $name must not be a sequence; otherwise undef is
+ # returned and a warning raised. $runtime is 0 if compiletime, otherwise
+ # gives the number of stack frames to go back to get the application caller
+ # info.
+ # If $name is not found, returns undef in runtime with no warning; and in
+ # compiletime, the Unicode replacement character, with a warning.
+
+ # It looks first in the aliases, then in the large table of official Unicode
+ # names.
+
+ my $utf8; # The string result
+ my $save_input;
+
+ if ($runtime) {
+
+ my $hints_ref = (caller($runtime))[10];
+
+ # If we didn't import anything (which happens with 'use charnames ()',
+ # substitute a dummy structure.
+ $hints_ref = \%dummy_H if ! defined $hints_ref
+ || (! defined $hints_ref->{charnames_full}
+ && ! defined $hints_ref->{charnames_loose});
+
+ # At runtime, but currently not at compile time, $^H gets
+ # stringified, so un-stringify back to the original data structures.
+ # These get thrown away by perl before the next invocation
+ # Also fill in the hash with the non-stringified data.
+ # N.B. New fields must be also added to %dummy_H
+
+ %{$^H{charnames_name_aliases}} = split ',',
+ $hints_ref->{charnames_stringified_names};
+ %{$^H{charnames_ord_aliases}} = split ',',
+ $hints_ref->{charnames_stringified_ords};
+ $^H{charnames_scripts} = $hints_ref->{charnames_scripts};
+ $^H{charnames_full} = $hints_ref->{charnames_full};
+ $^H{charnames_loose} = $hints_ref->{charnames_loose};
+ $^H{charnames_short} = $hints_ref->{charnames_short};
+ }
+
+ my $loose = $^H{charnames_loose};
+ my $lookup_name; # Input name suitably modified for grepping for in the
+ # table
+
+ # User alias should be checked first or else can't override ours, and if we
+ # were to add any, could conflict with theirs.
+ if (exists $^H{charnames_ord_aliases}{$name}) {
+ $utf8 = $^H{charnames_ord_aliases}{$name};
+ }
+ elsif (exists $^H{charnames_name_aliases}{$name}) {
+ $name = $^H{charnames_name_aliases}{$name};
+ $save_input = $lookup_name = $name; # Cache the result for any error
+ # message
+ # The aliases are documented to not match loosely, so change loose match
+ # into full.
+ if ($loose) {
+ $loose = 0;
+ $^H{charnames_full} = 1;
+ }
+ }
+ else {
+
+ # Here, not a user alias. That means that loose matching may be in
+ # effect; will have to modify the input name.
+ $lookup_name = $name;
+ if ($loose) {
+ $lookup_name = uc $lookup_name;
+
+ # Squeeze out all underscores
+ $lookup_name =~ s/_//g;
+
+ # Remove all medial hyphens
+ $lookup_name =~ s/ (?<= \S ) - (?= \S )//gx;
+
+ # Squeeze out all spaces
+ $lookup_name =~ s/\s//g;
+ }
+
+ # Here, $lookup_name has been modified as necessary for looking in the
+ # hashes. Check the system alias files next. Most of these aliases are
+ # the same for both strict and loose matching. To save space, the ones
+ # which differ are in their own separate hash, which is checked if loose
+ # matching is selected and the regular match fails. To save time, the
+ # loose hashes could be expanded to include all aliases, and there would
+ # only have to be one check. But if someone specifies :loose, they are
+ # interested in convenience over speed, and the time for this second check
+ # is miniscule compared to the rest of the routine.
+ if (exists $system_aliases{$lookup_name}) {
+ $utf8 = $system_aliases{$lookup_name};
+ }
+ # There are currently no entries in this hash, so don't waste time looking
+ # for them. But the code is retained for the unlikely possibility that
+ # some will be added in the future.
+# elsif ($loose && exists $loose_system_aliases{$lookup_name}) {
+# $utf8 = $loose_system_aliases{$lookup_name};
+# }
+# if (exists $deprecated_aliases{$lookup_name}) {
+# require warnings;
+# warnings::warnif('deprecated',
+# "Unicode character name \"$name\" is deprecated, use \""
+# . viacode(ord $deprecated_aliases{$lookup_name})
+# . "\" instead");
+# $utf8 = $deprecated_aliases{$lookup_name};
+# }
+ # There are currently no entries in this hash, so don't waste time looking
+ # for them. But the code is retained for the unlikely possibility that
+ # some will be added in the future.
+# elsif ($loose && exists $loose_deprecated_aliases{$lookup_name}) {
+# require warnings;
+# warnings::warnif('deprecated',
+# "Unicode character name \"$name\" is deprecated, use \""
+# . viacode(ord $loose_deprecated_aliases{$lookup_name})
+# . "\" instead");
+# $utf8 = $loose_deprecated_aliases{$lookup_name};
+# }
+ }
+
+ my @off; # Offsets into table of pattern match begin and end
+
+ # If haven't found it yet...
+ if (! defined $utf8) {
+
+ # See if has looked this input up earlier.
+ if (! $loose && $^H{charnames_full} && exists $full_names_cache{$name}) {
+ $utf8 = $full_names_cache{$name};
+ }
+ elsif ($loose && exists $loose_names_cache{$name}) {
+ $utf8 = $loose_names_cache{$name};
+ }
+ else { # Here, must do a look-up
+
+ # If full or loose matching succeeded, points to where to cache the
+ # result
+ my $cache_ref;
+
+ ## Suck in the code/name list as a big string.
+ ## Lines look like:
+ ## "00052\tLATIN CAPITAL LETTER R\n"
+ # or
+ # "0052 0303\tLATIN CAPITAL LETTER R WITH TILDE\n"
+ $txt = do "unicore/Name.pl" unless $txt;
+
+ ## @off will hold the index into the code/name string of the start and
+ ## end of the name as we find it.
+
+ ## If :loose, look for a loose match; if :full, look for the name
+ ## exactly
+ # First, see if the name is one which is algorithmically determinable.
+ # The subroutine is included in Name.pl. The table contained in
+ # $txt doesn't contain these. Experiments show that checking
+ # for these before checking for the regular names has no
+ # noticeable impact on performance for the regular names, but
+ # the other way around slows down finding these immensely.
+ # Algorithmically determinables are not placed in the cache because
+ # that uses up memory, and finding these again is fast.
+ if (($loose || $^H{charnames_full})
+ && (defined (my $ord = charnames::name_to_code_point_special($lookup_name, $loose))))
+ {
+ $utf8 = pack("U", $ord);
+ }
+ else {
+
+ # Not algorithmically determinable; look up in the table. The name
+ # will be turned into a regex, so quote any meta characters.
+ $lookup_name = quotemeta $lookup_name;
+
+ if ($loose) {
+
+ # For loose matches, $lookup_name has already squeezed out the
+ # non-essential characters. We have to add in code to make the
+ # squeezed version match the non-squeezed equivalent in the table.
+ # The only remaining hyphens are ones that start or end a word in
+ # the original. They have been quoted in $lookup_name so they look
+ # like "\-". Change all other characters except the backslash
+ # quotes for any metacharacters, and the final character, so that
+ # e.g., COLON gets transformed into: /C[- ]?O[- ]?L[- ]?O[- ]?N/
+ $lookup_name =~ s/ (?! \\ -) # Don't do this to the \- sequence
+ ( [^-\\] ) # Nor the "-" within that sequence,
+ # nor the "\" that quotes metachars,
+ # but otherwise put the char into $1
+ (?=.) # And don't do it for the final char
+ /$1\[- \]?/gx; # And add an optional blank or
+ # '-' after each $1 char
+
+ # Those remaining hyphens were originally at the beginning or end of
+ # a word, so they can match either a blank before or after, but not
+ # both. (Keep in mind that they have been quoted, so are a '\-'
+ # sequence)
+ $lookup_name =~ s/\\ -/(?:- | -)/xg;
+ }
+
+ # Do the lookup in the full table if asked for, and if succeeds
+ # save the offsets and set where to cache the result.
+ if (($loose || $^H{charnames_full}) && $txt =~ /\t$lookup_name$/m) {
+ @off = ($-[0] + 1, $+[0]); # The 1 is for the tab
+ $cache_ref = ($loose) ? \%loose_names_cache : \%full_names_cache;
+ }
+ else {
+
+ # Here, didn't look for, or didn't find the name.
+ # If :short is allowed, see if input is like "greek:Sigma".
+ # Keep in mind that $lookup_name has had the metas quoted.
+ my $scripts_trie = "";
+ my $name_has_uppercase;
+ if (($^H{charnames_short})
+ && $lookup_name =~ /^ (?: \\ \s)* # Quoted space
+ (.+?) # $1 = the script
+ (?: \\ \s)*
+ \\ : # Quoted colon
+ (?: \\ \s)*
+ (.+?) # $2 = the name
+ (?: \\ \s)* $
+ /xs)
+ {
+ # Even in non-loose matching, the script traditionally has been
+ # case insensitve
+ $scripts_trie = "\U$1";
+ $lookup_name = $2;
+
+ # Use original name to find its input casing, but ignore the
+ # script part of that to make the determination.
+ $save_input = $name if ! defined $save_input;
+ $name =~ s/.*?://;
+ $name_has_uppercase = $name =~ /[[:upper:]]/;
+ }
+ else { # Otherwise look in allowed scripts
+ $scripts_trie = $^H{charnames_scripts};
+
+ # Use original name to find its input casing
+ $name_has_uppercase = $name =~ /[[:upper:]]/;
+ }
+
+ my $case = $name_has_uppercase ? "CAPITAL" : "SMALL";
+ return if (! $scripts_trie || $txt !~
+ /\t (?: $scripts_trie ) \ (?:$case\ )? LETTER \ \U$lookup_name $/xm);
+
+ # Here have found the input name in the table.
+ @off = ($-[0] + 1, $+[0]); # The 1 is for the tab
+ }
+
+ # Here, the input name has been found; we haven't set up the output,
+ # but we know where in the string
+ # the name starts. The string is set up so that for single characters
+ # (and not named sequences), the name is preceded immediately by a
+ # tab and 5 hex digits for its code, with a \n before those. Named
+ # sequences won't have the 7th preceding character be a \n.
+ # (Actually, for the very first entry in the table this isn't strictly
+ # true: subtracting 7 will yield -1, and the substr below will
+ # therefore yield the very last character in the table, which should
+ # also be a \n, so the statement works anyway.)
+ if (substr($txt, $off[0] - 7, 1) eq "\n") {
+ $utf8 = pack("U", CORE::hex substr($txt, $off[0] - 6, 5));
+
+ # Handle the single loose matching special case, in which two names
+ # differ only by a single medial hyphen. If the original had a
+ # hyphen (or more) in the right place, then it is that one.
+ $utf8 = $HANGUL_JUNGSEONG_O_E_utf8
+ if $loose
+ && $utf8 eq $HANGUL_JUNGSEONG_OE_utf8
+ && $name =~ m/O \s* - [-\s]* E/ix;
+ # Note that this wouldn't work if there were a 2nd
+ # OE in the name
+ }
+ else {
+
+ # Here, is a named sequence. Need to go looking for the beginning,
+ # which is just after the \n from the previous entry in the table.
+ # The +1 skips past that newline, or, if the rindex() fails, to put
+ # us to an offset of zero.
+ my $charstart = rindex($txt, "\n", $off[0] - 7) + 1;
+ $utf8 = pack("U*", map { CORE::hex }
+ split " ", substr($txt, $charstart, $off[0] - $charstart - 1));
+ }
+ }
+
+ # Cache the input so as to not have to search the large table
+ # again, but only if it came from the one search that we cache.
+ # (Haven't bothered with the pain of sorting out scoping issues for the
+ # scripts searches.)
+ $cache_ref->{$name} = $utf8 if defined $cache_ref;
+ }
+ }
+
+
+ # Here, have the utf8. If the return is to be an ord, must be any single
+ # character.
+ if ($wants_ord) {
+ return ord($utf8) if length $utf8 == 1;
+ }
+ else {
+
+ # Here, wants string output. If utf8 is acceptable, just return what
+ # we've got; otherwise attempt to convert it to non-utf8 and return that.
+ my $in_bytes = ($runtime)
+ ? (caller $runtime)[8] & $bytes::hint_bits
+ : $^H & $bytes::hint_bits;
+ return $utf8 if (! $in_bytes || utf8::downgrade($utf8, 1)) # The 1 arg
+ # means don't die on failure
+ }
+
+ # Here, there is an error: either there are too many characters, or the
+ # result string needs to be non-utf8, and at least one character requires
+ # utf8. Prefer any official name over the input one for the error message.
+ if (@off) {
+ $name = substr($txt, $off[0], $off[1] - $off[0]) if @off;
+ }
+ else {
+ $name = (defined $save_input) ? $save_input : $_[0];
+ }
+
+ if ($wants_ord) {
+ # Only way to get here in this case is if result too long. Message
+ # assumes that our only caller that requires single char result is
+ # vianame.
+ carp "charnames::vianame() doesn't handle named sequences ($name). Use charnames::string_vianame() instead";
+ return;
+ }
+
+ # Only other possible failure here is from use bytes.
+ if ($runtime) {
+ carp not_legal_use_bytes_msg($name, $utf8);
+ return;
+ } else {
+ croak not_legal_use_bytes_msg($name, $utf8);
+ }
+
+} # lookup_name
+
+sub charnames {
+
+ # For \N{...}. Looks up the character name and returns the string
+ # representation of it.
+
+ # The first 0 arg means wants a string returned; the second that we are in
+ # compile time
+ return lookup_name($_[0], 0, 0);
+}
+
+sub import
+{
+ shift; ## ignore class name
+
+ if (not @_) {
+ carp("'use charnames' needs explicit imports list");
+ }
+ $^H{charnames} = \&charnames ;
+ $^H{charnames_ord_aliases} = {};
+ $^H{charnames_name_aliases} = {};
+ $^H{charnames_inverse_ords} = {};
+ # New fields must be added to %dummy_H, and the code in lookup_name()
+ # that copies fields from the runtime structure
+
+ ##
+ ## fill %h keys with our @_ args.
+ ##
+ my ($promote, %h, @args) = (0);
+ while (my $arg = shift) {
+ if ($arg eq ":alias") {
+ @_ or
+ croak ":alias needs an argument in charnames";
+ my $alias = shift;
+ if (ref $alias) {
+ ref $alias eq "HASH" or
+ croak "Only HASH reference supported as argument to :alias";
+ alias ($alias);
+ $promote = 1;
+ next;
+ }
+ if ($alias =~ m{:(\w+)$}) {
+ $1 eq "full" || $1 eq "loose" || $1 eq "short" and
+ croak ":alias cannot use existing pragma :$1 (reversed order?)";
+ alias_file ($1) and $promote = 1;
+ next;
+ }
+ alias_file ($alias) and $promote = 1;
+ next;
+ }
+ if (substr($arg, 0, 1) eq ':'
+ and ! ($arg eq ":full" || $arg eq ":short" || $arg eq ":loose"))
+ {
+ warn "unsupported special '$arg' in charnames";
+ next;
+ }
+ push @args, $arg;
+ }
+
+ @args == 0 && $promote and @args = (":full");
+ @h{@args} = (1) x @args;
+
+ # Don't leave these undefined as are tested for in lookup_names
+ $^H{charnames_full} = delete $h{':full'} || 0;
+ $^H{charnames_loose} = delete $h{':loose'} || 0;
+ $^H{charnames_short} = delete $h{':short'} || 0;
+ my @scripts = map { uc quotemeta } keys %h;
+
+ ##
+ ## If utf8? warnings are enabled, and some scripts were given,
+ ## see if at least we can find one letter from each script.
+ ##
+ if (warnings::enabled('utf8') && @scripts) {
+ $txt = do "unicore/Name.pl" unless $txt;
+
+ for my $script (@scripts) {
+ if (not $txt =~ m/\t$script (?:CAPITAL |SMALL )?LETTER /) {
+ warnings::warn('utf8', "No such script: '$script'");
+ $script = quotemeta $script; # Escape it, for use in the re.
+ }
+ }
+ }
+
+ # %^H gets stringified, so serialize it ourselves so can extract the
+ # real data back later.
+ $^H{charnames_stringified_ords} = join ",", %{$^H{charnames_ord_aliases}};
+ $^H{charnames_stringified_names} = join ",", %{$^H{charnames_name_aliases}};
+ $^H{charnames_stringified_inverse_ords} = join ",", %{$^H{charnames_inverse_ords}};
+
+ # Modify the input script names for loose name matching if that is also
+ # specified, similar to the way the base character name is prepared. They
+ # don't (currently, and hopefully never will) have dashes. These go into a
+ # regex, and have already been uppercased and quotemeta'd. Squeeze out all
+ # input underscores, blanks, and dashes. Then convert so will match a blank
+ # between any characters.
+ if ($^H{charnames_loose}) {
+ for (my $i = 0; $i < @scripts; $i++) {
+ $scripts[$i] =~ s/[_ -]//g;
+ $scripts[$i] =~ s/ ( [^\\] ) (?= . ) /$1\\ ?/gx;
+ }
+ }
+
+ $^H{charnames_scripts} = join "|", @scripts; # Stringifiy them as a trie
+} # import
+
+# Cache of already looked-up values. This is set to only contain
+# official values, and user aliases can't override them, so scoping is
+# not an issue.
+my %viacode;
+
+sub viacode {
+
+ # Returns the name of the code point argument
+
+ if (@_ != 1) {
+ carp "charnames::viacode() expects one argument";
+ return;
+ }
+
+ my $arg = shift;
+
+ # This is derived from Unicode::UCD, where it is nearly the same as the
+ # function _getcode(), but here it makes sure that even a hex argument
+ # has the proper number of leading zeros, which is critical in
+ # matching against $txt below
+ # Must check if decimal first; see comments at that definition
+ my $hex;
+ if ($arg =~ $decimal_qr) {
+ $hex = sprintf "%05X", $arg;
+ } elsif ($arg =~ $hex_qr) {
+ # Below is the line that differs from the _getcode() source
+ $hex = sprintf "%05X", hex $1;
+ } else {
+ carp("unexpected arg \"$arg\" to charnames::viacode()");
+ return;
+ }
+
+ return $viacode{$hex} if exists $viacode{$hex};
+
+ my $return;
+
+ # If the code point is above the max in the table, there's no point
+ # looking through it. Checking the length first is slightly faster
+ if (length($hex) <= 5 || CORE::hex($hex) <= 0x10FFFF) {
+ $txt = do "unicore/Name.pl" unless $txt;
+
+ # See if the name is algorithmically determinable.
+ my $algorithmic = charnames::code_point_to_name_special(CORE::hex $hex);
+ if (defined $algorithmic) {
+ $viacode{$hex} = $algorithmic;
+ return $algorithmic;
+ }
+
+ # Return the official name, if exists. It's unclear to me (khw) at
+ # this juncture if it is better to return a user-defined override, so
+ # leaving it as is for now.
+ if ($txt =~ m/^$hex\t/m) {
+
+ # The name starts with the next character and goes up to the
+ # next new-line. Using capturing parentheses above instead of
+ # @+ more than doubles the execution time in Perl 5.13
+ $return = substr($txt, $+[0], index($txt, "\n", $+[0]) - $+[0]);
+
+ # If not one of these 4 code points, return what we've found.
+ if ($hex !~ / ^ 000 (?: 8[014] | 99 ) $ /x) {
+ $viacode{$hex} = $return;
+ return $return;
+ }
+
+ # For backwards compatibility, we don't return the official name of
+ # the 4 code points if there are user-defined aliases for them -- so
+ # continue looking.
+ }
+ }
+
+ # See if there is a user name for it, before giving up completely.
+ # First get the scoped aliases, give up if have none.
+ my $H_ref = (caller(1))[10];
+ return if ! defined $return
+ && (! defined $H_ref
+ || ! exists $H_ref->{charnames_stringified_inverse_ords});
+
+ my %code_point_aliases;
+ if (defined $H_ref->{charnames_stringified_inverse_ords}) {
+ %code_point_aliases = split ',',
+ $H_ref->{charnames_stringified_inverse_ords};
+ return $code_point_aliases{$hex} if exists $code_point_aliases{$hex};
+ }
+
+ # Here there is no user-defined alias, return any official one.
+ return $return if defined $return;
+
+ if (CORE::hex($hex) > 0x10FFFF
+ && warnings::enabled('non_unicode'))
+ {
+ carp "Unicode characters only allocated up to U+10FFFF (you asked for U+$hex)";
+ }
+ return;
+
+} # _viacode
+
+1;
+
+# ex: set ts=8 sts=2 sw=2 et:
Index: trunk/contrib/perl/lib/abbrev.pl
===================================================================
--- trunk/contrib/perl/lib/abbrev.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/abbrev.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/abbrev.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/assert.pl
===================================================================
--- trunk/contrib/perl/lib/assert.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/assert.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/assert.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/lib/attributes.pm (from rev 6437, vendor/perl/5.18.1/lib/attributes.pm)
===================================================================
--- trunk/contrib/perl/lib/attributes.pm (rev 0)
+++ trunk/contrib/perl/lib/attributes.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,495 @@
+package attributes;
+
+our $VERSION = 0.09;
+
+ at EXPORT_OK = qw(get reftype);
+ at EXPORT = ();
+%EXPORT_TAGS = (ALL => [@EXPORT, @EXPORT_OK]);
+
+use strict;
+
+sub croak {
+ require Carp;
+ goto &Carp::croak;
+}
+
+sub carp {
+ require Carp;
+ goto &Carp::carp;
+}
+
+## forward declaration(s) rather than wrapping the bootstrap call in BEGIN{}
+#sub reftype ($) ;
+#sub _fetch_attrs ($) ;
+#sub _guess_stash ($) ;
+#sub _modify_attrs ;
+#
+# The extra trips through newATTRSUB in the interpreter wipe out any savings
+# from avoiding the BEGIN block. Just do the bootstrap now.
+BEGIN { bootstrap attributes }
+
+sub import {
+ @_ > 2 && ref $_[2] or do {
+ require Exporter;
+ goto &Exporter::import;
+ };
+ my (undef,$home_stash,$svref, at attrs) = @_;
+
+ my $svtype = uc reftype($svref);
+ my $pkgmeth;
+ $pkgmeth = UNIVERSAL::can($home_stash, "MODIFY_${svtype}_ATTRIBUTES")
+ if defined $home_stash && $home_stash ne '';
+ my @badattrs;
+ if ($pkgmeth) {
+ my @pkgattrs = _modify_attrs($svref, @attrs);
+ @badattrs = $pkgmeth->($home_stash, $svref, @pkgattrs);
+ if (!@badattrs && @pkgattrs) {
+ require warnings;
+ return unless warnings::enabled('reserved');
+ @pkgattrs = grep { m/\A[[:lower:]]+(?:\z|\()/ } @pkgattrs;
+ if (@pkgattrs) {
+ for my $attr (@pkgattrs) {
+ $attr =~ s/\(.+\z//s;
+ }
+ my $s = ((@pkgattrs == 1) ? '' : 's');
+ carp "$svtype package attribute$s " .
+ "may clash with future reserved word$s: " .
+ join(' : ' , @pkgattrs);
+ }
+ }
+ }
+ else {
+ @badattrs = _modify_attrs($svref, @attrs);
+ }
+ if (@badattrs) {
+ croak "Invalid $svtype attribute" .
+ (( @badattrs == 1 ) ? '' : 's') .
+ ": " .
+ join(' : ', @badattrs);
+ }
+}
+
+sub get ($) {
+ @_ == 1 && ref $_[0] or
+ croak 'Usage: '.__PACKAGE__.'::get $ref';
+ my $svref = shift;
+ my $svtype = uc reftype $svref;
+ my $stash = _guess_stash $svref;
+ $stash = caller unless defined $stash;
+ my $pkgmeth;
+ $pkgmeth = UNIVERSAL::can($stash, "FETCH_${svtype}_ATTRIBUTES")
+ if defined $stash && $stash ne '';
+ return $pkgmeth ?
+ (_fetch_attrs($svref), $pkgmeth->($stash, $svref)) :
+ (_fetch_attrs($svref))
+ ;
+}
+
+sub require_version { goto &UNIVERSAL::VERSION }
+
+1;
+__END__
+#The POD goes here
+
+=head1 NAME
+
+attributes - get/set subroutine or variable attributes
+
+=head1 SYNOPSIS
+
+ sub foo : method ;
+ my ($x, at y,%z) : Bent = 1;
+ my $s = sub : method { ... };
+
+ use attributes (); # optional, to get subroutine declarations
+ my @attrlist = attributes::get(\&foo);
+
+ use attributes 'get'; # import the attributes::get subroutine
+ my @attrlist = get \&foo;
+
+=head1 DESCRIPTION
+
+Subroutine declarations and definitions may optionally have attribute lists
+associated with them. (Variable C<my> declarations also may, but see the
+warning below.) Perl handles these declarations by passing some information
+about the call site and the thing being declared along with the attribute
+list to this module. In particular, the first example above is equivalent to
+the following:
+
+ use attributes __PACKAGE__, \&foo, 'method';
+
+The second example in the synopsis does something equivalent to this:
+
+ use attributes ();
+ my ($x, at y,%z);
+ attributes::->import(__PACKAGE__, \$x, 'Bent');
+ attributes::->import(__PACKAGE__, \@y, 'Bent');
+ attributes::->import(__PACKAGE__, \%z, 'Bent');
+ ($x, at y,%z) = 1;
+
+Yes, that's a lot of expansion.
+
+B<WARNING>: attribute declarations for variables are still evolving.
+The semantics and interfaces of such declarations could change in
+future versions. They are present for purposes of experimentation
+with what the semantics ought to be. Do not rely on the current
+implementation of this feature.
+
+There are only a few attributes currently handled by Perl itself (or
+directly by this module, depending on how you look at it.) However,
+package-specific attributes are allowed by an extension mechanism.
+(See L<"Package-specific Attribute Handling"> below.)
+
+The setting of subroutine attributes happens at compile time.
+Variable attributes in C<our> declarations are also applied at compile time.
+However, C<my> variables get their attributes applied at run-time.
+This means that you have to I<reach> the run-time component of the C<my>
+before those attributes will get applied. For example:
+
+ my $x : Bent = 42 if 0;
+
+will neither assign 42 to $x I<nor> will it apply the C<Bent> attribute
+to the variable.
+
+An attempt to set an unrecognized attribute is a fatal error. (The
+error is trappable, but it still stops the compilation within that
+C<eval>.) Setting an attribute with a name that's all lowercase
+letters that's not a built-in attribute (such as "foo") will result in
+a warning with B<-w> or C<use warnings 'reserved'>.
+
+=head2 What C<import> does
+
+In the description it is mentioned that
+
+ sub foo : method;
+
+is equivalent to
+
+ use attributes __PACKAGE__, \&foo, 'method';
+
+As you might know this calls the C<import> function of C<attributes> at compile
+time with these parameters: 'attributes', the caller's package name, the reference
+to the code and 'method'.
+
+ attributes->import( __PACKAGE__, \&foo, 'method' );
+
+So you want to know what C<import> actually does?
+
+First of all C<import> gets the type of the third parameter ('CODE' in this case).
+C<attributes.pm> checks if there is a subroutine called C<< MODIFY_<reftype>_ATTRIBUTES >>
+in the caller's namespace (here: 'main'). In this case a subroutine C<MODIFY_CODE_ATTRIBUTES> is
+required. Then this method is called to check if you have used a "bad attribute".
+The subroutine call in this example would look like
+
+ MODIFY_CODE_ATTRIBUTES( 'main', \&foo, 'method' );
+
+C<< MODIFY_<reftype>_ATTRIBUTES >> has to return a list of all "bad attributes".
+If there are any bad attributes C<import> croaks.
+
+(See L<"Package-specific Attribute Handling"> below.)
+
+=head2 Built-in Attributes
+
+The following are the built-in attributes for subroutines:
+
+=over 4
+
+=item locked
+
+B<5.005 threads only! The use of the "locked" attribute currently
+only makes sense if you are using the deprecated "Perl 5.005 threads"
+implementation of threads.>
+
+Setting this attribute is only meaningful when the subroutine or
+method is to be called by multiple threads. When set on a method
+subroutine (i.e., one marked with the B<method> attribute below),
+Perl ensures that any invocation of it implicitly locks its first
+argument before execution. When set on a non-method subroutine,
+Perl ensures that a lock is taken on the subroutine itself before
+execution. The semantics of the lock are exactly those of one
+explicitly taken with the C<lock> operator immediately after the
+subroutine is entered.
+
+=item method
+
+Indicates that the referenced subroutine is a method.
+This has a meaning when taken together with the B<locked> attribute,
+as described there. It also means that a subroutine so marked
+will not trigger the "Ambiguous call resolved as CORE::%s" warning.
+
+=item lvalue
+
+Indicates that the referenced subroutine is a valid lvalue and can
+be assigned to. The subroutine must return a modifiable value such
+as a scalar variable, as described in L<perlsub>.
+
+=back
+
+For global variables there is C<unique> attribute: see L<perlfunc/our>.
+
+=head2 Available Subroutines
+
+The following subroutines are available for general use once this module
+has been loaded:
+
+=over 4
+
+=item get
+
+This routine expects a single parameter--a reference to a
+subroutine or variable. It returns a list of attributes, which may be
+empty. If passed invalid arguments, it uses die() (via L<Carp::croak|Carp>)
+to raise a fatal exception. If it can find an appropriate package name
+for a class method lookup, it will include the results from a
+C<FETCH_I<type>_ATTRIBUTES> call in its return list, as described in
+L<"Package-specific Attribute Handling"> below.
+Otherwise, only L<built-in attributes|"Built-in Attributes"> will be returned.
+
+=item reftype
+
+This routine expects a single parameter--a reference to a subroutine or
+variable. It returns the built-in type of the referenced variable,
+ignoring any package into which it might have been blessed.
+This can be useful for determining the I<type> value which forms part of
+the method names described in L<"Package-specific Attribute Handling"> below.
+
+=back
+
+Note that these routines are I<not> exported by default.
+
+=head2 Package-specific Attribute Handling
+
+B<WARNING>: the mechanisms described here are still experimental. Do not
+rely on the current implementation. In particular, there is no provision
+for applying package attributes to 'cloned' copies of subroutines used as
+closures. (See L<perlref/"Making References"> for information on closures.)
+Package-specific attribute handling may change incompatibly in a future
+release.
+
+When an attribute list is present in a declaration, a check is made to see
+whether an attribute 'modify' handler is present in the appropriate package
+(or its @ISA inheritance tree). Similarly, when C<attributes::get> is
+called on a valid reference, a check is made for an appropriate attribute
+'fetch' handler. See L<"EXAMPLES"> to see how the "appropriate package"
+determination works.
+
+The handler names are based on the underlying type of the variable being
+declared or of the reference passed. Because these attributes are
+associated with subroutine or variable declarations, this deliberately
+ignores any possibility of being blessed into some package. Thus, a
+subroutine declaration uses "CODE" as its I<type>, and even a blessed
+hash reference uses "HASH" as its I<type>.
+
+The class methods invoked for modifying and fetching are these:
+
+=over 4
+
+=item FETCH_I<type>_ATTRIBUTES
+
+This method is called with two arguments: the relevant package name,
+and a reference to a variable or subroutine for which package-defined
+attributes are desired. The expected return value is a list of
+associated attributes. This list may be empty.
+
+=item MODIFY_I<type>_ATTRIBUTES
+
+This method is called with two fixed arguments, followed by the list of
+attributes from the relevant declaration. The two fixed arguments are
+the relevant package name and a reference to the declared subroutine or
+variable. The expected return value is a list of attributes which were
+not recognized by this handler. Note that this allows for a derived class
+to delegate a call to its base class, and then only examine the attributes
+which the base class didn't already handle for it.
+
+The call to this method is currently made I<during> the processing of the
+declaration. In particular, this means that a subroutine reference will
+probably be for an undefined subroutine, even if this declaration is
+actually part of the definition.
+
+=back
+
+Calling C<attributes::get()> from within the scope of a null package
+declaration C<package ;> for an unblessed variable reference will
+not provide any starting package name for the 'fetch' method lookup.
+Thus, this circumstance will not result in a method call for package-defined
+attributes. A named subroutine knows to which symbol table entry it belongs
+(or originally belonged), and it will use the corresponding package.
+An anonymous subroutine knows the package name into which it was compiled
+(unless it was also compiled with a null package declaration), and so it
+will use that package name.
+
+=head2 Syntax of Attribute Lists
+
+An attribute list is a sequence of attribute specifications, separated by
+whitespace or a colon (with optional whitespace).
+Each attribute specification is a simple
+name, optionally followed by a parenthesised parameter list.
+If such a parameter list is present, it is scanned past as for the rules
+for the C<q()> operator. (See L<perlop/"Quote and Quote-like Operators">.)
+The parameter list is passed as it was found, however, and not as per C<q()>.
+
+Some examples of syntactically valid attribute lists:
+
+ switch(10,foo(7,3)) : expensive
+ Ugly('\(") :Bad
+ _5x5
+ locked method
+
+Some examples of syntactically invalid attribute lists (with annotation):
+
+ switch(10,foo() # ()-string not balanced
+ Ugly('(') # ()-string not balanced
+ 5x5 # "5x5" not a valid identifier
+ Y2::north # "Y2::north" not a simple identifier
+ foo + bar # "+" neither a colon nor whitespace
+
+=head1 EXPORTS
+
+=head2 Default exports
+
+None.
+
+=head2 Available exports
+
+The routines C<get> and C<reftype> are exportable.
+
+=head2 Export tags defined
+
+The C<:ALL> tag will get all of the above exports.
+
+=head1 EXAMPLES
+
+Here are some samples of syntactically valid declarations, with annotation
+as to how they resolve internally into C<use attributes> invocations by
+perl. These examples are primarily useful to see how the "appropriate
+package" is found for the possible method lookups for package-defined
+attributes.
+
+=over 4
+
+=item 1.
+
+Code:
+
+ package Canine;
+ package Dog;
+ my Canine $spot : Watchful ;
+
+Effect:
+
+ use attributes ();
+ attributes::->import(Canine => \$spot, "Watchful");
+
+=item 2.
+
+Code:
+
+ package Felis;
+ my $cat : Nervous;
+
+Effect:
+
+ use attributes ();
+ attributes::->import(Felis => \$cat, "Nervous");
+
+=item 3.
+
+Code:
+
+ package X;
+ sub foo : locked ;
+
+Effect:
+
+ use attributes X => \&foo, "locked";
+
+=item 4.
+
+Code:
+
+ package X;
+ sub Y::x : locked { 1 }
+
+Effect:
+
+ use attributes Y => \&Y::x, "locked";
+
+=item 5.
+
+Code:
+
+ package X;
+ sub foo { 1 }
+
+ package Y;
+ BEGIN { *bar = \&X::foo; }
+
+ package Z;
+ sub Y::bar : locked ;
+
+Effect:
+
+ use attributes X => \&X::foo, "locked";
+
+=back
+
+This last example is purely for purposes of completeness. You should not
+be trying to mess with the attributes of something in a package that's
+not your own.
+
+=head1 MORE EXAMPLES
+
+=over 4
+
+=item 1.
+
+ sub MODIFY_CODE_ATTRIBUTES {
+ my ($class,$code, at attrs) = @_;
+
+ my $allowed = 'MyAttribute';
+ my @bad = grep { $_ ne $allowed } @attrs;
+
+ return @bad;
+ }
+
+ sub foo : MyAttribute {
+ print "foo\n";
+ }
+
+This example runs. At compile time C<MODIFY_CODE_ATTRIBUTES> is called. In that
+subroutine, we check if any attribute is disallowed and we return a list of
+these "bad attributes".
+
+As we return an empty list, everything is fine.
+
+=item 2.
+
+ sub MODIFY_CODE_ATTRIBUTES {
+ my ($class,$code, at attrs) = @_;
+
+ my $allowed = 'MyAttribute';
+ my @bad = grep{ $_ ne $allowed }@attrs;
+
+ return @bad;
+ }
+
+ sub foo : MyAttribute Test {
+ print "foo\n";
+ }
+
+This example is aborted at compile time as we use the attribute "Test" which
+isn't allowed. C<MODIFY_CODE_ATTRIBUTES> returns a list that contains a single
+element ('Test').
+
+=back
+
+=head1 SEE ALSO
+
+L<perlsub/"Private Variables via my()"> and
+L<perlsub/"Subroutine Attributes"> for details on the basic declarations;
+L<attrs> for the obsolescent form of subroutine attribute specification
+which this module replaces;
+L<perlfunc/use> for details on the normal invocation mechanism.
+
+=cut
+
Copied: trunk/contrib/perl/lib/autodie.pm (from rev 6437, vendor/perl/5.18.1/lib/autodie.pm)
===================================================================
--- trunk/contrib/perl/lib/autodie.pm (rev 0)
+++ trunk/contrib/perl/lib/autodie.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,424 @@
+package autodie;
+use 5.008;
+use strict;
+use warnings;
+
+use Fatal ();
+our @ISA = qw(Fatal);
+our $VERSION;
+
+BEGIN {
+ $VERSION = '2.06_01';
+}
+
+use constant ERROR_WRONG_FATAL => q{
+Incorrect version of Fatal.pm loaded by autodie.
+
+The autodie pragma uses an updated version of Fatal to do its
+heavy lifting. We seem to have loaded Fatal version %s, which is
+probably the version that came with your version of Perl. However
+autodie needs version %s, which would have come bundled with
+autodie.
+
+You may be able to solve this problem by adding the following
+line of code to your main program, before any use of Fatal or
+autodie.
+
+ use lib "%s";
+
+};
+
+# We have to check we've got the right version of Fatal before we
+# try to compile the rest of our code, lest we use a constant
+# that doesn't exist.
+
+BEGIN {
+
+ # If we have the wrong Fatal, then we've probably loaded the system
+ # one, not our own. Complain, and give a useful hint. ;)
+
+ if ($Fatal::VERSION ne $VERSION) {
+ my $autodie_path = $INC{'autodie.pm'};
+
+ $autodie_path =~ s/autodie\.pm//;
+
+ require Carp;
+
+ Carp::croak sprintf(
+ ERROR_WRONG_FATAL, $Fatal::VERSION, $VERSION, $autodie_path
+ );
+ }
+}
+
+# When passing args to Fatal we want to keep the first arg
+# (our package) in place. Hence the splice.
+
+sub import {
+ splice(@_,1,0,Fatal::LEXICAL_TAG);
+ goto &Fatal::import;
+}
+
+sub unimport {
+ splice(@_,1,0,Fatal::LEXICAL_TAG);
+ goto &Fatal::unimport;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+autodie - Replace functions with ones that succeed or die with lexical scope
+
+=head1 SYNOPSIS
+
+ use autodie; # Recommended: implies 'use autodie qw(:default)'
+
+ use autodie qw(:all); # Recommended more: defaults and system/exec.
+
+ use autodie qw(open close); # open/close succeed or die
+
+ open(my $fh, "<", $filename); # No need to check!
+
+ {
+ no autodie qw(open); # open failures won't die
+ open(my $fh, "<", $filename); # Could fail silently!
+ no autodie; # disable all autodies
+ }
+
+=head1 DESCRIPTION
+
+ bIlujDI' yIchegh()Qo'; yIHegh()!
+
+ It is better to die() than to return() in failure.
+
+ -- Klingon programming proverb.
+
+The C<autodie> pragma provides a convenient way to replace functions
+that normally return false on failure with equivalents that throw
+an exception on failure.
+
+The C<autodie> pragma has I<lexical scope>, meaning that functions
+and subroutines altered with C<autodie> will only change their behaviour
+until the end of the enclosing block, file, or C<eval>.
+
+If C<system> is specified as an argument to C<autodie>, then it
+uses L<IPC::System::Simple> to do the heavy lifting. See the
+description of that module for more information.
+
+=head1 EXCEPTIONS
+
+Exceptions produced by the C<autodie> pragma are members of the
+L<autodie::exception> class. The preferred way to work with
+these exceptions under Perl 5.10 is as follows:
+
+ use feature qw(switch);
+
+ eval {
+ use autodie;
+
+ open(my $fh, '<', $some_file);
+
+ my @records = <$fh>;
+
+ # Do things with @records...
+
+ close($fh);
+
+ };
+
+ given ($@) {
+ when (undef) { say "No error"; }
+ when ('open') { say "Error from open"; }
+ when (':io') { say "Non-open, IO error."; }
+ when (':all') { say "All other autodie errors." }
+ default { say "Not an autodie error at all." }
+ }
+
+Under Perl 5.8, the C<given/when> structure is not available, so the
+following structure may be used:
+
+ eval {
+ use autodie;
+
+ open(my $fh, '<', $some_file);
+
+ my @records = <$fh>;
+
+ # Do things with @records...
+
+ close($fh);
+ };
+
+ if ($@ and $@->isa('autodie::exception')) {
+ if ($@->matches('open')) { print "Error from open\n"; }
+ if ($@->matches(':io' )) { print "Non-open, IO error."; }
+ } elsif ($@) {
+ # A non-autodie exception.
+ }
+
+See L<autodie::exception> for further information on interrogating
+exceptions.
+
+=head1 CATEGORIES
+
+Autodie uses a simple set of categories to group together similar
+built-ins. Requesting a category type (starting with a colon) will
+enable autodie for all built-ins beneath that category. For example,
+requesting C<:file> will enable autodie for C<close>, C<fcntl>,
+C<fileno>, C<open> and C<sysopen>.
+
+The categories are currently:
+
+ :all
+ :default
+ :io
+ read
+ seek
+ sysread
+ sysseek
+ syswrite
+ :dbm
+ dbmclose
+ dbmopen
+ :file
+ binmode
+ close
+ fcntl
+ fileno
+ flock
+ ioctl
+ open
+ sysopen
+ truncate
+ :filesys
+ chdir
+ closedir
+ opendir
+ link
+ mkdir
+ readlink
+ rename
+ rmdir
+ symlink
+ unlink
+ :ipc
+ pipe
+ :msg
+ msgctl
+ msgget
+ msgrcv
+ msgsnd
+ :semaphore
+ semctl
+ semget
+ semop
+ :shm
+ shmctl
+ shmget
+ shmread
+ :socket
+ accept
+ bind
+ connect
+ getsockopt
+ listen
+ recv
+ send
+ setsockopt
+ shutdown
+ socketpair
+ :threads
+ fork
+ :system
+ system
+ exec
+
+
+Note that while the above category system is presently a strict
+hierarchy, this should not be assumed.
+
+A plain C<use autodie> implies C<use autodie qw(:default)>. Note that
+C<system> and C<exec> are not enabled by default. C<system> requires
+the optional L<IPC::System::Simple> module to be installed, and enabling
+C<system> or C<exec> will invalidate their exotic forms. See L</BUGS>
+below for more details.
+
+The syntax:
+
+ use autodie qw(:1.994);
+
+allows the C<:default> list from a particular version to be used. This
+provides the convenience of using the default methods, but the surety
+that no behavorial changes will occur if the C<autodie> module is
+upgraded.
+
+C<autodie> can be enabled for all of Perl's built-ins, including
+C<system> and C<exec> with:
+
+ use autodie qw(:all);
+
+=head1 FUNCTION SPECIFIC NOTES
+
+=head2 flock
+
+It is not considered an error for C<flock> to return false if it fails
+to an C<EWOULDBLOCK> (or equivalent) condition. This means one can
+still use the common convention of testing the return value of
+C<flock> when called with the C<LOCK_NB> option:
+
+ use autodie;
+
+ if ( flock($fh, LOCK_EX | LOCK_NB) ) {
+ # We have a lock
+ }
+
+Autodying C<flock> will generate an exception if C<flock> returns
+false with any other error.
+
+=head2 system/exec
+
+The C<system> built-in is considered to have failed in the following
+circumstances:
+
+=over 4
+
+=item *
+
+The command does not start.
+
+=item *
+
+The command is killed by a signal.
+
+=item *
+
+The command returns a non-zero exit value (but see below).
+
+=back
+
+On success, the autodying form of C<system> returns the I<exit value>
+rather than the contents of C<$?>.
+
+Additional allowable exit values can be supplied as an optional first
+argument to autodying C<system>:
+
+ system( [ 0, 1, 2 ], $cmd, @args); # 0,1,2 are good exit values
+
+C<autodie> uses the L<IPC::System::Simple> module to change C<system>.
+See its documentation for further information.
+
+Applying C<autodie> to C<system> or C<exec> causes the exotic
+forms C<system { $cmd } @args > or C<exec { $cmd } @args>
+to be considered a syntax error until the end of the lexical scope.
+If you really need to use the exotic form, you can call C<CORE::system>
+or C<CORE::exec> instead, or use C<no autodie qw(system exec)> before
+calling the exotic form.
+
+=head1 GOTCHAS
+
+Functions called in list context are assumed to have failed if they
+return an empty list, or a list consisting only of a single undef
+element.
+
+=head1 DIAGNOSTICS
+
+=over 4
+
+=item :void cannot be used with lexical scope
+
+The C<:void> option is supported in L<Fatal>, but not
+C<autodie>. To workaround this, C<autodie> may be explicitly disabled until
+the end of the current block with C<no autodie>.
+To disable autodie for only a single function (eg, open)
+use C<no autodie qw(open)>.
+
+=item No user hints defined for %s
+
+You've insisted on hints for user-subroutines, either by pre-pending
+a C<!> to the subroutine name itself, or earlier in the list of arguments
+to C<autodie>. However the subroutine in question does not have
+any hints available.
+
+=back
+
+See also L<Fatal/DIAGNOSTICS>.
+
+=head1 BUGS
+
+"Used only once" warnings can be generated when C<autodie> or C<Fatal>
+is used with package filehandles (eg, C<FILE>). Scalar filehandles are
+strongly recommended instead.
+
+When using C<autodie> or C<Fatal> with user subroutines, the
+declaration of those subroutines must appear before the first use of
+C<Fatal> or C<autodie>, or have been exported from a module.
+Attempting to use C<Fatal> or C<autodie> on other user subroutines will
+result in a compile-time error.
+
+Due to a bug in Perl, C<autodie> may "lose" any format which has the
+same name as an autodying built-in or function.
+
+C<autodie> may not work correctly if used inside a file with a
+name that looks like a string eval, such as F<eval (3)>.
+
+=head2 autodie and string eval
+
+Due to the current implementation of C<autodie>, unexpected results
+may be seen when used near or with the string version of eval.
+I<None of these bugs exist when using block eval>.
+
+Under Perl 5.8 only, C<autodie> I<does not> propagate into string C<eval>
+statements, although it can be explicitly enabled inside a string
+C<eval>.
+
+Under Perl 5.10 only, using a string eval when C<autodie> is in
+effect can cause the autodie behaviour to leak into the surrounding
+scope. This can be worked around by using a C<no autodie> at the
+end of the scope to explicitly remove autodie's effects, or by
+avoiding the use of string eval.
+
+I<None of these bugs exist when using block eval>. The use of
+C<autodie> with block eval is considered good practice.
+
+=head2 REPORTING BUGS
+
+Please report bugs via the CPAN Request Tracker at
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=autodie>.
+
+=head1 FEEDBACK
+
+If you find this module useful, please consider rating it on the
+CPAN Ratings service at
+L<http://cpanratings.perl.org/rate?distribution=autodie> .
+
+The module author loves to hear how C<autodie> has made your life
+better (or worse). Feedback can be sent to
+E<lt>pjf at perltraining.com.auE<gt>.
+
+=head1 AUTHOR
+
+Copyright 2008-2009, Paul Fenwick E<lt>pjf at perltraining.com.auE<gt>
+
+=head1 LICENSE
+
+This module is free software. You may distribute it under the
+same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<Fatal>, L<autodie::exception>, L<autodie::hints>, L<IPC::System::Simple>
+
+I<Perl tips, autodie> at
+L<http://perltraining.com.au/tips/2008-08-20.html>
+
+=head1 ACKNOWLEDGEMENTS
+
+Mark Reed and Roland Giersig -- Klingon translators.
+
+See the F<AUTHORS> file for full credits. The latest version of this
+file can be found at
+L<http://github.com/pfenwick/autodie/tree/master/AUTHORS> .
+
+=cut
Copied: trunk/contrib/perl/lib/autouse.pm (from rev 6437, vendor/perl/5.18.1/lib/autouse.pm)
===================================================================
--- trunk/contrib/perl/lib/autouse.pm (rev 0)
+++ trunk/contrib/perl/lib/autouse.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,171 @@
+package autouse;
+
+#use strict; # debugging only
+use 5.006; # use warnings
+
+$autouse::VERSION = '1.06';
+
+$autouse::DEBUG ||= 0;
+
+sub vet_import ($);
+
+sub croak {
+ require Carp;
+ Carp::croak(@_);
+}
+
+sub import {
+ my $class = @_ ? shift : 'autouse';
+ croak "usage: use $class MODULE [,SUBS...]" unless @_;
+ my $module = shift;
+
+ (my $pm = $module) =~ s{::}{/}g;
+ $pm .= '.pm';
+ if (exists $INC{$pm}) {
+ vet_import $module;
+ local $Exporter::ExportLevel = $Exporter::ExportLevel + 1;
+ # $Exporter::Verbose = 1;
+ return $module->import(map { (my $f = $_) =~ s/\(.*?\)$//; $f } @_);
+ }
+
+ # It is not loaded: need to do real work.
+ my $callpkg = caller(0);
+ print "autouse called from $callpkg\n" if $autouse::DEBUG;
+
+ my $index;
+ for my $f (@_) {
+ my $proto;
+ $proto = $1 if (my $func = $f) =~ s/\((.*)\)$//;
+
+ my $closure_import_func = $func; # Full name
+ my $closure_func = $func; # Name inside package
+ my $index = rindex($func, '::');
+ if ($index == -1) {
+ $closure_import_func = "${callpkg}::$func";
+ } else {
+ $closure_func = substr $func, $index + 2;
+ croak "autouse into different package attempted"
+ unless substr($func, 0, $index) eq $module;
+ }
+
+ my $load_sub = sub {
+ unless ($INC{$pm}) {
+ require $pm;
+ vet_import $module;
+ }
+ no warnings qw(redefine prototype);
+ *$closure_import_func = \&{"${module}::$closure_func"};
+ print "autousing $module; "
+ ."imported $closure_func as $closure_import_func\n"
+ if $autouse::DEBUG;
+ goto &$closure_import_func;
+ };
+
+ if (defined $proto) {
+ *$closure_import_func = eval "sub ($proto) { goto &\$load_sub }"
+ || die;
+ } else {
+ *$closure_import_func = $load_sub;
+ }
+ }
+}
+
+sub vet_import ($) {
+ my $module = shift;
+ if (my $import = $module->can('import')) {
+ croak "autoused module $module has unique import() method"
+ unless defined(&Exporter::import)
+ && ($import == \&Exporter::import ||
+ $import == \&UNIVERSAL::import)
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+autouse - postpone load of modules until a function is used
+
+=head1 SYNOPSIS
+
+ use autouse 'Carp' => qw(carp croak);
+ carp "this carp was predeclared and autoused ";
+
+=head1 DESCRIPTION
+
+If the module C<Module> is already loaded, then the declaration
+
+ use autouse 'Module' => qw(func1 func2($;$));
+
+is equivalent to
+
+ use Module qw(func1 func2);
+
+if C<Module> defines func2() with prototype C<($;$)>, and func1() has
+no prototypes. (At least if C<Module> uses C<Exporter>'s C<import>,
+otherwise it is a fatal error.)
+
+If the module C<Module> is not loaded yet, then the above declaration
+declares functions func1() and func2() in the current package. When
+these functions are called, they load the package C<Module> if needed,
+and substitute themselves with the correct definitions.
+
+=begin _deprecated
+
+ use Module qw(Module::func3);
+
+will work and is the equivalent to:
+
+ use Module qw(func3);
+
+It is not a very useful feature and has been deprecated.
+
+=end _deprecated
+
+
+=head1 WARNING
+
+Using C<autouse> will move important steps of your program's execution
+from compile time to runtime. This can
+
+=over 4
+
+=item *
+
+Break the execution of your program if the module you C<autouse>d has
+some initialization which it expects to be done early.
+
+=item *
+
+hide bugs in your code since important checks (like correctness of
+prototypes) is moved from compile time to runtime. In particular, if
+the prototype you specified on C<autouse> line is wrong, you will not
+find it out until the corresponding function is executed. This will be
+very unfortunate for functions which are not always called (note that
+for such functions C<autouse>ing gives biggest win, for a workaround
+see below).
+
+=back
+
+To alleviate the second problem (partially) it is advised to write
+your scripts like this:
+
+ use Module;
+ use autouse Module => qw(carp($) croak(&$));
+ carp "this carp was predeclared and autoused ";
+
+The first line ensures that the errors in your argument specification
+are found early. When you ship your application you should comment
+out the first line, since it makes the second one useless.
+
+=head1 AUTHOR
+
+Ilya Zakharevich (ilya at math.ohio-state.edu)
+
+=head1 SEE ALSO
+
+perl(1).
+
+=cut
Copied: trunk/contrib/perl/lib/autouse.t (from rev 6437, vendor/perl/5.18.1/lib/autouse.t)
===================================================================
--- trunk/contrib/perl/lib/autouse.t (rev 0)
+++ trunk/contrib/perl/lib/autouse.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,71 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config;
+ if (($Config::Config{'extensions'} !~ m!\bList/Util\b!) ){
+ print "1..0 # Skip -- Perl configured without List::Util module\n";
+ exit 0;
+ }
+}
+
+use Test;
+BEGIN { plan tests => 12; }
+
+BEGIN {
+ require autouse;
+ eval {
+ "autouse"->import('List::Util' => 'List::Util::first(&@)');
+ };
+ ok( !$@ );
+
+ eval {
+ "autouse"->import('List::Util' => 'Foo::min');
+ };
+ ok( $@, qr/^autouse into different package attempted/ );
+
+ "autouse"->import('List::Util' => qw(max first(&@)));
+}
+
+my @a = (1,2,3,4,5.5);
+ok( max(@a), 5.5);
+
+
+# first() has a prototype of &@. Make sure that's preserved.
+ok( (first { $_ > 3 } @a), 4);
+
+
+# Example from the docs.
+use autouse 'Carp' => qw(carp croak);
+
+{
+ my @warning;
+ local $SIG{__WARN__} = sub { push @warning, @_ };
+ carp "this carp was predeclared and autoused\n";
+ ok( scalar @warning, 1 );
+ ok( $warning[0], qr/^this carp was predeclared and autoused\n/ );
+
+ eval { croak "It is but a scratch!" };
+ ok( $@, qr/^It is but a scratch!/);
+}
+
+
+# Test that autouse's lazy module loading works.
+use autouse 'Errno' => qw(EPERM);
+
+my $mod_file = 'Errno.pm'; # just fine and portable for %INC
+ok( !exists $INC{$mod_file} );
+ok( EPERM ); # test if non-zero
+ok( exists $INC{$mod_file} );
+
+use autouse Env => "something";
+eval { something() };
+ok( $@, qr/^\Qautoused module Env has unique import() method/ );
+
+# Check that UNIVERSAL.pm doesn't interfere with modules that don't use
+# Exporter and have no import() of their own.
+require UNIVERSAL;
+autouse->import("Class::ISA" => 'self_and_super_versions');
+my %versions = self_and_super_versions("Class::ISA");
+ok( $versions{"Class::ISA"}, $Class::ISA::VERSION );
Copied: trunk/contrib/perl/lib/base.pm (from rev 6437, vendor/perl/5.18.1/lib/base.pm)
===================================================================
--- trunk/contrib/perl/lib/base.pm (rev 0)
+++ trunk/contrib/perl/lib/base.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,265 @@
+package base;
+
+use strict 'vars';
+use vars qw($VERSION);
+$VERSION = '2.14';
+$VERSION = eval $VERSION;
+
+# constant.pm is slow
+sub SUCCESS () { 1 }
+
+sub PUBLIC () { 2**0 }
+sub PRIVATE () { 2**1 }
+sub INHERITED () { 2**2 }
+sub PROTECTED () { 2**3 }
+
+
+my $Fattr = \%fields::attr;
+
+sub has_fields {
+ my($base) = shift;
+ my $fglob = ${"$base\::"}{FIELDS};
+ return( ($fglob && 'GLOB' eq ref($fglob) && *$fglob{HASH}) ? 1 : 0 );
+}
+
+sub has_version {
+ my($base) = shift;
+ my $vglob = ${$base.'::'}{VERSION};
+ return( ($vglob && *$vglob{SCALAR}) ? 1 : 0 );
+}
+
+sub has_attr {
+ my($proto) = shift;
+ my($class) = ref $proto || $proto;
+ return exists $Fattr->{$class};
+}
+
+sub get_attr {
+ $Fattr->{$_[0]} = [1] unless $Fattr->{$_[0]};
+ return $Fattr->{$_[0]};
+}
+
+if ($] < 5.009) {
+ *get_fields = sub {
+ # Shut up a possible typo warning.
+ () = \%{$_[0].'::FIELDS'};
+ my $f = \%{$_[0].'::FIELDS'};
+
+ # should be centralized in fields? perhaps
+ # fields::mk_FIELDS_be_OK. Peh. As long as %{ $package . '::FIELDS' }
+ # is used here anyway, it doesn't matter.
+ bless $f, 'pseudohash' if (ref($f) ne 'pseudohash');
+
+ return $f;
+ }
+}
+else {
+ *get_fields = sub {
+ # Shut up a possible typo warning.
+ () = \%{$_[0].'::FIELDS'};
+ return \%{$_[0].'::FIELDS'};
+ }
+}
+
+sub import {
+ my $class = shift;
+
+ return SUCCESS unless @_;
+
+ # List of base classes from which we will inherit %FIELDS.
+ my $fields_base;
+
+ my $inheritor = caller(0);
+ my @isa_classes;
+
+ my @bases;
+ foreach my $base (@_) {
+ if ( $inheritor eq $base ) {
+ warn "Class '$inheritor' tried to inherit from itself\n";
+ }
+
+ next if grep $_->isa($base), ($inheritor, @bases);
+
+ if (has_version($base)) {
+ ${$base.'::VERSION'} = '-1, set by base.pm'
+ unless defined ${$base.'::VERSION'};
+ }
+ else {
+ my $sigdie;
+ {
+ local $SIG{__DIE__};
+ eval "require $base";
+ # Only ignore "Can't locate" errors from our eval require.
+ # Other fatal errors (syntax etc) must be reported.
+ die if $@ && $@ !~ /^Can't locate .*? at \(eval /;
+ unless (%{"$base\::"}) {
+ require Carp;
+ local $" = " ";
+ Carp::croak(<<ERROR);
+Base class package "$base" is empty.
+ (Perhaps you need to 'use' the module which defines that package first,
+ or make that module available in \@INC (\@INC contains: @INC).
+ERROR
+ }
+ $sigdie = $SIG{__DIE__} || undef;
+ }
+ # Make sure a global $SIG{__DIE__} makes it out of the localization.
+ $SIG{__DIE__} = $sigdie if defined $sigdie;
+ ${$base.'::VERSION'} = "-1, set by base.pm"
+ unless defined ${$base.'::VERSION'};
+ }
+ push @bases, $base;
+
+ if ( has_fields($base) || has_attr($base) ) {
+ # No multiple fields inheritance *suck*
+ if ($fields_base) {
+ require Carp;
+ Carp::croak("Can't multiply inherit fields");
+ } else {
+ $fields_base = $base;
+ }
+ }
+ }
+ # Save this until the end so it's all or nothing if the above loop croaks.
+ push @{"$inheritor\::ISA"}, @isa_classes;
+
+ push @{"$inheritor\::ISA"}, @bases;
+
+ if( defined $fields_base ) {
+ inherit_fields($inheritor, $fields_base);
+ }
+}
+
+
+sub inherit_fields {
+ my($derived, $base) = @_;
+
+ return SUCCESS unless $base;
+
+ my $battr = get_attr($base);
+ my $dattr = get_attr($derived);
+ my $dfields = get_fields($derived);
+ my $bfields = get_fields($base);
+
+ $dattr->[0] = @$battr;
+
+ if( keys %$dfields ) {
+ warn <<"END";
+$derived is inheriting from $base but already has its own fields!
+This will cause problems. Be sure you use base BEFORE declaring fields.
+END
+
+ }
+
+ # Iterate through the base's fields adding all the non-private
+ # ones to the derived class. Hang on to the original attribute
+ # (Public, Private, etc...) and add Inherited.
+ # This is all too complicated to do efficiently with add_fields().
+ while (my($k,$v) = each %$bfields) {
+ my $fno;
+ if ($fno = $dfields->{$k} and $fno != $v) {
+ require Carp;
+ Carp::croak ("Inherited fields can't override existing fields");
+ }
+
+ if( $battr->[$v] & PRIVATE ) {
+ $dattr->[$v] = PRIVATE | INHERITED;
+ }
+ else {
+ $dattr->[$v] = INHERITED | $battr->[$v];
+ $dfields->{$k} = $v;
+ }
+ }
+
+ foreach my $idx (1..$#{$battr}) {
+ next if defined $dattr->[$idx];
+ $dattr->[$idx] = $battr->[$idx] & INHERITED;
+ }
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+base - Establish an ISA relationship with base classes at compile time
+
+=head1 SYNOPSIS
+
+ package Baz;
+ use base qw(Foo Bar);
+
+=head1 DESCRIPTION
+
+Unless you are using the C<fields> pragma, consider this module discouraged
+in favor of the lighter-weight C<parent>.
+
+Allows you to both load one or more modules, while setting up inheritance from
+those modules at the same time. Roughly similar in effect to
+
+ package Baz;
+ BEGIN {
+ require Foo;
+ require Bar;
+ push @ISA, qw(Foo Bar);
+ }
+
+C<base> employs some heuristics to determine if a module has already been
+loaded, if it has it doesn't try again. If C<base> tries to C<require> the
+module it will not die if it cannot find the module's file, but will die on any
+other error. After all this, should your base class be empty, containing no
+symbols, it will die. This is useful for inheriting from classes in the same
+file as yourself, like so:
+
+ package Foo;
+ sub exclaim { "I can have such a thing?!" }
+
+ package Bar;
+ use base "Foo";
+
+If $VERSION is not detected even after loading it, <base> will define $VERSION
+in the base package, setting it to the string C<-1, set by base.pm>.
+
+C<base> will also initialize the fields if one of the base classes has it.
+Multiple inheritance of fields is B<NOT> supported, if two or more base classes
+each have inheritable fields the 'base' pragma will croak. See L<fields>,
+L<public> and L<protected> for a description of this feature.
+
+The base class' C<import> method is B<not> called.
+
+
+=head1 DIAGNOSTICS
+
+=over 4
+
+=item Base class package "%s" is empty.
+
+base.pm was unable to require the base package, because it was not
+found in your path.
+
+=item Class 'Foo' tried to inherit from itself
+
+Attempting to inherit from yourself generates a warning.
+
+ use Foo;
+ use base 'Foo';
+
+=back
+
+=head1 HISTORY
+
+This module was introduced with Perl 5.004_04.
+
+=head1 CAVEATS
+
+Due to the limitations of the implementation, you must use
+base I<before> you declare any of your own fields.
+
+
+=head1 SEE ALSO
+
+L<fields>
+
+=cut
Index: trunk/contrib/perl/lib/bigfloat.pl
===================================================================
--- trunk/contrib/perl/lib/bigfloat.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/bigfloat.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/bigfloat.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/bigfloatpl.t
===================================================================
--- trunk/contrib/perl/lib/bigfloatpl.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/bigfloatpl.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/bigfloatpl.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/bigint.pl
===================================================================
--- trunk/contrib/perl/lib/bigint.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/bigint.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/bigint.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/lib/bigint.pm (from rev 6437, vendor/perl/5.18.1/lib/bigint.pm)
===================================================================
--- trunk/contrib/perl/lib/bigint.pm (rev 0)
+++ trunk/contrib/perl/lib/bigint.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,675 @@
+package bigint;
+use 5.006;
+
+$VERSION = '0.23';
+use Exporter;
+ at ISA = qw( Exporter );
+ at EXPORT_OK = qw( PI e bpi bexp );
+ at EXPORT = qw( inf NaN );
+
+use strict;
+use overload;
+
+##############################################################################
+
+# These are all alike, and thus faked by AUTOLOAD
+
+my @faked = qw/round_mode accuracy precision div_scale/;
+use vars qw/$VERSION $AUTOLOAD $_lite/; # _lite for testsuite
+
+sub AUTOLOAD
+ {
+ my $name = $AUTOLOAD;
+
+ $name =~ s/.*:://; # split package
+ no strict 'refs';
+ foreach my $n (@faked)
+ {
+ if ($n eq $name)
+ {
+ *{"bigint::$name"} = sub
+ {
+ my $self = shift;
+ no strict 'refs';
+ if (defined $_[0])
+ {
+ return Math::BigInt->$name($_[0]);
+ }
+ return Math::BigInt->$name();
+ };
+ return &$name;
+ }
+ }
+
+ # delayed load of Carp and avoid recursion
+ require Carp;
+ Carp::croak ("Can't call bigint\-\>$name, not a valid method");
+ }
+
+sub upgrade
+ {
+ $Math::BigInt::upgrade;
+ }
+
+sub _binary_constant
+ {
+ # this takes a binary/hexadecimal/octal constant string and returns it
+ # as string suitable for new. Basically it converts octal to decimal, and
+ # passes every thing else unmodified back.
+ my $string = shift;
+
+ return Math::BigInt->new($string) if $string =~ /^0[bx]/;
+
+ # so it must be an octal constant
+ Math::BigInt->from_oct($string);
+ }
+
+sub _float_constant
+ {
+ # this takes a floating point constant string and returns it truncated to
+ # integer. For instance, '4.5' => '4', '1.234e2' => '123' etc
+ my $float = shift;
+
+ # some simple cases first
+ return $float if ($float =~ /^[+-]?[0-9]+$/); # '+123','-1','0' etc
+ return $float
+ if ($float =~ /^[+-]?[0-9]+\.?[eE]\+?[0-9]+$/); # 123e2, 123.e+2
+ return '0' if ($float =~ /^[+-]?[0]*\.[0-9]+$/); # .2, 0.2, -.1
+ if ($float =~ /^[+-]?[0-9]+\.[0-9]*$/) # 1., 1.23, -1.2 etc
+ {
+ $float =~ s/\..*//;
+ return $float;
+ }
+ my ($mis,$miv,$mfv,$es,$ev) = Math::BigInt::_split($float);
+ return $float if !defined $mis; # doesn't look like a number to me
+ my $ec = int($$ev);
+ my $sign = $$mis; $sign = '' if $sign eq '+';
+ if ($$es eq '-')
+ {
+ # ignore fraction part entirely
+ if ($ec >= length($$miv)) # 123.23E-4
+ {
+ return '0';
+ }
+ return $sign . substr ($$miv,0,length($$miv)-$ec); # 1234.45E-2 = 12
+ }
+ # xE+y
+ if ($ec >= length($$mfv))
+ {
+ $ec -= length($$mfv);
+ return $sign.$$miv.$$mfv if $ec == 0; # 123.45E+2 => 12345
+ return $sign.$$miv.$$mfv.'E'.$ec; # 123.45e+3 => 12345e1
+ }
+ $mfv = substr($$mfv,0,$ec);
+ $sign.$$miv.$mfv; # 123.45e+1 => 1234
+ }
+
+sub unimport
+ {
+ $^H{bigint} = undef; # no longer in effect
+ overload::remove_constant('binary','','float','','integer');
+ }
+
+sub in_effect
+ {
+ my $level = shift || 0;
+ my $hinthash = (caller($level))[10];
+ $hinthash->{bigint};
+ }
+
+#############################################################################
+# the following two routines are for "use bigint qw/hex oct/;":
+
+sub _hex_global
+ {
+ my $i = $_[0];
+ $i = '0x'.$i unless $i =~ /^0x/;
+ Math::BigInt->new($i);
+ }
+
+sub _oct_global
+ {
+ my $i = $_[0];
+ return Math::BigInt->from_oct($i) if $i =~ /^0[0-7]/;
+ Math::BigInt->new($i);
+ }
+
+#############################################################################
+# the following two routines are for Perl 5.9.4 or later and are lexical
+
+sub _hex
+ {
+ return CORE::hex($_[0]) unless in_effect(1);
+ my $i = $_[0];
+ $i = '0x'.$i unless $i =~ /^0x/;
+ Math::BigInt->new($i);
+ }
+
+sub _oct
+ {
+ return CORE::oct($_[0]) unless in_effect(1);
+ my $i = $_[0];
+ return Math::BigInt->from_oct($i) if $i =~ /^0[0-7]/;
+ Math::BigInt->new($i);
+ }
+
+sub import
+ {
+ my $self = shift;
+
+ $^H{bigint} = 1; # we are in effect
+
+ my ($hex,$oct);
+ # for newer Perls always override hex() and oct() with a lexical version:
+ if ($] > 5.009004)
+ {
+ $oct = \&_oct;
+ $hex = \&_hex;
+ }
+ # some defaults
+ my $lib = ''; my $lib_kind = 'try';
+
+ my @import = ( ':constant' ); # drive it w/ constant
+ my @a = @_; my $l = scalar @_; my $j = 0;
+ my ($ver,$trace); # version? trace?
+ my ($a,$p); # accuracy, precision
+ for ( my $i = 0; $i < $l ; $i++,$j++ )
+ {
+ if ($_[$i] =~ /^(l|lib|try|only)$/)
+ {
+ # this causes a different low lib to take care...
+ $lib_kind = $1; $lib_kind = 'lib' if $lib_kind eq 'l';
+ $lib = $_[$i+1] || '';
+ my $s = 2; $s = 1 if @a-$j < 2; # avoid "can not modify non-existant..."
+ splice @a, $j, $s; $j -= $s; $i++;
+ }
+ elsif ($_[$i] =~ /^(a|accuracy)$/)
+ {
+ $a = $_[$i+1];
+ my $s = 2; $s = 1 if @a-$j < 2; # avoid "can not modify non-existant..."
+ splice @a, $j, $s; $j -= $s; $i++;
+ }
+ elsif ($_[$i] =~ /^(p|precision)$/)
+ {
+ $p = $_[$i+1];
+ my $s = 2; $s = 1 if @a-$j < 2; # avoid "can not modify non-existant..."
+ splice @a, $j, $s; $j -= $s; $i++;
+ }
+ elsif ($_[$i] =~ /^(v|version)$/)
+ {
+ $ver = 1;
+ splice @a, $j, 1; $j --;
+ }
+ elsif ($_[$i] =~ /^(t|trace)$/)
+ {
+ $trace = 1;
+ splice @a, $j, 1; $j --;
+ }
+ elsif ($_[$i] eq 'hex')
+ {
+ splice @a, $j, 1; $j --;
+ $hex = \&_hex_global;
+ }
+ elsif ($_[$i] eq 'oct')
+ {
+ splice @a, $j, 1; $j --;
+ $oct = \&_oct_global;
+ }
+ elsif ($_[$i] !~ /^(PI|e|bpi|bexp)\z/)
+ {
+ die ("unknown option $_[$i]");
+ }
+ }
+ my $class;
+ $_lite = 0; # using M::BI::L ?
+ if ($trace)
+ {
+ require Math::BigInt::Trace; $class = 'Math::BigInt::Trace';
+ }
+ else
+ {
+ # 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 '')
+ {
+ @import = ( ); # :constant in Lite, not MBI
+ Math::BigInt::Lite->import( ':constant' );
+ $_lite= 1; # signal okay
+ }
+ }
+ require Math::BigInt if $_lite == 0; # not already loaded?
+ $class = 'Math::BigInt'; # regardless of MBIL or not
+ }
+ push @import, $lib_kind => $lib if $lib ne '';
+ # Math::BigInt::Trace or plain Math::BigInt
+ $class->import(@import);
+
+ bigint->accuracy($a) if defined $a;
+ bigint->precision($p) if defined $p;
+ if ($ver)
+ {
+ print "bigint\t\t\t v$VERSION\n";
+ print "Math::BigInt::Lite\t v$Math::BigInt::Lite::VERSION\n" if $_lite;
+ print "Math::BigInt\t\t v$Math::BigInt::VERSION";
+ my $config = Math::BigInt->config();
+ print " lib => $config->{lib} v$config->{lib_version}\n";
+ exit;
+ }
+ # we take care of floating point constants, since BigFloat isn't available
+ # and BigInt doesn't like them:
+ overload::constant float => sub { Math::BigInt->new( _float_constant(shift) ); };
+ # Take care of octal/hexadecimal constants
+ overload::constant binary => sub { _binary_constant(shift) };
+
+ # if another big* was already loaded:
+ my ($package) = caller();
+
+ no strict 'refs';
+ if (!defined *{"${package}::inf"})
+ {
+ $self->export_to_level(1,$self, at a); # export inf and NaN, e and PI
+ }
+ {
+ no warnings 'redefine';
+ *CORE::GLOBAL::oct = $oct if $oct;
+ *CORE::GLOBAL::hex = $hex if $hex;
+ }
+ }
+
+sub inf () { Math::BigInt::binf(); }
+sub NaN () { Math::BigInt::bnan(); }
+
+sub PI () { Math::BigInt->new(3); }
+sub e () { Math::BigInt->new(2); }
+sub bpi ($) { Math::BigInt->new(3); }
+sub bexp ($$) { my $x = Math::BigInt->new($_[0]); $x->bexp($_[1]); }
+
+1;
+
+__END__
+
+=head1 NAME
+
+bigint - Transparent BigInteger support for Perl
+
+=head1 SYNOPSIS
+
+ use bigint;
+
+ $x = 2 + 4.5,"\n"; # BigInt 6
+ print 2 ** 512,"\n"; # really is what you think it is
+ print inf + 42,"\n"; # inf
+ print NaN * 7,"\n"; # NaN
+ print hex("0x1234567890123490"),"\n"; # Perl v5.9.4 or later
+
+ {
+ no bigint;
+ print 2 ** 256,"\n"; # a normal Perl scalar now
+ }
+
+ # Note that this will be global:
+ use bigint qw/hex oct/;
+ print hex("0x1234567890123490"),"\n";
+ print oct("01234567890123490"),"\n";
+
+=head1 DESCRIPTION
+
+All operators (including basic math operations) are overloaded. Integer
+constants are created as proper BigInts.
+
+Floating point constants are truncated to integer. All parts and results of
+expressions are also truncated.
+
+Unlike L<integer>, this pragma creates integer constants that are only
+limited in their size by the available memory and CPU time.
+
+=head2 use integer vs. use bigint
+
+There is one small difference between C<use integer> and C<use bigint>: the
+former will not affect assignments to variables and the return value of
+some functions. C<bigint> truncates these results to integer too:
+
+ # perl -Minteger -wle 'print 3.2'
+ 3.2
+ # perl -Minteger -wle 'print 3.2 + 0'
+ 3
+ # perl -Mbigint -wle 'print 3.2'
+ 3
+ # perl -Mbigint -wle 'print 3.2 + 0'
+ 3
+
+ # perl -Mbigint -wle 'print exp(1) + 0'
+ 2
+ # perl -Mbigint -wle 'print exp(1)'
+ 2
+ # perl -Minteger -wle 'print exp(1)'
+ 2.71828182845905
+ # perl -Minteger -wle 'print exp(1) + 0'
+ 2
+
+In practice this makes seldom a difference as B<parts and results> of
+expressions will be truncated anyway, but this can, for instance, affect the
+return value of subroutines:
+
+ sub three_integer { use integer; return 3.2; }
+ sub three_bigint { use bigint; return 3.2; }
+
+ print three_integer(), " ", three_bigint(),"\n"; # prints "3.2 3"
+
+=head2 Options
+
+bigint recognizes some options that can be passed while loading it via use.
+The options can (currently) be either a single letter form, or the long form.
+The following options exist:
+
+=over 2
+
+=item a or accuracy
+
+This sets the accuracy for all math operations. The argument must be greater
+than or equal to zero. See Math::BigInt's bround() function for details.
+
+ perl -Mbigint=a,2 -le 'print 12345+1'
+
+Note that setting precision and accurary at the same time is not possible.
+
+=item p or precision
+
+This sets the precision for all math operations. The argument can be any
+integer. Negative values mean a fixed number of digits after the dot, and
+are <B>ignored</B> since all operations happen in integer space.
+A positive value rounds to this digit left from the dot. 0 or 1 mean round to
+integer and are ignore like negative values.
+
+See Math::BigInt's bfround() function for details.
+
+ perl -Mbignum=p,5 -le 'print 123456789+123'
+
+Note that setting precision and accurary at the same time is not possible.
+
+=item t or trace
+
+This enables a trace mode and is primarily for debugging bigint or
+Math::BigInt.
+
+=item hex
+
+Override the built-in hex() method with a version that can handle big
+integers. Note that under Perl v5.9.4 or ealier, this will be global
+and cannot be disabled with "no bigint;".
+
+=item oct
+
+Override the built-in oct() method with a version that can handle big
+integers. Note that under Perl v5.9.4 or ealier, this will be global
+and cannot be disabled with "no bigint;".
+
+=item l, lib, try or only
+
+Load a different math lib, see L<Math Library>.
+
+ perl -Mbigint=lib,GMP -e 'print 2 ** 512'
+ perl -Mbigint=try,GMP -e 'print 2 ** 512'
+ perl -Mbigint=only,GMP -e 'print 2 ** 512'
+
+Currently there is no way to specify more than one library on the command
+line. This means the following does not work:
+
+ perl -Mbignum=l,GMP,Pari -e 'print 2 ** 512'
+
+This will be hopefully fixed soon ;)
+
+=item v or version
+
+This prints out the name and version of all modules used and then exits.
+
+ perl -Mbigint=v
+
+=back
+
+=head2 Math Library
+
+Math with the numbers is done (by default) by a module called
+Math::BigInt::Calc. This is equivalent to saying:
+
+ use bigint lib => 'Calc';
+
+You can change this by using:
+
+ use bignum lib => 'GMP';
+
+The following would first try to find Math::BigInt::Foo, then
+Math::BigInt::Bar, and when this also fails, revert to Math::BigInt::Calc:
+
+ use bigint lib => 'Foo,Math::BigInt::Bar';
+
+Using C<lib> warns if none of the specified libraries can be found and
+L<Math::BigInt> did fall back to one of the default libraries.
+To supress this warning, use C<try> instead:
+
+ use bignum try => 'GMP';
+
+If you want the code to die instead of falling back, use C<only> instead:
+
+ use bignum only => 'GMP';
+
+Please see respective module documentation for further details.
+
+=head2 Internal Format
+
+The numbers are stored as objects, and their internals might change at anytime,
+especially between math operations. The objects also might belong to different
+classes, like Math::BigInt, or Math::BigInt::Lite. Mixing them together, even
+with normal scalars is not extraordinary, but normal and expected.
+
+You should not depend on the internal format, all accesses must go through
+accessor methods. E.g. looking at $x->{sign} is not a good idea since there
+is no guaranty that the object in question has such a hash key, nor is a hash
+underneath at all.
+
+=head2 Sign
+
+The sign is either '+', '-', 'NaN', '+inf' or '-inf'.
+You can access it with the sign() method.
+
+A sign of 'NaN' is used to represent the result when input arguments are not
+numbers or as a result of 0/0. '+inf' and '-inf' represent plus respectively
+minus infinity. You will get '+inf' when dividing a positive number by 0, and
+'-inf' when dividing any negative number by 0.
+
+=head2 Methods
+
+Since all numbers are now objects, you can use all functions that are part of
+the BigInt API. You can only use the bxxx() notation, and not the fxxx()
+notation, though.
+
+=over 2
+
+=item inf()
+
+A shortcut to return Math::BigInt->binf(). Useful because Perl does not always
+handle bareword C<inf> properly.
+
+=item NaN()
+
+A shortcut to return Math::BigInt->bnan(). Useful because Perl does not always
+handle bareword C<NaN> properly.
+
+=item e
+
+ # perl -Mbigint=e -wle 'print e'
+
+Returns Euler's number C<e>, aka exp(1). Note that under bigint, this is
+truncated to an integer, and hence simple '2'.
+
+=item PI
+
+ # perl -Mbigint=PI -wle 'print PI'
+
+Returns PI. Note that under bigint, this is truncated to an integer, and hence
+simple '3'.
+
+=item bexp()
+
+ bexp($power,$accuracy);
+
+Returns Euler's number C<e> raised to the appropriate power, to
+the wanted accuracy.
+
+Note that under bigint, the result is truncated to an integer.
+
+Example:
+
+ # perl -Mbigint=bexp -wle 'print bexp(1,80)'
+
+=item bpi()
+
+ bpi($accuracy);
+
+Returns PI to the wanted accuracy. Note that under bigint, this is truncated
+to an integer, and hence simple '3'.
+
+Example:
+
+ # perl -Mbigint=bpi -wle 'print bpi(80)'
+
+=item upgrade()
+
+Return the class that numbers are upgraded to, is in fact returning
+C<$Math::BigInt::upgrade>.
+
+=item in_effect()
+
+ use bigint;
+
+ print "in effect\n" if bigint::in_effect; # true
+ {
+ no bigint;
+ print "in effect\n" if bigint::in_effect; # false
+ }
+
+Returns true or false if C<bigint> is in effect in the current scope.
+
+This method only works on Perl v5.9.4 or later.
+
+=back
+
+=head2 MATH LIBRARY
+
+Math with the numbers is done (by default) by a module called
+
+=head2 Caveat
+
+But a warning is in order. When using the following to make a copy of a number,
+only a shallow copy will be made.
+
+ $x = 9; $y = $x;
+ $x = $y = 7;
+
+Using the copy or the original with overloaded math is okay, e.g. the
+following work:
+
+ $x = 9; $y = $x;
+ print $x + 1, " ", $y,"\n"; # prints 10 9
+
+but calling any method that modifies the number directly will result in
+B<both> the original and the copy being destroyed:
+
+ $x = 9; $y = $x;
+ print $x->badd(1), " ", $y,"\n"; # prints 10 10
+
+ $x = 9; $y = $x;
+ print $x->binc(1), " ", $y,"\n"; # prints 10 10
+
+ $x = 9; $y = $x;
+ print $x->bmul(2), " ", $y,"\n"; # prints 18 18
+
+Using methods that do not modify, but testthe contents works:
+
+ $x = 9; $y = $x;
+ $z = 9 if $x->is_zero(); # works fine
+
+See the documentation about the copy constructor and C<=> in overload, as
+well as the documentation in BigInt for further details.
+
+=head1 CAVAETS
+
+=over 2
+
+=item in_effect()
+
+This method only works on Perl v5.9.4 or later.
+
+=item hex()/oct()
+
+C<bigint> overrides these routines with versions that can also handle
+big integer values. Under Perl prior to version v5.9.4, however, this
+will not happen unless you specifically ask for it with the two
+import tags "hex" and "oct" - and then it will be global and cannot be
+disabled inside a scope with "no bigint":
+
+ use bigint qw/hex oct/;
+
+ print hex("0x1234567890123456");
+ {
+ no bigint;
+ print hex("0x1234567890123456");
+ }
+
+The second call to hex() will warn about a non-portable constant.
+
+Compare this to:
+
+ use bigint;
+
+ # will warn only under Perl older than v5.9.4
+ print hex("0x1234567890123456");
+
+=back
+
+=head1 MODULES USED
+
+C<bigint> is just a thin wrapper around various modules of the Math::BigInt
+family. Think of it as the head of the family, who runs the shop, and orders
+the others to do the work.
+
+The following modules are currently used by bigint:
+
+ Math::BigInt::Lite (for speed, and only if it is loadable)
+ Math::BigInt
+
+=head1 EXAMPLES
+
+Some cool command line examples to impress the Python crowd ;) You might want
+to compare them to the results under -Mbignum or -Mbigrat:
+
+ perl -Mbigint -le 'print sqrt(33)'
+ perl -Mbigint -le 'print 2*255'
+ perl -Mbigint -le 'print 4.5+2*255'
+ perl -Mbigint -le 'print 3/7 + 5/7 + 8/3'
+ perl -Mbigint -le 'print 123->is_odd()'
+ perl -Mbigint -le 'print log(2)'
+ perl -Mbigint -le 'print 2 ** 0.5'
+ perl -Mbigint=a,65 -le 'print 2 ** 0.2'
+ perl -Mbignum=a,65,l,GMP -le 'print 7 ** 7777'
+
+=head1 LICENSE
+
+This program is free software; you may redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+Especially L<bigrat> as in C<perl -Mbigrat -le 'print 1/3+1/4'> and
+L<bignum> as in C<perl -Mbignum -le 'print sqrt(2)'>.
+
+L<Math::BigInt>, L<Math::BigRat> and L<Math::Big> as well
+as L<Math::BigInt::BitVect>, L<Math::BigInt::Pari> and L<Math::BigInt::GMP>.
+
+=head1 AUTHORS
+
+(C) by Tels L<http://bloodgate.com/> in early 2002 - 2007.
+
+=cut
Index: trunk/contrib/perl/lib/bigintpl.t
===================================================================
--- trunk/contrib/perl/lib/bigintpl.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/bigintpl.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/bigintpl.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/lib/bignum.pm (from rev 6437, vendor/perl/5.18.1/lib/bignum.pm)
===================================================================
--- trunk/contrib/perl/lib/bignum.pm (rev 0)
+++ trunk/contrib/perl/lib/bignum.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,681 @@
+package bignum;
+use 5.006;
+
+$VERSION = '0.23';
+use Exporter;
+ at ISA = qw( bigint );
+ at EXPORT_OK = qw( PI e bexp bpi );
+ at EXPORT = qw( inf NaN );
+
+use strict;
+use overload;
+require bigint; # no "use" to avoid import being called
+
+##############################################################################
+
+BEGIN
+ {
+ *inf = \&bigint::inf;
+ *NaN = \&bigint::NaN;
+ }
+
+# These are all alike, and thus faked by AUTOLOAD
+
+my @faked = qw/round_mode accuracy precision div_scale/;
+use vars qw/$VERSION $AUTOLOAD $_lite/; # _lite for testsuite
+
+sub AUTOLOAD
+ {
+ my $name = $AUTOLOAD;
+
+ $name =~ s/.*:://; # split package
+ no strict 'refs';
+ foreach my $n (@faked)
+ {
+ if ($n eq $name)
+ {
+ *{"bignum::$name"} = sub
+ {
+ my $self = shift;
+ no strict 'refs';
+ if (defined $_[0])
+ {
+ Math::BigInt->$name($_[0]);
+ return Math::BigFloat->$name($_[0]);
+ }
+ return Math::BigInt->$name();
+ };
+ return &$name;
+ }
+ }
+
+ # delayed load of Carp and avoid recursion
+ require Carp;
+ Carp::croak ("Can't call bignum\-\>$name, not a valid method");
+ }
+
+sub unimport
+ {
+ $^H{bignum} = undef; # no longer in effect
+ overload::remove_constant('binary','','float','','integer');
+ }
+
+sub in_effect
+ {
+ my $level = shift || 0;
+ my $hinthash = (caller($level))[10];
+ $hinthash->{bignum};
+ }
+
+#############################################################################
+# the following two routines are for Perl 5.9.4 or later and are lexical
+
+sub _hex
+ {
+ return CORE::hex($_[0]) unless in_effect(1);
+ my $i = $_[0];
+ $i = '0x'.$i unless $i =~ /^0x/;
+ Math::BigInt->new($i);
+ }
+
+sub _oct
+ {
+ return CORE::oct($_[0]) unless in_effect(1);
+ my $i = $_[0];
+ return Math::BigInt->from_oct($i) if $i =~ /^0[0-7]/;
+ Math::BigInt->new($i);
+ }
+
+sub import
+ {
+ my $self = shift;
+
+ $^H{bignum} = 1; # we are in effect
+
+ my ($hex,$oct);
+
+ # for newer Perls override hex() and oct() with a lexical version:
+ if ($] > 5.009003)
+ {
+ $hex = \&_hex;
+ $oct = \&_oct;
+ }
+
+ # some defaults
+ my $lib = ''; my $lib_kind = 'try';
+ my $upgrade = 'Math::BigFloat';
+ my $downgrade = 'Math::BigInt';
+
+ my @import = ( ':constant' ); # drive it w/ constant
+ my @a = @_; my $l = scalar @_; my $j = 0;
+ my ($ver,$trace); # version? trace?
+ my ($a,$p); # accuracy, precision
+ for ( my $i = 0; $i < $l ; $i++,$j++ )
+ {
+ if ($_[$i] eq 'upgrade')
+ {
+ # this causes upgrading
+ $upgrade = $_[$i+1]; # or undef to disable
+ my $s = 2; $s = 1 if @a-$j < 2; # avoid "can not modify non-existant..."
+ splice @a, $j, $s; $j -= $s; $i++;
+ }
+ elsif ($_[$i] eq 'downgrade')
+ {
+ # this causes downgrading
+ $downgrade = $_[$i+1]; # or undef to disable
+ my $s = 2; $s = 1 if @a-$j < 2; # avoid "can not modify non-existant..."
+ splice @a, $j, $s; $j -= $s; $i++;
+ }
+ elsif ($_[$i] =~ /^(l|lib|try|only)$/)
+ {
+ # this causes a different low lib to take care...
+ $lib_kind = $1; $lib_kind = 'lib' if $lib_kind eq 'l';
+ $lib = $_[$i+1] || '';
+ my $s = 2; $s = 1 if @a-$j < 2; # avoid "can not modify non-existant..."
+ splice @a, $j, $s; $j -= $s; $i++;
+ }
+ elsif ($_[$i] =~ /^(a|accuracy)$/)
+ {
+ $a = $_[$i+1];
+ my $s = 2; $s = 1 if @a-$j < 2; # avoid "can not modify non-existant..."
+ splice @a, $j, $s; $j -= $s; $i++;
+ }
+ elsif ($_[$i] =~ /^(p|precision)$/)
+ {
+ $p = $_[$i+1];
+ my $s = 2; $s = 1 if @a-$j < 2; # avoid "can not modify non-existant..."
+ splice @a, $j, $s; $j -= $s; $i++;
+ }
+ elsif ($_[$i] =~ /^(v|version)$/)
+ {
+ $ver = 1;
+ splice @a, $j, 1; $j --;
+ }
+ elsif ($_[$i] =~ /^(t|trace)$/)
+ {
+ $trace = 1;
+ splice @a, $j, 1; $j --;
+ }
+ elsif ($_[$i] eq 'hex')
+ {
+ splice @a, $j, 1; $j --;
+ $hex = \&bigint::_hex_global;
+ }
+ elsif ($_[$i] eq 'oct')
+ {
+ splice @a, $j, 1; $j --;
+ $oct = \&bigint::_oct_global;
+ }
+ elsif ($_[$i] !~ /^(PI|e|bexp|bpi)\z/)
+ {
+ die ("unknown option $_[$i]");
+ }
+ }
+ my $class;
+ $_lite = 0; # using M::BI::L ?
+ if ($trace)
+ {
+ require Math::BigInt::Trace; $class = 'Math::BigInt::Trace';
+ $upgrade = 'Math::BigFloat::Trace';
+ }
+ else
+ {
+ # 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 '')
+ {
+ @import = ( ); # :constant in Lite, not MBI
+ Math::BigInt::Lite->import( ':constant' );
+ $_lite= 1; # signal okay
+ }
+ }
+ require Math::BigInt if $_lite == 0; # not already loaded?
+ $class = 'Math::BigInt'; # regardless of MBIL or not
+ }
+ push @import, $lib_kind => $lib if $lib ne '';
+ # Math::BigInt::Trace or plain Math::BigInt
+ $class->import(@import, upgrade => $upgrade);
+
+ if ($trace)
+ {
+ require Math::BigFloat::Trace; $class = 'Math::BigFloat::Trace';
+ $downgrade = 'Math::BigInt::Trace';
+ }
+ else
+ {
+ require Math::BigFloat; $class = 'Math::BigFloat';
+ }
+ $class->import(':constant','downgrade',$downgrade);
+
+ bignum->accuracy($a) if defined $a;
+ bignum->precision($p) if defined $p;
+ if ($ver)
+ {
+ print "bignum\t\t\t v$VERSION\n";
+ print "Math::BigInt::Lite\t v$Math::BigInt::Lite::VERSION\n" if $_lite;
+ print "Math::BigInt\t\t v$Math::BigInt::VERSION";
+ my $config = Math::BigInt->config();
+ print " lib => $config->{lib} v$config->{lib_version}\n";
+ print "Math::BigFloat\t\t v$Math::BigFloat::VERSION\n";
+ exit;
+ }
+
+ # Take care of octal/hexadecimal constants
+ overload::constant binary => sub { bigint::_binary_constant(shift) };
+
+ # if another big* was already loaded:
+ my ($package) = caller();
+
+ no strict 'refs';
+ if (!defined *{"${package}::inf"})
+ {
+ $self->export_to_level(1,$self, at a); # export inf and NaN
+ }
+ {
+ no warnings 'redefine';
+ *CORE::GLOBAL::oct = $oct if $oct;
+ *CORE::GLOBAL::hex = $hex if $hex;
+ }
+ }
+
+sub PI () { Math::BigFloat->new('3.141592653589793238462643383279502884197'); }
+sub e () { Math::BigFloat->new('2.718281828459045235360287471352662497757'); }
+sub bpi ($) { Math::BigFloat::bpi(@_); }
+sub bexp ($$) { my $x = Math::BigFloat->new($_[0]); $x->bexp($_[1]); }
+
+1;
+
+__END__
+
+=head1 NAME
+
+bignum - Transparent BigNumber support for Perl
+
+=head1 SYNOPSIS
+
+ use bignum;
+
+ $x = 2 + 4.5,"\n"; # BigFloat 6.5
+ print 2 ** 512 * 0.1,"\n"; # really is what you think it is
+ print inf * inf,"\n"; # prints inf
+ print NaN * 3,"\n"; # prints NaN
+
+ {
+ no bignum;
+ print 2 ** 256,"\n"; # a normal Perl scalar now
+ }
+
+ # for older Perls, note that this will be global:
+ use bignum qw/hex oct/;
+ print hex("0x1234567890123490"),"\n";
+ print oct("01234567890123490"),"\n";
+
+=head1 DESCRIPTION
+
+All operators (including basic math operations) are overloaded. Integer and
+floating-point constants are created as proper BigInts or BigFloats,
+respectively.
+
+If you do
+
+ use bignum;
+
+at the top of your script, Math::BigFloat and Math::BigInt will be loaded
+and any constant number will be converted to an object (Math::BigFloat for
+floats like 3.1415 and Math::BigInt for integers like 1234).
+
+So, the following line:
+
+ $x = 1234;
+
+creates actually a Math::BigInt and stores a reference to in $x.
+This happens transparently and behind your back, so to speak.
+
+You can see this with the following:
+
+ perl -Mbignum -le 'print ref(1234)'
+
+Don't worry if it says Math::BigInt::Lite, bignum and friends will use Lite
+if it is installed since it is faster for some operations. It will be
+automatically upgraded to BigInt whenever necessary:
+
+ perl -Mbignum -le 'print ref(2**255)'
+
+This also means it is a bad idea to check for some specific package, since
+the actual contents of $x might be something unexpected. Due to the
+transparent way of bignum C<ref()> should not be necessary, anyway.
+
+Since Math::BigInt and BigFloat also overload the normal math operations,
+the following line will still work:
+
+ perl -Mbignum -le 'print ref(1234+1234)'
+
+Since numbers are actually objects, you can call all the usual methods from
+BigInt/BigFloat on them. This even works to some extent on expressions:
+
+ perl -Mbignum -le '$x = 1234; print $x->bdec()'
+ perl -Mbignum -le 'print 1234->copy()->binc();'
+ perl -Mbignum -le 'print 1234->copy()->binc->badd(6);'
+ perl -Mbignum -le 'print +(1234)->copy()->binc()'
+
+(Note that print doesn't do what you expect if the expression starts with
+'(' hence the C<+>)
+
+You can even chain the operations together as usual:
+
+ perl -Mbignum -le 'print 1234->copy()->binc->badd(6);'
+ 1241
+
+Under bignum (or bigint or bigrat), Perl will "upgrade" the numbers
+appropriately. This means that:
+
+ perl -Mbignum -le 'print 1234+4.5'
+ 1238.5
+
+will work correctly. These mixed cases don't do always work when using
+Math::BigInt or Math::BigFloat alone, or at least not in the way normal Perl
+scalars work.
+
+If you do want to work with large integers like under C<use integer;>, try
+C<use bigint;>:
+
+ perl -Mbigint -le 'print 1234.5+4.5'
+ 1238
+
+There is also C<use bigrat;> which gives you big rationals:
+
+ perl -Mbigrat -le 'print 1234+4.1'
+ 12381/10
+
+The entire upgrading/downgrading is still experimental and might not work
+as you expect or may even have bugs. You might get errors like this:
+
+ Can't use an undefined value as an ARRAY reference at
+ /usr/local/lib/perl5/5.8.0/Math/BigInt/Calc.pm line 864
+
+This means somewhere a routine got a BigFloat/Lite but expected a BigInt (or
+vice versa) and the upgrade/downgrad path was missing. This is a bug, please
+report it so that we can fix it.
+
+You might consider using just Math::BigInt or Math::BigFloat, since they
+allow you finer control over what get's done in which module/space. For
+instance, simple loop counters will be Math::BigInts under C<use bignum;> and
+this is slower than keeping them as Perl scalars:
+
+ perl -Mbignum -le 'for ($i = 0; $i < 10; $i++) { print ref($i); }'
+
+Please note the following does not work as expected (prints nothing), since
+overloading of '..' is not yet possible in Perl (as of v5.8.0):
+
+ perl -Mbignum -le 'for (1..2) { print ref($_); }'
+
+=head2 Options
+
+bignum recognizes some options that can be passed while loading it via use.
+The options can (currently) be either a single letter form, or the long form.
+The following options exist:
+
+=over 2
+
+=item a or accuracy
+
+This sets the accuracy for all math operations. The argument must be greater
+than or equal to zero. See Math::BigInt's bround() function for details.
+
+ perl -Mbignum=a,50 -le 'print sqrt(20)'
+
+Note that setting precision and accurary at the same time is not possible.
+
+=item p or precision
+
+This sets the precision for all math operations. The argument can be any
+integer. Negative values mean a fixed number of digits after the dot, while
+a positive value rounds to this digit left from the dot. 0 or 1 mean round to
+integer. See Math::BigInt's bfround() function for details.
+
+ perl -Mbignum=p,-50 -le 'print sqrt(20)'
+
+Note that setting precision and accurary at the same time is not possible.
+
+=item t or trace
+
+This enables a trace mode and is primarily for debugging bignum or
+Math::BigInt/Math::BigFloat.
+
+=item l or lib
+
+Load a different math lib, see L<MATH LIBRARY>.
+
+ perl -Mbignum=l,GMP -e 'print 2 ** 512'
+
+Currently there is no way to specify more than one library on the command
+line. This means the following does not work:
+
+ perl -Mbignum=l,GMP,Pari -e 'print 2 ** 512'
+
+This will be hopefully fixed soon ;)
+
+=item hex
+
+Override the built-in hex() method with a version that can handle big
+integers. Note that under Perl older than v5.9.4, this will be global
+and cannot be disabled with "no bigint;".
+
+=item oct
+
+Override the built-in oct() method with a version that can handle big
+integers. Note that under Perl older than v5.9.4, this will be global
+and cannot be disabled with "no bigint;".
+
+=item v or version
+
+This prints out the name and version of all modules used and then exits.
+
+ perl -Mbignum=v
+
+=back
+
+=head2 Methods
+
+Beside import() and AUTOLOAD() there are only a few other methods.
+
+Since all numbers are now objects, you can use all functions that are part of
+the BigInt or BigFloat API. It is wise to use only the bxxx() notation, and not
+the fxxx() notation, though. This makes it possible that the underlying object
+might morph into a different class than BigFloat.
+
+=head2 Caveats
+
+But a warning is in order. When using the following to make a copy of a number,
+only a shallow copy will be made.
+
+ $x = 9; $y = $x;
+ $x = $y = 7;
+
+If you want to make a real copy, use the following:
+
+ $y = $x->copy();
+
+Using the copy or the original with overloaded math is okay, e.g. the
+following work:
+
+ $x = 9; $y = $x;
+ print $x + 1, " ", $y,"\n"; # prints 10 9
+
+but calling any method that modifies the number directly will result in
+B<both> the original and the copy being destroyed:
+
+ $x = 9; $y = $x;
+ print $x->badd(1), " ", $y,"\n"; # prints 10 10
+
+ $x = 9; $y = $x;
+ print $x->binc(1), " ", $y,"\n"; # prints 10 10
+
+ $x = 9; $y = $x;
+ print $x->bmul(2), " ", $y,"\n"; # prints 18 18
+
+Using methods that do not modify, but test the contents works:
+
+ $x = 9; $y = $x;
+ $z = 9 if $x->is_zero(); # works fine
+
+See the documentation about the copy constructor and C<=> in overload, as
+well as the documentation in BigInt for further details.
+
+=over 2
+
+=item inf()
+
+A shortcut to return Math::BigInt->binf(). Useful because Perl does not always
+handle bareword C<inf> properly.
+
+=item NaN()
+
+A shortcut to return Math::BigInt->bnan(). Useful because Perl does not always
+handle bareword C<NaN> properly.
+
+=item e
+
+ # perl -Mbignum=e -wle 'print e'
+
+Returns Euler's number C<e>, aka exp(1).
+
+=item PI()
+
+ # perl -Mbignum=PI -wle 'print PI'
+
+Returns PI.
+
+=item bexp()
+
+ bexp($power,$accuracy);
+
+Returns Euler's number C<e> raised to the appropriate power, to
+the wanted accuracy.
+
+Example:
+
+ # perl -Mbignum=bexp -wle 'print bexp(1,80)'
+
+=item bpi()
+
+ bpi($accuracy);
+
+Returns PI to the wanted accuracy.
+
+Example:
+
+ # perl -Mbignum=bpi -wle 'print bpi(80)'
+
+=item upgrade()
+
+Return the class that numbers are upgraded to, is in fact returning
+C<$Math::BigInt::upgrade>.
+
+=item in_effect()
+
+ use bignum;
+
+ print "in effect\n" if bignum::in_effect; # true
+ {
+ no bignum;
+ print "in effect\n" if bignum::in_effect; # false
+ }
+
+Returns true or false if C<bignum> is in effect in the current scope.
+
+This method only works on Perl v5.9.4 or later.
+
+=back
+
+=head2 Math Library
+
+Math with the numbers is done (by default) by a module called
+Math::BigInt::Calc. This is equivalent to saying:
+
+ use bignum lib => 'Calc';
+
+You can change this by using:
+
+ use bignum lib => 'GMP';
+
+The following would first try to find Math::BigInt::Foo, then
+Math::BigInt::Bar, and when this also fails, revert to Math::BigInt::Calc:
+
+ use bignum lib => 'Foo,Math::BigInt::Bar';
+
+Please see respective module documentation for further details.
+
+Using C<lib> warns if none of the specified libraries can be found and
+L<Math::BigInt> did fall back to one of the default libraries.
+To supress this warning, use C<try> instead:
+
+ use bignum try => 'GMP';
+
+If you want the code to die instead of falling back, use C<only> instead:
+
+ use bignum only => 'GMP';
+
+=head2 INTERNAL FORMAT
+
+The numbers are stored as objects, and their internals might change at anytime,
+especially between math operations. The objects also might belong to different
+classes, like Math::BigInt, or Math::BigFLoat. Mixing them together, even
+with normal scalars is not extraordinary, but normal and expected.
+
+You should not depend on the internal format, all accesses must go through
+accessor methods. E.g. looking at $x->{sign} is not a bright idea since there
+is no guaranty that the object in question has such a hashkey, nor is a hash
+underneath at all.
+
+=head2 SIGN
+
+The sign is either '+', '-', 'NaN', '+inf' or '-inf' and stored seperately.
+You can access it with the sign() method.
+
+A sign of 'NaN' is used to represent the result when input arguments are not
+numbers or as a result of 0/0. '+inf' and '-inf' represent plus respectively
+minus infinity. You will get '+inf' when dividing a positive number by 0, and
+'-inf' when dividing any negative number by 0.
+
+=head1 CAVAETS
+
+=over 2
+
+=item in_effect()
+
+This method only works on Perl v5.9.4 or later.
+
+=item hex()/oct()
+
+C<bigint> overrides these routines with versions that can also handle
+big integer values. Under Perl prior to version v5.9.4, however, this
+will not happen unless you specifically ask for it with the two
+import tags "hex" and "oct" - and then it will be global and cannot be
+disabled inside a scope with "no bigint":
+
+ use bigint qw/hex oct/;
+
+ print hex("0x1234567890123456");
+ {
+ no bigint;
+ print hex("0x1234567890123456");
+ }
+
+The second call to hex() will warn about a non-portable constant.
+
+Compare this to:
+
+ use bigint;
+
+ # will warn only under older than v5.9.4
+ print hex("0x1234567890123456");
+
+=back
+
+=head1 MODULES USED
+
+C<bignum> is just a thin wrapper around various modules of the Math::BigInt
+family. Think of it as the head of the family, who runs the shop, and orders
+the others to do the work.
+
+The following modules are currently used by bignum:
+
+ Math::BigInt::Lite (for speed, and only if it is loadable)
+ Math::BigInt
+ Math::BigFloat
+
+=head1 EXAMPLES
+
+Some cool command line examples to impress the Python crowd ;)
+
+ perl -Mbignum -le 'print sqrt(33)'
+ perl -Mbignum -le 'print 2*255'
+ perl -Mbignum -le 'print 4.5+2*255'
+ perl -Mbignum -le 'print 3/7 + 5/7 + 8/3'
+ perl -Mbignum -le 'print 123->is_odd()'
+ perl -Mbignum -le 'print log(2)'
+ perl -Mbignum -le 'print exp(1)'
+ perl -Mbignum -le 'print 2 ** 0.5'
+ perl -Mbignum=a,65 -le 'print 2 ** 0.2'
+ perl -Mbignum=a,65,l,GMP -le 'print 7 ** 7777'
+
+=head1 LICENSE
+
+This program is free software; you may redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+Especially L<bigrat> as in C<perl -Mbigrat -le 'print 1/3+1/4'>.
+
+L<Math::BigFloat>, L<Math::BigInt>, L<Math::BigRat> and L<Math::Big> as well
+as L<Math::BigInt::BitVect>, L<Math::BigInt::Pari> and L<Math::BigInt::GMP>.
+
+=head1 AUTHORS
+
+(C) by Tels L<http://bloodgate.com/> in early 2002 - 2007.
+
+=cut
Index: trunk/contrib/perl/lib/bigrat.pl
===================================================================
--- trunk/contrib/perl/lib/bigrat.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/bigrat.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/bigrat.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/lib/bigrat.pm (from rev 6437, vendor/perl/5.18.1/lib/bigrat.pm)
===================================================================
--- trunk/contrib/perl/lib/bigrat.pm (rev 0)
+++ trunk/contrib/perl/lib/bigrat.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,566 @@
+package bigrat;
+use 5.006;
+
+$VERSION = '0.23';
+require Exporter;
+ at ISA = qw( bigint );
+ at EXPORT_OK = qw( PI e bpi bexp );
+ at EXPORT = qw( inf NaN );
+
+use strict;
+use overload;
+require bigint; # no "use" to avoid callind import
+
+##############################################################################
+
+BEGIN
+ {
+ *inf = \&bigint::inf;
+ *NaN = \&bigint::NaN;
+ }
+
+# These are all alike, and thus faked by AUTOLOAD
+
+my @faked = qw/round_mode accuracy precision div_scale/;
+use vars qw/$VERSION $AUTOLOAD $_lite/; # _lite for testsuite
+
+sub AUTOLOAD
+ {
+ my $name = $AUTOLOAD;
+
+ $name =~ s/.*:://; # split package
+ no strict 'refs';
+ foreach my $n (@faked)
+ {
+ if ($n eq $name)
+ {
+ *{"bigrat::$name"} = sub
+ {
+ my $self = shift;
+ no strict 'refs';
+ if (defined $_[0])
+ {
+ Math::BigInt->$name($_[0]);
+ Math::BigFloat->$name($_[0]);
+ return Math::BigRat->$name($_[0]);
+ }
+ return Math::BigInt->$name();
+ };
+ return &$name;
+ }
+ }
+
+ # delayed load of Carp and avoid recursion
+ require Carp;
+ Carp::croak ("Can't call bigrat\-\>$name, not a valid method");
+ }
+
+sub unimport
+ {
+ $^H{bigrat} = undef; # no longer in effect
+ overload::remove_constant('binary','','float','','integer');
+ }
+
+sub in_effect
+ {
+ my $level = shift || 0;
+ my $hinthash = (caller($level))[10];
+ $hinthash->{bigrat};
+ }
+
+#############################################################################
+# the following two routines are for Perl 5.9.4 or later and are lexical
+
+sub _hex
+ {
+ return CORE::hex($_[0]) unless in_effect(1);
+ my $i = $_[0];
+ $i = '0x'.$i unless $i =~ /^0x/;
+ Math::BigInt->new($i);
+ }
+
+sub _oct
+ {
+ return CORE::oct($_[0]) unless in_effect(1);
+ my $i = $_[0];
+ return Math::BigInt->from_oct($i) if $i =~ /^0[0-7]/;
+ Math::BigInt->new($i);
+ }
+
+sub import
+ {
+ my $self = shift;
+
+ # see also bignum->import() for additional comments
+
+ $^H{bigrat} = 1; # we are in effect
+
+ my ($hex,$oct);
+ # for newer Perls always override hex() and oct() with a lexical version:
+ if ($] > 5.009004)
+ {
+ $oct = \&_oct;
+ $hex = \&_hex;
+ }
+ # some defaults
+ my $lib = ''; my $lib_kind = 'try'; my $upgrade = 'Math::BigFloat';
+
+ my @import = ( ':constant' ); # drive it w/ constant
+ my @a = @_; my $l = scalar @_; my $j = 0;
+ my ($a,$p);
+ my ($ver,$trace); # version? trace?
+ for ( my $i = 0; $i < $l ; $i++,$j++ )
+ {
+ if ($_[$i] eq 'upgrade')
+ {
+ # this causes upgrading
+ $upgrade = $_[$i+1]; # or undef to disable
+ my $s = 2; $s = 1 if @a-$j < 2; # avoid "can not modify non-existant..."
+ splice @a, $j, $s; $j -= $s;
+ }
+ elsif ($_[$i] =~ /^(l|lib|try|only)$/)
+ {
+ # this causes a different low lib to take care...
+ $lib_kind = $1; $lib_kind = 'lib' if $lib_kind eq 'l';
+ $lib = $_[$i+1] || '';
+ my $s = 2; $s = 1 if @a-$j < 2; # avoid "can not modify non-existant..."
+ splice @a, $j, $s; $j -= $s; $i++;
+ }
+ elsif ($_[$i] =~ /^(a|accuracy)$/)
+ {
+ $a = $_[$i+1];
+ my $s = 2; $s = 1 if @a-$j < 2; # avoid "can not modify non-existant..."
+ splice @a, $j, $s; $j -= $s; $i++;
+ }
+ elsif ($_[$i] =~ /^(p|precision)$/)
+ {
+ $p = $_[$i+1];
+ my $s = 2; $s = 1 if @a-$j < 2; # avoid "can not modify non-existant..."
+ splice @a, $j, $s; $j -= $s; $i++;
+ }
+ elsif ($_[$i] =~ /^(v|version)$/)
+ {
+ $ver = 1;
+ splice @a, $j, 1; $j --;
+ }
+ elsif ($_[$i] =~ /^(t|trace)$/)
+ {
+ $trace = 1;
+ splice @a, $j, 1; $j --;
+ }
+ elsif ($_[$i] eq 'hex')
+ {
+ splice @a, $j, 1; $j --;
+ $hex = \&bigint::_hex_global;
+ }
+ elsif ($_[$i] eq 'oct')
+ {
+ splice @a, $j, 1; $j --;
+ $oct = \&bigint::_oct_global;
+ }
+ elsif ($_[$i] !~ /^(PI|e|bpi|bexp)\z/)
+ {
+ die ("unknown option $_[$i]");
+ }
+ }
+ my $class;
+ $_lite = 0; # using M::BI::L ?
+ if ($trace)
+ {
+ require Math::BigInt::Trace; $class = 'Math::BigInt::Trace';
+ $upgrade = 'Math::BigFloat::Trace';
+ }
+ else
+ {
+ # 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 '')
+ {
+ @import = ( ); # :constant in Lite, not MBI
+ Math::BigInt::Lite->import( ':constant' );
+ $_lite= 1; # signal okay
+ }
+ }
+ require Math::BigInt if $_lite == 0; # not already loaded?
+ $class = 'Math::BigInt'; # regardless of MBIL or not
+ }
+ push @import, $lib_kind => $lib if $lib ne '';
+ # Math::BigInt::Trace or plain Math::BigInt
+ $class->import(@import, upgrade => $upgrade);
+
+ require Math::BigFloat;
+ Math::BigFloat->import( upgrade => 'Math::BigRat', ':constant' );
+ require Math::BigRat;
+
+ bigrat->accuracy($a) if defined $a;
+ bigrat->precision($p) if defined $p;
+ if ($ver)
+ {
+ print "bigrat\t\t\t v$VERSION\n";
+ print "Math::BigInt::Lite\t v$Math::BigInt::Lite::VERSION\n" if $_lite;
+ print "Math::BigInt\t\t v$Math::BigInt::VERSION";
+ my $config = Math::BigInt->config();
+ print " lib => $config->{lib} v$config->{lib_version}\n";
+ print "Math::BigFloat\t\t v$Math::BigFloat::VERSION\n";
+ print "Math::BigRat\t\t v$Math::BigRat::VERSION\n";
+ exit;
+ }
+
+ # Take care of octal/hexadecimal constants
+ overload::constant binary => sub { bigint::_binary_constant(shift) };
+
+ # if another big* was already loaded:
+ my ($package) = caller();
+
+ no strict 'refs';
+ if (!defined *{"${package}::inf"})
+ {
+ $self->export_to_level(1,$self, at a); # export inf and NaN
+ }
+ {
+ no warnings 'redefine';
+ *CORE::GLOBAL::oct = $oct if $oct;
+ *CORE::GLOBAL::hex = $hex if $hex;
+ }
+ }
+
+sub PI () { Math::BigFloat->new('3.141592653589793238462643383279502884197'); }
+sub e () { Math::BigFloat->new('2.718281828459045235360287471352662497757'); }
+
+sub bpi ($) { local $Math::BigFloat::upgrade; Math::BigFloat::bpi(@_); }
+
+sub bexp ($$)
+ {
+ local $Math::BigFloat::upgrade;
+ my $x = Math::BigFloat->new($_[0]); $x->bexp($_[1]);
+ }
+
+1;
+
+__END__
+
+=head1 NAME
+
+bigrat - Transparent BigNumber/BigRational support for Perl
+
+=head1 SYNOPSIS
+
+ use bigrat;
+
+ print 2 + 4.5,"\n"; # BigFloat 6.5
+ print 1/3 + 1/4,"\n"; # produces 7/12
+
+ {
+ no bigrat;
+ print 1/3,"\n"; # 0.33333...
+ }
+
+ # Note that this will make hex() and oct() be globally overriden:
+ use bigrat qw/hex oct/;
+ print hex("0x1234567890123490"),"\n";
+ print oct("01234567890123490"),"\n";
+
+=head1 DESCRIPTION
+
+All operators (including basic math operations) are overloaded. Integer and
+floating-point constants are created as proper BigInts or BigFloats,
+respectively.
+
+Other than L<bignum>, this module upgrades to Math::BigRat, meaning that
+instead of 2.5 you will get 2+1/2 as output.
+
+=head2 Modules Used
+
+C<bigrat> is just a thin wrapper around various modules of the Math::BigInt
+family. Think of it as the head of the family, who runs the shop, and orders
+the others to do the work.
+
+The following modules are currently used by bignum:
+
+ Math::BigInt::Lite (for speed, and only if it is loadable)
+ Math::BigInt
+ Math::BigFloat
+ Math::BigRat
+
+=head2 Math Library
+
+Math with the numbers is done (by default) by a module called
+Math::BigInt::Calc. This is equivalent to saying:
+
+ use bigrat lib => 'Calc';
+
+You can change this by using:
+
+ use bignum lib => 'GMP';
+
+The following would first try to find Math::BigInt::Foo, then
+Math::BigInt::Bar, and when this also fails, revert to Math::BigInt::Calc:
+
+ use bigrat lib => 'Foo,Math::BigInt::Bar';
+
+Using C<lib> warns if none of the specified libraries can be found and
+L<Math::BigInt> did fall back to one of the default libraries.
+To supress this warning, use C<try> instead:
+
+ use bignum try => 'GMP';
+
+If you want the code to die instead of falling back, use C<only> instead:
+
+ use bignum only => 'GMP';
+
+Please see respective module documentation for further details.
+
+=head2 Sign
+
+The sign is either '+', '-', 'NaN', '+inf' or '-inf'.
+
+A sign of 'NaN' is used to represent the result when input arguments are not
+numbers or as a result of 0/0. '+inf' and '-inf' represent plus respectively
+minus infinity. You will get '+inf' when dividing a positive number by 0, and
+'-inf' when dividing any negative number by 0.
+
+=head2 Methods
+
+Since all numbers are not objects, you can use all functions that are part of
+the BigInt or BigFloat API. It is wise to use only the bxxx() notation, and not
+the fxxx() notation, though. This makes you independed on the fact that the
+underlying object might morph into a different class than BigFloat.
+
+=over 2
+
+=item inf()
+
+A shortcut to return Math::BigInt->binf(). Useful because Perl does not always
+handle bareword C<inf> properly.
+
+=item NaN()
+
+A shortcut to return Math::BigInt->bnan(). Useful because Perl does not always
+handle bareword C<NaN> properly.
+
+=item e
+
+ # perl -Mbigrat=e -wle 'print e'
+
+Returns Euler's number C<e>, aka exp(1).
+
+=item PI
+
+ # perl -Mbigrat=PI -wle 'print PI'
+
+Returns PI.
+
+=item bexp()
+
+ bexp($power,$accuracy);
+
+
+Returns Euler's number C<e> raised to the appropriate power, to
+the wanted accuracy.
+
+Example:
+
+ # perl -Mbigrat=bexp -wle 'print bexp(1,80)'
+
+=item bpi()
+
+ bpi($accuracy);
+
+Returns PI to the wanted accuracy.
+
+Example:
+
+ # perl -Mbigrat=bpi -wle 'print bpi(80)'
+
+=item upgrade()
+
+Return the class that numbers are upgraded to, is in fact returning
+C<$Math::BigInt::upgrade>.
+
+=item in_effect()
+
+ use bigrat;
+
+ print "in effect\n" if bigrat::in_effect; # true
+ {
+ no bigrat;
+ print "in effect\n" if bigrat::in_effect; # false
+ }
+
+Returns true or false if C<bigrat> is in effect in the current scope.
+
+This method only works on Perl v5.9.4 or later.
+
+=back
+
+=head2 MATH LIBRARY
+
+Math with the numbers is done (by default) by a module called
+
+=head2 Cavaet
+
+But a warning is in order. When using the following to make a copy of a number,
+only a shallow copy will be made.
+
+ $x = 9; $y = $x;
+ $x = $y = 7;
+
+If you want to make a real copy, use the following:
+
+ $y = $x->copy();
+
+Using the copy or the original with overloaded math is okay, e.g. the
+following work:
+
+ $x = 9; $y = $x;
+ print $x + 1, " ", $y,"\n"; # prints 10 9
+
+but calling any method that modifies the number directly will result in
+B<both> the original and the copy being destroyed:
+
+ $x = 9; $y = $x;
+ print $x->badd(1), " ", $y,"\n"; # prints 10 10
+
+ $x = 9; $y = $x;
+ print $x->binc(1), " ", $y,"\n"; # prints 10 10
+
+ $x = 9; $y = $x;
+ print $x->bmul(2), " ", $y,"\n"; # prints 18 18
+
+Using methods that do not modify, but testthe contents works:
+
+ $x = 9; $y = $x;
+ $z = 9 if $x->is_zero(); # works fine
+
+See the documentation about the copy constructor and C<=> in overload, as
+well as the documentation in BigInt for further details.
+
+=head2 Options
+
+bignum recognizes some options that can be passed while loading it via use.
+The options can (currently) be either a single letter form, or the long form.
+The following options exist:
+
+=over 2
+
+=item a or accuracy
+
+This sets the accuracy for all math operations. The argument must be greater
+than or equal to zero. See Math::BigInt's bround() function for details.
+
+ perl -Mbigrat=a,50 -le 'print sqrt(20)'
+
+Note that setting precision and accurary at the same time is not possible.
+
+=item p or precision
+
+This sets the precision for all math operations. The argument can be any
+integer. Negative values mean a fixed number of digits after the dot, while
+a positive value rounds to this digit left from the dot. 0 or 1 mean round to
+integer. See Math::BigInt's bfround() function for details.
+
+ perl -Mbigrat=p,-50 -le 'print sqrt(20)'
+
+Note that setting precision and accurary at the same time is not possible.
+
+=item t or trace
+
+This enables a trace mode and is primarily for debugging bignum or
+Math::BigInt/Math::BigFloat.
+
+=item l or lib
+
+Load a different math lib, see L<MATH LIBRARY>.
+
+ perl -Mbigrat=l,GMP -e 'print 2 ** 512'
+
+Currently there is no way to specify more than one library on the command
+line. This means the following does not work:
+
+ perl -Mbignum=l,GMP,Pari -e 'print 2 ** 512'
+
+This will be hopefully fixed soon ;)
+
+=item hex
+
+Override the built-in hex() method with a version that can handle big
+integers. Note that under Perl v5.9.4 or ealier, this will be global
+and cannot be disabled with "no bigint;".
+
+=item oct
+
+Override the built-in oct() method with a version that can handle big
+integers. Note that under Perl v5.9.4 or ealier, this will be global
+and cannot be disabled with "no bigint;".
+
+=item v or version
+
+This prints out the name and version of all modules used and then exits.
+
+ perl -Mbigrat=v
+
+=back
+
+=head1 CAVAETS
+
+=over 2
+
+=item in_effect()
+
+This method only works on Perl v5.9.4 or later.
+
+=item hex()/oct()
+
+C<bigint> overrides these routines with versions that can also handle
+big integer values. Under Perl prior to version v5.9.4, however, this
+will not happen unless you specifically ask for it with the two
+import tags "hex" and "oct" - and then it will be global and cannot be
+disabled inside a scope with "no bigint":
+
+ use bigint qw/hex oct/;
+
+ print hex("0x1234567890123456");
+ {
+ no bigint;
+ print hex("0x1234567890123456");
+ }
+
+The second call to hex() will warn about a non-portable constant.
+
+Compare this to:
+
+ use bigint;
+
+ # will warn only under Perl older than v5.9.4
+ print hex("0x1234567890123456");
+
+=back
+
+=head1 EXAMPLES
+
+ perl -Mbigrat -le 'print sqrt(33)'
+ perl -Mbigrat -le 'print 2*255'
+ perl -Mbigrat -le 'print 4.5+2*255'
+ perl -Mbigrat -le 'print 3/7 + 5/7 + 8/3'
+ perl -Mbigrat -le 'print 12->is_odd()';
+ perl -Mbignum=l,GMP -le 'print 7 ** 7777'
+
+=head1 LICENSE
+
+This program is free software; you may redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+Especially L<bignum>.
+
+L<Math::BigFloat>, L<Math::BigInt>, L<Math::BigRat> and L<Math::Big> as well
+as L<Math::BigInt::BitVect>, L<Math::BigInt::Pari> and L<Math::BigInt::GMP>.
+
+=head1 AUTHORS
+
+(C) by Tels L<http://bloodgate.com/> in early 2002 - 2007.
+
+=cut
Index: trunk/contrib/perl/lib/blib.pm
===================================================================
--- trunk/contrib/perl/lib/blib.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/blib.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/blib.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/lib/blib.t
===================================================================
--- trunk/contrib/perl/lib/blib.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/blib.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/blib.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/lib/bytes.pm
===================================================================
--- trunk/contrib/perl/lib/bytes.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/bytes.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/bytes.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/bytes.t
===================================================================
--- trunk/contrib/perl/lib/bytes.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/bytes.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/bytes.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/bytes_heavy.pl
===================================================================
--- trunk/contrib/perl/lib/bytes_heavy.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/bytes_heavy.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/bytes_heavy.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/cacheout.pl
===================================================================
--- trunk/contrib/perl/lib/cacheout.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/cacheout.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/cacheout.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/lib/charnames.pm
===================================================================
--- trunk/contrib/perl/lib/charnames.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/charnames.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,833 +1,26 @@
package charnames;
use strict;
use warnings;
-use File::Spec;
-our $VERSION = '1.18';
+our $VERSION = '1.36';
+use unicore::Name; # mktables-generated algorithmically-defined names
+use _charnames (); # The submodule for this where most of the work gets done
use bytes (); # for $bytes::hint_bits
+use re "/aa"; # Everything in here should be ASCII
-# The hashes are stored as utf8 strings. This makes it easier to deal with
-# sequences. I (khw) also tried making Name.pl utf8, but it slowed things
-# down by a factor of 7. I then tried making Name.pl store the ut8
-# equivalents but not calling them utf8. That led to similar speed as leaving
-# it alone, but since that is harder for a human to parse, I left it as-is.
+# Translate between Unicode character names and their code points.
+# This is a wrapper around the submodule C<_charnames>. This design allows
+# C<_charnames> to be autoloaded to enable use of \N{...}, but requires this
+# module to be explicitly requested for the functions API.
-my %system_aliases = (
- # Icky 3.2 names with parentheses.
- 'LINE FEED' => pack("U", 0x0A), # LINE FEED (LF)
- 'FORM FEED' => pack("U", 0x0C), # FORM FEED (FF)
- 'CARRIAGE RETURN' => pack("U", 0x0D), # CARRIAGE RETURN (CR)
- 'NEXT LINE' => pack("U", 0x85), # NEXT LINE (NEL)
+$Carp::Internal{ (__PACKAGE__) } = 1;
- # Some variant names from Wikipedia
- 'SINGLE-SHIFT 2' => pack("U", 0x8E),
- 'SINGLE-SHIFT 3' => pack("U", 0x8F),
- 'PRIVATE USE 1' => pack("U", 0x91),
- 'PRIVATE USE 2' => pack("U", 0x92),
- 'START OF PROTECTED AREA' => pack("U", 0x96),
- 'END OF PROTECTED AREA' => pack("U", 0x97),
-
- # Convenience. Standard abbreviations for the controls
- 'NUL' => pack("U", 0x00), # NULL
- 'SOH' => pack("U", 0x01), # START OF HEADING
- 'STX' => pack("U", 0x02), # START OF TEXT
- 'ETX' => pack("U", 0x03), # END OF TEXT
- 'EOT' => pack("U", 0x04), # END OF TRANSMISSION
- 'ENQ' => pack("U", 0x05), # ENQUIRY
- 'ACK' => pack("U", 0x06), # ACKNOWLEDGE
- 'BEL' => pack("U", 0x07), # ALERT; formerly BELL
- 'BS' => pack("U", 0x08), # BACKSPACE
- 'HT' => pack("U", 0x09), # HORIZONTAL TABULATION
- 'LF' => pack("U", 0x0A), # LINE FEED (LF)
- 'VT' => pack("U", 0x0B), # VERTICAL TABULATION
- 'FF' => pack("U", 0x0C), # FORM FEED (FF)
- 'CR' => pack("U", 0x0D), # CARRIAGE RETURN (CR)
- 'SO' => pack("U", 0x0E), # SHIFT OUT
- 'SI' => pack("U", 0x0F), # SHIFT IN
- 'DLE' => pack("U", 0x10), # DATA LINK ESCAPE
- 'DC1' => pack("U", 0x11), # DEVICE CONTROL ONE
- 'DC2' => pack("U", 0x12), # DEVICE CONTROL TWO
- 'DC3' => pack("U", 0x13), # DEVICE CONTROL THREE
- 'DC4' => pack("U", 0x14), # DEVICE CONTROL FOUR
- 'NAK' => pack("U", 0x15), # NEGATIVE ACKNOWLEDGE
- 'SYN' => pack("U", 0x16), # SYNCHRONOUS IDLE
- 'ETB' => pack("U", 0x17), # END OF TRANSMISSION BLOCK
- 'CAN' => pack("U", 0x18), # CANCEL
- 'EOM' => pack("U", 0x19), # END OF MEDIUM
- 'SUB' => pack("U", 0x1A), # SUBSTITUTE
- 'ESC' => pack("U", 0x1B), # ESCAPE
- 'FS' => pack("U", 0x1C), # FILE SEPARATOR
- 'GS' => pack("U", 0x1D), # GROUP SEPARATOR
- 'RS' => pack("U", 0x1E), # RECORD SEPARATOR
- 'US' => pack("U", 0x1F), # UNIT SEPARATOR
- 'DEL' => pack("U", 0x7F), # DELETE
- 'BPH' => pack("U", 0x82), # BREAK PERMITTED HERE
- 'NBH' => pack("U", 0x83), # NO BREAK HERE
- 'NEL' => pack("U", 0x85), # NEXT LINE (NEL)
- 'SSA' => pack("U", 0x86), # START OF SELECTED AREA
- 'ESA' => pack("U", 0x87), # END OF SELECTED AREA
- 'HTS' => pack("U", 0x88), # CHARACTER TABULATION SET
- 'HTJ' => pack("U", 0x89), # CHARACTER TABULATION WITH JUSTIFICATION
- 'VTS' => pack("U", 0x8A), # LINE TABULATION SET
- 'PLD' => pack("U", 0x8B), # PARTIAL LINE FORWARD
- 'PLU' => pack("U", 0x8C), # PARTIAL LINE BACKWARD
- 'RI ' => pack("U", 0x8D), # REVERSE LINE FEED
- 'SS2' => pack("U", 0x8E), # SINGLE SHIFT TWO
- 'SS3' => pack("U", 0x8F), # SINGLE SHIFT THREE
- 'DCS' => pack("U", 0x90), # DEVICE CONTROL STRING
- 'PU1' => pack("U", 0x91), # PRIVATE USE ONE
- 'PU2' => pack("U", 0x92), # PRIVATE USE TWO
- 'STS' => pack("U", 0x93), # SET TRANSMIT STATE
- 'CCH' => pack("U", 0x94), # CANCEL CHARACTER
- 'MW ' => pack("U", 0x95), # MESSAGE WAITING
- 'SPA' => pack("U", 0x96), # START OF GUARDED AREA
- 'EPA' => pack("U", 0x97), # END OF GUARDED AREA
- 'SOS' => pack("U", 0x98), # START OF STRING
- 'SCI' => pack("U", 0x9A), # SINGLE CHARACTER INTRODUCER
- 'CSI' => pack("U", 0x9B), # CONTROL SEQUENCE INTRODUCER
- 'ST ' => pack("U", 0x9C), # STRING TERMINATOR
- 'OSC' => pack("U", 0x9D), # OPERATING SYSTEM COMMAND
- 'PM ' => pack("U", 0x9E), # PRIVACY MESSAGE
- 'APC' => pack("U", 0x9F), # APPLICATION PROGRAM COMMAND
-
- # There are no names for these in the Unicode standard; perhaps should be
- # deprecated, but then again there are no alternative names, so am not
- # deprecating. And if did, the code would have to change to not recommend
- # an alternative for these.
- 'PADDING CHARACTER' => pack("U", 0x80),
- 'PAD' => pack("U", 0x80),
- 'HIGH OCTET PRESET' => pack("U", 0x81),
- 'HOP' => pack("U", 0x81),
- 'INDEX' => pack("U", 0x84),
- 'IND' => pack("U", 0x84),
- 'SINGLE GRAPHIC CHARACTER INTRODUCER' => pack("U", 0x99),
- 'SGC' => pack("U", 0x99),
-
- # More convenience. For further convenience, it is suggested some way of
- # using the NamesList aliases be implemented, but there are ambiguities in
- # NamesList.txt
- 'BOM' => pack("U", 0xFEFF), # BYTE ORDER MARK
- 'BYTE ORDER MARK'=> pack("U", 0xFEFF),
- 'CGJ' => pack("U", 0x034F), # COMBINING GRAPHEME JOINER
- 'FVS1' => pack("U", 0x180B), # MONGOLIAN FREE VARIATION SELECTOR ONE
- 'FVS2' => pack("U", 0x180C), # MONGOLIAN FREE VARIATION SELECTOR TWO
- 'FVS3' => pack("U", 0x180D), # MONGOLIAN FREE VARIATION SELECTOR THREE
- 'LRE' => pack("U", 0x202A), # LEFT-TO-RIGHT EMBEDDING
- 'LRM' => pack("U", 0x200E), # LEFT-TO-RIGHT MARK
- 'LRO' => pack("U", 0x202D), # LEFT-TO-RIGHT OVERRIDE
- 'MMSP' => pack("U", 0x205F), # MEDIUM MATHEMATICAL SPACE
- 'MVS' => pack("U", 0x180E), # MONGOLIAN VOWEL SEPARATOR
- 'NBSP' => pack("U", 0x00A0), # NO-BREAK SPACE
- 'NNBSP' => pack("U", 0x202F), # NARROW NO-BREAK SPACE
- 'PDF' => pack("U", 0x202C), # POP DIRECTIONAL FORMATTING
- 'RLE' => pack("U", 0x202B), # RIGHT-TO-LEFT EMBEDDING
- 'RLM' => pack("U", 0x200F), # RIGHT-TO-LEFT MARK
- 'RLO' => pack("U", 0x202E), # RIGHT-TO-LEFT OVERRIDE
- 'SHY' => pack("U", 0x00AD), # SOFT HYPHEN
- 'VS1' => pack("U", 0xFE00), # VARIATION SELECTOR-1
- 'VS2' => pack("U", 0xFE01), # VARIATION SELECTOR-2
- 'VS3' => pack("U", 0xFE02), # VARIATION SELECTOR-3
- 'VS4' => pack("U", 0xFE03), # VARIATION SELECTOR-4
- 'VS5' => pack("U", 0xFE04), # VARIATION SELECTOR-5
- 'VS6' => pack("U", 0xFE05), # VARIATION SELECTOR-6
- 'VS7' => pack("U", 0xFE06), # VARIATION SELECTOR-7
- 'VS8' => pack("U", 0xFE07), # VARIATION SELECTOR-8
- 'VS9' => pack("U", 0xFE08), # VARIATION SELECTOR-9
- 'VS10' => pack("U", 0xFE09), # VARIATION SELECTOR-10
- 'VS11' => pack("U", 0xFE0A), # VARIATION SELECTOR-11
- 'VS12' => pack("U", 0xFE0B), # VARIATION SELECTOR-12
- 'VS13' => pack("U", 0xFE0C), # VARIATION SELECTOR-13
- 'VS14' => pack("U", 0xFE0D), # VARIATION SELECTOR-14
- 'VS15' => pack("U", 0xFE0E), # VARIATION SELECTOR-15
- 'VS16' => pack("U", 0xFE0F), # VARIATION SELECTOR-16
- 'VS17' => pack("U", 0xE0100), # VARIATION SELECTOR-17
- 'VS18' => pack("U", 0xE0101), # VARIATION SELECTOR-18
- 'VS19' => pack("U", 0xE0102), # VARIATION SELECTOR-19
- 'VS20' => pack("U", 0xE0103), # VARIATION SELECTOR-20
- 'VS21' => pack("U", 0xE0104), # VARIATION SELECTOR-21
- 'VS22' => pack("U", 0xE0105), # VARIATION SELECTOR-22
- 'VS23' => pack("U", 0xE0106), # VARIATION SELECTOR-23
- 'VS24' => pack("U", 0xE0107), # VARIATION SELECTOR-24
- 'VS25' => pack("U", 0xE0108), # VARIATION SELECTOR-25
- 'VS26' => pack("U", 0xE0109), # VARIATION SELECTOR-26
- 'VS27' => pack("U", 0xE010A), # VARIATION SELECTOR-27
- 'VS28' => pack("U", 0xE010B), # VARIATION SELECTOR-28
- 'VS29' => pack("U", 0xE010C), # VARIATION SELECTOR-29
- 'VS30' => pack("U", 0xE010D), # VARIATION SELECTOR-30
- 'VS31' => pack("U", 0xE010E), # VARIATION SELECTOR-31
- 'VS32' => pack("U", 0xE010F), # VARIATION SELECTOR-32
- 'VS33' => pack("U", 0xE0110), # VARIATION SELECTOR-33
- 'VS34' => pack("U", 0xE0111), # VARIATION SELECTOR-34
- 'VS35' => pack("U", 0xE0112), # VARIATION SELECTOR-35
- 'VS36' => pack("U", 0xE0113), # VARIATION SELECTOR-36
- 'VS37' => pack("U", 0xE0114), # VARIATION SELECTOR-37
- 'VS38' => pack("U", 0xE0115), # VARIATION SELECTOR-38
- 'VS39' => pack("U", 0xE0116), # VARIATION SELECTOR-39
- 'VS40' => pack("U", 0xE0117), # VARIATION SELECTOR-40
- 'VS41' => pack("U", 0xE0118), # VARIATION SELECTOR-41
- 'VS42' => pack("U", 0xE0119), # VARIATION SELECTOR-42
- 'VS43' => pack("U", 0xE011A), # VARIATION SELECTOR-43
- 'VS44' => pack("U", 0xE011B), # VARIATION SELECTOR-44
- 'VS45' => pack("U", 0xE011C), # VARIATION SELECTOR-45
- 'VS46' => pack("U", 0xE011D), # VARIATION SELECTOR-46
- 'VS47' => pack("U", 0xE011E), # VARIATION SELECTOR-47
- 'VS48' => pack("U", 0xE011F), # VARIATION SELECTOR-48
- 'VS49' => pack("U", 0xE0120), # VARIATION SELECTOR-49
- 'VS50' => pack("U", 0xE0121), # VARIATION SELECTOR-50
- 'VS51' => pack("U", 0xE0122), # VARIATION SELECTOR-51
- 'VS52' => pack("U", 0xE0123), # VARIATION SELECTOR-52
- 'VS53' => pack("U", 0xE0124), # VARIATION SELECTOR-53
- 'VS54' => pack("U", 0xE0125), # VARIATION SELECTOR-54
- 'VS55' => pack("U", 0xE0126), # VARIATION SELECTOR-55
- 'VS56' => pack("U", 0xE0127), # VARIATION SELECTOR-56
- 'VS57' => pack("U", 0xE0128), # VARIATION SELECTOR-57
- 'VS58' => pack("U", 0xE0129), # VARIATION SELECTOR-58
- 'VS59' => pack("U", 0xE012A), # VARIATION SELECTOR-59
- 'VS60' => pack("U", 0xE012B), # VARIATION SELECTOR-60
- 'VS61' => pack("U", 0xE012C), # VARIATION SELECTOR-61
- 'VS62' => pack("U", 0xE012D), # VARIATION SELECTOR-62
- 'VS63' => pack("U", 0xE012E), # VARIATION SELECTOR-63
- 'VS64' => pack("U", 0xE012F), # VARIATION SELECTOR-64
- 'VS65' => pack("U", 0xE0130), # VARIATION SELECTOR-65
- 'VS66' => pack("U", 0xE0131), # VARIATION SELECTOR-66
- 'VS67' => pack("U", 0xE0132), # VARIATION SELECTOR-67
- 'VS68' => pack("U", 0xE0133), # VARIATION SELECTOR-68
- 'VS69' => pack("U", 0xE0134), # VARIATION SELECTOR-69
- 'VS70' => pack("U", 0xE0135), # VARIATION SELECTOR-70
- 'VS71' => pack("U", 0xE0136), # VARIATION SELECTOR-71
- 'VS72' => pack("U", 0xE0137), # VARIATION SELECTOR-72
- 'VS73' => pack("U", 0xE0138), # VARIATION SELECTOR-73
- 'VS74' => pack("U", 0xE0139), # VARIATION SELECTOR-74
- 'VS75' => pack("U", 0xE013A), # VARIATION SELECTOR-75
- 'VS76' => pack("U", 0xE013B), # VARIATION SELECTOR-76
- 'VS77' => pack("U", 0xE013C), # VARIATION SELECTOR-77
- 'VS78' => pack("U", 0xE013D), # VARIATION SELECTOR-78
- 'VS79' => pack("U", 0xE013E), # VARIATION SELECTOR-79
- 'VS80' => pack("U", 0xE013F), # VARIATION SELECTOR-80
- 'VS81' => pack("U", 0xE0140), # VARIATION SELECTOR-81
- 'VS82' => pack("U", 0xE0141), # VARIATION SELECTOR-82
- 'VS83' => pack("U", 0xE0142), # VARIATION SELECTOR-83
- 'VS84' => pack("U", 0xE0143), # VARIATION SELECTOR-84
- 'VS85' => pack("U", 0xE0144), # VARIATION SELECTOR-85
- 'VS86' => pack("U", 0xE0145), # VARIATION SELECTOR-86
- 'VS87' => pack("U", 0xE0146), # VARIATION SELECTOR-87
- 'VS88' => pack("U", 0xE0147), # VARIATION SELECTOR-88
- 'VS89' => pack("U", 0xE0148), # VARIATION SELECTOR-89
- 'VS90' => pack("U", 0xE0149), # VARIATION SELECTOR-90
- 'VS91' => pack("U", 0xE014A), # VARIATION SELECTOR-91
- 'VS92' => pack("U", 0xE014B), # VARIATION SELECTOR-92
- 'VS93' => pack("U", 0xE014C), # VARIATION SELECTOR-93
- 'VS94' => pack("U", 0xE014D), # VARIATION SELECTOR-94
- 'VS95' => pack("U", 0xE014E), # VARIATION SELECTOR-95
- 'VS96' => pack("U", 0xE014F), # VARIATION SELECTOR-96
- 'VS97' => pack("U", 0xE0150), # VARIATION SELECTOR-97
- 'VS98' => pack("U", 0xE0151), # VARIATION SELECTOR-98
- 'VS99' => pack("U", 0xE0152), # VARIATION SELECTOR-99
- 'VS100' => pack("U", 0xE0153), # VARIATION SELECTOR-100
- 'VS101' => pack("U", 0xE0154), # VARIATION SELECTOR-101
- 'VS102' => pack("U", 0xE0155), # VARIATION SELECTOR-102
- 'VS103' => pack("U", 0xE0156), # VARIATION SELECTOR-103
- 'VS104' => pack("U", 0xE0157), # VARIATION SELECTOR-104
- 'VS105' => pack("U", 0xE0158), # VARIATION SELECTOR-105
- 'VS106' => pack("U", 0xE0159), # VARIATION SELECTOR-106
- 'VS107' => pack("U", 0xE015A), # VARIATION SELECTOR-107
- 'VS108' => pack("U", 0xE015B), # VARIATION SELECTOR-108
- 'VS109' => pack("U", 0xE015C), # VARIATION SELECTOR-109
- 'VS110' => pack("U", 0xE015D), # VARIATION SELECTOR-110
- 'VS111' => pack("U", 0xE015E), # VARIATION SELECTOR-111
- 'VS112' => pack("U", 0xE015F), # VARIATION SELECTOR-112
- 'VS113' => pack("U", 0xE0160), # VARIATION SELECTOR-113
- 'VS114' => pack("U", 0xE0161), # VARIATION SELECTOR-114
- 'VS115' => pack("U", 0xE0162), # VARIATION SELECTOR-115
- 'VS116' => pack("U", 0xE0163), # VARIATION SELECTOR-116
- 'VS117' => pack("U", 0xE0164), # VARIATION SELECTOR-117
- 'VS118' => pack("U", 0xE0165), # VARIATION SELECTOR-118
- 'VS119' => pack("U", 0xE0166), # VARIATION SELECTOR-119
- 'VS120' => pack("U", 0xE0167), # VARIATION SELECTOR-120
- 'VS121' => pack("U", 0xE0168), # VARIATION SELECTOR-121
- 'VS122' => pack("U", 0xE0169), # VARIATION SELECTOR-122
- 'VS123' => pack("U", 0xE016A), # VARIATION SELECTOR-123
- 'VS124' => pack("U", 0xE016B), # VARIATION SELECTOR-124
- 'VS125' => pack("U", 0xE016C), # VARIATION SELECTOR-125
- 'VS126' => pack("U", 0xE016D), # VARIATION SELECTOR-126
- 'VS127' => pack("U", 0xE016E), # VARIATION SELECTOR-127
- 'VS128' => pack("U", 0xE016F), # VARIATION SELECTOR-128
- 'VS129' => pack("U", 0xE0170), # VARIATION SELECTOR-129
- 'VS130' => pack("U", 0xE0171), # VARIATION SELECTOR-130
- 'VS131' => pack("U", 0xE0172), # VARIATION SELECTOR-131
- 'VS132' => pack("U", 0xE0173), # VARIATION SELECTOR-132
- 'VS133' => pack("U", 0xE0174), # VARIATION SELECTOR-133
- 'VS134' => pack("U", 0xE0175), # VARIATION SELECTOR-134
- 'VS135' => pack("U", 0xE0176), # VARIATION SELECTOR-135
- 'VS136' => pack("U", 0xE0177), # VARIATION SELECTOR-136
- 'VS137' => pack("U", 0xE0178), # VARIATION SELECTOR-137
- 'VS138' => pack("U", 0xE0179), # VARIATION SELECTOR-138
- 'VS139' => pack("U", 0xE017A), # VARIATION SELECTOR-139
- 'VS140' => pack("U", 0xE017B), # VARIATION SELECTOR-140
- 'VS141' => pack("U", 0xE017C), # VARIATION SELECTOR-141
- 'VS142' => pack("U", 0xE017D), # VARIATION SELECTOR-142
- 'VS143' => pack("U", 0xE017E), # VARIATION SELECTOR-143
- 'VS144' => pack("U", 0xE017F), # VARIATION SELECTOR-144
- 'VS145' => pack("U", 0xE0180), # VARIATION SELECTOR-145
- 'VS146' => pack("U", 0xE0181), # VARIATION SELECTOR-146
- 'VS147' => pack("U", 0xE0182), # VARIATION SELECTOR-147
- 'VS148' => pack("U", 0xE0183), # VARIATION SELECTOR-148
- 'VS149' => pack("U", 0xE0184), # VARIATION SELECTOR-149
- 'VS150' => pack("U", 0xE0185), # VARIATION SELECTOR-150
- 'VS151' => pack("U", 0xE0186), # VARIATION SELECTOR-151
- 'VS152' => pack("U", 0xE0187), # VARIATION SELECTOR-152
- 'VS153' => pack("U", 0xE0188), # VARIATION SELECTOR-153
- 'VS154' => pack("U", 0xE0189), # VARIATION SELECTOR-154
- 'VS155' => pack("U", 0xE018A), # VARIATION SELECTOR-155
- 'VS156' => pack("U", 0xE018B), # VARIATION SELECTOR-156
- 'VS157' => pack("U", 0xE018C), # VARIATION SELECTOR-157
- 'VS158' => pack("U", 0xE018D), # VARIATION SELECTOR-158
- 'VS159' => pack("U", 0xE018E), # VARIATION SELECTOR-159
- 'VS160' => pack("U", 0xE018F), # VARIATION SELECTOR-160
- 'VS161' => pack("U", 0xE0190), # VARIATION SELECTOR-161
- 'VS162' => pack("U", 0xE0191), # VARIATION SELECTOR-162
- 'VS163' => pack("U", 0xE0192), # VARIATION SELECTOR-163
- 'VS164' => pack("U", 0xE0193), # VARIATION SELECTOR-164
- 'VS165' => pack("U", 0xE0194), # VARIATION SELECTOR-165
- 'VS166' => pack("U", 0xE0195), # VARIATION SELECTOR-166
- 'VS167' => pack("U", 0xE0196), # VARIATION SELECTOR-167
- 'VS168' => pack("U", 0xE0197), # VARIATION SELECTOR-168
- 'VS169' => pack("U", 0xE0198), # VARIATION SELECTOR-169
- 'VS170' => pack("U", 0xE0199), # VARIATION SELECTOR-170
- 'VS171' => pack("U", 0xE019A), # VARIATION SELECTOR-171
- 'VS172' => pack("U", 0xE019B), # VARIATION SELECTOR-172
- 'VS173' => pack("U", 0xE019C), # VARIATION SELECTOR-173
- 'VS174' => pack("U", 0xE019D), # VARIATION SELECTOR-174
- 'VS175' => pack("U", 0xE019E), # VARIATION SELECTOR-175
- 'VS176' => pack("U", 0xE019F), # VARIATION SELECTOR-176
- 'VS177' => pack("U", 0xE01A0), # VARIATION SELECTOR-177
- 'VS178' => pack("U", 0xE01A1), # VARIATION SELECTOR-178
- 'VS179' => pack("U", 0xE01A2), # VARIATION SELECTOR-179
- 'VS180' => pack("U", 0xE01A3), # VARIATION SELECTOR-180
- 'VS181' => pack("U", 0xE01A4), # VARIATION SELECTOR-181
- 'VS182' => pack("U", 0xE01A5), # VARIATION SELECTOR-182
- 'VS183' => pack("U", 0xE01A6), # VARIATION SELECTOR-183
- 'VS184' => pack("U", 0xE01A7), # VARIATION SELECTOR-184
- 'VS185' => pack("U", 0xE01A8), # VARIATION SELECTOR-185
- 'VS186' => pack("U", 0xE01A9), # VARIATION SELECTOR-186
- 'VS187' => pack("U", 0xE01AA), # VARIATION SELECTOR-187
- 'VS188' => pack("U", 0xE01AB), # VARIATION SELECTOR-188
- 'VS189' => pack("U", 0xE01AC), # VARIATION SELECTOR-189
- 'VS190' => pack("U", 0xE01AD), # VARIATION SELECTOR-190
- 'VS191' => pack("U", 0xE01AE), # VARIATION SELECTOR-191
- 'VS192' => pack("U", 0xE01AF), # VARIATION SELECTOR-192
- 'VS193' => pack("U", 0xE01B0), # VARIATION SELECTOR-193
- 'VS194' => pack("U", 0xE01B1), # VARIATION SELECTOR-194
- 'VS195' => pack("U", 0xE01B2), # VARIATION SELECTOR-195
- 'VS196' => pack("U", 0xE01B3), # VARIATION SELECTOR-196
- 'VS197' => pack("U", 0xE01B4), # VARIATION SELECTOR-197
- 'VS198' => pack("U", 0xE01B5), # VARIATION SELECTOR-198
- 'VS199' => pack("U", 0xE01B6), # VARIATION SELECTOR-199
- 'VS200' => pack("U", 0xE01B7), # VARIATION SELECTOR-200
- 'VS201' => pack("U", 0xE01B8), # VARIATION SELECTOR-201
- 'VS202' => pack("U", 0xE01B9), # VARIATION SELECTOR-202
- 'VS203' => pack("U", 0xE01BA), # VARIATION SELECTOR-203
- 'VS204' => pack("U", 0xE01BB), # VARIATION SELECTOR-204
- 'VS205' => pack("U", 0xE01BC), # VARIATION SELECTOR-205
- 'VS206' => pack("U", 0xE01BD), # VARIATION SELECTOR-206
- 'VS207' => pack("U", 0xE01BE), # VARIATION SELECTOR-207
- 'VS208' => pack("U", 0xE01BF), # VARIATION SELECTOR-208
- 'VS209' => pack("U", 0xE01C0), # VARIATION SELECTOR-209
- 'VS210' => pack("U", 0xE01C1), # VARIATION SELECTOR-210
- 'VS211' => pack("U", 0xE01C2), # VARIATION SELECTOR-211
- 'VS212' => pack("U", 0xE01C3), # VARIATION SELECTOR-212
- 'VS213' => pack("U", 0xE01C4), # VARIATION SELECTOR-213
- 'VS214' => pack("U", 0xE01C5), # VARIATION SELECTOR-214
- 'VS215' => pack("U", 0xE01C6), # VARIATION SELECTOR-215
- 'VS216' => pack("U", 0xE01C7), # VARIATION SELECTOR-216
- 'VS217' => pack("U", 0xE01C8), # VARIATION SELECTOR-217
- 'VS218' => pack("U", 0xE01C9), # VARIATION SELECTOR-218
- 'VS219' => pack("U", 0xE01CA), # VARIATION SELECTOR-219
- 'VS220' => pack("U", 0xE01CB), # VARIATION SELECTOR-220
- 'VS221' => pack("U", 0xE01CC), # VARIATION SELECTOR-221
- 'VS222' => pack("U", 0xE01CD), # VARIATION SELECTOR-222
- 'VS223' => pack("U", 0xE01CE), # VARIATION SELECTOR-223
- 'VS224' => pack("U", 0xE01CF), # VARIATION SELECTOR-224
- 'VS225' => pack("U", 0xE01D0), # VARIATION SELECTOR-225
- 'VS226' => pack("U", 0xE01D1), # VARIATION SELECTOR-226
- 'VS227' => pack("U", 0xE01D2), # VARIATION SELECTOR-227
- 'VS228' => pack("U", 0xE01D3), # VARIATION SELECTOR-228
- 'VS229' => pack("U", 0xE01D4), # VARIATION SELECTOR-229
- 'VS230' => pack("U", 0xE01D5), # VARIATION SELECTOR-230
- 'VS231' => pack("U", 0xE01D6), # VARIATION SELECTOR-231
- 'VS232' => pack("U", 0xE01D7), # VARIATION SELECTOR-232
- 'VS233' => pack("U", 0xE01D8), # VARIATION SELECTOR-233
- 'VS234' => pack("U", 0xE01D9), # VARIATION SELECTOR-234
- 'VS235' => pack("U", 0xE01DA), # VARIATION SELECTOR-235
- 'VS236' => pack("U", 0xE01DB), # VARIATION SELECTOR-236
- 'VS237' => pack("U", 0xE01DC), # VARIATION SELECTOR-237
- 'VS238' => pack("U", 0xE01DD), # VARIATION SELECTOR-238
- 'VS239' => pack("U", 0xE01DE), # VARIATION SELECTOR-239
- 'VS240' => pack("U", 0xE01DF), # VARIATION SELECTOR-240
- 'VS241' => pack("U", 0xE01E0), # VARIATION SELECTOR-241
- 'VS242' => pack("U", 0xE01E1), # VARIATION SELECTOR-242
- 'VS243' => pack("U", 0xE01E2), # VARIATION SELECTOR-243
- 'VS244' => pack("U", 0xE01E3), # VARIATION SELECTOR-244
- 'VS245' => pack("U", 0xE01E4), # VARIATION SELECTOR-245
- 'VS246' => pack("U", 0xE01E5), # VARIATION SELECTOR-246
- 'VS247' => pack("U", 0xE01E6), # VARIATION SELECTOR-247
- 'VS248' => pack("U", 0xE01E7), # VARIATION SELECTOR-248
- 'VS249' => pack("U", 0xE01E8), # VARIATION SELECTOR-249
- 'VS250' => pack("U", 0xE01E9), # VARIATION SELECTOR-250
- 'VS251' => pack("U", 0xE01EA), # VARIATION SELECTOR-251
- 'VS252' => pack("U", 0xE01EB), # VARIATION SELECTOR-252
- 'VS253' => pack("U", 0xE01EC), # VARIATION SELECTOR-253
- 'VS254' => pack("U", 0xE01ED), # VARIATION SELECTOR-254
- 'VS255' => pack("U", 0xE01EE), # VARIATION SELECTOR-255
- 'VS256' => pack("U", 0xE01EF), # VARIATION SELECTOR-256
- 'WJ' => pack("U", 0x2060), # WORD JOINER
- 'ZWJ' => pack("U", 0x200D), # ZERO WIDTH JOINER
- 'ZWNJ' => pack("U", 0x200C), # ZERO WIDTH NON-JOINER
- 'ZWSP' => pack("U", 0x200B), # ZERO WIDTH SPACE
-);
-
-my %deprecated_aliases = (
- # Pre-3.2 compatibility (only for the first 256 characters).
- # Use of these gives deprecated message.
- 'HORIZONTAL TABULATION' => pack("U", 0x09), # CHARACTER TABULATION
- 'VERTICAL TABULATION' => pack("U", 0x0B), # LINE TABULATION
- 'FILE SEPARATOR' => pack("U", 0x1C), # INFORMATION SEPARATOR FOUR
- 'GROUP SEPARATOR' => pack("U", 0x1D), # INFORMATION SEPARATOR THREE
- 'RECORD SEPARATOR' => pack("U", 0x1E), # INFORMATION SEPARATOR TWO
- 'UNIT SEPARATOR' => pack("U", 0x1F), # INFORMATION SEPARATOR ONE
- 'HORIZONTAL TABULATION SET' => pack("U", 0x88), # CHARACTER TABULATION SET
- 'HORIZONTAL TABULATION WITH JUSTIFICATION' => pack("U", 0x89), # CHARACTER TABULATION WITH JUSTIFICATION
- 'PARTIAL LINE DOWN' => pack("U", 0x8B), # PARTIAL LINE FORWARD
- 'PARTIAL LINE UP' => pack("U", 0x8C), # PARTIAL LINE BACKWARD
- 'VERTICAL TABULATION SET' => pack("U", 0x8A), # LINE TABULATION SET
- 'REVERSE INDEX' => pack("U", 0x8D), # REVERSE LINE FEED
-
- # Unicode 6.0 co-opted this for U+1F514, so deprecate it for now.
- 'BELL' => pack("U", 0x07),
-);
-
-
-my $txt; # The table of official character names
-
-my %full_names_cache; # Holds already-looked-up names, so don't have to
-# re-look them up again. The previous versions of charnames had scoping
-# bugs. For example if we use script A in one scope and find and cache
-# what Z resolves to, we can't use that cache in a different scope that
-# uses script B instead of A, as Z might be an entirely different letter
-# there; or there might be different aliases in effect in different
-# scopes, or :short may be in effect or not effect in different scopes,
-# or various combinations thereof. This was solved in this version
-# mostly by moving things to %^H. But some things couldn't be moved
-# there. One of them was the cache of runtime looked-up names, in part
-# because %^H is read-only at runtime. I (khw) don't know why the cache
-# was run-time only in the previous versions: perhaps oversight; perhaps
-# that compile time looking doesn't happen in a loop so didn't think it
-# was worthwhile; perhaps not wanting to make the cache too large. But
-# I decided to make it compile time as well; this could easily be
-# changed.
-# Anyway, this hash is not scoped, and is added to at runtime. It
-# doesn't have scoping problems because the data in it is restricted to
-# official names, which are always invariant, and we only set it and
-# look at it at during :full lookups, so is unaffected by any other
-# scoped options. I put this in to maintain parity with the older
-# version. If desired, a %short_names cache could also be made, as well
-# as one for each script, say in %script_names_cache, with each key
-# being a hash for a script named in a 'use charnames' statement. I
-# decided not to do that for now, just because it's added complication,
-# and because I'm just trying to maintain parity, not extend it.
-
-# Designed so that test decimal first, and then hex. Leading zeros
-# imply non-decimal, as do non-[0-9]
-my $decimal_qr = qr/^[1-9]\d*$/;
-
-# Returns the hex number in $1.
-my $hex_qr = qr/^(?:[Uu]\+|0[xX])?([[:xdigit:]]+)$/;
-
-sub croak
-{
- require Carp; goto &Carp::croak;
-} # croak
-
-sub carp
-{
- require Carp; goto &Carp::carp;
-} # carp
-
-sub alias (@) # Set up a single alias
-{
- my $alias = ref $_[0] ? $_[0] : { @_ };
- foreach my $name (keys %$alias) {
- my $value = $alias->{$name};
- next unless defined $value; # Omit if screwed up.
-
- # Is slightly slower to just after this statement see if it is
- # decimal, since we already know it is after having converted from
- # hex, but makes the code easier to maintain, and is called
- # infrequently, only at compile-time
- if ($value !~ $decimal_qr && $value =~ $hex_qr) {
- $value = CORE::hex $1;
- }
- if ($value =~ $decimal_qr) {
- no warnings 'utf8'; # Allow even illegal characters
- $^H{charnames_ord_aliases}{$name} = pack("U", $value);
-
- # Use a canonical form.
- $^H{charnames_inverse_ords}{sprintf("%05X", $value)} = $name;
- }
- else {
- # XXX validate syntax when deprecation cycle complete. ie. start
- # with an alpha only, etc.
- $^H{charnames_name_aliases}{$name} = $value;
- }
- }
-} # alias
-
-sub not_legal_use_bytes_msg {
- my ($name, $utf8) = @_;
- my $return;
-
- if (length($utf8) == 1) {
- $return = sprintf("Character 0x%04x with name '%s' is", ord $utf8, $name);
- } else {
- $return = sprintf("String with name '%s' (and ordinals %s) contains character(s)", $name, join(" ", map { sprintf "0x%04X", ord $_ } split(//, $utf8)));
- }
- return $return . " above 0xFF with 'use bytes' in effect";
-}
-
-sub alias_file ($) # Reads a file containing alias definitions
-{
- my ($arg, $file) = @_;
- if (-f $arg && File::Spec->file_name_is_absolute ($arg)) {
- $file = $arg;
- }
- elsif ($arg =~ m/^\w+$/) {
- $file = "unicore/${arg}_alias.pl";
- }
- else {
- croak "Charnames alias files can only have identifier characters";
- }
- if (my @alias = do $file) {
- @alias == 1 && !defined $alias[0] and
- croak "$file cannot be used as alias file for charnames";
- @alias % 2 and
- croak "$file did not return a (valid) list of alias pairs";
- alias (@alias);
- return (1);
- }
- 0;
-} # alias_file
-
-# For use when don't import anything. This structure must be kept in
-# sync with the one that import() fills up.
-my %dummy_H = (
- charnames_stringified_names => "",
- charnames_stringified_ords => "",
- charnames_scripts => "",
- charnames_full => 1,
- charnames_short => 0,
- );
-
-
-sub lookup_name ($$$) {
- my ($name, $wants_ord, $runtime) = @_;
-
- # Lookup the name or sequence $name in the tables. If $wants_ord is false,
- # returns the string equivalent of $name; if true, returns the ordinal value
- # instead, but in this case $name must not be a sequence; otherwise undef is
- # returned and a warning raised. $runtime is 0 if compiletime, otherwise
- # gives the number of stack frames to go back to get the application caller
- # info.
- # If $name is not found, returns undef in runtime with no warning; and in
- # compiletime, the Unicode replacement character, with a warning.
-
- # It looks first in the aliases, then in the large table of official Unicode
- # names.
-
- my $utf8; # The string result
- my $save_input;
-
- if ($runtime) {
-
- my $hints_ref = (caller($runtime))[10];
-
- # If we didn't import anything (which happens with 'use charnames ()',
- # substitute a dummy structure.
- $hints_ref = \%dummy_H if ! defined $hints_ref
- || ! defined $hints_ref->{charnames_full};
-
- # At runtime, but currently not at compile time, $^H gets
- # stringified, so un-stringify back to the original data structures.
- # These get thrown away by perl before the next invocation
- # Also fill in the hash with the non-stringified data.
- # N.B. New fields must be also added to %dummy_H
-
- %{$^H{charnames_name_aliases}} = split ',',
- $hints_ref->{charnames_stringified_names};
- %{$^H{charnames_ord_aliases}} = split ',',
- $hints_ref->{charnames_stringified_ords};
- $^H{charnames_scripts} = $hints_ref->{charnames_scripts};
- $^H{charnames_full} = $hints_ref->{charnames_full};
- $^H{charnames_short} = $hints_ref->{charnames_short};
- }
-
- # User alias should be checked first or else can't override ours, and if we
- # were to add any, could conflict with theirs.
- if (exists $^H{charnames_ord_aliases}{$name}) {
- $utf8 = $^H{charnames_ord_aliases}{$name};
- }
- elsif (exists $^H{charnames_name_aliases}{$name}) {
- $name = $^H{charnames_name_aliases}{$name};
- $save_input = $name; # Cache the result for any error message
- }
- elsif (exists $system_aliases{$name}) {
- $utf8 = $system_aliases{$name};
- }
- elsif (exists $deprecated_aliases{$name}) {
- require warnings;
- warnings::warnif('deprecated', "Unicode character name \"$name\" is deprecated, use \"" . viacode(ord $deprecated_aliases{$name}) . "\" instead");
- $utf8 = $deprecated_aliases{$name};
- }
-
- my @off;
-
- if (! defined $utf8) {
-
- # See if has looked this input up earlier.
- if ($^H{charnames_full} && exists $full_names_cache{$name}) {
- $utf8 = $full_names_cache{$name};
- }
- else {
-
- ## Suck in the code/name list as a big string.
- ## Lines look like:
- ## "00052\tLATIN CAPITAL LETTER R\n"
- # or
- # "0052 0303\tLATIN CAPITAL LETTER R WITH TILDE\n"
- $txt = do "unicore/Name.pl" unless $txt;
-
- ## @off will hold the index into the code/name string of the start and
- ## end of the name as we find it.
-
- ## If :full, look for the name exactly; runtime implies full
- my $found_full_in_table = 0; # Tells us if can cache the result
- if ($^H{charnames_full}) {
-
- # See if the name is one which is algorithmically determinable.
- # The subroutine is included in Name.pl. The table contained in
- # $txt doesn't contain these. Experiments show that checking
- # for these before checking for the regular names has no
- # noticeable impact on performance for the regular names, but
- # the other way around slows down finding these immensely.
- # Algorithmically determinables are not placed in the cache (that
- # $found_full_in_table indicates) because that uses up memory,
- # and finding these again is fast.
- if (defined (my $ord = name_to_code_point_special($name))) {
- $utf8 = pack("U", $ord);
- }
- else {
-
- # Not algorithmically determinable; look up in the table.
- if ($txt =~ /\t\Q$name\E$/m) {
- @off = ($-[0] + 1, $+[0]); # The 1 is for the tab
- $found_full_in_table = 1;
- }
- }
- }
-
- # If we didn't get it above, keep looking
- if (! $found_full_in_table && ! defined $utf8) {
-
- # If :short is allowed, see if input is like "greek:Sigma".
- my $scripts_trie;
- if (($^H{charnames_short})
- && $name =~ /^ \s* (.+?) \s* : \s* (.+?) \s* $ /xs)
- {
- $scripts_trie = "\U\Q$1";
- $name = $2;
- }
- else { # Otherwise look in allowed scripts
- $scripts_trie = $^H{charnames_scripts};
- }
-
- my $case = $name =~ /[[:upper:]]/ ? "CAPITAL" : "SMALL";
- if ($txt !~
- /\t (?: $scripts_trie ) \ (?:$case\ )? LETTER \ \U\Q$name\E $/xm)
- {
- # Here we still don't have it, give up.
- return if $runtime;
-
- # May have zapped input name, get it again.
- $name = (defined $save_input) ? $save_input : $_[0];
- carp "Unknown charname '$name'";
- return ($wants_ord) ? 0xFFFD : pack("U", 0xFFFD);
- }
-
- @off = ($-[0] + 1, $+[0]); # The 1 is for the tab
- }
-
- if (! defined $utf8) {
-
- # Here, we haven't set up the output, but we know where in the string
- # the name starts. The string is set up so that for single characters
- # (and not named sequences), the name is preceded immediately by a
- # tab and 5 hex digits for its code, with a \n before those. Named
- # sequences won't have the 7th preceding character be a \n.
- # (Actually, for the very first entry in the table this isn't strictly
- # true: subtracting 7 will yield -1, and the substr below will
- # therefore yield the very last character in the table, which should
- # also be a \n, so the statement works anyway.)
- if (substr($txt, $off[0] - 7, 1) eq "\n") {
- $utf8 = pack("U", CORE::hex substr($txt, $off[0] - 6, 5));
- }
- else {
-
- # Here, is a named sequence. Need to go looking for the beginning,
- # which is just after the \n from the previous entry in the table.
- # The +1 skips past that newline, or, if the rindex() fails, to put
- # us to an offset of zero.
- my $charstart = rindex($txt, "\n", $off[0] - 7) + 1;
- $utf8 = pack("U*", map { CORE::hex }
- split " ", substr($txt, $charstart, $off[0] - $charstart - 1));
- }
- }
-
- # Cache the input so as to not have to search the large table
- # again, but only if it came from the one search that we cache.
- $full_names_cache{$name} = $utf8 if $found_full_in_table;
- }
- }
-
-
- # Here, have the utf8. If the return is to be an ord, must be any single
- # character.
- if ($wants_ord) {
- return ord($utf8) if length $utf8 == 1;
- }
- else {
-
- # Here, wants string output. If utf8 is acceptable, just return what
- # we've got; otherwise attempt to convert it to non-utf8 and return that.
- my $in_bytes = ($runtime)
- ? (caller $runtime)[8] & $bytes::hint_bits
- : $^H & $bytes::hint_bits;
- return $utf8 if (! $in_bytes || utf8::downgrade($utf8, 1)) # The 1 arg
- # means don't die on failure
- }
-
- # Here, there is an error: either there are too many characters, or the
- # result string needs to be non-utf8, and at least one character requires
- # utf8. Prefer any official name over the input one for the error message.
- if (@off) {
- $name = substr($txt, $off[0], $off[1] - $off[0]) if @off;
- }
- else {
- $name = (defined $save_input) ? $save_input : $_[0];
- }
-
- if ($wants_ord) {
- # Only way to get here in this case is if result too long. Message
- # assumes that our only caller that requires single char result is
- # vianame.
- carp "charnames::vianame() doesn't handle named sequences ($name). Use charnames::string_vianame() instead";
- return;
- }
-
- # Only other possible failure here is from use bytes.
- if ($runtime) {
- carp not_legal_use_bytes_msg($name, $utf8);
- return;
- } else {
- croak not_legal_use_bytes_msg($name, $utf8);
- }
-
-} # lookup_name
-
-sub charnames {
-
- # For \N{...}. Looks up the character name and returns the string
- # representation of it.
-
- # The first 0 arg means wants a string returned; the second that we are in
- # compile time
- return lookup_name($_[0], 0, 0);
-}
-
sub import
{
shift; ## ignore class name
+ _charnames->import(@_);
+}
- if (not @_) {
- carp("`use charnames' needs explicit imports list");
- }
- $^H{charnames} = \&charnames ;
- $^H{charnames_ord_aliases} = {};
- $^H{charnames_name_aliases} = {};
- $^H{charnames_inverse_ords} = {};
- # New fields must be added to %dummy_H, and the code in lookup_name()
- # that copies fields from the runtime structure
-
- ##
- ## fill %h keys with our @_ args.
- ##
- my ($promote, %h, @args) = (0);
- while (my $arg = shift) {
- if ($arg eq ":alias") {
- @_ or
- croak ":alias needs an argument in charnames";
- my $alias = shift;
- if (ref $alias) {
- ref $alias eq "HASH" or
- croak "Only HASH reference supported as argument to :alias";
- alias ($alias);
- next;
- }
- if ($alias =~ m{:(\w+)$}) {
- $1 eq "full" || $1 eq "short" and
- croak ":alias cannot use existing pragma :$1 (reversed order?)";
- alias_file ($1) and $promote = 1;
- next;
- }
- alias_file ($alias);
- next;
- }
- if (substr($arg, 0, 1) eq ':' and ! ($arg eq ":full" || $arg eq ":short")) {
- warn "unsupported special '$arg' in charnames";
- next;
- }
- push @args, $arg;
- }
- @args == 0 && $promote and @args = (":full");
- @h{@args} = (1) x @args;
-
- $^H{charnames_full} = delete $h{':full'} || 0; # Don't leave undefined,
- # as tested for in
- # lookup_names
- $^H{charnames_short} = delete $h{':short'} || 0;
- my @scripts = map uc, keys %h;
-
- ##
- ## If utf8? warnings are enabled, and some scripts were given,
- ## see if at least we can find one letter from each script.
- ##
- if (warnings::enabled('utf8') && @scripts) {
- $txt = do "unicore/Name.pl" unless $txt;
-
- for my $script (@scripts) {
- if (not $txt =~ m/\t$script (?:CAPITAL |SMALL )?LETTER /) {
- warnings::warn('utf8', "No such script: '$script'");
- $script = quotemeta $script; # Escape it, for use in the re.
- }
- }
- }
-
- # %^H gets stringified, so serialize it ourselves so can extract the
- # real data back later.
- $^H{charnames_stringified_ords} = join ",", %{$^H{charnames_ord_aliases}};
- $^H{charnames_stringified_names} = join ",", %{$^H{charnames_name_aliases}};
- $^H{charnames_stringified_inverse_ords} = join ",", %{$^H{charnames_inverse_ords}};
- $^H{charnames_scripts} = join "|", @scripts; # Stringifiy them as a trie
-} # import
-
# Cache of already looked-up values. This is set to only contain
# official values, and user aliases can't override them, so scoping is
# not an issue.
@@ -834,81 +27,13 @@
my %viacode;
sub viacode {
+ return _charnames::viacode(@_);
+}
- # Returns the name of the code point argument
-
- if (@_ != 1) {
- carp "charnames::viacode() expects one argument";
- return;
- }
-
- my $arg = shift;
-
- # This is derived from Unicode::UCD, where it is nearly the same as the
- # function _getcode(), but here it makes sure that even a hex argument
- # has the proper number of leading zeros, which is critical in
- # matching against $txt below
- # Must check if decimal first; see comments at that definition
- my $hex;
- if ($arg =~ $decimal_qr) {
- $hex = sprintf "%05X", $arg;
- } elsif ($arg =~ $hex_qr) {
- # Below is the line that differs from the _getcode() source
- $hex = sprintf "%05X", hex $1;
- } else {
- carp("unexpected arg \"$arg\" to charnames::viacode()");
- return;
- }
-
- return $viacode{$hex} if exists $viacode{$hex};
-
- # If the code point is above the max in the table, there's no point
- # looking through it. Checking the length first is slightly faster
- if (length($hex) <= 5 || CORE::hex($hex) <= 0x10FFFF) {
- $txt = do "unicore/Name.pl" unless $txt;
-
- # See if the name is algorithmically determinable.
- my $algorithmic = code_point_to_name_special(CORE::hex $hex);
- if (defined $algorithmic) {
- $viacode{$hex} = $algorithmic;
- return $algorithmic;
- }
-
- # Return the official name, if exists. It's unclear to me (khw) at
- # this juncture if it is better to return a user-defined override, so
- # leaving it as is for now.
- if ($txt =~ m/^$hex\t/m) {
-
- # The name starts with the next character and goes up to the
- # next new-line. Using capturing parentheses above instead of
- # @+ more than doubles the execution time in Perl 5.13
- $viacode{$hex} = substr($txt, $+[0], index($txt, "\n", $+[0]) - $+[0]);
- return $viacode{$hex};
- }
- }
-
- # See if there is a user name for it, before giving up completely.
- # First get the scoped aliases, give up if have none.
- my $H_ref = (caller(0))[10];
- return if ! defined $H_ref
- || ! exists $H_ref->{charnames_stringified_inverse_ords};
-
- my %code_point_aliases = split ',',
- $H_ref->{charnames_stringified_inverse_ords};
- if (! exists $code_point_aliases{$hex}) {
- if (CORE::hex($hex) > 0x10FFFF) {
- carp "Unicode characters only allocated up to U+10FFFF (you asked for U+$hex)";
- }
- return;
- }
-
- return $code_point_aliases{$hex};
-} # viacode
-
sub vianame
{
if (@_ != 1) {
- carp "charnames::vianame() expects one name argument";
+ _charnames::carp "charnames::vianame() expects one name argument";
return ()
}
@@ -925,13 +50,13 @@
# string_vianame() instead.
my $ord = CORE::hex $1;
return chr $ord if $ord <= 255 || ! ((caller 0)[8] & $bytes::hint_bits);
- carp not_legal_use_bytes_msg($arg, chr $ord);
+ _charnames::carp _charnames::not_legal_use_bytes_msg($arg, chr $ord);
return;
}
# The first 1 arg means wants an ord returned; the second that we are in
# runtime, and this is the first level routine called from the user
- return lookup_name($arg, 1, 1);
+ return _charnames::lookup_name($arg, 1, 1);
} # vianame
sub string_vianame {
@@ -940,7 +65,7 @@
# found, undef otherwise.
if (@_ != 1) {
- carp "charnames::string_vianame() expects one name argument";
+ _charnames::carp "charnames::string_vianame() expects one name argument";
return;
}
@@ -951,20 +76,20 @@
my $ord = CORE::hex $1;
return chr $ord if $ord <= 255 || ! ((caller 0)[8] & $bytes::hint_bits);
- carp not_legal_use_bytes_msg($arg, chr $ord);
+ _charnames::carp _charnames::not_legal_use_bytes_msg($arg, chr $ord);
return;
}
# The 0 arg means wants a string returned; the 1 arg means that we are in
# runtime, and this is the first level routine called from the user
- return lookup_name($arg, 0, 1);
+ return _charnames::lookup_name($arg, 0, 1);
} # string_vianame
-
-
1;
__END__
+=encoding utf8
+
=head1 NAME
charnames - access to Unicode character names and named character sequences; also define character names
@@ -976,6 +101,11 @@
print "\N{LATIN CAPITAL LETTER E WITH VERTICAL LINE BELOW}",
" is an officially named sequence of two Unicode characters\n";
+ use charnames ':loose';
+ print "\N{Greek small-letter sigma}",
+ "can be used to ignore case, underscores, most blanks,"
+ "and when you aren't sure if the official name has hyphens\n";
+
use charnames ':short';
print "\N{greek:Sigma} is an upper-case sigma.\n";
@@ -982,12 +112,16 @@
use charnames qw(cyrillic greek);
print "\N{sigma} is Greek sigma, and \N{be} is Cyrillic b.\n";
+ use utf8;
use charnames ":full", ":alias" => {
e_ACUTE => "LATIN SMALL LETTER E WITH ACUTE",
mychar => 0xE8000, # Private use area
+ "自転車に乗る人" => "BICYCLIST"
};
print "\N{e_ACUTE} is a small letter e with an acute.\n";
- print "\\N{mychar} allows me to name private use characters.\n";
+ print "\N{mychar} allows me to name private use characters.\n";
+ print "And I can create synonyms in other languages,",
+ " such as \N{自転車に乗る人} for "BICYCLIST (U+1F6B4)\n";
use charnames ();
print charnames::viacode(0x1234); # prints "ETHIOPIC SYLLABLE SEE"
@@ -1027,42 +161,55 @@
=back
-All forms other than C<S<"use charnames ();">> also enable the use of
-C<\N{I<CHARNAME>}> sequences to compile a Unicode character into a
-string, based on its name.
+Starting in Perl v5.16, any occurrence of C<\N{I<CHARNAME>}> sequences
+in a double-quotish string automatically loads this module with arguments
+C<:full> and C<:short> (described below) if it hasn't already been loaded with
+different arguments, in order to compile the named Unicode character into
+position in the string. Prior to v5.16, an explicit S<C<use charnames>> was
+required to enable this usage. (However, prior to v5.16, the form C<S<"use
+charnames ();">> did not enable C<\N{I<CHARNAME>}>.)
Note that C<\N{U+I<...>}>, where the I<...> is a hexadecimal number,
-also inserts a character into a string, but doesn't require the use of
-this pragma. The character it inserts is the one whose code point
+also inserts a character into a string.
+The character it inserts is the one whose code point
(ordinal value) is equal to the number. For example, C<"\N{U+263a}"> is
-the Unicode (white background, black foreground) smiley face; it doesn't
-require this pragma, whereas the equivalent, C<"\N{WHITE SMILING FACE}">
-does.
-Also, C<\N{I<...>}> can mean a regex quantifier instead of a character
+the Unicode (white background, black foreground) smiley face
+equivalent to C<"\N{WHITE SMILING FACE}">.
+Also note, C<\N{I<...>}> can mean a regex quantifier instead of a character
name, when the I<...> is a number (or comma separated pair of numbers
(see L<perlreref/QUANTIFIERS>), and is not related to this pragma.
-The C<charnames> pragma supports arguments C<:full>, C<:short>, script
-names and customized aliases. If C<:full> is present, for expansion of
+The C<charnames> pragma supports arguments C<:full>, C<:loose>, C<:short>,
+script names and L<customized aliases|/CUSTOM ALIASES>.
+
+If C<:full> is present, for expansion of
C<\N{I<CHARNAME>}>, the string I<CHARNAME> is first looked up in the list of
-standard Unicode character names. If C<:short> is present, and
+standard Unicode character names.
+
+C<:loose> is a variant of C<:full> which allows I<CHARNAME> to be less
+precisely specified. Details are in L</LOOSE MATCHES>.
+
+If C<:short> is present, and
I<CHARNAME> has the form C<I<SCRIPT>:I<CNAME>>, then I<CNAME> is looked up
-as a letter in script I<SCRIPT>. If C<use charnames> is used
+as a letter in script I<SCRIPT>, as described in the next paragraph.
+Or, if C<use charnames> is used
with script name arguments, then for C<\N{I<CHARNAME>}> the name
I<CHARNAME> is looked up as a letter in the given scripts (in the
specified order). Customized aliases can override these, and are explained in
L</CUSTOM ALIASES>.
-For lookup of I<CHARNAME> inside a given script I<SCRIPTNAME>
-this pragma looks for the names
+For lookup of I<CHARNAME> inside a given script I<SCRIPTNAME>,
+this pragma looks in the table of standard Unicode names for the names
SCRIPTNAME CAPITAL LETTER CHARNAME
SCRIPTNAME SMALL LETTER CHARNAME
SCRIPTNAME LETTER CHARNAME
-in the table of standard Unicode names. If I<CHARNAME> is lowercase,
+If I<CHARNAME> is all lowercase,
then the C<CAPITAL> variant is ignored, otherwise the C<SMALL> variant
-is ignored.
+is ignored, and both I<CHARNAME> and I<SCRIPTNAME> are converted to all
+uppercase for look-up. Other than that, both of them follow L<loose|/LOOSE
+MATCHES> rules if C<:loose> is also specified; strict otherwise.
Note that C<\N{...}> is compile-time; it's a special form of string
constant used inside double-quotish strings; this means that you cannot
@@ -1070,14 +217,11 @@
functionality, use
L<charnames::string_vianame()|/charnames::string_vianame(I<name>)>.
-For the C0 and C1 control characters (U+0000..U+001F, U+0080..U+009F)
-there are no official Unicode names but you can use instead the ISO 6429
-names (LINE FEED, ESCAPE, and so forth, and their abbreviations, LF,
-ESC, ...). In Unicode 3.2 (as of Perl 5.8) some naming changes took
-place, and ISO 6429 was updated, see L</ALIASES>.
+Note, starting in Perl 5.18, the name C<BELL> refers to the Unicode character
+U+1F514, instead of the traditional U+0007. For the latter, use C<ALERT>
+or C<BEL>.
-If the input name is unknown, C<\N{NAME}> raises a warning and
-substitutes the Unicode REPLACEMENT CHARACTER (U+FFFD).
+It is a syntax error to use C<\N{NAME}> where C<NAME> is unknown.
For C<\N{NAME}>, it is a fatal error if C<use bytes> is in effect and the
input name is that of a character that won't fit into a byte (i.e., whose
@@ -1087,107 +231,44 @@
C<S<\N{U+I<code point>}>> will automatically have Unicode semantics (see
L<perlunicode/Byte and Character Semantics>).
-=head1 ALIASES
+=head1 LOOSE MATCHES
-A few aliases have been defined for convenience: instead of having
-to use the official names
+By specifying C<:loose>, Unicode's L<loose character name
+matching|http://www.unicode.org/reports/tr44#Matching_Rules> rules are
+selected instead of the strict exact match used otherwise.
+That means that I<CHARNAME> doesn't have to be so precisely specified.
+Upper/lower case doesn't matter (except with scripts as mentioned above), nor
+do any underscores, and the only hyphens that matter are those at the
+beginning or end of a word in the name (with one exception: the hyphen in
+U+1180 C<HANGUL JUNGSEONG O-E> does matter).
+Also, blanks not adjacent to hyphens don't matter.
+The official Unicode names are quite variable as to where they use hyphens
+versus spaces to separate word-like units, and this option allows you to not
+have to care as much.
+The reason non-medial hyphens matter is because of cases like
+U+0F60 C<TIBETAN LETTER -A> versus U+0F68 C<TIBETAN LETTER A>.
+The hyphen here is significant, as is the space before it, and so both must be
+included.
- LINE FEED (LF)
- FORM FEED (FF)
- CARRIAGE RETURN (CR)
- NEXT LINE (NEL)
+C<:loose> slows down look-ups by a factor of 2 to 3 versus
+C<:full>, but the trade-off may be worth it to you. Each individual look-up
+takes very little time, and the results are cached, so the speed difference
+would become a factor only in programs that do look-ups of many different
+spellings, and probably only when those look-ups are through C<vianame()> and
+C<string_vianame()>, since C<\N{...}> look-ups are done at compile time.
-(yes, with parentheses), one can use
+=head1 ALIASES
- LINE FEED
- FORM FEED
- CARRIAGE RETURN
- NEXT LINE
- LF
- FF
- CR
- NEL
+Starting in Unicode 6.1 and Perl v5.16, Unicode defines many abbreviations and
+names that were formerly Perl extensions, and some additional ones that Perl
+did not previously accept. The list is getting too long to reproduce here,
+but you can get the complete list from the Unicode web site:
+L<http://www.unicode.org/Public/UNIDATA/NameAliases.txt>.
-All the other standard abbreviations for the controls, such as C<ACK> for
-C<ACKNOWLEDGE> also can be used.
+Earlier versions of Perl accepted almost all the 6.1 names. These were most
+extensively documented in the v5.14 version of this pod:
+L<http://perldoc.perl.org/5.14.0/charnames.html#ALIASES>.
-One can also use
-
- BYTE ORDER MARK
- BOM
-
-and these abbreviations
-
- Abbreviation Full Name
-
- CGJ COMBINING GRAPHEME JOINER
- FVS1 MONGOLIAN FREE VARIATION SELECTOR ONE
- FVS2 MONGOLIAN FREE VARIATION SELECTOR TWO
- FVS3 MONGOLIAN FREE VARIATION SELECTOR THREE
- LRE LEFT-TO-RIGHT EMBEDDING
- LRM LEFT-TO-RIGHT MARK
- LRO LEFT-TO-RIGHT OVERRIDE
- MMSP MEDIUM MATHEMATICAL SPACE
- MVS MONGOLIAN VOWEL SEPARATOR
- NBSP NO-BREAK SPACE
- NNBSP NARROW NO-BREAK SPACE
- PDF POP DIRECTIONAL FORMATTING
- RLE RIGHT-TO-LEFT EMBEDDING
- RLM RIGHT-TO-LEFT MARK
- RLO RIGHT-TO-LEFT OVERRIDE
- SHY SOFT HYPHEN
- VS1 VARIATION SELECTOR-1
- .
- .
- .
- VS256 VARIATION SELECTOR-256
- WJ WORD JOINER
- ZWJ ZERO WIDTH JOINER
- ZWNJ ZERO WIDTH NON-JOINER
- ZWSP ZERO WIDTH SPACE
-
-For backward compatibility one can use the old names for
-certain C0 and C1 controls
-
- old new
-
- FILE SEPARATOR INFORMATION SEPARATOR FOUR
- GROUP SEPARATOR INFORMATION SEPARATOR THREE
- HORIZONTAL TABULATION CHARACTER TABULATION
- HORIZONTAL TABULATION SET CHARACTER TABULATION SET
- HORIZONTAL TABULATION WITH JUSTIFICATION CHARACTER TABULATION
- WITH JUSTIFICATION
- PARTIAL LINE DOWN PARTIAL LINE FORWARD
- PARTIAL LINE UP PARTIAL LINE BACKWARD
- RECORD SEPARATOR INFORMATION SEPARATOR TWO
- REVERSE INDEX REVERSE LINE FEED
- UNIT SEPARATOR INFORMATION SEPARATOR ONE
- VERTICAL TABULATION LINE TABULATION
- VERTICAL TABULATION SET LINE TABULATION SET
-
-but the old names in addition to giving the character
-will also give a warning about being deprecated.
-
-And finally, certain published variants are usable, including some for
-controls that have no Unicode names:
-
- name character
-
- END OF PROTECTED AREA END OF GUARDED AREA, U+0097
- HIGH OCTET PRESET U+0081
- HOP U+0081
- IND U+0084
- INDEX U+0084
- PAD U+0080
- PADDING CHARACTER U+0080
- PRIVATE USE 1 PRIVATE USE ONE, U+0091
- PRIVATE USE 2 PRIVATE USE TWO, U+0092
- SGC U+0099
- SINGLE GRAPHIC CHARACTER INTRODUCER U+0099
- SINGLE-SHIFT 2 SINGLE SHIFT TWO, U+008E
- SINGLE-SHIFT 3 SINGLE SHIFT THREE, U+008F
- START OF PROTECTED AREA START OF GUARDED AREA, U+0096
-
=head1 CUSTOM ALIASES
You can add customized aliases to standard (C<:full>) Unicode naming
@@ -1195,15 +276,22 @@
you're twisted enough, you can change C<"\N{LATIN CAPITAL LETTER A}"> to
mean C<"B">, etc.
-Note that an alias should not be something that is a legal curly
-brace-enclosed quantifier (see L<perlreref/QUANTIFIERS>). For example
-C<\N{123}> means to match 123 non-newline characters, and is not treated as a
-charnames alias. Aliases are discouraged from beginning with anything
-other than an alphabetic character and from containing anything other
-than alphanumerics, spaces, dashes, parentheses, and underscores.
-Currently they must be ASCII.
+Aliases must begin with a character that is alphabetic. After that, each may
+contain any combination of word (C<\w>) characters, SPACE (U+0020),
+HYPHEN-MINUS (U+002D), LEFT PARENTHESIS (U+0028), RIGHT PARENTHESIS (U+0029),
+and NO-BREAK SPACE (U+00A0). These last three should never have been allowed
+in names, and are retained for backwards compatibility only; they may be
+deprecated and removed in future releases of Perl, so don't use them for new
+names. (More precisely, the first character of a name you specify must be
+something that matches all of C<\p{ID_Start}>, C<\p{Alphabetic}>, and
+C<\p{Gc=Letter}>. This makes sure it is what any reasonable person would view
+as an alphabetic character. And, the continuation characters that match C<\w>
+must also match C<\p{ID_Continue}>.) Starting with Perl v5.18, any Unicode
+characters meeting the above criteria may be used; prior to that only
+Latin1-range characters were acceptable.
-An alias can map to either an official Unicode character name or to a
+An alias can map to either an official Unicode character name (not a loose
+matched name) or to a
numeric code point (ordinal). The latter is useful for assigning names
to code points in Unicode private use areas such as U+E800 through
U+F8FF.
@@ -1245,10 +333,46 @@
use charnames ":full", ":alias" => "pro";
-Also, both these methods currently allow only a single character to be named.
+C<":loose"> has no effect with these. Input names must match exactly, using
+C<":full"> rules.
+
+Also, both these methods currently allow only single characters to be named.
To name a sequence of characters, use a
L<custom translator|/CUSTOM TRANSLATORS> (described below).
+=head1 charnames::string_vianame(I<name>)
+
+This is a runtime equivalent to C<\N{...}>. I<name> can be any expression
+that evaluates to a name accepted by C<\N{...}> under the L<C<:full>
+option|/DESCRIPTION> to C<charnames>. In addition, any other options for the
+controlling C<"use charnames"> in the same scope apply, like C<:loose> or any
+L<script list, C<:short> option|/DESCRIPTION>, or L<custom aliases|/CUSTOM
+ALIASES> you may have defined.
+
+The only differences are due to the fact that C<string_vianame> is run-time
+and C<\N{}> is compile time. You can't interpolate inside a C<\N{}>, (so
+C<\N{$variable}> doesn't work); and if the input name is unknown,
+C<string_vianame> returns C<undef> instead of it being a syntax error.
+
+=head1 charnames::vianame(I<name>)
+
+This is similar to C<string_vianame>. The main difference is that under most
+circumstances, C<vianame> returns an ordinal code
+point, whereas C<string_vianame> returns a string. For example,
+
+ printf "U+%04X", charnames::vianame("FOUR TEARDROP-SPOKED ASTERISK");
+
+prints "U+2722".
+
+This leads to the other two differences. Since a single code point is
+returned, the function can't handle named character sequences, as these are
+composed of multiple characters (it returns C<undef> for these. And, the code
+point can be that of any
+character, even ones that aren't legal under the C<S<use bytes>> pragma,
+
+See L</BUGS> for the circumstances in which the behavior differs
+from that described above.
+
=head1 charnames::viacode(I<code>)
Returns the full name of the character indicated by the numeric code.
@@ -1258,57 +382,67 @@
prints "FOUR TEARDROP-SPOKED ASTERISK".
-The name returned is the official name for the code point, if
-available; otherwise your custom alias for it. This means that your
-alias will only be returned for code points that don't have an official
-Unicode name (nor Unicode version 1 name), such as private use code
-points, and the 4 control characters U+0080, U+0081, U+0084, and U+0099.
+The name returned is the "best" (defined below) official name or alias
+for the code point, if
+available; otherwise your custom alias for it, if defined; otherwise C<undef>.
+This means that your alias will only be returned for code points that don't
+have an official Unicode name (nor alias) such as private use code points.
+
If you define more than one name for the code point, it is indeterminate
which one will be returned.
-The function returns C<undef> if no name is known for the code point.
-In Unicode the proper name of these is the empty string, which
+As mentioned, the function returns C<undef> if no name is known for the code
+point. In Unicode the proper name for these is the empty string, which
C<undef> stringifies to. (If you ask for a code point past the legal
Unicode maximum of U+10FFFF that you haven't assigned an alias to, you
get C<undef> plus a warning.)
-The input number must be a non-negative integer or a string beginning
+The input number must be a non-negative integer, or a string beginning
with C<"U+"> or C<"0x"> with the remainder considered to be a
hexadecimal integer. A literal numeric constant must be unsigned; it
will be interpreted as hex if it has a leading zero or contains
non-decimal hex digits; otherwise it will be interpreted as decimal.
-Notice that the name returned for of U+FEFF is "ZERO WIDTH NO-BREAK
-SPACE", not "BYTE ORDER MARK".
+As mentioned above under L</ALIASES>, Unicode 6.1 defines extra names
+(synonyms or aliases) for some code points, most of which were already
+available as Perl extensions. All these are accepted by C<\N{...}> and the
+other functions in this module, but C<viacode> has to choose which one
+name to return for a given input code point, so it returns the "best" name.
+To understand how this works, it is helpful to know more about the Unicode
+name properties. All code points actually have only a single name, which
+(starting in Unicode 2.0) can never change once a character has been assigned
+to the code point. But mistakes have been made in assigning names, for
+example sometimes a clerical error was made during the publishing of the
+Standard which caused words to be misspelled, and there was no way to correct
+those. The Name_Alias property was eventually created to handle these
+situations. If a name was wrong, a corrected synonym would be published for
+it, using Name_Alias. C<viacode> will return that corrected synonym as the
+"best" name for a code point. (It is even possible, though it hasn't happened
+yet, that the correction itself will need to be corrected, and so another
+Name_Alias can be created for that code point; C<viacode> will return the
+most recent correction.)
-=head1 charnames::string_vianame(I<name>)
+The Unicode name for each of the control characters (such as LINE FEED) is the
+empty string. However almost all had names assigned by other standards, such
+as the ASCII Standard, or were in common use. C<viacode> returns these names
+as the "best" ones available. Unicode 6.1 has created Name_Aliases for each
+of them, including alternate names, like NEW LINE. C<viacode> uses the
+original name, "LINE FEED" in preference to the alternate. Similarly the
+name returned for U+FEFF is "ZERO WIDTH NO-BREAK SPACE", not "BYTE ORDER
+MARK".
-This is a runtime equivalent to C<\N{...}>. I<name> can be any expression
-that evaluates to a name accepted by C<\N{...}> under the L<C<:full>
-option|/DESCRIPTION> to C<charnames>. In addition, any other options for the
-controlling C<"use charnames"> in the same scope apply, like any L<script
-list, C<:short> option|/DESCRIPTION>, or L<custom aliases|/CUSTOM ALIASES> you
-may have defined.
+Until Unicode 6.1, the 4 control characters U+0080, U+0081, U+0084, and U+0099
+did not have names nor aliases.
+To preserve backwards compatibility, any alias you define for these code
+points will be returned by this function, in preference to the official name.
-The only difference is that if the input name is unknown, C<string_vianame>
-returns C<undef> instead of the REPLACEMENT CHARACTER and does not raise a
-warning message.
+Some code points also have abbreviated names, such as "LF" or "NL".
+C<viacode> never returns these.
-=head1 charnames::vianame(I<name>)
+Because a name correction may be added in future Unicode releases, the name
+that C<viacode> returns may change as a result. This is a rare event, but it
+does happen.
-This is similar to C<string_vianame>. The main difference is that under most
-circumstances (see L</BUGS> for the others), vianame returns an ordinal code
-point, whereas C<string_vianame> returns a string. For example,
-
- printf "U+%04X", charnames::vianame("FOUR TEARDROP-SPOKED ASTERISK");
-
-prints "U+2722".
-
-This leads to the other two differences. Since a single code point is
-returned, the function can't handle named character sequences, as these are
-composed of multiple characters. And, the code point can be that of any
-character, even ones that aren't legal under the C<S<use bytes>> pragma,
-
=head1 CUSTOM TRANSLATORS
The mechanism of translation of C<\N{...}> escapes is general and not
@@ -1323,7 +457,11 @@
Here translator() is a subroutine which takes I<CHARNAME> as an
argument, and returns text to insert into the string instead of the
-C<\N{I<CHARNAME>}> escape. Since the text to insert should be different
+C<\N{I<CHARNAME>}> escape.
+
+This is the only way you can create a custom named sequence of code points.
+
+Since the text to insert should be different
in C<bytes> mode and out of it, the function should check the current
state of C<bytes>-flag as in:
@@ -1339,20 +477,16 @@
See L</CUSTOM ALIASES> above for restrictions on I<CHARNAME>.
-Of course, C<vianame> and C<viacode> would need to be overridden as
-well.
+Of course, C<vianame>, C<viacode>, and C<string_vianame> would need to be
+overridden as well.
=head1 BUGS
-vianame normally returns an ordinal code point, but when the input name is of
+vianame() normally returns an ordinal code point, but when the input name is of
the form C<U+...>, it returns a chr instead. In this case, if C<use bytes> is
in effect and the character won't fit into a byte, it returns C<undef> and
raises a warning.
-Names must be ASCII characters only, which means that you are out of luck if
-you want to create aliases in a language where some or all the characters of
-the desired aliases are non-ASCII.
-
Since evaluation of the translation function (see L</CUSTOM
TRANSLATORS>) happens in the middle of compilation (of a string
literal), the translation function should not do any C<eval>s or
Property changes on: trunk/contrib/perl/lib/charnames.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/charnames.t
===================================================================
--- trunk/contrib/perl/lib/charnames.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/charnames.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,7 +1,7 @@
#!./perl
use strict;
-# Test charnames.pm. If $ENV{PERL_RUN_SLOW_TESTS} is unset or 0, a random
+# Test charnames.pm. If $ENV{PERL_RUN_SLOW_TESTS} is unset or 0, a random
# selection of names is tested, a higher percentage of regular names is tested
# than algorithmically-determined names.
@@ -29,10 +29,9 @@
# ---- For the alias extensions
require "../t/lib/common.pl";
-use charnames ':full';
+is("Here\N{EXCLAMATION MARK}?", "Here!?", "Basic sanity, autoload of :full upon \\N");
+is("\N{latin: Q}", "Q", "autoload of :short upon \\N");
-is("Here\N{EXCLAMATION MARK}?", "Here!?");
-
{
use bytes; # TEST -utf8 can switch utf8 on
@@ -42,8 +41,8 @@
1
EOE
- like($@, "above 0xFF");
- ok(! defined $res);
+ like($@, "above 0xFF", "Verify get warning for \\N{above ff} under 'use bytes' with :full");
+ ok(! defined $res, "... and result is undefined");
$res = eval <<'EOE';
use charnames 'cyrillic';
@@ -50,24 +49,26 @@
"Here: \N{Be}!";
1
EOE
- like($@, "CYRILLIC CAPITAL LETTER BE.*above 0xFF");
+ like($@, "CYRILLIC CAPITAL LETTER BE.*above 0xFF", "Verify get warning under 'use bytes' with explicit script");
+ ok(! defined $res, "... and result is undefined");
$res = eval <<'EOE';
use charnames ':full', ":alias" => { BOM => "LATIN SMALL LETTER B" };
"\N{BOM}";
EOE
- is ($@, "");
+ is ($@, "", "Verify that there is no warning for \\N{below 256} under 'use bytes'");
is ($res, 'b', "Verify that can redefine a standard alias");
}
{
- use charnames ':full', ":alias" => { mychar1 => "0xE8000",
- mychar2 => 983040, # U+F0000
- mychar3 => "U+100000",
- myctrl => 0x80,
- mylarge => "U+111000",
- };
+ use charnames ":alias" => { mychar1 => "0xE8000",
+ mychar2 => 983040, # U+F0000
+ mychar3 => "U+100000",
+ myctrl => 0x80,
+ mylarge => "U+111000",
+ };
+ is ("\N{PILE OF POO}", chr(0x1F4A9), "Verify :alias alone implies :full");
is ("\N{mychar1}", chr(0xE8000), "Verify that can define hex alias");
is (charnames::viacode(0xE8000), "mychar1", "And that can get the alias back");
is ("\N{mychar2}", chr(0xF0000), "Verify that can define decimal alias");
@@ -104,37 +105,78 @@
unpack"U0a*", shift;
}
+sub get_loose_name ($) { # Modify name to stress the loose tests.
+
+ # First, all lower case,
+ my $loose_name = lc shift;
+
+ # Then squeeze out all the blanks not adjacent to hyphens, but make the
+ # spaces that are adjacent to hypens into two, to make sure the code isn't
+ # looking for just one when looking for non-medial hyphens.
+ $loose_name =~ s/ (?<! - ) \ + (?! - )//gx;
+ $loose_name =~ s/ / /g;
+
+ # Similarly, double the hyphens
+ $loose_name =~ s/-/--/g;
+
+ # And convert ABC into "A B-C" to add medial hyphens and spaces. Probably
+ # better to do this randomly, but think this is sufficient.
+ $loose_name =~ s/ ([^-\s]) ([^-\s]) ([^-\s]) /$1 $2-$3/gx;
+
+ return $loose_name
+}
+
sub test_vianame ($$$) {
- # Run the vianame tests on a code point
+ # Run the vianame tests on a code point, both loose and full
+ my $all_pass = 1;
+
+ # $i is the code point in decimal; $hex in hexadecimal; $name is
+ # character name to test
my ($i, $hex, $name) = @_;
- # Half the time use vianame, and half string_vianame
- return is(charnames::vianame($name), $i, "Verify vianame(\"$name\") is 0x$hex") if rand() < .5;
- return is(charnames::string_vianame($name), chr($i), "Verify string_vianame(\"$name\") is chr(0x$hex)");
+ # Get a copy of the name modified to stress the loose tests.
+ my $loose_name = get_loose_name($name);
+
+ # Switch loose and full in vianame vs string_vianame half the time
+ if (rand() < .5) {
+ use charnames ":full";
+ $all_pass &= is(charnames::vianame($name), $i, "Verify vianame(\"$name\") is 0x$hex");
+ use charnames ":loose";
+ $all_pass &= is(charnames::string_vianame($loose_name), chr($i), "Verify string_vianame(\"$loose_name\") is chr(0x$hex)");
+ }
+ else {
+ use charnames ":loose";
+ $all_pass &= is(charnames::vianame($loose_name), $i, "Verify vianame(\"$loose_name\") is 0x$hex");
+ use charnames ":full";
+ $all_pass &= is(charnames::string_vianame($name), chr($i), "Verify string_vianame(\"$name\") is chr(0x$hex)");
+ }
+ return $all_pass;
}
{
use charnames ':full';
- is(to_bytes("\N{CYRILLIC SMALL LETTER BE}"), $encoded_be);
+ is(to_bytes("\N{CYRILLIC SMALL LETTER BE}"), $encoded_be,
+ 'Verify \N{CYRILLIC SMALL LETTER BE} is the correct UTF8');
use charnames qw(cyrillic greek :short);
is(to_bytes("\N{be},\N{alpha},\N{hebrew:bet}"),
- "$encoded_be,$encoded_alpha,$encoded_bet");
+ "$encoded_be,$encoded_alpha,$encoded_bet",
+ 'Verify using scripts gives the correct UTF8');
}
{
use charnames ':full';
- is("\x{263a}", "\N{WHITE SMILING FACE}");
- cmp_ok(length("\x{263a}"), '==', 1);
- cmp_ok(length("\N{WHITE SMILING FACE}"), '==', 1);
- is(sprintf("%vx", "\x{263a}"), "263a");
- is(sprintf("%vx", "\N{WHITE SMILING FACE}"), "263a");
- is(sprintf("%vx", "\xFF\N{WHITE SMILING FACE}"), "ff.263a");
- is(sprintf("%vx", "\x{ff}\N{WHITE SMILING FACE}"), "ff.263a");
+ is("\x{263a}", "\N{WHITE SMILING FACE}", 'Verify "\x{263a}" eq "\N{WHITE SMILING FACE}"');
+ cmp_ok(length("\x{263a}"), '==', 1, 'Verify length of \x{263a} is 1');
+ cmp_ok(length("\N{WHITE SMILING FACE}"), '==', 1, '... as is the length of \N{WHITE SMILING FACE}');
+ is(sprintf("%vx", "\x{263a}"), "263a", 'Verify sprintf("%vx", "\x{263a}") eq "263a"');
+ is(sprintf("%vx", "\N{WHITE SMILING FACE}"), "263a", 'Verify sprintf("%vx", "\N{WHITE SMILING FACE}") eq "263a"');
+ is(sprintf("%vx", "\xFF\N{WHITE SMILING FACE}"), "ff.263a", 'Verify sprintf("%vx" eq "\xFF\N{WHITE SMILING FACE}"), "ff.263a"');
+ is(sprintf("%vx", "\x{ff}\N{WHITE SMILING FACE}"), "ff.263a", 'Verify sprintf("%vx", "\x{ff}\N{WHITE SMILING FACE}") eq "ff.263a"');
}
{
@@ -144,19 +186,20 @@
my $x = "\x{221b}";
my $named = "\N{CUBE ROOT}";
- cmp_ok(ord($x), '==', ord($named));
+ cmp_ok(ord($x), '==', ord($named), 'Verify ord("\x{221b}") == ord("\N{CUBE ROOT}"');
}
{
use charnames qw(:full);
use utf8;
- is("\x{100}\N{CENT SIGN}", "\x{100}"."\N{CENT SIGN}");
+ is("\x{100}\N{CENT SIGN}", "\x{100}"."\N{CENT SIGN}", 'Verify "\x{100}\N{CENT SIGN}" eq "\x{100}"."\N{CENT SIGN}"');
}
{
use charnames ':full';
- is(to_bytes("\N{DESERET SMALL LETTER ENG}"), $encoded_deseng);
+ is(to_bytes("\N{DESERET SMALL LETTER ENG}"), $encoded_deseng,
+ 'Verify bytes of "\N{DESERET SMALL LETTER ENG}" are correct');
}
{
@@ -166,17 +209,18 @@
use charnames ':full';
my $text = "\N{LATIN CAPITAL LETTER A WITH DIAERESIS}";
- is($text, latin1_to_native("\xc4"));
+ is($text, latin1_to_native("\xc4"), 'Verify \N{} returns correct string under "no utf8"');
# I'm not sure that this tests anything different from the above.
- cmp_ok(ord($text), '==', ord(latin1_to_native("\xc4")));
+ cmp_ok(ord($text), '==', ord(latin1_to_native("\xc4")), '... and ords are ok');
}
{
- is(charnames::viacode(0x1234), "ETHIOPIC SYLLABLE SEE");
+ is(charnames::viacode(0x1234), "ETHIOPIC SYLLABLE SEE",
+ 'Verify viacode(0x1234) eq "ETHIOPIC SYLLABLE SEE"');
# No name
- ok(! defined charnames::viacode(0xFFFF));
+ ok(! defined charnames::viacode(0xFFFF), 'Verify \x{FFFF} has no name');
}
{
@@ -215,9 +259,11 @@
{
# check that caching at least hasn't broken anything
- is(charnames::viacode(0x1234), "ETHIOPIC SYLLABLE SEE");
+ is(charnames::viacode(0x1234), "ETHIOPIC SYLLABLE SEE",
+ 'Verify caching');
- is(sprintf("%04X", charnames::vianame("GOTHIC LETTER AHSA")), "10330");
+ is(sprintf("%04X", charnames::vianame("GOTHIC LETTER AHSA")), "10330",
+ 'More caching');
}
@@ -225,439 +271,472 @@
# NamedSequences.txt
is("\N{TAMIL CONSONANT K}", charnames::string_vianame("TAMIL CONSONANT K"), "Verify \\N{TAMIL CONSONANT K} eq charnames::vianame(\"TAMIL CONSONANT K\")");
-is("\N{CHARACTER TABULATION}", "\t");
+is("\N{CHARACTER TABULATION}", "\t", 'Verify "\N{CHARACTER TABULATION}" eq "\t"');
-is("\N{ESCAPE}", "\e");
-is("\N{NULL}", "\c@");
-is("\N{LINE FEED (LF)}", "\n");
-is("\N{LINE FEED}", "\n");
-is("\N{LF}", "\n");
+is("\N{ESCAPE}", "\e", 'Verify "\N{ESCAPE}" eq "\e"');
+is("\N{NULL}", "\c@", 'Verify "\N{NULL}" eq "\c@"');
+is("\N{LINE FEED (LF)}", "\n", 'Verify "\N{LINE FEED (LF)}" eq "\n"');
+is("\N{LINE FEED}", "\n", 'Verify "\N{LINE FEED}" eq "\n"');
+is("\N{LF}", "\n", 'Verify "\N{LF}" eq "\n"');
my $nel = latin1_to_native("\x85");
$nel = qr/^$nel$/;
-like("\N{NEXT LINE (NEL)}", $nel);
-like("\N{NEXT LINE}", $nel);
-like("\N{NEL}", $nel);
-is("\N{BYTE ORDER MARK}", chr(0xFEFF));
-is("\N{BOM}", chr(0xFEFF));
+like("\N{NEXT LINE (NEL)}", $nel, 'Verify "\N{NEXT LINE (NEL)}" is correct');
+like("\N{NEXT LINE}", $nel, 'Verify "\N{NEXT LINE)" is correct');
+like("\N{NEL}", $nel, 'Verify "\N{NEL}" is correct');
+is("\N{BYTE ORDER MARK}", chr(0xFEFF), 'Verify "\N{BYTE ORDER MARK}" is correct');
+is("\N{BOM}", chr(0xFEFF), 'Verify "\N{BOM}" is correct');
{
use warnings 'deprecated';
- is("\N{HORIZONTAL TABULATION}", "\t");
+ is("\N{HORIZONTAL TABULATION}", "\t", 'Verify "\N{HORIZONTAL TABULATION}" eq "\t"');
- ok(grep { /"HORIZONTAL TABULATION" is deprecated.*CHARACTER TABULATION/ } @WARN);
+ my $ok = ! grep { /"HORIZONTAL TABULATION" is deprecated.*"CHARACTER TABULATION"/ } @WARN;
+ ok($ok, '... and doesnt give deprecated warning');
- # XXX These tests should be changed for 5.16, when we convert BELL to the
- # Unicode version.
- is("\N{BELL}", "\a");
- ok((grep{ /"BELL" is deprecated.*ALERT/ } @WARN), 'BELL is deprecated');
+ if ($^V lt v5.17.0) {
+ is("\N{BELL}", "\a", 'Verify "\N{BELL}" eq "\a"');
+ my $ok = grep { /"BELL" is deprecated.*"ALERT"/ } @WARN;
+ ok($ok, '... and that gives correct deprecated warning');
+ }
no warnings 'deprecated';
- is("\N{VERTICAL TABULATION}", "\013");
+ is("\N{VERTICAL TABULATION}", "\013", 'Verify "\N{VERTICAL TABULATION}" eq "\013"');
- ok(! grep { /"VERTICAL TABULATION" is deprecated/ } @WARN);
+ my $nok = grep { /"VERTICAL TABULATION" is deprecated/ } @WARN;
+ ok(! $nok,
+ '... and doesnt give deprecated warning under no warnings "deprecated"');
}
-is(charnames::viacode(0xFEFF), "ZERO WIDTH NO-BREAK SPACE");
+is(charnames::viacode(0xFEFF), "ZERO WIDTH NO-BREAK SPACE",
+ 'Verify viacode(0xFEFF) is correct');
+# These test that the changes to these in 6.1 are recognized. (The double
+# test of using viacode and vianame is less than optimal as two errors could
+# cancel each other out, but later each is tested individually, and this
+# sidesteps and EBCDIC issues.
+is(charnames::viacode(charnames::vianame("CR")), "CARRIAGE RETURN",
+ 'Verify viacode(vianame("CR")) is "CARRIAGE RETURN"');
+is(charnames::viacode(charnames::vianame("LF")), "LINE FEED",
+ 'Verify viacode(vianame("LF")) is "LINE FEED"');
+is(charnames::viacode(charnames::vianame("FF")), "FORM FEED",
+ 'Verify viacode(vianame("FF")) is "FORM FEED"');
+is(charnames::viacode(charnames::vianame("NEL")), "NEXT LINE",
+ 'Verify viacode(vianame("NEL")) is "NEXT LINE"');
+
{
use warnings;
- cmp_ok(ord("\N{BOM}"), '==', 0xFEFF);
+ cmp_ok(ord("\N{BOM}"), '==', 0xFEFF, 'Verify \N{BOM} is correct');
}
-cmp_ok(ord("\N{ZWNJ}"), '==', 0x200C);
+cmp_ok(ord("\N{ZWNJ}"), '==', 0x200C, 'Verify \N{ZWNJ} is correct');
-cmp_ok(ord("\N{ZWJ}"), '==', 0x200D);
+cmp_ok(ord("\N{ZWJ}"), '==', 0x200D, 'Verify \N{ZWJ} is correct');
-is("\N{U+263A}", "\N{WHITE SMILING FACE}");
+is("\N{U+263A}", "\N{WHITE SMILING FACE}", 'Verify "\N{U+263A}" eq "\N{WHITE SMILING FACE}"');
{
- cmp_ok( 0x3093, '==', charnames::vianame("HIRAGANA LETTER N"));
- cmp_ok(0x0397, '==', charnames::vianame("GREEK CAPITAL LETTER ETA"));
+ cmp_ok( 0x3093, '==', charnames::vianame("HIRAGANA LETTER N"),
+ 'Verify vianame("HIRAGANA LETTER N") is correct');
+ cmp_ok(0x0397, '==', charnames::vianame("GREEK CAPITAL LETTER ETA"),
+ 'Verify vianame("GREEK CAPITAL LETTER ETA") is correct');
}
-ok(! defined charnames::viacode(0x110000));
-ok(! grep { /you asked for U+110000/ } @WARN);
+ok(! defined charnames::viacode(0x110000),
+ 'Verify viacode(above unicode) is undefined');
+ok((grep { /\Qyou asked for U+110000/ } @WARN), '... and gives warning');
-is(charnames::viacode(0), "NULL");
-is(charnames::viacode("BE"), "VULGAR FRACTION THREE QUARTERS");
-is(charnames::viacode("U+00000000000FEED"), "ARABIC LETTER WAW ISOLATED FORM");
+is(charnames::viacode(0), "NULL", 'Verify charnames::viacode(0) eq "NULL"');
+is(charnames::viacode("BE"), "VULGAR FRACTION THREE QUARTERS", 'Verify charnames::viacode("BE") eq "VULGAR FRACTION THREE QUARTERS"');
+is(charnames::viacode("U+00000000000FEED"), "ARABIC LETTER WAW ISOLATED FORM", 'Verify charnames::viacode("U+00000000000FEED") eq "ARABIC LETTER WAW ISOLATED FORM"');
{
no warnings 'deprecated';
- is("\N{LINE FEED}", "\N{LINE FEED (LF)}");
- is("\N{FORM FEED}", "\N{FORM FEED (FF)}");
- is("\N{CARRIAGE RETURN}", "\N{CARRIAGE RETURN (CR)}");
- is("\N{NEXT LINE}", "\N{NEXT LINE (NEL)}");
- is("\N{NUL}", "\N{NULL}");
- is("\N{SOH}", "\N{START OF HEADING}");
- is("\N{STX}", "\N{START OF TEXT}");
- is("\N{ETX}", "\N{END OF TEXT}");
- is("\N{EOT}", "\N{END OF TRANSMISSION}");
- is("\N{ENQ}", "\N{ENQUIRY}");
- is("\N{ACK}", "\N{ACKNOWLEDGE}");
- is("\N{BEL}", "\N{BELL}");
- is("\N{BS}", "\N{BACKSPACE}");
- is("\N{HT}", "\N{HORIZONTAL TABULATION}");
- is("\N{LF}", "\N{LINE FEED (LF)}");
- is("\N{VT}", "\N{VERTICAL TABULATION}");
- is("\N{FF}", "\N{FORM FEED (FF)}");
- is("\N{CR}", "\N{CARRIAGE RETURN (CR)}");
- is("\N{SO}", "\N{SHIFT OUT}");
- is("\N{SI}", "\N{SHIFT IN}");
- is("\N{DLE}", "\N{DATA LINK ESCAPE}");
- is("\N{DC1}", "\N{DEVICE CONTROL ONE}");
- is("\N{DC2}", "\N{DEVICE CONTROL TWO}");
- is("\N{DC3}", "\N{DEVICE CONTROL THREE}");
- is("\N{DC4}", "\N{DEVICE CONTROL FOUR}");
- is("\N{NAK}", "\N{NEGATIVE ACKNOWLEDGE}");
- is("\N{SYN}", "\N{SYNCHRONOUS IDLE}");
- is("\N{ETB}", "\N{END OF TRANSMISSION BLOCK}");
- is("\N{CAN}", "\N{CANCEL}");
- is("\N{EOM}", "\N{END OF MEDIUM}");
- is("\N{SUB}", "\N{SUBSTITUTE}");
- is("\N{ESC}", "\N{ESCAPE}");
- is("\N{FS}", "\N{FILE SEPARATOR}");
- is("\N{GS}", "\N{GROUP SEPARATOR}");
- is("\N{RS}", "\N{RECORD SEPARATOR}");
- is("\N{US}", "\N{UNIT SEPARATOR}");
- is("\N{DEL}", "\N{DELETE}");
- is("\N{BPH}", "\N{BREAK PERMITTED HERE}");
- is("\N{NBH}", "\N{NO BREAK HERE}");
- is("\N{NEL}", "\N{NEXT LINE (NEL)}");
- is("\N{SSA}", "\N{START OF SELECTED AREA}");
- is("\N{ESA}", "\N{END OF SELECTED AREA}");
- is("\N{HTS}", "\N{CHARACTER TABULATION SET}");
- is("\N{HTJ}", "\N{CHARACTER TABULATION WITH JUSTIFICATION}");
- is("\N{VTS}", "\N{LINE TABULATION SET}");
- is("\N{PLD}", "\N{PARTIAL LINE FORWARD}");
- is("\N{PLU}", "\N{PARTIAL LINE BACKWARD}");
- is("\N{RI }", "\N{REVERSE LINE FEED}");
- is("\N{SS2}", "\N{SINGLE SHIFT TWO}");
- is("\N{SS3}", "\N{SINGLE SHIFT THREE}");
- is("\N{DCS}", "\N{DEVICE CONTROL STRING}");
- is("\N{PU1}", "\N{PRIVATE USE ONE}");
- is("\N{PU2}", "\N{PRIVATE USE TWO}");
- is("\N{STS}", "\N{SET TRANSMIT STATE}");
- is("\N{CCH}", "\N{CANCEL CHARACTER}");
- is("\N{MW }", "\N{MESSAGE WAITING}");
- is("\N{SPA}", "\N{START OF GUARDED AREA}");
- is("\N{EPA}", "\N{END OF GUARDED AREA}");
- is("\N{SOS}", "\N{START OF STRING}");
- is("\N{SCI}", "\N{SINGLE CHARACTER INTRODUCER}");
- is("\N{CSI}", "\N{CONTROL SEQUENCE INTRODUCER}");
- is("\N{ST }", "\N{STRING TERMINATOR}");
- is("\N{OSC}", "\N{OPERATING SYSTEM COMMAND}");
- is("\N{PM }", "\N{PRIVACY MESSAGE}");
- is("\N{APC}", "\N{APPLICATION PROGRAM COMMAND}");
- is("\N{PADDING CHARACTER}", "\N{PAD}");
- is("\N{HIGH OCTET PRESET}","\N{HOP}");
- is("\N{INDEX}", "\N{IND}");
- is("\N{SINGLE GRAPHIC CHARACTER INTRODUCER}", "\N{SGC}");
- is("\N{BOM}", "\N{BYTE ORDER MARK}");
- is("\N{CGJ}", "\N{COMBINING GRAPHEME JOINER}");
- is("\N{FVS1}", "\N{MONGOLIAN FREE VARIATION SELECTOR ONE}");
- is("\N{FVS2}", "\N{MONGOLIAN FREE VARIATION SELECTOR TWO}");
- is("\N{FVS3}", "\N{MONGOLIAN FREE VARIATION SELECTOR THREE}");
- is("\N{LRE}", "\N{LEFT-TO-RIGHT EMBEDDING}");
- is("\N{LRM}", "\N{LEFT-TO-RIGHT MARK}");
- is("\N{LRO}", "\N{LEFT-TO-RIGHT OVERRIDE}");
- is("\N{MMSP}", "\N{MEDIUM MATHEMATICAL SPACE}");
- is("\N{MVS}", "\N{MONGOLIAN VOWEL SEPARATOR}");
- is("\N{NBSP}", "\N{NO-BREAK SPACE}");
- is("\N{NNBSP}", "\N{NARROW NO-BREAK SPACE}");
- is("\N{PDF}", "\N{POP DIRECTIONAL FORMATTING}");
- is("\N{RLE}", "\N{RIGHT-TO-LEFT EMBEDDING}");
- is("\N{RLM}", "\N{RIGHT-TO-LEFT MARK}");
- is("\N{RLO}", "\N{RIGHT-TO-LEFT OVERRIDE}");
- is("\N{SHY}", "\N{SOFT HYPHEN}");
- is("\N{WJ}", "\N{WORD JOINER}");
- is("\N{ZWJ}", "\N{ZERO WIDTH JOINER}");
- is("\N{ZWNJ}", "\N{ZERO WIDTH NON-JOINER}");
- is("\N{ZWSP}", "\N{ZERO WIDTH SPACE}");
- is("\N{HORIZONTAL TABULATION}", "\N{CHARACTER TABULATION}");
- is("\N{VERTICAL TABULATION}", "\N{LINE TABULATION}");
- is("\N{FILE SEPARATOR}", "\N{INFORMATION SEPARATOR FOUR}");
- is("\N{GROUP SEPARATOR}", "\N{INFORMATION SEPARATOR THREE}");
- is("\N{RECORD SEPARATOR}", "\N{INFORMATION SEPARATOR TWO}");
- is("\N{UNIT SEPARATOR}", "\N{INFORMATION SEPARATOR ONE}");
- is("\N{HORIZONTAL TABULATION SET}", "\N{CHARACTER TABULATION SET}");
- is("\N{HORIZONTAL TABULATION WITH JUSTIFICATION}", "\N{CHARACTER TABULATION WITH JUSTIFICATION}");
- is("\N{PARTIAL LINE DOWN}", "\N{PARTIAL LINE FORWARD}");
- is("\N{PARTIAL LINE UP}", "\N{PARTIAL LINE BACKWARD}");
- is("\N{VERTICAL TABULATION SET}", "\N{LINE TABULATION SET}");
- is("\N{REVERSE INDEX}", "\N{REVERSE LINE FEED}");
- is("\N{SINGLE-SHIFT 2}", "\N{SINGLE SHIFT TWO}");
- is("\N{SINGLE-SHIFT 3}", "\N{SINGLE SHIFT THREE}");
- is("\N{PRIVATE USE 1}", "\N{PRIVATE USE ONE}");
- is("\N{PRIVATE USE 2}", "\N{PRIVATE USE TWO}");
- is("\N{START OF PROTECTED AREA}", "\N{START OF GUARDED AREA}");
- is("\N{END OF PROTECTED AREA}", "\N{END OF GUARDED AREA}");
- is("\N{VS1}", "\N{VARIATION SELECTOR-1}");
- is("\N{VS2}", "\N{VARIATION SELECTOR-2}");
- is("\N{VS3}", "\N{VARIATION SELECTOR-3}");
- is("\N{VS4}", "\N{VARIATION SELECTOR-4}");
- is("\N{VS5}", "\N{VARIATION SELECTOR-5}");
- is("\N{VS6}", "\N{VARIATION SELECTOR-6}");
- is("\N{VS7}", "\N{VARIATION SELECTOR-7}");
- is("\N{VS8}", "\N{VARIATION SELECTOR-8}");
- is("\N{VS9}", "\N{VARIATION SELECTOR-9}");
- is("\N{VS10}", "\N{VARIATION SELECTOR-10}");
- is("\N{VS11}", "\N{VARIATION SELECTOR-11}");
- is("\N{VS12}", "\N{VARIATION SELECTOR-12}");
- is("\N{VS13}", "\N{VARIATION SELECTOR-13}");
- is("\N{VS14}", "\N{VARIATION SELECTOR-14}");
- is("\N{VS15}", "\N{VARIATION SELECTOR-15}");
- is("\N{VS16}", "\N{VARIATION SELECTOR-16}");
- is("\N{VS17}", "\N{VARIATION SELECTOR-17}");
- is("\N{VS18}", "\N{VARIATION SELECTOR-18}");
- is("\N{VS19}", "\N{VARIATION SELECTOR-19}");
- is("\N{VS20}", "\N{VARIATION SELECTOR-20}");
- is("\N{VS21}", "\N{VARIATION SELECTOR-21}");
- is("\N{VS22}", "\N{VARIATION SELECTOR-22}");
- is("\N{VS23}", "\N{VARIATION SELECTOR-23}");
- is("\N{VS24}", "\N{VARIATION SELECTOR-24}");
- is("\N{VS25}", "\N{VARIATION SELECTOR-25}");
- is("\N{VS26}", "\N{VARIATION SELECTOR-26}");
- is("\N{VS27}", "\N{VARIATION SELECTOR-27}");
- is("\N{VS28}", "\N{VARIATION SELECTOR-28}");
- is("\N{VS29}", "\N{VARIATION SELECTOR-29}");
- is("\N{VS30}", "\N{VARIATION SELECTOR-30}");
- is("\N{VS31}", "\N{VARIATION SELECTOR-31}");
- is("\N{VS32}", "\N{VARIATION SELECTOR-32}");
- is("\N{VS33}", "\N{VARIATION SELECTOR-33}");
- is("\N{VS34}", "\N{VARIATION SELECTOR-34}");
- is("\N{VS35}", "\N{VARIATION SELECTOR-35}");
- is("\N{VS36}", "\N{VARIATION SELECTOR-36}");
- is("\N{VS37}", "\N{VARIATION SELECTOR-37}");
- is("\N{VS38}", "\N{VARIATION SELECTOR-38}");
- is("\N{VS39}", "\N{VARIATION SELECTOR-39}");
- is("\N{VS40}", "\N{VARIATION SELECTOR-40}");
- is("\N{VS41}", "\N{VARIATION SELECTOR-41}");
- is("\N{VS42}", "\N{VARIATION SELECTOR-42}");
- is("\N{VS43}", "\N{VARIATION SELECTOR-43}");
- is("\N{VS44}", "\N{VARIATION SELECTOR-44}");
- is("\N{VS45}", "\N{VARIATION SELECTOR-45}");
- is("\N{VS46}", "\N{VARIATION SELECTOR-46}");
- is("\N{VS47}", "\N{VARIATION SELECTOR-47}");
- is("\N{VS48}", "\N{VARIATION SELECTOR-48}");
- is("\N{VS49}", "\N{VARIATION SELECTOR-49}");
- is("\N{VS50}", "\N{VARIATION SELECTOR-50}");
- is("\N{VS51}", "\N{VARIATION SELECTOR-51}");
- is("\N{VS52}", "\N{VARIATION SELECTOR-52}");
- is("\N{VS53}", "\N{VARIATION SELECTOR-53}");
- is("\N{VS54}", "\N{VARIATION SELECTOR-54}");
- is("\N{VS55}", "\N{VARIATION SELECTOR-55}");
- is("\N{VS56}", "\N{VARIATION SELECTOR-56}");
- is("\N{VS57}", "\N{VARIATION SELECTOR-57}");
- is("\N{VS58}", "\N{VARIATION SELECTOR-58}");
- is("\N{VS59}", "\N{VARIATION SELECTOR-59}");
- is("\N{VS60}", "\N{VARIATION SELECTOR-60}");
- is("\N{VS61}", "\N{VARIATION SELECTOR-61}");
- is("\N{VS62}", "\N{VARIATION SELECTOR-62}");
- is("\N{VS63}", "\N{VARIATION SELECTOR-63}");
- is("\N{VS64}", "\N{VARIATION SELECTOR-64}");
- is("\N{VS65}", "\N{VARIATION SELECTOR-65}");
- is("\N{VS66}", "\N{VARIATION SELECTOR-66}");
- is("\N{VS67}", "\N{VARIATION SELECTOR-67}");
- is("\N{VS68}", "\N{VARIATION SELECTOR-68}");
- is("\N{VS69}", "\N{VARIATION SELECTOR-69}");
- is("\N{VS70}", "\N{VARIATION SELECTOR-70}");
- is("\N{VS71}", "\N{VARIATION SELECTOR-71}");
- is("\N{VS72}", "\N{VARIATION SELECTOR-72}");
- is("\N{VS73}", "\N{VARIATION SELECTOR-73}");
- is("\N{VS74}", "\N{VARIATION SELECTOR-74}");
- is("\N{VS75}", "\N{VARIATION SELECTOR-75}");
- is("\N{VS76}", "\N{VARIATION SELECTOR-76}");
- is("\N{VS77}", "\N{VARIATION SELECTOR-77}");
- is("\N{VS78}", "\N{VARIATION SELECTOR-78}");
- is("\N{VS79}", "\N{VARIATION SELECTOR-79}");
- is("\N{VS80}", "\N{VARIATION SELECTOR-80}");
- is("\N{VS81}", "\N{VARIATION SELECTOR-81}");
- is("\N{VS82}", "\N{VARIATION SELECTOR-82}");
- is("\N{VS83}", "\N{VARIATION SELECTOR-83}");
- is("\N{VS84}", "\N{VARIATION SELECTOR-84}");
- is("\N{VS85}", "\N{VARIATION SELECTOR-85}");
- is("\N{VS86}", "\N{VARIATION SELECTOR-86}");
- is("\N{VS87}", "\N{VARIATION SELECTOR-87}");
- is("\N{VS88}", "\N{VARIATION SELECTOR-88}");
- is("\N{VS89}", "\N{VARIATION SELECTOR-89}");
- is("\N{VS90}", "\N{VARIATION SELECTOR-90}");
- is("\N{VS91}", "\N{VARIATION SELECTOR-91}");
- is("\N{VS92}", "\N{VARIATION SELECTOR-92}");
- is("\N{VS93}", "\N{VARIATION SELECTOR-93}");
- is("\N{VS94}", "\N{VARIATION SELECTOR-94}");
- is("\N{VS95}", "\N{VARIATION SELECTOR-95}");
- is("\N{VS96}", "\N{VARIATION SELECTOR-96}");
- is("\N{VS97}", "\N{VARIATION SELECTOR-97}");
- is("\N{VS98}", "\N{VARIATION SELECTOR-98}");
- is("\N{VS99}", "\N{VARIATION SELECTOR-99}");
- is("\N{VS100}", "\N{VARIATION SELECTOR-100}");
- is("\N{VS101}", "\N{VARIATION SELECTOR-101}");
- is("\N{VS102}", "\N{VARIATION SELECTOR-102}");
- is("\N{VS103}", "\N{VARIATION SELECTOR-103}");
- is("\N{VS104}", "\N{VARIATION SELECTOR-104}");
- is("\N{VS105}", "\N{VARIATION SELECTOR-105}");
- is("\N{VS106}", "\N{VARIATION SELECTOR-106}");
- is("\N{VS107}", "\N{VARIATION SELECTOR-107}");
- is("\N{VS108}", "\N{VARIATION SELECTOR-108}");
- is("\N{VS109}", "\N{VARIATION SELECTOR-109}");
- is("\N{VS110}", "\N{VARIATION SELECTOR-110}");
- is("\N{VS111}", "\N{VARIATION SELECTOR-111}");
- is("\N{VS112}", "\N{VARIATION SELECTOR-112}");
- is("\N{VS113}", "\N{VARIATION SELECTOR-113}");
- is("\N{VS114}", "\N{VARIATION SELECTOR-114}");
- is("\N{VS115}", "\N{VARIATION SELECTOR-115}");
- is("\N{VS116}", "\N{VARIATION SELECTOR-116}");
- is("\N{VS117}", "\N{VARIATION SELECTOR-117}");
- is("\N{VS118}", "\N{VARIATION SELECTOR-118}");
- is("\N{VS119}", "\N{VARIATION SELECTOR-119}");
- is("\N{VS120}", "\N{VARIATION SELECTOR-120}");
- is("\N{VS121}", "\N{VARIATION SELECTOR-121}");
- is("\N{VS122}", "\N{VARIATION SELECTOR-122}");
- is("\N{VS123}", "\N{VARIATION SELECTOR-123}");
- is("\N{VS124}", "\N{VARIATION SELECTOR-124}");
- is("\N{VS125}", "\N{VARIATION SELECTOR-125}");
- is("\N{VS126}", "\N{VARIATION SELECTOR-126}");
- is("\N{VS127}", "\N{VARIATION SELECTOR-127}");
- is("\N{VS128}", "\N{VARIATION SELECTOR-128}");
- is("\N{VS129}", "\N{VARIATION SELECTOR-129}");
- is("\N{VS130}", "\N{VARIATION SELECTOR-130}");
- is("\N{VS131}", "\N{VARIATION SELECTOR-131}");
- is("\N{VS132}", "\N{VARIATION SELECTOR-132}");
- is("\N{VS133}", "\N{VARIATION SELECTOR-133}");
- is("\N{VS134}", "\N{VARIATION SELECTOR-134}");
- is("\N{VS135}", "\N{VARIATION SELECTOR-135}");
- is("\N{VS136}", "\N{VARIATION SELECTOR-136}");
- is("\N{VS137}", "\N{VARIATION SELECTOR-137}");
- is("\N{VS138}", "\N{VARIATION SELECTOR-138}");
- is("\N{VS139}", "\N{VARIATION SELECTOR-139}");
- is("\N{VS140}", "\N{VARIATION SELECTOR-140}");
- is("\N{VS141}", "\N{VARIATION SELECTOR-141}");
- is("\N{VS142}", "\N{VARIATION SELECTOR-142}");
- is("\N{VS143}", "\N{VARIATION SELECTOR-143}");
- is("\N{VS144}", "\N{VARIATION SELECTOR-144}");
- is("\N{VS145}", "\N{VARIATION SELECTOR-145}");
- is("\N{VS146}", "\N{VARIATION SELECTOR-146}");
- is("\N{VS147}", "\N{VARIATION SELECTOR-147}");
- is("\N{VS148}", "\N{VARIATION SELECTOR-148}");
- is("\N{VS149}", "\N{VARIATION SELECTOR-149}");
- is("\N{VS150}", "\N{VARIATION SELECTOR-150}");
- is("\N{VS151}", "\N{VARIATION SELECTOR-151}");
- is("\N{VS152}", "\N{VARIATION SELECTOR-152}");
- is("\N{VS153}", "\N{VARIATION SELECTOR-153}");
- is("\N{VS154}", "\N{VARIATION SELECTOR-154}");
- is("\N{VS155}", "\N{VARIATION SELECTOR-155}");
- is("\N{VS156}", "\N{VARIATION SELECTOR-156}");
- is("\N{VS157}", "\N{VARIATION SELECTOR-157}");
- is("\N{VS158}", "\N{VARIATION SELECTOR-158}");
- is("\N{VS159}", "\N{VARIATION SELECTOR-159}");
- is("\N{VS160}", "\N{VARIATION SELECTOR-160}");
- is("\N{VS161}", "\N{VARIATION SELECTOR-161}");
- is("\N{VS162}", "\N{VARIATION SELECTOR-162}");
- is("\N{VS163}", "\N{VARIATION SELECTOR-163}");
- is("\N{VS164}", "\N{VARIATION SELECTOR-164}");
- is("\N{VS165}", "\N{VARIATION SELECTOR-165}");
- is("\N{VS166}", "\N{VARIATION SELECTOR-166}");
- is("\N{VS167}", "\N{VARIATION SELECTOR-167}");
- is("\N{VS168}", "\N{VARIATION SELECTOR-168}");
- is("\N{VS169}", "\N{VARIATION SELECTOR-169}");
- is("\N{VS170}", "\N{VARIATION SELECTOR-170}");
- is("\N{VS171}", "\N{VARIATION SELECTOR-171}");
- is("\N{VS172}", "\N{VARIATION SELECTOR-172}");
- is("\N{VS173}", "\N{VARIATION SELECTOR-173}");
- is("\N{VS174}", "\N{VARIATION SELECTOR-174}");
- is("\N{VS175}", "\N{VARIATION SELECTOR-175}");
- is("\N{VS176}", "\N{VARIATION SELECTOR-176}");
- is("\N{VS177}", "\N{VARIATION SELECTOR-177}");
- is("\N{VS178}", "\N{VARIATION SELECTOR-178}");
- is("\N{VS179}", "\N{VARIATION SELECTOR-179}");
- is("\N{VS180}", "\N{VARIATION SELECTOR-180}");
- is("\N{VS181}", "\N{VARIATION SELECTOR-181}");
- is("\N{VS182}", "\N{VARIATION SELECTOR-182}");
- is("\N{VS183}", "\N{VARIATION SELECTOR-183}");
- is("\N{VS184}", "\N{VARIATION SELECTOR-184}");
- is("\N{VS185}", "\N{VARIATION SELECTOR-185}");
- is("\N{VS186}", "\N{VARIATION SELECTOR-186}");
- is("\N{VS187}", "\N{VARIATION SELECTOR-187}");
- is("\N{VS188}", "\N{VARIATION SELECTOR-188}");
- is("\N{VS189}", "\N{VARIATION SELECTOR-189}");
- is("\N{VS190}", "\N{VARIATION SELECTOR-190}");
- is("\N{VS191}", "\N{VARIATION SELECTOR-191}");
- is("\N{VS192}", "\N{VARIATION SELECTOR-192}");
- is("\N{VS193}", "\N{VARIATION SELECTOR-193}");
- is("\N{VS194}", "\N{VARIATION SELECTOR-194}");
- is("\N{VS195}", "\N{VARIATION SELECTOR-195}");
- is("\N{VS196}", "\N{VARIATION SELECTOR-196}");
- is("\N{VS197}", "\N{VARIATION SELECTOR-197}");
- is("\N{VS198}", "\N{VARIATION SELECTOR-198}");
- is("\N{VS199}", "\N{VARIATION SELECTOR-199}");
- is("\N{VS200}", "\N{VARIATION SELECTOR-200}");
- is("\N{VS201}", "\N{VARIATION SELECTOR-201}");
- is("\N{VS202}", "\N{VARIATION SELECTOR-202}");
- is("\N{VS203}", "\N{VARIATION SELECTOR-203}");
- is("\N{VS204}", "\N{VARIATION SELECTOR-204}");
- is("\N{VS205}", "\N{VARIATION SELECTOR-205}");
- is("\N{VS206}", "\N{VARIATION SELECTOR-206}");
- is("\N{VS207}", "\N{VARIATION SELECTOR-207}");
- is("\N{VS208}", "\N{VARIATION SELECTOR-208}");
- is("\N{VS209}", "\N{VARIATION SELECTOR-209}");
- is("\N{VS210}", "\N{VARIATION SELECTOR-210}");
- is("\N{VS211}", "\N{VARIATION SELECTOR-211}");
- is("\N{VS212}", "\N{VARIATION SELECTOR-212}");
- is("\N{VS213}", "\N{VARIATION SELECTOR-213}");
- is("\N{VS214}", "\N{VARIATION SELECTOR-214}");
- is("\N{VS215}", "\N{VARIATION SELECTOR-215}");
- is("\N{VS216}", "\N{VARIATION SELECTOR-216}");
- is("\N{VS217}", "\N{VARIATION SELECTOR-217}");
- is("\N{VS218}", "\N{VARIATION SELECTOR-218}");
- is("\N{VS219}", "\N{VARIATION SELECTOR-219}");
- is("\N{VS220}", "\N{VARIATION SELECTOR-220}");
- is("\N{VS221}", "\N{VARIATION SELECTOR-221}");
- is("\N{VS222}", "\N{VARIATION SELECTOR-222}");
- is("\N{VS223}", "\N{VARIATION SELECTOR-223}");
- is("\N{VS224}", "\N{VARIATION SELECTOR-224}");
- is("\N{VS225}", "\N{VARIATION SELECTOR-225}");
- is("\N{VS226}", "\N{VARIATION SELECTOR-226}");
- is("\N{VS227}", "\N{VARIATION SELECTOR-227}");
- is("\N{VS228}", "\N{VARIATION SELECTOR-228}");
- is("\N{VS229}", "\N{VARIATION SELECTOR-229}");
- is("\N{VS230}", "\N{VARIATION SELECTOR-230}");
- is("\N{VS231}", "\N{VARIATION SELECTOR-231}");
- is("\N{VS232}", "\N{VARIATION SELECTOR-232}");
- is("\N{VS233}", "\N{VARIATION SELECTOR-233}");
- is("\N{VS234}", "\N{VARIATION SELECTOR-234}");
- is("\N{VS235}", "\N{VARIATION SELECTOR-235}");
- is("\N{VS236}", "\N{VARIATION SELECTOR-236}");
- is("\N{VS237}", "\N{VARIATION SELECTOR-237}");
- is("\N{VS238}", "\N{VARIATION SELECTOR-238}");
- is("\N{VS239}", "\N{VARIATION SELECTOR-239}");
- is("\N{VS240}", "\N{VARIATION SELECTOR-240}");
- is("\N{VS241}", "\N{VARIATION SELECTOR-241}");
- is("\N{VS242}", "\N{VARIATION SELECTOR-242}");
- is("\N{VS243}", "\N{VARIATION SELECTOR-243}");
- is("\N{VS244}", "\N{VARIATION SELECTOR-244}");
- is("\N{VS245}", "\N{VARIATION SELECTOR-245}");
- is("\N{VS246}", "\N{VARIATION SELECTOR-246}");
- is("\N{VS247}", "\N{VARIATION SELECTOR-247}");
- is("\N{VS248}", "\N{VARIATION SELECTOR-248}");
- is("\N{VS249}", "\N{VARIATION SELECTOR-249}");
- is("\N{VS250}", "\N{VARIATION SELECTOR-250}");
- is("\N{VS251}", "\N{VARIATION SELECTOR-251}");
- is("\N{VS252}", "\N{VARIATION SELECTOR-252}");
- is("\N{VS253}", "\N{VARIATION SELECTOR-253}");
- is("\N{VS254}", "\N{VARIATION SELECTOR-254}");
- is("\N{VS255}", "\N{VARIATION SELECTOR-255}");
- is("\N{VS256}", "\N{VARIATION SELECTOR-256}");
+ is("\N{LINE FEED}", "\N{LINE FEED (LF)}", 'Verify "\N{LINE FEED}" eq "\N{LINE FEED (LF)}"', 'Verify \N{LINE FEED} eq \N{LINE FEED (LF)}');
+ is("\N{FORM FEED}", "\N{FORM FEED (FF)}", 'Verify "\N{FORM FEED}" eq "\N{FORM FEED (FF)}"');
+ is("\N{CARRIAGE RETURN}", "\N{CARRIAGE RETURN (CR)}", 'Verify "\N{CARRIAGE RETURN}" eq "\N{CARRIAGE RETURN (CR)}"');
+ is("\N{NEXT LINE}", "\N{NEXT LINE (NEL)}", 'Verify "\N{NEXT LINE}" eq "\N{NEXT LINE (NEL)}"');
+ is("\N{NUL}", "\N{NULL}", 'Verify "\N{NUL}" eq "\N{NULL}"');
+ is("\N{SOH}", "\N{START OF HEADING}", 'Verify "\N{SOH}" eq "\N{START OF HEADING}"');
+ is("\N{STX}", "\N{START OF TEXT}", 'Verify "\N{STX}" eq "\N{START OF TEXT}"');
+ is("\N{ETX}", "\N{END OF TEXT}", 'Verify "\N{ETX}" eq "\N{END OF TEXT}"');
+ is("\N{EOT}", "\N{END OF TRANSMISSION}", 'Verify "\N{EOT}" eq "\N{END OF TRANSMISSION}"');
+ is("\N{ENQ}", "\N{ENQUIRY}", 'Verify "\N{ENQ}" eq "\N{ENQUIRY}"');
+ is("\N{ACK}", "\N{ACKNOWLEDGE}", 'Verify "\N{ACK}" eq "\N{ACKNOWLEDGE}"');
+ is("\N{BEL}", "\N{BELL}", 'Verify "\N{BEL}" eq "\N{BELL}"') if $^V lt v5.17.0;
+ is("\N{BS}", "\N{BACKSPACE}", 'Verify "\N{BS}" eq "\N{BACKSPACE}"');
+ is("\N{HT}", "\N{HORIZONTAL TABULATION}", 'Verify "\N{HT}" eq "\N{HORIZONTAL TABULATION}"');
+ is("\N{LF}", "\N{LINE FEED (LF)}", 'Verify "\N{LF}" eq "\N{LINE FEED (LF)}"');
+ is("\N{VT}", "\N{VERTICAL TABULATION}", 'Verify "\N{VT}" eq "\N{VERTICAL TABULATION}"');
+ is("\N{FF}", "\N{FORM FEED (FF)}", 'Verify "\N{FF}" eq "\N{FORM FEED (FF)}"');
+ is("\N{CR}", "\N{CARRIAGE RETURN (CR)}", 'Verify "\N{CR}" eq "\N{CARRIAGE RETURN (CR)}"');
+ is("\N{SO}", "\N{SHIFT OUT}", 'Verify "\N{SO}" eq "\N{SHIFT OUT}"');
+ is("\N{SI}", "\N{SHIFT IN}", 'Verify "\N{SI}" eq "\N{SHIFT IN}"');
+ is("\N{DLE}", "\N{DATA LINK ESCAPE}", 'Verify "\N{DLE}" eq "\N{DATA LINK ESCAPE}"');
+ is("\N{DC1}", "\N{DEVICE CONTROL ONE}", 'Verify "\N{DC1}" eq "\N{DEVICE CONTROL ONE}"');
+ is("\N{DC2}", "\N{DEVICE CONTROL TWO}", 'Verify "\N{DC2}" eq "\N{DEVICE CONTROL TWO}"');
+ is("\N{DC3}", "\N{DEVICE CONTROL THREE}", 'Verify "\N{DC3}" eq "\N{DEVICE CONTROL THREE}"');
+ is("\N{DC4}", "\N{DEVICE CONTROL FOUR}", 'Verify "\N{DC4}" eq "\N{DEVICE CONTROL FOUR}"');
+ is("\N{NAK}", "\N{NEGATIVE ACKNOWLEDGE}", 'Verify "\N{NAK}" eq "\N{NEGATIVE ACKNOWLEDGE}"');
+ is("\N{SYN}", "\N{SYNCHRONOUS IDLE}", 'Verify "\N{SYN}" eq "\N{SYNCHRONOUS IDLE}"');
+ is("\N{ETB}", "\N{END OF TRANSMISSION BLOCK}", 'Verify "\N{ETB}" eq "\N{END OF TRANSMISSION BLOCK}"');
+ is("\N{CAN}", "\N{CANCEL}", 'Verify "\N{CAN}" eq "\N{CANCEL}"');
+ is("\N{EOM}", "\N{END OF MEDIUM}", 'Verify "\N{EOM}" eq "\N{END OF MEDIUM}"');
+ is("\N{SUB}", "\N{SUBSTITUTE}", 'Verify "\N{SUB}" eq "\N{SUBSTITUTE}"');
+ is("\N{ESC}", "\N{ESCAPE}", 'Verify "\N{ESC}" eq "\N{ESCAPE}"');
+ is("\N{FS}", "\N{FILE SEPARATOR}", 'Verify "\N{FS}" eq "\N{FILE SEPARATOR}"');
+ is("\N{GS}", "\N{GROUP SEPARATOR}", 'Verify "\N{GS}" eq "\N{GROUP SEPARATOR}"');
+ is("\N{RS}", "\N{RECORD SEPARATOR}", 'Verify "\N{RS}" eq "\N{RECORD SEPARATOR}"');
+ is("\N{US}", "\N{UNIT SEPARATOR}", 'Verify "\N{US}" eq "\N{UNIT SEPARATOR}"');
+ is("\N{DEL}", "\N{DELETE}", 'Verify "\N{DEL}" eq "\N{DELETE}"');
+ is("\N{BPH}", "\N{BREAK PERMITTED HERE}", 'Verify "\N{BPH}" eq "\N{BREAK PERMITTED HERE}"');
+ is("\N{NBH}", "\N{NO BREAK HERE}", 'Verify "\N{NBH}" eq "\N{NO BREAK HERE}"');
+ is("\N{NEL}", "\N{NEXT LINE (NEL)}", 'Verify "\N{NEL}" eq "\N{NEXT LINE (NEL)}"');
+ is("\N{SSA}", "\N{START OF SELECTED AREA}", 'Verify "\N{SSA}" eq "\N{START OF SELECTED AREA}"');
+ is("\N{ESA}", "\N{END OF SELECTED AREA}", 'Verify "\N{ESA}" eq "\N{END OF SELECTED AREA}"');
+ is("\N{HTS}", "\N{CHARACTER TABULATION SET}", 'Verify "\N{HTS}" eq "\N{CHARACTER TABULATION SET}"');
+ is("\N{HTJ}", "\N{CHARACTER TABULATION WITH JUSTIFICATION}", 'Verify "\N{HTJ}" eq "\N{CHARACTER TABULATION WITH JUSTIFICATION}"');
+ is("\N{VTS}", "\N{LINE TABULATION SET}", 'Verify "\N{VTS}" eq "\N{LINE TABULATION SET}"');
+ is("\N{PLD}", "\N{PARTIAL LINE FORWARD}", 'Verify "\N{PLD}" eq "\N{PARTIAL LINE FORWARD}"');
+ is("\N{PLU}", "\N{PARTIAL LINE BACKWARD}", 'Verify "\N{PLU}" eq "\N{PARTIAL LINE BACKWARD}"');
+ is("\N{RI}", "\N{REVERSE LINE FEED}", 'Verify "\N{RI}" eq "\N{REVERSE LINE FEED}"');
+ is("\N{SS2}", "\N{SINGLE SHIFT TWO}", 'Verify "\N{SS2}" eq "\N{SINGLE SHIFT TWO}"');
+ is("\N{SS3}", "\N{SINGLE SHIFT THREE}", 'Verify "\N{SS3}" eq "\N{SINGLE SHIFT THREE}"');
+ is("\N{DCS}", "\N{DEVICE CONTROL STRING}", 'Verify "\N{DCS}" eq "\N{DEVICE CONTROL STRING}"');
+ is("\N{PU1}", "\N{PRIVATE USE ONE}", 'Verify "\N{PU1}" eq "\N{PRIVATE USE ONE}"');
+ is("\N{PU2}", "\N{PRIVATE USE TWO}", 'Verify "\N{PU2}" eq "\N{PRIVATE USE TWO}"');
+ is("\N{STS}", "\N{SET TRANSMIT STATE}", 'Verify "\N{STS}" eq "\N{SET TRANSMIT STATE}"');
+ is("\N{CCH}", "\N{CANCEL CHARACTER}", 'Verify "\N{CCH}" eq "\N{CANCEL CHARACTER}"');
+ is("\N{MW}", "\N{MESSAGE WAITING}", 'Verify "\N{MW}" eq "\N{MESSAGE WAITING}"');
+ is("\N{SPA}", "\N{START OF GUARDED AREA}", 'Verify "\N{SPA}" eq "\N{START OF GUARDED AREA}"');
+ is("\N{EPA}", "\N{END OF GUARDED AREA}", 'Verify "\N{EPA}" eq "\N{END OF GUARDED AREA}"');
+ is("\N{SOS}", "\N{START OF STRING}", 'Verify "\N{SOS}" eq "\N{START OF STRING}"');
+ is("\N{SCI}", "\N{SINGLE CHARACTER INTRODUCER}", 'Verify "\N{SCI}" eq "\N{SINGLE CHARACTER INTRODUCER}"');
+ is("\N{CSI}", "\N{CONTROL SEQUENCE INTRODUCER}", 'Verify "\N{CSI}" eq "\N{CONTROL SEQUENCE INTRODUCER}"');
+ is("\N{ST}", "\N{STRING TERMINATOR}", 'Verify "\N{ST}" eq "\N{STRING TERMINATOR}"');
+ is("\N{OSC}", "\N{OPERATING SYSTEM COMMAND}", 'Verify "\N{OSC}" eq "\N{OPERATING SYSTEM COMMAND}"');
+ is("\N{PM}", "\N{PRIVACY MESSAGE}", 'Verify "\N{PM}" eq "\N{PRIVACY MESSAGE}"');
+ is("\N{APC}", "\N{APPLICATION PROGRAM COMMAND}", 'Verify "\N{APC}" eq "\N{APPLICATION PROGRAM COMMAND}"');
+ is("\N{PADDING CHARACTER}", "\N{PAD}", 'Verify "\N{PADDING CHARACTER}" eq "\N{PAD}"');
+ is("\N{HIGH OCTET PRESET}","\N{HOP}", 'Verify "\N{HIGH OCTET PRESET}" eq "\N{HOP}"');
+ is("\N{INDEX}", "\N{IND}", 'Verify "\N{INDEX}" eq "\N{IND}"');
+ is("\N{SINGLE GRAPHIC CHARACTER INTRODUCER}", "\N{SGC}", 'Verify "\N{SINGLE GRAPHIC CHARACTER INTRODUCER}" eq "\N{SGC}"');
+ is("\N{BOM}", "\N{BYTE ORDER MARK}", 'Verify "\N{BOM}" eq "\N{BYTE ORDER MARK}"');
+ is("\N{CGJ}", "\N{COMBINING GRAPHEME JOINER}", 'Verify "\N{CGJ}" eq "\N{COMBINING GRAPHEME JOINER}"');
+ is("\N{FVS1}", "\N{MONGOLIAN FREE VARIATION SELECTOR ONE}", 'Verify "\N{FVS1}" eq "\N{MONGOLIAN FREE VARIATION SELECTOR ONE}"');
+ is("\N{FVS2}", "\N{MONGOLIAN FREE VARIATION SELECTOR TWO}", 'Verify "\N{FVS2}" eq "\N{MONGOLIAN FREE VARIATION SELECTOR TWO}"');
+ is("\N{FVS3}", "\N{MONGOLIAN FREE VARIATION SELECTOR THREE}", 'Verify "\N{FVS3}" eq "\N{MONGOLIAN FREE VARIATION SELECTOR THREE}"');
+ is("\N{LRE}", "\N{LEFT-TO-RIGHT EMBEDDING}", 'Verify "\N{LRE}" eq "\N{LEFT-TO-RIGHT EMBEDDING}"');
+ is("\N{LRM}", "\N{LEFT-TO-RIGHT MARK}", 'Verify "\N{LRM}" eq "\N{LEFT-TO-RIGHT MARK}"');
+ is("\N{LRO}", "\N{LEFT-TO-RIGHT OVERRIDE}", 'Verify "\N{LRO}" eq "\N{LEFT-TO-RIGHT OVERRIDE}"');
+ is("\N{MMSP}", "\N{MEDIUM MATHEMATICAL SPACE}", 'Verify "\N{MMSP}" eq "\N{MEDIUM MATHEMATICAL SPACE}"');
+ is("\N{MVS}", "\N{MONGOLIAN VOWEL SEPARATOR}", 'Verify "\N{MVS}" eq "\N{MONGOLIAN VOWEL SEPARATOR}"');
+ is("\N{NBSP}", "\N{NO-BREAK SPACE}", 'Verify "\N{NBSP}" eq "\N{NO-BREAK SPACE}"');
+ is("\N{NNBSP}", "\N{NARROW NO-BREAK SPACE}", 'Verify "\N{NNBSP}" eq "\N{NARROW NO-BREAK SPACE}"');
+ is("\N{PDF}", "\N{POP DIRECTIONAL FORMATTING}", 'Verify "\N{PDF}" eq "\N{POP DIRECTIONAL FORMATTING}"');
+ is("\N{RLE}", "\N{RIGHT-TO-LEFT EMBEDDING}", 'Verify "\N{RLE}" eq "\N{RIGHT-TO-LEFT EMBEDDING}"');
+ is("\N{RLM}", "\N{RIGHT-TO-LEFT MARK}", 'Verify "\N{RLM}" eq "\N{RIGHT-TO-LEFT MARK}"');
+ is("\N{RLO}", "\N{RIGHT-TO-LEFT OVERRIDE}", 'Verify "\N{RLO}" eq "\N{RIGHT-TO-LEFT OVERRIDE}"');
+ is("\N{SHY}", "\N{SOFT HYPHEN}", 'Verify "\N{SHY}" eq "\N{SOFT HYPHEN}"');
+ is("\N{WJ}", "\N{WORD JOINER}", 'Verify "\N{WJ}" eq "\N{WORD JOINER}"');
+ is("\N{ZWJ}", "\N{ZERO WIDTH JOINER}", 'Verify "\N{ZWJ}" eq "\N{ZERO WIDTH JOINER}"');
+ is("\N{ZWNJ}", "\N{ZERO WIDTH NON-JOINER}", 'Verify "\N{ZWNJ}" eq "\N{ZERO WIDTH NON-JOINER}"');
+ is("\N{ZWSP}", "\N{ZERO WIDTH SPACE}", 'Verify "\N{ZWSP}" eq "\N{ZERO WIDTH SPACE}"');
+ is("\N{HORIZONTAL TABULATION}", "\N{CHARACTER TABULATION}", 'Verify "\N{HORIZONTAL TABULATION}" eq "\N{CHARACTER TABULATION}"');
+ is("\N{VERTICAL TABULATION}", "\N{LINE TABULATION}", 'Verify "\N{VERTICAL TABULATION}" eq "\N{LINE TABULATION}"');
+ is("\N{FILE SEPARATOR}", "\N{INFORMATION SEPARATOR FOUR}", 'Verify "\N{FILE SEPARATOR}" eq "\N{INFORMATION SEPARATOR FOUR}"');
+ is("\N{GROUP SEPARATOR}", "\N{INFORMATION SEPARATOR THREE}", 'Verify "\N{GROUP SEPARATOR}" eq "\N{INFORMATION SEPARATOR THREE}"');
+ is("\N{RECORD SEPARATOR}", "\N{INFORMATION SEPARATOR TWO}", 'Verify "\N{RECORD SEPARATOR}" eq "\N{INFORMATION SEPARATOR TWO}"');
+ is("\N{UNIT SEPARATOR}", "\N{INFORMATION SEPARATOR ONE}", 'Verify "\N{UNIT SEPARATOR}" eq "\N{INFORMATION SEPARATOR ONE}"');
+ is("\N{HORIZONTAL TABULATION SET}", "\N{CHARACTER TABULATION SET}", 'Verify "\N{HORIZONTAL TABULATION SET}" eq "\N{CHARACTER TABULATION SET}"');
+ is("\N{HORIZONTAL TABULATION WITH JUSTIFICATION}", "\N{CHARACTER TABULATION WITH JUSTIFICATION}", 'Verify "\N{HORIZONTAL TABULATION WITH JUSTIFICATION}" eq "\N{CHARACTER TABULATION WITH JUSTIFICATION}"');
+ is("\N{PARTIAL LINE DOWN}", "\N{PARTIAL LINE FORWARD}", 'Verify "\N{PARTIAL LINE DOWN}" eq "\N{PARTIAL LINE FORWARD}"');
+ is("\N{PARTIAL LINE UP}", "\N{PARTIAL LINE BACKWARD}", 'Verify "\N{PARTIAL LINE UP}" eq "\N{PARTIAL LINE BACKWARD}"');
+ is("\N{VERTICAL TABULATION SET}", "\N{LINE TABULATION SET}", 'Verify "\N{VERTICAL TABULATION SET}" eq "\N{LINE TABULATION SET}"');
+ is("\N{REVERSE INDEX}", "\N{REVERSE LINE FEED}", 'Verify "\N{REVERSE INDEX}" eq "\N{REVERSE LINE FEED}"');
+ is("\N{SINGLE-SHIFT 2}", "\N{SINGLE SHIFT TWO}", 'Verify "\N{SINGLE-SHIFT 2}" eq "\N{SINGLE SHIFT TWO}"');
+ is("\N{SINGLE-SHIFT-2}", "\N{SINGLE-SHIFT 2}", 'Verify "\N{SINGLE-SHIFT-2}" eq "\N{SINGLE SHIFT 2}"');
+ is("\N{SINGLE-SHIFT 3}", "\N{SINGLE SHIFT THREE}", 'Verify "\N{SINGLE-SHIFT 3}" eq "\N{SINGLE SHIFT THREE}"');
+ is("\N{SINGLE-SHIFT-3}", "\N{SINGLE-SHIFT 3}", 'Verify "\N{SINGLE-SHIFT-3}" eq "\N{SINGLE SHIFT 3}"');
+ is("\N{PRIVATE USE 1}", "\N{PRIVATE USE ONE}", 'Verify "\N{PRIVATE USE 1}" eq "\N{PRIVATE USE ONE}"');
+ is("\N{PRIVATE USE-1}", "\N{PRIVATE USE 1}", 'Verify "\N{PRIVATE USE-1}" eq "\N{PRIVATE USE 1}"');
+ is("\N{PRIVATE USE 2}", "\N{PRIVATE USE TWO}", 'Verify "\N{PRIVATE USE 2}" eq "\N{PRIVATE USE TWO}"');
+ is("\N{PRIVATE USE-2}", "\N{PRIVATE USE 2}", 'Verify "\N{PRIVATE USE-2}" eq "\N{PRIVATE USE 2}"');
+ is("\N{START OF PROTECTED AREA}", "\N{START OF GUARDED AREA}", 'Verify "\N{START OF PROTECTED AREA}" eq "\N{START OF GUARDED AREA}"');
+ is("\N{END OF PROTECTED AREA}", "\N{END OF GUARDED AREA}", 'Verify "\N{END OF PROTECTED AREA}" eq "\N{END OF GUARDED AREA}"');
+ is("\N{VS1}", "\N{VARIATION SELECTOR-1}", 'Verify "\N{VS1}" eq "\N{VARIATION SELECTOR-1}"');
+ is("\N{VS2}", "\N{VARIATION SELECTOR-2}", 'Verify "\N{VS2}" eq "\N{VARIATION SELECTOR-2}"');
+ is("\N{VS3}", "\N{VARIATION SELECTOR-3}", 'Verify "\N{VS3}" eq "\N{VARIATION SELECTOR-3}"');
+ is("\N{VS4}", "\N{VARIATION SELECTOR-4}", 'Verify "\N{VS4}" eq "\N{VARIATION SELECTOR-4}"');
+ is("\N{VS5}", "\N{VARIATION SELECTOR-5}", 'Verify "\N{VS5}" eq "\N{VARIATION SELECTOR-5}"');
+ is("\N{VS6}", "\N{VARIATION SELECTOR-6}", 'Verify "\N{VS6}" eq "\N{VARIATION SELECTOR-6}"');
+ is("\N{VS7}", "\N{VARIATION SELECTOR-7}", 'Verify "\N{VS7}" eq "\N{VARIATION SELECTOR-7}"');
+ is("\N{VS8}", "\N{VARIATION SELECTOR-8}", 'Verify "\N{VS8}" eq "\N{VARIATION SELECTOR-8}"');
+ is("\N{VS9}", "\N{VARIATION SELECTOR-9}", 'Verify "\N{VS9}" eq "\N{VARIATION SELECTOR-9}"');
+ is("\N{VS10}", "\N{VARIATION SELECTOR-10}", 'Verify "\N{VS10}" eq "\N{VARIATION SELECTOR-10}"');
+ is("\N{VS11}", "\N{VARIATION SELECTOR-11}", 'Verify "\N{VS11}" eq "\N{VARIATION SELECTOR-11}"');
+ is("\N{VS12}", "\N{VARIATION SELECTOR-12}", 'Verify "\N{VS12}" eq "\N{VARIATION SELECTOR-12}"');
+ is("\N{VS13}", "\N{VARIATION SELECTOR-13}", 'Verify "\N{VS13}" eq "\N{VARIATION SELECTOR-13}"');
+ is("\N{VS14}", "\N{VARIATION SELECTOR-14}", 'Verify "\N{VS14}" eq "\N{VARIATION SELECTOR-14}"');
+ is("\N{VS15}", "\N{VARIATION SELECTOR-15}", 'Verify "\N{VS15}" eq "\N{VARIATION SELECTOR-15}"');
+ is("\N{VS16}", "\N{VARIATION SELECTOR-16}", 'Verify "\N{VS16}" eq "\N{VARIATION SELECTOR-16}"');
+ is("\N{VS17}", "\N{VARIATION SELECTOR-17}", 'Verify "\N{VS17}" eq "\N{VARIATION SELECTOR-17}"');
+ is("\N{VS18}", "\N{VARIATION SELECTOR-18}", 'Verify "\N{VS18}" eq "\N{VARIATION SELECTOR-18}"');
+ is("\N{VS19}", "\N{VARIATION SELECTOR-19}", 'Verify "\N{VS19}" eq "\N{VARIATION SELECTOR-19}"');
+ is("\N{VS20}", "\N{VARIATION SELECTOR-20}", 'Verify "\N{VS20}" eq "\N{VARIATION SELECTOR-20}"');
+ is("\N{VS21}", "\N{VARIATION SELECTOR-21}", 'Verify "\N{VS21}" eq "\N{VARIATION SELECTOR-21}"');
+ is("\N{VS22}", "\N{VARIATION SELECTOR-22}", 'Verify "\N{VS22}" eq "\N{VARIATION SELECTOR-22}"');
+ is("\N{VS23}", "\N{VARIATION SELECTOR-23}", 'Verify "\N{VS23}" eq "\N{VARIATION SELECTOR-23}"');
+ is("\N{VS24}", "\N{VARIATION SELECTOR-24}", 'Verify "\N{VS24}" eq "\N{VARIATION SELECTOR-24}"');
+ is("\N{VS25}", "\N{VARIATION SELECTOR-25}", 'Verify "\N{VS25}" eq "\N{VARIATION SELECTOR-25}"');
+ is("\N{VS26}", "\N{VARIATION SELECTOR-26}", 'Verify "\N{VS26}" eq "\N{VARIATION SELECTOR-26}"');
+ is("\N{VS27}", "\N{VARIATION SELECTOR-27}", 'Verify "\N{VS27}" eq "\N{VARIATION SELECTOR-27}"');
+ is("\N{VS28}", "\N{VARIATION SELECTOR-28}", 'Verify "\N{VS28}" eq "\N{VARIATION SELECTOR-28}"');
+ is("\N{VS29}", "\N{VARIATION SELECTOR-29}", 'Verify "\N{VS29}" eq "\N{VARIATION SELECTOR-29}"');
+ is("\N{VS30}", "\N{VARIATION SELECTOR-30}", 'Verify "\N{VS30}" eq "\N{VARIATION SELECTOR-30}"');
+ is("\N{VS31}", "\N{VARIATION SELECTOR-31}", 'Verify "\N{VS31}" eq "\N{VARIATION SELECTOR-31}"');
+ is("\N{VS32}", "\N{VARIATION SELECTOR-32}", 'Verify "\N{VS32}" eq "\N{VARIATION SELECTOR-32}"');
+ is("\N{VS33}", "\N{VARIATION SELECTOR-33}", 'Verify "\N{VS33}" eq "\N{VARIATION SELECTOR-33}"');
+ is("\N{VS34}", "\N{VARIATION SELECTOR-34}", 'Verify "\N{VS34}" eq "\N{VARIATION SELECTOR-34}"');
+ is("\N{VS35}", "\N{VARIATION SELECTOR-35}", 'Verify "\N{VS35}" eq "\N{VARIATION SELECTOR-35}"');
+ is("\N{VS36}", "\N{VARIATION SELECTOR-36}", 'Verify "\N{VS36}" eq "\N{VARIATION SELECTOR-36}"');
+ is("\N{VS37}", "\N{VARIATION SELECTOR-37}", 'Verify "\N{VS37}" eq "\N{VARIATION SELECTOR-37}"');
+ is("\N{VS38}", "\N{VARIATION SELECTOR-38}", 'Verify "\N{VS38}" eq "\N{VARIATION SELECTOR-38}"');
+ is("\N{VS39}", "\N{VARIATION SELECTOR-39}", 'Verify "\N{VS39}" eq "\N{VARIATION SELECTOR-39}"');
+ is("\N{VS40}", "\N{VARIATION SELECTOR-40}", 'Verify "\N{VS40}" eq "\N{VARIATION SELECTOR-40}"');
+ is("\N{VS41}", "\N{VARIATION SELECTOR-41}", 'Verify "\N{VS41}" eq "\N{VARIATION SELECTOR-41}"');
+ is("\N{VS42}", "\N{VARIATION SELECTOR-42}", 'Verify "\N{VS42}" eq "\N{VARIATION SELECTOR-42}"');
+ is("\N{VS43}", "\N{VARIATION SELECTOR-43}", 'Verify "\N{VS43}" eq "\N{VARIATION SELECTOR-43}"');
+ is("\N{VS44}", "\N{VARIATION SELECTOR-44}", 'Verify "\N{VS44}" eq "\N{VARIATION SELECTOR-44}"');
+ is("\N{VS45}", "\N{VARIATION SELECTOR-45}", 'Verify "\N{VS45}" eq "\N{VARIATION SELECTOR-45}"');
+ is("\N{VS46}", "\N{VARIATION SELECTOR-46}", 'Verify "\N{VS46}" eq "\N{VARIATION SELECTOR-46}"');
+ is("\N{VS47}", "\N{VARIATION SELECTOR-47}", 'Verify "\N{VS47}" eq "\N{VARIATION SELECTOR-47}"');
+ is("\N{VS48}", "\N{VARIATION SELECTOR-48}", 'Verify "\N{VS48}" eq "\N{VARIATION SELECTOR-48}"');
+ is("\N{VS49}", "\N{VARIATION SELECTOR-49}", 'Verify "\N{VS49}" eq "\N{VARIATION SELECTOR-49}"');
+ is("\N{VS50}", "\N{VARIATION SELECTOR-50}", 'Verify "\N{VS50}" eq "\N{VARIATION SELECTOR-50}"');
+ is("\N{VS51}", "\N{VARIATION SELECTOR-51}", 'Verify "\N{VS51}" eq "\N{VARIATION SELECTOR-51}"');
+ is("\N{VS52}", "\N{VARIATION SELECTOR-52}", 'Verify "\N{VS52}" eq "\N{VARIATION SELECTOR-52}"');
+ is("\N{VS53}", "\N{VARIATION SELECTOR-53}", 'Verify "\N{VS53}" eq "\N{VARIATION SELECTOR-53}"');
+ is("\N{VS54}", "\N{VARIATION SELECTOR-54}", 'Verify "\N{VS54}" eq "\N{VARIATION SELECTOR-54}"');
+ is("\N{VS55}", "\N{VARIATION SELECTOR-55}", 'Verify "\N{VS55}" eq "\N{VARIATION SELECTOR-55}"');
+ is("\N{VS56}", "\N{VARIATION SELECTOR-56}", 'Verify "\N{VS56}" eq "\N{VARIATION SELECTOR-56}"');
+ is("\N{VS57}", "\N{VARIATION SELECTOR-57}", 'Verify "\N{VS57}" eq "\N{VARIATION SELECTOR-57}"');
+ is("\N{VS58}", "\N{VARIATION SELECTOR-58}", 'Verify "\N{VS58}" eq "\N{VARIATION SELECTOR-58}"');
+ is("\N{VS59}", "\N{VARIATION SELECTOR-59}", 'Verify "\N{VS59}" eq "\N{VARIATION SELECTOR-59}"');
+ is("\N{VS60}", "\N{VARIATION SELECTOR-60}", 'Verify "\N{VS60}" eq "\N{VARIATION SELECTOR-60}"');
+ is("\N{VS61}", "\N{VARIATION SELECTOR-61}", 'Verify "\N{VS61}" eq "\N{VARIATION SELECTOR-61}"');
+ is("\N{VS62}", "\N{VARIATION SELECTOR-62}", 'Verify "\N{VS62}" eq "\N{VARIATION SELECTOR-62}"');
+ is("\N{VS63}", "\N{VARIATION SELECTOR-63}", 'Verify "\N{VS63}" eq "\N{VARIATION SELECTOR-63}"');
+ is("\N{VS64}", "\N{VARIATION SELECTOR-64}", 'Verify "\N{VS64}" eq "\N{VARIATION SELECTOR-64}"');
+ is("\N{VS65}", "\N{VARIATION SELECTOR-65}", 'Verify "\N{VS65}" eq "\N{VARIATION SELECTOR-65}"');
+ is("\N{VS66}", "\N{VARIATION SELECTOR-66}", 'Verify "\N{VS66}" eq "\N{VARIATION SELECTOR-66}"');
+ is("\N{VS67}", "\N{VARIATION SELECTOR-67}", 'Verify "\N{VS67}" eq "\N{VARIATION SELECTOR-67}"');
+ is("\N{VS68}", "\N{VARIATION SELECTOR-68}", 'Verify "\N{VS68}" eq "\N{VARIATION SELECTOR-68}"');
+ is("\N{VS69}", "\N{VARIATION SELECTOR-69}", 'Verify "\N{VS69}" eq "\N{VARIATION SELECTOR-69}"');
+ is("\N{VS70}", "\N{VARIATION SELECTOR-70}", 'Verify "\N{VS70}" eq "\N{VARIATION SELECTOR-70}"');
+ is("\N{VS71}", "\N{VARIATION SELECTOR-71}", 'Verify "\N{VS71}" eq "\N{VARIATION SELECTOR-71}"');
+ is("\N{VS72}", "\N{VARIATION SELECTOR-72}", 'Verify "\N{VS72}" eq "\N{VARIATION SELECTOR-72}"');
+ is("\N{VS73}", "\N{VARIATION SELECTOR-73}", 'Verify "\N{VS73}" eq "\N{VARIATION SELECTOR-73}"');
+ is("\N{VS74}", "\N{VARIATION SELECTOR-74}", 'Verify "\N{VS74}" eq "\N{VARIATION SELECTOR-74}"');
+ is("\N{VS75}", "\N{VARIATION SELECTOR-75}", 'Verify "\N{VS75}" eq "\N{VARIATION SELECTOR-75}"');
+ is("\N{VS76}", "\N{VARIATION SELECTOR-76}", 'Verify "\N{VS76}" eq "\N{VARIATION SELECTOR-76}"');
+ is("\N{VS77}", "\N{VARIATION SELECTOR-77}", 'Verify "\N{VS77}" eq "\N{VARIATION SELECTOR-77}"');
+ is("\N{VS78}", "\N{VARIATION SELECTOR-78}", 'Verify "\N{VS78}" eq "\N{VARIATION SELECTOR-78}"');
+ is("\N{VS79}", "\N{VARIATION SELECTOR-79}", 'Verify "\N{VS79}" eq "\N{VARIATION SELECTOR-79}"');
+ is("\N{VS80}", "\N{VARIATION SELECTOR-80}", 'Verify "\N{VS80}" eq "\N{VARIATION SELECTOR-80}"');
+ is("\N{VS81}", "\N{VARIATION SELECTOR-81}", 'Verify "\N{VS81}" eq "\N{VARIATION SELECTOR-81}"');
+ is("\N{VS82}", "\N{VARIATION SELECTOR-82}", 'Verify "\N{VS82}" eq "\N{VARIATION SELECTOR-82}"');
+ is("\N{VS83}", "\N{VARIATION SELECTOR-83}", 'Verify "\N{VS83}" eq "\N{VARIATION SELECTOR-83}"');
+ is("\N{VS84}", "\N{VARIATION SELECTOR-84}", 'Verify "\N{VS84}" eq "\N{VARIATION SELECTOR-84}"');
+ is("\N{VS85}", "\N{VARIATION SELECTOR-85}", 'Verify "\N{VS85}" eq "\N{VARIATION SELECTOR-85}"');
+ is("\N{VS86}", "\N{VARIATION SELECTOR-86}", 'Verify "\N{VS86}" eq "\N{VARIATION SELECTOR-86}"');
+ is("\N{VS87}", "\N{VARIATION SELECTOR-87}", 'Verify "\N{VS87}" eq "\N{VARIATION SELECTOR-87}"');
+ is("\N{VS88}", "\N{VARIATION SELECTOR-88}", 'Verify "\N{VS88}" eq "\N{VARIATION SELECTOR-88}"');
+ is("\N{VS89}", "\N{VARIATION SELECTOR-89}", 'Verify "\N{VS89}" eq "\N{VARIATION SELECTOR-89}"');
+ is("\N{VS90}", "\N{VARIATION SELECTOR-90}", 'Verify "\N{VS90}" eq "\N{VARIATION SELECTOR-90}"');
+ is("\N{VS91}", "\N{VARIATION SELECTOR-91}", 'Verify "\N{VS91}" eq "\N{VARIATION SELECTOR-91}"');
+ is("\N{VS92}", "\N{VARIATION SELECTOR-92}", 'Verify "\N{VS92}" eq "\N{VARIATION SELECTOR-92}"');
+ is("\N{VS93}", "\N{VARIATION SELECTOR-93}", 'Verify "\N{VS93}" eq "\N{VARIATION SELECTOR-93}"');
+ is("\N{VS94}", "\N{VARIATION SELECTOR-94}", 'Verify "\N{VS94}" eq "\N{VARIATION SELECTOR-94}"');
+ is("\N{VS95}", "\N{VARIATION SELECTOR-95}", 'Verify "\N{VS95}" eq "\N{VARIATION SELECTOR-95}"');
+ is("\N{VS96}", "\N{VARIATION SELECTOR-96}", 'Verify "\N{VS96}" eq "\N{VARIATION SELECTOR-96}"');
+ is("\N{VS97}", "\N{VARIATION SELECTOR-97}", 'Verify "\N{VS97}" eq "\N{VARIATION SELECTOR-97}"');
+ is("\N{VS98}", "\N{VARIATION SELECTOR-98}", 'Verify "\N{VS98}" eq "\N{VARIATION SELECTOR-98}"');
+ is("\N{VS99}", "\N{VARIATION SELECTOR-99}", 'Verify "\N{VS99}" eq "\N{VARIATION SELECTOR-99}"');
+ is("\N{VS100}", "\N{VARIATION SELECTOR-100}", 'Verify "\N{VS100}" eq "\N{VARIATION SELECTOR-100}"');
+ is("\N{VS101}", "\N{VARIATION SELECTOR-101}", 'Verify "\N{VS101}" eq "\N{VARIATION SELECTOR-101}"');
+ is("\N{VS102}", "\N{VARIATION SELECTOR-102}", 'Verify "\N{VS102}" eq "\N{VARIATION SELECTOR-102}"');
+ is("\N{VS103}", "\N{VARIATION SELECTOR-103}", 'Verify "\N{VS103}" eq "\N{VARIATION SELECTOR-103}"');
+ is("\N{VS104}", "\N{VARIATION SELECTOR-104}", 'Verify "\N{VS104}" eq "\N{VARIATION SELECTOR-104}"');
+ is("\N{VS105}", "\N{VARIATION SELECTOR-105}", 'Verify "\N{VS105}" eq "\N{VARIATION SELECTOR-105}"');
+ is("\N{VS106}", "\N{VARIATION SELECTOR-106}", 'Verify "\N{VS106}" eq "\N{VARIATION SELECTOR-106}"');
+ is("\N{VS107}", "\N{VARIATION SELECTOR-107}", 'Verify "\N{VS107}" eq "\N{VARIATION SELECTOR-107}"');
+ is("\N{VS108}", "\N{VARIATION SELECTOR-108}", 'Verify "\N{VS108}" eq "\N{VARIATION SELECTOR-108}"');
+ is("\N{VS109}", "\N{VARIATION SELECTOR-109}", 'Verify "\N{VS109}" eq "\N{VARIATION SELECTOR-109}"');
+ is("\N{VS110}", "\N{VARIATION SELECTOR-110}", 'Verify "\N{VS110}" eq "\N{VARIATION SELECTOR-110}"');
+ is("\N{VS111}", "\N{VARIATION SELECTOR-111}", 'Verify "\N{VS111}" eq "\N{VARIATION SELECTOR-111}"');
+ is("\N{VS112}", "\N{VARIATION SELECTOR-112}", 'Verify "\N{VS112}" eq "\N{VARIATION SELECTOR-112}"');
+ is("\N{VS113}", "\N{VARIATION SELECTOR-113}", 'Verify "\N{VS113}" eq "\N{VARIATION SELECTOR-113}"');
+ is("\N{VS114}", "\N{VARIATION SELECTOR-114}", 'Verify "\N{VS114}" eq "\N{VARIATION SELECTOR-114}"');
+ is("\N{VS115}", "\N{VARIATION SELECTOR-115}", 'Verify "\N{VS115}" eq "\N{VARIATION SELECTOR-115}"');
+ is("\N{VS116}", "\N{VARIATION SELECTOR-116}", 'Verify "\N{VS116}" eq "\N{VARIATION SELECTOR-116}"');
+ is("\N{VS117}", "\N{VARIATION SELECTOR-117}", 'Verify "\N{VS117}" eq "\N{VARIATION SELECTOR-117}"');
+ is("\N{VS118}", "\N{VARIATION SELECTOR-118}", 'Verify "\N{VS118}" eq "\N{VARIATION SELECTOR-118}"');
+ is("\N{VS119}", "\N{VARIATION SELECTOR-119}", 'Verify "\N{VS119}" eq "\N{VARIATION SELECTOR-119}"');
+ is("\N{VS120}", "\N{VARIATION SELECTOR-120}", 'Verify "\N{VS120}" eq "\N{VARIATION SELECTOR-120}"');
+ is("\N{VS121}", "\N{VARIATION SELECTOR-121}", 'Verify "\N{VS121}" eq "\N{VARIATION SELECTOR-121}"');
+ is("\N{VS122}", "\N{VARIATION SELECTOR-122}", 'Verify "\N{VS122}" eq "\N{VARIATION SELECTOR-122}"');
+ is("\N{VS123}", "\N{VARIATION SELECTOR-123}", 'Verify "\N{VS123}" eq "\N{VARIATION SELECTOR-123}"');
+ is("\N{VS124}", "\N{VARIATION SELECTOR-124}", 'Verify "\N{VS124}" eq "\N{VARIATION SELECTOR-124}"');
+ is("\N{VS125}", "\N{VARIATION SELECTOR-125}", 'Verify "\N{VS125}" eq "\N{VARIATION SELECTOR-125}"');
+ is("\N{VS126}", "\N{VARIATION SELECTOR-126}", 'Verify "\N{VS126}" eq "\N{VARIATION SELECTOR-126}"');
+ is("\N{VS127}", "\N{VARIATION SELECTOR-127}", 'Verify "\N{VS127}" eq "\N{VARIATION SELECTOR-127}"');
+ is("\N{VS128}", "\N{VARIATION SELECTOR-128}", 'Verify "\N{VS128}" eq "\N{VARIATION SELECTOR-128}"');
+ is("\N{VS129}", "\N{VARIATION SELECTOR-129}", 'Verify "\N{VS129}" eq "\N{VARIATION SELECTOR-129}"');
+ is("\N{VS130}", "\N{VARIATION SELECTOR-130}", 'Verify "\N{VS130}" eq "\N{VARIATION SELECTOR-130}"');
+ is("\N{VS131}", "\N{VARIATION SELECTOR-131}", 'Verify "\N{VS131}" eq "\N{VARIATION SELECTOR-131}"');
+ is("\N{VS132}", "\N{VARIATION SELECTOR-132}", 'Verify "\N{VS132}" eq "\N{VARIATION SELECTOR-132}"');
+ is("\N{VS133}", "\N{VARIATION SELECTOR-133}", 'Verify "\N{VS133}" eq "\N{VARIATION SELECTOR-133}"');
+ is("\N{VS134}", "\N{VARIATION SELECTOR-134}", 'Verify "\N{VS134}" eq "\N{VARIATION SELECTOR-134}"');
+ is("\N{VS135}", "\N{VARIATION SELECTOR-135}", 'Verify "\N{VS135}" eq "\N{VARIATION SELECTOR-135}"');
+ is("\N{VS136}", "\N{VARIATION SELECTOR-136}", 'Verify "\N{VS136}" eq "\N{VARIATION SELECTOR-136}"');
+ is("\N{VS137}", "\N{VARIATION SELECTOR-137}", 'Verify "\N{VS137}" eq "\N{VARIATION SELECTOR-137}"');
+ is("\N{VS138}", "\N{VARIATION SELECTOR-138}", 'Verify "\N{VS138}" eq "\N{VARIATION SELECTOR-138}"');
+ is("\N{VS139}", "\N{VARIATION SELECTOR-139}", 'Verify "\N{VS139}" eq "\N{VARIATION SELECTOR-139}"');
+ is("\N{VS140}", "\N{VARIATION SELECTOR-140}", 'Verify "\N{VS140}" eq "\N{VARIATION SELECTOR-140}"');
+ is("\N{VS141}", "\N{VARIATION SELECTOR-141}", 'Verify "\N{VS141}" eq "\N{VARIATION SELECTOR-141}"');
+ is("\N{VS142}", "\N{VARIATION SELECTOR-142}", 'Verify "\N{VS142}" eq "\N{VARIATION SELECTOR-142}"');
+ is("\N{VS143}", "\N{VARIATION SELECTOR-143}", 'Verify "\N{VS143}" eq "\N{VARIATION SELECTOR-143}"');
+ is("\N{VS144}", "\N{VARIATION SELECTOR-144}", 'Verify "\N{VS144}" eq "\N{VARIATION SELECTOR-144}"');
+ is("\N{VS145}", "\N{VARIATION SELECTOR-145}", 'Verify "\N{VS145}" eq "\N{VARIATION SELECTOR-145}"');
+ is("\N{VS146}", "\N{VARIATION SELECTOR-146}", 'Verify "\N{VS146}" eq "\N{VARIATION SELECTOR-146}"');
+ is("\N{VS147}", "\N{VARIATION SELECTOR-147}", 'Verify "\N{VS147}" eq "\N{VARIATION SELECTOR-147}"');
+ is("\N{VS148}", "\N{VARIATION SELECTOR-148}", 'Verify "\N{VS148}" eq "\N{VARIATION SELECTOR-148}"');
+ is("\N{VS149}", "\N{VARIATION SELECTOR-149}", 'Verify "\N{VS149}" eq "\N{VARIATION SELECTOR-149}"');
+ is("\N{VS150}", "\N{VARIATION SELECTOR-150}", 'Verify "\N{VS150}" eq "\N{VARIATION SELECTOR-150}"');
+ is("\N{VS151}", "\N{VARIATION SELECTOR-151}", 'Verify "\N{VS151}" eq "\N{VARIATION SELECTOR-151}"');
+ is("\N{VS152}", "\N{VARIATION SELECTOR-152}", 'Verify "\N{VS152}" eq "\N{VARIATION SELECTOR-152}"');
+ is("\N{VS153}", "\N{VARIATION SELECTOR-153}", 'Verify "\N{VS153}" eq "\N{VARIATION SELECTOR-153}"');
+ is("\N{VS154}", "\N{VARIATION SELECTOR-154}", 'Verify "\N{VS154}" eq "\N{VARIATION SELECTOR-154}"');
+ is("\N{VS155}", "\N{VARIATION SELECTOR-155}", 'Verify "\N{VS155}" eq "\N{VARIATION SELECTOR-155}"');
+ is("\N{VS156}", "\N{VARIATION SELECTOR-156}", 'Verify "\N{VS156}" eq "\N{VARIATION SELECTOR-156}"');
+ is("\N{VS157}", "\N{VARIATION SELECTOR-157}", 'Verify "\N{VS157}" eq "\N{VARIATION SELECTOR-157}"');
+ is("\N{VS158}", "\N{VARIATION SELECTOR-158}", 'Verify "\N{VS158}" eq "\N{VARIATION SELECTOR-158}"');
+ is("\N{VS159}", "\N{VARIATION SELECTOR-159}", 'Verify "\N{VS159}" eq "\N{VARIATION SELECTOR-159}"');
+ is("\N{VS160}", "\N{VARIATION SELECTOR-160}", 'Verify "\N{VS160}" eq "\N{VARIATION SELECTOR-160}"');
+ is("\N{VS161}", "\N{VARIATION SELECTOR-161}", 'Verify "\N{VS161}" eq "\N{VARIATION SELECTOR-161}"');
+ is("\N{VS162}", "\N{VARIATION SELECTOR-162}", 'Verify "\N{VS162}" eq "\N{VARIATION SELECTOR-162}"');
+ is("\N{VS163}", "\N{VARIATION SELECTOR-163}", 'Verify "\N{VS163}" eq "\N{VARIATION SELECTOR-163}"');
+ is("\N{VS164}", "\N{VARIATION SELECTOR-164}", 'Verify "\N{VS164}" eq "\N{VARIATION SELECTOR-164}"');
+ is("\N{VS165}", "\N{VARIATION SELECTOR-165}", 'Verify "\N{VS165}" eq "\N{VARIATION SELECTOR-165}"');
+ is("\N{VS166}", "\N{VARIATION SELECTOR-166}", 'Verify "\N{VS166}" eq "\N{VARIATION SELECTOR-166}"');
+ is("\N{VS167}", "\N{VARIATION SELECTOR-167}", 'Verify "\N{VS167}" eq "\N{VARIATION SELECTOR-167}"');
+ is("\N{VS168}", "\N{VARIATION SELECTOR-168}", 'Verify "\N{VS168}" eq "\N{VARIATION SELECTOR-168}"');
+ is("\N{VS169}", "\N{VARIATION SELECTOR-169}", 'Verify "\N{VS169}" eq "\N{VARIATION SELECTOR-169}"');
+ is("\N{VS170}", "\N{VARIATION SELECTOR-170}", 'Verify "\N{VS170}" eq "\N{VARIATION SELECTOR-170}"');
+ is("\N{VS171}", "\N{VARIATION SELECTOR-171}", 'Verify "\N{VS171}" eq "\N{VARIATION SELECTOR-171}"');
+ is("\N{VS172}", "\N{VARIATION SELECTOR-172}", 'Verify "\N{VS172}" eq "\N{VARIATION SELECTOR-172}"');
+ is("\N{VS173}", "\N{VARIATION SELECTOR-173}", 'Verify "\N{VS173}" eq "\N{VARIATION SELECTOR-173}"');
+ is("\N{VS174}", "\N{VARIATION SELECTOR-174}", 'Verify "\N{VS174}" eq "\N{VARIATION SELECTOR-174}"');
+ is("\N{VS175}", "\N{VARIATION SELECTOR-175}", 'Verify "\N{VS175}" eq "\N{VARIATION SELECTOR-175}"');
+ is("\N{VS176}", "\N{VARIATION SELECTOR-176}", 'Verify "\N{VS176}" eq "\N{VARIATION SELECTOR-176}"');
+ is("\N{VS177}", "\N{VARIATION SELECTOR-177}", 'Verify "\N{VS177}" eq "\N{VARIATION SELECTOR-177}"');
+ is("\N{VS178}", "\N{VARIATION SELECTOR-178}", 'Verify "\N{VS178}" eq "\N{VARIATION SELECTOR-178}"');
+ is("\N{VS179}", "\N{VARIATION SELECTOR-179}", 'Verify "\N{VS179}" eq "\N{VARIATION SELECTOR-179}"');
+ is("\N{VS180}", "\N{VARIATION SELECTOR-180}", 'Verify "\N{VS180}" eq "\N{VARIATION SELECTOR-180}"');
+ is("\N{VS181}", "\N{VARIATION SELECTOR-181}", 'Verify "\N{VS181}" eq "\N{VARIATION SELECTOR-181}"');
+ is("\N{VS182}", "\N{VARIATION SELECTOR-182}", 'Verify "\N{VS182}" eq "\N{VARIATION SELECTOR-182}"');
+ is("\N{VS183}", "\N{VARIATION SELECTOR-183}", 'Verify "\N{VS183}" eq "\N{VARIATION SELECTOR-183}"');
+ is("\N{VS184}", "\N{VARIATION SELECTOR-184}", 'Verify "\N{VS184}" eq "\N{VARIATION SELECTOR-184}"');
+ is("\N{VS185}", "\N{VARIATION SELECTOR-185}", 'Verify "\N{VS185}" eq "\N{VARIATION SELECTOR-185}"');
+ is("\N{VS186}", "\N{VARIATION SELECTOR-186}", 'Verify "\N{VS186}" eq "\N{VARIATION SELECTOR-186}"');
+ is("\N{VS187}", "\N{VARIATION SELECTOR-187}", 'Verify "\N{VS187}" eq "\N{VARIATION SELECTOR-187}"');
+ is("\N{VS188}", "\N{VARIATION SELECTOR-188}", 'Verify "\N{VS188}" eq "\N{VARIATION SELECTOR-188}"');
+ is("\N{VS189}", "\N{VARIATION SELECTOR-189}", 'Verify "\N{VS189}" eq "\N{VARIATION SELECTOR-189}"');
+ is("\N{VS190}", "\N{VARIATION SELECTOR-190}", 'Verify "\N{VS190}" eq "\N{VARIATION SELECTOR-190}"');
+ is("\N{VS191}", "\N{VARIATION SELECTOR-191}", 'Verify "\N{VS191}" eq "\N{VARIATION SELECTOR-191}"');
+ is("\N{VS192}", "\N{VARIATION SELECTOR-192}", 'Verify "\N{VS192}" eq "\N{VARIATION SELECTOR-192}"');
+ is("\N{VS193}", "\N{VARIATION SELECTOR-193}", 'Verify "\N{VS193}" eq "\N{VARIATION SELECTOR-193}"');
+ is("\N{VS194}", "\N{VARIATION SELECTOR-194}", 'Verify "\N{VS194}" eq "\N{VARIATION SELECTOR-194}"');
+ is("\N{VS195}", "\N{VARIATION SELECTOR-195}", 'Verify "\N{VS195}" eq "\N{VARIATION SELECTOR-195}"');
+ is("\N{VS196}", "\N{VARIATION SELECTOR-196}", 'Verify "\N{VS196}" eq "\N{VARIATION SELECTOR-196}"');
+ is("\N{VS197}", "\N{VARIATION SELECTOR-197}", 'Verify "\N{VS197}" eq "\N{VARIATION SELECTOR-197}"');
+ is("\N{VS198}", "\N{VARIATION SELECTOR-198}", 'Verify "\N{VS198}" eq "\N{VARIATION SELECTOR-198}"');
+ is("\N{VS199}", "\N{VARIATION SELECTOR-199}", 'Verify "\N{VS199}" eq "\N{VARIATION SELECTOR-199}"');
+ is("\N{VS200}", "\N{VARIATION SELECTOR-200}", 'Verify "\N{VS200}" eq "\N{VARIATION SELECTOR-200}"');
+ is("\N{VS201}", "\N{VARIATION SELECTOR-201}", 'Verify "\N{VS201}" eq "\N{VARIATION SELECTOR-201}"');
+ is("\N{VS202}", "\N{VARIATION SELECTOR-202}", 'Verify "\N{VS202}" eq "\N{VARIATION SELECTOR-202}"');
+ is("\N{VS203}", "\N{VARIATION SELECTOR-203}", 'Verify "\N{VS203}" eq "\N{VARIATION SELECTOR-203}"');
+ is("\N{VS204}", "\N{VARIATION SELECTOR-204}", 'Verify "\N{VS204}" eq "\N{VARIATION SELECTOR-204}"');
+ is("\N{VS205}", "\N{VARIATION SELECTOR-205}", 'Verify "\N{VS205}" eq "\N{VARIATION SELECTOR-205}"');
+ is("\N{VS206}", "\N{VARIATION SELECTOR-206}", 'Verify "\N{VS206}" eq "\N{VARIATION SELECTOR-206}"');
+ is("\N{VS207}", "\N{VARIATION SELECTOR-207}", 'Verify "\N{VS207}" eq "\N{VARIATION SELECTOR-207}"');
+ is("\N{VS208}", "\N{VARIATION SELECTOR-208}", 'Verify "\N{VS208}" eq "\N{VARIATION SELECTOR-208}"');
+ is("\N{VS209}", "\N{VARIATION SELECTOR-209}", 'Verify "\N{VS209}" eq "\N{VARIATION SELECTOR-209}"');
+ is("\N{VS210}", "\N{VARIATION SELECTOR-210}", 'Verify "\N{VS210}" eq "\N{VARIATION SELECTOR-210}"');
+ is("\N{VS211}", "\N{VARIATION SELECTOR-211}", 'Verify "\N{VS211}" eq "\N{VARIATION SELECTOR-211}"');
+ is("\N{VS212}", "\N{VARIATION SELECTOR-212}", 'Verify "\N{VS212}" eq "\N{VARIATION SELECTOR-212}"');
+ is("\N{VS213}", "\N{VARIATION SELECTOR-213}", 'Verify "\N{VS213}" eq "\N{VARIATION SELECTOR-213}"');
+ is("\N{VS214}", "\N{VARIATION SELECTOR-214}", 'Verify "\N{VS214}" eq "\N{VARIATION SELECTOR-214}"');
+ is("\N{VS215}", "\N{VARIATION SELECTOR-215}", 'Verify "\N{VS215}" eq "\N{VARIATION SELECTOR-215}"');
+ is("\N{VS216}", "\N{VARIATION SELECTOR-216}", 'Verify "\N{VS216}" eq "\N{VARIATION SELECTOR-216}"');
+ is("\N{VS217}", "\N{VARIATION SELECTOR-217}", 'Verify "\N{VS217}" eq "\N{VARIATION SELECTOR-217}"');
+ is("\N{VS218}", "\N{VARIATION SELECTOR-218}", 'Verify "\N{VS218}" eq "\N{VARIATION SELECTOR-218}"');
+ is("\N{VS219}", "\N{VARIATION SELECTOR-219}", 'Verify "\N{VS219}" eq "\N{VARIATION SELECTOR-219}"');
+ is("\N{VS220}", "\N{VARIATION SELECTOR-220}", 'Verify "\N{VS220}" eq "\N{VARIATION SELECTOR-220}"');
+ is("\N{VS221}", "\N{VARIATION SELECTOR-221}", 'Verify "\N{VS221}" eq "\N{VARIATION SELECTOR-221}"');
+ is("\N{VS222}", "\N{VARIATION SELECTOR-222}", 'Verify "\N{VS222}" eq "\N{VARIATION SELECTOR-222}"');
+ is("\N{VS223}", "\N{VARIATION SELECTOR-223}", 'Verify "\N{VS223}" eq "\N{VARIATION SELECTOR-223}"');
+ is("\N{VS224}", "\N{VARIATION SELECTOR-224}", 'Verify "\N{VS224}" eq "\N{VARIATION SELECTOR-224}"');
+ is("\N{VS225}", "\N{VARIATION SELECTOR-225}", 'Verify "\N{VS225}" eq "\N{VARIATION SELECTOR-225}"');
+ is("\N{VS226}", "\N{VARIATION SELECTOR-226}", 'Verify "\N{VS226}" eq "\N{VARIATION SELECTOR-226}"');
+ is("\N{VS227}", "\N{VARIATION SELECTOR-227}", 'Verify "\N{VS227}" eq "\N{VARIATION SELECTOR-227}"');
+ is("\N{VS228}", "\N{VARIATION SELECTOR-228}", 'Verify "\N{VS228}" eq "\N{VARIATION SELECTOR-228}"');
+ is("\N{VS229}", "\N{VARIATION SELECTOR-229}", 'Verify "\N{VS229}" eq "\N{VARIATION SELECTOR-229}"');
+ is("\N{VS230}", "\N{VARIATION SELECTOR-230}", 'Verify "\N{VS230}" eq "\N{VARIATION SELECTOR-230}"');
+ is("\N{VS231}", "\N{VARIATION SELECTOR-231}", 'Verify "\N{VS231}" eq "\N{VARIATION SELECTOR-231}"');
+ is("\N{VS232}", "\N{VARIATION SELECTOR-232}", 'Verify "\N{VS232}" eq "\N{VARIATION SELECTOR-232}"');
+ is("\N{VS233}", "\N{VARIATION SELECTOR-233}", 'Verify "\N{VS233}" eq "\N{VARIATION SELECTOR-233}"');
+ is("\N{VS234}", "\N{VARIATION SELECTOR-234}", 'Verify "\N{VS234}" eq "\N{VARIATION SELECTOR-234}"');
+ is("\N{VS235}", "\N{VARIATION SELECTOR-235}", 'Verify "\N{VS235}" eq "\N{VARIATION SELECTOR-235}"');
+ is("\N{VS236}", "\N{VARIATION SELECTOR-236}", 'Verify "\N{VS236}" eq "\N{VARIATION SELECTOR-236}"');
+ is("\N{VS237}", "\N{VARIATION SELECTOR-237}", 'Verify "\N{VS237}" eq "\N{VARIATION SELECTOR-237}"');
+ is("\N{VS238}", "\N{VARIATION SELECTOR-238}", 'Verify "\N{VS238}" eq "\N{VARIATION SELECTOR-238}"');
+ is("\N{VS239}", "\N{VARIATION SELECTOR-239}", 'Verify "\N{VS239}" eq "\N{VARIATION SELECTOR-239}"');
+ is("\N{VS240}", "\N{VARIATION SELECTOR-240}", 'Verify "\N{VS240}" eq "\N{VARIATION SELECTOR-240}"');
+ is("\N{VS241}", "\N{VARIATION SELECTOR-241}", 'Verify "\N{VS241}" eq "\N{VARIATION SELECTOR-241}"');
+ is("\N{VS242}", "\N{VARIATION SELECTOR-242}", 'Verify "\N{VS242}" eq "\N{VARIATION SELECTOR-242}"');
+ is("\N{VS243}", "\N{VARIATION SELECTOR-243}", 'Verify "\N{VS243}" eq "\N{VARIATION SELECTOR-243}"');
+ is("\N{VS244}", "\N{VARIATION SELECTOR-244}", 'Verify "\N{VS244}" eq "\N{VARIATION SELECTOR-244}"');
+ is("\N{VS245}", "\N{VARIATION SELECTOR-245}", 'Verify "\N{VS245}" eq "\N{VARIATION SELECTOR-245}"');
+ is("\N{VS246}", "\N{VARIATION SELECTOR-246}", 'Verify "\N{VS246}" eq "\N{VARIATION SELECTOR-246}"');
+ is("\N{VS247}", "\N{VARIATION SELECTOR-247}", 'Verify "\N{VS247}" eq "\N{VARIATION SELECTOR-247}"');
+ is("\N{VS248}", "\N{VARIATION SELECTOR-248}", 'Verify "\N{VS248}" eq "\N{VARIATION SELECTOR-248}"');
+ is("\N{VS249}", "\N{VARIATION SELECTOR-249}", 'Verify "\N{VS249}" eq "\N{VARIATION SELECTOR-249}"');
+ is("\N{VS250}", "\N{VARIATION SELECTOR-250}", 'Verify "\N{VS250}" eq "\N{VARIATION SELECTOR-250}"');
+ is("\N{VS251}", "\N{VARIATION SELECTOR-251}", 'Verify "\N{VS251}" eq "\N{VARIATION SELECTOR-251}"');
+ is("\N{VS252}", "\N{VARIATION SELECTOR-252}", 'Verify "\N{VS252}" eq "\N{VARIATION SELECTOR-252}"');
+ is("\N{VS253}", "\N{VARIATION SELECTOR-253}", 'Verify "\N{VS253}" eq "\N{VARIATION SELECTOR-253}"');
+ is("\N{VS254}", "\N{VARIATION SELECTOR-254}", 'Verify "\N{VS254}" eq "\N{VARIATION SELECTOR-254}"');
+ is("\N{VS255}", "\N{VARIATION SELECTOR-255}", 'Verify "\N{VS255}" eq "\N{VARIATION SELECTOR-255}"');
+ is("\N{VS256}", "\N{VARIATION SELECTOR-256}", 'Verify "\N{VS256}" eq "\N{VARIATION SELECTOR-256}"');
+
+ # Test a few of the above with :loose
+ use charnames ":loose";
+ is("\N{n-e xt l-i ne}", "\N{n-e xt l-i ne (-n-e l-)}", 'Verify "\N{n-e xt l-i ne}" eq "\N{n-e xt l-i ne (-n-e l-)}"');
+ is("\N{n e-l}", "\N{n e-xt l i-ne ( n e-l )}", 'Verify "\N{n e-l}" eq "\N{n e-xt l i-ne ( n e-l )}"');
+ is("\N{p-a dd-i ng c-h ar-a ct-e r}", "\N{p-a d}", 'Verify "\N{p-a dd-i ng c-h ar-a ct-e r}" eq "\N{p-a d}"');
+ is("\N{s i-ng l-e-s h-i f-t 3}", "\N{s i-ng l-e s h-i f-t t h-r e-e}", 'Verify "\N{s i-ng l-e-s h-i f-t 3}" eq "\N{s i-ng l-e s h-i f-t t h-r e-e}"');
+ is("\N{vs256}", "\N{v-a ri-a ti-o n s-e le-c t o-r-256}", 'Verify "\N{vs256}" eq "\N{v-a ri-a ti-o n s-e le-c t o-r-256}"');
}
# [perl #30409] charnames.pm clobbers default variable
$_ = 'foobar';
eval "use charnames ':full';";
-is($_, 'foobar');
+is($_, 'foobar', 'Verify charnames.pm doesnt clobbers $_');
# Unicode slowdown noted by Phil Pennock, traced to a bug fix in index
# SADAHIRO Tomoyuki's suggestion is to ensure that the UTF-8ness of both
@@ -667,7 +746,7 @@
# may be a problem (khw).
my $names = do "unicore/Name.pl";
-ok(defined $names);
+ok(defined $names, "Verify can read 'unicore/Name.pl'");
my $non_ascii = native_to_latin1($names) =~ tr/\0-\177//c;
ok(! $non_ascii, "Verify all official names are ASCII-only");
@@ -678,11 +757,12 @@
fail('next test also fails to make the same number of tests');
} else {
pass('charnames propagated to eval("")');
- is($evaltry, "Eval: \N{LEFT-POINTING DOUBLE ANGLE QUOTATION MARK}");
+ is($evaltry, "Eval: \N{LEFT-POINTING DOUBLE ANGLE QUOTATION MARK}",
+ "... and got correct answer");
}
# Verify that db includes the normative NameAliases.txt names
-is("\N{U+1D0C5}", "\N{BYZANTINE MUSICAL SYMBOL FTHORA SKLIRON CHROMA VASIS}");
+is("\N{U+1D0C5}", "\N{BYZANTINE MUSICAL SYMBOL FTHORA SKLIRON CHROMA VASIS}", 'Verify "\N{U+1D0C5}" eq "\N{BYZANTINE MUSICAL SYMBOL FTHORA SKLIRON CHROMA VASIS}"');
# [perl #73174] use of \N{FOO} used to reset %^H
@@ -697,9 +777,13 @@
$res .= '-' . ($^H{73174} // "");
$res .= '-2' if ":" =~ /\N{COLON}/;
$res .= '-3' if ":" =~ /\N{COLON}/i;
- is($res, "foo-foo-1--2-3");
+ is($res, "foo-foo-1--2-3", "Verify %^H doesn't get reset by \\N{...}");
}
+{ use charnames qw(.*);
+ ok (! defined charnames::vianame("a"), "Verify that metachars in script names get quoted");
+}
+
{
# Test scoping. Outer block sets up some things; inner blocks
# override them, and then see if get restored.
@@ -753,7 +837,8 @@
is("\N{mychar1}", "f", "Inner block: verify that \\N{mychar1} is redefined");
is(charnames::vianame("mychar1"), ord("f"), "Inner block: verify that vianame(mychar1) is redefined");
is(charnames::string_vianame("mychar1"), "f", "Inner block: verify that string_vianame(mychar1) is redefined");
- is("\N{mychar2}", "\x{FFFD}", "Inner block: verify that \\N{mychar2} outer definition didn't leak");
+ eval '"\N{mychar2}"';
+ like($@, qr/Unknown charname 'mychar2'/, "Inner block: verify that \\N{mychar2} outer definition didn't leak");
ok( ! defined charnames::vianame("mychar2"), "Inner block: verify that vianame(mychar2) outer definition didn't leak");
ok( ! defined charnames::string_vianame("mychar2"), "Inner block: verify that string_vianame(mychar2) outer definition didn't leak");
is("\N{myprivate1}", "\x{E8001}", "Inner block: verify that \\N{myprivate1} is redefined ");
@@ -761,7 +846,8 @@
is(charnames::string_vianame("myprivate1"), chr(0xE8001), "Inner block: verify that string_vianame(myprivate1) is redefined");
is(charnames::viacode(0xE8001), "myprivate1", "Inner block: verify that myprivate1 viacode is redefined");
ok(! defined charnames::viacode(0xE8000), "Inner block: verify that outer myprivate1 viacode didn't leak");
- is("\N{myprivate2}", "\x{FFFD}", "Inner block: verify that \\N{myprivate2} outer definition didn't leak");
+ eval '"\N{myprivate2}"';
+ like($@, qr/Unknown charname 'myprivate2'/, "Inner block: verify that \\N{myprivate2} outer definition didn't leak");
ok(! defined charnames::vianame("myprivate2"), "Inner block: verify that vianame(myprivate2) outer definition didn't leak");
ok(! defined charnames::string_vianame("myprivate2"), "Inner block: verify that string_vianame(myprivate2) outer definition didn't leak");
ok(! defined charnames::viacode(0x100000), "Inner block: verify that myprivate2 viacode outer definition didn't leak");
@@ -768,31 +854,38 @@
is("\N{BE}", $hiragana_be, "Inner block: verify that \\N uses the correct script");
cmp_ok(charnames::vianame("BE"), "==", ord($hiragana_be), "Inner block: verify that vianame uses the correct script");
cmp_ok(charnames::string_vianame("BE"), "==", $hiragana_be, "Inner block: verify that string_vianame uses the correct script");
- is("\N{Hiragana: BE}", "\x{FFFD}", "Inner block without :short: \\N with short doesn't work");
+ eval '"\N{Hiragana: BE}"';
+ like($@, qr/Unknown charname 'Hiragana: BE'/, "Inner block without :short: \\N with short doesn't work");
ok(! defined charnames::vianame("Hiragana: BE"), "Inner block without :short: verify that vianame with short doesn't work");
ok(! defined charnames::string_vianame("Hiragana: BE"), "Inner block without :short: verify that string_vianame with short doesn't work");
{ # An inner block where only :short definitions are valid.
use charnames ":short";
- is("\N{mychar1}", "\x{FFFD}", "Inner inner block: verify that mychar1 outer definition didn't leak with \\N");
+ eval '"\N{mychar1}"';
+ like($@, qr/Unknown charname 'mychar1'/, "Inner inner block: verify that mychar1 outer definition didn't leak with \\N");
ok( ! defined charnames::vianame("mychar1"), "Inner inner block: verify that mychar1 outer definition didn't leak with vianame");
ok( ! defined charnames::string_vianame("mychar1"), "Inner inner block: verify that mychar1 outer definition didn't leak with string_vianame");
- is("\N{mychar2}", "\x{FFFD}", "Inner inner block: verify that mychar2 outer definition didn't leak with \\N");
+ eval '"\N{mychar2}"';
+ like($@, qr/Unknown charname 'mychar2'/, "Inner inner block: verify that mychar2 outer definition didn't leak with \\N");
ok( ! defined charnames::vianame("mychar2"), "Inner inner block: verify that mychar2 outer definition didn't leak with vianame");
ok( ! defined charnames::string_vianame("mychar2"), "Inner inner block: verify that mychar2 outer definition didn't leak with string_vianame");
- is("\N{myprivate1}", "\x{FFFD}", "Inner inner block: verify that myprivate1 outer definition didn't leak with \\N");
+ eval '"\N{myprivate1}"';
+ like($@, qr/Unknown charname 'myprivate1'/, "Inner inner block: verify that myprivate1 outer definition didn't leak with \\N");
ok(! defined charnames::vianame("myprivate1"), "Inner inner block: verify that myprivate1 outer definition didn't leak with vianame");
ok(! defined charnames::string_vianame("myprivate1"), "Inner inner block: verify that myprivate1 outer definition didn't leak with string_vianame");
- is("\N{myprivate2}", "\x{FFFD}", "Inner inner block: verify that myprivate2 outer definition didn't leak with \\N");
+ eval '"\N{myprivate2}"';
+ like($@, qr/Unknown charname 'myprivate2'/, "Inner inner block: verify that myprivate2 outer definition didn't leak with \\N");
ok(! defined charnames::vianame("myprivate2"), "Inner inner block: verify that myprivate2 outer definition didn't leak with vianame");
ok(! defined charnames::string_vianame("myprivate2"), "Inner inner block: verify that myprivate2 outer definition didn't leak with string_vianame");
ok(! defined charnames::viacode(0xE8000), "Inner inner block: verify that mychar1 outer outer definition didn't leak with viacode");
ok(! defined charnames::viacode(0xE8001), "Inner inner block: verify that mychar1 outer definition didn't leak with viacode");
ok(! defined charnames::viacode(0x100000), "Inner inner block: verify that mychar2 outer definition didn't leak with viacode");
- is("\N{BE}", "\x{FFFD}", "Inner inner block without script: verify that outer :script didn't leak with \\N");
+ eval '"\N{BE}"';
+ like($@, qr/Unknown charname 'BE'/, "Inner inner block without script: verify that outer :script didn't leak with \\N");
ok(! defined charnames::vianame("BE"), "Inner inner block without script: verify that outer :script didn't leak with vianames");
ok(! defined charnames::string_vianame("BE"), "Inner inner block without script: verify that outer :script didn't leak with string_vianames");
- is("\N{HIRAGANA LETTER BE}", "\x{FFFD}", "Inner inner block without :full: verify that outer :full didn't leak with \\N");
+ eval '"\N{HIRAGANA LETTER BE}"';
+ like($@, qr/Unknown charname 'HIRAGANA LETTER BE'/, "Inner inner block without :full: verify that outer :full didn't leak with \\N");
is("\N{Hiragana: BE}", $hiragana_be, "Inner inner block with :short: verify that \\N works with :short");
cmp_ok(charnames::vianame("Hiragana: BE"), "==", ord($hiragana_be), "Inner inner block with :short: verify that vianame works with :short");
cmp_ok(charnames::string_vianame("Hiragana: BE"), "==", $hiragana_be, "Inner inner block with :short: verify that string_vianame works with :short");
@@ -802,7 +895,8 @@
is("\N{mychar1}", "f", "Inner block: verify that \\N{mychar1} is redefined");
is(charnames::vianame("mychar1"), ord("f"), "Inner block: verify that vianame(mychar1) is redefined");
is(charnames::string_vianame("mychar1"), "f", "Inner block: verify that string_vianame(mychar1) is redefined");
- is("\N{mychar2}", "\x{FFFD}", "Inner block: verify that \\N{mychar2} outer definition didn't leak");
+ eval '"\N{mychar2}"';
+ like($@, qr/Unknown charname 'mychar2'/, "Inner block: verify that \\N{mychar2} outer definition didn't leak");
ok( ! defined charnames::vianame("mychar2"), "Inner block: verify that vianame(mychar2) outer definition didn't leak");
ok( ! defined charnames::string_vianame("mychar2"), "Inner block: verify that string_vianame(mychar2) outer definition didn't leak");
is("\N{myprivate1}", "\x{E8001}", "Inner block: verify that \\N{myprivate1} is redefined ");
@@ -810,7 +904,8 @@
is(charnames::string_vianame("myprivate1"), chr(0xE8001), "Inner block: verify that string_vianame(myprivate1) is redefined");
is(charnames::viacode(0xE8001), "myprivate1", "Inner block: verify that myprivate1 viacode is redefined");
ok(! defined charnames::viacode(0xE8000), "Inner block: verify that outer myprivate1 viacode didn't leak");
- is("\N{myprivate2}", "\x{FFFD}", "Inner block: verify that \\N{myprivate2} outer definition didn't leak");
+ eval '"\N{myprivate2}"';
+ like($@, qr/Unknown charname 'myprivate2'/, "Inner block: verify that \\N{myprivate2} outer definition didn't leak");
ok(! defined charnames::vianame("myprivate2"), "Inner block: verify that vianame(myprivate2) outer definition didn't leak");
ok(! defined charnames::string_vianame("myprivate2"), "Inner block: verify that string_vianame(myprivate2) outer definition didn't leak");
ok(! defined charnames::viacode(0x100000), "Inner block: verify that myprivate2 viacode outer definition didn't leak");
@@ -817,7 +912,8 @@
is("\N{BE}", $hiragana_be, "Inner block: verify that \\N uses the correct script");
cmp_ok(charnames::vianame("BE"), "==", ord($hiragana_be), "Inner block: verify that vianame uses the correct script");
cmp_ok(charnames::string_vianame("BE"), "==", $hiragana_be, "Inner block: verify that string_vianame uses the correct script");
- is("\N{Hiragana: BE}", "\x{FFFD}", "Inner block without :short: \\N with short doesn't work");
+ eval '"\N{Hiragana: BE}"';
+ like($@, qr/Unknown charname 'Hiragana: BE'/, "Inner block without :short: \\N with short doesn't work");
ok(! defined charnames::vianame("Hiragana: BE"), "Inner block without :short: verify that vianame with short doesn't work");
ok(! defined charnames::string_vianame("Hiragana: BE"), "Inner block without :short: verify that string_vianame with short doesn't work");
}
@@ -843,6 +939,21 @@
is("\N{Hiragana: BE}", $hiragana_be, "Outer block: verify that :short works with \\N");
cmp_ok(charnames::vianame("Hiragana: BE"), "==", ord($hiragana_be), "Outer block: verify that :short works with vianame");
cmp_ok(charnames::string_vianame("Hiragana: BE"), "==", $hiragana_be, "Outer block: verify that :short works with string_vianame");
+ {
+ use charnames qw(:loose new_tai_lue des_eret);
+ is("\N{latincapitallettera}", "A", "Verify that loose matching works");
+ cmp_ok("\N{high-qa}", "==", chr(0x1980), "Verify that loose script list matching works");
+ is(charnames::string_vianame("O-i"), chr(0x10426), "Verify that loose script list matching works with string_vianame");
+ is(charnames::vianame("o i"), 0x1044E, "Verify that loose script list matching works with vianame");
+ }
+ eval '"\N{latincapitallettera}"';
+ like($@, qr/Unknown charname 'latincapitallettera'/, "Verify that loose matching caching doesn't leak outside of scope");
+ {
+ use charnames qw(:loose :short);
+ cmp_ok("\N{co pt-ic:she-i}", "==", chr(0x3E3), "Verify that loose :short matching works");
+ is(charnames::string_vianame("co pt_ic: She i"), chr(0x3E2), "Verify that loose :short matching works with string_vianame");
+ is(charnames::vianame(" Arm-en-ian: x e h_"), 0x56D, "Verify that loose :short matching works with vianame");
+ }
}
{
@@ -876,7 +987,7 @@
# of the character. The percentage of each type to test is
# fuzzily independently settable. This breaks down when the block size is
# 1 or is large enough that both types of names occur in the same block
- my $percentage_of_regular_names = ($run_slow_tests) ? 100 : 25;
+ my $percentage_of_regular_names = ($run_slow_tests) ? 100 : 13;
my $percentage_of_algorithmic_names = (100 / $block_size); # 1 test/block
# If wants everything tested, do so by changing the block size to 1 so
@@ -916,15 +1027,15 @@
my $decimal = hex $code;
# The Unicode version 1 name is used instead of any that are
- # marked <control>
+ # marked <control>.
$name = $u1name if $name eq "<control>";
+ # In earlier Perls, we reject this code point's name (BELL)
+ $name = "" if $^V lt v5.17.0 && $decimal == 0x1F514;
+
+ # ALERT overrides BELL
$name = 'ALERT' if $decimal == 7;
- # XXX This test should be changed for 5.16 when we convert to use
- # Unicode's BELL
- $name = "" if $decimal == 0x1F514;
-
# Some don't have names, leave those array elements undefined
next unless $name;
@@ -956,33 +1067,77 @@
}
close $fh;
- # The Hangul syllable names aren't in the file above; their names
- # are algorithmically determinable, but to avoid perpetuating any
- # programming errors, this file contains the complete list, gathered
- # from the web.
- while (<DATA>) {
- chomp;
- next unless $_; # Guard against empty lines getting inserted.
- my ($code, $name) = split ";";
- my $decimal = hex $code;
- $names[$decimal] = $name;
- my $block = $decimal >> $block_size_bits;
- $algorithmic_names_count[$block] = 1;
+ use Unicode::UCD;
+ if (pack("C*", split /\./, Unicode::UCD::UnicodeVersion()) gt v1.1.5) {
+ # The Hangul syllable names aren't in the file above; their names
+ # are algorithmically determinable, but to avoid perpetuating any
+ # programming errors, this file contains the complete list, gathered
+ # from the web.
+ while (<DATA>) {
+ chomp;
+ next unless $_; # Guard against empty lines getting inserted.
+ my ($code, $name) = split ";";
+ my $decimal = hex $code;
+ $names[$decimal] = $name;
+ my $block = $decimal >> $block_size_bits;
+ $algorithmic_names_count[$block] = 1;
+ }
}
- open $fh, "<", "../../lib/unicore/NameAliases.txt" or
- die "Can't open ../../lib/unicore/NameAliases.txt: $!";
- while (<$fh>) {
+ my @name_aliases;
+ use Unicode::UCD;
+ if (ord('A') != 65
+ || pack( "C*", split /\./, Unicode::UCD::UnicodeVersion()) ge v6.1.0)
+ {
+ open my $fh, "<", "../../lib/unicore/NameAliases.txt"
+ or die "Can't open ../../lib/unicore/NameAliases.txt: $!";
+ @name_aliases = <$fh>
+ }
+ else {
+
+ # If this Unicode version doesn't have the full .txt file, or are on
+ # an EBCDIC platform where they need to be translated, get the data
+ # from prop_invmap() (which should do the translation) and convert it
+ # to the file's format
+ use Unicode::UCD 'prop_invmap';
+ my ($invlist_ref, $invmap_ref, undef, $default)
+ = prop_invmap('Name_Alias');
+ for my $i (0 .. @$invlist_ref - 1) {
+
+ # Convert the aliases for code points that have just one alias to
+ # single element arrays for uniform handling below.
+ if (! ref $invmap_ref->[$i]) {
+
+ # But we test only the real aliases, not the ones which are
+ # just really placeholders.
+ next if $invmap_ref->[$i] eq $default;
+
+ $invmap_ref->[$i] = [ $invmap_ref->[$i] ];
+ }
+
+
+ # Change each alias for the code point to the form that the file
+ # has
+ foreach my $j ($invlist_ref->[$i] .. $invlist_ref->[$i+1] - 1) {
+ foreach my $value (@{$invmap_ref->[$i]}) {
+ $value =~ s/: /;/;
+ push @name_aliases, sprintf("%04X;%s\n", $j, $value);
+ }
+ }
+ }
+ }
+
+ for (@name_aliases) {
chomp;
s/^\s*#.*//;
next unless $_;
- my ($hex, $name) = split ";";
+ my ($hex, $name, $type) = split ";";
my $i = CORE::hex $hex;
# Make sure that both aliases (the one in UnicodeData, and the one we
# just read) return the same code point.
test_vianame($i, $hex, $name);
- test_vianame($i, $hex, $names[$i]);
+ test_vianame($i, $hex, $names[$i]) if $names[$i] ne "";
# Set up so that a test below of this code point will use the alias
# instead of the less-correct original. We can't test here that
@@ -990,7 +1145,7 @@
# aliases for the same code point, and viacode should return only the
# final one. So don't do it here; instead rely on the loop below to
# pick up the test.
- $names[$i] = $name;
+ $names[$i] = $name if $type eq 'correction';
}
close $fh;
@@ -1051,6 +1206,11 @@
my $hex = sprintf("%04X", $i);
if (! $names[$i]) {
+ # These four code points now have names, from NameAlias, but
+ # aren't listed as having names in UnicodeData.txt, so viacode
+ # returns their alias names, not undef
+ next if $i == 0x80 || $i == 0x81 || $i == 0x84 || $i == 0x99;
+
# If there is no name for this code point, all we can
# test is that.
$all_pass &= ok(! defined charnames::viacode($i), "Verify viacode(0x$hex) is undefined");
@@ -1059,8 +1219,14 @@
# Otherwise, test that the name and code point map
# correctly.
$all_pass &= test_vianame($i, $hex, $names[$i]);
- $all_pass &= is(charnames::viacode($i), $names[$i], "Verify viacode(0x$hex) is \"$names[$i]\"");
+ # These four code points have a different Unicode1 name than
+ # regular name, and viacode has already specifically tested
+ # for the regular name
+ if ($i != 0x0a && $i != 0x0c && $i != 0x0d && $i != 0x85) {
+ $all_pass &= is(charnames::viacode($i), $names[$i], "Verify viacode(0x$hex) is \"$names[$i]\"");
+ }
+
# And make sure that a non-algorithmically named code
# point doesn't also map to one that is.
if ($names[$i] !~ /$hex$/) {
@@ -1077,19 +1243,26 @@
$block = $end_block + 1;
}
- open $fh, "<", "../../lib/unicore/NamedSequences.txt" or
- die "Can't open ../../lib/unicore/NamedSequences.txt: $!";
- while (<$fh>) {
- chomp;
- s/^\s*#.*//;
- next unless $_;
- my ($name, $codes) = split ";";
- my $utf8 = pack("U*", map { hex } split " ", $codes);
- is(charnames::string_vianame($name), $utf8, "Verify string_vianame(\"$name\") is the proper utf8");
- is(charnames::string_vianame($name), $utf8, "Verify string_vianame(\"$name\") is the proper utf8");
- #diag("$name, $utf8");
+ if (open my $fh, "<", "../../lib/unicore/NamedSequences.txt") {
+ while (<$fh>) {
+ chomp;
+ s/^\s*#.*//;
+ next unless $_;
+ my ($name, $codes) = split ";";
+ my $utf8 = pack("U*", map { hex } split " ", $codes);
+ is(charnames::string_vianame($name), $utf8, "Verify string_vianame(\"$name\") is the proper utf8");
+ my $loose_name = get_loose_name($name);
+ use charnames ":loose";
+ is(charnames::string_vianame($loose_name), $utf8, "Verify string_vianame(\"$loose_name\") is the proper utf8");
+ #diag("$name, $utf8");
+ }
+ close $fh;
}
- close $fh;
+ else {
+ use Unicode::UCD;
+ die "Can't open ../../lib/unicore/NamedSequences.txt: $!"
+ if pack("C*", split /\./, Unicode::UCD::UnicodeVersion()) ge v4.1.0;
+ }
unless ($all_pass) {
Property changes on: trunk/contrib/perl/lib/charnames.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/lib/complete.pl
===================================================================
--- trunk/contrib/perl/lib/complete.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/complete.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/complete.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/lib/constant.pm (from rev 6437, vendor/perl/5.18.1/lib/constant.pm)
===================================================================
--- trunk/contrib/perl/lib/constant.pm (rev 0)
+++ trunk/contrib/perl/lib/constant.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,374 @@
+package constant;
+use 5.005;
+use strict;
+use warnings::register;
+
+use vars qw($VERSION %declared);
+$VERSION = '1.17';
+
+#=======================================================================
+
+# Some names are evil choices.
+my %keywords = map +($_, 1), qw{ BEGIN INIT CHECK END DESTROY AUTOLOAD };
+$keywords{UNITCHECK}++ if $] > 5.009;
+
+my %forced_into_main = map +($_, 1),
+ qw{ STDIN STDOUT STDERR ARGV ARGVOUT ENV INC SIG };
+
+my %forbidden = (%keywords, %forced_into_main);
+
+#=======================================================================
+# import() - import symbols into user's namespace
+#
+# What we actually do is define a function in the caller's namespace
+# which returns the value. The function we create will normally
+# be inlined as a constant, thereby avoiding further sub calling
+# overhead.
+#=======================================================================
+sub import {
+ my $class = shift;
+ return unless @_; # Ignore 'use constant;'
+ my $constants;
+ my $multiple = ref $_[0];
+ my $pkg = caller;
+ my $symtab;
+ my $str_end = $] >= 5.006 ? "\\z" : "\\Z";
+
+ if ($] > 5.009002) {
+ no strict 'refs';
+ $symtab = \%{$pkg . '::'};
+ };
+
+ if ( $multiple ) {
+ if (ref $_[0] ne 'HASH') {
+ require Carp;
+ Carp::croak("Invalid reference type '".ref(shift)."' not 'HASH'");
+ }
+ $constants = shift;
+ } else {
+ $constants->{+shift} = undef;
+ }
+
+ foreach my $name ( keys %$constants ) {
+ unless (defined $name) {
+ require Carp;
+ Carp::croak("Can't use undef as constant name");
+ }
+
+ # Normal constant name
+ if ($name =~ /^_?[^\W_0-9]\w*$str_end/ and !$forbidden{$name}) {
+ # Everything is okay
+
+ # Name forced into main, but we're not in main. Fatal.
+ } elsif ($forced_into_main{$name} and $pkg ne 'main') {
+ require Carp;
+ Carp::croak("Constant name '$name' is forced into main::");
+
+ # Starts with double underscore. Fatal.
+ } elsif ($name =~ /^__/) {
+ require Carp;
+ Carp::croak("Constant name '$name' begins with '__'");
+
+ # Maybe the name is tolerable
+ } elsif ($name =~ /^[A-Za-z_]\w*$str_end/) {
+ # Then we'll warn only if you've asked for warnings
+ if (warnings::enabled()) {
+ if ($keywords{$name}) {
+ warnings::warn("Constant name '$name' is a Perl keyword");
+ } elsif ($forced_into_main{$name}) {
+ warnings::warn("Constant name '$name' is " .
+ "forced into package main::");
+ }
+ }
+
+ # Looks like a boolean
+ # use constant FRED == fred;
+ } elsif ($name =~ /^[01]?$str_end/) {
+ require Carp;
+ if (@_) {
+ Carp::croak("Constant name '$name' is invalid");
+ } else {
+ Carp::croak("Constant name looks like boolean value");
+ }
+
+ } else {
+ # Must have bad characters
+ require Carp;
+ Carp::croak("Constant name '$name' has invalid characters");
+ }
+
+ {
+ no strict 'refs';
+ my $full_name = "${pkg}::$name";
+ $declared{$full_name}++;
+ if ($multiple || @_ == 1) {
+ my $scalar = $multiple ? $constants->{$name} : $_[0];
+ if ($symtab && !exists $symtab->{$name}) {
+ # No typeglob yet, so we can use a reference as space-
+ # efficient proxy for a constant subroutine
+ # 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);
+ $symtab->{$name} = \$scalar;
+ mro::method_changed_in($pkg);
+ } else {
+ *$full_name = sub () { $scalar };
+ }
+ } elsif (@_) {
+ my @list = @_;
+ *$full_name = sub () { @list };
+ } else {
+ *$full_name = sub () { };
+ }
+ }
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+constant - Perl pragma to declare constants
+
+=head1 SYNOPSIS
+
+ use constant PI => 4 * atan2(1, 1);
+ use constant DEBUG => 0;
+
+ print "Pi equals ", PI, "...\n" if DEBUG;
+
+ use constant {
+ SEC => 0,
+ MIN => 1,
+ HOUR => 2,
+ MDAY => 3,
+ MON => 4,
+ YEAR => 5,
+ WDAY => 6,
+ YDAY => 7,
+ ISDST => 8,
+ };
+
+ use constant WEEKDAYS => qw(
+ Sunday Monday Tuesday Wednesday Thursday Friday Saturday
+ );
+
+ print "Today is ", (WEEKDAYS)[ (localtime)[WDAY] ], ".\n";
+
+=head1 DESCRIPTION
+
+This pragma allows you to declare constants at compile-time.
+
+When you declare a constant such as C<PI> using the method shown
+above, each machine your script runs upon can have as many digits
+of accuracy as it can use. Also, your program will be easier to
+read, more likely to be maintained (and maintained correctly), and
+far less likely to send a space probe to the wrong planet because
+nobody noticed the one equation in which you wrote C<3.14195>.
+
+When a constant is used in an expression, Perl replaces it with its
+value at compile time, and may then optimize the expression further.
+In particular, any code in an C<if (CONSTANT)> block will be optimized
+away if the constant is false.
+
+=head1 NOTES
+
+As with all C<use> directives, defining a constant happens at
+compile time. Thus, it's probably not correct to put a constant
+declaration inside of a conditional statement (like C<if ($foo)
+{ use constant ... }>).
+
+Constants defined using this module cannot be interpolated into
+strings like variables. However, concatenation works just fine:
+
+ print "Pi equals PI...\n"; # WRONG: does not expand "PI"
+ print "Pi equals ".PI."...\n"; # right
+
+Even though a reference may be declared as a constant, the reference may
+point to data which may be changed, as this code shows.
+
+ use constant ARRAY => [ 1,2,3,4 ];
+ print ARRAY->[1];
+ 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<Some::Package::CONSTANT>. Constants may be exported by modules,
+and may also be called as either class or instance methods, that is,
+as C<< Some::Package->CONSTANT >> or as C<< $obj->CONSTANT >> where
+C<$obj> is an instance of C<Some::Package>. Subclasses may define
+their own constants to override those in their base class.
+
+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
+subroutine names. Constant names must begin with a letter or
+underscore. Names beginning with a double underscore are reserved. Some
+poor choices for names will generate warnings, if warnings are enabled at
+compile time.
+
+=head2 List constants
+
+Constants may be lists of more (or less) than one value. A constant
+with no values evaluates to C<undef> in scalar context. Note that
+constants with more than one value do I<not> return their last value in
+scalar context as one might expect. They currently return the number
+of values, but B<this may change in the future>. Do not use constants
+with multiple values in scalar context.
+
+B<NOTE:> This implies that the expression defining the value of a
+constant is evaluated in list context. This may produce surprises:
+
+ use constant TIMESTAMP => localtime; # WRONG!
+ use constant TIMESTAMP => scalar localtime; # right
+
+The first line above defines C<TIMESTAMP> as a 9-element list, as
+returned by C<localtime()> in list context. To set it to the string
+returned by C<localtime()> in scalar context, an explicit C<scalar>
+keyword is required.
+
+List constants are lists, not arrays. To index or slice them, they
+must be placed in parentheses.
+
+ my @workdays = WEEKDAYS[1 .. 5]; # WRONG!
+ my @workdays = (WEEKDAYS)[1 .. 5]; # right
+
+=head2 Defining multiple constants at once
+
+Instead of writing multiple C<use constant> statements, you may define
+multiple constants in a single statement by giving, instead of the
+constant name, a reference to a hash where the keys are the names of
+the constants to be defined. Obviously, all constants defined using
+this method must have a single value.
+
+ use constant {
+ FOO => "A single value",
+ BAR => "This", "won't", "work!", # Error!
+ };
+
+This is a fundamental limitation of the way hashes are constructed in
+Perl. The error messages produced when this happens will often be
+quite cryptic -- in the worst case there may be none at all, and
+you'll only later find that something is broken.
+
+When defining multiple constants, you cannot use the values of other
+constants defined in the same declaration. This is because the
+calling package doesn't know about any constant within that group
+until I<after> the C<use> statement is finished.
+
+ use constant {
+ BITMASK => 0xAFBAEBA8,
+ NEGMASK => ~BITMASK, # Error!
+ };
+
+=head2 Magic constants
+
+Magical values and references can be made into constants at compile
+time, allowing for way cool stuff like this. (These error numbers
+aren't totally portable, alas.)
+
+ use constant E2BIG => ($! = 7);
+ print E2BIG, "\n"; # something like "Arg list too long"
+ print 0+E2BIG, "\n"; # "7"
+
+You can't produce a tied constant by giving a tied scalar as the
+value. References to tied variables, however, can be used as
+constants without any problems.
+
+=head1 TECHNICAL NOTES
+
+In the current implementation, scalar constants are actually
+inlinable subroutines. As of version 5.004 of Perl, the appropriate
+scalar constant is inserted directly in place of some subroutine
+calls, thereby saving the overhead of a subroutine call. See
+L<perlsub/"Constant Functions"> for details about how and when this
+happens.
+
+In the rare case in which you need to discover at run time whether a
+particular constant has been declared via this module, you may use
+this function to examine the hash C<%constant::declared>. If the given
+constant name does not include a package name, the current package is
+used.
+
+ sub declared ($) {
+ use constant 1.01; # don't omit this!
+ my $name = shift;
+ $name =~ s/^::/main::/;
+ my $pkg = caller;
+ my $full_name = $name =~ /::/ ? $name : "${pkg}::$name";
+ $constant::declared{$full_name};
+ }
+
+=head1 CAVEATS
+
+In the current version of Perl, list constants are not inlined
+and some symbols may be redefined without generating a warning.
+
+It is not possible to have a subroutine or a keyword with the same
+name as a constant in the same package. This is probably a Good Thing.
+
+A constant with a name in the list C<STDIN STDOUT STDERR ARGV ARGVOUT
+ENV INC SIG> is not allowed anywhere but in package C<main::>, for
+technical reasons.
+
+Unlike constants in some languages, these cannot be overridden
+on the command line or via environment variables.
+
+You can get into trouble if you use constants in a context which
+automatically quotes barewords (as is true for any subroutine call).
+For example, you can't say C<$hash{CONSTANT}> because C<CONSTANT> will
+be interpreted as a string. Use C<$hash{CONSTANT()}> or
+C<$hash{+CONSTANT}> to prevent the bareword quoting mechanism from
+kicking in. Similarly, since the C<< => >> operator quotes a bareword
+immediately to its left, you have to say C<< CONSTANT() => 'value' >>
+(or simply use a comma in place of the big arrow) instead of
+C<< CONSTANT => 'value' >>.
+
+=head1 SEE ALSO
+
+L<Readonly> - Facility for creating read-only scalars, arrays, hashes.
+
+L<Const> - Facility for creating read-only variables. Similar to C<Readonly>,
+but uses C<SvREADONLY> instead of C<tie>.
+
+L<Attribute::Constant> - Make read-only variables via attribute
+
+L<Scalar::Readonly> - Perl extension to the C<SvREADONLY> scalar flag
+
+L<Hash::Util> - A selection of general-utility hash subroutines (mostly
+to lock/unlock keys and values)
+
+=head1 BUGS
+
+Please report any bugs or feature requests via the perlbug(1) utility.
+
+=head1 AUTHORS
+
+Tom Phoenix, E<lt>F<rootbeer at redcat.com>E<gt>, with help from
+many other folks.
+
+Multiple constant declarations at once added by Casey West,
+E<lt>F<casey at geeknest.com>E<gt>.
+
+Documentation mostly rewritten by Ilmari Karonen,
+E<lt>F<perl at itz.pp.sci.fi>E<gt>.
+
+This program is maintained by the Perl 5 Porters.
+The CPAN distribution is maintained by SE<eacute>bastien Aperghis-Tramoni
+E<lt>F<sebastien at aperghis.net>E<gt>.
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright (C) 1997, 1999 Tom Phoenix
+
+This module is free software; you can redistribute it or modify it
+under the same terms as Perl itself.
+
+=cut
Copied: trunk/contrib/perl/lib/constant.t (from rev 6437, vendor/perl/5.18.1/lib/constant.t)
===================================================================
--- trunk/contrib/perl/lib/constant.t (rev 0)
+++ trunk/contrib/perl/lib/constant.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,350 @@
+#!./perl -T
+
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+}
+
+use warnings;
+use vars qw{ @warnings $fagwoosh $putt $kloong};
+BEGIN { # ...and save 'em for later
+ $SIG{'__WARN__'} = sub { push @warnings, @_ }
+}
+END { @warnings && print STDERR join "\n- ", "accumulated warnings:", @warnings }
+
+
+use strict;
+use Test::More tests => 95;
+my $TB = Test::More->builder;
+
+BEGIN { use_ok('constant'); }
+
+use constant PI => 4 * atan2 1, 1;
+
+ok defined PI, 'basic scalar constant';
+is substr(PI, 0, 7), '3.14159', ' in substr()';
+
+sub deg2rad { PI * $_[0] / 180 }
+
+my $ninety = deg2rad 90;
+
+cmp_ok abs($ninety - 1.5707), '<', 0.0001, ' in math expression';
+
+use constant UNDEF1 => undef; # the right way
+use constant UNDEF2 => ; # the weird way
+use constant 'UNDEF3' ; # the 'short' way
+use constant EMPTY => ( ) ; # the right way for lists
+
+is UNDEF1, undef, 'right way to declare an undef';
+is UNDEF2, undef, ' weird way';
+is UNDEF3, undef, ' short way';
+
+# XXX Why is this way different than the other ones?
+my @undef = UNDEF1;
+is @undef, 1;
+is $undef[0], undef;
+
+ at undef = UNDEF2;
+is @undef, 0;
+ at undef = UNDEF3;
+is @undef, 0;
+ at undef = EMPTY;
+is @undef, 0;
+
+use constant COUNTDOWN => scalar reverse 1, 2, 3, 4, 5;
+use constant COUNTLIST => reverse 1, 2, 3, 4, 5;
+use constant COUNTLAST => (COUNTLIST)[-1];
+
+is COUNTDOWN, '54321';
+my @cl = COUNTLIST;
+is @cl, 5;
+is COUNTDOWN, join '', @cl;
+is COUNTLAST, 1;
+is((COUNTLIST)[1], 4);
+
+use constant ABC => 'ABC';
+is "abc${\( ABC )}abc", "abcABCabc";
+
+use constant DEF => 'D', 'E', chr ord 'F';
+is "d e f @{[ DEF ]} d e f", "d e f D E F d e f";
+
+use constant SINGLE => "'";
+use constant DOUBLE => '"';
+use constant BACK => '\\';
+my $tt = BACK . SINGLE . DOUBLE ;
+is $tt, q(\\'");
+
+use constant MESS => q('"'\\"'"\\);
+is MESS, q('"'\\"'"\\);
+is length(MESS), 8;
+
+use constant LEADING => " \t1234";
+cmp_ok LEADING, '==', 1234;
+is LEADING, " \t1234";
+
+use constant ZERO1 => 0;
+use constant ZERO2 => 0.0;
+use constant ZERO3 => '0.0';
+is ZERO1, '0';
+is ZERO2, '0';
+is ZERO3, '0.0';
+
+{
+ package Other;
+ use constant PI => 3.141;
+}
+
+cmp_ok(abs(PI - 3.1416), '<', 0.0001);
+is Other::PI, 3.141;
+
+use constant E2BIG => $! = 7;
+cmp_ok E2BIG, '==', 7;
+# This is something like "Arg list too long", but the actual message
+# text may vary, so we can't test much better than this.
+cmp_ok length(E2BIG), '>', 6;
+
+is @warnings, 0 or diag join "\n- ", "unexpected warning:", @warnings;
+ at warnings = (); # just in case
+undef &PI;
+ok @warnings && ($warnings[0] =~ /Constant sub.* undefined/) or
+ diag join "\n", "unexpected warning", @warnings;
+shift @warnings;
+
+is @warnings, 0, "unexpected warning";
+
+my $curr_test = $TB->current_test;
+use constant CSCALAR => \"ok 35\n";
+use constant CHASH => { foo => "ok 36\n" };
+use constant CARRAY => [ undef, "ok 37\n" ];
+use constant CCODE => sub { "ok $_[0]\n" };
+
+my $output = $TB->output ;
+print $output ${+CSCALAR};
+print $output CHASH->{foo};
+print $output CARRAY->[1];
+print $output CCODE->($curr_test+4);
+
+$TB->current_test($curr_test+4);
+
+eval q{ CCODE->{foo} };
+ok scalar($@ =~ /^Constant is not a HASH/);
+
+
+# Allow leading underscore
+use constant _PRIVATE => 47;
+is _PRIVATE, 47;
+
+# Disallow doubled leading underscore
+eval q{
+ use constant __DISALLOWED => "Oops";
+};
+like $@, qr/begins with '__'/;
+
+# Check on declared() and %declared. This sub should be EXACTLY the
+# same as the one quoted in the docs!
+sub declared ($) {
+ use constant 1.01; # don't omit this!
+ my $name = shift;
+ $name =~ s/^::/main::/;
+ my $pkg = caller;
+ my $full_name = $name =~ /::/ ? $name : "${pkg}::$name";
+ $constant::declared{$full_name};
+}
+
+ok declared 'PI';
+ok $constant::declared{'main::PI'};
+
+ok !declared 'PIE';
+ok !$constant::declared{'main::PIE'};
+
+{
+ package Other;
+ use constant IN_OTHER_PACK => 42;
+ ::ok ::declared 'IN_OTHER_PACK';
+ ::ok $constant::declared{'Other::IN_OTHER_PACK'};
+ ::ok ::declared 'main::PI';
+ ::ok $constant::declared{'main::PI'};
+}
+
+ok declared 'Other::IN_OTHER_PACK';
+ok $constant::declared{'Other::IN_OTHER_PACK'};
+
+ at warnings = ();
+eval q{
+ no warnings;
+ #local $^W if $] < 5.006;
+ use warnings 'constant';
+ use constant 'BEGIN' => 1 ;
+ use constant 'INIT' => 1 ;
+ use constant 'CHECK' => 1 ;
+ use constant 'END' => 1 ;
+ use constant 'DESTROY' => 1 ;
+ use constant 'AUTOLOAD' => 1 ;
+ use constant 'STDIN' => 1 ;
+ use constant 'STDOUT' => 1 ;
+ use constant 'STDERR' => 1 ;
+ use constant 'ARGV' => 1 ;
+ use constant 'ARGVOUT' => 1 ;
+ use constant 'ENV' => 1 ;
+ use constant 'INC' => 1 ;
+ use constant 'SIG' => 1 ;
+ use constant 'UNITCHECK' => 1;
+};
+
+my @Expected_Warnings =
+ (
+ qr/^Constant name 'BEGIN' is a Perl keyword at/,
+ qr/^Constant subroutine BEGIN redefined at/,
+ qr/^Constant name 'INIT' is a Perl keyword at/,
+ qr/^Constant name 'CHECK' is a Perl keyword at/,
+ qr/^Constant name 'END' is a Perl keyword at/,
+ qr/^Constant name 'DESTROY' is a Perl keyword at/,
+ qr/^Constant name 'AUTOLOAD' is a Perl keyword at/,
+ qr/^Constant name 'STDIN' is forced into package main:: a/,
+ qr/^Constant name 'STDOUT' is forced into package main:: at/,
+ qr/^Constant name 'STDERR' is forced into package main:: at/,
+ qr/^Constant name 'ARGV' is forced into package main:: at/,
+ qr/^Constant name 'ARGVOUT' is forced into package main:: at/,
+ qr/^Constant name 'ENV' is forced into package main:: at/,
+ qr/^Constant name 'INC' is forced into package main:: at/,
+ qr/^Constant name 'SIG' is forced into package main:: at/,
+ qr/^Constant name 'UNITCHECK' is a Perl keyword at/,
+);
+
+unless ($] > 5.009) {
+ # Remove the UNITCHECK warning
+ pop @Expected_Warnings;
+ # But keep the count the same
+ push @Expected_Warnings, qr/^$/;
+ push @warnings, "";
+}
+
+# when run under "make test"
+if (@warnings == 16) {
+ push @warnings, "";
+ push @Expected_Warnings, qr/^$/;
+}
+# when run directly: perl -wT -Ilib t/constant.t
+elsif (@warnings == 17) {
+ splice @Expected_Warnings, 1, 0,
+ qr/^Prototype mismatch: sub main::BEGIN \(\) vs none at/;
+}
+# when run directly under 5.6.2: perl -wT -Ilib t/constant.t
+elsif (@warnings == 15) {
+ splice @Expected_Warnings, 1, 1;
+ push @warnings, "", "";
+ push @Expected_Warnings, qr/^$/, qr/^$/;
+}
+else {
+ my $rule = " -" x 20;
+ diag "/!\\ unexpected case: ", scalar @warnings, " warnings\n$rule\n";
+ diag map { " $_" } @warnings;
+ diag $rule, $/;
+}
+
+is @warnings, 17;
+
+for my $idx (0..$#warnings) {
+ like $warnings[$idx], $Expected_Warnings[$idx];
+}
+
+ at warnings = ();
+
+
+use constant {
+ THREE => 3,
+ FAMILY => [ qw( John Jane Sally ) ],
+ AGES => { John => 33, Jane => 28, Sally => 3 },
+ RFAM => [ [ qw( John Jane Sally ) ] ],
+ SPIT => sub { shift },
+};
+
+is @{+FAMILY}, THREE;
+is @{+FAMILY}, @{RFAM->[0]};
+is FAMILY->[2], RFAM->[0]->[2];
+is AGES->{FAMILY->[1]}, 28;
+is THREE**3, SPIT->(@{+FAMILY}**3);
+
+# Allow name of digits/underscores only if it begins with underscore
+{
+ use warnings FATAL => 'constant';
+ eval q{
+ use constant _1_2_3 => 'allowed';
+ };
+ ok( $@ eq '' );
+}
+
+sub slotch ();
+
+{
+ my @warnings;
+ local $SIG{'__WARN__'} = sub { push @warnings, @_ };
+ eval 'use constant slotch => 3; 1' or die $@;
+
+ is ("@warnings", "", "No warnings if a prototype exists");
+
+ my $value = eval 'slotch';
+ is ($@, '');
+ is ($value, 3);
+}
+
+sub zit;
+
+{
+ my @warnings;
+ local $SIG{'__WARN__'} = sub { push @warnings, @_ };
+ eval 'use constant zit => 4; 1' or die $@;
+
+ # empty prototypes are reported differently in different versions
+ my $no_proto = $] < 5.008004 ? "" : ": none";
+
+ is(scalar @warnings, 1, "1 warning");
+ like ($warnings[0], qr/^Prototype mismatch: sub main::zit$no_proto vs \(\)/,
+ "about the prototype mismatch");
+
+ my $value = eval 'zit';
+ is ($@, '');
+ is ($value, 4);
+}
+
+$fagwoosh = 'geronimo';
+$putt = 'leutwein';
+$kloong = 'schlozhauer';
+
+{
+ my @warnings;
+ local $SIG{'__WARN__'} = sub { push @warnings, @_ };
+ eval 'use constant fagwoosh => 5; 1' or die $@;
+
+ is ("@warnings", "", "No warnings if the typeglob exists already");
+
+ my $value = eval 'fagwoosh';
+ is ($@, '');
+ is ($value, 5);
+
+ my @value = eval 'fagwoosh';
+ is ($@, '');
+ is_deeply (\@value, [5]);
+
+ eval 'use constant putt => 6, 7; 1' or die $@;
+
+ is ("@warnings", "", "No warnings if the typeglob exists already");
+
+ @value = eval 'putt';
+ is ($@, '');
+ is_deeply (\@value, [6, 7]);
+
+ eval 'use constant "klong"; 1' or die $@;
+
+ is ("@warnings", "", "No warnings if the typeglob exists already");
+
+ $value = eval 'klong';
+ is ($@, '');
+ is ($value, undef);
+
+ @value = eval 'klong';
+ is ($@, '');
+ is_deeply (\@value, []);
+}
Index: trunk/contrib/perl/lib/ctime.pl
===================================================================
--- trunk/contrib/perl/lib/ctime.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/ctime.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/ctime.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/lib/dbm_filter_util.pl
===================================================================
--- trunk/contrib/perl/lib/dbm_filter_util.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/dbm_filter_util.pl 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,6 +1,9 @@
use strict;
use warnings;
+use Data::Dumper;
+*qquote= *Data::Dumper::qquote;
+
sub StoreData
{
my $hashref = shift ;
@@ -36,11 +39,11 @@
while (my ($k, $v) = each %$hashref) {
no warnings 'uninitialized';
if ($expected{$k} eq $v) {
- #diag "Match [$k][$v]";
+ #diag "Match " . qquote($k) . " => " . qquote($v);
delete $expected{$k} ;
}
else {
- #diag "No Match [$k][$v]";
+ #diag "No Match " . qquote($k) . " => " . qquote($v) . " want " . qquote($expected{$k});
$bad{$k} = $v;
}
}
@@ -50,7 +53,7 @@
if (keys %expected ) {
$bad .=" No Match from Expected:\n" ;
while (my ($k, $v) = each %expected) {
- $bad .= "\t'$k' =>\t'$v'\n";
+ $bad .= "\t" . qquote($k) . " => " . qquote($v) . "\n";
}
}
if (keys %bad ) {
@@ -57,10 +60,10 @@
$bad .= "\n No Match from Actual:\n" ;
while (my ($k, $v) = each %bad) {
no warnings 'uninitialized';
- $bad .= "\t'$k' =>\t'$v'\n";
+ $bad .= "\t" . qquote($k) . " => " . qquote($v) . "\n";
}
}
- diag "${bad}\n" ;
+ diag( "${bad}\n" );
}
}
Property changes on: trunk/contrib/perl/lib/dbm_filter_util.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/deprecate.pm
===================================================================
--- trunk/contrib/perl/lib/deprecate.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/deprecate.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/deprecate.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/lib/diagnostics.pm
===================================================================
--- trunk/contrib/perl/lib/diagnostics.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/diagnostics.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -59,13 +59,14 @@
allowing duplicate user messages to be displayed.
This module also adds a stack trace to the error message when perl dies.
-This is useful for pinpointing what caused the death. The B<-traceonly> (or
+This is useful for pinpointing what
+caused the death. The B<-traceonly> (or
just B<-t>) flag turns off the explanations of warning messages leaving just
-the stack traces. So if your script is dieing, run it again with
+the stack traces. So if your script is dieing, run it again with
perl -Mdiagnostics=-traceonly my_bad_script
-to see the call stack at the time of death. By supplying the B<-warntrace>
+to see the call stack at the time of death. By supplying the B<-warntrace>
(or just B<-w>) flag, any warnings emitted will also come with a stack
trace.
@@ -185,7 +186,7 @@
use Carp;
$Carp::Internal{__PACKAGE__.""}++;
-our $VERSION = '1.22';
+our $VERSION = '1.31';
our $DEBUG;
our $VERBOSE;
our $PRETTY;
@@ -193,18 +194,13 @@
our $WARNTRACE = 0;
use Config;
-my($privlib, $archlib) = @Config{qw(privlibexp archlibexp)};
+my $privlib = $Config{privlibexp};
if ($^O eq 'VMS') {
require VMS::Filespec;
$privlib = VMS::Filespec::unixify($privlib);
- $archlib = VMS::Filespec::unixify($archlib);
}
my @trypod = (
- "$archlib/pod/perldiag.pod",
- "$privlib/pod/perldiag-$Config{version}.pod",
"$privlib/pod/perldiag.pod",
- "$archlib/pods/perldiag.pod",
- "$privlib/pods/perldiag-$Config{version}.pod",
"$privlib/pods/perldiag.pod",
);
# handy for development testing of new warnings etc
@@ -215,7 +211,7 @@
my $WHOAMI = ref bless []; # nobody's business, prolly not even mine
local $| = 1;
-my $_;
+local $_;
local $.;
my $standalone;
@@ -311,7 +307,6 @@
my $transmo = <<EOFUNC;
sub transmo {
#local \$^W = 0; # recursive warnings we do NOT need!
- study;
EOFUNC
my %msg;
@@ -318,6 +313,7 @@
{
print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
local $/ = '';
+ local $_;
my $header;
my @headers;
my $for_item;
@@ -344,6 +340,9 @@
? italic($sect) . ' in ' . italic($page)
: italic($page)
/ges;
+ s/S<(.*?)>/
+ $1
+ /ges;
} else {
s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/$+/gs;
s/[IF]<(.*?)>/$1/gs;
@@ -355,6 +354,9 @@
? qq '"$sect" in $page'
: $page
/ges;
+ s/S<(.*?)>/
+ $1
+ /ges;
}
unless (/^=/) {
if (defined $header) {
@@ -383,7 +385,7 @@
push @headers, $header if defined $header;
}
- unless ( s/=item (.*?)\s*\z//) {
+ unless ( s/=item (.*?)\s*\z//s) {
if ( s/=head1\sDESCRIPTION//) {
$msg{$header = 'DESCRIPTION'} = '';
@@ -398,16 +400,17 @@
if( $for_item ) { $header = $for_item; undef $for_item }
else {
$header = $1;
- while( $header =~ /[;,]\z/ ) {
- <POD_DIAG> =~ /^\s*(.*?)\s*\z/;
- $header .= ' '.$1;
- }
+
+ $header =~ s/\n/ /gs; # Allow multi-line headers
}
# strip formatting directives from =item line
$header =~ s/[A-Z]<(.*?)>/$1/g;
- my @toks = split( /(%l?[dx]|%c|%(?:\.\d+)?[fs])/, $header );
+ # Since we strip "(\.\s*)\n" when we search a warning, strip it here as well
+ $header =~ s/(\.\s*)?$//;
+
+ my @toks = split( /(%l?[dxX]|%[ucp]|%(?:\.\d+)?[fs])/, $header );
if (@toks > 1) {
my $conlen = 0;
for my $i (0..$#toks){
@@ -414,15 +417,15 @@
if( $i % 2 ){
if( $toks[$i] eq '%c' ){
$toks[$i] = '.';
- } elsif( $toks[$i] eq '%d' ){
+ } elsif( $toks[$i] =~ /^%(?:d|u)$/ ){
$toks[$i] = '\d+';
} elsif( $toks[$i] =~ '^%(?:s|.*f)$' ){
$toks[$i] = $i == $#toks ? '.*' : '.*?';
} elsif( $toks[$i] =~ '%.(\d+)s' ){
$toks[$i] = ".{$1}";
- } elsif( $toks[$i] =~ '^%l*x$' ){
- $toks[$i] = '[\da-f]+';
- }
+ } elsif( $toks[$i] =~ '^%l*([pxX])$' ){
+ $toks[$i] = $1 eq 'X' ? '[\dA-F]+' : '[\da-f]+';
+ }
} elsif( length( $toks[$i] ) ){
$toks[$i] = quotemeta $toks[$i];
$conlen += length( $toks[$i] );
@@ -429,12 +432,15 @@
}
}
my $lhs = join( '', @toks );
+ $lhs =~ s/(\\\s)+/\\s+/g; # Replace lit space with multi-space match
$transfmt{$header}{pat} =
- " s{^$lhs}\n {\Q$header\E}s\n\t&& return 1;\n";
+ " s^\\s*$lhs\\s*\Q$header\Es\n\t&& return 1;\n";
$transfmt{$header}{len} = $conlen;
} else {
+ my $lhs = "\Q$header\E";
+ $lhs =~ s/(\\\s)+/\\s+/g; # Replace lit space with multi-space match
$transfmt{$header}{pat} =
- " m{^\Q$header\E} && return 1;\n";
+ " s^\\s*$lhs\\s*\Q$header\E\n\t && return 1;\n";
$transfmt{$header}{len} = length( $header );
}
@@ -563,10 +569,12 @@
# traps.
$SIG{__DIE__} = $SIG{__WARN__} = '';
- # Have carp skip over death_trap() when showing the stack trace.
- local($Carp::CarpLevel) = 1;
+ $exception =~ s/\n(?=.)/\n\t/gas;
- confess "Uncaught exception from user code:\n\t$exception";
+ die Carp::longmess("__diagnostics__")
+ =~ s/^__diagnostics__.*?line \d+\.?\n/
+ "Uncaught exception from user code:\n\t$exception"
+ /re;
# up we go; where we stop, nobody knows, but i think we die now
# but i'm deeply afraid of the &$olddie guy reraising and us getting
# into an indirect recursion loop
@@ -577,12 +585,12 @@
my $count;
my $wantspace;
sub splainthis {
- return 0 if $TRACEONLY;
- $_ = shift;
+ return 0 if $TRACEONLY;
+ for (my $tmp = shift) {
local $\;
local $!;
### &finish_compilation unless %msg;
- s/\.?\n+$//;
+ s/(\.\s*)?\n+$//;
my $orig = $_;
# return unless defined;
@@ -603,7 +611,7 @@
$_ .= ' at ' . $secs[$i];
}
}
-
+
# remove parenthesis occurring at the end of some messages
s/^\((.*)\)$/$1/;
@@ -613,17 +621,25 @@
return 0 unless &transmo;
}
- $orig = shorten($orig);
+ my $short = shorten($orig);
if ($old_diag{$_}) {
autodescribe();
- print THITHER "$orig (#$old_diag{$_})\n";
+ print THITHER "$short (#$old_diag{$_})\n";
$wantspace = 1;
+ } elsif (!$msg{$_} && $orig =~ /\n./s) {
+ # A multiline message, like "Attempt to reload /
+ # Compilation failed"
+ my $found;
+ for (split /^/, $orig) {
+ splainthis($_) and $found = 1;
+ }
+ return $found;
} else {
autodescribe();
$old_diag{$_} = ++$count;
print THITHER "\n" if $wantspace;
$wantspace = 0;
- print THITHER "$orig (#$old_diag{$_})\n";
+ print THITHER "$short (#$old_diag{$_})\n";
if ($msg{$_}) {
print THITHER $msg{$_};
} else {
@@ -636,6 +652,7 @@
}
}
return 1;
+ }
}
sub autodescribe {
Property changes on: trunk/contrib/perl/lib/diagnostics.pm
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/lib/diagnostics.t
===================================================================
--- trunk/contrib/perl/lib/diagnostics.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/diagnostics.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,14 +1,19 @@
-#!./perl
+#!./perl -w
BEGIN {
chdir '..' if -d '../pod' && -d '../t';
@INC = 'lib';
+ require './t/test.pl';
+ plan(24);
}
-use Test::More tests => 6;
+BEGIN {
+ my $w;
+ $SIG{__WARN__} = sub { $w = shift };
+ use_ok('diagnostics');
+ is $w, undef, 'no warnings when loading diagnostics.pm';
+}
-BEGIN { use_ok('diagnostics') }
-
require base;
eval {
@@ -15,12 +20,15 @@
'base'->import(qw(I::do::not::exist));
};
-like( $@, qr/^Base class package "I::do::not::exist" is empty/);
+like( $@, qr/^Base class package "I::do::not::exist" is empty/,
+ 'diagnostics not tripped up by "use base qw(Dont::Exist)"');
+open *whatever, ">", \my $warning
+ or die "Couldn't redirect STDERR to var: $!";
+my $old_stderr = *STDERR{IO};
+*STDERR = *whatever{IO};
+
# Test for %.0f patterns in perldiag, added in 5.11.0
-close STDERR;
-open STDERR, ">", \my $warning
- or die "Couldn't redirect STDERR to var: $!";
warn('gmtime(nan) too large');
like $warning, qr/\(W overflow\) You called/, '%0.f patterns';
@@ -40,7 +48,150 @@
# Multiple messages with the same description
seek STDERR, 0,0;
$warning = '';
-warn 'Code point 0x%X is not Unicode, may not be portable';
-like $warning, qr/W utf8/,
+warn 'Code point 0xBEE5 is not Unicode, may not be portable';
+like $warning, qr/S utf8/,
'Message sharing its description with the following message';
+# Periods at end of entries in perldiag.pod get matched correctly
+seek STDERR, 0,0;
+$warning = '';
+warn "Execution of -e aborted due to compilation errors.\n";
+like $warning, qr/The final summary message/, 'Periods at end of line';
+
+# Test for %d/%u
+seek STDERR, 0,0;
+$warning = '';
+warn "Bad arg length for us, is 4, should be 42";
+like $warning, qr/In C parlance/, '%u works';
+
+# Test for %X
+seek STDERR, 0,0;
+$warning = '';
+warn "Unicode surrogate U+C0FFEE is illegal in UTF-8";
+like $warning, qr/You had a UTF-16 surrogate/, '%X';
+
+# Test for %p
+seek STDERR, 0,0;
+$warning = '';
+warn "Slab leaked from cv fadedc0ffee";
+like $warning, qr/bookkeeping of op trees/, '%p';
+
+# Strip S<>
+seek STDERR, 0,0;
+$warning = '';
+warn "syntax error";
+like $warning, qr/cybernetic version of 20 questions/s, 'strip S<>';
+
+# Errors ending with dots
+seek STDERR, 0,0;
+$warning = '';
+warn "I had compilation errors.\n";
+like $warning, qr/final summary message/, 'dotty errors';
+
+# Multiline errors
+seek STDERR, 0,0;
+$warning = '';
+warn "Attempt to reload weapon aborted.\nCompilation failed in require";
+like $warning,
+ qr/You tried to load a file.*Perl could not compile/s,
+ 'multiline errors';
+
+# Multiline entry in perldiag.pod
+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,
+ 'multi-line entries in perldiag.pod match';
+
+# ; at end of entry in perldiag.pod
+seek STDERR, 0,0;
+$warning = '';
+warn "Perl folding rules are not up-to-date for 0xA; please use the perlbug utility to report; in regex; marked by <-- HERE in m/\ <-- HERE q/";
+like $warning,
+ qr/regular expression folding rules/s,
+ '; works at the end of entries in perldiag.pod';
+
+# Differences in spaces in warnings (Why not be nice and accept them?)
+seek STDERR, 0,0;
+$warning = '';
+warn "Assignment to both a list and a scalar\n";
+like $warning,
+ qr/2nd and 3rd/s,
+ 'spaces in warnings are matched lightly';
+
+# Differences in spaces in warnings with a period at the end
+seek STDERR, 0,0;
+$warning = '';
+warn "perl: warning: Setting locale failed.\n";
+like $warning,
+ qr/The whole warning/s,
+ 'spaces in warnings with periods at the end are matched lightly';
+
+
+*STDERR = $old_stderr;
+
+# These tests use a panic under the hope that the description is not likely
+# to change.
+ at runperl_args = (
+ switches => [ '-Ilib', '-Mdiagnostics' ],
+ stderr => 1,
+ nolib => 1, # -I../lib would go outside the build dir
+);
+$subs =
+ "sub foo{bar()}sub bar{baz()}sub baz{die q _panic: gremlins_}foo()";
+is runperl(@runperl_args, prog => $subs),
+ << 'EOT', 'internal error with backtrace';
+panic: gremlins at -e line 1 (#1)
+ (P) An internal error.
+
+Uncaught exception from user code:
+ panic: gremlins at -e line 1.
+ main::baz() called at -e line 1
+ main::bar() called at -e line 1
+ main::foo() called at -e line 1
+EOT
+is runperl(@runperl_args, prog => $subs =~ s/panic\K/k/r),
+ << 'EOU', 'user error with backtrace';
+Uncaught exception from user code:
+ panick: gremlins at -e line 1.
+ main::baz() called at -e line 1
+ main::bar() called at -e line 1
+ main::foo() called at -e line 1
+EOU
+is runperl(@runperl_args, prog => 'die q _panic: gremlins_'),
+ << 'EOV', 'no backtrace from top-level internal error';
+panic: gremlins at -e line 1 (#1)
+ (P) An internal error.
+
+Uncaught exception from user code:
+ panic: gremlins at -e line 1.
+EOV
+is runperl(@runperl_args, prog => 'die q _panick: gremlins_'),
+ << 'EOW', 'no backtrace from top-level user error';
+Uncaught exception from user code:
+ panick: gremlins at -e line 1.
+EOW
+like runperl(
+ @runperl_args,
+ prog => $subs =~
+ s[q _panic: gremlins_]
+ [qq _Attempt to reload foo aborted.\\nCompilation failed in require_]r,
+ ),
+ qr/Uncaught exception from user code:
+ Attempt to reload foo aborted\.
+ Compilation failed in require at -e line \d+\.
+ main::baz\(\) called at -e line \d+
+ main::bar\(\) called at -e line \d+
+ main::foo\(\) called at -e line \d+
+/, 'backtrace from multiline error';
+is runperl(@runperl_args, prog => 'BEGIN { die q _panic: gremlins_ }'),
+ << 'EOX', 'BEGIN{die} does not suppress diagnostics';
+panic: gremlins at -e line 1.
+BEGIN failed--compilation aborted at -e line 1 (#1)
+ (P) An internal error.
+
+Uncaught exception from user code:
+ panic: gremlins at -e line 1.
+ BEGIN failed--compilation aborted at -e line 1.
+EOX
Property changes on: trunk/contrib/perl/lib/diagnostics.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/dotsh.pl
===================================================================
--- trunk/contrib/perl/lib/dotsh.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/dotsh.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/dotsh.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/lib/dumpvar.pl
===================================================================
--- trunk/contrib/perl/lib/dumpvar.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/dumpvar.pl 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,4 +1,4 @@
-require 5.002; # For (defined ref)
+require 5.014; # For more reliable $@ after eval
package dumpvar;
# Needed for PrettyPrinter only:
@@ -37,7 +37,7 @@
# This one is good for variable names:
sub unctrl {
- local($_) = @_;
+ for (my($dummy) = shift) {
local($v) ;
return \$_ if ref \$_ eq "GLOB";
@@ -47,7 +47,8 @@
} else {
s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;
}
- $_;
+ return $_;
+ }
}
sub uniescape {
@@ -57,7 +58,17 @@
}
sub stringify {
- local($_,$noticks) = @_;
+ my $string;
+ if (eval { $string = _stringify(@_); 1 }) {
+ return $string;
+ }
+
+ return "<< value could not be dumped: $@ >>";
+}
+
+sub _stringify {
+ (my $__, local $noticks) = @_;
+ for ($__) {
local($v) ;
my $tick = $tick;
@@ -101,9 +112,10 @@
}
$_ = uniescape($_);
s/([\200-\377])/'\\'.sprintf('%3o',ord($1))/eg if $quoteHighBit;
- ($noticks || /^\d+(\.\d*)?\Z/)
+ return ($noticks || /^\d+(\.\d*)?\Z/)
? $_
: $tick . $_ . $tick;
+ }
}
# Ensure a resulting \ is escaped to be \\
@@ -157,6 +169,7 @@
$sp = " " x $s ;
$s += 3 ;
+ eval {
# Check for reused addresses
if (ref $v) {
my $val = $v;
@@ -165,8 +178,7 @@
# Match type and address.
# Unblessed references will look like TYPE(0x...)
# Blessed references will look like Class=TYPE(0x...)
- ($start_part, $val) = split /=/,$val;
- $val = $start_part unless defined $val;
+ $val =~ s/^.*=//; # suppress the Class part, just keep TYPE(0x...)
($item_type, $address) =
$val =~ /([^\(]+) # Keep stuff that's
# not an open paren
@@ -310,6 +322,12 @@
print( (' ' x $s) . "FileHandle({$v}) => fileno($fileno)\n" );
}
}
+ };
+ if ($@) {
+ print( (' ' x $s) . "<< value could not be dumped: $@ >>\n");
+ }
+
+ return;
}
sub matchlex {
@@ -343,7 +361,7 @@
if ($in eq 'unctrl' or $in eq 'quote') {
$unctrl = $in;
} else {
- print "Unknown value for `unctrl'.\n";
+ print "Unknown value for 'unctrl'.\n";
}
}
$unctrl;
Property changes on: trunk/contrib/perl/lib/dumpvar.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/lib/dumpvar.t
===================================================================
--- trunk/contrib/perl/lib/dumpvar.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/dumpvar.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -49,6 +49,16 @@
use overload '""' => sub { "Bar<@{$_[0]}>" };
+package Tyre;
+
+sub TIESCALAR{bless[]}
+# other methods intentionally omitted
+
+package Kerb;
+
+sub TIEHASH{bless{}}
+# other methods intentionally omitted
+
package main;
my $foo = Foo->new(1..5);
@@ -314,3 +324,19 @@
my %x=(a=>1, b=>2); dumpvalue(\%x);
EXPECT
/0 HASH\(0x[0-9a-f]+\)\n 'a' => 1\n 'b' => 2\n/i
+########
+dumpvalue(bless[1,2,3,4],"a=b=c");
+EXPECT
+/0 a=b=c=ARRAY\(0x[0-9a-f]+\)\n 0 1\n 1 2\n 2 3\n 3 4\n/i
+########
+local *_; tie $_, 'Tyre'; stringify('');
+EXPECT
+''
+########
+local *_; tie $_, 'Tyre'; unctrl('abc');
+EXPECT
+abc
+########
+tie my %h, 'Kerb'; my $v = { a => 1, b => \%h, c => 2 }; dumpvalue($v);
+EXPECT
+/'a' => 1\n.+Can't locate object method.+'c' => 2/s
Property changes on: trunk/contrib/perl/lib/dumpvar.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/exceptions.pl
===================================================================
--- trunk/contrib/perl/lib/exceptions.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/exceptions.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/exceptions.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/fastcwd.pl
===================================================================
--- trunk/contrib/perl/lib/fastcwd.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/fastcwd.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/fastcwd.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/lib/feature/unicode_strings.t
===================================================================
--- trunk/contrib/perl/lib/feature/unicode_strings.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/feature/unicode_strings.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -172,6 +172,7 @@
my @s = (0) x 256;
$s[ord_latin1_to_native 0x09] = 1; # Tab
$s[ord_latin1_to_native 0x0A] = 1; # LF
+$s[ord_latin1_to_native 0x0B] = 1; # VT
$s[ord_latin1_to_native 0x0C] = 1; # FF
$s[ord_latin1_to_native 0x0D] = 1; # CR
$s[ord_latin1_to_native 0x20] = 1; # SPACE
Property changes on: trunk/contrib/perl/lib/feature/unicode_strings.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/lib/feature.pm
===================================================================
--- trunk/contrib/perl/lib/feature.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/feature.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,33 +1,50 @@
+# -*- buffer-read-only: t -*-
+# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+# This file is built by regen/feature.pl.
+# Any changes made here will be lost!
+
package feature;
-our $VERSION = '1.20';
+our $VERSION = '1.32';
-# (feature name) => (internal name, used in %^H)
-my %feature = (
+our %feature = (
+ fc => 'feature_fc',
+ say => 'feature_say',
+ state => 'feature_state',
switch => 'feature_switch',
- say => "feature_say",
- state => "feature_state",
- unicode_strings => "feature_unicode",
+ evalbytes => 'feature_evalbytes',
+ array_base => 'feature_arybase',
+ current_sub => 'feature___SUB__',
+ lexical_subs => 'feature_lexsubs',
+ unicode_eval => 'feature_unieval',
+ unicode_strings => 'feature_unicode',
);
+our %feature_bundle = (
+ "5.10" => [qw(array_base say state switch)],
+ "5.11" => [qw(array_base say state switch unicode_strings)],
+ "5.15" => [qw(current_sub evalbytes fc say state switch unicode_eval unicode_strings)],
+ "all" => [qw(array_base current_sub evalbytes fc lexical_subs say state switch unicode_eval unicode_strings)],
+ "default" => [qw(array_base)],
+);
+
+$feature_bundle{"5.12"} = $feature_bundle{"5.11"};
+$feature_bundle{"5.13"} = $feature_bundle{"5.11"};
+$feature_bundle{"5.14"} = $feature_bundle{"5.11"};
+$feature_bundle{"5.16"} = $feature_bundle{"5.15"};
+$feature_bundle{"5.17"} = $feature_bundle{"5.15"};
+$feature_bundle{"5.18"} = $feature_bundle{"5.15"};
+$feature_bundle{"5.9.5"} = $feature_bundle{"5.10"};
+
+our $hint_shift = 26;
+our $hint_mask = 0x1c000000;
+our @hint_bundles = qw( default 5.10 5.11 5.15 );
+
# This gets set (for now) in $^H as well as in %^H,
# for runtime speed of the uc/lc/ucfirst/lcfirst functions.
# See HINT_UNI_8_BIT in perl.h.
our $hint_uni8bit = 0x00000800;
-# NB. the latest bundle must be loaded by the -E switch (see toke.c)
-
-my %feature_bundle = (
- "5.10" => [qw(switch say state)],
- "5.11" => [qw(switch say state unicode_strings)],
- "5.12" => [qw(switch say state unicode_strings)],
- "5.13" => [qw(switch say state unicode_strings)],
- "5.14" => [qw(switch say state unicode_strings)],
-);
-
-# special case
-$feature_bundle{"5.9.5"} = $feature_bundle{"5.10"};
-
# TODO:
# - think about versioned features (use feature switch => 2)
@@ -37,29 +54,33 @@
=head1 SYNOPSIS
- use feature qw(switch say);
+ use feature qw(say switch);
given ($foo) {
- when (1) { say "\$foo == 1" }
- when ([2,3]) { say "\$foo == 2 || \$foo == 3" }
- when (/^a[bc]d$/) { say "\$foo eq 'abd' || \$foo eq 'acd'" }
- when ($_ > 100) { say "\$foo > 100" }
- default { say "None of the above" }
+ when (1) { say "\$foo == 1" }
+ when ([2,3]) { say "\$foo == 2 || \$foo == 3" }
+ when (/^a[bc]d$/) { say "\$foo eq 'abd' || \$foo eq 'acd'" }
+ when ($_ > 100) { say "\$foo > 100" }
+ default { say "None of the above" }
}
use feature ':5.10'; # loads all features available in perl 5.10
+ use v5.10; # implicitly loads :5.10 feature bundle
+
=head1 DESCRIPTION
It is usually impossible to add new syntax to Perl without breaking
-some existing programs. This pragma provides a way to minimize that
+some existing programs. This pragma provides a way to minimize that
risk. New syntactic constructs, or new semantic meanings to older
constructs, can be enabled by C<use feature 'foo'>, and will be parsed
-only when the appropriate feature pragma is in scope.
+only when the appropriate feature pragma is in scope. (Nevertheless, the
+C<CORE::> prefix provides access to all Perl keywords, regardless of this
+pragma.)
=head2 Lexical effect
Like other pragmas (C<use strict>, for example), features have a lexical
-effect. C<use feature qw(foo)> will only make the feature "foo" available
+effect. C<use feature qw(foo)> will only make the feature "foo" available
from that point to the end of the enclosing block.
{
@@ -70,7 +91,7 @@
=head2 C<no feature>
-Features can also be turned off by using C<no feature "foo">. This too
+Features can also be turned off by using C<no feature "foo">. This too
has lexical effect.
use feature 'say';
@@ -81,36 +102,46 @@
}
say "Yet it is here.";
-C<no feature> with no features specified will turn off all features.
+C<no feature> with no features specified will reset to the default group. To
+disable I<all> features (an unusual request!) use C<no feature ':all'>.
-=head2 The 'switch' feature
+=head1 AVAILABLE FEATURES
-C<use feature 'switch'> tells the compiler to enable the Perl 6
-given/when construct.
-
-See L<perlsyn/"Switch statements"> for details.
-
=head2 The 'say' feature
-C<use feature 'say'> tells the compiler to enable the Perl 6
+C<use feature 'say'> tells the compiler to enable the Perl 6 style
C<say> function.
See L<perlfunc/say> for details.
-=head2 the 'state' feature
+This feature is available starting with Perl 5.10.
+=head2 The 'state' feature
+
C<use feature 'state'> tells the compiler to enable C<state>
variables.
See L<perlsub/"Persistent Private Variables"> for details.
-=head2 the 'unicode_strings' feature
+This feature is available starting with Perl 5.10.
+=head2 The 'switch' feature
+
+C<use feature 'switch'> tells the compiler to enable the Perl 6
+given/when construct.
+
+See L<perlsyn/"Switch Statements"> for details.
+
+This feature is available starting with Perl 5.10.
+
+=head2 The 'unicode_strings' feature
+
C<use feature 'unicode_strings'> tells the compiler to use Unicode semantics
in all string operations executed within its scope (unless they are also
within the scope of either C<use locale> or C<use bytes>). The same applies
to all regular expressions compiled within the scope, even if executed outside
-it.
+it. It does not change the internal representation of strings, but only how
+they are interpreted.
C<no feature 'unicode_strings'> tells the compiler to use the traditional
Perl semantics wherein the native character set semantics is used unless it is
@@ -120,44 +151,160 @@
potentially using Unicode in your program, the
C<use feature 'unicode_strings'> subpragma is B<strongly> recommended.
-This subpragma is available starting with Perl 5.11.3, but was not fully
-implemented until 5.13.8.
+This feature is available starting with Perl 5.12; was almost fully
+implemented in Perl 5.14; and extended in Perl 5.16 to cover C<quotemeta>.
+=head2 The 'unicode_eval' and 'evalbytes' features
+
+Under the C<unicode_eval> feature, Perl's C<eval> function, when passed a
+string, will evaluate it as a string of characters, ignoring any
+C<use utf8> declarations. C<use utf8> exists to declare the encoding of
+the script, which only makes sense for a stream of bytes, not a string of
+characters. Source filters are forbidden, as they also really only make
+sense on strings of bytes. Any attempt to activate a source filter will
+result in an error.
+
+The C<evalbytes> feature enables the C<evalbytes> keyword, which evaluates
+the argument passed to it as a string of bytes. It dies if the string
+contains any characters outside the 8-bit range. Source filters work
+within C<evalbytes>: they apply to the contents of the string being
+evaluated.
+
+Together, these two features are intended to replace the historical C<eval>
+function, which has (at least) two bugs in it, that cannot easily be fixed
+without breaking existing programs:
+
+=over
+
+=item *
+
+C<eval> behaves differently depending on the internal encoding of the
+string, sometimes treating its argument as a string of bytes, and sometimes
+as a string of characters.
+
+=item *
+
+Source filters activated within C<eval> leak out into whichever I<file>
+scope is currently being compiled. To give an example with the CPAN module
+L<Semi::Semicolons>:
+
+ BEGIN { eval "use Semi::Semicolons; # not filtered here " }
+ # filtered here!
+
+C<evalbytes> fixes that to work the way one would expect:
+
+ use feature "evalbytes";
+ BEGIN { evalbytes "use Semi::Semicolons; # filtered " }
+ # not filtered
+
+=back
+
+These two features are available starting with Perl 5.16.
+
+=head2 The 'current_sub' feature
+
+This provides the C<__SUB__> token that returns a reference to the current
+subroutine or C<undef> outside of a subroutine.
+
+This feature is available starting with Perl 5.16.
+
+=head2 The 'array_base' feature
+
+This feature supports the legacy C<$[> variable. See L<perlvar/$[> and
+L<arybase>. It is on by default but disabled under C<use v5.16> (see
+L</IMPLICIT LOADING>, below).
+
+This feature is available under this name starting with Perl 5.16. In
+previous versions, it was simply on all the time, and this pragma knew
+nothing about it.
+
+=head2 The 'fc' feature
+
+C<use feature 'fc'> tells the compiler to enable the C<fc> function,
+which implements Unicode casefolding.
+
+See L<perlfunc/fc> for details.
+
+This feature is available from Perl 5.16 onwards.
+
+=head2 The 'lexical_subs' feature
+
+B<WARNING>: This feature is still experimental and the implementation may
+change in future versions of Perl. For this reason, Perl will
+warn when you use the feature, unless you have explicitly disabled the
+warning:
+
+ no warnings "experimental::lexical_subs";
+
+This enables declaration of subroutines via C<my sub foo>, C<state sub foo>
+and C<our sub foo> syntax. See L<perlsub/Lexical Subroutines> for details.
+
+This feature is available from Perl 5.18 onwards.
+
=head1 FEATURE BUNDLES
-It's possible to load a whole slew of features in one go, using
-a I<feature bundle>. The name of a feature bundle is prefixed with
-a colon, to distinguish it from an actual feature. At present, the
-only feature bundle is C<use feature ":5.10"> which is equivalent
-to C<use feature qw(switch say state)>.
+It's possible to load multiple features together, using
+a I<feature bundle>. The name of a feature bundle is prefixed with
+a colon, to distinguish it from an actual feature.
-Specifying sub-versions such as the C<0> in C<5.10.0> in feature bundles has
-no effect: feature bundles are guaranteed to be the same for all sub-versions.
+ use feature ":5.10";
+The following feature bundles are available:
+
+ bundle features included
+ --------- -----------------
+ :default array_base
+
+ :5.10 say state switch array_base
+
+ :5.12 say state switch unicode_strings array_base
+
+ :5.14 say state switch unicode_strings array_base
+
+ :5.16 say state switch unicode_strings
+ unicode_eval evalbytes current_sub fc
+
+ :5.18 say state switch unicode_strings
+ unicode_eval evalbytes current_sub fc
+
+The C<:default> bundle represents the feature set that is enabled before
+any C<use feature> or C<no feature> declaration.
+
+Specifying sub-versions such as the C<0> in C<5.14.0> in feature bundles has
+no effect. Feature bundles are guaranteed to be the same for all sub-versions.
+
+ use feature ":5.14.0"; # same as ":5.14"
+ use feature ":5.14.1"; # same as ":5.14"
+
=head1 IMPLICIT LOADING
-There are two ways to load the C<feature> pragma implicitly :
+Instead of loading feature bundles by name, it is easier to let Perl do
+implicit loading of a feature bundle for you.
+There are two ways to load the C<feature> pragma implicitly:
+
=over 4
=item *
-By using the C<-E> switch on the command-line instead of C<-e>. It enables
-all available features in the main compilation unit (that is, the one-liner.)
+By using the C<-E> switch on the Perl command-line instead of C<-e>.
+That will enable the feature bundle for that version of Perl in the
+main compilation unit (that is, the one-liner that follows C<-E>).
=item *
-By requiring explicitly a minimal Perl version number for your program, with
-the C<use VERSION> construct, and when the version is higher than or equal to
-5.10.0. That is,
+By explicitly requiring a minimum Perl version number for your program, with
+the C<use VERSION> construct. That is,
- use 5.10.0;
+ use v5.10.0;
will do an implicit
+ no feature ':all';
use feature ':5.10';
-and so on. Note how the trailing sub-version is automatically stripped from the
+and so on. Note how the trailing sub-version
+is automatically stripped from the
version.
But to avoid portability warnings (see L<perlfunc/use>), you may prefer:
@@ -166,6 +313,9 @@
with the same effect.
+If the required version is older than Perl 5.10, the ":default" feature
+bundle is automatically loaded instead.
+
=back
=cut
@@ -172,60 +322,65 @@
sub import {
my $class = shift;
- if (@_ == 0) {
- croak("No features specified");
+
+ if (!@_) {
+ croak("No features specified");
}
- while (@_) {
- my $name = shift(@_);
- if (substr($name, 0, 1) eq ":") {
- my $v = substr($name, 1);
- if (!exists $feature_bundle{$v}) {
- $v =~ s/^([0-9]+)\.([0-9]+).[0-9]+$/$1.$2/;
- if (!exists $feature_bundle{$v}) {
- unknown_feature_bundle(substr($name, 1));
- }
- }
- unshift @_, @{$feature_bundle{$v}};
- next;
- }
- if (!exists $feature{$name}) {
- unknown_feature($name);
- }
- $^H{$feature{$name}} = 1;
- $^H |= $hint_uni8bit if $name eq 'unicode_strings';
- }
+
+ __common(1, @_);
}
sub unimport {
my $class = shift;
- # A bare C<no feature> should disable *all* features
+ # A bare C<no feature> should reset to the default bundle
if (!@_) {
- delete @^H{ values(%feature) };
- $^H &= ~ $hint_uni8bit;
+ $^H &= ~($hint_uni8bit|$hint_mask);
return;
}
+ __common(0, @_);
+}
+
+
+sub __common {
+ my $import = shift;
+ my $bundle_number = $^H & $hint_mask;
+ my $features = $bundle_number != $hint_mask
+ && $feature_bundle{$hint_bundles[$bundle_number >> $hint_shift]};
+ if ($features) {
+ # Features are enabled implicitly via bundle hints.
+ # Delete any keys that may be left over from last time.
+ delete @^H{ values(%feature) };
+ $^H |= $hint_mask;
+ for (@$features) {
+ $^H{$feature{$_}} = 1;
+ $^H |= $hint_uni8bit if $_ eq 'unicode_strings';
+ }
+ }
while (@_) {
- my $name = shift;
- if (substr($name, 0, 1) eq ":") {
- my $v = substr($name, 1);
- if (!exists $feature_bundle{$v}) {
- $v =~ s/^([0-9]+)\.([0-9]+).[0-9]+$/$1.$2/;
- if (!exists $feature_bundle{$v}) {
- unknown_feature_bundle(substr($name, 1));
- }
- }
- unshift @_, @{$feature_bundle{$v}};
- next;
- }
- if (!exists($feature{$name})) {
- unknown_feature($name);
- }
- else {
- delete $^H{$feature{$name}};
+ my $name = shift;
+ if (substr($name, 0, 1) eq ":") {
+ my $v = substr($name, 1);
+ if (!exists $feature_bundle{$v}) {
+ $v =~ s/^([0-9]+)\.([0-9]+).[0-9]+$/$1.$2/;
+ if (!exists $feature_bundle{$v}) {
+ unknown_feature_bundle(substr($name, 1));
+ }
+ }
+ unshift @_, @{$feature_bundle{$v}};
+ next;
+ }
+ if (!exists $feature{$name}) {
+ unknown_feature($name);
+ }
+ if ($import) {
+ $^H{$feature{$name}} = 1;
+ $^H |= $hint_uni8bit if $name eq 'unicode_strings';
+ } else {
+ delete $^H{$feature{$name}};
$^H &= ~ $hint_uni8bit if $name eq 'unicode_strings';
- }
+ }
}
}
@@ -232,13 +387,13 @@
sub unknown_feature {
my $feature = shift;
croak(sprintf('Feature "%s" is not supported by Perl %vd',
- $feature, $^V));
+ $feature, $^V));
}
sub unknown_feature_bundle {
my $feature = shift;
croak(sprintf('Feature bundle "%s" is not supported by Perl %vd',
- $feature, $^V));
+ $feature, $^V));
}
sub croak {
@@ -247,3 +402,5 @@
}
1;
+
+# ex: set ro:
Property changes on: trunk/contrib/perl/lib/feature.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/lib/feature.t
===================================================================
--- trunk/contrib/perl/lib/feature.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/feature.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/feature.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/lib/fields.pm (from rev 6437, vendor/perl/5.18.1/lib/fields.pm)
===================================================================
--- trunk/contrib/perl/lib/fields.pm (rev 0)
+++ trunk/contrib/perl/lib/fields.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,327 @@
+package fields;
+
+require 5.005;
+use strict;
+no strict 'refs';
+unless( eval q{require warnings::register; warnings::register->import; 1} ) {
+ *warnings::warnif = sub {
+ require Carp;
+ Carp::carp(@_);
+ }
+}
+use vars qw(%attr $VERSION);
+
+$VERSION = '2.14';
+
+# constant.pm is slow
+sub PUBLIC () { 2**0 }
+sub PRIVATE () { 2**1 }
+sub INHERITED () { 2**2 }
+sub PROTECTED () { 2**3 }
+
+
+# The %attr hash holds the attributes of the currently assigned fields
+# per class. The hash is indexed by class names and the hash value is
+# an array reference. The first element in the array is the lowest field
+# number not belonging to a base class. The remaining elements' indices
+# are the field numbers. The values are integer bit masks, or undef
+# in the case of base class private fields (which occupy a slot but are
+# otherwise irrelevant to the class).
+
+sub import {
+ my $class = shift;
+ return unless @_;
+ my $package = caller(0);
+ # avoid possible typo warnings
+ %{"$package\::FIELDS"} = () unless %{"$package\::FIELDS"};
+ my $fields = \%{"$package\::FIELDS"};
+ my $fattr = ($attr{$package} ||= [1]);
+ my $next = @$fattr;
+
+ # Quiet pseudo-hash deprecation warning for uses of fields::new.
+ bless \%{"$package\::FIELDS"}, 'pseudohash';
+
+ if ($next > $fattr->[0]
+ and ($fields->{$_[0]} || 0) >= $fattr->[0])
+ {
+ # There are already fields not belonging to base classes.
+ # Looks like a possible module reload...
+ $next = $fattr->[0];
+ }
+ foreach my $f (@_) {
+ my $fno = $fields->{$f};
+
+ # Allow the module to be reloaded so long as field positions
+ # have not changed.
+ if ($fno and $fno != $next) {
+ require Carp;
+ if ($fno < $fattr->[0]) {
+ if ($] < 5.006001) {
+ warn("Hides field '$f' in base class") if $^W;
+ } else {
+ warnings::warnif("Hides field '$f' in base class") ;
+ }
+ } else {
+ Carp::croak("Field name '$f' already in use");
+ }
+ }
+ $fields->{$f} = $next;
+ $fattr->[$next] = ($f =~ /^_/) ? PRIVATE : PUBLIC;
+ $next += 1;
+ }
+ if (@$fattr > $next) {
+ # Well, we gave them the benefit of the doubt by guessing the
+ # module was reloaded, but they appear to be declaring fields
+ # in more than one place. We can't be sure (without some extra
+ # bookkeeping) that the rest of the fields will be declared or
+ # have the same positions, so punt.
+ require Carp;
+ Carp::croak ("Reloaded module must declare all fields at once");
+ }
+}
+
+sub inherit {
+ require base;
+ goto &base::inherit_fields;
+}
+
+sub _dump # sometimes useful for debugging
+{
+ for my $pkg (sort keys %attr) {
+ print "\n$pkg";
+ if (@{"$pkg\::ISA"}) {
+ print " (", join(", ", @{"$pkg\::ISA"}), ")";
+ }
+ print "\n";
+ my $fields = \%{"$pkg\::FIELDS"};
+ for my $f (sort {$fields->{$a} <=> $fields->{$b}} keys %$fields) {
+ my $no = $fields->{$f};
+ print " $no: $f";
+ my $fattr = $attr{$pkg}[$no];
+ if (defined $fattr) {
+ my @a;
+ push(@a, "public") if $fattr & PUBLIC;
+ push(@a, "private") if $fattr & PRIVATE;
+ push(@a, "inherited") if $fattr & INHERITED;
+ print "\t(", join(", ", @a), ")";
+ }
+ print "\n";
+ }
+ }
+}
+
+if ($] < 5.009) {
+ *new = sub {
+ my $class = shift;
+ $class = ref $class if ref $class;
+ return bless [\%{$class . "::FIELDS"}], $class;
+ }
+} else {
+ *new = sub {
+ my $class = shift;
+ $class = ref $class if ref $class;
+ require Hash::Util;
+ my $self = bless {}, $class;
+
+ # The lock_keys() prototype won't work since we require Hash::Util :(
+ &Hash::Util::lock_keys(\%$self, _accessible_keys($class));
+ return $self;
+ }
+}
+
+sub _accessible_keys {
+ my ($class) = @_;
+ return (
+ keys %{$class.'::FIELDS'},
+ map(_accessible_keys($_), @{$class.'::ISA'}),
+ );
+}
+
+sub phash {
+ die "Pseudo-hashes have been removed from Perl" if $] >= 5.009;
+ my $h;
+ my $v;
+ if (@_) {
+ if (ref $_[0] eq 'ARRAY') {
+ my $a = shift;
+ @$h{@$a} = 1 .. @$a;
+ if (@_) {
+ $v = shift;
+ unless (! @_ and ref $v eq 'ARRAY') {
+ require Carp;
+ Carp::croak ("Expected at most two array refs\n");
+ }
+ }
+ }
+ else {
+ if (@_ % 2) {
+ require Carp;
+ Carp::croak ("Odd number of elements initializing pseudo-hash\n");
+ }
+ my $i = 0;
+ @$h{grep ++$i % 2, @_} = 1 .. @_ / 2;
+ $i = 0;
+ $v = [grep $i++ % 2, @_];
+ }
+ }
+ else {
+ $h = {};
+ $v = [];
+ }
+ [ $h, @$v ];
+
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+fields - compile-time class fields
+
+=head1 SYNOPSIS
+
+ {
+ package Foo;
+ use fields qw(foo bar _Foo_private);
+ sub new {
+ my Foo $self = shift;
+ unless (ref $self) {
+ $self = fields::new($self);
+ $self->{_Foo_private} = "this is Foo's secret";
+ }
+ $self->{foo} = 10;
+ $self->{bar} = 20;
+ return $self;
+ }
+ }
+
+ my $var = Foo->new;
+ $var->{foo} = 42;
+
+ # this will generate an error
+ $var->{zap} = 42;
+
+ # subclassing
+ {
+ package Bar;
+ use base 'Foo';
+ use fields qw(baz _Bar_private); # not shared with Foo
+ sub new {
+ my $class = shift;
+ my $self = fields::new($class);
+ $self->SUPER::new(); # init base fields
+ $self->{baz} = 10; # init own fields
+ $self->{_Bar_private} = "this is Bar's secret";
+ return $self;
+ }
+ }
+
+=head1 DESCRIPTION
+
+The C<fields> pragma enables compile-time verified class fields.
+
+NOTE: The current implementation keeps the declared fields in the %FIELDS
+hash of the calling package, but this may change in future versions.
+Do B<not> update the %FIELDS hash directly, because it must be created
+at compile-time for it to be fully useful, as is done by this pragma.
+
+B<Only valid for perl before 5.9.0:>
+
+If a typed lexical variable holding a reference is used to access a
+hash element and a package with the same name as the type has
+declared class fields using this pragma, then the operation is
+turned into an array access at compile time.
+
+
+The related C<base> pragma will combine fields from base classes and any
+fields declared using the C<fields> pragma. This enables field
+inheritance to work properly.
+
+Field names that start with an underscore character are made private to
+the class and are not visible to subclasses. Inherited fields can be
+overridden but will generate a warning if used together with the C<-w>
+switch.
+
+B<Only valid for perls before 5.9.0:>
+
+The effect of all this is that you can have objects with named
+fields which are as compact and as fast arrays to access. This only
+works as long as the objects are accessed through properly typed
+variables. If the objects are not typed, access is only checked at
+run time.
+
+
+The following functions are supported:
+
+=over 4
+
+=item new
+
+B< perl before 5.9.0: > fields::new() creates and blesses a
+pseudo-hash comprised of the fields declared using the C<fields>
+pragma into the specified class.
+
+B< perl 5.9.0 and higher: > fields::new() creates and blesses a
+restricted-hash comprised of the fields declared using the C<fields>
+pragma into the specified class.
+
+This function is usable with or without pseudo-hashes. It is the
+recommended way to construct a fields-based object.
+
+This makes it possible to write a constructor like this:
+
+ package Critter::Sounds;
+ use fields qw(cat dog bird);
+
+ sub new {
+ my $self = shift;
+ $self = fields::new($self) unless ref $self;
+ $self->{cat} = 'meow'; # scalar element
+ @$self{'dog','bird'} = ('bark','tweet'); # slice
+ return $self;
+ }
+
+=item phash
+
+B< before perl 5.9.0: >
+
+fields::phash() can be used to create and initialize a plain (unblessed)
+pseudo-hash. This function should always be used instead of creating
+pseudo-hashes directly.
+
+If the first argument is a reference to an array, the pseudo-hash will
+be created with keys from that array. If a second argument is supplied,
+it must also be a reference to an array whose elements will be used as
+the values. If the second array contains less elements than the first,
+the trailing elements of the pseudo-hash will not be initialized.
+This makes it particularly useful for creating a pseudo-hash from
+subroutine arguments:
+
+ sub dogtag {
+ my $tag = fields::phash([qw(name rank ser_num)], [@_]);
+ }
+
+fields::phash() also accepts a list of key-value pairs that will
+be used to construct the pseudo hash. Examples:
+
+ my $tag = fields::phash(name => "Joe",
+ rank => "captain",
+ ser_num => 42);
+
+ my $pseudohash = fields::phash(%args);
+
+B< perl 5.9.0 and higher: >
+
+Pseudo-hashes have been removed from Perl as of 5.10. Consider using
+restricted hashes or fields::new() instead. Using fields::phash()
+will cause an error.
+
+=back
+
+=head1 SEE ALSO
+
+L<base>
+
+=cut
Modified: trunk/contrib/perl/lib/filetest.pm
===================================================================
--- trunk/contrib/perl/lib/filetest.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/filetest.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,6 +1,6 @@
package filetest;
-our $VERSION = '1.02';
+our $VERSION = '1.03';
=head1 NAME
@@ -71,7 +71,7 @@
Because access() does not invoke stat() (at least not in a way visible
to Perl), B<the stat result cache "_" is not set>. This means that the
outcome of the following two tests is different. The first has the stat
-bits of C</etc/passwd> in C<_>, and in the second case this still
+bits of F</etc/passwd> in C<_>, and in the second case this still
contains the bits of C</etc>.
{ -d '/etc';
Property changes on: trunk/contrib/perl/lib/filetest.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/lib/filetest.t
===================================================================
--- trunk/contrib/perl/lib/filetest.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/filetest.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -57,6 +57,7 @@
my $chflags = "/usr/bin/chflags";
my $tstfile = "filetest.tst";
skip("No $chflags available", 4) if !-x $chflags;
+ skip("Dragonfly filetests seem non-chflags aware", 4) if $^O eq 'dragonfly';
my $skip_eff_user_tests = (!$Config{d_setreuid} && !$Config{d_setresuid})
||
Property changes on: trunk/contrib/perl/lib/filetest.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/find.pl
===================================================================
--- trunk/contrib/perl/lib/find.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/find.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/find.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/finddepth.pl
===================================================================
--- trunk/contrib/perl/lib/finddepth.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/finddepth.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/finddepth.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/flush.pl
===================================================================
--- trunk/contrib/perl/lib/flush.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/flush.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/flush.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/getcwd.pl
===================================================================
--- trunk/contrib/perl/lib/getcwd.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/getcwd.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/getcwd.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/getopt.pl
===================================================================
--- trunk/contrib/perl/lib/getopt.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/getopt.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/getopt.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/getopts.pl
===================================================================
--- trunk/contrib/perl/lib/getopts.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/getopts.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/getopts.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/h2ph.t
===================================================================
--- trunk/contrib/perl/lib/h2ph.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/h2ph.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/h2ph.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/h2xs.t
===================================================================
--- trunk/contrib/perl/lib/h2xs.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/h2xs.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -159,8 +159,10 @@
# 1 test for running it, 1 test for the expected result, and 1 for each file
# plus 1 to open and 1 to check for the use in lib/$name.pm and Makefile.PL
# And 1 more for our check for "bonus" files, 2 more for ExtUtil::Manifest.
+ # And 1 more to examine const-c.inc contents in tests that use $header.
# use the () to force list context and hence count the number of matches.
$total_tests += 9 + (() = $tests[$i] =~ /(Writing)/sg);
+ $total_tests++ if $tests[$i-2] =~ / \Q$header\E$/;
}
plan tests => $total_tests;
@@ -169,6 +171,8 @@
print HEADER <<HEADER or die $!;
#define Camel 2
#define Dromedary 1
+#define Bactrian /* empty */
+#define Bactrian2
HEADER
ok (close (HEADER), "close '$header'");
@@ -215,6 +219,23 @@
pop @INC;
chdir ($up) or die "chdir $up failed: $!";
+ if ($args =~ / \Q$header\E$/) {
+ my $const_c = File::Spec->catfile($name, 'fallback', 'const-c.inc');
+ my ($found, $diag);
+ if (!open FILE, '<', $const_c) {
+ $diag = "can't open $const_c: $!";
+ }
+ else {
+ while (<FILE>) {
+ next unless /\b Bactrian 2? \b/x;
+ $found = 1;
+ last;
+ }
+ }
+ ok (!$found, "generated $const_c has no Bactrian(2)");
+ diag ($diag) if defined $diag;
+ }
+
foreach my $leaf (File::Spec->catfile('lib', "$name.pm"), 'Makefile.PL') {
my $file = File::Spec->catfile($name, $leaf);
if (ok (open (FILE, $file), "open $file")) {
Property changes on: trunk/contrib/perl/lib/h2xs.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/lib/hostname.pl
===================================================================
--- trunk/contrib/perl/lib/hostname.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/hostname.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/hostname.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/lib/if.pm (from rev 6437, vendor/perl/5.18.1/lib/if.pm)
===================================================================
--- trunk/contrib/perl/lib/if.pm (rev 0)
+++ trunk/contrib/perl/lib/if.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,56 @@
+package if;
+
+$VERSION = '0.05';
+
+sub work {
+ my $method = shift() ? 'import' : 'unimport';
+ die "Too few arguments to `use if' (some code returning an empty list in list context?)"
+ unless @_ >= 2;
+ return unless shift; # CONDITION
+
+ my $p = $_[0]; # PACKAGE
+ (my $file = "$p.pm") =~ s!::!/!g;
+ require $file; # Works even if $_[0] is a keyword (like open)
+ my $m = $p->can($method);
+ goto &$m if $m;
+}
+
+sub import { shift; unshift @_, 1; goto &work }
+sub unimport { shift; unshift @_, 0; goto &work }
+
+1;
+__END__
+
+=head1 NAME
+
+if - C<use> a Perl module if a condition holds
+
+=head1 SYNOPSIS
+
+ use if CONDITION, MODULE => ARGUMENTS;
+
+=head1 DESCRIPTION
+
+The construct
+
+ use if CONDITION, MODULE => ARGUMENTS;
+
+has no effect unless C<CONDITION> is true. In this case the effect is
+the same as of
+
+ use MODULE ARGUMENTS;
+
+Above C<< => >> provides necessary quoting of C<MODULE>. If not used (e.g.,
+no ARGUMENTS to give), you'd better quote C<MODULE> yourselves.
+
+=head1 BUGS
+
+The current implementation does not allow specification of the
+required version of the module.
+
+=head1 AUTHOR
+
+Ilya Zakharevich L<mailto:perl-module-if at ilyaz.org>.
+
+=cut
+
Copied: trunk/contrib/perl/lib/if.t (from rev 6437, vendor/perl/5.18.1/lib/if.t)
===================================================================
--- trunk/contrib/perl/lib/if.t (rev 0)
+++ trunk/contrib/perl/lib/if.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,41 @@
+#!./perl
+
+BEGIN {
+ chdir 't' and @INC = '../lib' if $ENV{PERL_CORE};
+}
+
+my $t = 1;
+print "1..5\n";
+sub ok {
+ print "not " unless shift;
+ print "ok $t # ", shift, "\n";
+ $t++;
+}
+
+my $v_plus = $] + 1;
+my $v_minus = $] - 1;
+
+unless (eval 'use open ":std"; 1') {
+ # pretend that open.pm is present
+ $INC{'open.pm'} = 'open.pm';
+ eval 'sub open::foo{}'; # Just in case...
+}
+
+
+ok( eval "use if ($v_minus > \$]), strict => 'subs'; \${'f'} = 12" eq 12,
+ '"use if" with a false condition, fake pragma');
+
+ok( eval "use if ($v_minus > \$]), strict => 'refs'; \${'f'} = 12" eq 12,
+ '"use if" with a false condition and a pragma');
+
+ok( eval "use if ($v_plus > \$]), strict => 'subs'; \${'f'} = 12" eq 12,
+ '"use if" with a true condition, fake pragma');
+
+ok( (not defined eval "use if ($v_plus > \$]), strict => 'refs'; \${'f'} = 12"
+ and $@ =~ /while "strict refs" in use/),
+ '"use if" with a true condition and a pragma');
+
+# Old version had problems with the module name `open', which is a keyword too
+# Use 'open' =>, since pre-5.6.0 could interpret differently
+ok( (eval "use if ($v_plus > \$]), 'open' => IN => ':crlf'; 12" || 0) eq 12,
+ '"use if" with open');
Index: trunk/contrib/perl/lib/importenv.pl
===================================================================
--- trunk/contrib/perl/lib/importenv.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/importenv.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/importenv.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/integer.pm
===================================================================
--- trunk/contrib/perl/lib/integer.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/integer.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/integer.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/integer.t
===================================================================
--- trunk/contrib/perl/lib/integer.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/integer.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/integer.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/less.pm
===================================================================
--- trunk/contrib/perl/lib/less.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/less.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/less.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/less.t
===================================================================
--- trunk/contrib/perl/lib/less.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/less.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/less.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/lib/lib.t (from rev 6437, vendor/perl/5.18.1/lib/lib.t)
===================================================================
--- trunk/contrib/perl/lib/lib.t (rev 0)
+++ trunk/contrib/perl/lib/lib.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,91 @@
+#!./perl -w
+
+BEGIN {
+ chdir 't';
+ unshift @INC, '..';
+ unshift @INC, '../lib';
+ @OrigINC = @INC;
+}
+
+use Test::More tests => 13;
+use Config;
+use File::Spec;
+use File::Path;
+
+#set up files and directories
+my @lib_dir;
+my $Lib_Dir;
+my $Arch_Dir;
+my $Auto_Dir;
+my $Module;
+BEGIN {
+ # lib.pm is documented to only work with Unix filepaths.
+ @lib_dir = qw(stuff moo);
+ $Lib_Dir = join "/", @lib_dir;
+ $Arch_Dir = join "/", @lib_dir, $Config{archname};
+
+ # create the auto/ directory and a module
+ $Auto_Dir = File::Spec->catdir(@lib_dir, $Config{archname},'auto');
+ $Module = File::Spec->catfile(@lib_dir, 'Yup.pm');
+
+ mkpath [$Auto_Dir];
+
+ open(MOD, ">$Module") || DIE $!;
+ print MOD <<'MODULE';
+package Yup;
+$Plan = 9;
+return '42';
+MODULE
+
+ close MOD;
+}
+
+END {
+ # cleanup the auto/ directory we created.
+ rmtree([$lib_dir[0]]);
+}
+
+
+use lib $Lib_Dir;
+use lib $Lib_Dir;
+
+BEGIN { use_ok('Yup') }
+
+BEGIN {
+ if ($^O eq 'MacOS') {
+ for ($Lib_Dir, $Arch_Dir) {
+ tr|/|:|;
+ $_ .= ":" unless /:$/;
+ $_ = ":$_" unless /^:/; # we know this path is relative
+ }
+ }
+ is( $INC[1], $Lib_Dir, 'lib adding at end of @INC' );
+ print "# \@INC == @INC\n";
+ is( $INC[0], $Arch_Dir, ' auto/ dir in front of that' );
+ is( grep(/^\Q$Lib_Dir\E$/, @INC), 1, ' no duplicates' );
+
+ # Yes, %INC uses Unixy filepaths.
+ # Not on Mac OS, it doesn't ... it never has, at least.
+ my $path = join("/",$Lib_Dir, 'Yup.pm');
+ if ($^O eq 'MacOS') {
+ $path = $Lib_Dir . 'Yup.pm';
+ }
+ is( $INC{'Yup.pm'}, $path, '%INC set properly' );
+
+ is( eval { do 'Yup.pm' }, 42, 'do() works' );
+ ok( eval { require Yup; }, ' require()' );
+ ok( eval "use Yup; 1;", ' use()' );
+ is( $@, '' );
+
+ is_deeply(\@OrigINC, \@lib::ORIG_INC, '@lib::ORIG_INC' );
+}
+
+no lib $Lib_Dir;
+
+unlike( do { eval 'use lib $Config{installsitelib};'; $@ || '' },
+ qr/::Config is read-only/, 'lib handles readonly stuff' );
+
+BEGIN {
+ is( grep(/stuff/, @INC), 0, 'no lib' );
+ ok( !do 'Yup.pm', ' do() effected' );
+}
Copied: trunk/contrib/perl/lib/lib_pm.PL (from rev 6437, vendor/perl/5.18.1/lib/lib_pm.PL)
===================================================================
--- trunk/contrib/perl/lib/lib_pm.PL (rev 0)
+++ trunk/contrib/perl/lib/lib_pm.PL 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,319 @@
+use Config;
+use File::Basename qw(&basename &dirname);
+use File::Spec;
+use Cwd;
+
+my $origdir = cwd;
+chdir dirname($0);
+my $file = basename($0, '.PL');
+$file =~ s/_(pm)$/.$1/i;
+
+my $useConfig;
+my $Config_archname;
+my $Config_version;
+my $Config_inc_version_list;
+
+# Expand the variables only if explicitly requested
+# or if a previously installed lib.pm does this, too
+# because otherwise relocating Perl becomes much harder.
+
+my $expand_config_vars = 0;
+if ($ENV{PERL_BUILD_EXPAND_CONFIG_VARS}) {
+ $expand_config_vars = 1;
+}
+elsif (exists $ENV{PERL_BUILD_EXPAND_CONFIG_VARS}) {
+ $expand_config_vars = 0;
+}
+else {
+ eval <<'HERE';
+ require lib;
+ my $lib_file = $INC{"lib.pm"};
+ open my $fh, '<', $lib_file
+ or die "Could not open file '$lib_file' for reading: $!";
+ my $ConfigRegex = qr/(?:use|require)\s+Config(?:\s+|;)/;
+ my $found_config = 0;
+ while (defined($_ = <$fh>)) {
+ # crude heuristics to check that we were using Config
+ if (/^\s*$ConfigRegex/ || /^\s*eval.*$ConfigRegex/) {
+ $found_config = 1;
+ last;
+ }
+ }
+ $expand_config_vars = $found_config ? 0 : 1;
+HERE
+ $expand_config_vars = 0 if $@;
+}
+
+if ($expand_config_vars) {
+ $useConfig = '';
+ $Config_archname = qq('$Config{archname}');
+ $Config_version = qq('$Config{version}');
+ my @Config_inc_version_list =
+ reverse split / /, $Config{inc_version_list};
+ $Config_inc_version_list =
+ @Config_inc_version_list ?
+ qq(qw(@Config_inc_version_list)) : q(());
+} else {
+ $useConfig = 'use Config;';
+ $Config_archname = q($Config{archname});
+ $Config_version = q($Config{version});
+ $Config_inc_version_list =
+ q(reverse split / /, $Config{inc_version_list});
+}
+
+open OUT,">$file" or die "Can't create $file: $!";
+
+print "Extracting $file (with variable substitutions)\n";
+
+# In this section, perl variables will be expanded during extraction.
+# You can use $Config{...} to use Configure variables.
+
+print OUT <<"!GROK!THIS!";
+package lib;
+
+# THIS FILE IS AUTOMATICALLY GENERATED FROM lib_pm.PL.
+# ANY CHANGES TO THIS FILE WILL BE OVERWRITTEN BY THE NEXT PERL BUILD.
+
+$useConfig
+
+use strict;
+
+my \$archname = $Config_archname;
+my \$version = $Config_version;
+my \@inc_version_list = $Config_inc_version_list;
+
+!GROK!THIS!
+print OUT <<'!NO!SUBS!';
+
+our @ORIG_INC = @INC; # take a handy copy of 'original' value
+our $VERSION = '0.62';
+my $Is_MacOS = $^O eq 'MacOS';
+my $Mac_FS;
+if ($Is_MacOS) {
+ require File::Spec;
+ $Mac_FS = eval { require Mac::FileSpec::Unixish };
+}
+
+sub import {
+ shift;
+
+ my %names;
+ foreach (reverse @_) {
+ my $path = $_; # we'll be modifying it, so break the alias
+ if ($path eq '') {
+ require Carp;
+ Carp::carp("Empty compile time value given to use lib");
+ }
+
+ $path = _nativize($path);
+
+ if ($path !~ /\.par$/i && -e $path && ! -d _) {
+ require Carp;
+ Carp::carp("Parameter to use lib must be directory, not file");
+ }
+ unshift(@INC, $path);
+ # Add any previous version directories we found at configure time
+ foreach my $incver (@inc_version_list)
+ {
+ my $dir = $Is_MacOS
+ ? File::Spec->catdir( $path, $incver )
+ : "$path/$incver";
+ unshift(@INC, $dir) if -d $dir;
+ }
+ # Put a corresponding archlib directory in front of $path if it
+ # looks like $path has an archlib directory below it.
+ my($arch_auto_dir, $arch_dir, $version_dir, $version_arch_dir)
+ = _get_dirs($path);
+ unshift(@INC, $arch_dir) if -d $arch_auto_dir;
+ unshift(@INC, $version_dir) if -d $version_dir;
+ unshift(@INC, $version_arch_dir) if -d $version_arch_dir;
+ }
+
+ # remove trailing duplicates
+ @INC = grep { ++$names{$_} == 1 } @INC;
+ return;
+}
+
+
+sub unimport {
+ shift;
+
+ my %names;
+ foreach (@_) {
+ my $path = _nativize($_);
+
+ my($arch_auto_dir, $arch_dir, $version_dir, $version_arch_dir)
+ = _get_dirs($path);
+ ++$names{$path};
+ ++$names{$arch_dir} if -d $arch_auto_dir;
+ ++$names{$version_dir} if -d $version_dir;
+ ++$names{$version_arch_dir} if -d $version_arch_dir;
+ }
+
+ # Remove ALL instances of each named directory.
+ @INC = grep { !exists $names{$_} } @INC;
+ return;
+}
+
+sub _get_dirs {
+ my($dir) = @_;
+ my($arch_auto_dir, $arch_dir, $version_dir, $version_arch_dir);
+
+ # we could use this for all platforms in the future, but leave it
+ # Mac-only for now, until there is more time for testing it.
+ if ($Is_MacOS) {
+ $arch_auto_dir = File::Spec->catdir( $dir, $archname, 'auto' );
+ $arch_dir = File::Spec->catdir( $dir, $archname, );
+ $version_dir = File::Spec->catdir( $dir, $version );
+ $version_arch_dir = File::Spec->catdir( $dir, $version, $archname );
+ } else {
+ $arch_auto_dir = "$dir/$archname/auto";
+ $arch_dir = "$dir/$archname";
+ $version_dir = "$dir/$version";
+ $version_arch_dir = "$dir/$version/$archname";
+ }
+ return($arch_auto_dir, $arch_dir, $version_dir, $version_arch_dir);
+}
+
+sub _nativize {
+ my($dir) = @_;
+
+ if ($Is_MacOS && $Mac_FS && ! -d $dir) {
+ $dir = Mac::FileSpec::Unixish::nativize($dir);
+ $dir .= ":" unless $dir =~ /:$/;
+ }
+
+ return $dir;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+lib - manipulate @INC at compile time
+
+=head1 SYNOPSIS
+
+ use lib LIST;
+
+ no lib LIST;
+
+=head1 DESCRIPTION
+
+This is a small simple module which simplifies the manipulation of @INC
+at compile time.
+
+It is typically used to add extra directories to perl's search path so
+that later C<use> or C<require> statements will find modules which are
+not located on perl's default search path.
+
+=head2 Adding directories to @INC
+
+The parameters to C<use lib> are added to the start of the perl search
+path. Saying
+
+ use lib LIST;
+
+is I<almost> the same as saying
+
+ BEGIN { unshift(@INC, LIST) }
+
+For each directory in LIST (called $dir here) the lib module also
+checks to see if a directory called $dir/$archname/auto exists.
+If so the $dir/$archname directory is assumed to be a corresponding
+architecture specific directory and is added to @INC in front of $dir.
+lib.pm also checks if directories called $dir/$version and $dir/$version/$archname
+exist and adds these directories to @INC.
+
+The current value of C<$archname> can be found with this command:
+
+ perl -V:archname
+
+The corresponding command to get the current value of C<$version> is:
+
+ perl -V:version
+
+To avoid memory leaks, all trailing duplicate entries in @INC are
+removed.
+
+=head2 Deleting directories from @INC
+
+You should normally only add directories to @INC. If you need to
+delete directories from @INC take care to only delete those which you
+added yourself or which you are certain are not needed by other modules
+in your script. Other modules may have added directories which they
+need for correct operation.
+
+The C<no lib> statement deletes all instances of each named directory
+from @INC.
+
+For each directory in LIST (called $dir here) the lib module also
+checks to see if a directory called $dir/$archname/auto exists.
+If so the $dir/$archname directory is assumed to be a corresponding
+architecture specific directory and is also deleted from @INC.
+
+=head2 Restoring original @INC
+
+When the lib module is first loaded it records the current value of @INC
+in an array C<@lib::ORIG_INC>. To restore @INC to that value you
+can say
+
+ @INC = @lib::ORIG_INC;
+
+=head1 CAVEATS
+
+In order to keep lib.pm small and simple, it only works with Unix
+filepaths. This doesn't mean it only works on Unix, but non-Unix
+users must first translate their file paths to Unix conventions.
+
+ # VMS users wanting to put [.stuff.moo] into
+ # their @INC would write
+ use lib 'stuff/moo';
+
+=head1 NOTES
+
+In the future, this module will likely use File::Spec for determining
+paths, as it does now for Mac OS (where Unix-style or Mac-style paths
+work, and Unix-style paths are converted properly to Mac-style paths
+before being added to @INC).
+
+If you try to add a file to @INC as follows:
+
+ use lib 'this_is_a_file.txt';
+
+C<lib> will warn about this. The sole exceptions are files with the
+C<.par> extension which are intended to be used as libraries.
+
+=head1 SEE ALSO
+
+FindBin - optional module which deals with paths relative to the source file.
+
+PAR - optional module which can treat C<.par> files as Perl libraries.
+
+=head1 AUTHOR
+
+Tim Bunce, 2nd June 1995.
+
+C<lib> is maintained by the perl5-porters. Please direct
+any questions to the canonical mailing list. Anything that
+is applicable to the CPAN release can be sent to its maintainer,
+though.
+
+Maintainer: The Perl5-Porters <perl5-porters at perl.org>
+
+Maintainer of the CPAN release: Steffen Mueller <smueller at cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This package has been part of the perl core since perl 5.001.
+It has been released separately to CPAN so older installations
+can benefit from bug fixes.
+
+This package has the same copyright and license as the perl core.
+
+=cut
+!NO!SUBS!
+
+close OUT or die "Can't close $file: $!";
+chdir $origdir;
Modified: trunk/contrib/perl/lib/locale.pm
===================================================================
--- trunk/contrib/perl/lib/locale.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/locale.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,40 +1,101 @@
package locale;
-our $VERSION = '1.00';
+our $VERSION = '1.02';
+use Config;
+$Carp::Internal{ (__PACKAGE__) } = 1;
+
=head1 NAME
-locale - Perl pragma to use and avoid POSIX locales for built-in operations
+locale - Perl pragma to use or avoid POSIX locales for built-in operations
=head1 SYNOPSIS
- @x = sort @y; # ASCII sorting order
+ @x = sort @y; # Unicode sorting order
{
use locale;
@x = sort @y; # Locale-defined sorting order
}
- @x = sort @y; # ASCII sorting order again
+ @x = sort @y; # Unicode sorting order again
=head1 DESCRIPTION
This pragma tells the compiler to enable (or disable) the use of POSIX
-locales for built-in operations (LC_CTYPE for regular expressions, and
-LC_COLLATE for string comparison). Each "use locale" or "no locale"
+locales for built-in operations (for example, LC_CTYPE for regular
+expressions, LC_COLLATE for string comparison, and LC_NUMERIC for number
+formatting). Each "use locale" or "no locale"
affects statements to the end of the enclosing BLOCK.
+Starting in Perl 5.16, a hybrid mode for this pragma is available,
+
+ use locale ':not_characters';
+
+which enables only the portions of locales that don't affect the character
+set (that is, all except LC_COLLATE and LC_CTYPE). This is useful when mixing
+Unicode and locales, including UTF-8 locales.
+
+ use locale ':not_characters';
+ use open ":locale"; # Convert I/O to/from Unicode
+ use POSIX qw(locale_h); # Import the LC_ALL constant
+ setlocale(LC_ALL, ""); # Required for the next statement
+ # to take effect
+ printf "%.2f\n", 12345.67' # Locale-defined formatting
+ @x = sort @y; # Unicode-defined sorting order.
+ # (Note that you will get better
+ # results using Unicode::Collate.)
+
See L<perllocale> for more detailed information on how Perl supports
locales.
+=head1 NOTE
+
+If your system does not support locales, then loading this module will
+cause the program to die with a message:
+
+ "Your vendor does not support locales, you cannot use the locale
+ module."
+
=cut
+# A separate bit is used for each of the two forms of the pragma, as they are
+# mostly independent, and interact with each other and the unicode_strings
+# feature. This allows for fast determination of which one(s) of the three
+# are to be used at any given point, and no code has to be written to deal
+# with coming in and out of scopes--it falls automatically out from the hint
+# handling
+
$locale::hint_bits = 0x4;
+$locale::not_chars_hint_bits = 0x10;
sub import {
- $^H |= $locale::hint_bits;
+ shift; # should be 'locale'; not checked
+
+ if(!$Config{d_setlocale}) {
+ ## No locale support found on this Perl, giving up:
+ die('Your vendor does not support locales, you cannot use the locale module.');
+ }
+
+ my $found_not_chars = 0;
+ while (defined (my $arg = shift)) {
+ if ($arg eq ":not_characters") {
+ $^H |= $locale::not_chars_hint_bits;
+
+ # This form of the pragma overrides the other
+ $^H &= ~$locale::hint_bits;
+ $found_not_chars = 1;
+ }
+ else {
+ require Carp;
+ Carp::croak("Unknown parameter '$arg' to 'use locale'");
+ }
+ }
+
+ # Use the plain form if not doing the :not_characters one.
+ $^H |= $locale::hint_bits unless $found_not_chars;
}
sub unimport {
- $^H &= ~$locale::hint_bits;
+ $^H &= ~($locale::hint_bits|$locale::not_chars_hint_bits);
}
1;
Property changes on: trunk/contrib/perl/lib/locale.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/lib/locale.t
===================================================================
--- trunk/contrib/perl/lib/locale.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/locale.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,5 +1,15 @@
#!./perl -wT
+# This tests plain 'use locale' and adorned 'use locale ":not_characters"'
+# Because these pragmas are compile time, and I (khw) am trying to test
+# without using 'eval' as much as possible, which might cloud the issue, the
+# crucial parts of the code are duplicated in a block for each pragma.
+
+# To make a TODO test, add the string 'TODO' to its %test_names value
+
+binmode STDOUT, ':utf8';
+binmode STDERR, ':utf8';
+
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
@@ -13,9 +23,14 @@
}
use strict;
+use feature 'fc';
-my $debug = 1;
+my $debug = 0;
+# Certain tests have been shown to be problematical for a few locales. Don't
+# fail them unless at least this percentage of the tested locales fail.
+my $acceptable_fold_failure_percentage = 5;
+
use Dumpvalue;
my $dumper = Dumpvalue->new(
@@ -50,22 +65,23 @@
$have_setlocale = 0 if ((($^O eq 'MSWin32' && !$winxp) || $^O eq 'NetWare') &&
$Config{cc} =~ /^(cl|gcc)/i);
-# UWIN seems to loop after test 98, just skip for now
+# UWIN seems to loop after taint tests, just skip for now
$have_setlocale = 0 if ($^O =~ /^uwin/);
-my $last = $have_setlocale ? &last : &last_without_setlocale;
-
-print "1..$last\n";
-
sub LC_ALL ();
$a = 'abc %';
+my $test_num = 0;
+
sub ok {
- my ($n, $result) = @_;
+ my ($result, $message) = @_;
+ $message = "" unless defined $message;
print 'not ' unless ($result);
- print "ok $n\n";
+ print "ok " . ++$test_num;
+ print " $message";
+ print "\n";
}
# First we'll do a lot of taint checking for locales.
@@ -75,182 +91,363 @@
sub is_tainted { # hello, camel two.
no warnings 'uninitialized' ;
my $dummy;
+ local $@;
not eval { $dummy = join("", @_), kill 0; 1 }
}
-sub check_taint ($$) {
- ok $_[0], is_tainted($_[1]);
+sub check_taint ($;$) {
+ my $message_tail = $_[1] // "";
+ $message_tail = ": $message_tail" if $message_tail;
+ ok is_tainted($_[0]), "verify that is tainted$message_tail";
}
-sub check_taint_not ($$) {
- ok $_[0], not is_tainted($_[1]);
+sub check_taint_not ($;$) {
+ my $message_tail = $_[1] // "";
+ $message_tail = ": $message_tail" if $message_tail;
+ ok((not is_tainted($_[0])), "verify that isn't tainted$message_tail");
}
+"\tb\t" =~ /^m?(\s)(.*)\1$/;
+check_taint_not $&, "not tainted outside 'use locale'";
+;
+
use locale; # engage locale and therefore locale taint.
-check_taint_not 1, $a;
+check_taint_not $a;
-check_taint 2, uc($a);
-check_taint 3, "\U$a";
-check_taint 4, ucfirst($a);
-check_taint 5, "\u$a";
-check_taint 6, lc($a);
-check_taint 7, "\L$a";
-check_taint 8, lcfirst($a);
-check_taint 9, "\l$a";
+check_taint uc($a);
+check_taint "\U$a";
+check_taint ucfirst($a);
+check_taint "\u$a";
+check_taint lc($a);
+check_taint fc($a);
+check_taint "\L$a";
+check_taint "\F$a";
+check_taint lcfirst($a);
+check_taint "\l$a";
-check_taint_not 10, sprintf('%e', 123.456);
-check_taint_not 11, sprintf('%f', 123.456);
-check_taint_not 12, sprintf('%g', 123.456);
-check_taint_not 13, sprintf('%d', 123.456);
-check_taint_not 14, sprintf('%x', 123.456);
+check_taint_not sprintf('%e', 123.456);
+check_taint_not sprintf('%f', 123.456);
+check_taint_not sprintf('%g', 123.456);
+check_taint_not sprintf('%d', 123.456);
+check_taint_not sprintf('%x', 123.456);
$_ = $a; # untaint $_
$_ = uc($a); # taint $_
-check_taint 15, $_;
+check_taint $_;
/(\w)/; # taint $&, $`, $', $+, $1.
-check_taint 16, $&;
-check_taint 17, $`;
-check_taint 18, $';
-check_taint 19, $+;
-check_taint 20, $1;
-check_taint_not 21, $2;
+check_taint $&;
+check_taint $`;
+check_taint $';
+check_taint $+;
+check_taint $1;
+check_taint_not $2;
/(.)/; # untaint $&, $`, $', $+, $1.
-check_taint_not 22, $&;
-check_taint_not 23, $`;
-check_taint_not 24, $';
-check_taint_not 25, $+;
-check_taint_not 26, $1;
-check_taint_not 27, $2;
+check_taint_not $&;
+check_taint_not $`;
+check_taint_not $';
+check_taint_not $+;
+check_taint_not $1;
+check_taint_not $2;
/(\W)/; # taint $&, $`, $', $+, $1.
-check_taint 28, $&;
-check_taint 29, $`;
-check_taint 30, $';
-check_taint 31, $+;
-check_taint 32, $1;
-check_taint_not 33, $2;
+check_taint $&;
+check_taint $`;
+check_taint $';
+check_taint $+;
+check_taint $1;
+check_taint_not $2;
/(\s)/; # taint $&, $`, $', $+, $1.
-check_taint 34, $&;
-check_taint 35, $`;
-check_taint 36, $';
-check_taint 37, $+;
-check_taint 38, $1;
-check_taint_not 39, $2;
+check_taint $&;
+check_taint $`;
+check_taint $';
+check_taint $+;
+check_taint $1;
+check_taint_not $2;
/(\S)/; # taint $&, $`, $', $+, $1.
-check_taint 40, $&;
-check_taint 41, $`;
-check_taint 42, $';
-check_taint 43, $+;
-check_taint 44, $1;
-check_taint_not 45, $2;
+check_taint $&;
+check_taint $`;
+check_taint $';
+check_taint $+;
+check_taint $1;
+check_taint_not $2;
$_ = $a; # untaint $_
-check_taint_not 46, $_;
+check_taint_not $_;
/(b)/; # this must not taint
-check_taint_not 47, $&;
-check_taint_not 48, $`;
-check_taint_not 49, $';
-check_taint_not 50, $+;
-check_taint_not 51, $1;
-check_taint_not 52, $2;
+check_taint_not $&;
+check_taint_not $`;
+check_taint_not $';
+check_taint_not $+;
+check_taint_not $1;
+check_taint_not $2;
$_ = $a; # untaint $_
-check_taint_not 53, $_;
+check_taint_not $_;
$b = uc($a); # taint $b
s/(.+)/$b/; # this must taint only the $_
-check_taint 54, $_;
-check_taint_not 55, $&;
-check_taint_not 56, $`;
-check_taint_not 57, $';
-check_taint_not 58, $+;
-check_taint_not 59, $1;
-check_taint_not 60, $2;
+check_taint $_;
+check_taint_not $&;
+check_taint_not $`;
+check_taint_not $';
+check_taint_not $+;
+check_taint_not $1;
+check_taint_not $2;
$_ = $a; # untaint $_
s/(.+)/b/; # this must not taint
-check_taint_not 61, $_;
-check_taint_not 62, $&;
-check_taint_not 63, $`;
-check_taint_not 64, $';
-check_taint_not 65, $+;
-check_taint_not 66, $1;
-check_taint_not 67, $2;
+check_taint_not $_;
+check_taint_not $&;
+check_taint_not $`;
+check_taint_not $';
+check_taint_not $+;
+check_taint_not $1;
+check_taint_not $2;
$b = $a; # untaint $b
($b = $a) =~ s/\w/$&/;
-check_taint 68, $b; # $b should be tainted.
-check_taint_not 69, $a; # $a should be not.
+check_taint $b; # $b should be tainted.
+check_taint_not $a; # $a should be not.
$_ = $a; # untaint $_
s/(\w)/\l$1/; # this must taint
-check_taint 70, $_;
-check_taint 71, $&;
-check_taint 72, $`;
-check_taint 73, $';
-check_taint 74, $+;
-check_taint 75, $1;
-check_taint_not 76, $2;
+check_taint $_;
+check_taint $&;
+check_taint $`;
+check_taint $';
+check_taint $+;
+check_taint $1;
+check_taint_not $2;
$_ = $a; # untaint $_
s/(\w)/\L$1/; # this must taint
-check_taint 77, $_;
-check_taint 78, $&;
-check_taint 79, $`;
-check_taint 80, $';
-check_taint 81, $+;
-check_taint 82, $1;
-check_taint_not 83, $2;
+check_taint $_;
+check_taint $&;
+check_taint $`;
+check_taint $';
+check_taint $+;
+check_taint $1;
+check_taint_not $2;
$_ = $a; # untaint $_
s/(\w)/\u$1/; # this must taint
-check_taint 84, $_;
-check_taint 85, $&;
-check_taint 86, $`;
-check_taint 87, $';
-check_taint 88, $+;
-check_taint 89, $1;
-check_taint_not 90, $2;
+check_taint $_;
+check_taint $&;
+check_taint $`;
+check_taint $';
+check_taint $+;
+check_taint $1;
+check_taint_not $2;
$_ = $a; # untaint $_
s/(\w)/\U$1/; # this must taint
-check_taint 91, $_;
-check_taint 92, $&;
-check_taint 93, $`;
-check_taint 94, $';
-check_taint 95, $+;
-check_taint 96, $1;
-check_taint_not 97, $2;
+check_taint $_;
+check_taint $&;
+check_taint $`;
+check_taint $';
+check_taint $+;
+check_taint $1;
+check_taint_not $2;
# After all this tainting $a should be cool.
-check_taint_not 98, $a;
+check_taint_not $a;
-sub last_without_setlocale { 98 }
+{ # This is just the previous tests copied here with a different
+ # compile-time pragma.
+ use locale ':not_characters'; # engage restricted locale with different
+ # tainting rules
+
+ check_taint_not $a;
+
+ check_taint_not uc($a);
+ check_taint_not "\U$a";
+ check_taint_not ucfirst($a);
+ check_taint_not "\u$a";
+ check_taint_not lc($a);
+ check_taint_not fc($a);
+ check_taint_not "\L$a";
+ check_taint_not "\F$a";
+ check_taint_not lcfirst($a);
+ check_taint_not "\l$a";
+
+ check_taint_not sprintf('%e', 123.456);
+ check_taint_not sprintf('%f', 123.456);
+ check_taint_not sprintf('%g', 123.456);
+ check_taint_not sprintf('%d', 123.456);
+ check_taint_not sprintf('%x', 123.456);
+
+ $_ = $a; # untaint $_
+
+ $_ = uc($a); # taint $_
+
+ check_taint_not $_;
+
+ /(\w)/; # taint $&, $`, $', $+, $1.
+ check_taint_not $&;
+ check_taint_not $`;
+ check_taint_not $';
+ check_taint_not $+;
+ check_taint_not $1;
+ check_taint_not $2;
+
+ /(.)/; # untaint $&, $`, $', $+, $1.
+ check_taint_not $&;
+ check_taint_not $`;
+ check_taint_not $';
+ check_taint_not $+;
+ check_taint_not $1;
+ check_taint_not $2;
+
+ /(\W)/; # taint $&, $`, $', $+, $1.
+ check_taint_not $&;
+ check_taint_not $`;
+ check_taint_not $';
+ check_taint_not $+;
+ check_taint_not $1;
+ check_taint_not $2;
+
+ /(\s)/; # taint $&, $`, $', $+, $1.
+ check_taint_not $&;
+ check_taint_not $`;
+ check_taint_not $';
+ check_taint_not $+;
+ check_taint_not $1;
+ check_taint_not $2;
+
+ /(\S)/; # taint $&, $`, $', $+, $1.
+ check_taint_not $&;
+ check_taint_not $`;
+ check_taint_not $';
+ check_taint_not $+;
+ check_taint_not $1;
+ check_taint_not $2;
+
+ $_ = $a; # untaint $_
+
+ check_taint_not $_;
+
+ /(b)/; # this must not taint
+ check_taint_not $&;
+ check_taint_not $`;
+ check_taint_not $';
+ check_taint_not $+;
+ check_taint_not $1;
+ check_taint_not $2;
+
+ $_ = $a; # untaint $_
+
+ check_taint_not $_;
+
+ $b = uc($a); # taint $b
+ s/(.+)/$b/; # this must taint only the $_
+
+ check_taint_not $_;
+ check_taint_not $&;
+ check_taint_not $`;
+ check_taint_not $';
+ check_taint_not $+;
+ check_taint_not $1;
+ check_taint_not $2;
+
+ $_ = $a; # untaint $_
+
+ s/(.+)/b/; # this must not taint
+ check_taint_not $_;
+ check_taint_not $&;
+ check_taint_not $`;
+ check_taint_not $';
+ check_taint_not $+;
+ check_taint_not $1;
+ check_taint_not $2;
+
+ $b = $a; # untaint $b
+
+ ($b = $a) =~ s/\w/$&/;
+ check_taint_not $b; # $b should be tainted.
+ check_taint_not $a; # $a should be not.
+
+ $_ = $a; # untaint $_
+
+ s/(\w)/\l$1/; # this must taint
+ check_taint_not $_;
+ check_taint_not $&;
+ check_taint_not $`;
+ check_taint_not $';
+ check_taint_not $+;
+ check_taint_not $1;
+ check_taint_not $2;
+
+ $_ = $a; # untaint $_
+
+ s/(\w)/\L$1/; # this must taint
+ check_taint_not $_;
+ check_taint_not $&;
+ check_taint_not $`;
+ check_taint_not $';
+ check_taint_not $+;
+ check_taint_not $1;
+ check_taint_not $2;
+
+ $_ = $a; # untaint $_
+
+ s/(\w)/\u$1/; # this must taint
+ check_taint_not $_;
+ check_taint_not $&;
+ check_taint_not $`;
+ check_taint_not $';
+ check_taint_not $+;
+ check_taint_not $1;
+ check_taint_not $2;
+
+ $_ = $a; # untaint $_
+
+ s/(\w)/\U$1/; # this must taint
+ check_taint_not $_;
+ check_taint_not $&;
+ check_taint_not $`;
+ check_taint_not $';
+ check_taint_not $+;
+ check_taint_not $1;
+ check_taint_not $2;
+
+ # After all this tainting $a should be cool.
+
+ check_taint_not $a;
+}
+
+# Here are in scope of 'use locale'
+
# I think we've seen quite enough of taint.
# Let us do some *real* locale work now,
# unless setlocale() is missing (i.e. minitest).
-exit unless $have_setlocale;
+unless ($have_setlocale) {
+ print "1..$test_num\n";
+ exit;
+}
+# The test number before our first setlocale()
+my $final_without_setlocale = $test_num;
+
# Find locales.
debug "# Scanning for locales...\n";
@@ -269,7 +466,7 @@
Hrvatski Croatian:hr:hr:2
Cymraeg Welsh:cy:cy:1 14 15
Czech:cs:cz:2
-Dansk Danish:dk:da:1 15
+Dansk Danish:da:dk:1 15
Nederlands Dutch:nl:be nl:1 15
English American British:en:au ca gb ie nz us uk zw:1 15 cp850
Esperanto:eo:eo:3
@@ -284,7 +481,7 @@
Greenlandic:kl:gl:4 6
Hebrew:iw:il:8 hebrew8
Hungarian:hu:hu:2
-Indonesian:in:id:1 15
+Indonesian:id:id:1 15
Gaeilge Irish:ga:IE:1 14 15
Italiano Italian:it:ch it:1 15
Nihongo Japanese:ja:jp:euc eucJP jp.EUC sjis
@@ -295,7 +492,7 @@
Macedonian:mk:mk:1 15
Maltese:mt:mt:3
Moldovan:mo:mo:2
-Norsk Norwegian:no no\@nynorsk:no:1 15
+Norsk Norwegian:no no\@nynorsk nb nn:no:1 15
Occitan:oc:es:1 15
Polski Polish:pl:pl:2
Rumanian:ro:ro:2
@@ -328,18 +525,23 @@
my $Locale;
my @Alnum_;
-my @utf8locale;
-my %utf8skip;
-
-sub getalnum_ {
- sort grep /\w/, map { chr } 0..255
-}
-
sub trylocale {
my $locale = shift;
- if (setlocale(LC_ALL, $locale)) {
- push @Locale, $locale;
+ return if grep { $locale eq $_ } @Locale;
+ return unless setlocale(LC_ALL, $locale);
+ my $badutf8;
+ {
+ local $SIG{__WARN__} = sub {
+ $badutf8 = $_[0] =~ /Malformed UTF-8/;
+ };
+ $Locale =~ /UTF-?8/i;
}
+
+ if ($badutf8) {
+ ok(0, "Locale name contains malformed utf8");
+ return;
+ }
+ push @Locale, $locale;
}
sub decode_encodings {
@@ -396,7 +598,7 @@
}
close(LOCALES);
} elsif ($^O eq 'VMS' && defined($ENV{'SYS$I18N_LOCALE'}) && -d 'SYS$I18N_LOCALE') {
-# The SYS$I18N_LOCALE logical name search list was not present on
+# The SYS$I18N_LOCALE logical name search list was not present on
# VAX VMS V5.5-12, but was on AXP && VAX VMS V6.2 as well as later versions.
opendir(LOCALES, "SYS\$I18N_LOCALE:");
while ($_ = readdir(LOCALES)) {
@@ -476,46 +678,81 @@
my %Problem;
my %Okay;
my %Testing;
-my @Neoalpha;
-my %Neoalpha;
+my @Neoalpha; # Alnums that aren't in the C locale.
+my %test_names;
sub tryneoalpha {
- my ($Locale, $i, $test) = @_;
+ my ($Locale, $i, $test, $message) = @_;
+ $message //= "";
+ $message = " ($message)" if $message;
unless ($test) {
$Problem{$i}{$Locale} = 1;
- debug "# failed $i with locale '$Locale'\n";
+ debug "# failed $i with locale '$Locale'$message\n";
} else {
push @{$Okay{$i}}, $Locale;
}
}
+my $first_locales_test_number = $final_without_setlocale + 1;
+my $locales_test_number;
+my $not_necessarily_a_problem_test_number;
+my $first_casing_test_number;
+my $final_casing_test_number;
+my %setlocale_failed; # List of locales that setlocale() didn't work on
+
foreach $Locale (@Locale) {
+ $locales_test_number = $first_locales_test_number - 1;
debug "# Locale = $Locale\n";
- @Alnum_ = getalnum_();
- debug "# w = ", join("", at Alnum_), "\n";
unless (setlocale(LC_ALL, $Locale)) {
- foreach (99..103) {
- $Problem{$_}{$Locale} = -1;
- }
+ $setlocale_failed{$Locale} = $Locale;
next;
}
- # Sieve the uppercase and the lowercase.
-
+ # We test UTF-8 locales only under ':not_characters'; otherwise they have
+ # documented deficiencies. Non- UTF-8 locales are tested only under plain
+ # 'use locale', as otherwise we would have to convert everything in them
+ # to Unicode.
+ my $is_utf8_locale = $Locale =~ /UTF-?8/i;
+
my %UPPER = ();
my %lower = ();
my %BoThCaSe = ();
- for (@Alnum_) {
- if (/[^\d_]/) { # skip digits and the _
- if (uc($_) eq $_) {
- $UPPER{$_} = $_;
- }
- if (lc($_) eq $_) {
- $lower{$_} = $_;
- }
- }
+
+ if (! $is_utf8_locale) {
+ use locale;
+ @Alnum_ = sort grep /\w/, map { chr } 0..255;
+
+ debug "# w = ", join("", at Alnum_), "\n";
+
+ # Sieve the uppercase and the lowercase.
+
+ for (@Alnum_) {
+ if (/[^\d_]/) { # skip digits and the _
+ if (uc($_) eq $_) {
+ $UPPER{$_} = $_;
+ }
+ if (lc($_) eq $_) {
+ $lower{$_} = $_;
+ }
+ }
+ }
}
+ else {
+ use locale ':not_characters';
+ @Alnum_ = sort grep /\w/, map { chr } 0..255;
+ debug "# w = ", join("", at Alnum_), "\n";
+ for (@Alnum_) {
+ if (/[^\d_]/) { # skip digits and the _
+ if (uc($_) eq $_) {
+ $UPPER{$_} = $_;
+ }
+ if (lc($_) eq $_) {
+ $lower{$_} = $_;
+ }
+ }
+ }
+ }
foreach (keys %UPPER) {
$BoThCaSe{$_}++ if exists $lower{$_};
}
@@ -531,15 +768,78 @@
debug "# lower = ", join("", sort keys %lower ), "\n";
debug "# BoThCaSe = ", join("", sort keys %BoThCaSe), "\n";
- # Find the alphabets that are not alphabets in the default locale.
+ my @failures;
+ my @fold_failures;
+ foreach my $x (sort keys %UPPER) {
+ my $ok;
+ my $fold_ok;
+ if ($is_utf8_locale) {
+ use locale ':not_characters';
+ $ok = $x =~ /[[:upper:]]/;
+ $fold_ok = $x =~ /[[:lower:]]/i;
+ }
+ else {
+ use locale;
+ $ok = $x =~ /[[:upper:]]/;
+ $fold_ok = $x =~ /[[:lower:]]/i;
+ }
+ push @failures, $x unless $ok;
+ push @fold_failures, $x unless $fold_ok;
+ }
+ my $message = "";
+ $locales_test_number++;
+ $first_casing_test_number = $locales_test_number;
+ $test_names{$locales_test_number} = 'Verify that /[[:upper:]]/ matches sieved uppercase characters.';
+ $message = 'Failed for ' . join ", ", @failures if @failures;
+ tryneoalpha($Locale, $locales_test_number, scalar @failures == 0, $message);
- {
+ $message = "";
+ $locales_test_number++;
+
+ $test_names{$locales_test_number} = 'Verify that /[[:lower:]]/i matches sieved uppercase characters.';
+ $message = 'Failed for ' . join ", ", @fold_failures if @fold_failures;
+ tryneoalpha($Locale, $locales_test_number, scalar @fold_failures == 0, $message);
+
+ $message = "";
+ undef @failures;
+ undef @fold_failures;
+
+ foreach my $x (sort keys %lower) {
+ my $ok;
+ my $fold_ok;
+ if ($is_utf8_locale) {
+ use locale ':not_characters';
+ $ok = $x =~ /[[:lower:]]/;
+ $fold_ok = $x =~ /[[:upper:]]/i;
+ }
+ else {
+ use locale;
+ $ok = $x =~ /[[:lower:]]/;
+ $fold_ok = $x =~ /[[:upper:]]/i;
+ }
+ push @failures, $x unless $ok;
+ push @fold_failures, $x unless $fold_ok;
+ }
+
+ $locales_test_number++;
+ $test_names{$locales_test_number} = 'Verify that /[[:lower:]]/ matches sieved lowercase characters.';
+ $message = 'Failed for ' . join ", ", @failures if @failures;
+ tryneoalpha($Locale, $locales_test_number, scalar @failures == 0, $message);
+ $message = "";
+ $locales_test_number++;
+ $final_casing_test_number = $locales_test_number;
+ $test_names{$locales_test_number} = 'Verify that /[[:upper:]]/i matches sieved lowercase characters.';
+ $message = 'Failed for ' . join ", ", @fold_failures if @fold_failures;
+ tryneoalpha($Locale, $locales_test_number, scalar @fold_failures == 0, $message);
+
+ { # Find the alphabetic characters that are not considered alphabetics
+ # in the default (C) locale.
+
no locale;
-
+
@Neoalpha = ();
for (keys %UPPER, keys %lower) {
push(@Neoalpha, $_) if (/\W/);
- $Neoalpha{$_} = $_;
}
}
@@ -547,46 +847,51 @@
debug "# Neoalpha = ", join("", at Neoalpha), "\n";
+ my $first_Neoalpha_test_number = $locales_test_number + 1;
+ my $final_Neoalpha_test_number = $first_Neoalpha_test_number + 3;
if (@Neoalpha == 0) {
# If we have no Neoalphas the remaining tests are no-ops.
- debug "# no Neoalpha, skipping tests 99..102 for locale '$Locale'\n";
- foreach (99..102) {
+ debug "# no Neoalpha, skipping tests $first_Neoalpha_test_number..$final_Neoalpha_test_number for locale '$Locale'\n";
+ foreach ($locales_test_number+1..$final_Neoalpha_test_number) {
push @{$Okay{$_}}, $Locale;
+ $locales_test_number++;
}
} else {
# Test \w.
-
+
my $word = join('', @Neoalpha);
- my $badutf8;
- {
- local $SIG{__WARN__} = sub {
- $badutf8 = $_[0] =~ /Malformed UTF-8/;
- };
- $Locale =~ /utf-?8/i;
- }
+ ++$locales_test_number;
+ $test_names{$locales_test_number} = 'Verify that alnums outside the C locale match \w';
+ my $ok;
+ if ($is_utf8_locale) {
+ use locale ':not_characters';
+ $ok = $word =~ /^(\w+)$/;
+ }
+ else {
+ # Already in 'use locale'; this tests that exiting scopes works
+ $ok = $word =~ /^(\w+)$/;
+ }
+ tryneoalpha($Locale, $locales_test_number, $ok);
- if ($badutf8) {
- debug "# Locale name contains bad UTF-8, skipping test 99 for locale '$Locale'\n";
- } elsif ($Locale =~ /utf-?8/i) {
- debug "# unknown whether locale and Unicode have the same \\w, skipping test 99 for locale '$Locale'\n";
- push @{$Okay{99}}, $Locale;
- } else {
- if ($word =~ /^(\w+)$/) {
- tryneoalpha($Locale, 99, 1);
- } else {
- tryneoalpha($Locale, 99, 0);
- }
- }
-
# Cross-check the whole 8-bit character set.
+ ++$locales_test_number;
+ $test_names{$locales_test_number} = 'Verify that \w and \W are mutually exclusive, as are \d, \D; \s, \S';
for (map { chr } 0..255) {
- tryneoalpha($Locale, 100,
- (/\w/ xor /\W/) ||
+ if ($is_utf8_locale) {
+ use locale ':not_characters';
+ $ok = (/\w/ xor /\W/) ||
(/\d/ xor /\D/) ||
- (/\s/ xor /\S/));
+ (/\s/ xor /\S/);
+ }
+ else {
+ $ok = (/\w/ xor /\W/) ||
+ (/\d/ xor /\D/) ||
+ (/\s/ xor /\S/);
+ }
+ tryneoalpha($Locale, $locales_test_number, $ok);
}
# Test for read-only scalars' locale vs non-locale comparisons.
@@ -594,10 +899,16 @@
{
no locale;
$a = "qwerty";
- {
- use locale;
- tryneoalpha($Locale, 101, ($a cmp "qwerty") == 0);
- }
+ if ($is_utf8_locale) {
+ use locale ':not_characters';
+ $ok = ($a cmp "qwerty") == 0;
+ }
+ else {
+ use locale;
+ $ok = ($a cmp "qwerty") == 0;
+ }
+ tryneoalpha($Locale, ++$locales_test_number, $ok);
+ $test_names{$locales_test_number} = 'Verify that cmp works with a read-only scalar; no- vs locale';
}
{
@@ -604,6 +915,9 @@
my ($from, $to, $lesser, $greater,
@test, %test, $test, $yes, $no, $sign);
+ ++$locales_test_number;
+ $test_names{$locales_test_number} = 'Verify that "le", "ne", etc work';
+ $not_necessarily_a_problem_test_number = $locales_test_number;
for (0..9) {
# Select a slice.
$from = int(($_*@Alnum_)/10);
@@ -614,13 +928,22 @@
$from++; $to++;
$to = $#Alnum_ if ($to > $#Alnum_);
$greater = join('', @Alnum_[$from..$to]);
- ($yes, $no, $sign) = ($lesser lt $greater
+ if ($is_utf8_locale) {
+ use locale ':not_characters';
+ ($yes, $no, $sign) = ($lesser lt $greater
? (" ", "not ", 1)
: ("not ", " ", -1));
+ }
+ else {
+ use locale;
+ ($yes, $no, $sign) = ($lesser lt $greater
+ ? (" ", "not ", 1)
+ : ("not ", " ", -1));
+ }
# all these tests should FAIL (return 0).
# Exact lt or gt cannot be tested because
# in some locales, say, eacute and E may test equal.
- @test =
+ @test =
(
$no.' ($lesser le $greater)', # 1
'not ($lesser ne $greater)', # 2
@@ -636,10 +959,17 @@
@test{@test} = 0 x @test;
$test = 0;
for my $ti (@test) {
- $test{$ti} = eval $ti;
+ if ($is_utf8_locale) {
+ use locale ':not_characters';
+ $test{$ti} = eval $ti;
+ }
+ else {
+ # Already in 'use locale';
+ $test{$ti} = eval $ti;
+ }
$test ||= $test{$ti}
}
- tryneoalpha($Locale, 102, $test == 0);
+ tryneoalpha($Locale, $locales_test_number, $test == 0);
if ($test) {
debug "# lesser = '$lesser'\n";
debug "# greater = '$greater'\n";
@@ -663,78 +993,194 @@
}
}
- use locale;
+ if ($locales_test_number != $final_Neoalpha_test_number) {
+ die("The delta for \$final_Neoalpha needs to be updated from "
+ . ($final_Neoalpha_test_number - $first_Neoalpha_test_number)
+ . " to "
+ . ($locales_test_number - $first_Neoalpha_test_number)
+ );
+ }
- my ($x, $y) = (1.23, 1.23);
+ my $ok1;
+ my $ok2;
+ my $ok3;
+ my $ok4;
+ my $ok5;
+ my $ok6;
+ my $ok7;
+ my $ok8;
+ my $ok9;
+ my $ok10;
+ my $ok11;
+ my $ok12;
+ my $ok13;
- $a = "$x";
- printf ''; # printf used to reset locale to "C"
- $b = "$y";
+ my $c;
+ my $d;
+ my $e;
+ my $f;
+ my $g;
- debug "# 103..107: a = $a, b = $b, Locale = $Locale\n";
+ if (! $is_utf8_locale) {
+ use locale;
- tryneoalpha($Locale, 103, $a eq $b);
+ my ($x, $y) = (1.23, 1.23);
- my $c = "$x";
- my $z = sprintf ''; # sprintf used to reset locale to "C"
- my $d = "$y";
+ $a = "$x";
+ printf ''; # printf used to reset locale to "C"
+ $b = "$y";
+ $ok1 = $a eq $b;
- debug "# 104..107: c = $c, d = $d, Locale = $Locale\n";
+ $c = "$x";
+ my $z = sprintf ''; # sprintf used to reset locale to "C"
+ $d = "$y";
+ $ok2 = $c eq $d;
+ {
- tryneoalpha($Locale, 104, $c eq $d);
+ use warnings;
+ my $w = 0;
+ local $SIG{__WARN__} =
+ sub {
+ print "# @_\n";
+ $w++;
+ };
- {
- use warnings;
- my $w = 0;
- local $SIG{__WARN__} =
- sub {
- print "# @_\n";
- $w++;
- };
+ # The == (among other ops) used to warn for locales
+ # that had something else than "." as the radix character.
- # The == (among other ops) used to warn for locales
- # that had something else than "." as the radix character.
+ $ok3 = $c == 1.23;
+ $ok4 = $c == $x;
+ $ok5 = $c == $d;
+ {
+ no locale;
- tryneoalpha($Locale, 105, $c == 1.23);
+ # The earlier test was $e = "$x". But this fails [perl
+ # #108378], and the "no locale" was commented out. But doing
+ # that made all the tests in the block after this one
+ # meaningless, as originally it was testing the nesting of a
+ # "no locale" scope, and how it recovers after that scope is
+ # done. So I (khw) filed a bug report and changed this so it
+ # wouldn't fail. It seemed too much work to add TODOs
+ # instead. Should this be fixed, the following test names
+ # would need to be revised; they mostly don't really test
+ # anything currently.
+ $e = $x;
- tryneoalpha($Locale, 106, $c == $x);
+ $ok6 = $e == 1.23;
+ $ok7 = $e == $x;
+ $ok8 = $e == $c;
+ }
- tryneoalpha($Locale, 107, $c == $d);
+ $f = "1.23";
+ $g = 2.34;
- {
-# no locale; # XXX did this ever work correctly?
-
- my $e = "$x";
+ $ok9 = $f == 1.23;
+ $ok10 = $f == $x;
+ $ok11 = $f == $c;
+ $ok12 = abs(($f + $g) - 3.57) < 0.01;
+ $ok13 = $w == 0;
+ }
+ }
+ else {
+ use locale ':not_characters';
- debug "# 108..110: e = $e, Locale = $Locale\n";
+ my ($x, $y) = (1.23, 1.23);
+ $a = "$x";
+ printf ''; # printf used to reset locale to "C"
+ $b = "$y";
+ $ok1 = $a eq $b;
- tryneoalpha($Locale, 108, $e == 1.23);
+ $c = "$x";
+ my $z = sprintf ''; # sprintf used to reset locale to "C"
+ $d = "$y";
+ $ok2 = $c eq $d;
+ {
+ use warnings;
+ my $w = 0;
+ local $SIG{__WARN__} =
+ sub {
+ print "# @_\n";
+ $w++;
+ };
+ $ok3 = $c == 1.23;
+ $ok4 = $c == $x;
+ $ok5 = $c == $d;
+ {
+ no locale;
+ $e = $x;
- tryneoalpha($Locale, 109, $e == $x);
-
- tryneoalpha($Locale, 110, $e == $c);
- }
-
- my $f = "1.23";
- my $g = 2.34;
+ $ok6 = $e == 1.23;
+ $ok7 = $e == $x;
+ $ok8 = $e == $c;
+ }
- debug "# 111..115: f = $f, g = $g, locale = $Locale\n";
+ $f = "1.23";
+ $g = 2.34;
- tryneoalpha($Locale, 111, $f == 1.23);
+ $ok9 = $f == 1.23;
+ $ok10 = $f == $x;
+ $ok11 = $f == $c;
+ $ok12 = abs(($f + $g) - 3.57) < 0.01;
+ $ok13 = $w == 0;
+ }
+ }
- tryneoalpha($Locale, 112, $f == $x);
-
- tryneoalpha($Locale, 113, $f == $c);
+ tryneoalpha($Locale, ++$locales_test_number, $ok1);
+ $test_names{$locales_test_number} = 'Verify that an intervening printf doesn\'t change assignment results';
+ my $first_a_test = $locales_test_number;
- tryneoalpha($Locale, 114, abs(($f + $g) - 3.57) < 0.01);
+ debug "# $first_a_test..$locales_test_number: \$a = $a, \$b = $b, Locale = $Locale\n";
- tryneoalpha($Locale, 115, $w == 0);
- }
+ tryneoalpha($Locale, ++$locales_test_number, $ok2);
+ $test_names{$locales_test_number} = 'Verify that an intervening sprintf doesn\'t change assignment results';
+ my $first_c_test = $locales_test_number;
+
+ tryneoalpha($Locale, ++$locales_test_number, $ok3);
+ $test_names{$locales_test_number} = 'Verify that a different locale radix works when doing "==" with a constant';
+
+ tryneoalpha($Locale, ++$locales_test_number, $ok4);
+ $test_names{$locales_test_number} = 'Verify that a different locale radix works when doing "==" with a scalar';
+
+ tryneoalpha($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';
+
+ debug "# $first_c_test..$locales_test_number: \$c = $c, \$d = $d, Locale = $Locale\n";
+
+ tryneoalpha($Locale, ++$locales_test_number, $ok6);
+ $test_names{$locales_test_number} = 'Verify that can assign numerically under inner no-locale block';
+ my $first_e_test = $locales_test_number;
+
+ tryneoalpha($Locale, ++$locales_test_number, $ok7);
+ $test_names{$locales_test_number} = 'Verify that "==" with a scalar still works in inner no locale';
+
+ tryneoalpha($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';
+
+ debug "# $first_e_test..$locales_test_number: \$e = $e, no locale\n";
+
+ tryneoalpha($Locale, ++$locales_test_number, $ok9);
+ $test_names{$locales_test_number} = 'Verify that after a no-locale block, a different locale radix still works when doing "==" with a constant';
+ my $first_f_test = $locales_test_number;
+
+ tryneoalpha($Locale, ++$locales_test_number, $ok10);
+ $test_names{$locales_test_number} = 'Verify that after a no-locale block, a different locale radix still works when doing "==" with a scalar';
+
+ tryneoalpha($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';
+
+ tryneoalpha($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';
+
+ tryneoalpha($Locale, ++$locales_test_number, $ok13);
+ $test_names{$locales_test_number} = 'Verify that don\'t get warning under "==" even if radix is not a dot';
+
+ debug "# $first_f_test..$locales_test_number: \$f = $f, \$g = $g, back to locale = $Locale\n";
+
# Does taking lc separately differ from taking
# the lc "in-line"? (This was the bug 19990704.002, change #3568.)
# The bug was in the caching of the 'o'-magic.
- {
+ if (! $is_utf8_locale) {
use locale;
sub lcA {
@@ -751,11 +1197,33 @@
my $y = "aa";
my $z = "AB";
- tryneoalpha($Locale, 116,
+ tryneoalpha($Locale, ++$locales_test_number,
lcA($x, $y) == 1 && lcB($x, $y) == 1 ||
lcA($x, $z) == 0 && lcB($x, $z) == 0);
}
+ else {
+ use locale ':not_characters';
+ sub lcC {
+ my $lc0 = lc $_[0];
+ my $lc1 = lc $_[1];
+ return $lc0 cmp $lc1;
+ }
+
+ sub lcD {
+ return lc($_[0]) cmp lc($_[1]);
+ }
+
+ my $x = "ab";
+ my $y = "aa";
+ my $z = "AB";
+
+ tryneoalpha($Locale, ++$locales_test_number,
+ lcC($x, $y) == 1 && lcD($x, $y) == 1 ||
+ lcC($x, $z) == 0 && lcD($x, $z) == 0);
+ }
+ $test_names{$locales_test_number} = 'Verify "lc(foo) cmp lc(bar)" is the same as using intermediaries for the cmp';
+
# Does lc of an UPPER (if different from the UPPER) match
# case-insensitively the UPPER, and does the UPPER match
# case-insensitively the lc of the UPPER. And vice versa.
@@ -765,78 +1233,175 @@
my $re = qr/[\[\(\{\*\+\?\|\^\$\\]/;
my @f = ();
- foreach my $x (keys %UPPER) {
- my $y = lc $x;
- next unless uc $y eq $x;
- print "# UPPER $x lc $y ",
- $x =~ /$y/i ? 1 : 0, " ",
- $y =~ /$x/i ? 1 : 0, "\n" if 0;
- #
- # If $x and $y contain regular expression characters
- # AND THEY lowercase (/i) to regular expression characters,
- # regcomp() will be mightily confused. No, the \Q doesn't
- # help here (maybe regex engine internal lowercasing
- # is done after the \Q?) An example of this happening is
- # the bg_BG (Bulgarian) locale under EBCDIC (OS/390 USS):
- # the chr(173) (the "[") is the lowercase of the chr(235).
- #
- # Similarly losing EBCDIC locales include cs_cz, cs_CZ,
- # el_gr, el_GR, en_us.IBM-037 (!), en_US.IBM-037 (!),
- # et_ee, et_EE, hr_hr, hr_HR, hu_hu, hu_HU, lt_LT,
- # mk_mk, mk_MK, nl_nl.IBM-037, nl_NL.IBM-037,
- # pl_pl, pl_PL, ro_ro, ro_RO, ru_ru, ru_RU,
- # sk_sk, sk_SK, sl_si, sl_SI, tr_tr, tr_TR.
- #
- # Similar things can happen even under (bastardised)
- # non-EBCDIC locales: in many European countries before the
- # advent of ISO 8859-x nationally customised versions of
- # ISO 646 were devised, reusing certain punctuation
- # characters for modified characters needed by the
- # country/language. For example, the "|" might have
- # stood for U+00F6 or LATIN SMALL LETTER O WITH DIAERESIS.
- #
- if ($x =~ $re || $y =~ $re) {
- print "# Regex characters in '$x' or '$y', skipping test 117 for locale '$Locale'\n";
- next;
- }
- # With utf8 both will fail since the locale concept
- # of upper/lower does not work well in Unicode.
- push @f, $x unless $x =~ /$y/i == $y =~ /$x/i;
+ ++$locales_test_number;
+ $test_names{$locales_test_number} = 'Verify case insensitive matching works';
+ foreach my $x (sort keys %UPPER) {
+ if (! $is_utf8_locale) {
+ my $y = lc $x;
+ next unless uc $y eq $x;
+ print "# UPPER $x lc $y ",
+ $x =~ /$y/i ? 1 : 0, " ",
+ $y =~ /$x/i ? 1 : 0, "\n" if 0;
+ #
+ # If $x and $y contain regular expression characters
+ # AND THEY lowercase (/i) to regular expression characters,
+ # regcomp() will be mightily confused. No, the \Q doesn't
+ # help here (maybe regex engine internal lowercasing
+ # is done after the \Q?) An example of this happening is
+ # the bg_BG (Bulgarian) locale under EBCDIC (OS/390 USS):
+ # the chr(173) (the "[") is the lowercase of the chr(235).
+ #
+ # Similarly losing EBCDIC locales include cs_cz, cs_CZ,
+ # el_gr, el_GR, en_us.IBM-037 (!), en_US.IBM-037 (!),
+ # et_ee, et_EE, hr_hr, hr_HR, hu_hu, hu_HU, lt_LT,
+ # mk_mk, mk_MK, nl_nl.IBM-037, nl_NL.IBM-037,
+ # pl_pl, pl_PL, ro_ro, ro_RO, ru_ru, ru_RU,
+ # sk_sk, sk_SK, sl_si, sl_SI, tr_tr, tr_TR.
+ #
+ # Similar things can happen even under (bastardised)
+ # non-EBCDIC locales: in many European countries before the
+ # advent of ISO 8859-x nationally customised versions of
+ # ISO 646 were devised, reusing certain punctuation
+ # characters for modified characters needed by the
+ # country/language. For example, the "|" might have
+ # stood for U+00F6 or LATIN SMALL LETTER O WITH DIAERESIS.
+ #
+ if ($x =~ $re || $y =~ $re) {
+ print "# Regex characters in '$x' or '$y', skipping test $locales_test_number for locale '$Locale'\n";
+ next;
+ }
+ # With utf8 both will fail since the locale concept
+ # of upper/lower does not work well in Unicode.
+ push @f, $x unless $x =~ /$y/i == $y =~ /$x/i;
+
+ # fc is not a locale concept, so Perl uses lc for it.
+ push @f, $x unless lc $x eq fc $x;
+ }
+ else {
+ use locale ':not_characters';
+ my $y = lc $x;
+ next unless uc $y eq $x;
+ print "# UPPER $x lc $y ",
+ $x =~ /$y/i ? 1 : 0, " ",
+ $y =~ /$x/i ? 1 : 0, "\n" if 0;
+
+ # Here, we can fully test things, unlike plain 'use locale',
+ # because this form does work well with Unicode
+ push @f, $x unless $x =~ /$y/i && $y =~ /$x/i;
+
+ # The places where Unicode's lc is different from fc are
+ # skipped here by virtue of the 'next unless uc...' line above
+ push @f, $x unless lc $x eq fc $x;
+ }
}
- foreach my $x (keys %lower) {
- my $y = uc $x;
- next unless lc $y eq $x;
- print "# lower $x uc $y ",
- $x =~ /$y/i ? 1 : 0, " ",
- $y =~ /$x/i ? 1 : 0, "\n" if 0;
- if ($x =~ $re || $y =~ $re) { # See above.
- print "# Regex characters in '$x' or '$y', skipping test 117 for locale '$Locale'\n";
- next;
- }
- # With utf8 both will fail since the locale concept
- # of upper/lower does not work well in Unicode.
- push @f, $x unless $x =~ /$y/i == $y =~ /$x/i;
+ foreach my $x (sort keys %lower) {
+ if (! $is_utf8_locale) {
+ my $y = uc $x;
+ next unless lc $y eq $x;
+ print "# lower $x uc $y ",
+ $x =~ /$y/i ? 1 : 0, " ",
+ $y =~ /$x/i ? 1 : 0, "\n" if 0;
+ if ($x =~ $re || $y =~ $re) { # See above.
+ print "# Regex characters in '$x' or '$y', skipping test $locales_test_number for locale '$Locale'\n";
+ next;
+ }
+ # With utf8 both will fail since the locale concept
+ # of upper/lower does not work well in Unicode.
+ push @f, $x unless $x =~ /$y/i == $y =~ /$x/i;
+
+ push @f, $x unless lc $x eq fc $x;
+ }
+ else {
+ use locale ':not_characters';
+ my $y = uc $x;
+ next unless lc $y eq $x;
+ print "# lower $x uc $y ",
+ $x =~ /$y/i ? 1 : 0, " ",
+ $y =~ /$x/i ? 1 : 0, "\n" if 0;
+ push @f, $x unless $x =~ /$y/i && $y =~ /$x/i;
+
+ push @f, $x unless lc $x eq fc $x;
+ }
}
- tryneoalpha($Locale, 117, @f == 0);
+ tryneoalpha($Locale, $locales_test_number, @f == 0);
if (@f) {
- print "# failed 117 locale '$Locale' characters @f\n"
+ print "# failed $locales_test_number locale '$Locale' characters @f\n"
}
}
+
+ # [perl #109318]
+ {
+ my @f = ();
+ ++$locales_test_number;
+ $test_names{$locales_test_number} = 'Verify atof with locale radix and negative exponent';
+
+ my $radix = POSIX::localeconv()->{decimal_point};
+ my @nums = (
+ "3.14e+9", "3${radix}14e+9", "3.14e-9", "3${radix}14e-9",
+ "-3.14e+9", "-3${radix}14e+9", "-3.14e-9", "-3${radix}14e-9",
+ );
+
+ if (! $is_utf8_locale) {
+ use locale;
+ for my $num (@nums) {
+ push @f, $num
+ unless sprintf("%g", $num) =~ /3.+14/;
+ }
+ }
+ else {
+ use locale ':not_characters';
+ for my $num (@nums) {
+ push @f, $num
+ unless sprintf("%g", $num) =~ /3.+14/;
+ }
+ }
+
+ tryneoalpha($Locale, $locales_test_number, @f == 0);
+ if (@f) {
+ print "# failed $locales_test_number locale '$Locale' numbers @f\n"
+ }
+ }
}
+my $final_locales_test_number = $locales_test_number;
+
# Recount the errors.
-foreach (&last_without_setlocale()+1..$last) {
- if ($Problem{$_} || !defined $Okay{$_} || !@{$Okay{$_}}) {
- if ($_ == 102) {
- print "# The failure of test 102 is not necessarily fatal.\n";
+foreach ($first_locales_test_number..$final_locales_test_number) {
+ if (%setlocale_failed) {
+ print "not ";
+ }
+ elsif ($Problem{$_} || !defined $Okay{$_} || !@{$Okay{$_}}) {
+ if (defined $not_necessarily_a_problem_test_number
+ && $_ == $not_necessarily_a_problem_test_number)
+ {
+ print "# The failure of test $not_necessarily_a_problem_test_number is not necessarily fatal.\n";
print "# It usually indicates a problem in the environment,\n";
print "# not in Perl itself.\n";
}
+ if ($Okay{$_} && ($_ >= $first_casing_test_number
+ && $_ <= $final_casing_test_number))
+ {
+ my $percent_fail = int(.5 + (100 * scalar(keys $Problem{$_})
+ / scalar(@{$Okay{$_}})));
+ if ($percent_fail < $acceptable_fold_failure_percentage) {
+ $test_names{$_} .= 'TODO';
+ print "# ", 100 - $percent_fail, "% of locales pass the following test, so it is likely that the failures\n";
+ print "# are errors in the locale definitions. The test is marked TODO, as the\n";
+ print "# problem is not likely to be Perl's\n";
+ }
+ }
print "not ";
}
- print "ok $_\n";
+ print "ok $_";
+ if (defined $test_names{$_}) {
+ # If TODO is in the test name, make it thus
+ my $todo = $test_names{$_} =~ s/TODO\s*//;
+ print " $test_names{$_}";
+ print " # TODO" if $todo;
+ }
+ print "\n";
}
# Give final advice.
@@ -843,7 +1408,7 @@
my $didwarn = 0;
-foreach (99..$last) {
+foreach ($first_locales_test_number..$final_locales_test_number) {
if ($Problem{$_}) {
my @f = sort keys %{ $Problem{$_} };
my $f = join(" ", @f);
@@ -872,16 +1437,23 @@
if ($didwarn) {
my (@s, @F);
-
+
foreach my $l (@Locale) {
my $p = 0;
- foreach my $t (102..$last) {
- $p++ if $Problem{$t}{$l};
+ if ($setlocale_failed{$l}) {
+ $p++;
+ }
+ else {
+ foreach my $t
+ ($first_locales_test_number..$final_locales_test_number)
+ {
+ $p++ if $Problem{$t}{$l};
+ }
}
push @s, $l if $p == 0;
- push @F, $l unless $p == 0;
+ push @F, $l unless $p == 0;
}
-
+
if (@s) {
my $s = join(" ", @s);
$s =~ s/(.{50,60}) /$1\n#\t/g;
@@ -905,19 +1477,127 @@
} else {
warn "# None of your locales were broken.\n";
}
+}
- if (@utf8locale) {
- my $S = join(" ", @utf8locale);
- $S =~ s/(.{50,60}) /$1\n#\t/g;
-
- warn "#\n# The following locales\n#\n",
- "#\t", $S, "\n#\n",
- "# were skipped for the tests ",
- join(" ", sort {$a<=>$b} keys %utf8skip), "\n",
- "# because UTF-8 and locales do not work together in Perl.\n#\n";
+$test_num = $final_locales_test_number;
+
+# Test that tainting and case changing works on utf8 strings. These tests are
+# placed last to avoid disturbing the hard-coded test numbers that existed at
+# the time these were added above this in this file.
+# This also tests that locale overrides unicode_strings in the same scope for
+# non-utf8 strings.
+setlocale(LC_ALL, "C");
+{
+ use locale;
+ use feature 'unicode_strings';
+
+ foreach my $function ("uc", "ucfirst", "lc", "lcfirst", "fc") {
+ my @list; # List of code points to test for $function
+
+ # Used to calculate the changed case for ASCII characters by using the
+ # ord, instead of using one of the functions under test.
+ my $ascii_case_change_delta;
+ my $above_latin1_case_change_delta; # Same for the specific ords > 255
+ # that we use
+
+ # We test an ASCII character, which should change case and be tainted;
+ # a Latin1 character, which shouldn't change case under this C locale,
+ # and is tainted.
+ # an above-Latin1 character that when the case is changed would cross
+ # the 255/256 boundary, so doesn't change case and isn't tainted
+ # (the \x{149} is one of these, but changes into 2 characters, the
+ # first one of which doesn't cross the boundary.
+ # the final one in each list is an above-Latin1 character whose case
+ # does change, and shouldn't be tainted. The code below uses its
+ # position in its list as a marker to indicate that it, unlike the
+ # other code points above ASCII, has a successful case change
+ if ($function =~ /^u/) {
+ @list = ("", "a", "\xe0", "\xff", "\x{fb00}", "\x{149}", "\x{101}");
+ $ascii_case_change_delta = -32;
+ $above_latin1_case_change_delta = -1;
+ }
+ else {
+ @list = ("", "A", "\xC0", "\x{1E9E}", "\x{100}");
+ $ascii_case_change_delta = +32;
+ $above_latin1_case_change_delta = +1;
+ }
+ foreach my $is_utf8_locale (0 .. 1) {
+ foreach my $j (0 .. $#list) {
+ my $char = $list[$j];
+
+ for my $encoded_in_utf8 (0 .. 1) {
+ my $should_be;
+ my $changed;
+ if (! $is_utf8_locale) {
+ $should_be = ($j == $#list)
+ ? chr(ord($char) + $above_latin1_case_change_delta)
+ : (length $char == 0 || ord($char) > 127)
+ ? $char
+ : chr(ord($char) + $ascii_case_change_delta);
+
+ # This monstrosity is in order to avoid using an eval,
+ # which might perturb the results
+ $changed = ($function eq "uc")
+ ? uc($char)
+ : ($function eq "ucfirst")
+ ? ucfirst($char)
+ : ($function eq "lc")
+ ? lc($char)
+ : ($function eq "lcfirst")
+ ? lcfirst($char)
+ : ($function eq "fc")
+ ? fc($char)
+ : die("Unexpected function \"$function\"");
+ }
+ else {
+ {
+ no locale;
+
+ # For utf8-locales the case changing functions
+ # should work just like they do outside of locale.
+ # Can use eval here because not testing it when
+ # not in locale.
+ $should_be = eval "$function('$char')";
+ die "Unexpected eval error $@ from 'eval \"$function('$char')\"'" if $@;
+
+ }
+ use locale ':not_characters';
+ $changed = ($function eq "uc")
+ ? uc($char)
+ : ($function eq "ucfirst")
+ ? ucfirst($char)
+ : ($function eq "lc")
+ ? lc($char)
+ : ($function eq "lcfirst")
+ ? lcfirst($char)
+ : ($function eq "fc")
+ ? fc($char)
+ : die("Unexpected function \"$function\"");
+ }
+ ok($changed eq $should_be,
+ "$function(\"$char\") in C locale "
+ . (($is_utf8_locale)
+ ? "(use locale ':not_characters'"
+ : "(use locale")
+ . (($encoded_in_utf8)
+ ? "; encoded in utf8)"
+ : "; not encoded in utf8)")
+ . " should be \"$should_be\", got \"$changed\"");
+
+ # Tainting shouldn't happen for utf8 locales, empty
+ # strings, or those characters above 255.
+ (! $is_utf8_locale && length($char) > 0 && ord($char) < 256)
+ ? check_taint($changed)
+ : check_taint_not($changed);
+
+ # Use UTF-8 next time through the loop
+ utf8::upgrade($char);
+ }
+ }
+ }
}
}
-sub last { 117 }
+print "1..$test_num\n";
# eof
Property changes on: trunk/contrib/perl/lib/locale.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/lib/look.pl
===================================================================
--- trunk/contrib/perl/lib/look.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/look.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/look.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/lib/mro.pm (from rev 6437, vendor/perl/5.18.1/lib/mro.pm)
===================================================================
--- trunk/contrib/perl/lib/mro.pm (rev 0)
+++ trunk/contrib/perl/lib/mro.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,378 @@
+# mro.pm
+#
+# Copyright (c) 2007 Brandon L Black
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the README file.
+#
+package mro;
+use strict;
+use warnings;
+
+# mro.pm versions < 1.00 reserved for MRO::Compat
+# for partial back-compat to 5.[68].x
+our $VERSION = '1.00';
+
+sub import {
+ mro::set_mro(scalar(caller), $_[1]) if $_[1];
+}
+
+package # hide me from PAUSE
+ next;
+
+sub can { mro::_nextcan($_[0], 0) }
+
+sub method {
+ my $method = mro::_nextcan($_[0], 1);
+ goto &$method;
+}
+
+package # hide me from PAUSE
+ maybe::next;
+
+sub method {
+ my $method = mro::_nextcan($_[0], 0);
+ goto &$method if defined $method;
+ return;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+mro - Method Resolution Order
+
+=head1 SYNOPSIS
+
+ use mro; # enables next::method and friends globally
+
+ use mro 'dfs'; # enable DFS MRO for this class (Perl default)
+ use mro 'c3'; # enable C3 MRO for this class
+
+=head1 DESCRIPTION
+
+The "mro" namespace provides several utilities for dealing
+with method resolution order and method caching in general.
+
+These interfaces are only available in Perl 5.9.5 and higher.
+See L<MRO::Compat> on CPAN for a mostly forwards compatible
+implementation for older Perls.
+
+=head1 OVERVIEW
+
+It's possible to change the MRO of a given class either by using C<use
+mro> as shown in the synopsis, or by using the L</mro::set_mro> function
+below. The functions in the mro namespace do not require loading the
+C<mro> module, as they are actually provided by the core perl interpreter.
+
+The special methods C<next::method>, C<next::can>, and
+C<maybe::next::method> are not available until this C<mro> module
+has been loaded via C<use> or C<require>.
+
+=head1 The C3 MRO
+
+In addition to the traditional Perl default MRO (depth first
+search, called C<DFS> here), Perl now offers the C3 MRO as
+well. Perl's support for C3 is based on the work done in
+Stevan Little's module L<Class::C3>, and most of the C3-related
+documentation here is ripped directly from there.
+
+=head2 What is C3?
+
+C3 is the name of an algorithm which aims to provide a sane method
+resolution order under multiple inheritance. It was first introduced in
+the language Dylan (see links in the L</"SEE ALSO"> section), and then
+later adopted as the preferred MRO (Method Resolution Order) for the
+new-style classes in Python 2.3. Most recently it has been adopted as the
+"canonical" MRO for Perl 6 classes, and the default MRO for Parrot objects
+as well.
+
+=head2 How does C3 work
+
+C3 works by always preserving local precendence ordering. This essentially
+means that no class will appear before any of its subclasses. Take, for
+instance, the classic diamond inheritance pattern:
+
+ <A>
+ / \
+ <B> <C>
+ \ /
+ <D>
+
+The standard Perl 5 MRO would be (D, B, A, C). The result being that B<A>
+appears before B<C>, even though B<C> is the subclass of B<A>. The C3 MRO
+algorithm however, produces the following order: (D, B, C, A), which does
+not have this issue.
+
+This example is fairly trivial; for more complex cases and a deeper
+explanation, see the links in the L</"SEE ALSO"> section.
+
+=head1 Functions
+
+=head2 mro::get_linear_isa($classname[, $type])
+
+Returns an arrayref which is the linearized MRO of the given class.
+Uses whichever MRO is currently in effect for that class by default,
+or the given MRO (either C<c3> or C<dfs> if specified as C<$type>).
+
+The linearized MRO of a class is an ordered array of all of the
+classes one would search when resolving a method on that class,
+starting with the class itself.
+
+If the requested class doesn't yet exist, this function will still
+succeed, and return C<[ $classname ]>
+
+Note that C<UNIVERSAL> (and any members of C<UNIVERSAL>'s MRO) are not
+part of the MRO of a class, even though all classes implicitly inherit
+methods from C<UNIVERSAL> and its parents.
+
+=head2 mro::set_mro($classname, $type)
+
+Sets the MRO of the given class to the C<$type> argument (either
+C<c3> or C<dfs>).
+
+=head2 mro::get_mro($classname)
+
+Returns the MRO of the given class (either C<c3> or C<dfs>).
+
+=head2 mro::get_isarev($classname)
+
+Gets the C<mro_isarev> for this class, returned as an
+arrayref of class names. These are every class that "isa"
+the given class name, even if the isa relationship is
+indirect. This is used internally by the MRO code to
+keep track of method/MRO cache invalidations.
+
+Currently, this list only grows, it never shrinks. This
+was a performance consideration (properly tracking and
+deleting isarev entries when someone removes an entry
+from an C<@ISA> is costly, and it doesn't happen often
+anyways). The fact that a class which no longer truly
+"isa" this class at runtime remains on the list should be
+considered a quirky implementation detail which is subject
+to future change. It shouldn't be an issue as long as
+you're looking at this list for the same reasons the
+core code does: as a performance optimization
+over having to search every class in existence.
+
+As with C<mro::get_mro> above, C<UNIVERSAL> is special.
+C<UNIVERSAL> (and parents') isarev lists do not include
+every class in existence, even though all classes are
+effectively descendants for method inheritance purposes.
+
+=head2 mro::is_universal($classname)
+
+Returns a boolean status indicating whether or not
+the given classname is either C<UNIVERSAL> itself,
+or one of C<UNIVERSAL>'s parents by C<@ISA> inheritance.
+
+Any class for which this function returns true is
+"universal" in the sense that all classes potentially
+inherit methods from it.
+
+For similar reasons to C<isarev> above, this flag is
+permanent. Once it is set, it does not go away, even
+if the class in question really isn't universal anymore.
+
+=head2 mro::invalidate_all_method_caches()
+
+Increments C<PL_sub_generation>, which invalidates method
+caching in all packages.
+
+=head2 mro::method_changed_in($classname)
+
+Invalidates the method cache of any classes dependent on the
+given class. This is not normally necessary. The only
+known case where pure perl code can confuse the method
+cache is when you manually install a new constant
+subroutine by using a readonly scalar value, like the
+internals of L<constant> do. If you find another case,
+please report it so we can either fix it or document
+the exception here.
+
+=head2 mro::get_pkg_gen($classname)
+
+Returns an integer which is incremented every time a
+real local method in the package C<$classname> changes,
+or the local C<@ISA> of C<$classname> is modified.
+
+This is intended for authors of modules which do lots
+of class introspection, as it allows them to very quickly
+check if anything important about the local properties
+of a given class have changed since the last time they
+looked. It does not increment on method/C<@ISA>
+changes in superclasses.
+
+It's still up to you to seek out the actual changes,
+and there might not actually be any. Perhaps all
+of the changes since you last checked cancelled each
+other out and left the package in the state it was in
+before.
+
+This integer normally starts off at a value of C<1>
+when a package stash is instantiated. Calling it
+on packages whose stashes do not exist at all will
+return C<0>. If a package stash is completely
+deleted (not a normal occurence, but it can happen
+if someone does something like C<undef %PkgName::>),
+the number will be reset to either C<0> or C<1>,
+depending on how completely package was wiped out.
+
+=head2 next::method
+
+This is somewhat like C<SUPER>, but it uses the C3 method
+resolution order to get better consistency in multiple
+inheritance situations. Note that while inheritance in
+general follows whichever MRO is in effect for the
+given class, C<next::method> only uses the C3 MRO.
+
+One generally uses it like so:
+
+ sub some_method {
+ my $self = shift;
+ my $superclass_answer = $self->next::method(@_);
+ return $superclass_answer + 1;
+ }
+
+Note that you don't (re-)specify the method name.
+It forces you to always use the same method name
+as the method you started in.
+
+It can be called on an object or a class, of course.
+
+The way it resolves which actual method to call is:
+
+=over 4
+
+=item 1
+
+First, it determines the linearized C3 MRO of
+the object or class it is being called on.
+
+=item 2
+
+Then, it determines the class and method name
+of the context it was invoked from.
+
+=item 3
+
+Finally, it searches down the C3 MRO list until
+it reaches the contextually enclosing class, then
+searches further down the MRO list for the next
+method with the same name as the contextually
+enclosing method.
+
+=back
+
+Failure to find a next method will result in an
+exception being thrown (see below for alternatives).
+
+This is substantially different than the behavior
+of C<SUPER> under complex multiple inheritance.
+(This becomes obvious when one realizes that the
+common superclasses in the C3 linearizations of
+a given class and one of its parents will not
+always be ordered the same for both.)
+
+B<Caveat>: Calling C<next::method> from methods defined outside the class:
+
+There is an edge case when using C<next::method> from within a subroutine
+which was created in a different module than the one it is called from. It
+sounds complicated, but it really isn't. Here is an example which will not
+work correctly:
+
+ *Foo::foo = sub { (shift)->next::method(@_) };
+
+The problem exists because the anonymous subroutine being assigned to the
+C<*Foo::foo> glob will show up in the call stack as being called
+C<__ANON__> and not C<foo> as you might expect. Since C<next::method> uses
+C<caller> to find the name of the method it was called in, it will fail in
+this case.
+
+But fear not, there's a simple solution. The module C<Sub::Name> will
+reach into the perl internals and assign a name to an anonymous subroutine
+for you. Simply do this:
+
+ use Sub::Name 'subname';
+ *Foo::foo = subname 'Foo::foo' => sub { (shift)->next::method(@_) };
+
+and things will Just Work.
+
+=head2 next::can
+
+This is similar to C<next::method>, but just returns either a code
+reference or C<undef> to indicate that no further methods of this name
+exist.
+
+=head2 maybe::next::method
+
+In simple cases, it is equivalent to:
+
+ $self->next::method(@_) if $self->next_can;
+
+But there are some cases where only this solution
+works (like C<goto &maybe::next::method>);
+
+=head1 SEE ALSO
+
+=head2 The original Dylan paper
+
+=over 4
+
+=item L<http://www.webcom.com/haahr/dylan/linearization-oopsla96.html>
+
+=back
+
+=head2 The prototype Perl 6 Object Model uses C3
+
+=over 4
+
+=item L<http://svn.openfoundry.org/pugs/perl5/Perl6-MetaModel/>
+
+=back
+
+=head2 Parrot now uses C3
+
+=over 4
+
+=item L<http://aspn.activestate.com/ASPN/Mail/Message/perl6-internals/2746631>
+
+=item L<http://use.perl.org/~autrijus/journal/25768>
+
+=back
+
+=head2 Python 2.3 MRO related links
+
+=over 4
+
+=item L<http://www.python.org/2.3/mro.html>
+
+=item L<http://www.python.org/2.2.2/descrintro.html#mro>
+
+=back
+
+=head2 C3 for TinyCLOS
+
+=over 4
+
+=item L<http://www.call-with-current-continuation.org/eggs/c3.html>
+
+=back
+
+=head2 Class::C3
+
+=over 4
+
+=item L<Class::C3>
+
+=back
+
+=head1 AUTHOR
+
+Brandon L. Black, E<lt>blblack at gmail.comE<gt>
+
+Based on Stevan Little's L<Class::C3>
+
+=cut
Index: trunk/contrib/perl/lib/newgetopt.pl
===================================================================
--- trunk/contrib/perl/lib/newgetopt.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/newgetopt.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/newgetopt.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/open.pm
===================================================================
--- trunk/contrib/perl/lib/open.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/open.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,7 +1,7 @@
package open;
use warnings;
-our $VERSION = '1.08';
+our $VERSION = '1.10';
require 5.008001; # for PerlIO::get_layers()
@@ -95,16 +95,22 @@
}
}
if ($type eq 'IN') {
- _drop_oldenc(*STDIN, @val);
+ _drop_oldenc(*STDIN, @val) if $std;
$in = join(' ', @val);
}
elsif ($type eq 'OUT') {
- _drop_oldenc(*STDOUT, @val);
+ if ($std) {
+ _drop_oldenc(*STDOUT, @val);
+ _drop_oldenc(*STDERR, @val);
+ }
$out = join(' ', @val);
}
elsif ($type eq 'IO') {
- _drop_oldenc(*STDIN, @val);
- _drop_oldenc(*STDOUT, @val);
+ if ($std) {
+ _drop_oldenc(*STDIN, @val);
+ _drop_oldenc(*STDOUT, @val);
+ _drop_oldenc(*STDERR, @val);
+ }
$in = $out = join(' ', @val);
}
else {
@@ -207,7 +213,9 @@
details and the list of supported locales.
When open() is given an explicit list of layers (with the three-arg
-syntax), they override the list declared using this pragma.
+syntax), they override the list declared using this pragma. open() can
+also be given a single colon (:) for a layer name, to override this pragma
+and use the default (C<:raw> on Unix, C<:crlf> on Windows).
The C<:std> subpragma on its own has no effect, but if combined with
the C<:utf8> or C<:encoding> subpragmas, it converts the standard
Property changes on: trunk/contrib/perl/lib/open.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/open.t
===================================================================
--- trunk/contrib/perl/lib/open.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/open.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -4,9 +4,10 @@
chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
+ require './test.pl';
}
-use Test::More tests => 23;
+plan 23;
# open::import expects 'open' as its first argument, but it clashes with open()
sub import {
@@ -185,13 +186,26 @@
eval q[use Encode::Alias;use open ":std", ":locale"];
is($@, '', 'can use :std and :locale');
+}
- use open IN => ':non-existent';
- eval {
- require Symbol; # Anything that exists but we havn't loaded
- };
- like($@, qr/Can't locate Symbol|Recursive call/i,
- "test for an endless loop in PerlIO_find_layer");
+{
+ local $ENV{PERL_UNICODE};
+ delete $ENV{PERL_UNICODE};
+ is runperl(
+ progs => [
+ 'use open q\:encoding(UTF-8)\, q-:std-;',
+ 'use open q\:encoding(UTF-8)\;',
+ 'if(($_ = <STDIN>) eq qq-\x{100}\n-) { print qq-stdin ok\n- }',
+ 'else { print qq-got -, join(q q q, map ord, split//), "\n" }',
+ 'print STDOUT qq-\x{ff}\n-;',
+ 'print STDERR qq-\x{ff}\n-;',
+ ],
+ stdin => "\xc4\x80\n",
+ stderr => 1,
+ ),
+ "stdin ok\n\xc3\xbf\n\xc3\xbf\n",
+ "use open without :std does not affect standard handles",
+ ;
}
END {
Property changes on: trunk/contrib/perl/lib/open.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/lib/open2.pl
===================================================================
--- trunk/contrib/perl/lib/open2.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/open2.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/open2.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/open3.pl
===================================================================
--- trunk/contrib/perl/lib/open3.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/open3.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/open3.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/lib/overload/numbers.pm
===================================================================
--- trunk/contrib/perl/lib/overload/numbers.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/overload/numbers.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -82,7 +82,6 @@
(~~
(-X
(qr
- DESTROY
#;
our @enums = qw#
@@ -154,7 +153,6 @@
smart
ftest
regexp
- DESTROY
#;
{ my $i = 0; our %names = map { $_ => $i++ } @names }
Property changes on: trunk/contrib/perl/lib/overload/numbers.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/lib/overload.pm
===================================================================
--- trunk/contrib/perl/lib/overload.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/overload.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,7 +1,30 @@
package overload;
-our $VERSION = '1.13';
+our $VERSION = '1.22';
+%ops = (
+ with_assign => "+ - * / % ** << >> x .",
+ assign => "+= -= *= /= %= **= <<= >>= x= .=",
+ num_comparison => "< <= > >= == !=",
+ '3way_comparison' => "<=> cmp",
+ str_comparison => "lt le gt ge eq ne",
+ binary => '& &= | |= ^ ^=',
+ unary => "neg ! ~",
+ mutators => '++ --',
+ func => "atan2 cos sin exp abs log sqrt int",
+ conversion => 'bool "" 0+ qr',
+ iterators => '<>',
+ filetest => "-X",
+ dereferencing => '${} @{} %{} &{} *{}',
+ matching => '~~',
+ special => 'nomethod fallback =',
+);
+
+my %ops_seen;
+for $category (keys %ops) {
+ $ops_seen{$_}++ for (split /\s+/, $ops{$category});
+}
+
sub nil {}
sub OVERLOAD {
@@ -8,23 +31,25 @@
$package = shift;
my %arg = @_;
my ($sub, $fb);
- $ {$package . "::OVERLOAD"}{dummy}++; # Register with magic by touching.
- $fb = ${$package . "::()"}; # preserve old fallback value RT#68196
- *{$package . "::()"} = \&nil; # Make it findable via fetchmethod.
+ *{$package . "::(("} = \&nil; # Make it findable via fetchmethod.
for (keys %arg) {
if ($_ eq 'fallback') {
- $fb = $arg{$_};
+ for my $sym (*{$package . "::()"}) {
+ *$sym = \&nil; # Make it findable via fetchmethod.
+ $$sym = $arg{$_};
+ }
} else {
+ warnings::warnif("overload arg '$_' is invalid")
+ unless $ops_seen{$_};
$sub = $arg{$_};
- if (not ref $sub and $sub !~ /::/) {
+ if (not ref $sub) {
$ {$package . "::(" . $_} = $sub;
$sub = \&nil;
}
- #print STDERR "Setting `$ {'package'}::\cO$_' to \\&`$sub'.\n";
+ #print STDERR "Setting '$ {'package'}::\cO$_' to \\&'$sub'.\n";
*{$package . "::(" . $_} = \&{ $sub };
}
}
- ${$package . "::()"} = $fb; # Make it findable too (fallback only).
}
sub import {
@@ -36,14 +61,12 @@
sub unimport {
$package = (caller())[0];
- ${$package . "::OVERLOAD"}{dummy}++; # Upgrade the table
shift;
+ *{$package . "::(("} = \&nil;
for (@_) {
- if ($_ eq 'fallback') {
- undef $ {$package . "::()"};
- } else {
- delete $ {$package . "::"}{"(" . $_};
- }
+ warnings::warnif("overload arg '$_' is invalid")
+ unless $ops_seen{$_};
+ delete $ {$package . "::"}{$_ eq 'fallback' ? '()' : "(" .$_};
}
}
@@ -50,7 +73,7 @@
sub Overloaded {
my $package = shift;
$package = ref $package if ref $package;
- $package->can('()');
+ mycan ($package, '()') || mycan ($package, '((');
}
sub ov_method {
@@ -57,9 +80,8 @@
my $globref = shift;
return undef unless $globref;
my $sub = \&{*$globref};
- require Scalar::Util;
- return $sub
- if Scalar::Util::refaddr($sub) != Scalar::Util::refaddr(\&nil);
+ no overloading;
+ return $sub if !ref $sub or $sub != \&nil;
return shift->can($ {*$globref});
}
@@ -89,17 +111,8 @@
}
sub AddrRef {
- my $package = ref $_[0];
- return "$_[0]" unless $package;
-
- local $@;
- local $!;
- require Scalar::Util;
- my $class = Scalar::Util::blessed($_[0]);
- my $class_prefix = defined($class) ? "$class=" : "";
- my $type = Scalar::Util::reftype($_[0]);
- my $addr = Scalar::Util::refaddr($_[0]);
- return sprintf("%s%s(0x%x)", $class_prefix, $type, $addr);
+ no overloading;
+ "$_[0]";
}
*StrVal = *AddrRef;
@@ -128,22 +141,6 @@
'qr' => 0x10000, # HINT_NEW_RE
);
-%ops = ( with_assign => "+ - * / % ** << >> x .",
- assign => "+= -= *= /= %= **= <<= >>= x= .=",
- num_comparison => "< <= > >= == !=",
- '3way_comparison'=> "<=> cmp",
- str_comparison => "lt le gt ge eq ne",
- binary => '& &= | |= ^ ^=',
- unary => "neg ! ~",
- mutators => '++ --',
- func => "atan2 cos sin exp abs log sqrt int",
- conversion => 'bool "" 0+ qr',
- iterators => '<>',
- filetest => "-X",
- dereferencing => '${} @{} %{} &{} *{}',
- matching => '~~',
- special => 'nomethod fallback =');
-
use warnings::register;
sub constant {
# Arguments: what, sub
@@ -153,7 +150,7 @@
last;
}
elsif (!exists $constants {$_ [0]}) {
- warnings::warnif ("`$_[0]' is not an overloadable type");
+ warnings::warnif ("'$_[0]' is not an overloadable type");
}
elsif (!ref $_ [1] || "$_[1]" !~ /(^|=)CODE\(0x[0-9a-f]+\)$/) {
# Can't use C<ref $_[1] eq "CODE"> above as code references can be
@@ -160,7 +157,7 @@
# blessed, and C<ref> would return the package the ref is blessed into.
if (warnings::enabled) {
$_ [1] = "undef" unless defined $_ [1];
- warnings::warn ("`$_[1]' is not a code reference");
+ warnings::warn ("'$_[1]' is not a code reference");
}
}
else {
@@ -264,7 +261,7 @@
case of a unary operator.
The third argument is set to TRUE if (and only if) the two
-operands have been swapped. Perl may do this to ensure that the
+operands have been swapped. Perl may do this to ensure that the
first argument (C<$self>) is an object implementing the overloaded
operation, in line with general object calling conventions.
For example, if C<$x> and C<$y> are C<Number>s:
@@ -280,7 +277,7 @@
according to the rules for L<Magic Autogeneration> described later.
For example, the C<use overload> above declared no subroutine
for any of the operators C<-->, C<neg> (the overload key for
-unary minus), or C<-=>. Thus
+unary minus), or C<-=>. Thus
operation | generates a call to
============|======================
@@ -379,6 +376,9 @@
Exceptions, including additional overloadable operations not
apparent from this hash, are included in the notes which follow.
+A warning is issued if an attempt is made to register an operator not found
+above.
+
=over 5
=item * C<not>
@@ -476,7 +476,7 @@
the operation will be called again with this value.
As a special case if the overload returns the object itself then it will
-be used directly. An overloaded conversion returning the object is
+be used directly. An overloaded conversion returning the object is
probably a bug, because you're likely to get something that looks like
C<YourPackage=HASH(0x8172b34)>.
@@ -496,9 +496,6 @@
for both the I<read-filehandle> syntax C<E<lt>$varE<gt>> and
I<globbing> syntax C<E<lt>${var}E<gt>>.
-B<BUGS> Even in list context, the iterator is currently called only
-once and with scalar context.
-
=item * I<File tests>
The key C<'-X'> is used to specify a subroutine to handle all the
@@ -510,7 +507,7 @@
is used to pass the second operand).
Calling an overloaded filetest operator does not affect the stat value
-associated with the special filehandle C<_>. It still refers to the
+associated with the special filehandle C<_>. It still refers to the
result of the last C<stat>, C<lstat> or unoverloaded filetest.
This overload was introduced in Perl 5.12.
@@ -519,7 +516,7 @@
The key C<"~~"> allows you to override the smart matching logic used by
the C<~~> operator and the switch construct (C<given>/C<when>). See
-L<perlsyn/switch> and L<feature>.
+L<perlsyn/Switch Statements> and L<feature>.
Unusually, the overloaded implementation of the smart match operator
does not get full control of the smart match behaviour.
@@ -543,7 +540,7 @@
$obj->match(2,0);
$obj->match(3,0);
-Consult the match table in L<perlsyn/"Smart matching in detail"> for
+Consult the match table in L<perlop/"Smartmatch Operator"> for
details of when overloading is invoked.
=item * I<Dereferencing>
@@ -667,7 +664,7 @@
a minimal set of operations that need to be overloaded in order to have
the complete set of overloaded operations at one's disposal.
Of course, the autogenerated operations may not do exactly what the user
-expects. The minimal set is:
+expects. The minimal set is:
+ - * / % ** << >> x
<=> cmp
@@ -767,7 +764,7 @@
The subroutine for C<'='> does not overload the Perl assignment
operator: it is used only to allow mutators to work as described
-here. (See L</Assignments> above.)
+here. (See L</Assignments> above.)
=item *
@@ -877,7 +874,8 @@
There are exceptions to the above rules for dereference operations
(which, if Step 1 fails, always fall back to the normal, built-in
implementations - see Dereferencing), and for C<~~> (which has its
-own set of rules - see L<Matching>).
+own set of rules - see C<Matching> under L</Overloadable Operations>
+above).
Note on Step 7: some operators have a different semantic depending
on the type of their operands.
@@ -889,9 +887,9 @@
=head2 Losing Overloading
The restriction for the comparison operation is that even if, for example,
-`C<cmp>' should return a blessed reference, the autogenerated `C<lt>'
+C<cmp> should return a blessed reference, the autogenerated C<lt>
function will produce only a standard logical value based on the
-numerical value of the result of `C<cmp>'. In particular, a working
+numerical value of the result of C<cmp>. In particular, a working
numeric conversion is needed in this case (possibly expressed in terms of
other conversions).
@@ -933,10 +931,10 @@
=back
-Note that since the value of the C<fallback> key is not a subroutine,
-its inheritance is not governed by the above rules. In the current
-implementation, the value of C<fallback> in the first overloaded
-ancestor is used, but this is accidental and subject to change.
+Note that in Perl version prior to 5.18 inheritance of the C<fallback> key
+was not governed by the above rules. The value of C<fallback> in the first
+overloaded ancestor was used. This was fixed in 5.18 to follow the usual
+rules of inheritance.
=head2 Run-time Overloading
@@ -959,7 +957,8 @@
=item overload::StrVal(arg)
-Gives string value of C<arg> as in absence of stringify overloading. If you
+Gives the string value of C<arg> as in the
+absence of stringify overloading. If you
are using this to get the address of a reference (useful for checking if two
references point to the same thing) then you may be better off using
C<Scalar::Util::refaddr()>, which is faster.
@@ -1030,12 +1029,12 @@
and overload::remove_constant() from anywhere but import() and unimport() methods.
From these methods they may be called as
- sub import {
- shift;
- return unless @_;
- die "unknown import: @_" unless @_ == 1 and $_[0] eq ':constant';
- overload::constant integer => sub {Math::BigInt->new(shift)};
- }
+ sub import {
+ shift;
+ return unless @_;
+ die "unknown import: @_" unless @_ == 1 and $_[0] eq ':constant';
+ overload::constant integer => sub {Math::BigInt->new(shift)};
+ }
=head1 IMPLEMENTATION
@@ -1044,38 +1043,23 @@
The table of methods for all operations is cached in magic for the
symbol table hash for the package. The cache is invalidated during
processing of C<use overload>, C<no overload>, new function
-definitions, and changes in @ISA. However, this invalidation remains
-unprocessed until the next C<bless>ing into the package. Hence if you
-want to change overloading structure dynamically, you'll need an
-additional (fake) C<bless>ing to update the table.
+definitions, and changes in @ISA.
(Every SVish thing has a magic queue, and magic is an entry in that
queue. This is how a single variable may participate in multiple
forms of magic simultaneously. For instance, environment variables
regularly have two forms at once: their %ENV magic and their taint
-magic. However, the magic which implements overloading is applied to
+magic. However, the magic which implements overloading is applied to
the stashes, which are rarely used directly, thus should not slow down
Perl.)
-If an object belongs to a package using overload, it carries a special
-flag. Thus the only speed penalty during arithmetic operations without
-overloading is the checking of this flag.
+If a package uses overload, it carries a special flag. This flag is also
+set when new function are defined or @ISA is modified. There will be a
+slight speed penalty on the very first operation thereafter that supports
+overloading, while the overload tables are updated. If there is no
+overloading present, the flag is turned off. Thus the only speed penalty
+thereafter is the checking of this flag.
-In fact, if C<use overload> is not present, there is almost no overhead
-for overloadable operations, so most programs should not suffer
-measurable performance penalties. A considerable effort was made to
-minimize the overhead when overload is used in some package, but the
-arguments in question do not belong to packages using overload. When
-in doubt, test your speed with C<use overload> and without it. So far
-there have been no reports of substantial speed degradation if Perl is
-compiled with optimization turned on.
-
-There is no size penalty for data if overload is not used. The only
-size penalty if overload is used in some package is that I<all> the
-packages acquire a magic during the next C<bless>ing into the
-package. This magic is three-words-long for packages without
-overloading, and carries the cache table if the package is overloaded.
-
It is expected that arguments to methods that are not explicitly supposed
to be changed are constant (but this is not enforced).
@@ -1099,13 +1083,13 @@
require two_face;
my $seven = two_face->new("vii", 7);
printf "seven=$seven, seven=%d, eight=%d\n", $seven, $seven+1;
- print "seven contains `i'\n" if $seven =~ /i/;
+ print "seven contains 'i'\n" if $seven =~ /i/;
(The second line creates a scalar which has both a string value, and a
numeric value.) This prints:
seven=vii, seven=7, eight=8
- seven contains `i'
+ seven contains 'i'
=head2 Two-face References
@@ -1247,7 +1231,7 @@
This module is very unusual as overloaded modules go: it does not
provide any usual overloaded operators, instead it provides an
-implementation for L<C<nomethod>>. In this example the C<nomethod>
+implementation for L</C<nomethod>>. In this example the C<nomethod>
subroutine returns an object which encapsulates operations done over
the objects: C<< symbolic->new(3) >> contains C<['n', 3]>, C<< 2 +
symbolic->new(3) >> contains C<['+', 2, ['n', 3]]>.
@@ -1386,7 +1370,7 @@
my $cnt = $iter;
while ($cnt) {
- $cnt = $cnt - 1; # Mutator `--' not implemented
+ $cnt = $cnt - 1; # Mutator '--' not implemented
$side = (sqrt(1 + $side**2) - 1)/$side;
}
printf "%s=%f\n", $side, $side;
@@ -1416,7 +1400,7 @@
$subr{$op} = eval "sub {shift() $op shift()}";
}
foreach my $op (split " ", "@overload::ops{qw(unary func)}") {
- print "defining `$op'\n";
+ print "defining '$op'\n";
$subr{$op} = eval "sub {$op shift()}";
}
@@ -1567,8 +1551,8 @@
Using the C<m> command of Perl debugger (see L<perldebug>) one can
deduce which operations are overloaded (and which ancestor triggers
-this overloading). Say, if C<eq> is overloaded, then the method C<(eq>
-is shown by debugger. The method C<()> corresponds to the C<fallback>
+this overloading). Say, if C<eq> is overloaded, then the method C<(eq>
+is shown by debugger. The method C<()> corresponds to the C<fallback>
key (in fact a presence of this method shows that this package has
overloading enabled, and it is what is used by the C<Overloaded>
function of module C<overload>).
@@ -1582,16 +1566,21 @@
(W) The call to overload::constant contained an odd number of arguments.
The arguments should come in pairs.
-=item `%s' is not an overloadable type
+=item '%s' is not an overloadable type
(W) You tried to overload a constant type the overload package is unaware of.
-=item `%s' is not a code reference
+=item '%s' is not a code reference
(W) The second (fourth, sixth, ...) argument of overload::constant needs
-to be a code reference. Either an anonymous subroutine, or a reference
+to be a code reference. Either an anonymous subroutine, or a reference
to a subroutine.
+=item overload arg '%s' is invalid
+
+(W) C<use overload> was passed an argument it did not
+recognize. Did you mistype an operator?
+
=back
=head1 BUGS AND PITFALLS
@@ -1600,16 +1589,6 @@
=item *
-No warning is issued for invalid C<use overload> keys.
-Such errors are not always obvious:
-
- use overload "+0" => sub { ...; }, # should be "0+"
- "not" => sub { ...; }; # should be "!"
-
-(Bug #74098)
-
-=item *
-
A pitfall when fallback is TRUE and Perl resorts to a built-in
implementation of an operator is that some operators have more
than one semantic, for example C<|>:
@@ -1666,14 +1645,15 @@
=item *
-Because it is used for overloading, the per-package hash
-C<%OVERLOAD> now has a special meaning in Perl.
The symbol table is filled with names looking like line-noise.
=item *
+This bug was fixed in Perl 5.18, but may still trip you up if you are using
+older versions:
+
For the purpose of inheritance every overloaded package behaves as if
-C<fallback> is present (possibly undefined). This may create
+C<fallback> is present (possibly undefined). This may create
interesting effects if some package is not overloaded, but inherits
from two overloaded packages.
@@ -1680,7 +1660,7 @@
=item *
Before Perl 5.14, the relation between overloading and tie()ing was broken.
-Overloading is triggered or not basing on the I<previous> class of the
+Overloading was triggered or not based on the I<previous> class of the
tie()d variable.
This happened because the presence of overloading was checked
@@ -1695,6 +1675,10 @@
Barewords are not covered by overloaded string constants.
+=item *
+
+The range operator C<..> cannot be overloaded.
+
=back
=cut
Property changes on: trunk/contrib/perl/lib/overload.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/overload.t
===================================================================
--- trunk/contrib/perl/lib/overload.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/overload.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -48,7 +48,7 @@
$| = 1;
BEGIN { require './test.pl' }
-plan tests => 4980;
+plan tests => 5191;
use Scalar::Util qw(tainted);
@@ -131,7 +131,7 @@
is(ref $b, "Oscalar");
is($a, "087");
-is($b, "88");
+is($b, "89");
is(ref $a, "Oscalar");
package Oscalar;
@@ -142,7 +142,7 @@
is(ref $b, "Oscalar");
is($a, "087");
-is($b, "90");
+is($b, "91");
is(ref $a, "Oscalar");
$b=$a;
@@ -267,11 +267,12 @@
is($aI, "xx");
is("b${aI}c", "_._.b.__.xx._.__.c._");
-# Here we test blessing to a package updates hash
+# Here we test that both "no overload" and
+# blessing to a package update hash
eval "package Oscalar; no overload '.'";
-is("b${a}", "_.b.__.xx._");
+is("b${a}", "bxx");
$x="1";
bless \$x, Oscalar;
is("b${a}c", "bxxc");
@@ -291,20 +292,20 @@
eval "package Oscalar; sub comple; use overload '~' => 'comple'";
-$na = eval { ~$a }; # Hash was not updated
-like($@, qr/no method found/);
+$na = eval { ~$a };
+is($@, '');
bless \$x, Oscalar;
$na = eval { ~$a }; # Hash updated
-warn "`$na', $@" if $@;
+warn "'$na', $@" if $@;
ok !$@;
is($na, '_!_xx_!_');
$na = 0;
-$na = eval { ~$aI }; # Hash was not updated
-like($@, qr/no method found/);
+$na = eval { ~$aI };
+like($@, '');
bless \$x, OscalarI;
@@ -316,8 +317,8 @@
eval "package Oscalar; sub rshft; use overload '>>' => 'rshft'";
-$na = eval { $aI >> 1 }; # Hash was not updated
-like($@, qr/no method found/);
+$na = eval { $aI >> 1 };
+is($@, '');
bless \$x, OscalarI;
@@ -603,8 +604,7 @@
}
sub TIESCALAR { my $pack = shift; $pack->new(@_) }
sub FETCH { shift }
- sub nop { } # Around a bug
- sub vars { my $p = shift; tie($_, $p), $_->nop foreach @_; }
+ sub vars { my $p = shift; tie($_, $p) foreach @_; }
sub STORE {
my $obj = shift;
$#$obj = 1;
@@ -936,7 +936,7 @@
}
{
- # check the `$_[0]' is not an overloadable type warning
+ # check the '$_[0]' is not an overloadable type warning
my $a = "" ;
local $SIG{__WARN__} = sub {$a = $_[0]} ;
$x = eval ' overload::constant "fred" => sub {} ; ' ;
@@ -943,11 +943,11 @@
is($a, "");
use warnings 'overload' ;
$x = eval ' overload::constant "fred" => sub {} ; ' ;
- like($a, qr/^`fred' is not an overloadable type at/);
+ like($a, qr/^'fred' is not an overloadable type at/);
}
{
- # check the `$_[1]' is not a code reference warning
+ # check the '$_[1]' is not a code reference warning
my $a = "" ;
local $SIG{__WARN__} = sub {$a = $_[0]} ;
$x = eval ' overload::constant "integer" => 1; ' ;
@@ -954,10 +954,27 @@
is($a, "");
use warnings 'overload' ;
$x = eval ' overload::constant "integer" => 1; ' ;
- like($a, qr/^`1' is not a code reference at/);
+ like($a, qr/^'1' is not a code reference at/);
}
{
+ # check the invalid argument warning [perl #74098]
+ my $a = "" ;
+ local $SIG{__WARN__} = sub {$a = $_[0]} ;
+ $x = eval ' use overload "~|_|~" => sub{} ' ;
+ eval ' no overload "~|_|~" ' ;
+ is($a, "");
+ use warnings 'overload' ;
+ $x = eval ' use overload "~|_|~" => sub{} ' ;
+ like($a, qr/^overload arg '~\|_\|~' is invalid at \(eval \d+\) line /,
+ 'invalid arg warning');
+ undef $a;
+ eval ' no overload "~|_|~" ' ;
+ like($a, qr/^overload arg '~\|_\|~' is invalid at \(eval \d+\) line /,
+ 'invalid arg warning');
+}
+
+{
my $c = 0;
package ov_int1;
use overload '""' => sub { 3+shift->[0] },
@@ -1102,18 +1119,6 @@
}
{
- package Numify;
- use overload (qw(0+ numify fallback 1));
-
- sub new {
- my $val = $_[1];
- bless \$val, $_[0];
- }
-
- sub numify { ${$_[0]} }
-}
-
-{
package perl31793;
use overload cmp => sub { 0 };
package perl31793_fb;
@@ -1134,8 +1139,20 @@
like(overload::StrVal($no), qr/^no_overload=ARRAY\(0x[0-9a-f]+\)$/);
}
-# These are all check that overloaded values rather than reference addresses
-# are what is getting tested.
+{
+ package Numify;
+ use overload (qw(0+ numify fallback 1));
+
+ sub new {
+ my $val = $_[1];
+ bless \$val, $_[0];
+ }
+
+ sub numify { ${$_[0]} }
+}
+
+# These all check that overloaded values, rather than reference addresses,
+# are what are getting tested.
my ($two, $one, $un, $deux) = map {new Numify $_} 2, 1, 1, 2;
my ($ein, $zwei) = (1, 2);
@@ -1189,6 +1206,8 @@
# doesn't look like a regex
ok("x" =~ $x, "qr-only matches");
ok("y" !~ $x, "qr-only doesn't match what it shouldn't");
+ ok("x" =~ /^(??{$x})$/, "qr-only with ?? matches");
+ ok("y" !~ /^(??{$x})$/, "qr-only with ?? doesn't match what it shouldn't");
ok("xx" =~ /x$x/, "qr-only matches with concat");
like("$x", qr/^QRonly=ARRAY/, "qr-only doesn't have string overload");
@@ -1195,11 +1214,15 @@
my $qr = bless qr/y/, "QRonly";
ok("x" =~ $qr, "qr with qr-overload uses overload");
ok("y" !~ $qr, "qr with qr-overload uses overload");
+ ok("x" =~ /^(??{$qr})$/, "qr with qr-overload with ?? uses overload");
+ ok("y" !~ /^(??{$qr})$/, "qr with qr-overload with ?? uses overload");
is("$qr", "".qr/y/, "qr with qr-overload stringify");
my $rx = $$qr;
ok("y" =~ $rx, "bare rx with qr-overload doesn't overload match");
ok("x" !~ $rx, "bare rx with qr-overload doesn't overload match");
+ ok("y" =~ /^(??{$rx})$/, "bare rx with qr-overload with ?? doesn't overload match");
+ ok("x" !~ /^(??{$rx})$/, "bare rx with qr-overload with ?? doesn't overload match");
is("$rx", "".qr/y/, "bare rx with qr-overload stringify");
}
{
@@ -1794,6 +1817,8 @@
# note: this is testing unary qr, not binary =~
$subs{qr} = '(qr/%s/)';
push @tests, [ "abc", '"abc" =~ (%s)', '(qr)', '("")', [ 1, 2, 0 ], 0 ];
+ push @tests, [ chr 256, 'chr(256) =~ (%s)', '(qr)', '("")',
+ [ 1, 2, 0 ], 0 ];
$e = '"abc" ~~ (%s)';
$subs{'~~'} = $e;
@@ -1821,7 +1846,7 @@
$subs{'%{}'} = '%s';
push @tests, [ {qw(a 1 b 2 c 3)}, 'join "", sort keys %%{%s}',
- '(%{})', undef, [ 1, 2, 0 ], 0 ];
+ '(%{})', undef, [ 1, 1, 0 ], 0 ];
$subs{'&{}'} = '%s';
push @tests, [ sub {99}, 'do {&{%s} for 1,2}',
@@ -1838,6 +1863,9 @@
or die "open of \$iter_text gave ($!)\n";
$subs{'<>'} = '<$iter_fh>';
push @tests, [ $iter_fh, '<%s>', '(<>)', undef, [ 1, 1, 0 ], 1 ];
+ push @tests, [ $iter_fh,
+ 'local *CORE::GLOBAL::glob = sub {}; eval q|<%s>|',
+ '(<>)', undef, [ 1, 1, 0 ], 1 ];
# eval should do tie, overload on its arg before checking taint */
push @tests, [ '1;', 'eval q(eval %s); $@ =~ /Insecure/',
@@ -1845,6 +1873,7 @@
for my $sub (keys %subs) {
+ no warnings 'experimental::smartmatch';
my $term = $subs{$sub};
my $t = sprintf $term, '$_[0][0]';
my $e ="sub { \$funcs .= '($sub)'; my \$r; if (\$use_int) {"
@@ -1886,6 +1915,7 @@
? "-\$_[0][0]"
: "$_[3](\$_[0][0])";
my $r;
+ no warnings 'experimental::smartmatch';
if ($use_int) {
use integer; $r = eval $e;
}
@@ -1932,7 +1962,7 @@
$use_int = ($int ne '');
my $plain = $tainted_val;
my $plain_term = $int . sprintf $sub_term, '$plain';
- my $exp = eval $plain_term;
+ my $exp = do {no warnings 'experimental::smartmatch'; eval $plain_term };
diag("eval of plain_term <$plain_term> gave <$@>") if $@;
is(tainted($exp), $exp_taint,
"<$plain_term> taint of expected return");
@@ -1960,7 +1990,7 @@
my $res_term = $int . sprintf $sub_term, $var;
my $desc = "<$res_term> $ov_pkg" ;
- my $res = eval $res_term;
+ my $res = do { no warnings 'experimental::smartmatch'; eval $res_term };
diag("eval of res_term $desc gave <$@>") if $@;
# uniquely, the inc/dec ops return the original
# ref rather than a copy, so stringify it to
@@ -2168,5 +2198,505 @@
is ($a[2], 12, 'Iter1: a[2] concat');
}
+# Some tests for error messages
+{
+ package Justus;
+ use overload '+' => 'justice';
+ eval {"".bless[]};
+ ::like $@, qr/^Can't resolve method "justice" overloading "\+" in p(?x:
+ )ackage "Justus" at /,
+ 'Error message when explicitly named overload method does not exist';
+ package JustUs;
+ our @ISA = 'JustYou';
+ package JustYou { use overload '+' => 'injustice'; }
+ "JustUs"->${\"(+"};
+ eval {"".bless []};
+ ::like $@, qr/^Stub found while resolving method "\?{3}" overloadin(?x:
+ )g "\+" in package "JustUs" at /,
+ 'Error message when sub stub is encountered';
+}
+
+{
+ # check that the right number of stringifications
+ # and the correct un-utf8-ifying happen on regex compile
+ package utf8_match;
+ my $c;
+ use overload '""' => sub { $c++; $_[0][0] ? "^\x{100}\$" : "^A\$"; };
+ my $o = bless [0], 'utf8_match';
+
+ $o->[0] = 0;
+ $c = 0;
+ ::ok("A" =~ "^A\$", "regex stringify utf8=0 ol=0 bytes=0");
+ ::ok("A" =~ $o, "regex stringify utf8=0 ol=1 bytes=0");
+ ::is($c, 1, "regex stringify utf8=0 ol=1 bytes=0 count");
+
+ $o->[0] = 1;
+ $c = 0;
+ ::ok("\x{100}" =~ "^\x{100}\$",
+ "regex stringify utf8=1 ol=0 bytes=0");
+ ::ok("\x{100}" =~ $o, "regex stringify utf8=1 ol=1 bytes=0");
+ ::is($c, 1, "regex stringify utf8=1 ol=1 bytes=0 count");
+
+ use bytes;
+
+ $o->[0] = 0;
+ $c = 0;
+ ::ok("A" =~ "^A\$", "regex stringify utf8=0 ol=0 bytes=1");
+ ::ok("A" =~ $o, "regex stringify utf8=0 ol=1 bytes=1");
+ ::is($c, 1, "regex stringify utf8=0 ol=1 bytes=1 count");
+
+ $o->[0] = 1;
+ $c = 0;
+ ::ok("\xc4\x80" =~ "^\x{100}\$",
+ "regex stringify utf8=1 ol=0 bytes=1");
+ ::ok("\xc4\x80" =~ $o, "regex stringify utf8=1 ol=1 bytes=1");
+ ::is($c, 1, "regex stringify utf8=1 ol=1 bytes=1 count");
+
+
+}
+
+# [perl #40333]
+# overload::Overloaded should not use a ->can designed for autoloading.
+# This example attempts to be as realistic as possible. The o class has a
+# default singleton object, but can have instances, too. The proxy class
+# represents proxies for o objects, but class methods delegate to the
+# singleton.
+# overload::Overloaded used to return incorrect results for proxy objects.
+package proxy {
+ sub new { bless [$_[1]], $_[0] }
+ sub AUTOLOAD {
+ our $AUTOLOAD =~ s/.*:://;
+ &_self->$AUTOLOAD;
+ }
+ sub can { SUPER::can{@_} || &_self->can($_[1]) }
+ sub _self { ref $_[0] ? $_[0][0] : $o::singleton }
+}
+package o { use overload '""' => sub { 'keck' };
+ sub new { bless[], $_[0] }
+ our $singleton = o->new; }
+ok !overload::Overloaded(new proxy new o),
+ 'overload::Overloaded does not incorrectly return true for proxy classes';
+
+# Another test, based on the type of explosive test class for which
+# perl #40333 was filed.
+{
+ package broken_can;
+ sub can {}
+ use overload '""' => sub {"Ahoy!"};
+
+ package main;
+ my $obj = bless [], 'broken_can';
+ ok(overload::Overloaded($obj));
+}
+
+sub eleventative::cos { 'eleven' }
+sub twelvetative::abs { 'twelve' }
+sub thirteentative::abs { 'thirteen' }
+sub fourteentative::abs { 'fourteen' }
+ at eleventative::ISA = twelvetative::;
+{
+ my $o = bless [], 'eleventative';
+ eval 'package eleventative; use overload map +($_)x2, cos=>abs=>';
+ is cos $o, 'eleven', 'overloading applies to object blessed before';
+ bless [], 'eleventative';
+ is cos $o, 'eleven',
+ 'ovrld applies to previously-blessed obj after other obj is blessed';
+ $o = bless [], 'eleventative';
+ *eleventative::cos = sub { 'ten' };
+ is cos $o, 'ten', 'method changes affect overloading';
+ @eleventative::ISA = thirteentative::;
+ is abs $o, 'thirteen', 'isa changes affect overloading';
+ bless $o, 'fourteentative';
+ @fourteentative::ISA = 'eleventative';
+ is abs $o, 'fourteen', 'isa changes can turn overloading on';
+}
+
+# no overload "fallback";
+{ package phake;
+ use overload fallback => 1, '""' => sub { 'arakas' };
+ no overload 'fallback';
+}
+$a = bless [], 'phake';
+is "$a", "arakas",
+ 'no overload "fallback" does not stop overload from working';
+ok !eval { () = $a eq 'mpizeli'; 1 },
+ 'no overload "fallback" resets fallback to undef on overloaded class';
+{ package ent; use overload fallback => 0, abs => sub{};
+ our at ISA = 'huorn';
+ package huorn;
+ use overload fallback => 1;
+ package ent;
+ no overload "fallback"; # disable previous declaration
+}
+$a = bless [], ent::;
+is eval {"$a"}, overload::StrVal($a),
+ 'no overload undoes fallback declaration completetly'
+ or diag $@;
+
+# inherited fallback
+{
+ package pervyy;
+ our @ISA = 'vtoryy';
+ use overload "abs" =>=> sub {};
+ package vtoryy;
+ use overload fallback => 1, 'sin' =>=> sub{}
+}
+$a = bless [], pervyy::;
+is eval {"$a"}, overload::StrVal($a),
+ 'fallback is inherited by classes that have their own overloading'
+ or diag $@;
+
+# package separators in method names
+{
+ package mane;
+ use overload q\""\ => "bear::strength";
+ use overload bool => "bear'bouillon";
+}
+ at bear::ISA = 'food';
+sub food::strength { 'twine' }
+sub food::bouillon { 0 }
+$a = bless[], mane::;
+is eval { "$a" }, 'twine', ':: in method name' or diag $@;
+is eval { !$a }, 1, "' in method name" or diag $@;
+
+# [perl #113050] Half of CPAN assumes fallback is under "()"
+{
+ package dodo;
+ use overload '+' => sub {};
+ no strict;
+ *{"dodo::()"} = sub{};
+ ${"dodo::()"} = 1;
+}
+$a = bless [],'dodo';
+is eval {"$a"}, overload::StrVal($a), 'fallback is stored under "()"';
+
+# [perl #47119]
+{
+ my $context;
+
+ {
+ package Splitter;
+ use overload '<>' => \&chars;
+
+ sub new {
+ my $class = shift;
+ my ($string) = @_;
+ bless \$string, $class;
+ }
+
+ sub chars {
+ my $self = shift;
+ my @chars = split //, $$self;
+ $context = wantarray;
+ return @chars;
+ }
+ }
+
+ my $obj = Splitter->new('bar');
+
+ $context = 42; # not 1, '', or undef
+
+ my @foo = <$obj>;
+ is($context, 1, "list context (readline list)");
+ is(scalar(@foo), 3, "correct result (readline list)");
+ is($foo[0], 'b', "correct result (readline list)");
+ is($foo[1], 'a', "correct result (readline list)");
+ is($foo[2], 'r', "correct result (readline list)");
+
+ $context = 42;
+
+ my $foo = <$obj>;
+ ok(defined($context), "scalar context (readline scalar)");
+ is($context, '', "scalar context (readline scalar)");
+ is($foo, 3, "correct result (readline scalar)");
+
+ $context = 42;
+
+ <$obj>;
+ ok(!defined($context), "void context (readline void)");
+
+ $context = 42;
+
+ my @bar = <${obj}>;
+ is($context, 1, "list context (glob list)");
+ is(scalar(@bar), 3, "correct result (glob list)");
+ is($bar[0], 'b', "correct result (glob list)");
+ is($bar[1], 'a', "correct result (glob list)");
+ is($bar[2], 'r', "correct result (glob list)");
+
+ $context = 42;
+
+ my $bar = <${obj}>;
+ ok(defined($context), "scalar context (glob scalar)");
+ is($context, '', "scalar context (glob scalar)");
+ is($bar, 3, "correct result (glob scalar)");
+
+ $context = 42;
+
+ <${obj}>;
+ ok(!defined($context), "void context (glob void)");
+}
+{
+ my $context;
+
+ {
+ package StringWithContext;
+ use overload '""' => \&stringify;
+
+ sub new {
+ my $class = shift;
+ my ($string) = @_;
+ bless \$string, $class;
+ }
+
+ sub stringify {
+ my $self = shift;
+ $context = wantarray;
+ return $$self;
+ }
+ }
+
+ my $obj = StringWithContext->new('bar');
+
+ $context = 42;
+
+ my @foo = "".$obj;
+ ok(defined($context), "scalar context (stringify list)");
+ is($context, '', "scalar context (stringify list)");
+ is(scalar(@foo), 1, "correct result (stringify list)");
+ is($foo[0], 'bar', "correct result (stringify list)");
+
+ $context = 42;
+
+ my $foo = "".$obj;
+ ok(defined($context), "scalar context (stringify scalar)");
+ is($context, '', "scalar context (stringify scalar)");
+ is($foo, 'bar', "correct result (stringify scalar)");
+
+ $context = 42;
+
+ "".$obj;
+
+ is($context, '', "scalar context (stringify void)");
+}
+{
+ my ($context, $swap);
+
+ {
+ package AddWithContext;
+ use overload '+' => \&add;
+
+ sub new {
+ my $class = shift;
+ my ($num) = @_;
+ bless \$num, $class;
+ }
+
+ sub add {
+ my $self = shift;
+ my ($other, $swapped) = @_;
+ $context = wantarray;
+ $swap = $swapped;
+ return ref($self)->new($$self + $other);
+ }
+
+ sub val { ${ $_[0] } }
+ }
+
+ my $obj = AddWithContext->new(6);
+
+ $context = $swap = 42;
+
+ my @foo = $obj + 7;
+ ok(defined($context), "scalar context (add list)");
+ is($context, '', "scalar context (add list)");
+ ok(defined($swap), "not swapped (add list)");
+ is($swap, '', "not swapped (add list)");
+ is(scalar(@foo), 1, "correct result (add list)");
+ is($foo[0]->val, 13, "correct result (add list)");
+
+ $context = $swap = 42;
+
+ @foo = 7 + $obj;
+ ok(defined($context), "scalar context (add list swap)");
+ is($context, '', "scalar context (add list swap)");
+ ok(defined($swap), "swapped (add list swap)");
+ is($swap, 1, "swapped (add list swap)");
+ is(scalar(@foo), 1, "correct result (add list swap)");
+ is($foo[0]->val, 13, "correct result (add list swap)");
+
+ $context = $swap = 42;
+
+ my $foo = $obj + 7;
+ ok(defined($context), "scalar context (add scalar)");
+ is($context, '', "scalar context (add scalar)");
+ ok(defined($swap), "not swapped (add scalar)");
+ is($swap, '', "not swapped (add scalar)");
+ is($foo->val, 13, "correct result (add scalar)");
+
+ $context = $swap = 42;
+
+ my $foo = 7 + $obj;
+ ok(defined($context), "scalar context (add scalar swap)");
+ is($context, '', "scalar context (add scalar swap)");
+ ok(defined($swap), "swapped (add scalar swap)");
+ is($swap, 1, "swapped (add scalar swap)");
+ is($foo->val, 13, "correct result (add scalar swap)");
+
+ $context = $swap = 42;
+
+ $obj + 7;
+
+ ok(!defined($context), "void context (add void)");
+ ok(defined($swap), "not swapped (add void)");
+ is($swap, '', "not swapped (add void)");
+
+ $context = $swap = 42;
+
+ 7 + $obj;
+
+ ok(!defined($context), "void context (add void swap)");
+ ok(defined($swap), "swapped (add void swap)");
+ is($swap, 1, "swapped (add void swap)");
+
+ $obj = AddWithContext->new(6);
+
+ $context = $swap = 42;
+
+ my @foo = $obj += 7;
+ ok(defined($context), "scalar context (add assign list)");
+ is($context, '', "scalar context (add assign list)");
+ ok(!defined($swap), "not swapped and autogenerated (add assign list)");
+ is(scalar(@foo), 1, "correct result (add assign list)");
+ is($foo[0]->val, 13, "correct result (add assign list)");
+ is($obj->val, 13, "correct result (add assign list)");
+
+ $obj = AddWithContext->new(6);
+
+ $context = $swap = 42;
+
+ my $foo = $obj += 7;
+ ok(defined($context), "scalar context (add assign scalar)");
+ is($context, '', "scalar context (add assign scalar)");
+ ok(!defined($swap), "not swapped and autogenerated (add assign scalar)");
+ is($foo->val, 13, "correct result (add assign scalar)");
+ is($obj->val, 13, "correct result (add assign scalar)");
+
+ $obj = AddWithContext->new(6);
+
+ $context = $swap = 42;
+
+ $obj += 7;
+
+ ok(defined($context), "scalar context (add assign void)");
+ is($context, '', "scalar context (add assign void)");
+ ok(!defined($swap), "not swapped and autogenerated (add assign void)");
+ is($obj->val, 13, "correct result (add assign void)");
+
+ $obj = AddWithContext->new(6);
+
+ $context = $swap = 42;
+
+ my @foo = ++$obj;
+ ok(defined($context), "scalar context (add incr list)");
+ is($context, '', "scalar context (add incr list)");
+ ok(!defined($swap), "not swapped and autogenerated (add incr list)");
+ is(scalar(@foo), 1, "correct result (add incr list)");
+ is($foo[0]->val, 7, "correct result (add incr list)");
+ is($obj->val, 7, "correct result (add incr list)");
+
+ $obj = AddWithContext->new(6);
+
+ $context = $swap = 42;
+
+ my $foo = ++$obj;
+ ok(defined($context), "scalar context (add incr scalar)");
+ is($context, '', "scalar context (add incr scalar)");
+ ok(!defined($swap), "not swapped and autogenerated (add incr scalar)");
+ is($foo->val, 7, "correct result (add incr scalar)");
+ is($obj->val, 7, "correct result (add incr scalar)");
+
+ $obj = AddWithContext->new(6);
+
+ $context = $swap = 42;
+
+ ++$obj;
+
+ ok(defined($context), "scalar context (add incr void)");
+ is($context, '', "scalar context (add incr void)");
+ ok(!defined($swap), "not swapped and autogenerated (add incr void)");
+ is($obj->val, 7, "correct result (add incr void)");
+}
+
+# [perl #113010]
+{
+ {
+ package OnlyFallback;
+ use overload fallback => 0;
+ }
+ {
+ my $obj = bless {}, 'OnlyFallback';
+ my $died = !eval { "".$obj; 1 };
+ my $err = $@;
+ ok($died, "fallback of 0 causes error");
+ like($err, qr/"\.": no method found/, "correct error");
+ }
+
+ {
+ package OnlyFallbackUndef;
+ use overload fallback => undef;
+ }
+ {
+ my $obj = bless {}, 'OnlyFallbackUndef';
+ my $died = !eval { "".$obj; 1 };
+ my $err = $@;
+ ok($died, "fallback of undef causes error");
+ # this one tries falling back to stringify before dying
+ like($err, qr/"""": no method found/, "correct error");
+ }
+
+ {
+ package OnlyFallbackTrue;
+ use overload fallback => 1;
+ }
+ {
+ my $obj = bless {}, 'OnlyFallbackTrue';
+ my $val;
+ my $died = !eval { $val = "".$obj; 1 };
+ my $err = $@;
+ ok(!$died, "fallback of 1 doesn't cause error")
+ || diag("got error of $err");
+ like($val, qr/^OnlyFallbackTrue=HASH\(/, "stringified correctly");
+ }
+}
+
+{
+ # Making Regexp class overloaded: avoid infinite recursion.
+ # Do this in a separate process since it, well, overloads Regexp!
+ fresh_perl_is(
+ <<'EOF',
+package Regexp;
+use overload q{""} => sub {$_[0] };
+package main;
+my $r1 = qr/1/;
+my $r2 = qr/ABC$r1/;
+print $r2,"\n";
+EOF
+ '(?^:ABC(?^:1))',
+ { stderr => 1 },
+ 'overloaded REGEXP'
+ );
+}
+
+{ # undefining the overload stash -- KEEP THIS TEST LAST
+ package ant;
+ use overload '+' => 'onion';
+ $_ = \&overload::nil;
+ undef %overload::;
+ ()=0+bless[];
+ ::ok(1, 'no crash when undefining %overload::');
+}
+
+
# EOF
Property changes on: trunk/contrib/perl/lib/overload.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/lib/overload64.t
===================================================================
--- trunk/contrib/perl/lib/overload64.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/overload64.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/overload64.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/lib/overloading.pm
===================================================================
--- trunk/contrib/perl/lib/overloading.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/overloading.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,10 +1,8 @@
package overloading;
use warnings;
-use Carp ();
+our $VERSION = '0.02';
-our $VERSION = '0.01';
-
my $HINT_NO_AMAGIC = 0x01000000; # see perl.h
require 5.010001;
@@ -14,7 +12,7 @@
map { exists $overload::numbers::names{"($_"}
? $overload::numbers::names{"($_"}
- : Carp::croak("'$_' is not a valid overload")
+ : do { require Carp; Carp::croak("'$_' is not a valid overload") }
} @_;
}
Property changes on: trunk/contrib/perl/lib/overloading.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/lib/overloading.t
===================================================================
--- trunk/contrib/perl/lib/overloading.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/overloading.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,6 +1,6 @@
#./perl
-use Test::More tests => 35;
+use Test::More tests => 50;
use Scalar::Util qw(refaddr);
@@ -18,8 +18,11 @@
}
my $x = Stringifies->new;
+my $y = qr//;
+my $ystr = "$y";
is( "$x", "foo", "stringifies" );
+is( "$y", $ystr, "stringifies qr//" );
is( 0 + $x, 42, "numifies" );
is( cos($x), "far side of overload table", "cosinusfies" );
@@ -26,6 +29,7 @@
{
no overloading;
is( "$x", overload::StrVal($x), "no stringification" );
+ is( "$y", overload::StrVal($y), "no stringification of qr//" );
is( 0 + $x, refaddr($x), "no numification" );
is( cos($x), cos(refaddr($x)), "no cosinusfication" );
@@ -32,6 +36,7 @@
{
no overloading '""';
is( "$x", overload::StrVal($x), "no stringification" );
+ is( "$y", overload::StrVal($y), "no stringification of qr//" );
is( 0 + $x, refaddr($x), "no numification" );
is( cos($x), cos(refaddr($x)), "no cosinusfication" );
}
@@ -41,12 +46,24 @@
no overloading '""';
is( "$x", overload::StrVal($x), "no stringification" );
+ is( "$y", overload::StrVal($y), "no stringification of qr//" );
is( 0 + $x, 42, "numifies" );
is( cos($x), "far side of overload table", "cosinusfies" );
+ my $q = qr/abc/;
+ ok "abc" =~ $q, '=~ qr// with no "" overloading';
+ ok "abcd" =~ /${q}d/, '=~ /foo$qr/ with no "" overloading';
{
+ no overloading 'qr';
+ my $q = qr/abc/;
+ ok "abc" =~ $q, '=~ qr// with no "" or qr overloading';
+ ok "abcd" =~ /${q}d/, '=~ /foo$qr/ with no "" or qr overloading';
+ }
+
+ {
no overloading;
is( "$x", overload::StrVal($x), "no stringification" );
+ is( "$y", overload::StrVal($y), "no stringification of qr//" );
is( 0 + $x, refaddr($x), "no numification" );
is( cos($x), cos(refaddr($x)), "no cosinusfication" );
}
@@ -54,11 +71,13 @@
use overloading '""';
is( "$x", "foo", "stringifies" );
+ is( "$y", $ystr, "stringifies qr//" );
is( 0 + $x, 42, "numifies" );
is( cos($x), "far side of overload table", "cosinusfies" );
no overloading '0+';
is( "$x", "foo", "stringifies" );
+ is( "$y", $ystr, "stringifies qr//" );
is( 0 + $x, refaddr($x), "no numification" );
is( cos($x), "far side of overload table", "cosinusfies" );
@@ -65,6 +84,7 @@
{
no overloading '""';
is( "$x", overload::StrVal($x), "no stringification" );
+ is( "$y", overload::StrVal($y), "no stringification of qr//" );
is( 0 + $x, refaddr($x), "no numification" );
is( cos($x), "far side of overload table", "cosinusfies" );
@@ -71,6 +91,7 @@
{
use overloading;
is( "$x", "foo", "stringifies" );
+ is( "$y", $ystr, "stringifies qr//" );
is( 0 + $x, 42, "numifies" );
is( cos($x), "far side of overload table", "cosinusfies" );
}
@@ -77,11 +98,13 @@
}
is( "$x", "foo", "stringifies" );
+ is( "$y", $ystr, "stringifies qr//" );
is( 0 + $x, refaddr($x), "no numification" );
is( cos($x), "far side of overload table", "cosinusfies" );
no overloading "cos";
is( "$x", "foo", "stringifies" );
+ is( "$y", $ystr, "stringifies qr//" );
is( 0 + $x, refaddr($x), "no numification" );
is( cos($x), cos(refaddr($x)), "no cosinusfication" );
Property changes on: trunk/contrib/perl/lib/overloading.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/lib/parent.pm (from rev 6437, vendor/perl/5.18.1/lib/parent.pm)
===================================================================
--- trunk/contrib/perl/lib/parent.pm (rev 0)
+++ trunk/contrib/perl/lib/parent.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,136 @@
+package parent;
+use strict;
+use vars qw($VERSION);
+$VERSION = '0.221';
+
+sub import {
+ my $class = shift;
+
+ my $inheritor = caller(0);
+
+ if ( @_ and $_[0] eq '-norequire' ) {
+ shift @_;
+ } else {
+ for ( my @filename = @_ ) {
+ if ( $_ eq $inheritor ) {
+ warn "Class '$inheritor' tried to inherit from itself\n";
+ };
+
+ s{::|'}{/}g;
+ require "$_.pm"; # dies if the file is not found
+ }
+ }
+
+ {
+ no strict 'refs';
+ # This is more efficient than push for the new MRO
+ # at least until the new MRO is fixed
+ @{"$inheritor\::ISA"} = (@{"$inheritor\::ISA"} , @_);
+ };
+};
+
+"All your base are belong to us"
+
+__END__
+
+=head1 NAME
+
+parent - Establish an ISA relationship with base classes at compile time
+
+=head1 SYNOPSIS
+
+ package Baz;
+ use parent qw(Foo Bar);
+
+=head1 DESCRIPTION
+
+Allows you to both load one or more modules, while setting up inheritance from
+those modules at the same time. Mostly similar in effect to
+
+ package Baz;
+ BEGIN {
+ require Foo;
+ require Bar;
+ push @ISA, qw(Foo Bar);
+ }
+
+By default, every base class needs to live in a file of its own.
+If you want to have a subclass and its parent class in the same file, you
+can tell C<parent> not to load any modules by using the C<-norequire> switch:
+
+ package Foo;
+ sub exclaim { "I CAN HAS PERL" }
+
+ package DoesNotLoadFooBar;
+ use parent -norequire, 'Foo', 'Bar';
+ # will not go looking for Foo.pm or Bar.pm
+
+This is equivalent to the following code:
+
+ package Foo;
+ sub exclaim { "I CAN HAS PERL" }
+
+ package DoesNotLoadFooBar;
+ push @DoesNotLoadFooBar::ISA, 'Foo';
+
+This is also helpful for the case where a package lives within
+a differently named file:
+
+ package MyHash;
+ use Tie::Hash;
+ use parent -norequire, 'Tie::StdHash';
+
+This is equivalent to the following code:
+
+ package MyHash;
+ require Tie::Hash;
+ push @ISA, 'Tie::StdHash';
+
+If you want to load a subclass from a file that C<require> would
+not consider an eligible filename (that is, it does not end in
+either C<.pm> or C<.pmc>), use the following code:
+
+ package MySecondPlugin;
+ require './plugins/custom.plugin'; # contains Plugin::Custom
+ use parent -norequire, 'Plugin::Custom';
+
+=head1 DIAGNOSTICS
+
+=over 4
+
+=item Class 'Foo' tried to inherit from itself
+
+Attempting to inherit from yourself generates a warning.
+
+ use Foo;
+ use parent 'Foo';
+
+=back
+
+=head1 HISTORY
+
+This module was forked from L<base> to remove the cruft
+that had accumulated in it.
+
+=head1 CAVEATS
+
+=head1 SEE ALSO
+
+L<base>
+
+=head1 AUTHORS AND CONTRIBUTORS
+
+Rafa\xEBl Garcia-Suarez, Bart Lateur, Max Maischein, Anno Siegel, Michael Schwern
+
+=head1 MAINTAINER
+
+Max Maischein C< corion at cpan.org >
+
+Copyright (c) 2007 Max Maischein C<< <corion at cpan.org> >>
+Based on the idea of C<base.pm>, which was introduced with Perl 5.004_04.
+
+=head1 LICENSE
+
+This module is released under the same terms as Perl itself.
+
+=cut
Copied: trunk/contrib/perl/lib/perl5db/t/EnableModule.pm (from rev 6437, vendor/perl/5.18.1/lib/perl5db/t/EnableModule.pm)
===================================================================
--- trunk/contrib/perl/lib/perl5db/t/EnableModule.pm (rev 0)
+++ trunk/contrib/perl/lib/perl5db/t/EnableModule.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,18 @@
+package EnableModule;
+
+use strict;
+use warnings;
+
+sub set_x
+{
+ my $x_ref = shift;
+
+ ${$x_ref} .= "TwoHundred";
+
+ my $x = ${$x_ref};
+
+ my $t = $x;
+ $t .= "Foo";
+}
+
+1;
Copied: trunk/contrib/perl/lib/perl5db/t/MyModule.pm (from rev 6437, vendor/perl/5.18.1/lib/perl5db/t/MyModule.pm)
===================================================================
--- trunk/contrib/perl/lib/perl5db/t/MyModule.pm (rev 0)
+++ trunk/contrib/perl/lib/perl5db/t/MyModule.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,15 @@
+package MyModule;
+
+use strict;
+use warnings;
+
+use vars qw($var);
+
+$var = "Bar";
+
+sub function
+{
+ print "In MyModule.\n";
+}
+
+1;
Copied: trunk/contrib/perl/lib/perl5db/t/break-on-dot (from rev 6437, vendor/perl/5.18.1/lib/perl5db/t/break-on-dot)
===================================================================
--- trunk/contrib/perl/lib/perl5db/t/break-on-dot (rev 0)
+++ trunk/contrib/perl/lib/perl5db/t/break-on-dot 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,10 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+my $exp = 1;
+for my $i (1 .. 20)
+{
+ $exp *= 2;
+}
Copied: trunk/contrib/perl/lib/perl5db/t/breakpoint-bug (from rev 6437, vendor/perl/5.18.1/lib/perl5db/t/breakpoint-bug)
===================================================================
--- trunk/contrib/perl/lib/perl5db/t/breakpoint-bug (rev 0)
+++ trunk/contrib/perl/lib/perl5db/t/breakpoint-bug 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,8 @@
+#!/usr/bin/perl
+my $x = "One";
+
+$x = "Two";
+
+my $y = "Lambda";
+
+$x = "Four";
Copied: trunk/contrib/perl/lib/perl5db/t/disable-breakpoints-1 (from rev 6437, vendor/perl/5.18.1/lib/perl5db/t/disable-breakpoints-1)
===================================================================
--- trunk/contrib/perl/lib/perl5db/t/disable-breakpoints-1 (rev 0)
+++ trunk/contrib/perl/lib/perl5db/t/disable-breakpoints-1 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,19 @@
+#!/usr/bin/perl
+my $x = "One";
+my $dummy = 0;
+
+$x = "FirstVal";
+
+$dummy++;
+
+$x = "SecondVal";
+
+$dummy++;
+
+$x = "ThirdVal";
+
+$dummy++;
+
+$x = "FourthVal";
+
+$dummy++;
Copied: trunk/contrib/perl/lib/perl5db/t/disable-breakpoints-2 (from rev 6437, vendor/perl/5.18.1/lib/perl5db/t/disable-breakpoints-2)
===================================================================
--- trunk/contrib/perl/lib/perl5db/t/disable-breakpoints-2 (rev 0)
+++ trunk/contrib/perl/lib/perl5db/t/disable-breakpoints-2 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,26 @@
+#!/usr/bin/perl
+my $x = "One";
+
+$x = "FirstVal";
+
+set_x();
+
+$x = "SecondVal";
+
+set_x();
+
+$x = "ThirdVal";
+
+set_x();
+
+$x = "FourthVal";
+
+set_x();
+
+sub set_x
+{
+ $x .= "OneHundred";
+
+ my $t = $x;
+ $t .= "Foo";
+}
Copied: trunk/contrib/perl/lib/perl5db/t/disable-breakpoints-3 (from rev 6437, vendor/perl/5.18.1/lib/perl5db/t/disable-breakpoints-3)
===================================================================
--- trunk/contrib/perl/lib/perl5db/t/disable-breakpoints-3 (rev 0)
+++ trunk/contrib/perl/lib/perl5db/t/disable-breakpoints-3 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,21 @@
+#!/usr/bin/perl
+
+use EnableModule;
+my $x = "One";
+
+$x = "FirstVal";
+
+EnableModule::set_x(\$x);
+
+$x = "SecondVal";
+
+EnableModule::set_x(\$x);
+
+$x = "ThirdVal";
+
+EnableModule::set_x(\$x);
+
+$x = "FourthVal";
+
+EnableModule::set_x(\$x);
+
Index: trunk/contrib/perl/lib/perl5db/t/eval-line-bug
===================================================================
--- trunk/contrib/perl/lib/perl5db/t/eval-line-bug 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/perl5db/t/eval-line-bug 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/perl5db/t/eval-line-bug
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/lib/perl5db/t/fact (from rev 6437, vendor/perl/5.18.1/lib/perl5db/t/fact)
===================================================================
--- trunk/contrib/perl/lib/perl5db/t/fact (rev 0)
+++ trunk/contrib/perl/lib/perl5db/t/fact 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,14 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+sub fact {
+ my $n = shift;
+ if ($n > 1) {
+ return $n * fact($n - 1);
+ } else {
+ return 1;
+ }
+}
+fact(5);
Copied: trunk/contrib/perl/lib/perl5db/t/filename-line-breakpoint (from rev 6437, vendor/perl/5.18.1/lib/perl5db/t/filename-line-breakpoint)
===================================================================
--- trunk/contrib/perl/lib/perl5db/t/filename-line-breakpoint (rev 0)
+++ trunk/contrib/perl/lib/perl5db/t/filename-line-breakpoint 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,14 @@
+#!/perl
+
+use strict;
+use warnings;
+
+use MyModule;
+
+my $x = "Foo";
+
+MyModule::function();
+
+print "In Main File.\n";
+
+1;
Copied: trunk/contrib/perl/lib/perl5db/t/load-modules (from rev 6437, vendor/perl/5.18.1/lib/perl5db/t/load-modules)
===================================================================
--- trunk/contrib/perl/lib/perl5db/t/load-modules (rev 0)
+++ trunk/contrib/perl/lib/perl5db/t/load-modules 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,6 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Scalar::Util;
Index: trunk/contrib/perl/lib/perl5db/t/lvalue-bug
===================================================================
--- trunk/contrib/perl/lib/perl5db/t/lvalue-bug 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/perl5db/t/lvalue-bug 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/perl5db/t/lvalue-bug
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/perl5db/t/proxy-constants
===================================================================
--- trunk/contrib/perl/lib/perl5db/t/proxy-constants 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/perl5db/t/proxy-constants 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/perl5db/t/proxy-constants
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/lib/perl5db/t/rt-104168 (from rev 6437, vendor/perl/5.18.1/lib/perl5db/t/rt-104168)
===================================================================
--- trunk/contrib/perl/lib/perl5db/t/rt-104168 (rev 0)
+++ trunk/contrib/perl/lib/perl5db/t/rt-104168 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,21 @@
+#!/usr/bin/perl
+#
+# This code is used by lib/perl5db.t !!!
+#
+
+foo();
+
+sub foo {
+ bar();
+}
+
+
+sub bar {
+ baz();
+}
+
+sub baz {
+ 1;
+}
+
+1;
Index: trunk/contrib/perl/lib/perl5db/t/rt-61222
===================================================================
--- trunk/contrib/perl/lib/perl5db/t/rt-61222 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/perl5db/t/rt-61222 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/perl5db/t/rt-61222
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/perl5db/t/rt-66110
===================================================================
--- trunk/contrib/perl/lib/perl5db/t/rt-66110 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/perl5db/t/rt-66110 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/perl5db/t/rt-66110
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/lib/perl5db/t/source-cmd-test-no-q.perldb (from rev 6437, vendor/perl/5.18.1/lib/perl5db/t/source-cmd-test-no-q.perldb)
===================================================================
--- trunk/contrib/perl/lib/perl5db/t/source-cmd-test-no-q.perldb (rev 0)
+++ trunk/contrib/perl/lib/perl5db/t/source-cmd-test-no-q.perldb 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1 @@
+l 3-10
Copied: trunk/contrib/perl/lib/perl5db/t/source-cmd-test.perldb (from rev 6437, vendor/perl/5.18.1/lib/perl5db/t/source-cmd-test.perldb)
===================================================================
--- trunk/contrib/perl/lib/perl5db/t/source-cmd-test.perldb (rev 0)
+++ trunk/contrib/perl/lib/perl5db/t/source-cmd-test.perldb 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,2 @@
+l 3-10
+q
Index: trunk/contrib/perl/lib/perl5db/t/symbol-table-bug
===================================================================
--- trunk/contrib/perl/lib/perl5db/t/symbol-table-bug 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/perl5db/t/symbol-table-bug 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/perl5db/t/symbol-table-bug
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/perl5db/t/taint
===================================================================
--- trunk/contrib/perl/lib/perl5db/t/taint 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/perl5db/t/taint 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/perl5db/t/taint
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/lib/perl5db/t/test-PrintRet-option-1 (from rev 6437, vendor/perl/5.18.1/lib/perl5db/t/test-PrintRet-option-1)
===================================================================
--- trunk/contrib/perl/lib/perl5db/t/test-PrintRet-option-1 (rev 0)
+++ trunk/contrib/perl/lib/perl5db/t/test-PrintRet-option-1 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,46 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+my ($x, $y);
+
+sub return_scalar
+{
+ $y++;
+
+ return "20024";
+}
+
+sub return_list
+{
+ $y++;
+
+ return ("Foo", "Bar", "Baz");
+}
+
+sub return_void
+{
+ $y++;
+
+ return;
+}
+
+$y++;
+
+# Choose one based on $x
+#
+if ($x eq "s")
+{
+ my $s = return_scalar();
+}
+elsif ($x eq "l")
+{
+ my @l = return_list();
+}
+else
+{
+ return_void();
+ $y++;
+}
+
Copied: trunk/contrib/perl/lib/perl5db/t/test-a-statement-1 (from rev 6437, vendor/perl/5.18.1/lib/perl5db/t/test-a-statement-1)
===================================================================
--- trunk/contrib/perl/lib/perl5db/t/test-a-statement-1 (rev 0)
+++ trunk/contrib/perl/lib/perl5db/t/test-a-statement-1 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,22 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+while (my $l = <DATA>) {
+ chomp $l;
+ print "$l\n";
+}
+
+__DATA__
+123456789012 This is a test
+3456789012345This is another test
+6789012345678This is yet another test
+9012345678901Is this yet another test?
+234567890123 Yes, this is another test.
+4567890123456I think this is a test.
+7890123456789Now is the time.
+0123456789012For all good men.
+3456789012345To come to the aid party.
+678901234678 This is the tenth line.
+
Copied: trunk/contrib/perl/lib/perl5db/t/test-dieLevel-option-1 (from rev 6437, vendor/perl/5.18.1/lib/perl5db/t/test-dieLevel-option-1)
===================================================================
--- trunk/contrib/perl/lib/perl5db/t/test-dieLevel-option-1 (rev 0)
+++ trunk/contrib/perl/lib/perl5db/t/test-dieLevel-option-1 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,22 @@
+use strict;
+use warnings;
+
+sub foo
+{
+ print "In foo\n";
+ bar();
+}
+
+sub bar
+{
+ print "In baz\n";
+ baz();
+}
+
+sub baz
+{
+ die "This program dies.";
+}
+
+foo();
+
Copied: trunk/contrib/perl/lib/perl5db/t/test-frame-option-1 (from rev 6437, vendor/perl/5.18.1/lib/perl5db/t/test-frame-option-1)
===================================================================
--- trunk/contrib/perl/lib/perl5db/t/test-frame-option-1 (rev 0)
+++ trunk/contrib/perl/lib/perl5db/t/test-frame-option-1 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,26 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+sub my_func
+{
+ my ($num1, $num2) = @_;
+
+ print $num1+$num2, "\n";
+
+ my_other_func ($num1*3, $num2*24);
+
+ return $num1*$num2;
+}
+
+sub my_other_func
+{
+ my ($num1, $num2) = @_;
+
+ print "my_other_func: n1=<$num1> n2=<$num2>\n";
+
+ return $num1 * $num2;
+}
+
+my_func(1, 50);
Copied: trunk/contrib/perl/lib/perl5db/t/test-l-statement-1 (from rev 6437, vendor/perl/5.18.1/lib/perl5db/t/test-l-statement-1)
===================================================================
--- trunk/contrib/perl/lib/perl5db/t/test-l-statement-1 (rev 0)
+++ trunk/contrib/perl/lib/perl5db/t/test-l-statement-1 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,20 @@
+$x = 1;
+print "1\n";
+
+$x = 2;
+print "2\n";
+
+$x = 3;
+print "3\n";
+
+$x = 4;
+print "4\n";
+
+$x = 5;
+print "5\n";
+
+$x = 6;
+print "6\n";
+
+$x = 7;
+print "7\n";
Copied: trunk/contrib/perl/lib/perl5db/t/test-l-statement-2 (from rev 6437, vendor/perl/5.18.1/lib/perl5db/t/test-l-statement-2)
===================================================================
--- trunk/contrib/perl/lib/perl5db/t/test-l-statement-2 (rev 0)
+++ trunk/contrib/perl/lib/perl5db/t/test-l-statement-2 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,24 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+sub fact {
+ my $n = shift;
+ if ($n > 1) {
+ return $n * fact($n - 1);
+ } else {
+ return 1;
+ }
+}
+
+sub bar {
+ print "One\n";
+ print "Two\n";
+ print "Three\n";
+
+ return;
+}
+
+fact(5);
+bar();
Copied: trunk/contrib/perl/lib/perl5db/t/test-m-statement-1 (from rev 6437, vendor/perl/5.18.1/lib/perl5db/t/test-m-statement-1)
===================================================================
--- trunk/contrib/perl/lib/perl5db/t/test-m-statement-1 (rev 0)
+++ trunk/contrib/perl/lib/perl5db/t/test-m-statement-1 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,43 @@
+use strict;
+use warnings;
+
+package MyClass;
+
+sub new
+{
+ my $class = shift;
+
+ my $self = bless {}, $class;
+
+ $self->_init(@_);
+
+ return $self;
+}
+
+sub _init
+{
+ my $self = shift;
+
+ $self->{foo} = 'bar';
+
+ return;
+}
+
+sub greet
+{
+ my ($self, $msg) = @_;
+
+ print "$msg - $self->{foo}\n";
+
+ return;
+}
+
+1;
+
+package main;
+
+my $obj = MyClass->new;
+
+$obj->greet("Hello");
+
+1;
Copied: trunk/contrib/perl/lib/perl5db/t/test-passing-at-underscore-to-x-etc (from rev 6437, vendor/perl/5.18.1/lib/perl5db/t/test-passing-at-underscore-to-x-etc)
===================================================================
--- trunk/contrib/perl/lib/perl5db/t/test-passing-at-underscore-to-x-etc (rev 0)
+++ trunk/contrib/perl/lib/perl5db/t/test-passing-at-underscore-to-x-etc 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,15 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+print "One\n";
+
+sub my_pass_args_to
+{
+ print "Two\n";
+}
+
+my_pass_args_to ("Arg1", "Capsula", "GreekHumor", "Socrates");
+
+print "Three\n";
Copied: trunk/contrib/perl/lib/perl5db/t/test-r-statement (from rev 6437, vendor/perl/5.18.1/lib/perl5db/t/test-r-statement)
===================================================================
--- trunk/contrib/perl/lib/perl5db/t/test-r-statement (rev 0)
+++ trunk/contrib/perl/lib/perl5db/t/test-r-statement 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,27 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+my $var = "Test";
+
+sub mysub
+{
+ my $flag = 1;
+
+ $flag = 0;
+
+ print "Foo\n";
+
+ if ($flag)
+ {
+ print "Bar\n";
+ }
+
+ return;
+}
+
+mysub();
+
+$var .= "More";
+
Copied: trunk/contrib/perl/lib/perl5db/t/test-w-statement-1 (from rev 6437, vendor/perl/5.18.1/lib/perl5db/t/test-w-statement-1)
===================================================================
--- trunk/contrib/perl/lib/perl5db/t/test-w-statement-1 (rev 0)
+++ trunk/contrib/perl/lib/perl5db/t/test-w-statement-1 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,20 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use vars qw($foo);
+
+$foo = 1;
+
+print "Hello\n";
+
+for my $idx (map { $_ * 10 } 1 .. 10)
+{
+ if ($idx > 17)
+ {
+ $foo = 2;
+ print "Baz\n";
+ }
+}
+
Copied: trunk/contrib/perl/lib/perl5db/t/test-warnLevel-option-1 (from rev 6437, vendor/perl/5.18.1/lib/perl5db/t/test-warnLevel-option-1)
===================================================================
--- trunk/contrib/perl/lib/perl5db/t/test-warnLevel-option-1 (rev 0)
+++ trunk/contrib/perl/lib/perl5db/t/test-warnLevel-option-1 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,29 @@
+use strict;
+use warnings;
+
+sub foo
+{
+ print "In foo\n";
+ bar();
+}
+
+sub bar
+{
+ print "In baz\n";
+ baz();
+}
+
+sub baz
+{
+ warn "This is not a warning.";
+
+ return;
+}
+
+sub myfunc
+{
+ bar();
+}
+
+myfunc();
+
Copied: trunk/contrib/perl/lib/perl5db/t/uncalled-subroutine (from rev 6437, vendor/perl/5.18.1/lib/perl5db/t/uncalled-subroutine)
===================================================================
--- trunk/contrib/perl/lib/perl5db/t/uncalled-subroutine (rev 0)
+++ trunk/contrib/perl/lib/perl5db/t/uncalled-subroutine 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,11 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+exit(0);
+
+sub uncalled_subroutine
+{
+ print '<', join(',', 1 .. 5), ">\n";
+}
Copied: trunk/contrib/perl/lib/perl5db/t/with-subroutine (from rev 6437, vendor/perl/5.18.1/lib/perl5db/t/with-subroutine)
===================================================================
--- trunk/contrib/perl/lib/perl5db/t/with-subroutine (rev 0)
+++ trunk/contrib/perl/lib/perl5db/t/with-subroutine 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,17 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+my $x = 'hello world';
+
+print "$x\n";
+
+back();
+
+exit;
+
+sub back {
+ print "hello back\n";
+}
+
Modified: trunk/contrib/perl/lib/perl5db.pl
===================================================================
--- trunk/contrib/perl/lib/perl5db.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/perl5db.pl 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,5 +1,5 @@
-=head1 NAME
+=head1 NAME
perl5db.pl - the perl debugger
@@ -22,7 +22,7 @@
When the debugger was first written, Perl didn't have a lot of its nicer
features - no references, no lexical variables, no closures, no object-oriented
programming. So a lot of the things one would normally have done using such
-features was done using global variables, globs and the C<local()> operator
+features was done using global variables, globs and the C<local()> operator
in creative ways.
Some of these have survived into the current debugger; a few of the more
@@ -34,7 +34,7 @@
Experienced Perl programmers will note that the debugger code tends to use
mostly package globals rather than lexically-scoped variables. This is done
to allow a significant amount of control of the debugger from outside the
-debugger itself.
+debugger itself.
Unfortunately, though the variables are accessible, they're not well
documented, so it's generally been a decision that hasn't made a lot of
@@ -46,9 +46,9 @@
=head2 Automated variable stacking via C<local()>
-As you may recall from reading C<perlfunc>, the C<local()> operator makes a
+As you may recall from reading C<perlfunc>, the C<local()> operator makes a
temporary copy of a variable in the current scope. When the scope ends, the
-old copy is restored. This is often used in the debugger to handle the
+old copy is restored. This is often used in the debugger to handle the
automatic stacking of variables during recursive calls:
sub foo {
@@ -59,14 +59,14 @@
}
What happens is that on entry to the subroutine, C<$some_global> is localized,
-then altered. When the subroutine returns, Perl automatically undoes the
+then altered. When the subroutine returns, Perl automatically undoes the
localization, restoring the previous value. Voila, automatic stack management.
-The debugger uses this trick a I<lot>. Of particular note is C<DB::eval>,
+The debugger uses this trick a I<lot>. Of particular note is C<DB::eval>,
which lets the debugger get control inside of C<eval>'ed code. The debugger
localizes a saved copy of C<$@> inside the subroutine, which allows it to
keep C<$@> safe until it C<DB::eval> returns, at which point the previous
-value of C<$@> is restored. This makes it simple (well, I<simpler>) to keep
+value of C<$@> is restored. This makes it simple (well, I<simpler>) to keep
track of C<$@> inside C<eval>s which C<eval> other C<eval's>.
In any case, watch for this pattern. It occurs fairly often.
@@ -73,31 +73,31 @@
=head2 The C<^> trick
-This is used to cleverly reverse the sense of a logical test depending on
+This is used to cleverly reverse the sense of a logical test depending on
the value of an auxiliary variable. For instance, the debugger's C<S>
-(search for subroutines by pattern) allows you to negate the pattern
+(search for subroutines by pattern) allows you to negate the pattern
like this:
# Find all non-'foo' subs:
- S !/foo/
+ S !/foo/
Boolean algebra states that the truth table for XOR looks like this:
=over 4
-=item * 0 ^ 0 = 0
+=item * 0 ^ 0 = 0
(! not present and no match) --> false, don't print
-=item * 0 ^ 1 = 1
+=item * 0 ^ 1 = 1
(! not present and matches) --> true, print
-=item * 1 ^ 0 = 1
+=item * 1 ^ 0 = 1
(! present and no match) --> true, print
-=item * 1 ^ 1 = 0
+=item * 1 ^ 1 = 0
(! present and matches) --> false, don't print
@@ -105,7 +105,7 @@
As you can see, the first pair applies when C<!> isn't supplied, and
the second pair applies when it is. The XOR simply allows us to
-compact a more complicated if-then-elseif-else into a more elegant
+compact a more complicated if-then-elseif-else into a more elegant
(but perhaps overly clever) single test. After all, it needed this
explanation...
@@ -114,20 +114,20 @@
There is a certain C programming legacy in the debugger. Some variables,
such as C<$single>, C<$trace>, and C<$frame>, have I<magical> values composed
of 1, 2, 4, etc. (powers of 2) OR'ed together. This allows several pieces
-of state to be stored independently in a single scalar.
+of state to be stored independently in a single scalar.
A test like
if ($scalar & 4) ...
-is checking to see if the appropriate bit is on. Since each bit can be
+is checking to see if the appropriate bit is on. Since each bit can be
"addressed" independently in this way, C<$scalar> is acting sort of like
-an array of bits. Obviously, since the contents of C<$scalar> are just a
+an array of bits. Obviously, since the contents of C<$scalar> are just a
bit-pattern, we can save and restore it easily (it will just look like
a number).
The problem, is of course, that this tends to leave magic numbers scattered
-all over your program whenever a bit is set, cleared, or checked. So why do
+all over your program whenever a bit is set, cleared, or checked. So why do
it?
=over 4
@@ -137,24 +137,24 @@
First, doing an arithmetical or bitwise operation on a scalar is
just about the fastest thing you can do in Perl: C<use constant> actually
creates a subroutine call, and array and hash lookups are much slower. Is
-this over-optimization at the expense of readability? Possibly, but the
+this over-optimization at the expense of readability? Possibly, but the
debugger accesses these variables a I<lot>. Any rewrite of the code will
probably have to benchmark alternate implementations and see which is the
-best balance of readability and speed, and then document how it actually
+best balance of readability and speed, and then document how it actually
works.
=item *
-Second, it's very easy to serialize a scalar number. This is done in
+Second, it's very easy to serialize a scalar number. This is done in
the restart code; the debugger state variables are saved in C<%ENV> and then
restored when the debugger is restarted. Having them be just numbers makes
-this trivial.
+this trivial.
=item *
-Third, some of these variables are being shared with the Perl core
-smack in the middle of the interpreter's execution loop. It's much faster for
-a C program (like the interpreter) to check a bit in a scalar than to access
+Third, some of these variables are being shared with the Perl core
+smack in the middle of the interpreter's execution loop. It's much faster for
+a C program (like the interpreter) to check a bit in a scalar than to access
several different variables (or a Perl array).
=back
@@ -162,13 +162,13 @@
=head2 What are those C<XXX> comments for?
Any comment containing C<XXX> means that the comment is either somewhat
-speculative - it's not exactly clear what a given variable or chunk of
+speculative - it's not exactly clear what a given variable or chunk of
code is doing, or that it is incomplete - the basics may be clear, but the
subtleties are not completely documented.
Send in a patch if you can clear up, fill out, or clarify an C<XXX>.
-=head1 DATA STRUCTURES MAINTAINED BY CORE
+=head1 DATA STRUCTURES MAINTAINED BY CORE
There are a number of special data structures provided to the debugger by
the Perl interpreter.
@@ -179,17 +179,17 @@
breakable lines will be dualvars with the numeric component being the
memory address of a COP node. Non-breakable lines are dualvar to 0.
-The hash C<%{'_<'.$filename}> (aliased locally to C<%dbline> via glob
-assignment) contains breakpoints and actions. The keys are line numbers;
-you can set individual values, but not the whole hash. The Perl interpreter
+The hash C<%{'_<'.$filename}> (aliased locally to C<%dbline> via glob
+assignment) contains breakpoints and actions. The keys are line numbers;
+you can set individual values, but not the whole hash. The Perl interpreter
uses this hash to determine where breakpoints have been set. Any true value is
considered to be a breakpoint; C<perl5db.pl> uses C<$break_condition\0$action>.
Values are magical in numeric context: 1 if the line is breakable, 0 if not.
-The scalar C<${"_<$filename"}> simply contains the string C<_<$filename>.
+The scalar C<${"_<$filename"}> simply contains the string C<$filename>.
This is also the case for evaluated strings that contain subroutines, or
which are currently being executed. The $filename for C<eval>ed strings looks
-like C<(eval 34)> or C<(re_eval 19)>.
+like C<(eval 34).
=head1 DEBUGGER STARTUP
@@ -196,10 +196,10 @@
When C<perl5db.pl> starts, it reads an rcfile (C<perl5db.ini> for
non-interactive sessions, C<.perldb> for interactive ones) that can set a number
of options. In addition, this file may define a subroutine C<&afterinit>
-that will be executed (in the debugger's context) after the debugger has
+that will be executed (in the debugger's context) after the debugger has
initialized itself.
-Next, it checks the C<PERLDB_OPTS> environment variable and treats its
+Next, it checks the C<PERLDB_OPTS> environment variable and treats its
contents as the argument of a C<o> command in the debugger.
=head2 STARTUP-ONLY OPTIONS
@@ -210,11 +210,11 @@
=over 4
-=item * TTY
+=item * TTY
the TTY to use for debugging i/o.
-=item * noTTY
+=item * noTTY
if set, goes in NonStop mode. On interrupt, if TTY is not set,
uses the value of noTTY or F<$HOME/.perldbtty$$> to find TTY using
@@ -221,21 +221,21 @@
Term::Rendezvous. Current variant is to have the name of TTY in this
file.
-=item * ReadLine
+=item * ReadLine
if false, a dummy ReadLine is used, so you can debug
ReadLine applications.
-=item * NonStop
+=item * NonStop
if true, no i/o is performed until interrupt.
-=item * LineInfo
+=item * LineInfo
file or pipe to print line number info to. If it is a
pipe, a short "emacs like" message is used.
-=item * RemotePort
+=item * RemotePort
host:port to connect to on remote host for remote debugging.
@@ -279,9 +279,9 @@
=head4 C<$CreateTTY>
Used to control when the debugger will attempt to acquire another TTY to be
-used for input.
+used for input.
-=over
+=over
=item * 1 - on C<fork()>
@@ -304,7 +304,7 @@
=head4 C<$frame>
Determines what messages (if any) will get printed when a subroutine (or eval)
-is entered or exited.
+is entered or exited.
=over 4
@@ -328,8 +328,8 @@
=head4 C<$level>
-Tracks current debugger nesting level. Used to figure out how many
-C<E<lt>E<gt>> pairs to surround the line number with when the debugger
+Tracks current debugger nesting level. Used to figure out how many
+C<E<lt>E<gt>> pairs to surround the line number with when the debugger
outputs a prompt. Also used to help determine if the program has finished
during command parsing.
@@ -364,7 +364,7 @@
Controls behavior during single-stepping. Stacked in C<@stack> on entry to
each subroutine; popped again at the end of each subroutine.
-=over 4
+=over 4
=item * 0 - run continuously.
@@ -379,7 +379,7 @@
=head4 C<$trace>
-Controls the output of trace information.
+Controls the output of trace information.
=over 4
@@ -402,7 +402,7 @@
=head4 C<@dbline>
-Local alias to the magical line array, C<@{$main::{'_<'.$filename}}> ,
+Local alias to the magical line array, C<@{$main::{'_<'.$filename}}> ,
supplied by the Perl interpreter to the debugger. Contains the source.
=head4 C<@old_watch>
@@ -450,7 +450,7 @@
Keys are file names; values are bitfields:
-=over 4
+=over 4
=item * 1 - file has a breakpoint in it.
@@ -487,10 +487,10 @@
=head1 DEBUGGER INITIALIZATION
The debugger's initialization actually jumps all over the place inside this
-package. This is because there are several BEGIN blocks (which of course
-execute immediately) spread through the code. Why is that?
+package. This is because there are several BEGIN blocks (which of course
+execute immediately) spread through the code. Why is that?
-The debugger needs to be able to change some things and set some things up
+The debugger needs to be able to change some things and set some things up
before the debugger code is compiled; most notably, the C<$deep> variable that
C<DB::sub> uses to tell when a program has recursed deeply. In addition, the
debugger has to turn off warnings while the debugger code is compiled, but then
@@ -500,7 +500,7 @@
The first C<BEGIN> block simply turns off warnings by saving the current
setting of C<$^W> and then setting it to zero. The second one initializes
the debugger variables that are needed before the debugger begins executing.
-The third one puts C<$^X> back to its former value.
+The third one puts C<$^X> back to its former value.
We'll detail the second C<BEGIN> block later; just remember that if you need
to initialize something before the debugger starts really executing, that's
@@ -510,11 +510,21 @@
package DB;
-BEGIN {eval 'use IO::Handle'}; # Needed for flush only? breaks under miniperl
+use strict;
+BEGIN {eval 'use IO::Handle'}; # Needed for flush only? breaks under miniperl
+
+BEGIN {
+ require feature;
+ $^V =~ /^v(\d+\.\d+)/;
+ feature->import(":$1");
+}
+
# Debugger for Perl 5.00x; perl5db.pl patch level:
-$VERSION = '1.33';
+use vars qw($VERSION $header);
+$VERSION = '1.39_10';
+
$header = "perl5db.pl version $VERSION";
=head1 DEBUGGER ROUTINES
@@ -524,7 +534,7 @@
This function replaces straight C<eval()> inside the debugger; it simplifies
the process of evaluating code in the user's context.
-The code to be evaluated is passed via the package global variable
+The code to be evaluated is passed via the package global variable
C<$DB::evalarg>; this is done to avoid fiddling with the contents of C<@_>.
Before we do the C<eval()>, we preserve the current settings of C<$trace>,
@@ -535,19 +545,19 @@
restore C<$trace>, C<$single>, and C<$^D>.
Next we need to handle C<$@> without getting confused. We save C<$@> in a
-local lexical, localize C<$saved[0]> (which is where C<save()> will put
-C<$@>), and then call C<save()> to capture C<$@>, C<$!>, C<$^E>, C<$,>,
+local lexical, localize C<$saved[0]> (which is where C<save()> will put
+C<$@>), and then call C<save()> to capture C<$@>, C<$!>, C<$^E>, C<$,>,
C<$/>, C<$\>, and C<$^W>) and set C<$,>, C<$/>, C<$\>, and C<$^W> to values
-considered sane by the debugger. If there was an C<eval()> error, we print
-it on the debugger's output. If C<$onetimedump> is defined, we call
-C<dumpit> if it's set to 'dump', or C<methods> if it's set to
-'methods'. Setting it to something else causes the debugger to do the eval
-but not print the result - handy if you want to do something else with it
+considered sane by the debugger. If there was an C<eval()> error, we print
+it on the debugger's output. If C<$onetimedump> is defined, we call
+C<dumpit> if it's set to 'dump', or C<methods> if it's set to
+'methods'. Setting it to something else causes the debugger to do the eval
+but not print the result - handy if you want to do something else with it
(the "watch expressions" code does this to get the value of the watch
expression but not show it unless it matters).
-In any case, we then return the list of output from C<eval> to the caller,
-and unwinding restores the former version of C<$@> in C<@saved> as well
+In any case, we then return the list of output from C<eval> to the caller,
+and unwinding restores the former version of C<$@> in C<@saved> as well
(the localization of C<$saved[0]> goes away at the end of this scope).
=head3 Parameters and variables influencing execution of DB::eval()
@@ -554,7 +564,7 @@
C<DB::eval> isn't parameterized in the standard way; this is to keep the
debugger's calls to C<DB::eval()> from mucking with C<@_>, among other things.
-The variables listed below influence C<DB::eval()>'s execution directly.
+The variables listed below influence C<DB::eval()>'s execution directly.
=over 4
@@ -564,7 +574,7 @@
=item C<$single> - Current state of single-stepping
-=item C<$onetimeDump> - what is to be displayed after the evaluation
+=item C<$onetimeDump> - what is to be displayed after the evaluation
=item C<$onetimeDumpDepth> - how deep C<dumpit()> should go when dumping results
@@ -571,7 +581,7 @@
=back
The following variables are altered by C<DB::eval()> during its execution. They
-are "stacked" via C<local()>, enabling recursive calls to C<DB::eval()>.
+are "stacked" via C<local()>, enabling recursive calls to C<DB::eval()>.
=over 4
@@ -579,13 +589,13 @@
=item C<$otrace> - saved value of C<$trace>.
-=item C<$osingle> - saved value of C<$single>.
+=item C<$osingle> - saved value of C<$single>.
=item C<$od> - saved value of C<$^D>.
=item C<$saved[0]> - saved value of C<$@>.
-=item $\ - for output of C<$@> if there is an evaluation error.
+=item $\ - for output of C<$@> if there is an evaluation error.
=back
@@ -594,7 +604,7 @@
The context of C<DB::eval()> presents us with some problems. Obviously,
we want to be 'sandboxed' away from the debugger's internals when we do
the eval, but we need some way to control how punctuation variables and
-debugger globals are used.
+debugger globals are used.
We can't use local, because the code inside C<DB::eval> can see localized
variables; and we can't use C<my> either for the same reason. The code
@@ -614,6 +624,88 @@
# Fiddling with the debugger's context could be Bad. We insulate things as
# much as we can.
+use vars qw(
+ @args
+ %break_on_load
+ $CommandSet
+ $CreateTTY
+ $DBGR
+ @dbline
+ $dbline
+ %dbline
+ $dieLevel
+ $filename
+ $histfile
+ $histsize
+ $IN
+ $inhibit_exit
+ @ini_INC
+ $ini_warn
+ $maxtrace
+ $od
+ @options
+ $osingle
+ $otrace
+ $pager
+ $post
+ %postponed
+ $prc
+ $pre
+ $pretype
+ $psh
+ @RememberOnROptions
+ $remoteport
+ @res
+ $rl
+ @saved
+ $signalLevel
+ $sub
+ $term
+ $usercontext
+ $warnLevel
+);
+
+our (
+ @cmdfhs,
+ $evalarg,
+ $frame,
+ $hist,
+ $ImmediateStop,
+ $line,
+ $onetimeDump,
+ $onetimedumpDepth,
+ %option,
+ $OUT,
+ $packname,
+ $signal,
+ $single,
+ $start,
+ %sub,
+ $subname,
+ $trace,
+ $window,
+);
+
+# Used to save @ARGV and extract any debugger-related flags.
+use vars qw(@ARGS);
+
+# Used to prevent multiple entries to diesignal()
+# (if for instance diesignal() itself dies)
+use vars qw($panic);
+
+# Used to prevent the debugger from running nonstop
+# after a restart
+our ($second_time);
+
+sub _calc_usercontext {
+ my ($package) = @_;
+
+ # Cancel strict completely for the evaluated code, so the code
+ # the user evaluates won't be affected by it. (Shlomi Fish)
+ return 'no strict; ($@, $!, $^E, $,, $/, $\, $^W) = @DB::saved;'
+ . "package $package;"; # this won't let them modify, alas
+}
+
sub eval {
# 'my' would make it visible from user code
@@ -706,267 +798,7 @@
# Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
# Johan Vromans -- upgrade to 4.0 pl 10
# Ilya Zakharevich -- patches after 5.001 (and some before ;-)
-
-# (We have made efforts to clarify the comments in the change log
-# in other places; some of them may seem somewhat obscure as they
-# were originally written, and explaining them away from the code
-# in question seems conterproductive.. -JM)
-
########################################################################
-# Changes: 0.94
-# + A lot of things changed after 0.94. First of all, core now informs
-# debugger about entry into XSUBs, overloaded operators, tied operations,
-# BEGIN and END. Handy with `O f=2'.
-# + This can make debugger a little bit too verbose, please be patient
-# and report your problems promptly.
-# + Now the option frame has 3 values: 0,1,2. XXX Document!
-# + Note that if DESTROY returns a reference to the object (or object),
-# the deletion of data may be postponed until the next function call,
-# due to the need to examine the return value.
-#
-# Changes: 0.95
-# + `v' command shows versions.
-#
-# Changes: 0.96
-# + `v' command shows version of readline.
-# primitive completion works (dynamic variables, subs for `b' and `l',
-# options). Can `p %var'
-# + Better help (`h <' now works). New commands <<, >>, {, {{.
-# {dump|print}_trace() coded (to be able to do it from <<cmd).
-# + `c sub' documented.
-# + At last enough magic combined to stop after the end of debuggee.
-# + !! should work now (thanks to Emacs bracket matching an extra
-# `]' in a regexp is caught).
-# + `L', `D' and `A' span files now (as documented).
-# + Breakpoints in `require'd code are possible (used in `R').
-# + Some additional words on internal work of debugger.
-# + `b load filename' implemented.
-# + `b postpone subr' implemented.
-# + now only `q' exits debugger (overwritable on $inhibit_exit).
-# + When restarting debugger breakpoints/actions persist.
-# + Buglet: When restarting debugger only one breakpoint/action per
-# autoloaded function persists.
-#
-# Changes: 0.97: NonStop will not stop in at_exit().
-# + Option AutoTrace implemented.
-# + Trace printed differently if frames are printed too.
-# + new `inhibitExit' option.
-# + printing of a very long statement interruptible.
-# Changes: 0.98: New command `m' for printing possible methods
-# + 'l -' is a synonym for `-'.
-# + Cosmetic bugs in printing stack trace.
-# + `frame' & 8 to print "expanded args" in stack trace.
-# + Can list/break in imported subs.
-# + new `maxTraceLen' option.
-# + frame & 4 and frame & 8 granted.
-# + new command `m'
-# + nonstoppable lines do not have `:' near the line number.
-# + `b compile subname' implemented.
-# + Will not use $` any more.
-# + `-' behaves sane now.
-# Changes: 0.99: Completion for `f', `m'.
-# + `m' will remove duplicate names instead of duplicate functions.
-# + `b load' strips trailing whitespace.
-# completion ignores leading `|'; takes into account current package
-# when completing a subroutine name (same for `l').
-# Changes: 1.07: Many fixed by tchrist 13-March-2000
-# BUG FIXES:
-# + Added bare minimal security checks on perldb rc files, plus
-# comments on what else is needed.
-# + Fixed the ornaments that made "|h" completely unusable.
-# They are not used in print_help if they will hurt. Strip pod
-# if we're paging to less.
-# + Fixed mis-formatting of help messages caused by ornaments
-# to restore Larry's original formatting.
-# + Fixed many other formatting errors. The code is still suboptimal,
-# and needs a lot of work at restructuring. It's also misindented
-# in many places.
-# + Fixed bug where trying to look at an option like your pager
-# shows "1".
-# + Fixed some $? processing. Note: if you use csh or tcsh, you will
-# lose. You should consider shell escapes not using their shell,
-# or else not caring about detailed status. This should really be
-# unified into one place, too.
-# + Fixed bug where invisible trailing whitespace on commands hoses you,
-# tricking Perl into thinking you weren't calling a debugger command!
-# + Fixed bug where leading whitespace on commands hoses you. (One
-# suggests a leading semicolon or any other irrelevant non-whitespace
-# to indicate literal Perl code.)
-# + Fixed bugs that ate warnings due to wrong selected handle.
-# + Fixed a precedence bug on signal stuff.
-# + Fixed some unseemly wording.
-# + Fixed bug in help command trying to call perl method code.
-# + Fixed to call dumpvar from exception handler. SIGPIPE killed us.
-# ENHANCEMENTS:
-# + Added some comments. This code is still nasty spaghetti.
-# + Added message if you clear your pre/post command stacks which was
-# very easy to do if you just typed a bare >, <, or {. (A command
-# without an argument should *never* be a destructive action; this
-# API is fundamentally screwed up; likewise option setting, which
-# is equally buggered.)
-# + Added command stack dump on argument of "?" for >, <, or {.
-# + Added a semi-built-in doc viewer command that calls man with the
-# proper %Config::Config path (and thus gets caching, man -k, etc),
-# or else perldoc on obstreperous platforms.
-# + Added to and rearranged the help information.
-# + Detected apparent misuse of { ... } to declare a block; this used
-# to work but now is a command, and mysteriously gave no complaint.
-#
-# Changes: 1.08: Apr 25, 2001 Jon Eveland <jweveland at yahoo.com>
-# BUG FIX:
-# + This patch to perl5db.pl cleans up formatting issues on the help
-# summary (h h) screen in the debugger. Mostly columnar alignment
-# issues, plus converted the printed text to use all spaces, since
-# tabs don't seem to help much here.
-#
-# Changes: 1.09: May 19, 2001 Ilya Zakharevich <ilya at math.ohio-state.edu>
-# Minor bugs corrected;
-# + Support for auto-creation of new TTY window on startup, either
-# unconditionally, or if started as a kid of another debugger session;
-# + New `O'ption CreateTTY
-# I<CreateTTY> bits control attempts to create a new TTY on events:
-# 1: on fork()
-# 2: debugger is started inside debugger
-# 4: on startup
-# + Code to auto-create a new TTY window on OS/2 (currently one
-# extra window per session - need named pipes to have more...);
-# + Simplified interface for custom createTTY functions (with a backward
-# compatibility hack); now returns the TTY name to use; return of ''
-# means that the function reset the I/O handles itself;
-# + Better message on the semantic of custom createTTY function;
-# + Convert the existing code to create a TTY into a custom createTTY
-# function;
-# + Consistent support for TTY names of the form "TTYin,TTYout";
-# + Switch line-tracing output too to the created TTY window;
-# + make `b fork' DWIM with CORE::GLOBAL::fork;
-# + High-level debugger API cmd_*():
-# cmd_b_load($filenamepart) # b load filenamepart
-# cmd_b_line($lineno [, $cond]) # b lineno [cond]
-# cmd_b_sub($sub [, $cond]) # b sub [cond]
-# cmd_stop() # Control-C
-# cmd_d($lineno) # d lineno (B)
-# The cmd_*() API returns FALSE on failure; in this case it outputs
-# the error message to the debugging output.
-# + Low-level debugger API
-# break_on_load($filename) # b load filename
-# @files = report_break_on_load() # List files with load-breakpoints
-# breakable_line_in_filename($name, $from [, $to])
-# # First breakable line in the
-# # range $from .. $to. $to defaults
-# # to $from, and may be less than
-# # $to
-# breakable_line($from [, $to]) # Same for the current file
-# break_on_filename_line($name, $lineno [, $cond])
-# # Set breakpoint,$cond defaults to
-# # 1
-# break_on_filename_line_range($name, $from, $to [, $cond])
-# # As above, on the first
-# # breakable line in range
-# break_on_line($lineno [, $cond]) # As above, in the current file
-# break_subroutine($sub [, $cond]) # break on the first breakable line
-# ($name, $from, $to) = subroutine_filename_lines($sub)
-# # The range of lines of the text
-# The low-level API returns TRUE on success, and die()s on failure.
-#
-# Changes: 1.10: May 23, 2001 Daniel Lewart <d-lewart at uiuc.edu>
-# BUG FIXES:
-# + Fixed warnings generated by "perl -dWe 42"
-# + Corrected spelling errors
-# + Squeezed Help (h) output into 80 columns
-#
-# Changes: 1.11: May 24, 2001 David Dyck <dcd at tc.fluke.com>
-# + Made "x @INC" work like it used to
-#
-# Changes: 1.12: May 24, 2001 Daniel Lewart <d-lewart at uiuc.edu>
-# + Fixed warnings generated by "O" (Show debugger options)
-# + Fixed warnings generated by "p 42" (Print expression)
-# Changes: 1.13: Jun 19, 2001 Scott.L.Miller at compaq.com
-# + Added windowSize option
-# Changes: 1.14: Oct 9, 2001 multiple
-# + Clean up after itself on VMS (Charles Lane in 12385)
-# + Adding "@ file" syntax (Peter Scott in 12014)
-# + Debug reloading selfloaded stuff (Ilya Zakharevich in 11457)
-# + $^S and other debugger fixes (Ilya Zakharevich in 11120)
-# + Forgot a my() declaration (Ilya Zakharevich in 11085)
-# Changes: 1.15: Nov 6, 2001 Michael G Schwern <schwern at pobox.com>
-# + Updated 1.14 change log
-# + Added *dbline explanatory comments
-# + Mentioning perldebguts man page
-# Changes: 1.16: Feb 15, 2002 Mark-Jason Dominus <mjd at plover.com>
-# + $onetimeDump improvements
-# Changes: 1.17: Feb 20, 2002 Richard Foley <richard.foley at rfi.net>
-# Moved some code to cmd_[.]()'s for clarity and ease of handling,
-# rationalised the following commands and added cmd_wrapper() to
-# enable switching between old and frighteningly consistent new
-# behaviours for diehards: 'o CommandSet=pre580' (sigh...)
-# a(add), A(del) # action expr (added del by line)
-# + b(add), B(del) # break [line] (was b,D)
-# + w(add), W(del) # watch expr (was W,W)
-# # added del by expr
-# + h(summary), h h(long) # help (hh) (was h h,h)
-# + m(methods), M(modules) # ... (was m,v)
-# + o(option) # lc (was O)
-# + v(view code), V(view Variables) # ... (was w,V)
-# Changes: 1.18: Mar 17, 2002 Richard Foley <richard.foley at rfi.net>
-# + fixed missing cmd_O bug
-# Changes: 1.19: Mar 29, 2002 Spider Boardman
-# + Added missing local()s -- DB::DB is called recursively.
-# Changes: 1.20: Feb 17, 2003 Richard Foley <richard.foley at rfi.net>
-# + pre'n'post commands no longer trashed with no args
-# + watch val joined out of eval()
-# Changes: 1.21: Jun 04, 2003 Joe McMahon <mcmahon at ibiblio.org>
-# + Added comments and reformatted source. No bug fixes/enhancements.
-# + Includes cleanup by Robin Barker and Jarkko Hietaniemi.
-# Changes: 1.22 Jun 09, 2003 Alex Vandiver <alexmv at MIT.EDU>
-# + Flush stdout/stderr before the debugger prompt is printed.
-# Changes: 1.23: Dec 21, 2003 Dominique Quatravaux
-# + Fix a side-effect of bug #24674 in the perl debugger ("odd taint bug")
-# Changes: 1.24: Mar 03, 2004 Richard Foley <richard.foley at rfi.net>
-# + Added command to save all debugger commands for sourcing later.
-# + Added command to display parent inheritance tree of given class.
-# + Fixed minor newline in history bug.
-# Changes: 1.25: Apr 17, 2004 Richard Foley <richard.foley at rfi.net>
-# + Fixed option bug (setting invalid options + not recognising valid short forms)
-# Changes: 1.26: Apr 22, 2004 Richard Foley <richard.foley at rfi.net>
-# + unfork the 5.8.x and 5.9.x debuggers.
-# + whitespace and assertions call cleanup across versions
-# + H * deletes (resets) history
-# + i now handles Class + blessed objects
-# Changes: 1.27: May 09, 2004 Richard Foley <richard.foley at rfi.net>
-# + updated pod page references - clunky.
-# + removed windowid restriction for forking into an xterm.
-# + more whitespace again.
-# + wrapped restart and enabled rerun [-n] (go back n steps) command.
-# Changes: 1.28: Oct 12, 2004 Richard Foley <richard.foley at rfi.net>
-# + Added threads support (inc. e and E commands)
-# Changes: 1.29: Nov 28, 2006 Bo Lindbergh <blgl at hagernas.com>
-# + Added macosx_get_fork_TTY support
-# Changes: 1.30: Mar 06, 2007 Andreas Koenig <andk at cpan.org>
-# + Added HistFile, HistSize
-# Changes: 1.31
-# + Remove support for assertions and -A
-# + stop NEXT::AUTOLOAD from emitting warnings under the debugger. RT #25053
-# + "update for Mac OS X 10.5" [finding the tty device]
-# + "What I needed to get the forked debugger to work" [on VMS]
-# + [perl #57016] debugger: o warn=0 die=0 ignored
-# + Note, but don't use, PERLDBf_SAVESRC
-# + Fix #7013: lvalue subs not working inside debugger
-# Changes: 1.32: Jun 03, 2009 Jonathan Leto <jonathan at leto.net>
-# + Fix bug where a key _< with undefined value was put into the symbol table
-# + when the $filename variable is not set
-# Changes: 1.33:
-# + Debugger prints lines to the remote port when it forks and openes a new port (f633fd2)
-# + The debugger now continues to use RemotePort when it's been configured to use it. (11653f7)
-# + Stop using $ENV{LESS} for parameters not intended for less (d463cf2)
-# + Configure has a path to less and perl5db.pl can use it (bf320d6)
-# + Die with $@ instead of empty message (86755f4)
-# + Remove extra/useless $@ check after eval { require PadWalker } (which is still checked) (dab8d6d)
-# + Promote eval( "require ..." ) to eval { require ... } (4a49187)
-# + Promote eval { require( ... )} || die to mere require( ... ) (999f23b)
-# + Remove indirect object notation from debugger (bee4b46)
-# + Document that @{$main::{'_<'.$filename}} lines are dualvar to (COP*). (7e17a74)
-# + Remove MacOS classic support from the debugger. (2b894b7)
-########################################################################
=head1 DEBUGGER INITIALIZATION
@@ -1004,7 +836,7 @@
you of each new thread created. It will also indicate the thread id in which
we are currently running within the prompt like this:
- [tid] DB<$i>
+ [tid] DB<$i>
Where C<[tid]> is an integer thread id and C<$i> is the familiar debugger
command prompt. The prompt will show: C<[0]> when running under threads, but
@@ -1011,7 +843,7 @@
not actually in a thread. C<[tid]> is consistent with C<gdb> usage.
While running under threads, when you set or delete a breakpoint (etc.), this
-will apply to all threads, not just the currently running one. When you are
+will apply to all threads, not just the currently running one. When you are
in a currently executing thread, you will stay there until it completes. With
the current implementation it is not currently possible to hop from one thread
to another.
@@ -1024,56 +856,43 @@
=cut
BEGIN {
- # ensure we can share our non-threaded variables or no-op
- if ($ENV{PERL5DB_THREADED}) {
- require threads;
- require threads::shared;
- import threads::shared qw(share);
- $DBGR;
- share(\$DBGR);
- lock($DBGR);
- print "Threads support enabled\n";
- } else {
- *lock = sub(*) {};
- *share = sub(*) {};
- }
+ # ensure we can share our non-threaded variables or no-op
+ if ($ENV{PERL5DB_THREADED}) {
+ require threads;
+ require threads::shared;
+ import threads::shared qw(share);
+ $DBGR;
+ share(\$DBGR);
+ lock($DBGR);
+ print "Threads support enabled\n";
+ } else {
+ *share = sub(\[$@%]) {};
+ }
}
-# This would probably be better done with "use vars", but that wasn't around
-# when this code was originally written. (Neither was "use strict".) And on
-# the principle of not fiddling with something that was working, this was
-# left alone.
-warn( # Do not ;-)
- # These variables control the execution of 'dumpvar.pl'.
- $dumpvar::hashDepth,
- $dumpvar::arrayDepth,
- $dumpvar::dumpDBFiles,
- $dumpvar::dumpPackages,
- $dumpvar::quoteHighBit,
- $dumpvar::printUndef,
- $dumpvar::globPrint,
- $dumpvar::usageOnly,
+# These variables control the execution of 'dumpvar.pl'.
+{
+ package dumpvar;
+ use vars qw(
+ $hashDepth
+ $arrayDepth
+ $dumpDBFiles
+ $dumpPackages
+ $quoteHighBit
+ $printUndef
+ $globPrint
+ $usageOnly
+ );
+}
- # used to save @ARGV and extract any debugger-related flags.
- @ARGS,
+# used to control die() reporting in diesignal()
+{
+ package Carp;
+ use vars qw($CarpLevel);
+}
- # used to control die() reporting in diesignal()
- $Carp::CarpLevel,
-
- # used to prevent multiple entries to diesignal()
- # (if for instance diesignal() itself dies)
- $panic,
-
- # used to prevent the debugger from running nonstop
- # after a restart
- $second_time,
- )
- if 0;
-
# without threads, $filename is not defined until DB::DB is called
-foreach my $k (keys (%INC)) {
- &share(\$main::{'_<'.$filename}) if defined $filename;
-};
+share($main::{'_<'.$filename}) if defined $filename;
# Command-line + PERLLIB:
# Save the contents of @INC before they are modified elsewhere.
@@ -1092,10 +911,15 @@
# value when the 'r' command is used to return from a subroutine.
$inhibit_exit = $option{PrintRet} = 1;
+use vars qw($trace_to_depth);
+
+# Default to 1E9 so it won't be limited to a certain recursion depth.
+$trace_to_depth = 1E9;
+
=head1 OPTION PROCESSING
-The debugger's options are actually spread out over the debugger itself and
-C<dumpvar.pl>; some of these are variables to be set, while others are
+The debugger's options are actually spread out over the debugger itself and
+C<dumpvar.pl>; some of these are variables to be set, while others are
subs to be called with a value. To try to make this a little easier to
manage, the debugger uses a few data structures to define what options
are legal and how they are to be processed.
@@ -1131,6 +955,8 @@
=cut
+use vars qw(%optionVars);
+
%optionVars = (
hashDepth => \$dumpvar::hashDepth,
arrayDepth => \$dumpvar::arrayDepth,
@@ -1160,8 +986,10 @@
Third, C<%optionAction> defines the subroutine to be called to process each
option.
-=cut
+=cut
+use vars qw(%optionAction);
+
%optionAction = (
compactDump => \&dumpvar::compactDump,
veryCompact => \&dumpvar::veryCompact,
@@ -1195,6 +1023,8 @@
# not in the table. A subsequent patch will correct this problem; for
# the moment, we're just recommenting, and we are NOT going to change
# function.
+use vars qw(%optionRequire);
+
%optionRequire = (
compactDump => 'dumpvar.pl',
veryCompact => 'dumpvar.pl',
@@ -1302,8 +1132,8 @@
# Set up defaults for command recall and shell escape (note:
# these currently don't work in linemode debugging).
-&recallCommand("!") unless defined $prc;
-&shellBang("!") unless defined $psh;
+recallCommand("!") unless defined $prc;
+shellBang("!") unless defined $psh;
=pod
@@ -1341,8 +1171,11 @@
# Save the current contents of the environment; we're about to
# much with it. We'll need this if we have to restart.
+use vars qw($ini_pids);
$ini_pids = $ENV{PERLDB_PIDS};
+use vars qw ($pids $term_pid);
+
if ( defined $ENV{PERLDB_PIDS} ) {
# We're a child. Make us a label out of the current PID structure
@@ -1374,29 +1207,29 @@
$term_pid = $$;
}
+use vars qw($pidprompt);
$pidprompt = '';
# Sets up $emacs as a synonym for $slave_editor.
+our ($slave_editor);
*emacs = $slave_editor if $slave_editor; # May be used in afterinit()...
=head2 READING THE RC FILE
-The debugger will read a file of initialization options if supplied. If
+The debugger will read a file of initialization options if supplied. If
running interactively, this is C<.perldb>; if not, it's C<perldb.ini>.
-=cut
+=cut
# As noted, this test really doesn't check accurately that the debugger
# is running at a terminal or not.
-my $dev_tty = '/dev/tty';
- $dev_tty = 'TT:' if ($^O eq 'VMS');
-if ( -e $dev_tty ) { # this is the wrong metric!
- $rcfile = ".perldb";
+use vars qw($rcfile);
+{
+ my $dev_tty = (($^O eq 'VMS') ? 'TT:' : '/dev/tty');
+ # this is the wrong metric!
+ $rcfile = ((-e $dev_tty) ? ".perldb" : "perldb.ini");
}
-else {
- $rcfile = "perldb.ini";
-}
=pod
@@ -1422,7 +1255,7 @@
unless ( is_safe_file($file) ) {
CORE::warn <<EO_GRIPE;
perldb: Must not source insecure rcfile $file.
- You or the superuser must be the owner, and it must not
+ You or the superuser must be the owner, and it must not
be writable by anyone but its owner.
EO_GRIPE
return;
@@ -1475,7 +1308,7 @@
The last thing we do during initialization is determine which subroutine is
to be used to obtain a new terminal when a new debugger is started. Right now,
-the debugger only handles TCP sockets, X Windows, OS/2, amd Mac OS X
+the debugger only handles TCP sockets, X11, OS/2, amd Mac OS X
(darwin).
=cut
@@ -1486,7 +1319,7 @@
if (not defined &get_fork_TTY) # only if no routine exists
{
- if ( defined $remoteport ) {
+ if ( defined $remoteport ) {
# Expect an inetd-like server
*get_fork_TTY = \&socket_get_fork_TTY; # to listen to us
}
@@ -1526,7 +1359,7 @@
if C<PERLDB_RESTART> is there; if so, we reload all the information that
the R command stuffed into the environment variables.
- PERLDB_RESTART - flag only, contains no restart data itself.
+ PERLDB_RESTART - flag only, contains no restart data itself.
PERLDB_HIST - command history, if it's available
PERLDB_ON_LOAD - breakpoints set by the rc file
PERLDB_POSTPONE - subs that have been loaded/not executed, and have actions
@@ -1544,36 +1377,58 @@
=cut
-if ( exists $ENV{PERLDB_RESTART} ) {
+use vars qw(%postponed_file @typeahead);
- # We're restarting, so we don't need the flag that says to restart anymore.
- delete $ENV{PERLDB_RESTART};
+our (@hist, @truehist);
- # $restart = 1;
+sub _restore_shared_globals_after_restart
+{
@hist = get_list('PERLDB_HIST');
%break_on_load = get_list("PERLDB_ON_LOAD");
%postponed = get_list("PERLDB_POSTPONE");
- share(@hist);
- share(@truehist);
- share(%break_on_load);
- share(%postponed);
+ share(@hist);
+ share(@truehist);
+ share(%break_on_load);
+ share(%postponed);
+}
- # restore breakpoints/actions
+sub _restore_breakpoints_and_actions {
+
my @had_breakpoints = get_list("PERLDB_VISITED");
- for ( 0 .. $#had_breakpoints ) {
- my %pf = get_list("PERLDB_FILE_$_");
- $postponed_file{ $had_breakpoints[$_] } = \%pf if %pf;
+
+ for my $file_idx ( 0 .. $#had_breakpoints ) {
+ my $filename = $had_breakpoints[$file_idx];
+ my %pf = get_list("PERLDB_FILE_$file_idx");
+ $postponed_file{ $filename } = \%pf if %pf;
+ my @lines = sort {$a <=> $b} keys(%pf);
+ my @enabled_statuses = get_list("PERLDB_FILE_ENABLED_$file_idx");
+ for my $line_idx (0 .. $#lines) {
+ _set_breakpoint_enabled_status(
+ $filename,
+ $lines[$line_idx],
+ ($enabled_statuses[$line_idx] ? 1 : ''),
+ );
+ }
}
- # restore options
- my %opt = get_list("PERLDB_OPT");
- my ( $opt, $val );
- while ( ( $opt, $val ) = each %opt ) {
+ return;
+}
+
+sub _restore_options_after_restart
+{
+ my %options_map = get_list("PERLDB_OPT");
+
+ while ( my ( $opt, $val ) = each %options_map ) {
$val =~ s/[\\\']/\\$1/g;
parse_options("$opt'$val'");
}
+ return;
+}
+
+sub _restore_globals_after_restart
+{
# restore original @INC
@INC = get_list("PERLDB_INC");
@ini_INC = @INC;
@@ -1583,6 +1438,25 @@
$pre = [ get_list("PERLDB_PRE") ];
$post = [ get_list("PERLDB_POST") ];
@typeahead = get_list( "PERLDB_TYPEAHEAD", @typeahead );
+
+ return;
+}
+
+
+if ( exists $ENV{PERLDB_RESTART} ) {
+
+ # We're restarting, so we don't need the flag that says to restart anymore.
+ delete $ENV{PERLDB_RESTART};
+
+ # $restart = 1;
+ _restore_shared_globals_after_restart();
+
+ _restore_breakpoints_and_actions();
+
+ # restore options
+ _restore_options_after_restart();
+
+ _restore_globals_after_restart();
} ## end if (exists $ENV{PERLDB_RESTART...
=head2 SETTING UP THE TERMINAL
@@ -1593,9 +1467,23 @@
=cut
+use vars qw($notty $console $tty $LINEINFO);
+use vars qw($lineinfo $doccmd);
+
+our ($runnonstop);
+
+# Local autoflush to avoid rt#116769,
+# as calling IO::File methods causes an unresolvable loop
+# that results in debugger failure.
+sub _autoflush {
+ my $o = select($_[0]);
+ $|++;
+ select($o);
+}
+
if ($notty) {
$runnonstop = 1;
- share($runnonstop);
+ share($runnonstop);
}
=pod
@@ -1611,9 +1499,10 @@
# Is Perl being run from a slave editor or graphical debugger?
# If so, don't use readline, and set $slave_editor = 1.
- $slave_editor =
- ( ( defined $main::ARGV[0] ) and ( $main::ARGV[0] eq '-emacs' ) );
- $rl = 0, shift(@main::ARGV) if $slave_editor;
+ if ($slave_editor = ( @main::ARGV && ( $main::ARGV[0] eq '-emacs' ) )) {
+ $rl = 0;
+ shift(@main::ARGV);
+ }
#require Term::ReadLine;
@@ -1633,7 +1522,7 @@
undef $console;
}
-=item * Unix - use C</dev/tty>.
+=item * Unix - use F</dev/tty>.
=cut
@@ -1665,7 +1554,7 @@
Several other systems don't use a specific console. We C<undef $console>
for those (Windows using a slave editor/graphical debugger, NetWare, OS/2
-with a slave editor, Epoc).
+with a slave editor).
=cut
@@ -1688,11 +1577,6 @@
$console = undef;
}
- # EPOC also falls into the 'got to use STDIN' camp.
- if ( $^O eq 'epoc' ) {
- $console = undef;
- }
-
=pod
If there is a TTY hanging around from a parent, we use that as the console.
@@ -1701,7 +1585,7 @@
$console = $tty if defined $tty;
-=head2 SOCKET HANDLING
+=head2 SOCKET HANDLING
The debugger is capable of opening a socket and carrying out a debugging
session over the socket.
@@ -1773,13 +1657,14 @@
# Keep copies of the filehandles so that when the pager runs, it
# can close standard input without clobbering ours.
- $IN = \*IN, $OUT = \*OUT if $console or not defined $console;
+ if ($console or (not defined($console))) {
+ $IN = \*IN;
+ $OUT = \*OUT;
+ }
} ## end elsif (from if(defined $remoteport))
# Unbuffer DB::OUT. We need to see responses right away.
- my $previous = select($OUT);
- $| = 1; # for DB::OUT
- select($previous);
+ _autoflush($OUT);
# Line info goes to debugger output unless pointed elsewhere.
# Pointing elsewhere makes it possible for slave editors to
@@ -1787,8 +1672,8 @@
# and a I/O description to keep track of.
$LINEINFO = $OUT unless defined $LINEINFO;
$lineinfo = $console unless defined $lineinfo;
- # share($LINEINFO); # <- unable to share globs
- share($lineinfo); #
+ # share($LINEINFO); # <- unable to share globs
+ share($lineinfo); #
=pod
@@ -1812,7 +1697,7 @@
$slave_editor ? "enabled" : "available", ".\n"
);
print $OUT
-"\nEnter h or `h h' for help, or `$doccmd perldebug' for more help.\n\n";
+"\nEnter h or 'h h' for help, or '$doccmd perldebug' for more help.\n\n";
} ## end else [ if ($term_pid eq '-1')
} ## end unless ($runnonstop)
} ## end else [ if ($notty)
@@ -1820,20 +1705,22 @@
# XXX This looks like a bug to me.
# Why copy to @ARGS and then futz with @args?
@ARGS = @ARGV;
-for (@args) {
+# for (@args) {
# Make sure backslashes before single quotes are stripped out, and
# keep args unless they are numeric (XXX why?)
# s/\'/\\\'/g; # removed while not justified understandably
# s/(.*)/'$1'/ unless /^-?[\d.]+$/; # ditto
-}
+# }
# If there was an afterinit() sub defined, call it. It will get
# executed in our scope, so it can fiddle with debugger globals.
if ( defined &afterinit ) { # May be defined in $rcfile
- &afterinit();
+ afterinit();
}
# Inform us about "Stack dump during die enabled ..." in dieLevel().
+use vars qw($I_m_init);
+
$I_m_init = 1;
############################################################ Subroutines
@@ -1855,51 +1742,807 @@
=cut
-sub DB {
+# $cmd cannot be an our() variable unfortunately (possible perl bug?).
- # lock the debugger and get the thread id for the prompt
- lock($DBGR);
- my $tid;
- if ($ENV{PERL5DB_THREADED}) {
- $tid = eval { "[".threads->tid."]" };
- }
+use vars qw(
+ $action
+ $cmd
+ $file
+ $filename_ini
+ $finished
+ %had_breakpoints
+ $level
+ $max
+ $package
+ $try
+);
- # Check for whether we should be running continuously or not.
- # _After_ the perl program is compiled, $single is set to 1:
- if ( $single and not $second_time++ ) {
+our (
+ %alias,
+ $doret,
+ $end,
+ $fall_off_end,
+ $incr,
+ $laststep,
+ $rc,
+ $sh,
+ $stack_depth,
+ @stack,
+ @to_watch,
+ @old_watch,
+);
- # Options say run non-stop. Run until we get an interrupt.
- if ($runnonstop) { # Disable until signal
- # If there's any call stack in place, turn off single
- # stepping into subs throughout the stack.
- for ( $i = 0 ; $i <= $stack_depth ; ) {
- $stack[ $i++ ] &= ~1;
+sub _DB__determine_if_we_should_break
+{
+ # if we have something here, see if we should break.
+ # $stop is lexical and local to this block - $action on the other hand
+ # is global.
+ my $stop;
+
+ if ( $dbline{$line}
+ && _is_breakpoint_enabled($filename, $line)
+ && (( $stop, $action ) = split( /\0/, $dbline{$line} ) ) )
+ {
+
+ # Stop if the stop criterion says to just stop.
+ if ( $stop eq '1' ) {
+ $signal |= 1;
+ }
+
+ # It's a conditional stop; eval it in the user's context and
+ # see if we should stop. If so, remove the one-time sigil.
+ elsif ($stop) {
+ $evalarg = "\$DB::signal |= 1 if do {$stop}";
+ # The &-call is here to ascertain the mutability of @_.
+ &DB::eval;
+ # If the breakpoint is temporary, then delete its enabled status.
+ if ($dbline{$line} =~ s/;9($|\0)/$1/) {
+ _cancel_breakpoint_temp_enabled_status($filename, $line);
}
+ }
+ } ## end if ($dbline{$line} && ...
+}
- # And we are now no longer in single-step mode.
- $single = 0;
+sub _DB__is_finished {
+ if ($finished and $level <= 1) {
+ end_report();
+ return 1;
+ }
+ else {
+ return;
+ }
+}
- # If we simply returned at this point, we wouldn't get
- # the trace info. Fall on through.
- # return;
- } ## end if ($runnonstop)
+sub _DB__read_next_cmd
+{
+ my ($tid) = @_;
- elsif ($ImmediateStop) {
+ # We have a terminal, or can get one ...
+ if (!$term) {
+ setterm();
+ }
- # We are supposed to stop here; XXX probably a break.
- $ImmediateStop = 0; # We've processed it; turn it off
- $signal = 1; # Simulate an interrupt to force
- # us into the command loop
+ # ... and it belogs to this PID or we get one for this PID ...
+ if ($term_pid != $$) {
+ resetterm(1);
+ }
+
+ # ... and we got a line of command input ...
+ $cmd = DB::readline(
+ "$pidprompt $tid DB"
+ . ( '<' x $level )
+ . ( $#hist + 1 )
+ . ( '>' x $level ) . " "
+ );
+
+ return defined($cmd);
+}
+
+sub _DB__trim_command_and_return_first_component {
+ my ($obj) = @_;
+
+ $cmd =~ s/\A\s+//s; # trim annoying leading whitespace
+ $cmd =~ s/\s+\z//s; # trim annoying trailing whitespace
+
+ my ($verb, $args) = $cmd =~ m{\A(\S*)\s*(.*)}s;
+
+ $obj->cmd_verb($verb);
+ $obj->cmd_args($args);
+
+ return;
+}
+
+sub _DB__handle_f_command {
+ my ($obj) = @_;
+
+ if ($file = $obj->cmd_args) {
+ # help for no arguments (old-style was return from sub).
+ if ( !$file ) {
+ print $OUT
+ "The old f command is now the r command.\n"; # hint
+ print $OUT "The new f command switches filenames.\n";
+ next CMD;
+ } ## end if (!$file)
+
+ # if not in magic file list, try a close match.
+ if ( !defined $main::{ '_<' . $file } ) {
+ if ( ($try) = grep( m#^_<.*$file#, keys %main:: ) ) {
+ {
+ $try = substr( $try, 2 );
+ print $OUT "Choosing $try matching '$file':\n";
+ $file = $try;
+ }
+ } ## end if (($try) = grep(m#^_<.*$file#...
+ } ## end if (!defined $main::{ ...
+
+ # If not successfully switched now, we failed.
+ if ( !defined $main::{ '_<' . $file } ) {
+ print $OUT "No file matching '$file' is loaded.\n";
+ next CMD;
}
- } ## end if ($single and not $second_time...
- # If we're in single-step mode, or an interrupt (real or fake)
- # has occurred, turn off non-stop mode.
- $runnonstop = 0 if $single or $signal;
+ # We switched, so switch the debugger internals around.
+ elsif ( $file ne $filename ) {
+ *dbline = $main::{ '_<' . $file };
+ $max = $#dbline;
+ $filename = $file;
+ $start = 1;
+ $cmd = "l";
+ } ## end elsif ($file ne $filename)
+ # We didn't switch; say we didn't.
+ else {
+ print $OUT "Already in $file.\n";
+ next CMD;
+ }
+ }
+
+ return;
+}
+
+sub _DB__handle_dot_command {
+ my ($obj) = @_;
+
+ # . command.
+ if ($obj->_is_full('.')) {
+ $incr = -1; # stay at current line
+
+ # Reset everything to the old location.
+ $start = $line;
+ $filename = $filename_ini;
+ *dbline = $main::{ '_<' . $filename };
+ $max = $#dbline;
+
+ # Now where are we?
+ print_lineinfo($obj->position());
+ next CMD;
+ }
+
+ return;
+}
+
+sub _DB__handle_y_command {
+ my ($obj) = @_;
+
+ if (my ($match_level, $match_vars)
+ = $obj->cmd_args =~ /\A(?:(\d*)\s*(.*))?\z/) {
+
+ # See if we've got the necessary support.
+ if (!eval { require PadWalker; PadWalker->VERSION(0.08) }) {
+ my $Err = $@;
+ _db_warn(
+ $Err =~ /locate/
+ ? "PadWalker module not found - please install\n"
+ : $Err
+ );
+ next CMD;
+ }
+
+ # Load up dumpvar if we don't have it. If we can, that is.
+ do 'dumpvar.pl' || die $@ unless defined &main::dumpvar;
+ defined &main::dumpvar
+ or print $OUT "dumpvar.pl not available.\n"
+ and next CMD;
+
+ # Got all the modules we need. Find them and print them.
+ my @vars = split( ' ', $match_vars || '' );
+
+ # Find the pad.
+ my $h = eval { PadWalker::peek_my( ( $match_level || 0 ) + 1 ) };
+
+ # Oops. Can't find it.
+ if (my $Err = $@) {
+ $Err =~ s/ at .*//;
+ _db_warn($Err);
+ next CMD;
+ }
+
+ # Show the desired vars with dumplex().
+ my $savout = select($OUT);
+
+ # Have dumplex dump the lexicals.
+ foreach my $key (sort keys %$h) {
+ dumpvar::dumplex( $key, $h->{$key},
+ defined $option{dumpDepth} ? $option{dumpDepth} : -1,
+ @vars );
+ }
+ select($savout);
+ next CMD;
+ }
+}
+
+sub _DB__handle_c_command {
+ my ($obj) = @_;
+
+ my $i = $obj->cmd_args;
+
+ if ($i =~ m#\A[\w:]*\z#) {
+
+ # Hey, show's over. The debugged program finished
+ # executing already.
+ next CMD if _DB__is_finished();
+
+ # Capture the place to put a one-time break.
+ $subname = $i;
+
+ # Probably not needed, since we finish an interactive
+ # sub-session anyway...
+ # local $filename = $filename;
+ # local *dbline = *dbline; # XXX Would this work?!
+ #
+ # The above question wonders if localizing the alias
+ # to the magic array works or not. Since it's commented
+ # out, we'll just leave that to speculation for now.
+
+ # If the "subname" isn't all digits, we'll assume it
+ # is a subroutine name, and try to find it.
+ if ( $subname =~ /\D/ ) { # subroutine name
+ # Qualify it to the current package unless it's
+ # already qualified.
+ $subname = $package . "::" . $subname
+ unless $subname =~ /::/;
+
+ # find_sub will return "file:line_number" corresponding
+ # to where the subroutine is defined; we call find_sub,
+ # break up the return value, and assign it in one
+ # operation.
+ ( $file, $i ) = ( find_sub($subname) =~ /^(.*):(.*)$/ );
+
+ # Force the line number to be numeric.
+ $i = $i + 0;
+
+ # If we got a line number, we found the sub.
+ if ($i) {
+
+ # Switch all the debugger's internals around so
+ # we're actually working with that file.
+ $filename = $file;
+ *dbline = $main::{ '_<' . $filename };
+
+ # Mark that there's a breakpoint in this file.
+ $had_breakpoints{$filename} |= 1;
+
+ # Scan forward to the first executable line
+ # after the 'sub whatever' line.
+ $max = $#dbline;
+ my $_line_num = $i;
+ while ($dbline[$_line_num] == 0 && $_line_num< $max)
+ {
+ $_line_num++;
+ }
+ $i = $_line_num;
+ } ## end if ($i)
+
+ # We didn't find a sub by that name.
+ else {
+ print $OUT "Subroutine $subname not found.\n";
+ next CMD;
+ }
+ } ## end if ($subname =~ /\D/)
+
+ # At this point, either the subname was all digits (an
+ # absolute line-break request) or we've scanned through
+ # the code following the definition of the sub, looking
+ # for an executable, which we may or may not have found.
+ #
+ # If $i (which we set $subname from) is non-zero, we
+ # got a request to break at some line somewhere. On
+ # one hand, if there wasn't any real subroutine name
+ # involved, this will be a request to break in the current
+ # file at the specified line, so we have to check to make
+ # sure that the line specified really is breakable.
+ #
+ # On the other hand, if there was a subname supplied, the
+ # preceding block has moved us to the proper file and
+ # location within that file, and then scanned forward
+ # looking for the next executable line. We have to make
+ # sure that one was found.
+ #
+ # On the gripping hand, we can't do anything unless the
+ # current value of $i points to a valid breakable line.
+ # Check that.
+ if ($i) {
+
+ # Breakable?
+ if ( $dbline[$i] == 0 ) {
+ print $OUT "Line $i not breakable.\n";
+ next CMD;
+ }
+
+ # Yes. Set up the one-time-break sigil.
+ $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
+ _enable_breakpoint_temp_enabled_status($filename, $i);
+ } ## end if ($i)
+
+ # Turn off stack tracing from here up.
+ for my $j (0 .. $stack_depth) {
+ $stack[ $j ] &= ~1;
+ }
+ last CMD;
+ }
+
+ return;
+}
+
+sub _DB__handle_forward_slash_command {
+ my ($obj) = @_;
+
+ # The pattern as a string.
+ use vars qw($inpat);
+
+ if (($inpat) = $cmd =~ m#\A/(.*)\z#) {
+
+ # Remove the final slash.
+ $inpat =~ s:([^\\])/$:$1:;
+
+ # If the pattern isn't null ...
+ if ( $inpat ne "" ) {
+
+ # Turn of warn and die procesing for a bit.
+ local $SIG{__DIE__};
+ local $SIG{__WARN__};
+
+ # Create the pattern.
+ eval 'no strict q/vars/; $inpat =~ m' . "\a$inpat\a";
+ if ( $@ ne "" ) {
+
+ # Oops. Bad pattern. No biscuit.
+ # Print the eval error and go back for more
+ # commands.
+ print {$OUT} "$@";
+ next CMD;
+ }
+ $obj->pat($inpat);
+ } ## end if ($inpat ne "")
+
+ # Set up to stop on wrap-around.
+ $end = $start;
+
+ # Don't move off the current line.
+ $incr = -1;
+
+ my $pat = $obj->pat;
+
+ # Done in eval so nothing breaks if the pattern
+ # does something weird.
+ eval
+ {
+ no strict q/vars/;
+ for (;;) {
+ # Move ahead one line.
+ ++$start;
+
+ # Wrap if we pass the last line.
+ if ($start > $max) {
+ $start = 1;
+ }
+
+ # Stop if we have gotten back to this line again,
+ last if ($start == $end);
+
+ # A hit! (Note, though, that we are doing
+ # case-insensitive matching. Maybe a qr//
+ # expression would be better, so the user could
+ # do case-sensitive matching if desired.
+ if ($dbline[$start] =~ m/$pat/i) {
+ if ($slave_editor) {
+ # Handle proper escaping in the slave.
+ print {$OUT} "\032\032$filename:$start:0\n";
+ }
+ else {
+ # Just print the line normally.
+ print {$OUT} "$start:\t",$dbline[$start],"\n";
+ }
+ # And quit since we found something.
+ last;
+ }
+ }
+ };
+
+ if ($@) {
+ warn $@;
+ }
+
+ # If we wrapped, there never was a match.
+ if ( $start == $end ) {
+ print {$OUT} "/$pat/: not found\n";
+ }
+ next CMD;
+ }
+
+ return;
+}
+
+sub _DB__handle_question_mark_command {
+ my ($obj) = @_;
+
+ # ? - backward pattern search.
+ if (my ($inpat) = $cmd =~ m#\A\?(.*)\z#) {
+
+ # Get the pattern, remove trailing question mark.
+ $inpat =~ s:([^\\])\?$:$1:;
+
+ # If we've got one ...
+ if ( $inpat ne "" ) {
+
+ # Turn off die & warn handlers.
+ local $SIG{__DIE__};
+ local $SIG{__WARN__};
+ eval '$inpat =~ m' . "\a$inpat\a";
+
+ if ( $@ ne "" ) {
+
+ # Ouch. Not good. Print the error.
+ print $OUT $@;
+ next CMD;
+ }
+ $obj->pat($inpat);
+ } ## end if ($inpat ne "")
+
+ # Where we are now is where to stop after wraparound.
+ $end = $start;
+
+ # Don't move away from this line.
+ $incr = -1;
+
+ my $pat = $obj->pat;
+ # Search inside the eval to prevent pattern badness
+ # from killing us.
+ eval {
+ no strict q/vars/;
+ for (;;) {
+ # Back up a line.
+ --$start;
+
+ # Wrap if we pass the first line.
+
+ $start = $max if ($start <= 0);
+
+ # Quit if we get back where we started,
+ last if ($start == $end);
+
+ # Match?
+ if ($dbline[$start] =~ m/$pat/i) {
+ if ($slave_editor) {
+ # Yep, follow slave editor requirements.
+ print $OUT "\032\032$filename:$start:0\n";
+ }
+ else {
+ # Yep, just print normally.
+ print $OUT "$start:\t",$dbline[$start],"\n";
+ }
+
+ # Found, so done.
+ last;
+ }
+ }
+ };
+
+ # Say we failed if the loop never found anything,
+ if ( $start == $end ) {
+ print {$OUT} "?$pat?: not found\n";
+ }
+ next CMD;
+ }
+
+ return;
+}
+
+sub _DB__handle_restart_and_rerun_commands {
+ my ($obj) = @_;
+
+ my $cmd_cmd = $obj->cmd_verb;
+ my $cmd_params = $obj->cmd_args;
+ # R - restart execution.
+ # rerun - controlled restart execution.
+ if ($cmd_cmd eq 'rerun' or $cmd_params eq '') {
+ my @args = ($cmd_cmd eq 'R' ? restart() : rerun($cmd_params));
+
+ # Close all non-system fds for a clean restart. A more
+ # correct method would be to close all fds that were not
+ # open when the process started, but this seems to be
+ # hard. See "debugger 'R'estart and open database
+ # connections" on p5p.
+
+ my $max_fd = 1024; # default if POSIX can't be loaded
+ if (eval { require POSIX }) {
+ eval { $max_fd = POSIX::sysconf(POSIX::_SC_OPEN_MAX()) };
+ }
+
+ if (defined $max_fd) {
+ foreach ($^F+1 .. $max_fd-1) {
+ next unless open FD_TO_CLOSE, "<&=$_";
+ close(FD_TO_CLOSE);
+ }
+ }
+
+ # And run Perl again. We use exec() to keep the
+ # PID stable (and that way $ini_pids is still valid).
+ exec(@args) or print {$OUT} "exec failed: $!\n";
+
+ last CMD;
+ }
+
+ return;
+}
+
+sub _DB__handle_run_command_in_pager_command {
+ my ($obj) = @_;
+
+ if ($cmd =~ m#\A\|\|?\s*[^|]#) {
+ if ( $pager =~ /^\|/ ) {
+
+ # Default pager is into a pipe. Redirect I/O.
+ open( SAVEOUT, ">&STDOUT" )
+ || _db_warn("Can't save STDOUT");
+ open( STDOUT, ">&OUT" )
+ || _db_warn("Can't redirect STDOUT");
+ } ## end if ($pager =~ /^\|/)
+ else {
+
+ # Not into a pipe. STDOUT is safe.
+ open( SAVEOUT, ">&OUT" ) || _db_warn("Can't save DB::OUT");
+ }
+
+ # Fix up environment to record we have less if so.
+ fix_less();
+
+ unless ( $obj->piped(scalar ( open( OUT, $pager ) ) ) ) {
+
+ # Couldn't open pipe to pager.
+ _db_warn("Can't pipe output to '$pager'");
+ if ( $pager =~ /^\|/ ) {
+
+ # Redirect I/O back again.
+ open( OUT, ">&STDOUT" ) # XXX: lost message
+ || _db_warn("Can't restore DB::OUT");
+ open( STDOUT, ">&SAVEOUT" )
+ || _db_warn("Can't restore STDOUT");
+ close(SAVEOUT);
+ } ## end if ($pager =~ /^\|/)
+ else {
+
+ # Redirect I/O. STDOUT already safe.
+ open( OUT, ">&STDOUT" ) # XXX: lost message
+ || _db_warn("Can't restore DB::OUT");
+ }
+ next CMD;
+ } ## end unless ($piped = open(OUT,...
+
+ # Set up broken-pipe handler if necessary.
+ $SIG{PIPE} = \&DB::catch
+ if $pager =~ /^\|/
+ && ( "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE} );
+
+ _autoflush(\*OUT);
+ # Save current filehandle, and put it back.
+ $obj->selected(scalar( select(OUT) ));
+ # Don't put it back if pager was a pipe.
+ if ($cmd !~ /\A\|\|/)
+ {
+ select($obj->selected());
+ $obj->selected("");
+ }
+
+ # Trim off the pipe symbols and run the command now.
+ $cmd =~ s#\A\|+\s*##;
+ redo PIPE;
+ }
+
+ return;
+}
+
+sub _DB__handle_m_command {
+ my ($obj) = @_;
+
+ if ($cmd =~ s#\Am\s+([\w:]+)\s*\z# #) {
+ methods($1);
+ next CMD;
+ }
+
+ # m expr - set up DB::eval to do the work
+ if ($cmd =~ s#\Am\b# #) { # Rest gets done by DB::eval()
+ $onetimeDump = 'methods'; # method output gets used there
+ }
+
+ return;
+}
+
+sub _DB__at_end_of_every_command {
+ my ($obj) = @_;
+
+ # At the end of every command:
+ if ($obj->piped) {
+
+ # Unhook the pipe mechanism now.
+ if ( $pager =~ /^\|/ ) {
+
+ # No error from the child.
+ $? = 0;
+
+ # we cannot warn here: the handle is missing --tchrist
+ close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
+
+ # most of the $? crud was coping with broken cshisms
+ # $? is explicitly set to 0, so this never runs.
+ if ($?) {
+ print SAVEOUT "Pager '$pager' failed: ";
+ if ( $? == -1 ) {
+ print SAVEOUT "shell returned -1\n";
+ }
+ elsif ( $? >> 8 ) {
+ print SAVEOUT ( $? & 127 )
+ ? " (SIG#" . ( $? & 127 ) . ")"
+ : "", ( $? & 128 ) ? " -- core dumped" : "", "\n";
+ }
+ else {
+ print SAVEOUT "status ", ( $? >> 8 ), "\n";
+ }
+ } ## end if ($?)
+
+ # Reopen filehandle for our output (if we can) and
+ # restore STDOUT (if we can).
+ open( OUT, ">&STDOUT" ) || _db_warn("Can't restore DB::OUT");
+ open( STDOUT, ">&SAVEOUT" )
+ || _db_warn("Can't restore STDOUT");
+
+ # Turn off pipe exception handler if necessary.
+ $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
+
+ # Will stop ignoring SIGPIPE if done like nohup(1)
+ # does SIGINT but Perl doesn't give us a choice.
+ } ## end if ($pager =~ /^\|/)
+ else {
+
+ # Non-piped "pager". Just restore STDOUT.
+ open( OUT, ">&SAVEOUT" ) || _db_warn("Can't restore DB::OUT");
+ }
+
+ # Close filehandle pager was using, restore the normal one
+ # if necessary,
+ close(SAVEOUT);
+
+ if ($obj->selected() ne "") {
+ select($obj->selected);
+ $obj->selected("");
+ }
+
+ # No pipes now.
+ $obj->piped("");
+ } ## end if ($piped)
+
+ return;
+}
+
+sub _DB__handle_watch_expressions
+{
+ my $self = shift;
+
+ if ( $DB::trace & 2 ) {
+ for my $n (0 .. $#DB::to_watch) {
+ $DB::evalarg = $DB::to_watch[$n];
+ local $DB::onetimeDump; # Tell DB::eval() to not output results
+
+ # Fix context DB::eval() wants to return an array, but
+ # we need a scalar here.
+ my ($val) = join( "', '", DB::eval(@_) );
+ $val = ( ( defined $val ) ? "'$val'" : 'undef' );
+
+ # Did it change?
+ if ( $val ne $DB::old_watch[$n] ) {
+
+ # Yep! Show the difference, and fake an interrupt.
+ $DB::signal = 1;
+ print {$DB::OUT} <<EOP;
+Watchpoint $n:\t$DB::to_watch[$n] changed:
+ old value:\t$DB::old_watch[$n]
+ new value:\t$val
+EOP
+ $DB::old_watch[$n] = $val;
+ } ## end if ($val ne $old_watch...
+ } ## end for my $n (0 ..
+ } ## end if ($trace & 2)
+
+ return;
+}
+
+# 't' is type.
+# 'm' is method.
+# 'v' is the value (i.e: method name or subroutine ref).
+# 's' is subroutine.
+my %cmd_lookup =
+(
+ '-' => { t => 'm', v => '_handle_dash_command', },
+ '.' => { t => 's', v => \&_DB__handle_dot_command, },
+ '=' => { t => 'm', v => '_handle_equal_sign_command', },
+ 'H' => { t => 'm', v => '_handle_H_command', },
+ 'S' => { t => 'm', v => '_handle_S_command', },
+ 'T' => { t => 'm', v => '_handle_T_command', },
+ 'W' => { t => 'm', v => '_handle_W_command', },
+ 'c' => { t => 's', v => \&_DB__handle_c_command, },
+ 'f' => { t => 's', v => \&_DB__handle_f_command, },
+ 'm' => { t => 's', v => \&_DB__handle_m_command, },
+ 'n' => { t => 'm', v => '_handle_n_command', },
+ 'p' => { t => 'm', v => '_handle_p_command', },
+ 'q' => { t => 'm', v => '_handle_q_command', },
+ 'r' => { t => 'm', v => '_handle_r_command', },
+ 's' => { t => 'm', v => '_handle_s_command', },
+ 'save' => { t => 'm', v => '_handle_save_command', },
+ 'source' => { t => 'm', v => '_handle_source_command', },
+ 't' => { t => 'm', v => '_handle_t_command', },
+ 'w' => { t => 'm', v => '_handle_w_command', },
+ 'x' => { t => 'm', v => '_handle_x_command', },
+ 'y' => { t => 's', v => \&_DB__handle_y_command, },
+ (map { $_ => { t => 'm', v => '_handle_V_command_and_X_command', }, }
+ ('X', 'V')),
+ (map { $_ => { t => 'm', v => '_handle_enable_disable_commands', }, }
+ qw(enable disable)),
+ (map { $_ =>
+ { t => 's', v => \&_DB__handle_restart_and_rerun_commands, },
+ } qw(R rerun)),
+ (map { $_ => {t => 'm', v => '_handle_cmd_wrapper_commands' }, }
+ qw(a A b B e E h i l L M o O P v w W)),
+);
+
+sub DB {
+
+ # lock the debugger and get the thread id for the prompt
+ lock($DBGR);
+ my $tid;
+ my $position;
+ my ($prefix, $after, $infix);
+ my $pat;
+ my $explicit_stop;
+ my $piped;
+ my $selected;
+
+ if ($ENV{PERL5DB_THREADED}) {
+ $tid = eval { "[".threads->tid."]" };
+ }
+
+ my $cmd_verb;
+ my $cmd_args;
+
+ my $obj = DB::Obj->new(
+ {
+ position => \$position,
+ prefix => \$prefix,
+ after => \$after,
+ explicit_stop => \$explicit_stop,
+ infix => \$infix,
+ cmd_args => \$cmd_args,
+ cmd_verb => \$cmd_verb,
+ pat => \$pat,
+ piped => \$piped,
+ selected => \$selected,
+ },
+ );
+
+ $obj->_DB_on_init__initialize_globals(@_);
+
# Preserve current values of $@, $!, $^E, $,, $/, $\, $^W.
# The code being debugged may have altered them.
- &save;
+ DB::save();
# Since DB::DB gets called after every line, we can use caller() to
# figure out where we last were executing. Sneaky, eh? This works because
@@ -1906,13 +2549,12 @@
# caller is returning all the extra information when called from the
# debugger.
local ( $package, $filename, $line ) = caller;
- local $filename_ini = $filename;
+ $filename_ini = $filename;
# set up the context for DB::eval, so it can properly execute
# code on behalf of the user. We add the package in so that the
# code is eval'ed in the proper package (not in the debugger!).
- local $usercontext =
- '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' . "package $package;";
+ local $usercontext = _calc_usercontext($package);
# Create an alias to the active file magical array to simplify
# the code here.
@@ -1919,64 +2561,25 @@
local (*dbline) = $main::{ '_<' . $filename };
# Last line in the program.
- local $max = $#dbline;
+ $max = $#dbline;
- # if we have something here, see if we should break.
- if ( $dbline{$line}
- && ( ( $stop, $action ) = split( /\0/, $dbline{$line} ) ) )
- {
+ # The &-call is here to ascertain the mutability of @_.
+ &_DB__determine_if_we_should_break;
- # Stop if the stop criterion says to just stop.
- if ( $stop eq '1' ) {
- $signal |= 1;
- }
-
- # It's a conditional stop; eval it in the user's context and
- # see if we should stop. If so, remove the one-time sigil.
- elsif ($stop) {
- $evalarg = "\$DB::signal |= 1 if do {$stop}";
- &eval;
- $dbline{$line} =~ s/;9($|\0)/$1/;
- }
- } ## end if ($dbline{$line} && ...
-
# Preserve the current stop-or-not, and see if any of the W
# (watch expressions) has changed.
my $was_signal = $signal;
# If we have any watch expressions ...
- if ( $trace & 2 ) {
- for ( my $n = 0 ; $n <= $#to_watch ; $n++ ) {
- $evalarg = $to_watch[$n];
- local $onetimeDump; # Tell DB::eval() to not output results
+ _DB__handle_watch_expressions($obj);
- # Fix context DB::eval() wants to return an array, but
- # we need a scalar here.
- my ($val) = join( "', '", &eval );
- $val = ( ( defined $val ) ? "'$val'" : 'undef' );
-
- # Did it change?
- if ( $val ne $old_watch[$n] ) {
-
- # Yep! Show the difference, and fake an interrupt.
- $signal = 1;
- print $OUT <<EOP;
-Watchpoint $n:\t$to_watch[$n] changed:
- old value:\t$old_watch[$n]
- new value:\t$val
-EOP
- $old_watch[$n] = $val;
- } ## end if ($val ne $old_watch...
- } ## end for (my $n = 0 ; $n <= ...
- } ## end if ($trace & 2)
-
=head2 C<watchfunction()>
C<watchfunction()> is a function that can be defined by the user; it is a
-function which will be run on each entry to C<DB::DB>; it gets the
+function which will be run on each entry to C<DB::DB>; it gets the
current package, filename, and line as its parameters.
-The watchfunction can do anything it likes; it is executing in the
+The watchfunction can do anything it likes; it is executing in the
debugger's context, so it has access to all of the debugger's internal
data structures and functions.
@@ -1984,7 +2587,7 @@
will cause the debugger to return control to the user's program after
C<watchfunction()> executes:
-=over 4
+=over 4
=item *
@@ -2034,123 +2637,29 @@
=cut
+ # Make sure that we always print if asked for explicitly regardless
+ # of $trace_to_depth .
+ $explicit_stop = ($single || $was_signal);
+
# Check to see if we should grab control ($single true,
# trace set appropriately, or we got a signal).
- if ( $single || ( $trace & 1 ) || $was_signal ) {
-
- # Yes, grab control.
- if ($slave_editor) {
-
- # Tell the editor to update its position.
- $position = "\032\032$filename:$line:0\n";
- print_lineinfo($position);
- }
-
-=pod
-
-Special check: if we're in package C<DB::fake>, we've gone through the
-C<END> block at least once. We set up everything so that we can continue
-to enter commands and have a valid context to be in.
-
-=cut
-
- elsif ( $package eq 'DB::fake' ) {
-
- # Fallen off the end already.
- $term || &setterm;
- print_help(<<EOP);
-Debugged program terminated. Use B<q> to quit or B<R> to restart,
- use B<o> I<inhibit_exit> to avoid stopping after program termination,
- B<h q>, B<h R> or B<h o> to get additional info.
-EOP
-
- # Set the DB::eval context appropriately.
- $package = 'main';
- $usercontext =
- '($@, $!, $^E, $,, $/, $\, $^W) = @saved;'
- . "package $package;"; # this won't let them modify, alas
- } ## end elsif ($package eq 'DB::fake')
-
-=pod
-
-If the program hasn't finished executing, we scan forward to the
-next executable line, print that out, build the prompt from the file and line
-number information, and print that.
-
-=cut
-
- else {
-
- # Still somewhere in the midst of execution. Set up the
- # debugger prompt.
- $sub =~ s/\'/::/; # Swap Perl 4 package separators (') to
- # Perl 5 ones (sorry, we don't print Klingon
- #module names)
-
- $prefix = $sub =~ /::/ ? "" : "${'package'}::";
- $prefix .= "$sub($filename:";
- $after = ( $dbline[$line] =~ /\n$/ ? '' : "\n" );
-
- # Break up the prompt if it's really long.
- if ( length($prefix) > 30 ) {
- $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
- $prefix = "";
- $infix = ":\t";
- }
- else {
- $infix = "):\t";
- $position = "$prefix$line$infix$dbline[$line]$after";
- }
-
- # Print current line info, indenting if necessary.
- if ($frame) {
- print_lineinfo( ' ' x $stack_depth,
- "$line:\t$dbline[$line]$after" );
- }
- else {
- print_lineinfo($position);
- }
-
- # Scan forward, stopping at either the end or the next
- # unbreakable line.
- for ( $i = $line + 1 ; $i <= $max && $dbline[$i] == 0 ; ++$i )
- { #{ vi
-
- # Drop out on null statements, block closers, and comments.
- last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
-
- # Drop out if the user interrupted us.
- last if $signal;
-
- # Append a newline if the line doesn't have one. Can happen
- # in eval'ed text, for instance.
- $after = ( $dbline[$i] =~ /\n$/ ? '' : "\n" );
-
- # Next executable line.
- $incr_pos = "$prefix$i$infix$dbline[$i]$after";
- $position .= $incr_pos;
- if ($frame) {
-
- # Print it indented if tracing is on.
- print_lineinfo( ' ' x $stack_depth,
- "$i:\t$dbline[$i]$after" );
- }
- else {
- print_lineinfo($incr_pos);
- }
- } ## end for ($i = $line + 1 ; $i...
- } ## end else [ if ($slave_editor)
+ if ( $explicit_stop || ( $trace & 1 ) ) {
+ $obj->_DB__grab_control(@_);
} ## end if ($single || ($trace...
=pod
If there's an action to be executed for the line we stopped at, execute it.
-If there are any preprompt actions, execute those as well.
+If there are any preprompt actions, execute those as well.
=cut
# If there's an action, do it now.
- $evalarg = $action, &eval if $action;
+ if ($action) {
+ $evalarg = $action;
+ # The &-call is here to ascertain the mutability of @_.
+ &DB::eval;
+ }
# Are we nested another level (e.g., did we evaluate a function
# that had a breakpoint in it at the debugger prompt)?
@@ -2161,12 +2670,14 @@
# Do any pre-prompt actions.
foreach $evalarg (@$pre) {
- &eval;
+ # The &-call is here to ascertain the mutability of @_.
+ &DB::eval;
}
# Complain about too much recursion if we passed the limit.
- print $OUT $stack_depth . " levels deep in subroutine calls!\n"
- if $single & 4;
+ if ($single & 4) {
+ print $OUT $stack_depth . " levels deep in subroutine calls!\n";
+ }
# The line we're currently on. Set $incr to -1 to stay here
# until we get a command that tells us to advance.
@@ -2225,28 +2736,12 @@
#
# If we have a terminal for input, and we get something back
# from readline(), keep on processing.
+
CMD:
- while (
-
- # We have a terminal, or can get one ...
- ( $term || &setterm ),
-
- # ... and it belogs to this PID or we get one for this PID ...
- ( $term_pid == $$ or resetterm(1) ),
-
- # ... and we got a line of command input ...
- defined(
- $cmd = &readline(
- "$pidprompt $tid DB"
- . ( '<' x $level )
- . ( $#hist + 1 )
- . ( '>' x $level ) . " "
- )
- )
- )
+ while (_DB__read_next_cmd($tid))
{
- share($cmd);
+ share($cmd);
# ... try to execute the input as debugger commands.
# Don't stop running.
@@ -2256,10 +2751,10 @@
$signal = 0;
# Handle continued commands (ending with \):
- $cmd =~ s/\\$/\n/ && do {
- $cmd .= &readline(" cont: ");
+ if ($cmd =~ s/\\\z/\n/) {
+ $cmd .= DB::readline(" cont: ");
redo CMD;
- };
+ }
=head4 The null command
@@ -2273,20 +2768,22 @@
=cut
# Empty input means repeat the last command.
- $cmd =~ /^$/ && ( $cmd = $laststep );
+ if ($cmd eq '') {
+ $cmd = $laststep;
+ }
chomp($cmd); # get rid of the annoying extra newline
- push( @hist, $cmd ) if length($cmd) > 1;
+ if (length($cmd) >= 2) {
+ push( @hist, $cmd );
+ }
push( @truehist, $cmd );
- share(@hist);
- share(@truehist);
+ share(@hist);
+ share(@truehist);
# This is a restart point for commands that didn't arrive
# via direct user input. It allows us to 'redo PIPE' to
# re-execute command processing without reading a new command.
PIPE: {
- $cmd =~ s/^\s+//s; # trim annoying leading whitespace
- $cmd =~ s/\s+$//s; # trim annoying trailing whitespace
- ($i) = split( /\s+/, $cmd );
+ _DB__trim_command_and_return_first_component($obj);
=head3 COMMAND ALIASES
@@ -2298,7 +2795,7 @@
=cut
# See if there's an alias for the command, and set it up if so.
- if ( $alias{$i} ) {
+ if ( $alias{$cmd_verb} ) {
# Squelch signal handling; we want to keep control here
# if something goes loco during the alias eval.
@@ -2309,1246 +2806,1179 @@
# scope! Otherwise, we can't see the special debugger
# variables, or get to the debugger's subs. (Well, we
# _could_, but why make it even more complicated?)
- eval "\$cmd =~ $alias{$i}";
+ eval "\$cmd =~ $alias{$cmd_verb}";
if ($@) {
local $\ = '';
- print $OUT "Couldn't evaluate `$i' alias: $@";
+ print $OUT "Couldn't evaluate '$cmd_verb' alias: $@";
next CMD;
}
- } ## end if ($alias{$i})
+ _DB__trim_command_and_return_first_component($obj);
+ } ## end if ($alias{$cmd_verb})
=head3 MAIN-LINE COMMANDS
All of these commands work up to and after the program being debugged has
-terminated.
+terminated.
=head4 C<q> - quit
-Quit the debugger. This entails setting the C<$fall_off_end> flag, so we don't
+Quit the debugger. This entails setting the C<$fall_off_end> flag, so we don't
try to execute further, cleaning any restart-related stuff out of the
environment, and executing with the last value of C<$?>.
=cut
- $cmd =~ /^q$/ && do {
- $fall_off_end = 1;
- clean_ENV();
- exit $?;
- };
+ # All of these commands were remapped in perl 5.8.0;
+ # we send them off to the secondary dispatcher (see below).
+ $obj->_handle_special_char_cmd_wrapper_commands;
+ _DB__trim_command_and_return_first_component($obj);
-=head4 C<t> - trace
+ if (my $cmd_rec = $cmd_lookup{$cmd_verb}) {
+ my $type = $cmd_rec->{t};
+ my $val = $cmd_rec->{v};
+ if ($type eq 'm') {
+ $obj->$val();
+ }
+ elsif ($type eq 's') {
+ $val->($obj);
+ }
+ }
+=head4 C<t> - trace [n]
+
Turn tracing on or off. Inverts the appropriate bit in C<$trace> (q.v.).
+If level is specified, set C<$trace_to_depth>.
-=cut
-
- $cmd =~ /^t$/ && do {
- $trace ^= 1;
- local $\ = '';
- print $OUT "Trace = "
- . ( ( $trace & 1 ) ? "on" : "off" ) . "\n";
- next CMD;
- };
-
=head4 C<S> - list subroutines matching/not matching a pattern
Walks through C<%sub>, checking to see whether or not to print the name.
-=cut
+=head4 C<X> - list variables in current package
- $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
+Since the C<V> command actually processes this, just change this to the
+appropriate C<V> command and fall through.
- $Srev = defined $2; # Reverse scan?
- $Spatt = $3; # The pattern (if any) to use.
- $Snocheck = !defined $1; # No args - print all subs.
+=head4 C<V> - list variables
- # Need to make these sane here.
- local $\ = '';
- local $, = '';
+Uses C<dumpvar.pl> to dump out the current values for selected variables.
- # Search through the debugger's magical hash of subs.
- # If $nocheck is true, just print the sub name.
- # Otherwise, check it against the pattern. We then use
- # the XOR trick to reverse the condition as required.
- foreach $subname ( sort( keys %sub ) ) {
- if ( $Snocheck or $Srev ^ ( $subname =~ /$Spatt/ ) ) {
- print $OUT $subname, "\n";
- }
- }
- next CMD;
- };
+=head4 C<x> - evaluate and print an expression
-=head4 C<X> - list variables in current package
+Hands the expression off to C<DB::eval>, setting it up to print the value
+via C<dumpvar.pl> instead of just printing it directly.
-Since the C<V> command actually processes this, just change this to the
-appropriate C<V> command and fall through.
+=head4 C<m> - print methods
-=cut
+Just uses C<DB::methods> to determine what methods are available.
- $cmd =~ s/^X\b/V $package/;
+=head4 C<f> - switch files
-=head4 C<V> - list variables
+Switch to a different filename.
-Uses C<dumpvar.pl> to dump out the current values for selected variables.
+=head4 C<.> - return to last-executed line.
-=cut
+We set C<$incr> to -1 to indicate that the debugger shouldn't move ahead,
+and then we look up the line in the magical C<%dbline> hash.
- # Bare V commands get the currently-being-debugged package
- # added.
- $cmd =~ /^V$/ && do {
- $cmd = "V $package";
- };
+=head4 C<-> - back one window
- # V - show variables in package.
- $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
+We change C<$start> to be one window back; if we go back past the first line,
+we set it to be the first line. We ser C<$incr> to put us back at the
+currently-executing line, and then put a C<l $start +> (list one window from
+C<$start>) in C<$cmd> to be executed later.
- # Save the currently selected filehandle and
- # force output to debugger's filehandle (dumpvar
- # just does "print" for output).
- local ($savout) = select($OUT);
+=head3 PRE-580 COMMANDS VS. NEW COMMANDS: C<a, A, b, B, h, l, L, M, o, O, P, v, w, W, E<lt>, E<lt>E<lt>, E<0x7B>, E<0x7B>E<0x7B>>
- # Grab package name and variables to dump.
- $packname = $1;
- @vars = split( ' ', $2 );
+In Perl 5.8.0, a realignment of the commands was done to fix up a number of
+problems, most notably that the default case of several commands destroying
+the user's work in setting watchpoints, actions, etc. We wanted, however, to
+retain the old commands for those who were used to using them or who preferred
+them. At this point, we check for the new commands and call C<cmd_wrapper> to
+deal with them instead of processing them in-line.
- # If main::dumpvar isn't here, get it.
- do 'dumpvar.pl' || die $@ unless defined &main::dumpvar;
- if ( defined &main::dumpvar ) {
+=head4 C<y> - List lexicals in higher scope
- # We got it. Turn off subroutine entry/exit messages
- # for the moment, along with return values.
- local $frame = 0;
- local $doret = -2;
+Uses C<PadWalker> to find the lexicals supplied as arguments in a scope
+above the current one and then displays then using C<dumpvar.pl>.
- # must detect sigpipe failures - not catching
- # then will cause the debugger to die.
- eval {
- &main::dumpvar(
- $packname,
- defined $option{dumpDepth}
- ? $option{dumpDepth}
- : -1, # assume -1 unless specified
- @vars
- );
- };
+=head3 COMMANDS NOT WORKING AFTER PROGRAM ENDS
- # The die doesn't need to include the $@, because
- # it will automatically get propagated for us.
- if ($@) {
- die unless $@ =~ /dumpvar print failed/;
- }
- } ## end if (defined &main::dumpvar)
- else {
+All of the commands below this point don't work after the program being
+debugged has ended. All of them check to see if the program has ended; this
+allows the commands to be relocated without worrying about a 'line of
+demarcation' above which commands can be entered anytime, and below which
+they can't.
- # Couldn't load dumpvar.
- print $OUT "dumpvar.pl not available.\n";
- }
+=head4 C<n> - single step, but don't trace down into subs
- # Restore the output filehandle, and go round again.
- select($savout);
- next CMD;
- };
+Done by setting C<$single> to 2, which forces subs to execute straight through
+when entered (see C<DB::sub>). We also save the C<n> command in C<$laststep>,
+so a null command knows what to re-execute.
-=head4 C<x> - evaluate and print an expression
+=head4 C<s> - single-step, entering subs
-Hands the expression off to C<DB::eval>, setting it up to print the value
-via C<dumpvar.pl> instead of just printing it directly.
+Sets C<$single> to 1, which causes C<DB::sub> to continue tracing inside
+subs. Also saves C<s> as C<$lastcmd>.
-=cut
+=head4 C<c> - run continuously, setting an optional breakpoint
- $cmd =~ s/^x\b/ / && do { # Remainder gets done by DB::eval()
- $onetimeDump = 'dump'; # main::dumpvar shows the output
+Most of the code for this command is taken up with locating the optional
+breakpoint, which is either a subroutine name or a line number. We set
+the appropriate one-time-break in C<@dbline> and then turn off single-stepping
+in this and all call levels above this one.
- # handle special "x 3 blah" syntax XXX propagate
- # doc back to special variables.
- if ( $cmd =~ s/^\s*(\d+)(?=\s)/ / ) {
- $onetimedumpDepth = $1;
- }
- };
+=head4 C<r> - return from a subroutine
-=head4 C<m> - print methods
+For C<r> to work properly, the debugger has to stop execution again
+immediately after the return is executed. This is done by forcing
+single-stepping to be on in the call level above the current one. If
+we are printing return values when a C<r> is executed, set C<$doret>
+appropriately, and force us out of the command loop.
-Just uses C<DB::methods> to determine what methods are available.
+=head4 C<T> - stack trace
-=cut
+Just calls C<DB::print_trace>.
- $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
- methods($1);
- next CMD;
- };
+=head4 C<w> - List window around current line.
- # m expr - set up DB::eval to do the work
- $cmd =~ s/^m\b/ / && do { # Rest gets done by DB::eval()
- $onetimeDump = 'methods'; # method output gets used there
- };
+Just calls C<DB::cmd_w>.
-=head4 C<f> - switch files
+=head4 C<W> - watch-expression processing.
-=cut
+Just calls C<DB::cmd_W>.
- $cmd =~ /^f\b\s*(.*)/ && do {
- $file = $1;
- $file =~ s/\s+$//;
+=head4 C</> - search forward for a string in the source
- # help for no arguments (old-style was return from sub).
- if ( !$file ) {
- print $OUT
- "The old f command is now the r command.\n"; # hint
- print $OUT "The new f command switches filenames.\n";
- next CMD;
- } ## end if (!$file)
+We take the argument and treat it as a pattern. If it turns out to be a
+bad one, we return the error we got from trying to C<eval> it and exit.
+If not, we create some code to do the search and C<eval> it so it can't
+mess us up.
- # if not in magic file list, try a close match.
- if ( !defined $main::{ '_<' . $file } ) {
- if ( ($try) = grep( m#^_<.*$file#, keys %main:: ) ) {
- {
- $try = substr( $try, 2 );
- print $OUT "Choosing $try matching `$file':\n";
- $file = $try;
- }
- } ## end if (($try) = grep(m#^_<.*$file#...
- } ## end if (!defined $main::{ ...
+=cut
- # If not successfully switched now, we failed.
- if ( !defined $main::{ '_<' . $file } ) {
- print $OUT "No file matching `$file' is loaded.\n";
- next CMD;
- }
+ _DB__handle_forward_slash_command($obj);
- # We switched, so switch the debugger internals around.
- elsif ( $file ne $filename ) {
- *dbline = $main::{ '_<' . $file };
- $max = $#dbline;
- $filename = $file;
- $start = 1;
- $cmd = "l";
- } ## end elsif ($file ne $filename)
+=head4 C<?> - search backward for a string in the source
- # We didn't switch; say we didn't.
- else {
- print $OUT "Already in $file.\n";
- next CMD;
- }
- };
+Same as for C</>, except the loop runs backwards.
-=head4 C<.> - return to last-executed line.
+=cut
-We set C<$incr> to -1 to indicate that the debugger shouldn't move ahead,
-and then we look up the line in the magical C<%dbline> hash.
+ _DB__handle_question_mark_command($obj);
-=cut
+=head4 C<$rc> - Recall command
- # . command.
- $cmd =~ /^\.$/ && do {
- $incr = -1; # stay at current line
+Manages the commands in C<@hist> (which is created if C<Term::ReadLine> reports
+that the terminal supports history). It find the the command required, puts it
+into C<$cmd>, and redoes the loop to execute it.
- # Reset everything to the old location.
- $start = $line;
- $filename = $filename_ini;
- *dbline = $main::{ '_<' . $filename };
- $max = $#dbline;
+=cut
- # Now where are we?
- print_lineinfo($position);
- next CMD;
- };
+ # $rc - recall command.
+ $obj->_handle_rc_recall_command;
-=head4 C<-> - back one window
+=head4 C<$sh$sh> - C<system()> command
-We change C<$start> to be one window back; if we go back past the first line,
-we set it to be the first line. We ser C<$incr> to put us back at the
-currently-executing line, and then put a C<l $start +> (list one window from
-C<$start>) in C<$cmd> to be executed later.
+Calls the C<_db_system()> to handle the command. This keeps the C<STDIN> and
+C<STDOUT> from getting messed up.
=cut
- # - - back a window.
- $cmd =~ /^-$/ && do {
+ $obj->_handle_sh_command;
- # back up by a window; go to 1 if back too far.
- $start -= $incr + $window + 1;
- $start = 1 if $start <= 0;
- $incr = $window - 1;
+=head4 C<$rc I<pattern> $rc> - Search command history
- # Generate and execute a "l +" command (handled below).
- $cmd = 'l ' . ($start) . '+';
- };
+Another command to manipulate C<@hist>: this one searches it with a pattern.
+If a command is found, it is placed in C<$cmd> and executed via C<redo>.
-=head3 PRE-580 COMMANDS VS. NEW COMMANDS: C<a, A, b, B, h, l, L, M, o, O, P, v, w, W, E<lt>, E<lt>E<lt>, {, {{>
-
-In Perl 5.8.0, a realignment of the commands was done to fix up a number of
-problems, most notably that the default case of several commands destroying
-the user's work in setting watchpoints, actions, etc. We wanted, however, to
-retain the old commands for those who were used to using them or who preferred
-them. At this point, we check for the new commands and call C<cmd_wrapper> to
-deal with them instead of processing them in-line.
-
=cut
- # All of these commands were remapped in perl 5.8.0;
- # we send them off to the secondary dispatcher (see below).
- $cmd =~ /^([aAbBeEhilLMoOPvwW]\b|[<>\{]{1,2})\s*(.*)/so && do {
- &cmd_wrapper( $1, $2, $line );
- next CMD;
- };
+ $obj->_handle_rc_search_history_command;
-=head4 C<y> - List lexicals in higher scope
+=head4 C<$sh> - Invoke a shell
-Uses C<PadWalker> to find the lexicals supplied as arguments in a scope
-above the current one and then displays then using C<dumpvar.pl>.
+Uses C<_db_system()> to invoke a shell.
=cut
- $cmd =~ /^y(?:\s+(\d*)\s*(.*))?$/ && do {
+=head4 C<$sh I<command>> - Force execution of a command in a shell
- # See if we've got the necessary support.
- eval { require PadWalker; PadWalker->VERSION(0.08) }
- or &warn(
- $@ =~ /locate/
- ? "PadWalker module not found - please install\n"
- : $@
- )
- and next CMD;
+Like the above, but the command is passed to the shell. Again, we use
+C<_db_system()> to avoid problems with C<STDIN> and C<STDOUT>.
- # Load up dumpvar if we don't have it. If we can, that is.
- do 'dumpvar.pl' || die $@ unless defined &main::dumpvar;
- defined &main::dumpvar
- or print $OUT "dumpvar.pl not available.\n"
- and next CMD;
+=head4 C<H> - display commands in history
- # Got all the modules we need. Find them and print them.
- my @vars = split( ' ', $2 || '' );
+Prints the contents of C<@hist> (if any).
- # Find the pad.
- my $h = eval { PadWalker::peek_my( ( $1 || 0 ) + 1 ) };
+=head4 C<man, doc, perldoc> - look up documentation
- # Oops. Can't find it.
- $@ and $@ =~ s/ at .*//, &warn($@), next CMD;
+Just calls C<runman()> to print the appropriate document.
- # Show the desired vars with dumplex().
- my $savout = select($OUT);
+=cut
- # Have dumplex dump the lexicals.
- dumpvar::dumplex( $_, $h->{$_},
- defined $option{dumpDepth} ? $option{dumpDepth} : -1,
- @vars )
- for sort keys %$h;
- select($savout);
- next CMD;
- };
+ $obj->_handle_doc_command;
-=head3 COMMANDS NOT WORKING AFTER PROGRAM ENDS
+=head4 C<p> - print
-All of the commands below this point don't work after the program being
-debugged has ended. All of them check to see if the program has ended; this
-allows the commands to be relocated without worrying about a 'line of
-demarcation' above which commands can be entered anytime, and below which
-they can't.
+Builds a C<print EXPR> expression in the C<$cmd>; this will get executed at
+the bottom of the loop.
-=head4 C<n> - single step, but don't trace down into subs
+=head4 C<=> - define command alias
-Done by setting C<$single> to 2, which forces subs to execute straight through
-when entered (see C<DB::sub>). We also save the C<n> command in C<$laststep>,
-so a null command knows what to re-execute.
+Manipulates C<%alias> to add or list command aliases.
-=cut
+=head4 C<source> - read commands from a file.
- # n - next
- $cmd =~ /^n$/ && do {
- end_report(), next CMD if $finished and $level <= 1;
+Opens a lexical filehandle and stacks it on C<@cmdfhs>; C<DB::readline> will
+pick it up.
- # Single step, but don't enter subs.
- $single = 2;
+=head4 C<enable> C<disable> - enable or disable breakpoints
- # Save for empty command (repeat last).
- $laststep = $cmd;
- last CMD;
- };
+This enables or disables breakpoints.
-=head4 C<s> - single-step, entering subs
+=head4 C<save> - send current history to a file
-Sets C<$single> to 1, which causes C<DB::sub> to continue tracing inside
-subs. Also saves C<s> as C<$lastcmd>.
+Takes the complete history, (not the shrunken version you see with C<H>),
+and saves it to the given filename, so it can be replayed using C<source>.
-=cut
+Note that all C<^(save|source)>'s are commented out with a view to minimise recursion.
- # s - single step.
- $cmd =~ /^s$/ && do {
+=head4 C<R> - restart
- # Get out and restart the command loop if program
- # has finished.
- end_report(), next CMD if $finished and $level <= 1;
+Restart the debugger session.
- # Single step should enter subs.
- $single = 1;
+=head4 C<rerun> - rerun the current session
- # Save for empty command (repeat last).
- $laststep = $cmd;
- last CMD;
- };
+Return to any given position in the B<true>-history list
-=head4 C<c> - run continuously, setting an optional breakpoint
+=head4 C<|, ||> - pipe output through the pager.
-Most of the code for this command is taken up with locating the optional
-breakpoint, which is either a subroutine name or a line number. We set
-the appropriate one-time-break in C<@dbline> and then turn off single-stepping
-in this and all call levels above this one.
+For C<|>, we save C<OUT> (the debugger's output filehandle) and C<STDOUT>
+(the program's standard output). For C<||>, we only save C<OUT>. We open a
+pipe to the pager (restoring the output filehandles if this fails). If this
+is the C<|> command, we also set up a C<SIGPIPE> handler which will simply
+set C<$signal>, sending us back into the debugger.
+We then trim off the pipe symbols and C<redo> the command loop at the
+C<PIPE> label, causing us to evaluate the command in C<$cmd> without
+reading another.
+
=cut
- # c - start continuous execution.
- $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
+ # || - run command in the pager, with output to DB::OUT.
+ _DB__handle_run_command_in_pager_command($obj);
- # Hey, show's over. The debugged program finished
- # executing already.
- end_report(), next CMD if $finished and $level <= 1;
+=head3 END OF COMMAND PARSING
- # Capture the place to put a one-time break.
- $subname = $i = $1;
+Anything left in C<$cmd> at this point is a Perl expression that we want to
+evaluate. We'll always evaluate in the user's context, and fully qualify
+any variables we might want to address in the C<DB> package.
- # Probably not needed, since we finish an interactive
- # sub-session anyway...
- # local $filename = $filename;
- # local *dbline = *dbline; # XXX Would this work?!
- #
- # The above question wonders if localizing the alias
- # to the magic array works or not. Since it's commented
- # out, we'll just leave that to speculation for now.
+=cut
- # If the "subname" isn't all digits, we'll assume it
- # is a subroutine name, and try to find it.
- if ( $subname =~ /\D/ ) { # subroutine name
- # Qualify it to the current package unless it's
- # already qualified.
- $subname = $package . "::" . $subname
- unless $subname =~ /::/;
+ } # PIPE:
- # find_sub will return "file:line_number" corresponding
- # to where the subroutine is defined; we call find_sub,
- # break up the return value, and assign it in one
- # operation.
- ( $file, $i ) = ( find_sub($subname) =~ /^(.*):(.*)$/ );
+ # trace an expression
+ $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
- # Force the line number to be numeric.
- $i += 0;
+ # Make sure the flag that says "the debugger's running" is
+ # still on, to make sure we get control again.
+ $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd";
- # If we got a line number, we found the sub.
- if ($i) {
+ # Run *our* eval that executes in the caller's context.
+ # The &-call is here to ascertain the mutability of @_.
+ &DB::eval;
- # Switch all the debugger's internals around so
- # we're actually working with that file.
- $filename = $file;
- *dbline = $main::{ '_<' . $filename };
+ # Turn off the one-time-dump stuff now.
+ if ($onetimeDump) {
+ $onetimeDump = undef;
+ $onetimedumpDepth = undef;
+ }
+ elsif ( $term_pid == $$ ) {
+ eval { # May run under miniperl, when not available...
+ STDOUT->flush();
+ STDERR->flush();
+ };
- # Mark that there's a breakpoint in this file.
- $had_breakpoints{$filename} |= 1;
+ # XXX If this is the master pid, print a newline.
+ print {$OUT} "\n";
+ }
+ } ## end while (($term || &setterm...
- # Scan forward to the first executable line
- # after the 'sub whatever' line.
- $max = $#dbline;
- ++$i while $dbline[$i] == 0 && $i < $max;
- } ## end if ($i)
+=head3 POST-COMMAND PROCESSING
- # We didn't find a sub by that name.
- else {
- print $OUT "Subroutine $subname not found.\n";
- next CMD;
- }
- } ## end if ($subname =~ /\D/)
+After each command, we check to see if the command output was piped anywhere.
+If so, we go through the necessary code to unhook the pipe and go back to
+our standard filehandles for input and output.
- # At this point, either the subname was all digits (an
- # absolute line-break request) or we've scanned through
- # the code following the definition of the sub, looking
- # for an executable, which we may or may not have found.
- #
- # If $i (which we set $subname from) is non-zero, we
- # got a request to break at some line somewhere. On
- # one hand, if there wasn't any real subroutine name
- # involved, this will be a request to break in the current
- # file at the specified line, so we have to check to make
- # sure that the line specified really is breakable.
- #
- # On the other hand, if there was a subname supplied, the
- # preceding block has moved us to the proper file and
- # location within that file, and then scanned forward
- # looking for the next executable line. We have to make
- # sure that one was found.
- #
- # On the gripping hand, we can't do anything unless the
- # current value of $i points to a valid breakable line.
- # Check that.
- if ($i) {
+=cut
- # Breakable?
- if ( $dbline[$i] == 0 ) {
- print $OUT "Line $i not breakable.\n";
- next CMD;
- }
+ continue { # CMD:
+ _DB__at_end_of_every_command($obj);
+ } # CMD:
- # Yes. Set up the one-time-break sigil.
- $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
- } ## end if ($i)
+=head3 COMMAND LOOP TERMINATION
- # Turn off stack tracing from here up.
- for ( $i = 0 ; $i <= $stack_depth ; ) {
- $stack[ $i++ ] &= ~1;
- }
- last CMD;
- };
+When commands have finished executing, we come here. If the user closed the
+input filehandle, we turn on C<$fall_off_end> to emulate a C<q> command. We
+evaluate any post-prompt items. We restore C<$@>, C<$!>, C<$^E>, C<$,>, C<$/>,
+C<$\>, and C<$^W>, and return a null list as expected by the Perl interpreter.
+The interpreter will then execute the next line and then return control to us
+again.
-=head4 C<r> - return from a subroutine
+=cut
-For C<r> to work properly, the debugger has to stop execution again
-immediately after the return is executed. This is done by forcing
-single-stepping to be on in the call level above the current one. If
-we are printing return values when a C<r> is executed, set C<$doret>
-appropriately, and force us out of the command loop.
+ # No more commands? Quit.
+ $fall_off_end = 1 unless defined $cmd; # Emulate 'q' on EOF
-=cut
+ # Evaluate post-prompt commands.
+ foreach $evalarg (@$post) {
+ # The &-call is here to ascertain the mutability of @_.
+ &DB::eval;
+ }
+ } # if ($single || $signal)
- # r - return from the current subroutine.
- $cmd =~ /^r$/ && do {
+ # Put the user's globals back where you found them.
+ ( $@, $!, $^E, $,, $/, $\, $^W ) = @saved;
+ ();
+} ## end sub DB
- # Can't do anything if the program's over.
- end_report(), next CMD if $finished and $level <= 1;
+# Because DB::Obj is used above,
+#
+# my $obj = DB::Obj->new(
+#
+# The following package declaraton must come before that,
+# or else runtime errors will occur with
+#
+# PERLDB_OPTS="autotrace nonstop"
+#
+# ( rt#116771 )
+BEGIN {
- # Turn on stack trace.
- $stack[$stack_depth] |= 1;
+package DB::Obj;
- # Print return value unless the stack is empty.
- $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
- last CMD;
- };
+sub new {
+ my $class = shift;
-=head4 C<T> - stack trace
+ my $self = bless {}, $class;
-Just calls C<DB::print_trace>.
+ $self->_init(@_);
-=cut
+ return $self;
+}
- $cmd =~ /^T$/ && do {
- print_trace( $OUT, 1 ); # skip DB
- next CMD;
- };
+sub _init {
+ my ($self, $args) = @_;
-=head4 C<w> - List window around current line.
+ %{$self} = (%$self, %$args);
-Just calls C<DB::cmd_w>.
+ return;
+}
-=cut
+{
+ no strict 'refs';
+ foreach my $slot_name (qw(
+ after explicit_stop infix pat piped position prefix selected cmd_verb
+ cmd_args
+ )) {
+ my $slot = $slot_name;
+ *{$slot} = sub {
+ my $self = shift;
- $cmd =~ /^w\b\s*(.*)/s && do { &cmd_w( 'w', $1 ); next CMD; };
+ if (@_) {
+ ${ $self->{$slot} } = shift;
+ }
-=head4 C<W> - watch-expression processing.
+ return ${ $self->{$slot} };
+ };
-Just calls C<DB::cmd_W>.
+ *{"append_to_$slot"} = sub {
+ my $self = shift;
+ my $s = shift;
-=cut
+ return $self->$slot($self->$slot . $s);
+ };
+ }
+}
- $cmd =~ /^W\b\s*(.*)/s && do { &cmd_W( 'W', $1 ); next CMD; };
+sub _DB_on_init__initialize_globals
+{
+ my $self = shift;
-=head4 C</> - search forward for a string in the source
+ # Check for whether we should be running continuously or not.
+ # _After_ the perl program is compiled, $single is set to 1:
+ if ( $single and not $second_time++ ) {
-We take the argument and treat it as a pattern. If it turns out to be a
-bad one, we return the error we got from trying to C<eval> it and exit.
-If not, we create some code to do the search and C<eval> it so it can't
-mess us up.
+ # Options say run non-stop. Run until we get an interrupt.
+ if ($runnonstop) { # Disable until signal
+ # If there's any call stack in place, turn off single
+ # stepping into subs throughout the stack.
+ for my $i (0 .. $stack_depth) {
+ $stack[ $i ] &= ~1;
+ }
-=cut
+ # And we are now no longer in single-step mode.
+ $single = 0;
- $cmd =~ /^\/(.*)$/ && do {
+ # If we simply returned at this point, we wouldn't get
+ # the trace info. Fall on through.
+ # return;
+ } ## end if ($runnonstop)
- # The pattern as a string.
- $inpat = $1;
+ elsif ($ImmediateStop) {
- # Remove the final slash.
- $inpat =~ s:([^\\])/$:$1:;
+ # We are supposed to stop here; XXX probably a break.
+ $ImmediateStop = 0; # We've processed it; turn it off
+ $signal = 1; # Simulate an interrupt to force
+ # us into the command loop
+ }
+ } ## end if ($single and not $second_time...
- # If the pattern isn't null ...
- if ( $inpat ne "" ) {
+ # If we're in single-step mode, or an interrupt (real or fake)
+ # has occurred, turn off non-stop mode.
+ $runnonstop = 0 if $single or $signal;
- # Turn of warn and die procesing for a bit.
- local $SIG{__DIE__};
- local $SIG{__WARN__};
+ return;
+}
- # Create the pattern.
- eval '$inpat =~ m' . "\a$inpat\a";
- if ( $@ ne "" ) {
+sub _my_print_lineinfo
+{
+ my ($self, $i, $incr_pos) = @_;
- # Oops. Bad pattern. No biscuit.
- # Print the eval error and go back for more
- # commands.
- print $OUT "$@";
- next CMD;
- }
- $pat = $inpat;
- } ## end if ($inpat ne "")
+ if ($frame) {
+ # Print it indented if tracing is on.
+ DB::print_lineinfo( ' ' x $stack_depth,
+ "$i:\t$DB::dbline[$i]" . $self->after );
+ }
+ else {
+ DB::depth_print_lineinfo($self->explicit_stop, $incr_pos);
+ }
+}
- # Set up to stop on wrap-around.
- $end = $start;
+sub _curr_line {
+ return $DB::dbline[$line];
+}
- # Don't move off the current line.
- $incr = -1;
+sub _is_full {
+ my ($self, $letter) = @_;
- # Done in eval so nothing breaks if the pattern
- # does something weird.
- eval '
- for (;;) {
- # Move ahead one line.
- ++$start;
+ return ($DB::cmd eq $letter);
+}
- # Wrap if we pass the last line.
- $start = 1 if ($start > $max);
+sub _DB__grab_control
+{
+ my $self = shift;
- # Stop if we have gotten back to this line again,
- last if ($start == $end);
+ # Yes, grab control.
+ if ($slave_editor) {
- # A hit! (Note, though, that we are doing
- # case-insensitive matching. Maybe a qr//
- # expression would be better, so the user could
- # do case-sensitive matching if desired.
- if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
- if ($slave_editor) {
- # Handle proper escaping in the slave.
- print $OUT "\032\032$filename:$start:0\n";
- }
- else {
- # Just print the line normally.
- print $OUT "$start:\t",$dbline[$start],"\n";
- }
- # And quit since we found something.
- last;
- }
- } ';
+ # Tell the editor to update its position.
+ $self->position("\032\032${DB::filename}:$line:0\n");
+ DB::print_lineinfo($self->position());
+ }
- # If we wrapped, there never was a match.
- print $OUT "/$pat/: not found\n" if ( $start == $end );
- next CMD;
- };
+=pod
-=head4 C<?> - search backward for a string in the source
+Special check: if we're in package C<DB::fake>, we've gone through the
+C<END> block at least once. We set up everything so that we can continue
+to enter commands and have a valid context to be in.
-Same as for C</>, except the loop runs backwards.
-
=cut
- # ? - backward pattern search.
- $cmd =~ /^\?(.*)$/ && do {
+ elsif ( $DB::package eq 'DB::fake' ) {
- # Get the pattern, remove trailing question mark.
- $inpat = $1;
- $inpat =~ s:([^\\])\?$:$1:;
+ # Fallen off the end already.
+ if (!$DB::term) {
+ DB::setterm();
+ }
- # If we've got one ...
- if ( $inpat ne "" ) {
+ DB::print_help(<<EOP);
+Debugged program terminated. Use B<q> to quit or B<R> to restart,
+use B<o> I<inhibit_exit> to avoid stopping after program termination,
+B<h q>, B<h R> or B<h o> to get additional info.
+EOP
- # Turn off die & warn handlers.
- local $SIG{__DIE__};
- local $SIG{__WARN__};
- eval '$inpat =~ m' . "\a$inpat\a";
+ # Set the DB::eval context appropriately.
+ $DB::package = 'main';
+ $DB::usercontext = DB::_calc_usercontext($DB::package);
+ } ## end elsif ($package eq 'DB::fake')
- if ( $@ ne "" ) {
+=pod
- # Ouch. Not good. Print the error.
- print $OUT $@;
- next CMD;
- }
- $pat = $inpat;
- } ## end if ($inpat ne "")
+If the program hasn't finished executing, we scan forward to the
+next executable line, print that out, build the prompt from the file and line
+number information, and print that.
- # Where we are now is where to stop after wraparound.
- $end = $start;
+=cut
- # Don't move away from this line.
- $incr = -1;
+ else {
- # Search inside the eval to prevent pattern badness
- # from killing us.
- eval '
- for (;;) {
- # Back up a line.
- --$start;
- # Wrap if we pass the first line.
+ # Still somewhere in the midst of execution. Set up the
+ # debugger prompt.
+ $DB::sub =~ s/\'/::/; # Swap Perl 4 package separators (') to
+ # Perl 5 ones (sorry, we don't print Klingon
+ #module names)
- $start = $max if ($start <= 0);
+ $self->prefix($DB::sub =~ /::/ ? "" : ($DB::package . '::'));
+ $self->append_to_prefix( "$DB::sub(${DB::filename}:" );
+ $self->after( $self->_curr_line =~ /\n$/ ? '' : "\n" );
- # Quit if we get back where we started,
- last if ($start == $end);
+ # Break up the prompt if it's really long.
+ if ( length($self->prefix()) > 30 ) {
+ $self->position($self->prefix . "$line):\n$line:\t" . $self->_curr_line . $self->after);
+ $self->prefix("");
+ $self->infix(":\t");
+ }
+ else {
+ $self->infix("):\t");
+ $self->position(
+ $self->prefix . $line. $self->infix
+ . $self->_curr_line . $self->after
+ );
+ }
- # Match?
- if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
- if ($slave_editor) {
- # Yep, follow slave editor requirements.
- print $OUT "\032\032$filename:$start:0\n";
- }
- else {
- # Yep, just print normally.
- print $OUT "$start:\t",$dbline[$start],"\n";
- }
+ # Print current line info, indenting if necessary.
+ $self->_my_print_lineinfo($line, $self->position);
- # Found, so done.
- last;
- }
- } ';
+ my $i;
+ my $line_i = sub { return $DB::dbline[$i]; };
- # Say we failed if the loop never found anything,
- print $OUT "?$pat?: not found\n" if ( $start == $end );
- next CMD;
- };
+ # Scan forward, stopping at either the end or the next
+ # unbreakable line.
+ for ( $i = $line + 1 ; $i <= $DB::max && $line_i->() == 0 ; ++$i )
+ { #{ vi
-=head4 C<$rc> - Recall command
+ # Drop out on null statements, block closers, and comments.
+ last if $line_i->() =~ /^\s*[\;\}\#\n]/;
-Manages the commands in C<@hist> (which is created if C<Term::ReadLine> reports
-that the terminal supports history). It find the the command required, puts it
-into C<$cmd>, and redoes the loop to execute it.
+ # Drop out if the user interrupted us.
+ last if $signal;
-=cut
+ # Append a newline if the line doesn't have one. Can happen
+ # in eval'ed text, for instance.
+ $self->after( $line_i->() =~ /\n$/ ? '' : "\n" );
- # $rc - recall command.
- $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
+ # Next executable line.
+ my $incr_pos = $self->prefix . $i . $self->infix . $line_i->()
+ . $self->after;
+ $self->append_to_position($incr_pos);
+ $self->_my_print_lineinfo($i, $incr_pos);
+ } ## end for ($i = $line + 1 ; $i...
+ } ## end else [ if ($slave_editor)
- # No arguments, take one thing off history.
- pop(@hist) if length($cmd) > 1;
+ return;
+}
- # Relative (- found)?
- # Y - index back from most recent (by 1 if bare minus)
- # N - go to that particular command slot or the last
- # thing if nothing following.
- $i = $1 ? ( $#hist - ( $2 || 1 ) ) : ( $2 || $#hist );
+sub _handle_t_command {
+ my $self = shift;
- # Pick out the command desired.
- $cmd = $hist[$i];
+ my $levels = $self->cmd_args();
- # Print the command to be executed and restart the loop
- # with that command in the buffer.
- print $OUT $cmd, "\n";
- redo CMD;
- };
+ if ((!length($levels)) or ($levels !~ /\D/)) {
+ $trace ^= 1;
+ local $\ = '';
+ $DB::trace_to_depth = $levels ? $stack_depth + $levels : 1E9;
+ print {$OUT} "Trace = "
+ . ( ( $trace & 1 )
+ ? ( $levels ? "on (to level $DB::trace_to_depth)" : "on" )
+ : "off" ) . "\n";
+ next CMD;
+ }
-=head4 C<$sh$sh> - C<system()> command
+ return;
+}
-Calls the C<DB::system()> to handle the command. This keeps the C<STDIN> and
-C<STDOUT> from getting messed up.
-=cut
+sub _handle_S_command {
+ my $self = shift;
- # $sh$sh - run a shell command (if it's all ASCII).
- # Can't run shell commands with Unicode in the debugger, hmm.
- $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
+ if (my ($print_all_subs, $should_reverse, $Spatt)
+ = $self->cmd_args =~ /\A((!)?(.+))?\z/) {
+ # $Spatt is the pattern (if any) to use.
+ # Reverse scan?
+ my $Srev = defined $should_reverse;
+ # No args - print all subs.
+ my $Snocheck = !defined $print_all_subs;
- # System it.
- &system($1);
- next CMD;
- };
+ # Need to make these sane here.
+ local $\ = '';
+ local $, = '';
-=head4 C<$rc I<pattern> $rc> - Search command history
+ # Search through the debugger's magical hash of subs.
+ # If $nocheck is true, just print the sub name.
+ # Otherwise, check it against the pattern. We then use
+ # the XOR trick to reverse the condition as required.
+ foreach $subname ( sort( keys %sub ) ) {
+ if ( $Snocheck or $Srev ^ ( $subname =~ /$Spatt/ ) ) {
+ print $OUT $subname, "\n";
+ }
+ }
+ next CMD;
+ }
-Another command to manipulate C<@hist>: this one searches it with a pattern.
-If a command is found, it is placed in C<$cmd> and executed via C<redo>.
+ return;
+}
-=cut
+sub _handle_V_command_and_X_command {
+ my $self = shift;
- # $rc pattern $rc - find a command in the history.
- $cmd =~ /^$rc([^$rc].*)$/ && do {
+ $DB::cmd =~ s/^X\b/V $DB::package/;
- # Create the pattern to use.
- $pat = "^$1";
+ # Bare V commands get the currently-being-debugged package
+ # added.
+ if ($self->_is_full('V')) {
+ $DB::cmd = "V $DB::package";
+ }
- # Toss off last entry if length is >1 (and it always is).
- pop(@hist) if length($cmd) > 1;
+ # V - show variables in package.
+ if (my ($new_packname, $new_vars_str) =
+ $DB::cmd =~ /\AV\b\s*(\S+)\s*(.*)/) {
- # Look backward through the history.
- for ( $i = $#hist ; $i ; --$i ) {
+ # Save the currently selected filehandle and
+ # force output to debugger's filehandle (dumpvar
+ # just does "print" for output).
+ my $savout = select($OUT);
- # Stop if we find it.
- last if $hist[$i] =~ /$pat/;
- }
+ # Grab package name and variables to dump.
+ $packname = $new_packname;
+ my @vars = split( ' ', $new_vars_str );
- if ( !$i ) {
+ # If main::dumpvar isn't here, get it.
+ do 'dumpvar.pl' || die $@ unless defined &main::dumpvar;
+ if ( defined &main::dumpvar ) {
- # Never found it.
- print $OUT "No such command!\n\n";
- next CMD;
- }
+ # We got it. Turn off subroutine entry/exit messages
+ # for the moment, along with return values.
+ local $frame = 0;
+ local $doret = -2;
- # Found it. Put it in the buffer, print it, and process it.
- $cmd = $hist[$i];
- print $OUT $cmd, "\n";
- redo CMD;
- };
+ # must detect sigpipe failures - not catching
+ # then will cause the debugger to die.
+ eval {
+ main::dumpvar(
+ $packname,
+ defined $option{dumpDepth}
+ ? $option{dumpDepth}
+ : -1, # assume -1 unless specified
+ @vars
+ );
+ };
-=head4 C<$sh> - Invoke a shell
+ # The die doesn't need to include the $@, because
+ # it will automatically get propagated for us.
+ if ($@) {
+ die unless $@ =~ /dumpvar print failed/;
+ }
+ } ## end if (defined &main::dumpvar)
+ else {
-Uses C<DB::system> to invoke a shell.
+ # Couldn't load dumpvar.
+ print $OUT "dumpvar.pl not available.\n";
+ }
-=cut
+ # Restore the output filehandle, and go round again.
+ select($savout);
+ next CMD;
+ }
- # $sh - start a shell.
- $cmd =~ /^$sh$/ && do {
+ return;
+}
- # Run the user's shell. If none defined, run Bourne.
- # We resume execution when the shell terminates.
- &system( $ENV{SHELL} || "/bin/sh" );
- next CMD;
- };
+sub _handle_dash_command {
+ my $self = shift;
-=head4 C<$sh I<command>> - Force execution of a command in a shell
+ if ($self->_is_full('-')) {
-Like the above, but the command is passed to the shell. Again, we use
-C<DB::system> to avoid problems with C<STDIN> and C<STDOUT>.
+ # back up by a window; go to 1 if back too far.
+ $start -= $incr + $window + 1;
+ $start = 1 if $start <= 0;
+ $incr = $window - 1;
-=cut
+ # Generate and execute a "l +" command (handled below).
+ $DB::cmd = 'l ' . ($start) . '+';
+ redo CMD;
+ }
+ return;
+}
- # $sh command - start a shell and run a command in it.
- $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
+sub _n_or_s_commands_generic {
+ my ($self, $new_val) = @_;
+ # n - next
+ next CMD if DB::_DB__is_finished();
- # XXX: using csh or tcsh destroys sigint retvals!
- #&system($1); # use this instead
+ # Single step, but don't enter subs.
+ $single = $new_val;
- # use the user's shell, or Bourne if none defined.
- &system( $ENV{SHELL} || "/bin/sh", "-c", $1 );
- next CMD;
- };
+ # Save for empty command (repeat last).
+ $laststep = $DB::cmd;
+ last CMD;
+}
-=head4 C<H> - display commands in history
+sub _n_or_s {
+ my ($self, $letter, $new_val) = @_;
-Prints the contents of C<@hist> (if any).
+ if ($self->_is_full($letter)) {
+ $self->_n_or_s_commands_generic($new_val);
+ }
+ else {
+ $self->_n_or_s_and_arg_commands_generic($letter, $new_val);
+ }
-=cut
+ return;
+}
- $cmd =~ /^H\b\s*\*/ && do {
- @hist = @truehist = ();
- print $OUT "History cleansed\n";
- next CMD;
- };
+sub _handle_n_command {
+ my $self = shift;
- $cmd =~ /^H\b\s*(-(\d+))?/ && do {
+ return $self->_n_or_s('n', 2);
+}
- # Anything other than negative numbers is ignored by
- # the (incorrect) pattern, so this test does nothing.
- $end = $2 ? ( $#hist - $2 ) : 0;
+sub _handle_s_command {
+ my $self = shift;
- # Set to the minimum if less than zero.
- $hist = 0 if $hist < 0;
+ return $self->_n_or_s('s', 1);
+}
- # Start at the end of the array.
- # Stay in while we're still above the ending value.
- # Tick back by one each time around the loop.
- for ( $i = $#hist ; $i > $end ; $i-- ) {
+sub _handle_r_command {
+ my $self = shift;
- # Print the command unless it has no arguments.
- print $OUT "$i: ", $hist[$i], "\n"
- unless $hist[$i] =~ /^.?$/;
- }
- next CMD;
- };
+ # r - return from the current subroutine.
+ if ($self->_is_full('r')) {
-=head4 C<man, doc, perldoc> - look up documentation
+ # Can't do anything if the program's over.
+ next CMD if DB::_DB__is_finished();
-Just calls C<runman()> to print the appropriate document.
+ # Turn on stack trace.
+ $stack[$stack_depth] |= 1;
-=cut
+ # Print return value unless the stack is empty.
+ $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
+ last CMD;
+ }
- # man, perldoc, doc - show manual pages.
- $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do {
- runman($1);
- next CMD;
- };
+ return;
+}
-=head4 C<p> - print
+sub _handle_T_command {
+ my $self = shift;
-Builds a C<print EXPR> expression in the C<$cmd>; this will get executed at
-the bottom of the loop.
+ if ($self->_is_full('T')) {
+ DB::print_trace( $OUT, 1 ); # skip DB
+ next CMD;
+ }
-=cut
+ return;
+}
- # p - print (no args): print $_.
- $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
+sub _handle_w_command {
+ my $self = shift;
- # p - print the given expression.
- $cmd =~ s/^p\b/print {\$DB::OUT} /;
+ DB::cmd_w( 'w', $self->cmd_args() );
+ next CMD;
-=head4 C<=> - define command alias
+ return;
+}
-Manipulates C<%alias> to add or list command aliases.
+sub _handle_W_command {
+ my $self = shift;
-=cut
+ if (my $arg = $self->cmd_args) {
+ DB::cmd_W( 'W', $arg );
+ next CMD;
+ }
- # = - set up a command alias.
- $cmd =~ s/^=\s*// && do {
- my @keys;
- if ( length $cmd == 0 ) {
+ return;
+}
- # No args, get current aliases.
- @keys = sort keys %alias;
- }
- elsif ( my ( $k, $v ) = ( $cmd =~ /^(\S+)\s+(\S.*)/ ) ) {
+sub _handle_rc_recall_command {
+ my $self = shift;
- # Creating a new alias. $k is alias name, $v is
- # alias value.
+ # $rc - recall command.
+ if (my ($minus, $arg) = $DB::cmd =~ m#\A$rc+\s*(-)?(\d+)?\z#) {
- # can't use $_ or kill //g state
- for my $x ( $k, $v ) {
+ # No arguments, take one thing off history.
+ pop(@hist) if length($DB::cmd) > 1;
- # Escape "alarm" characters.
- $x =~ s/\a/\\a/g;
- }
+ # Relative (- found)?
+ # Y - index back from most recent (by 1 if bare minus)
+ # N - go to that particular command slot or the last
+ # thing if nothing following.
- # Substitute key for value, using alarm chars
- # as separators (which is why we escaped them in
- # the command).
- $alias{$k} = "s\a$k\a$v\a";
+ $self->cmd_verb(
+ scalar($minus ? ( $#hist - ( $arg || 1 ) ) : ( $arg || $#hist ))
+ );
- # Turn off standard warn and die behavior.
- local $SIG{__DIE__};
- local $SIG{__WARN__};
+ # Pick out the command desired.
+ $DB::cmd = $hist[$self->cmd_verb];
- # Is it valid Perl?
- unless ( eval "sub { s\a$k\a$v\a }; 1" ) {
+ # Print the command to be executed and restart the loop
+ # with that command in the buffer.
+ print {$OUT} $DB::cmd, "\n";
+ redo CMD;
+ }
- # Nope. Bad alias. Say so and get out.
- print $OUT "Can't alias $k to $v: $@\n";
- delete $alias{$k};
- next CMD;
- }
+ return;
+}
- # We'll only list the new one.
- @keys = ($k);
- } ## end elsif (my ($k, $v) = ($cmd...
+sub _handle_rc_search_history_command {
+ my $self = shift;
- # The argument is the alias to list.
- else {
- @keys = ($cmd);
- }
+ # $rc pattern $rc - find a command in the history.
+ if (my ($arg) = $DB::cmd =~ /\A$rc([^$rc].*)\z/) {
- # List aliases.
- for my $k (@keys) {
+ # Create the pattern to use.
+ my $pat = "^$arg";
+ $self->pat($pat);
- # Messy metaquoting: Trim the substitution code off.
- # We use control-G as the delimiter because it's not
- # likely to appear in the alias.
- if ( ( my $v = $alias{$k} ) =~ ss\a$k\a(.*)\a$1 ) {
+ # Toss off last entry if length is >1 (and it always is).
+ pop(@hist) if length($DB::cmd) > 1;
- # Print the alias.
- print $OUT "$k\t= $1\n";
- }
- elsif ( defined $alias{$k} ) {
+ my $i;
- # Couldn't trim it off; just print the alias code.
- print $OUT "$k\t$alias{$k}\n";
- }
- else {
+ # Look backward through the history.
+ SEARCH_HIST:
+ for ( $i = $#hist ; $i ; --$i ) {
+ # Stop if we find it.
+ last SEARCH_HIST if $hist[$i] =~ /$pat/;
+ }
- # No such, dude.
- print "No alias for $k\n";
- }
- } ## end for my $k (@keys)
- next CMD;
- };
+ if ( !$i ) {
-=head4 C<source> - read commands from a file.
+ # Never found it.
+ print $OUT "No such command!\n\n";
+ next CMD;
+ }
-Opens a lexical filehandle and stacks it on C<@cmdfhs>; C<DB::readline> will
-pick it up.
+ # Found it. Put it in the buffer, print it, and process it.
+ $DB::cmd = $hist[$i];
+ print $OUT $DB::cmd, "\n";
+ redo CMD;
+ }
-=cut
+ return;
+}
- # source - read commands from a file (or pipe!) and execute.
- $cmd =~ /^source\s+(.*\S)/ && do {
- if ( open my $fh, $1 ) {
+sub _handle_H_command {
+ my $self = shift;
- # Opened OK; stick it in the list of file handles.
- push @cmdfhs, $fh;
- }
- else {
+ if ($self->cmd_args =~ m#\A\*#) {
+ @hist = @truehist = ();
+ print $OUT "History cleansed\n";
+ next CMD;
+ }
- # Couldn't open it.
- &warn("Can't execute `$1': $!\n");
- }
- next CMD;
- };
+ if (my ($num) = $self->cmd_args =~ /\A(?:-(\d+))?/) {
-=head4 C<save> - send current history to a file
+ # Anything other than negative numbers is ignored by
+ # the (incorrect) pattern, so this test does nothing.
+ $end = $num ? ( $#hist - $num ) : 0;
-Takes the complete history, (not the shrunken version you see with C<H>),
-and saves it to the given filename, so it can be replayed using C<source>.
+ # Set to the minimum if less than zero.
+ $hist = 0 if $hist < 0;
-Note that all C<^(save|source)>'s are commented out with a view to minimise recursion.
+ # Start at the end of the array.
+ # Stay in while we're still above the ending value.
+ # Tick back by one each time around the loop.
+ my $i;
-=cut
+ for ( $i = $#hist ; $i > $end ; $i-- ) {
- # save source - write commands to a file for later use
- $cmd =~ /^save\s*(.*)$/ && do {
- my $file = $1 || '.perl5dbrc'; # default?
- if ( open my $fh, "> $file" ) {
+ # Print the command unless it has no arguments.
+ print $OUT "$i: ", $hist[$i], "\n"
+ unless $hist[$i] =~ /^.?$/;
+ }
- # chomp to remove extraneous newlines from source'd files
- chomp( my @truelist =
- map { m/^\s*(save|source)/ ? "#$_" : $_ }
- @truehist );
- print $fh join( "\n", @truelist );
- print "commands saved in $file\n";
- }
- else {
- &warn("Can't save debugger commands in '$1': $!\n");
- }
- next CMD;
- };
+ next CMD;
+ }
-=head4 C<R> - restart
+ return;
+}
-Restart the debugger session.
+sub _handle_doc_command {
+ my $self = shift;
-=head4 C<rerun> - rerun the current session
+ # man, perldoc, doc - show manual pages.
+ if (my ($man_page)
+ = $DB::cmd =~ /\A(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?\z/) {
+ DB::runman($man_page);
+ next CMD;
+ }
-Return to any given position in the B<true>-history list
+ return;
+}
-=cut
+sub _handle_p_command {
+ my $self = shift;
- # R - restart execution.
- # rerun - controlled restart execution.
- $cmd =~ /^(R|rerun\s*(.*))$/ && do {
- my @args = ($1 eq 'R' ? restart() : rerun($2));
+ my $print_cmd = 'print {$DB::OUT} ';
+ # p - print (no args): print $_.
+ if ($self->_is_full('p')) {
+ $DB::cmd = $print_cmd . '$_';
+ }
+ else {
+ # p - print the given expression.
+ $DB::cmd =~ s/\Ap\b/$print_cmd /;
+ }
- # Close all non-system fds for a clean restart. A more
- # correct method would be to close all fds that were not
- # open when the process started, but this seems to be
- # hard. See "debugger 'R'estart and open database
- # connections" on p5p.
+ return;
+}
- my $max_fd = 1024; # default if POSIX can't be loaded
- if (eval { require POSIX }) {
- $max_fd = POSIX::sysconf(POSIX::_SC_OPEN_MAX());
- }
+sub _handle_equal_sign_command {
+ my $self = shift;
- if (defined $max_fd) {
- foreach ($^F+1 .. $max_fd-1) {
- next unless open FD_TO_CLOSE, "<&=$_";
- close(FD_TO_CLOSE);
- }
- }
+ if ($DB::cmd =~ s/\A=\s*//) {
+ my @keys;
+ if ( length $DB::cmd == 0 ) {
- # And run Perl again. We use exec() to keep the
- # PID stable (and that way $ini_pids is still valid).
- exec(@args) || print $OUT "exec failed: $!\n";
+ # No args, get current aliases.
+ @keys = sort keys %alias;
+ }
+ elsif ( my ( $k, $v ) = ( $DB::cmd =~ /^(\S+)\s+(\S.*)/ ) ) {
- last CMD;
- };
+ # Creating a new alias. $k is alias name, $v is
+ # alias value.
-=head4 C<|, ||> - pipe output through the pager.
+ # can't use $_ or kill //g state
+ for my $x ( $k, $v ) {
-For C<|>, we save C<OUT> (the debugger's output filehandle) and C<STDOUT>
-(the program's standard output). For C<||>, we only save C<OUT>. We open a
-pipe to the pager (restoring the output filehandles if this fails). If this
-is the C<|> command, we also set up a C<SIGPIPE> handler which will simply
-set C<$signal>, sending us back into the debugger.
+ # Escape "alarm" characters.
+ $x =~ s/\a/\\a/g;
+ }
-We then trim off the pipe symbols and C<redo> the command loop at the
-C<PIPE> label, causing us to evaluate the command in C<$cmd> without
-reading another.
+ # Substitute key for value, using alarm chars
+ # as separators (which is why we escaped them in
+ # the command).
+ $alias{$k} = "s\a$k\a$v\a";
-=cut
+ # Turn off standard warn and die behavior.
+ local $SIG{__DIE__};
+ local $SIG{__WARN__};
- # || - run command in the pager, with output to DB::OUT.
- $cmd =~ /^\|\|?\s*[^|]/ && do {
- if ( $pager =~ /^\|/ ) {
+ # Is it valid Perl?
+ unless ( eval "sub { s\a$k\a$v\a }; 1" ) {
- # Default pager is into a pipe. Redirect I/O.
- open( SAVEOUT, ">&STDOUT" )
- || &warn("Can't save STDOUT");
- open( STDOUT, ">&OUT" )
- || &warn("Can't redirect STDOUT");
- } ## end if ($pager =~ /^\|/)
- else {
+ # Nope. Bad alias. Say so and get out.
+ print $OUT "Can't alias $k to $v: $@\n";
+ delete $alias{$k};
+ next CMD;
+ }
- # Not into a pipe. STDOUT is safe.
- open( SAVEOUT, ">&OUT" ) || &warn("Can't save DB::OUT");
- }
+ # We'll only list the new one.
+ @keys = ($k);
+ } ## end elsif (my ($k, $v) = ($DB::cmd...
- # Fix up environment to record we have less if so.
- fix_less();
+ # The argument is the alias to list.
+ else {
+ @keys = ($DB::cmd);
+ }
- unless ( $piped = open( OUT, $pager ) ) {
+ # List aliases.
+ for my $k (@keys) {
- # Couldn't open pipe to pager.
- &warn("Can't pipe output to `$pager'");
- if ( $pager =~ /^\|/ ) {
+ # Messy metaquoting: Trim the substitution code off.
+ # We use control-G as the delimiter because it's not
+ # likely to appear in the alias.
+ if ( ( my $v = $alias{$k} ) =~ ss\a$k\a(.*)\a$1 ) {
- # Redirect I/O back again.
- open( OUT, ">&STDOUT" ) # XXX: lost message
- || &warn("Can't restore DB::OUT");
- open( STDOUT, ">&SAVEOUT" )
- || &warn("Can't restore STDOUT");
- close(SAVEOUT);
- } ## end if ($pager =~ /^\|/)
- else {
+ # Print the alias.
+ print $OUT "$k\t= $1\n";
+ }
+ elsif ( defined $alias{$k} ) {
- # Redirect I/O. STDOUT already safe.
- open( OUT, ">&STDOUT" ) # XXX: lost message
- || &warn("Can't restore DB::OUT");
- }
- next CMD;
- } ## end unless ($piped = open(OUT,...
+ # Couldn't trim it off; just print the alias code.
+ print $OUT "$k\t$alias{$k}\n";
+ }
+ else {
- # Set up broken-pipe handler if necessary.
- $SIG{PIPE} = \&DB::catch
- if $pager =~ /^\|/
- && ( "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE} );
+ # No such, dude.
+ print "No alias for $k\n";
+ }
+ } ## end for my $k (@keys)
+ next CMD;
+ }
- # Save current filehandle, unbuffer out, and put it back.
- $selected = select(OUT);
- $| = 1;
+ return;
+}
- # Don't put it back if pager was a pipe.
- select($selected), $selected = "" unless $cmd =~ /^\|\|/;
+sub _handle_source_command {
+ my $self = shift;
- # Trim off the pipe symbols and run the command now.
- $cmd =~ s/^\|+\s*//;
- redo PIPE;
- };
+ # source - read commands from a file (or pipe!) and execute.
+ if (my $sourced_fn = $self->cmd_args) {
+ if ( open my $fh, $sourced_fn ) {
-=head3 END OF COMMAND PARSING
+ # Opened OK; stick it in the list of file handles.
+ push @cmdfhs, $fh;
+ }
+ else {
-Anything left in C<$cmd> at this point is a Perl expression that we want to
-evaluate. We'll always evaluate in the user's context, and fully qualify
-any variables we might want to address in the C<DB> package.
+ # Couldn't open it.
+ DB::_db_warn("Can't execute '$sourced_fn': $!\n");
+ }
+ next CMD;
+ }
-=cut
+ return;
+}
- # t - turn trace on.
- $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
+sub _handle_enable_disable_commands {
+ my $self = shift;
- # s - single-step. Remember the last command was 's'.
- $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do { $laststep = 's' };
+ my $which_cmd = $self->cmd_verb;
+ my $position = $self->cmd_args;
- # n - single-step, but not into subs. Remember last command
- # was 'n'.
- $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do { $laststep = 'n' };
+ if ($position !~ /\s/) {
+ my ($fn, $line_num);
+ if ($position =~ m{\A\d+\z})
+ {
+ $fn = $DB::filename;
+ $line_num = $position;
+ }
+ elsif (my ($new_fn, $new_line_num)
+ = $position =~ m{\A(.*):(\d+)\z}) {
+ ($fn, $line_num) = ($new_fn, $new_line_num);
+ }
+ else
+ {
+ DB::_db_warn("Wrong spec for enable/disable argument.\n");
+ }
- } # PIPE:
+ if (defined($fn)) {
+ if (DB::_has_breakpoint_data_ref($fn, $line_num)) {
+ DB::_set_breakpoint_enabled_status($fn, $line_num,
+ ($which_cmd eq 'enable' ? 1 : '')
+ );
+ }
+ else {
+ DB::_db_warn("No breakpoint set at ${fn}:${line_num}\n");
+ }
+ }
- # Make sure the flag that says "the debugger's running" is
- # still on, to make sure we get control again.
- $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd";
+ next CMD;
+ }
- # Run *our* eval that executes in the caller's context.
- &eval;
+ return;
+}
- # Turn off the one-time-dump stuff now.
- if ($onetimeDump) {
- $onetimeDump = undef;
- $onetimedumpDepth = undef;
- }
- elsif ( $term_pid == $$ ) {
- eval { # May run under miniperl, when not available...
- STDOUT->flush();
- STDERR->flush();
- };
+sub _handle_save_command {
+ my $self = shift;
- # XXX If this is the master pid, print a newline.
- print $OUT "\n";
- }
- } ## end while (($term || &setterm...
+ if (my $new_fn = $self->cmd_args) {
+ my $filename = $new_fn || '.perl5dbrc'; # default?
+ if ( open my $fh, '>', $filename ) {
-=head3 POST-COMMAND PROCESSING
+ # chomp to remove extraneous newlines from source'd files
+ chomp( my @truelist =
+ map { m/\A\s*(save|source)/ ? "#$_" : $_ }
+ @truehist );
+ print {$fh} join( "\n", @truelist );
+ print "commands saved in $filename\n";
+ }
+ else {
+ DB::_db_warn("Can't save debugger commands in '$new_fn': $!\n");
+ }
+ next CMD;
+ }
-After each command, we check to see if the command output was piped anywhere.
-If so, we go through the necessary code to unhook the pipe and go back to
-our standard filehandles for input and output.
+ return;
+}
-=cut
+sub _n_or_s_and_arg_commands_generic {
+ my ($self, $letter, $new_val) = @_;
- continue { # CMD:
+ # s - single-step. Remember the last command was 's'.
+ if ($DB::cmd =~ s#\A\Q$letter\E\s#\$DB::single = $new_val;\n#) {
+ $laststep = $letter;
+ }
- # At the end of every command:
- if ($piped) {
+ return;
+}
- # Unhook the pipe mechanism now.
- if ( $pager =~ /^\|/ ) {
+sub _handle_sh_command {
+ my $self = shift;
- # No error from the child.
- $? = 0;
+ # $sh$sh - run a shell command (if it's all ASCII).
+ # Can't run shell commands with Unicode in the debugger, hmm.
+ my $my_cmd = $DB::cmd;
+ if ($my_cmd =~ m#\A$sh#gms) {
- # we cannot warn here: the handle is missing --tchrist
- close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
+ if ($my_cmd =~ m#\G\z#cgms) {
+ # Run the user's shell. If none defined, run Bourne.
+ # We resume execution when the shell terminates.
+ DB::_db_system( $ENV{SHELL} || "/bin/sh" );
+ next CMD;
+ }
+ elsif ($my_cmd =~ m#\G$sh\s*(.*)#cgms) {
+ # System it.
+ DB::_db_system($1);
+ next CMD;
+ }
+ elsif ($my_cmd =~ m#\G\s*(.*)#cgms) {
+ DB::_db_system( $ENV{SHELL} || "/bin/sh", "-c", $1 );
+ next CMD;
+ }
+ }
+}
- # most of the $? crud was coping with broken cshisms
- # $? is explicitly set to 0, so this never runs.
- if ($?) {
- print SAVEOUT "Pager `$pager' failed: ";
- if ( $? == -1 ) {
- print SAVEOUT "shell returned -1\n";
- }
- elsif ( $? >> 8 ) {
- print SAVEOUT ( $? & 127 )
- ? " (SIG#" . ( $? & 127 ) . ")"
- : "", ( $? & 128 ) ? " -- core dumped" : "", "\n";
- }
- else {
- print SAVEOUT "status ", ( $? >> 8 ), "\n";
- }
- } ## end if ($?)
+sub _handle_x_command {
+ my $self = shift;
- # Reopen filehandle for our output (if we can) and
- # restore STDOUT (if we can).
- open( OUT, ">&STDOUT" ) || &warn("Can't restore DB::OUT");
- open( STDOUT, ">&SAVEOUT" )
- || &warn("Can't restore STDOUT");
+ if ($DB::cmd =~ s#\Ax\b# #) { # Remainder gets done by DB::eval()
+ $onetimeDump = 'dump'; # main::dumpvar shows the output
- # Turn off pipe exception handler if necessary.
- $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
+ # handle special "x 3 blah" syntax XXX propagate
+ # doc back to special variables.
+ if ( $DB::cmd =~ s#\A\s*(\d+)(?=\s)# #) {
+ $onetimedumpDepth = $1;
+ }
+ }
- # Will stop ignoring SIGPIPE if done like nohup(1)
- # does SIGINT but Perl doesn't give us a choice.
- } ## end if ($pager =~ /^\|/)
- else {
+ return;
+}
- # Non-piped "pager". Just restore STDOUT.
- open( OUT, ">&SAVEOUT" ) || &warn("Can't restore DB::OUT");
- }
+sub _handle_q_command {
+ my $self = shift;
- # Close filehandle pager was using, restore the normal one
- # if necessary,
- close(SAVEOUT);
- select($selected), $selected = "" unless $selected eq "";
+ if ($self->_is_full('q')) {
+ $fall_off_end = 1;
+ DB::clean_ENV();
+ exit $?;
+ }
- # No pipes now.
- $piped = "";
- } ## end if ($piped)
- } # CMD:
+ return;
+}
-=head3 COMMAND LOOP TERMINATION
+sub _handle_cmd_wrapper_commands {
+ my $self = shift;
-When commands have finished executing, we come here. If the user closed the
-input filehandle, we turn on C<$fall_off_end> to emulate a C<q> command. We
-evaluate any post-prompt items. We restore C<$@>, C<$!>, C<$^E>, C<$,>, C<$/>,
-C<$\>, and C<$^W>, and return a null list as expected by the Perl interpreter.
-The interpreter will then execute the next line and then return control to us
-again.
+ DB::cmd_wrapper( $self->cmd_verb, $self->cmd_args, $line );
+ next CMD;
+}
-=cut
+sub _handle_special_char_cmd_wrapper_commands {
+ my $self = shift;
- # No more commands? Quit.
- $fall_off_end = 1 unless defined $cmd; # Emulate `q' on EOF
+ # All of these commands were remapped in perl 5.8.0;
+ # we send them off to the secondary dispatcher (see below).
+ if (my ($cmd_letter, $my_arg) = $DB::cmd =~ /\A([<>\{]{1,2})\s*(.*)/so) {
+ DB::cmd_wrapper( $cmd_letter, $my_arg, $line );
+ next CMD;
+ }
- # Evaluate post-prompt commands.
- foreach $evalarg (@$post) {
- &eval;
- }
- } # if ($single || $signal)
+ return;
+}
- # Put the user's globals back where you found them.
- ( $@, $!, $^E, $,, $/, $\, $^W ) = @saved;
- ();
-} ## end sub DB
+} ## end DB::Obj
+package DB;
+
# The following code may be executed now:
# BEGIN {warn 4}
=head2 sub
-C<sub> is called whenever a subroutine call happens in the program being
+C<sub> is called whenever a subroutine call happens in the program being
debugged. The variable C<$DB::sub> contains the name of the subroutine
being called.
@@ -3562,7 +3992,7 @@
C<sub> does all the work of printing the subroutine entry and exit messages
enabled by setting C<$frame>. It notes what sub the autoloader got called for,
-and also prints the return value if needed (for the C<r> command and if
+and also prints the return value if needed (for the C<r> command and if
the 16 bit is set in C<$frame>).
It also tracks the subroutine call depth by saving the current setting of
@@ -3626,24 +4056,61 @@
=cut
-sub sub {
- # Do not use a regex in this subroutine -> results in corrupted memory
- # See: [perl #66110]
+use vars qw($deep);
- # lock ourselves under threads
- lock($DBGR);
+# We need to fully qualify the name ("DB::sub") to make "use strict;"
+# happy. -- Shlomi Fish
+sub _indent_print_line_info {
+ my ($offset, $str) = @_;
+
+ print_lineinfo( ' ' x ($stack_depth - $offset), $str);
+
+ return;
+}
+
+sub _print_frame_message {
+ my ($al) = @_;
+
+ if ($frame) {
+ if ($frame & 4) { # Extended frame entry message
+ _indent_print_line_info(-1, "in ");
+
+ # Why -1? But it works! :-(
+ # Because print_trace will call add 1 to it and then call
+ # dump_trace; this results in our skipping -1+1 = 0 stack frames
+ # in dump_trace.
+ #
+ # Now it's 0 because we extracted a function.
+ print_trace( $LINEINFO, 0, 1, 1, "$sub$al" );
+ }
+ else {
+ _indent_print_line_info(-1, "entering $sub$al\n" );
+ }
+ }
+
+ return;
+}
+
+sub DB::sub {
+ # Do not use a regex in this subroutine -> results in corrupted memory
+ # See: [perl #66110]
+
+ # lock ourselves under threads
+ lock($DBGR);
+
# Whether or not the autoloader was running, a scalar to put the
# sub's return value in (if needed), and an array to put the sub's
# return value in (if needed).
my ( $al, $ret, @ret ) = "";
- if ($sub eq 'threads::new' && $ENV{PERL5DB_THREADED}) {
- print "creating new thread\n";
- }
+ if ($sub eq 'threads::new' && $ENV{PERL5DB_THREADED}) {
+ print "creating new thread\n";
+ }
# If the last ten characters are '::AUTOLOAD', note we've traced
# into AUTOLOAD for $sub.
if ( length($sub) > 10 && substr( $sub, -10, 10 ) eq '::AUTOLOAD' ) {
+ no strict 'refs';
$al = " for $$sub" if defined $$sub;
}
@@ -3667,22 +4134,26 @@
$single |= 4 if $stack_depth == $deep;
# If frame messages are on ...
- (
- $frame & 4 # Extended frame entry message
- ? (
- print_lineinfo( ' ' x ( $stack_depth - 1 ), "in " ),
- # Why -1? But it works! :-(
- # Because print_trace will call add 1 to it and then call
- # dump_trace; this results in our skipping -1+1 = 0 stack frames
- # in dump_trace.
- print_trace( $LINEINFO, -1, 1, 1, "$sub$al" )
- )
- : print_lineinfo( ' ' x ( $stack_depth - 1 ), "entering $sub$al\n" )
+ _print_frame_message($al);
+ # standard frame entry message
- # standard frame entry message
- )
- if $frame;
+ my $print_exit_msg = sub {
+ # Check for exit trace messages...
+ if ($frame & 2)
+ {
+ if ($frame & 4) # Extended exit message
+ {
+ _indent_print_line_info(0, "out ");
+ print_trace( $LINEINFO, 0, 1, 1, "$sub$al" );
+ }
+ else
+ {
+ _indent_print_line_info(0, "exited $sub$al\n" );
+ }
+ }
+ return;
+ };
# Determine the sub's return type, and capture appropriately.
if (wantarray) {
@@ -3690,24 +4161,16 @@
# Called in array context. call sub and capture output.
# DB::DB will recursively get control again if appropriate; we'll come
# back here when the sub is finished.
- @ret = &$sub;
+ {
+ no strict 'refs';
+ @ret = &$sub;
+ }
# Pop the single-step value back off the stack.
$single |= $stack[ $stack_depth-- ];
- # Check for exit trace messages...
- (
- $frame & 4 # Extended exit message
- ? (
- print_lineinfo( ' ' x $stack_depth, "out " ),
- print_trace( $LINEINFO, -1, 1, 1, "$sub$al" )
- )
- : print_lineinfo( ' ' x $stack_depth, "exited $sub$al\n" )
+ $print_exit_msg->();
- # Standard exit message
- )
- if $frame & 2;
-
# Print the return info if we need to.
if ( $doret eq $stack_depth or $frame & 16 ) {
@@ -3716,10 +4179,13 @@
my $fh = ( $doret eq $stack_depth ? $OUT : $LINEINFO );
# Indent if we're printing because of $frame tracing.
- print $fh ' ' x $stack_depth if $frame & 16;
+ if ($frame & 16)
+ {
+ print {$fh} ' ' x $stack_depth;
+ }
# Print the return value.
- print $fh "list context return from $sub:\n";
+ print {$fh} "list context return from $sub:\n";
dumpit( $fh, \@ret );
# And don't print it again.
@@ -3731,34 +4197,24 @@
# Scalar context.
else {
- if ( defined wantarray ) {
+ if ( defined wantarray ) {
+ no strict 'refs';
+ # Save the value if it's wanted at all.
+ $ret = &$sub;
+ }
+ else {
+ no strict 'refs';
+ # Void return, explicitly.
+ &$sub;
+ undef $ret;
+ }
- # Save the value if it's wanted at all.
- $ret = &$sub;
- }
- else {
-
- # Void return, explicitly.
- &$sub;
- undef $ret;
- }
-
# Pop the single-step value off the stack.
$single |= $stack[ $stack_depth-- ];
# If we're doing exit messages...
- (
- $frame & 4 # Extended messages
- ? (
- print_lineinfo( ' ' x $stack_depth, "out " ),
- print_trace( $LINEINFO, -1, 1, 1, "$sub$al" )
- )
- : print_lineinfo( ' ' x $stack_depth, "exited $sub$al\n" )
+ $print_exit_msg->();
- # Standard messages
- )
- if $frame & 2;
-
# If we are supposed to show the return value... same as before.
if ( $doret eq $stack_depth or $frame & 16 and defined wantarray ) {
local $\ = '';
@@ -3776,20 +4232,22 @@
# Return the appropriate scalar value.
$ret;
} ## end else [ if (wantarray)
-} ## end sub sub
+} ## end sub _sub
sub lsub : lvalue {
- # lock ourselves under threads
- lock($DBGR);
+ no strict 'refs';
+ # lock ourselves under threads
+ lock($DBGR);
+
# Whether or not the autoloader was running, a scalar to put the
# sub's return value in (if needed), and an array to put the sub's
# return value in (if needed).
my ( $al, $ret, @ret ) = "";
- if ($sub =~ /^threads::new$/ && $ENV{PERL5DB_THREADED}) {
- print "creating new thread\n";
- }
+ if ($sub =~ /^threads::new$/ && $ENV{PERL5DB_THREADED}) {
+ print "creating new thread\n";
+ }
# If the last ten characters are C'::AUTOLOAD', note we've traced
# into AUTOLOAD for $sub.
@@ -3817,23 +4275,8 @@
$single |= 4 if $stack_depth == $deep;
# If frame messages are on ...
- (
- $frame & 4 # Extended frame entry message
- ? (
- print_lineinfo( ' ' x ( $stack_depth - 1 ), "in " ),
+ _print_frame_message($al);
- # Why -1? But it works! :-(
- # Because print_trace will call add 1 to it and then call
- # dump_trace; this results in our skipping -1+1 = 0 stack frames
- # in dump_trace.
- print_trace( $LINEINFO, -1, 1, 1, "$sub$al" )
- )
- : print_lineinfo( ' ' x ( $stack_depth - 1 ), "entering $sub$al\n" )
-
- # standard frame entry message
- )
- if $frame;
-
# Pop the single-step value back off the stack.
$single |= $stack[ $stack_depth-- ];
@@ -3841,6 +4284,13 @@
&$sub;
}
+# Abstracting common code from multiple places elsewhere:
+sub depth_print_lineinfo {
+ my $always_print = shift;
+
+ print_lineinfo( @_ ) if ($always_print or $stack_depth < $trace_to_depth);
+}
+
=head1 EXTENDED COMMAND HANDLING AND THE COMMAND API
In Perl 5.8.0, there was a major realignment of the commands and what they did,
@@ -3847,14 +4297,14 @@
Most of the changes were to systematize the command structure and to eliminate
commands that threw away user input without checking.
-The following sections describe the code added to make it easy to support
-multiple command sets with conflicting command names. This section is a start
+The following sections describe the code added to make it easy to support
+multiple command sets with conflicting command names. This section is a start
at unifying all command processing to make it simpler to develop commands.
-Note that all the cmd_[a-zA-Z] subroutines require the command name, a line
+Note that all the cmd_[a-zA-Z] subroutines require the command name, a line
number, and C<$dbline> (the current line) as arguments.
-Support functions in this section which have multiple modes of failure C<die>
+Support functions in this section which have multiple modes of failure C<die>
on error; the rest simply return a false value.
The user-interface functions (all of the C<cmd_*> functions) just output
@@ -3863,13 +4313,13 @@
=head2 C<%set>
The C<%set> hash defines the mapping from command letter to subroutine
-name suffix.
+name suffix.
C<%set> is a two-level hash, indexed by set name and then by command name.
Note that trying to set the CommandSet to C<foobar> simply results in the
5.8.0 command set being used, since there's no top-level entry for C<foobar>.
-=cut
+=cut
### The API section
@@ -3899,18 +4349,86 @@
},
);
+my %breakpoints_data;
+
+sub _has_breakpoint_data_ref {
+ my ($filename, $line) = @_;
+
+ return (
+ exists( $breakpoints_data{$filename} )
+ and
+ exists( $breakpoints_data{$filename}{$line} )
+ );
+}
+
+sub _get_breakpoint_data_ref {
+ my ($filename, $line) = @_;
+
+ return ($breakpoints_data{$filename}{$line} ||= +{});
+}
+
+sub _delete_breakpoint_data_ref {
+ my ($filename, $line) = @_;
+
+ delete($breakpoints_data{$filename}{$line});
+ if (! scalar(keys( %{$breakpoints_data{$filename}} )) ) {
+ delete($breakpoints_data{$filename});
+ }
+
+ return;
+}
+
+sub _set_breakpoint_enabled_status {
+ my ($filename, $line, $status) = @_;
+
+ _get_breakpoint_data_ref($filename, $line)->{'enabled'} =
+ ($status ? 1 : '')
+ ;
+
+ return;
+}
+
+sub _enable_breakpoint_temp_enabled_status {
+ my ($filename, $line) = @_;
+
+ _get_breakpoint_data_ref($filename, $line)->{'temp_enabled'} = 1;
+
+ return;
+}
+
+sub _cancel_breakpoint_temp_enabled_status {
+ my ($filename, $line) = @_;
+
+ my $ref = _get_breakpoint_data_ref($filename, $line);
+
+ delete ($ref->{'temp_enabled'});
+
+ if (! %$ref) {
+ _delete_breakpoint_data_ref($filename, $line);
+ }
+
+ return;
+}
+
+sub _is_breakpoint_enabled {
+ my ($filename, $line) = @_;
+
+ my $data_ref = _get_breakpoint_data_ref($filename, $line);
+ return ($data_ref->{'enabled'} || $data_ref->{'temp_enabled'});
+}
+
=head2 C<cmd_wrapper()> (API)
-C<cmd_wrapper()> allows the debugger to switch command sets
-depending on the value of the C<CommandSet> option.
+C<cmd_wrapper()> allows the debugger to switch command sets
+depending on the value of the C<CommandSet> option.
It tries to look up the command in the C<%set> package-level I<lexical>
-(which means external entities can't fiddle with it) and create the name of
-the sub to call based on the value found in the hash (if it's there). I<All>
-of the commands to be handled in a set have to be added to C<%set>; if they
+(which means external entities can't fiddle with it) and create the name of
+the sub to call based on the value found in the hash (if it's there). I<All>
+of the commands to be handled in a set have to be added to C<%set>; if they
aren't found, the 5.8.0 equivalent is called (if there is one).
-This code uses symbolic references.
+This code uses symbolic references.
=cut
@@ -3924,17 +4442,17 @@
# default to the older version of the command.
my $call = 'cmd_'
. ( $set{$CommandSet}{$cmd}
- || ( $cmd =~ /^[<>{]+/o ? 'prepost' : $cmd ) );
+ || ( $cmd =~ /\A[<>{]+/o ? 'prepost' : $cmd ) );
# Call the command subroutine, call it by name.
- return &$call( $cmd, $line, $dblineno );
+ return __PACKAGE__->can($call)->( $cmd, $line, $dblineno );
} ## end sub cmd_wrapper
=head3 C<cmd_a> (command)
The C<a> command handles pre-execution actions. These are associated with a
-particular line, so they're stored in C<%dbline>. We default to the current
-line if none is specified.
+particular line, so they're stored in C<%dbline>. We default to the current
+line if none is specified.
=cut
@@ -3944,12 +4462,15 @@
my $dbline = shift;
# If it's dot (here), or not all digits, use the current line.
- $line =~ s/^(\.|(?:[^\d]))/$dbline/;
+ $line =~ s/\A\./$dbline/;
# Should be a line number followed by an expression.
- if ( $line =~ /^\s*(\d*)\s*(\S.+)/ ) {
- my ( $lineno, $expr ) = ( $1, $2 );
+ if ( my ($lineno, $expr) = $line =~ /^\s*(\d*)\s*(\S.+)/ ) {
+ if (! length($lineno)) {
+ $lineno = $dbline;
+ }
+
# If we have an expression ...
if ( length $expr ) {
@@ -3968,6 +4489,8 @@
# Add the action to the line.
$dbline{$lineno} .= "\0" . action($expr);
+
+ _set_breakpoint_enabled_status($filename, $lineno, 1);
}
} ## end if (length $expr)
} ## end if ($line =~ /^\s*(\d*)\s*(\S.+)/)
@@ -4000,13 +4523,19 @@
# if delete_action blows up for some reason, in which case
# we print $@ and get out.
if ( $line eq '*' ) {
- eval { &delete_action(); 1 } or print $OUT $@ and return;
+ if (! eval { _delete_all_actions(); 1 }) {
+ print {$OUT} $@;
+ return;
+ }
}
# There's a real line number. Pass it to delete_action.
# Error trapping is as above.
elsif ( $line =~ /^(\S.*)/ ) {
- eval { &delete_action($1); 1 } or print $OUT $@ and return;
+ if (! eval { delete_action($1); 1 }) {
+ print {$OUT} $@;
+ return;
+ }
}
# Swing and a miss. Bad syntax.
@@ -4019,41 +4548,56 @@
=head3 C<delete_action> (API)
C<delete_action> accepts either a line number or C<undef>. If a line number
-is specified, we check for the line being executable (if it's not, it
+is specified, we check for the line being executable (if it's not, it
couldn't have had an action). If it is, we just take the action off (this
will get any kind of an action, including breakpoints).
=cut
+sub _remove_action_from_dbline {
+ my $i = shift;
+
+ $dbline{$i} =~ s/\0[^\0]*//; # \^a
+ delete $dbline{$i} if $dbline{$i} eq '';
+
+ return;
+}
+
+sub _delete_all_actions {
+ print {$OUT} "Deleting all actions...\n";
+
+ for my $file ( keys %had_breakpoints ) {
+ local *dbline = $main::{ '_<' . $file };
+ $max = $#dbline;
+ my $was;
+ for my $i (1 .. $max) {
+ if ( defined $dbline{$i} ) {
+ _remove_action_from_dbline($i);
+ }
+ }
+
+ unless ( $had_breakpoints{$file} &= ~2 ) {
+ delete $had_breakpoints{$file};
+ }
+ }
+
+ return;
+}
+
sub delete_action {
my $i = shift;
+
if ( defined($i) ) {
-
# Can there be one?
die "Line $i has no action .\n" if $dbline[$i] == 0;
# Nuke whatever's there.
- $dbline{$i} =~ s/\0[^\0]*//; # \^a
- delete $dbline{$i} if $dbline{$i} eq '';
+ _remove_action_from_dbline($i);
}
else {
- print $OUT "Deleting all actions...\n";
- for my $file ( keys %had_breakpoints ) {
- local *dbline = $main::{ '_<' . $file };
- my $max = $#dbline;
- my $was;
- for ( $i = 1 ; $i <= $max ; $i++ ) {
- if ( defined $dbline{$i} ) {
- $dbline{$i} =~ s/\0[^\0]*//;
- delete $dbline{$i} if $dbline{$i} eq '';
- }
- unless ( $had_breakpoints{$file} &= ~2 ) {
- delete $had_breakpoints{$file};
- }
- } ## end for ($i = 1 ; $i <= $max...
- } ## end for my $file (keys %had_breakpoints)
- } ## end else [ if (defined($i))
-} ## end sub delete_action
+ _delete_all_actions();
+ }
+}
=head3 C<cmd_b> (command)
@@ -4070,66 +4614,71 @@
my $line = shift; # [.|line] [cond]
my $dbline = shift;
+ my $default_cond = sub {
+ my $cond = shift;
+ return length($cond) ? $cond : '1';
+ };
+
# Make . the current line number if it's there..
- $line =~ s/^\./$dbline/;
+ $line =~ s/^\.(\s|\z)/$dbline$1/;
# No line number, no condition. Simple break on current line.
if ( $line =~ /^\s*$/ ) {
- &cmd_b_line( $dbline, 1 );
+ cmd_b_line( $dbline, 1 );
}
# Break on load for a file.
- elsif ( $line =~ /^load\b\s*(.*)/ ) {
- my $file = $1;
- $file =~ s/\s+$//;
- &cmd_b_load($file);
+ elsif ( my ($file) = $line =~ /^load\b\s*(.*)/ ) {
+ $file =~ s/\s+\z//;
+ cmd_b_load($file);
}
# b compile|postpone <some sub> [<condition>]
# The interpreter actually traps this one for us; we just put the
# necessary condition in the %postponed hash.
- elsif ( $line =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ ) {
+ elsif ( my ($action, $subname, $cond)
+ = $line =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ ) {
- # Capture the condition if there is one. Make it true if none.
- my $cond = length $3 ? $3 : '1';
-
- # Save the sub name and set $break to 1 if $1 was 'postpone', 0
- # if it was 'compile'.
- my ( $subname, $break ) = ( $2, $1 eq 'postpone' );
-
# De-Perl4-ify the name - ' separators to ::.
- $subname =~ s/\'/::/g;
+ $subname =~ s/'/::/g;
# Qualify it into the current package unless it's already qualified.
- $subname = "${'package'}::" . $subname unless $subname =~ /::/;
+ $subname = "${package}::" . $subname unless $subname =~ /::/;
# Add main if it starts with ::.
$subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::";
# Save the break type for this sub.
- $postponed{$subname} = $break ? "break +0 if $cond" : "compile";
+ $postponed{$subname} = (($action eq 'postpone')
+ ? ( "break +0 if " . $default_cond->($cond) )
+ : "compile");
} ## end elsif ($line =~ ...
-
+ # b <filename>:<line> [<condition>]
+ elsif (my ($filename, $line_num, $cond)
+ = $line =~ /\A(\S+[^:]):(\d+)\s*(.*)/ms) {
+ cmd_b_filename_line(
+ $filename,
+ $line_num,
+ (length($cond) ? $cond : '1'),
+ );
+ }
# b <sub name> [<condition>]
- elsif ( $line =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ ) {
+ elsif ( my ($new_subname, $new_cond) =
+ $line =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ ) {
#
- $subname = $1;
- $cond = length $2 ? $2 : '1';
- &cmd_b_sub( $subname, $cond );
+ $subname = $new_subname;
+ cmd_b_sub( $subname, $default_cond->($new_cond) );
}
# b <line> [<condition>].
- elsif ( $line =~ /^(\d*)\s*(.*)/ ) {
+ elsif ( my ($line_n, $cond) = $line =~ /^(\d*)\s*(.*)/ ) {
# Capture the line. If none, it's the current line.
- $line = $1 || $dbline;
+ $line = $line_n || $dbline;
- # If there's no condition, make it '1'.
- $cond = length $2 ? $2 : '1';
-
# Break on line.
- &cmd_b_line( $line, $cond );
+ cmd_b_line( $line, $default_cond->($cond) );
}
# Line didn't make sense.
@@ -4136,12 +4685,14 @@
else {
print "confused by line($line)?\n";
}
+
+ return;
} ## end sub cmd_b
=head3 C<break_on_load> (API)
We want to break when this file is loaded. Mark this file in the
-C<%break_on_load> hash, and note that it has a breakpoint in
+C<%break_on_load> hash, and note that it has a breakpoint in
C<%had_breakpoints>.
=cut
@@ -4154,7 +4705,7 @@
=head3 C<report_break_on_load> (API)
-Gives us an array of filenames that are set to break on load. Note that
+Gives us an array of filenames that are set to break on load. Note that
only files with break-on-load are in here, so simply showing the keys
suffices.
@@ -4167,7 +4718,7 @@
=head3 C<cmd_b_load> (command)
We take the file passed in and try to find it in C<%INC> (which maps modules
-to files they came from). We mark those files for break-on-load via
+to files they came from). We mark those files for break-on-load via
C<break_on_load> and then report that it was done.
=cut
@@ -4198,7 +4749,7 @@
# Normalize for the purposes of our printing this.
local $\ = '';
local $" = ' ';
- print $OUT "Will stop on load of `@files'.\n";
+ print $OUT "Will stop on load of '@files'.\n";
} ## end sub cmd_b_load
=head3 C<$filename_error> (API package global)
@@ -4205,7 +4756,7 @@
Several of the functions we need to implement in the API need to work both
on the current file and on other files. We don't want to duplicate code, so
-C<$filename_error> is used to contain the name of the file that's being
+C<$filename_error> is used to contain the name of the file that's being
worked on (if it's not the current one).
We can now build functions in pairs: the basic function works on the current
@@ -4215,7 +4766,7 @@
The second function is a wrapper which does the following:
-=over 4
+=over 4
=item *
@@ -4223,11 +4774,11 @@
=item *
-Localizes the C<*dbline> glob and reassigns it to point to the file we want to process.
+Localizes the C<*dbline> glob and reassigns it to point to the file we want to process.
=item *
-Calls the first function.
+Calls the first function.
The first function works on the I<current> file (i.e., the one we changed to),
and prints C<$filename_error> in the error message (the name of the other file)
@@ -4243,6 +4794,7 @@
=cut
+use vars qw($filename_error);
$filename_error = '';
=head3 breakable_line(from, to) (API)
@@ -4251,7 +4803,7 @@
It walks through C<@dbline> within the range of lines specified, looking for
the first line that is breakable.
-If C<$to> is greater than C<$from>, the search moves forwards, finding the
+If C<$to> is greater than C<$from>, the search moves forwards, finding the
first line I<after> C<$to> that's breakable, if there is one.
If C<$from> is greater than C<$to>, the search goes I<backwards>, finding the
@@ -4343,7 +4895,7 @@
local *dbline = $main::{ '_<' . $f };
# If there's an error, it's in this other file.
- local $filename_error = " of `$f'";
+ local $filename_error = " of '$f'";
# Find the breakable line.
breakable_line(@_);
@@ -4354,17 +4906,15 @@
=head3 break_on_line(lineno, [condition]) (API)
-Adds a breakpoint with the specified condition (or 1 if no condition was
+Adds a breakpoint with the specified condition (or 1 if no condition was
specified) to the specified line. Dies if it can't.
=cut
sub break_on_line {
- my ( $i, $cond ) = @_;
+ my $i = shift;
+ my $cond = @_ ? shift(@_) : 1;
- # Always true if no condition supplied.
- $cond = 1 unless @_ >= 2;
-
my $inii = $i;
my $after = '';
my $pl = '';
@@ -4386,65 +4936,90 @@
# Nothing here - just add the condition.
$dbline{$i} = $cond;
+
+ _set_breakpoint_enabled_status($filename, $i, 1);
}
+
+ return;
} ## end sub break_on_line
=head3 cmd_b_line(line, [condition]) (command)
-Wrapper for C<break_on_line>. Prints the failure message if it
+Wrapper for C<break_on_line>. Prints the failure message if it
doesn't work.
-=cut
+=cut
sub cmd_b_line {
- eval { break_on_line(@_); 1 } or do {
+ if (not eval { break_on_line(@_); 1 }) {
local $\ = '';
print $OUT $@ and return;
- };
+ }
+
+ return;
} ## end sub cmd_b_line
+=head3 cmd_b_filename_line(line, [condition]) (command)
+
+Wrapper for C<break_on_filename_line>. Prints the failure message if it
+doesn't work.
+
+=cut
+
+sub cmd_b_filename_line {
+ if (not eval { break_on_filename_line(@_); 1 }) {
+ local $\ = '';
+ print $OUT $@ and return;
+ }
+
+ return;
+}
+
=head3 break_on_filename_line(file, line, [condition]) (API)
-Switches to the file specified and then calls C<break_on_line> to set
+Switches to the file specified and then calls C<break_on_line> to set
the breakpoint.
=cut
sub break_on_filename_line {
- my ( $f, $i, $cond ) = @_;
+ my $f = shift;
+ my $i = shift;
+ my $cond = @_ ? shift(@_) : 1;
- # Always true if condition left off.
- $cond = 1 unless @_ >= 3;
-
# Switch the magical hash temporarily.
local *dbline = $main::{ '_<' . $f };
# Localize the variables that break_on_line uses to make its message.
- local $filename_error = " of `$f'";
+ local $filename_error = " of '$f'";
local $filename = $f;
# Add the breakpoint.
break_on_line( $i, $cond );
+
+ return;
} ## end sub break_on_filename_line
=head3 break_on_filename_line_range(file, from, to, [condition]) (API)
-Switch to another file, search the range of lines specified for an
+Switch to another file, search the range of lines specified for an
executable one, and put a breakpoint on the first one you find.
=cut
sub break_on_filename_line_range {
- my ( $f, $from, $to, $cond ) = @_;
+ my $f = shift;
+ my $from = shift;
+ my $to = shift;
+ my $cond = @_ ? shift(@_) : 1;
# Find a breakable line if there is one.
my $i = breakable_line_in_filename( $f, $from, $to );
- # Always true if missing.
- $cond = 1 unless @_ >= 3;
-
# Add the breakpoint.
break_on_filename_line( $f, $i, $cond );
+
+ return;
} ## end sub break_on_filename_line_range
=head3 subroutine_filename_lines(subname, [condition]) (API)
@@ -4455,18 +5030,17 @@
=cut
sub subroutine_filename_lines {
- my ( $subname, $cond ) = @_;
+ my ( $subname ) = @_;
# Returned value from find_sub() is fullpathname:startline-endline.
- # The match creates the list (fullpathname, start, end). Falling off
- # the end of the subroutine returns this implicitly.
- find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/;
+ # The match creates the list (fullpathname, start, end).
+ return (find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/);
} ## end sub subroutine_filename_lines
=head3 break_subroutine(subname) (API)
Places a break on the first line possible in the specified subroutine. Uses
-C<subroutine_filename_lines> to find the subroutine, and
+C<subroutine_filename_lines> to find the subroutine, and
C<break_on_filename_line_range> to place the break.
=cut
@@ -4478,12 +5052,15 @@
my ( $file, $s, $e ) = subroutine_filename_lines($subname)
or die "Subroutine $subname not found.\n";
+
# Null condition changes to '1' (always true).
- $cond = 1 unless @_ >= 2;
+ my $cond = @_ ? shift(@_) : 1;
# Put a break the first place possible in the range of lines
# that make up this subroutine.
- break_on_filename_line_range( $file, $s, $e, @_ );
+ break_on_filename_line_range( $file, $s, $e, $cond );
+
+ return;
} ## end sub break_subroutine
=head3 cmd_b_sub(subname, [condition]) (command)
@@ -4492,7 +5069,7 @@
=over 4
-=item 1. If it's already fully-qualified, leave it alone.
+=item 1. If it's already fully-qualified, leave it alone.
=item 2. Try putting it in the current package.
@@ -4502,47 +5079,55 @@
=back
-After all this cleanup, we call C<break_subroutine> to try to set the
+After all this cleanup, we call C<break_subroutine> to try to set the
breakpoint.
=cut
sub cmd_b_sub {
- my ( $subname, $cond ) = @_;
+ my $subname = shift;
+ my $cond = @_ ? shift : 1;
- # Add always-true condition if we have none.
- $cond = 1 unless @_ >= 2;
-
# If the subname isn't a code reference, qualify it so that
# break_subroutine() will work right.
- unless ( ref $subname eq 'CODE' ) {
+ if ( ref($subname) ne 'CODE' ) {
- # Not Perl4.
- $subname =~ s/\'/::/g;
+ # Not Perl 4.
+ $subname =~ s/'/::/g;
my $s = $subname;
# Put it in this package unless it's already qualified.
- $subname = "${'package'}::" . $subname
- unless $subname =~ /::/;
+ if ($subname !~ /::/)
+ {
+ $subname = $package . '::' . $subname;
+ };
# Requalify it into CORE::GLOBAL if qualifying it into this
# package resulted in its not being defined, but only do so
# if it really is in CORE::GLOBAL.
- $subname = "CORE::GLOBAL::$s"
- if not defined &$subname
- and $s !~ /::/
- and defined &{"CORE::GLOBAL::$s"};
+ my $core_name = "CORE::GLOBAL::$s";
+ if ((!defined(&$subname))
+ and ($s !~ /::/)
+ and (defined &{$core_name}))
+ {
+ $subname = $core_name;
+ }
# Put it in package 'main' if it has a leading ::.
- $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::";
+ if ($subname =~ /\A::/)
+ {
+ $subname = "main" . $subname;
+ }
+ } ## end if ( ref($subname) ne 'CODE' ) {
- } ## end unless (ref $subname eq 'CODE')
-
# Try to set the breakpoint.
- eval { break_subroutine( $subname, $cond ); 1 } or do {
+ if (not eval { break_subroutine( $subname, $cond ); 1 }) {
local $\ = '';
- print $OUT $@ and return;
- }
+ print {$OUT} $@;
+ return;
+ }
+
+ return;
} ## end sub cmd_b_sub
=head3 C<cmd_B> - delete breakpoint(s) (command)
@@ -4561,7 +5146,7 @@
# No line spec? Use dbline.
# If there is one, use it if it's non-zero, or wipe it out if it is.
- my $line = ( $_[0] =~ /^\./ ) ? $dbline : shift || '';
+ my $line = ( $_[0] =~ /\A\./ ) ? $dbline : (shift || '');
my $dbline = shift;
# If the line was dot, make the line the current one.
@@ -4569,23 +5154,27 @@
# If it's * we're deleting all the breakpoints.
if ( $line eq '*' ) {
- eval { &delete_breakpoint(); 1 } or print $OUT $@ and return;
+ if (not eval { delete_breakpoint(); 1 }) {
+ print {$OUT} $@;
+ }
}
# If there is a line spec, delete the breakpoint on that line.
- elsif ( $line =~ /^(\S.*)/ ) {
- eval { &delete_breakpoint( $line || $dbline ); 1 } or do {
+ elsif ( $line =~ /\A(\S.*)/ ) {
+ if (not eval { delete_breakpoint( $line || $dbline ); 1 }) {
local $\ = '';
- print $OUT $@ and return;
- };
+ print {$OUT} $@;
+ }
} ## end elsif ($line =~ /^(\S.*)/)
# No line spec.
else {
- print $OUT
+ print {$OUT}
"Deleting a breakpoint requires a line number, or '*' for all\n"
; # hint
}
+
+ return;
} ## end sub cmd_B
=head3 delete_breakpoint([line]) (API)
@@ -4599,7 +5188,7 @@
after we've done that, there's nothing left, we delete the corresponding
line in C<%dbline> to signal that no action needs to be taken for this line.
-For all breakpoints, we iterate through the keys of C<%had_breakpoints>,
+For all breakpoints, we iterate through the keys of C<%had_breakpoints>,
which lists all currently-loaded files which have breakpoints. We then look
at each line in each of these files, temporarily switching the C<%dbline>
and C<@dbline> structures to point to the files in question, and do what
@@ -4606,7 +5195,7 @@
we did in the single line case: delete the condition in C<@dbline>, and
delete the key in C<%dbline> if nothing's left.
-We then wholesale delete C<%postponed>, C<%postponed_file>, and
+We then wholesale delete C<%postponed>, C<%postponed_file>, and
C<%break_on_load>, because these structures contain breakpoints for files
and code that haven't been loaded yet. We can just kill these off because there
are no magical debugger structures associated with them.
@@ -4613,68 +5202,91 @@
=cut
-sub delete_breakpoint {
- my $i = shift;
+sub _remove_breakpoint_entry {
+ my ($fn, $i) = @_;
- # If we got a line, delete just that one.
- if ( defined($i) ) {
+ delete $dbline{$i};
+ _delete_breakpoint_data_ref($fn, $i);
- # Woops. This line wasn't breakable at all.
- die "Line $i not breakable.\n" if $dbline[$i] == 0;
+ return;
+}
- # Kill the condition, but leave any action.
- $dbline{$i} =~ s/^[^\0]*//;
+sub _delete_all_breakpoints {
+ print {$OUT} "Deleting all breakpoints...\n";
- # Remove the entry entirely if there's no action left.
- delete $dbline{$i} if $dbline{$i} eq '';
- }
+ # %had_breakpoints lists every file that had at least one
+ # breakpoint in it.
+ for my $fn ( keys %had_breakpoints ) {
- # No line; delete them all.
- else {
- print $OUT "Deleting all breakpoints...\n";
+ # Switch to the desired file temporarily.
+ local *dbline = $main::{ '_<' . $fn };
- # %had_breakpoints lists every file that had at least one
- # breakpoint in it.
- for my $file ( keys %had_breakpoints ) {
+ $max = $#dbline;
- # Switch to the desired file temporarily.
- local *dbline = $main::{ '_<' . $file };
+ # For all lines in this file ...
+ for my $i (1 .. $max) {
- my $max = $#dbline;
- my $was;
+ # If there's a breakpoint or action on this line ...
+ if ( defined $dbline{$i} ) {
- # For all lines in this file ...
- for ( $i = 1 ; $i <= $max ; $i++ ) {
+ # ... remove the breakpoint.
+ $dbline{$i} =~ s/\A[^\0]+//;
+ if ( $dbline{$i} =~ s/\A\0?\z// ) {
+ # Remove the entry altogether if no action is there.
+ _remove_breakpoint_entry($fn, $i);
+ }
+ } ## end if (defined $dbline{$i...
+ } ## end for $i (1 .. $max)
- # If there's a breakpoint or action on this line ...
- if ( defined $dbline{$i} ) {
+ # If, after we turn off the "there were breakpoints in this file"
+ # bit, the entry in %had_breakpoints for this file is zero,
+ # we should remove this file from the hash.
+ if ( not $had_breakpoints{$fn} &= (~1) ) {
+ delete $had_breakpoints{$fn};
+ }
+ } ## end for my $fn (keys %had_breakpoints)
- # ... remove the breakpoint.
- $dbline{$i} =~ s/^[^\0]+//;
- if ( $dbline{$i} =~ s/^\0?$// ) {
+ # Kill off all the other breakpoints that are waiting for files that
+ # haven't been loaded yet.
+ undef %postponed;
+ undef %postponed_file;
+ undef %break_on_load;
- # Remove the entry altogether if no action is there.
- delete $dbline{$i};
- }
- } ## end if (defined $dbline{$i...
- } ## end for ($i = 1 ; $i <= $max...
+ return;
+}
- # If, after we turn off the "there were breakpoints in this file"
- # bit, the entry in %had_breakpoints for this file is zero,
- # we should remove this file from the hash.
- if ( not $had_breakpoints{$file} &= ~1 ) {
- delete $had_breakpoints{$file};
- }
- } ## end for my $file (keys %had_breakpoints)
+sub _delete_breakpoint_from_line {
+ my ($i) = @_;
- # Kill off all the other breakpoints that are waiting for files that
- # haven't been loaded yet.
- undef %postponed;
- undef %postponed_file;
- undef %break_on_load;
- } ## end else [ if (defined($i))
-} ## end sub delete_breakpoint
+ # Woops. This line wasn't breakable at all.
+ die "Line $i not breakable.\n" if $dbline[$i] == 0;
+ # Kill the condition, but leave any action.
+ $dbline{$i} =~ s/\A[^\0]*//;
+
+ # Remove the entry entirely if there's no action left.
+ if ($dbline{$i} eq '') {
+ _remove_breakpoint_entry($filename, $i);
+ }
+
+ return;
+}
+
+sub delete_breakpoint {
+ my $i = shift;
+
+ # If we got a line, delete just that one.
+ if ( defined($i) ) {
+ _delete_breakpoint_from_line($i);
+ }
+ # No line; delete them all.
+ else {
+ _delete_all_breakpoints();
+ }
+
+ return;
+}
+
=head3 cmd_stop (command)
This is meant to be part of the new command API, but it isn't called or used
@@ -4691,7 +5303,7 @@
Display the current thread id:
- e
+ e
This could be how (when implemented) to send commands to this thread id (e cmd)
or that thread id (e tid cmd).
@@ -4701,13 +5313,13 @@
sub cmd_e {
my $cmd = shift;
my $line = shift;
- unless (exists($INC{'threads.pm'})) {
- print "threads not loaded($ENV{PERL5DB_THREADED})
- please run the debugger with PERL5DB_THREADED=1 set in the environment\n";
- } else {
- my $tid = threads->tid;
- print "thread id: $tid\n";
- }
+ unless (exists($INC{'threads.pm'})) {
+ print "threads not loaded($ENV{PERL5DB_THREADED})
+ please run the debugger with PERL5DB_THREADED=1 set in the environment\n";
+ } else {
+ my $tid = threads->tid;
+ print "thread id: $tid\n";
+ }
} ## end sub cmd_e
=head3 C<cmd_E> - list of thread ids
@@ -4714,7 +5326,7 @@
Display the list of available thread ids:
- E
+ E
This could be used (when implemented) to send commands to all threads (E cmd).
@@ -4723,15 +5335,15 @@
sub cmd_E {
my $cmd = shift;
my $line = shift;
- unless (exists($INC{'threads.pm'})) {
- print "threads not loaded($ENV{PERL5DB_THREADED})
- please run the debugger with PERL5DB_THREADED=1 set in the environment\n";
- } else {
- my $tid = threads->tid;
- print "thread ids: ".join(', ',
- map { ($tid == $_->tid ? '<'.$_->tid.'>' : $_->tid) } threads->list
- )."\n";
- }
+ unless (exists($INC{'threads.pm'})) {
+ print "threads not loaded($ENV{PERL5DB_THREADED})
+ please run the debugger with PERL5DB_THREADED=1 set in the environment\n";
+ } else {
+ my $tid = threads->tid;
+ print "thread ids: ".join(', ',
+ map { ($tid == $_->tid ? '<'.$_->tid.'>' : $_->tid) } threads->list
+ )."\n";
+ }
} ## end sub cmd_E
=head3 C<cmd_h> - help command (command)
@@ -4752,6 +5364,9 @@
=cut
+use vars qw($help);
+use vars qw($summary);
+
sub cmd_h {
my $cmd = shift;
@@ -4759,18 +5374,15 @@
my $line = shift || '';
# 'h h'. Print the long-format help.
- if ( $line =~ /^h\s*/ ) {
+ if ( $line =~ /\Ah\s*\z/ ) {
print_help($help);
}
# 'h <something>'. Search for the command and print only its help.
- elsif ( $line =~ /^(\S.*)$/ ) {
+ elsif ( my ($asked) = $line =~ /\A(\S.*)\z/ ) {
# support long commands; otherwise bogus errors
# happen when you ask for h on <CR> for example
- my $asked = $1; # the command requested
- # (for proper error message)
-
my $qasked = quotemeta($asked); # for searching; we don't
# want to use it as a pattern.
# XXX: finds CR but not <CR>
@@ -4793,7 +5405,7 @@
$qasked # The command
([\s\S]*?) # Description line(s)
\n) # End of last description line
- (?!\s) # Next line not starting with
+ (?!\s) # Next line not starting with
# whitespace
/mgx
)
@@ -4825,7 +5437,8 @@
my $line = shift;
foreach my $isa ( split( /\s+/, $line ) ) {
$evalarg = $isa;
- ($isa) = &eval;
+ # The &-call is here to ascertain the mutability of @_.
+ ($isa) = &DB::eval;
no strict 'refs';
print join(
', ',
@@ -4845,10 +5458,10 @@
Most of the command is taken up with transforming all the different line
specification syntaxes into 'start-stop'. After that is done, the command
-runs a loop over C<@dbline> for the specified range of lines. It handles
+runs a loop over C<@dbline> for the specified range of lines. It handles
the printing of each line and any markers (C<==E<gt>> for current line,
C<b> for break on this line, C<a> for action on this line, C<:> for this
-line breakable).
+line breakable).
We save the last line listed in the C<$start> global for further listing
later.
@@ -4855,196 +5468,273 @@
=cut
-sub cmd_l {
- my $current_line = $line;
- my $cmd = shift;
- my $line = shift;
+sub _min {
+ my $min = shift;
+ foreach my $v (@_) {
+ if ($min > $v) {
+ $min = $v;
+ }
+ }
+ return $min;
+}
- # If this is '-something', delete any spaces after the dash.
- $line =~ s/^-\s*$/-/;
+sub _max {
+ my $max = shift;
+ foreach my $v (@_) {
+ if ($max < $v) {
+ $max = $v;
+ }
+ }
+ return $max;
+}
- # If the line is '$something', assume this is a scalar containing a
- # line number.
- if ( $line =~ /^(\$.*)/s ) {
+sub _minify_to_max {
+ my $ref = shift;
- # Set up for DB::eval() - evaluate in *user* context.
- $evalarg = $1;
- # $evalarg = $2;
- my ($s) = &eval;
+ $$ref = _min($$ref, $max);
- # Ooops. Bad scalar.
- print( $OUT "Error: $@\n" ), next CMD if $@;
+ return;
+}
- # Good scalar. If it's a reference, find what it points to.
- $s = CvGV_name($s);
- print( $OUT "Interpreted as: $1 $s\n" );
- $line = "$1 $s";
+sub _cmd_l_handle_var_name {
+ my $var_name = shift;
- # Call self recursively to really do the command.
- &cmd_l( 'l', $s );
- } ## end if ($line =~ /^(\$.*)/s)
+ $evalarg = $var_name;
- # l name. Try to find a sub by that name.
- elsif ( $line =~ /^([\':A-Za-z_][\':\w]*(\[.*\])?)/s ) {
- my $s = $subname = $1;
+ my ($s) = DB::eval();
- # De-Perl4.
- $subname =~ s/\'/::/;
+ # Ooops. Bad scalar.
+ if ($@) {
+ print {$OUT} "Error: $@\n";
+ next CMD;
+ }
- # Put it in this package unless it starts with ::.
- $subname = $package . "::" . $subname unless $subname =~ /::/;
+ # Good scalar. If it's a reference, find what it points to.
+ $s = CvGV_name($s);
+ print {$OUT} "Interpreted as: $1 $s\n";
+ $line = "$1 $s";
- # Put it in CORE::GLOBAL if t doesn't start with :: and
- # it doesn't live in this package and it lives in CORE::GLOBAL.
- $subname = "CORE::GLOBAL::$s"
- if not defined &$subname
- and $s !~ /::/
- and defined &{"CORE::GLOBAL::$s"};
+ # Call self recursively to really do the command.
+ return _cmd_l_main( $s );
+}
- # Put leading '::' names into 'main::'.
- $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::";
+sub _cmd_l_handle_subname {
- # Get name:start-stop from find_sub, and break this up at
- # colons.
- @pieces = split( /:/, find_sub($subname) || $sub{$subname} );
+ my $s = $subname;
- # Pull off start-stop.
- $subrange = pop @pieces;
+ # De-Perl4.
+ $subname =~ s/\'/::/;
- # If the name contained colons, the split broke it up.
- # Put it back together.
- $file = join( ':', @pieces );
+ # Put it in this package unless it starts with ::.
+ $subname = $package . "::" . $subname unless $subname =~ /::/;
- # If we're not in that file, switch over to it.
- if ( $file ne $filename ) {
- print $OUT "Switching to file '$file'.\n"
- unless $slave_editor;
+ # Put it in CORE::GLOBAL if t doesn't start with :: and
+ # it doesn't live in this package and it lives in CORE::GLOBAL.
+ $subname = "CORE::GLOBAL::$s"
+ if not defined &$subname
+ and $s !~ /::/
+ and defined &{"CORE::GLOBAL::$s"};
- # Switch debugger's magic structures.
- *dbline = $main::{ '_<' . $file };
- $max = $#dbline;
- $filename = $file;
- } ## end if ($file ne $filename)
+ # Put leading '::' names into 'main::'.
+ $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::";
- # Subrange is 'start-stop'. If this is less than a window full,
- # swap it to 'start+', which will list a window from the start point.
- if ($subrange) {
- if ( eval($subrange) < -$window ) {
- $subrange =~ s/-.*/+/;
- }
+ # Get name:start-stop from find_sub, and break this up at
+ # colons.
+ my @pieces = split( /:/, find_sub($subname) || $sub{$subname} );
- # Call self recursively to list the range.
- $line = $subrange;
- &cmd_l( 'l', $subrange );
- } ## end if ($subrange)
+ # Pull off start-stop.
+ my $subrange = pop @pieces;
- # Couldn't find it.
- else {
- print $OUT "Subroutine $subname not found.\n";
+ # If the name contained colons, the split broke it up.
+ # Put it back together.
+ $file = join( ':', @pieces );
+
+ # If we're not in that file, switch over to it.
+ if ( $file ne $filename ) {
+ if (! $slave_editor) {
+ print {$OUT} "Switching to file '$file'.\n";
}
- } ## end elsif ($line =~ /^([\':A-Za-z_][\':\w]*(\[.*\])?)/s)
- # Bare 'l' command.
- elsif ( $line =~ /^\s*$/ ) {
+ # Switch debugger's magic structures.
+ *dbline = $main::{ '_<' . $file };
+ $max = $#dbline;
+ $filename = $file;
+ } ## end if ($file ne $filename)
- # Compute new range to list.
- $incr = $window - 1;
- $line = $start . '-' . ( $start + $incr );
+ # Subrange is 'start-stop'. If this is less than a window full,
+ # swap it to 'start+', which will list a window from the start point.
+ if ($subrange) {
+ if ( eval($subrange) < -$window ) {
+ $subrange =~ s/-.*/+/;
+ }
- # Recurse to do it.
- &cmd_l( 'l', $line );
+ # Call self recursively to list the range.
+ return _cmd_l_main( $subrange );
+ } ## end if ($subrange)
+
+ # Couldn't find it.
+ else {
+ print {$OUT} "Subroutine $subname not found.\n";
+ return;
}
+}
- # l [start]+number_of_lines
- elsif ( $line =~ /^(\d*)\+(\d*)$/ ) {
+sub _cmd_l_empty {
+ # Compute new range to list.
+ $incr = $window - 1;
- # Don't reset start for 'l +nnn'.
- $start = $1 if $1;
+ # Recurse to do it.
+ return _cmd_l_main( $start . '-' . ( $start + $incr ) );
+}
- # Increment for list. Use window size if not specified.
- # (Allows 'l +' to work.)
- $incr = $2;
- $incr = $window - 1 unless $incr;
+sub _cmd_l_plus {
+ my ($new_start, $new_incr) = @_;
- # Create a line range we'll understand, and recurse to do it.
- $line = $start . '-' . ( $start + $incr );
- &cmd_l( 'l', $line );
- } ## end elsif ($line =~ /^(\d*)\+(\d*)$/)
+ # Don't reset start for 'l +nnn'.
+ $start = $new_start if $new_start;
- # l start-stop or l start,stop
- elsif ( $line =~ /^((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ ) {
+ # Increment for list. Use window size if not specified.
+ # (Allows 'l +' to work.)
+ $incr = $new_incr || ($window - 1);
- # Determine end point; use end of file if not specified.
- $end = ( !defined $2 ) ? $max : ( $4 ? $4 : $2 );
+ # Create a line range we'll understand, and recurse to do it.
+ return _cmd_l_main( $start . '-' . ( $start + $incr ) );
+}
- # Go on to the end, and then stop.
- $end = $max if $end > $max;
+sub _cmd_l_calc_initial_end_and_i {
+ my ($spec, $start_match, $end_match) = @_;
- # Determine start line.
- $i = $2;
- $i = $line if $i eq '.';
- $i = 1 if $i < 1;
- $incr = $end - $i;
+ # Determine end point; use end of file if not specified.
+ my $end = ( !defined $start_match ) ? $max :
+ ( $end_match ? $end_match : $start_match );
- # If we're running under a slave editor, force it to show the lines.
- if ($slave_editor) {
- print $OUT "\032\032$filename:$i:0\n";
- $i = $end;
- }
+ # Go on to the end, and then stop.
+ _minify_to_max(\$end);
- # We're doing it ourselves. We want to show the line and special
- # markers for:
- # - the current line in execution
- # - whether a line is breakable or not
- # - whether a line has a break or not
- # - whether a line has an action or not
- else {
- for ( ; $i <= $end ; $i++ ) {
+ # Determine start line.
+ my $i = $start_match;
- # Check for breakpoints and actions.
- my ( $stop, $action );
- ( $stop, $action ) = split( /\0/, $dbline{$i} )
- if $dbline{$i};
+ if ($i eq '.') {
+ $i = $spec;
+ }
- # ==> if this is the current line in execution,
- # : if it's breakable.
- $arrow =
- ( $i == $current_line and $filename eq $filename_ini )
- ? '==>'
- : ( $dbline[$i] + 0 ? ':' : ' ' );
+ $i = _max($i, 1);
- # Add break and action indicators.
- $arrow .= 'b' if $stop;
- $arrow .= 'a' if $action;
+ $incr = $end - $i;
- # Print the line.
- print $OUT "$i$arrow\t", $dbline[$i];
+ return ($end, $i);
+}
- # Move on to the next line. Drop out on an interrupt.
- $i++, last if $signal;
- } ## end for (; $i <= $end ; $i++)
+sub _cmd_l_range {
+ my ($spec, $current_line, $start_match, $end_match) = @_;
- # Line the prompt up; print a newline if the last line listed
- # didn't have a newline.
- print $OUT "\n" unless $dbline[ $i - 1 ] =~ /\n$/;
- } ## end else [ if ($slave_editor)
+ my ($end, $i) =
+ _cmd_l_calc_initial_end_and_i($spec, $start_match, $end_match);
- # Save the point we last listed to in case another relative 'l'
- # command is desired. Don't let it run off the end.
- $start = $i;
- $start = $max if $start > $max;
- } ## end elsif ($line =~ /^((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/)
+ # If we're running under a slave editor, force it to show the lines.
+ if ($slave_editor) {
+ print {$OUT} "\032\032$filename:$i:0\n";
+ $i = $end;
+ }
+ # We're doing it ourselves. We want to show the line and special
+ # markers for:
+ # - the current line in execution
+ # - whether a line is breakable or not
+ # - whether a line has a break or not
+ # - whether a line has an action or not
+ else {
+ I_TO_END:
+ for ( ; $i <= $end ; $i++ ) {
+
+ # Check for breakpoints and actions.
+ my ( $stop, $action );
+ if ($dbline{$i}) {
+ ( $stop, $action ) = split( /\0/, $dbline{$i} );
+ }
+
+ # ==> if this is the current line in execution,
+ # : if it's breakable.
+ my $arrow =
+ ( $i == $current_line and $filename eq $filename_ini )
+ ? '==>'
+ : ( $dbline[$i] + 0 ? ':' : ' ' );
+
+ # Add break and action indicators.
+ $arrow .= 'b' if $stop;
+ $arrow .= 'a' if $action;
+
+ # Print the line.
+ print {$OUT} "$i$arrow\t", $dbline[$i];
+
+ # Move on to the next line. Drop out on an interrupt.
+ if ($signal) {
+ $i++;
+ last I_TO_END;
+ }
+ } ## end for (; $i <= $end ; $i++)
+
+ # Line the prompt up; print a newline if the last line listed
+ # didn't have a newline.
+ if ($dbline[ $i - 1 ] !~ /\n\z/) {
+ print {$OUT} "\n";
+ }
+ } ## end else [ if ($slave_editor)
+
+ # Save the point we last listed to in case another relative 'l'
+ # command is desired. Don't let it run off the end.
+ $start = $i;
+ _minify_to_max(\$start);
+
+ return;
+}
+
+sub _cmd_l_main {
+ my $spec = shift;
+
+ # If this is '-something', delete any spaces after the dash.
+ $spec =~ s/\A-\s*\z/-/;
+
+ # If the line is '$something', assume this is a scalar containing a
+ # line number.
+ # Set up for DB::eval() - evaluate in *user* context.
+ if ( my ($var_name) = $spec =~ /\A(\$.*)/s ) {
+ return _cmd_l_handle_var_name($var_name);
+ }
+ # l name. Try to find a sub by that name.
+ elsif ( ($subname) = $spec =~ /\A([\':A-Za-z_][\':\w]*(?:\[.*\])?)/s ) {
+ return _cmd_l_handle_subname();
+ }
+ # Bare 'l' command.
+ elsif ( $spec !~ /\S/ ) {
+ return _cmd_l_empty();
+ }
+ # l [start]+number_of_lines
+ elsif ( my ($new_start, $new_incr) = $spec =~ /\A(\d*)\+(\d*)\z/ ) {
+ return _cmd_l_plus($new_start, $new_incr);
+ }
+ # l start-stop or l start,stop
+ elsif (my ($s, $e) = $spec =~ /^(?:(-?[\d\$\.]+)(?:[-,]([\d\$\.]+))?)?/ ) {
+ return _cmd_l_range($spec, $line, $s, $e);
+ }
+
+ return;
} ## end sub cmd_l
+sub cmd_l {
+ my (undef, $line) = @_;
+
+ return _cmd_l_main($line);
+}
+
=head3 C<cmd_L> - list breakpoints, actions, and watch expressions (command)
To list breakpoints, the command has to look determine where all of them are
first. It starts a C<%had_breakpoints>, which tells us what all files have
-breakpoints and/or actions. For each file, we switch the C<*dbline> glob (the
-magic source and breakpoint data structures) to the file, and then look
-through C<%dbline> for lines with breakpoints and/or actions, listing them
-out. We look through C<%postponed> not-yet-compiled subroutines that have
-breakpoints, and through C<%postponed_file> for not-yet-C<require>'d files
+breakpoints and/or actions. For each file, we switch the C<*dbline> glob (the
+magic source and breakpoint data structures) to the file, and then look
+through C<%dbline> for lines with breakpoints and/or actions, listing them
+out. We look through C<%postponed> not-yet-compiled subroutines that have
+breakpoints, and through C<%postponed_file> for not-yet-C<require>'d files
that have breakpoints.
Watchpoints are simpler: we just list the entries in C<@to_watch>.
@@ -5051,73 +5741,132 @@
=cut
-sub cmd_L {
- my $cmd = shift;
-
+sub _cmd_L_calc_arg {
# If no argument, list everything. Pre-5.8.0 version always lists
# everything
my $arg = shift || 'abw';
- $arg = 'abw' unless $CommandSet eq '580'; # sigh...
+ if ($CommandSet ne '580')
+ {
+ $arg = 'abw';
+ }
- # See what is wanted.
- my $action_wanted = ( $arg =~ /a/ ) ? 1 : 0;
- my $break_wanted = ( $arg =~ /b/ ) ? 1 : 0;
- my $watch_wanted = ( $arg =~ /w/ ) ? 1 : 0;
+ return $arg;
+}
- # Breaks and actions are found together, so we look in the same place
- # for both.
- if ( $break_wanted or $action_wanted ) {
+sub _cmd_L_calc_wanted_flags {
+ my $arg = _cmd_L_calc_arg(shift);
- # Look in all the files with breakpoints...
- for my $file ( keys %had_breakpoints ) {
+ return (map { index($arg, $_) >= 0 ? 1 : 0 } qw(a b w));
+}
- # Temporary switch to this file.
- local *dbline = $main::{ '_<' . $file };
- # Set up to look through the whole file.
- my $max = $#dbline;
- my $was; # Flag: did we print something
- # in this file?
+sub _cmd_L_handle_breakpoints {
+ my ($handle_db_line) = @_;
- # For each line in the file ...
- for ( $i = 1 ; $i <= $max ; $i++ ) {
+ BREAKPOINTS_SCAN:
+ # Look in all the files with breakpoints...
+ for my $file ( keys %had_breakpoints ) {
- # We've got something on this line.
- if ( defined $dbline{$i} ) {
+ # Temporary switch to this file.
+ local *dbline = $main::{ '_<' . $file };
- # Print the header if we haven't.
- print $OUT "$file:\n" unless $was++;
+ # Set up to look through the whole file.
+ $max = $#dbline;
+ my $was; # Flag: did we print something
+ # in this file?
- # Print the line.
- print $OUT " $i:\t", $dbline[$i];
+ # For each line in the file ...
+ for my $i (1 .. $max) {
- # Pull out the condition and the action.
- ( $stop, $action ) = split( /\0/, $dbline{$i} );
+ # We've got something on this line.
+ if ( defined $dbline{$i} ) {
- # Print the break if there is one and it's wanted.
- print $OUT " break if (", $stop, ")\n"
- if $stop
- and $break_wanted;
+ # Print the header if we haven't.
+ if (not $was++) {
+ print {$OUT} "$file:\n";
+ }
- # Print the action if there is one and it's wanted.
- print $OUT " action: ", $action, "\n"
- if $action
- and $action_wanted;
+ # Print the line.
+ print {$OUT} " $i:\t", $dbline[$i];
- # Quit if the user hit interrupt.
- last if $signal;
- } ## end if (defined $dbline{$i...
- } ## end for ($i = 1 ; $i <= $max...
- } ## end for my $file (keys %had_breakpoints)
- } ## end if ($break_wanted or $action_wanted)
+ $handle_db_line->($dbline{$i});
+ # Quit if the user hit interrupt.
+ if ($signal) {
+ last BREAKPOINTS_SCAN;
+ }
+ } ## end if (defined $dbline{$i...
+ } ## end for my $i (1 .. $max)
+ } ## end for my $file (keys %had_breakpoints)
+
+ return;
+}
+
+sub _cmd_L_handle_postponed_breakpoints {
+ my ($handle_db_line) = @_;
+
+ print {$OUT} "Postponed breakpoints in files:\n";
+
+ POSTPONED_SCANS:
+ for my $file ( keys %postponed_file ) {
+ my $db = $postponed_file{$file};
+ print {$OUT} " $file:\n";
+ for my $line ( sort { $a <=> $b } keys %$db ) {
+ print {$OUT} " $line:\n";
+
+ $handle_db_line->($db->{$line});
+
+ if ($signal) {
+ last POSTPONED_SCANS;
+ }
+ }
+ if ($signal) {
+ last POSTPONED_SCANS;
+ }
+ }
+
+ return;
+}
+
+
+sub cmd_L {
+ my $cmd = shift;
+
+ my ($action_wanted, $break_wanted, $watch_wanted) =
+ _cmd_L_calc_wanted_flags(shift);
+
+ my $handle_db_line = sub {
+ my ($l) = @_;
+
+ my ( $stop, $action ) = split( /\0/, $l );
+
+ if ($stop and $break_wanted) {
+ print {$OUT} " break if (", $stop, ")\n"
+ }
+
+ if ($action && $action_wanted) {
+ print {$OUT} " action: ", $action, "\n"
+ }
+
+ return;
+ };
+
+ # Breaks and actions are found together, so we look in the same place
+ # for both.
+ if ( $break_wanted or $action_wanted ) {
+ _cmd_L_handle_breakpoints($handle_db_line);
+ }
+
# Look for breaks in not-yet-compiled subs:
if ( %postponed and $break_wanted ) {
- print $OUT "Postponed breakpoints in subroutines:\n";
+ print {$OUT} "Postponed breakpoints in subroutines:\n";
my $subname;
+ SUBS_SCAN:
for $subname ( keys %postponed ) {
- print $OUT " $subname\t$postponed{$subname}\n";
- last if $signal;
+ print {$OUT} " $subname\t$postponed{$subname}\n";
+ if ($signal) {
+ last SUBS_SCAN;
+ }
}
} ## end if (%postponed and $break_wanted)
@@ -5128,43 +5877,26 @@
# If there are any, list them.
if ( @have and ( $break_wanted or $action_wanted ) ) {
- print $OUT "Postponed breakpoints in files:\n";
- my ( $file, $line );
+ _cmd_L_handle_postponed_breakpoints($handle_db_line);
+ } ## end if (@have and ($break_wanted...
- for $file ( keys %postponed_file ) {
- my $db = $postponed_file{$file};
- print $OUT " $file:\n";
- for $line ( sort { $a <=> $b } keys %$db ) {
- print $OUT " $line:\n";
- my ( $stop, $action ) = split( /\0/, $$db{$line} );
- print $OUT " break if (", $stop, ")\n"
- if $stop
- and $break_wanted;
- print $OUT " action: ", $action, "\n"
- if $action
- and $action_wanted;
- last if $signal;
- } ## end for $line (sort { $a <=>...
- last if $signal;
- } ## end for $file (keys %postponed_file)
- } ## end if (@have and ($break_wanted...
if ( %break_on_load and $break_wanted ) {
- print $OUT "Breakpoints on load:\n";
- my $file;
- for $file ( keys %break_on_load ) {
- print $OUT " $file\n";
- last if $signal;
+ print {$OUT} "Breakpoints on load:\n";
+ BREAK_ON_LOAD: for my $filename ( keys %break_on_load ) {
+ print {$OUT} " $filename\n";
+ last BREAK_ON_LOAD if $signal;
}
} ## end if (%break_on_load and...
- if ($watch_wanted) {
- if ( $trace & 2 ) {
- print $OUT "Watch-expressions:\n" if @to_watch;
- for my $expr (@to_watch) {
- print $OUT " $expr\n";
- last if $signal;
- }
- } ## end if ($trace & 2)
- } ## end if ($watch_wanted)
+
+ if ($watch_wanted and ( $trace & 2 )) {
+ print {$OUT} "Watch-expressions:\n" if @to_watch;
+ TO_WATCH: for my $expr (@to_watch) {
+ print {$OUT} " $expr\n";
+ last TO_WATCH if $signal;
+ }
+ }
+
+ return;
} ## end sub cmd_L
=head3 C<cmd_M> - list modules (command)
@@ -5174,12 +5906,14 @@
=cut
sub cmd_M {
- &list_modules();
+ list_modules();
+
+ return;
}
=head3 C<cmd_o> - options (command)
-If this is just C<o> by itself, we list the current settings via
+If this is just C<o> by itself, we list the current settings via
C<dump_option>. If there's a nonblank value following it, we pass that on to
C<parse_options> for processing.
@@ -5191,13 +5925,13 @@
# Nonblank. Try to parse and process.
if ( $opt =~ /^(\S.*)/ ) {
- &parse_options($1);
+ parse_options($1);
}
# Blank. List the current option settings.
else {
for (@options) {
- &dump_option($_);
+ dump_option($_);
}
}
} ## end sub cmd_o
@@ -5220,8 +5954,10 @@
move back a few lines to list the selected line in context. Uses C<cmd_l>
to do the actual listing after figuring out the range of line to request.
-=cut
+=cut
+use vars qw($preview);
+
sub cmd_v {
my $cmd = shift;
my $line = shift;
@@ -5245,7 +5981,7 @@
$line = $start . '-' . ( $start + $incr );
# List the lines.
- &cmd_l( 'l', $line );
+ cmd_l( 'l', $line );
} ## end if ($line =~ /^(\d*)$/)
} ## end sub cmd_v
@@ -5261,6 +5997,29 @@
=cut
+sub _add_watch_expr {
+ my $expr = shift;
+
+ # ... save it.
+ push @to_watch, $expr;
+
+ # Parameterize DB::eval and call it to get the expression's value
+ # in the user's context. This version can handle expressions which
+ # return a list value.
+ $evalarg = $expr;
+ # The &-call is here to ascertain the mutability of @_.
+ my ($val) = join( ' ', &DB::eval);
+ $val = ( defined $val ) ? "'$val'" : 'undef';
+
+ # Save the current value of the expression.
+ push @old_watch, $val;
+
+ # We are now watching expressions.
+ $trace |= 2;
+
+ return;
+}
+
sub cmd_w {
my $cmd = shift;
@@ -5268,23 +6027,8 @@
my $expr = shift || '';
# If expression is not null ...
- if ( $expr =~ /^(\S.*)/ ) {
-
- # ... save it.
- push @to_watch, $expr;
-
- # Parameterize DB::eval and call it to get the expression's value
- # in the user's context. This version can handle expressions which
- # return a list value.
- $evalarg = $expr;
- my ($val) = join( ' ', &eval );
- $val = ( defined $val ) ? "'$val'" : 'undef';
-
- # Save the current value of the expression.
- push @old_watch, $val;
-
- # We are now watching expressions.
- $trace |= 2;
+ if ( $expr =~ /\A\S/ ) {
+ _add_watch_expr($expr);
} ## end if ($expr =~ /^(\S.*)/)
# You have to give one to get one.
@@ -5291,20 +6035,22 @@
else {
print $OUT "Adding a watch-expression requires an expression\n"; # hint
}
-} ## end sub cmd_w
+ return;
+}
+
=head3 C<cmd_W> - delete watch expressions (command)
This command accepts either a watch expression to be removed from the list
of watch expressions, or C<*> to delete them all.
-If C<*> is specified, we simply empty the watch expression list and the
-watch expression value list. We also turn off the bit that says we've got
+If C<*> is specified, we simply empty the watch expression list and the
+watch expression value list. We also turn off the bit that says we've got
watch expressions.
If an expression (or partial expression) is specified, we pattern-match
through the expressions and remove the ones that match. We also discard
-the corresponding values. If no watch expressions are left, we turn off
+the corresponding values. If no watch expressions are left, we turn off
the I<watching expressions> bit.
=cut
@@ -5368,7 +6114,7 @@
=head2 save
save() saves the user's versions of globals that would mess us up in C<@saved>,
-and installs the versions we like better.
+and installs the versions we like better.
=cut
@@ -5389,7 +6135,7 @@
print_lineinfo prints whatever it is that it is handed; it prints it to the
C<$LINEINFO> filehandle instead of just printing it to STDOUT. This allows
-us to feed line information to a slave editor without messing up the
+us to feed line information to a slave editor without messing up the
debugger output.
=cut
@@ -5408,11 +6154,11 @@
Handles setting postponed breakpoints in subroutines once they're compiled.
For breakpoints, we use C<DB::find_sub> to locate the source file and line
range for the subroutine, then mark the file as having a breakpoint,
-temporarily switch the C<*dbline> glob over to the source file, and then
+temporarily switch the C<*dbline> glob over to the source file, and then
search the given range of lines to find a breakable line. If we find one,
we set the breakpoint on it, deleting the breakpoint from C<%postponed>.
-=cut
+=cut
# The following takes its argument via $evalarg to preserve current @_
@@ -5446,7 +6192,7 @@
$had_breakpoints{$file} |= 1;
# Last line in file.
- my $max = $#dbline;
+ $max = $#dbline;
# Search forward until we hit a breakable line or get to
# the end of the file.
@@ -5465,17 +6211,17 @@
} ## end if ($postponed{$subname...
elsif ( $postponed{$subname} eq 'compile' ) { $signal = 1 }
- #print $OUT "In postponed_sub for `$subname'.\n";
+ #print $OUT "In postponed_sub for '$subname'.\n";
} ## end sub postponed_sub
=head2 C<postponed>
Called after each required file is compiled, but before it is executed;
-also called if the name of a just-compiled subroutine is a key of
+also called if the name of a just-compiled subroutine is a key of
C<%postponed>. Propagates saved breakpoints (from C<b compile>, C<b load>,
etc.) into the just-compiled code.
-If this is a C<require>'d file, the incoming parameter is the glob
+If this is a C<require>'d file, the incoming parameter is the glob
C<*{"_<$filename"}>, with C<$filename> the name of the C<require>'d file.
If it's a subroutine, the incoming parameter is the subroutine name.
@@ -5495,7 +6241,9 @@
}
# If this is a subroutine, let postponed_sub() deal with it.
- return &postponed_sub unless ref \$_[0] eq 'GLOB';
+ if (ref(\$_[0]) ne 'GLOB') {
+ return postponed_sub(@_);
+ }
# Not a subroutine. Deal with the file.
local *dbline = shift;
@@ -5534,36 +6282,36 @@
=head2 C<dumpit>
-C<dumpit> is the debugger's wrapper around dumpvar.pl.
+C<dumpit> is the debugger's wrapper around dumpvar.pl.
It gets a filehandle (to which C<dumpvar.pl>'s output will be directed) and
-a reference to a variable (the thing to be dumped) as its input.
+a reference to a variable (the thing to be dumped) as its input.
The incoming filehandle is selected for output (C<dumpvar.pl> is printing to
the currently-selected filehandle, thank you very much). The current
-values of the package globals C<$single> and C<$trace> are backed up in
+values of the package globals C<$single> and C<$trace> are backed up in
lexicals, and they are turned off (this keeps the debugger from trying
to single-step through C<dumpvar.pl> (I think.)). C<$frame> is localized to
preserve its current value and it is set to zero to prevent entry/exit
-messages from printing, and C<$doret> is localized as well and set to -2 to
+messages from printing, and C<$doret> is localized as well and set to -2 to
prevent return values from being shown.
-C<dumpit()> then checks to see if it needs to load C<dumpvar.pl> and
-tries to load it (note: if you have a C<dumpvar.pl> ahead of the
-installed version in C<@INC>, yours will be used instead. Possible security
+C<dumpit()> then checks to see if it needs to load C<dumpvar.pl> and
+tries to load it (note: if you have a C<dumpvar.pl> ahead of the
+installed version in C<@INC>, yours will be used instead. Possible security
problem?).
It then checks to see if the subroutine C<main::dumpValue> is now defined
-(it should have been defined by C<dumpvar.pl>). If it has, C<dumpit()>
+it should have been defined by C<dumpvar.pl>). If it has, C<dumpit()>
localizes the globals necessary for things to be sane when C<main::dumpValue()>
-is called, and picks up the variable to be dumped from the parameter list.
+is called, and picks up the variable to be dumped from the parameter list.
-It checks the package global C<%options> to see if there's a C<dumpDepth>
-specified. If not, -1 is assumed; if so, the supplied value gets passed on to
-C<dumpvar.pl>. This tells C<dumpvar.pl> where to leave off when dumping a
+It checks the package global C<%options> to see if there's a C<dumpDepth>
+specified. If not, -1 is assumed; if so, the supplied value gets passed on to
+C<dumpvar.pl>. This tells C<dumpvar.pl> where to leave off when dumping a
structure: -1 means dump everything.
-C<dumpValue()> is then called if possible; if not, C<dumpit()>just prints a
+C<dumpValue()> is then called if possible; if not, C<dumpit()>just prints a
warning.
In either case, C<$single>, C<$trace>, C<$frame>, and C<$doret> are restored
@@ -5575,7 +6323,7 @@
# Save the current output filehandle and switch to the one
# passed in as the first parameter.
- local ($savout) = select(shift);
+ my $savout = select(shift);
# Save current settings of $single and $trace, and then turn them off.
my $osingle = $single;
@@ -5600,7 +6348,7 @@
my $v = shift;
my $maxdepth = shift || $option{dumpDepth};
$maxdepth = -1 unless defined $maxdepth; # -1 means infinite depth
- &main::dumpValue( $v, $maxdepth );
+ main::dumpValue( $v, $maxdepth );
} ## end if (defined &main::dumpValue)
# Oops, couldn't load dumpvar.pl.
@@ -5619,7 +6367,7 @@
=head2 C<print_trace>
-C<print_trace>'s job is to print a stack trace. It does this via the
+C<print_trace>'s job is to print a stack trace. It does this via the
C<dump_trace> routine, which actually does all the ferreting-out of the
stack trace data. C<print_trace> takes care of formatting it nicely and
printing it to the proper filehandle.
@@ -5673,7 +6421,7 @@
# Run through the traceback info, format it, and print it.
my $s;
- for ( $i = 0 ; $i <= $#sub ; $i++ ) {
+ for my $i (0 .. $#sub) {
# Drop out if the user has lost interest and hit control-C.
last if $signal;
@@ -5695,10 +6443,10 @@
my $file = $sub[$i]{file};
# Put in a filename header if short is off.
- $file = $file eq '-e' ? $file : "file `$file'" unless $short;
+ $file = $file eq '-e' ? $file : "file '$file'" unless $short;
# Get the actual sub's name, and shorten to $maxtrace's requirement.
- $s = $sub[$i]{sub};
+ $s = $sub[$i]{'sub'};
$s = ( substr $s, 0, $maxtrace - 3 ) . '...' if length $s > $maxtrace;
# Short report uses trimmed file and sub names.
@@ -5713,7 +6461,7 @@
. " called from $file"
. " line $sub[$i]{line}\n";
}
- } ## end for ($i = 0 ; $i <= $#sub...
+ } ## end for my $i (0 .. $#sub)
} ## end sub print_trace
=head2 dump_trace(skip[,count])
@@ -5723,7 +6471,7 @@
make C<print_trace()>'s job easier.
C<skip> defines the number of stack frames to be skipped, working backwards
-from the most current. C<count> determines the total number of frames to
+from the most current. C<count> determines the total number of frames to
be returned; all of them (well, the first 10^9) are returned if C<count>
is omitted.
@@ -5746,6 +6494,51 @@
=cut
+sub _dump_trace_calc_saved_single_arg
+{
+ my ($nothard, $arg) = @_;
+
+ my $type;
+ if ( not defined $arg ) { # undefined parameter
+ return "undef";
+ }
+
+ elsif ( $nothard and tied $arg ) { # tied parameter
+ return "tied";
+ }
+ elsif ( $nothard and $type = ref $arg ) { # reference
+ return "ref($type)";
+ }
+ else { # can be stringified
+ local $_ =
+ "$arg"; # Safe to stringify now - should not call f().
+
+ # Backslash any single-quotes or backslashes.
+ s/([\'\\])/\\$1/g;
+
+ # Single-quote it unless it's a number or a colon-separated
+ # name.
+ s/(.*)/'$1'/s
+ unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
+
+ # Turn high-bit characters into meta-whatever.
+ s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
+
+ # Turn control characters into ^-whatever.
+ s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
+
+ return $_;
+ }
+}
+
+sub _dump_trace_calc_save_args {
+ my ($nothard) = @_;
+
+ return [
+ map { _dump_trace_calc_saved_single_arg($nothard, $_) } @args
+ ];
+}
+
sub dump_trace {
# How many levels to skip.
@@ -5765,7 +6558,7 @@
# These variables are used to capture output from caller();
my ( $p, $file, $line, $sub, $h, $context );
- my ( $e, $r, @a, @sub, $args );
+ my ( $e, $r, @sub, $args );
# XXX Okay... why'd we do that?
my $nothard = not $frame & 8;
@@ -5782,49 +6575,16 @@
# quit.
# Up the stack frame index to go back one more level each time.
for (
- $i = $skip ;
+ my $i = $skip ;
$i < $count
and ( $p, $file, $line, $sub, $h, $context, $e, $r ) = caller($i) ;
$i++
- )
+ )
{
# Go through the arguments and save them for later.
- @a = ();
- for $arg (@args) {
- my $type;
- if ( not defined $arg ) { # undefined parameter
- push @a, "undef";
- }
+ my $save_args = _dump_trace_calc_save_args($nothard);
- elsif ( $nothard and tied $arg ) { # tied parameter
- push @a, "tied";
- }
- elsif ( $nothard and $type = ref $arg ) { # reference
- push @a, "ref($type)";
- }
- else { # can be stringified
- local $_ =
- "$arg"; # Safe to stringify now - should not call f().
-
- # Backslash any single-quotes or backslashes.
- s/([\'\\])/\\$1/g;
-
- # Single-quote it unless it's a number or a colon-separated
- # name.
- s/(.*)/'$1'/s
- unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
-
- # Turn high-bit characters into meta-whatever.
- s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
-
- # Turn control characters into ^-whatever.
- s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
-
- push( @a, $_ );
- } ## end else [ if (not defined $arg)
- } ## end for $arg (@args)
-
# If context is true, this is array (@)context.
# If context is false, this is scalar ($) context.
# If neither, context isn't defined. (This is apparently a 'can't
@@ -5833,7 +6593,7 @@
# if the sub has args ($h true), make an anonymous array of the
# dumped args.
- $args = $h ? [@a] : undef;
+ $args = $h ? $save_args : undef;
# remove trailing newline-whitespace-semicolon-end of line sequence
# from the eval text, if any.
@@ -5894,7 +6654,7 @@
while ( $action =~ s/\\$// ) {
# We have a backslash on the end. Read more.
- $action .= &gets;
+ $action .= gets();
} ## end while ($action =~ s/\\$//)
# Return the assembled action.
@@ -5908,15 +6668,17 @@
curly braces.
Of note is the definition of the C<$balanced_brace_re> global via C<||=>, which
-speeds things up by only creating the qr//'ed expression once; if it's
+speeds things up by only creating the qr//'ed expression once; if it's
already defined, we don't try to define it again. A speed hack.
=cut
+use vars qw($balanced_brace_re);
+
sub unbalanced {
# I hate using globals!
- $balanced_brace_re ||= qr{
+ $balanced_brace_re ||= qr{
^ \{
(?:
(?> [^{}] + ) # Non-parens without backtracking
@@ -5937,43 +6699,43 @@
=cut
sub gets {
- &readline("cont: ");
+ return DB::readline("cont: ");
}
-=head2 C<DB::system()> - handle calls to<system()> without messing up the debugger
+=head2 C<_db_system()> - handle calls to<system()> without messing up the debugger
The C<system()> function assumes that it can just go ahead and use STDIN and
-STDOUT, but under the debugger, we want it to use the debugger's input and
-outout filehandles.
+STDOUT, but under the debugger, we want it to use the debugger's input and
+outout filehandles.
-C<DB::system()> socks away the program's STDIN and STDOUT, and then substitutes
+C<_db_system()> socks away the program's STDIN and STDOUT, and then substitutes
the debugger's IN and OUT filehandles for them. It does the C<system()> call,
and then puts everything back again.
=cut
-sub system {
+sub _db_system {
# We save, change, then restore STDIN and STDOUT to avoid fork() since
# some non-Unix systems can do system() but have problems with fork().
- open( SAVEIN, "<&STDIN" ) || &warn("Can't save STDIN");
- open( SAVEOUT, ">&STDOUT" ) || &warn("Can't save STDOUT");
- open( STDIN, "<&IN" ) || &warn("Can't redirect STDIN");
- open( STDOUT, ">&OUT" ) || &warn("Can't redirect STDOUT");
+ open( SAVEIN, "<&STDIN" ) || db_warn("Can't save STDIN");
+ open( SAVEOUT, ">&STDOUT" ) || db_warn("Can't save STDOUT");
+ open( STDIN, "<&IN" ) || db_warn("Can't redirect STDIN");
+ open( STDOUT, ">&OUT" ) || db_warn("Can't redirect STDOUT");
# XXX: using csh or tcsh destroys sigint retvals!
system(@_);
- open( STDIN, "<&SAVEIN" ) || &warn("Can't restore STDIN");
- open( STDOUT, ">&SAVEOUT" ) || &warn("Can't restore STDOUT");
+ open( STDIN, "<&SAVEIN" ) || db_warn("Can't restore STDIN");
+ open( STDOUT, ">&SAVEOUT" ) || db_warn("Can't restore STDOUT");
close(SAVEIN);
close(SAVEOUT);
# most of the $? crud was coping with broken cshisms
if ( $? >> 8 ) {
- &warn( "(Command exited ", ( $? >> 8 ), ")\n" );
+ db_warn( "(Command exited ", ( $? >> 8 ), ")\n" );
}
elsif ($?) {
- &warn(
+ db_warn(
"(Command died of SIG#",
( $? & 127 ),
( ( $? & 128 ) ? " -- core dumped" : "" ),
@@ -5985,6 +6747,8 @@
} ## end sub system
+*system = \&_db_system;
+
=head1 TTY MANAGEMENT
The subs here do some of the terminal management for multiple debuggers.
@@ -5996,15 +6760,18 @@
If the C<noTTY> debugger option was set, we'll either use the terminal
supplied (the value of the C<noTTY> option), or we'll use C<Term::Rendezvous>
-to find one. If we're a forked debugger, we call C<resetterm> to try to
-get a whole new terminal if we can.
+to find one. If we're a forked debugger, we call C<resetterm> to try to
+get a whole new terminal if we can.
In either case, we set up the terminal next. If the C<ReadLine> option was
true, we'll get a C<Term::ReadLine> object for the current terminal and save
-the appropriate attributes. We then
+the appropriate attributes. We then
=cut
+use vars qw($ornaments);
+use vars qw($rl_attribs);
+
sub setterm {
# Load Term::Readline, but quietly; don't debug it and don't trace it.
@@ -6017,13 +6784,11 @@
if ($tty) {
my ( $i, $o ) = split $tty, /,/;
$o = $i unless defined $o;
- open( IN, "<$i" ) or die "Cannot open TTY `$i' for read: $!";
- open( OUT, ">$o" ) or die "Cannot open TTY `$o' for write: $!";
+ open( IN, "<$i" ) or die "Cannot open TTY '$i' for read: $!";
+ open( OUT, ">$o" ) or die "Cannot open TTY '$o' for write: $!";
$IN = \*IN;
$OUT = \*OUT;
- my $sel = select($OUT);
- $| = 1;
- select($sel);
+ _autoflush($OUT);
} ## end if ($tty)
# We don't have a TTY - try to find one via Term::Rendezvous.
@@ -6070,7 +6835,7 @@
$term->MinLine(2);
- &load_hist();
+ load_hist();
if ( $term->Features->{setHistory} and "@hist" ne "?" ) {
$term->SetHistory(@hist);
@@ -6118,19 +6883,19 @@
fight over the terminal, and you can never quite be sure who's going to get the
input you're typing.
-C<get_fork_TTY> is a glob-aliased function which calls the real function that
-is tasked with doing all the necessary operating system mojo to get a new
+C<get_fork_TTY> is a glob-aliased function which calls the real function that
+is tasked with doing all the necessary operating system mojo to get a new
TTY (and probably another window) and to direct the new debugger to read and
write there.
The debugger provides C<get_fork_TTY> functions which work for TCP
-socket servers, X Windows, OS/2, and Mac OS X. Other systems are not
+socket servers, X11, OS/2, and Mac OS X. Other systems are not
supported. You are encouraged to write C<get_fork_TTY> functions which
work for I<your> platform and contribute them.
=head3 C<socket_get_fork_TTY>
-=cut
+=cut
sub connect_remoteport {
require IO::Socket;
@@ -6157,18 +6922,18 @@
=head3 C<xterm_get_fork_TTY>
-This function provides the C<get_fork_TTY> function for X windows. If a
+This function provides the C<get_fork_TTY> function for X11. If a
program running under the debugger forks, a new <xterm> window is opened and
the subsidiary debugger is directed there.
The C<open()> call is of particular note here. We have the new C<xterm>
-we're spawning route file number 3 to STDOUT, and then execute the C<tty>
-command (which prints the device name of the TTY we'll want to use for input
+we're spawning route file number 3 to STDOUT, and then execute the C<tty>
+command (which prints the device name of the TTY we'll want to use for input
and output to STDOUT, then C<sleep> for a very long time, routing this output
to file number 3. This way we can simply read from the <XT> filehandle (which
-is STDOUT from the I<commands> we ran) to get the TTY we want to use.
+is STDOUT from the I<commands> we ran) to get the TTY we want to use.
-Only works if C<xterm> is in your path and C<$ENV{DISPLAY}>, etc. are
+Only works if C<xterm> is in your path and C<$ENV{DISPLAY}>, etc. are
properly set up.
=cut
@@ -6210,8 +6975,8 @@
sub os2_get_fork_TTY { # A simplification of the following (and works without):
local $\ = '';
( my $name = $0 ) =~ s,^.*[/\\],,s;
- my %opt = ( title => "Daughter Perl debugger $pids $name",
- ($rl ? (read_by_key => 1) : ()) );
+ my %opt = ( title => "Daughter Perl debugger $pids $name",
+ ($rl ? (read_by_key => 1) : ()) );
require OS2::Process;
my ($in, $out, $pid) = eval { OS2::Process::io_term(related => 0, %opt) }
or return;
@@ -6294,10 +7059,10 @@
return unless $version=$ENV{TERM_PROGRAM_VERSION};
foreach my $entry (@script_versions) {
- if ($version>=$entry->[0]) {
- $script=$entry->[1];
- last;
- }
+ if ($version>=$entry->[0]) {
+ $script=$entry->[1];
+ last;
+ }
}
return unless defined($script);
return unless open($pipe,'-|','/usr/bin/osascript','-e',$script);
@@ -6327,11 +7092,13 @@
=cut
+use vars qw($fork_TTY);
+
sub create_IN_OUT { # Create a window with IN/OUT handles redirected there
# If we know how to get a new TTY, do it! $in will have
# the TTY name if get_fork_TTY works.
- my $in = &get_fork_TTY if defined &get_fork_TTY;
+ my $in = get_fork_TTY(@_) if defined &get_fork_TTY;
# It used to be that
$in = $fork_TTY if defined $fork_TTY; # Backward compatibility
@@ -6379,13 +7146,13 @@
Handles rejiggering the prompt when we've forked off a new debugger.
-If the new debugger happened because of a C<system()> that invoked a
+If the new debugger happened because of a C<system()> that invoked a
program under the debugger, the arrow between the old pid and the new
in the prompt has I<two> dashes instead of one.
We take the current list of pids and add this one to the end. If there
-isn't any list yet, we make one up out of the initial pid associated with
-the terminal and our new pid, sticking an arrow (either one-dashed or
+isn't any list yet, we make one up out of the initial pid associated with
+the terminal and our new pid, sticking an arrow (either one-dashed or
two dashed) in between them.
If C<CreateTTY> is off, or C<resetterm> was called with no arguments,
@@ -6437,8 +7204,8 @@
if we got one. If not, we pop the filehandle off and close it, and try the
next one up the stack.
-If we've emptied the filehandle stack, we check to see if we've got a socket
-open, and we read that and return it if we do. If we don't, we just call the
+If we've emptied the filehandle stack, we check to see if we've got a socket
+open, and we read that and return it if we do. If we don't, we just call the
core C<readline()> and return its value.
=cut
@@ -6448,6 +7215,20 @@
# Localize to prevent it from being smashed in the program being debugged.
local $.;
+ # If there are stacked filehandles to read from ...
+ # (Handle it before the typeahead, because we may call source/etc. from
+ # the typeahead.)
+ while (@cmdfhs) {
+
+ # Read from the last one in the stack.
+ my $line = CORE::readline( $cmdfhs[-1] );
+
+ # If we got a line ...
+ defined $line
+ ? ( print $OUT ">> $line" and return $line ) # Echo and return
+ : close pop @cmdfhs; # Pop and close
+ } ## end while (@cmdfhs)
+
# Pull a line out of the typeahead if there's stuff there.
if (@typeahead) {
@@ -6473,18 +7254,6 @@
local $frame = 0;
local $doret = -2;
- # If there are stacked filehandles to read from ...
- while (@cmdfhs) {
-
- # Read from the last one in the stack.
- my $line = CORE::readline( $cmdfhs[-1] );
-
- # If we got a line ...
- defined $line
- ? ( print $OUT ">> $line" and return $line ) # Echo and return
- : close pop @cmdfhs; # Pop and close
- } ## end while (@cmdfhs)
-
# Nothing on the filehandle stack. Socket?
if ( ref $OUT and UNIVERSAL::isa( $OUT, 'IO::Socket::INET' ) ) {
@@ -6492,21 +7261,24 @@
$OUT->write( join( '', @_ ) );
# Receive anything there is to receive.
- $stuff;
my $stuff = '';
my $buf;
- do {
+ my $first_time = 1;
+
+ while ($first_time or (length($buf) && ($stuff .= $buf) !~ /\n/))
+ {
+ $first_time = 0;
$IN->recv( $buf = '', 2048 ); # XXX "what's wrong with sysread?"
# XXX Don't know. You tell me.
- } while length $buf and ($stuff .= $buf) !~ /\n/;
+ }
# What we got.
- $stuff;
+ return $stuff;
} ## end if (ref $OUT and UNIVERSAL::isa...
# No socket. Just read from the terminal.
else {
- $term->readline(@_);
+ return $term->readline(@_);
}
} ## end sub readline
@@ -6598,7 +7370,7 @@
value (if it is quoted). If it's not, we just use the whole value as-is.
We load any modules required to service this option, and then we set it: if
-it just gets stuck in a variable, we do that; if there's a subroutine to
+it just gets stuck in a variable, we do that; if there's a subroutine to
handle setting the option, we call that.
Finally, if we're running in interactive mode, we display the effect of the
@@ -6608,9 +7380,11 @@
=cut
sub parse_options {
- local ($_) = @_;
+ my ($s) = @_;
local $\ = '';
+ my $option;
+
# These options need a value. Don't allow them to be clobbered by accident.
my %opt_needs_val = map { ( $_ => 1 ) } qw{
dumpDepth arrayDepth hashDepth LineInfo maxTraceLen ornaments windowSize
@@ -6617,31 +7391,42 @@
pager quote ReadLine recallCommand RemotePort ShellBang TTY CommandSet
};
- while (length) {
+ while (length($s)) {
my $val_defaulted;
# Clean off excess leading whitespace.
- s/^\s+// && next;
+ $s =~ s/^\s+// && next;
# Options are always all word characters, followed by a non-word
# separator.
- s/^(\w+)(\W?)// or print( $OUT "Invalid option `$_'\n" ), last;
+ if ($s !~ s/^(\w+)(\W?)//) {
+ print {$OUT} "Invalid option '$s'\n";
+ last;
+ }
my ( $opt, $sep ) = ( $1, $2 );
# Make sure that such an option exists.
- my $matches = grep( /^\Q$opt/ && ( $option = $_ ), @options )
- || grep( /^\Q$opt/i && ( $option = $_ ), @options );
+ my $matches = ( grep { /^\Q$opt/ && ( $option = $_ ) } @options )
+ || ( grep { /^\Q$opt/i && ( $option = $_ ) } @options );
- print( $OUT "Unknown option `$opt'\n" ), next unless $matches;
- print( $OUT "Ambiguous option `$opt'\n" ), next if $matches > 1;
+ unless ($matches) {
+ print {$OUT} "Unknown option '$opt'\n";
+ next;
+ }
+ if ($matches > 1) {
+ print {$OUT} "Ambiguous option '$opt'\n";
+ next;
+ }
my $val;
# '?' as separator means query, but must have whitespace after it.
if ( "?" eq $sep ) {
- print( $OUT "Option query `$opt?' followed by non-space `$_'\n" ),
- last
- if /^\S/;
+ if ($s =~ /\A\S/) {
+ print {$OUT} "Option query '$opt?' followed by non-space '$s'\n" ;
+ last;
+ }
+
#&dump_option($opt);
} ## end if ("?" eq $sep)
@@ -6656,7 +7441,7 @@
elsif ( $sep eq "=" ) {
# If quoted, extract a quoted string.
- if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) {
+ if ($s =~ s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) {
my $quote = $1;
( $val = $2 ) =~ s/\\([$quote\\])/$1/g;
}
@@ -6663,7 +7448,7 @@
# Not quoted. Use the whole thing. Warn about 'option='.
else {
- s/^(\S*)//;
+ $s =~ s/^(\S*)//;
$val = $1;
print OUT qq(Option better cleared using $opt=""\n)
unless length $val;
@@ -6675,8 +7460,8 @@
else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
my ($end) =
"\\" . substr( ")]>}$sep", index( "([<{", $sep ), 1 ); #}
- s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)//
- or print( $OUT "Unclosed option value `$opt$sep$_'\n" ), last;
+ $s =~ s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)//
+ or print( $OUT "Unclosed option value '$opt$sep$_'\n" ), last;
( $val = $1 ) =~ s/\\([\\$end])/$1/g;
} ## end else [ if ("?" eq $sep)
@@ -6683,8 +7468,8 @@
# Exclude non-booleans from getting set to 1 by default.
if ( $opt_needs_val{$option} && $val_defaulted ) {
my $cmd = ( $CommandSet eq '580' ) ? 'o' : 'O';
- print $OUT
-"Option `$opt' is non-boolean. Use `$cmd $option=VAL' to set, `$cmd $option?' to query\n";
+ print {$OUT}
+"Option '$opt' is non-boolean. Use '$cmd $option=VAL' to set, '$cmd $option?' to query\n";
next;
} ## end if ($opt_needs_val{$option...
@@ -6692,35 +7477,37 @@
$option{$option} = $val if defined $val;
# Load any module that this option requires.
- eval qq{
- local \$frame = 0;
- local \$doret = -2;
- require '$optionRequire{$option}';
- 1;
- } || die $@ # XXX: shouldn't happen
- if defined $optionRequire{$option}
- && defined $val;
+ if ( defined($optionRequire{$option}) && defined($val) ) {
+ eval qq{
+ local \$frame = 0;
+ local \$doret = -2;
+ require '$optionRequire{$option}';
+ 1;
+ } || die $@ # XXX: shouldn't happen
+ }
# Set it.
# Stick it in the proper variable if it goes in a variable.
- ${ $optionVars{$option} } = $val
- if defined $optionVars{$option}
- && defined $val;
+ if (defined($optionVars{$option}) && defined($val)) {
+ ${ $optionVars{$option} } = $val;
+ }
# Call the appropriate sub if it gets set via sub.
- &{ $optionAction{$option} }($val)
- if defined $optionAction{$option}
- && defined &{ $optionAction{$option} }
- && defined $val;
+ if (defined($optionAction{$option})
+ && defined (&{ $optionAction{$option} })
+ && defined ($val))
+ {
+ &{ $optionAction{$option} }($val);
+ }
# Not initialization - echo the value we set it to.
- dump_option($option) unless $OUT eq \*STDERR;
+ dump_option($option) if ($OUT ne \*STDERR);
} ## end while (length)
} ## end sub parse_options
=head1 RESTART SUPPORT
-These routines are used to store (and restore) lists of items in environment
+These routines are used to store (and restore) lists of items in environment
variables during a restart.
=head2 set_list
@@ -6741,7 +7528,7 @@
# Grab each item in the list, escape the backslashes, encode the non-ASCII
# as hex, and then save in the appropriate VAR_0, VAR_1, etc.
- for $i ( 0 .. $#list ) {
+ for my $i ( 0 .. $#list ) {
$val = $list[$i];
$val =~ s/\\/\\\\/g;
$val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
@@ -6754,7 +7541,7 @@
Reverse the set_list operation: grab VAR_n to see how many we should be getting
back, and then pull VAR_0, VAR_1. etc. back out.
-=cut
+=cut
sub get_list {
my $stem = shift;
@@ -6761,7 +7548,7 @@
my @list;
my $n = delete $ENV{"${stem}_n"};
my $val;
- for $i ( 0 .. $n - 1 ) {
+ for my $i ( 0 .. $n - 1 ) {
$val = delete $ENV{"${stem}_$i"};
$val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
push @list, $val;
@@ -6774,7 +7561,7 @@
=head2 catch()
The C<catch()> subroutine is the essence of fast and low-impact. We simply
-set an already-existing global scalar variable to a constant value. This
+set an already-existing global scalar variable to a constant value. This
avoids allocating any memory possibly in the middle of something that will
get all confused if we do, particularly under I<unsafe signals>.
@@ -6790,14 +7577,14 @@
C<warn> emits a warning, by joining together its arguments and printing
them, with couple of fillips.
-If the composited message I<doesn't> end with a newline, we automatically
-add C<$!> and a newline to the end of the message. The subroutine expects $OUT
-to be set to the filehandle to be used to output warnings; it makes no
+If the composited message I<doesn't> end with a newline, we automatically
+add C<$!> and a newline to the end of the message. The subroutine expects $OUT
+to be set to the filehandle to be used to output warnings; it makes no
assumptions about what filehandles are available.
=cut
-sub warn {
+sub _db_warn {
my ($msg) = join( "", @_ );
$msg .= ": $!\n" unless $msg =~ /\n$/;
local $\ = '';
@@ -6804,12 +7591,14 @@
print $OUT $msg;
} ## end sub warn
+*warn = \&_db_warn;
+
=head1 INITIALIZATION TTY SUPPORT
=head2 C<reset_IN_OUT>
This routine handles restoring the debugger's input and output filehandles
-after we've tried and failed to move them elsewhere. In addition, it assigns
+after we've tried and failed to move them elsewhere. In addition, it assigns
the debugger's output filehandle to $LINEINFO if it was already open there.
=cut
@@ -6825,7 +7614,7 @@
# This term can't get a new tty now. Better luck later.
elsif ($term) {
- &warn("Too late to set IN/OUT filehandles, enabled on next `R'!\n");
+ _db_warn("Too late to set IN/OUT filehandles, enabled on next 'R'!\n");
}
# Set the filehndles up as they were.
@@ -6834,9 +7623,7 @@
}
# Unbuffer the output filehandle.
- my $o = select $OUT;
- $| = 1;
- select $o;
+ _autoflush($OUT);
# Point LINEINFO to the same output filehandle if it was there before.
$LINEINFO = $OUT if $switch_li;
@@ -6844,7 +7631,7 @@
=head1 OPTION SUPPORT ROUTINES
-The following routines are used to process some of the more complicated
+The following routines are used to process some of the more complicated
debugger options.
=head2 C<TTY>
@@ -6880,8 +7667,8 @@
}
# Open file onto the debugger's filehandles, if you can.
- open IN, $in or die "cannot open `$in' for read: $!";
- open OUT, ">$out" or die "cannot open `$out' for write: $!";
+ open IN, $in or die "cannot open '$in' for read: $!";
+ open OUT, ">$out" or die "cannot open '$out' for write: $!";
# Swap to the new filehandles.
reset_IN_OUT( \*IN, \*OUT );
@@ -6892,7 +7679,9 @@
# Terminal doesn't support new TTY, or doesn't support readline.
# Can't do it now, try restarting.
- &warn("Too late to set TTY, enabled on next `R'!\n") if $term and @_;
+ if ($term and @_) {
+ _db_warn("Too late to set TTY, enabled on next 'R'!\n");
+ }
# Useful if done through PERLDB_OPTS:
$console = $tty = shift if @_;
@@ -6911,7 +7700,7 @@
sub noTTY {
if ($term) {
- &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
+ _db_warn("Too late to set noTTY, enabled on next 'R'!\n") if @_;
}
$notty = shift if @_;
$notty;
@@ -6919,7 +7708,7 @@
=head2 C<ReadLine>
-Sets the C<$rl> option variable. If 0, we use C<Term::ReadLine::Stub>
+Sets the C<$rl> option variable. If 0, we use C<Term::ReadLine::Stub>
(essentially, no C<readline> processing on this I<terminal>). Otherwise, we
use C<Term::ReadLine>. Can't be changed after a terminal's in place; we save
the value in case a restart is done so we can change it then.
@@ -6928,7 +7717,7 @@
sub ReadLine {
if ($term) {
- &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
+ _db_warn("Too late to set ReadLine, enabled on next 'R'!\n") if @_;
}
$rl = shift if @_;
$rl;
@@ -6944,7 +7733,7 @@
sub RemotePort {
if ($term) {
- &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
+ _db_warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
}
$remoteport = shift if @_;
$remoteport;
@@ -6977,7 +7766,7 @@
sub NonStop {
if ($term) {
- &warn("Too late to set up NonStop mode, enabled on next `R'!\n")
+ _db_warn("Too late to set up NonStop mode, enabled on next 'R'!\n")
if @_;
}
$runnonstop = shift if @_;
@@ -6986,7 +7775,7 @@
sub DollarCaretP {
if ($term) {
- &warn("Some flag changes could not take effect until next 'R'!\n")
+ _db_warn("Some flag changes could not take effect until next 'R'!\n")
if @_;
}
$^P = parse_DollarCaretP_flags(shift) if @_;
@@ -7010,7 +7799,7 @@
=head2 C<shellBang>
-Sets the shell escape command, and generates a printable copy to be used
+Sets the shell escape command, and generates a printable copy to be used
in the help.
=cut
@@ -7037,23 +7826,30 @@
was passed as the argument. (This means you can't override the terminal's
ornaments.)
-=cut
+=cut
sub ornaments {
if ( defined $term ) {
# We don't want to show warning backtraces, but we do want die() ones.
- local ( $warnLevel, $dieLevel ) = ( 0, 1 );
+ local $warnLevel = 0;
+ local $dieLevel = 1;
# No ornaments if the terminal doesn't support them.
- return '' unless $term->Features->{ornaments};
- eval { $term->ornaments(@_) } || '';
+ if (not $term->Features->{ornaments}) {
+ return '';
+ }
+
+ return (eval { $term->ornaments(@_) } || '');
}
# Use what was passed in if we can't determine it ourselves.
else {
$ornaments = shift;
+
+ return $ornaments;
}
+
} ## end sub ornaments
=head2 C<recallCommand>
@@ -7073,10 +7869,10 @@
}
# Build it into a printable version.
- $prc = $rc; # Copy it
+ $prc = $rc; # Copy it
$prc =~ s/\\b$//; # Remove trailing \b
$prc =~ s/\\(.)/$1/g; # Remove escapes
- $prc; # Return the printable version
+ return $prc; # Return the printable version
} ## end sub recallCommand
=head2 C<LineInfo> - where the line number information goes
@@ -7083,32 +7879,32 @@
Called with no arguments, returns the file or pipe that line info should go to.
-Called with an argument (a file or a pipe), it opens that onto the
-C<LINEINFO> filehandle, unbuffers the filehandle, and then returns the
+Called with an argument (a file or a pipe), it opens that onto the
+C<LINEINFO> filehandle, unbuffers the filehandle, and then returns the
file or pipe again to the caller.
=cut
sub LineInfo {
- return $lineinfo unless @_;
- $lineinfo = shift;
+ if (@_) {
+ $lineinfo = shift;
- # If this is a valid "thing to be opened for output", tack a
- # '>' onto the front.
- my $stream = ( $lineinfo =~ /^(\+?\>|\|)/ ) ? $lineinfo : ">$lineinfo";
+ # If this is a valid "thing to be opened for output", tack a
+ # '>' onto the front.
+ my $stream = ( $lineinfo =~ /^(\+?\>|\|)/ ) ? $lineinfo : ">$lineinfo";
- # If this is a pipe, the stream points to a slave editor.
- $slave_editor = ( $stream =~ /^\|/ );
+ # If this is a pipe, the stream points to a slave editor.
+ $slave_editor = ( $stream =~ /^\|/ );
- # Open it up and unbuffer it.
- open( LINEINFO, "$stream" ) || &warn("Cannot open `$stream' for write");
- $LINEINFO = \*LINEINFO;
- my $save = select($LINEINFO);
- $| = 1;
- select($save);
+ my $new_lineinfo_fh;
+ # Open it up and unbuffer it.
+ open ($new_lineinfo_fh , $stream )
+ or _db_warn("Cannot open '$stream' for write");
+ $LINEINFO = $new_lineinfo_fh;
+ _autoflush($LINEINFO);
+ }
- # Hand the file or pipe back again.
- $lineinfo;
+ return $lineinfo;
} ## end sub LineInfo
=head1 COMMAND SUPPORT ROUTINES
@@ -7140,8 +7936,9 @@
# If the package has a $VERSION package global (as all good packages
# should!) decode it and save as partial message.
- if ( defined ${ $_ . '::VERSION' } ) {
- $version{$file} = "${ $_ . '::VERSION' } from ";
+ my $pkg_version = do { no strict 'refs'; ${ $_ . '::VERSION' } };
+ if ( defined $pkg_version ) {
+ $version{$file} = "$pkg_version from ";
}
# Finish up the message with the file the package came from.
@@ -7169,12 +7966,15 @@
need to continue the descriptive text to another line, start that line with
just tabs and then enter the marked-up text.
-If you are modifying the help text, I<be careful>. The help-string parser is
-not very sophisticated, and if you don't follow these rules it will mangle the
+If you are modifying the help text, I<be careful>. The help-string parser is
+not very sophisticated, and if you don't follow these rules it will mangle the
help beyond hope until you fix the string.
=cut
+use vars qw($pre580_help);
+use vars qw($pre580_summary);
+
sub sethelp {
# XXX: make sure there are tabs between the command and explanation,
@@ -7182,8 +7982,8 @@
# eeevil ornaments enabled. This is an insane mess.
$help = "
-Help is currently only available for the new 5.8 command set.
-No help is available for the old command set.
+Help is currently only available for the new 5.8 command set.
+No help is available for the old command set.
We assume you know what you're doing if you switch to it.
B<T> Stack trace.
@@ -7213,8 +8013,8 @@
B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
B<L> [I<a|b|w>] List actions and or breakpoints and or watch-expressions.
B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
-B<t> Toggle trace mode.
-B<t> I<expr> Trace through execution of I<expr>.
+B<t> [I<n>] Toggle trace mode (to max I<n> levels below current stack depth).
+B<t> [I<n>] I<expr> Trace through execution of I<expr>.
B<b> Sets breakpoint on current line)
B<b> [I<line>] [I<condition>]
Set breakpoint; I<line> defaults to the current execution line;
@@ -7224,7 +8024,7 @@
B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>.
B<b> B<load> I<filename> Set breakpoint on 'require'ing the given file.
B<b> B<postpone> I<subname> [I<condition>]
- Set breakpoint at first line of subroutine after
+ Set breakpoint at first line of subroutine after
it is compiled.
B<b> B<compile> I<subname>
Stop after the subroutine is compiled.
@@ -7295,12 +8095,12 @@
B<R> Pure-man-restart of debugger, some of debugger state
and command-line options may be lost.
Currently the following settings are preserved:
- history, breakpoints and actions, debugger B<O>ptions
+ history, breakpoints and actions, debugger B<O>ptions
and the following command-line options: I<-w>, I<-I>, I<-e>.
B<o> [I<opt>] ... Set boolean option to true
B<o> [I<opt>B<?>] Query options
-B<o> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
+B<o> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
Set options. Use quotes if spaces in value.
I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell;
I<pager> program for output of \"|cmd\";
@@ -7330,17 +8130,17 @@
During startup options are initialized from \$ENV{PERLDB_OPTS}.
You can put additional initialization options I<TTY>, I<noTTY>,
I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
- `B<R>' after you set them).
+ B<R> after you set them).
B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
B<h> Summary of debugger commands.
B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
B<h h> Long help for debugger commands
-B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the
+B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the
named Perl I<manpage>, or on B<$doccmd> itself if omitted.
Set B<\$DB::doccmd> to change viewer.
-Type `|h h' for a paged display if this was too hard to read.
+Type '|h h' for a paged display if this was too hard to read.
"; # Fix balance of vi % matching: }}}}
@@ -7354,7 +8154,7 @@
B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
B<M> Show module versions B<c> [I<ln>|I<sub>] Continue until position
I<Debugger controls:> B<L> List break/watch/actions
- B<o> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
+ B<o> [...] Set debugger options B<t> [I<n>] [I<expr>] Toggle trace [max depth] ][trace expr]
B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
B<$prc> [I<N>|I<pat>] Redo a previous command B<B> I<ln|*> Delete a/all breakpoints
B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
@@ -7405,8 +8205,8 @@
B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
B<L> List all breakpoints and actions.
B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
-B<t> Toggle trace mode.
-B<t> I<expr> Trace through execution of I<expr>.
+B<t> [I<n>] Toggle trace mode (to max I<n> levels below current stack depth) .
+B<t> [I<n>] I<expr> Trace through execution of I<expr>.
B<b> [I<line>] [I<condition>]
Set breakpoint; I<line> defaults to the current execution line;
I<condition> breaks if it evaluates to true, defaults to '1'.
@@ -7413,9 +8213,9 @@
B<b> I<subname> [I<condition>]
Set breakpoint at first line of subroutine.
B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>.
-B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
+B<b> B<load> I<filename> Set breakpoint on 'require'ing the given file.
B<b> B<postpone> I<subname> [I<condition>]
- Set breakpoint at first line of subroutine after
+ Set breakpoint at first line of subroutine after
it is compiled.
B<b> B<compile> I<subname>
Stop after the subroutine is compiled.
@@ -7471,12 +8271,12 @@
B<R> Pure-man-restart of debugger, some of debugger state
and command-line options may be lost.
Currently the following settings are preserved:
- history, breakpoints and actions, debugger B<O>ptions
+ history, breakpoints and actions, debugger B<O>ptions
and the following command-line options: I<-w>, I<-I>, I<-e>.
B<O> [I<opt>] ... Set boolean option to true
B<O> [I<opt>B<?>] Query options
-B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
+B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
Set options. Use quotes if spaces in value.
I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell;
I<pager> program for output of \"|cmd\";
@@ -7506,16 +8306,16 @@
During startup options are initialized from \$ENV{PERLDB_OPTS}.
You can put additional initialization options I<TTY>, I<noTTY>,
I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
- `B<R>' after you set them).
+ B<R> after you set them).
B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
B<h h> Summary of debugger commands.
-B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the
+B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the
named Perl I<manpage>, or on B<$doccmd> itself if omitted.
Set B<\$DB::doccmd> to change viewer.
-Type `|h' for a paged display if this was too hard to read.
+Type '|h' for a paged display if this was too hard to read.
"; # Fix balance of vi % matching: }}}}
@@ -7555,13 +8355,13 @@
Most of what C<print_help> does is just text formatting. It finds the
C<B> and C<I> ornaments, cleans them off, and substitutes the proper
-terminal control characters to simulate them (courtesy of
+terminal control characters to simulate them (courtesy of
C<Term::ReadLine::TermCap>).
=cut
sub print_help {
- local $_ = shift;
+ my $help_str = shift;
# Restore proper alignment destroyed by eeevil I<> and B<>
# ornaments: A pox on both their houses!
@@ -7569,18 +8369,18 @@
# A help command will have everything up to and including
# the first tab sequence padded into a field 16 (or if indented 20)
# wide. If it's wider than that, an extra space will be added.
- s{
+ $help_str =~ s{
^ # only matters at start of line
( \040{4} | \t )* # some subcommands are indented
( < ? # so <CR> works
[BI] < [^\t\n] + ) # find an eeevil ornament
( \t+ ) # original separation, discarded
- ( .* ) # this will now start (no earlier) than
+ ( .* ) # this will now start (no earlier) than
# column 16
} {
my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4);
my $clean = $command;
- $clean =~ s/[BI]<([^>]*)>/$1/g;
+ $clean =~ s/[BI]<([^>]*)>/$1/g;
# replace with this whole string:
($leadwhite ? " " x 4 : "")
@@ -7590,27 +8390,29 @@
}mgex;
- s{ # handle bold ornaments
+ $help_str =~ s{ # handle bold ornaments
B < ( [^>] + | > ) >
} {
- $Term::ReadLine::TermCap::rl_term_set[2]
+ $Term::ReadLine::TermCap::rl_term_set[2]
. $1
. $Term::ReadLine::TermCap::rl_term_set[3]
}gex;
- s{ # handle italic ornaments
+ $help_str =~ s{ # handle italic ornaments
I < ( [^>] + | > ) >
} {
- $Term::ReadLine::TermCap::rl_term_set[0]
+ $Term::ReadLine::TermCap::rl_term_set[0]
. $1
. $Term::ReadLine::TermCap::rl_term_set[1]
}gex;
local $\ = '';
- print $OUT $_;
+ print {$OUT} $help_str;
+
+ return;
} ## end sub print_help
-=head2 C<fix_less>
+=head2 C<fix_less>
This routine does a lot of gyrations to be sure that the pager is C<less>.
It checks for C<less> masquerading as C<more> and records the result in
@@ -7618,29 +8420,42 @@
=cut
-sub fix_less {
+use vars qw($fixed_less);
- # We already know if this is set.
- return if $fixed_less;
-
- # Pager is less for sure.
- my $is_less = $pager =~ /\bless\b/;
- if ( $pager =~ /\bmore\b/ ) {
-
+sub _calc_is_less {
+ if ($pager =~ /\bless\b/)
+ {
+ return 1;
+ }
+ elsif ($pager =~ /\bmore\b/)
+ {
# Nope, set to more. See what's out there.
my @st_more = stat('/usr/bin/more');
my @st_less = stat('/usr/bin/less');
# is it really less, pretending to be more?
- $is_less = @st_more
- && @st_less
- && $st_more[0] == $st_less[0]
- && $st_more[1] == $st_less[1];
- } ## end if ($pager =~ /\bmore\b/)
+ return (
+ @st_more
+ && @st_less
+ && $st_more[0] == $st_less[0]
+ && $st_more[1] == $st_less[1]
+ );
+ }
+ else {
+ return;
+ }
+}
+sub fix_less {
+
+ # We already know if this is set.
+ return if $fixed_less;
+
# changes environment!
# 'r' added so we don't do (slow) stats again.
- $fixed_less = 1 if $is_less;
+ $fixed_less = 1 if _calc_is_less();
+
+ return;
} ## end sub fix_less
=head1 DIE AND WARN MANAGEMENT
@@ -7681,7 +8496,7 @@
local $Carp::CarpLevel = 2; # mydie + confess
# Tell us all about it.
- &warn( Carp::longmess("Signal @_") );
+ _db_warn( Carp::longmess("Signal @_") );
}
# No Carp. Tell us about the signal as best we can.
@@ -7740,20 +8555,20 @@
# Use the debugger's own special way of printing warnings to print
# the stack trace message.
- &warn($mess);
+ _db_warn($mess);
} ## end sub dbwarn
=head2 C<dbdie>
The debugger's own C<$SIG{__DIE__}> handler. Handles providing a stack trace
-by loading C<Carp> and calling C<Carp::longmess()> to get it. We turn off
-single stepping and tracing during the call to C<Carp::longmess> to avoid
+by loading C<Carp> and calling C<Carp::longmess()> to get it. We turn off
+single stepping and tracing during the call to C<Carp::longmess> to avoid
debugging it - we just want to use it.
If C<dieLevel> is zero, we let the program being debugged handle the
exceptions. If it's 1, you get backtraces for any exception. If it's 2,
the debugger takes over all exception handling, printing a backtrace and
-displaying the exception via its C<dbwarn()> routine.
+displaying the exception via its C<dbwarn()> routine.
=cut
@@ -7762,12 +8577,9 @@
local $doret = -2;
local $SIG{__DIE__} = '';
local $SIG{__WARN__} = '';
- my $i = 0;
- my $ineval = 0;
- my $sub;
if ( $dieLevel > 2 ) {
local $SIG{__WARN__} = \&dbwarn;
- &warn(@_); # Yell no matter what
+ _db_warn(@_); # Yell no matter what
return;
}
if ( $dieLevel < 2 ) {
@@ -7811,7 +8623,7 @@
sub warnLevel {
if (@_) {
- $prevwarn = $SIG{__WARN__} unless $warnLevel;
+ my $prevwarn = $SIG{__WARN__} unless $warnLevel;
$warnLevel = shift;
if ($warnLevel) {
$SIG{__WARN__} = \&DB::dbwarn;
@@ -7827,7 +8639,7 @@
=head2 C<dielevel>
-Similar to C<warnLevel>. Non-zero values for C<dieLevel> result in the
+Similar to C<warnLevel>. Non-zero values for C<dieLevel> result in the
C<DB::dbdie()> function overriding any other C<die()> handler. Setting it to
zero lets you use your own C<die()> handler.
@@ -7836,7 +8648,7 @@
sub dieLevel {
local $\ = '';
if (@_) {
- $prevdie = $SIG{__DIE__} unless $dieLevel;
+ my $prevdie = $SIG{__DIE__} unless $dieLevel;
$dieLevel = shift;
if ($dieLevel) {
@@ -7872,7 +8684,7 @@
=head2 C<signalLevel>
Number three in a series: set C<signalLevel> to zero to keep your own
-signal handler for C<SIGSEGV> and/or C<SIGBUS>. Otherwise, the debugger
+signal handler for C<SIGSEGV> and/or C<SIGBUS>. Otherwise, the debugger
takes over and handles them with C<DB::diesignal()>.
=cut
@@ -7879,8 +8691,8 @@
sub signalLevel {
if (@_) {
- $prevsegv = $SIG{SEGV} unless $signalLevel;
- $prevbus = $SIG{BUS} unless $signalLevel;
+ my $prevsegv = $SIG{SEGV} unless $signalLevel;
+ my $prevbus = $SIG{BUS} unless $signalLevel;
$signalLevel = shift;
if ($signalLevel) {
$SIG{SEGV} = \&DB::diesignal;
@@ -7926,6 +8738,8 @@
=cut
+use vars qw($skipCvGV);
+
sub CvGV_name_or_bust {
my $in = shift;
return if $skipCvGV; # Backdoor to avoid problems if XS broken...
@@ -7938,7 +8752,7 @@
=head2 C<find_sub>
-A utility routine used in various places; finds the file where a subroutine
+A utility routine used in various places; finds the file where a subroutine
was defined, and returns that filename and a line-number range.
Tries to use C<@sub> first; if it can't find it there, it tries building a
@@ -7948,33 +8762,47 @@
=cut
+sub _find_sub_helper {
+ my $subr = shift;
+
+ return unless defined &$subr;
+ my $name = CvGV_name_or_bust($subr);
+ my $data;
+ $data = $sub{$name} if defined $name;
+ return $data if defined $data;
+
+ # Old stupid way...
+ $subr = \&$subr; # Hard reference
+ my $s;
+ for ( keys %sub ) {
+ $s = $_, last if $subr eq \&$_;
+ }
+ if ($s)
+ {
+ return $sub{$s};
+ }
+ else
+ {
+ return;
+ }
+
+}
+
sub find_sub {
my $subr = shift;
- $sub{$subr} or do {
- return unless defined &$subr;
- my $name = CvGV_name_or_bust($subr);
- my $data;
- $data = $sub{$name} if defined $name;
- return $data if defined $data;
-
- # Old stupid way...
- $subr = \&$subr; # Hard reference
- my $s;
- for ( keys %sub ) {
- $s = $_, last if $subr eq \&$_;
- }
- $sub{$s} if $s;
- } ## end do
+ return ( $sub{$subr} || _find_sub_helper($subr) );
} ## end sub find_sub
=head2 C<methods>
A subroutine that uses the utility function C<methods_via> to find all the
-methods in the class corresponding to the current reference and in
+methods in the class corresponding to the current reference and in
C<UNIVERSAL>.
=cut
+use vars qw(%seen);
+
sub methods {
# Figure out the class - either this is the class or it's a reference
@@ -8013,24 +8841,25 @@
my @to_print;
# Extract from all the symbols in this class.
- while (my ($name, $glob) = each %{"${class}::"}) {
- # references directly in the symbol table are Proxy Constant
- # Subroutines, and are by their very nature defined
- # Otherwise, check if the thing is a typeglob, and if it is, it decays
- # to a subroutine reference, which can be tested by defined.
- # $glob might also be the value -1 (from sub foo;)
- # or (say) '$$' (from sub foo ($$);)
- # \$glob will be SCALAR in both cases.
- if ((ref $glob || ($glob && ref \$glob eq 'GLOB' && defined &$glob))
- && !$seen{$name}++) {
- push @to_print, "$prepend$name\n";
- }
+ my $class_ref = do { no strict "refs"; \%{$class . '::'} };
+ while (my ($name, $glob) = each %$class_ref) {
+ # references directly in the symbol table are Proxy Constant
+ # Subroutines, and are by their very nature defined
+ # Otherwise, check if the thing is a typeglob, and if it is, it decays
+ # to a subroutine reference, which can be tested by defined.
+ # $glob might also be the value -1 (from sub foo;)
+ # or (say) '$$' (from sub foo ($$);)
+ # \$glob will be SCALAR in both cases.
+ if ((ref $glob || ($glob && ref \$glob eq 'GLOB' && defined &$glob))
+ && !$seen{$name}++) {
+ push @to_print, "$prepend$name\n";
+ }
}
{
- local $\ = '';
- local $, = '';
- print $DB::OUT $_ foreach sort @to_print;
+ local $\ = '';
+ local $, = '';
+ print $DB::OUT $_ foreach sort @to_print;
}
# If the $crawl_upward argument is false, just quit here.
@@ -8038,7 +8867,8 @@
# $crawl_upward true: keep going up the tree.
# Find all the classes this one is a subclass of.
- for $name ( @{"${class}::ISA"} ) {
+ my $class_ISA_ref = do { no strict "refs"; \@{"${class}::ISA"} };
+ for my $name ( @$class_ISA_ref ) {
# Set up the new prefix.
$prepend = $prefix ? $prefix . " -> $name" : $name;
@@ -8063,53 +8893,13 @@
=head2 C<runman> - run the appropriate command to show documentation
Accepts a man page name; runs the appropriate command to display it (set up
-during debugger initialization). Uses C<DB::system> to avoid mucking up the
+during debugger initialization). Uses C<_db_system()> to avoid mucking up the
program's STDIN and STDOUT.
=cut
-sub runman {
- my $page = shift;
- unless ($page) {
- &system("$doccmd $doccmd");
- return;
- }
-
- # this way user can override, like with $doccmd="man -Mwhatever"
- # or even just "man " to disable the path check.
- unless ( $doccmd eq 'man' ) {
- &system("$doccmd $page");
- return;
- }
-
- $page = 'perl' if lc($page) eq 'help';
-
- require Config;
- my $man1dir = $Config::Config{'man1dir'};
- my $man3dir = $Config::Config{'man3dir'};
- for ( $man1dir, $man3dir ) { s#/[^/]*\z## if /\S/ }
- my $manpath = '';
- $manpath .= "$man1dir:" if $man1dir =~ /\S/;
- $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir;
- chop $manpath if $manpath;
-
- # harmless if missing, I figure
- my $oldpath = $ENV{MANPATH};
- $ENV{MANPATH} = $manpath if $manpath;
- my $nopathopt = $^O =~ /dunno what goes here/;
- if (
- CORE::system(
- $doccmd,
-
- # I just *know* there are men without -M
- ( ( $manpath && !$nopathopt ) ? ( "-M", $manpath ) : () ),
- split ' ', $page
- )
- )
- {
- unless ( $page =~ /^perl\w/ ) {
-# do it this way because its easier to slurp in to keep up to date - clunky though.
-my @pods = qw(
+my %_is_in_pods = (map { $_ => 1 }
+ qw(
5004delta
5005delta
561delta
@@ -8131,7 +8921,6 @@
apio
api
artistic
- beos
book
boot
bot
@@ -8156,7 +8945,6 @@
dsc
ebcdic
embed
- epoc
faq1
faq2
faq3
@@ -8194,7 +8982,6 @@
modlib
mod
modstyle
- mpeix
netware
newmod
number
@@ -8236,20 +9023,61 @@
util
uts
var
- vmesa
vms
vos
win32
xs
xstut
+ )
);
- if (grep { $page eq $_ } @pods) {
- $page =~ s/^/perl/;
+
+sub runman {
+ my $page = shift;
+ unless ($page) {
+ _db_system("$doccmd $doccmd");
+ return;
+ }
+
+ # this way user can override, like with $doccmd="man -Mwhatever"
+ # or even just "man " to disable the path check.
+ if ( $doccmd ne 'man' ) {
+ _db_system("$doccmd $page");
+ return;
+ }
+
+ $page = 'perl' if lc($page) eq 'help';
+
+ require Config;
+ my $man1dir = $Config::Config{'man1dir'};
+ my $man3dir = $Config::Config{'man3dir'};
+ for ( $man1dir, $man3dir ) { s#/[^/]*\z## if /\S/ }
+ my $manpath = '';
+ $manpath .= "$man1dir:" if $man1dir =~ /\S/;
+ $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir;
+ chop $manpath if $manpath;
+
+ # harmless if missing, I figure
+ my $oldpath = $ENV{MANPATH};
+ $ENV{MANPATH} = $manpath if $manpath;
+ my $nopathopt = $^O =~ /dunno what goes here/;
+ if (
+ CORE::system(
+ $doccmd,
+
+ # I just *know* there are men without -M
+ ( ( $manpath && !$nopathopt ) ? ( "-M", $manpath ) : () ),
+ split ' ', $page
+ )
+ )
+ {
+ unless ( $page =~ /^perl\w/ ) {
+# do it this way because its easier to slurp in to keep up to date - clunky though.
+ if (exists($_is_in_pods{$page})) {
CORE::system( $doccmd,
( ( $manpath && !$nopathopt ) ? ( "-M", $manpath ) : () ),
- $page );
- } ## end if (grep { $page eq $_...
- } ## end unless ($page =~ /^perl\w/)
+ "perl$page" );
+ }
+ }
} ## end if (CORE::system($doccmd...
if ( defined $oldpath ) {
$ENV{MANPATH} = $manpath;
@@ -8271,7 +9099,7 @@
before the debugger starts executing. We set up various variables that the
debugger has to have set up before the Perl core starts running:
-=over 4
+=over 4
=item *
@@ -8323,6 +9151,8 @@
# The following BEGIN is very handy if debugger goes havoc, debugging debugger?
+use vars qw($db_stop);
+
BEGIN { # This does not compile, alas. (XXX eh?)
$IN = \*STDIN; # For bugs before DB::OUT has been opened
$OUT = \*STDERR; # For errors before DB::OUT has been opened
@@ -8374,7 +9204,7 @@
# "Triggers bug (?) in perl if we postpone this until runtime."
# XXX No details on this yet, or whether we should fix the bug instead
# of work around it. Stay tuned.
- @postponed = @stack = (0);
+ @stack = (0);
# Used to track the current stack depth using the auto-stacked-variable
# trick.
@@ -8394,14 +9224,14 @@
=head2 db_complete
-C<readline> support - adds command completion to basic C<readline>.
+C<readline> support - adds command completion to basic C<readline>.
Returns a list of possible completions to C<readline> when invoked. C<readline>
-will print the longest common substring following the text already entered.
+will print the longest common substring following the text already entered.
If there is only a single possible completion, C<readline> will use it in full.
-This code uses C<map> and C<grep> heavily to create lists of possible
+This code uses C<map> and C<grep> heavily to create lists of possible
completion. Think LISP in this section.
=cut
@@ -8418,9 +9248,9 @@
# The search pattern is current package, ::, extract the next qualifier
# Prefix and pack are set to undef.
my ( $itext, $search, $prefix, $pack ) =
- ( $text, "^\Q${'package'}::\E([^:]+)\$" );
+ ( $text, "^\Q${package}::\E([^:]+)\$" );
-=head3 C<b postpone|compile>
+=head3 C<b postpone|compile>
=over 4
@@ -8446,7 +9276,7 @@
=back
-=cut
+=cut
return sort grep /^\Q$text/, ( keys %sub ),
qw(postpone load compile), # subroutines
@@ -8483,7 +9313,7 @@
Take a partially-qualified package and find all subpackages for it
by getting all the subpackages for the package so far, matching all
-the subpackages against the text, and discarding all of them which
+the subpackages against the text, and discarding all of them which
start with 'main::'. Return this list.
=cut
@@ -8490,7 +9320,8 @@
return sort map { ( $_, db_complete( $_ . "::", "V ", 2 ) ) }
grep !/^main::/, grep /^\Q$text/,
- map { /^(.*)::$/ ? ( $prefix . "::$1" ) : () } keys %{ $prefix . '::' }
+ map { /^(.*)::$/ ? ( $prefix . "::$1" ) : () }
+ do { no strict 'refs'; keys %{ $prefix . '::' } }
if ( substr $line, 0, $start ) =~ /^\|*[Vm]\s+$/
and $text =~ /^(.*[^:])::?(\w*)$/
and $prefix = $1;
@@ -8521,9 +9352,9 @@
=pod
-Under the debugger, source files are represented as C<_E<lt>/fullpath/to/file>
-(C<eval>s are C<_E<lt>(eval NNN)>) keys in C<%main::>. We pull all of these
-out of C<%main::>, add the initial source file, and extract the ones that
+Under the debugger, source files are represented as C<_E<lt>/fullpath/to/file>
+(C<eval>s are C<_E<lt>(eval NNN)>) keys in C<%main::>. We pull all of these
+out of C<%main::>, add the initial source file, and extract the ones that
match the completion text so far.
=cut
@@ -8561,7 +9392,7 @@
=pod
-=over 4
+=over 4
=item *
@@ -8590,8 +9421,11 @@
=cut
- my @out = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/,
- keys %$pack;
+ my @out = do {
+ no strict 'refs';
+ map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/,
+ keys %$pack;
+ };
=pod
@@ -8696,10 +9530,10 @@
return sort @out;
} ## end if ($text =~ /^[\$@%]/)
-=head3 Options
+=head3 Options
We use C<option_val()> to look up the current value of the option. If there's
-only a single value, we complete the command in such a way that it is a
+only a single value, we complete the command in such a way that it is a
complete command for setting the option in question. If there are multiple
possible values, we generate a command consisting of the option plus a trailing
question mark, which, if executed, will list the current value of the option.
@@ -8729,7 +9563,7 @@
# We'll want to quote the string (because of the embedded
# whtespace), but we want to make sure we don't end up with
# mismatched quote characters. We try several possibilities.
- foreach $l ( split //, qq/\"\'\#\|/ ) {
+ foreach my $l ( split //, qq/\"\'\#\|/ ) {
# If we didn't find this quote character in the value,
# quote it using this quote character.
@@ -8775,7 +9609,7 @@
sub end_report {
local $\ = '';
- print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n";
+ print $OUT "Use 'q' to quit or 'R' to restart. 'h q' for details.\n";
}
=head2 clean_ENV
@@ -8886,7 +9720,7 @@
=cut
sub rerun {
- my $i = shift;
+ my $i = shift;
my @args;
pop(@truehist); # strim
unless (defined $truehist[$i]) {
@@ -8896,9 +9730,9 @@
my @temp = @truehist; # store
push(@DB::typeahead, @truehist); # saved
@truehist = @hist = (); # flush
- @args = &restart(); # setup
- &get_list("PERLDB_HIST"); # clean
- &set_list("PERLDB_HIST", @temp); # reset
+ @args = restart(); # setup
+ get_list("PERLDB_HIST"); # clean
+ set_list("PERLDB_HIST", @temp); # reset
}
return @args;
}
@@ -8940,8 +9774,9 @@
# the 'require perl5db.pl;' line), and add them back on
# to the command line to be executed.
if ( $0 eq '-e' ) {
- for ( 1 .. $#{'::_<-e'} ) { # The first line is PERL5DB
- chomp( $cl = ${'::_<-e'}[$_] );
+ my $lines = *{$main::{'_<-e'}}{ARRAY};
+ for ( 1 .. $#$lines ) { # The first line is PERL5DB
+ chomp( $cl = $lines->[$_] );
push @script, '-e', $cl;
}
} ## end if ($0 eq '-e')
@@ -8981,7 +9816,7 @@
# Save the break-on-loads.
set_list( "PERLDB_ON_LOAD", %break_on_load );
-=pod
+=pod
The most complex part of this is the saving of all of the breakpoints. They
can live in an awful lot of places, and we have to go through all of them,
@@ -9018,50 +9853,61 @@
# Save the list of all the breakpoints for this file.
set_list( "PERLDB_FILE_$_", %dbline, @add );
+
+ # Serialize the extra data %breakpoints_data hash.
+ # That's a bug fix.
+ set_list( "PERLDB_FILE_ENABLED_$_",
+ map { _is_breakpoint_enabled($file, $_) ? 1 : 0 }
+ sort { $a <=> $b } keys(%dbline)
+ )
} ## end for (0 .. $#had_breakpoints)
# The breakpoint was inside an eval. This is a little
# more difficult. XXX and I don't understand it.
- for (@hard) {
+ foreach my $hard_file (@hard) {
# Get over to the eval in question.
- *dbline = $main::{ '_<' . $_ };
- my ( $quoted, $sub, %subs, $line ) = quotemeta $_;
- for $sub ( keys %sub ) {
- next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
- $subs{$sub} = [ $1, $2 ];
+ *dbline = $main::{ '_<' . $hard_file };
+ my $quoted = quotemeta $hard_file;
+ my %subs;
+ for my $sub ( keys %sub ) {
+ if (my ($n1, $n2) = $sub{$sub} =~ /\A$quoted:(\d+)-(\d+)\z/) {
+ $subs{$sub} = [ $n1, $n2 ];
+ }
}
unless (%subs) {
- print $OUT
- "No subroutines in $_, ignoring breakpoints.\n";
+ print {$OUT}
+ "No subroutines in $hard_file, ignoring breakpoints.\n";
next;
}
- LINES: for $line ( keys %dbline ) {
+ LINES: foreach my $line ( keys %dbline ) {
# One breakpoint per sub only:
- my ( $offset, $sub, $found );
- SUBS: for $sub ( keys %subs ) {
+ my ( $offset, $found );
+ SUBS: foreach my $sub ( keys %subs ) {
if (
- $subs{$sub}->[1] >=
- $line # Not after the subroutine
+ $subs{$sub}->[1] >= $line # Not after the subroutine
and (
not defined $offset # Not caught
- or $offset < 0
+ or $offset < 0
)
- )
+ )
{ # or badly caught
$found = $sub;
$offset = $line - $subs{$sub}->[0];
- $offset = "+$offset", last SUBS
- if $offset >= 0;
+ if ($offset >= 0) {
+ $offset = "+$offset";
+ last SUBS;
+ }
} ## end if ($subs{$sub}->[1] >=...
} ## end for $sub (keys %subs)
if ( defined $offset ) {
$postponed{$found} =
- "break $offset if $dbline{$line}";
+ "break $offset if $dbline{$line}";
}
else {
- print $OUT
-"Breakpoint in $_:$line ignored: after all the subroutines.\n";
+ print {$OUT}
+ ("Breakpoint in ${hard_file}:$line ignored:"
+ . " after all the subroutines.\n");
}
} ## end for $line (keys %dbline)
} ## end for (@hard)
@@ -9083,7 +9929,7 @@
# Set this back to the initial pid.
$ENV{PERLDB_PIDS} = $ini_pids if defined $ini_pids;
-=pod
+=pod
After all the debugger status has been saved, we take the command we built up
and then return it, so we can C<exec()> it. The debugger will spot the
@@ -9095,7 +9941,7 @@
# And run Perl again. Add the "-d" flag, all the
# flags we built up, the script (whether a one-liner
# or a file), add on the -emacs flag for a slave editor,
- # and then the old arguments.
+ # and then the old arguments.
return ($^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS);
@@ -9105,9 +9951,9 @@
=head1 END PROCESSING - THE C<END> BLOCK
-Come here at the very end of processing. We want to go into a
-loop where we allow the user to enter commands and interact with the
-debugger, but we don't want anything else to execute.
+Come here at the very end of processing. We want to go into a
+loop where we allow the user to enter commands and interact with the
+debugger, but we don't want anything else to execute.
First we set the C<$finished> variable, so that some commands that
shouldn't be run after the end of program quit working.
@@ -9120,7 +9966,7 @@
message and returns control to the debugger. Repeat.
When the user finally enters a C<q> command, C<$fall_off_end> is set to
-1 and the C<END> block simply exits with C<$single> set to 0 (don't
+1 and the C<END> block simply exits with C<$single> set to 0 (don't
break, run to completion.).
=cut
@@ -9131,7 +9977,7 @@
# Do not stop in at_exit() and destructors on exit:
if ($fall_off_end or $runnonstop) {
- &save_hist();
+ save_hist();
} else {
$DB::single = 1;
DB::fake::at_exit();
@@ -9140,12 +9986,12 @@
=head1 PRE-5.8 COMMANDS
-Some of the commands changed function quite a bit in the 5.8 command
+Some of the commands changed function quite a bit in the 5.8 command
realignment, so much so that the old code had to be replaced completely.
Because we wanted to retain the option of being able to go back to the
former command set, we moved the old code off to this section.
-There's an awful lot of duplicated code here. We've duplicated the
+There's an awful lot of duplicated code here. We've duplicated the
comments to keep things clear.
=head2 Null command
@@ -9174,8 +10020,8 @@
if ( $cmd =~ /^(\d*)\s*(.*)/ ) {
# If the line isn't there, use the current line.
- $i = $1 || $line;
- $j = $2;
+ my $i = $1 || $line;
+ my $j = $2;
# If there is an action ...
if ( length $j ) {
@@ -9210,7 +10056,7 @@
} ## end if ($cmd =~ /^(\d*)\s*(.*)/)
} ## end sub cmd_pre580_a
-=head2 Old C<b> command
+=head2 Old C<b> command
Add breakpoints.
@@ -9225,7 +10071,7 @@
if ( $cmd =~ /^load\b\s*(.*)/ ) {
my $file = $1;
$file =~ s/\s+$//;
- &cmd_b_load($file);
+ cmd_b_load($file);
}
# b compile|postpone <some sub> [<condition>]
@@ -9244,7 +10090,7 @@
$subname =~ s/\'/::/g;
# Qualify it into the current package unless it's already qualified.
- $subname = "${'package'}::" . $subname
+ $subname = "${package}::" . $subname
unless $subname =~ /::/;
# Add main if it starts with ::.
@@ -9258,14 +10104,13 @@
elsif ( $cmd =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ ) {
my $subname = $1;
my $cond = length $2 ? $2 : '1';
- &cmd_b_sub( $subname, $cond );
+ cmd_b_sub( $subname, $cond );
}
-
# b <line> [<condition>].
elsif ( $cmd =~ /^(\d*)\s*(.*)/ ) {
my $i = $1 || $dbline;
my $cond = length $2 ? $2 : '1';
- &cmd_b_line( $i, $cond );
+ cmd_b_line( $i, $cond );
}
} ## end sub cmd_pre580_b
@@ -9289,11 +10134,11 @@
# Switch to the desired file temporarily.
local *dbline = $main::{ '_<' . $file };
- my $max = $#dbline;
+ $max = $#dbline;
my $was;
# For all lines in this file ...
- for ( $i = 1 ; $i <= $max ; $i++ ) {
+ for my $i (1 .. $max) {
# If there's a breakpoint or action on this line ...
if ( defined $dbline{$i} ) {
@@ -9306,7 +10151,7 @@
delete $dbline{$i};
}
} ## end if (defined $dbline{$i...
- } ## end for ($i = 1 ; $i <= $max...
+ } ## end for my $i (1 .. $max)
# If, after we turn off the "there were breakpoints in this file"
# bit, the entry in %had_breakpoints for this file is zero,
@@ -9326,7 +10171,7 @@
=head2 Old C<h> command
-Print help. Defaults to printing the long-form help; the 5.8 version
+Print help. Defaults to printing the long-form help; the 5.8 version
prints the summary by default.
=cut
@@ -9412,7 +10257,8 @@
# Get the current value of the expression.
# Doesn't handle expressions returning list values!
$evalarg = $1;
- my ($val) = &eval;
+ # The &-call is here to ascertain the mutability of @_.
+ my ($val) = &DB::eval;
$val = ( defined $val ) ? "'$val'" : 'undef';
# Save it.
@@ -9426,9 +10272,9 @@
=head1 PRE-AND-POST-PROMPT COMMANDS AND ACTIONS
-The debugger used to have a bunch of nearly-identical code to handle
+The debugger used to have a bunch of nearly-identical code to handle
the pre-and-post-prompt action commands. C<cmd_pre590_prepost> and
-C<cmd_prepost> unify all this into one set of code to handle the
+C<cmd_prepost> unify all this into one set of code to handle the
appropriate actions.
=head2 C<cmd_pre590_prepost>
@@ -9444,7 +10290,7 @@
my $line = shift || '*';
my $dbline = shift;
- return &cmd_prepost( $cmd, $line, $dbline );
+ return cmd_prepost( $cmd, $line, $dbline );
} ## end sub cmd_pre590_prepost
=head2 C<cmd_prepost>
@@ -9486,7 +10332,7 @@
elsif ( $cmd =~ /^\{/o ) {
if ( $cmd =~ /^\{.*\}$/o && unbalanced( substr( $cmd, 1 ) ) ) {
print $OUT
-"$cmd is now a debugger command\nuse `;$cmd' if you mean Perl code\n";
+"$cmd is now a debugger command\nuse ';$cmd' if you mean Perl code\n";
}
# Properly balanced. Pre-prompt debugger actions.
@@ -9563,7 +10409,7 @@
package DB::fake;
sub at_exit {
- "Debugged program terminated. Use `q' to quit or `R' to restart.";
+ "Debugged program terminated. Use 'q' to quit or 'R' to restart.";
}
package DB; # Do not trace this 1; below!
Property changes on: trunk/contrib/perl/lib/perl5db.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/perl5db.t
===================================================================
--- trunk/contrib/perl/lib/perl5db.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/perl5db.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -11,175 +11,2702 @@
use Config;
BEGIN {
- if (!-c "/dev/null") {
- print "1..0 # Skip: no /dev/null\n";
- exit 0;
+ if (! -c "/dev/null") {
+ print "1..0 # Skip: no /dev/null\n";
+ exit 0;
}
-my $dev_tty = '/dev/tty';
- $dev_tty = 'TT:' if ($^O eq 'VMS');
- if (!-c $dev_tty) {
- print "1..0 # Skip: no $dev_tty\n";
- exit 0;
+
+ my $dev_tty = '/dev/tty';
+ $dev_tty = 'TT:' if ($^O eq 'VMS');
+ if (! -c $dev_tty) {
+ print "1..0 # Skip: no $dev_tty\n";
+ exit 0;
}
if ($ENV{PERL5DB}) {
- print "1..0 # Skip: \$ENV{PERL5DB} is already set to '$ENV{PERL5DB}'\n";
- exit 0;
+ print "1..0 # Skip: \$ENV{PERL5DB} is already set to '$ENV{PERL5DB}'\n";
+ exit 0;
}
}
-plan(9);
+plan(116);
+my $rc_filename = '.perldb';
+
sub rc {
- open RC, ">", ".perldb" or die $!;
- print RC @_;
- close(RC);
+ open my $rc_fh, '>', $rc_filename
+ or die $!;
+ print {$rc_fh} @_;
+ close ($rc_fh);
+
# overly permissive perms gives "Must not source insecure rcfile"
# and hangs at the DB(1> prompt
- chmod 0644, ".perldb";
+ chmod 0644, $rc_filename;
}
-my $target = '../lib/perl5db/t/eval-line-bug';
+sub _slurp
+{
+ my $filename = shift;
-rc(
- qq|
- &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
- \n|,
+ open my $in, '<', $filename
+ or die "Cannot open '$filename' for slurping - $!";
- qq|
- sub afterinit {
- push(\@DB::typeahead,
- 'b 23',
- 'n',
- 'n',
- 'n',
- 'c', # line 23
- 'n',
- "p \\\@{'main::_<$target'}",
- 'q',
- );
- }\n|,
-);
+ local $/;
+ my $contents = <$in>;
+ close($in);
+
+ return $contents;
+}
+
+my $out_fn = 'db.out';
+
+sub _out_contents
{
- local $ENV{PERLDB_OPTS} = "ReadLine=0";
- runperl(switches => [ '-d' ], progfile => $target);
+ return _slurp($out_fn);
}
-my $contents;
+
+# Test for Proxy constants
{
- local $/;
- open I, "<", 'db.out' or die $!;
- $contents = <I>;
- close(I);
+ rc(
+ <<'EOF',
+
+&parse_options("NonStop=0 ReadLine=0 TTY=db.out LineInfo=db.out");
+
+sub afterinit {
+ push(@DB::typeahead,
+ 'm main->s1',
+ 'q',
+ );
}
-like($contents, qr/sub factorial/,
- 'The ${main::_<filename} variable in the debugger was not destroyed'
-);
+EOF
+ );
+ my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/proxy-constants');
+ is($output, "", "proxy constant subroutines");
+}
+
+# [perl #66110] Call a subroutine inside a regex
{
+ local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
+ my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/rt-66110');
+ like($output, "All tests successful.", "[perl #66110]");
+}
+# [ perl #116769] Frame=2
+{
+ local $ENV{PERLDB_OPTS} = "frame=2 nonstop";
+ my $output = runperl( switches => [ '-d' ], prog => 'print q{success}' );
+ is( $?, 0, '[perl #116769] frame=2 does not crash debugger, exit == 0' );
+ like( $output, 'success' , '[perl #116769] code is run' );
+}
+# [ perl #116771] autotrace
+{
+ local $ENV{PERLDB_OPTS} = "autotrace nonstop";
+ my $output = runperl( switches => [ '-d' ], prog => 'print q{success}' );
+ is( $?, 0, '[perl #116771] autotrace does not crash debugger, exit == 0' );
+ like( $output, 'success' , '[perl #116771] code is run' );
+}
+
+{
+ rc(<<'EOF');
+&parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
+
+sub afterinit {
+ push (@DB::typeahead,
+ 't 2',
+ 'c',
+ 'q',
+ );
+
+}
+EOF
+}
+
+package DebugWrap;
+
+sub new {
+ my $class = shift;
+
+ my $self = bless {}, $class;
+
+ $self->_init(@_);
+
+ return $self;
+}
+
+sub _cmds {
+ my $self = shift;
+
+ if (@_) {
+ $self->{_cmds} = shift;
+ }
+
+ return $self->{_cmds};
+}
+
+sub _prog {
+ my $self = shift;
+
+ if (@_) {
+ $self->{_prog} = shift;
+ }
+
+ return $self->{_prog};
+}
+
+sub _output {
+ my $self = shift;
+
+ if (@_) {
+ $self->{_output} = shift;
+ }
+
+ return $self->{_output};
+}
+
+sub _include_t
+{
+ my $self = shift;
+
+ if (@_)
+ {
+ $self->{_include_t} = shift;
+ }
+
+ return $self->{_include_t};
+}
+
+sub _stderr_val
+{
+ my $self = shift;
+
+ if (@_)
+ {
+ $self->{_stderr_val} = shift;
+ }
+
+ return $self->{_stderr_val};
+}
+
+sub field
+{
+ my $self = shift;
+
+ if (@_)
+ {
+ $self->{field} = shift;
+ }
+
+ return $self->{field};
+}
+
+sub _switches
+{
+ my $self = shift;
+
+ if (@_)
+ {
+ $self->{_switches} = shift;
+ }
+
+ return $self->{_switches};
+}
+
+sub _contents
+{
+ my $self = shift;
+
+ if (@_)
+ {
+ $self->{_contents} = shift;
+ }
+
+ return $self->{_contents};
+}
+
+sub _init
+{
+ my ($self, $args) = @_;
+
+ my $cmds = $args->{cmds};
+
+ if (ref($cmds) ne 'ARRAY') {
+ die "cmds must be an array of commands.";
+ }
+
+ $self->_cmds($cmds);
+
+ my $prog = $args->{prog};
+
+ if (ref($prog) ne '' or !defined($prog)) {
+ die "prog should be a path to a program file.";
+ }
+
+ $self->_prog($prog);
+
+ $self->_include_t($args->{include_t} ? 1 : 0);
+
+ $self->_stderr_val(exists($args->{stderr}) ? $args->{stderr} : 1);
+
+ if (exists($args->{switches}))
+ {
+ $self->_switches($args->{switches});
+ }
+
+ $self->_run();
+
+ return;
+}
+
+sub _quote
+{
+ my ($self, $str) = @_;
+
+ $str =~ s/(["\@\$\\])/\\$1/g;
+ $str =~ s/\n/\\n/g;
+ $str =~ s/\r/\\r/g;
+
+ return qq{"$str"};
+}
+
+sub _run {
+ my $self = shift;
+
+ my $rc = qq{&parse_options("NonStop=0 TTY=db.out LineInfo=db.out");\n};
+
+ $rc .= join('',
+ map { "$_\n"}
+ (q#sub afterinit {#,
+ q#push (@DB::typeahead,#,
+ (map { $self->_quote($_) . "," } @{$self->_cmds()}),
+ q#);#,
+ q#}#,
+ )
+ );
+
+ # I guess two objects like that cannot be used at the same time.
+ # Oh well.
+ ::rc($rc);
+
+ my $output =
+ ::runperl(
+ switches =>
+ [
+ ($self->_switches ? (@{$self->_switches()}) : ('-d')),
+ ($self->_include_t ? ('-I', '../lib/perl5db/t') : ())
+ ],
+ (defined($self->_stderr_val())
+ ? (stderr => $self->_stderr_val())
+ : ()
+ ),
+ progfile => $self->_prog()
+ );
+
+ $self->_output($output);
+
+ $self->_contents(::_out_contents());
+
+ return;
+}
+
+sub get_output
+{
+ return shift->_output();
+}
+
+sub output_like {
+ my ($self, $re, $msg) = @_;
+
+ local $::Level = $::Level + 1;
+ ::like($self->_output(), $re, $msg);
+}
+
+sub output_unlike {
+ my ($self, $re, $msg) = @_;
+
+ local $::Level = $::Level + 1;
+ ::unlike($self->_output(), $re, $msg);
+}
+
+sub contents_like {
+ my ($self, $re, $msg) = @_;
+
+ local $::Level = $::Level + 1;
+ ::like($self->_contents(), $re, $msg);
+}
+
+sub contents_unlike {
+ my ($self, $re, $msg) = @_;
+
+ local $::Level = $::Level + 1;
+ ::unlike($self->_contents(), $re, $msg);
+}
+
+package main;
+
+{
local $ENV{PERLDB_OPTS} = "ReadLine=0";
- my $output = runperl(switches => [ '-d' ], progfile => '../lib/perl5db/t/lvalue-bug');
- like($output, qr/foo is defined/, 'lvalue subs work in the debugger');
+ my $target = '../lib/perl5db/t/eval-line-bug';
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'b 23',
+ 'n',
+ 'n',
+ 'n',
+ 'c', # line 23
+ 'n',
+ "p \@{'main::_<$target'}",
+ 'q',
+ ],
+ prog => $target,
+ }
+ );
+ $wrapper->contents_like(
+ qr/sub factorial/,
+ 'The ${main::_<filename} variable in the debugger was not destroyed',
+ );
}
+sub _calc_generic_wrapper
{
- local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
- my $output = runperl(switches => [ '-d' ], progfile => '../lib/perl5db/t/symbol-table-bug');
- like($output, qr/Undefined symbols 0/, 'there are no undefined values in the symbol table');
+ my $args = shift;
+
+ my $extra_opts = delete($args->{extra_opts});
+ $extra_opts ||= '';
+ local $ENV{PERLDB_OPTS} = "ReadLine=0" . $extra_opts;
+ return DebugWrap->new(
+ {
+ cmds => delete($args->{cmds}),
+ prog => delete($args->{prog}),
+ %$args,
+ }
+ );
}
-SKIP: {
+sub _calc_new_var_wrapper
+{
+ my ($args) = @_;
+ return _calc_generic_wrapper(
+ {
+ cmds =>
+ [
+ 'b 23',
+ 'c',
+ '$new_var = "Foo"',
+ 'x "new_var = <$new_var>\\n"',
+ 'q',
+ ],
+ %$args,
+ }
+ );
+}
+
+sub _calc_threads_wrapper
+{
+ my $args = shift;
+
+ return _calc_new_var_wrapper(
+ {
+ switches => [ '-dt', ],
+ stderr => 1,
+ %$args
+ }
+ );
+}
+
+{
+ _calc_new_var_wrapper({ prog => '../lib/perl5db/t/eval-line-bug'})
+ ->contents_like(
+ qr/new_var = <Foo>/,
+ "no strict 'vars' in evaluated lines.",
+ );
+}
+
+{
+ _calc_new_var_wrapper(
+ {
+ prog => '../lib/perl5db/t/lvalue-bug',
+ stderr => undef(),
+ },
+ )->output_like(
+ qr/foo is defined/,
+ 'lvalue subs work in the debugger',
+ );
+}
+
+{
+ _calc_new_var_wrapper(
+ {
+ prog => '../lib/perl5db/t/symbol-table-bug',
+ extra_opts => "NonStop=1",
+ stderr => undef(),
+ }
+ )->output_like(
+ qr/Undefined symbols 0/,
+ 'there are no undefined values in the symbol table',
+ );
+}
+
+SKIP:
+{
if ( $Config{usethreads} ) {
skip('This perl has threads, skipping non-threaded debugger tests');
- } else {
+ }
+ else {
my $error = 'This Perl not built to support threads';
- my $output = runperl( switches => [ '-dt' ], stderr => 1 );
- like($output, qr/$error/, 'Perl debugger correctly complains that it was not built with threads');
+ _calc_threads_wrapper(
+ {
+ prog => '../lib/perl5db/t/eval-line-bug',
+ }
+ )->output_like(
+ qr/\Q$error\E/,
+ 'Perl debugger correctly complains that it was not built with threads',
+ );
}
+}
-}
-SKIP: {
+SKIP:
+{
if ( $Config{usethreads} ) {
- local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
- my $output = runperl(switches => [ '-dt' ], progfile => '../lib/perl5db/t/symbol-table-bug');
- like($output, qr/Undefined symbols 0/, 'there are no undefined values in the symbol table when running with thread support');
- } else {
+ _calc_threads_wrapper(
+ {
+ prog => '../lib/perl5db/t/symbol-table-bug',
+ }
+ )->output_like(
+ qr/Undefined symbols 0/,
+ 'there are no undefined values in the symbol table when running with thread support',
+ );
+ }
+ else {
skip("This perl is not threaded, skipping threaded debugger tests");
}
}
-
# Test [perl #61222]
{
- rc(
- qq|
- &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
- \n|,
-
- qq|
- sub afterinit {
- push(\@DB::typeahead,
+ local $ENV{PERLDB_OPTS};
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
'm Pie',
'q',
- );
- }\n|,
+ ],
+ prog => '../lib/perl5db/t/rt-61222',
+ }
);
- my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/rt-61222');
- my $contents;
- {
- local $/;
- open I, "<", 'db.out' or die $!;
- $contents = <I>;
- close(I);
- }
- unlike($contents, qr/INCORRECT/, "[perl #61222]");
+ $wrapper->contents_unlike(qr/INCORRECT/, "[perl #61222]");
}
+sub _calc_trace_wrapper
+{
+ my ($args) = @_;
+ return _calc_generic_wrapper(
+ {
+ cmds =>
+ [
+ 't 2',
+ 'c',
+ 'q',
+ ],
+ %$args,
+ }
+ );
+}
-# Test for Proxy constants
+# [perl 104168] level option for tracing
{
- rc(
- qq|
- &parse_options("NonStop=0 ReadLine=0 TTY=db.out LineInfo=db.out");
- \n|,
+ my $wrapper = _calc_trace_wrapper({ prog => '../lib/perl5db/t/rt-104168' });
+ $wrapper->contents_like(qr/level 2/, "[perl #104168] - level 2 appears");
+ $wrapper->contents_unlike(qr/baz/, "[perl #104168] - no 'baz'");
+}
- qq|
- sub afterinit {
- push(\@DB::typeahead,
- 'm main->s1',
+# taint tests
+{
+ my $wrapper = _calc_trace_wrapper(
+ {
+ prog => '../lib/perl5db/t/taint',
+ extra_opts => ' NonStop=1',
+ switches => [ '-d', '-T', ],
+ }
+ );
+
+ my $output = $wrapper->get_output();
+ chomp $output if $^O eq 'VMS'; # newline guaranteed at EOF
+ is($output, '[$^X][done]', "taint");
+}
+
+# Testing that we can set a line in the middle of the file.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'b ../lib/perl5db/t/MyModule.pm:12',
+ 'c',
+ q/do { use IO::Handle; STDOUT->autoflush(1); print "Var=$var\n"; }/,
+ 'c',
'q',
- );
- }\n|,
+ ],
+ include_t => 1,
+ prog => '../lib/perl5db/t/filename-line-breakpoint'
+ }
);
- my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/proxy-constants');
- is($output, "", "proxy constant subroutines");
+ $wrapper->output_like(qr/
+ ^Var=Bar$
+ .*
+ ^In\ MyModule\.$
+ .*
+ ^In\ Main\ File\.$
+ .*
+ /msx,
+ "Can set breakpoint in a line in the middle of the file.");
}
+# Testing that we can set a breakpoint
+{
+ my $wrapper = DebugWrap->new(
+ {
+ prog => '../lib/perl5db/t/breakpoint-bug',
+ cmds =>
+ [
+ 'b 6',
+ 'c',
+ q/do { use IO::Handle; STDOUT->autoflush(1); print "X={$x}\n"; }/,
+ 'c',
+ 'q',
+ ],
+ },
+ );
-# [perl #66110] Call a subroutine inside a regex
+ $wrapper->output_like(
+ qr/X=\{Two\}/msx,
+ "Can set breakpoint in a line."
+ );
+}
+
+# Testing that we can disable a breakpoint at a numeric line.
{
- local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
- my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/rt-66110');
- like($output, "All tests successful.", "[perl #66110]");
+ my $wrapper = DebugWrap->new(
+ {
+ prog => '../lib/perl5db/t/disable-breakpoints-1',
+ cmds =>
+ [
+ 'b 7',
+ 'b 11',
+ 'disable 7',
+ 'c',
+ q/print "X={$x}\n";/,
+ 'c',
+ 'q',
+ ],
+ }
+ );
+
+ $wrapper->output_like(qr/X=\{SecondVal\}/ms,
+ "Can set breakpoint in a line.");
}
-# taint tests
+# Testing that we can re-enable a breakpoint at a numeric line.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ prog => '../lib/perl5db/t/disable-breakpoints-2',
+ cmds =>
+ [
+ 'b 8',
+ 'b 24',
+ 'disable 24',
+ 'c',
+ 'enable 24',
+ 'c',
+ q/print "X={$x}\n";/,
+ 'c',
+ 'q',
+ ],
+ },
+ );
+ $wrapper->output_like(
+ qr/
+ X=\{SecondValOneHundred\}
+ /msx,
+ "Can set breakpoint in a line."
+ );
+}
+# clean up.
+
+# Disable and enable for breakpoints on outer files.
{
- local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
- my $output = runperl(switches => [ '-d', '-T' ], stderr => 1,
- progfile => '../lib/perl5db/t/taint');
- chomp $output if $^O eq 'VMS'; # newline guaranteed at EOF
- is($output, '[$^X][done]', "taint");
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'b 10',
+ 'b ../lib/perl5db/t/EnableModule.pm:14',
+ 'disable ../lib/perl5db/t/EnableModule.pm:14',
+ 'c',
+ 'enable ../lib/perl5db/t/EnableModule.pm:14',
+ 'c',
+ q/print "X={$x}\n";/,
+ 'c',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/disable-breakpoints-3',
+ include_t => 1,
+ }
+ );
+
+ $wrapper->output_like(qr/
+ X=\{SecondValTwoHundred\}
+ /msx,
+ "Can set breakpoint in a line.");
}
+# Testing that the prompt with the information appears.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds => ['q'],
+ prog => '../lib/perl5db/t/disable-breakpoints-1',
+ }
+ );
-# clean up.
+ $wrapper->contents_like(qr/
+ ^main::\([^\)]*\bdisable-breakpoints-1:2\):\n
+ 2:\s+my\ \$x\ =\ "One";\n
+ /msx,
+ "Prompt should display the first line of code.");
+}
+# Testing that R (restart) and "B *" work.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'b 13',
+ 'c',
+ 'B *',
+ 'b 9',
+ 'R',
+ 'c',
+ q/print "X={$x};dummy={$dummy}\n";/,
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/disable-breakpoints-1',
+ }
+ );
+
+ $wrapper->output_like(qr/
+ X=\{FirstVal\};dummy=\{1\}
+ /msx,
+ "Restart and delete all breakpoints work properly.");
+}
+
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'c 15',
+ q/print "X={$x}\n";/,
+ 'c',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/disable-breakpoints-1',
+ }
+ );
+
+ $wrapper->output_like(qr/
+ X=\{ThirdVal\}
+ /msx,
+ "'c line_num' is working properly.");
+}
+
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'n',
+ 'n',
+ 'b . $exp > 200',
+ 'c',
+ q/print "Exp={$exp}\n";/,
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/break-on-dot',
+ }
+ );
+
+ $wrapper->output_like(qr/
+ Exp=\{256\}
+ /msx,
+ "'b .' is working correctly.");
+}
+
+# Testing that the prompt with the information appears inside a subroutine call.
+# See https://rt.perl.org/rt3/Ticket/Display.html?id=104820
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'c back',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/with-subroutine',
+ }
+ );
+
+ $wrapper->contents_like(
+ qr/
+ ^main::back\([^\)\n]*\bwith-subroutine:15\):[\ \t]*\n
+ ^15:\s*print\ "hello\ back\\n";
+ /msx,
+ "Prompt should display the line of code inside a subroutine.");
+}
+
+# Checking that the p command works.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'p "<<<" . (4*6) . ">>>"',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/with-subroutine',
+ }
+ );
+
+ $wrapper->contents_like(
+ qr/<<<24>>>/,
+ "p command works.");
+}
+
+# Tests for x.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ q/x {500 => 600}/,
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/with-subroutine',
+ }
+ );
+
+ $wrapper->contents_like(
+ # qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/,
+ qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/ms,
+ "x command test."
+ );
+}
+
+# Tests for x with @_
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'b 10',
+ 'c',
+ 'x @_',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-passing-at-underscore-to-x-etc',
+ }
+ );
+
+ $wrapper->contents_like(
+ # qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/,
+ qr/Arg1.*?Capsula.*GreekHumor.*Socrates/ms,
+ q/x command test with '@_'./,
+ );
+}
+
+# Tests for mutating @_
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'b 10',
+ 'c',
+ 'shift(@_)',
+ 'print "\n\n\n(((" . join(",", @_) . ")))\n\n\n"',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-passing-at-underscore-to-x-etc',
+ }
+ );
+
+ $wrapper->output_like(
+ qr/^\(\(\(Capsula,GreekHumor,Socrates\)\)\)$/ms,
+ q/Mutating '@_'./,
+ );
+}
+
+# Tests for x with AutoTrace=1.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'n',
+ 'o AutoTrace=1',
+ # So it may fail.
+ q/x "failure"/,
+ q/x \$x/,
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/with-subroutine',
+ }
+ );
+
+ $wrapper->contents_like(
+ # qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/,
+ qr/^0\s+SCALAR\([^\)]+\)\n\s+-> 'hello world'\n/ms,
+ "x after AutoTrace=1 command is working."
+ );
+}
+
+# Tests for "T" (stack trace).
+{
+ my $prog_fn = '../lib/perl5db/t/rt-104168';
+ my $wrapper = DebugWrap->new(
+ {
+ prog => $prog_fn,
+ cmds =>
+ [
+ 'c baz',
+ 'T',
+ 'q',
+ ],
+ }
+ );
+ my $re_text = join('',
+ map {
+ sprintf(
+ "%s = %s\\(\\) called from file " .
+ "'" . quotemeta($prog_fn) . "' line %s\\n",
+ (map { quotemeta($_) } @$_)
+ )
+ }
+ (
+ ['.', 'main::baz', 14,],
+ ['.', 'main::bar', 9,],
+ ['.', 'main::foo', 6],
+ )
+ );
+ $wrapper->contents_like(
+ # qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/,
+ qr/^$re_text/ms,
+ "T command test."
+ );
+}
+
+# Test for s.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'b 9',
+ 'c',
+ 's',
+ q/print "X={$x};dummy={$dummy}\n";/,
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/disable-breakpoints-1'
+ }
+ );
+
+ $wrapper->output_like(qr/
+ X=\{SecondVal\};dummy=\{1\}
+ /msx,
+ 'test for s - single step',
+ );
+}
+
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'n',
+ 'n',
+ 'b . $exp > 200',
+ 'c',
+ q/print "Exp={$exp}\n";/,
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/break-on-dot'
+ }
+ );
+
+ $wrapper->output_like(qr/
+ Exp=\{256\}
+ /msx,
+ "'b .' is working correctly.");
+}
+
+{
+ my $prog_fn = '../lib/perl5db/t/rt-104168';
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 's',
+ 'q',
+ ],
+ prog => $prog_fn,
+ }
+ );
+
+ $wrapper->contents_like(
+ qr/
+ ^main::foo\([^\)\n]*\brt-104168:9\):[\ \t]*\n
+ ^9:\s*bar\(\);
+ /msx,
+ 'Test for the s command.',
+ );
+}
+
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 's uncalled_subroutine()',
+ 'c',
+ 'q',
+ ],
+
+ prog => '../lib/perl5db/t/uncalled-subroutine'}
+ );
+
+ $wrapper->output_like(
+ qr/<1,2,3,4,5>\n/,
+ 'uncalled_subroutine was called after s EXPR()',
+ );
+}
+
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'n uncalled_subroutine()',
+ 'c',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/uncalled-subroutine',
+ }
+ );
+
+ $wrapper->output_like(
+ qr/<1,2,3,4,5>\n/,
+ 'uncalled_subroutine was called after n EXPR()',
+ );
+}
+
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'b fact',
+ 'c',
+ 'c',
+ 'c',
+ 'n',
+ 'print "<$n>"',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/fact',
+ }
+ );
+
+ $wrapper->output_like(
+ qr/<3>/,
+ 'b subroutine works fine',
+ );
+}
+
+# Test for 'M' (module list).
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'M',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/load-modules'
+ }
+ );
+
+ $wrapper->contents_like(
+ qr[Scalar/Util\.pm],
+ 'M (module list) works fine',
+ );
+}
+
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'b 14',
+ 'c',
+ '$flag = 1;',
+ 'r',
+ 'print "Var=$var\n";',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-r-statement',
+ }
+ );
+
+ $wrapper->output_like(
+ qr/
+ ^Foo$
+ .*?
+ ^Bar$
+ .*?
+ ^Var=Test$
+ /msx,
+ 'r statement is working properly.',
+ );
+}
+
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'l',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-l-statement-1',
+ }
+ );
+
+ $wrapper->contents_like(
+ qr/
+ ^1==>\s+\$x\ =\ 1;\n
+ 2:\s+print\ "1\\n";\n
+ 3\s*\n
+ 4:\s+\$x\ =\ 2;\n
+ 5:\s+print\ "2\\n";\n
+ /msx,
+ 'l statement is working properly (test No. 1).',
+ );
+}
+
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'l',
+ q/# After l 1/,
+ 'l',
+ q/# After l 2/,
+ '-',
+ q/# After -/,
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-l-statement-1',
+ }
+ );
+
+ my $first_l_out = qr/
+ 1==>\s+\$x\ =\ 1;\n
+ 2:\s+print\ "1\\n";\n
+ 3\s*\n
+ 4:\s+\$x\ =\ 2;\n
+ 5:\s+print\ "2\\n";\n
+ 6\s*\n
+ 7:\s+\$x\ =\ 3;\n
+ 8:\s+print\ "3\\n";\n
+ 9\s*\n
+ 10:\s+\$x\ =\ 4;\n
+ /msx;
+
+ my $second_l_out = qr/
+ 11:\s+print\ "4\\n";\n
+ 12\s*\n
+ 13:\s+\$x\ =\ 5;\n
+ 14:\s+print\ "5\\n";\n
+ 15\s*\n
+ 16:\s+\$x\ =\ 6;\n
+ 17:\s+print\ "6\\n";\n
+ 18\s*\n
+ 19:\s+\$x\ =\ 7;\n
+ 20:\s+print\ "7\\n";\n
+ /msx;
+ $wrapper->contents_like(
+ qr/
+ ^$first_l_out
+ [^\n]*?DB<\d+>\ \#\ After\ l\ 1\n
+ [\ \t]*\n
+ [^\n]*?DB<\d+>\ l\s*\n
+ $second_l_out
+ [^\n]*?DB<\d+>\ \#\ After\ l\ 2\n
+ [\ \t]*\n
+ [^\n]*?DB<\d+>\ -\s*\n
+ $first_l_out
+ [^\n]*?DB<\d+>\ \#\ After\ -\n
+ /msx,
+ 'l followed by l and then followed by -',
+ );
+}
+
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'l fact',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-l-statement-2',
+ }
+ );
+
+ my $first_l_out = qr/
+ 6\s+sub\ fact\ \{\n
+ 7:\s+my\ \$n\ =\ shift;\n
+ 8:\s+if\ \(\$n\ >\ 1\)\ \{\n
+ 9:\s+return\ \$n\ \*\ fact\(\$n\ -\ 1\);
+ /msx;
+
+ $wrapper->contents_like(
+ qr/
+ DB<1>\s+l\ fact\n
+ $first_l_out
+ /msx,
+ 'l subroutine_name',
+ );
+}
+
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'b fact',
+ 'c',
+ # Repeat several times to avoid @typeahead problems.
+ '.',
+ '.',
+ '.',
+ '.',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-l-statement-2',
+ }
+ );
+
+ my $line_out = qr /
+ ^main::fact\([^\n]*?:7\):\n
+ ^7:\s+my\ \$n\ =\ shift;\n
+ /msx;
+
+ $wrapper->contents_like(
+ qr/
+ $line_out
+ $line_out
+ /msx,
+ 'Test the "." command',
+ );
+}
+
+# Testing that the f command works.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'f ../lib/perl5db/t/MyModule.pm',
+ 'b 12',
+ 'c',
+ q/do { use IO::Handle; STDOUT->autoflush(1); print "Var=$var\n"; }/,
+ 'c',
+ 'q',
+ ],
+ include_t => 1,
+ prog => '../lib/perl5db/t/filename-line-breakpoint'
+ }
+ );
+
+ $wrapper->output_like(qr/
+ ^Var=Bar$
+ .*
+ ^In\ MyModule\.$
+ .*
+ ^In\ Main\ File\.$
+ .*
+ /msx,
+ "f command is working.",
+ );
+}
+
+# We broke the /pattern/ command because apparently the CORE::eval-s inside
+# lib/perl5db.pl cannot handle lexical variable properly. So we now fix this
+# bug.
+#
+# TODO :
+#
+# 1. Go over the rest of the "eval"s in lib/perl5db.t and see if they cause
+# problems.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ '/for/',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/eval-line-bug',
+ }
+ );
+
+ $wrapper->contents_like(
+ qr/12: \s* for\ my\ \$q\ \(1\ \.\.\ 10\)\ \{/msx,
+ "/pat/ command is working and found a match.",
+ );
+}
+
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'b 22',
+ 'c',
+ '?for?',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/eval-line-bug',
+ }
+ );
+
+ $wrapper->contents_like(
+ qr/12: \s* for\ my\ \$q\ \(1\ \.\.\ 10\)\ \{/msx,
+ "?pat? command is working and found a match.",
+ );
+}
+
+# Test the L command.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'b 6',
+ 'b 13 ($q == 5)',
+ 'L',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/eval-line-bug',
+ }
+ );
+
+ $wrapper->contents_like(
+ qr#
+ ^\S*?eval-line-bug:\n
+ \s*6:\s*my\ \$i\ =\ 5;\n
+ \s*break\ if\ \(1\)\n
+ \s*13:\s*\$i\ \+=\ \$q;\n
+ \s*break\ if\ \(\(\$q\ ==\ 5\)\)\n
+ #msx,
+ "L command is listing breakpoints",
+ );
+}
+
+# Test the L command for watch expressions.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'w (5+6)',
+ 'L',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/eval-line-bug',
+ }
+ );
+
+ $wrapper->contents_like(
+ qr#
+ ^Watch-expressions:\n
+ \s*\(5\+6\)\n
+ #msx,
+ "L command is listing watch expressions",
+ );
+}
+
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'w (5+6)',
+ 'w (11*23)',
+ 'W (5+6)',
+ 'L',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/eval-line-bug',
+ }
+ );
+
+ $wrapper->contents_like(
+ qr#
+ ^Watch-expressions:\n
+ \s*\(11\*23\)\n
+ ^auto\(
+ #msx,
+ "L command is not listing deleted watch expressions",
+ );
+}
+
+# Test the L command.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'b 6',
+ 'a 13 print $i',
+ 'L',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/eval-line-bug',
+ }
+ );
+
+ $wrapper->contents_like(
+ qr#
+ ^\S*?eval-line-bug:\n
+ \s*6:\s*my\ \$i\ =\ 5;\n
+ \s*break\ if\ \(1\)\n
+ \s*13:\s*\$i\ \+=\ \$q;\n
+ \s*action:\s+print\ \$i\n
+ #msx,
+ "L command is listing actions and breakpoints",
+ );
+}
+
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'S',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/rt-104168',
+ }
+ );
+
+ $wrapper->contents_like(
+ qr#
+ ^main::bar\n
+ main::baz\n
+ main::foo\n
+ #msx,
+ "S command - 1",
+ );
+}
+
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'S ^main::ba',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/rt-104168',
+ }
+ );
+
+ $wrapper->contents_like(
+ qr#
+ ^main::bar\n
+ main::baz\n
+ auto\(
+ #msx,
+ "S command with regex",
+ );
+}
+
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'S !^main::ba',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/rt-104168',
+ }
+ );
+
+ $wrapper->contents_unlike(
+ qr#
+ ^main::ba
+ #msx,
+ "S command with negative regex",
+ );
+
+ $wrapper->contents_like(
+ qr#
+ ^main::foo\n
+ #msx,
+ "S command with negative regex - what it still matches",
+ );
+}
+
+# Test the 'a' command.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'a 13 print "\nVar<Q>=$q\n"',
+ 'c',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/eval-line-bug',
+ }
+ );
+
+ $wrapper->output_like(qr#
+ \nVar<Q>=1\n
+ \nVar<Q>=2\n
+ \nVar<Q>=3\n
+ #msx,
+ "a command is working",
+ );
+}
+
+# Test the 'a' command with no line number.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'n',
+ q/a print "Hello " . (3 * 4) . "\n";/,
+ 'c',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-a-statement-1',
+ }
+ );
+
+ $wrapper->output_like(qr#
+ (?:^Hello\ 12\n.*?){4}
+ #msx,
+ "a command with no line number is working",
+ );
+}
+
+# Test the 'A' command
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'a 13 print "\nVar<Q>=$q\n"',
+ 'A 13',
+ 'c',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/eval-line-bug',
+ }
+ );
+
+ $wrapper->output_like(
+ qr#\A\z#msx, # The empty string.
+ "A command (for removing actions) is working",
+ );
+}
+
+# Test the 'A *' command
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'a 6 print "\nFail!\n"',
+ 'a 13 print "\nVar<Q>=$q\n"',
+ 'A *',
+ 'c',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/eval-line-bug',
+ }
+ );
+
+ $wrapper->output_like(
+ qr#\A\z#msx, # The empty string.
+ "'A *' command (for removing all actions) is working",
+ );
+}
+
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'n',
+ 'w $foo',
+ 'c',
+ 'print "\nIDX=<$idx>\n"',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-w-statement-1',
+ }
+ );
+
+
+ $wrapper->contents_like(qr#
+ \$foo\ changed:\n
+ \s+old\ value:\s+'1'\n
+ \s+new\ value:\s+'2'\n
+ #msx,
+ 'w command - watchpoint changed',
+ );
+ $wrapper->output_like(qr#
+ \nIDX=<20>\n
+ #msx,
+ "w command - correct output from IDX",
+ );
+}
+
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'n',
+ 'w $foo',
+ 'W $foo',
+ 'c',
+ 'print "\nIDX=<$idx>\n"',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-w-statement-1',
+ }
+ );
+
+ $wrapper->contents_unlike(qr#
+ \$foo\ changed:
+ #msx,
+ 'W command - watchpoint was deleted',
+ );
+
+ $wrapper->output_like(qr#
+ \nIDX=<>\n
+ #msx,
+ "W command - stopped at end.",
+ );
+}
+
+# Test the W * command.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'n',
+ 'w $foo',
+ 'w ($foo*$foo)',
+ 'W *',
+ 'c',
+ 'print "\nIDX=<$idx>\n"',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-w-statement-1',
+ }
+ );
+
+ $wrapper->contents_unlike(qr#
+ \$foo\ changed:
+ #msx,
+ '"W *" command - watchpoint was deleted',
+ );
+
+ $wrapper->output_like(qr#
+ \nIDX=<>\n
+ #msx,
+ '"W *" command - stopped at end.',
+ );
+}
+
+# Test the 'o' command (without further arguments).
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'o',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-w-statement-1',
+ }
+ );
+
+ $wrapper->contents_like(qr#
+ ^\s*warnLevel\ =\ '1'\n
+ #msx,
+ q#"o" command (without arguments) displays warnLevel#,
+ );
+
+ $wrapper->contents_like(qr#
+ ^\s*signalLevel\ =\ '1'\n
+ #msx,
+ q#"o" command (without arguments) displays signalLevel#,
+ );
+
+ $wrapper->contents_like(qr#
+ ^\s*dieLevel\ =\ '1'\n
+ #msx,
+ q#"o" command (without arguments) displays dieLevel#,
+ );
+
+ $wrapper->contents_like(qr#
+ ^\s*hashDepth\ =\ 'N/A'\n
+ #msx,
+ q#"o" command (without arguments) displays hashDepth#,
+ );
+}
+
+# Test the 'o' query command.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'o hashDepth? signalLevel?',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-w-statement-1',
+ }
+ );
+
+ $wrapper->contents_unlike(qr#warnLevel#,
+ q#"o" query command does not display warnLevel#,
+ );
+
+ $wrapper->contents_like(qr#
+ ^\s*signalLevel\ =\ '1'\n
+ #msx,
+ q#"o" query command displays signalLevel#,
+ );
+
+ $wrapper->contents_unlike(qr#dieLevel#,
+ q#"o" query command does not display dieLevel#,
+ );
+
+ $wrapper->contents_like(qr#
+ ^\s*hashDepth\ =\ 'N/A'\n
+ #msx,
+ q#"o" query command displays hashDepth#,
+ );
+}
+
+# Test the 'o' set command.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'o signalLevel=0',
+ 'o',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-w-statement-1',
+ }
+ );
+
+ $wrapper->contents_like(qr/
+ ^\s*(signalLevel\ =\ '0'\n)
+ .*?
+ ^\s*\1
+ /msx,
+ q#o set command works#,
+ );
+
+ $wrapper->contents_like(qr#
+ ^\s*hashDepth\ =\ 'N/A'\n
+ #msx,
+ q#o set command - hashDepth#,
+ );
+}
+
+# Test the '<' and "< ?" commands.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ q/< print "\nX=<$x>\n"/,
+ q/b 7/,
+ q/< ?/,
+ 'c',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/disable-breakpoints-1',
+ }
+ );
+
+ $wrapper->contents_like(qr/
+ ^pre-perl\ commands:\n
+ \s*<\ --\ print\ "\\nX=<\$x>\\n"\n
+ /msx,
+ q#Test < and < ? commands - contents.#,
+ );
+
+ $wrapper->output_like(qr#
+ ^X=<FirstVal>\n
+ #msx,
+ q#Test < and < ? commands - output.#,
+ );
+}
+
+# Test the '< *' command.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ q/< print "\nX=<$x>\n"/,
+ q/b 7/,
+ q/< */,
+ 'c',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/disable-breakpoints-1',
+ }
+ );
+
+ $wrapper->output_unlike(qr/FirstVal/,
+ q#Test the '< *' command.#,
+ );
+}
+
+# Test the '>' and "> ?" commands.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ q/$::foo = 500;/,
+ q/> print "\nFOO=<$::foo>\n"/,
+ q/b 7/,
+ q/> ?/,
+ 'c',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/disable-breakpoints-1',
+ }
+ );
+
+ $wrapper->contents_like(qr/
+ ^post-perl\ commands:\n
+ \s*>\ --\ print\ "\\nFOO=<\$::foo>\\n"\n
+ /msx,
+ q#Test > and > ? commands - contents.#,
+ );
+
+ $wrapper->output_like(qr#
+ ^FOO=<500>\n
+ #msx,
+ q#Test > and > ? commands - output.#,
+ );
+}
+
+# Test the '> *' command.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ q/> print "\nFOO=<$::foo>\n"/,
+ q/b 7/,
+ q/> */,
+ 'c',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/disable-breakpoints-1',
+ }
+ );
+
+ $wrapper->output_unlike(qr/FOO=/,
+ q#Test the '> *' command.#,
+ );
+}
+
+# Test the < and > commands together
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ q/$::lorem = 0;/,
+ q/< $::lorem += 10;/,
+ q/> print "\nLOREM=<$::lorem>\n"/,
+ q/b 7/,
+ q/b 5/,
+ 'c',
+ 'c',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/disable-breakpoints-1',
+ }
+ );
+
+ $wrapper->output_like(qr#
+ ^LOREM=<10>\n
+ #msx,
+ q#Test < and > commands. #,
+ );
+}
+
+# Test the { ? and { [command] commands.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ '{ ?',
+ '{ l',
+ '{ ?',
+ q/b 5/,
+ q/c/,
+ q/q/,
+ ],
+ prog => '../lib/perl5db/t/disable-breakpoints-1',
+ }
+ );
+
+ $wrapper->contents_like(qr#
+ ^No\ pre-debugger\ actions\.\n
+ .*?
+ ^pre-debugger\ commands:\n
+ \s+\{\ --\ l\n
+ .*?
+ ^5==>b\s+\$x\ =\ "FirstVal";\n
+ 6\s*\n
+ 7:\s+\$dummy\+\+;\n
+ 8\s*\n
+ 9:\s+\$x\ =\ "SecondVal";\n
+
+ #msx,
+ 'Test the pre-prompt debugger commands',
+ );
+}
+
+# Test the { * command.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ '{ q',
+ '{ *',
+ q/b 5/,
+ q/c/,
+ q/print (("One" x 5), "\n");/,
+ q/q/,
+ ],
+ prog => '../lib/perl5db/t/disable-breakpoints-1',
+ }
+ );
+
+ $wrapper->contents_like(qr#
+ ^All\ \{\ actions\ cleared\.\n
+ #msx,
+ 'Test the { * command',
+ );
+
+ $wrapper->output_like(qr/OneOneOneOneOne/,
+ '{ * test - output is OK.',
+ );
+}
+
+# Test the ! command.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'l 3-5',
+ '!',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/disable-breakpoints-1',
+ }
+ );
+
+ $wrapper->contents_like(qr#
+ (^3:\s+my\ \$dummy\ =\ 0;\n
+ 4\s*\n
+ 5:\s+\$x\ =\ "FirstVal";)\n
+ .*?
+ ^l\ 3-5\n
+ \1
+ #msx,
+ 'Test the ! command (along with l 3-5)',
+ );
+}
+
+# Test the ! -number command.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'l 3-5',
+ 'l 2',
+ '! -1',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/disable-breakpoints-1',
+ }
+ );
+
+ $wrapper->contents_like(qr#
+ (^3:\s+my\ \$dummy\ =\ 0;\n
+ 4\s*\n
+ 5:\s+\$x\ =\ "FirstVal";)\n
+ .*?
+ ^2==\>\s+my\ \$x\ =\ "One";\n
+ .*?
+ ^l\ 3-5\n
+ \1
+ #msx,
+ 'Test the ! -n command (along with l)',
+ );
+}
+
+# Test the 'source' command.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'source ../lib/perl5db/t/source-cmd-test.perldb',
+ # If we have a 'q' here, then the typeahead will override the
+ # input, and so it won't be reached - solution:
+ # put a q inside the .perldb commands.
+ # ( This may be a bug or a misfeature. )
+ ],
+ prog => '../lib/perl5db/t/disable-breakpoints-1',
+ }
+ );
+
+ $wrapper->contents_like(qr#
+ ^3:\s+my\ \$dummy\ =\ 0;\n
+ 4\s*\n
+ 5:\s+\$x\ =\ "FirstVal";\n
+ 6\s*\n
+ 7:\s+\$dummy\+\+;\n
+ 8\s*\n
+ 9:\s+\$x\ =\ "SecondVal";\n
+ 10\s*\n
+ #msx,
+ 'Test the source command (along with l)',
+ );
+}
+
+# Test the 'source' command being traversed from withing typeahead.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'source ../lib/perl5db/t/source-cmd-test-no-q.perldb',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/disable-breakpoints-1',
+ }
+ );
+
+ $wrapper->contents_like(qr#
+ ^3:\s+my\ \$dummy\ =\ 0;\n
+ 4\s*\n
+ 5:\s+\$x\ =\ "FirstVal";\n
+ 6\s*\n
+ 7:\s+\$dummy\+\+;\n
+ 8\s*\n
+ 9:\s+\$x\ =\ "SecondVal";\n
+ 10\s*\n
+ #msx,
+ 'Test the source command inside a typeahead',
+ );
+}
+
+# Test the 'H -number' command.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'l 1-10',
+ 'l 5-10',
+ 'x "Hello World"',
+ 'l 1-5',
+ 'b 3',
+ 'x (20+4)',
+ 'H -7',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/disable-breakpoints-1',
+ }
+ );
+
+ $wrapper->contents_like(qr#
+ ^\d+:\s+H\ -7\n
+ \d+:\s+x\ \(20\+4\)\n
+ \d+:\s+b\ 3\n
+ \d+:\s+l\ 1-5\n
+ \d+:\s+x\ "Hello\ World"\n
+ \d+:\s+l\ 5-10\n
+ \d+:\s+l\ 1-10\n
+ #msx,
+ 'Test the H -num command',
+ );
+}
+
+# Add a test for H (without arguments)
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'l 1-10',
+ 'l 5-10',
+ 'x "Hello World"',
+ 'l 1-5',
+ 'b 3',
+ 'x (20+4)',
+ 'H',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/disable-breakpoints-1',
+ }
+ );
+
+ $wrapper->contents_like(qr#
+ ^\d+:\s+x\ \(20\+4\)\n
+ \d+:\s+b\ 3\n
+ \d+:\s+l\ 1-5\n
+ \d+:\s+x\ "Hello\ World"\n
+ \d+:\s+l\ 5-10\n
+ \d+:\s+l\ 1-10\n
+ #msx,
+ 'Test the H command (without a number.)',
+ );
+}
+
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ '= quit q',
+ '= foobar l',
+ 'foobar',
+ 'quit',
+ ],
+ prog => '../lib/perl5db/t/test-l-statement-1',
+ }
+ );
+
+ $wrapper->contents_like(
+ qr/
+ ^1==>\s+\$x\ =\ 1;\n
+ 2:\s+print\ "1\\n";\n
+ 3\s*\n
+ 4:\s+\$x\ =\ 2;\n
+ 5:\s+print\ "2\\n";\n
+ /msx,
+ 'Test the = (command alias) command.',
+ );
+}
+
+# Test the m statement.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'm main',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/disable-breakpoints-1',
+ }
+ );
+
+ $wrapper->contents_like(qr#
+ ^via\ UNIVERSAL:\ DOES$
+ #msx,
+ "Test m for main - 1",
+ );
+
+ $wrapper->contents_like(qr#
+ ^via\ UNIVERSAL:\ can$
+ #msx,
+ "Test m for main - 2",
+ );
+}
+
+# Test the m statement.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'b 41',
+ 'c',
+ 'm $obj',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-m-statement-1',
+ }
+ );
+
+ $wrapper->contents_like(qr#^greet$#ms,
+ "Test m for obj - 1",
+ );
+
+ $wrapper->contents_like(qr#^via UNIVERSAL: can$#ms,
+ "Test m for obj - 1",
+ );
+}
+
+# Test the M command.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'M',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-m-statement-1',
+ }
+ );
+
+ $wrapper->contents_like(qr#
+ ^'strict\.pm'\ =>\ '\d+\.\d+\ from
+ #msx,
+ "Test M",
+ );
+
+}
+
+# Test the recallCommand option.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'o recallCommand=%',
+ 'l 3-5',
+ 'l 2',
+ '% -1',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/disable-breakpoints-1',
+ }
+ );
+
+ $wrapper->contents_like(qr#
+ (^3:\s+my\ \$dummy\ =\ 0;\n
+ 4\s*\n
+ 5:\s+\$x\ =\ "FirstVal";)\n
+ .*?
+ ^2==\>\s+my\ \$x\ =\ "One";\n
+ .*?
+ ^l\ 3-5\n
+ \1
+ #msx,
+ 'Test the o recallCommand option',
+ );
+}
+
+# Test the dieLevel option
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ q/o dieLevel='1'/,
+ q/c/,
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-dieLevel-option-1',
+ }
+ );
+
+ $wrapper->output_like(qr#
+ ^This\ program\ dies\.\ at\ \S+\ line\ 18\.\n
+ .*?
+ ^\s+main::baz\(\)\ called\ at\ \S+\ line\ 13\n
+ \s+main::bar\(\)\ called\ at\ \S+\ line\ 7\n
+ \s+main::foo\(\)\ called\ at\ \S+\ line\ 21\n
+ #msx,
+ 'Test the o dieLevel option',
+ );
+}
+
+# Test the warnLevel option
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ q/o warnLevel='1'/,
+ q/c/,
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-warnLevel-option-1',
+ }
+ );
+
+ $wrapper->contents_like(qr#
+ ^This\ is\ not\ a\ warning\.\ at\ \S+\ line\ 18\.\n
+ .*?
+ ^\s+main::baz\(\)\ called\ at\ \S+\ line\ 13\n
+ \s+main::bar\(\)\ called\ at\ \S+\ line\ 25\n
+ \s+main::myfunc\(\)\ called\ at\ \S+\ line\ 28\n
+ #msx,
+ 'Test the o warnLevel option',
+ );
+}
+
+# Test the t command
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 't',
+ 'c',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/disable-breakpoints-1',
+ }
+ );
+
+ $wrapper->contents_like(qr/
+ ^main::\([^:]+:15\):\n
+ 15:\s+\$dummy\+\+;\n
+ main::\([^:]+:17\):\n
+ 17:\s+\$x\ =\ "FourthVal";\n
+ /msx,
+ 'Test the t command (without a number.)',
+ );
+}
+
+# Test the o AutoTrace command
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'o AutoTrace',
+ 'c',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/disable-breakpoints-1',
+ }
+ );
+
+ $wrapper->contents_like(qr/
+ ^main::\([^:]+:15\):\n
+ 15:\s+\$dummy\+\+;\n
+ main::\([^:]+:17\):\n
+ 17:\s+\$x\ =\ "FourthVal";\n
+ /msx,
+ 'Test the o AutoTrace command',
+ );
+}
+
+# Test the t command with function calls
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 't',
+ 'b 18',
+ 'c',
+ 'x ["foo"]',
+ 'x ["bar"]',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-warnLevel-option-1',
+ }
+ );
+
+ $wrapper->contents_like(qr/
+ ^main::\([^:]+:28\):\n
+ 28:\s+myfunc\(\);\n
+ main::myfunc\([^:]+:25\):\n
+ 25:\s+bar\(\);\n
+ /msx,
+ 'Test the t command with function calls.',
+ );
+}
+
+# Test the o AutoTrace command with function calls
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'o AutoTrace',
+ 'b 18',
+ 'c',
+ 'x ["foo"]',
+ 'x ["bar"]',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-warnLevel-option-1',
+ }
+ );
+
+ $wrapper->contents_like(qr/
+ ^main::\([^:]+:28\):\n
+ 28:\s+myfunc\(\);\n
+ main::myfunc\([^:]+:25\):\n
+ 25:\s+bar\(\);\n
+ /msx,
+ 'Test the t command with function calls.',
+ );
+}
+
+# Test the final message.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'c',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-warnLevel-option-1',
+ }
+ );
+
+ $wrapper->contents_like(qr/
+ ^Debugged\ program\ terminated\.
+ /msx,
+ 'Test the final "Debugged program terminated" message.',
+ );
+}
+
+# Test the o inhibit_exit=0 command
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'o inhibit_exit=0',
+ 'n',
+ 'n',
+ 'n',
+ 'n',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-warnLevel-option-1',
+ }
+ );
+
+ $wrapper->contents_unlike(qr/
+ ^Debugged\ program\ terminated\.
+ /msx,
+ 'Test the o inhibit_exit=0 command.',
+ );
+}
+
+# Test the o PrintRet=1 option
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'o PrintRet=1',
+ 'b 29',
+ 'c',
+ q/$x = 's';/,
+ 'b 10',
+ 'c',
+ 'r',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-PrintRet-option-1',
+ }
+ );
+
+ $wrapper->contents_like(
+ qr/scalar context return from main::return_scalar: 20024/,
+ "Test o PrintRet=1",
+ );
+}
+
+# Test the o PrintRet=0 option
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'o PrintRet=0',
+ 'b 29',
+ 'c',
+ q/$x = 's';/,
+ 'b 10',
+ 'c',
+ 'r',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-PrintRet-option-1',
+ }
+ );
+
+ $wrapper->contents_unlike(
+ qr/scalar context/,
+ "Test o PrintRet=0",
+ );
+}
+
+# Test the o PrintRet=1 option in list context
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'o PrintRet=1',
+ 'b 29',
+ 'c',
+ q/$x = 'l';/,
+ 'b 17',
+ 'c',
+ 'r',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-PrintRet-option-1',
+ }
+ );
+
+ $wrapper->contents_like(
+ qr/list context return from main::return_list:\n0\s*'Foo'\n1\s*'Bar'\n2\s*'Baz'\n/,
+ "Test o PrintRet=1 in list context",
+ );
+}
+
+# Test the o PrintRet=0 option in list context
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'o PrintRet=0',
+ 'b 29',
+ 'c',
+ q/$x = 'l';/,
+ 'b 17',
+ 'c',
+ 'r',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-PrintRet-option-1',
+ }
+ );
+
+ $wrapper->contents_unlike(
+ qr/list context/,
+ "Test o PrintRet=0 in list context",
+ );
+}
+
+# Test the o PrintRet=1 option in void context
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'o PrintRet=1',
+ 'b 29',
+ 'c',
+ q/$x = 'v';/,
+ 'b 24',
+ 'c',
+ 'r',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-PrintRet-option-1',
+ }
+ );
+
+ $wrapper->contents_like(
+ qr/void context return from main::return_void/,
+ "Test o PrintRet=1 in void context",
+ );
+}
+
+# Test the o PrintRet=1 option in void context
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'o PrintRet=0',
+ 'b 29',
+ 'c',
+ q/$x = 'v';/,
+ 'b 24',
+ 'c',
+ 'r',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-PrintRet-option-1',
+ }
+ );
+
+ $wrapper->contents_unlike(
+ qr/void context/,
+ "Test o PrintRet=0 in void context",
+ );
+}
+
+# Test the o frame option.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ # This is to avoid getting the "Debugger program terminated"
+ # junk that interferes with the normal output.
+ 'o inhibit_exit=0',
+ 'b 10',
+ 'c',
+ 'o frame=255',
+ 'c',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-frame-option-1',
+ }
+ );
+
+ $wrapper->contents_like(
+ qr/
+ in\s*\.=main::my_other_func\(3,\ 1200\)\ from.*?
+ out\s*\.=main::my_other_func\(3,\ 1200\)\ from
+ /msx,
+ "Test o PrintRet=0 in void context",
+ );
+}
+
+{ # test t expr
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ # This is to avoid getting the "Debugger program terminated"
+ # junk that interferes with the normal output.
+ 'o inhibit_exit=0',
+ 't fact(3)',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/fact',
+ }
+ );
+
+ $wrapper->contents_like(
+ qr/
+ (?:^main::fact.*return\ \$n\ \*\ fact\(\$n\ -\ 1\);.*)
+ /msx,
+ "Test t expr",
+ );
+}
+
+# Test the w for lexical variables expression.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ # This is to avoid getting the "Debugger program terminated"
+ # junk that interferes with the normal output.
+ 'w $exp',
+ 'n',
+ 'n',
+ 'n',
+ 'n',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/break-on-dot',
+ }
+ );
+
+ $wrapper->contents_like(
+ qr/
+\s+old\ value:\s+'1'\n
+\s+new\ value:\s+'2'\n
+ /msx,
+ "Test w for lexical values.",
+ );
+}
+
+# Test the perldoc command
+# We don't actually run the program, but we need to provide one to the wrapper.
+SKIP:
+{
+ $^O eq "linux"
+ or skip "man errors aren't especially portable", 1;
+ -x '/usr/bin/man'
+ or skip "man command seems to be missing", 1;
+ local $ENV{LANG} = "C";
+ local $ENV{LC_MESSAGES} = "C";
+ local $ENV{LC_ALL} = "C";
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'perldoc perlrules',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/fact',
+ }
+ );
+
+ $wrapper->output_like(
+ qr/No manual entry for perlrules/,
+ 'perldoc command works fine',
+ );
+}
+
END {
- 1 while unlink qw(.perldb db.out);
+ 1 while unlink ($rc_filename, $out_fn);
}
Property changes on: trunk/contrib/perl/lib/perl5db.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/lib/pwd.pl
===================================================================
--- trunk/contrib/perl/lib/pwd.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/pwd.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/pwd.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/shellwords.pl
===================================================================
--- trunk/contrib/perl/lib/shellwords.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/shellwords.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/shellwords.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/lib/sigtrap.pm
===================================================================
--- trunk/contrib/perl/lib/sigtrap.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/sigtrap.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -8,7 +8,7 @@
use Carp;
-$VERSION = 1.05;
+$VERSION = 1.07;
$Verbose ||= 0;
sub import {
@@ -95,8 +95,7 @@
# Now go for broke.
for ($i = 1; ($p,$f,$l,$s,$h,$w,$e,$r) = caller($i); $i++) {
@a = ();
- for my $fr (@args) {
- my $_ = $fr;
+ for (@{[@args]}) {
s/([\'\\])/\\$1/g;
s/([^\0]*)/'$1'/
unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
@@ -115,7 +114,7 @@
} elsif ($s eq '(eval)') {
$s = "eval {...}";
}
- $f = "file `$f'" unless $f eq '-e';
+ $f = "file '$f'" unless $f eq '-e';
$mess = "$w$s$a called from $f line $l\n";
syswrite(STDERR, $mess, length($mess));
}
Property changes on: trunk/contrib/perl/lib/sigtrap.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/sigtrap.t
===================================================================
--- trunk/contrib/perl/lib/sigtrap.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/sigtrap.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/sigtrap.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/lib/sort.pm
===================================================================
--- trunk/contrib/perl/lib/sort.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/sort.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,6 +1,6 @@
package sort;
-our $VERSION = '2.01';
+our $VERSION = '2.02';
# The hints for pp_sort are now stored in $^H{sort}; older versions
# of perl used the global variable $sort::hints. -- rjh 2005-12-19
@@ -180,7 +180,7 @@
{ use sort qw(defaults _quicksort); # force quicksort
no sort "stable"; # stability not wanted
my $current;
- BEGIN { $current = print sort::current; }
+ BEGIN { $current = sort::current; }
print "$current\n";
@a = sort @b;
# Pragmas go out of scope at the end of the block
@@ -187,7 +187,7 @@
}
{ use sort qw(defaults stable); # force stability
my $current;
- BEGIN { $current = print sort::current; }
+ BEGIN { $current = sort::current; }
print "$current\n";
@c = sort @d;
}
Property changes on: trunk/contrib/perl/lib/sort.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/sort.t
===================================================================
--- trunk/contrib/perl/lib/sort.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/sort.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/sort.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/stat.pl
===================================================================
--- trunk/contrib/perl/lib/stat.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/stat.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/stat.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/lib/strict.pm
===================================================================
--- trunk/contrib/perl/lib/strict.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/strict.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,6 +1,6 @@
package strict;
-$strict::VERSION = "1.04";
+$strict::VERSION = "1.07";
# Verify that we're called correctly so that strictures will work.
unless ( __FILE__ =~ /(^|[\/\\])\Q${\__PACKAGE__}\E\.pmc?$/ ) {
@@ -14,12 +14,20 @@
subs => 0x00000200,
vars => 0x00000400
);
+my %explicit_bitmask = (
+refs => 0x00000020,
+subs => 0x00000040,
+vars => 0x00000080
+);
sub bits {
my $bits = 0;
my @wrong;
foreach my $s (@_) {
- push @wrong, $s unless exists $bitmask{$s};
+ if (exists $bitmask{$s}) {
+ $^H |= $explicit_bitmask{$s};
+ }
+ else { push @wrong, $s };
$bits |= $bitmask{$s} || 0;
}
if (@wrong) {
@@ -29,16 +37,16 @@
$bits;
}
-my $default_bits = bits(qw(refs subs vars));
+my @default_bits = qw(refs subs vars);
sub import {
shift;
- $^H |= @_ ? bits(@_) : $default_bits;
+ $^H |= bits(@_ ? @_ : @default_bits);
}
sub unimport {
shift;
- $^H &= ~ (@_ ? bits(@_) : $default_bits);
+ $^H &= ~ bits(@_ ? @_ : @default_bits);
}
1;
@@ -91,17 +99,17 @@
=item C<strict vars>
-This generates a compile-time error if you access a variable that wasn't
-declared via C<our> or C<use vars>,
-localized via C<my()>, or wasn't fully qualified. Because this is to avoid
-variable suicide problems and subtle dynamic scoping issues, a merely
-local() variable isn't good enough. See L<perlfunc/my> and
-L<perlfunc/local>.
+This generates a compile-time error if you access a variable that was
+neither explicitly declared (using any of C<my>, C<our>, C<state>, or C<use
+vars>) nor fully qualified. (Because this is to avoid variable suicide
+problems and subtle dynamic scoping issues, a merely C<local> variable isn't
+good enough.) See L<perlfunc/my>, L<perlfunc/our>, L<perlfunc/state>,
+L<perlfunc/local>, and L<vars>.
use strict 'vars';
$X::foo = 1; # ok, fully qualified
my $foo = 10; # ok, my() var
- local $foo = 9; # blows up
+ local $baz = 9; # blows up, $baz not declared before
package Cinna;
our $bar; # Declares $bar in current package
Property changes on: trunk/contrib/perl/lib/strict.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/strict.t
===================================================================
--- trunk/contrib/perl/lib/strict.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/strict.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/strict.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/subs.pm
===================================================================
--- trunk/contrib/perl/lib/subs.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/subs.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,6 +1,6 @@
package subs;
-our $VERSION = '1.00';
+our $VERSION = '1.01';
=head1 NAME
@@ -19,7 +19,7 @@
Unlike pragmas that affect the C<$^H> hints variable, the C<use vars> and
C<use subs> declarations are not BLOCK-scoped. They are thus effective
-for the entire file in which they appear. You may not rescind such
+for the entire package in which they appear. You may not rescind such
declarations with C<no vars> or C<no subs>.
See L<perlmodlib/Pragmatic Modules> and L<strict/strict subs>.
Property changes on: trunk/contrib/perl/lib/subs.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/subs.t
===================================================================
--- trunk/contrib/perl/lib/subs.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/subs.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/subs.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/lib/syslog.pl
===================================================================
--- trunk/contrib/perl/lib/syslog.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/syslog.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/syslog.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/tainted.pl
===================================================================
--- trunk/contrib/perl/lib/tainted.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/tainted.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/tainted.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/termcap.pl
===================================================================
--- trunk/contrib/perl/lib/termcap.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/termcap.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/termcap.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/timelocal.pl
===================================================================
--- trunk/contrib/perl/lib/timelocal.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/timelocal.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/timelocal.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/ArabicShaping.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/ArabicShaping.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/ArabicShaping.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,27 +1,30 @@
-# ArabicShaping-6.0.0.txt
-# Date: 2010-04-30, 13:47:00 PDT [KW]
+# ArabicShaping-6.2.0.txt
+# Date: 2012-05-15, 21:05:00 GMT [KW]
#
# This file is a normative contributory data file in the
# Unicode Character Database.
#
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
#
-# This file defines the shaping classes for Arabic, Syriac, and N'Ko
+# This file defines the Joining_Type and Joining_Group
+# property values for Arabic, Syriac, N'Ko, and Mandaic
# positional shaping, repeating in machine readable form the
-# information exemplified in Tables 8-3, 8-7, 8-8, 8-11, 8-12,
-# 8-13, and 13-5 of The Unicode Standard, Version 6.0.
+# information exemplified in Tables 8-3, 8-8, 8-9, 8-10, 8-13, 8-14,
+# 8-15, 13-5, 14-5, and 14-6 of The Unicode Standard, Version 6.2.
#
-# See sections 8.2, 8.3, and 13.5 of The Unicode Standard, Version 6.0
-# for more information.
+# See sections 8.2, 8.3, 13.5, and 14.12 of The Unicode Standard,
+# Version 6.2 for more information.
#
# Each line contains four fields, separated by a semicolon.
#
# Field 0: the code point, in 4-digit hexadecimal
-# form, of an Arabic, Syriac, or N'Ko character.
+# form, of an Arabic, Syriac, N'Ko, or Mandaic character.
#
-# Field 1: gives a short schematic name for that character,
-# abbreviated from the normative Unicode character name.
+# Field 1: gives a short schematic name for that character.
+# The schematic name is descriptive of the shape, based as
+# consistently as possible on a name for the skeleton and
+# then the diacritic marks applied to the skeleton, if any.
# Note that this schematic name is considered a comment,
# and does not constitute a formal property value.
#
@@ -65,7 +68,7 @@
# to jg=No_Joining_Group in this data file. Other, more specific
# joining group values will be defined only if an explicit proposal
# to define those values exactly has been approved by the UTC. This
-# is the convention exemplified by the N'Ko script. Only the Arabic
+# is the convention exemplified by the N'Ko and Mandaic scripts. Only the Arabic
# and Syriac scripts currently have explicit joining group values defined.
#
# Note: Code points that are not explicitly listed in this file are
@@ -84,44 +87,45 @@
# Unicode; Schematic Name; Joining Type; Joining Group
-# Arabic characters
+# Arabic Characters
0600; ARABIC NUMBER SIGN; U; No_Joining_Group
0601; ARABIC SIGN SANAH; U; No_Joining_Group
0602; ARABIC FOOTNOTE MARKER; U; No_Joining_Group
0603; ARABIC SIGN SAFHA; U; No_Joining_Group
+0604; ARABIC SIGN SAMVAT; U; No_Joining_Group
0608; ARABIC RAY; U; No_Joining_Group
060B; AFGHANI SIGN; U; No_Joining_Group
-0620; YEH WITH RING; D; YEH
+0620; DOTLESS YEH WITH SEPARATE RING BELOW; D; YEH
0621; HAMZA; U; No_Joining_Group
-0622; MADDA ON ALEF; R; ALEF
-0623; HAMZA ON ALEF; R; ALEF
-0624; HAMZA ON WAW; R; WAW
-0625; HAMZA UNDER ALEF; R; ALEF
-0626; HAMZA ON YEH; D; YEH
+0622; ALEF WITH MADDA ABOVE; R; ALEF
+0623; ALEF WITH HAMZA ABOVE; R; ALEF
+0624; WAW WITH HAMZA ABOVE; R; WAW
+0625; ALEF WITH HAMZA BELOW; R; ALEF
+0626; DOTLESS YEH WITH HAMZA ABOVE; D; YEH
0627; ALEF; R; ALEF
0628; BEH; D; BEH
0629; TEH MARBUTA; R; TEH MARBUTA
-062A; TEH; D; BEH
-062B; THEH; D; BEH
-062C; JEEM; D; HAH
+062A; DOTLESS BEH WITH 2 DOTS ABOVE; D; BEH
+062B; DOTLESS BEH WITH 3 DOTS ABOVE; D; BEH
+062C; HAH WITH DOT BELOW; D; HAH
062D; HAH; D; HAH
-062E; KHAH; D; HAH
+062E; HAH WITH DOT ABOVE; D; HAH
062F; DAL; R; DAL
-0630; THAL; R; DAL
+0630; DAL WITH DOT ABOVE; R; DAL
0631; REH; R; REH
-0632; ZAIN; R; REH
+0632; REH WITH DOT ABOVE; R; REH
0633; SEEN; D; SEEN
-0634; SHEEN; D; SEEN
+0634; SEEN WITH 3 DOTS ABOVE; D; SEEN
0635; SAD; D; SAD
-0636; DAD; D; SAD
+0636; SAD WITH DOT ABOVE; D; SAD
0637; TAH; D; TAH
-0638; ZAH; D; TAH
+0638; TAH WITH DOT ABOVE; D; TAH
0639; AIN; D; AIN
-063A; GHAIN; D; AIN
+063A; AIN WITH DOT ABOVE; D; AIN
063B; KEHEH WITH 2 DOTS ABOVE; D; GAF
-063C; KEHEH WITH 3 DOTS BELOW; D; GAF
-063D; FARSI YEH WITH INVERTED V; D; FARSI YEH
+063C; KEHEH WITH 3 DOTS BELOW; D; GAF
+063D; FARSI YEH WITH INVERTED V ABOVE; D; FARSI YEH
063E; FARSI YEH WITH 2 DOTS ABOVE; D; FARSI YEH
063F; FARSI YEH WITH 3 DOTS ABOVE; D; FARSI YEH
0640; TATWEEL; C; No_Joining_Group
@@ -133,48 +137,48 @@
0646; NOON; D; NOON
0647; HEH; D; HEH
0648; WAW; R; WAW
-0649; ALEF MAKSURA; D; YEH
+0649; DOTLESS YEH; D; YEH
064A; YEH; D; YEH
066E; DOTLESS BEH; D; BEH
066F; DOTLESS QAF; D; QAF
-0671; HAMZAT WASL ON ALEF; R; ALEF
-0672; WAVY HAMZA ON ALEF; R; ALEF
-0673; WAVY HAMZA UNDER ALEF; R; ALEF
+0671; ALEF WITH WASLA ABOVE; R; ALEF
+0672; ALEF WITH WAVY HAMZA ABOVE; R; ALEF
+0673; ALEF WITH WAVY HAMZA BELOW; R; ALEF
0674; HIGH HAMZA; U; No_Joining_Group
0675; HIGH HAMZA ALEF; R; ALEF
0676; HIGH HAMZA WAW; R; WAW
-0677; HIGH HAMZA WAW WITH DAMMA; R; WAW
-0678; HIGH HAMZA YEH; D; YEH
-0679; TEH WITH SMALL TAH; D; BEH
-067A; TEH WITH 2 DOTS VERTICAL ABOVE; D; BEH
-067B; BEH WITH 2 DOTS VERTICAL BELOW; D; BEH
-067C; TEH WITH RING; D; BEH
-067D; TEH WITH 3 DOTS ABOVE DOWNWARD; D; BEH
-067E; TEH WITH 3 DOTS BELOW; D; BEH
-067F; TEH WITH 4 DOTS ABOVE; D; BEH
-0680; BEH WITH 4 DOTS BELOW; D; BEH
-0681; HAMZA ON HAH; D; HAH
-0682; HAH WITH 2 DOTS VERTICAL ABOVE; D; HAH
-0683; HAH WITH MIDDLE 2 DOTS; D; HAH
-0684; HAH WITH MIDDLE 2 DOTS VERTICAL; D; HAH
+0677; HIGH HAMZA WAW WITH DAMMA ABOVE; R; WAW
+0678; HIGH HAMZA DOTLESS YEH; D; YEH
+0679; DOTLESS BEH WITH TAH ABOVE; D; BEH
+067A; DOTLESS BEH WITH VERTICAL 2 DOTS ABOVE; D; BEH
+067B; DOTLESS BEH WITH VERTICAL 2 DOTS BELOW; D; BEH
+067C; DOTLESS BEH WITH ATTACHED RING BELOW AND 2 DOTS ABOVE; D; BEH
+067D; DOTLESS BEH WITH INVERTED 3 DOTS ABOVE; D; BEH
+067E; DOTLESS BEH WITH 3 DOTS BELOW; D; BEH
+067F; DOTLESS BEH WITH 4 DOTS ABOVE; D; BEH
+0680; DOTLESS BEH WITH 4 DOTS BELOW; D; BEH
+0681; HAH WITH HAMZA ABOVE; D; HAH
+0682; HAH WITH VERTICAL 2 DOTS ABOVE; D; HAH
+0683; HAH WITH 2 DOTS BELOW; D; HAH
+0684; HAH WITH VERTICAL 2 DOTS BELOW; D; HAH
0685; HAH WITH 3 DOTS ABOVE; D; HAH
-0686; HAH WITH MIDDLE 3 DOTS DOWNWARD; D; HAH
-0687; HAH WITH MIDDLE 4 DOTS; D; HAH
-0688; DAL WITH SMALL TAH; R; DAL
-0689; DAL WITH RING; R; DAL
+0686; HAH WITH 3 DOTS BELOW; D; HAH
+0687; HAH WITH 4 DOTS BELOW; D; HAH
+0688; DAL WITH TAH ABOVE; R; DAL
+0689; DAL WITH ATTACHED RING BELOW; R; DAL
068A; DAL WITH DOT BELOW; R; DAL
-068B; DAL WITH DOT BELOW AND SMALL TAH; R; DAL
+068B; DAL WITH DOT BELOW AND TAH ABOVE; R; DAL
068C; DAL WITH 2 DOTS ABOVE; R; DAL
068D; DAL WITH 2 DOTS BELOW; R; DAL
068E; DAL WITH 3 DOTS ABOVE; R; DAL
-068F; DAL WITH 3 DOTS ABOVE DOWNWARD; R; DAL
+068F; DAL WITH INVERTED 3 DOTS ABOVE; R; DAL
0690; DAL WITH 4 DOTS ABOVE; R; DAL
-0691; REH WITH SMALL TAH; R; REH
-0692; REH WITH SMALL V; R; REH
-0693; REH WITH RING; R; REH
+0691; REH WITH TAH ABOVE; R; REH
+0692; REH WITH V ABOVE; R; REH
+0693; REH WITH ATTACHED RING BELOW; R; REH
0694; REH WITH DOT BELOW; R; REH
-0695; REH WITH SMALL V BELOW; R; REH
-0696; REH WITH DOT BELOW AND DOT ABOVE; R; REH
+0695; REH WITH V BELOW; R; REH
+0696; REH WITH DOT BELOW AND DOT WITHIN; R; REH
0697; REH WITH 2 DOTS ABOVE; R; REH
0698; REH WITH 3 DOTS ABOVE; R; REH
0699; REH WITH 4 DOTS ABOVE; R; REH
@@ -186,66 +190,66 @@
069F; TAH WITH 3 DOTS ABOVE; D; TAH
06A0; AIN WITH 3 DOTS ABOVE; D; AIN
06A1; DOTLESS FEH; D; FEH
-06A2; FEH WITH DOT MOVED BELOW; D; FEH
+06A2; DOTLESS FEH WITH DOT BELOW; D; FEH
06A3; FEH WITH DOT BELOW; D; FEH
-06A4; FEH WITH 3 DOTS ABOVE; D; FEH
-06A5; FEH WITH 3 DOTS BELOW; D; FEH
-06A6; FEH WITH 4 DOTS ABOVE; D; FEH
-06A7; QAF WITH DOT ABOVE; D; QAF
-06A8; QAF WITH 3 DOTS ABOVE; D; QAF
+06A4; DOTLESS FEH WITH 3 DOTS ABOVE; D; FEH
+06A5; DOTLESS FEH WITH 3 DOTS BELOW; D; FEH
+06A6; DOTLESS FEH WITH 4 DOTS ABOVE; D; FEH
+06A7; DOTLESS QAF WITH DOT ABOVE; D; QAF
+06A8; DOTLESS QAF WITH 3 DOTS ABOVE; D; QAF
06A9; KEHEH; D; GAF
06AA; SWASH KAF; D; SWASH KAF
-06AB; KAF WITH RING; D; GAF
+06AB; KEHEH WITH ATTACHED RING BELOW; D; GAF
06AC; KAF WITH DOT ABOVE; D; KAF
06AD; KAF WITH 3 DOTS ABOVE; D; KAF
06AE; KAF WITH 3 DOTS BELOW; D; KAF
06AF; GAF; D; GAF
-06B0; GAF WITH RING; D; GAF
+06B0; GAF WITH ATTACHED RING BELOW; D; GAF
06B1; GAF WITH 2 DOTS ABOVE; D; GAF
06B2; GAF WITH 2 DOTS BELOW; D; GAF
-06B3; GAF WITH 2 DOTS VERTICAL BELOW; D; GAF
+06B3; GAF WITH VERTICAL 2 DOTS BELOW; D; GAF
06B4; GAF WITH 3 DOTS ABOVE; D; GAF
-06B5; LAM WITH SMALL V; D; LAM
+06B5; LAM WITH V ABOVE; D; LAM
06B6; LAM WITH DOT ABOVE; D; LAM
06B7; LAM WITH 3 DOTS ABOVE; D; LAM
06B8; LAM WITH 3 DOTS BELOW; D; LAM
06B9; NOON WITH DOT BELOW; D; NOON
06BA; DOTLESS NOON; D; NOON
-06BB; DOTLESS NOON WITH SMALL TAH; D; NOON
-06BC; NOON WITH RING; D; NOON
+06BB; DOTLESS NOON WITH TAH ABOVE; D; NOON
+06BC; NOON WITH ATTACHED RING BELOW; D; NOON
06BD; NYA; D; NYA
06BE; KNOTTED HEH; D; KNOTTED HEH
-06BF; HAH WITH MIDDLE 3 DOTS DOWNWARD AND DOT ABOVE; D; HAH
-06C0; HAMZA ON HEH; R; TEH MARBUTA
+06BF; HAH WITH 3 DOTS BELOW AND DOT ABOVE; D; HAH
+06C0; DOTLESS TEH MARBUTA WITH HAMZA ABOVE; R; TEH MARBUTA
06C1; HEH GOAL; D; HEH GOAL
-06C2; HAMZA ON HEH GOAL; D; HEH GOAL
+06C2; HEH GOAL WITH HAMZA ABOVE; D; HEH GOAL
06C3; TEH MARBUTA GOAL; R; TEH MARBUTA GOAL
-06C4; WAW WITH RING; R; WAW
+06C4; WAW WITH ATTACHED RING WITHIN; R; WAW
06C5; WAW WITH BAR; R; WAW
-06C6; WAW WITH SMALL V; R; WAW
-06C7; WAW WITH DAMMA; R; WAW
+06C6; WAW WITH V ABOVE; R; WAW
+06C7; WAW WITH DAMMA ABOVE; R; WAW
06C8; WAW WITH ALEF ABOVE; R; WAW
-06C9; WAW WITH INVERTED SMALL V; R; WAW
+06C9; WAW WITH INVERTED V ABOVE; R; WAW
06CA; WAW WITH 2 DOTS ABOVE; R; WAW
06CB; WAW WITH 3 DOTS ABOVE; R; WAW
06CC; FARSI YEH; D; FARSI YEH
06CD; YEH WITH TAIL; R; YEH WITH TAIL
-06CE; FARSI YEH WITH SMALL V; D; FARSI YEH
+06CE; FARSI YEH WITH V ABOVE; D; FARSI YEH
06CF; WAW WITH DOT ABOVE; R; WAW
-06D0; YEH WITH 2 DOTS VERTICAL BELOW; D; YEH
-06D1; YEH WITH 3 DOTS BELOW; D; YEH
+06D0; DOTLESS YEH WITH VERTICAL 2 DOTS BELOW; D; YEH
+06D1; DOTLESS YEH WITH 3 DOTS BELOW; D; YEH
06D2; YEH BARREE; R; YEH BARREE
-06D3; HAMZA ON YEH BARREE; R; YEH BARREE
-06D5; AE; R; TEH MARBUTA
+06D3; YEH BARREE WITH HAMZA ABOVE; R; YEH BARREE
+06D5; DOTLESS TEH MARBUTA; R; TEH MARBUTA
06DD; ARABIC END OF AYAH; U; No_Joining_Group
-06EE; DAL WITH INVERTED V; R; DAL
-06EF; REH WITH INVERTED V; R; REH
+06EE; DAL WITH INVERTED V ABOVE; R; DAL
+06EF; REH WITH INVERTED V ABOVE; R; REH
06FA; SEEN WITH DOT BELOW AND 3 DOTS ABOVE; D; SEEN
-06FB; DAD WITH DOT BELOW; D; SAD
-06FC; GHAIN WITH DOT BELOW; D; AIN
-06FF; HEH WITH INVERTED V; D; KNOTTED HEH
+06FB; SAD WITH DOT BELOW AND DOT ABOVE; D; SAD
+06FC; AIN WITH DOT BELOW AND DOT ABOVE; D; AIN
+06FF; KNOTTED HEH WITH INVERTED V ABOVE; D; KNOTTED HEH
-# Syriac characters
+# Syriac Characters
0710; ALAPH; R; ALAPH
0712; BETH; D; BETH
@@ -282,55 +286,55 @@
074E; SOGDIAN KHAPH; D; KHAPH
074F; SOGDIAN FE; D; FE
-# Arabic supplement characters
+# Arabic Supplement Characters
-0750; BEH WITH 3 DOTS HORIZONTALLY BELOW; D; BEH
-0751; BEH WITH DOT BELOW AND 3 DOTS ABOVE; D; BEH
-0752; BEH WITH 3 DOTS POINTING UPWARDS BELOW; D; BEH
-0753; BEH WITH 3 DOTS POINTING UPWARDS BELOW AND 2 DOTS ABOVE; D; BEH
-0754; BEH WITH 2 DOTS BELOW AND DOT ABOVE; D; BEH
-0755; BEH WITH INVERTED SMALL V BELOW; D; BEH
-0756; BEH WITH SMALL V; D; BEH
+0750; DOTLESS BEH WITH HORIZONTAL 3 DOTS BELOW; D; BEH
+0751; BEH WITH 3 DOTS ABOVE; D; BEH
+0752; DOTLESS BEH WITH INVERTED 3 DOTS BELOW; D; BEH
+0753; DOTLESS BEH WITH INVERTED 3 DOTS BELOW AND 2 DOTS ABOVE; D; BEH
+0754; DOTLESS BEH WITH 2 DOTS BELOW AND DOT ABOVE; D; BEH
+0755; DOTLESS BEH WITH INVERTED V BELOW; D; BEH
+0756; DOTLESS BEH WITH V ABOVE; D; BEH
0757; HAH WITH 2 DOTS ABOVE; D; HAH
-0758; HAH WITH 3 DOTS POINTING UPWARDS BELOW; D; HAH
-0759; DAL WITH 2 DOTS VERTICALLY BELOW AND SMALL TAH; R; DAL
-075A; DAL WITH INVERTED SMALL V BELOW; R; DAL
-075B; REH WITH STROKE; R; REH
+0758; HAH WITH INVERTED 3 DOTS BELOW; D; HAH
+0759; DAL WITH VERTICAL 2 DOTS BELOW AND TAH ABOVE; R; DAL
+075A; DAL WITH INVERTED V BELOW; R; DAL
+075B; REH WITH BAR; R; REH
075C; SEEN WITH 4 DOTS ABOVE; D; SEEN
075D; AIN WITH 2 DOTS ABOVE; D; AIN
-075E; AIN WITH 3 DOTS POINTING DOWNWARDS ABOVE; D; AIN
-075F; AIN WITH 2 DOTS VERTICALLY ABOVE; D; AIN
-0760; FEH WITH 2 DOTS BELOW; D; FEH
-0761; FEH WITH 3 DOTS POINTING UPWARDS BELOW; D; FEH
+075E; AIN WITH INVERTED 3 DOTS ABOVE; D; AIN
+075F; AIN WITH VERTICAL 2 DOTS ABOVE; D; AIN
+0760; DOTLESS FEH WITH 2 DOTS BELOW; D; FEH
+0761; DOTLESS FEH WITH INVERTED 3 DOTS BELOW; D; FEH
0762; KEHEH WITH DOT ABOVE; D; GAF
0763; KEHEH WITH 3 DOTS ABOVE; D; GAF
-0764; KEHEH WITH 3 DOTS POINTING UPWARDS BELOW; D; GAF
+0764; KEHEH WITH INVERTED 3 DOTS BELOW; D; GAF
0765; MEEM WITH DOT ABOVE; D; MEEM
0766; MEEM WITH DOT BELOW; D; MEEM
0767; NOON WITH 2 DOTS BELOW; D; NOON
-0768; NOON WITH SMALL TAH; D; NOON
-0769; NOON WITH SMALL V; D; NOON
+0768; NOON WITH TAH ABOVE; D; NOON
+0769; NOON WITH V ABOVE; D; NOON
076A; LAM WITH BAR; D; LAM
-076B; REH WITH 2 DOTS VERTICALLY ABOVE; R; REH
+076B; REH WITH VERTICAL 2 DOTS ABOVE; R; REH
076C; REH WITH HAMZA ABOVE; R; REH
-076D; SEEN WITH 2 DOTS VERTICALLY ABOVE; D; SEEN
-076E; HAH WITH SMALL TAH BELOW; D; HAH
-076F; HAH WITH SMALL TAH AND 2 DOTS; D; HAH
-0770; SEEN WITH SMALL TAH AND 2 DOTS; D; SEEN
-0771; REH WITH SMALL TAH AND 2 DOTS; R; REH
-0772; HAH WITH SMALL TAH ABOVE; D; HAH
+076D; SEEN WITH VERTICAL 2 DOTS ABOVE; D; SEEN
+076E; HAH WITH TAH BELOW; D; HAH
+076F; HAH WITH TAH AND 2 DOTS BELOW; D; HAH
+0770; SEEN WITH 2 DOTS AND TAH ABOVE; D; SEEN
+0771; REH WITH 2 DOTS AND TAH ABOVE; R; REH
+0772; HAH WITH TAH ABOVE; D; HAH
0773; ALEF WITH DIGIT TWO ABOVE; R; ALEF
0774; ALEF WITH DIGIT THREE ABOVE; R; ALEF
0775; FARSI YEH WITH DIGIT TWO ABOVE; D; FARSI YEH
0776; FARSI YEH WITH DIGIT THREE ABOVE; D; FARSI YEH
-0777; YEH WITH DIGIT FOUR BELOW; D; YEH
+0777; DOTLESS YEH WITH DIGIT FOUR BELOW; D; YEH
0778; WAW WITH DIGIT TWO ABOVE; R; WAW
0779; WAW WITH DIGIT THREE ABOVE; R; WAW
-077A; YEH BARREE WITH DIGIT TWO ABOVE; D; BURUSHASKI YEH BARREE
-077B; YEH BARREE WITH DIGIT THREE ABOVE; D; BURUSHASKI YEH BARREE
+077A; BURUSHASKI YEH BARREE WITH DIGIT TWO ABOVE; D; BURUSHASKI YEH BARREE
+077B; BURUSHASKI YEH BARREE WITH DIGIT THREE ABOVE; D; BURUSHASKI YEH BARREE
077C; HAH WITH DIGIT FOUR BELOW; D; HAH
077D; SEEN WITH DIGIT FOUR ABOVE; D; SEEN
-077E; SEEN WITH INVERTED V; D; SEEN
+077E; SEEN WITH INVERTED V ABOVE; D; SEEN
077F; KAF WITH 2 DOTS ABOVE; D; KAF
# N'Ko Characters
@@ -370,6 +374,49 @@
07EA; NKO JONA RA; D; No_Joining_Group
07FA; NKO LAJANYALAN; C; No_Joining_Group
+# Mandaic Characters
+
+0840; MANDAIC HALQA; R; No_Joining_Group
+0841; MANDAIC AB; D; No_Joining_Group
+0842; MANDAIC AG; D; No_Joining_Group
+0843; MANDAIC AD; D; No_Joining_Group
+0844; MANDAIC AH; D; No_Joining_Group
+0845; MANDAIC USHENNA; D; No_Joining_Group
+0846; MANDAIC AZ; R; No_Joining_Group
+0847; MANDAIC IT; D; No_Joining_Group
+0848; MANDAIC ATT; D; No_Joining_Group
+0849; MANDAIC AKSA; R; No_Joining_Group
+084A; MANDAIC AK; D; No_Joining_Group
+084B; MANDAIC AL; D; No_Joining_Group
+084C; MANDAIC AM; D; No_Joining_Group
+084D; MANDAIC AN; D; No_Joining_Group
+084E; MANDAIC AS; D; No_Joining_Group
+084F; MANDAIC IN; R; No_Joining_Group
+0850; MANDAIC AP; D; No_Joining_Group
+0851; MANDAIC ASZ; D; No_Joining_Group
+0852; MANDAIC AQ; D; No_Joining_Group
+0853; MANDAIC AR; D; No_Joining_Group
+0854; MANDAIC ASH; R; No_Joining_Group
+0855; MANDAIC AT; D; No_Joining_Group
+0856; MANDAIC DUSHENNA; U; No_Joining_Group
+0857; MANDAIC KAD; U; No_Joining_Group
+0858; MANDAIC AIN; U; No_Joining_Group
+
+# Arabic Extended-A Characters
+
+08A0; DOTLESS BEH WITH V BELOW; D; BEH
+08A2; HAH WITH DOT BELOW AND 2 DOTS ABOVE; D; HAH
+08A3; TAH WITH 2 DOTS ABOVE; D; TAH
+08A4; DOTLESS FEH WITH DOT BELOW AND 3 DOTS ABOVE; D; FEH
+08A5; QAF WITH DOT BELOW; D; QAF
+08A6; LAM WITH DOUBLE BAR; D; LAM
+08A7; MEEM WITH 3 DOTS ABOVE; D; MEEM
+08A8; YEH WITH HAMZA ABOVE; D; YEH
+08A9; YEH WITH DOT ABOVE; D; YEH
+08AA; REH WITH LOOP; R; REH
+08AB; WAW WITH DOT WITHIN; R; WAW
+08AC; ROHINGYA YEH; R; ROHINGYA YEH
+
# Other
200C; ZERO WIDTH NON-JOINER; U; No_Joining_Group
Property changes on: trunk/contrib/perl/lib/unicore/ArabicShaping.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/BidiMirroring.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/BidiMirroring.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/BidiMirroring.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,5 +1,5 @@
-# BidiMirroring-6.0.0.txt
-# Date: 2010-06-21, 12:09:00 PDT [KW]
+# BidiMirroring-6.2.0.txt
+# Date: 2012-05-15, 24:19:00 GMT [KW, LI]
#
# Bidi_Mirroring_Glyph Property
#
@@ -6,14 +6,14 @@
# This file is an informative contributory data file in the
# Unicode Character Database.
#
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
#
-# This data file lists characters that have the Bidi_Mirrored=True property
+# This data file lists characters that have the Bidi_Mirrored=Yes property
# value, for which there is another Unicode character that typically has a glyph
# that is the mirror image of the original character's glyph.
#
-# The repertoire covered by the file is Unicode 6.0.0.
+# The repertoire covered by the file is Unicode 6.2.0.
#
# The file contains a list of lines with mappings from one code point
# to another one for character-based mirroring.
@@ -26,12 +26,12 @@
# variable-length hexadecimal value with 4 to 6 digits.
# A comment indicates where the characters are "BEST FIT" mirroring.
#
-# Code points for which Bidi_Mirrored=True, but for which no appropriate
+# Code points for which Bidi_Mirrored=Yes, but for which no appropriate
# characters exist with mirrored glyphs, are
# listed as comments at the end of the file.
#
# Formally, the default value of the Bidi_Mirroring_Glyph property
-# for each code point is the code point itself, unless a mapping to
+# for each code point is <none>, unless a mapping to
# some other character is specified in this data file. When a code
# point has the default value for the Bidi_Mirroring_Glyph property,
# that means that no other character exists whose glyph is suitable
@@ -41,9 +41,14 @@
# at http://www.unicode.org/unicode/reports/tr9/
#
# This file was originally created by Markus Scherer.
-# Extended for Unicode 3.2, 4.0, 4.1, 5.0, 5.1, 5.2, and 6.0 by Ken Whistler.
+# Extended for Unicode 3.2, 4.0, 4.1, 5.0, 5.1, 5.2, and 6.0 by Ken Whistler,
+# and for Unicode 6.1 and 6.2 by Ken Whistler and Laurentiu Iancu.
#
# ############################################################
+#
+# Property: Bidi_Mirroring_Glyph
+#
+# @missing: 0000..10FFFF; <none>
0028; 0029 # LEFT PARENTHESIS
0029; 0028 # RIGHT PARENTHESIS
@@ -209,6 +214,8 @@
27C6; 27C5 # RIGHT S-SHAPED BAG DELIMITER
27C8; 27C9 # REVERSE SOLIDUS PRECEDING SUBSET
27C9; 27C8 # SUPERSET PRECEDING SOLIDUS
+27CB; 27CD # MATHEMATICAL RISING DIAGONAL
+27CD; 27CB # MATHEMATICAL FALLING DIAGONAL
27D5; 27D6 # LEFT OUTER JOIN
27D6; 27D5 # RIGHT OUTER JOIN
27DD; 27DE # LONG RIGHT TACK
Property changes on: trunk/contrib/perl/lib/unicore/BidiMirroring.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/Blocks.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/Blocks.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/Blocks.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,8 +1,8 @@
-# Blocks-6.0.0.txt
-# Date: 2010-06-04, 11:12:00 PDT [KW]
+# Blocks-6.2.0.txt
+# Date: 2012-05-14, 22:42:00 GMT [KW, LI]
#
# Unicode Character Database
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
# For documentation, see http://www.unicode.org/reports/tr44/
#
@@ -46,6 +46,7 @@
07C0..07FF; NKo
0800..083F; Samaritan
0840..085F; Mandaic
+08A0..08FF; Arabic Extended-A
0900..097F; Devanagari
0980..09FF; Bengali
0A00..0A7F; Gurmukhi
@@ -86,6 +87,7 @@
1BC0..1BFF; Batak
1C00..1C4F; Lepcha
1C50..1C7F; Ol Chiki
+1CC0..1CCF; Sundanese Supplement
1CD0..1CFF; Vedic Extensions
1D00..1D7F; Phonetic Extensions
1D80..1DBF; Phonetic Extensions Supplement
@@ -161,6 +163,7 @@
AA00..AA5F; Cham
AA60..AA7F; Myanmar Extended-A
AA80..AADF; Tai Viet
+AAE0..AAFF; Meetei Mayek Extensions
AB00..AB2F; Ethiopic Extended-A
ABC0..ABFF; Meetei Mayek
AC00..D7AF; Hangul Syllables
@@ -199,6 +202,8 @@
10840..1085F; Imperial Aramaic
10900..1091F; Phoenician
10920..1093F; Lydian
+10980..1099F; Meroitic Hieroglyphs
+109A0..109FF; Meroitic Cursive
10A00..10A5F; Kharoshthi
10A60..10A7F; Old South Arabian
10B00..10B3F; Avestan
@@ -208,10 +213,15 @@
10E60..10E7F; Rumi Numeral Symbols
11000..1107F; Brahmi
11080..110CF; Kaithi
+110D0..110FF; Sora Sompeng
+11100..1114F; Chakma
+11180..111DF; Sharada
+11680..116CF; Takri
12000..123FF; Cuneiform
12400..1247F; Cuneiform Numbers and Punctuation
13000..1342F; Egyptian Hieroglyphs
16800..16A3F; Bamum Supplement
+16F00..16F9F; Miao
1B000..1B0FF; Kana Supplement
1D000..1D0FF; Byzantine Musical Symbols
1D100..1D1FF; Musical Symbols
@@ -219,6 +229,7 @@
1D300..1D35F; Tai Xuan Jing Symbols
1D360..1D37F; Counting Rod Numerals
1D400..1D7FF; Mathematical Alphanumeric Symbols
+1EE00..1EEFF; Arabic Mathematical Alphabetic Symbols
1F000..1F02F; Mahjong Tiles
1F030..1F09F; Domino Tiles
1F0A0..1F0FF; Playing Cards
@@ -237,4 +248,4 @@
F0000..FFFFF; Supplementary Private Use Area-A
100000..10FFFF; Supplementary Private Use Area-B
-# EOF
\ No newline at end of file
+# EOF
Property changes on: trunk/contrib/perl/lib/unicore/Blocks.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/CJKRadicals.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/CJKRadicals.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/CJKRadicals.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,8 +1,8 @@
-# CJKRadicals-6.0.0.txt
-# Date: 2010-01-22, 10:53:25 PDT [RC]
+# CJKRadicals-6.2.0.txt
+# Date: 2012-05-15, 21:08:00 GMT [RC, KW]
#
# Unicode Character Database
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
# For documentation, see http://www.unicode.org/reports/tr38/
#
@@ -24,6 +24,7 @@
#
# This file was created for Unicode 5.2 by Richard Cook.
# Updated for Unicode 6.0 by Richard Cook.
+# Updated for Unicode 6.1 and 6.2 by Ken Whistler.
#
# ####################################################
Property changes on: trunk/contrib/perl/lib/unicore/CJKRadicals.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/CaseFolding.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/CaseFolding.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/CaseFolding.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,8 +1,8 @@
-# CaseFolding-6.0.0.txt
-# Date: 2010-05-18, 00:48:57 GMT [MD]
+# CaseFolding-6.2.0.txt
+# Date: 2012-08-14, 17:54:49 GMT [MD]
#
# Unicode Character Database
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
# For documentation, see http://www.unicode.org/reports/tr44/
#
@@ -52,7 +52,15 @@
# behavior. (The default option is to exclude them.)
#
# =================================================================
-# @missing 0000..10FFFF; <codepoint>
+
+# Property: Case_Folding
+
+# All code points not explicitly listed for Case_Folding
+# have the value C for the status field, and the code point itself for the mapping field.
+
+# @missing: 0000..10FFFF; C; <code point>
+
+# =================================================================
0041; C; 0061; # LATIN CAPITAL LETTER A
0042; C; 0062; # LATIN CAPITAL LETTER B
0043; C; 0063; # LATIN CAPITAL LETTER C
@@ -574,6 +582,8 @@
10C3; C; 2D23; # GEORGIAN CAPITAL LETTER WE
10C4; C; 2D24; # GEORGIAN CAPITAL LETTER HAR
10C5; C; 2D25; # GEORGIAN CAPITAL LETTER HOE
+10C7; C; 2D27; # GEORGIAN CAPITAL LETTER YN
+10CD; C; 2D2D; # GEORGIAN CAPITAL LETTER AEN
1E00; C; 1E01; # LATIN CAPITAL LETTER A WITH RING BELOW
1E02; C; 1E03; # LATIN CAPITAL LETTER B WITH DOT ABOVE
1E04; C; 1E05; # LATIN CAPITAL LETTER B WITH DOT BELOW
@@ -1042,6 +1052,7 @@
2CE2; C; 2CE3; # COPTIC CAPITAL LETTER OLD NUBIAN WAU
2CEB; C; 2CEC; # COPTIC CAPITAL LETTER CRYPTOGRAMMIC SHEI
2CED; C; 2CEE; # COPTIC CAPITAL LETTER CRYPTOGRAMMIC GANGIA
+2CF2; C; 2CF3; # COPTIC CAPITAL LETTER BOHAIRIC KHEI
A640; C; A641; # CYRILLIC CAPITAL LETTER ZEMLYA
A642; C; A643; # CYRILLIC CAPITAL LETTER DZELO
A644; C; A645; # CYRILLIC CAPITAL LETTER REVERSED DZE
@@ -1126,11 +1137,13 @@
A78B; C; A78C; # LATIN CAPITAL LETTER SALTILLO
A78D; C; 0265; # LATIN CAPITAL LETTER TURNED H
A790; C; A791; # LATIN CAPITAL LETTER N WITH DESCENDER
+A792; C; A793; # LATIN CAPITAL LETTER C WITH BAR
A7A0; C; A7A1; # LATIN CAPITAL LETTER G WITH OBLIQUE STROKE
A7A2; C; A7A3; # LATIN CAPITAL LETTER K WITH OBLIQUE STROKE
A7A4; C; A7A5; # LATIN CAPITAL LETTER N WITH OBLIQUE STROKE
A7A6; C; A7A7; # LATIN CAPITAL LETTER R WITH OBLIQUE STROKE
A7A8; C; A7A9; # LATIN CAPITAL LETTER S WITH OBLIQUE STROKE
+A7AA; C; 0266; # LATIN CAPITAL LETTER H WITH HOOK
FB00; F; 0066 0066; # LATIN SMALL LIGATURE FF
FB01; F; 0066 0069; # LATIN SMALL LIGATURE FI
FB02; F; 0066 006C; # LATIN SMALL LIGATURE FL
@@ -1209,3 +1222,5 @@
10425; C; 1044D; # DESERET CAPITAL LETTER ENG
10426; C; 1044E; # DESERET CAPITAL LETTER OI
10427; C; 1044F; # DESERET CAPITAL LETTER EW
+#
+# EOF
Property changes on: trunk/contrib/perl/lib/unicore/CaseFolding.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/CompositionExclusions.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/CompositionExclusions.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/CompositionExclusions.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,5 +1,5 @@
-# CompositionExclusions-6.0.0.txt
-# Date: 2010-06-25, 14:34:00 PDT [KW]
+# CompositionExclusions-6.2.0.txt
+# Date: 2012-05-15, 22:21:00 GMT [KW, LI]
#
# This file lists the characters for the Composition Exclusion Table
# defined in UAX #15, Unicode Normalization Forms.
@@ -7,7 +7,7 @@
# This file is a normative contributory data file in the
# Unicode Character Database.
#
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
#
# For more information, see
@@ -169,17 +169,16 @@
# FA20 CJK COMPATIBILITY IDEOGRAPH-FA20
# FA22 CJK COMPATIBILITY IDEOGRAPH-FA22
# FA25..FA26 [2] CJK COMPATIBILITY IDEOGRAPH-FA25..CJK COMPATIBILITY IDEOGRAPH-FA26
-# FA2A..FA2D [4] CJK COMPATIBILITY IDEOGRAPH-FA2A..CJK COMPATIBILITY IDEOGRAPH-FA2D
-# FA30..FA6D [62] CJK COMPATIBILITY IDEOGRAPH-FA30..CJK COMPATIBILITY IDEOGRAPH-FA6D
+# FA2A..FA6D [68] CJK COMPATIBILITY IDEOGRAPH-FA2A..CJK COMPATIBILITY IDEOGRAPH-FA6D
# FA70..FAD9 [106] CJK COMPATIBILITY IDEOGRAPH-FA70..CJK COMPATIBILITY IDEOGRAPH-FAD9
# 2F800..2FA1D [542] CJK COMPATIBILITY IDEOGRAPH-2F800..CJK COMPATIBILITY IDEOGRAPH-2FA1D
-# Total code points: 1033
+# Total code points: 1035
# ================================================
# (4) Non-Starter Decompositions
#
-# These characters can be derived from the UnicodeData file
+# These characters can be derived from the UnicodeData.txt file
# by including each expanding canonical decomposition
# (i.e., those which canonically decompose to a sequence
# of characters instead of a single character), such that:
@@ -204,3 +203,4 @@
# Total code points: 4
+# EOF
Property changes on: trunk/contrib/perl/lib/unicore/CompositionExclusions.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/DAge.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/DAge.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/DAge.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,8 +1,8 @@
-# DerivedAge-6.0.0.txt
-# Date: 2010-10-05, 00:47:58 GMT [MD, KW]
+# DerivedAge-6.2.0.txt
+# Date: 2012-09-20, 21:30:39 GMT [MD]
#
# Unicode Character Database
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
# For documentation, see http://www.unicode.org/reports/tr44/
#
@@ -42,12 +42,14 @@
# For more information, see [http://www.unicode.org/reports/tr18/].
# All code points not explicitly listed for Age
-# have the value unassigned.
+# have the value Unassigned (NA).
-# @missing: 0000..10FFFF; unassigned
+# @missing: 0000..10FFFF; Unassigned
# ================================================
+# Age=V1_1
+
# Assigned as of Unicode 1.1.0 (June, 1993)
# [excluding removed Hangul Syllables]
@@ -357,6 +359,8 @@
# ================================================
+# Age=V2_0
+
# Newly assigned in Unicode 2.0.0 (July, 1996)
0591..05A1 ; 2.0 # [17] HEBREW ACCENT ETNAHTA..HEBREW ACCENT PAZER
@@ -397,6 +401,8 @@
# ================================================
+# Age=V2_1
+
# Newly assigned in Unicode 2.1.2 (May, 1998)
20AC ; 2.1 # EURO SIGN
@@ -406,6 +412,8 @@
# ================================================
+# Age=V3_0
+
# Newly assigned in Unicode 3.0.0 (September, 1999)
01F6..01F9 ; 3.0 # [4] LATIN CAPITAL LETTER HWAIR..LATIN SMALL LETTER N WITH GRAVE
@@ -493,9 +501,7 @@
1401..1676 ; 3.0 # [630] CANADIAN SYLLABICS E..CANADIAN SYLLABICS NNGAA
1680..169C ; 3.0 # [29] OGHAM SPACE MARK..OGHAM REVERSED FEATHER MARK
16A0..16F0 ; 3.0 # [81] RUNIC LETTER FEHU FEOH FE F..RUNIC BELGTHOR SYMBOL
-1780..17B3 ; 3.0 # [52] KHMER LETTER KA..KHMER INDEPENDENT VOWEL QAU
-17B4..17B5 ; 3.0 # [2] KHMER VOWEL INHERENT AQ..KHMER VOWEL INHERENT AA
-17B6..17DC ; 3.0 # [39] KHMER VOWEL SIGN AA..KHMER SIGN AVAKRAHASANYA
+1780..17DC ; 3.0 # [93] KHMER LETTER KA..KHMER SIGN AVAKRAHASANYA
17E0..17E9 ; 3.0 # [10] KHMER DIGIT ZERO..KHMER DIGIT NINE
1800..180E ; 3.0 # [15] MONGOLIAN BIRGA..MONGOLIAN VOWEL SEPARATOR
1810..1819 ; 3.0 # [10] MONGOLIAN DIGIT ZERO..MONGOLIAN DIGIT NINE
@@ -537,6 +543,8 @@
# ================================================
+# Age=V3_1
+
# Newly assigned in Unicode 3.1.0 (March, 2001)
03F4..03F5 ; 3.1 # [2] GREEK CAPITAL THETA SYMBOL..GREEK LUNATE EPSILON SYMBOL
@@ -582,6 +590,8 @@
# ================================================
+# Age=V3_2
+
# Newly assigned in Unicode 3.2.0 (March, 2002)
0220 ; 3.2 # LATIN CAPITAL LETTER N WITH LONG RIGHT LEG
@@ -649,6 +659,8 @@
# ================================================
+# Age=V4_0
+
# Newly assigned in Unicode 4.0.0 (April, 2003)
0221 ; 4.0 # LATIN SMALL LETTER D WITH CURL
@@ -733,6 +745,8 @@
# ================================================
+# Age=V4_1
+
# Newly assigned in Unicode 4.1.0 (March, 2005)
0237..0241 ; 4.1 # [11] LATIN SMALL LETTER DOTLESS J..LATIN CAPITAL LETTER GLOTTAL STOP
@@ -826,6 +840,8 @@
# ================================================
+# Age=V5_0
+
# Newly assigned in Unicode 5.0.0 (July, 2006)
0242..024F ; 5.0 # [14] LATIN SMALL LETTER GLOTTAL STOP..LATIN SMALL LETTER Y WITH STROKE
@@ -868,6 +884,8 @@
# ================================================
+# Age=V5_1
+
# Newly assigned in Unicode 5.1.0 (March, 2008)
0370..0373 ; 5.1 # [4] GREEK CAPITAL LETTER HETA..GREEK SMALL LETTER ARCHAIC SAMPI
@@ -964,6 +982,8 @@
# ================================================
+# Age=V5_2
+
# Newly assigned in Unicode 5.2.0 (October, 2009)
0524..0525 ; 5.2 # [2] CYRILLIC CAPITAL LETTER PE WITH DESCENDER..CYRILLIC SMALL LETTER PE WITH DESCENDER
@@ -1063,6 +1083,8 @@
# ================================================
+# Age=V6_0
+
# Newly assigned in Unicode 6.0.0 (October, 2010)
0526..0527 ; 6.0 # [2] CYRILLIC CAPITAL LETTER SHHA WITH DESCENDER..CYRILLIC SMALL LETTER SHHA WITH DESCENDER
@@ -1174,4 +1196,112 @@
# Total code points: 2088
+# ================================================
+
+# Age=V6_1
+
+# Newly assigned in Unicode 6.1.0 (January, 2012)
+
+058F ; 6.1 # ARMENIAN DRAM SIGN
+0604 ; 6.1 # ARABIC SIGN SAMVAT
+08A0 ; 6.1 # ARABIC LETTER BEH WITH SMALL V BELOW
+08A2..08AC ; 6.1 # [11] ARABIC LETTER JEEM WITH TWO DOTS ABOVE..ARABIC LETTER ROHINGYA YEH
+08E4..08FE ; 6.1 # [27] ARABIC CURLY FATHA..ARABIC DAMMA WITH DOT
+0AF0 ; 6.1 # GUJARATI ABBREVIATION SIGN
+0EDE..0EDF ; 6.1 # [2] LAO LETTER KHMU GO..LAO LETTER KHMU NYO
+10C7 ; 6.1 # GEORGIAN CAPITAL LETTER YN
+10CD ; 6.1 # GEORGIAN CAPITAL LETTER AEN
+10FD..10FF ; 6.1 # [3] GEORGIAN LETTER AEN..GEORGIAN LETTER LABIAL SIGN
+1BAB..1BAD ; 6.1 # [3] SUNDANESE SIGN VIRAMA..SUNDANESE CONSONANT SIGN PASANGAN WA
+1BBA..1BBF ; 6.1 # [6] SUNDANESE AVAGRAHA..SUNDANESE LETTER FINAL M
+1CC0..1CC7 ; 6.1 # [8] SUNDANESE PUNCTUATION BINDU SURYA..SUNDANESE PUNCTUATION BINDU BA SATANGA
+1CF3..1CF6 ; 6.1 # [4] VEDIC SIGN ROTATED ARDHAVISARGA..VEDIC SIGN UPADHMANIYA
+27CB ; 6.1 # MATHEMATICAL RISING DIAGONAL
+27CD ; 6.1 # MATHEMATICAL FALLING DIAGONAL
+2CF2..2CF3 ; 6.1 # [2] COPTIC CAPITAL LETTER BOHAIRIC KHEI..COPTIC SMALL LETTER BOHAIRIC KHEI
+2D27 ; 6.1 # GEORGIAN SMALL LETTER YN
+2D2D ; 6.1 # GEORGIAN SMALL LETTER AEN
+2D66..2D67 ; 6.1 # [2] TIFINAGH LETTER YE..TIFINAGH LETTER YO
+2E32..2E3B ; 6.1 # [10] TURNED COMMA..THREE-EM DASH
+9FCC ; 6.1 # CJK UNIFIED IDEOGRAPH-9FCC
+A674..A67B ; 6.1 # [8] COMBINING CYRILLIC LETTER UKRAINIAN IE..COMBINING CYRILLIC LETTER OMEGA
+A69F ; 6.1 # COMBINING CYRILLIC LETTER IOTIFIED E
+A792..A793 ; 6.1 # [2] LATIN CAPITAL LETTER C WITH BAR..LATIN SMALL LETTER C WITH BAR
+A7AA ; 6.1 # LATIN CAPITAL LETTER H WITH HOOK
+A7F8..A7F9 ; 6.1 # [2] MODIFIER LETTER CAPITAL H WITH STROKE..MODIFIER LETTER SMALL LIGATURE OE
+AAE0..AAF6 ; 6.1 # [23] MEETEI MAYEK LETTER E..MEETEI MAYEK VIRAMA
+FA2E..FA2F ; 6.1 # [2] CJK COMPATIBILITY IDEOGRAPH-FA2E..CJK COMPATIBILITY IDEOGRAPH-FA2F
+10980..109B7 ; 6.1 # [56] MEROITIC HIEROGLYPHIC LETTER A..MEROITIC CURSIVE LETTER DA
+109BE..109BF ; 6.1 # [2] MEROITIC CURSIVE LOGOGRAM RMT..MEROITIC CURSIVE LOGOGRAM IMN
+110D0..110E8 ; 6.1 # [25] SORA SOMPENG LETTER SAH..SORA SOMPENG LETTER MAE
+110F0..110F9 ; 6.1 # [10] SORA SOMPENG DIGIT ZERO..SORA SOMPENG DIGIT NINE
+11100..11134 ; 6.1 # [53] CHAKMA SIGN CANDRABINDU..CHAKMA MAAYYAA
+11136..11143 ; 6.1 # [14] CHAKMA DIGIT ZERO..CHAKMA QUESTION MARK
+11180..111C8 ; 6.1 # [73] SHARADA SIGN CANDRABINDU..SHARADA SEPARATOR
+111D0..111D9 ; 6.1 # [10] SHARADA DIGIT ZERO..SHARADA DIGIT NINE
+11680..116B7 ; 6.1 # [56] TAKRI LETTER A..TAKRI SIGN NUKTA
+116C0..116C9 ; 6.1 # [10] TAKRI DIGIT ZERO..TAKRI DIGIT NINE
+16F00..16F44 ; 6.1 # [69] MIAO LETTER PA..MIAO LETTER HHA
+16F50..16F7E ; 6.1 # [47] MIAO LETTER NASALIZATION..MIAO VOWEL SIGN NG
+16F8F..16F9F ; 6.1 # [17] MIAO TONE RIGHT..MIAO LETTER REFORMED TONE-8
+1EE00..1EE03 ; 6.1 # [4] ARABIC MATHEMATICAL ALEF..ARABIC MATHEMATICAL DAL
+1EE05..1EE1F ; 6.1 # [27] ARABIC MATHEMATICAL WAW..ARABIC MATHEMATICAL DOTLESS QAF
+1EE21..1EE22 ; 6.1 # [2] ARABIC MATHEMATICAL INITIAL BEH..ARABIC MATHEMATICAL INITIAL JEEM
+1EE24 ; 6.1 # ARABIC MATHEMATICAL INITIAL HEH
+1EE27 ; 6.1 # ARABIC MATHEMATICAL INITIAL HAH
+1EE29..1EE32 ; 6.1 # [10] ARABIC MATHEMATICAL INITIAL YEH..ARABIC MATHEMATICAL INITIAL QAF
+1EE34..1EE37 ; 6.1 # [4] ARABIC MATHEMATICAL INITIAL SHEEN..ARABIC MATHEMATICAL INITIAL KHAH
+1EE39 ; 6.1 # ARABIC MATHEMATICAL INITIAL DAD
+1EE3B ; 6.1 # ARABIC MATHEMATICAL INITIAL GHAIN
+1EE42 ; 6.1 # ARABIC MATHEMATICAL TAILED JEEM
+1EE47 ; 6.1 # ARABIC MATHEMATICAL TAILED HAH
+1EE49 ; 6.1 # ARABIC MATHEMATICAL TAILED YEH
+1EE4B ; 6.1 # ARABIC MATHEMATICAL TAILED LAM
+1EE4D..1EE4F ; 6.1 # [3] ARABIC MATHEMATICAL TAILED NOON..ARABIC MATHEMATICAL TAILED AIN
+1EE51..1EE52 ; 6.1 # [2] ARABIC MATHEMATICAL TAILED SAD..ARABIC MATHEMATICAL TAILED QAF
+1EE54 ; 6.1 # ARABIC MATHEMATICAL TAILED SHEEN
+1EE57 ; 6.1 # ARABIC MATHEMATICAL TAILED KHAH
+1EE59 ; 6.1 # ARABIC MATHEMATICAL TAILED DAD
+1EE5B ; 6.1 # ARABIC MATHEMATICAL TAILED GHAIN
+1EE5D ; 6.1 # ARABIC MATHEMATICAL TAILED DOTLESS NOON
+1EE5F ; 6.1 # ARABIC MATHEMATICAL TAILED DOTLESS QAF
+1EE61..1EE62 ; 6.1 # [2] ARABIC MATHEMATICAL STRETCHED BEH..ARABIC MATHEMATICAL STRETCHED JEEM
+1EE64 ; 6.1 # ARABIC MATHEMATICAL STRETCHED HEH
+1EE67..1EE6A ; 6.1 # [4] ARABIC MATHEMATICAL STRETCHED HAH..ARABIC MATHEMATICAL STRETCHED KAF
+1EE6C..1EE72 ; 6.1 # [7] ARABIC MATHEMATICAL STRETCHED MEEM..ARABIC MATHEMATICAL STRETCHED QAF
+1EE74..1EE77 ; 6.1 # [4] ARABIC MATHEMATICAL STRETCHED SHEEN..ARABIC MATHEMATICAL STRETCHED KHAH
+1EE79..1EE7C ; 6.1 # [4] ARABIC MATHEMATICAL STRETCHED DAD..ARABIC MATHEMATICAL STRETCHED DOTLESS BEH
+1EE7E ; 6.1 # ARABIC MATHEMATICAL STRETCHED DOTLESS FEH
+1EE80..1EE89 ; 6.1 # [10] ARABIC MATHEMATICAL LOOPED ALEF..ARABIC MATHEMATICAL LOOPED YEH
+1EE8B..1EE9B ; 6.1 # [17] ARABIC MATHEMATICAL LOOPED LAM..ARABIC MATHEMATICAL LOOPED GHAIN
+1EEA1..1EEA3 ; 6.1 # [3] ARABIC MATHEMATICAL DOUBLE-STRUCK BEH..ARABIC MATHEMATICAL DOUBLE-STRUCK DAL
+1EEA5..1EEA9 ; 6.1 # [5] ARABIC MATHEMATICAL DOUBLE-STRUCK WAW..ARABIC MATHEMATICAL DOUBLE-STRUCK YEH
+1EEAB..1EEBB ; 6.1 # [17] ARABIC MATHEMATICAL DOUBLE-STRUCK LAM..ARABIC MATHEMATICAL DOUBLE-STRUCK GHAIN
+1EEF0..1EEF1 ; 6.1 # [2] ARABIC MATHEMATICAL OPERATOR MEEM WITH HAH WITH TATWEEL..ARABIC MATHEMATICAL OPERATOR HAH WITH DAL
+1F16A..1F16B ; 6.1 # [2] RAISED MC SIGN..RAISED MD SIGN
+1F540..1F543 ; 6.1 # [4] CIRCLED CROSS POMMEE..NOTCHED LEFT SEMICIRCLE WITH THREE DOTS
+1F600 ; 6.1 # GRINNING FACE
+1F611 ; 6.1 # EXPRESSIONLESS FACE
+1F615 ; 6.1 # CONFUSED FACE
+1F617 ; 6.1 # KISSING FACE
+1F619 ; 6.1 # KISSING FACE WITH SMILING EYES
+1F61B ; 6.1 # FACE WITH STUCK-OUT TONGUE
+1F61F ; 6.1 # WORRIED FACE
+1F626..1F627 ; 6.1 # [2] FROWNING FACE WITH OPEN MOUTH..ANGUISHED FACE
+1F62C ; 6.1 # GRIMACING FACE
+1F62E..1F62F ; 6.1 # [2] FACE WITH OPEN MOUTH..HUSHED FACE
+1F634 ; 6.1 # SLEEPING FACE
+
+# Total code points: 732
+
+# ================================================
+
+# Age=V6_2
+
+# Newly assigned in Unicode 6.2.0 (September, 2012)
+
+20BA ; 6.2 # TURKISH LIRA SIGN
+
+# Total code points: 1
+
# EOF
Property changes on: trunk/contrib/perl/lib/unicore/DAge.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/DCoreProperties.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/DCoreProperties.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/DCoreProperties.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,8 +1,8 @@
-# DerivedCoreProperties-6.0.0.txt
-# Date: 2010-08-19, 00:48:05 GMT [MD]
+# DerivedCoreProperties-6.2.0.txt
+# Date: 2012-05-20, 00:42:31 GMT [MD]
#
# Unicode Character Database
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
# For documentation, see http://www.unicode.org/reports/tr44/
@@ -113,9 +113,7 @@
27C0..27C4 ; Math # Sm [5] THREE DIMENSIONAL ANGLE..OPEN SUPERSET
27C5 ; Math # Ps LEFT S-SHAPED BAG DELIMITER
27C6 ; Math # Pe RIGHT S-SHAPED BAG DELIMITER
-27C7..27CA ; Math # Sm [4] OR WITH DOT INSIDE..VERTICAL BAR WITH HORIZONTAL STROKE
-27CC ; Math # Sm LONG DIVISION
-27CE..27E5 ; Math # Sm [24] SQUARED LOGICAL AND..WHITE SQUARE WITH RIGHTWARDS TICK
+27C7..27E5 ; Math # Sm [31] OR WITH DOT INSIDE..WHITE SQUARE WITH RIGHTWARDS TICK
27E6 ; Math # Ps MATHEMATICAL LEFT WHITE SQUARE BRACKET
27E7 ; Math # Pe MATHEMATICAL RIGHT WHITE SQUARE BRACKET
27E8 ; Math # Ps MATHEMATICAL LEFT ANGLE BRACKET
@@ -216,8 +214,42 @@
1D7C3 ; Math # Sm MATHEMATICAL SANS-SERIF BOLD ITALIC PARTIAL DIFFERENTIAL
1D7C4..1D7CB ; Math # L& [8] MATHEMATICAL SANS-SERIF BOLD ITALIC EPSILON SYMBOL..MATHEMATICAL BOLD SMALL DIGAMMA
1D7CE..1D7FF ; Math # Nd [50] MATHEMATICAL BOLD DIGIT ZERO..MATHEMATICAL MONOSPACE DIGIT NINE
+1EE00..1EE03 ; Math # Lo [4] ARABIC MATHEMATICAL ALEF..ARABIC MATHEMATICAL DAL
+1EE05..1EE1F ; Math # Lo [27] ARABIC MATHEMATICAL WAW..ARABIC MATHEMATICAL DOTLESS QAF
+1EE21..1EE22 ; Math # Lo [2] ARABIC MATHEMATICAL INITIAL BEH..ARABIC MATHEMATICAL INITIAL JEEM
+1EE24 ; Math # Lo ARABIC MATHEMATICAL INITIAL HEH
+1EE27 ; Math # Lo ARABIC MATHEMATICAL INITIAL HAH
+1EE29..1EE32 ; Math # Lo [10] ARABIC MATHEMATICAL INITIAL YEH..ARABIC MATHEMATICAL INITIAL QAF
+1EE34..1EE37 ; Math # Lo [4] ARABIC MATHEMATICAL INITIAL SHEEN..ARABIC MATHEMATICAL INITIAL KHAH
+1EE39 ; Math # Lo ARABIC MATHEMATICAL INITIAL DAD
+1EE3B ; Math # Lo ARABIC MATHEMATICAL INITIAL GHAIN
+1EE42 ; Math # Lo ARABIC MATHEMATICAL TAILED JEEM
+1EE47 ; Math # Lo ARABIC MATHEMATICAL TAILED HAH
+1EE49 ; Math # Lo ARABIC MATHEMATICAL TAILED YEH
+1EE4B ; Math # Lo ARABIC MATHEMATICAL TAILED LAM
+1EE4D..1EE4F ; Math # Lo [3] ARABIC MATHEMATICAL TAILED NOON..ARABIC MATHEMATICAL TAILED AIN
+1EE51..1EE52 ; Math # Lo [2] ARABIC MATHEMATICAL TAILED SAD..ARABIC MATHEMATICAL TAILED QAF
+1EE54 ; Math # Lo ARABIC MATHEMATICAL TAILED SHEEN
+1EE57 ; Math # Lo ARABIC MATHEMATICAL TAILED KHAH
+1EE59 ; Math # Lo ARABIC MATHEMATICAL TAILED DAD
+1EE5B ; Math # Lo ARABIC MATHEMATICAL TAILED GHAIN
+1EE5D ; Math # Lo ARABIC MATHEMATICAL TAILED DOTLESS NOON
+1EE5F ; Math # Lo ARABIC MATHEMATICAL TAILED DOTLESS QAF
+1EE61..1EE62 ; Math # Lo [2] ARABIC MATHEMATICAL STRETCHED BEH..ARABIC MATHEMATICAL STRETCHED JEEM
+1EE64 ; Math # Lo ARABIC MATHEMATICAL STRETCHED HEH
+1EE67..1EE6A ; Math # Lo [4] ARABIC MATHEMATICAL STRETCHED HAH..ARABIC MATHEMATICAL STRETCHED KAF
+1EE6C..1EE72 ; Math # Lo [7] ARABIC MATHEMATICAL STRETCHED MEEM..ARABIC MATHEMATICAL STRETCHED QAF
+1EE74..1EE77 ; Math # Lo [4] ARABIC MATHEMATICAL STRETCHED SHEEN..ARABIC MATHEMATICAL STRETCHED KHAH
+1EE79..1EE7C ; Math # Lo [4] ARABIC MATHEMATICAL STRETCHED DAD..ARABIC MATHEMATICAL STRETCHED DOTLESS BEH
+1EE7E ; Math # Lo ARABIC MATHEMATICAL STRETCHED DOTLESS FEH
+1EE80..1EE89 ; Math # Lo [10] ARABIC MATHEMATICAL LOOPED ALEF..ARABIC MATHEMATICAL LOOPED YEH
+1EE8B..1EE9B ; Math # Lo [17] ARABIC MATHEMATICAL LOOPED LAM..ARABIC MATHEMATICAL LOOPED GHAIN
+1EEA1..1EEA3 ; Math # Lo [3] ARABIC MATHEMATICAL DOUBLE-STRUCK BEH..ARABIC MATHEMATICAL DOUBLE-STRUCK DAL
+1EEA5..1EEA9 ; Math # Lo [5] ARABIC MATHEMATICAL DOUBLE-STRUCK WAW..ARABIC MATHEMATICAL DOUBLE-STRUCK YEH
+1EEAB..1EEBB ; Math # Lo [17] ARABIC MATHEMATICAL DOUBLE-STRUCK LAM..ARABIC MATHEMATICAL DOUBLE-STRUCK GHAIN
+1EEF0..1EEF1 ; Math # Sm [2] ARABIC MATHEMATICAL OPERATOR MEEM WITH HAH WITH TATWEEL..ARABIC MATHEMATICAL OPERATOR HAH WITH DAL
-# Total code points: 2165
+# Total code points: 2310
# ================================================
@@ -226,9 +258,9 @@
0041..005A ; Alphabetic # L& [26] LATIN CAPITAL LETTER A..LATIN CAPITAL LETTER Z
0061..007A ; Alphabetic # L& [26] LATIN SMALL LETTER A..LATIN SMALL LETTER Z
-00AA ; Alphabetic # L& FEMININE ORDINAL INDICATOR
+00AA ; Alphabetic # Lo FEMININE ORDINAL INDICATOR
00B5 ; Alphabetic # L& MICRO SIGN
-00BA ; Alphabetic # L& MASCULINE ORDINAL INDICATOR
+00BA ; Alphabetic # Lo MASCULINE ORDINAL INDICATOR
00C0..00D6 ; Alphabetic # L& [23] LATIN CAPITAL LETTER A WITH GRAVE..LATIN CAPITAL LETTER O WITH DIAERESIS
00D8..00F6 ; Alphabetic # L& [31] LATIN CAPITAL LETTER O WITH STROKE..LATIN SMALL LETTER O WITH DIAERESIS
00F8..01BA ; Alphabetic # L& [195] LATIN SMALL LETTER O WITH STROKE..LATIN SMALL LETTER EZH WITH TAIL
@@ -303,6 +335,10 @@
0828 ; Alphabetic # Lm SAMARITAN MODIFIER LETTER I
0829..082C ; Alphabetic # Mn [4] SAMARITAN VOWEL SIGN LONG I..SAMARITAN VOWEL SIGN SUKUN
0840..0858 ; Alphabetic # Lo [25] MANDAIC LETTER HALQA..MANDAIC LETTER AIN
+08A0 ; Alphabetic # Lo ARABIC LETTER BEH WITH SMALL V BELOW
+08A2..08AC ; Alphabetic # Lo [11] ARABIC LETTER JEEM WITH TWO DOTS ABOVE..ARABIC LETTER ROHINGYA YEH
+08E4..08E9 ; Alphabetic # Mn [6] ARABIC CURLY FATHA..ARABIC CURLY KASRATAN
+08F0..08FE ; Alphabetic # Mn [15] ARABIC OPEN FATHATAN..ARABIC DAMMA WITH DOT
0900..0902 ; Alphabetic # Mn [3] DEVANAGARI SIGN INVERTED CANDRABINDU..DEVANAGARI SIGN ANUSVARA
0903 ; Alphabetic # Mc DEVANAGARI SIGN VISARGA
0904..0939 ; Alphabetic # Lo [54] DEVANAGARI LETTER SHORT A..DEVANAGARI LETTER HA
@@ -500,7 +536,7 @@
0EC0..0EC4 ; Alphabetic # Lo [5] LAO VOWEL SIGN E..LAO VOWEL SIGN AI
0EC6 ; Alphabetic # Lm LAO KO LA
0ECD ; Alphabetic # Mn LAO NIGGAHITA
-0EDC..0EDD ; Alphabetic # Lo [2] LAO HO NO..LAO HO MO
+0EDC..0EDF ; Alphabetic # Lo [4] LAO HO NO..LAO LETTER KHMU NYO
0F00 ; Alphabetic # Lo TIBETAN SYLLABLE OM
0F40..0F47 ; Alphabetic # Lo [8] TIBETAN LETTER KA..TIBETAN LETTER JA
0F49..0F6C ; Alphabetic # Lo [36] TIBETAN LETTER NYA..TIBETAN LETTER RRA
@@ -538,9 +574,11 @@
109C ; Alphabetic # Mc MYANMAR VOWEL SIGN AITON A
109D ; Alphabetic # Mn MYANMAR VOWEL SIGN AITON AI
10A0..10C5 ; Alphabetic # L& [38] GEORGIAN CAPITAL LETTER AN..GEORGIAN CAPITAL LETTER HOE
+10C7 ; Alphabetic # L& GEORGIAN CAPITAL LETTER YN
+10CD ; Alphabetic # L& GEORGIAN CAPITAL LETTER AEN
10D0..10FA ; Alphabetic # Lo [43] GEORGIAN LETTER AN..GEORGIAN LETTER AIN
10FC ; Alphabetic # Lm MODIFIER LETTER GEORGIAN NAR
-1100..1248 ; Alphabetic # Lo [329] HANGUL CHOSEONG KIYEOK..ETHIOPIC SYLLABLE QWA
+10FD..1248 ; Alphabetic # Lo [332] GEORGIAN LETTER AEN..ETHIOPIC SYLLABLE QWA
124A..124D ; Alphabetic # Lo [4] ETHIOPIC SYLLABLE QWI..ETHIOPIC SYLLABLE QWE
1250..1256 ; Alphabetic # Lo [7] ETHIOPIC SYLLABLE QHA..ETHIOPIC SYLLABLE QHO
1258 ; Alphabetic # Lo ETHIOPIC SYLLABLE QHWA
@@ -636,8 +674,9 @@
1BA2..1BA5 ; Alphabetic # Mn [4] SUNDANESE CONSONANT SIGN PANYAKRA..SUNDANESE VOWEL SIGN PANYUKU
1BA6..1BA7 ; Alphabetic # Mc [2] SUNDANESE VOWEL SIGN PANAELAENG..SUNDANESE VOWEL SIGN PANOLONG
1BA8..1BA9 ; Alphabetic # Mn [2] SUNDANESE VOWEL SIGN PAMEPET..SUNDANESE VOWEL SIGN PANEULEUNG
+1BAC..1BAD ; Alphabetic # Mc [2] SUNDANESE CONSONANT SIGN PASANGAN MA..SUNDANESE CONSONANT SIGN PASANGAN WA
1BAE..1BAF ; Alphabetic # Lo [2] SUNDANESE LETTER KHA..SUNDANESE LETTER SYA
-1BC0..1BE5 ; Alphabetic # Lo [38] BATAK LETTER A..BATAK LETTER U
+1BBA..1BE5 ; Alphabetic # Lo [44] SUNDANESE AVAGRAHA..BATAK LETTER U
1BE7 ; Alphabetic # Mc BATAK VOWEL SIGN E
1BE8..1BE9 ; Alphabetic # Mn [2] BATAK VOWEL SIGN PAKPAK E..BATAK VOWEL SIGN EE
1BEA..1BEC ; Alphabetic # Mc [3] BATAK VOWEL SIGN I..BATAK VOWEL SIGN O
@@ -653,10 +692,11 @@
1C78..1C7D ; Alphabetic # Lm [6] OL CHIKI MU TTUDDAG..OL CHIKI AHAD
1CE9..1CEC ; Alphabetic # Lo [4] VEDIC SIGN ANUSVARA ANTARGOMUKHA..VEDIC SIGN ANUSVARA VAMAGOMUKHA WITH TAIL
1CEE..1CF1 ; Alphabetic # Lo [4] VEDIC SIGN HEXIFORM LONG ANUSVARA..VEDIC SIGN ANUSVARA UBHAYATO MUKHA
-1CF2 ; Alphabetic # Mc VEDIC SIGN ARDHAVISARGA
+1CF2..1CF3 ; Alphabetic # Mc [2] VEDIC SIGN ARDHAVISARGA..VEDIC SIGN ROTATED ARDHAVISARGA
+1CF5..1CF6 ; Alphabetic # Lo [2] VEDIC SIGN JIHVAMULIYA..VEDIC SIGN UPADHMANIYA
1D00..1D2B ; Alphabetic # L& [44] LATIN LETTER SMALL CAPITAL A..CYRILLIC LETTER SMALL CAPITAL EL
-1D2C..1D61 ; Alphabetic # Lm [54] MODIFIER LETTER CAPITAL A..MODIFIER LETTER SMALL CHI
-1D62..1D77 ; Alphabetic # L& [22] LATIN SUBSCRIPT SMALL LETTER I..LATIN SMALL LETTER TURNED G
+1D2C..1D6A ; Alphabetic # Lm [63] MODIFIER LETTER CAPITAL A..GREEK SUBSCRIPT SMALL LETTER CHI
+1D6B..1D77 ; Alphabetic # L& [13] LATIN SMALL LETTER UE..LATIN SMALL LETTER TURNED G
1D78 ; Alphabetic # Lm MODIFIER LETTER CYRILLIC EN
1D79..1D9A ; Alphabetic # L& [34] LATIN SMALL LETTER INSULAR G..LATIN SMALL LETTER EZH WITH RETROFLEX HOOK
1D9B..1DBF ; Alphabetic # Lm [37] MODIFIER LETTER SMALL TURNED ALPHA..MODIFIER LETTER SMALL THETA
@@ -703,12 +743,15 @@
24B6..24E9 ; Alphabetic # So [52] CIRCLED LATIN CAPITAL LETTER A..CIRCLED LATIN SMALL LETTER Z
2C00..2C2E ; Alphabetic # L& [47] GLAGOLITIC CAPITAL LETTER AZU..GLAGOLITIC CAPITAL LETTER LATINATE MYSLITE
2C30..2C5E ; Alphabetic # L& [47] GLAGOLITIC SMALL LETTER AZU..GLAGOLITIC SMALL LETTER LATINATE MYSLITE
-2C60..2C7C ; Alphabetic # L& [29] LATIN CAPITAL LETTER L WITH DOUBLE BAR..LATIN SUBSCRIPT SMALL LETTER J
-2C7D ; Alphabetic # Lm MODIFIER LETTER CAPITAL V
+2C60..2C7B ; Alphabetic # L& [28] LATIN CAPITAL LETTER L WITH DOUBLE BAR..LATIN LETTER SMALL CAPITAL TURNED E
+2C7C..2C7D ; Alphabetic # Lm [2] LATIN SUBSCRIPT SMALL LETTER J..MODIFIER LETTER CAPITAL V
2C7E..2CE4 ; Alphabetic # L& [103] LATIN CAPITAL LETTER S WITH SWASH TAIL..COPTIC SYMBOL KAI
2CEB..2CEE ; Alphabetic # L& [4] COPTIC CAPITAL LETTER CRYPTOGRAMMIC SHEI..COPTIC SMALL LETTER CRYPTOGRAMMIC GANGIA
+2CF2..2CF3 ; Alphabetic # L& [2] COPTIC CAPITAL LETTER BOHAIRIC KHEI..COPTIC SMALL LETTER BOHAIRIC KHEI
2D00..2D25 ; Alphabetic # L& [38] GEORGIAN SMALL LETTER AN..GEORGIAN SMALL LETTER HOE
-2D30..2D65 ; Alphabetic # Lo [54] TIFINAGH LETTER YA..TIFINAGH LETTER YAZZ
+2D27 ; Alphabetic # L& GEORGIAN SMALL LETTER YN
+2D2D ; Alphabetic # L& GEORGIAN SMALL LETTER AEN
+2D30..2D67 ; Alphabetic # Lo [56] TIFINAGH LETTER YA..TIFINAGH LETTER YO
2D6F ; Alphabetic # Lm TIFINAGH MODIFIER LETTER LABIALIZATION MARK
2D80..2D96 ; Alphabetic # Lo [23] ETHIOPIC SYLLABLE LOA..ETHIOPIC SYLLABLE GGWE
2DA0..2DA6 ; Alphabetic # Lo [7] ETHIOPIC SYLLABLE SSA..ETHIOPIC SYLLABLE SSO
@@ -740,7 +783,7 @@
31A0..31BA ; Alphabetic # Lo [27] BOPOMOFO LETTER BU..BOPOMOFO LETTER ZY
31F0..31FF ; Alphabetic # Lo [16] KATAKANA LETTER SMALL KU..KATAKANA LETTER SMALL RO
3400..4DB5 ; Alphabetic # Lo [6582] CJK UNIFIED IDEOGRAPH-3400..CJK UNIFIED IDEOGRAPH-4DB5
-4E00..9FCB ; Alphabetic # Lo [20940] CJK UNIFIED IDEOGRAPH-4E00..CJK UNIFIED IDEOGRAPH-9FCB
+4E00..9FCC ; Alphabetic # Lo [20941] CJK UNIFIED IDEOGRAPH-4E00..CJK UNIFIED IDEOGRAPH-9FCC
A000..A014 ; Alphabetic # Lo [21] YI SYLLABLE IT..YI SYLLABLE E
A015 ; Alphabetic # Lm YI SYLLABLE WU
A016..A48C ; Alphabetic # Lo [1143] YI SYLLABLE BIT..YI SYLLABLE YYR
@@ -752,8 +795,10 @@
A62A..A62B ; Alphabetic # Lo [2] VAI SYLLABLE NDOLE MA..VAI SYLLABLE NDOLE DO
A640..A66D ; Alphabetic # L& [46] CYRILLIC CAPITAL LETTER ZEMLYA..CYRILLIC SMALL LETTER DOUBLE MONOCULAR O
A66E ; Alphabetic # Lo CYRILLIC LETTER MULTIOCULAR O
+A674..A67B ; Alphabetic # Mn [8] COMBINING CYRILLIC LETTER UKRAINIAN IE..COMBINING CYRILLIC LETTER OMEGA
A67F ; Alphabetic # Lm CYRILLIC PAYEROK
A680..A697 ; Alphabetic # L& [24] CYRILLIC CAPITAL LETTER DWE..CYRILLIC SMALL LETTER SHWE
+A69F ; Alphabetic # Mn COMBINING CYRILLIC LETTER IOTIFIED E
A6A0..A6E5 ; Alphabetic # Lo [70] BAMUM LETTER A..BAMUM LETTER KI
A6E6..A6EF ; Alphabetic # Nl [10] BAMUM LETTER MO..BAMUM LETTER KOGHOM
A717..A71F ; Alphabetic # Lm [9] MODIFIER LETTER DOT VERTICAL BAR..MODIFIER LETTER LOW INVERTED EXCLAMATION MARK
@@ -762,8 +807,9 @@
A771..A787 ; Alphabetic # L& [23] LATIN SMALL LETTER DUM..LATIN SMALL LETTER INSULAR T
A788 ; Alphabetic # Lm MODIFIER LETTER LOW CIRCUMFLEX ACCENT
A78B..A78E ; Alphabetic # L& [4] LATIN CAPITAL LETTER SALTILLO..LATIN SMALL LETTER L WITH RETROFLEX HOOK AND BELT
-A790..A791 ; Alphabetic # L& [2] LATIN CAPITAL LETTER N WITH DESCENDER..LATIN SMALL LETTER N WITH DESCENDER
-A7A0..A7A9 ; Alphabetic # L& [10] LATIN CAPITAL LETTER G WITH OBLIQUE STROKE..LATIN SMALL LETTER S WITH OBLIQUE STROKE
+A790..A793 ; Alphabetic # L& [4] LATIN CAPITAL LETTER N WITH DESCENDER..LATIN SMALL LETTER C WITH BAR
+A7A0..A7AA ; Alphabetic # L& [11] LATIN CAPITAL LETTER G WITH OBLIQUE STROKE..LATIN CAPITAL LETTER H WITH HOOK
+A7F8..A7F9 ; Alphabetic # Lm [2] MODIFIER LETTER CAPITAL H WITH STROKE..MODIFIER LETTER SMALL LIGATURE OE
A7FA ; Alphabetic # L& LATIN LETTER SMALL CAPITAL TURNED M
A7FB..A801 ; Alphabetic # Lo [7] LATIN EPIGRAPHIC LETTER REVERSED F..SYLOTI NAGRI LETTER I
A803..A805 ; Alphabetic # Lo [3] SYLOTI NAGRI LETTER U..SYLOTI NAGRI LETTER O
@@ -820,6 +866,13 @@
AAC2 ; Alphabetic # Lo TAI VIET TONE MAI SONG
AADB..AADC ; Alphabetic # Lo [2] TAI VIET SYMBOL KON..TAI VIET SYMBOL NUENG
AADD ; Alphabetic # Lm TAI VIET SYMBOL SAM
+AAE0..AAEA ; Alphabetic # Lo [11] MEETEI MAYEK LETTER E..MEETEI MAYEK LETTER SSA
+AAEB ; Alphabetic # Mc MEETEI MAYEK VOWEL SIGN II
+AAEC..AAED ; Alphabetic # Mn [2] MEETEI MAYEK VOWEL SIGN UU..MEETEI MAYEK VOWEL SIGN AAI
+AAEE..AAEF ; Alphabetic # Mc [2] MEETEI MAYEK VOWEL SIGN AU..MEETEI MAYEK VOWEL SIGN AAU
+AAF2 ; Alphabetic # Lo MEETEI MAYEK ANJI
+AAF3..AAF4 ; Alphabetic # Lm [2] MEETEI MAYEK SYLLABLE REPETITION MARK..MEETEI MAYEK WORD REPETITION MARK
+AAF5 ; Alphabetic # Mc MEETEI MAYEK VOWEL SIGN VISARGA
AB01..AB06 ; Alphabetic # Lo [6] ETHIOPIC SYLLABLE TTHU..ETHIOPIC SYLLABLE TTHO
AB09..AB0E ; Alphabetic # Lo [6] ETHIOPIC SYLLABLE DDHU..ETHIOPIC SYLLABLE DDHO
AB11..AB16 ; Alphabetic # Lo [6] ETHIOPIC SYLLABLE DZU..ETHIOPIC SYLLABLE DZO
@@ -834,8 +887,7 @@
AC00..D7A3 ; Alphabetic # Lo [11172] HANGUL SYLLABLE GA..HANGUL SYLLABLE HIH
D7B0..D7C6 ; Alphabetic # Lo [23] HANGUL JUNGSEONG O-YEO..HANGUL JUNGSEONG ARAEA-E
D7CB..D7FB ; Alphabetic # Lo [49] HANGUL JONGSEONG NIEUN-RIEUL..HANGUL JONGSEONG PHIEUPH-THIEUTH
-F900..FA2D ; Alphabetic # Lo [302] CJK COMPATIBILITY IDEOGRAPH-F900..CJK COMPATIBILITY IDEOGRAPH-FA2D
-FA30..FA6D ; Alphabetic # Lo [62] CJK COMPATIBILITY IDEOGRAPH-FA30..CJK COMPATIBILITY IDEOGRAPH-FA6D
+F900..FA6D ; Alphabetic # Lo [366] CJK COMPATIBILITY IDEOGRAPH-F900..CJK COMPATIBILITY IDEOGRAPH-FA6D
FA70..FAD9 ; Alphabetic # Lo [106] CJK COMPATIBILITY IDEOGRAPH-FA70..CJK COMPATIBILITY IDEOGRAPH-FAD9
FB00..FB06 ; Alphabetic # L& [7] LATIN SMALL LIGATURE FF..LATIN SMALL LIGATURE ST
FB13..FB17 ; Alphabetic # L& [5] ARMENIAN SMALL LIGATURE MEN NOW..ARMENIAN SMALL LIGATURE MEN XEH
@@ -894,6 +946,8 @@
1083F..10855 ; Alphabetic # Lo [23] CYPRIOT SYLLABLE ZO..IMPERIAL ARAMAIC LETTER TAW
10900..10915 ; Alphabetic # Lo [22] PHOENICIAN LETTER ALF..PHOENICIAN LETTER TAU
10920..10939 ; Alphabetic # Lo [26] LYDIAN LETTER A..LYDIAN LETTER C
+10980..109B7 ; Alphabetic # Lo [56] MEROITIC HIEROGLYPHIC LETTER A..MEROITIC CURSIVE LETTER DA
+109BE..109BF ; Alphabetic # Lo [2] MEROITIC CURSIVE LOGOGRAM RMT..MEROITIC CURSIVE LOGOGRAM IMN
10A00 ; Alphabetic # Lo KHAROSHTHI LETTER A
10A01..10A03 ; Alphabetic # Mn [3] KHAROSHTHI VOWEL SIGN I..KHAROSHTHI VOWEL SIGN VOCALIC R
10A05..10A06 ; Alphabetic # Mn [2] KHAROSHTHI VOWEL SIGN E..KHAROSHTHI VOWEL SIGN O
@@ -916,10 +970,33 @@
110B0..110B2 ; Alphabetic # Mc [3] KAITHI VOWEL SIGN AA..KAITHI VOWEL SIGN II
110B3..110B6 ; Alphabetic # Mn [4] KAITHI VOWEL SIGN U..KAITHI VOWEL SIGN AI
110B7..110B8 ; Alphabetic # Mc [2] KAITHI VOWEL SIGN O..KAITHI VOWEL SIGN AU
+110D0..110E8 ; Alphabetic # Lo [25] SORA SOMPENG LETTER SAH..SORA SOMPENG LETTER MAE
+11100..11102 ; Alphabetic # Mn [3] CHAKMA SIGN CANDRABINDU..CHAKMA SIGN VISARGA
+11103..11126 ; Alphabetic # Lo [36] CHAKMA LETTER AA..CHAKMA LETTER HAA
+11127..1112B ; Alphabetic # Mn [5] CHAKMA VOWEL SIGN A..CHAKMA VOWEL SIGN UU
+1112C ; Alphabetic # Mc CHAKMA VOWEL SIGN E
+1112D..11132 ; Alphabetic # Mn [6] CHAKMA VOWEL SIGN AI..CHAKMA AU MARK
+11180..11181 ; Alphabetic # Mn [2] SHARADA SIGN CANDRABINDU..SHARADA SIGN ANUSVARA
+11182 ; Alphabetic # Mc SHARADA SIGN VISARGA
+11183..111B2 ; Alphabetic # Lo [48] SHARADA LETTER A..SHARADA LETTER HA
+111B3..111B5 ; Alphabetic # Mc [3] SHARADA VOWEL SIGN AA..SHARADA VOWEL SIGN II
+111B6..111BE ; Alphabetic # Mn [9] SHARADA VOWEL SIGN U..SHARADA VOWEL SIGN O
+111BF ; Alphabetic # Mc SHARADA VOWEL SIGN AU
+111C1..111C4 ; Alphabetic # Lo [4] SHARADA SIGN AVAGRAHA..SHARADA OM
+11680..116AA ; Alphabetic # Lo [43] TAKRI LETTER A..TAKRI LETTER RRA
+116AB ; Alphabetic # Mn TAKRI SIGN ANUSVARA
+116AC ; Alphabetic # Mc TAKRI SIGN VISARGA
+116AD ; Alphabetic # Mn TAKRI VOWEL SIGN AA
+116AE..116AF ; Alphabetic # Mc [2] TAKRI VOWEL SIGN I..TAKRI VOWEL SIGN II
+116B0..116B5 ; Alphabetic # Mn [6] TAKRI VOWEL SIGN U..TAKRI VOWEL SIGN AU
12000..1236E ; Alphabetic # Lo [879] CUNEIFORM SIGN A..CUNEIFORM SIGN ZUM
12400..12462 ; Alphabetic # Nl [99] CUNEIFORM NUMERIC SIGN TWO ASH..CUNEIFORM NUMERIC SIGN OLD ASSYRIAN ONE QUARTER
13000..1342E ; Alphabetic # Lo [1071] EGYPTIAN HIEROGLYPH A001..EGYPTIAN HIEROGLYPH AA032
16800..16A38 ; Alphabetic # Lo [569] BAMUM LETTER PHASE-A NGKUE MFON..BAMUM LETTER PHASE-F VUEQ
+16F00..16F44 ; Alphabetic # Lo [69] MIAO LETTER PA..MIAO LETTER HHA
+16F50 ; Alphabetic # Lo MIAO LETTER NASALIZATION
+16F51..16F7E ; Alphabetic # Mc [46] MIAO SIGN ASPIRATION..MIAO VOWEL SIGN NG
+16F93..16F9F ; Alphabetic # Lm [13] MIAO LETTER TONE-2..MIAO LETTER REFORMED TONE-8
1B000..1B001 ; Alphabetic # Lo [2] KATAKANA LETTER ARCHAIC E..HIRAGANA LETTER ARCHAIC YE
1D400..1D454 ; Alphabetic # L& [85] MATHEMATICAL BOLD CAPITAL A..MATHEMATICAL ITALIC SMALL G
1D456..1D49C ; Alphabetic # L& [71] MATHEMATICAL ITALIC SMALL I..MATHEMATICAL SCRIPT CAPITAL A
@@ -951,12 +1028,45 @@
1D78A..1D7A8 ; Alphabetic # L& [31] MATHEMATICAL SANS-SERIF BOLD EPSILON SYMBOL..MATHEMATICAL SANS-SERIF BOLD ITALIC CAPITAL OMEGA
1D7AA..1D7C2 ; Alphabetic # L& [25] MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL ALPHA..MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL OMEGA
1D7C4..1D7CB ; Alphabetic # L& [8] MATHEMATICAL SANS-SERIF BOLD ITALIC EPSILON SYMBOL..MATHEMATICAL BOLD SMALL DIGAMMA
+1EE00..1EE03 ; Alphabetic # Lo [4] ARABIC MATHEMATICAL ALEF..ARABIC MATHEMATICAL DAL
+1EE05..1EE1F ; Alphabetic # Lo [27] ARABIC MATHEMATICAL WAW..ARABIC MATHEMATICAL DOTLESS QAF
+1EE21..1EE22 ; Alphabetic # Lo [2] ARABIC MATHEMATICAL INITIAL BEH..ARABIC MATHEMATICAL INITIAL JEEM
+1EE24 ; Alphabetic # Lo ARABIC MATHEMATICAL INITIAL HEH
+1EE27 ; Alphabetic # Lo ARABIC MATHEMATICAL INITIAL HAH
+1EE29..1EE32 ; Alphabetic # Lo [10] ARABIC MATHEMATICAL INITIAL YEH..ARABIC MATHEMATICAL INITIAL QAF
+1EE34..1EE37 ; Alphabetic # Lo [4] ARABIC MATHEMATICAL INITIAL SHEEN..ARABIC MATHEMATICAL INITIAL KHAH
+1EE39 ; Alphabetic # Lo ARABIC MATHEMATICAL INITIAL DAD
+1EE3B ; Alphabetic # Lo ARABIC MATHEMATICAL INITIAL GHAIN
+1EE42 ; Alphabetic # Lo ARABIC MATHEMATICAL TAILED JEEM
+1EE47 ; Alphabetic # Lo ARABIC MATHEMATICAL TAILED HAH
+1EE49 ; Alphabetic # Lo ARABIC MATHEMATICAL TAILED YEH
+1EE4B ; Alphabetic # Lo ARABIC MATHEMATICAL TAILED LAM
+1EE4D..1EE4F ; Alphabetic # Lo [3] ARABIC MATHEMATICAL TAILED NOON..ARABIC MATHEMATICAL TAILED AIN
+1EE51..1EE52 ; Alphabetic # Lo [2] ARABIC MATHEMATICAL TAILED SAD..ARABIC MATHEMATICAL TAILED QAF
+1EE54 ; Alphabetic # Lo ARABIC MATHEMATICAL TAILED SHEEN
+1EE57 ; Alphabetic # Lo ARABIC MATHEMATICAL TAILED KHAH
+1EE59 ; Alphabetic # Lo ARABIC MATHEMATICAL TAILED DAD
+1EE5B ; Alphabetic # Lo ARABIC MATHEMATICAL TAILED GHAIN
+1EE5D ; Alphabetic # Lo ARABIC MATHEMATICAL TAILED DOTLESS NOON
+1EE5F ; Alphabetic # Lo ARABIC MATHEMATICAL TAILED DOTLESS QAF
+1EE61..1EE62 ; Alphabetic # Lo [2] ARABIC MATHEMATICAL STRETCHED BEH..ARABIC MATHEMATICAL STRETCHED JEEM
+1EE64 ; Alphabetic # Lo ARABIC MATHEMATICAL STRETCHED HEH
+1EE67..1EE6A ; Alphabetic # Lo [4] ARABIC MATHEMATICAL STRETCHED HAH..ARABIC MATHEMATICAL STRETCHED KAF
+1EE6C..1EE72 ; Alphabetic # Lo [7] ARABIC MATHEMATICAL STRETCHED MEEM..ARABIC MATHEMATICAL STRETCHED QAF
+1EE74..1EE77 ; Alphabetic # Lo [4] ARABIC MATHEMATICAL STRETCHED SHEEN..ARABIC MATHEMATICAL STRETCHED KHAH
+1EE79..1EE7C ; Alphabetic # Lo [4] ARABIC MATHEMATICAL STRETCHED DAD..ARABIC MATHEMATICAL STRETCHED DOTLESS BEH
+1EE7E ; Alphabetic # Lo ARABIC MATHEMATICAL STRETCHED DOTLESS FEH
+1EE80..1EE89 ; Alphabetic # Lo [10] ARABIC MATHEMATICAL LOOPED ALEF..ARABIC MATHEMATICAL LOOPED YEH
+1EE8B..1EE9B ; Alphabetic # Lo [17] ARABIC MATHEMATICAL LOOPED LAM..ARABIC MATHEMATICAL LOOPED GHAIN
+1EEA1..1EEA3 ; Alphabetic # Lo [3] ARABIC MATHEMATICAL DOUBLE-STRUCK BEH..ARABIC MATHEMATICAL DOUBLE-STRUCK DAL
+1EEA5..1EEA9 ; Alphabetic # Lo [5] ARABIC MATHEMATICAL DOUBLE-STRUCK WAW..ARABIC MATHEMATICAL DOUBLE-STRUCK YEH
+1EEAB..1EEBB ; Alphabetic # Lo [17] ARABIC MATHEMATICAL DOUBLE-STRUCK LAM..ARABIC MATHEMATICAL DOUBLE-STRUCK GHAIN
20000..2A6D6 ; Alphabetic # Lo [42711] CJK UNIFIED IDEOGRAPH-20000..CJK UNIFIED IDEOGRAPH-2A6D6
2A700..2B734 ; Alphabetic # Lo [4149] CJK UNIFIED IDEOGRAPH-2A700..CJK UNIFIED IDEOGRAPH-2B734
2B740..2B81D ; Alphabetic # Lo [222] CJK UNIFIED IDEOGRAPH-2B740..CJK UNIFIED IDEOGRAPH-2B81D
2F800..2FA1D ; Alphabetic # Lo [542] CJK COMPATIBILITY IDEOGRAPH-2F800..CJK COMPATIBILITY IDEOGRAPH-2FA1D
-# Total code points: 101539
+# Total code points: 102159
# ================================================
@@ -964,9 +1074,9 @@
# Generated from: Ll + Other_Lowercase
0061..007A ; Lowercase # L& [26] LATIN SMALL LETTER A..LATIN SMALL LETTER Z
-00AA ; Lowercase # L& FEMININE ORDINAL INDICATOR
+00AA ; Lowercase # Lo FEMININE ORDINAL INDICATOR
00B5 ; Lowercase # L& MICRO SIGN
-00BA ; Lowercase # L& MASCULINE ORDINAL INDICATOR
+00BA ; Lowercase # Lo MASCULINE ORDINAL INDICATOR
00DF..00F6 ; Lowercase # L& [24] LATIN SMALL LETTER SHARP S..LATIN SMALL LETTER O WITH DIAERESIS
00F8..00FF ; Lowercase # L& [8] LATIN SMALL LETTER O WITH STROKE..LATIN SMALL LETTER Y WITH DIAERESIS
0101 ; Lowercase # L& LATIN SMALL LETTER A WITH MACRON
@@ -1237,8 +1347,8 @@
0527 ; Lowercase # L& CYRILLIC SMALL LETTER SHHA WITH DESCENDER
0561..0587 ; Lowercase # L& [39] ARMENIAN SMALL LETTER AYB..ARMENIAN SMALL LIGATURE ECH YIWN
1D00..1D2B ; Lowercase # L& [44] LATIN LETTER SMALL CAPITAL A..CYRILLIC LETTER SMALL CAPITAL EL
-1D2C..1D61 ; Lowercase # Lm [54] MODIFIER LETTER CAPITAL A..MODIFIER LETTER SMALL CHI
-1D62..1D77 ; Lowercase # L& [22] LATIN SUBSCRIPT SMALL LETTER I..LATIN SMALL LETTER TURNED G
+1D2C..1D6A ; Lowercase # Lm [63] MODIFIER LETTER CAPITAL A..GREEK SUBSCRIPT SMALL LETTER CHI
+1D6B..1D77 ; Lowercase # L& [13] LATIN SMALL LETTER UE..LATIN SMALL LETTER TURNED G
1D78 ; Lowercase # Lm MODIFIER LETTER CYRILLIC EN
1D79..1D9A ; Lowercase # L& [34] LATIN SMALL LETTER INSULAR G..LATIN SMALL LETTER EZH WITH RETROFLEX HOOK
1D9B..1DBF ; Lowercase # Lm [37] MODIFIER LETTER SMALL TURNED ALPHA..MODIFIER LETTER SMALL THETA
@@ -1386,7 +1496,9 @@
1FE0..1FE7 ; Lowercase # L& [8] GREEK SMALL LETTER UPSILON WITH VRACHY..GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI
1FF2..1FF4 ; Lowercase # L& [3] GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI..GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI
1FF6..1FF7 ; Lowercase # L& [2] GREEK SMALL LETTER OMEGA WITH PERISPOMENI..GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI
-2090..2094 ; Lowercase # Lm [5] LATIN SUBSCRIPT SMALL LETTER A..LATIN SUBSCRIPT SMALL LETTER SCHWA
+2071 ; Lowercase # Lm SUPERSCRIPT LATIN SMALL LETTER I
+207F ; Lowercase # Lm SUPERSCRIPT LATIN SMALL LETTER N
+2090..209C ; Lowercase # Lm [13] LATIN SUBSCRIPT SMALL LETTER A..LATIN SUBSCRIPT SMALL LETTER T
210A ; Lowercase # L& SCRIPT SMALL G
210E..210F ; Lowercase # L& [2] PLANCK CONSTANT..PLANCK CONSTANT OVER TWO PI
2113 ; Lowercase # L& SCRIPT SMALL L
@@ -1407,8 +1519,8 @@
2C6C ; Lowercase # L& LATIN SMALL LETTER Z WITH DESCENDER
2C71 ; Lowercase # L& LATIN SMALL LETTER V WITH RIGHT HOOK
2C73..2C74 ; Lowercase # L& [2] LATIN SMALL LETTER W WITH HOOK..LATIN SMALL LETTER V WITH CURL
-2C76..2C7C ; Lowercase # L& [7] LATIN SMALL LETTER HALF H..LATIN SUBSCRIPT SMALL LETTER J
-2C7D ; Lowercase # Lm MODIFIER LETTER CAPITAL V
+2C76..2C7B ; Lowercase # L& [6] LATIN SMALL LETTER HALF H..LATIN LETTER SMALL CAPITAL TURNED E
+2C7C..2C7D ; Lowercase # Lm [2] LATIN SUBSCRIPT SMALL LETTER J..MODIFIER LETTER CAPITAL V
2C81 ; Lowercase # L& COPTIC SMALL LETTER ALFA
2C83 ; Lowercase # L& COPTIC SMALL LETTER VIDA
2C85 ; Lowercase # L& COPTIC SMALL LETTER GAMMA
@@ -1461,7 +1573,10 @@
2CE3..2CE4 ; Lowercase # L& [2] COPTIC SMALL LETTER OLD NUBIAN WAU..COPTIC SYMBOL KAI
2CEC ; Lowercase # L& COPTIC SMALL LETTER CRYPTOGRAMMIC SHEI
2CEE ; Lowercase # L& COPTIC SMALL LETTER CRYPTOGRAMMIC GANGIA
+2CF3 ; Lowercase # L& COPTIC SMALL LETTER BOHAIRIC KHEI
2D00..2D25 ; Lowercase # L& [38] GEORGIAN SMALL LETTER AN..GEORGIAN SMALL LETTER HOE
+2D27 ; Lowercase # L& GEORGIAN SMALL LETTER YN
+2D2D ; Lowercase # L& GEORGIAN SMALL LETTER AEN
A641 ; Lowercase # L& CYRILLIC SMALL LETTER ZEMLYA
A643 ; Lowercase # L& CYRILLIC SMALL LETTER DZELO
A645 ; Lowercase # L& CYRILLIC SMALL LETTER REVERSED DZE
@@ -1547,11 +1662,13 @@
A78C ; Lowercase # L& LATIN SMALL LETTER SALTILLO
A78E ; Lowercase # L& LATIN SMALL LETTER L WITH RETROFLEX HOOK AND BELT
A791 ; Lowercase # L& LATIN SMALL LETTER N WITH DESCENDER
+A793 ; Lowercase # L& LATIN SMALL LETTER C WITH BAR
A7A1 ; Lowercase # L& LATIN SMALL LETTER G WITH OBLIQUE STROKE
A7A3 ; Lowercase # L& LATIN SMALL LETTER K WITH OBLIQUE STROKE
A7A5 ; Lowercase # L& LATIN SMALL LETTER N WITH OBLIQUE STROKE
A7A7 ; Lowercase # L& LATIN SMALL LETTER R WITH OBLIQUE STROKE
A7A9 ; Lowercase # L& LATIN SMALL LETTER S WITH OBLIQUE STROKE
+A7F8..A7F9 ; Lowercase # Lm [2] MODIFIER LETTER CAPITAL H WITH STROKE..MODIFIER LETTER SMALL LIGATURE OE
A7FA ; Lowercase # L& LATIN LETTER SMALL CAPITAL TURNED M
FB00..FB06 ; Lowercase # L& [7] LATIN SMALL LIGATURE FF..LATIN SMALL LIGATURE ST
FB13..FB17 ; Lowercase # L& [5] ARMENIAN SMALL LIGATURE MEN NOW..ARMENIAN SMALL LIGATURE MEN XEH
@@ -1586,7 +1703,7 @@
1D7C4..1D7C9 ; Lowercase # L& [6] MATHEMATICAL SANS-SERIF BOLD ITALIC EPSILON SYMBOL..MATHEMATICAL SANS-SERIF BOLD ITALIC PI SYMBOL
1D7CB ; Lowercase # L& MATHEMATICAL BOLD SMALL DIGAMMA
-# Total code points: 1918
+# Total code points: 1934
# ================================================
@@ -1861,6 +1978,8 @@
0526 ; Uppercase # L& CYRILLIC CAPITAL LETTER SHHA WITH DESCENDER
0531..0556 ; Uppercase # L& [38] ARMENIAN CAPITAL LETTER AYB..ARMENIAN CAPITAL LETTER FEH
10A0..10C5 ; Uppercase # L& [38] GEORGIAN CAPITAL LETTER AN..GEORGIAN CAPITAL LETTER HOE
+10C7 ; Uppercase # L& GEORGIAN CAPITAL LETTER YN
+10CD ; Uppercase # L& GEORGIAN CAPITAL LETTER AEN
1E00 ; Uppercase # L& LATIN CAPITAL LETTER A WITH RING BELOW
1E02 ; Uppercase # L& LATIN CAPITAL LETTER B WITH DOT ABOVE
1E04 ; Uppercase # L& LATIN CAPITAL LETTER B WITH DOT BELOW
@@ -2077,6 +2196,7 @@
2CE2 ; Uppercase # L& COPTIC CAPITAL LETTER OLD NUBIAN WAU
2CEB ; Uppercase # L& COPTIC CAPITAL LETTER CRYPTOGRAMMIC SHEI
2CED ; Uppercase # L& COPTIC CAPITAL LETTER CRYPTOGRAMMIC GANGIA
+2CF2 ; Uppercase # L& COPTIC CAPITAL LETTER BOHAIRIC KHEI
A640 ; Uppercase # L& CYRILLIC CAPITAL LETTER ZEMLYA
A642 ; Uppercase # L& CYRILLIC CAPITAL LETTER DZELO
A644 ; Uppercase # L& CYRILLIC CAPITAL LETTER REVERSED DZE
@@ -2160,11 +2280,13 @@
A78B ; Uppercase # L& LATIN CAPITAL LETTER SALTILLO
A78D ; Uppercase # L& LATIN CAPITAL LETTER TURNED H
A790 ; Uppercase # L& LATIN CAPITAL LETTER N WITH DESCENDER
+A792 ; Uppercase # L& LATIN CAPITAL LETTER C WITH BAR
A7A0 ; Uppercase # L& LATIN CAPITAL LETTER G WITH OBLIQUE STROKE
A7A2 ; Uppercase # L& LATIN CAPITAL LETTER K WITH OBLIQUE STROKE
A7A4 ; Uppercase # L& LATIN CAPITAL LETTER N WITH OBLIQUE STROKE
A7A6 ; Uppercase # L& LATIN CAPITAL LETTER R WITH OBLIQUE STROKE
A7A8 ; Uppercase # L& LATIN CAPITAL LETTER S WITH OBLIQUE STROKE
+A7AA ; Uppercase # L& LATIN CAPITAL LETTER H WITH HOOK
FF21..FF3A ; Uppercase # L& [26] FULLWIDTH LATIN CAPITAL LETTER A..FULLWIDTH LATIN CAPITAL LETTER Z
10400..10427 ; Uppercase # L& [40] DESERET CAPITAL LETTER LONG I..DESERET CAPITAL LETTER EW
1D400..1D419 ; Uppercase # L& [26] MATHEMATICAL BOLD CAPITAL A..MATHEMATICAL BOLD CAPITAL Z
@@ -2199,7 +2321,7 @@
1D790..1D7A8 ; Uppercase # L& [25] MATHEMATICAL SANS-SERIF BOLD ITALIC CAPITAL ALPHA..MATHEMATICAL SANS-SERIF BOLD ITALIC CAPITAL OMEGA
1D7CA ; Uppercase # L& MATHEMATICAL BOLD CAPITAL DIGAMMA
-# Total code points: 1478
+# Total code points: 1483
# ================================================
@@ -2209,9 +2331,9 @@
0041..005A ; Cased # L& [26] LATIN CAPITAL LETTER A..LATIN CAPITAL LETTER Z
0061..007A ; Cased # L& [26] LATIN SMALL LETTER A..LATIN SMALL LETTER Z
-00AA ; Cased # L& FEMININE ORDINAL INDICATOR
+00AA ; Cased # Lo FEMININE ORDINAL INDICATOR
00B5 ; Cased # L& MICRO SIGN
-00BA ; Cased # L& MASCULINE ORDINAL INDICATOR
+00BA ; Cased # Lo MASCULINE ORDINAL INDICATOR
00C0..00D6 ; Cased # L& [23] LATIN CAPITAL LETTER A WITH GRAVE..LATIN CAPITAL LETTER O WITH DIAERESIS
00D8..00F6 ; Cased # L& [31] LATIN CAPITAL LETTER O WITH STROKE..LATIN SMALL LETTER O WITH DIAERESIS
00F8..01BA ; Cased # L& [195] LATIN SMALL LETTER O WITH STROKE..LATIN SMALL LETTER EZH WITH TAIL
@@ -2236,9 +2358,11 @@
0531..0556 ; Cased # L& [38] ARMENIAN CAPITAL LETTER AYB..ARMENIAN CAPITAL LETTER FEH
0561..0587 ; Cased # L& [39] ARMENIAN SMALL LETTER AYB..ARMENIAN SMALL LIGATURE ECH YIWN
10A0..10C5 ; Cased # L& [38] GEORGIAN CAPITAL LETTER AN..GEORGIAN CAPITAL LETTER HOE
+10C7 ; Cased # L& GEORGIAN CAPITAL LETTER YN
+10CD ; Cased # L& GEORGIAN CAPITAL LETTER AEN
1D00..1D2B ; Cased # L& [44] LATIN LETTER SMALL CAPITAL A..CYRILLIC LETTER SMALL CAPITAL EL
-1D2C..1D61 ; Cased # Lm [54] MODIFIER LETTER CAPITAL A..MODIFIER LETTER SMALL CHI
-1D62..1D77 ; Cased # L& [22] LATIN SUBSCRIPT SMALL LETTER I..LATIN SMALL LETTER TURNED G
+1D2C..1D6A ; Cased # Lm [63] MODIFIER LETTER CAPITAL A..GREEK SUBSCRIPT SMALL LETTER CHI
+1D6B..1D77 ; Cased # L& [13] LATIN SMALL LETTER UE..LATIN SMALL LETTER TURNED G
1D78 ; Cased # Lm MODIFIER LETTER CYRILLIC EN
1D79..1D9A ; Cased # L& [34] LATIN SMALL LETTER INSULAR G..LATIN SMALL LETTER EZH WITH RETROFLEX HOOK
1D9B..1DBF ; Cased # Lm [37] MODIFIER LETTER SMALL TURNED ALPHA..MODIFIER LETTER SMALL THETA
@@ -2261,7 +2385,9 @@
1FE0..1FEC ; Cased # L& [13] GREEK SMALL LETTER UPSILON WITH VRACHY..GREEK CAPITAL LETTER RHO WITH DASIA
1FF2..1FF4 ; Cased # L& [3] GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI..GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI
1FF6..1FFC ; Cased # L& [7] GREEK SMALL LETTER OMEGA WITH PERISPOMENI..GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI
-2090..2094 ; Cased # Lm [5] LATIN SUBSCRIPT SMALL LETTER A..LATIN SUBSCRIPT SMALL LETTER SCHWA
+2071 ; Cased # Lm SUPERSCRIPT LATIN SMALL LETTER I
+207F ; Cased # Lm SUPERSCRIPT LATIN SMALL LETTER N
+2090..209C ; Cased # Lm [13] LATIN SUBSCRIPT SMALL LETTER A..LATIN SUBSCRIPT SMALL LETTER T
2102 ; Cased # L& DOUBLE-STRUCK CAPITAL C
2107 ; Cased # L& EULER CONSTANT
210A..2113 ; Cased # L& [10] SCRIPT SMALL G..SCRIPT SMALL L
@@ -2281,11 +2407,14 @@
24B6..24E9 ; Cased # So [52] CIRCLED LATIN CAPITAL LETTER A..CIRCLED LATIN SMALL LETTER Z
2C00..2C2E ; Cased # L& [47] GLAGOLITIC CAPITAL LETTER AZU..GLAGOLITIC CAPITAL LETTER LATINATE MYSLITE
2C30..2C5E ; Cased # L& [47] GLAGOLITIC SMALL LETTER AZU..GLAGOLITIC SMALL LETTER LATINATE MYSLITE
-2C60..2C7C ; Cased # L& [29] LATIN CAPITAL LETTER L WITH DOUBLE BAR..LATIN SUBSCRIPT SMALL LETTER J
-2C7D ; Cased # Lm MODIFIER LETTER CAPITAL V
+2C60..2C7B ; Cased # L& [28] LATIN CAPITAL LETTER L WITH DOUBLE BAR..LATIN LETTER SMALL CAPITAL TURNED E
+2C7C..2C7D ; Cased # Lm [2] LATIN SUBSCRIPT SMALL LETTER J..MODIFIER LETTER CAPITAL V
2C7E..2CE4 ; Cased # L& [103] LATIN CAPITAL LETTER S WITH SWASH TAIL..COPTIC SYMBOL KAI
2CEB..2CEE ; Cased # L& [4] COPTIC CAPITAL LETTER CRYPTOGRAMMIC SHEI..COPTIC SMALL LETTER CRYPTOGRAMMIC GANGIA
+2CF2..2CF3 ; Cased # L& [2] COPTIC CAPITAL LETTER BOHAIRIC KHEI..COPTIC SMALL LETTER BOHAIRIC KHEI
2D00..2D25 ; Cased # L& [38] GEORGIAN SMALL LETTER AN..GEORGIAN SMALL LETTER HOE
+2D27 ; Cased # L& GEORGIAN SMALL LETTER YN
+2D2D ; Cased # L& GEORGIAN SMALL LETTER AEN
A640..A66D ; Cased # L& [46] CYRILLIC CAPITAL LETTER ZEMLYA..CYRILLIC SMALL LETTER DOUBLE MONOCULAR O
A680..A697 ; Cased # L& [24] CYRILLIC CAPITAL LETTER DWE..CYRILLIC SMALL LETTER SHWE
A722..A76F ; Cased # L& [78] LATIN CAPITAL LETTER EGYPTOLOGICAL ALEF..LATIN SMALL LETTER CON
@@ -2292,8 +2421,9 @@
A770 ; Cased # Lm MODIFIER LETTER US
A771..A787 ; Cased # L& [23] LATIN SMALL LETTER DUM..LATIN SMALL LETTER INSULAR T
A78B..A78E ; Cased # L& [4] LATIN CAPITAL LETTER SALTILLO..LATIN SMALL LETTER L WITH RETROFLEX HOOK AND BELT
-A790..A791 ; Cased # L& [2] LATIN CAPITAL LETTER N WITH DESCENDER..LATIN SMALL LETTER N WITH DESCENDER
-A7A0..A7A9 ; Cased # L& [10] LATIN CAPITAL LETTER G WITH OBLIQUE STROKE..LATIN SMALL LETTER S WITH OBLIQUE STROKE
+A790..A793 ; Cased # L& [4] LATIN CAPITAL LETTER N WITH DESCENDER..LATIN SMALL LETTER C WITH BAR
+A7A0..A7AA ; Cased # L& [11] LATIN CAPITAL LETTER G WITH OBLIQUE STROKE..LATIN CAPITAL LETTER H WITH HOOK
+A7F8..A7F9 ; Cased # Lm [2] MODIFIER LETTER CAPITAL H WITH STROKE..MODIFIER LETTER SMALL LIGATURE OE
A7FA ; Cased # L& LATIN LETTER SMALL CAPITAL TURNED M
FB00..FB06 ; Cased # L& [7] LATIN SMALL LIGATURE FF..LATIN SMALL LIGATURE ST
FB13..FB17 ; Cased # L& [5] ARMENIAN SMALL LIGATURE MEN NOW..ARMENIAN SMALL LIGATURE MEN XEH
@@ -2331,7 +2461,7 @@
1D7AA..1D7C2 ; Cased # L& [25] MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL ALPHA..MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL OMEGA
1D7C4..1D7CB ; Cased # L& [8] MATHEMATICAL SANS-SERIF BOLD ITALIC EPSILON SYMBOL..MATHEMATICAL BOLD SMALL DIGAMMA
-# Total code points: 3427
+# Total code points: 3448
# ================================================
@@ -2377,7 +2507,7 @@
05C4..05C5 ; Case_Ignorable # Mn [2] HEBREW MARK UPPER DOT..HEBREW MARK LOWER DOT
05C7 ; Case_Ignorable # Mn HEBREW POINT QAMATS QATAN
05F4 ; Case_Ignorable # Po HEBREW PUNCTUATION GERSHAYIM
-0600..0603 ; Case_Ignorable # Cf [4] ARABIC NUMBER SIGN..ARABIC SIGN SAFHA
+0600..0604 ; Case_Ignorable # Cf [5] ARABIC NUMBER SIGN..ARABIC SIGN SAMVAT
0610..061A ; Case_Ignorable # Mn [11] ARABIC SIGN SALLALLAHOU ALAYHE WASSALLAM..ARABIC SMALL KASRA
0640 ; Case_Ignorable # Lm ARABIC TATWEEL
064B..065F ; Case_Ignorable # Mn [21] ARABIC FATHATAN..ARABIC WAVY HAMZA BELOW
@@ -2403,6 +2533,7 @@
0828 ; Case_Ignorable # Lm SAMARITAN MODIFIER LETTER I
0829..082D ; Case_Ignorable # Mn [5] SAMARITAN VOWEL SIGN LONG I..SAMARITAN MARK NEQUDAA
0859..085B ; Case_Ignorable # Mn [3] MANDAIC AFFRICATION MARK..MANDAIC GEMINATION MARK
+08E4..08FE ; Case_Ignorable # Mn [27] ARABIC CURLY FATHA..ARABIC DAMMA WITH DOT
0900..0902 ; Case_Ignorable # Mn [3] DEVANAGARI SIGN INVERTED CANDRABINDU..DEVANAGARI SIGN ANUSVARA
093A ; Case_Ignorable # Mn DEVANAGARI VOWEL SIGN OE
093C ; Case_Ignorable # Mn DEVANAGARI SIGN NUKTA
@@ -2492,7 +2623,7 @@
1732..1734 ; Case_Ignorable # Mn [3] HANUNOO VOWEL SIGN I..HANUNOO SIGN PAMUDPOD
1752..1753 ; Case_Ignorable # Mn [2] BUHID VOWEL SIGN I..BUHID VOWEL SIGN U
1772..1773 ; Case_Ignorable # Mn [2] TAGBANWA VOWEL SIGN I..TAGBANWA VOWEL SIGN U
-17B4..17B5 ; Case_Ignorable # Cf [2] KHMER VOWEL INHERENT AQ..KHMER VOWEL INHERENT AA
+17B4..17B5 ; Case_Ignorable # Mn [2] KHMER VOWEL INHERENT AQ..KHMER VOWEL INHERENT AA
17B7..17BD ; Case_Ignorable # Mn [7] KHMER VOWEL SIGN I..KHMER VOWEL SIGN UA
17C6 ; Case_Ignorable # Mn KHMER SIGN NIKAHIT
17C9..17D3 ; Case_Ignorable # Mn [11] KHMER SIGN MUUSIKATOAN..KHMER SIGN BATHAMASAT
@@ -2523,6 +2654,7 @@
1B80..1B81 ; Case_Ignorable # Mn [2] SUNDANESE SIGN PANYECEK..SUNDANESE SIGN PANGLAYAR
1BA2..1BA5 ; Case_Ignorable # Mn [4] SUNDANESE CONSONANT SIGN PANYAKRA..SUNDANESE VOWEL SIGN PANYUKU
1BA8..1BA9 ; Case_Ignorable # Mn [2] SUNDANESE VOWEL SIGN PAMEPET..SUNDANESE VOWEL SIGN PANEULEUNG
+1BAB ; Case_Ignorable # Mn SUNDANESE SIGN VIRAMA
1BE6 ; Case_Ignorable # Mn BATAK SIGN TOMPI
1BE8..1BE9 ; Case_Ignorable # Mn [2] BATAK VOWEL SIGN PAKPAK E..BATAK VOWEL SIGN EE
1BED ; Case_Ignorable # Mn BATAK VOWEL SIGN KARO O
@@ -2534,7 +2666,8 @@
1CD4..1CE0 ; Case_Ignorable # Mn [13] VEDIC SIGN YAJURVEDIC MIDLINE SVARITA..VEDIC TONE RIGVEDIC KASHMIRI INDEPENDENT SVARITA
1CE2..1CE8 ; Case_Ignorable # Mn [7] VEDIC SIGN VISARGA SVARITA..VEDIC SIGN VISARGA ANUDATTA WITH TAIL
1CED ; Case_Ignorable # Mn VEDIC SIGN TIRYAK
-1D2C..1D61 ; Case_Ignorable # Lm [54] MODIFIER LETTER CAPITAL A..MODIFIER LETTER SMALL CHI
+1CF4 ; Case_Ignorable # Mn VEDIC TONE CANDRA ABOVE
+1D2C..1D6A ; Case_Ignorable # Lm [63] MODIFIER LETTER CAPITAL A..GREEK SUBSCRIPT SMALL LETTER CHI
1D78 ; Case_Ignorable # Lm MODIFIER LETTER CYRILLIC EN
1D9B..1DBF ; Case_Ignorable # Lm [37] MODIFIER LETTER SMALL TURNED ALPHA..MODIFIER LETTER SMALL THETA
1DC0..1DE6 ; Case_Ignorable # Mn [39] COMBINING DOTTED GRAVE ACCENT..COMBINING LATIN SMALL LETTER Z
@@ -2561,7 +2694,7 @@
20E1 ; Case_Ignorable # Mn COMBINING LEFT RIGHT ARROW ABOVE
20E2..20E4 ; Case_Ignorable # Me [3] COMBINING ENCLOSING SCREEN..COMBINING ENCLOSING UPWARD POINTING TRIANGLE
20E5..20F0 ; Case_Ignorable # Mn [12] COMBINING REVERSE SOLIDUS OVERLAY..COMBINING ASTERISK ABOVE
-2C7D ; Case_Ignorable # Lm MODIFIER LETTER CAPITAL V
+2C7C..2C7D ; Case_Ignorable # Lm [2] LATIN SUBSCRIPT SMALL LETTER J..MODIFIER LETTER CAPITAL V
2CEF..2CF1 ; Case_Ignorable # Mn [3] COPTIC COMBINING NI ABOVE..COPTIC COMBINING SPIRITUS LENIS
2D6F ; Case_Ignorable # Lm TIFINAGH MODIFIER LETTER LABIALIZATION MARK
2D7F ; Case_Ignorable # Mn TIFINAGH CONSONANT JOINER
@@ -2568,7 +2701,7 @@
2DE0..2DFF ; Case_Ignorable # Mn [32] COMBINING CYRILLIC LETTER BE..COMBINING CYRILLIC LETTER IOTIFIED BIG YUS
2E2F ; Case_Ignorable # Lm VERTICAL TILDE
3005 ; Case_Ignorable # Lm IDEOGRAPHIC ITERATION MARK
-302A..302F ; Case_Ignorable # Mn [6] IDEOGRAPHIC LEVEL TONE MARK..HANGUL DOUBLE DOT TONE MARK
+302A..302D ; Case_Ignorable # Mn [4] IDEOGRAPHIC LEVEL TONE MARK..IDEOGRAPHIC ENTERING TONE MARK
3031..3035 ; Case_Ignorable # Lm [5] VERTICAL KANA REPEAT MARK..VERTICAL KANA REPEAT MARK LOWER HALF
303B ; Case_Ignorable # Lm VERTICAL IDEOGRAPHIC ITERATION MARK
3099..309A ; Case_Ignorable # Mn [2] COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK..COMBINING KATAKANA-HIRAGANA SEMI-VOICED SOUND MARK
@@ -2580,8 +2713,9 @@
A60C ; Case_Ignorable # Lm VAI SYLLABLE LENGTHENER
A66F ; Case_Ignorable # Mn COMBINING CYRILLIC VZMET
A670..A672 ; Case_Ignorable # Me [3] COMBINING CYRILLIC TEN MILLIONS SIGN..COMBINING CYRILLIC THOUSAND MILLIONS SIGN
-A67C..A67D ; Case_Ignorable # Mn [2] COMBINING CYRILLIC KAVYKA..COMBINING CYRILLIC PAYEROK
+A674..A67D ; Case_Ignorable # Mn [10] COMBINING CYRILLIC LETTER UKRAINIAN IE..COMBINING CYRILLIC PAYEROK
A67F ; Case_Ignorable # Lm CYRILLIC PAYEROK
+A69F ; Case_Ignorable # Mn COMBINING CYRILLIC LETTER IOTIFIED E
A6F0..A6F1 ; Case_Ignorable # Mn [2] BAMUM COMBINING MARK KOQNDON..BAMUM COMBINING MARK TUKWENTIS
A700..A716 ; Case_Ignorable # Sk [23] MODIFIER LETTER CHINESE TONE YIN PING..MODIFIER LETTER EXTRA-LOW LEFT-STEM TONE BAR
A717..A71F ; Case_Ignorable # Lm [9] MODIFIER LETTER DOT VERTICAL BAR..MODIFIER LETTER LOW INVERTED EXCLAMATION MARK
@@ -2589,6 +2723,7 @@
A770 ; Case_Ignorable # Lm MODIFIER LETTER US
A788 ; Case_Ignorable # Lm MODIFIER LETTER LOW CIRCUMFLEX ACCENT
A789..A78A ; Case_Ignorable # Sk [2] MODIFIER LETTER COLON..MODIFIER LETTER SHORT EQUALS SIGN
+A7F8..A7F9 ; Case_Ignorable # Lm [2] MODIFIER LETTER CAPITAL H WITH STROKE..MODIFIER LETTER SMALL LIGATURE OE
A802 ; Case_Ignorable # Mn SYLOTI NAGRI SIGN DVISVARA
A806 ; Case_Ignorable # Mn SYLOTI NAGRI SIGN HASANTA
A80B ; Case_Ignorable # Mn SYLOTI NAGRI SIGN ANUSVARA
@@ -2614,6 +2749,9 @@
AABE..AABF ; Case_Ignorable # Mn [2] TAI VIET VOWEL AM..TAI VIET TONE MAI EK
AAC1 ; Case_Ignorable # Mn TAI VIET TONE MAI THO
AADD ; Case_Ignorable # Lm TAI VIET SYMBOL SAM
+AAEC..AAED ; Case_Ignorable # Mn [2] MEETEI MAYEK VOWEL SIGN UU..MEETEI MAYEK VOWEL SIGN AAI
+AAF3..AAF4 ; Case_Ignorable # Lm [2] MEETEI MAYEK SYLLABLE REPETITION MARK..MEETEI MAYEK WORD REPETITION MARK
+AAF6 ; Case_Ignorable # Mn MEETEI MAYEK VIRAMA
ABE5 ; Case_Ignorable # Mn MEETEI MAYEK VOWEL SIGN ANAP
ABE8 ; Case_Ignorable # Mn MEETEI MAYEK VOWEL SIGN UNAP
ABED ; Case_Ignorable # Mn MEETEI MAYEK APUN IYEK
@@ -2646,6 +2784,17 @@
110B3..110B6 ; Case_Ignorable # Mn [4] KAITHI VOWEL SIGN U..KAITHI VOWEL SIGN AI
110B9..110BA ; Case_Ignorable # Mn [2] KAITHI SIGN VIRAMA..KAITHI SIGN NUKTA
110BD ; Case_Ignorable # Cf KAITHI NUMBER SIGN
+11100..11102 ; Case_Ignorable # Mn [3] CHAKMA SIGN CANDRABINDU..CHAKMA SIGN VISARGA
+11127..1112B ; Case_Ignorable # Mn [5] CHAKMA VOWEL SIGN A..CHAKMA VOWEL SIGN UU
+1112D..11134 ; Case_Ignorable # Mn [8] CHAKMA VOWEL SIGN AI..CHAKMA MAAYYAA
+11180..11181 ; Case_Ignorable # Mn [2] SHARADA SIGN CANDRABINDU..SHARADA SIGN ANUSVARA
+111B6..111BE ; Case_Ignorable # Mn [9] SHARADA VOWEL SIGN U..SHARADA VOWEL SIGN O
+116AB ; Case_Ignorable # Mn TAKRI SIGN ANUSVARA
+116AD ; Case_Ignorable # Mn TAKRI VOWEL SIGN AA
+116B0..116B5 ; Case_Ignorable # Mn [6] TAKRI VOWEL SIGN U..TAKRI VOWEL SIGN AU
+116B7 ; Case_Ignorable # Mn TAKRI SIGN NUKTA
+16F8F..16F92 ; Case_Ignorable # Mn [4] MIAO TONE RIGHT..MIAO TONE BELOW
+16F93..16F9F ; Case_Ignorable # Lm [13] MIAO LETTER TONE-2..MIAO LETTER REFORMED TONE-8
1D167..1D169 ; Case_Ignorable # Mn [3] MUSICAL SYMBOL COMBINING TREMOLO-1..MUSICAL SYMBOL COMBINING TREMOLO-3
1D173..1D17A ; Case_Ignorable # Cf [8] MUSICAL SYMBOL BEGIN BEAM..MUSICAL SYMBOL END PHRASE
1D17B..1D182 ; Case_Ignorable # Mn [8] MUSICAL SYMBOL COMBINING ACCENT..MUSICAL SYMBOL COMBINING LOURE
@@ -2656,7 +2805,7 @@
E0020..E007F ; Case_Ignorable # Cf [96] TAG SPACE..CANCEL TAG
E0100..E01EF ; Case_Ignorable # Mn [240] VARIATION SELECTOR-17..VARIATION SELECTOR-256
-# Total code points: 1692
+# Total code points: 1799
# ================================================
@@ -2932,6 +3081,8 @@
0526 ; Changes_When_Lowercased # L& CYRILLIC CAPITAL LETTER SHHA WITH DESCENDER
0531..0556 ; Changes_When_Lowercased # L& [38] ARMENIAN CAPITAL LETTER AYB..ARMENIAN CAPITAL LETTER FEH
10A0..10C5 ; Changes_When_Lowercased # L& [38] GEORGIAN CAPITAL LETTER AN..GEORGIAN CAPITAL LETTER HOE
+10C7 ; Changes_When_Lowercased # L& GEORGIAN CAPITAL LETTER YN
+10CD ; Changes_When_Lowercased # L& GEORGIAN CAPITAL LETTER AEN
1E00 ; Changes_When_Lowercased # L& LATIN CAPITAL LETTER A WITH RING BELOW
1E02 ; Changes_When_Lowercased # L& LATIN CAPITAL LETTER B WITH DOT ABOVE
1E04 ; Changes_When_Lowercased # L& LATIN CAPITAL LETTER B WITH DOT BELOW
@@ -3141,6 +3292,7 @@
2CE2 ; Changes_When_Lowercased # L& COPTIC CAPITAL LETTER OLD NUBIAN WAU
2CEB ; Changes_When_Lowercased # L& COPTIC CAPITAL LETTER CRYPTOGRAMMIC SHEI
2CED ; Changes_When_Lowercased # L& COPTIC CAPITAL LETTER CRYPTOGRAMMIC GANGIA
+2CF2 ; Changes_When_Lowercased # L& COPTIC CAPITAL LETTER BOHAIRIC KHEI
A640 ; Changes_When_Lowercased # L& CYRILLIC CAPITAL LETTER ZEMLYA
A642 ; Changes_When_Lowercased # L& CYRILLIC CAPITAL LETTER DZELO
A644 ; Changes_When_Lowercased # L& CYRILLIC CAPITAL LETTER REVERSED DZE
@@ -3224,15 +3376,17 @@
A78B ; Changes_When_Lowercased # L& LATIN CAPITAL LETTER SALTILLO
A78D ; Changes_When_Lowercased # L& LATIN CAPITAL LETTER TURNED H
A790 ; Changes_When_Lowercased # L& LATIN CAPITAL LETTER N WITH DESCENDER
+A792 ; Changes_When_Lowercased # L& LATIN CAPITAL LETTER C WITH BAR
A7A0 ; Changes_When_Lowercased # L& LATIN CAPITAL LETTER G WITH OBLIQUE STROKE
A7A2 ; Changes_When_Lowercased # L& LATIN CAPITAL LETTER K WITH OBLIQUE STROKE
A7A4 ; Changes_When_Lowercased # L& LATIN CAPITAL LETTER N WITH OBLIQUE STROKE
A7A6 ; Changes_When_Lowercased # L& LATIN CAPITAL LETTER R WITH OBLIQUE STROKE
A7A8 ; Changes_When_Lowercased # L& LATIN CAPITAL LETTER S WITH OBLIQUE STROKE
+A7AA ; Changes_When_Lowercased # L& LATIN CAPITAL LETTER H WITH HOOK
FF21..FF3A ; Changes_When_Lowercased # L& [26] FULLWIDTH LATIN CAPITAL LETTER A..FULLWIDTH LATIN CAPITAL LETTER Z
10400..10427 ; Changes_When_Lowercased # L& [40] DESERET CAPITAL LETTER LONG I..DESERET CAPITAL LETTER EW
-# Total code points: 1038
+# Total code points: 1043
# ================================================
@@ -3390,7 +3544,7 @@
025B ; Changes_When_Uppercased # L& LATIN SMALL LETTER OPEN E
0260 ; Changes_When_Uppercased # L& LATIN SMALL LETTER G WITH HOOK
0263 ; Changes_When_Uppercased # L& LATIN SMALL LETTER GAMMA
-0265 ; Changes_When_Uppercased # L& LATIN SMALL LETTER TURNED H
+0265..0266 ; Changes_When_Uppercased # L& [2] LATIN SMALL LETTER TURNED H..LATIN SMALL LETTER H WITH HOOK
0268..0269 ; Changes_When_Uppercased # L& [2] LATIN SMALL LETTER I WITH STROKE..LATIN SMALL LETTER IOTA
026B ; Changes_When_Uppercased # L& LATIN SMALL LETTER L WITH MIDDLE TILDE
026F ; Changes_When_Uppercased # L& LATIN SMALL LETTER TURNED M
@@ -3731,7 +3885,10 @@
2CE3 ; Changes_When_Uppercased # L& COPTIC SMALL LETTER OLD NUBIAN WAU
2CEC ; Changes_When_Uppercased # L& COPTIC SMALL LETTER CRYPTOGRAMMIC SHEI
2CEE ; Changes_When_Uppercased # L& COPTIC SMALL LETTER CRYPTOGRAMMIC GANGIA
+2CF3 ; Changes_When_Uppercased # L& COPTIC SMALL LETTER BOHAIRIC KHEI
2D00..2D25 ; Changes_When_Uppercased # L& [38] GEORGIAN SMALL LETTER AN..GEORGIAN SMALL LETTER HOE
+2D27 ; Changes_When_Uppercased # L& GEORGIAN SMALL LETTER YN
+2D2D ; Changes_When_Uppercased # L& GEORGIAN SMALL LETTER AEN
A641 ; Changes_When_Uppercased # L& CYRILLIC SMALL LETTER ZEMLYA
A643 ; Changes_When_Uppercased # L& CYRILLIC SMALL LETTER DZELO
A645 ; Changes_When_Uppercased # L& CYRILLIC SMALL LETTER REVERSED DZE
@@ -3814,6 +3971,7 @@
A787 ; Changes_When_Uppercased # L& LATIN SMALL LETTER INSULAR T
A78C ; Changes_When_Uppercased # L& LATIN SMALL LETTER SALTILLO
A791 ; Changes_When_Uppercased # L& LATIN SMALL LETTER N WITH DESCENDER
+A793 ; Changes_When_Uppercased # L& LATIN SMALL LETTER C WITH BAR
A7A1 ; Changes_When_Uppercased # L& LATIN SMALL LETTER G WITH OBLIQUE STROKE
A7A3 ; Changes_When_Uppercased # L& LATIN SMALL LETTER K WITH OBLIQUE STROKE
A7A5 ; Changes_When_Uppercased # L& LATIN SMALL LETTER N WITH OBLIQUE STROKE
@@ -3824,7 +3982,7 @@
FF41..FF5A ; Changes_When_Uppercased # L& [26] FULLWIDTH LATIN SMALL LETTER A..FULLWIDTH LATIN SMALL LETTER Z
10428..1044F ; Changes_When_Uppercased # L& [40] DESERET SMALL LETTER LONG I..DESERET SMALL LETTER EW
-# Total code points: 1121
+# Total code points: 1126
# ================================================
@@ -3983,7 +4141,7 @@
025B ; Changes_When_Titlecased # L& LATIN SMALL LETTER OPEN E
0260 ; Changes_When_Titlecased # L& LATIN SMALL LETTER G WITH HOOK
0263 ; Changes_When_Titlecased # L& LATIN SMALL LETTER GAMMA
-0265 ; Changes_When_Titlecased # L& LATIN SMALL LETTER TURNED H
+0265..0266 ; Changes_When_Titlecased # L& [2] LATIN SMALL LETTER TURNED H..LATIN SMALL LETTER H WITH HOOK
0268..0269 ; Changes_When_Titlecased # L& [2] LATIN SMALL LETTER I WITH STROKE..LATIN SMALL LETTER IOTA
026B ; Changes_When_Titlecased # L& LATIN SMALL LETTER L WITH MIDDLE TILDE
026F ; Changes_When_Titlecased # L& LATIN SMALL LETTER TURNED M
@@ -4324,7 +4482,10 @@
2CE3 ; Changes_When_Titlecased # L& COPTIC SMALL LETTER OLD NUBIAN WAU
2CEC ; Changes_When_Titlecased # L& COPTIC SMALL LETTER CRYPTOGRAMMIC SHEI
2CEE ; Changes_When_Titlecased # L& COPTIC SMALL LETTER CRYPTOGRAMMIC GANGIA
+2CF3 ; Changes_When_Titlecased # L& COPTIC SMALL LETTER BOHAIRIC KHEI
2D00..2D25 ; Changes_When_Titlecased # L& [38] GEORGIAN SMALL LETTER AN..GEORGIAN SMALL LETTER HOE
+2D27 ; Changes_When_Titlecased # L& GEORGIAN SMALL LETTER YN
+2D2D ; Changes_When_Titlecased # L& GEORGIAN SMALL LETTER AEN
A641 ; Changes_When_Titlecased # L& CYRILLIC SMALL LETTER ZEMLYA
A643 ; Changes_When_Titlecased # L& CYRILLIC SMALL LETTER DZELO
A645 ; Changes_When_Titlecased # L& CYRILLIC SMALL LETTER REVERSED DZE
@@ -4407,6 +4568,7 @@
A787 ; Changes_When_Titlecased # L& LATIN SMALL LETTER INSULAR T
A78C ; Changes_When_Titlecased # L& LATIN SMALL LETTER SALTILLO
A791 ; Changes_When_Titlecased # L& LATIN SMALL LETTER N WITH DESCENDER
+A793 ; Changes_When_Titlecased # L& LATIN SMALL LETTER C WITH BAR
A7A1 ; Changes_When_Titlecased # L& LATIN SMALL LETTER G WITH OBLIQUE STROKE
A7A3 ; Changes_When_Titlecased # L& LATIN SMALL LETTER K WITH OBLIQUE STROKE
A7A5 ; Changes_When_Titlecased # L& LATIN SMALL LETTER N WITH OBLIQUE STROKE
@@ -4417,7 +4579,7 @@
FF41..FF5A ; Changes_When_Titlecased # L& [26] FULLWIDTH LATIN SMALL LETTER A..FULLWIDTH LATIN SMALL LETTER Z
10428..1044F ; Changes_When_Titlecased # L& [40] DESERET SMALL LETTER LONG I..DESERET SMALL LETTER EW
-# Total code points: 1094
+# Total code points: 1099
# ================================================
@@ -4700,6 +4862,8 @@
0531..0556 ; Changes_When_Casefolded # L& [38] ARMENIAN CAPITAL LETTER AYB..ARMENIAN CAPITAL LETTER FEH
0587 ; Changes_When_Casefolded # L& ARMENIAN SMALL LIGATURE ECH YIWN
10A0..10C5 ; Changes_When_Casefolded # L& [38] GEORGIAN CAPITAL LETTER AN..GEORGIAN CAPITAL LETTER HOE
+10C7 ; Changes_When_Casefolded # L& GEORGIAN CAPITAL LETTER YN
+10CD ; Changes_When_Casefolded # L& GEORGIAN CAPITAL LETTER AEN
1E00 ; Changes_When_Casefolded # L& LATIN CAPITAL LETTER A WITH RING BELOW
1E02 ; Changes_When_Casefolded # L& LATIN CAPITAL LETTER B WITH DOT ABOVE
1E04 ; Changes_When_Casefolded # L& LATIN CAPITAL LETTER B WITH DOT BELOW
@@ -4911,6 +5075,7 @@
2CE2 ; Changes_When_Casefolded # L& COPTIC CAPITAL LETTER OLD NUBIAN WAU
2CEB ; Changes_When_Casefolded # L& COPTIC CAPITAL LETTER CRYPTOGRAMMIC SHEI
2CED ; Changes_When_Casefolded # L& COPTIC CAPITAL LETTER CRYPTOGRAMMIC GANGIA
+2CF2 ; Changes_When_Casefolded # L& COPTIC CAPITAL LETTER BOHAIRIC KHEI
A640 ; Changes_When_Casefolded # L& CYRILLIC CAPITAL LETTER ZEMLYA
A642 ; Changes_When_Casefolded # L& CYRILLIC CAPITAL LETTER DZELO
A644 ; Changes_When_Casefolded # L& CYRILLIC CAPITAL LETTER REVERSED DZE
@@ -4994,17 +5159,19 @@
A78B ; Changes_When_Casefolded # L& LATIN CAPITAL LETTER SALTILLO
A78D ; Changes_When_Casefolded # L& LATIN CAPITAL LETTER TURNED H
A790 ; Changes_When_Casefolded # L& LATIN CAPITAL LETTER N WITH DESCENDER
+A792 ; Changes_When_Casefolded # L& LATIN CAPITAL LETTER C WITH BAR
A7A0 ; Changes_When_Casefolded # L& LATIN CAPITAL LETTER G WITH OBLIQUE STROKE
A7A2 ; Changes_When_Casefolded # L& LATIN CAPITAL LETTER K WITH OBLIQUE STROKE
A7A4 ; Changes_When_Casefolded # L& LATIN CAPITAL LETTER N WITH OBLIQUE STROKE
A7A6 ; Changes_When_Casefolded # L& LATIN CAPITAL LETTER R WITH OBLIQUE STROKE
A7A8 ; Changes_When_Casefolded # L& LATIN CAPITAL LETTER S WITH OBLIQUE STROKE
+A7AA ; Changes_When_Casefolded # L& LATIN CAPITAL LETTER H WITH HOOK
FB00..FB06 ; Changes_When_Casefolded # L& [7] LATIN SMALL LIGATURE FF..LATIN SMALL LIGATURE ST
FB13..FB17 ; Changes_When_Casefolded # L& [5] ARMENIAN SMALL LIGATURE MEN NOW..ARMENIAN SMALL LIGATURE MEN XEH
FF21..FF3A ; Changes_When_Casefolded # L& [26] FULLWIDTH LATIN CAPITAL LETTER A..FULLWIDTH LATIN CAPITAL LETTER Z
10400..10427 ; Changes_When_Casefolded # L& [40] DESERET CAPITAL LETTER LONG I..DESERET CAPITAL LETTER EW
-# Total code points: 1102
+# Total code points: 1107
# ================================================
@@ -5033,7 +5200,7 @@
025B ; Changes_When_Casemapped # L& LATIN SMALL LETTER OPEN E
0260 ; Changes_When_Casemapped # L& LATIN SMALL LETTER G WITH HOOK
0263 ; Changes_When_Casemapped # L& LATIN SMALL LETTER GAMMA
-0265 ; Changes_When_Casemapped # L& LATIN SMALL LETTER TURNED H
+0265..0266 ; Changes_When_Casemapped # L& [2] LATIN SMALL LETTER TURNED H..LATIN SMALL LETTER H WITH HOOK
0268..0269 ; Changes_When_Casemapped # L& [2] LATIN SMALL LETTER I WITH STROKE..LATIN SMALL LETTER IOTA
026B ; Changes_When_Casemapped # L& LATIN SMALL LETTER L WITH MIDDLE TILDE
026F ; Changes_When_Casemapped # L& LATIN SMALL LETTER TURNED M
@@ -5061,6 +5228,8 @@
0531..0556 ; Changes_When_Casemapped # L& [38] ARMENIAN CAPITAL LETTER AYB..ARMENIAN CAPITAL LETTER FEH
0561..0587 ; Changes_When_Casemapped # L& [39] ARMENIAN SMALL LETTER AYB..ARMENIAN SMALL LIGATURE ECH YIWN
10A0..10C5 ; Changes_When_Casemapped # L& [38] GEORGIAN CAPITAL LETTER AN..GEORGIAN CAPITAL LETTER HOE
+10C7 ; Changes_When_Casemapped # L& GEORGIAN CAPITAL LETTER YN
+10CD ; Changes_When_Casemapped # L& GEORGIAN CAPITAL LETTER AEN
1D79 ; Changes_When_Casemapped # L& LATIN SMALL LETTER INSULAR G
1D7D ; Changes_When_Casemapped # L& LATIN SMALL LETTER P WITH STROKE
1E00..1E9B ; Changes_When_Casemapped # L& [156] LATIN CAPITAL LETTER A WITH RING BELOW..LATIN SMALL LETTER LONG S WITH DOT ABOVE
@@ -5098,7 +5267,10 @@
2C75..2C76 ; Changes_When_Casemapped # L& [2] LATIN CAPITAL LETTER HALF H..LATIN SMALL LETTER HALF H
2C7E..2CE3 ; Changes_When_Casemapped # L& [102] LATIN CAPITAL LETTER S WITH SWASH TAIL..COPTIC SMALL LETTER OLD NUBIAN WAU
2CEB..2CEE ; Changes_When_Casemapped # L& [4] COPTIC CAPITAL LETTER CRYPTOGRAMMIC SHEI..COPTIC SMALL LETTER CRYPTOGRAMMIC GANGIA
+2CF2..2CF3 ; Changes_When_Casemapped # L& [2] COPTIC CAPITAL LETTER BOHAIRIC KHEI..COPTIC SMALL LETTER BOHAIRIC KHEI
2D00..2D25 ; Changes_When_Casemapped # L& [38] GEORGIAN SMALL LETTER AN..GEORGIAN SMALL LETTER HOE
+2D27 ; Changes_When_Casemapped # L& GEORGIAN SMALL LETTER YN
+2D2D ; Changes_When_Casemapped # L& GEORGIAN SMALL LETTER AEN
A640..A66D ; Changes_When_Casemapped # L& [46] CYRILLIC CAPITAL LETTER ZEMLYA..CYRILLIC SMALL LETTER DOUBLE MONOCULAR O
A680..A697 ; Changes_When_Casemapped # L& [24] CYRILLIC CAPITAL LETTER DWE..CYRILLIC SMALL LETTER SHWE
A722..A72F ; Changes_When_Casemapped # L& [14] LATIN CAPITAL LETTER EGYPTOLOGICAL ALEF..LATIN SMALL LETTER CUATRILLO WITH COMMA
@@ -5105,8 +5277,8 @@
A732..A76F ; Changes_When_Casemapped # L& [62] LATIN CAPITAL LETTER AA..LATIN SMALL LETTER CON
A779..A787 ; Changes_When_Casemapped # L& [15] LATIN CAPITAL LETTER INSULAR D..LATIN SMALL LETTER INSULAR T
A78B..A78D ; Changes_When_Casemapped # L& [3] LATIN CAPITAL LETTER SALTILLO..LATIN CAPITAL LETTER TURNED H
-A790..A791 ; Changes_When_Casemapped # L& [2] LATIN CAPITAL LETTER N WITH DESCENDER..LATIN SMALL LETTER N WITH DESCENDER
-A7A0..A7A9 ; Changes_When_Casemapped # L& [10] LATIN CAPITAL LETTER G WITH OBLIQUE STROKE..LATIN SMALL LETTER S WITH OBLIQUE STROKE
+A790..A793 ; Changes_When_Casemapped # L& [4] LATIN CAPITAL LETTER N WITH DESCENDER..LATIN SMALL LETTER C WITH BAR
+A7A0..A7AA ; Changes_When_Casemapped # L& [11] LATIN CAPITAL LETTER G WITH OBLIQUE STROKE..LATIN CAPITAL LETTER H WITH HOOK
FB00..FB06 ; Changes_When_Casemapped # L& [7] LATIN SMALL LIGATURE FF..LATIN SMALL LIGATURE ST
FB13..FB17 ; Changes_When_Casemapped # L& [5] ARMENIAN SMALL LIGATURE MEN NOW..ARMENIAN SMALL LIGATURE MEN XEH
FF21..FF3A ; Changes_When_Casemapped # L& [26] FULLWIDTH LATIN CAPITAL LETTER A..FULLWIDTH LATIN CAPITAL LETTER Z
@@ -5113,7 +5285,7 @@
FF41..FF5A ; Changes_When_Casemapped # L& [26] FULLWIDTH LATIN SMALL LETTER A..FULLWIDTH LATIN SMALL LETTER Z
10400..1044F ; Changes_When_Casemapped # L& [80] DESERET CAPITAL LETTER LONG I..DESERET SMALL LETTER EW
-# Total code points: 2128
+# Total code points: 2138
# ================================================
@@ -5128,9 +5300,9 @@
0041..005A ; ID_Start # L& [26] LATIN CAPITAL LETTER A..LATIN CAPITAL LETTER Z
0061..007A ; ID_Start # L& [26] LATIN SMALL LETTER A..LATIN SMALL LETTER Z
-00AA ; ID_Start # L& FEMININE ORDINAL INDICATOR
+00AA ; ID_Start # Lo FEMININE ORDINAL INDICATOR
00B5 ; ID_Start # L& MICRO SIGN
-00BA ; ID_Start # L& MASCULINE ORDINAL INDICATOR
+00BA ; ID_Start # Lo MASCULINE ORDINAL INDICATOR
00C0..00D6 ; ID_Start # L& [23] LATIN CAPITAL LETTER A WITH GRAVE..LATIN CAPITAL LETTER O WITH DIAERESIS
00D8..00F6 ; ID_Start # L& [31] LATIN CAPITAL LETTER O WITH STROKE..LATIN SMALL LETTER O WITH DIAERESIS
00F8..01BA ; ID_Start # L& [195] LATIN SMALL LETTER O WITH STROKE..LATIN SMALL LETTER EZH WITH TAIL
@@ -5184,6 +5356,8 @@
0824 ; ID_Start # Lm SAMARITAN MODIFIER LETTER SHORT A
0828 ; ID_Start # Lm SAMARITAN MODIFIER LETTER I
0840..0858 ; ID_Start # Lo [25] MANDAIC LETTER HALQA..MANDAIC LETTER AIN
+08A0 ; ID_Start # Lo ARABIC LETTER BEH WITH SMALL V BELOW
+08A2..08AC ; ID_Start # Lo [11] ARABIC LETTER JEEM WITH TWO DOTS ABOVE..ARABIC LETTER ROHINGYA YEH
0904..0939 ; ID_Start # Lo [54] DEVANAGARI LETTER SHORT A..DEVANAGARI LETTER HA
093D ; ID_Start # Lo DEVANAGARI SIGN AVAGRAHA
0950 ; ID_Start # Lo DEVANAGARI OM
@@ -5291,7 +5465,7 @@
0EBD ; ID_Start # Lo LAO SEMIVOWEL SIGN NYO
0EC0..0EC4 ; ID_Start # Lo [5] LAO VOWEL SIGN E..LAO VOWEL SIGN AI
0EC6 ; ID_Start # Lm LAO KO LA
-0EDC..0EDD ; ID_Start # Lo [2] LAO HO NO..LAO HO MO
+0EDC..0EDF ; ID_Start # Lo [4] LAO HO NO..LAO LETTER KHMU NYO
0F00 ; ID_Start # Lo TIBETAN SYLLABLE OM
0F40..0F47 ; ID_Start # Lo [8] TIBETAN LETTER KA..TIBETAN LETTER JA
0F49..0F6C ; ID_Start # Lo [36] TIBETAN LETTER NYA..TIBETAN LETTER RRA
@@ -5306,9 +5480,11 @@
1075..1081 ; ID_Start # Lo [13] MYANMAR LETTER SHAN KA..MYANMAR LETTER SHAN HA
108E ; ID_Start # Lo MYANMAR LETTER RUMAI PALAUNG FA
10A0..10C5 ; ID_Start # L& [38] GEORGIAN CAPITAL LETTER AN..GEORGIAN CAPITAL LETTER HOE
+10C7 ; ID_Start # L& GEORGIAN CAPITAL LETTER YN
+10CD ; ID_Start # L& GEORGIAN CAPITAL LETTER AEN
10D0..10FA ; ID_Start # Lo [43] GEORGIAN LETTER AN..GEORGIAN LETTER AIN
10FC ; ID_Start # Lm MODIFIER LETTER GEORGIAN NAR
-1100..1248 ; ID_Start # Lo [329] HANGUL CHOSEONG KIYEOK..ETHIOPIC SYLLABLE QWA
+10FD..1248 ; ID_Start # Lo [332] GEORGIAN LETTER AEN..ETHIOPIC SYLLABLE QWA
124A..124D ; ID_Start # Lo [4] ETHIOPIC SYLLABLE QWI..ETHIOPIC SYLLABLE QWE
1250..1256 ; ID_Start # Lo [7] ETHIOPIC SYLLABLE QHA..ETHIOPIC SYLLABLE QHO
1258 ; ID_Start # Lo ETHIOPIC SYLLABLE QHWA
@@ -5358,7 +5534,7 @@
1B45..1B4B ; ID_Start # Lo [7] BALINESE LETTER KAF SASAK..BALINESE LETTER ASYURA SASAK
1B83..1BA0 ; ID_Start # Lo [30] SUNDANESE LETTER A..SUNDANESE LETTER HA
1BAE..1BAF ; ID_Start # Lo [2] SUNDANESE LETTER KHA..SUNDANESE LETTER SYA
-1BC0..1BE5 ; ID_Start # Lo [38] BATAK LETTER A..BATAK LETTER U
+1BBA..1BE5 ; ID_Start # Lo [44] SUNDANESE AVAGRAHA..BATAK LETTER U
1C00..1C23 ; ID_Start # Lo [36] LEPCHA LETTER KA..LEPCHA LETTER A
1C4D..1C4F ; ID_Start # Lo [3] LEPCHA LETTER TTA..LEPCHA LETTER DDA
1C5A..1C77 ; ID_Start # Lo [30] OL CHIKI LETTER LA..OL CHIKI LETTER OH
@@ -5365,9 +5541,10 @@
1C78..1C7D ; ID_Start # Lm [6] OL CHIKI MU TTUDDAG..OL CHIKI AHAD
1CE9..1CEC ; ID_Start # Lo [4] VEDIC SIGN ANUSVARA ANTARGOMUKHA..VEDIC SIGN ANUSVARA VAMAGOMUKHA WITH TAIL
1CEE..1CF1 ; ID_Start # Lo [4] VEDIC SIGN HEXIFORM LONG ANUSVARA..VEDIC SIGN ANUSVARA UBHAYATO MUKHA
+1CF5..1CF6 ; ID_Start # Lo [2] VEDIC SIGN JIHVAMULIYA..VEDIC SIGN UPADHMANIYA
1D00..1D2B ; ID_Start # L& [44] LATIN LETTER SMALL CAPITAL A..CYRILLIC LETTER SMALL CAPITAL EL
-1D2C..1D61 ; ID_Start # Lm [54] MODIFIER LETTER CAPITAL A..MODIFIER LETTER SMALL CHI
-1D62..1D77 ; ID_Start # L& [22] LATIN SUBSCRIPT SMALL LETTER I..LATIN SMALL LETTER TURNED G
+1D2C..1D6A ; ID_Start # Lm [63] MODIFIER LETTER CAPITAL A..GREEK SUBSCRIPT SMALL LETTER CHI
+1D6B..1D77 ; ID_Start # L& [13] LATIN SMALL LETTER UE..LATIN SMALL LETTER TURNED G
1D78 ; ID_Start # Lm MODIFIER LETTER CYRILLIC EN
1D79..1D9A ; ID_Start # L& [34] LATIN SMALL LETTER INSULAR G..LATIN SMALL LETTER EZH WITH RETROFLEX HOOK
1D9B..1DBF ; ID_Start # Lm [37] MODIFIER LETTER SMALL TURNED ALPHA..MODIFIER LETTER SMALL THETA
@@ -5415,12 +5592,15 @@
2185..2188 ; ID_Start # Nl [4] ROMAN NUMERAL SIX LATE FORM..ROMAN NUMERAL ONE HUNDRED THOUSAND
2C00..2C2E ; ID_Start # L& [47] GLAGOLITIC CAPITAL LETTER AZU..GLAGOLITIC CAPITAL LETTER LATINATE MYSLITE
2C30..2C5E ; ID_Start # L& [47] GLAGOLITIC SMALL LETTER AZU..GLAGOLITIC SMALL LETTER LATINATE MYSLITE
-2C60..2C7C ; ID_Start # L& [29] LATIN CAPITAL LETTER L WITH DOUBLE BAR..LATIN SUBSCRIPT SMALL LETTER J
-2C7D ; ID_Start # Lm MODIFIER LETTER CAPITAL V
+2C60..2C7B ; ID_Start # L& [28] LATIN CAPITAL LETTER L WITH DOUBLE BAR..LATIN LETTER SMALL CAPITAL TURNED E
+2C7C..2C7D ; ID_Start # Lm [2] LATIN SUBSCRIPT SMALL LETTER J..MODIFIER LETTER CAPITAL V
2C7E..2CE4 ; ID_Start # L& [103] LATIN CAPITAL LETTER S WITH SWASH TAIL..COPTIC SYMBOL KAI
2CEB..2CEE ; ID_Start # L& [4] COPTIC CAPITAL LETTER CRYPTOGRAMMIC SHEI..COPTIC SMALL LETTER CRYPTOGRAMMIC GANGIA
+2CF2..2CF3 ; ID_Start # L& [2] COPTIC CAPITAL LETTER BOHAIRIC KHEI..COPTIC SMALL LETTER BOHAIRIC KHEI
2D00..2D25 ; ID_Start # L& [38] GEORGIAN SMALL LETTER AN..GEORGIAN SMALL LETTER HOE
-2D30..2D65 ; ID_Start # Lo [54] TIFINAGH LETTER YA..TIFINAGH LETTER YAZZ
+2D27 ; ID_Start # L& GEORGIAN SMALL LETTER YN
+2D2D ; ID_Start # L& GEORGIAN SMALL LETTER AEN
+2D30..2D67 ; ID_Start # Lo [56] TIFINAGH LETTER YA..TIFINAGH LETTER YO
2D6F ; ID_Start # Lm TIFINAGH MODIFIER LETTER LABIALIZATION MARK
2D80..2D96 ; ID_Start # Lo [23] ETHIOPIC SYLLABLE LOA..ETHIOPIC SYLLABLE GGWE
2DA0..2DA6 ; ID_Start # Lo [7] ETHIOPIC SYLLABLE SSA..ETHIOPIC SYLLABLE SSO
@@ -5451,7 +5631,7 @@
31A0..31BA ; ID_Start # Lo [27] BOPOMOFO LETTER BU..BOPOMOFO LETTER ZY
31F0..31FF ; ID_Start # Lo [16] KATAKANA LETTER SMALL KU..KATAKANA LETTER SMALL RO
3400..4DB5 ; ID_Start # Lo [6582] CJK UNIFIED IDEOGRAPH-3400..CJK UNIFIED IDEOGRAPH-4DB5
-4E00..9FCB ; ID_Start # Lo [20940] CJK UNIFIED IDEOGRAPH-4E00..CJK UNIFIED IDEOGRAPH-9FCB
+4E00..9FCC ; ID_Start # Lo [20941] CJK UNIFIED IDEOGRAPH-4E00..CJK UNIFIED IDEOGRAPH-9FCC
A000..A014 ; ID_Start # Lo [21] YI SYLLABLE IT..YI SYLLABLE E
A015 ; ID_Start # Lm YI SYLLABLE WU
A016..A48C ; ID_Start # Lo [1143] YI SYLLABLE BIT..YI SYLLABLE YYR
@@ -5473,8 +5653,9 @@
A771..A787 ; ID_Start # L& [23] LATIN SMALL LETTER DUM..LATIN SMALL LETTER INSULAR T
A788 ; ID_Start # Lm MODIFIER LETTER LOW CIRCUMFLEX ACCENT
A78B..A78E ; ID_Start # L& [4] LATIN CAPITAL LETTER SALTILLO..LATIN SMALL LETTER L WITH RETROFLEX HOOK AND BELT
-A790..A791 ; ID_Start # L& [2] LATIN CAPITAL LETTER N WITH DESCENDER..LATIN SMALL LETTER N WITH DESCENDER
-A7A0..A7A9 ; ID_Start # L& [10] LATIN CAPITAL LETTER G WITH OBLIQUE STROKE..LATIN SMALL LETTER S WITH OBLIQUE STROKE
+A790..A793 ; ID_Start # L& [4] LATIN CAPITAL LETTER N WITH DESCENDER..LATIN SMALL LETTER C WITH BAR
+A7A0..A7AA ; ID_Start # L& [11] LATIN CAPITAL LETTER G WITH OBLIQUE STROKE..LATIN CAPITAL LETTER H WITH HOOK
+A7F8..A7F9 ; ID_Start # Lm [2] MODIFIER LETTER CAPITAL H WITH STROKE..MODIFIER LETTER SMALL LIGATURE OE
A7FA ; ID_Start # L& LATIN LETTER SMALL CAPITAL TURNED M
A7FB..A801 ; ID_Start # Lo [7] LATIN EPIGRAPHIC LETTER REVERSED F..SYLOTI NAGRI LETTER I
A803..A805 ; ID_Start # Lo [3] SYLOTI NAGRI LETTER U..SYLOTI NAGRI LETTER O
@@ -5504,6 +5685,9 @@
AAC2 ; ID_Start # Lo TAI VIET TONE MAI SONG
AADB..AADC ; ID_Start # Lo [2] TAI VIET SYMBOL KON..TAI VIET SYMBOL NUENG
AADD ; ID_Start # Lm TAI VIET SYMBOL SAM
+AAE0..AAEA ; ID_Start # Lo [11] MEETEI MAYEK LETTER E..MEETEI MAYEK LETTER SSA
+AAF2 ; ID_Start # Lo MEETEI MAYEK ANJI
+AAF3..AAF4 ; ID_Start # Lm [2] MEETEI MAYEK SYLLABLE REPETITION MARK..MEETEI MAYEK WORD REPETITION MARK
AB01..AB06 ; ID_Start # Lo [6] ETHIOPIC SYLLABLE TTHU..ETHIOPIC SYLLABLE TTHO
AB09..AB0E ; ID_Start # Lo [6] ETHIOPIC SYLLABLE DDHU..ETHIOPIC SYLLABLE DDHO
AB11..AB16 ; ID_Start # Lo [6] ETHIOPIC SYLLABLE DZU..ETHIOPIC SYLLABLE DZO
@@ -5513,8 +5697,7 @@
AC00..D7A3 ; ID_Start # Lo [11172] HANGUL SYLLABLE GA..HANGUL SYLLABLE HIH
D7B0..D7C6 ; ID_Start # Lo [23] HANGUL JUNGSEONG O-YEO..HANGUL JUNGSEONG ARAEA-E
D7CB..D7FB ; ID_Start # Lo [49] HANGUL JONGSEONG NIEUN-RIEUL..HANGUL JONGSEONG PHIEUPH-THIEUTH
-F900..FA2D ; ID_Start # Lo [302] CJK COMPATIBILITY IDEOGRAPH-F900..CJK COMPATIBILITY IDEOGRAPH-FA2D
-FA30..FA6D ; ID_Start # Lo [62] CJK COMPATIBILITY IDEOGRAPH-FA30..CJK COMPATIBILITY IDEOGRAPH-FA6D
+F900..FA6D ; ID_Start # Lo [366] CJK COMPATIBILITY IDEOGRAPH-F900..CJK COMPATIBILITY IDEOGRAPH-FA6D
FA70..FAD9 ; ID_Start # Lo [106] CJK COMPATIBILITY IDEOGRAPH-FA70..CJK COMPATIBILITY IDEOGRAPH-FAD9
FB00..FB06 ; ID_Start # L& [7] LATIN SMALL LIGATURE FF..LATIN SMALL LIGATURE ST
FB13..FB17 ; ID_Start # L& [5] ARMENIAN SMALL LIGATURE MEN NOW..ARMENIAN SMALL LIGATURE MEN XEH
@@ -5572,6 +5755,8 @@
1083F..10855 ; ID_Start # Lo [23] CYPRIOT SYLLABLE ZO..IMPERIAL ARAMAIC LETTER TAW
10900..10915 ; ID_Start # Lo [22] PHOENICIAN LETTER ALF..PHOENICIAN LETTER TAU
10920..10939 ; ID_Start # Lo [26] LYDIAN LETTER A..LYDIAN LETTER C
+10980..109B7 ; ID_Start # Lo [56] MEROITIC HIEROGLYPHIC LETTER A..MEROITIC CURSIVE LETTER DA
+109BE..109BF ; ID_Start # Lo [2] MEROITIC CURSIVE LOGOGRAM RMT..MEROITIC CURSIVE LOGOGRAM IMN
10A00 ; ID_Start # Lo KHAROSHTHI LETTER A
10A10..10A13 ; ID_Start # Lo [4] KHAROSHTHI LETTER KA..KHAROSHTHI LETTER GHA
10A15..10A17 ; ID_Start # Lo [3] KHAROSHTHI LETTER CA..KHAROSHTHI LETTER JA
@@ -5583,10 +5768,18 @@
10C00..10C48 ; ID_Start # Lo [73] OLD TURKIC LETTER ORKHON A..OLD TURKIC LETTER ORKHON BASH
11003..11037 ; ID_Start # Lo [53] BRAHMI SIGN JIHVAMULIYA..BRAHMI LETTER OLD TAMIL NNNA
11083..110AF ; ID_Start # Lo [45] KAITHI LETTER A..KAITHI LETTER HA
+110D0..110E8 ; ID_Start # Lo [25] SORA SOMPENG LETTER SAH..SORA SOMPENG LETTER MAE
+11103..11126 ; ID_Start # Lo [36] CHAKMA LETTER AA..CHAKMA LETTER HAA
+11183..111B2 ; ID_Start # Lo [48] SHARADA LETTER A..SHARADA LETTER HA
+111C1..111C4 ; ID_Start # Lo [4] SHARADA SIGN AVAGRAHA..SHARADA OM
+11680..116AA ; ID_Start # Lo [43] TAKRI LETTER A..TAKRI LETTER RRA
12000..1236E ; ID_Start # Lo [879] CUNEIFORM SIGN A..CUNEIFORM SIGN ZUM
12400..12462 ; ID_Start # Nl [99] CUNEIFORM NUMERIC SIGN TWO ASH..CUNEIFORM NUMERIC SIGN OLD ASSYRIAN ONE QUARTER
13000..1342E ; ID_Start # Lo [1071] EGYPTIAN HIEROGLYPH A001..EGYPTIAN HIEROGLYPH AA032
16800..16A38 ; ID_Start # Lo [569] BAMUM LETTER PHASE-A NGKUE MFON..BAMUM LETTER PHASE-F VUEQ
+16F00..16F44 ; ID_Start # Lo [69] MIAO LETTER PA..MIAO LETTER HHA
+16F50 ; ID_Start # Lo MIAO LETTER NASALIZATION
+16F93..16F9F ; ID_Start # Lm [13] MIAO LETTER TONE-2..MIAO LETTER REFORMED TONE-8
1B000..1B001 ; ID_Start # Lo [2] KATAKANA LETTER ARCHAIC E..HIRAGANA LETTER ARCHAIC YE
1D400..1D454 ; ID_Start # L& [85] MATHEMATICAL BOLD CAPITAL A..MATHEMATICAL ITALIC SMALL G
1D456..1D49C ; ID_Start # L& [71] MATHEMATICAL ITALIC SMALL I..MATHEMATICAL SCRIPT CAPITAL A
@@ -5618,12 +5811,45 @@
1D78A..1D7A8 ; ID_Start # L& [31] MATHEMATICAL SANS-SERIF BOLD EPSILON SYMBOL..MATHEMATICAL SANS-SERIF BOLD ITALIC CAPITAL OMEGA
1D7AA..1D7C2 ; ID_Start # L& [25] MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL ALPHA..MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL OMEGA
1D7C4..1D7CB ; ID_Start # L& [8] MATHEMATICAL SANS-SERIF BOLD ITALIC EPSILON SYMBOL..MATHEMATICAL BOLD SMALL DIGAMMA
+1EE00..1EE03 ; ID_Start # Lo [4] ARABIC MATHEMATICAL ALEF..ARABIC MATHEMATICAL DAL
+1EE05..1EE1F ; ID_Start # Lo [27] ARABIC MATHEMATICAL WAW..ARABIC MATHEMATICAL DOTLESS QAF
+1EE21..1EE22 ; ID_Start # Lo [2] ARABIC MATHEMATICAL INITIAL BEH..ARABIC MATHEMATICAL INITIAL JEEM
+1EE24 ; ID_Start # Lo ARABIC MATHEMATICAL INITIAL HEH
+1EE27 ; ID_Start # Lo ARABIC MATHEMATICAL INITIAL HAH
+1EE29..1EE32 ; ID_Start # Lo [10] ARABIC MATHEMATICAL INITIAL YEH..ARABIC MATHEMATICAL INITIAL QAF
+1EE34..1EE37 ; ID_Start # Lo [4] ARABIC MATHEMATICAL INITIAL SHEEN..ARABIC MATHEMATICAL INITIAL KHAH
+1EE39 ; ID_Start # Lo ARABIC MATHEMATICAL INITIAL DAD
+1EE3B ; ID_Start # Lo ARABIC MATHEMATICAL INITIAL GHAIN
+1EE42 ; ID_Start # Lo ARABIC MATHEMATICAL TAILED JEEM
+1EE47 ; ID_Start # Lo ARABIC MATHEMATICAL TAILED HAH
+1EE49 ; ID_Start # Lo ARABIC MATHEMATICAL TAILED YEH
+1EE4B ; ID_Start # Lo ARABIC MATHEMATICAL TAILED LAM
+1EE4D..1EE4F ; ID_Start # Lo [3] ARABIC MATHEMATICAL TAILED NOON..ARABIC MATHEMATICAL TAILED AIN
+1EE51..1EE52 ; ID_Start # Lo [2] ARABIC MATHEMATICAL TAILED SAD..ARABIC MATHEMATICAL TAILED QAF
+1EE54 ; ID_Start # Lo ARABIC MATHEMATICAL TAILED SHEEN
+1EE57 ; ID_Start # Lo ARABIC MATHEMATICAL TAILED KHAH
+1EE59 ; ID_Start # Lo ARABIC MATHEMATICAL TAILED DAD
+1EE5B ; ID_Start # Lo ARABIC MATHEMATICAL TAILED GHAIN
+1EE5D ; ID_Start # Lo ARABIC MATHEMATICAL TAILED DOTLESS NOON
+1EE5F ; ID_Start # Lo ARABIC MATHEMATICAL TAILED DOTLESS QAF
+1EE61..1EE62 ; ID_Start # Lo [2] ARABIC MATHEMATICAL STRETCHED BEH..ARABIC MATHEMATICAL STRETCHED JEEM
+1EE64 ; ID_Start # Lo ARABIC MATHEMATICAL STRETCHED HEH
+1EE67..1EE6A ; ID_Start # Lo [4] ARABIC MATHEMATICAL STRETCHED HAH..ARABIC MATHEMATICAL STRETCHED KAF
+1EE6C..1EE72 ; ID_Start # Lo [7] ARABIC MATHEMATICAL STRETCHED MEEM..ARABIC MATHEMATICAL STRETCHED QAF
+1EE74..1EE77 ; ID_Start # Lo [4] ARABIC MATHEMATICAL STRETCHED SHEEN..ARABIC MATHEMATICAL STRETCHED KHAH
+1EE79..1EE7C ; ID_Start # Lo [4] ARABIC MATHEMATICAL STRETCHED DAD..ARABIC MATHEMATICAL STRETCHED DOTLESS BEH
+1EE7E ; ID_Start # Lo ARABIC MATHEMATICAL STRETCHED DOTLESS FEH
+1EE80..1EE89 ; ID_Start # Lo [10] ARABIC MATHEMATICAL LOOPED ALEF..ARABIC MATHEMATICAL LOOPED YEH
+1EE8B..1EE9B ; ID_Start # Lo [17] ARABIC MATHEMATICAL LOOPED LAM..ARABIC MATHEMATICAL LOOPED GHAIN
+1EEA1..1EEA3 ; ID_Start # Lo [3] ARABIC MATHEMATICAL DOUBLE-STRUCK BEH..ARABIC MATHEMATICAL DOUBLE-STRUCK DAL
+1EEA5..1EEA9 ; ID_Start # Lo [5] ARABIC MATHEMATICAL DOUBLE-STRUCK WAW..ARABIC MATHEMATICAL DOUBLE-STRUCK YEH
+1EEAB..1EEBB ; ID_Start # Lo [17] ARABIC MATHEMATICAL DOUBLE-STRUCK LAM..ARABIC MATHEMATICAL DOUBLE-STRUCK GHAIN
20000..2A6D6 ; ID_Start # Lo [42711] CJK UNIFIED IDEOGRAPH-20000..CJK UNIFIED IDEOGRAPH-2A6D6
2A700..2B734 ; ID_Start # Lo [4149] CJK UNIFIED IDEOGRAPH-2A700..CJK UNIFIED IDEOGRAPH-2B734
2B740..2B81D ; ID_Start # Lo [222] CJK UNIFIED IDEOGRAPH-2B740..CJK UNIFIED IDEOGRAPH-2B81D
2F800..2FA1D ; ID_Start # Lo [542] CJK COMPATIBILITY IDEOGRAPH-2F800..CJK COMPATIBILITY IDEOGRAPH-2FA1D
-# Total code points: 100747
+# Total code points: 101240
# ================================================
@@ -5641,10 +5867,10 @@
0041..005A ; ID_Continue # L& [26] LATIN CAPITAL LETTER A..LATIN CAPITAL LETTER Z
005F ; ID_Continue # Pc LOW LINE
0061..007A ; ID_Continue # L& [26] LATIN SMALL LETTER A..LATIN SMALL LETTER Z
-00AA ; ID_Continue # L& FEMININE ORDINAL INDICATOR
+00AA ; ID_Continue # Lo FEMININE ORDINAL INDICATOR
00B5 ; ID_Continue # L& MICRO SIGN
00B7 ; ID_Continue # Po MIDDLE DOT
-00BA ; ID_Continue # L& MASCULINE ORDINAL INDICATOR
+00BA ; ID_Continue # Lo MASCULINE ORDINAL INDICATOR
00C0..00D6 ; ID_Continue # L& [23] LATIN CAPITAL LETTER A WITH GRAVE..LATIN CAPITAL LETTER O WITH DIAERESIS
00D8..00F6 ; ID_Continue # L& [31] LATIN CAPITAL LETTER O WITH STROKE..LATIN SMALL LETTER O WITH DIAERESIS
00F8..01BA ; ID_Continue # L& [195] LATIN SMALL LETTER O WITH STROKE..LATIN SMALL LETTER EZH WITH TAIL
@@ -5725,6 +5951,9 @@
0829..082D ; ID_Continue # Mn [5] SAMARITAN VOWEL SIGN LONG I..SAMARITAN MARK NEQUDAA
0840..0858 ; ID_Continue # Lo [25] MANDAIC LETTER HALQA..MANDAIC LETTER AIN
0859..085B ; ID_Continue # Mn [3] MANDAIC AFFRICATION MARK..MANDAIC GEMINATION MARK
+08A0 ; ID_Continue # Lo ARABIC LETTER BEH WITH SMALL V BELOW
+08A2..08AC ; ID_Continue # Lo [11] ARABIC LETTER JEEM WITH TWO DOTS ABOVE..ARABIC LETTER ROHINGYA YEH
+08E4..08FE ; ID_Continue # Mn [27] ARABIC CURLY FATHA..ARABIC DAMMA WITH DOT
0900..0902 ; ID_Continue # Mn [3] DEVANAGARI SIGN INVERTED CANDRABINDU..DEVANAGARI SIGN ANUSVARA
0903 ; ID_Continue # Mc DEVANAGARI SIGN VISARGA
0904..0939 ; ID_Continue # Lo [54] DEVANAGARI LETTER SHORT A..DEVANAGARI LETTER HA
@@ -5946,7 +6175,7 @@
0EC6 ; ID_Continue # Lm LAO KO LA
0EC8..0ECD ; ID_Continue # Mn [6] LAO TONE MAI EK..LAO NIGGAHITA
0ED0..0ED9 ; ID_Continue # Nd [10] LAO DIGIT ZERO..LAO DIGIT NINE
-0EDC..0EDD ; ID_Continue # Lo [2] LAO HO NO..LAO HO MO
+0EDC..0EDF ; ID_Continue # Lo [4] LAO HO NO..LAO LETTER KHMU NYO
0F00 ; ID_Continue # Lo TIBETAN SYLLABLE OM
0F18..0F19 ; ID_Continue # Mn [2] TIBETAN ASTROLOGICAL SIGN -KHYUD PA..TIBETAN ASTROLOGICAL SIGN SDONG TSHUGS
0F20..0F29 ; ID_Continue # Nd [10] TIBETAN DIGIT ZERO..TIBETAN DIGIT NINE
@@ -5998,9 +6227,11 @@
109A..109C ; ID_Continue # Mc [3] MYANMAR SIGN KHAMTI TONE-1..MYANMAR VOWEL SIGN AITON A
109D ; ID_Continue # Mn MYANMAR VOWEL SIGN AITON AI
10A0..10C5 ; ID_Continue # L& [38] GEORGIAN CAPITAL LETTER AN..GEORGIAN CAPITAL LETTER HOE
+10C7 ; ID_Continue # L& GEORGIAN CAPITAL LETTER YN
+10CD ; ID_Continue # L& GEORGIAN CAPITAL LETTER AEN
10D0..10FA ; ID_Continue # Lo [43] GEORGIAN LETTER AN..GEORGIAN LETTER AIN
10FC ; ID_Continue # Lm MODIFIER LETTER GEORGIAN NAR
-1100..1248 ; ID_Continue # Lo [329] HANGUL CHOSEONG KIYEOK..ETHIOPIC SYLLABLE QWA
+10FD..1248 ; ID_Continue # Lo [332] GEORGIAN LETTER AEN..ETHIOPIC SYLLABLE QWA
124A..124D ; ID_Continue # Lo [4] ETHIOPIC SYLLABLE QWI..ETHIOPIC SYLLABLE QWE
1250..1256 ; ID_Continue # Lo [7] ETHIOPIC SYLLABLE QHA..ETHIOPIC SYLLABLE QHO
1258 ; ID_Continue # Lo ETHIOPIC SYLLABLE QHWA
@@ -6036,6 +6267,7 @@
176E..1770 ; ID_Continue # Lo [3] TAGBANWA LETTER LA..TAGBANWA LETTER SA
1772..1773 ; ID_Continue # Mn [2] TAGBANWA VOWEL SIGN I..TAGBANWA VOWEL SIGN U
1780..17B3 ; ID_Continue # Lo [52] KHMER LETTER KA..KHMER INDEPENDENT VOWEL QAU
+17B4..17B5 ; ID_Continue # Mn [2] KHMER VOWEL INHERENT AQ..KHMER VOWEL INHERENT AA
17B6 ; ID_Continue # Mc KHMER VOWEL SIGN AA
17B7..17BD ; ID_Continue # Mn [7] KHMER VOWEL SIGN I..KHMER VOWEL SIGN UA
17BE..17C5 ; ID_Continue # Mc [8] KHMER VOWEL SIGN OE..KHMER VOWEL SIGN AU
@@ -6114,9 +6346,11 @@
1BA6..1BA7 ; ID_Continue # Mc [2] SUNDANESE VOWEL SIGN PANAELAENG..SUNDANESE VOWEL SIGN PANOLONG
1BA8..1BA9 ; ID_Continue # Mn [2] SUNDANESE VOWEL SIGN PAMEPET..SUNDANESE VOWEL SIGN PANEULEUNG
1BAA ; ID_Continue # Mc SUNDANESE SIGN PAMAAEH
+1BAB ; ID_Continue # Mn SUNDANESE SIGN VIRAMA
+1BAC..1BAD ; ID_Continue # Mc [2] SUNDANESE CONSONANT SIGN PASANGAN MA..SUNDANESE CONSONANT SIGN PASANGAN WA
1BAE..1BAF ; ID_Continue # Lo [2] SUNDANESE LETTER KHA..SUNDANESE LETTER SYA
1BB0..1BB9 ; ID_Continue # Nd [10] SUNDANESE DIGIT ZERO..SUNDANESE DIGIT NINE
-1BC0..1BE5 ; ID_Continue # Lo [38] BATAK LETTER A..BATAK LETTER U
+1BBA..1BE5 ; ID_Continue # Lo [44] SUNDANESE AVAGRAHA..BATAK LETTER U
1BE6 ; ID_Continue # Mn BATAK SIGN TOMPI
1BE7 ; ID_Continue # Mc BATAK VOWEL SIGN E
1BE8..1BE9 ; ID_Continue # Mn [2] BATAK VOWEL SIGN PAKPAK E..BATAK VOWEL SIGN EE
@@ -6142,10 +6376,12 @@
1CE9..1CEC ; ID_Continue # Lo [4] VEDIC SIGN ANUSVARA ANTARGOMUKHA..VEDIC SIGN ANUSVARA VAMAGOMUKHA WITH TAIL
1CED ; ID_Continue # Mn VEDIC SIGN TIRYAK
1CEE..1CF1 ; ID_Continue # Lo [4] VEDIC SIGN HEXIFORM LONG ANUSVARA..VEDIC SIGN ANUSVARA UBHAYATO MUKHA
-1CF2 ; ID_Continue # Mc VEDIC SIGN ARDHAVISARGA
+1CF2..1CF3 ; ID_Continue # Mc [2] VEDIC SIGN ARDHAVISARGA..VEDIC SIGN ROTATED ARDHAVISARGA
+1CF4 ; ID_Continue # Mn VEDIC TONE CANDRA ABOVE
+1CF5..1CF6 ; ID_Continue # Lo [2] VEDIC SIGN JIHVAMULIYA..VEDIC SIGN UPADHMANIYA
1D00..1D2B ; ID_Continue # L& [44] LATIN LETTER SMALL CAPITAL A..CYRILLIC LETTER SMALL CAPITAL EL
-1D2C..1D61 ; ID_Continue # Lm [54] MODIFIER LETTER CAPITAL A..MODIFIER LETTER SMALL CHI
-1D62..1D77 ; ID_Continue # L& [22] LATIN SUBSCRIPT SMALL LETTER I..LATIN SMALL LETTER TURNED G
+1D2C..1D6A ; ID_Continue # Lm [63] MODIFIER LETTER CAPITAL A..GREEK SUBSCRIPT SMALL LETTER CHI
+1D6B..1D77 ; ID_Continue # L& [13] LATIN SMALL LETTER UE..LATIN SMALL LETTER TURNED G
1D78 ; ID_Continue # Lm MODIFIER LETTER CYRILLIC EN
1D79..1D9A ; ID_Continue # L& [34] LATIN SMALL LETTER INSULAR G..LATIN SMALL LETTER EZH WITH RETROFLEX HOOK
1D9B..1DBF ; ID_Continue # Lm [37] MODIFIER LETTER SMALL TURNED ALPHA..MODIFIER LETTER SMALL THETA
@@ -6200,13 +6436,16 @@
2185..2188 ; ID_Continue # Nl [4] ROMAN NUMERAL SIX LATE FORM..ROMAN NUMERAL ONE HUNDRED THOUSAND
2C00..2C2E ; ID_Continue # L& [47] GLAGOLITIC CAPITAL LETTER AZU..GLAGOLITIC CAPITAL LETTER LATINATE MYSLITE
2C30..2C5E ; ID_Continue # L& [47] GLAGOLITIC SMALL LETTER AZU..GLAGOLITIC SMALL LETTER LATINATE MYSLITE
-2C60..2C7C ; ID_Continue # L& [29] LATIN CAPITAL LETTER L WITH DOUBLE BAR..LATIN SUBSCRIPT SMALL LETTER J
-2C7D ; ID_Continue # Lm MODIFIER LETTER CAPITAL V
+2C60..2C7B ; ID_Continue # L& [28] LATIN CAPITAL LETTER L WITH DOUBLE BAR..LATIN LETTER SMALL CAPITAL TURNED E
+2C7C..2C7D ; ID_Continue # Lm [2] LATIN SUBSCRIPT SMALL LETTER J..MODIFIER LETTER CAPITAL V
2C7E..2CE4 ; ID_Continue # L& [103] LATIN CAPITAL LETTER S WITH SWASH TAIL..COPTIC SYMBOL KAI
2CEB..2CEE ; ID_Continue # L& [4] COPTIC CAPITAL LETTER CRYPTOGRAMMIC SHEI..COPTIC SMALL LETTER CRYPTOGRAMMIC GANGIA
2CEF..2CF1 ; ID_Continue # Mn [3] COPTIC COMBINING NI ABOVE..COPTIC COMBINING SPIRITUS LENIS
+2CF2..2CF3 ; ID_Continue # L& [2] COPTIC CAPITAL LETTER BOHAIRIC KHEI..COPTIC SMALL LETTER BOHAIRIC KHEI
2D00..2D25 ; ID_Continue # L& [38] GEORGIAN SMALL LETTER AN..GEORGIAN SMALL LETTER HOE
-2D30..2D65 ; ID_Continue # Lo [54] TIFINAGH LETTER YA..TIFINAGH LETTER YAZZ
+2D27 ; ID_Continue # L& GEORGIAN SMALL LETTER YN
+2D2D ; ID_Continue # L& GEORGIAN SMALL LETTER AEN
+2D30..2D67 ; ID_Continue # Lo [56] TIFINAGH LETTER YA..TIFINAGH LETTER YO
2D6F ; ID_Continue # Lm TIFINAGH MODIFIER LETTER LABIALIZATION MARK
2D7F ; ID_Continue # Mn TIFINAGH CONSONANT JOINER
2D80..2D96 ; ID_Continue # Lo [23] ETHIOPIC SYLLABLE LOA..ETHIOPIC SYLLABLE GGWE
@@ -6223,7 +6462,8 @@
3006 ; ID_Continue # Lo IDEOGRAPHIC CLOSING MARK
3007 ; ID_Continue # Nl IDEOGRAPHIC NUMBER ZERO
3021..3029 ; ID_Continue # Nl [9] HANGZHOU NUMERAL ONE..HANGZHOU NUMERAL NINE
-302A..302F ; ID_Continue # Mn [6] IDEOGRAPHIC LEVEL TONE MARK..HANGUL DOUBLE DOT TONE MARK
+302A..302D ; ID_Continue # Mn [4] IDEOGRAPHIC LEVEL TONE MARK..IDEOGRAPHIC ENTERING TONE MARK
+302E..302F ; ID_Continue # Mc [2] HANGUL SINGLE DOT TONE MARK..HANGUL DOUBLE DOT TONE MARK
3031..3035 ; ID_Continue # Lm [5] VERTICAL KANA REPEAT MARK..VERTICAL KANA REPEAT MARK LOWER HALF
3038..303A ; ID_Continue # Nl [3] HANGZHOU NUMERAL TEN..HANGZHOU NUMERAL THIRTY
303B ; ID_Continue # Lm VERTICAL IDEOGRAPHIC ITERATION MARK
@@ -6241,7 +6481,7 @@
31A0..31BA ; ID_Continue # Lo [27] BOPOMOFO LETTER BU..BOPOMOFO LETTER ZY
31F0..31FF ; ID_Continue # Lo [16] KATAKANA LETTER SMALL KU..KATAKANA LETTER SMALL RO
3400..4DB5 ; ID_Continue # Lo [6582] CJK UNIFIED IDEOGRAPH-3400..CJK UNIFIED IDEOGRAPH-4DB5
-4E00..9FCB ; ID_Continue # Lo [20940] CJK UNIFIED IDEOGRAPH-4E00..CJK UNIFIED IDEOGRAPH-9FCB
+4E00..9FCC ; ID_Continue # Lo [20941] CJK UNIFIED IDEOGRAPH-4E00..CJK UNIFIED IDEOGRAPH-9FCC
A000..A014 ; ID_Continue # Lo [21] YI SYLLABLE IT..YI SYLLABLE E
A015 ; ID_Continue # Lm YI SYLLABLE WU
A016..A48C ; ID_Continue # Lo [1143] YI SYLLABLE BIT..YI SYLLABLE YYR
@@ -6255,9 +6495,10 @@
A640..A66D ; ID_Continue # L& [46] CYRILLIC CAPITAL LETTER ZEMLYA..CYRILLIC SMALL LETTER DOUBLE MONOCULAR O
A66E ; ID_Continue # Lo CYRILLIC LETTER MULTIOCULAR O
A66F ; ID_Continue # Mn COMBINING CYRILLIC VZMET
-A67C..A67D ; ID_Continue # Mn [2] COMBINING CYRILLIC KAVYKA..COMBINING CYRILLIC PAYEROK
+A674..A67D ; ID_Continue # Mn [10] COMBINING CYRILLIC LETTER UKRAINIAN IE..COMBINING CYRILLIC PAYEROK
A67F ; ID_Continue # Lm CYRILLIC PAYEROK
A680..A697 ; ID_Continue # L& [24] CYRILLIC CAPITAL LETTER DWE..CYRILLIC SMALL LETTER SHWE
+A69F ; ID_Continue # Mn COMBINING CYRILLIC LETTER IOTIFIED E
A6A0..A6E5 ; ID_Continue # Lo [70] BAMUM LETTER A..BAMUM LETTER KI
A6E6..A6EF ; ID_Continue # Nl [10] BAMUM LETTER MO..BAMUM LETTER KOGHOM
A6F0..A6F1 ; ID_Continue # Mn [2] BAMUM COMBINING MARK KOQNDON..BAMUM COMBINING MARK TUKWENTIS
@@ -6267,8 +6508,9 @@
A771..A787 ; ID_Continue # L& [23] LATIN SMALL LETTER DUM..LATIN SMALL LETTER INSULAR T
A788 ; ID_Continue # Lm MODIFIER LETTER LOW CIRCUMFLEX ACCENT
A78B..A78E ; ID_Continue # L& [4] LATIN CAPITAL LETTER SALTILLO..LATIN SMALL LETTER L WITH RETROFLEX HOOK AND BELT
-A790..A791 ; ID_Continue # L& [2] LATIN CAPITAL LETTER N WITH DESCENDER..LATIN SMALL LETTER N WITH DESCENDER
-A7A0..A7A9 ; ID_Continue # L& [10] LATIN CAPITAL LETTER G WITH OBLIQUE STROKE..LATIN SMALL LETTER S WITH OBLIQUE STROKE
+A790..A793 ; ID_Continue # L& [4] LATIN CAPITAL LETTER N WITH DESCENDER..LATIN SMALL LETTER C WITH BAR
+A7A0..A7AA ; ID_Continue # L& [11] LATIN CAPITAL LETTER G WITH OBLIQUE STROKE..LATIN CAPITAL LETTER H WITH HOOK
+A7F8..A7F9 ; ID_Continue # Lm [2] MODIFIER LETTER CAPITAL H WITH STROKE..MODIFIER LETTER SMALL LIGATURE OE
A7FA ; ID_Continue # L& LATIN LETTER SMALL CAPITAL TURNED M
A7FB..A801 ; ID_Continue # Lo [7] LATIN EPIGRAPHIC LETTER REVERSED F..SYLOTI NAGRI LETTER I
A802 ; ID_Continue # Mn SYLOTI NAGRI SIGN DVISVARA
@@ -6337,6 +6579,14 @@
AAC2 ; ID_Continue # Lo TAI VIET TONE MAI SONG
AADB..AADC ; ID_Continue # Lo [2] TAI VIET SYMBOL KON..TAI VIET SYMBOL NUENG
AADD ; ID_Continue # Lm TAI VIET SYMBOL SAM
+AAE0..AAEA ; ID_Continue # Lo [11] MEETEI MAYEK LETTER E..MEETEI MAYEK LETTER SSA
+AAEB ; ID_Continue # Mc MEETEI MAYEK VOWEL SIGN II
+AAEC..AAED ; ID_Continue # Mn [2] MEETEI MAYEK VOWEL SIGN UU..MEETEI MAYEK VOWEL SIGN AAI
+AAEE..AAEF ; ID_Continue # Mc [2] MEETEI MAYEK VOWEL SIGN AU..MEETEI MAYEK VOWEL SIGN AAU
+AAF2 ; ID_Continue # Lo MEETEI MAYEK ANJI
+AAF3..AAF4 ; ID_Continue # Lm [2] MEETEI MAYEK SYLLABLE REPETITION MARK..MEETEI MAYEK WORD REPETITION MARK
+AAF5 ; ID_Continue # Mc MEETEI MAYEK VOWEL SIGN VISARGA
+AAF6 ; ID_Continue # Mn MEETEI MAYEK VIRAMA
AB01..AB06 ; ID_Continue # Lo [6] ETHIOPIC SYLLABLE TTHU..ETHIOPIC SYLLABLE TTHO
AB09..AB0E ; ID_Continue # Lo [6] ETHIOPIC SYLLABLE DDHU..ETHIOPIC SYLLABLE DDHO
AB11..AB16 ; ID_Continue # Lo [6] ETHIOPIC SYLLABLE DZU..ETHIOPIC SYLLABLE DZO
@@ -6354,8 +6604,7 @@
AC00..D7A3 ; ID_Continue # Lo [11172] HANGUL SYLLABLE GA..HANGUL SYLLABLE HIH
D7B0..D7C6 ; ID_Continue # Lo [23] HANGUL JUNGSEONG O-YEO..HANGUL JUNGSEONG ARAEA-E
D7CB..D7FB ; ID_Continue # Lo [49] HANGUL JONGSEONG NIEUN-RIEUL..HANGUL JONGSEONG PHIEUPH-THIEUTH
-F900..FA2D ; ID_Continue # Lo [302] CJK COMPATIBILITY IDEOGRAPH-F900..CJK COMPATIBILITY IDEOGRAPH-FA2D
-FA30..FA6D ; ID_Continue # Lo [62] CJK COMPATIBILITY IDEOGRAPH-FA30..CJK COMPATIBILITY IDEOGRAPH-FA6D
+F900..FA6D ; ID_Continue # Lo [366] CJK COMPATIBILITY IDEOGRAPH-F900..CJK COMPATIBILITY IDEOGRAPH-FA6D
FA70..FAD9 ; ID_Continue # Lo [106] CJK COMPATIBILITY IDEOGRAPH-FA70..CJK COMPATIBILITY IDEOGRAPH-FAD9
FB00..FB06 ; ID_Continue # L& [7] LATIN SMALL LIGATURE FF..LATIN SMALL LIGATURE ST
FB13..FB17 ; ID_Continue # L& [5] ARMENIAN SMALL LIGATURE MEN NOW..ARMENIAN SMALL LIGATURE MEN XEH
@@ -6422,6 +6671,8 @@
1083F..10855 ; ID_Continue # Lo [23] CYPRIOT SYLLABLE ZO..IMPERIAL ARAMAIC LETTER TAW
10900..10915 ; ID_Continue # Lo [22] PHOENICIAN LETTER ALF..PHOENICIAN LETTER TAU
10920..10939 ; ID_Continue # Lo [26] LYDIAN LETTER A..LYDIAN LETTER C
+10980..109B7 ; ID_Continue # Lo [56] MEROITIC HIEROGLYPHIC LETTER A..MEROITIC CURSIVE LETTER DA
+109BE..109BF ; ID_Continue # Lo [2] MEROITIC CURSIVE LOGOGRAM RMT..MEROITIC CURSIVE LOGOGRAM IMN
10A00 ; ID_Continue # Lo KHAROSHTHI LETTER A
10A01..10A03 ; ID_Continue # Mn [3] KHAROSHTHI VOWEL SIGN I..KHAROSHTHI VOWEL SIGN VOCALIC R
10A05..10A06 ; ID_Continue # Mn [2] KHAROSHTHI VOWEL SIGN E..KHAROSHTHI VOWEL SIGN O
@@ -6449,10 +6700,40 @@
110B3..110B6 ; ID_Continue # Mn [4] KAITHI VOWEL SIGN U..KAITHI VOWEL SIGN AI
110B7..110B8 ; ID_Continue # Mc [2] KAITHI VOWEL SIGN O..KAITHI VOWEL SIGN AU
110B9..110BA ; ID_Continue # Mn [2] KAITHI SIGN VIRAMA..KAITHI SIGN NUKTA
+110D0..110E8 ; ID_Continue # Lo [25] SORA SOMPENG LETTER SAH..SORA SOMPENG LETTER MAE
+110F0..110F9 ; ID_Continue # Nd [10] SORA SOMPENG DIGIT ZERO..SORA SOMPENG DIGIT NINE
+11100..11102 ; ID_Continue # Mn [3] CHAKMA SIGN CANDRABINDU..CHAKMA SIGN VISARGA
+11103..11126 ; ID_Continue # Lo [36] CHAKMA LETTER AA..CHAKMA LETTER HAA
+11127..1112B ; ID_Continue # Mn [5] CHAKMA VOWEL SIGN A..CHAKMA VOWEL SIGN UU
+1112C ; ID_Continue # Mc CHAKMA VOWEL SIGN E
+1112D..11134 ; ID_Continue # Mn [8] CHAKMA VOWEL SIGN AI..CHAKMA MAAYYAA
+11136..1113F ; ID_Continue # Nd [10] CHAKMA DIGIT ZERO..CHAKMA DIGIT NINE
+11180..11181 ; ID_Continue # Mn [2] SHARADA SIGN CANDRABINDU..SHARADA SIGN ANUSVARA
+11182 ; ID_Continue # Mc SHARADA SIGN VISARGA
+11183..111B2 ; ID_Continue # Lo [48] SHARADA LETTER A..SHARADA LETTER HA
+111B3..111B5 ; ID_Continue # Mc [3] SHARADA VOWEL SIGN AA..SHARADA VOWEL SIGN II
+111B6..111BE ; ID_Continue # Mn [9] SHARADA VOWEL SIGN U..SHARADA VOWEL SIGN O
+111BF..111C0 ; ID_Continue # Mc [2] SHARADA VOWEL SIGN AU..SHARADA SIGN VIRAMA
+111C1..111C4 ; ID_Continue # Lo [4] SHARADA SIGN AVAGRAHA..SHARADA OM
+111D0..111D9 ; ID_Continue # Nd [10] SHARADA DIGIT ZERO..SHARADA DIGIT NINE
+11680..116AA ; ID_Continue # Lo [43] TAKRI LETTER A..TAKRI LETTER RRA
+116AB ; ID_Continue # Mn TAKRI SIGN ANUSVARA
+116AC ; ID_Continue # Mc TAKRI SIGN VISARGA
+116AD ; ID_Continue # Mn TAKRI VOWEL SIGN AA
+116AE..116AF ; ID_Continue # Mc [2] TAKRI VOWEL SIGN I..TAKRI VOWEL SIGN II
+116B0..116B5 ; ID_Continue # Mn [6] TAKRI VOWEL SIGN U..TAKRI VOWEL SIGN AU
+116B6 ; ID_Continue # Mc TAKRI SIGN VIRAMA
+116B7 ; ID_Continue # Mn TAKRI SIGN NUKTA
+116C0..116C9 ; ID_Continue # Nd [10] TAKRI DIGIT ZERO..TAKRI DIGIT NINE
12000..1236E ; ID_Continue # Lo [879] CUNEIFORM SIGN A..CUNEIFORM SIGN ZUM
12400..12462 ; ID_Continue # Nl [99] CUNEIFORM NUMERIC SIGN TWO ASH..CUNEIFORM NUMERIC SIGN OLD ASSYRIAN ONE QUARTER
13000..1342E ; ID_Continue # Lo [1071] EGYPTIAN HIEROGLYPH A001..EGYPTIAN HIEROGLYPH AA032
16800..16A38 ; ID_Continue # Lo [569] BAMUM LETTER PHASE-A NGKUE MFON..BAMUM LETTER PHASE-F VUEQ
+16F00..16F44 ; ID_Continue # Lo [69] MIAO LETTER PA..MIAO LETTER HHA
+16F50 ; ID_Continue # Lo MIAO LETTER NASALIZATION
+16F51..16F7E ; ID_Continue # Mc [46] MIAO SIGN ASPIRATION..MIAO VOWEL SIGN NG
+16F8F..16F92 ; ID_Continue # Mn [4] MIAO TONE RIGHT..MIAO TONE BELOW
+16F93..16F9F ; ID_Continue # Lm [13] MIAO LETTER TONE-2..MIAO LETTER REFORMED TONE-8
1B000..1B001 ; ID_Continue # Lo [2] KATAKANA LETTER ARCHAIC E..HIRAGANA LETTER ARCHAIC YE
1D165..1D166 ; ID_Continue # Mc [2] MUSICAL SYMBOL COMBINING STEM..MUSICAL SYMBOL COMBINING SPRECHGESANG STEM
1D167..1D169 ; ID_Continue # Mn [3] MUSICAL SYMBOL COMBINING TREMOLO-1..MUSICAL SYMBOL COMBINING TREMOLO-3
@@ -6492,6 +6773,39 @@
1D7AA..1D7C2 ; ID_Continue # L& [25] MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL ALPHA..MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL OMEGA
1D7C4..1D7CB ; ID_Continue # L& [8] MATHEMATICAL SANS-SERIF BOLD ITALIC EPSILON SYMBOL..MATHEMATICAL BOLD SMALL DIGAMMA
1D7CE..1D7FF ; ID_Continue # Nd [50] MATHEMATICAL BOLD DIGIT ZERO..MATHEMATICAL MONOSPACE DIGIT NINE
+1EE00..1EE03 ; ID_Continue # Lo [4] ARABIC MATHEMATICAL ALEF..ARABIC MATHEMATICAL DAL
+1EE05..1EE1F ; ID_Continue # Lo [27] ARABIC MATHEMATICAL WAW..ARABIC MATHEMATICAL DOTLESS QAF
+1EE21..1EE22 ; ID_Continue # Lo [2] ARABIC MATHEMATICAL INITIAL BEH..ARABIC MATHEMATICAL INITIAL JEEM
+1EE24 ; ID_Continue # Lo ARABIC MATHEMATICAL INITIAL HEH
+1EE27 ; ID_Continue # Lo ARABIC MATHEMATICAL INITIAL HAH
+1EE29..1EE32 ; ID_Continue # Lo [10] ARABIC MATHEMATICAL INITIAL YEH..ARABIC MATHEMATICAL INITIAL QAF
+1EE34..1EE37 ; ID_Continue # Lo [4] ARABIC MATHEMATICAL INITIAL SHEEN..ARABIC MATHEMATICAL INITIAL KHAH
+1EE39 ; ID_Continue # Lo ARABIC MATHEMATICAL INITIAL DAD
+1EE3B ; ID_Continue # Lo ARABIC MATHEMATICAL INITIAL GHAIN
+1EE42 ; ID_Continue # Lo ARABIC MATHEMATICAL TAILED JEEM
+1EE47 ; ID_Continue # Lo ARABIC MATHEMATICAL TAILED HAH
+1EE49 ; ID_Continue # Lo ARABIC MATHEMATICAL TAILED YEH
+1EE4B ; ID_Continue # Lo ARABIC MATHEMATICAL TAILED LAM
+1EE4D..1EE4F ; ID_Continue # Lo [3] ARABIC MATHEMATICAL TAILED NOON..ARABIC MATHEMATICAL TAILED AIN
+1EE51..1EE52 ; ID_Continue # Lo [2] ARABIC MATHEMATICAL TAILED SAD..ARABIC MATHEMATICAL TAILED QAF
+1EE54 ; ID_Continue # Lo ARABIC MATHEMATICAL TAILED SHEEN
+1EE57 ; ID_Continue # Lo ARABIC MATHEMATICAL TAILED KHAH
+1EE59 ; ID_Continue # Lo ARABIC MATHEMATICAL TAILED DAD
+1EE5B ; ID_Continue # Lo ARABIC MATHEMATICAL TAILED GHAIN
+1EE5D ; ID_Continue # Lo ARABIC MATHEMATICAL TAILED DOTLESS NOON
+1EE5F ; ID_Continue # Lo ARABIC MATHEMATICAL TAILED DOTLESS QAF
+1EE61..1EE62 ; ID_Continue # Lo [2] ARABIC MATHEMATICAL STRETCHED BEH..ARABIC MATHEMATICAL STRETCHED JEEM
+1EE64 ; ID_Continue # Lo ARABIC MATHEMATICAL STRETCHED HEH
+1EE67..1EE6A ; ID_Continue # Lo [4] ARABIC MATHEMATICAL STRETCHED HAH..ARABIC MATHEMATICAL STRETCHED KAF
+1EE6C..1EE72 ; ID_Continue # Lo [7] ARABIC MATHEMATICAL STRETCHED MEEM..ARABIC MATHEMATICAL STRETCHED QAF
+1EE74..1EE77 ; ID_Continue # Lo [4] ARABIC MATHEMATICAL STRETCHED SHEEN..ARABIC MATHEMATICAL STRETCHED KHAH
+1EE79..1EE7C ; ID_Continue # Lo [4] ARABIC MATHEMATICAL STRETCHED DAD..ARABIC MATHEMATICAL STRETCHED DOTLESS BEH
+1EE7E ; ID_Continue # Lo ARABIC MATHEMATICAL STRETCHED DOTLESS FEH
+1EE80..1EE89 ; ID_Continue # Lo [10] ARABIC MATHEMATICAL LOOPED ALEF..ARABIC MATHEMATICAL LOOPED YEH
+1EE8B..1EE9B ; ID_Continue # Lo [17] ARABIC MATHEMATICAL LOOPED LAM..ARABIC MATHEMATICAL LOOPED GHAIN
+1EEA1..1EEA3 ; ID_Continue # Lo [3] ARABIC MATHEMATICAL DOUBLE-STRUCK BEH..ARABIC MATHEMATICAL DOUBLE-STRUCK DAL
+1EEA5..1EEA9 ; ID_Continue # Lo [5] ARABIC MATHEMATICAL DOUBLE-STRUCK WAW..ARABIC MATHEMATICAL DOUBLE-STRUCK YEH
+1EEAB..1EEBB ; ID_Continue # Lo [17] ARABIC MATHEMATICAL DOUBLE-STRUCK LAM..ARABIC MATHEMATICAL DOUBLE-STRUCK GHAIN
20000..2A6D6 ; ID_Continue # Lo [42711] CJK UNIFIED IDEOGRAPH-20000..CJK UNIFIED IDEOGRAPH-2A6D6
2A700..2B734 ; ID_Continue # Lo [4149] CJK UNIFIED IDEOGRAPH-2A700..CJK UNIFIED IDEOGRAPH-2B734
2B740..2B81D ; ID_Continue # Lo [222] CJK UNIFIED IDEOGRAPH-2B740..CJK UNIFIED IDEOGRAPH-2B81D
@@ -6498,7 +6812,7 @@
2F800..2FA1D ; ID_Continue # Lo [542] CJK COMPATIBILITY IDEOGRAPH-2F800..CJK COMPATIBILITY IDEOGRAPH-2FA1D
E0100..E01EF ; ID_Continue # Mn [240] VARIATION SELECTOR-17..VARIATION SELECTOR-256
-# Total code points: 102675
+# Total code points: 103355
# ================================================
@@ -6511,9 +6825,9 @@
0041..005A ; XID_Start # L& [26] LATIN CAPITAL LETTER A..LATIN CAPITAL LETTER Z
0061..007A ; XID_Start # L& [26] LATIN SMALL LETTER A..LATIN SMALL LETTER Z
-00AA ; XID_Start # L& FEMININE ORDINAL INDICATOR
+00AA ; XID_Start # Lo FEMININE ORDINAL INDICATOR
00B5 ; XID_Start # L& MICRO SIGN
-00BA ; XID_Start # L& MASCULINE ORDINAL INDICATOR
+00BA ; XID_Start # Lo MASCULINE ORDINAL INDICATOR
00C0..00D6 ; XID_Start # L& [23] LATIN CAPITAL LETTER A WITH GRAVE..LATIN CAPITAL LETTER O WITH DIAERESIS
00D8..00F6 ; XID_Start # L& [31] LATIN CAPITAL LETTER O WITH STROKE..LATIN SMALL LETTER O WITH DIAERESIS
00F8..01BA ; XID_Start # L& [195] LATIN SMALL LETTER O WITH STROKE..LATIN SMALL LETTER EZH WITH TAIL
@@ -6566,6 +6880,8 @@
0824 ; XID_Start # Lm SAMARITAN MODIFIER LETTER SHORT A
0828 ; XID_Start # Lm SAMARITAN MODIFIER LETTER I
0840..0858 ; XID_Start # Lo [25] MANDAIC LETTER HALQA..MANDAIC LETTER AIN
+08A0 ; XID_Start # Lo ARABIC LETTER BEH WITH SMALL V BELOW
+08A2..08AC ; XID_Start # Lo [11] ARABIC LETTER JEEM WITH TWO DOTS ABOVE..ARABIC LETTER ROHINGYA YEH
0904..0939 ; XID_Start # Lo [54] DEVANAGARI LETTER SHORT A..DEVANAGARI LETTER HA
093D ; XID_Start # Lo DEVANAGARI SIGN AVAGRAHA
0950 ; XID_Start # Lo DEVANAGARI OM
@@ -6673,7 +6989,7 @@
0EBD ; XID_Start # Lo LAO SEMIVOWEL SIGN NYO
0EC0..0EC4 ; XID_Start # Lo [5] LAO VOWEL SIGN E..LAO VOWEL SIGN AI
0EC6 ; XID_Start # Lm LAO KO LA
-0EDC..0EDD ; XID_Start # Lo [2] LAO HO NO..LAO HO MO
+0EDC..0EDF ; XID_Start # Lo [4] LAO HO NO..LAO LETTER KHMU NYO
0F00 ; XID_Start # Lo TIBETAN SYLLABLE OM
0F40..0F47 ; XID_Start # Lo [8] TIBETAN LETTER KA..TIBETAN LETTER JA
0F49..0F6C ; XID_Start # Lo [36] TIBETAN LETTER NYA..TIBETAN LETTER RRA
@@ -6688,9 +7004,11 @@
1075..1081 ; XID_Start # Lo [13] MYANMAR LETTER SHAN KA..MYANMAR LETTER SHAN HA
108E ; XID_Start # Lo MYANMAR LETTER RUMAI PALAUNG FA
10A0..10C5 ; XID_Start # L& [38] GEORGIAN CAPITAL LETTER AN..GEORGIAN CAPITAL LETTER HOE
+10C7 ; XID_Start # L& GEORGIAN CAPITAL LETTER YN
+10CD ; XID_Start # L& GEORGIAN CAPITAL LETTER AEN
10D0..10FA ; XID_Start # Lo [43] GEORGIAN LETTER AN..GEORGIAN LETTER AIN
10FC ; XID_Start # Lm MODIFIER LETTER GEORGIAN NAR
-1100..1248 ; XID_Start # Lo [329] HANGUL CHOSEONG KIYEOK..ETHIOPIC SYLLABLE QWA
+10FD..1248 ; XID_Start # Lo [332] GEORGIAN LETTER AEN..ETHIOPIC SYLLABLE QWA
124A..124D ; XID_Start # Lo [4] ETHIOPIC SYLLABLE QWI..ETHIOPIC SYLLABLE QWE
1250..1256 ; XID_Start # Lo [7] ETHIOPIC SYLLABLE QHA..ETHIOPIC SYLLABLE QHO
1258 ; XID_Start # Lo ETHIOPIC SYLLABLE QHWA
@@ -6740,7 +7058,7 @@
1B45..1B4B ; XID_Start # Lo [7] BALINESE LETTER KAF SASAK..BALINESE LETTER ASYURA SASAK
1B83..1BA0 ; XID_Start # Lo [30] SUNDANESE LETTER A..SUNDANESE LETTER HA
1BAE..1BAF ; XID_Start # Lo [2] SUNDANESE LETTER KHA..SUNDANESE LETTER SYA
-1BC0..1BE5 ; XID_Start # Lo [38] BATAK LETTER A..BATAK LETTER U
+1BBA..1BE5 ; XID_Start # Lo [44] SUNDANESE AVAGRAHA..BATAK LETTER U
1C00..1C23 ; XID_Start # Lo [36] LEPCHA LETTER KA..LEPCHA LETTER A
1C4D..1C4F ; XID_Start # Lo [3] LEPCHA LETTER TTA..LEPCHA LETTER DDA
1C5A..1C77 ; XID_Start # Lo [30] OL CHIKI LETTER LA..OL CHIKI LETTER OH
@@ -6747,9 +7065,10 @@
1C78..1C7D ; XID_Start # Lm [6] OL CHIKI MU TTUDDAG..OL CHIKI AHAD
1CE9..1CEC ; XID_Start # Lo [4] VEDIC SIGN ANUSVARA ANTARGOMUKHA..VEDIC SIGN ANUSVARA VAMAGOMUKHA WITH TAIL
1CEE..1CF1 ; XID_Start # Lo [4] VEDIC SIGN HEXIFORM LONG ANUSVARA..VEDIC SIGN ANUSVARA UBHAYATO MUKHA
+1CF5..1CF6 ; XID_Start # Lo [2] VEDIC SIGN JIHVAMULIYA..VEDIC SIGN UPADHMANIYA
1D00..1D2B ; XID_Start # L& [44] LATIN LETTER SMALL CAPITAL A..CYRILLIC LETTER SMALL CAPITAL EL
-1D2C..1D61 ; XID_Start # Lm [54] MODIFIER LETTER CAPITAL A..MODIFIER LETTER SMALL CHI
-1D62..1D77 ; XID_Start # L& [22] LATIN SUBSCRIPT SMALL LETTER I..LATIN SMALL LETTER TURNED G
+1D2C..1D6A ; XID_Start # Lm [63] MODIFIER LETTER CAPITAL A..GREEK SUBSCRIPT SMALL LETTER CHI
+1D6B..1D77 ; XID_Start # L& [13] LATIN SMALL LETTER UE..LATIN SMALL LETTER TURNED G
1D78 ; XID_Start # Lm MODIFIER LETTER CYRILLIC EN
1D79..1D9A ; XID_Start # L& [34] LATIN SMALL LETTER INSULAR G..LATIN SMALL LETTER EZH WITH RETROFLEX HOOK
1D9B..1DBF ; XID_Start # Lm [37] MODIFIER LETTER SMALL TURNED ALPHA..MODIFIER LETTER SMALL THETA
@@ -6797,12 +7116,15 @@
2185..2188 ; XID_Start # Nl [4] ROMAN NUMERAL SIX LATE FORM..ROMAN NUMERAL ONE HUNDRED THOUSAND
2C00..2C2E ; XID_Start # L& [47] GLAGOLITIC CAPITAL LETTER AZU..GLAGOLITIC CAPITAL LETTER LATINATE MYSLITE
2C30..2C5E ; XID_Start # L& [47] GLAGOLITIC SMALL LETTER AZU..GLAGOLITIC SMALL LETTER LATINATE MYSLITE
-2C60..2C7C ; XID_Start # L& [29] LATIN CAPITAL LETTER L WITH DOUBLE BAR..LATIN SUBSCRIPT SMALL LETTER J
-2C7D ; XID_Start # Lm MODIFIER LETTER CAPITAL V
+2C60..2C7B ; XID_Start # L& [28] LATIN CAPITAL LETTER L WITH DOUBLE BAR..LATIN LETTER SMALL CAPITAL TURNED E
+2C7C..2C7D ; XID_Start # Lm [2] LATIN SUBSCRIPT SMALL LETTER J..MODIFIER LETTER CAPITAL V
2C7E..2CE4 ; XID_Start # L& [103] LATIN CAPITAL LETTER S WITH SWASH TAIL..COPTIC SYMBOL KAI
2CEB..2CEE ; XID_Start # L& [4] COPTIC CAPITAL LETTER CRYPTOGRAMMIC SHEI..COPTIC SMALL LETTER CRYPTOGRAMMIC GANGIA
+2CF2..2CF3 ; XID_Start # L& [2] COPTIC CAPITAL LETTER BOHAIRIC KHEI..COPTIC SMALL LETTER BOHAIRIC KHEI
2D00..2D25 ; XID_Start # L& [38] GEORGIAN SMALL LETTER AN..GEORGIAN SMALL LETTER HOE
-2D30..2D65 ; XID_Start # Lo [54] TIFINAGH LETTER YA..TIFINAGH LETTER YAZZ
+2D27 ; XID_Start # L& GEORGIAN SMALL LETTER YN
+2D2D ; XID_Start # L& GEORGIAN SMALL LETTER AEN
+2D30..2D67 ; XID_Start # Lo [56] TIFINAGH LETTER YA..TIFINAGH LETTER YO
2D6F ; XID_Start # Lm TIFINAGH MODIFIER LETTER LABIALIZATION MARK
2D80..2D96 ; XID_Start # Lo [23] ETHIOPIC SYLLABLE LOA..ETHIOPIC SYLLABLE GGWE
2DA0..2DA6 ; XID_Start # Lo [7] ETHIOPIC SYLLABLE SSA..ETHIOPIC SYLLABLE SSO
@@ -6832,7 +7154,7 @@
31A0..31BA ; XID_Start # Lo [27] BOPOMOFO LETTER BU..BOPOMOFO LETTER ZY
31F0..31FF ; XID_Start # Lo [16] KATAKANA LETTER SMALL KU..KATAKANA LETTER SMALL RO
3400..4DB5 ; XID_Start # Lo [6582] CJK UNIFIED IDEOGRAPH-3400..CJK UNIFIED IDEOGRAPH-4DB5
-4E00..9FCB ; XID_Start # Lo [20940] CJK UNIFIED IDEOGRAPH-4E00..CJK UNIFIED IDEOGRAPH-9FCB
+4E00..9FCC ; XID_Start # Lo [20941] CJK UNIFIED IDEOGRAPH-4E00..CJK UNIFIED IDEOGRAPH-9FCC
A000..A014 ; XID_Start # Lo [21] YI SYLLABLE IT..YI SYLLABLE E
A015 ; XID_Start # Lm YI SYLLABLE WU
A016..A48C ; XID_Start # Lo [1143] YI SYLLABLE BIT..YI SYLLABLE YYR
@@ -6854,8 +7176,9 @@
A771..A787 ; XID_Start # L& [23] LATIN SMALL LETTER DUM..LATIN SMALL LETTER INSULAR T
A788 ; XID_Start # Lm MODIFIER LETTER LOW CIRCUMFLEX ACCENT
A78B..A78E ; XID_Start # L& [4] LATIN CAPITAL LETTER SALTILLO..LATIN SMALL LETTER L WITH RETROFLEX HOOK AND BELT
-A790..A791 ; XID_Start # L& [2] LATIN CAPITAL LETTER N WITH DESCENDER..LATIN SMALL LETTER N WITH DESCENDER
-A7A0..A7A9 ; XID_Start # L& [10] LATIN CAPITAL LETTER G WITH OBLIQUE STROKE..LATIN SMALL LETTER S WITH OBLIQUE STROKE
+A790..A793 ; XID_Start # L& [4] LATIN CAPITAL LETTER N WITH DESCENDER..LATIN SMALL LETTER C WITH BAR
+A7A0..A7AA ; XID_Start # L& [11] LATIN CAPITAL LETTER G WITH OBLIQUE STROKE..LATIN CAPITAL LETTER H WITH HOOK
+A7F8..A7F9 ; XID_Start # Lm [2] MODIFIER LETTER CAPITAL H WITH STROKE..MODIFIER LETTER SMALL LIGATURE OE
A7FA ; XID_Start # L& LATIN LETTER SMALL CAPITAL TURNED M
A7FB..A801 ; XID_Start # Lo [7] LATIN EPIGRAPHIC LETTER REVERSED F..SYLOTI NAGRI LETTER I
A803..A805 ; XID_Start # Lo [3] SYLOTI NAGRI LETTER U..SYLOTI NAGRI LETTER O
@@ -6885,6 +7208,9 @@
AAC2 ; XID_Start # Lo TAI VIET TONE MAI SONG
AADB..AADC ; XID_Start # Lo [2] TAI VIET SYMBOL KON..TAI VIET SYMBOL NUENG
AADD ; XID_Start # Lm TAI VIET SYMBOL SAM
+AAE0..AAEA ; XID_Start # Lo [11] MEETEI MAYEK LETTER E..MEETEI MAYEK LETTER SSA
+AAF2 ; XID_Start # Lo MEETEI MAYEK ANJI
+AAF3..AAF4 ; XID_Start # Lm [2] MEETEI MAYEK SYLLABLE REPETITION MARK..MEETEI MAYEK WORD REPETITION MARK
AB01..AB06 ; XID_Start # Lo [6] ETHIOPIC SYLLABLE TTHU..ETHIOPIC SYLLABLE TTHO
AB09..AB0E ; XID_Start # Lo [6] ETHIOPIC SYLLABLE DDHU..ETHIOPIC SYLLABLE DDHO
AB11..AB16 ; XID_Start # Lo [6] ETHIOPIC SYLLABLE DZU..ETHIOPIC SYLLABLE DZO
@@ -6894,8 +7220,7 @@
AC00..D7A3 ; XID_Start # Lo [11172] HANGUL SYLLABLE GA..HANGUL SYLLABLE HIH
D7B0..D7C6 ; XID_Start # Lo [23] HANGUL JUNGSEONG O-YEO..HANGUL JUNGSEONG ARAEA-E
D7CB..D7FB ; XID_Start # Lo [49] HANGUL JONGSEONG NIEUN-RIEUL..HANGUL JONGSEONG PHIEUPH-THIEUTH
-F900..FA2D ; XID_Start # Lo [302] CJK COMPATIBILITY IDEOGRAPH-F900..CJK COMPATIBILITY IDEOGRAPH-FA2D
-FA30..FA6D ; XID_Start # Lo [62] CJK COMPATIBILITY IDEOGRAPH-FA30..CJK COMPATIBILITY IDEOGRAPH-FA6D
+F900..FA6D ; XID_Start # Lo [366] CJK COMPATIBILITY IDEOGRAPH-F900..CJK COMPATIBILITY IDEOGRAPH-FA6D
FA70..FAD9 ; XID_Start # Lo [106] CJK COMPATIBILITY IDEOGRAPH-FA70..CJK COMPATIBILITY IDEOGRAPH-FAD9
FB00..FB06 ; XID_Start # L& [7] LATIN SMALL LIGATURE FF..LATIN SMALL LIGATURE ST
FB13..FB17 ; XID_Start # L& [5] ARMENIAN SMALL LIGATURE MEN NOW..ARMENIAN SMALL LIGATURE MEN XEH
@@ -6958,6 +7283,8 @@
1083F..10855 ; XID_Start # Lo [23] CYPRIOT SYLLABLE ZO..IMPERIAL ARAMAIC LETTER TAW
10900..10915 ; XID_Start # Lo [22] PHOENICIAN LETTER ALF..PHOENICIAN LETTER TAU
10920..10939 ; XID_Start # Lo [26] LYDIAN LETTER A..LYDIAN LETTER C
+10980..109B7 ; XID_Start # Lo [56] MEROITIC HIEROGLYPHIC LETTER A..MEROITIC CURSIVE LETTER DA
+109BE..109BF ; XID_Start # Lo [2] MEROITIC CURSIVE LOGOGRAM RMT..MEROITIC CURSIVE LOGOGRAM IMN
10A00 ; XID_Start # Lo KHAROSHTHI LETTER A
10A10..10A13 ; XID_Start # Lo [4] KHAROSHTHI LETTER KA..KHAROSHTHI LETTER GHA
10A15..10A17 ; XID_Start # Lo [3] KHAROSHTHI LETTER CA..KHAROSHTHI LETTER JA
@@ -6969,10 +7296,18 @@
10C00..10C48 ; XID_Start # Lo [73] OLD TURKIC LETTER ORKHON A..OLD TURKIC LETTER ORKHON BASH
11003..11037 ; XID_Start # Lo [53] BRAHMI SIGN JIHVAMULIYA..BRAHMI LETTER OLD TAMIL NNNA
11083..110AF ; XID_Start # Lo [45] KAITHI LETTER A..KAITHI LETTER HA
+110D0..110E8 ; XID_Start # Lo [25] SORA SOMPENG LETTER SAH..SORA SOMPENG LETTER MAE
+11103..11126 ; XID_Start # Lo [36] CHAKMA LETTER AA..CHAKMA LETTER HAA
+11183..111B2 ; XID_Start # Lo [48] SHARADA LETTER A..SHARADA LETTER HA
+111C1..111C4 ; XID_Start # Lo [4] SHARADA SIGN AVAGRAHA..SHARADA OM
+11680..116AA ; XID_Start # Lo [43] TAKRI LETTER A..TAKRI LETTER RRA
12000..1236E ; XID_Start # Lo [879] CUNEIFORM SIGN A..CUNEIFORM SIGN ZUM
12400..12462 ; XID_Start # Nl [99] CUNEIFORM NUMERIC SIGN TWO ASH..CUNEIFORM NUMERIC SIGN OLD ASSYRIAN ONE QUARTER
13000..1342E ; XID_Start # Lo [1071] EGYPTIAN HIEROGLYPH A001..EGYPTIAN HIEROGLYPH AA032
16800..16A38 ; XID_Start # Lo [569] BAMUM LETTER PHASE-A NGKUE MFON..BAMUM LETTER PHASE-F VUEQ
+16F00..16F44 ; XID_Start # Lo [69] MIAO LETTER PA..MIAO LETTER HHA
+16F50 ; XID_Start # Lo MIAO LETTER NASALIZATION
+16F93..16F9F ; XID_Start # Lm [13] MIAO LETTER TONE-2..MIAO LETTER REFORMED TONE-8
1B000..1B001 ; XID_Start # Lo [2] KATAKANA LETTER ARCHAIC E..HIRAGANA LETTER ARCHAIC YE
1D400..1D454 ; XID_Start # L& [85] MATHEMATICAL BOLD CAPITAL A..MATHEMATICAL ITALIC SMALL G
1D456..1D49C ; XID_Start # L& [71] MATHEMATICAL ITALIC SMALL I..MATHEMATICAL SCRIPT CAPITAL A
@@ -7004,12 +7339,45 @@
1D78A..1D7A8 ; XID_Start # L& [31] MATHEMATICAL SANS-SERIF BOLD EPSILON SYMBOL..MATHEMATICAL SANS-SERIF BOLD ITALIC CAPITAL OMEGA
1D7AA..1D7C2 ; XID_Start # L& [25] MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL ALPHA..MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL OMEGA
1D7C4..1D7CB ; XID_Start # L& [8] MATHEMATICAL SANS-SERIF BOLD ITALIC EPSILON SYMBOL..MATHEMATICAL BOLD SMALL DIGAMMA
+1EE00..1EE03 ; XID_Start # Lo [4] ARABIC MATHEMATICAL ALEF..ARABIC MATHEMATICAL DAL
+1EE05..1EE1F ; XID_Start # Lo [27] ARABIC MATHEMATICAL WAW..ARABIC MATHEMATICAL DOTLESS QAF
+1EE21..1EE22 ; XID_Start # Lo [2] ARABIC MATHEMATICAL INITIAL BEH..ARABIC MATHEMATICAL INITIAL JEEM
+1EE24 ; XID_Start # Lo ARABIC MATHEMATICAL INITIAL HEH
+1EE27 ; XID_Start # Lo ARABIC MATHEMATICAL INITIAL HAH
+1EE29..1EE32 ; XID_Start # Lo [10] ARABIC MATHEMATICAL INITIAL YEH..ARABIC MATHEMATICAL INITIAL QAF
+1EE34..1EE37 ; XID_Start # Lo [4] ARABIC MATHEMATICAL INITIAL SHEEN..ARABIC MATHEMATICAL INITIAL KHAH
+1EE39 ; XID_Start # Lo ARABIC MATHEMATICAL INITIAL DAD
+1EE3B ; XID_Start # Lo ARABIC MATHEMATICAL INITIAL GHAIN
+1EE42 ; XID_Start # Lo ARABIC MATHEMATICAL TAILED JEEM
+1EE47 ; XID_Start # Lo ARABIC MATHEMATICAL TAILED HAH
+1EE49 ; XID_Start # Lo ARABIC MATHEMATICAL TAILED YEH
+1EE4B ; XID_Start # Lo ARABIC MATHEMATICAL TAILED LAM
+1EE4D..1EE4F ; XID_Start # Lo [3] ARABIC MATHEMATICAL TAILED NOON..ARABIC MATHEMATICAL TAILED AIN
+1EE51..1EE52 ; XID_Start # Lo [2] ARABIC MATHEMATICAL TAILED SAD..ARABIC MATHEMATICAL TAILED QAF
+1EE54 ; XID_Start # Lo ARABIC MATHEMATICAL TAILED SHEEN
+1EE57 ; XID_Start # Lo ARABIC MATHEMATICAL TAILED KHAH
+1EE59 ; XID_Start # Lo ARABIC MATHEMATICAL TAILED DAD
+1EE5B ; XID_Start # Lo ARABIC MATHEMATICAL TAILED GHAIN
+1EE5D ; XID_Start # Lo ARABIC MATHEMATICAL TAILED DOTLESS NOON
+1EE5F ; XID_Start # Lo ARABIC MATHEMATICAL TAILED DOTLESS QAF
+1EE61..1EE62 ; XID_Start # Lo [2] ARABIC MATHEMATICAL STRETCHED BEH..ARABIC MATHEMATICAL STRETCHED JEEM
+1EE64 ; XID_Start # Lo ARABIC MATHEMATICAL STRETCHED HEH
+1EE67..1EE6A ; XID_Start # Lo [4] ARABIC MATHEMATICAL STRETCHED HAH..ARABIC MATHEMATICAL STRETCHED KAF
+1EE6C..1EE72 ; XID_Start # Lo [7] ARABIC MATHEMATICAL STRETCHED MEEM..ARABIC MATHEMATICAL STRETCHED QAF
+1EE74..1EE77 ; XID_Start # Lo [4] ARABIC MATHEMATICAL STRETCHED SHEEN..ARABIC MATHEMATICAL STRETCHED KHAH
+1EE79..1EE7C ; XID_Start # Lo [4] ARABIC MATHEMATICAL STRETCHED DAD..ARABIC MATHEMATICAL STRETCHED DOTLESS BEH
+1EE7E ; XID_Start # Lo ARABIC MATHEMATICAL STRETCHED DOTLESS FEH
+1EE80..1EE89 ; XID_Start # Lo [10] ARABIC MATHEMATICAL LOOPED ALEF..ARABIC MATHEMATICAL LOOPED YEH
+1EE8B..1EE9B ; XID_Start # Lo [17] ARABIC MATHEMATICAL LOOPED LAM..ARABIC MATHEMATICAL LOOPED GHAIN
+1EEA1..1EEA3 ; XID_Start # Lo [3] ARABIC MATHEMATICAL DOUBLE-STRUCK BEH..ARABIC MATHEMATICAL DOUBLE-STRUCK DAL
+1EEA5..1EEA9 ; XID_Start # Lo [5] ARABIC MATHEMATICAL DOUBLE-STRUCK WAW..ARABIC MATHEMATICAL DOUBLE-STRUCK YEH
+1EEAB..1EEBB ; XID_Start # Lo [17] ARABIC MATHEMATICAL DOUBLE-STRUCK LAM..ARABIC MATHEMATICAL DOUBLE-STRUCK GHAIN
20000..2A6D6 ; XID_Start # Lo [42711] CJK UNIFIED IDEOGRAPH-20000..CJK UNIFIED IDEOGRAPH-2A6D6
2A700..2B734 ; XID_Start # Lo [4149] CJK UNIFIED IDEOGRAPH-2A700..CJK UNIFIED IDEOGRAPH-2B734
2B740..2B81D ; XID_Start # Lo [222] CJK UNIFIED IDEOGRAPH-2B740..CJK UNIFIED IDEOGRAPH-2B81D
2F800..2FA1D ; XID_Start # Lo [542] CJK COMPATIBILITY IDEOGRAPH-2F800..CJK COMPATIBILITY IDEOGRAPH-2FA1D
-# Total code points: 100724
+# Total code points: 101217
# ================================================
@@ -7016,7 +7384,6 @@
# Derived Property: XID_Continue
# Mod_ID_Continue modified for closure under NFKx
# Modified as described in UAX #15
-# NOTE: Cf characters should be filtered out.
# NOTE: Does NOT remove the non-NFKx characters.
# Merely ensures that if isIdentifer(string) then isIdentifier(NFKx(string))
# NOTE: See UAX #31 for more information
@@ -7025,10 +7392,10 @@
0041..005A ; XID_Continue # L& [26] LATIN CAPITAL LETTER A..LATIN CAPITAL LETTER Z
005F ; XID_Continue # Pc LOW LINE
0061..007A ; XID_Continue # L& [26] LATIN SMALL LETTER A..LATIN SMALL LETTER Z
-00AA ; XID_Continue # L& FEMININE ORDINAL INDICATOR
+00AA ; XID_Continue # Lo FEMININE ORDINAL INDICATOR
00B5 ; XID_Continue # L& MICRO SIGN
00B7 ; XID_Continue # Po MIDDLE DOT
-00BA ; XID_Continue # L& MASCULINE ORDINAL INDICATOR
+00BA ; XID_Continue # Lo MASCULINE ORDINAL INDICATOR
00C0..00D6 ; XID_Continue # L& [23] LATIN CAPITAL LETTER A WITH GRAVE..LATIN CAPITAL LETTER O WITH DIAERESIS
00D8..00F6 ; XID_Continue # L& [31] LATIN CAPITAL LETTER O WITH STROKE..LATIN SMALL LETTER O WITH DIAERESIS
00F8..01BA ; XID_Continue # L& [195] LATIN SMALL LETTER O WITH STROKE..LATIN SMALL LETTER EZH WITH TAIL
@@ -7108,6 +7475,9 @@
0829..082D ; XID_Continue # Mn [5] SAMARITAN VOWEL SIGN LONG I..SAMARITAN MARK NEQUDAA
0840..0858 ; XID_Continue # Lo [25] MANDAIC LETTER HALQA..MANDAIC LETTER AIN
0859..085B ; XID_Continue # Mn [3] MANDAIC AFFRICATION MARK..MANDAIC GEMINATION MARK
+08A0 ; XID_Continue # Lo ARABIC LETTER BEH WITH SMALL V BELOW
+08A2..08AC ; XID_Continue # Lo [11] ARABIC LETTER JEEM WITH TWO DOTS ABOVE..ARABIC LETTER ROHINGYA YEH
+08E4..08FE ; XID_Continue # Mn [27] ARABIC CURLY FATHA..ARABIC DAMMA WITH DOT
0900..0902 ; XID_Continue # Mn [3] DEVANAGARI SIGN INVERTED CANDRABINDU..DEVANAGARI SIGN ANUSVARA
0903 ; XID_Continue # Mc DEVANAGARI SIGN VISARGA
0904..0939 ; XID_Continue # Lo [54] DEVANAGARI LETTER SHORT A..DEVANAGARI LETTER HA
@@ -7329,7 +7699,7 @@
0EC6 ; XID_Continue # Lm LAO KO LA
0EC8..0ECD ; XID_Continue # Mn [6] LAO TONE MAI EK..LAO NIGGAHITA
0ED0..0ED9 ; XID_Continue # Nd [10] LAO DIGIT ZERO..LAO DIGIT NINE
-0EDC..0EDD ; XID_Continue # Lo [2] LAO HO NO..LAO HO MO
+0EDC..0EDF ; XID_Continue # Lo [4] LAO HO NO..LAO LETTER KHMU NYO
0F00 ; XID_Continue # Lo TIBETAN SYLLABLE OM
0F18..0F19 ; XID_Continue # Mn [2] TIBETAN ASTROLOGICAL SIGN -KHYUD PA..TIBETAN ASTROLOGICAL SIGN SDONG TSHUGS
0F20..0F29 ; XID_Continue # Nd [10] TIBETAN DIGIT ZERO..TIBETAN DIGIT NINE
@@ -7381,9 +7751,11 @@
109A..109C ; XID_Continue # Mc [3] MYANMAR SIGN KHAMTI TONE-1..MYANMAR VOWEL SIGN AITON A
109D ; XID_Continue # Mn MYANMAR VOWEL SIGN AITON AI
10A0..10C5 ; XID_Continue # L& [38] GEORGIAN CAPITAL LETTER AN..GEORGIAN CAPITAL LETTER HOE
+10C7 ; XID_Continue # L& GEORGIAN CAPITAL LETTER YN
+10CD ; XID_Continue # L& GEORGIAN CAPITAL LETTER AEN
10D0..10FA ; XID_Continue # Lo [43] GEORGIAN LETTER AN..GEORGIAN LETTER AIN
10FC ; XID_Continue # Lm MODIFIER LETTER GEORGIAN NAR
-1100..1248 ; XID_Continue # Lo [329] HANGUL CHOSEONG KIYEOK..ETHIOPIC SYLLABLE QWA
+10FD..1248 ; XID_Continue # Lo [332] GEORGIAN LETTER AEN..ETHIOPIC SYLLABLE QWA
124A..124D ; XID_Continue # Lo [4] ETHIOPIC SYLLABLE QWI..ETHIOPIC SYLLABLE QWE
1250..1256 ; XID_Continue # Lo [7] ETHIOPIC SYLLABLE QHA..ETHIOPIC SYLLABLE QHO
1258 ; XID_Continue # Lo ETHIOPIC SYLLABLE QHWA
@@ -7419,6 +7791,7 @@
176E..1770 ; XID_Continue # Lo [3] TAGBANWA LETTER LA..TAGBANWA LETTER SA
1772..1773 ; XID_Continue # Mn [2] TAGBANWA VOWEL SIGN I..TAGBANWA VOWEL SIGN U
1780..17B3 ; XID_Continue # Lo [52] KHMER LETTER KA..KHMER INDEPENDENT VOWEL QAU
+17B4..17B5 ; XID_Continue # Mn [2] KHMER VOWEL INHERENT AQ..KHMER VOWEL INHERENT AA
17B6 ; XID_Continue # Mc KHMER VOWEL SIGN AA
17B7..17BD ; XID_Continue # Mn [7] KHMER VOWEL SIGN I..KHMER VOWEL SIGN UA
17BE..17C5 ; XID_Continue # Mc [8] KHMER VOWEL SIGN OE..KHMER VOWEL SIGN AU
@@ -7497,9 +7870,11 @@
1BA6..1BA7 ; XID_Continue # Mc [2] SUNDANESE VOWEL SIGN PANAELAENG..SUNDANESE VOWEL SIGN PANOLONG
1BA8..1BA9 ; XID_Continue # Mn [2] SUNDANESE VOWEL SIGN PAMEPET..SUNDANESE VOWEL SIGN PANEULEUNG
1BAA ; XID_Continue # Mc SUNDANESE SIGN PAMAAEH
+1BAB ; XID_Continue # Mn SUNDANESE SIGN VIRAMA
+1BAC..1BAD ; XID_Continue # Mc [2] SUNDANESE CONSONANT SIGN PASANGAN MA..SUNDANESE CONSONANT SIGN PASANGAN WA
1BAE..1BAF ; XID_Continue # Lo [2] SUNDANESE LETTER KHA..SUNDANESE LETTER SYA
1BB0..1BB9 ; XID_Continue # Nd [10] SUNDANESE DIGIT ZERO..SUNDANESE DIGIT NINE
-1BC0..1BE5 ; XID_Continue # Lo [38] BATAK LETTER A..BATAK LETTER U
+1BBA..1BE5 ; XID_Continue # Lo [44] SUNDANESE AVAGRAHA..BATAK LETTER U
1BE6 ; XID_Continue # Mn BATAK SIGN TOMPI
1BE7 ; XID_Continue # Mc BATAK VOWEL SIGN E
1BE8..1BE9 ; XID_Continue # Mn [2] BATAK VOWEL SIGN PAKPAK E..BATAK VOWEL SIGN EE
@@ -7525,10 +7900,12 @@
1CE9..1CEC ; XID_Continue # Lo [4] VEDIC SIGN ANUSVARA ANTARGOMUKHA..VEDIC SIGN ANUSVARA VAMAGOMUKHA WITH TAIL
1CED ; XID_Continue # Mn VEDIC SIGN TIRYAK
1CEE..1CF1 ; XID_Continue # Lo [4] VEDIC SIGN HEXIFORM LONG ANUSVARA..VEDIC SIGN ANUSVARA UBHAYATO MUKHA
-1CF2 ; XID_Continue # Mc VEDIC SIGN ARDHAVISARGA
+1CF2..1CF3 ; XID_Continue # Mc [2] VEDIC SIGN ARDHAVISARGA..VEDIC SIGN ROTATED ARDHAVISARGA
+1CF4 ; XID_Continue # Mn VEDIC TONE CANDRA ABOVE
+1CF5..1CF6 ; XID_Continue # Lo [2] VEDIC SIGN JIHVAMULIYA..VEDIC SIGN UPADHMANIYA
1D00..1D2B ; XID_Continue # L& [44] LATIN LETTER SMALL CAPITAL A..CYRILLIC LETTER SMALL CAPITAL EL
-1D2C..1D61 ; XID_Continue # Lm [54] MODIFIER LETTER CAPITAL A..MODIFIER LETTER SMALL CHI
-1D62..1D77 ; XID_Continue # L& [22] LATIN SUBSCRIPT SMALL LETTER I..LATIN SMALL LETTER TURNED G
+1D2C..1D6A ; XID_Continue # Lm [63] MODIFIER LETTER CAPITAL A..GREEK SUBSCRIPT SMALL LETTER CHI
+1D6B..1D77 ; XID_Continue # L& [13] LATIN SMALL LETTER UE..LATIN SMALL LETTER TURNED G
1D78 ; XID_Continue # Lm MODIFIER LETTER CYRILLIC EN
1D79..1D9A ; XID_Continue # L& [34] LATIN SMALL LETTER INSULAR G..LATIN SMALL LETTER EZH WITH RETROFLEX HOOK
1D9B..1DBF ; XID_Continue # Lm [37] MODIFIER LETTER SMALL TURNED ALPHA..MODIFIER LETTER SMALL THETA
@@ -7583,13 +7960,16 @@
2185..2188 ; XID_Continue # Nl [4] ROMAN NUMERAL SIX LATE FORM..ROMAN NUMERAL ONE HUNDRED THOUSAND
2C00..2C2E ; XID_Continue # L& [47] GLAGOLITIC CAPITAL LETTER AZU..GLAGOLITIC CAPITAL LETTER LATINATE MYSLITE
2C30..2C5E ; XID_Continue # L& [47] GLAGOLITIC SMALL LETTER AZU..GLAGOLITIC SMALL LETTER LATINATE MYSLITE
-2C60..2C7C ; XID_Continue # L& [29] LATIN CAPITAL LETTER L WITH DOUBLE BAR..LATIN SUBSCRIPT SMALL LETTER J
-2C7D ; XID_Continue # Lm MODIFIER LETTER CAPITAL V
+2C60..2C7B ; XID_Continue # L& [28] LATIN CAPITAL LETTER L WITH DOUBLE BAR..LATIN LETTER SMALL CAPITAL TURNED E
+2C7C..2C7D ; XID_Continue # Lm [2] LATIN SUBSCRIPT SMALL LETTER J..MODIFIER LETTER CAPITAL V
2C7E..2CE4 ; XID_Continue # L& [103] LATIN CAPITAL LETTER S WITH SWASH TAIL..COPTIC SYMBOL KAI
2CEB..2CEE ; XID_Continue # L& [4] COPTIC CAPITAL LETTER CRYPTOGRAMMIC SHEI..COPTIC SMALL LETTER CRYPTOGRAMMIC GANGIA
2CEF..2CF1 ; XID_Continue # Mn [3] COPTIC COMBINING NI ABOVE..COPTIC COMBINING SPIRITUS LENIS
+2CF2..2CF3 ; XID_Continue # L& [2] COPTIC CAPITAL LETTER BOHAIRIC KHEI..COPTIC SMALL LETTER BOHAIRIC KHEI
2D00..2D25 ; XID_Continue # L& [38] GEORGIAN SMALL LETTER AN..GEORGIAN SMALL LETTER HOE
-2D30..2D65 ; XID_Continue # Lo [54] TIFINAGH LETTER YA..TIFINAGH LETTER YAZZ
+2D27 ; XID_Continue # L& GEORGIAN SMALL LETTER YN
+2D2D ; XID_Continue # L& GEORGIAN SMALL LETTER AEN
+2D30..2D67 ; XID_Continue # Lo [56] TIFINAGH LETTER YA..TIFINAGH LETTER YO
2D6F ; XID_Continue # Lm TIFINAGH MODIFIER LETTER LABIALIZATION MARK
2D7F ; XID_Continue # Mn TIFINAGH CONSONANT JOINER
2D80..2D96 ; XID_Continue # Lo [23] ETHIOPIC SYLLABLE LOA..ETHIOPIC SYLLABLE GGWE
@@ -7606,7 +7986,8 @@
3006 ; XID_Continue # Lo IDEOGRAPHIC CLOSING MARK
3007 ; XID_Continue # Nl IDEOGRAPHIC NUMBER ZERO
3021..3029 ; XID_Continue # Nl [9] HANGZHOU NUMERAL ONE..HANGZHOU NUMERAL NINE
-302A..302F ; XID_Continue # Mn [6] IDEOGRAPHIC LEVEL TONE MARK..HANGUL DOUBLE DOT TONE MARK
+302A..302D ; XID_Continue # Mn [4] IDEOGRAPHIC LEVEL TONE MARK..IDEOGRAPHIC ENTERING TONE MARK
+302E..302F ; XID_Continue # Mc [2] HANGUL SINGLE DOT TONE MARK..HANGUL DOUBLE DOT TONE MARK
3031..3035 ; XID_Continue # Lm [5] VERTICAL KANA REPEAT MARK..VERTICAL KANA REPEAT MARK LOWER HALF
3038..303A ; XID_Continue # Nl [3] HANGZHOU NUMERAL TEN..HANGZHOU NUMERAL THIRTY
303B ; XID_Continue # Lm VERTICAL IDEOGRAPHIC ITERATION MARK
@@ -7623,7 +8004,7 @@
31A0..31BA ; XID_Continue # Lo [27] BOPOMOFO LETTER BU..BOPOMOFO LETTER ZY
31F0..31FF ; XID_Continue # Lo [16] KATAKANA LETTER SMALL KU..KATAKANA LETTER SMALL RO
3400..4DB5 ; XID_Continue # Lo [6582] CJK UNIFIED IDEOGRAPH-3400..CJK UNIFIED IDEOGRAPH-4DB5
-4E00..9FCB ; XID_Continue # Lo [20940] CJK UNIFIED IDEOGRAPH-4E00..CJK UNIFIED IDEOGRAPH-9FCB
+4E00..9FCC ; XID_Continue # Lo [20941] CJK UNIFIED IDEOGRAPH-4E00..CJK UNIFIED IDEOGRAPH-9FCC
A000..A014 ; XID_Continue # Lo [21] YI SYLLABLE IT..YI SYLLABLE E
A015 ; XID_Continue # Lm YI SYLLABLE WU
A016..A48C ; XID_Continue # Lo [1143] YI SYLLABLE BIT..YI SYLLABLE YYR
@@ -7637,9 +8018,10 @@
A640..A66D ; XID_Continue # L& [46] CYRILLIC CAPITAL LETTER ZEMLYA..CYRILLIC SMALL LETTER DOUBLE MONOCULAR O
A66E ; XID_Continue # Lo CYRILLIC LETTER MULTIOCULAR O
A66F ; XID_Continue # Mn COMBINING CYRILLIC VZMET
-A67C..A67D ; XID_Continue # Mn [2] COMBINING CYRILLIC KAVYKA..COMBINING CYRILLIC PAYEROK
+A674..A67D ; XID_Continue # Mn [10] COMBINING CYRILLIC LETTER UKRAINIAN IE..COMBINING CYRILLIC PAYEROK
A67F ; XID_Continue # Lm CYRILLIC PAYEROK
A680..A697 ; XID_Continue # L& [24] CYRILLIC CAPITAL LETTER DWE..CYRILLIC SMALL LETTER SHWE
+A69F ; XID_Continue # Mn COMBINING CYRILLIC LETTER IOTIFIED E
A6A0..A6E5 ; XID_Continue # Lo [70] BAMUM LETTER A..BAMUM LETTER KI
A6E6..A6EF ; XID_Continue # Nl [10] BAMUM LETTER MO..BAMUM LETTER KOGHOM
A6F0..A6F1 ; XID_Continue # Mn [2] BAMUM COMBINING MARK KOQNDON..BAMUM COMBINING MARK TUKWENTIS
@@ -7649,8 +8031,9 @@
A771..A787 ; XID_Continue # L& [23] LATIN SMALL LETTER DUM..LATIN SMALL LETTER INSULAR T
A788 ; XID_Continue # Lm MODIFIER LETTER LOW CIRCUMFLEX ACCENT
A78B..A78E ; XID_Continue # L& [4] LATIN CAPITAL LETTER SALTILLO..LATIN SMALL LETTER L WITH RETROFLEX HOOK AND BELT
-A790..A791 ; XID_Continue # L& [2] LATIN CAPITAL LETTER N WITH DESCENDER..LATIN SMALL LETTER N WITH DESCENDER
-A7A0..A7A9 ; XID_Continue # L& [10] LATIN CAPITAL LETTER G WITH OBLIQUE STROKE..LATIN SMALL LETTER S WITH OBLIQUE STROKE
+A790..A793 ; XID_Continue # L& [4] LATIN CAPITAL LETTER N WITH DESCENDER..LATIN SMALL LETTER C WITH BAR
+A7A0..A7AA ; XID_Continue # L& [11] LATIN CAPITAL LETTER G WITH OBLIQUE STROKE..LATIN CAPITAL LETTER H WITH HOOK
+A7F8..A7F9 ; XID_Continue # Lm [2] MODIFIER LETTER CAPITAL H WITH STROKE..MODIFIER LETTER SMALL LIGATURE OE
A7FA ; XID_Continue # L& LATIN LETTER SMALL CAPITAL TURNED M
A7FB..A801 ; XID_Continue # Lo [7] LATIN EPIGRAPHIC LETTER REVERSED F..SYLOTI NAGRI LETTER I
A802 ; XID_Continue # Mn SYLOTI NAGRI SIGN DVISVARA
@@ -7719,6 +8102,14 @@
AAC2 ; XID_Continue # Lo TAI VIET TONE MAI SONG
AADB..AADC ; XID_Continue # Lo [2] TAI VIET SYMBOL KON..TAI VIET SYMBOL NUENG
AADD ; XID_Continue # Lm TAI VIET SYMBOL SAM
+AAE0..AAEA ; XID_Continue # Lo [11] MEETEI MAYEK LETTER E..MEETEI MAYEK LETTER SSA
+AAEB ; XID_Continue # Mc MEETEI MAYEK VOWEL SIGN II
+AAEC..AAED ; XID_Continue # Mn [2] MEETEI MAYEK VOWEL SIGN UU..MEETEI MAYEK VOWEL SIGN AAI
+AAEE..AAEF ; XID_Continue # Mc [2] MEETEI MAYEK VOWEL SIGN AU..MEETEI MAYEK VOWEL SIGN AAU
+AAF2 ; XID_Continue # Lo MEETEI MAYEK ANJI
+AAF3..AAF4 ; XID_Continue # Lm [2] MEETEI MAYEK SYLLABLE REPETITION MARK..MEETEI MAYEK WORD REPETITION MARK
+AAF5 ; XID_Continue # Mc MEETEI MAYEK VOWEL SIGN VISARGA
+AAF6 ; XID_Continue # Mn MEETEI MAYEK VIRAMA
AB01..AB06 ; XID_Continue # Lo [6] ETHIOPIC SYLLABLE TTHU..ETHIOPIC SYLLABLE TTHO
AB09..AB0E ; XID_Continue # Lo [6] ETHIOPIC SYLLABLE DDHU..ETHIOPIC SYLLABLE DDHO
AB11..AB16 ; XID_Continue # Lo [6] ETHIOPIC SYLLABLE DZU..ETHIOPIC SYLLABLE DZO
@@ -7736,8 +8127,7 @@
AC00..D7A3 ; XID_Continue # Lo [11172] HANGUL SYLLABLE GA..HANGUL SYLLABLE HIH
D7B0..D7C6 ; XID_Continue # Lo [23] HANGUL JUNGSEONG O-YEO..HANGUL JUNGSEONG ARAEA-E
D7CB..D7FB ; XID_Continue # Lo [49] HANGUL JONGSEONG NIEUN-RIEUL..HANGUL JONGSEONG PHIEUPH-THIEUTH
-F900..FA2D ; XID_Continue # Lo [302] CJK COMPATIBILITY IDEOGRAPH-F900..CJK COMPATIBILITY IDEOGRAPH-FA2D
-FA30..FA6D ; XID_Continue # Lo [62] CJK COMPATIBILITY IDEOGRAPH-FA30..CJK COMPATIBILITY IDEOGRAPH-FA6D
+F900..FA6D ; XID_Continue # Lo [366] CJK COMPATIBILITY IDEOGRAPH-F900..CJK COMPATIBILITY IDEOGRAPH-FA6D
FA70..FAD9 ; XID_Continue # Lo [106] CJK COMPATIBILITY IDEOGRAPH-FA70..CJK COMPATIBILITY IDEOGRAPH-FAD9
FB00..FB06 ; XID_Continue # L& [7] LATIN SMALL LIGATURE FF..LATIN SMALL LIGATURE ST
FB13..FB17 ; XID_Continue # L& [5] ARMENIAN SMALL LIGATURE MEN NOW..ARMENIAN SMALL LIGATURE MEN XEH
@@ -7810,6 +8200,8 @@
1083F..10855 ; XID_Continue # Lo [23] CYPRIOT SYLLABLE ZO..IMPERIAL ARAMAIC LETTER TAW
10900..10915 ; XID_Continue # Lo [22] PHOENICIAN LETTER ALF..PHOENICIAN LETTER TAU
10920..10939 ; XID_Continue # Lo [26] LYDIAN LETTER A..LYDIAN LETTER C
+10980..109B7 ; XID_Continue # Lo [56] MEROITIC HIEROGLYPHIC LETTER A..MEROITIC CURSIVE LETTER DA
+109BE..109BF ; XID_Continue # Lo [2] MEROITIC CURSIVE LOGOGRAM RMT..MEROITIC CURSIVE LOGOGRAM IMN
10A00 ; XID_Continue # Lo KHAROSHTHI LETTER A
10A01..10A03 ; XID_Continue # Mn [3] KHAROSHTHI VOWEL SIGN I..KHAROSHTHI VOWEL SIGN VOCALIC R
10A05..10A06 ; XID_Continue # Mn [2] KHAROSHTHI VOWEL SIGN E..KHAROSHTHI VOWEL SIGN O
@@ -7837,10 +8229,40 @@
110B3..110B6 ; XID_Continue # Mn [4] KAITHI VOWEL SIGN U..KAITHI VOWEL SIGN AI
110B7..110B8 ; XID_Continue # Mc [2] KAITHI VOWEL SIGN O..KAITHI VOWEL SIGN AU
110B9..110BA ; XID_Continue # Mn [2] KAITHI SIGN VIRAMA..KAITHI SIGN NUKTA
+110D0..110E8 ; XID_Continue # Lo [25] SORA SOMPENG LETTER SAH..SORA SOMPENG LETTER MAE
+110F0..110F9 ; XID_Continue # Nd [10] SORA SOMPENG DIGIT ZERO..SORA SOMPENG DIGIT NINE
+11100..11102 ; XID_Continue # Mn [3] CHAKMA SIGN CANDRABINDU..CHAKMA SIGN VISARGA
+11103..11126 ; XID_Continue # Lo [36] CHAKMA LETTER AA..CHAKMA LETTER HAA
+11127..1112B ; XID_Continue # Mn [5] CHAKMA VOWEL SIGN A..CHAKMA VOWEL SIGN UU
+1112C ; XID_Continue # Mc CHAKMA VOWEL SIGN E
+1112D..11134 ; XID_Continue # Mn [8] CHAKMA VOWEL SIGN AI..CHAKMA MAAYYAA
+11136..1113F ; XID_Continue # Nd [10] CHAKMA DIGIT ZERO..CHAKMA DIGIT NINE
+11180..11181 ; XID_Continue # Mn [2] SHARADA SIGN CANDRABINDU..SHARADA SIGN ANUSVARA
+11182 ; XID_Continue # Mc SHARADA SIGN VISARGA
+11183..111B2 ; XID_Continue # Lo [48] SHARADA LETTER A..SHARADA LETTER HA
+111B3..111B5 ; XID_Continue # Mc [3] SHARADA VOWEL SIGN AA..SHARADA VOWEL SIGN II
+111B6..111BE ; XID_Continue # Mn [9] SHARADA VOWEL SIGN U..SHARADA VOWEL SIGN O
+111BF..111C0 ; XID_Continue # Mc [2] SHARADA VOWEL SIGN AU..SHARADA SIGN VIRAMA
+111C1..111C4 ; XID_Continue # Lo [4] SHARADA SIGN AVAGRAHA..SHARADA OM
+111D0..111D9 ; XID_Continue # Nd [10] SHARADA DIGIT ZERO..SHARADA DIGIT NINE
+11680..116AA ; XID_Continue # Lo [43] TAKRI LETTER A..TAKRI LETTER RRA
+116AB ; XID_Continue # Mn TAKRI SIGN ANUSVARA
+116AC ; XID_Continue # Mc TAKRI SIGN VISARGA
+116AD ; XID_Continue # Mn TAKRI VOWEL SIGN AA
+116AE..116AF ; XID_Continue # Mc [2] TAKRI VOWEL SIGN I..TAKRI VOWEL SIGN II
+116B0..116B5 ; XID_Continue # Mn [6] TAKRI VOWEL SIGN U..TAKRI VOWEL SIGN AU
+116B6 ; XID_Continue # Mc TAKRI SIGN VIRAMA
+116B7 ; XID_Continue # Mn TAKRI SIGN NUKTA
+116C0..116C9 ; XID_Continue # Nd [10] TAKRI DIGIT ZERO..TAKRI DIGIT NINE
12000..1236E ; XID_Continue # Lo [879] CUNEIFORM SIGN A..CUNEIFORM SIGN ZUM
12400..12462 ; XID_Continue # Nl [99] CUNEIFORM NUMERIC SIGN TWO ASH..CUNEIFORM NUMERIC SIGN OLD ASSYRIAN ONE QUARTER
13000..1342E ; XID_Continue # Lo [1071] EGYPTIAN HIEROGLYPH A001..EGYPTIAN HIEROGLYPH AA032
16800..16A38 ; XID_Continue # Lo [569] BAMUM LETTER PHASE-A NGKUE MFON..BAMUM LETTER PHASE-F VUEQ
+16F00..16F44 ; XID_Continue # Lo [69] MIAO LETTER PA..MIAO LETTER HHA
+16F50 ; XID_Continue # Lo MIAO LETTER NASALIZATION
+16F51..16F7E ; XID_Continue # Mc [46] MIAO SIGN ASPIRATION..MIAO VOWEL SIGN NG
+16F8F..16F92 ; XID_Continue # Mn [4] MIAO TONE RIGHT..MIAO TONE BELOW
+16F93..16F9F ; XID_Continue # Lm [13] MIAO LETTER TONE-2..MIAO LETTER REFORMED TONE-8
1B000..1B001 ; XID_Continue # Lo [2] KATAKANA LETTER ARCHAIC E..HIRAGANA LETTER ARCHAIC YE
1D165..1D166 ; XID_Continue # Mc [2] MUSICAL SYMBOL COMBINING STEM..MUSICAL SYMBOL COMBINING SPRECHGESANG STEM
1D167..1D169 ; XID_Continue # Mn [3] MUSICAL SYMBOL COMBINING TREMOLO-1..MUSICAL SYMBOL COMBINING TREMOLO-3
@@ -7880,6 +8302,39 @@
1D7AA..1D7C2 ; XID_Continue # L& [25] MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL ALPHA..MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL OMEGA
1D7C4..1D7CB ; XID_Continue # L& [8] MATHEMATICAL SANS-SERIF BOLD ITALIC EPSILON SYMBOL..MATHEMATICAL BOLD SMALL DIGAMMA
1D7CE..1D7FF ; XID_Continue # Nd [50] MATHEMATICAL BOLD DIGIT ZERO..MATHEMATICAL MONOSPACE DIGIT NINE
+1EE00..1EE03 ; XID_Continue # Lo [4] ARABIC MATHEMATICAL ALEF..ARABIC MATHEMATICAL DAL
+1EE05..1EE1F ; XID_Continue # Lo [27] ARABIC MATHEMATICAL WAW..ARABIC MATHEMATICAL DOTLESS QAF
+1EE21..1EE22 ; XID_Continue # Lo [2] ARABIC MATHEMATICAL INITIAL BEH..ARABIC MATHEMATICAL INITIAL JEEM
+1EE24 ; XID_Continue # Lo ARABIC MATHEMATICAL INITIAL HEH
+1EE27 ; XID_Continue # Lo ARABIC MATHEMATICAL INITIAL HAH
+1EE29..1EE32 ; XID_Continue # Lo [10] ARABIC MATHEMATICAL INITIAL YEH..ARABIC MATHEMATICAL INITIAL QAF
+1EE34..1EE37 ; XID_Continue # Lo [4] ARABIC MATHEMATICAL INITIAL SHEEN..ARABIC MATHEMATICAL INITIAL KHAH
+1EE39 ; XID_Continue # Lo ARABIC MATHEMATICAL INITIAL DAD
+1EE3B ; XID_Continue # Lo ARABIC MATHEMATICAL INITIAL GHAIN
+1EE42 ; XID_Continue # Lo ARABIC MATHEMATICAL TAILED JEEM
+1EE47 ; XID_Continue # Lo ARABIC MATHEMATICAL TAILED HAH
+1EE49 ; XID_Continue # Lo ARABIC MATHEMATICAL TAILED YEH
+1EE4B ; XID_Continue # Lo ARABIC MATHEMATICAL TAILED LAM
+1EE4D..1EE4F ; XID_Continue # Lo [3] ARABIC MATHEMATICAL TAILED NOON..ARABIC MATHEMATICAL TAILED AIN
+1EE51..1EE52 ; XID_Continue # Lo [2] ARABIC MATHEMATICAL TAILED SAD..ARABIC MATHEMATICAL TAILED QAF
+1EE54 ; XID_Continue # Lo ARABIC MATHEMATICAL TAILED SHEEN
+1EE57 ; XID_Continue # Lo ARABIC MATHEMATICAL TAILED KHAH
+1EE59 ; XID_Continue # Lo ARABIC MATHEMATICAL TAILED DAD
+1EE5B ; XID_Continue # Lo ARABIC MATHEMATICAL TAILED GHAIN
+1EE5D ; XID_Continue # Lo ARABIC MATHEMATICAL TAILED DOTLESS NOON
+1EE5F ; XID_Continue # Lo ARABIC MATHEMATICAL TAILED DOTLESS QAF
+1EE61..1EE62 ; XID_Continue # Lo [2] ARABIC MATHEMATICAL STRETCHED BEH..ARABIC MATHEMATICAL STRETCHED JEEM
+1EE64 ; XID_Continue # Lo ARABIC MATHEMATICAL STRETCHED HEH
+1EE67..1EE6A ; XID_Continue # Lo [4] ARABIC MATHEMATICAL STRETCHED HAH..ARABIC MATHEMATICAL STRETCHED KAF
+1EE6C..1EE72 ; XID_Continue # Lo [7] ARABIC MATHEMATICAL STRETCHED MEEM..ARABIC MATHEMATICAL STRETCHED QAF
+1EE74..1EE77 ; XID_Continue # Lo [4] ARABIC MATHEMATICAL STRETCHED SHEEN..ARABIC MATHEMATICAL STRETCHED KHAH
+1EE79..1EE7C ; XID_Continue # Lo [4] ARABIC MATHEMATICAL STRETCHED DAD..ARABIC MATHEMATICAL STRETCHED DOTLESS BEH
+1EE7E ; XID_Continue # Lo ARABIC MATHEMATICAL STRETCHED DOTLESS FEH
+1EE80..1EE89 ; XID_Continue # Lo [10] ARABIC MATHEMATICAL LOOPED ALEF..ARABIC MATHEMATICAL LOOPED YEH
+1EE8B..1EE9B ; XID_Continue # Lo [17] ARABIC MATHEMATICAL LOOPED LAM..ARABIC MATHEMATICAL LOOPED GHAIN
+1EEA1..1EEA3 ; XID_Continue # Lo [3] ARABIC MATHEMATICAL DOUBLE-STRUCK BEH..ARABIC MATHEMATICAL DOUBLE-STRUCK DAL
+1EEA5..1EEA9 ; XID_Continue # Lo [5] ARABIC MATHEMATICAL DOUBLE-STRUCK WAW..ARABIC MATHEMATICAL DOUBLE-STRUCK YEH
+1EEAB..1EEBB ; XID_Continue # Lo [17] ARABIC MATHEMATICAL DOUBLE-STRUCK LAM..ARABIC MATHEMATICAL DOUBLE-STRUCK GHAIN
20000..2A6D6 ; XID_Continue # Lo [42711] CJK UNIFIED IDEOGRAPH-20000..CJK UNIFIED IDEOGRAPH-2A6D6
2A700..2B734 ; XID_Continue # Lo [4149] CJK UNIFIED IDEOGRAPH-2A700..CJK UNIFIED IDEOGRAPH-2B734
2B740..2B81D ; XID_Continue # Lo [222] CJK UNIFIED IDEOGRAPH-2B740..CJK UNIFIED IDEOGRAPH-2B81D
@@ -7886,7 +8341,7 @@
2F800..2FA1D ; XID_Continue # Lo [542] CJK COMPATIBILITY IDEOGRAPH-2F800..CJK COMPATIBILITY IDEOGRAPH-2FA1D
E0100..E01EF ; XID_Continue # Mn [240] VARIATION SELECTOR-17..VARIATION SELECTOR-256
-# Total code points: 102656
+# Total code points: 103336
# ================================================
@@ -7897,12 +8352,12 @@
# + Variation_Selector
# - White_Space
# - FFF9..FFFB (Annotation Characters)
-# - 0600..0603, 06DD, 070F, 110BD (exceptional Cf characters that should be visible)
+# - 0600..0604, 06DD, 070F, 110BD (exceptional Cf characters that should be visible)
00AD ; Default_Ignorable_Code_Point # Cf SOFT HYPHEN
034F ; Default_Ignorable_Code_Point # Mn COMBINING GRAPHEME JOINER
115F..1160 ; Default_Ignorable_Code_Point # Lo [2] HANGUL CHOSEONG FILLER..HANGUL JUNGSEONG FILLER
-17B4..17B5 ; Default_Ignorable_Code_Point # Cf [2] KHMER VOWEL INHERENT AQ..KHMER VOWEL INHERENT AA
+17B4..17B5 ; Default_Ignorable_Code_Point # Mn [2] KHMER VOWEL INHERENT AQ..KHMER VOWEL INHERENT AA
180B..180D ; Default_Ignorable_Code_Point # Mn [3] MONGOLIAN FREE VARIATION SELECTOR ONE..MONGOLIAN FREE VARIATION SELECTOR THREE
200B..200F ; Default_Ignorable_Code_Point # Cf [5] ZERO WIDTH SPACE..RIGHT-TO-LEFT MARK
202A..202E ; Default_Ignorable_Code_Point # Cf [5] LEFT-TO-RIGHT EMBEDDING..RIGHT-TO-LEFT OVERRIDE
@@ -7956,6 +8411,7 @@
0825..0827 ; Grapheme_Extend # Mn [3] SAMARITAN VOWEL SIGN SHORT A..SAMARITAN VOWEL SIGN U
0829..082D ; Grapheme_Extend # Mn [5] SAMARITAN VOWEL SIGN LONG I..SAMARITAN MARK NEQUDAA
0859..085B ; Grapheme_Extend # Mn [3] MANDAIC AFFRICATION MARK..MANDAIC GEMINATION MARK
+08E4..08FE ; Grapheme_Extend # Mn [27] ARABIC CURLY FATHA..ARABIC DAMMA WITH DOT
0900..0902 ; Grapheme_Extend # Mn [3] DEVANAGARI SIGN INVERTED CANDRABINDU..DEVANAGARI SIGN ANUSVARA
093A ; Grapheme_Extend # Mn DEVANAGARI VOWEL SIGN OE
093C ; Grapheme_Extend # Mn DEVANAGARI SIGN NUKTA
@@ -8053,6 +8509,7 @@
1732..1734 ; Grapheme_Extend # Mn [3] HANUNOO VOWEL SIGN I..HANUNOO SIGN PAMUDPOD
1752..1753 ; Grapheme_Extend # Mn [2] BUHID VOWEL SIGN I..BUHID VOWEL SIGN U
1772..1773 ; Grapheme_Extend # Mn [2] TAGBANWA VOWEL SIGN I..TAGBANWA VOWEL SIGN U
+17B4..17B5 ; Grapheme_Extend # Mn [2] KHMER VOWEL INHERENT AQ..KHMER VOWEL INHERENT AA
17B7..17BD ; Grapheme_Extend # Mn [7] KHMER VOWEL SIGN I..KHMER VOWEL SIGN UA
17C6 ; Grapheme_Extend # Mn KHMER SIGN NIKAHIT
17C9..17D3 ; Grapheme_Extend # Mn [11] KHMER SIGN MUUSIKATOAN..KHMER SIGN BATHAMASAT
@@ -8080,6 +8537,7 @@
1B80..1B81 ; Grapheme_Extend # Mn [2] SUNDANESE SIGN PANYECEK..SUNDANESE SIGN PANGLAYAR
1BA2..1BA5 ; Grapheme_Extend # Mn [4] SUNDANESE CONSONANT SIGN PANYAKRA..SUNDANESE VOWEL SIGN PANYUKU
1BA8..1BA9 ; Grapheme_Extend # Mn [2] SUNDANESE VOWEL SIGN PAMEPET..SUNDANESE VOWEL SIGN PANEULEUNG
+1BAB ; Grapheme_Extend # Mn SUNDANESE SIGN VIRAMA
1BE6 ; Grapheme_Extend # Mn BATAK SIGN TOMPI
1BE8..1BE9 ; Grapheme_Extend # Mn [2] BATAK VOWEL SIGN PAKPAK E..BATAK VOWEL SIGN EE
1BED ; Grapheme_Extend # Mn BATAK VOWEL SIGN KARO O
@@ -8090,6 +8548,7 @@
1CD4..1CE0 ; Grapheme_Extend # Mn [13] VEDIC SIGN YAJURVEDIC MIDLINE SVARITA..VEDIC TONE RIGVEDIC KASHMIRI INDEPENDENT SVARITA
1CE2..1CE8 ; Grapheme_Extend # Mn [7] VEDIC SIGN VISARGA SVARITA..VEDIC SIGN VISARGA ANUDATTA WITH TAIL
1CED ; Grapheme_Extend # Mn VEDIC SIGN TIRYAK
+1CF4 ; Grapheme_Extend # Mn VEDIC TONE CANDRA ABOVE
1DC0..1DE6 ; Grapheme_Extend # Mn [39] COMBINING DOTTED GRAVE ACCENT..COMBINING LATIN SMALL LETTER Z
1DFC..1DFF ; Grapheme_Extend # Mn [4] COMBINING DOUBLE INVERTED BREVE BELOW..COMBINING RIGHT ARROWHEAD AND DOWN ARROWHEAD BELOW
200C..200D ; Grapheme_Extend # Cf [2] ZERO WIDTH NON-JOINER..ZERO WIDTH JOINER
@@ -8101,11 +8560,13 @@
2CEF..2CF1 ; Grapheme_Extend # Mn [3] COPTIC COMBINING NI ABOVE..COPTIC COMBINING SPIRITUS LENIS
2D7F ; Grapheme_Extend # Mn TIFINAGH CONSONANT JOINER
2DE0..2DFF ; Grapheme_Extend # Mn [32] COMBINING CYRILLIC LETTER BE..COMBINING CYRILLIC LETTER IOTIFIED BIG YUS
-302A..302F ; Grapheme_Extend # Mn [6] IDEOGRAPHIC LEVEL TONE MARK..HANGUL DOUBLE DOT TONE MARK
+302A..302D ; Grapheme_Extend # Mn [4] IDEOGRAPHIC LEVEL TONE MARK..IDEOGRAPHIC ENTERING TONE MARK
+302E..302F ; Grapheme_Extend # Mc [2] HANGUL SINGLE DOT TONE MARK..HANGUL DOUBLE DOT TONE MARK
3099..309A ; Grapheme_Extend # Mn [2] COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK..COMBINING KATAKANA-HIRAGANA SEMI-VOICED SOUND MARK
A66F ; Grapheme_Extend # Mn COMBINING CYRILLIC VZMET
A670..A672 ; Grapheme_Extend # Me [3] COMBINING CYRILLIC TEN MILLIONS SIGN..COMBINING CYRILLIC THOUSAND MILLIONS SIGN
-A67C..A67D ; Grapheme_Extend # Mn [2] COMBINING CYRILLIC KAVYKA..COMBINING CYRILLIC PAYEROK
+A674..A67D ; Grapheme_Extend # Mn [10] COMBINING CYRILLIC LETTER UKRAINIAN IE..COMBINING CYRILLIC PAYEROK
+A69F ; Grapheme_Extend # Mn COMBINING CYRILLIC LETTER IOTIFIED E
A6F0..A6F1 ; Grapheme_Extend # Mn [2] BAMUM COMBINING MARK KOQNDON..BAMUM COMBINING MARK TUKWENTIS
A802 ; Grapheme_Extend # Mn SYLOTI NAGRI SIGN DVISVARA
A806 ; Grapheme_Extend # Mn SYLOTI NAGRI SIGN HASANTA
@@ -8129,6 +8590,8 @@
AAB7..AAB8 ; Grapheme_Extend # Mn [2] TAI VIET MAI KHIT..TAI VIET VOWEL IA
AABE..AABF ; Grapheme_Extend # Mn [2] TAI VIET VOWEL AM..TAI VIET TONE MAI EK
AAC1 ; Grapheme_Extend # Mn TAI VIET TONE MAI THO
+AAEC..AAED ; Grapheme_Extend # Mn [2] MEETEI MAYEK VOWEL SIGN UU..MEETEI MAYEK VOWEL SIGN AAI
+AAF6 ; Grapheme_Extend # Mn MEETEI MAYEK VIRAMA
ABE5 ; Grapheme_Extend # Mn MEETEI MAYEK VOWEL SIGN ANAP
ABE8 ; Grapheme_Extend # Mn MEETEI MAYEK VOWEL SIGN UNAP
ABED ; Grapheme_Extend # Mn MEETEI MAYEK APUN IYEK
@@ -8147,6 +8610,16 @@
11080..11081 ; Grapheme_Extend # Mn [2] KAITHI SIGN CANDRABINDU..KAITHI SIGN ANUSVARA
110B3..110B6 ; Grapheme_Extend # Mn [4] KAITHI VOWEL SIGN U..KAITHI VOWEL SIGN AI
110B9..110BA ; Grapheme_Extend # Mn [2] KAITHI SIGN VIRAMA..KAITHI SIGN NUKTA
+11100..11102 ; Grapheme_Extend # Mn [3] CHAKMA SIGN CANDRABINDU..CHAKMA SIGN VISARGA
+11127..1112B ; Grapheme_Extend # Mn [5] CHAKMA VOWEL SIGN A..CHAKMA VOWEL SIGN UU
+1112D..11134 ; Grapheme_Extend # Mn [8] CHAKMA VOWEL SIGN AI..CHAKMA MAAYYAA
+11180..11181 ; Grapheme_Extend # Mn [2] SHARADA SIGN CANDRABINDU..SHARADA SIGN ANUSVARA
+111B6..111BE ; Grapheme_Extend # Mn [9] SHARADA VOWEL SIGN U..SHARADA VOWEL SIGN O
+116AB ; Grapheme_Extend # Mn TAKRI SIGN ANUSVARA
+116AD ; Grapheme_Extend # Mn TAKRI VOWEL SIGN AA
+116B0..116B5 ; Grapheme_Extend # Mn [6] TAKRI VOWEL SIGN U..TAKRI VOWEL SIGN AU
+116B7 ; Grapheme_Extend # Mn TAKRI SIGN NUKTA
+16F8F..16F92 ; Grapheme_Extend # Mn [4] MIAO TONE RIGHT..MIAO TONE BELOW
1D165 ; Grapheme_Extend # Mc MUSICAL SYMBOL COMBINING STEM
1D167..1D169 ; Grapheme_Extend # Mn [3] MUSICAL SYMBOL COMBINING TREMOLO-1..MUSICAL SYMBOL COMBINING TREMOLO-3
1D16E..1D172 ; Grapheme_Extend # Mc [5] MUSICAL SYMBOL COMBINING FLAG-1..MUSICAL SYMBOL COMBINING FLAG-5
@@ -8156,7 +8629,7 @@
1D242..1D244 ; Grapheme_Extend # Mn [3] COMBINING GREEK MUSICAL TRISEME..COMBINING GREEK MUSICAL PENTASEME
E0100..E01EF ; Grapheme_Extend # Mn [240] VARIATION SELECTOR-17..VARIATION SELECTOR-256
-# Total code points: 1234
+# Total code points: 1317
# ================================================
@@ -8195,10 +8668,11 @@
00A0 ; Grapheme_Base # Zs NO-BREAK SPACE
00A1 ; Grapheme_Base # Po INVERTED EXCLAMATION MARK
00A2..00A5 ; Grapheme_Base # Sc [4] CENT SIGN..YEN SIGN
-00A6..00A7 ; Grapheme_Base # So [2] BROKEN BAR..SECTION SIGN
+00A6 ; Grapheme_Base # So BROKEN BAR
+00A7 ; Grapheme_Base # Po SECTION SIGN
00A8 ; Grapheme_Base # Sk DIAERESIS
00A9 ; Grapheme_Base # So COPYRIGHT SIGN
-00AA ; Grapheme_Base # L& FEMININE ORDINAL INDICATOR
+00AA ; Grapheme_Base # Lo FEMININE ORDINAL INDICATOR
00AB ; Grapheme_Base # Pi LEFT-POINTING DOUBLE ANGLE QUOTATION MARK
00AC ; Grapheme_Base # Sm NOT SIGN
00AE ; Grapheme_Base # So REGISTERED SIGN
@@ -8208,11 +8682,10 @@
00B2..00B3 ; Grapheme_Base # No [2] SUPERSCRIPT TWO..SUPERSCRIPT THREE
00B4 ; Grapheme_Base # Sk ACUTE ACCENT
00B5 ; Grapheme_Base # L& MICRO SIGN
-00B6 ; Grapheme_Base # So PILCROW SIGN
-00B7 ; Grapheme_Base # Po MIDDLE DOT
+00B6..00B7 ; Grapheme_Base # Po [2] PILCROW SIGN..MIDDLE DOT
00B8 ; Grapheme_Base # Sk CEDILLA
00B9 ; Grapheme_Base # No SUPERSCRIPT ONE
-00BA ; Grapheme_Base # L& MASCULINE ORDINAL INDICATOR
+00BA ; Grapheme_Base # Lo MASCULINE ORDINAL INDICATOR
00BB ; Grapheme_Base # Pf RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK
00BC..00BE ; Grapheme_Base # No [3] VULGAR FRACTION ONE QUARTER..VULGAR FRACTION THREE QUARTERS
00BF ; Grapheme_Base # Po INVERTED QUESTION MARK
@@ -8261,6 +8734,7 @@
0561..0587 ; Grapheme_Base # L& [39] ARMENIAN SMALL LETTER AYB..ARMENIAN SMALL LIGATURE ECH YIWN
0589 ; Grapheme_Base # Po ARMENIAN FULL STOP
058A ; Grapheme_Base # Pd ARMENIAN HYPHEN
+058F ; Grapheme_Base # Sc ARMENIAN DRAM SIGN
05BE ; Grapheme_Base # Pd HEBREW PUNCTUATION MAQAF
05C0 ; Grapheme_Base # Po HEBREW PUNCTUATION PASEQ
05C3 ; Grapheme_Base # Po HEBREW PUNCTUATION SOF PASUQ
@@ -8310,6 +8784,8 @@
0830..083E ; Grapheme_Base # Po [15] SAMARITAN PUNCTUATION NEQUDAA..SAMARITAN PUNCTUATION ANNAAU
0840..0858 ; Grapheme_Base # Lo [25] MANDAIC LETTER HALQA..MANDAIC LETTER AIN
085E ; Grapheme_Base # Po MANDAIC PUNCTUATION
+08A0 ; Grapheme_Base # Lo ARABIC LETTER BEH WITH SMALL V BELOW
+08A2..08AC ; Grapheme_Base # Lo [11] ARABIC LETTER JEEM WITH TWO DOTS ABOVE..ARABIC LETTER ROHINGYA YEH
0903 ; Grapheme_Base # Mc DEVANAGARI SIGN VISARGA
0904..0939 ; Grapheme_Base # Lo [54] DEVANAGARI LETTER SHORT A..DEVANAGARI LETTER HA
093B ; Grapheme_Base # Mc DEVANAGARI VOWEL SIGN OOE
@@ -8372,6 +8848,7 @@
0AD0 ; Grapheme_Base # Lo GUJARATI OM
0AE0..0AE1 ; Grapheme_Base # Lo [2] GUJARATI LETTER VOCALIC RR..GUJARATI LETTER VOCALIC LL
0AE6..0AEF ; Grapheme_Base # Nd [10] GUJARATI DIGIT ZERO..GUJARATI DIGIT NINE
+0AF0 ; Grapheme_Base # Po GUJARATI ABBREVIATION SIGN
0AF1 ; Grapheme_Base # Sc GUJARATI RUPEE SIGN
0B02..0B03 ; Grapheme_Base # Mc [2] ORIYA SIGN ANUSVARA..ORIYA SIGN VISARGA
0B05..0B0C ; Grapheme_Base # Lo [8] ORIYA LETTER A..ORIYA LETTER VOCALIC L
@@ -8488,11 +8965,13 @@
0EC0..0EC4 ; Grapheme_Base # Lo [5] LAO VOWEL SIGN E..LAO VOWEL SIGN AI
0EC6 ; Grapheme_Base # Lm LAO KO LA
0ED0..0ED9 ; Grapheme_Base # Nd [10] LAO DIGIT ZERO..LAO DIGIT NINE
-0EDC..0EDD ; Grapheme_Base # Lo [2] LAO HO NO..LAO HO MO
+0EDC..0EDF ; Grapheme_Base # Lo [4] LAO HO NO..LAO LETTER KHMU NYO
0F00 ; Grapheme_Base # Lo TIBETAN SYLLABLE OM
0F01..0F03 ; Grapheme_Base # So [3] TIBETAN MARK GTER YIG MGO TRUNCATED A..TIBETAN MARK GTER YIG MGO -UM GTER TSHEG MA
0F04..0F12 ; Grapheme_Base # Po [15] TIBETAN MARK INITIAL YIG MGO MDUN MA..TIBETAN MARK RGYA GRAM SHAD
-0F13..0F17 ; Grapheme_Base # So [5] TIBETAN MARK CARET -DZUD RTAGS ME LONG CAN..TIBETAN ASTROLOGICAL SIGN SGRA GCAN -CHAR RTAGS
+0F13 ; Grapheme_Base # So TIBETAN MARK CARET -DZUD RTAGS ME LONG CAN
+0F14 ; Grapheme_Base # Po TIBETAN MARK GTER TSHEG
+0F15..0F17 ; Grapheme_Base # So [3] TIBETAN LOGOTYPE SIGN CHAD RTAGS..TIBETAN ASTROLOGICAL SIGN SGRA GCAN -CHAR RTAGS
0F1A..0F1F ; Grapheme_Base # So [6] TIBETAN SIGN RDEL DKAR GCIG..TIBETAN SIGN RDEL DKAR RDEL NAG
0F20..0F29 ; Grapheme_Base # Nd [10] TIBETAN DIGIT ZERO..TIBETAN DIGIT NINE
0F2A..0F33 ; Grapheme_Base # No [10] TIBETAN DIGIT HALF ONE..TIBETAN DIGIT HALF ZERO
@@ -8540,10 +9019,12 @@
109A..109C ; Grapheme_Base # Mc [3] MYANMAR SIGN KHAMTI TONE-1..MYANMAR VOWEL SIGN AITON A
109E..109F ; Grapheme_Base # So [2] MYANMAR SYMBOL SHAN ONE..MYANMAR SYMBOL SHAN EXCLAMATION
10A0..10C5 ; Grapheme_Base # L& [38] GEORGIAN CAPITAL LETTER AN..GEORGIAN CAPITAL LETTER HOE
+10C7 ; Grapheme_Base # L& GEORGIAN CAPITAL LETTER YN
+10CD ; Grapheme_Base # L& GEORGIAN CAPITAL LETTER AEN
10D0..10FA ; Grapheme_Base # Lo [43] GEORGIAN LETTER AN..GEORGIAN LETTER AIN
10FB ; Grapheme_Base # Po GEORGIAN PARAGRAPH SEPARATOR
10FC ; Grapheme_Base # Lm MODIFIER LETTER GEORGIAN NAR
-1100..1248 ; Grapheme_Base # Lo [329] HANGUL CHOSEONG KIYEOK..ETHIOPIC SYLLABLE QWA
+10FD..1248 ; Grapheme_Base # Lo [332] GEORGIAN LETTER AEN..ETHIOPIC SYLLABLE QWA
124A..124D ; Grapheme_Base # Lo [4] ETHIOPIC SYLLABLE QWI..ETHIOPIC SYLLABLE QWE
1250..1256 ; Grapheme_Base # Lo [7] ETHIOPIC SYLLABLE QHA..ETHIOPIC SYLLABLE QHO
1258 ; Grapheme_Base # Lo ETHIOPIC SYLLABLE QHWA
@@ -8559,8 +9040,7 @@
12D8..1310 ; Grapheme_Base # Lo [57] ETHIOPIC SYLLABLE ZA..ETHIOPIC SYLLABLE GWA
1312..1315 ; Grapheme_Base # Lo [4] ETHIOPIC SYLLABLE GWI..ETHIOPIC SYLLABLE GWE
1318..135A ; Grapheme_Base # Lo [67] ETHIOPIC SYLLABLE GGA..ETHIOPIC SYLLABLE FYA
-1360 ; Grapheme_Base # So ETHIOPIC SECTION MARK
-1361..1368 ; Grapheme_Base # Po [8] ETHIOPIC WORDSPACE..ETHIOPIC PARAGRAPH SEPARATOR
+1360..1368 ; Grapheme_Base # Po [9] ETHIOPIC SECTION MARK..ETHIOPIC PARAGRAPH SEPARATOR
1369..137C ; Grapheme_Base # No [20] ETHIOPIC DIGIT ONE..ETHIOPIC NUMBER TEN THOUSAND
1380..138F ; Grapheme_Base # Lo [16] ETHIOPIC SYLLABLE SEBATBEIT MWA..ETHIOPIC SYLLABLE PWE
1390..1399 ; Grapheme_Base # So [10] ETHIOPIC TONAL MARK YIZET..ETHIOPIC TONAL MARK KURT
@@ -8652,9 +9132,10 @@
1BA1 ; Grapheme_Base # Mc SUNDANESE CONSONANT SIGN PAMINGKAL
1BA6..1BA7 ; Grapheme_Base # Mc [2] SUNDANESE VOWEL SIGN PANAELAENG..SUNDANESE VOWEL SIGN PANOLONG
1BAA ; Grapheme_Base # Mc SUNDANESE SIGN PAMAAEH
+1BAC..1BAD ; Grapheme_Base # Mc [2] SUNDANESE CONSONANT SIGN PASANGAN MA..SUNDANESE CONSONANT SIGN PASANGAN WA
1BAE..1BAF ; Grapheme_Base # Lo [2] SUNDANESE LETTER KHA..SUNDANESE LETTER SYA
1BB0..1BB9 ; Grapheme_Base # Nd [10] SUNDANESE DIGIT ZERO..SUNDANESE DIGIT NINE
-1BC0..1BE5 ; Grapheme_Base # Lo [38] BATAK LETTER A..BATAK LETTER U
+1BBA..1BE5 ; Grapheme_Base # Lo [44] SUNDANESE AVAGRAHA..BATAK LETTER U
1BE7 ; Grapheme_Base # Mc BATAK VOWEL SIGN E
1BEA..1BEC ; Grapheme_Base # Mc [3] BATAK VOWEL SIGN I..BATAK VOWEL SIGN O
1BEE ; Grapheme_Base # Mc BATAK VOWEL SIGN U
@@ -8670,14 +9151,16 @@
1C5A..1C77 ; Grapheme_Base # Lo [30] OL CHIKI LETTER LA..OL CHIKI LETTER OH
1C78..1C7D ; Grapheme_Base # Lm [6] OL CHIKI MU TTUDDAG..OL CHIKI AHAD
1C7E..1C7F ; Grapheme_Base # Po [2] OL CHIKI PUNCTUATION MUCAAD..OL CHIKI PUNCTUATION DOUBLE MUCAAD
+1CC0..1CC7 ; Grapheme_Base # Po [8] SUNDANESE PUNCTUATION BINDU SURYA..SUNDANESE PUNCTUATION BINDU BA SATANGA
1CD3 ; Grapheme_Base # Po VEDIC SIGN NIHSHVASA
1CE1 ; Grapheme_Base # Mc VEDIC TONE ATHARVAVEDIC INDEPENDENT SVARITA
1CE9..1CEC ; Grapheme_Base # Lo [4] VEDIC SIGN ANUSVARA ANTARGOMUKHA..VEDIC SIGN ANUSVARA VAMAGOMUKHA WITH TAIL
1CEE..1CF1 ; Grapheme_Base # Lo [4] VEDIC SIGN HEXIFORM LONG ANUSVARA..VEDIC SIGN ANUSVARA UBHAYATO MUKHA
-1CF2 ; Grapheme_Base # Mc VEDIC SIGN ARDHAVISARGA
+1CF2..1CF3 ; Grapheme_Base # Mc [2] VEDIC SIGN ARDHAVISARGA..VEDIC SIGN ROTATED ARDHAVISARGA
+1CF5..1CF6 ; Grapheme_Base # Lo [2] VEDIC SIGN JIHVAMULIYA..VEDIC SIGN UPADHMANIYA
1D00..1D2B ; Grapheme_Base # L& [44] LATIN LETTER SMALL CAPITAL A..CYRILLIC LETTER SMALL CAPITAL EL
-1D2C..1D61 ; Grapheme_Base # Lm [54] MODIFIER LETTER CAPITAL A..MODIFIER LETTER SMALL CHI
-1D62..1D77 ; Grapheme_Base # L& [22] LATIN SUBSCRIPT SMALL LETTER I..LATIN SMALL LETTER TURNED G
+1D2C..1D6A ; Grapheme_Base # Lm [63] MODIFIER LETTER CAPITAL A..GREEK SUBSCRIPT SMALL LETTER CHI
+1D6B..1D77 ; Grapheme_Base # L& [13] LATIN SMALL LETTER UE..LATIN SMALL LETTER TURNED G
1D78 ; Grapheme_Base # Lm MODIFIER LETTER CYRILLIC EN
1D79..1D9A ; Grapheme_Base # L& [34] LATIN SMALL LETTER INSULAR G..LATIN SMALL LETTER EZH WITH RETROFLEX HOOK
1D9B..1DBF ; Grapheme_Base # Lm [37] MODIFIER LETTER SMALL TURNED ALPHA..MODIFIER LETTER SMALL THETA
@@ -8745,7 +9228,7 @@
208D ; Grapheme_Base # Ps SUBSCRIPT LEFT PARENTHESIS
208E ; Grapheme_Base # Pe SUBSCRIPT RIGHT PARENTHESIS
2090..209C ; Grapheme_Base # Lm [13] LATIN SUBSCRIPT SMALL LETTER A..LATIN SUBSCRIPT SMALL LETTER T
-20A0..20B9 ; Grapheme_Base # Sc [26] EURO-CURRENCY SIGN..INDIAN RUPEE SIGN
+20A0..20BA ; Grapheme_Base # Sc [27] EURO-CURRENCY SIGN..TURKISH LIRA SIGN
2100..2101 ; Grapheme_Base # So [2] ACCOUNT OF..ADDRESSED TO THE SUBJECT
2102 ; Grapheme_Base # L& DOUBLE-STRUCK CAPITAL C
2103..2106 ; Grapheme_Base # So [4] DEGREE CELSIUS..CADA UNA
@@ -8850,9 +9333,7 @@
27C0..27C4 ; Grapheme_Base # Sm [5] THREE DIMENSIONAL ANGLE..OPEN SUPERSET
27C5 ; Grapheme_Base # Ps LEFT S-SHAPED BAG DELIMITER
27C6 ; Grapheme_Base # Pe RIGHT S-SHAPED BAG DELIMITER
-27C7..27CA ; Grapheme_Base # Sm [4] OR WITH DOT INSIDE..VERTICAL BAR WITH HORIZONTAL STROKE
-27CC ; Grapheme_Base # Sm LONG DIVISION
-27CE..27E5 ; Grapheme_Base # Sm [24] SQUARED LOGICAL AND..WHITE SQUARE WITH RIGHTWARDS TICK
+27C7..27E5 ; Grapheme_Base # Sm [31] OR WITH DOT INSIDE..WHITE SQUARE WITH RIGHTWARDS TICK
27E6 ; Grapheme_Base # Ps MATHEMATICAL LEFT WHITE SQUARE BRACKET
27E7 ; Grapheme_Base # Pe MATHEMATICAL RIGHT WHITE SQUARE BRACKET
27E8 ; Grapheme_Base # Ps MATHEMATICAL LEFT ANGLE BRACKET
@@ -8904,16 +9385,19 @@
2B50..2B59 ; Grapheme_Base # So [10] WHITE MEDIUM STAR..HEAVY CIRCLED SALTIRE
2C00..2C2E ; Grapheme_Base # L& [47] GLAGOLITIC CAPITAL LETTER AZU..GLAGOLITIC CAPITAL LETTER LATINATE MYSLITE
2C30..2C5E ; Grapheme_Base # L& [47] GLAGOLITIC SMALL LETTER AZU..GLAGOLITIC SMALL LETTER LATINATE MYSLITE
-2C60..2C7C ; Grapheme_Base # L& [29] LATIN CAPITAL LETTER L WITH DOUBLE BAR..LATIN SUBSCRIPT SMALL LETTER J
-2C7D ; Grapheme_Base # Lm MODIFIER LETTER CAPITAL V
+2C60..2C7B ; Grapheme_Base # L& [28] LATIN CAPITAL LETTER L WITH DOUBLE BAR..LATIN LETTER SMALL CAPITAL TURNED E
+2C7C..2C7D ; Grapheme_Base # Lm [2] LATIN SUBSCRIPT SMALL LETTER J..MODIFIER LETTER CAPITAL V
2C7E..2CE4 ; Grapheme_Base # L& [103] LATIN CAPITAL LETTER S WITH SWASH TAIL..COPTIC SYMBOL KAI
2CE5..2CEA ; Grapheme_Base # So [6] COPTIC SYMBOL MI RO..COPTIC SYMBOL SHIMA SIMA
2CEB..2CEE ; Grapheme_Base # L& [4] COPTIC CAPITAL LETTER CRYPTOGRAMMIC SHEI..COPTIC SMALL LETTER CRYPTOGRAMMIC GANGIA
+2CF2..2CF3 ; Grapheme_Base # L& [2] COPTIC CAPITAL LETTER BOHAIRIC KHEI..COPTIC SMALL LETTER BOHAIRIC KHEI
2CF9..2CFC ; Grapheme_Base # Po [4] COPTIC OLD NUBIAN FULL STOP..COPTIC OLD NUBIAN VERSE DIVIDER
2CFD ; Grapheme_Base # No COPTIC FRACTION ONE HALF
2CFE..2CFF ; Grapheme_Base # Po [2] COPTIC FULL STOP..COPTIC MORPHOLOGICAL DIVIDER
2D00..2D25 ; Grapheme_Base # L& [38] GEORGIAN SMALL LETTER AN..GEORGIAN SMALL LETTER HOE
-2D30..2D65 ; Grapheme_Base # Lo [54] TIFINAGH LETTER YA..TIFINAGH LETTER YAZZ
+2D27 ; Grapheme_Base # L& GEORGIAN SMALL LETTER YN
+2D2D ; Grapheme_Base # L& GEORGIAN SMALL LETTER AEN
+2D30..2D67 ; Grapheme_Base # Lo [56] TIFINAGH LETTER YA..TIFINAGH LETTER YO
2D6F ; Grapheme_Base # Lm TIFINAGH MODIFIER LETTER LABIALIZATION MARK
2D70 ; Grapheme_Base # Po TIFINAGH SEPARATOR MARK
2D80..2D96 ; Grapheme_Base # Lo [23] ETHIOPIC SYLLABLE LOA..ETHIOPIC SYLLABLE GGWE
@@ -8956,7 +9440,8 @@
2E29 ; Grapheme_Base # Pe RIGHT DOUBLE PARENTHESIS
2E2A..2E2E ; Grapheme_Base # Po [5] TWO DOTS OVER ONE DOT PUNCTUATION..REVERSED QUESTION MARK
2E2F ; Grapheme_Base # Lm VERTICAL TILDE
-2E30..2E31 ; Grapheme_Base # Po [2] RING POINT..WORD SEPARATOR MIDDLE DOT
+2E30..2E39 ; Grapheme_Base # Po [10] RING POINT..TOP HALF SECTION SIGN
+2E3A..2E3B ; Grapheme_Base # Pd [2] TWO-EM DASH..THREE-EM DASH
2E80..2E99 ; Grapheme_Base # So [26] CJK RADICAL REPEAT..CJK RADICAL RAP
2E9B..2EF3 ; Grapheme_Base # So [89] CJK RADICAL CHOKE..CJK RADICAL C-SIMPLIFIED TURTLE
2F00..2FD5 ; Grapheme_Base # So [214] KANGXI RADICAL ONE..KANGXI RADICAL FLUTE
@@ -9018,7 +9503,9 @@
31F0..31FF ; Grapheme_Base # Lo [16] KATAKANA LETTER SMALL KU..KATAKANA LETTER SMALL RO
3200..321E ; Grapheme_Base # So [31] PARENTHESIZED HANGUL KIYEOK..PARENTHESIZED KOREAN CHARACTER O HU
3220..3229 ; Grapheme_Base # No [10] PARENTHESIZED IDEOGRAPH ONE..PARENTHESIZED IDEOGRAPH TEN
-322A..3250 ; Grapheme_Base # So [39] PARENTHESIZED IDEOGRAPH MOON..PARTNERSHIP SIGN
+322A..3247 ; Grapheme_Base # So [30] PARENTHESIZED IDEOGRAPH MOON..CIRCLED IDEOGRAPH KOTO
+3248..324F ; Grapheme_Base # No [8] CIRCLED NUMBER TEN ON BLACK SQUARE..CIRCLED NUMBER EIGHTY ON BLACK SQUARE
+3250 ; Grapheme_Base # So PARTNERSHIP SIGN
3251..325F ; Grapheme_Base # No [15] CIRCLED NUMBER TWENTY ONE..CIRCLED NUMBER THIRTY FIVE
3260..327F ; Grapheme_Base # So [32] CIRCLED HANGUL KIYEOK..KOREAN STANDARD SYMBOL
3280..3289 ; Grapheme_Base # No [10] CIRCLED IDEOGRAPH ONE..CIRCLED IDEOGRAPH TEN
@@ -9028,7 +9515,7 @@
3300..33FF ; Grapheme_Base # So [256] SQUARE APAATO..SQUARE GAL
3400..4DB5 ; Grapheme_Base # Lo [6582] CJK UNIFIED IDEOGRAPH-3400..CJK UNIFIED IDEOGRAPH-4DB5
4DC0..4DFF ; Grapheme_Base # So [64] HEXAGRAM FOR THE CREATIVE HEAVEN..HEXAGRAM FOR BEFORE COMPLETION
-4E00..9FCB ; Grapheme_Base # Lo [20940] CJK UNIFIED IDEOGRAPH-4E00..CJK UNIFIED IDEOGRAPH-9FCB
+4E00..9FCC ; Grapheme_Base # Lo [20941] CJK UNIFIED IDEOGRAPH-4E00..CJK UNIFIED IDEOGRAPH-9FCC
A000..A014 ; Grapheme_Base # Lo [21] YI SYLLABLE IT..YI SYLLABLE E
A015 ; Grapheme_Base # Lm YI SYLLABLE WU
A016..A48C ; Grapheme_Base # Lo [1143] YI SYLLABLE BIT..YI SYLLABLE YYR
@@ -9060,8 +9547,9 @@
A788 ; Grapheme_Base # Lm MODIFIER LETTER LOW CIRCUMFLEX ACCENT
A789..A78A ; Grapheme_Base # Sk [2] MODIFIER LETTER COLON..MODIFIER LETTER SHORT EQUALS SIGN
A78B..A78E ; Grapheme_Base # L& [4] LATIN CAPITAL LETTER SALTILLO..LATIN SMALL LETTER L WITH RETROFLEX HOOK AND BELT
-A790..A791 ; Grapheme_Base # L& [2] LATIN CAPITAL LETTER N WITH DESCENDER..LATIN SMALL LETTER N WITH DESCENDER
-A7A0..A7A9 ; Grapheme_Base # L& [10] LATIN CAPITAL LETTER G WITH OBLIQUE STROKE..LATIN SMALL LETTER S WITH OBLIQUE STROKE
+A790..A793 ; Grapheme_Base # L& [4] LATIN CAPITAL LETTER N WITH DESCENDER..LATIN SMALL LETTER C WITH BAR
+A7A0..A7AA ; Grapheme_Base # L& [11] LATIN CAPITAL LETTER G WITH OBLIQUE STROKE..LATIN CAPITAL LETTER H WITH HOOK
+A7F8..A7F9 ; Grapheme_Base # Lm [2] MODIFIER LETTER CAPITAL H WITH STROKE..MODIFIER LETTER SMALL LIGATURE OE
A7FA ; Grapheme_Base # L& LATIN LETTER SMALL CAPITAL TURNED M
A7FB..A801 ; Grapheme_Base # Lo [7] LATIN EPIGRAPHIC LETTER REVERSED F..SYLOTI NAGRI LETTER I
A803..A805 ; Grapheme_Base # Lo [3] SYLOTI NAGRI LETTER U..SYLOTI NAGRI LETTER O
@@ -9123,6 +9611,13 @@
AADB..AADC ; Grapheme_Base # Lo [2] TAI VIET SYMBOL KON..TAI VIET SYMBOL NUENG
AADD ; Grapheme_Base # Lm TAI VIET SYMBOL SAM
AADE..AADF ; Grapheme_Base # Po [2] TAI VIET SYMBOL HO HOI..TAI VIET SYMBOL KOI KOI
+AAE0..AAEA ; Grapheme_Base # Lo [11] MEETEI MAYEK LETTER E..MEETEI MAYEK LETTER SSA
+AAEB ; Grapheme_Base # Mc MEETEI MAYEK VOWEL SIGN II
+AAEE..AAEF ; Grapheme_Base # Mc [2] MEETEI MAYEK VOWEL SIGN AU..MEETEI MAYEK VOWEL SIGN AAU
+AAF0..AAF1 ; Grapheme_Base # Po [2] MEETEI MAYEK CHEIKHAN..MEETEI MAYEK AHANG KHUDAM
+AAF2 ; Grapheme_Base # Lo MEETEI MAYEK ANJI
+AAF3..AAF4 ; Grapheme_Base # Lm [2] MEETEI MAYEK SYLLABLE REPETITION MARK..MEETEI MAYEK WORD REPETITION MARK
+AAF5 ; Grapheme_Base # Mc MEETEI MAYEK VOWEL SIGN VISARGA
AB01..AB06 ; Grapheme_Base # Lo [6] ETHIOPIC SYLLABLE TTHU..ETHIOPIC SYLLABLE TTHO
AB09..AB0E ; Grapheme_Base # Lo [6] ETHIOPIC SYLLABLE DDHU..ETHIOPIC SYLLABLE DDHO
AB11..AB16 ; Grapheme_Base # Lo [6] ETHIOPIC SYLLABLE DZU..ETHIOPIC SYLLABLE DZO
@@ -9138,8 +9633,7 @@
AC00..D7A3 ; Grapheme_Base # Lo [11172] HANGUL SYLLABLE GA..HANGUL SYLLABLE HIH
D7B0..D7C6 ; Grapheme_Base # Lo [23] HANGUL JUNGSEONG O-YEO..HANGUL JUNGSEONG ARAEA-E
D7CB..D7FB ; Grapheme_Base # Lo [49] HANGUL JONGSEONG NIEUN-RIEUL..HANGUL JONGSEONG PHIEUPH-THIEUTH
-F900..FA2D ; Grapheme_Base # Lo [302] CJK COMPATIBILITY IDEOGRAPH-F900..CJK COMPATIBILITY IDEOGRAPH-FA2D
-FA30..FA6D ; Grapheme_Base # Lo [62] CJK COMPATIBILITY IDEOGRAPH-FA30..CJK COMPATIBILITY IDEOGRAPH-FA6D
+F900..FA6D ; Grapheme_Base # Lo [366] CJK COMPATIBILITY IDEOGRAPH-F900..CJK COMPATIBILITY IDEOGRAPH-FA6D
FA70..FAD9 ; Grapheme_Base # Lo [106] CJK COMPATIBILITY IDEOGRAPH-FA70..CJK COMPATIBILITY IDEOGRAPH-FAD9
FB00..FB06 ; Grapheme_Base # L& [7] LATIN SMALL LIGATURE FF..LATIN SMALL LIGATURE ST
FB13..FB17 ; Grapheme_Base # L& [5] ARMENIAN SMALL LIGATURE MEN NOW..ARMENIAN SMALL LIGATURE MEN XEH
@@ -9263,8 +9757,7 @@
1003F..1004D ; Grapheme_Base # Lo [15] LINEAR B SYLLABLE B020 ZO..LINEAR B SYLLABLE B091 TWO
10050..1005D ; Grapheme_Base # Lo [14] LINEAR B SYMBOL B018..LINEAR B SYMBOL B089
10080..100FA ; Grapheme_Base # Lo [123] LINEAR B IDEOGRAM B100 MAN..LINEAR B IDEOGRAM VESSEL B305
-10100..10101 ; Grapheme_Base # Po [2] AEGEAN WORD SEPARATOR LINE..AEGEAN WORD SEPARATOR DOT
-10102 ; Grapheme_Base # So AEGEAN CHECK MARK
+10100..10102 ; Grapheme_Base # Po [3] AEGEAN WORD SEPARATOR LINE..AEGEAN CHECK MARK
10107..10133 ; Grapheme_Base # No [45] AEGEAN NUMBER ONE..AEGEAN NUMBER NINETY THOUSAND
10137..1013F ; Grapheme_Base # So [9] AEGEAN WEIGHT BASE UNIT..AEGEAN MEASURE THIRD SUBUNIT
10140..10174 ; Grapheme_Base # Nl [53] GREEK ACROPHONIC ATTIC ONE QUARTER..GREEK ACROPHONIC STRATIAN FIFTY MNAS
@@ -9303,6 +9796,8 @@
1091F ; Grapheme_Base # Po PHOENICIAN WORD SEPARATOR
10920..10939 ; Grapheme_Base # Lo [26] LYDIAN LETTER A..LYDIAN LETTER C
1093F ; Grapheme_Base # Po LYDIAN TRIANGULAR MARK
+10980..109B7 ; Grapheme_Base # Lo [56] MEROITIC HIEROGLYPHIC LETTER A..MEROITIC CURSIVE LETTER DA
+109BE..109BF ; Grapheme_Base # Lo [2] MEROITIC CURSIVE LOGOGRAM RMT..MEROITIC CURSIVE LOGOGRAM IMN
10A00 ; Grapheme_Base # Lo KHAROSHTHI LETTER A
10A10..10A13 ; Grapheme_Base # Lo [4] KHAROSHTHI LETTER KA..KHAROSHTHI LETTER GHA
10A15..10A17 ; Grapheme_Base # Lo [3] KHAROSHTHI LETTER CA..KHAROSHTHI LETTER JA
@@ -9332,11 +9827,33 @@
110B7..110B8 ; Grapheme_Base # Mc [2] KAITHI VOWEL SIGN O..KAITHI VOWEL SIGN AU
110BB..110BC ; Grapheme_Base # Po [2] KAITHI ABBREVIATION SIGN..KAITHI ENUMERATION SIGN
110BE..110C1 ; Grapheme_Base # Po [4] KAITHI SECTION MARK..KAITHI DOUBLE DANDA
+110D0..110E8 ; Grapheme_Base # Lo [25] SORA SOMPENG LETTER SAH..SORA SOMPENG LETTER MAE
+110F0..110F9 ; Grapheme_Base # Nd [10] SORA SOMPENG DIGIT ZERO..SORA SOMPENG DIGIT NINE
+11103..11126 ; Grapheme_Base # Lo [36] CHAKMA LETTER AA..CHAKMA LETTER HAA
+1112C ; Grapheme_Base # Mc CHAKMA VOWEL SIGN E
+11136..1113F ; Grapheme_Base # Nd [10] CHAKMA DIGIT ZERO..CHAKMA DIGIT NINE
+11140..11143 ; Grapheme_Base # Po [4] CHAKMA SECTION MARK..CHAKMA QUESTION MARK
+11182 ; Grapheme_Base # Mc SHARADA SIGN VISARGA
+11183..111B2 ; Grapheme_Base # Lo [48] SHARADA LETTER A..SHARADA LETTER HA
+111B3..111B5 ; Grapheme_Base # Mc [3] SHARADA VOWEL SIGN AA..SHARADA VOWEL SIGN II
+111BF..111C0 ; Grapheme_Base # Mc [2] SHARADA VOWEL SIGN AU..SHARADA SIGN VIRAMA
+111C1..111C4 ; Grapheme_Base # Lo [4] SHARADA SIGN AVAGRAHA..SHARADA OM
+111C5..111C8 ; Grapheme_Base # Po [4] SHARADA DANDA..SHARADA SEPARATOR
+111D0..111D9 ; Grapheme_Base # Nd [10] SHARADA DIGIT ZERO..SHARADA DIGIT NINE
+11680..116AA ; Grapheme_Base # Lo [43] TAKRI LETTER A..TAKRI LETTER RRA
+116AC ; Grapheme_Base # Mc TAKRI SIGN VISARGA
+116AE..116AF ; Grapheme_Base # Mc [2] TAKRI VOWEL SIGN I..TAKRI VOWEL SIGN II
+116B6 ; Grapheme_Base # Mc TAKRI SIGN VIRAMA
+116C0..116C9 ; Grapheme_Base # Nd [10] TAKRI DIGIT ZERO..TAKRI DIGIT NINE
12000..1236E ; Grapheme_Base # Lo [879] CUNEIFORM SIGN A..CUNEIFORM SIGN ZUM
12400..12462 ; Grapheme_Base # Nl [99] CUNEIFORM NUMERIC SIGN TWO ASH..CUNEIFORM NUMERIC SIGN OLD ASSYRIAN ONE QUARTER
12470..12473 ; Grapheme_Base # Po [4] CUNEIFORM PUNCTUATION SIGN OLD ASSYRIAN WORD DIVIDER..CUNEIFORM PUNCTUATION SIGN DIAGONAL TRICOLON
13000..1342E ; Grapheme_Base # Lo [1071] EGYPTIAN HIEROGLYPH A001..EGYPTIAN HIEROGLYPH AA032
16800..16A38 ; Grapheme_Base # Lo [569] BAMUM LETTER PHASE-A NGKUE MFON..BAMUM LETTER PHASE-F VUEQ
+16F00..16F44 ; Grapheme_Base # Lo [69] MIAO LETTER PA..MIAO LETTER HHA
+16F50 ; Grapheme_Base # Lo MIAO LETTER NASALIZATION
+16F51..16F7E ; Grapheme_Base # Mc [46] MIAO SIGN ASPIRATION..MIAO VOWEL SIGN NG
+16F93..16F9F ; Grapheme_Base # Lm [13] MIAO LETTER TONE-2..MIAO LETTER REFORMED TONE-8
1B000..1B001 ; Grapheme_Base # Lo [2] KATAKANA LETTER ARCHAIC E..HIRAGANA LETTER ARCHAIC YE
1D000..1D0F5 ; Grapheme_Base # So [246] BYZANTINE MUSICAL SYMBOL PSILI..BYZANTINE MUSICAL SYMBOL GORGON NEO KATO
1D100..1D126 ; Grapheme_Base # So [39] MUSICAL SYMBOL SINGLE BARLINE..MUSICAL SYMBOL DRUM CLEF-2
@@ -9392,6 +9909,40 @@
1D7C3 ; Grapheme_Base # Sm MATHEMATICAL SANS-SERIF BOLD ITALIC PARTIAL DIFFERENTIAL
1D7C4..1D7CB ; Grapheme_Base # L& [8] MATHEMATICAL SANS-SERIF BOLD ITALIC EPSILON SYMBOL..MATHEMATICAL BOLD SMALL DIGAMMA
1D7CE..1D7FF ; Grapheme_Base # Nd [50] MATHEMATICAL BOLD DIGIT ZERO..MATHEMATICAL MONOSPACE DIGIT NINE
+1EE00..1EE03 ; Grapheme_Base # Lo [4] ARABIC MATHEMATICAL ALEF..ARABIC MATHEMATICAL DAL
+1EE05..1EE1F ; Grapheme_Base # Lo [27] ARABIC MATHEMATICAL WAW..ARABIC MATHEMATICAL DOTLESS QAF
+1EE21..1EE22 ; Grapheme_Base # Lo [2] ARABIC MATHEMATICAL INITIAL BEH..ARABIC MATHEMATICAL INITIAL JEEM
+1EE24 ; Grapheme_Base # Lo ARABIC MATHEMATICAL INITIAL HEH
+1EE27 ; Grapheme_Base # Lo ARABIC MATHEMATICAL INITIAL HAH
+1EE29..1EE32 ; Grapheme_Base # Lo [10] ARABIC MATHEMATICAL INITIAL YEH..ARABIC MATHEMATICAL INITIAL QAF
+1EE34..1EE37 ; Grapheme_Base # Lo [4] ARABIC MATHEMATICAL INITIAL SHEEN..ARABIC MATHEMATICAL INITIAL KHAH
+1EE39 ; Grapheme_Base # Lo ARABIC MATHEMATICAL INITIAL DAD
+1EE3B ; Grapheme_Base # Lo ARABIC MATHEMATICAL INITIAL GHAIN
+1EE42 ; Grapheme_Base # Lo ARABIC MATHEMATICAL TAILED JEEM
+1EE47 ; Grapheme_Base # Lo ARABIC MATHEMATICAL TAILED HAH
+1EE49 ; Grapheme_Base # Lo ARABIC MATHEMATICAL TAILED YEH
+1EE4B ; Grapheme_Base # Lo ARABIC MATHEMATICAL TAILED LAM
+1EE4D..1EE4F ; Grapheme_Base # Lo [3] ARABIC MATHEMATICAL TAILED NOON..ARABIC MATHEMATICAL TAILED AIN
+1EE51..1EE52 ; Grapheme_Base # Lo [2] ARABIC MATHEMATICAL TAILED SAD..ARABIC MATHEMATICAL TAILED QAF
+1EE54 ; Grapheme_Base # Lo ARABIC MATHEMATICAL TAILED SHEEN
+1EE57 ; Grapheme_Base # Lo ARABIC MATHEMATICAL TAILED KHAH
+1EE59 ; Grapheme_Base # Lo ARABIC MATHEMATICAL TAILED DAD
+1EE5B ; Grapheme_Base # Lo ARABIC MATHEMATICAL TAILED GHAIN
+1EE5D ; Grapheme_Base # Lo ARABIC MATHEMATICAL TAILED DOTLESS NOON
+1EE5F ; Grapheme_Base # Lo ARABIC MATHEMATICAL TAILED DOTLESS QAF
+1EE61..1EE62 ; Grapheme_Base # Lo [2] ARABIC MATHEMATICAL STRETCHED BEH..ARABIC MATHEMATICAL STRETCHED JEEM
+1EE64 ; Grapheme_Base # Lo ARABIC MATHEMATICAL STRETCHED HEH
+1EE67..1EE6A ; Grapheme_Base # Lo [4] ARABIC MATHEMATICAL STRETCHED HAH..ARABIC MATHEMATICAL STRETCHED KAF
+1EE6C..1EE72 ; Grapheme_Base # Lo [7] ARABIC MATHEMATICAL STRETCHED MEEM..ARABIC MATHEMATICAL STRETCHED QAF
+1EE74..1EE77 ; Grapheme_Base # Lo [4] ARABIC MATHEMATICAL STRETCHED SHEEN..ARABIC MATHEMATICAL STRETCHED KHAH
+1EE79..1EE7C ; Grapheme_Base # Lo [4] ARABIC MATHEMATICAL STRETCHED DAD..ARABIC MATHEMATICAL STRETCHED DOTLESS BEH
+1EE7E ; Grapheme_Base # Lo ARABIC MATHEMATICAL STRETCHED DOTLESS FEH
+1EE80..1EE89 ; Grapheme_Base # Lo [10] ARABIC MATHEMATICAL LOOPED ALEF..ARABIC MATHEMATICAL LOOPED YEH
+1EE8B..1EE9B ; Grapheme_Base # Lo [17] ARABIC MATHEMATICAL LOOPED LAM..ARABIC MATHEMATICAL LOOPED GHAIN
+1EEA1..1EEA3 ; Grapheme_Base # Lo [3] ARABIC MATHEMATICAL DOUBLE-STRUCK BEH..ARABIC MATHEMATICAL DOUBLE-STRUCK DAL
+1EEA5..1EEA9 ; Grapheme_Base # Lo [5] ARABIC MATHEMATICAL DOUBLE-STRUCK WAW..ARABIC MATHEMATICAL DOUBLE-STRUCK YEH
+1EEAB..1EEBB ; Grapheme_Base # Lo [17] ARABIC MATHEMATICAL DOUBLE-STRUCK LAM..ARABIC MATHEMATICAL DOUBLE-STRUCK GHAIN
+1EEF0..1EEF1 ; Grapheme_Base # Sm [2] ARABIC MATHEMATICAL OPERATOR MEEM WITH HAH WITH TATWEEL..ARABIC MATHEMATICAL OPERATOR HAH WITH DAL
1F000..1F02B ; Grapheme_Base # So [44] MAHJONG TILE EAST WIND..MAHJONG TILE BACK
1F030..1F093 ; Grapheme_Base # So [100] DOMINO TILE HORIZONTAL BACK..DOMINO TILE VERTICAL-06-06
1F0A0..1F0AE ; Grapheme_Base # So [15] PLAYING CARD BACK..PLAYING CARD KING OF SPADES
@@ -9400,7 +9951,7 @@
1F0D1..1F0DF ; Grapheme_Base # So [15] PLAYING CARD ACE OF CLUBS..PLAYING CARD WHITE JOKER
1F100..1F10A ; Grapheme_Base # No [11] DIGIT ZERO FULL STOP..DIGIT NINE COMMA
1F110..1F12E ; Grapheme_Base # So [31] PARENTHESIZED LATIN CAPITAL LETTER A..CIRCLED WZ
-1F130..1F169 ; Grapheme_Base # So [58] SQUARED LATIN CAPITAL LETTER A..NEGATIVE CIRCLED LATIN CAPITAL LETTER Z
+1F130..1F16B ; Grapheme_Base # So [60] SQUARED LATIN CAPITAL LETTER A..RAISED MD SIGN
1F170..1F19A ; Grapheme_Base # So [43] NEGATIVE SQUARED LATIN CAPITAL LETTER A..SQUARED VS
1F1E6..1F202 ; Grapheme_Base # So [29] REGIONAL INDICATOR SYMBOL LETTER A..SQUARED KATAKANA SA
1F210..1F23A ; Grapheme_Base # So [43] SQUARED CJK UNIFIED IDEOGRAPH-624B..SQUARED CJK UNIFIED IDEOGRAPH-55B6
@@ -9418,19 +9969,9 @@
1F442..1F4F7 ; Grapheme_Base # So [182] EAR..CAMERA
1F4F9..1F4FC ; Grapheme_Base # So [4] VIDEO CAMERA..VIDEOCASSETTE
1F500..1F53D ; Grapheme_Base # So [62] TWISTED RIGHTWARDS ARROWS..DOWN-POINTING SMALL RED TRIANGLE
+1F540..1F543 ; Grapheme_Base # So [4] CIRCLED CROSS POMMEE..NOTCHED LEFT SEMICIRCLE WITH THREE DOTS
1F550..1F567 ; Grapheme_Base # So [24] CLOCK FACE ONE OCLOCK..CLOCK FACE TWELVE-THIRTY
-1F5FB..1F5FF ; Grapheme_Base # So [5] MOUNT FUJI..MOYAI
-1F601..1F610 ; Grapheme_Base # So [16] GRINNING FACE WITH SMILING EYES..NEUTRAL FACE
-1F612..1F614 ; Grapheme_Base # So [3] UNAMUSED FACE..PENSIVE FACE
-1F616 ; Grapheme_Base # So CONFOUNDED FACE
-1F618 ; Grapheme_Base # So FACE THROWING A KISS
-1F61A ; Grapheme_Base # So KISSING FACE WITH CLOSED EYES
-1F61C..1F61E ; Grapheme_Base # So [3] FACE WITH STUCK-OUT TONGUE AND WINKING EYE..DISAPPOINTED FACE
-1F620..1F625 ; Grapheme_Base # So [6] ANGRY FACE..DISAPPOINTED BUT RELIEVED FACE
-1F628..1F62B ; Grapheme_Base # So [4] FEARFUL FACE..TIRED FACE
-1F62D ; Grapheme_Base # So LOUDLY CRYING FACE
-1F630..1F633 ; Grapheme_Base # So [4] FACE WITH OPEN MOUTH AND COLD SWEAT..FLUSHED FACE
-1F635..1F640 ; Grapheme_Base # So [12] DIZZY FACE..WEARY CAT FACE
+1F5FB..1F640 ; Grapheme_Base # So [70] MOUNT FUJI..WEARY CAT FACE
1F645..1F64F ; Grapheme_Base # So [11] FACE WITH NO GOOD GESTURE..PERSON WITH FOLDED HANDS
1F680..1F6C5 ; Grapheme_Base # So [70] ROCKET..LEFT LUGGAGE
1F700..1F773 ; Grapheme_Base # So [116] ALCHEMICAL SYMBOL FOR QUINTESSENCE..ALCHEMICAL SYMBOL FOR HALF OUNCE
@@ -9439,7 +9980,7 @@
2B740..2B81D ; Grapheme_Base # Lo [222] CJK UNIFIED IDEOGRAPH-2B740..CJK UNIFIED IDEOGRAPH-2B81D
2F800..2FA1D ; Grapheme_Base # Lo [542] CJK COMPATIBILITY IDEOGRAPH-2F800..CJK COMPATIBILITY IDEOGRAPH-2FA1D
-# Total code points: 108010
+# Total code points: 108661
# ================================================
@@ -9466,6 +10007,7 @@
1A60 ; Grapheme_Link # Mn TAI THAM SIGN SAKOT
1B44 ; Grapheme_Link # Mc BALINESE ADEG ADEG
1BAA ; Grapheme_Link # Mc SUNDANESE SIGN PAMAAEH
+1BAB ; Grapheme_Link # Mn SUNDANESE SIGN VIRAMA
1BF2..1BF3 ; Grapheme_Link # Mc [2] BATAK PANGOLAT..BATAK PANONGONAN
2D7F ; Grapheme_Link # Mn TIFINAGH CONSONANT JOINER
A806 ; Grapheme_Link # Mn SYLOTI NAGRI SIGN HASANTA
@@ -9472,11 +10014,15 @@
A8C4 ; Grapheme_Link # Mn SAURASHTRA SIGN VIRAMA
A953 ; Grapheme_Link # Mc REJANG VIRAMA
A9C0 ; Grapheme_Link # Mc JAVANESE PANGKON
+AAF6 ; Grapheme_Link # Mn MEETEI MAYEK VIRAMA
ABED ; Grapheme_Link # Mn MEETEI MAYEK APUN IYEK
10A3F ; Grapheme_Link # Mn KHAROSHTHI VIRAMA
11046 ; Grapheme_Link # Mn BRAHMI VIRAMA
110B9 ; Grapheme_Link # Mn KAITHI SIGN VIRAMA
+11133..11134 ; Grapheme_Link # Mn [2] CHAKMA VIRAMA..CHAKMA MAAYYAA
+111C0 ; Grapheme_Link # Mc SHARADA SIGN VIRAMA
+116B6 ; Grapheme_Link # Mc TAKRI SIGN VIRAMA
-# Total code points: 31
+# Total code points: 37
# EOF
Property changes on: trunk/contrib/perl/lib/unicore/DCoreProperties.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/DNormalizationProps.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/DNormalizationProps.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/DNormalizationProps.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,8 +1,8 @@
-# DerivedNormalizationProps-6.0.0.txt
-# Date: 2010-05-20, 15:14:12 GMT [MD]
+# DerivedNormalizationProps-6.2.0.txt
+# Date: 2012-05-23, 20:34:48 GMT [MD]
#
# Unicode Character Database
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
# For documentation, see http://www.unicode.org/reports/tr44/
@@ -131,6 +131,7 @@
33DD ; FC_NFKC; 0077 0062 # So SQUARE WB
33DE ; FC_NFKC; 0076 2215 006D # So SQUARE V OVER M
33DF ; FC_NFKC; 0061 2215 006D # So SQUARE A OVER M
+A7F8 ; FC_NFKC; 0127 # Lm MODIFIER LETTER CAPITAL H WITH STROKE
1D400 ; FC_NFKC; 0061 # L& MATHEMATICAL BOLD CAPITAL A
1D401 ; FC_NFKC; 0062 # L& MATHEMATICAL BOLD CAPITAL B
1D402 ; FC_NFKC; 0063 # L& MATHEMATICAL BOLD CAPITAL C
@@ -643,9 +644,11 @@
1F14D ; FC_NFKC; 0073 0073 # So SQUARED SS
1F14E ; FC_NFKC; 0070 0070 0076 # So SQUARED PPV
1F14F ; FC_NFKC; 0077 0063 # So SQUARED WC
+1F16A ; FC_NFKC; 006D 0063 # So RAISED MC SIGN
+1F16B ; FC_NFKC; 006D 0064 # So RAISED MD SIGN
1F190 ; FC_NFKC; 0064 006A # So SQUARE DJ
-# Total code points: 630
+# Total code points: 633
# ================================================
@@ -713,8 +716,7 @@
FA20 ; Full_Composition_Exclusion # Lo CJK COMPATIBILITY IDEOGRAPH-FA20
FA22 ; Full_Composition_Exclusion # Lo CJK COMPATIBILITY IDEOGRAPH-FA22
FA25..FA26 ; Full_Composition_Exclusion # Lo [2] CJK COMPATIBILITY IDEOGRAPH-FA25..CJK COMPATIBILITY IDEOGRAPH-FA26
-FA2A..FA2D ; Full_Composition_Exclusion # Lo [4] CJK COMPATIBILITY IDEOGRAPH-FA2A..CJK COMPATIBILITY IDEOGRAPH-FA2D
-FA30..FA6D ; Full_Composition_Exclusion # Lo [62] CJK COMPATIBILITY IDEOGRAPH-FA30..CJK COMPATIBILITY IDEOGRAPH-FA6D
+FA2A..FA6D ; Full_Composition_Exclusion # Lo [68] CJK COMPATIBILITY IDEOGRAPH-FA2A..CJK COMPATIBILITY IDEOGRAPH-FA6D
FA70..FAD9 ; Full_Composition_Exclusion # Lo [106] CJK COMPATIBILITY IDEOGRAPH-FA70..CJK COMPATIBILITY IDEOGRAPH-FAD9
FB1D ; Full_Composition_Exclusion # Lo HEBREW LETTER YOD WITH HIRIQ
FB1F ; Full_Composition_Exclusion # Lo HEBREW LIGATURE YIDDISH YOD YOD PATAH
@@ -728,7 +730,7 @@
1D1BB..1D1C0 ; Full_Composition_Exclusion # So [6] MUSICAL SYMBOL MINIMA..MUSICAL SYMBOL FUSA BLACK
2F800..2FA1D ; Full_Composition_Exclusion # Lo [542] CJK COMPATIBILITY IDEOGRAPH-2F800..CJK COMPATIBILITY IDEOGRAPH-2FA1D
-# Total code points: 1118
+# Total code points: 1120
# ================================================
@@ -964,8 +966,7 @@
FA20 ; NFD_QC; N # Lo CJK COMPATIBILITY IDEOGRAPH-FA20
FA22 ; NFD_QC; N # Lo CJK COMPATIBILITY IDEOGRAPH-FA22
FA25..FA26 ; NFD_QC; N # Lo [2] CJK COMPATIBILITY IDEOGRAPH-FA25..CJK COMPATIBILITY IDEOGRAPH-FA26
-FA2A..FA2D ; NFD_QC; N # Lo [4] CJK COMPATIBILITY IDEOGRAPH-FA2A..CJK COMPATIBILITY IDEOGRAPH-FA2D
-FA30..FA6D ; NFD_QC; N # Lo [62] CJK COMPATIBILITY IDEOGRAPH-FA30..CJK COMPATIBILITY IDEOGRAPH-FA6D
+FA2A..FA6D ; NFD_QC; N # Lo [68] CJK COMPATIBILITY IDEOGRAPH-FA2A..CJK COMPATIBILITY IDEOGRAPH-FA6D
FA70..FAD9 ; NFD_QC; N # Lo [106] CJK COMPATIBILITY IDEOGRAPH-FA70..CJK COMPATIBILITY IDEOGRAPH-FAD9
FB1D ; NFD_QC; N # Lo HEBREW LETTER YOD WITH HIRIQ
FB1F ; NFD_QC; N # Lo HEBREW LIGATURE YIDDISH YOD YOD PATAH
@@ -978,11 +979,12 @@
1109A ; NFD_QC; N # Lo KAITHI LETTER DDDHA
1109C ; NFD_QC; N # Lo KAITHI LETTER RHA
110AB ; NFD_QC; N # Lo KAITHI LETTER VA
+1112E..1112F ; NFD_QC; N # Mn [2] CHAKMA VOWEL SIGN O..CHAKMA VOWEL SIGN AU
1D15E..1D164 ; NFD_QC; N # So [7] MUSICAL SYMBOL HALF NOTE..MUSICAL SYMBOL ONE HUNDRED TWENTY-EIGHTH NOTE
1D1BB..1D1C0 ; NFD_QC; N # So [6] MUSICAL SYMBOL MINIMA..MUSICAL SYMBOL FUSA BLACK
2F800..2FA1D ; NFD_QC; N # Lo [542] CJK COMPATIBILITY IDEOGRAPH-2F800..CJK COMPATIBILITY IDEOGRAPH-2FA1D
-# Total code points: 13221
+# Total code points: 13225
# ================================================
@@ -1058,8 +1060,7 @@
FA20 ; NFC_QC; N # Lo CJK COMPATIBILITY IDEOGRAPH-FA20
FA22 ; NFC_QC; N # Lo CJK COMPATIBILITY IDEOGRAPH-FA22
FA25..FA26 ; NFC_QC; N # Lo [2] CJK COMPATIBILITY IDEOGRAPH-FA25..CJK COMPATIBILITY IDEOGRAPH-FA26
-FA2A..FA2D ; NFC_QC; N # Lo [4] CJK COMPATIBILITY IDEOGRAPH-FA2A..CJK COMPATIBILITY IDEOGRAPH-FA2D
-FA30..FA6D ; NFC_QC; N # Lo [62] CJK COMPATIBILITY IDEOGRAPH-FA30..CJK COMPATIBILITY IDEOGRAPH-FA6D
+FA2A..FA6D ; NFC_QC; N # Lo [68] CJK COMPATIBILITY IDEOGRAPH-FA2A..CJK COMPATIBILITY IDEOGRAPH-FA6D
FA70..FAD9 ; NFC_QC; N # Lo [106] CJK COMPATIBILITY IDEOGRAPH-FA70..CJK COMPATIBILITY IDEOGRAPH-FAD9
FB1D ; NFC_QC; N # Lo HEBREW LETTER YOD WITH HIRIQ
FB1F ; NFC_QC; N # Lo HEBREW LIGATURE YIDDISH YOD YOD PATAH
@@ -1073,7 +1074,7 @@
1D1BB..1D1C0 ; NFC_QC; N # So [6] MUSICAL SYMBOL MINIMA..MUSICAL SYMBOL FUSA BLACK
2F800..2FA1D ; NFC_QC; N # Lo [542] CJK COMPATIBILITY IDEOGRAPH-2F800..CJK COMPATIBILITY IDEOGRAPH-2FA1D
-# Total code points: 1118
+# Total code points: 1120
# ================================================
@@ -1114,8 +1115,9 @@
1B35 ; NFC_QC; M # Mc BALINESE VOWEL SIGN TEDUNG
3099..309A ; NFC_QC; M # Mn [2] COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK..COMBINING KATAKANA-HIRAGANA SEMI-VOICED SOUND MARK
110BA ; NFC_QC; M # Mn KAITHI SIGN NUKTA
+11127 ; NFC_QC; M # Mn CHAKMA VOWEL SIGN A
-# Total code points: 103
+# Total code points: 104
# ================================================
@@ -1132,7 +1134,7 @@
00A0 ; NFKD_QC; N # Zs NO-BREAK SPACE
00A8 ; NFKD_QC; N # Sk DIAERESIS
-00AA ; NFKD_QC; N # L& FEMININE ORDINAL INDICATOR
+00AA ; NFKD_QC; N # Lo FEMININE ORDINAL INDICATOR
00AF ; NFKD_QC; N # Sk MACRON
00B2..00B3 ; NFKD_QC; N # No [2] SUPERSCRIPT TWO..SUPERSCRIPT THREE
00B4 ; NFKD_QC; N # Sk ACUTE ACCENT
@@ -1139,7 +1141,7 @@
00B5 ; NFKD_QC; N # L& MICRO SIGN
00B8 ; NFKD_QC; N # Sk CEDILLA
00B9 ; NFKD_QC; N # No SUPERSCRIPT ONE
-00BA ; NFKD_QC; N # L& MASCULINE ORDINAL INDICATOR
+00BA ; NFKD_QC; N # Lo MASCULINE ORDINAL INDICATOR
00BC..00BE ; NFKD_QC; N # No [3] VULGAR FRACTION ONE QUARTER..VULGAR FRACTION THREE QUARTERS
00C0..00C5 ; NFKD_QC; N # L& [6] LATIN CAPITAL LETTER A WITH GRAVE..LATIN CAPITAL LETTER A WITH RING ABOVE
00C7..00CF ; NFKD_QC; N # L& [9] LATIN CAPITAL LETTER C WITH CEDILLA..LATIN CAPITAL LETTER I WITH DIAERESIS
@@ -1267,8 +1269,7 @@
1D2C..1D2E ; NFKD_QC; N # Lm [3] MODIFIER LETTER CAPITAL A..MODIFIER LETTER CAPITAL B
1D30..1D3A ; NFKD_QC; N # Lm [11] MODIFIER LETTER CAPITAL D..MODIFIER LETTER CAPITAL N
1D3C..1D4D ; NFKD_QC; N # Lm [18] MODIFIER LETTER CAPITAL O..MODIFIER LETTER SMALL G
-1D4F..1D61 ; NFKD_QC; N # Lm [19] MODIFIER LETTER SMALL K..MODIFIER LETTER SMALL CHI
-1D62..1D6A ; NFKD_QC; N # L& [9] LATIN SUBSCRIPT SMALL LETTER I..GREEK SUBSCRIPT SMALL LETTER CHI
+1D4F..1D6A ; NFKD_QC; N # Lm [28] MODIFIER LETTER SMALL K..GREEK SUBSCRIPT SMALL LETTER CHI
1D78 ; NFKD_QC; N # Lm MODIFIER LETTER CYRILLIC EN
1D9B..1DBF ; NFKD_QC; N # Lm [37] MODIFIER LETTER SMALL TURNED ALPHA..MODIFIER LETTER SMALL THETA
1E00..1E9B ; NFKD_QC; N # L& [156] LATIN CAPITAL LETTER A WITH RING BELOW..LATIN SMALL LETTER LONG S WITH DOT ABOVE
@@ -1383,8 +1384,7 @@
2A0C ; NFKD_QC; N # Sm QUADRUPLE INTEGRAL OPERATOR
2A74..2A76 ; NFKD_QC; N # Sm [3] DOUBLE COLON EQUAL..THREE CONSECUTIVE EQUALS SIGNS
2ADC ; NFKD_QC; N # Sm FORKING
-2C7C ; NFKD_QC; N # L& LATIN SUBSCRIPT SMALL LETTER J
-2C7D ; NFKD_QC; N # Lm MODIFIER LETTER CAPITAL V
+2C7C..2C7D ; NFKD_QC; N # Lm [2] LATIN SUBSCRIPT SMALL LETTER J..MODIFIER LETTER CAPITAL V
2D6F ; NFKD_QC; N # Lm TIFINAGH MODIFIER LETTER LABIALIZATION MARK
2E9F ; NFKD_QC; N # So CJK RADICAL MOTHER
2EF3 ; NFKD_QC; N # So CJK RADICAL C-SIMPLIFIED TURTLE
@@ -1455,6 +1455,7 @@
32C0..32FE ; NFKD_QC; N # So [63] IDEOGRAPHIC TELEGRAPH SYMBOL FOR JANUARY..CIRCLED KATAKANA WO
3300..33FF ; NFKD_QC; N # So [256] SQUARE APAATO..SQUARE GAL
A770 ; NFKD_QC; N # Lm MODIFIER LETTER US
+A7F8..A7F9 ; NFKD_QC; N # Lm [2] MODIFIER LETTER CAPITAL H WITH STROKE..MODIFIER LETTER SMALL LIGATURE OE
AC00..D7A3 ; NFKD_QC; N # Lo [11172] HANGUL SYLLABLE GA..HANGUL SYLLABLE HIH
F900..FA0D ; NFKD_QC; N # Lo [270] CJK COMPATIBILITY IDEOGRAPH-F900..CJK COMPATIBILITY IDEOGRAPH-FA0D
FA10 ; NFKD_QC; N # Lo CJK COMPATIBILITY IDEOGRAPH-FA10
@@ -1463,8 +1464,7 @@
FA20 ; NFKD_QC; N # Lo CJK COMPATIBILITY IDEOGRAPH-FA20
FA22 ; NFKD_QC; N # Lo CJK COMPATIBILITY IDEOGRAPH-FA22
FA25..FA26 ; NFKD_QC; N # Lo [2] CJK COMPATIBILITY IDEOGRAPH-FA25..CJK COMPATIBILITY IDEOGRAPH-FA26
-FA2A..FA2D ; NFKD_QC; N # Lo [4] CJK COMPATIBILITY IDEOGRAPH-FA2A..CJK COMPATIBILITY IDEOGRAPH-FA2D
-FA30..FA6D ; NFKD_QC; N # Lo [62] CJK COMPATIBILITY IDEOGRAPH-FA30..CJK COMPATIBILITY IDEOGRAPH-FA6D
+FA2A..FA6D ; NFKD_QC; N # Lo [68] CJK COMPATIBILITY IDEOGRAPH-FA2A..CJK COMPATIBILITY IDEOGRAPH-FA6D
FA70..FAD9 ; NFKD_QC; N # Lo [106] CJK COMPATIBILITY IDEOGRAPH-FA70..CJK COMPATIBILITY IDEOGRAPH-FAD9
FB00..FB06 ; NFKD_QC; N # L& [7] LATIN SMALL LIGATURE FF..LATIN SMALL LIGATURE ST
FB13..FB17 ; NFKD_QC; N # L& [5] ARMENIAN SMALL LIGATURE MEN NOW..ARMENIAN SMALL LIGATURE MEN XEH
@@ -1580,6 +1580,7 @@
1109A ; NFKD_QC; N # Lo KAITHI LETTER DDDHA
1109C ; NFKD_QC; N # Lo KAITHI LETTER RHA
110AB ; NFKD_QC; N # Lo KAITHI LETTER VA
+1112E..1112F ; NFKD_QC; N # Mn [2] CHAKMA VOWEL SIGN O..CHAKMA VOWEL SIGN AU
1D15E..1D164 ; NFKD_QC; N # So [7] MUSICAL SYMBOL HALF NOTE..MUSICAL SYMBOL ONE HUNDRED TWENTY-EIGHTH NOTE
1D1BB..1D1C0 ; NFKD_QC; N # So [6] MUSICAL SYMBOL MINIMA..MUSICAL SYMBOL FUSA BLACK
1D400..1D454 ; NFKD_QC; N # L& [85] MATHEMATICAL BOLD CAPITAL A..MATHEMATICAL ITALIC SMALL G
@@ -1623,9 +1624,43 @@
1D7C3 ; NFKD_QC; N # Sm MATHEMATICAL SANS-SERIF BOLD ITALIC PARTIAL DIFFERENTIAL
1D7C4..1D7CB ; NFKD_QC; N # L& [8] MATHEMATICAL SANS-SERIF BOLD ITALIC EPSILON SYMBOL..MATHEMATICAL BOLD SMALL DIGAMMA
1D7CE..1D7FF ; NFKD_QC; N # Nd [50] MATHEMATICAL BOLD DIGIT ZERO..MATHEMATICAL MONOSPACE DIGIT NINE
+1EE00..1EE03 ; NFKD_QC; N # Lo [4] ARABIC MATHEMATICAL ALEF..ARABIC MATHEMATICAL DAL
+1EE05..1EE1F ; NFKD_QC; N # Lo [27] ARABIC MATHEMATICAL WAW..ARABIC MATHEMATICAL DOTLESS QAF
+1EE21..1EE22 ; NFKD_QC; N # Lo [2] ARABIC MATHEMATICAL INITIAL BEH..ARABIC MATHEMATICAL INITIAL JEEM
+1EE24 ; NFKD_QC; N # Lo ARABIC MATHEMATICAL INITIAL HEH
+1EE27 ; NFKD_QC; N # Lo ARABIC MATHEMATICAL INITIAL HAH
+1EE29..1EE32 ; NFKD_QC; N # Lo [10] ARABIC MATHEMATICAL INITIAL YEH..ARABIC MATHEMATICAL INITIAL QAF
+1EE34..1EE37 ; NFKD_QC; N # Lo [4] ARABIC MATHEMATICAL INITIAL SHEEN..ARABIC MATHEMATICAL INITIAL KHAH
+1EE39 ; NFKD_QC; N # Lo ARABIC MATHEMATICAL INITIAL DAD
+1EE3B ; NFKD_QC; N # Lo ARABIC MATHEMATICAL INITIAL GHAIN
+1EE42 ; NFKD_QC; N # Lo ARABIC MATHEMATICAL TAILED JEEM
+1EE47 ; NFKD_QC; N # Lo ARABIC MATHEMATICAL TAILED HAH
+1EE49 ; NFKD_QC; N # Lo ARABIC MATHEMATICAL TAILED YEH
+1EE4B ; NFKD_QC; N # Lo ARABIC MATHEMATICAL TAILED LAM
+1EE4D..1EE4F ; NFKD_QC; N # Lo [3] ARABIC MATHEMATICAL TAILED NOON..ARABIC MATHEMATICAL TAILED AIN
+1EE51..1EE52 ; NFKD_QC; N # Lo [2] ARABIC MATHEMATICAL TAILED SAD..ARABIC MATHEMATICAL TAILED QAF
+1EE54 ; NFKD_QC; N # Lo ARABIC MATHEMATICAL TAILED SHEEN
+1EE57 ; NFKD_QC; N # Lo ARABIC MATHEMATICAL TAILED KHAH
+1EE59 ; NFKD_QC; N # Lo ARABIC MATHEMATICAL TAILED DAD
+1EE5B ; NFKD_QC; N # Lo ARABIC MATHEMATICAL TAILED GHAIN
+1EE5D ; NFKD_QC; N # Lo ARABIC MATHEMATICAL TAILED DOTLESS NOON
+1EE5F ; NFKD_QC; N # Lo ARABIC MATHEMATICAL TAILED DOTLESS QAF
+1EE61..1EE62 ; NFKD_QC; N # Lo [2] ARABIC MATHEMATICAL STRETCHED BEH..ARABIC MATHEMATICAL STRETCHED JEEM
+1EE64 ; NFKD_QC; N # Lo ARABIC MATHEMATICAL STRETCHED HEH
+1EE67..1EE6A ; NFKD_QC; N # Lo [4] ARABIC MATHEMATICAL STRETCHED HAH..ARABIC MATHEMATICAL STRETCHED KAF
+1EE6C..1EE72 ; NFKD_QC; N # Lo [7] ARABIC MATHEMATICAL STRETCHED MEEM..ARABIC MATHEMATICAL STRETCHED QAF
+1EE74..1EE77 ; NFKD_QC; N # Lo [4] ARABIC MATHEMATICAL STRETCHED SHEEN..ARABIC MATHEMATICAL STRETCHED KHAH
+1EE79..1EE7C ; NFKD_QC; N # Lo [4] ARABIC MATHEMATICAL STRETCHED DAD..ARABIC MATHEMATICAL STRETCHED DOTLESS BEH
+1EE7E ; NFKD_QC; N # Lo ARABIC MATHEMATICAL STRETCHED DOTLESS FEH
+1EE80..1EE89 ; NFKD_QC; N # Lo [10] ARABIC MATHEMATICAL LOOPED ALEF..ARABIC MATHEMATICAL LOOPED YEH
+1EE8B..1EE9B ; NFKD_QC; N # Lo [17] ARABIC MATHEMATICAL LOOPED LAM..ARABIC MATHEMATICAL LOOPED GHAIN
+1EEA1..1EEA3 ; NFKD_QC; N # Lo [3] ARABIC MATHEMATICAL DOUBLE-STRUCK BEH..ARABIC MATHEMATICAL DOUBLE-STRUCK DAL
+1EEA5..1EEA9 ; NFKD_QC; N # Lo [5] ARABIC MATHEMATICAL DOUBLE-STRUCK WAW..ARABIC MATHEMATICAL DOUBLE-STRUCK YEH
+1EEAB..1EEBB ; NFKD_QC; N # Lo [17] ARABIC MATHEMATICAL DOUBLE-STRUCK LAM..ARABIC MATHEMATICAL DOUBLE-STRUCK GHAIN
1F100..1F10A ; NFKD_QC; N # No [11] DIGIT ZERO FULL STOP..DIGIT NINE COMMA
1F110..1F12E ; NFKD_QC; N # So [31] PARENTHESIZED LATIN CAPITAL LETTER A..CIRCLED WZ
1F130..1F14F ; NFKD_QC; N # So [32] SQUARED LATIN CAPITAL LETTER A..SQUARED WC
+1F16A..1F16B ; NFKD_QC; N # So [2] RAISED MC SIGN..RAISED MD SIGN
1F190 ; NFKD_QC; N # So SQUARE DJ
1F200..1F202 ; NFKD_QC; N # So [3] SQUARE HIRAGANA HOKA..SQUARED KATAKANA SA
1F210..1F23A ; NFKD_QC; N # So [43] SQUARED CJK UNIFIED IDEOGRAPH-624B..SQUARED CJK UNIFIED IDEOGRAPH-55B6
@@ -1633,7 +1668,7 @@
1F250..1F251 ; NFKD_QC; N # So [2] CIRCLED IDEOGRAPH ADVANTAGE..CIRCLED IDEOGRAPH ACCEPT
2F800..2FA1D ; NFKD_QC; N # Lo [542] CJK COMPATIBILITY IDEOGRAPH-2F800..CJK COMPATIBILITY IDEOGRAPH-2FA1D
-# Total code points: 16731
+# Total code points: 16880
# ================================================
@@ -1650,7 +1685,7 @@
00A0 ; NFKC_QC; N # Zs NO-BREAK SPACE
00A8 ; NFKC_QC; N # Sk DIAERESIS
-00AA ; NFKC_QC; N # L& FEMININE ORDINAL INDICATOR
+00AA ; NFKC_QC; N # Lo FEMININE ORDINAL INDICATOR
00AF ; NFKC_QC; N # Sk MACRON
00B2..00B3 ; NFKC_QC; N # No [2] SUPERSCRIPT TWO..SUPERSCRIPT THREE
00B4 ; NFKC_QC; N # Sk ACUTE ACCENT
@@ -1657,7 +1692,7 @@
00B5 ; NFKC_QC; N # L& MICRO SIGN
00B8 ; NFKC_QC; N # Sk CEDILLA
00B9 ; NFKC_QC; N # No SUPERSCRIPT ONE
-00BA ; NFKC_QC; N # L& MASCULINE ORDINAL INDICATOR
+00BA ; NFKC_QC; N # Lo MASCULINE ORDINAL INDICATOR
00BC..00BE ; NFKC_QC; N # No [3] VULGAR FRACTION ONE QUARTER..VULGAR FRACTION THREE QUARTERS
0132..0133 ; NFKC_QC; N # L& [2] LATIN CAPITAL LIGATURE IJ..LATIN SMALL LIGATURE IJ
013F..0140 ; NFKC_QC; N # L& [2] LATIN CAPITAL LETTER L WITH MIDDLE DOT..LATIN SMALL LETTER L WITH MIDDLE DOT
@@ -1712,8 +1747,7 @@
1D2C..1D2E ; NFKC_QC; N # Lm [3] MODIFIER LETTER CAPITAL A..MODIFIER LETTER CAPITAL B
1D30..1D3A ; NFKC_QC; N # Lm [11] MODIFIER LETTER CAPITAL D..MODIFIER LETTER CAPITAL N
1D3C..1D4D ; NFKC_QC; N # Lm [18] MODIFIER LETTER CAPITAL O..MODIFIER LETTER SMALL G
-1D4F..1D61 ; NFKC_QC; N # Lm [19] MODIFIER LETTER SMALL K..MODIFIER LETTER SMALL CHI
-1D62..1D6A ; NFKC_QC; N # L& [9] LATIN SUBSCRIPT SMALL LETTER I..GREEK SUBSCRIPT SMALL LETTER CHI
+1D4F..1D6A ; NFKC_QC; N # Lm [28] MODIFIER LETTER SMALL K..GREEK SUBSCRIPT SMALL LETTER CHI
1D78 ; NFKC_QC; N # Lm MODIFIER LETTER CYRILLIC EN
1D9B..1DBF ; NFKC_QC; N # Lm [37] MODIFIER LETTER SMALL TURNED ALPHA..MODIFIER LETTER SMALL THETA
1E9A..1E9B ; NFKC_QC; N # L& [2] LATIN SMALL LETTER A WITH RIGHT HALF RING..LATIN SMALL LETTER LONG S WITH DOT ABOVE
@@ -1801,8 +1835,7 @@
2A0C ; NFKC_QC; N # Sm QUADRUPLE INTEGRAL OPERATOR
2A74..2A76 ; NFKC_QC; N # Sm [3] DOUBLE COLON EQUAL..THREE CONSECUTIVE EQUALS SIGNS
2ADC ; NFKC_QC; N # Sm FORKING
-2C7C ; NFKC_QC; N # L& LATIN SUBSCRIPT SMALL LETTER J
-2C7D ; NFKC_QC; N # Lm MODIFIER LETTER CAPITAL V
+2C7C..2C7D ; NFKC_QC; N # Lm [2] LATIN SUBSCRIPT SMALL LETTER J..MODIFIER LETTER CAPITAL V
2D6F ; NFKC_QC; N # Lm TIFINAGH MODIFIER LETTER LABIALIZATION MARK
2E9F ; NFKC_QC; N # So CJK RADICAL MOTHER
2EF3 ; NFKC_QC; N # So CJK RADICAL C-SIMPLIFIED TURTLE
@@ -1828,6 +1861,7 @@
32C0..32FE ; NFKC_QC; N # So [63] IDEOGRAPHIC TELEGRAPH SYMBOL FOR JANUARY..CIRCLED KATAKANA WO
3300..33FF ; NFKC_QC; N # So [256] SQUARE APAATO..SQUARE GAL
A770 ; NFKC_QC; N # Lm MODIFIER LETTER US
+A7F8..A7F9 ; NFKC_QC; N # Lm [2] MODIFIER LETTER CAPITAL H WITH STROKE..MODIFIER LETTER SMALL LIGATURE OE
F900..FA0D ; NFKC_QC; N # Lo [270] CJK COMPATIBILITY IDEOGRAPH-F900..CJK COMPATIBILITY IDEOGRAPH-FA0D
FA10 ; NFKC_QC; N # Lo CJK COMPATIBILITY IDEOGRAPH-FA10
FA12 ; NFKC_QC; N # Lo CJK COMPATIBILITY IDEOGRAPH-FA12
@@ -1835,8 +1869,7 @@
FA20 ; NFKC_QC; N # Lo CJK COMPATIBILITY IDEOGRAPH-FA20
FA22 ; NFKC_QC; N # Lo CJK COMPATIBILITY IDEOGRAPH-FA22
FA25..FA26 ; NFKC_QC; N # Lo [2] CJK COMPATIBILITY IDEOGRAPH-FA25..CJK COMPATIBILITY IDEOGRAPH-FA26
-FA2A..FA2D ; NFKC_QC; N # Lo [4] CJK COMPATIBILITY IDEOGRAPH-FA2A..CJK COMPATIBILITY IDEOGRAPH-FA2D
-FA30..FA6D ; NFKC_QC; N # Lo [62] CJK COMPATIBILITY IDEOGRAPH-FA30..CJK COMPATIBILITY IDEOGRAPH-FA6D
+FA2A..FA6D ; NFKC_QC; N # Lo [68] CJK COMPATIBILITY IDEOGRAPH-FA2A..CJK COMPATIBILITY IDEOGRAPH-FA6D
FA70..FAD9 ; NFKC_QC; N # Lo [106] CJK COMPATIBILITY IDEOGRAPH-FA70..CJK COMPATIBILITY IDEOGRAPH-FAD9
FB00..FB06 ; NFKC_QC; N # L& [7] LATIN SMALL LIGATURE FF..LATIN SMALL LIGATURE ST
FB13..FB17 ; NFKC_QC; N # L& [5] ARMENIAN SMALL LIGATURE MEN NOW..ARMENIAN SMALL LIGATURE MEN XEH
@@ -1992,9 +2025,43 @@
1D7C3 ; NFKC_QC; N # Sm MATHEMATICAL SANS-SERIF BOLD ITALIC PARTIAL DIFFERENTIAL
1D7C4..1D7CB ; NFKC_QC; N # L& [8] MATHEMATICAL SANS-SERIF BOLD ITALIC EPSILON SYMBOL..MATHEMATICAL BOLD SMALL DIGAMMA
1D7CE..1D7FF ; NFKC_QC; N # Nd [50] MATHEMATICAL BOLD DIGIT ZERO..MATHEMATICAL MONOSPACE DIGIT NINE
+1EE00..1EE03 ; NFKC_QC; N # Lo [4] ARABIC MATHEMATICAL ALEF..ARABIC MATHEMATICAL DAL
+1EE05..1EE1F ; NFKC_QC; N # Lo [27] ARABIC MATHEMATICAL WAW..ARABIC MATHEMATICAL DOTLESS QAF
+1EE21..1EE22 ; NFKC_QC; N # Lo [2] ARABIC MATHEMATICAL INITIAL BEH..ARABIC MATHEMATICAL INITIAL JEEM
+1EE24 ; NFKC_QC; N # Lo ARABIC MATHEMATICAL INITIAL HEH
+1EE27 ; NFKC_QC; N # Lo ARABIC MATHEMATICAL INITIAL HAH
+1EE29..1EE32 ; NFKC_QC; N # Lo [10] ARABIC MATHEMATICAL INITIAL YEH..ARABIC MATHEMATICAL INITIAL QAF
+1EE34..1EE37 ; NFKC_QC; N # Lo [4] ARABIC MATHEMATICAL INITIAL SHEEN..ARABIC MATHEMATICAL INITIAL KHAH
+1EE39 ; NFKC_QC; N # Lo ARABIC MATHEMATICAL INITIAL DAD
+1EE3B ; NFKC_QC; N # Lo ARABIC MATHEMATICAL INITIAL GHAIN
+1EE42 ; NFKC_QC; N # Lo ARABIC MATHEMATICAL TAILED JEEM
+1EE47 ; NFKC_QC; N # Lo ARABIC MATHEMATICAL TAILED HAH
+1EE49 ; NFKC_QC; N # Lo ARABIC MATHEMATICAL TAILED YEH
+1EE4B ; NFKC_QC; N # Lo ARABIC MATHEMATICAL TAILED LAM
+1EE4D..1EE4F ; NFKC_QC; N # Lo [3] ARABIC MATHEMATICAL TAILED NOON..ARABIC MATHEMATICAL TAILED AIN
+1EE51..1EE52 ; NFKC_QC; N # Lo [2] ARABIC MATHEMATICAL TAILED SAD..ARABIC MATHEMATICAL TAILED QAF
+1EE54 ; NFKC_QC; N # Lo ARABIC MATHEMATICAL TAILED SHEEN
+1EE57 ; NFKC_QC; N # Lo ARABIC MATHEMATICAL TAILED KHAH
+1EE59 ; NFKC_QC; N # Lo ARABIC MATHEMATICAL TAILED DAD
+1EE5B ; NFKC_QC; N # Lo ARABIC MATHEMATICAL TAILED GHAIN
+1EE5D ; NFKC_QC; N # Lo ARABIC MATHEMATICAL TAILED DOTLESS NOON
+1EE5F ; NFKC_QC; N # Lo ARABIC MATHEMATICAL TAILED DOTLESS QAF
+1EE61..1EE62 ; NFKC_QC; N # Lo [2] ARABIC MATHEMATICAL STRETCHED BEH..ARABIC MATHEMATICAL STRETCHED JEEM
+1EE64 ; NFKC_QC; N # Lo ARABIC MATHEMATICAL STRETCHED HEH
+1EE67..1EE6A ; NFKC_QC; N # Lo [4] ARABIC MATHEMATICAL STRETCHED HAH..ARABIC MATHEMATICAL STRETCHED KAF
+1EE6C..1EE72 ; NFKC_QC; N # Lo [7] ARABIC MATHEMATICAL STRETCHED MEEM..ARABIC MATHEMATICAL STRETCHED QAF
+1EE74..1EE77 ; NFKC_QC; N # Lo [4] ARABIC MATHEMATICAL STRETCHED SHEEN..ARABIC MATHEMATICAL STRETCHED KHAH
+1EE79..1EE7C ; NFKC_QC; N # Lo [4] ARABIC MATHEMATICAL STRETCHED DAD..ARABIC MATHEMATICAL STRETCHED DOTLESS BEH
+1EE7E ; NFKC_QC; N # Lo ARABIC MATHEMATICAL STRETCHED DOTLESS FEH
+1EE80..1EE89 ; NFKC_QC; N # Lo [10] ARABIC MATHEMATICAL LOOPED ALEF..ARABIC MATHEMATICAL LOOPED YEH
+1EE8B..1EE9B ; NFKC_QC; N # Lo [17] ARABIC MATHEMATICAL LOOPED LAM..ARABIC MATHEMATICAL LOOPED GHAIN
+1EEA1..1EEA3 ; NFKC_QC; N # Lo [3] ARABIC MATHEMATICAL DOUBLE-STRUCK BEH..ARABIC MATHEMATICAL DOUBLE-STRUCK DAL
+1EEA5..1EEA9 ; NFKC_QC; N # Lo [5] ARABIC MATHEMATICAL DOUBLE-STRUCK WAW..ARABIC MATHEMATICAL DOUBLE-STRUCK YEH
+1EEAB..1EEBB ; NFKC_QC; N # Lo [17] ARABIC MATHEMATICAL DOUBLE-STRUCK LAM..ARABIC MATHEMATICAL DOUBLE-STRUCK GHAIN
1F100..1F10A ; NFKC_QC; N # No [11] DIGIT ZERO FULL STOP..DIGIT NINE COMMA
1F110..1F12E ; NFKC_QC; N # So [31] PARENTHESIZED LATIN CAPITAL LETTER A..CIRCLED WZ
1F130..1F14F ; NFKC_QC; N # So [32] SQUARED LATIN CAPITAL LETTER A..SQUARED WC
+1F16A..1F16B ; NFKC_QC; N # So [2] RAISED MC SIGN..RAISED MD SIGN
1F190 ; NFKC_QC; N # So SQUARE DJ
1F200..1F202 ; NFKC_QC; N # So [3] SQUARE HIRAGANA HOKA..SQUARED KATAKANA SA
1F210..1F23A ; NFKC_QC; N # So [43] SQUARED CJK UNIFIED IDEOGRAPH-624B..SQUARED CJK UNIFIED IDEOGRAPH-55B6
@@ -2002,7 +2069,7 @@
1F250..1F251 ; NFKC_QC; N # So [2] CIRCLED IDEOGRAPH ADVANTAGE..CIRCLED IDEOGRAPH ACCEPT
2F800..2FA1D ; NFKC_QC; N # Lo [542] CJK COMPATIBILITY IDEOGRAPH-2F800..CJK COMPATIBILITY IDEOGRAPH-2FA1D
-# Total code points: 4640
+# Total code points: 4787
# ================================================
@@ -2043,8 +2110,9 @@
1B35 ; NFKC_QC; M # Mc BALINESE VOWEL SIGN TEDUNG
3099..309A ; NFKC_QC; M # Mn [2] COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK..COMBINING KATAKANA-HIRAGANA SEMI-VOICED SOUND MARK
110BA ; NFKC_QC; M # Mn KAITHI SIGN NUKTA
+11127 ; NFKC_QC; M # Mn CHAKMA VOWEL SIGN A
-# Total code points: 103
+# Total code points: 104
# ================================================
@@ -2269,10 +2337,11 @@
1109A ; Expands_On_NFD # Lo KAITHI LETTER DDDHA
1109C ; Expands_On_NFD # Lo KAITHI LETTER RHA
110AB ; Expands_On_NFD # Lo KAITHI LETTER VA
+1112E..1112F ; Expands_On_NFD # Mn [2] CHAKMA VOWEL SIGN O..CHAKMA VOWEL SIGN AU
1D15E..1D164 ; Expands_On_NFD # So [7] MUSICAL SYMBOL HALF NOTE..MUSICAL SYMBOL ONE HUNDRED TWENTY-EIGHTH NOTE
1D1BB..1D1C0 ; Expands_On_NFD # So [6] MUSICAL SYMBOL MINIMA..MUSICAL SYMBOL FUSA BLACK
-# Total code points: 12206
+# Total code points: 12208
# ================================================
@@ -2617,6 +2686,7 @@
1109A ; Expands_On_NFKD # Lo KAITHI LETTER DDDHA
1109C ; Expands_On_NFKD # Lo KAITHI LETTER RHA
110AB ; Expands_On_NFKD # Lo KAITHI LETTER VA
+1112E..1112F ; Expands_On_NFKD # Mn [2] CHAKMA VOWEL SIGN O..CHAKMA VOWEL SIGN AU
1D15E..1D164 ; Expands_On_NFKD # So [7] MUSICAL SYMBOL HALF NOTE..MUSICAL SYMBOL ONE HUNDRED TWENTY-EIGHTH NOTE
1D1BB..1D1C0 ; Expands_On_NFKD # So [6] MUSICAL SYMBOL MINIMA..MUSICAL SYMBOL FUSA BLACK
1F100..1F10A ; Expands_On_NFKD # No [11] DIGIT ZERO FULL STOP..DIGIT NINE COMMA
@@ -2623,12 +2693,13 @@
1F110..1F12A ; Expands_On_NFKD # So [27] PARENTHESIZED LATIN CAPITAL LETTER A..TORTOISE SHELL BRACKETED LATIN CAPITAL LETTER S
1F12D..1F12E ; Expands_On_NFKD # So [2] CIRCLED CD..CIRCLED WZ
1F14A..1F14F ; Expands_On_NFKD # So [6] SQUARED HV..SQUARED WC
+1F16A..1F16B ; Expands_On_NFKD # So [2] RAISED MC SIGN..RAISED MD SIGN
1F190 ; Expands_On_NFKD # So SQUARE DJ
1F200..1F201 ; Expands_On_NFKD # So [2] SQUARE HIRAGANA HOKA..SQUARED KATAKANA KOKO
1F213 ; Expands_On_NFKD # So SQUARED KATAKANA DE
1F240..1F248 ; Expands_On_NFKD # So [9] TORTOISE SHELL BRACKETED CJK UNIFIED IDEOGRAPH-672C..TORTOISE SHELL BRACKETED CJK UNIFIED IDEOGRAPH-6557
-# Total code points: 13376
+# Total code points: 13380
# ================================================
@@ -2761,11 +2832,12 @@
1F110..1F12A ; Expands_On_NFKC # So [27] PARENTHESIZED LATIN CAPITAL LETTER A..TORTOISE SHELL BRACKETED LATIN CAPITAL LETTER S
1F12D..1F12E ; Expands_On_NFKC # So [2] CIRCLED CD..CIRCLED WZ
1F14A..1F14F ; Expands_On_NFKC # So [6] SQUARED HV..SQUARED WC
+1F16A..1F16B ; Expands_On_NFKC # So [2] RAISED MC SIGN..RAISED MD SIGN
1F190 ; Expands_On_NFKC # So SQUARE DJ
1F200..1F201 ; Expands_On_NFKC # So [2] SQUARE HIRAGANA HOKA..SQUARED KATAKANA KOKO
1F240..1F248 ; Expands_On_NFKC # So [9] TORTOISE SHELL BRACKETED CJK UNIFIED IDEOGRAPH-672C..TORTOISE SHELL BRACKETED CJK UNIFIED IDEOGRAPH-6557
-# Total code points: 1233
+# Total code points: 1235
# ================================================
@@ -2810,7 +2882,7 @@
005A ; NFKC_CF; 007A # L& LATIN CAPITAL LETTER Z
00A0 ; NFKC_CF; 0020 # Zs NO-BREAK SPACE
00A8 ; NFKC_CF; 0020 0308 # Sk DIAERESIS
-00AA ; NFKC_CF; 0061 # L& FEMININE ORDINAL INDICATOR
+00AA ; NFKC_CF; 0061 # Lo FEMININE ORDINAL INDICATOR
00AD ; NFKC_CF; # Cf SOFT HYPHEN
00AF ; NFKC_CF; 0020 0304 # Sk MACRON
00B2 ; NFKC_CF; 0032 # No SUPERSCRIPT TWO
@@ -2819,7 +2891,7 @@
00B5 ; NFKC_CF; 03BC # L& MICRO SIGN
00B8 ; NFKC_CF; 0020 0327 # Sk CEDILLA
00B9 ; NFKC_CF; 0031 # No SUPERSCRIPT ONE
-00BA ; NFKC_CF; 006F # L& MASCULINE ORDINAL INDICATOR
+00BA ; NFKC_CF; 006F # Lo MASCULINE ORDINAL INDICATOR
00BC ; NFKC_CF; 0031 2044 0034 # No VULGAR FRACTION ONE QUARTER
00BD ; NFKC_CF; 0031 2044 0032 # No VULGAR FRACTION ONE HALF
00BE ; NFKC_CF; 0033 2044 0034 # No VULGAR FRACTION THREE QUARTERS
@@ -3390,9 +3462,11 @@
10C3 ; NFKC_CF; 2D23 # L& GEORGIAN CAPITAL LETTER WE
10C4 ; NFKC_CF; 2D24 # L& GEORGIAN CAPITAL LETTER HAR
10C5 ; NFKC_CF; 2D25 # L& GEORGIAN CAPITAL LETTER HOE
+10C7 ; NFKC_CF; 2D27 # L& GEORGIAN CAPITAL LETTER YN
+10CD ; NFKC_CF; 2D2D # L& GEORGIAN CAPITAL LETTER AEN
10FC ; NFKC_CF; 10DC # Lm MODIFIER LETTER GEORGIAN NAR
115F..1160 ; NFKC_CF; # Lo [2] HANGUL CHOSEONG FILLER..HANGUL JUNGSEONG FILLER
-17B4..17B5 ; NFKC_CF; # Cf [2] KHMER VOWEL INHERENT AQ..KHMER VOWEL INHERENT AA
+17B4..17B5 ; NFKC_CF; # Mn [2] KHMER VOWEL INHERENT AQ..KHMER VOWEL INHERENT AA
180B..180D ; NFKC_CF; # Mn [3] MONGOLIAN FREE VARIATION SELECTOR ONE..MONGOLIAN FREE VARIATION SELECTOR THREE
1D2C ; NFKC_CF; 0061 # Lm MODIFIER LETTER CAPITAL A
1D2D ; NFKC_CF; 00E6 # Lm MODIFIER LETTER CAPITAL AE
@@ -3445,15 +3519,15 @@
1D5F ; NFKC_CF; 03B4 # Lm MODIFIER LETTER SMALL DELTA
1D60 ; NFKC_CF; 03C6 # Lm MODIFIER LETTER SMALL GREEK PHI
1D61 ; NFKC_CF; 03C7 # Lm MODIFIER LETTER SMALL CHI
-1D62 ; NFKC_CF; 0069 # L& LATIN SUBSCRIPT SMALL LETTER I
-1D63 ; NFKC_CF; 0072 # L& LATIN SUBSCRIPT SMALL LETTER R
-1D64 ; NFKC_CF; 0075 # L& LATIN SUBSCRIPT SMALL LETTER U
-1D65 ; NFKC_CF; 0076 # L& LATIN SUBSCRIPT SMALL LETTER V
-1D66 ; NFKC_CF; 03B2 # L& GREEK SUBSCRIPT SMALL LETTER BETA
-1D67 ; NFKC_CF; 03B3 # L& GREEK SUBSCRIPT SMALL LETTER GAMMA
-1D68 ; NFKC_CF; 03C1 # L& GREEK SUBSCRIPT SMALL LETTER RHO
-1D69 ; NFKC_CF; 03C6 # L& GREEK SUBSCRIPT SMALL LETTER PHI
-1D6A ; NFKC_CF; 03C7 # L& GREEK SUBSCRIPT SMALL LETTER CHI
+1D62 ; NFKC_CF; 0069 # Lm LATIN SUBSCRIPT SMALL LETTER I
+1D63 ; NFKC_CF; 0072 # Lm LATIN SUBSCRIPT SMALL LETTER R
+1D64 ; NFKC_CF; 0075 # Lm LATIN SUBSCRIPT SMALL LETTER U
+1D65 ; NFKC_CF; 0076 # Lm LATIN SUBSCRIPT SMALL LETTER V
+1D66 ; NFKC_CF; 03B2 # Lm GREEK SUBSCRIPT SMALL LETTER BETA
+1D67 ; NFKC_CF; 03B3 # Lm GREEK SUBSCRIPT SMALL LETTER GAMMA
+1D68 ; NFKC_CF; 03C1 # Lm GREEK SUBSCRIPT SMALL LETTER RHO
+1D69 ; NFKC_CF; 03C6 # Lm GREEK SUBSCRIPT SMALL LETTER PHI
+1D6A ; NFKC_CF; 03C7 # Lm GREEK SUBSCRIPT SMALL LETTER CHI
1D78 ; NFKC_CF; 043D # Lm MODIFIER LETTER CYRILLIC EN
1D9B ; NFKC_CF; 0252 # Lm MODIFIER LETTER SMALL TURNED ALPHA
1D9C ; NFKC_CF; 0063 # Lm MODIFIER LETTER SMALL C
@@ -4148,7 +4222,7 @@
2C70 ; NFKC_CF; 0252 # L& LATIN CAPITAL LETTER TURNED ALPHA
2C72 ; NFKC_CF; 2C73 # L& LATIN CAPITAL LETTER W WITH HOOK
2C75 ; NFKC_CF; 2C76 # L& LATIN CAPITAL LETTER HALF H
-2C7C ; NFKC_CF; 006A # L& LATIN SUBSCRIPT SMALL LETTER J
+2C7C ; NFKC_CF; 006A # Lm LATIN SUBSCRIPT SMALL LETTER J
2C7D ; NFKC_CF; 0076 # Lm MODIFIER LETTER CAPITAL V
2C7E ; NFKC_CF; 023F # L& LATIN CAPITAL LETTER S WITH SWASH TAIL
2C7F ; NFKC_CF; 0240 # L& LATIN CAPITAL LETTER Z WITH SWASH TAIL
@@ -4204,6 +4278,7 @@
2CE2 ; NFKC_CF; 2CE3 # L& COPTIC CAPITAL LETTER OLD NUBIAN WAU
2CEB ; NFKC_CF; 2CEC # L& COPTIC CAPITAL LETTER CRYPTOGRAMMIC SHEI
2CED ; NFKC_CF; 2CEE # L& COPTIC CAPITAL LETTER CRYPTOGRAMMIC GANGIA
+2CF2 ; NFKC_CF; 2CF3 # L& COPTIC CAPITAL LETTER BOHAIRIC KHEI
2D6F ; NFKC_CF; 2D61 # Lm TIFINAGH MODIFIER LETTER LABIALIZATION MARK
2E9F ; NFKC_CF; 6BCD # So CJK RADICAL MOTHER
2EF3 ; NFKC_CF; 9F9F # So CJK RADICAL C-SIMPLIFIED TURTLE
@@ -5124,11 +5199,15 @@
A78B ; NFKC_CF; A78C # L& LATIN CAPITAL LETTER SALTILLO
A78D ; NFKC_CF; 0265 # L& LATIN CAPITAL LETTER TURNED H
A790 ; NFKC_CF; A791 # L& LATIN CAPITAL LETTER N WITH DESCENDER
+A792 ; NFKC_CF; A793 # L& LATIN CAPITAL LETTER C WITH BAR
A7A0 ; NFKC_CF; A7A1 # L& LATIN CAPITAL LETTER G WITH OBLIQUE STROKE
A7A2 ; NFKC_CF; A7A3 # L& LATIN CAPITAL LETTER K WITH OBLIQUE STROKE
A7A4 ; NFKC_CF; A7A5 # L& LATIN CAPITAL LETTER N WITH OBLIQUE STROKE
A7A6 ; NFKC_CF; A7A7 # L& LATIN CAPITAL LETTER R WITH OBLIQUE STROKE
A7A8 ; NFKC_CF; A7A9 # L& LATIN CAPITAL LETTER S WITH OBLIQUE STROKE
+A7AA ; NFKC_CF; 0266 # L& LATIN CAPITAL LETTER H WITH HOOK
+A7F8 ; NFKC_CF; 0127 # Lm MODIFIER LETTER CAPITAL H WITH STROKE
+A7F9 ; NFKC_CF; 0153 # Lm MODIFIER LETTER SMALL LIGATURE OE
F900 ; NFKC_CF; 8C48 # Lo CJK COMPATIBILITY IDEOGRAPH-F900
F901 ; NFKC_CF; 66F4 # Lo CJK COMPATIBILITY IDEOGRAPH-F901
F902 ; NFKC_CF; 8ECA # Lo CJK COMPATIBILITY IDEOGRAPH-F902
@@ -5418,6 +5497,8 @@
FA2B ; NFKC_CF; 98FC # Lo CJK COMPATIBILITY IDEOGRAPH-FA2B
FA2C ; NFKC_CF; 9928 # Lo CJK COMPATIBILITY IDEOGRAPH-FA2C
FA2D ; NFKC_CF; 9DB4 # Lo CJK COMPATIBILITY IDEOGRAPH-FA2D
+FA2E ; NFKC_CF; 90DE # Lo CJK COMPATIBILITY IDEOGRAPH-FA2E
+FA2F ; NFKC_CF; 96B7 # Lo CJK COMPATIBILITY IDEOGRAPH-FA2F
FA30 ; NFKC_CF; 4FAE # Lo CJK COMPATIBILITY IDEOGRAPH-FA30
FA31 ; NFKC_CF; 50E7 # Lo CJK COMPATIBILITY IDEOGRAPH-FA31
FA32 ; NFKC_CF; 514D # Lo CJK COMPATIBILITY IDEOGRAPH-FA32
@@ -7507,6 +7588,147 @@
1D7FD ; NFKC_CF; 0037 # Nd MATHEMATICAL MONOSPACE DIGIT SEVEN
1D7FE ; NFKC_CF; 0038 # Nd MATHEMATICAL MONOSPACE DIGIT EIGHT
1D7FF ; NFKC_CF; 0039 # Nd MATHEMATICAL MONOSPACE DIGIT NINE
+1EE00 ; NFKC_CF; 0627 # Lo ARABIC MATHEMATICAL ALEF
+1EE01 ; NFKC_CF; 0628 # Lo ARABIC MATHEMATICAL BEH
+1EE02 ; NFKC_CF; 062C # Lo ARABIC MATHEMATICAL JEEM
+1EE03 ; NFKC_CF; 062F # Lo ARABIC MATHEMATICAL DAL
+1EE05 ; NFKC_CF; 0648 # Lo ARABIC MATHEMATICAL WAW
+1EE06 ; NFKC_CF; 0632 # Lo ARABIC MATHEMATICAL ZAIN
+1EE07 ; NFKC_CF; 062D # Lo ARABIC MATHEMATICAL HAH
+1EE08 ; NFKC_CF; 0637 # Lo ARABIC MATHEMATICAL TAH
+1EE09 ; NFKC_CF; 064A # Lo ARABIC MATHEMATICAL YEH
+1EE0A ; NFKC_CF; 0643 # Lo ARABIC MATHEMATICAL KAF
+1EE0B ; NFKC_CF; 0644 # Lo ARABIC MATHEMATICAL LAM
+1EE0C ; NFKC_CF; 0645 # Lo ARABIC MATHEMATICAL MEEM
+1EE0D ; NFKC_CF; 0646 # Lo ARABIC MATHEMATICAL NOON
+1EE0E ; NFKC_CF; 0633 # Lo ARABIC MATHEMATICAL SEEN
+1EE0F ; NFKC_CF; 0639 # Lo ARABIC MATHEMATICAL AIN
+1EE10 ; NFKC_CF; 0641 # Lo ARABIC MATHEMATICAL FEH
+1EE11 ; NFKC_CF; 0635 # Lo ARABIC MATHEMATICAL SAD
+1EE12 ; NFKC_CF; 0642 # Lo ARABIC MATHEMATICAL QAF
+1EE13 ; NFKC_CF; 0631 # Lo ARABIC MATHEMATICAL REH
+1EE14 ; NFKC_CF; 0634 # Lo ARABIC MATHEMATICAL SHEEN
+1EE15 ; NFKC_CF; 062A # Lo ARABIC MATHEMATICAL TEH
+1EE16 ; NFKC_CF; 062B # Lo ARABIC MATHEMATICAL THEH
+1EE17 ; NFKC_CF; 062E # Lo ARABIC MATHEMATICAL KHAH
+1EE18 ; NFKC_CF; 0630 # Lo ARABIC MATHEMATICAL THAL
+1EE19 ; NFKC_CF; 0636 # Lo ARABIC MATHEMATICAL DAD
+1EE1A ; NFKC_CF; 0638 # Lo ARABIC MATHEMATICAL ZAH
+1EE1B ; NFKC_CF; 063A # Lo ARABIC MATHEMATICAL GHAIN
+1EE1C ; NFKC_CF; 066E # Lo ARABIC MATHEMATICAL DOTLESS BEH
+1EE1D ; NFKC_CF; 06BA # Lo ARABIC MATHEMATICAL DOTLESS NOON
+1EE1E ; NFKC_CF; 06A1 # Lo ARABIC MATHEMATICAL DOTLESS FEH
+1EE1F ; NFKC_CF; 066F # Lo ARABIC MATHEMATICAL DOTLESS QAF
+1EE21 ; NFKC_CF; 0628 # Lo ARABIC MATHEMATICAL INITIAL BEH
+1EE22 ; NFKC_CF; 062C # Lo ARABIC MATHEMATICAL INITIAL JEEM
+1EE24 ; NFKC_CF; 0647 # Lo ARABIC MATHEMATICAL INITIAL HEH
+1EE27 ; NFKC_CF; 062D # Lo ARABIC MATHEMATICAL INITIAL HAH
+1EE29 ; NFKC_CF; 064A # Lo ARABIC MATHEMATICAL INITIAL YEH
+1EE2A ; NFKC_CF; 0643 # Lo ARABIC MATHEMATICAL INITIAL KAF
+1EE2B ; NFKC_CF; 0644 # Lo ARABIC MATHEMATICAL INITIAL LAM
+1EE2C ; NFKC_CF; 0645 # Lo ARABIC MATHEMATICAL INITIAL MEEM
+1EE2D ; NFKC_CF; 0646 # Lo ARABIC MATHEMATICAL INITIAL NOON
+1EE2E ; NFKC_CF; 0633 # Lo ARABIC MATHEMATICAL INITIAL SEEN
+1EE2F ; NFKC_CF; 0639 # Lo ARABIC MATHEMATICAL INITIAL AIN
+1EE30 ; NFKC_CF; 0641 # Lo ARABIC MATHEMATICAL INITIAL FEH
+1EE31 ; NFKC_CF; 0635 # Lo ARABIC MATHEMATICAL INITIAL SAD
+1EE32 ; NFKC_CF; 0642 # Lo ARABIC MATHEMATICAL INITIAL QAF
+1EE34 ; NFKC_CF; 0634 # Lo ARABIC MATHEMATICAL INITIAL SHEEN
+1EE35 ; NFKC_CF; 062A # Lo ARABIC MATHEMATICAL INITIAL TEH
+1EE36 ; NFKC_CF; 062B # Lo ARABIC MATHEMATICAL INITIAL THEH
+1EE37 ; NFKC_CF; 062E # Lo ARABIC MATHEMATICAL INITIAL KHAH
+1EE39 ; NFKC_CF; 0636 # Lo ARABIC MATHEMATICAL INITIAL DAD
+1EE3B ; NFKC_CF; 063A # Lo ARABIC MATHEMATICAL INITIAL GHAIN
+1EE42 ; NFKC_CF; 062C # Lo ARABIC MATHEMATICAL TAILED JEEM
+1EE47 ; NFKC_CF; 062D # Lo ARABIC MATHEMATICAL TAILED HAH
+1EE49 ; NFKC_CF; 064A # Lo ARABIC MATHEMATICAL TAILED YEH
+1EE4B ; NFKC_CF; 0644 # Lo ARABIC MATHEMATICAL TAILED LAM
+1EE4D ; NFKC_CF; 0646 # Lo ARABIC MATHEMATICAL TAILED NOON
+1EE4E ; NFKC_CF; 0633 # Lo ARABIC MATHEMATICAL TAILED SEEN
+1EE4F ; NFKC_CF; 0639 # Lo ARABIC MATHEMATICAL TAILED AIN
+1EE51 ; NFKC_CF; 0635 # Lo ARABIC MATHEMATICAL TAILED SAD
+1EE52 ; NFKC_CF; 0642 # Lo ARABIC MATHEMATICAL TAILED QAF
+1EE54 ; NFKC_CF; 0634 # Lo ARABIC MATHEMATICAL TAILED SHEEN
+1EE57 ; NFKC_CF; 062E # Lo ARABIC MATHEMATICAL TAILED KHAH
+1EE59 ; NFKC_CF; 0636 # Lo ARABIC MATHEMATICAL TAILED DAD
+1EE5B ; NFKC_CF; 063A # Lo ARABIC MATHEMATICAL TAILED GHAIN
+1EE5D ; NFKC_CF; 06BA # Lo ARABIC MATHEMATICAL TAILED DOTLESS NOON
+1EE5F ; NFKC_CF; 066F # Lo ARABIC MATHEMATICAL TAILED DOTLESS QAF
+1EE61 ; NFKC_CF; 0628 # Lo ARABIC MATHEMATICAL STRETCHED BEH
+1EE62 ; NFKC_CF; 062C # Lo ARABIC MATHEMATICAL STRETCHED JEEM
+1EE64 ; NFKC_CF; 0647 # Lo ARABIC MATHEMATICAL STRETCHED HEH
+1EE67 ; NFKC_CF; 062D # Lo ARABIC MATHEMATICAL STRETCHED HAH
+1EE68 ; NFKC_CF; 0637 # Lo ARABIC MATHEMATICAL STRETCHED TAH
+1EE69 ; NFKC_CF; 064A # Lo ARABIC MATHEMATICAL STRETCHED YEH
+1EE6A ; NFKC_CF; 0643 # Lo ARABIC MATHEMATICAL STRETCHED KAF
+1EE6C ; NFKC_CF; 0645 # Lo ARABIC MATHEMATICAL STRETCHED MEEM
+1EE6D ; NFKC_CF; 0646 # Lo ARABIC MATHEMATICAL STRETCHED NOON
+1EE6E ; NFKC_CF; 0633 # Lo ARABIC MATHEMATICAL STRETCHED SEEN
+1EE6F ; NFKC_CF; 0639 # Lo ARABIC MATHEMATICAL STRETCHED AIN
+1EE70 ; NFKC_CF; 0641 # Lo ARABIC MATHEMATICAL STRETCHED FEH
+1EE71 ; NFKC_CF; 0635 # Lo ARABIC MATHEMATICAL STRETCHED SAD
+1EE72 ; NFKC_CF; 0642 # Lo ARABIC MATHEMATICAL STRETCHED QAF
+1EE74 ; NFKC_CF; 0634 # Lo ARABIC MATHEMATICAL STRETCHED SHEEN
+1EE75 ; NFKC_CF; 062A # Lo ARABIC MATHEMATICAL STRETCHED TEH
+1EE76 ; NFKC_CF; 062B # Lo ARABIC MATHEMATICAL STRETCHED THEH
+1EE77 ; NFKC_CF; 062E # Lo ARABIC MATHEMATICAL STRETCHED KHAH
+1EE79 ; NFKC_CF; 0636 # Lo ARABIC MATHEMATICAL STRETCHED DAD
+1EE7A ; NFKC_CF; 0638 # Lo ARABIC MATHEMATICAL STRETCHED ZAH
+1EE7B ; NFKC_CF; 063A # Lo ARABIC MATHEMATICAL STRETCHED GHAIN
+1EE7C ; NFKC_CF; 066E # Lo ARABIC MATHEMATICAL STRETCHED DOTLESS BEH
+1EE7E ; NFKC_CF; 06A1 # Lo ARABIC MATHEMATICAL STRETCHED DOTLESS FEH
+1EE80 ; NFKC_CF; 0627 # Lo ARABIC MATHEMATICAL LOOPED ALEF
+1EE81 ; NFKC_CF; 0628 # Lo ARABIC MATHEMATICAL LOOPED BEH
+1EE82 ; NFKC_CF; 062C # Lo ARABIC MATHEMATICAL LOOPED JEEM
+1EE83 ; NFKC_CF; 062F # Lo ARABIC MATHEMATICAL LOOPED DAL
+1EE84 ; NFKC_CF; 0647 # Lo ARABIC MATHEMATICAL LOOPED HEH
+1EE85 ; NFKC_CF; 0648 # Lo ARABIC MATHEMATICAL LOOPED WAW
+1EE86 ; NFKC_CF; 0632 # Lo ARABIC MATHEMATICAL LOOPED ZAIN
+1EE87 ; NFKC_CF; 062D # Lo ARABIC MATHEMATICAL LOOPED HAH
+1EE88 ; NFKC_CF; 0637 # Lo ARABIC MATHEMATICAL LOOPED TAH
+1EE89 ; NFKC_CF; 064A # Lo ARABIC MATHEMATICAL LOOPED YEH
+1EE8B ; NFKC_CF; 0644 # Lo ARABIC MATHEMATICAL LOOPED LAM
+1EE8C ; NFKC_CF; 0645 # Lo ARABIC MATHEMATICAL LOOPED MEEM
+1EE8D ; NFKC_CF; 0646 # Lo ARABIC MATHEMATICAL LOOPED NOON
+1EE8E ; NFKC_CF; 0633 # Lo ARABIC MATHEMATICAL LOOPED SEEN
+1EE8F ; NFKC_CF; 0639 # Lo ARABIC MATHEMATICAL LOOPED AIN
+1EE90 ; NFKC_CF; 0641 # Lo ARABIC MATHEMATICAL LOOPED FEH
+1EE91 ; NFKC_CF; 0635 # Lo ARABIC MATHEMATICAL LOOPED SAD
+1EE92 ; NFKC_CF; 0642 # Lo ARABIC MATHEMATICAL LOOPED QAF
+1EE93 ; NFKC_CF; 0631 # Lo ARABIC MATHEMATICAL LOOPED REH
+1EE94 ; NFKC_CF; 0634 # Lo ARABIC MATHEMATICAL LOOPED SHEEN
+1EE95 ; NFKC_CF; 062A # Lo ARABIC MATHEMATICAL LOOPED TEH
+1EE96 ; NFKC_CF; 062B # Lo ARABIC MATHEMATICAL LOOPED THEH
+1EE97 ; NFKC_CF; 062E # Lo ARABIC MATHEMATICAL LOOPED KHAH
+1EE98 ; NFKC_CF; 0630 # Lo ARABIC MATHEMATICAL LOOPED THAL
+1EE99 ; NFKC_CF; 0636 # Lo ARABIC MATHEMATICAL LOOPED DAD
+1EE9A ; NFKC_CF; 0638 # Lo ARABIC MATHEMATICAL LOOPED ZAH
+1EE9B ; NFKC_CF; 063A # Lo ARABIC MATHEMATICAL LOOPED GHAIN
+1EEA1 ; NFKC_CF; 0628 # Lo ARABIC MATHEMATICAL DOUBLE-STRUCK BEH
+1EEA2 ; NFKC_CF; 062C # Lo ARABIC MATHEMATICAL DOUBLE-STRUCK JEEM
+1EEA3 ; NFKC_CF; 062F # Lo ARABIC MATHEMATICAL DOUBLE-STRUCK DAL
+1EEA5 ; NFKC_CF; 0648 # Lo ARABIC MATHEMATICAL DOUBLE-STRUCK WAW
+1EEA6 ; NFKC_CF; 0632 # Lo ARABIC MATHEMATICAL DOUBLE-STRUCK ZAIN
+1EEA7 ; NFKC_CF; 062D # Lo ARABIC MATHEMATICAL DOUBLE-STRUCK HAH
+1EEA8 ; NFKC_CF; 0637 # Lo ARABIC MATHEMATICAL DOUBLE-STRUCK TAH
+1EEA9 ; NFKC_CF; 064A # Lo ARABIC MATHEMATICAL DOUBLE-STRUCK YEH
+1EEAB ; NFKC_CF; 0644 # Lo ARABIC MATHEMATICAL DOUBLE-STRUCK LAM
+1EEAC ; NFKC_CF; 0645 # Lo ARABIC MATHEMATICAL DOUBLE-STRUCK MEEM
+1EEAD ; NFKC_CF; 0646 # Lo ARABIC MATHEMATICAL DOUBLE-STRUCK NOON
+1EEAE ; NFKC_CF; 0633 # Lo ARABIC MATHEMATICAL DOUBLE-STRUCK SEEN
+1EEAF ; NFKC_CF; 0639 # Lo ARABIC MATHEMATICAL DOUBLE-STRUCK AIN
+1EEB0 ; NFKC_CF; 0641 # Lo ARABIC MATHEMATICAL DOUBLE-STRUCK FEH
+1EEB1 ; NFKC_CF; 0635 # Lo ARABIC MATHEMATICAL DOUBLE-STRUCK SAD
+1EEB2 ; NFKC_CF; 0642 # Lo ARABIC MATHEMATICAL DOUBLE-STRUCK QAF
+1EEB3 ; NFKC_CF; 0631 # Lo ARABIC MATHEMATICAL DOUBLE-STRUCK REH
+1EEB4 ; NFKC_CF; 0634 # Lo ARABIC MATHEMATICAL DOUBLE-STRUCK SHEEN
+1EEB5 ; NFKC_CF; 062A # Lo ARABIC MATHEMATICAL DOUBLE-STRUCK TEH
+1EEB6 ; NFKC_CF; 062B # Lo ARABIC MATHEMATICAL DOUBLE-STRUCK THEH
+1EEB7 ; NFKC_CF; 062E # Lo ARABIC MATHEMATICAL DOUBLE-STRUCK KHAH
+1EEB8 ; NFKC_CF; 0630 # Lo ARABIC MATHEMATICAL DOUBLE-STRUCK THAL
+1EEB9 ; NFKC_CF; 0636 # Lo ARABIC MATHEMATICAL DOUBLE-STRUCK DAD
+1EEBA ; NFKC_CF; 0638 # Lo ARABIC MATHEMATICAL DOUBLE-STRUCK ZAH
+1EEBB ; NFKC_CF; 063A # Lo ARABIC MATHEMATICAL DOUBLE-STRUCK GHAIN
1F100 ; NFKC_CF; 0030 002E # No DIGIT ZERO FULL STOP
1F101 ; NFKC_CF; 0030 002C # No DIGIT ZERO COMMA
1F102 ; NFKC_CF; 0031 002C # No DIGIT ONE COMMA
@@ -7581,6 +7803,8 @@
1F14D ; NFKC_CF; 0073 0073 # So SQUARED SS
1F14E ; NFKC_CF; 0070 0070 0076 # So SQUARED PPV
1F14F ; NFKC_CF; 0077 0063 # So SQUARED WC
+1F16A ; NFKC_CF; 006D 0063 # So RAISED MC SIGN
+1F16B ; NFKC_CF; 006D 0064 # So RAISED MD SIGN
1F190 ; NFKC_CF; 0064 006A # So SQUARE DJ
1F200 ; NFKC_CF; 307B 304B # So SQUARE HIRAGANA HOKA
1F201 ; NFKC_CF; 30B3 30B3 # So SQUARED KATAKANA KOKO
@@ -8179,7 +8403,7 @@
E0100..E01EF ; NFKC_CF; # Mn [240] VARIATION SELECTOR-17..VARIATION SELECTOR-256
E01F0..E0FFF ; NFKC_CF; # Cn [3600] <reserved-E01F0>..<reserved-E0FFF>
-# Total code points: 9792
+# Total code points: 9944
# ================================================
@@ -8190,7 +8414,7 @@
0041..005A ; Changes_When_NFKC_Casefolded # L& [26] LATIN CAPITAL LETTER A..LATIN CAPITAL LETTER Z
00A0 ; Changes_When_NFKC_Casefolded # Zs NO-BREAK SPACE
00A8 ; Changes_When_NFKC_Casefolded # Sk DIAERESIS
-00AA ; Changes_When_NFKC_Casefolded # L& FEMININE ORDINAL INDICATOR
+00AA ; Changes_When_NFKC_Casefolded # Lo FEMININE ORDINAL INDICATOR
00AD ; Changes_When_NFKC_Casefolded # Cf SOFT HYPHEN
00AF ; Changes_When_NFKC_Casefolded # Sk MACRON
00B2..00B3 ; Changes_When_NFKC_Casefolded # No [2] SUPERSCRIPT TWO..SUPERSCRIPT THREE
@@ -8198,7 +8422,7 @@
00B5 ; Changes_When_NFKC_Casefolded # L& MICRO SIGN
00B8 ; Changes_When_NFKC_Casefolded # Sk CEDILLA
00B9 ; Changes_When_NFKC_Casefolded # No SUPERSCRIPT ONE
-00BA ; Changes_When_NFKC_Casefolded # L& MASCULINE ORDINAL INDICATOR
+00BA ; Changes_When_NFKC_Casefolded # Lo MASCULINE ORDINAL INDICATOR
00BC..00BE ; Changes_When_NFKC_Casefolded # No [3] VULGAR FRACTION ONE QUARTER..VULGAR FRACTION THREE QUARTERS
00C0..00D6 ; Changes_When_NFKC_Casefolded # L& [23] LATIN CAPITAL LETTER A WITH GRAVE..LATIN CAPITAL LETTER O WITH DIAERESIS
00D8..00DF ; Changes_When_NFKC_Casefolded # L& [8] LATIN CAPITAL LETTER O WITH STROKE..LATIN SMALL LETTER SHARP S
@@ -8503,15 +8727,16 @@
0FAC ; Changes_When_NFKC_Casefolded # Mn TIBETAN SUBJOINED LETTER DZHA
0FB9 ; Changes_When_NFKC_Casefolded # Mn TIBETAN SUBJOINED LETTER KSSA
10A0..10C5 ; Changes_When_NFKC_Casefolded # L& [38] GEORGIAN CAPITAL LETTER AN..GEORGIAN CAPITAL LETTER HOE
+10C7 ; Changes_When_NFKC_Casefolded # L& GEORGIAN CAPITAL LETTER YN
+10CD ; Changes_When_NFKC_Casefolded # L& GEORGIAN CAPITAL LETTER AEN
10FC ; Changes_When_NFKC_Casefolded # Lm MODIFIER LETTER GEORGIAN NAR
115F..1160 ; Changes_When_NFKC_Casefolded # Lo [2] HANGUL CHOSEONG FILLER..HANGUL JUNGSEONG FILLER
-17B4..17B5 ; Changes_When_NFKC_Casefolded # Cf [2] KHMER VOWEL INHERENT AQ..KHMER VOWEL INHERENT AA
+17B4..17B5 ; Changes_When_NFKC_Casefolded # Mn [2] KHMER VOWEL INHERENT AQ..KHMER VOWEL INHERENT AA
180B..180D ; Changes_When_NFKC_Casefolded # Mn [3] MONGOLIAN FREE VARIATION SELECTOR ONE..MONGOLIAN FREE VARIATION SELECTOR THREE
1D2C..1D2E ; Changes_When_NFKC_Casefolded # Lm [3] MODIFIER LETTER CAPITAL A..MODIFIER LETTER CAPITAL B
1D30..1D3A ; Changes_When_NFKC_Casefolded # Lm [11] MODIFIER LETTER CAPITAL D..MODIFIER LETTER CAPITAL N
1D3C..1D4D ; Changes_When_NFKC_Casefolded # Lm [18] MODIFIER LETTER CAPITAL O..MODIFIER LETTER SMALL G
-1D4F..1D61 ; Changes_When_NFKC_Casefolded # Lm [19] MODIFIER LETTER SMALL K..MODIFIER LETTER SMALL CHI
-1D62..1D6A ; Changes_When_NFKC_Casefolded # L& [9] LATIN SUBSCRIPT SMALL LETTER I..GREEK SUBSCRIPT SMALL LETTER CHI
+1D4F..1D6A ; Changes_When_NFKC_Casefolded # Lm [28] MODIFIER LETTER SMALL K..GREEK SUBSCRIPT SMALL LETTER CHI
1D78 ; Changes_When_NFKC_Casefolded # Lm MODIFIER LETTER CYRILLIC EN
1D9B..1DBF ; Changes_When_NFKC_Casefolded # Lm [37] MODIFIER LETTER SMALL TURNED ALPHA..MODIFIER LETTER SMALL THETA
1E00 ; Changes_When_NFKC_Casefolded # L& LATIN CAPITAL LETTER A WITH RING BELOW
@@ -8749,8 +8974,7 @@
2C6D..2C70 ; Changes_When_NFKC_Casefolded # L& [4] LATIN CAPITAL LETTER ALPHA..LATIN CAPITAL LETTER TURNED ALPHA
2C72 ; Changes_When_NFKC_Casefolded # L& LATIN CAPITAL LETTER W WITH HOOK
2C75 ; Changes_When_NFKC_Casefolded # L& LATIN CAPITAL LETTER HALF H
-2C7C ; Changes_When_NFKC_Casefolded # L& LATIN SUBSCRIPT SMALL LETTER J
-2C7D ; Changes_When_NFKC_Casefolded # Lm MODIFIER LETTER CAPITAL V
+2C7C..2C7D ; Changes_When_NFKC_Casefolded # Lm [2] LATIN SUBSCRIPT SMALL LETTER J..MODIFIER LETTER CAPITAL V
2C7E..2C80 ; Changes_When_NFKC_Casefolded # L& [3] LATIN CAPITAL LETTER S WITH SWASH TAIL..COPTIC CAPITAL LETTER ALFA
2C82 ; Changes_When_NFKC_Casefolded # L& COPTIC CAPITAL LETTER VIDA
2C84 ; Changes_When_NFKC_Casefolded # L& COPTIC CAPITAL LETTER GAMMA
@@ -8803,6 +9027,7 @@
2CE2 ; Changes_When_NFKC_Casefolded # L& COPTIC CAPITAL LETTER OLD NUBIAN WAU
2CEB ; Changes_When_NFKC_Casefolded # L& COPTIC CAPITAL LETTER CRYPTOGRAMMIC SHEI
2CED ; Changes_When_NFKC_Casefolded # L& COPTIC CAPITAL LETTER CRYPTOGRAMMIC GANGIA
+2CF2 ; Changes_When_NFKC_Casefolded # L& COPTIC CAPITAL LETTER BOHAIRIC KHEI
2D6F ; Changes_When_NFKC_Casefolded # Lm TIFINAGH MODIFIER LETTER LABIALIZATION MARK
2E9F ; Changes_When_NFKC_Casefolded # So CJK RADICAL MOTHER
2EF3 ; Changes_When_NFKC_Casefolded # So CJK RADICAL C-SIMPLIFIED TURTLE
@@ -8911,11 +9136,14 @@
A78B ; Changes_When_NFKC_Casefolded # L& LATIN CAPITAL LETTER SALTILLO
A78D ; Changes_When_NFKC_Casefolded # L& LATIN CAPITAL LETTER TURNED H
A790 ; Changes_When_NFKC_Casefolded # L& LATIN CAPITAL LETTER N WITH DESCENDER
+A792 ; Changes_When_NFKC_Casefolded # L& LATIN CAPITAL LETTER C WITH BAR
A7A0 ; Changes_When_NFKC_Casefolded # L& LATIN CAPITAL LETTER G WITH OBLIQUE STROKE
A7A2 ; Changes_When_NFKC_Casefolded # L& LATIN CAPITAL LETTER K WITH OBLIQUE STROKE
A7A4 ; Changes_When_NFKC_Casefolded # L& LATIN CAPITAL LETTER N WITH OBLIQUE STROKE
A7A6 ; Changes_When_NFKC_Casefolded # L& LATIN CAPITAL LETTER R WITH OBLIQUE STROKE
A7A8 ; Changes_When_NFKC_Casefolded # L& LATIN CAPITAL LETTER S WITH OBLIQUE STROKE
+A7AA ; Changes_When_NFKC_Casefolded # L& LATIN CAPITAL LETTER H WITH HOOK
+A7F8..A7F9 ; Changes_When_NFKC_Casefolded # Lm [2] MODIFIER LETTER CAPITAL H WITH STROKE..MODIFIER LETTER SMALL LIGATURE OE
F900..FA0D ; Changes_When_NFKC_Casefolded # Lo [270] CJK COMPATIBILITY IDEOGRAPH-F900..CJK COMPATIBILITY IDEOGRAPH-FA0D
FA10 ; Changes_When_NFKC_Casefolded # Lo CJK COMPATIBILITY IDEOGRAPH-FA10
FA12 ; Changes_When_NFKC_Casefolded # Lo CJK COMPATIBILITY IDEOGRAPH-FA12
@@ -8923,8 +9151,7 @@
FA20 ; Changes_When_NFKC_Casefolded # Lo CJK COMPATIBILITY IDEOGRAPH-FA20
FA22 ; Changes_When_NFKC_Casefolded # Lo CJK COMPATIBILITY IDEOGRAPH-FA22
FA25..FA26 ; Changes_When_NFKC_Casefolded # Lo [2] CJK COMPATIBILITY IDEOGRAPH-FA25..CJK COMPATIBILITY IDEOGRAPH-FA26
-FA2A..FA2D ; Changes_When_NFKC_Casefolded # Lo [4] CJK COMPATIBILITY IDEOGRAPH-FA2A..CJK COMPATIBILITY IDEOGRAPH-FA2D
-FA30..FA6D ; Changes_When_NFKC_Casefolded # Lo [62] CJK COMPATIBILITY IDEOGRAPH-FA30..CJK COMPATIBILITY IDEOGRAPH-FA6D
+FA2A..FA6D ; Changes_When_NFKC_Casefolded # Lo [68] CJK COMPATIBILITY IDEOGRAPH-FA2A..CJK COMPATIBILITY IDEOGRAPH-FA6D
FA70..FAD9 ; Changes_When_NFKC_Casefolded # Lo [106] CJK COMPATIBILITY IDEOGRAPH-FA70..CJK COMPATIBILITY IDEOGRAPH-FAD9
FB00..FB06 ; Changes_When_NFKC_Casefolded # L& [7] LATIN SMALL LIGATURE FF..LATIN SMALL LIGATURE ST
FB13..FB17 ; Changes_When_NFKC_Casefolded # L& [5] ARMENIAN SMALL LIGATURE MEN NOW..ARMENIAN SMALL LIGATURE MEN XEH
@@ -9085,9 +9312,43 @@
1D7C3 ; Changes_When_NFKC_Casefolded # Sm MATHEMATICAL SANS-SERIF BOLD ITALIC PARTIAL DIFFERENTIAL
1D7C4..1D7CB ; Changes_When_NFKC_Casefolded # L& [8] MATHEMATICAL SANS-SERIF BOLD ITALIC EPSILON SYMBOL..MATHEMATICAL BOLD SMALL DIGAMMA
1D7CE..1D7FF ; Changes_When_NFKC_Casefolded # Nd [50] MATHEMATICAL BOLD DIGIT ZERO..MATHEMATICAL MONOSPACE DIGIT NINE
+1EE00..1EE03 ; Changes_When_NFKC_Casefolded # Lo [4] ARABIC MATHEMATICAL ALEF..ARABIC MATHEMATICAL DAL
+1EE05..1EE1F ; Changes_When_NFKC_Casefolded # Lo [27] ARABIC MATHEMATICAL WAW..ARABIC MATHEMATICAL DOTLESS QAF
+1EE21..1EE22 ; Changes_When_NFKC_Casefolded # Lo [2] ARABIC MATHEMATICAL INITIAL BEH..ARABIC MATHEMATICAL INITIAL JEEM
+1EE24 ; Changes_When_NFKC_Casefolded # Lo ARABIC MATHEMATICAL INITIAL HEH
+1EE27 ; Changes_When_NFKC_Casefolded # Lo ARABIC MATHEMATICAL INITIAL HAH
+1EE29..1EE32 ; Changes_When_NFKC_Casefolded # Lo [10] ARABIC MATHEMATICAL INITIAL YEH..ARABIC MATHEMATICAL INITIAL QAF
+1EE34..1EE37 ; Changes_When_NFKC_Casefolded # Lo [4] ARABIC MATHEMATICAL INITIAL SHEEN..ARABIC MATHEMATICAL INITIAL KHAH
+1EE39 ; Changes_When_NFKC_Casefolded # Lo ARABIC MATHEMATICAL INITIAL DAD
+1EE3B ; Changes_When_NFKC_Casefolded # Lo ARABIC MATHEMATICAL INITIAL GHAIN
+1EE42 ; Changes_When_NFKC_Casefolded # Lo ARABIC MATHEMATICAL TAILED JEEM
+1EE47 ; Changes_When_NFKC_Casefolded # Lo ARABIC MATHEMATICAL TAILED HAH
+1EE49 ; Changes_When_NFKC_Casefolded # Lo ARABIC MATHEMATICAL TAILED YEH
+1EE4B ; Changes_When_NFKC_Casefolded # Lo ARABIC MATHEMATICAL TAILED LAM
+1EE4D..1EE4F ; Changes_When_NFKC_Casefolded # Lo [3] ARABIC MATHEMATICAL TAILED NOON..ARABIC MATHEMATICAL TAILED AIN
+1EE51..1EE52 ; Changes_When_NFKC_Casefolded # Lo [2] ARABIC MATHEMATICAL TAILED SAD..ARABIC MATHEMATICAL TAILED QAF
+1EE54 ; Changes_When_NFKC_Casefolded # Lo ARABIC MATHEMATICAL TAILED SHEEN
+1EE57 ; Changes_When_NFKC_Casefolded # Lo ARABIC MATHEMATICAL TAILED KHAH
+1EE59 ; Changes_When_NFKC_Casefolded # Lo ARABIC MATHEMATICAL TAILED DAD
+1EE5B ; Changes_When_NFKC_Casefolded # Lo ARABIC MATHEMATICAL TAILED GHAIN
+1EE5D ; Changes_When_NFKC_Casefolded # Lo ARABIC MATHEMATICAL TAILED DOTLESS NOON
+1EE5F ; Changes_When_NFKC_Casefolded # Lo ARABIC MATHEMATICAL TAILED DOTLESS QAF
+1EE61..1EE62 ; Changes_When_NFKC_Casefolded # Lo [2] ARABIC MATHEMATICAL STRETCHED BEH..ARABIC MATHEMATICAL STRETCHED JEEM
+1EE64 ; Changes_When_NFKC_Casefolded # Lo ARABIC MATHEMATICAL STRETCHED HEH
+1EE67..1EE6A ; Changes_When_NFKC_Casefolded # Lo [4] ARABIC MATHEMATICAL STRETCHED HAH..ARABIC MATHEMATICAL STRETCHED KAF
+1EE6C..1EE72 ; Changes_When_NFKC_Casefolded # Lo [7] ARABIC MATHEMATICAL STRETCHED MEEM..ARABIC MATHEMATICAL STRETCHED QAF
+1EE74..1EE77 ; Changes_When_NFKC_Casefolded # Lo [4] ARABIC MATHEMATICAL STRETCHED SHEEN..ARABIC MATHEMATICAL STRETCHED KHAH
+1EE79..1EE7C ; Changes_When_NFKC_Casefolded # Lo [4] ARABIC MATHEMATICAL STRETCHED DAD..ARABIC MATHEMATICAL STRETCHED DOTLESS BEH
+1EE7E ; Changes_When_NFKC_Casefolded # Lo ARABIC MATHEMATICAL STRETCHED DOTLESS FEH
+1EE80..1EE89 ; Changes_When_NFKC_Casefolded # Lo [10] ARABIC MATHEMATICAL LOOPED ALEF..ARABIC MATHEMATICAL LOOPED YEH
+1EE8B..1EE9B ; Changes_When_NFKC_Casefolded # Lo [17] ARABIC MATHEMATICAL LOOPED LAM..ARABIC MATHEMATICAL LOOPED GHAIN
+1EEA1..1EEA3 ; Changes_When_NFKC_Casefolded # Lo [3] ARABIC MATHEMATICAL DOUBLE-STRUCK BEH..ARABIC MATHEMATICAL DOUBLE-STRUCK DAL
+1EEA5..1EEA9 ; Changes_When_NFKC_Casefolded # Lo [5] ARABIC MATHEMATICAL DOUBLE-STRUCK WAW..ARABIC MATHEMATICAL DOUBLE-STRUCK YEH
+1EEAB..1EEBB ; Changes_When_NFKC_Casefolded # Lo [17] ARABIC MATHEMATICAL DOUBLE-STRUCK LAM..ARABIC MATHEMATICAL DOUBLE-STRUCK GHAIN
1F100..1F10A ; Changes_When_NFKC_Casefolded # No [11] DIGIT ZERO FULL STOP..DIGIT NINE COMMA
1F110..1F12E ; Changes_When_NFKC_Casefolded # So [31] PARENTHESIZED LATIN CAPITAL LETTER A..CIRCLED WZ
1F130..1F14F ; Changes_When_NFKC_Casefolded # So [32] SQUARED LATIN CAPITAL LETTER A..SQUARED WC
+1F16A..1F16B ; Changes_When_NFKC_Casefolded # So [2] RAISED MC SIGN..RAISED MD SIGN
1F190 ; Changes_When_NFKC_Casefolded # So SQUARE DJ
1F200..1F202 ; Changes_When_NFKC_Casefolded # So [3] SQUARE HIRAGANA HOKA..SQUARED KATAKANA SA
1F210..1F23A ; Changes_When_NFKC_Casefolded # So [43] SQUARED CJK UNIFIED IDEOGRAPH-624B..SQUARED CJK UNIFIED IDEOGRAPH-55B6
@@ -9102,6 +9363,6 @@
E0100..E01EF ; Changes_When_NFKC_Casefolded # Mn [240] VARIATION SELECTOR-17..VARIATION SELECTOR-256
E01F0..E0FFF ; Changes_When_NFKC_Casefolded # Cn [3600] <reserved-E01F0>..<reserved-E0FFF>
-# Total code points: 9792
+# Total code points: 9944
# EOF
Property changes on: trunk/contrib/perl/lib/unicore/DNormalizationProps.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/EastAsianWidth.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/EastAsianWidth.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/EastAsianWidth.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,5 +1,5 @@
-# EastAsianWidth-6.0.0.txt
-# Date: 2010-08-17, 12:17:00 PDT [KW]
+# EastAsianWidth-6.2.0.txt
+# Date: 2012-05-15, 18:30:00 GMT [KW]
#
# East Asian Width Properties
#
@@ -6,7 +6,7 @@
# This file is an informative contributory data file in the
# Unicode Character Database.
#
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
#
# The format is two fields separated by a semicolon.
@@ -1432,6 +1432,7 @@
0587;N # ARMENIAN SMALL LIGATURE ECH YIWN
0589;N # ARMENIAN FULL STOP
058A;N # ARMENIAN HYPHEN
+058F;N # ARMENIAN DRAM SIGN
0591;N # HEBREW ACCENT ETNAHTA
0592;N # HEBREW ACCENT SEGOL
0593;N # HEBREW ACCENT SHALSHELET
@@ -1523,6 +1524,7 @@
0601;N # ARABIC SIGN SANAH
0602;N # ARABIC FOOTNOTE MARKER
0603;N # ARABIC SIGN SAFHA
+0604;N # ARABIC SIGN SAMVAT
0606;N # ARABIC-INDIC CUBE ROOT
0607;N # ARABIC-INDIC FOURTH ROOT
0608;N # ARABIC RAY
@@ -2095,6 +2097,45 @@
085A;N # MANDAIC VOCALIZATION MARK
085B;N # MANDAIC GEMINATION MARK
085E;N # MANDAIC PUNCTUATION
+08A0;N # ARABIC LETTER BEH WITH SMALL V BELOW
+08A2;N # ARABIC LETTER JEEM WITH TWO DOTS ABOVE
+08A3;N # ARABIC LETTER TAH WITH TWO DOTS ABOVE
+08A4;N # ARABIC LETTER FEH WITH DOT BELOW AND THREE DOTS ABOVE
+08A5;N # ARABIC LETTER QAF WITH DOT BELOW
+08A6;N # ARABIC LETTER LAM WITH DOUBLE BAR
+08A7;N # ARABIC LETTER MEEM WITH THREE DOTS ABOVE
+08A8;N # ARABIC LETTER YEH WITH TWO DOTS BELOW AND HAMZA ABOVE
+08A9;N # ARABIC LETTER YEH WITH TWO DOTS BELOW AND DOT ABOVE
+08AA;N # ARABIC LETTER REH WITH LOOP
+08AB;N # ARABIC LETTER WAW WITH DOT WITHIN
+08AC;N # ARABIC LETTER ROHINGYA YEH
+08E4;N # ARABIC CURLY FATHA
+08E5;N # ARABIC CURLY DAMMA
+08E6;N # ARABIC CURLY KASRA
+08E7;N # ARABIC CURLY FATHATAN
+08E8;N # ARABIC CURLY DAMMATAN
+08E9;N # ARABIC CURLY KASRATAN
+08EA;N # ARABIC TONE ONE DOT ABOVE
+08EB;N # ARABIC TONE TWO DOTS ABOVE
+08EC;N # ARABIC TONE LOOP ABOVE
+08ED;N # ARABIC TONE ONE DOT BELOW
+08EE;N # ARABIC TONE TWO DOTS BELOW
+08EF;N # ARABIC TONE LOOP BELOW
+08F0;N # ARABIC OPEN FATHATAN
+08F1;N # ARABIC OPEN DAMMATAN
+08F2;N # ARABIC OPEN KASRATAN
+08F3;N # ARABIC SMALL HIGH WAW
+08F4;N # ARABIC FATHA WITH RING
+08F5;N # ARABIC FATHA WITH DOT ABOVE
+08F6;N # ARABIC KASRA WITH DOT BELOW
+08F7;N # ARABIC LEFT ARROWHEAD ABOVE
+08F8;N # ARABIC RIGHT ARROWHEAD ABOVE
+08F9;N # ARABIC LEFT ARROWHEAD BELOW
+08FA;N # ARABIC RIGHT ARROWHEAD BELOW
+08FB;N # ARABIC DOUBLE RIGHT ARROWHEAD ABOVE
+08FC;N # ARABIC DOUBLE RIGHT ARROWHEAD ABOVE WITH DOT
+08FD;N # ARABIC RIGHT ARROWHEAD ABOVE WITH DOT
+08FE;N # ARABIC DAMMA WITH DOT
0900;N # DEVANAGARI SIGN INVERTED CANDRABINDU
0901;N # DEVANAGARI SIGN CANDRABINDU
0902;N # DEVANAGARI SIGN ANUSVARA
@@ -2475,6 +2516,7 @@
0AED;N # GUJARATI DIGIT SEVEN
0AEE;N # GUJARATI DIGIT EIGHT
0AEF;N # GUJARATI DIGIT NINE
+0AF0;N # GUJARATI ABBREVIATION SIGN
0AF1;N # GUJARATI RUPEE SIGN
0B01;N # ORIYA SIGN CANDRABINDU
0B02;N # ORIYA SIGN ANUSVARA
@@ -3147,6 +3189,8 @@
0ED9;N # LAO DIGIT NINE
0EDC;N # LAO HO NO
0EDD;N # LAO HO MO
+0EDE;N # LAO LETTER KHMU GO
+0EDF;N # LAO LETTER KHMU NYO
0F00;N # TIBETAN SYLLABLE OM
0F01;N # TIBETAN MARK GTER YIG MGO TRUNCATED A
0F02;N # TIBETAN MARK GTER YIG MGO -UM RNAM BCAD MA
@@ -3556,6 +3600,8 @@
10C3;N # GEORGIAN CAPITAL LETTER WE
10C4;N # GEORGIAN CAPITAL LETTER HAR
10C5;N # GEORGIAN CAPITAL LETTER HOE
+10C7;N # GEORGIAN CAPITAL LETTER YN
+10CD;N # GEORGIAN CAPITAL LETTER AEN
10D0;N # GEORGIAN LETTER AN
10D1;N # GEORGIAN LETTER BAN
10D2;N # GEORGIAN LETTER GAN
@@ -3601,6 +3647,9 @@
10FA;N # GEORGIAN LETTER AIN
10FB;N # GEORGIAN PARAGRAPH SEPARATOR
10FC;N # MODIFIER LETTER GEORGIAN NAR
+10FD;N # GEORGIAN LETTER AEN
+10FE;N # GEORGIAN LETTER HARD SIGN
+10FF;N # GEORGIAN LETTER LABIAL SIGN
1100;W # HANGUL CHOSEONG KIYEOK
1101;W # HANGUL CHOSEONG SSANGKIYEOK
1102;W # HANGUL CHOSEONG NIEUN
@@ -3764,11 +3813,11 @@
11A0;N # HANGUL JUNGSEONG ARAEA-U
11A1;N # HANGUL JUNGSEONG ARAEA-I
11A2;N # HANGUL JUNGSEONG SSANGARAEA
-11A3;W # HANGUL JUNGSEONG A-EU
-11A4;W # HANGUL JUNGSEONG YA-U
-11A5;W # HANGUL JUNGSEONG YEO-YA
-11A6;W # HANGUL JUNGSEONG O-YA
-11A7;W # HANGUL JUNGSEONG O-YAE
+11A3;N # HANGUL JUNGSEONG A-EU
+11A4;N # HANGUL JUNGSEONG YA-U
+11A5;N # HANGUL JUNGSEONG YEO-YA
+11A6;N # HANGUL JUNGSEONG O-YA
+11A7;N # HANGUL JUNGSEONG O-YAE
11A8;N # HANGUL JONGSEONG KIYEOK
11A9;N # HANGUL JONGSEONG SSANGKIYEOK
11AA;N # HANGUL JONGSEONG KIYEOK-SIOS
@@ -3851,12 +3900,12 @@
11F7;N # HANGUL JONGSEONG HIEUH-MIEUM
11F8;N # HANGUL JONGSEONG HIEUH-PIEUP
11F9;N # HANGUL JONGSEONG YEORINHIEUH
-11FA;W # HANGUL JONGSEONG KIYEOK-NIEUN
-11FB;W # HANGUL JONGSEONG KIYEOK-PIEUP
-11FC;W # HANGUL JONGSEONG KIYEOK-CHIEUCH
-11FD;W # HANGUL JONGSEONG KIYEOK-KHIEUKH
-11FE;W # HANGUL JONGSEONG KIYEOK-HIEUH
-11FF;W # HANGUL JONGSEONG SSANGNIEUN
+11FA;N # HANGUL JONGSEONG KIYEOK-NIEUN
+11FB;N # HANGUL JONGSEONG KIYEOK-PIEUP
+11FC;N # HANGUL JONGSEONG KIYEOK-CHIEUCH
+11FD;N # HANGUL JONGSEONG KIYEOK-KHIEUKH
+11FE;N # HANGUL JONGSEONG KIYEOK-HIEUH
+11FF;N # HANGUL JONGSEONG SSANGNIEUN
1200;N # ETHIOPIC SYLLABLE HA
1201;N # ETHIOPIC SYLLABLE HU
1202;N # ETHIOPIC SYLLABLE HI
@@ -6034,6 +6083,9 @@
1BA8;N # SUNDANESE VOWEL SIGN PAMEPET
1BA9;N # SUNDANESE VOWEL SIGN PANEULEUNG
1BAA;N # SUNDANESE SIGN PAMAAEH
+1BAB;N # SUNDANESE SIGN VIRAMA
+1BAC;N # SUNDANESE CONSONANT SIGN PASANGAN MA
+1BAD;N # SUNDANESE CONSONANT SIGN PASANGAN WA
1BAE;N # SUNDANESE LETTER KHA
1BAF;N # SUNDANESE LETTER SYA
1BB0;N # SUNDANESE DIGIT ZERO
@@ -6046,6 +6098,12 @@
1BB7;N # SUNDANESE DIGIT SEVEN
1BB8;N # SUNDANESE DIGIT EIGHT
1BB9;N # SUNDANESE DIGIT NINE
+1BBA;N # SUNDANESE AVAGRAHA
+1BBB;N # SUNDANESE LETTER REU
+1BBC;N # SUNDANESE LETTER LEU
+1BBD;N # SUNDANESE LETTER BHA
+1BBE;N # SUNDANESE LETTER FINAL K
+1BBF;N # SUNDANESE LETTER FINAL M
1BC0;N # BATAK LETTER A
1BC1;N # BATAK LETTER SIMALUNGUN A
1BC2;N # BATAK LETTER HA
@@ -6224,6 +6282,14 @@
1C7D;N # OL CHIKI AHAD
1C7E;N # OL CHIKI PUNCTUATION MUCAAD
1C7F;N # OL CHIKI PUNCTUATION DOUBLE MUCAAD
+1CC0;N # SUNDANESE PUNCTUATION BINDU SURYA
+1CC1;N # SUNDANESE PUNCTUATION BINDU PANGLONG
+1CC2;N # SUNDANESE PUNCTUATION BINDU PURNAMA
+1CC3;N # SUNDANESE PUNCTUATION BINDU CAKRA
+1CC4;N # SUNDANESE PUNCTUATION BINDU LEU SATANGA
+1CC5;N # SUNDANESE PUNCTUATION BINDU KA SATANGA
+1CC6;N # SUNDANESE PUNCTUATION BINDU DA SATANGA
+1CC7;N # SUNDANESE PUNCTUATION BINDU BA SATANGA
1CD0;N # VEDIC TONE KARSHANA
1CD1;N # VEDIC TONE SHARA
1CD2;N # VEDIC TONE PRENKHA
@@ -6259,6 +6325,10 @@
1CF0;N # VEDIC SIGN RTHANG LONG ANUSVARA
1CF1;N # VEDIC SIGN ANUSVARA UBHAYATO MUKHA
1CF2;N # VEDIC SIGN ARDHAVISARGA
+1CF3;N # VEDIC SIGN ROTATED ARDHAVISARGA
+1CF4;N # VEDIC TONE CANDRA ABOVE
+1CF5;N # VEDIC SIGN JIHVAMULIYA
+1CF6;N # VEDIC SIGN UPADHMANIYA
1D00;N # LATIN LETTER SMALL CAPITAL A
1D01;N # LATIN LETTER SMALL CAPITAL AE
1D02;N # LATIN SMALL LETTER TURNED AE
@@ -7158,6 +7228,7 @@
20B7;N # SPESMILO SIGN
20B8;N # TENGE SIGN
20B9;N # INDIAN RUPEE SIGN
+20BA;N # TURKISH LIRA SIGN
20D0;N # COMBINING LEFT HARPOON ABOVE
20D1;N # COMBINING RIGHT HARPOON ABOVE
20D2;N # COMBINING LONG VERTICAL LINE OVERLAY
@@ -8865,7 +8936,9 @@
27C8;N # REVERSE SOLIDUS PRECEDING SUBSET
27C9;N # SUPERSET PRECEDING SOLIDUS
27CA;N # VERTICAL BAR WITH HORIZONTAL STROKE
+27CB;N # MATHEMATICAL RISING DIAGONAL
27CC;N # LONG DIVISION
+27CD;N # MATHEMATICAL FALLING DIAGONAL
27CE;N # SQUARED LOGICAL AND
27CF;N # SQUARED LOGICAL OR
27D0;N # WHITE DIAMOND WITH CENTRED DOT
@@ -10011,6 +10084,8 @@
2CEF;N # COPTIC COMBINING NI ABOVE
2CF0;N # COPTIC COMBINING SPIRITUS ASPER
2CF1;N # COPTIC COMBINING SPIRITUS LENIS
+2CF2;N # COPTIC CAPITAL LETTER BOHAIRIC KHEI
+2CF3;N # COPTIC SMALL LETTER BOHAIRIC KHEI
2CF9;N # COPTIC OLD NUBIAN FULL STOP
2CFA;N # COPTIC OLD NUBIAN DIRECT QUESTION MARK
2CFB;N # COPTIC OLD NUBIAN INDIRECT QUESTION MARK
@@ -10056,6 +10131,8 @@
2D23;N # GEORGIAN SMALL LETTER WE
2D24;N # GEORGIAN SMALL LETTER HAR
2D25;N # GEORGIAN SMALL LETTER HOE
+2D27;N # GEORGIAN SMALL LETTER YN
+2D2D;N # GEORGIAN SMALL LETTER AEN
2D30;N # TIFINAGH LETTER YA
2D31;N # TIFINAGH LETTER YAB
2D32;N # TIFINAGH LETTER YABH
@@ -10110,6 +10187,8 @@
2D63;N # TIFINAGH LETTER YAZ
2D64;N # TIFINAGH LETTER TAWELLEMET YAZ
2D65;N # TIFINAGH LETTER YAZZ
+2D66;N # TIFINAGH LETTER YE
+2D67;N # TIFINAGH LETTER YO
2D6F;N # TIFINAGH MODIFIER LETTER LABIALIZATION MARK
2D70;N # TIFINAGH SEPARATOR MARK
2D7F;N # TIFINAGH CONSONANT JOINER
@@ -10274,6 +10353,16 @@
2E2F;N # VERTICAL TILDE
2E30;N # RING POINT
2E31;N # WORD SEPARATOR MIDDLE DOT
+2E32;N # TURNED COMMA
+2E33;N # RAISED DOT
+2E34;N # RAISED COMMA
+2E35;N # TURNED SEMICOLON
+2E36;N # DAGGER WITH LEFT GUARD
+2E37;N # DAGGER WITH RIGHT GUARD
+2E38;N # TURNED DAGGER
+2E39;N # TOP HALF SECTION SIGN
+2E3A;N # TWO-EM DASH
+2E3B;N # THREE-EM DASH
2E80;W # CJK RADICAL REPEAT
2E81;W # CJK RADICAL CLIFF
2E82;W # CJK RADICAL SECOND ONE
@@ -11674,8 +11763,8 @@
4DFD;N # HEXAGRAM FOR SMALL PREPONDERANCE
4DFE;N # HEXAGRAM FOR AFTER COMPLETION
4DFF;N # HEXAGRAM FOR BEFORE COMPLETION
-4E00..9FCB;W # <CJK Ideograph, First>..<CJK Ideograph, Last>
-9FCC..9FFF;W # <reserved-9FCC>..<reserved-9FFF>
+4E00..9FCC;W # <CJK Ideograph, First>..<CJK Ideograph, Last>
+9FCD..9FFF;W # <reserved-9FCD>..<reserved-9FFF>
A000;W # YI SYLLABLE IT
A001;W # YI SYLLABLE IX
A002;W # YI SYLLABLE I
@@ -13296,6 +13385,14 @@
A671;N # COMBINING CYRILLIC HUNDRED MILLIONS SIGN
A672;N # COMBINING CYRILLIC THOUSAND MILLIONS SIGN
A673;N # SLAVONIC ASTERISK
+A674;N # COMBINING CYRILLIC LETTER UKRAINIAN IE
+A675;N # COMBINING CYRILLIC LETTER I
+A676;N # COMBINING CYRILLIC LETTER YI
+A677;N # COMBINING CYRILLIC LETTER U
+A678;N # COMBINING CYRILLIC LETTER HARD SIGN
+A679;N # COMBINING CYRILLIC LETTER YERU
+A67A;N # COMBINING CYRILLIC LETTER SOFT SIGN
+A67B;N # COMBINING CYRILLIC LETTER OMEGA
A67C;N # COMBINING CYRILLIC KAVYKA
A67D;N # COMBINING CYRILLIC PAYEROK
A67E;N # CYRILLIC KAVYKA
@@ -13324,6 +13421,7 @@
A695;N # CYRILLIC SMALL LETTER HWE
A696;N # CYRILLIC CAPITAL LETTER SHWE
A697;N # CYRILLIC SMALL LETTER SHWE
+A69F;N # COMBINING CYRILLIC LETTER IOTIFIED E
A6A0;N # BAMUM LETTER A
A6A1;N # BAMUM LETTER KA
A6A2;N # BAMUM LETTER U
@@ -13557,6 +13655,8 @@
A78E;N # LATIN SMALL LETTER L WITH RETROFLEX HOOK AND BELT
A790;N # LATIN CAPITAL LETTER N WITH DESCENDER
A791;N # LATIN SMALL LETTER N WITH DESCENDER
+A792;N # LATIN CAPITAL LETTER C WITH BAR
+A793;N # LATIN SMALL LETTER C WITH BAR
A7A0;N # LATIN CAPITAL LETTER G WITH OBLIQUE STROKE
A7A1;N # LATIN SMALL LETTER G WITH OBLIQUE STROKE
A7A2;N # LATIN CAPITAL LETTER K WITH OBLIQUE STROKE
@@ -13567,6 +13667,9 @@
A7A7;N # LATIN SMALL LETTER R WITH OBLIQUE STROKE
A7A8;N # LATIN CAPITAL LETTER S WITH OBLIQUE STROKE
A7A9;N # LATIN SMALL LETTER S WITH OBLIQUE STROKE
+A7AA;N # LATIN CAPITAL LETTER H WITH HOOK
+A7F8;N # MODIFIER LETTER CAPITAL H WITH STROKE
+A7F9;N # MODIFIER LETTER SMALL LIGATURE OE
A7FA;N # LATIN LETTER SMALL CAPITAL TURNED M
A7FB;N # LATIN EPIGRAPHIC LETTER REVERSED F
A7FC;N # LATIN EPIGRAPHIC LETTER REVERSED P
@@ -14180,6 +14283,29 @@
AADD;N # TAI VIET SYMBOL SAM
AADE;N # TAI VIET SYMBOL HO HOI
AADF;N # TAI VIET SYMBOL KOI KOI
+AAE0;N # MEETEI MAYEK LETTER E
+AAE1;N # MEETEI MAYEK LETTER O
+AAE2;N # MEETEI MAYEK LETTER CHA
+AAE3;N # MEETEI MAYEK LETTER NYA
+AAE4;N # MEETEI MAYEK LETTER TTA
+AAE5;N # MEETEI MAYEK LETTER TTHA
+AAE6;N # MEETEI MAYEK LETTER DDA
+AAE7;N # MEETEI MAYEK LETTER DDHA
+AAE8;N # MEETEI MAYEK LETTER NNA
+AAE9;N # MEETEI MAYEK LETTER SHA
+AAEA;N # MEETEI MAYEK LETTER SSA
+AAEB;N # MEETEI MAYEK VOWEL SIGN II
+AAEC;N # MEETEI MAYEK VOWEL SIGN UU
+AAED;N # MEETEI MAYEK VOWEL SIGN AAI
+AAEE;N # MEETEI MAYEK VOWEL SIGN AU
+AAEF;N # MEETEI MAYEK VOWEL SIGN AAU
+AAF0;N # MEETEI MAYEK CHEIKHAN
+AAF1;N # MEETEI MAYEK AHANG KHUDAM
+AAF2;N # MEETEI MAYEK ANJI
+AAF3;N # MEETEI MAYEK SYLLABLE REPETITION MARK
+AAF4;N # MEETEI MAYEK WORD REPETITION MARK
+AAF5;N # MEETEI MAYEK VOWEL SIGN VISARGA
+AAF6;N # MEETEI MAYEK VIRAMA
AB01;N # ETHIOPIC SYLLABLE TTHU
AB02;N # ETHIOPIC SYLLABLE TTHI
AB03;N # ETHIOPIC SYLLABLE TTHAA
@@ -14269,78 +14395,78 @@
ABF8;N # MEETEI MAYEK DIGIT EIGHT
ABF9;N # MEETEI MAYEK DIGIT NINE
AC00..D7A3;W # <Hangul Syllable, First>..<Hangul Syllable, Last>
-D7B0;W # HANGUL JUNGSEONG O-YEO
-D7B1;W # HANGUL JUNGSEONG O-O-I
-D7B2;W # HANGUL JUNGSEONG YO-A
-D7B3;W # HANGUL JUNGSEONG YO-AE
-D7B4;W # HANGUL JUNGSEONG YO-EO
-D7B5;W # HANGUL JUNGSEONG U-YEO
-D7B6;W # HANGUL JUNGSEONG U-I-I
-D7B7;W # HANGUL JUNGSEONG YU-AE
-D7B8;W # HANGUL JUNGSEONG YU-O
-D7B9;W # HANGUL JUNGSEONG EU-A
-D7BA;W # HANGUL JUNGSEONG EU-EO
-D7BB;W # HANGUL JUNGSEONG EU-E
-D7BC;W # HANGUL JUNGSEONG EU-O
-D7BD;W # HANGUL JUNGSEONG I-YA-O
-D7BE;W # HANGUL JUNGSEONG I-YAE
-D7BF;W # HANGUL JUNGSEONG I-YEO
-D7C0;W # HANGUL JUNGSEONG I-YE
-D7C1;W # HANGUL JUNGSEONG I-O-I
-D7C2;W # HANGUL JUNGSEONG I-YO
-D7C3;W # HANGUL JUNGSEONG I-YU
-D7C4;W # HANGUL JUNGSEONG I-I
-D7C5;W # HANGUL JUNGSEONG ARAEA-A
-D7C6;W # HANGUL JUNGSEONG ARAEA-E
-D7CB;W # HANGUL JONGSEONG NIEUN-RIEUL
-D7CC;W # HANGUL JONGSEONG NIEUN-CHIEUCH
-D7CD;W # HANGUL JONGSEONG SSANGTIKEUT
-D7CE;W # HANGUL JONGSEONG SSANGTIKEUT-PIEUP
-D7CF;W # HANGUL JONGSEONG TIKEUT-PIEUP
-D7D0;W # HANGUL JONGSEONG TIKEUT-SIOS
-D7D1;W # HANGUL JONGSEONG TIKEUT-SIOS-KIYEOK
-D7D2;W # HANGUL JONGSEONG TIKEUT-CIEUC
-D7D3;W # HANGUL JONGSEONG TIKEUT-CHIEUCH
-D7D4;W # HANGUL JONGSEONG TIKEUT-THIEUTH
-D7D5;W # HANGUL JONGSEONG RIEUL-SSANGKIYEOK
-D7D6;W # HANGUL JONGSEONG RIEUL-KIYEOK-HIEUH
-D7D7;W # HANGUL JONGSEONG SSANGRIEUL-KHIEUKH
-D7D8;W # HANGUL JONGSEONG RIEUL-MIEUM-HIEUH
-D7D9;W # HANGUL JONGSEONG RIEUL-PIEUP-TIKEUT
-D7DA;W # HANGUL JONGSEONG RIEUL-PIEUP-PHIEUPH
-D7DB;W # HANGUL JONGSEONG RIEUL-YESIEUNG
-D7DC;W # HANGUL JONGSEONG RIEUL-YEORINHIEUH-HIEUH
-D7DD;W # HANGUL JONGSEONG KAPYEOUNRIEUL
-D7DE;W # HANGUL JONGSEONG MIEUM-NIEUN
-D7DF;W # HANGUL JONGSEONG MIEUM-SSANGNIEUN
-D7E0;W # HANGUL JONGSEONG SSANGMIEUM
-D7E1;W # HANGUL JONGSEONG MIEUM-PIEUP-SIOS
-D7E2;W # HANGUL JONGSEONG MIEUM-CIEUC
-D7E3;W # HANGUL JONGSEONG PIEUP-TIKEUT
-D7E4;W # HANGUL JONGSEONG PIEUP-RIEUL-PHIEUPH
-D7E5;W # HANGUL JONGSEONG PIEUP-MIEUM
-D7E6;W # HANGUL JONGSEONG SSANGPIEUP
-D7E7;W # HANGUL JONGSEONG PIEUP-SIOS-TIKEUT
-D7E8;W # HANGUL JONGSEONG PIEUP-CIEUC
-D7E9;W # HANGUL JONGSEONG PIEUP-CHIEUCH
-D7EA;W # HANGUL JONGSEONG SIOS-MIEUM
-D7EB;W # HANGUL JONGSEONG SIOS-KAPYEOUNPIEUP
-D7EC;W # HANGUL JONGSEONG SSANGSIOS-KIYEOK
-D7ED;W # HANGUL JONGSEONG SSANGSIOS-TIKEUT
-D7EE;W # HANGUL JONGSEONG SIOS-PANSIOS
-D7EF;W # HANGUL JONGSEONG SIOS-CIEUC
-D7F0;W # HANGUL JONGSEONG SIOS-CHIEUCH
-D7F1;W # HANGUL JONGSEONG SIOS-THIEUTH
-D7F2;W # HANGUL JONGSEONG SIOS-HIEUH
-D7F3;W # HANGUL JONGSEONG PANSIOS-PIEUP
-D7F4;W # HANGUL JONGSEONG PANSIOS-KAPYEOUNPIEUP
-D7F5;W # HANGUL JONGSEONG YESIEUNG-MIEUM
-D7F6;W # HANGUL JONGSEONG YESIEUNG-HIEUH
-D7F7;W # HANGUL JONGSEONG CIEUC-PIEUP
-D7F8;W # HANGUL JONGSEONG CIEUC-SSANGPIEUP
-D7F9;W # HANGUL JONGSEONG SSANGCIEUC
-D7FA;W # HANGUL JONGSEONG PHIEUPH-SIOS
-D7FB;W # HANGUL JONGSEONG PHIEUPH-THIEUTH
+D7B0;N # HANGUL JUNGSEONG O-YEO
+D7B1;N # HANGUL JUNGSEONG O-O-I
+D7B2;N # HANGUL JUNGSEONG YO-A
+D7B3;N # HANGUL JUNGSEONG YO-AE
+D7B4;N # HANGUL JUNGSEONG YO-EO
+D7B5;N # HANGUL JUNGSEONG U-YEO
+D7B6;N # HANGUL JUNGSEONG U-I-I
+D7B7;N # HANGUL JUNGSEONG YU-AE
+D7B8;N # HANGUL JUNGSEONG YU-O
+D7B9;N # HANGUL JUNGSEONG EU-A
+D7BA;N # HANGUL JUNGSEONG EU-EO
+D7BB;N # HANGUL JUNGSEONG EU-E
+D7BC;N # HANGUL JUNGSEONG EU-O
+D7BD;N # HANGUL JUNGSEONG I-YA-O
+D7BE;N # HANGUL JUNGSEONG I-YAE
+D7BF;N # HANGUL JUNGSEONG I-YEO
+D7C0;N # HANGUL JUNGSEONG I-YE
+D7C1;N # HANGUL JUNGSEONG I-O-I
+D7C2;N # HANGUL JUNGSEONG I-YO
+D7C3;N # HANGUL JUNGSEONG I-YU
+D7C4;N # HANGUL JUNGSEONG I-I
+D7C5;N # HANGUL JUNGSEONG ARAEA-A
+D7C6;N # HANGUL JUNGSEONG ARAEA-E
+D7CB;N # HANGUL JONGSEONG NIEUN-RIEUL
+D7CC;N # HANGUL JONGSEONG NIEUN-CHIEUCH
+D7CD;N # HANGUL JONGSEONG SSANGTIKEUT
+D7CE;N # HANGUL JONGSEONG SSANGTIKEUT-PIEUP
+D7CF;N # HANGUL JONGSEONG TIKEUT-PIEUP
+D7D0;N # HANGUL JONGSEONG TIKEUT-SIOS
+D7D1;N # HANGUL JONGSEONG TIKEUT-SIOS-KIYEOK
+D7D2;N # HANGUL JONGSEONG TIKEUT-CIEUC
+D7D3;N # HANGUL JONGSEONG TIKEUT-CHIEUCH
+D7D4;N # HANGUL JONGSEONG TIKEUT-THIEUTH
+D7D5;N # HANGUL JONGSEONG RIEUL-SSANGKIYEOK
+D7D6;N # HANGUL JONGSEONG RIEUL-KIYEOK-HIEUH
+D7D7;N # HANGUL JONGSEONG SSANGRIEUL-KHIEUKH
+D7D8;N # HANGUL JONGSEONG RIEUL-MIEUM-HIEUH
+D7D9;N # HANGUL JONGSEONG RIEUL-PIEUP-TIKEUT
+D7DA;N # HANGUL JONGSEONG RIEUL-PIEUP-PHIEUPH
+D7DB;N # HANGUL JONGSEONG RIEUL-YESIEUNG
+D7DC;N # HANGUL JONGSEONG RIEUL-YEORINHIEUH-HIEUH
+D7DD;N # HANGUL JONGSEONG KAPYEOUNRIEUL
+D7DE;N # HANGUL JONGSEONG MIEUM-NIEUN
+D7DF;N # HANGUL JONGSEONG MIEUM-SSANGNIEUN
+D7E0;N # HANGUL JONGSEONG SSANGMIEUM
+D7E1;N # HANGUL JONGSEONG MIEUM-PIEUP-SIOS
+D7E2;N # HANGUL JONGSEONG MIEUM-CIEUC
+D7E3;N # HANGUL JONGSEONG PIEUP-TIKEUT
+D7E4;N # HANGUL JONGSEONG PIEUP-RIEUL-PHIEUPH
+D7E5;N # HANGUL JONGSEONG PIEUP-MIEUM
+D7E6;N # HANGUL JONGSEONG SSANGPIEUP
+D7E7;N # HANGUL JONGSEONG PIEUP-SIOS-TIKEUT
+D7E8;N # HANGUL JONGSEONG PIEUP-CIEUC
+D7E9;N # HANGUL JONGSEONG PIEUP-CHIEUCH
+D7EA;N # HANGUL JONGSEONG SIOS-MIEUM
+D7EB;N # HANGUL JONGSEONG SIOS-KAPYEOUNPIEUP
+D7EC;N # HANGUL JONGSEONG SSANGSIOS-KIYEOK
+D7ED;N # HANGUL JONGSEONG SSANGSIOS-TIKEUT
+D7EE;N # HANGUL JONGSEONG SIOS-PANSIOS
+D7EF;N # HANGUL JONGSEONG SIOS-CIEUC
+D7F0;N # HANGUL JONGSEONG SIOS-CHIEUCH
+D7F1;N # HANGUL JONGSEONG SIOS-THIEUTH
+D7F2;N # HANGUL JONGSEONG SIOS-HIEUH
+D7F3;N # HANGUL JONGSEONG PANSIOS-PIEUP
+D7F4;N # HANGUL JONGSEONG PANSIOS-KAPYEOUNPIEUP
+D7F5;N # HANGUL JONGSEONG YESIEUNG-MIEUM
+D7F6;N # HANGUL JONGSEONG YESIEUNG-HIEUH
+D7F7;N # HANGUL JONGSEONG CIEUC-PIEUP
+D7F8;N # HANGUL JONGSEONG CIEUC-SSANGPIEUP
+D7F9;N # HANGUL JONGSEONG SSANGCIEUC
+D7FA;N # HANGUL JONGSEONG PHIEUPH-SIOS
+D7FB;N # HANGUL JONGSEONG PHIEUPH-THIEUTH
D800..DB7F;N # <Non Private Use High Surrogate, First>..<Non Private Use High Surrogate, Last>
DB80..DBFF;N # <Private Use High Surrogate, First>..<Private Use High Surrogate, Last>
DC00..DFFF;N # <Low Surrogate, First>..<Low Surrogate, Last>
@@ -14647,7 +14773,8 @@
FA2B;W # CJK COMPATIBILITY IDEOGRAPH-FA2B
FA2C;W # CJK COMPATIBILITY IDEOGRAPH-FA2C
FA2D;W # CJK COMPATIBILITY IDEOGRAPH-FA2D
-FA2E..FA2F;W # <reserved-FA2E>..<reserved-FA2F>
+FA2E;W # CJK COMPATIBILITY IDEOGRAPH-FA2E
+FA2F;W # CJK COMPATIBILITY IDEOGRAPH-FA2F
FA30;W # CJK COMPATIBILITY IDEOGRAPH-FA30
FA31;W # CJK COMPATIBILITY IDEOGRAPH-FA31
FA32;W # CJK COMPATIBILITY IDEOGRAPH-FA32
@@ -16881,6 +17008,64 @@
10938;N # LYDIAN LETTER NN
10939;N # LYDIAN LETTER C
1093F;N # LYDIAN TRIANGULAR MARK
+10980;N # MEROITIC HIEROGLYPHIC LETTER A
+10981;N # MEROITIC HIEROGLYPHIC LETTER E
+10982;N # MEROITIC HIEROGLYPHIC LETTER I
+10983;N # MEROITIC HIEROGLYPHIC LETTER O
+10984;N # MEROITIC HIEROGLYPHIC LETTER YA
+10985;N # MEROITIC HIEROGLYPHIC LETTER WA
+10986;N # MEROITIC HIEROGLYPHIC LETTER BA
+10987;N # MEROITIC HIEROGLYPHIC LETTER BA-2
+10988;N # MEROITIC HIEROGLYPHIC LETTER PA
+10989;N # MEROITIC HIEROGLYPHIC LETTER MA
+1098A;N # MEROITIC HIEROGLYPHIC LETTER NA
+1098B;N # MEROITIC HIEROGLYPHIC LETTER NA-2
+1098C;N # MEROITIC HIEROGLYPHIC LETTER NE
+1098D;N # MEROITIC HIEROGLYPHIC LETTER NE-2
+1098E;N # MEROITIC HIEROGLYPHIC LETTER RA
+1098F;N # MEROITIC HIEROGLYPHIC LETTER RA-2
+10990;N # MEROITIC HIEROGLYPHIC LETTER LA
+10991;N # MEROITIC HIEROGLYPHIC LETTER KHA
+10992;N # MEROITIC HIEROGLYPHIC LETTER HHA
+10993;N # MEROITIC HIEROGLYPHIC LETTER SA
+10994;N # MEROITIC HIEROGLYPHIC LETTER SA-2
+10995;N # MEROITIC HIEROGLYPHIC LETTER SE
+10996;N # MEROITIC HIEROGLYPHIC LETTER KA
+10997;N # MEROITIC HIEROGLYPHIC LETTER QA
+10998;N # MEROITIC HIEROGLYPHIC LETTER TA
+10999;N # MEROITIC HIEROGLYPHIC LETTER TA-2
+1099A;N # MEROITIC HIEROGLYPHIC LETTER TE
+1099B;N # MEROITIC HIEROGLYPHIC LETTER TE-2
+1099C;N # MEROITIC HIEROGLYPHIC LETTER TO
+1099D;N # MEROITIC HIEROGLYPHIC LETTER DA
+1099E;N # MEROITIC HIEROGLYPHIC SYMBOL VIDJ
+1099F;N # MEROITIC HIEROGLYPHIC SYMBOL VIDJ-2
+109A0;N # MEROITIC CURSIVE LETTER A
+109A1;N # MEROITIC CURSIVE LETTER E
+109A2;N # MEROITIC CURSIVE LETTER I
+109A3;N # MEROITIC CURSIVE LETTER O
+109A4;N # MEROITIC CURSIVE LETTER YA
+109A5;N # MEROITIC CURSIVE LETTER WA
+109A6;N # MEROITIC CURSIVE LETTER BA
+109A7;N # MEROITIC CURSIVE LETTER PA
+109A8;N # MEROITIC CURSIVE LETTER MA
+109A9;N # MEROITIC CURSIVE LETTER NA
+109AA;N # MEROITIC CURSIVE LETTER NE
+109AB;N # MEROITIC CURSIVE LETTER RA
+109AC;N # MEROITIC CURSIVE LETTER LA
+109AD;N # MEROITIC CURSIVE LETTER KHA
+109AE;N # MEROITIC CURSIVE LETTER HHA
+109AF;N # MEROITIC CURSIVE LETTER SA
+109B0;N # MEROITIC CURSIVE LETTER ARCHAIC SA
+109B1;N # MEROITIC CURSIVE LETTER SE
+109B2;N # MEROITIC CURSIVE LETTER KA
+109B3;N # MEROITIC CURSIVE LETTER QA
+109B4;N # MEROITIC CURSIVE LETTER TA
+109B5;N # MEROITIC CURSIVE LETTER TE
+109B6;N # MEROITIC CURSIVE LETTER TO
+109B7;N # MEROITIC CURSIVE LETTER DA
+109BE;N # MEROITIC CURSIVE LOGOGRAM RMT
+109BF;N # MEROITIC CURSIVE LOGOGRAM IMN
10A00;N # KHAROSHTHI LETTER A
10A01;N # KHAROSHTHI VOWEL SIGN I
10A02;N # KHAROSHTHI VOWEL SIGN U
@@ -17374,6 +17559,257 @@
110BF;N # KAITHI DOUBLE SECTION MARK
110C0;N # KAITHI DANDA
110C1;N # KAITHI DOUBLE DANDA
+110D0;N # SORA SOMPENG LETTER SAH
+110D1;N # SORA SOMPENG LETTER TAH
+110D2;N # SORA SOMPENG LETTER BAH
+110D3;N # SORA SOMPENG LETTER CAH
+110D4;N # SORA SOMPENG LETTER DAH
+110D5;N # SORA SOMPENG LETTER GAH
+110D6;N # SORA SOMPENG LETTER MAH
+110D7;N # SORA SOMPENG LETTER NGAH
+110D8;N # SORA SOMPENG LETTER LAH
+110D9;N # SORA SOMPENG LETTER NAH
+110DA;N # SORA SOMPENG LETTER VAH
+110DB;N # SORA SOMPENG LETTER PAH
+110DC;N # SORA SOMPENG LETTER YAH
+110DD;N # SORA SOMPENG LETTER RAH
+110DE;N # SORA SOMPENG LETTER HAH
+110DF;N # SORA SOMPENG LETTER KAH
+110E0;N # SORA SOMPENG LETTER JAH
+110E1;N # SORA SOMPENG LETTER NYAH
+110E2;N # SORA SOMPENG LETTER AH
+110E3;N # SORA SOMPENG LETTER EEH
+110E4;N # SORA SOMPENG LETTER IH
+110E5;N # SORA SOMPENG LETTER UH
+110E6;N # SORA SOMPENG LETTER OH
+110E7;N # SORA SOMPENG LETTER EH
+110E8;N # SORA SOMPENG LETTER MAE
+110F0;N # SORA SOMPENG DIGIT ZERO
+110F1;N # SORA SOMPENG DIGIT ONE
+110F2;N # SORA SOMPENG DIGIT TWO
+110F3;N # SORA SOMPENG DIGIT THREE
+110F4;N # SORA SOMPENG DIGIT FOUR
+110F5;N # SORA SOMPENG DIGIT FIVE
+110F6;N # SORA SOMPENG DIGIT SIX
+110F7;N # SORA SOMPENG DIGIT SEVEN
+110F8;N # SORA SOMPENG DIGIT EIGHT
+110F9;N # SORA SOMPENG DIGIT NINE
+11100;N # CHAKMA SIGN CANDRABINDU
+11101;N # CHAKMA SIGN ANUSVARA
+11102;N # CHAKMA SIGN VISARGA
+11103;N # CHAKMA LETTER AA
+11104;N # CHAKMA LETTER I
+11105;N # CHAKMA LETTER U
+11106;N # CHAKMA LETTER E
+11107;N # CHAKMA LETTER KAA
+11108;N # CHAKMA LETTER KHAA
+11109;N # CHAKMA LETTER GAA
+1110A;N # CHAKMA LETTER GHAA
+1110B;N # CHAKMA LETTER NGAA
+1110C;N # CHAKMA LETTER CAA
+1110D;N # CHAKMA LETTER CHAA
+1110E;N # CHAKMA LETTER JAA
+1110F;N # CHAKMA LETTER JHAA
+11110;N # CHAKMA LETTER NYAA
+11111;N # CHAKMA LETTER TTAA
+11112;N # CHAKMA LETTER TTHAA
+11113;N # CHAKMA LETTER DDAA
+11114;N # CHAKMA LETTER DDHAA
+11115;N # CHAKMA LETTER NNAA
+11116;N # CHAKMA LETTER TAA
+11117;N # CHAKMA LETTER THAA
+11118;N # CHAKMA LETTER DAA
+11119;N # CHAKMA LETTER DHAA
+1111A;N # CHAKMA LETTER NAA
+1111B;N # CHAKMA LETTER PAA
+1111C;N # CHAKMA LETTER PHAA
+1111D;N # CHAKMA LETTER BAA
+1111E;N # CHAKMA LETTER BHAA
+1111F;N # CHAKMA LETTER MAA
+11120;N # CHAKMA LETTER YYAA
+11121;N # CHAKMA LETTER YAA
+11122;N # CHAKMA LETTER RAA
+11123;N # CHAKMA LETTER LAA
+11124;N # CHAKMA LETTER WAA
+11125;N # CHAKMA LETTER SAA
+11126;N # CHAKMA LETTER HAA
+11127;N # CHAKMA VOWEL SIGN A
+11128;N # CHAKMA VOWEL SIGN I
+11129;N # CHAKMA VOWEL SIGN II
+1112A;N # CHAKMA VOWEL SIGN U
+1112B;N # CHAKMA VOWEL SIGN UU
+1112C;N # CHAKMA VOWEL SIGN E
+1112D;N # CHAKMA VOWEL SIGN AI
+1112E;N # CHAKMA VOWEL SIGN O
+1112F;N # CHAKMA VOWEL SIGN AU
+11130;N # CHAKMA VOWEL SIGN OI
+11131;N # CHAKMA O MARK
+11132;N # CHAKMA AU MARK
+11133;N # CHAKMA VIRAMA
+11134;N # CHAKMA MAAYYAA
+11136;N # CHAKMA DIGIT ZERO
+11137;N # CHAKMA DIGIT ONE
+11138;N # CHAKMA DIGIT TWO
+11139;N # CHAKMA DIGIT THREE
+1113A;N # CHAKMA DIGIT FOUR
+1113B;N # CHAKMA DIGIT FIVE
+1113C;N # CHAKMA DIGIT SIX
+1113D;N # CHAKMA DIGIT SEVEN
+1113E;N # CHAKMA DIGIT EIGHT
+1113F;N # CHAKMA DIGIT NINE
+11140;N # CHAKMA SECTION MARK
+11141;N # CHAKMA DANDA
+11142;N # CHAKMA DOUBLE DANDA
+11143;N # CHAKMA QUESTION MARK
+11180;N # SHARADA SIGN CANDRABINDU
+11181;N # SHARADA SIGN ANUSVARA
+11182;N # SHARADA SIGN VISARGA
+11183;N # SHARADA LETTER A
+11184;N # SHARADA LETTER AA
+11185;N # SHARADA LETTER I
+11186;N # SHARADA LETTER II
+11187;N # SHARADA LETTER U
+11188;N # SHARADA LETTER UU
+11189;N # SHARADA LETTER VOCALIC R
+1118A;N # SHARADA LETTER VOCALIC RR
+1118B;N # SHARADA LETTER VOCALIC L
+1118C;N # SHARADA LETTER VOCALIC LL
+1118D;N # SHARADA LETTER E
+1118E;N # SHARADA LETTER AI
+1118F;N # SHARADA LETTER O
+11190;N # SHARADA LETTER AU
+11191;N # SHARADA LETTER KA
+11192;N # SHARADA LETTER KHA
+11193;N # SHARADA LETTER GA
+11194;N # SHARADA LETTER GHA
+11195;N # SHARADA LETTER NGA
+11196;N # SHARADA LETTER CA
+11197;N # SHARADA LETTER CHA
+11198;N # SHARADA LETTER JA
+11199;N # SHARADA LETTER JHA
+1119A;N # SHARADA LETTER NYA
+1119B;N # SHARADA LETTER TTA
+1119C;N # SHARADA LETTER TTHA
+1119D;N # SHARADA LETTER DDA
+1119E;N # SHARADA LETTER DDHA
+1119F;N # SHARADA LETTER NNA
+111A0;N # SHARADA LETTER TA
+111A1;N # SHARADA LETTER THA
+111A2;N # SHARADA LETTER DA
+111A3;N # SHARADA LETTER DHA
+111A4;N # SHARADA LETTER NA
+111A5;N # SHARADA LETTER PA
+111A6;N # SHARADA LETTER PHA
+111A7;N # SHARADA LETTER BA
+111A8;N # SHARADA LETTER BHA
+111A9;N # SHARADA LETTER MA
+111AA;N # SHARADA LETTER YA
+111AB;N # SHARADA LETTER RA
+111AC;N # SHARADA LETTER LA
+111AD;N # SHARADA LETTER LLA
+111AE;N # SHARADA LETTER VA
+111AF;N # SHARADA LETTER SHA
+111B0;N # SHARADA LETTER SSA
+111B1;N # SHARADA LETTER SA
+111B2;N # SHARADA LETTER HA
+111B3;N # SHARADA VOWEL SIGN AA
+111B4;N # SHARADA VOWEL SIGN I
+111B5;N # SHARADA VOWEL SIGN II
+111B6;N # SHARADA VOWEL SIGN U
+111B7;N # SHARADA VOWEL SIGN UU
+111B8;N # SHARADA VOWEL SIGN VOCALIC R
+111B9;N # SHARADA VOWEL SIGN VOCALIC RR
+111BA;N # SHARADA VOWEL SIGN VOCALIC L
+111BB;N # SHARADA VOWEL SIGN VOCALIC LL
+111BC;N # SHARADA VOWEL SIGN E
+111BD;N # SHARADA VOWEL SIGN AI
+111BE;N # SHARADA VOWEL SIGN O
+111BF;N # SHARADA VOWEL SIGN AU
+111C0;N # SHARADA SIGN VIRAMA
+111C1;N # SHARADA SIGN AVAGRAHA
+111C2;N # SHARADA SIGN JIHVAMULIYA
+111C3;N # SHARADA SIGN UPADHMANIYA
+111C4;N # SHARADA OM
+111C5;N # SHARADA DANDA
+111C6;N # SHARADA DOUBLE DANDA
+111C7;N # SHARADA ABBREVIATION SIGN
+111C8;N # SHARADA SEPARATOR
+111D0;N # SHARADA DIGIT ZERO
+111D1;N # SHARADA DIGIT ONE
+111D2;N # SHARADA DIGIT TWO
+111D3;N # SHARADA DIGIT THREE
+111D4;N # SHARADA DIGIT FOUR
+111D5;N # SHARADA DIGIT FIVE
+111D6;N # SHARADA DIGIT SIX
+111D7;N # SHARADA DIGIT SEVEN
+111D8;N # SHARADA DIGIT EIGHT
+111D9;N # SHARADA DIGIT NINE
+11680;N # TAKRI LETTER A
+11681;N # TAKRI LETTER AA
+11682;N # TAKRI LETTER I
+11683;N # TAKRI LETTER II
+11684;N # TAKRI LETTER U
+11685;N # TAKRI LETTER UU
+11686;N # TAKRI LETTER E
+11687;N # TAKRI LETTER AI
+11688;N # TAKRI LETTER O
+11689;N # TAKRI LETTER AU
+1168A;N # TAKRI LETTER KA
+1168B;N # TAKRI LETTER KHA
+1168C;N # TAKRI LETTER GA
+1168D;N # TAKRI LETTER GHA
+1168E;N # TAKRI LETTER NGA
+1168F;N # TAKRI LETTER CA
+11690;N # TAKRI LETTER CHA
+11691;N # TAKRI LETTER JA
+11692;N # TAKRI LETTER JHA
+11693;N # TAKRI LETTER NYA
+11694;N # TAKRI LETTER TTA
+11695;N # TAKRI LETTER TTHA
+11696;N # TAKRI LETTER DDA
+11697;N # TAKRI LETTER DDHA
+11698;N # TAKRI LETTER NNA
+11699;N # TAKRI LETTER TA
+1169A;N # TAKRI LETTER THA
+1169B;N # TAKRI LETTER DA
+1169C;N # TAKRI LETTER DHA
+1169D;N # TAKRI LETTER NA
+1169E;N # TAKRI LETTER PA
+1169F;N # TAKRI LETTER PHA
+116A0;N # TAKRI LETTER BA
+116A1;N # TAKRI LETTER BHA
+116A2;N # TAKRI LETTER MA
+116A3;N # TAKRI LETTER YA
+116A4;N # TAKRI LETTER RA
+116A5;N # TAKRI LETTER LA
+116A6;N # TAKRI LETTER VA
+116A7;N # TAKRI LETTER SHA
+116A8;N # TAKRI LETTER SA
+116A9;N # TAKRI LETTER HA
+116AA;N # TAKRI LETTER RRA
+116AB;N # TAKRI SIGN ANUSVARA
+116AC;N # TAKRI SIGN VISARGA
+116AD;N # TAKRI VOWEL SIGN AA
+116AE;N # TAKRI VOWEL SIGN I
+116AF;N # TAKRI VOWEL SIGN II
+116B0;N # TAKRI VOWEL SIGN U
+116B1;N # TAKRI VOWEL SIGN UU
+116B2;N # TAKRI VOWEL SIGN E
+116B3;N # TAKRI VOWEL SIGN AI
+116B4;N # TAKRI VOWEL SIGN O
+116B5;N # TAKRI VOWEL SIGN AU
+116B6;N # TAKRI SIGN VIRAMA
+116B7;N # TAKRI SIGN NUKTA
+116C0;N # TAKRI DIGIT ZERO
+116C1;N # TAKRI DIGIT ONE
+116C2;N # TAKRI DIGIT TWO
+116C3;N # TAKRI DIGIT THREE
+116C4;N # TAKRI DIGIT FOUR
+116C5;N # TAKRI DIGIT FIVE
+116C6;N # TAKRI DIGIT SIX
+116C7;N # TAKRI DIGIT SEVEN
+116C8;N # TAKRI DIGIT EIGHT
+116C9;N # TAKRI DIGIT NINE
12000;N # CUNEIFORM SIGN A
12001;N # CUNEIFORM SIGN A TIMES A
12002;N # CUNEIFORM SIGN A TIMES BAD
@@ -19996,6 +20432,139 @@
16A36;N # BAMUM LETTER PHASE-F KPA
16A37;N # BAMUM LETTER PHASE-F SAMBA
16A38;N # BAMUM LETTER PHASE-F VUEQ
+16F00;N # MIAO LETTER PA
+16F01;N # MIAO LETTER BA
+16F02;N # MIAO LETTER YI PA
+16F03;N # MIAO LETTER PLA
+16F04;N # MIAO LETTER MA
+16F05;N # MIAO LETTER MHA
+16F06;N # MIAO LETTER ARCHAIC MA
+16F07;N # MIAO LETTER FA
+16F08;N # MIAO LETTER VA
+16F09;N # MIAO LETTER VFA
+16F0A;N # MIAO LETTER TA
+16F0B;N # MIAO LETTER DA
+16F0C;N # MIAO LETTER YI TTA
+16F0D;N # MIAO LETTER YI TA
+16F0E;N # MIAO LETTER TTA
+16F0F;N # MIAO LETTER DDA
+16F10;N # MIAO LETTER NA
+16F11;N # MIAO LETTER NHA
+16F12;N # MIAO LETTER YI NNA
+16F13;N # MIAO LETTER ARCHAIC NA
+16F14;N # MIAO LETTER NNA
+16F15;N # MIAO LETTER NNHA
+16F16;N # MIAO LETTER LA
+16F17;N # MIAO LETTER LYA
+16F18;N # MIAO LETTER LHA
+16F19;N # MIAO LETTER LHYA
+16F1A;N # MIAO LETTER TLHA
+16F1B;N # MIAO LETTER DLHA
+16F1C;N # MIAO LETTER TLHYA
+16F1D;N # MIAO LETTER DLHYA
+16F1E;N # MIAO LETTER KA
+16F1F;N # MIAO LETTER GA
+16F20;N # MIAO LETTER YI KA
+16F21;N # MIAO LETTER QA
+16F22;N # MIAO LETTER QGA
+16F23;N # MIAO LETTER NGA
+16F24;N # MIAO LETTER NGHA
+16F25;N # MIAO LETTER ARCHAIC NGA
+16F26;N # MIAO LETTER HA
+16F27;N # MIAO LETTER XA
+16F28;N # MIAO LETTER GHA
+16F29;N # MIAO LETTER GHHA
+16F2A;N # MIAO LETTER TSSA
+16F2B;N # MIAO LETTER DZZA
+16F2C;N # MIAO LETTER NYA
+16F2D;N # MIAO LETTER NYHA
+16F2E;N # MIAO LETTER TSHA
+16F2F;N # MIAO LETTER DZHA
+16F30;N # MIAO LETTER YI TSHA
+16F31;N # MIAO LETTER YI DZHA
+16F32;N # MIAO LETTER REFORMED TSHA
+16F33;N # MIAO LETTER SHA
+16F34;N # MIAO LETTER SSA
+16F35;N # MIAO LETTER ZHA
+16F36;N # MIAO LETTER ZSHA
+16F37;N # MIAO LETTER TSA
+16F38;N # MIAO LETTER DZA
+16F39;N # MIAO LETTER YI TSA
+16F3A;N # MIAO LETTER SA
+16F3B;N # MIAO LETTER ZA
+16F3C;N # MIAO LETTER ZSA
+16F3D;N # MIAO LETTER ZZA
+16F3E;N # MIAO LETTER ZZSA
+16F3F;N # MIAO LETTER ARCHAIC ZZA
+16F40;N # MIAO LETTER ZZYA
+16F41;N # MIAO LETTER ZZSYA
+16F42;N # MIAO LETTER WA
+16F43;N # MIAO LETTER AH
+16F44;N # MIAO LETTER HHA
+16F50;N # MIAO LETTER NASALIZATION
+16F51;N # MIAO SIGN ASPIRATION
+16F52;N # MIAO SIGN REFORMED VOICING
+16F53;N # MIAO SIGN REFORMED ASPIRATION
+16F54;N # MIAO VOWEL SIGN A
+16F55;N # MIAO VOWEL SIGN AA
+16F56;N # MIAO VOWEL SIGN AHH
+16F57;N # MIAO VOWEL SIGN AN
+16F58;N # MIAO VOWEL SIGN ANG
+16F59;N # MIAO VOWEL SIGN O
+16F5A;N # MIAO VOWEL SIGN OO
+16F5B;N # MIAO VOWEL SIGN WO
+16F5C;N # MIAO VOWEL SIGN W
+16F5D;N # MIAO VOWEL SIGN E
+16F5E;N # MIAO VOWEL SIGN EN
+16F5F;N # MIAO VOWEL SIGN ENG
+16F60;N # MIAO VOWEL SIGN OEY
+16F61;N # MIAO VOWEL SIGN I
+16F62;N # MIAO VOWEL SIGN IA
+16F63;N # MIAO VOWEL SIGN IAN
+16F64;N # MIAO VOWEL SIGN IANG
+16F65;N # MIAO VOWEL SIGN IO
+16F66;N # MIAO VOWEL SIGN IE
+16F67;N # MIAO VOWEL SIGN II
+16F68;N # MIAO VOWEL SIGN IU
+16F69;N # MIAO VOWEL SIGN ING
+16F6A;N # MIAO VOWEL SIGN U
+16F6B;N # MIAO VOWEL SIGN UA
+16F6C;N # MIAO VOWEL SIGN UAN
+16F6D;N # MIAO VOWEL SIGN UANG
+16F6E;N # MIAO VOWEL SIGN UU
+16F6F;N # MIAO VOWEL SIGN UEI
+16F70;N # MIAO VOWEL SIGN UNG
+16F71;N # MIAO VOWEL SIGN Y
+16F72;N # MIAO VOWEL SIGN YI
+16F73;N # MIAO VOWEL SIGN AE
+16F74;N # MIAO VOWEL SIGN AEE
+16F75;N # MIAO VOWEL SIGN ERR
+16F76;N # MIAO VOWEL SIGN ROUNDED ERR
+16F77;N # MIAO VOWEL SIGN ER
+16F78;N # MIAO VOWEL SIGN ROUNDED ER
+16F79;N # MIAO VOWEL SIGN AI
+16F7A;N # MIAO VOWEL SIGN EI
+16F7B;N # MIAO VOWEL SIGN AU
+16F7C;N # MIAO VOWEL SIGN OU
+16F7D;N # MIAO VOWEL SIGN N
+16F7E;N # MIAO VOWEL SIGN NG
+16F8F;N # MIAO TONE RIGHT
+16F90;N # MIAO TONE TOP RIGHT
+16F91;N # MIAO TONE ABOVE
+16F92;N # MIAO TONE BELOW
+16F93;N # MIAO LETTER TONE-2
+16F94;N # MIAO LETTER TONE-3
+16F95;N # MIAO LETTER TONE-4
+16F96;N # MIAO LETTER TONE-5
+16F97;N # MIAO LETTER TONE-6
+16F98;N # MIAO LETTER TONE-7
+16F99;N # MIAO LETTER TONE-8
+16F9A;N # MIAO LETTER REFORMED TONE-1
+16F9B;N # MIAO LETTER REFORMED TONE-2
+16F9C;N # MIAO LETTER REFORMED TONE-4
+16F9D;N # MIAO LETTER REFORMED TONE-5
+16F9E;N # MIAO LETTER REFORMED TONE-6
+16F9F;N # MIAO LETTER REFORMED TONE-8
1B000;W # KATAKANA LETTER ARCHAIC E
1B001;W # HIRAGANA LETTER ARCHAIC YE
1D000;N # BYZANTINE MUSICAL SYMBOL PSILI
@@ -21635,6 +22204,149 @@
1D7FD;N # MATHEMATICAL MONOSPACE DIGIT SEVEN
1D7FE;N # MATHEMATICAL MONOSPACE DIGIT EIGHT
1D7FF;N # MATHEMATICAL MONOSPACE DIGIT NINE
+1EE00;N # ARABIC MATHEMATICAL ALEF
+1EE01;N # ARABIC MATHEMATICAL BEH
+1EE02;N # ARABIC MATHEMATICAL JEEM
+1EE03;N # ARABIC MATHEMATICAL DAL
+1EE05;N # ARABIC MATHEMATICAL WAW
+1EE06;N # ARABIC MATHEMATICAL ZAIN
+1EE07;N # ARABIC MATHEMATICAL HAH
+1EE08;N # ARABIC MATHEMATICAL TAH
+1EE09;N # ARABIC MATHEMATICAL YEH
+1EE0A;N # ARABIC MATHEMATICAL KAF
+1EE0B;N # ARABIC MATHEMATICAL LAM
+1EE0C;N # ARABIC MATHEMATICAL MEEM
+1EE0D;N # ARABIC MATHEMATICAL NOON
+1EE0E;N # ARABIC MATHEMATICAL SEEN
+1EE0F;N # ARABIC MATHEMATICAL AIN
+1EE10;N # ARABIC MATHEMATICAL FEH
+1EE11;N # ARABIC MATHEMATICAL SAD
+1EE12;N # ARABIC MATHEMATICAL QAF
+1EE13;N # ARABIC MATHEMATICAL REH
+1EE14;N # ARABIC MATHEMATICAL SHEEN
+1EE15;N # ARABIC MATHEMATICAL TEH
+1EE16;N # ARABIC MATHEMATICAL THEH
+1EE17;N # ARABIC MATHEMATICAL KHAH
+1EE18;N # ARABIC MATHEMATICAL THAL
+1EE19;N # ARABIC MATHEMATICAL DAD
+1EE1A;N # ARABIC MATHEMATICAL ZAH
+1EE1B;N # ARABIC MATHEMATICAL GHAIN
+1EE1C;N # ARABIC MATHEMATICAL DOTLESS BEH
+1EE1D;N # ARABIC MATHEMATICAL DOTLESS NOON
+1EE1E;N # ARABIC MATHEMATICAL DOTLESS FEH
+1EE1F;N # ARABIC MATHEMATICAL DOTLESS QAF
+1EE21;N # ARABIC MATHEMATICAL INITIAL BEH
+1EE22;N # ARABIC MATHEMATICAL INITIAL JEEM
+1EE24;N # ARABIC MATHEMATICAL INITIAL HEH
+1EE27;N # ARABIC MATHEMATICAL INITIAL HAH
+1EE29;N # ARABIC MATHEMATICAL INITIAL YEH
+1EE2A;N # ARABIC MATHEMATICAL INITIAL KAF
+1EE2B;N # ARABIC MATHEMATICAL INITIAL LAM
+1EE2C;N # ARABIC MATHEMATICAL INITIAL MEEM
+1EE2D;N # ARABIC MATHEMATICAL INITIAL NOON
+1EE2E;N # ARABIC MATHEMATICAL INITIAL SEEN
+1EE2F;N # ARABIC MATHEMATICAL INITIAL AIN
+1EE30;N # ARABIC MATHEMATICAL INITIAL FEH
+1EE31;N # ARABIC MATHEMATICAL INITIAL SAD
+1EE32;N # ARABIC MATHEMATICAL INITIAL QAF
+1EE34;N # ARABIC MATHEMATICAL INITIAL SHEEN
+1EE35;N # ARABIC MATHEMATICAL INITIAL TEH
+1EE36;N # ARABIC MATHEMATICAL INITIAL THEH
+1EE37;N # ARABIC MATHEMATICAL INITIAL KHAH
+1EE39;N # ARABIC MATHEMATICAL INITIAL DAD
+1EE3B;N # ARABIC MATHEMATICAL INITIAL GHAIN
+1EE42;N # ARABIC MATHEMATICAL TAILED JEEM
+1EE47;N # ARABIC MATHEMATICAL TAILED HAH
+1EE49;N # ARABIC MATHEMATICAL TAILED YEH
+1EE4B;N # ARABIC MATHEMATICAL TAILED LAM
+1EE4D;N # ARABIC MATHEMATICAL TAILED NOON
+1EE4E;N # ARABIC MATHEMATICAL TAILED SEEN
+1EE4F;N # ARABIC MATHEMATICAL TAILED AIN
+1EE51;N # ARABIC MATHEMATICAL TAILED SAD
+1EE52;N # ARABIC MATHEMATICAL TAILED QAF
+1EE54;N # ARABIC MATHEMATICAL TAILED SHEEN
+1EE57;N # ARABIC MATHEMATICAL TAILED KHAH
+1EE59;N # ARABIC MATHEMATICAL TAILED DAD
+1EE5B;N # ARABIC MATHEMATICAL TAILED GHAIN
+1EE5D;N # ARABIC MATHEMATICAL TAILED DOTLESS NOON
+1EE5F;N # ARABIC MATHEMATICAL TAILED DOTLESS QAF
+1EE61;N # ARABIC MATHEMATICAL STRETCHED BEH
+1EE62;N # ARABIC MATHEMATICAL STRETCHED JEEM
+1EE64;N # ARABIC MATHEMATICAL STRETCHED HEH
+1EE67;N # ARABIC MATHEMATICAL STRETCHED HAH
+1EE68;N # ARABIC MATHEMATICAL STRETCHED TAH
+1EE69;N # ARABIC MATHEMATICAL STRETCHED YEH
+1EE6A;N # ARABIC MATHEMATICAL STRETCHED KAF
+1EE6C;N # ARABIC MATHEMATICAL STRETCHED MEEM
+1EE6D;N # ARABIC MATHEMATICAL STRETCHED NOON
+1EE6E;N # ARABIC MATHEMATICAL STRETCHED SEEN
+1EE6F;N # ARABIC MATHEMATICAL STRETCHED AIN
+1EE70;N # ARABIC MATHEMATICAL STRETCHED FEH
+1EE71;N # ARABIC MATHEMATICAL STRETCHED SAD
+1EE72;N # ARABIC MATHEMATICAL STRETCHED QAF
+1EE74;N # ARABIC MATHEMATICAL STRETCHED SHEEN
+1EE75;N # ARABIC MATHEMATICAL STRETCHED TEH
+1EE76;N # ARABIC MATHEMATICAL STRETCHED THEH
+1EE77;N # ARABIC MATHEMATICAL STRETCHED KHAH
+1EE79;N # ARABIC MATHEMATICAL STRETCHED DAD
+1EE7A;N # ARABIC MATHEMATICAL STRETCHED ZAH
+1EE7B;N # ARABIC MATHEMATICAL STRETCHED GHAIN
+1EE7C;N # ARABIC MATHEMATICAL STRETCHED DOTLESS BEH
+1EE7E;N # ARABIC MATHEMATICAL STRETCHED DOTLESS FEH
+1EE80;N # ARABIC MATHEMATICAL LOOPED ALEF
+1EE81;N # ARABIC MATHEMATICAL LOOPED BEH
+1EE82;N # ARABIC MATHEMATICAL LOOPED JEEM
+1EE83;N # ARABIC MATHEMATICAL LOOPED DAL
+1EE84;N # ARABIC MATHEMATICAL LOOPED HEH
+1EE85;N # ARABIC MATHEMATICAL LOOPED WAW
+1EE86;N # ARABIC MATHEMATICAL LOOPED ZAIN
+1EE87;N # ARABIC MATHEMATICAL LOOPED HAH
+1EE88;N # ARABIC MATHEMATICAL LOOPED TAH
+1EE89;N # ARABIC MATHEMATICAL LOOPED YEH
+1EE8B;N # ARABIC MATHEMATICAL LOOPED LAM
+1EE8C;N # ARABIC MATHEMATICAL LOOPED MEEM
+1EE8D;N # ARABIC MATHEMATICAL LOOPED NOON
+1EE8E;N # ARABIC MATHEMATICAL LOOPED SEEN
+1EE8F;N # ARABIC MATHEMATICAL LOOPED AIN
+1EE90;N # ARABIC MATHEMATICAL LOOPED FEH
+1EE91;N # ARABIC MATHEMATICAL LOOPED SAD
+1EE92;N # ARABIC MATHEMATICAL LOOPED QAF
+1EE93;N # ARABIC MATHEMATICAL LOOPED REH
+1EE94;N # ARABIC MATHEMATICAL LOOPED SHEEN
+1EE95;N # ARABIC MATHEMATICAL LOOPED TEH
+1EE96;N # ARABIC MATHEMATICAL LOOPED THEH
+1EE97;N # ARABIC MATHEMATICAL LOOPED KHAH
+1EE98;N # ARABIC MATHEMATICAL LOOPED THAL
+1EE99;N # ARABIC MATHEMATICAL LOOPED DAD
+1EE9A;N # ARABIC MATHEMATICAL LOOPED ZAH
+1EE9B;N # ARABIC MATHEMATICAL LOOPED GHAIN
+1EEA1;N # ARABIC MATHEMATICAL DOUBLE-STRUCK BEH
+1EEA2;N # ARABIC MATHEMATICAL DOUBLE-STRUCK JEEM
+1EEA3;N # ARABIC MATHEMATICAL DOUBLE-STRUCK DAL
+1EEA5;N # ARABIC MATHEMATICAL DOUBLE-STRUCK WAW
+1EEA6;N # ARABIC MATHEMATICAL DOUBLE-STRUCK ZAIN
+1EEA7;N # ARABIC MATHEMATICAL DOUBLE-STRUCK HAH
+1EEA8;N # ARABIC MATHEMATICAL DOUBLE-STRUCK TAH
+1EEA9;N # ARABIC MATHEMATICAL DOUBLE-STRUCK YEH
+1EEAB;N # ARABIC MATHEMATICAL DOUBLE-STRUCK LAM
+1EEAC;N # ARABIC MATHEMATICAL DOUBLE-STRUCK MEEM
+1EEAD;N # ARABIC MATHEMATICAL DOUBLE-STRUCK NOON
+1EEAE;N # ARABIC MATHEMATICAL DOUBLE-STRUCK SEEN
+1EEAF;N # ARABIC MATHEMATICAL DOUBLE-STRUCK AIN
+1EEB0;N # ARABIC MATHEMATICAL DOUBLE-STRUCK FEH
+1EEB1;N # ARABIC MATHEMATICAL DOUBLE-STRUCK SAD
+1EEB2;N # ARABIC MATHEMATICAL DOUBLE-STRUCK QAF
+1EEB3;N # ARABIC MATHEMATICAL DOUBLE-STRUCK REH
+1EEB4;N # ARABIC MATHEMATICAL DOUBLE-STRUCK SHEEN
+1EEB5;N # ARABIC MATHEMATICAL DOUBLE-STRUCK TEH
+1EEB6;N # ARABIC MATHEMATICAL DOUBLE-STRUCK THEH
+1EEB7;N # ARABIC MATHEMATICAL DOUBLE-STRUCK KHAH
+1EEB8;N # ARABIC MATHEMATICAL DOUBLE-STRUCK THAL
+1EEB9;N # ARABIC MATHEMATICAL DOUBLE-STRUCK DAD
+1EEBA;N # ARABIC MATHEMATICAL DOUBLE-STRUCK ZAH
+1EEBB;N # ARABIC MATHEMATICAL DOUBLE-STRUCK GHAIN
+1EEF0;N # ARABIC MATHEMATICAL OPERATOR MEEM WITH HAH WITH TATWEEL
+1EEF1;N # ARABIC MATHEMATICAL OPERATOR HAH WITH DAL
1F000;N # MAHJONG TILE EAST WIND
1F001;N # MAHJONG TILE SOUTH WIND
1F002;N # MAHJONG TILE WEST WIND
@@ -21938,6 +22650,8 @@
1F167;A # NEGATIVE CIRCLED LATIN CAPITAL LETTER X
1F168;A # NEGATIVE CIRCLED LATIN CAPITAL LETTER Y
1F169;A # NEGATIVE CIRCLED LATIN CAPITAL LETTER Z
+1F16A;N # RAISED MC SIGN
+1F16B;N # RAISED MD SIGN
1F170;A # NEGATIVE SQUARED LATIN CAPITAL LETTER A
1F171;A # NEGATIVE SQUARED LATIN CAPITAL LETTER B
1F172;A # NEGATIVE SQUARED LATIN CAPITAL LETTER C
@@ -22564,6 +23278,10 @@
1F53B;N # DOWN-POINTING RED TRIANGLE
1F53C;N # UP-POINTING SMALL RED TRIANGLE
1F53D;N # DOWN-POINTING SMALL RED TRIANGLE
+1F540;N # CIRCLED CROSS POMMEE
+1F541;N # CROSS POMMEE WITH HALF-CIRCLE BELOW
+1F542;N # CROSS POMMEE
+1F543;N # NOTCHED LEFT SEMICIRCLE WITH THREE DOTS
1F550;N # CLOCK FACE ONE OCLOCK
1F551;N # CLOCK FACE TWO OCLOCK
1F552;N # CLOCK FACE THREE OCLOCK
@@ -22593,6 +23311,7 @@
1F5FD;N # STATUE OF LIBERTY
1F5FE;N # SILHOUETTE OF JAPAN
1F5FF;N # MOYAI
+1F600;N # GRINNING FACE
1F601;N # GRINNING FACE WITH SMILING EYES
1F602;N # FACE WITH TEARS OF JOY
1F603;N # SMILING FACE WITH OPEN MOUTH
@@ -22609,15 +23328,21 @@
1F60E;N # SMILING FACE WITH SUNGLASSES
1F60F;N # SMIRKING FACE
1F610;N # NEUTRAL FACE
+1F611;N # EXPRESSIONLESS FACE
1F612;N # UNAMUSED FACE
1F613;N # FACE WITH COLD SWEAT
1F614;N # PENSIVE FACE
+1F615;N # CONFUSED FACE
1F616;N # CONFOUNDED FACE
+1F617;N # KISSING FACE
1F618;N # FACE THROWING A KISS
+1F619;N # KISSING FACE WITH SMILING EYES
1F61A;N # KISSING FACE WITH CLOSED EYES
+1F61B;N # FACE WITH STUCK-OUT TONGUE
1F61C;N # FACE WITH STUCK-OUT TONGUE AND WINKING EYE
1F61D;N # FACE WITH STUCK-OUT TONGUE AND TIGHTLY-CLOSED EYES
1F61E;N # DISAPPOINTED FACE
+1F61F;N # WORRIED FACE
1F620;N # ANGRY FACE
1F621;N # POUTING FACE
1F622;N # CRYING FACE
@@ -22624,15 +23349,21 @@
1F623;N # PERSEVERING FACE
1F624;N # FACE WITH LOOK OF TRIUMPH
1F625;N # DISAPPOINTED BUT RELIEVED FACE
+1F626;N # FROWNING FACE WITH OPEN MOUTH
+1F627;N # ANGUISHED FACE
1F628;N # FEARFUL FACE
1F629;N # WEARY FACE
1F62A;N # SLEEPY FACE
1F62B;N # TIRED FACE
+1F62C;N # GRIMACING FACE
1F62D;N # LOUDLY CRYING FACE
+1F62E;N # FACE WITH OPEN MOUTH
+1F62F;N # HUSHED FACE
1F630;N # FACE WITH OPEN MOUTH AND COLD SWEAT
1F631;N # FACE SCREAMING IN FEAR
1F632;N # ASTONISHED FACE
1F633;N # FLUSHED FACE
+1F634;N # SLEEPING FACE
1F635;N # DIZZY FACE
1F636;N # FACE WITHOUT MOUTH
1F637;N # FACE WITH MEDICAL MASK
@@ -22845,7 +23576,7 @@
20000..2A6D6;W # <CJK Ideograph Extension B, First>..<CJK Ideograph Extension B, Last>
2A6D7..2A6FF;W # <reserved-2A6D7>..<reserved-2A6FF>
2A700..2B734;W # <CJK Ideograph Extension C, First>..<CJK Ideograph Extension C, Last>
-2B735..2F73F;W # <reserved-2B735>..<reserved-2F73F>
+2B735..2B73F;W # <reserved-2B735>..<reserved-2B73F>
2B740..2B81D;W # <CJK Ideograph Extension D, First>..<CJK Ideograph Extension D, Last>
2B81E..2F7FF;W # <reserved-2B735>..<reserved-2F7FF>
2F800;W # CJK COMPATIBILITY IDEOGRAPH-2F800
Property changes on: trunk/contrib/perl/lib/unicore/EastAsianWidth.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/EmojiSources.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/EmojiSources.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/EmojiSources.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,8 +1,8 @@
-# EmojiSources-6.0.0.txt
-# Date: 2010-04-24, 00:00:00 GMT [MS]
+# EmojiSources-6.2.0.txt
+# Date: 2012-03-08, 21:21:00 GMT [MS, KW]
#
# Unicode Character Database
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
# For documentation, see http://www.unicode.org/reports/tr44/
#
@@ -15,6 +15,10 @@
# Note: It is possible that future versions of this file will include
# additional data columns providing mappings for additional vendors.
#
+# Created for Unicode 6.0 by Markus Scherer.
+# Updated for Unicode 6.1 by Ken Whistler (no changes to mappings).
+# Updated for Unicode 6.2 by Ken Whistler (no changes to mappings).
+#
# Format: Semicolon-delimited file with a fixed number of fields.
# The number of fields may increase in the future.
#
Property changes on: trunk/contrib/perl/lib/unicore/EmojiSources.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/HangulSyllableType.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/HangulSyllableType.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/HangulSyllableType.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,8 +1,8 @@
-# HangulSyllableType-6.0.0.txt
-# Date: 2010-05-18, 00:49:27 GMT [MD]
+# HangulSyllableType-6.2.0.txt
+# Date: 2012-05-23, 20:34:56 GMT [MD]
#
# Unicode Character Database
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
# For documentation, see http://www.unicode.org/reports/tr44/
Property changes on: trunk/contrib/perl/lib/unicore/HangulSyllableType.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/Index.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/Index.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/Index.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -249,6 +249,7 @@
Arabic Contextual Form Glyphs FE80
ARABIC DATE SEPARATOR 060D
ARABIC DECIMAL SEPARATOR 066B
+Arabic Extended-A 08A0
Arabic Extensions 0671
ARABIC FULL STOP 06D4
Arabic Harakat 064B
@@ -261,6 +262,7 @@
Arabic Letters, Extended 0750
ARABIC LIGATURE BISMILLAH AR-RAHMAN AR-RAHEEM FDFD
Arabic Ligatures FBEA
+Arabic Mathematical Alphabetic Symbols 1EE00
arabic phrase separator 066C
Arabic Points, Glyphs for Spacing Forms of FE70
Arabic Presentation Forms-A FB50
@@ -769,7 +771,7 @@
CASTLE 26EB
CAT 1F408
CAT FACE 1F431
-Cat faces 1F638
+Cat Faces 1F638
CAUTION SIGN 2621
cd 1F4BF
CEDI SIGN 20B5
@@ -792,6 +794,7 @@
CENTRELINE OVERLINE FE4A
cgj 034F
CHAINS 26D3
+Chakma 11100
Cham AA00
chandrakkala, malayalam 0D4D
CHARACTER INTRODUCER, SINGLE 009A
@@ -1224,6 +1227,7 @@
CROSS MARK 274C
CROSS OF JERUSALEM 2629
CROSS OF LORRAINE 2628
+CROSS POMMEE 1F542
cross ratio 211E
cross, constantine's 2627
CROSS, DOTTED 205C
@@ -1339,8 +1343,10 @@
DASH, EM 2014
DASH, EN 2013
DASH, FIGURE 2012
+dash, omission 2E3A
dash, quotation 2015
DASH, SWUNG 2053
+DASH, TWO-EM 2E3A
DASH, WAVE 301C
DASH, WAVY 3030
DASHED LOW LINE FE4D
@@ -2227,6 +2233,7 @@
Greek, Precomposed Polytonic 1F00
GROUND, EARTH 23DA
group lock 21F0
+group select (ISO 9995-7) 21E8
group separator 001D
GROUP SEPARATOR, SYMBOL FOR 241D
GUARANI SIGN 20B2
@@ -2987,6 +2994,7 @@
Letterlike Mathematical Symbols, Hebrew 2135
Letterlike Symbols 2100
level 2 lock 21EB
+level 2 select (ISO 9995-7) 21E7
level 3 lock 21EF
level 3 select 21EE
LEZH, LATIN SMALL LETTER 026E
@@ -3053,8 +3061,8 @@
Lines, Horizontal Scan 23BA
Lines, Vertical 2223
LIRA SIGN 20A4
+LIRA SIGN, TURKISH 20BA
lira, italian 00A3
-lira, turkish 00A3
Lisu A4D0
liter 2113
LIVRE TOURNOIS SIGN 20B6
@@ -3141,6 +3149,7 @@
MACRON, MODIFIER LETTER 02C9
MACRON, MODIFIER LETTER LOW 02CD
macron, spacing 00AF
+Magnetic Ink Character Recognition, MICR 2446
MAGNIFYING GLASS, LEFT-POINTING 1F50D
MAGNIFYING GLASS, RIGHT-POINTING 1F50E
Mahjong Tiles 1F000
@@ -3181,6 +3190,8 @@
Markers, Go 2686
Marks, Combining Diacritical 0300
Marks, Combining Half FE20
+marque de commerce 1F16A
+marque deposee 1F16B
MARRIAGE SYMBOL 26AD
mars 2642
MASCULINE ORDINAL INDICATOR 00BA
@@ -3222,6 +3233,8 @@
Mathematical Symbols-A, Miscellaneous 27C0
Mathematical Symbols-B, Miscellaneous 2980
MATRIX, HERMITIAN CONJUGATE 22B9
+MC SIGN, RAISED 1F16A
+MD SIGN, RAISED 1F16B
MEASURED ANGLE 2221
Measured Angles, Angles and 299B
MEASURED BY 225E
@@ -3238,6 +3251,7 @@
MEDIUM, END OF 0019
MEDIUM, SYMBOL FOR END OF 2419
Meetei Mayek ABC0
+Meetei Mayek Extensions AAE0
MEMBER, CONTAINS AS 220B
MEMBER, DOES NOT CONTAIN AS 220C
MEMBER, SMALL CONTAINS AS 220D
@@ -3246,11 +3260,15 @@
MEN HOLDING HANDS, TWO 1F46C
MERCURY 263F
merge 2A07
+Meroitic Cursive 109A0
+Meroitic Hieroglyphs 10980
merpadi, tamil 0BF8
MESSAGE WAITING 0095
MESSAGE, PRIVACY 009E
Metrical Symbols 23D1
mho 2127
+Miao 16F00
+MICR, Magnetic Ink Character Recognition 2446
MICRO SIGN 00B5
mid space 2005
MIDDLE DOT 00B7
@@ -3599,6 +3617,7 @@
OM, TIBETAN SYLLABLE 0F00
omega pi 03D6
OMEGA, LATIN SMALL LETTER CLOSED 0277
+omission dash 2E3A
ONE DOT LEADER 2024
ONE HALF, VULGAR FRACTION 00BD
ONE QUARTER, VULGAR FRACTION 00BC
@@ -3622,6 +3641,7 @@
opening parenthesis 0028
opening square bracket 005B
OPERATING SYSTEM COMMAND 009D
+operating system key (ISO 9995-7) 2318
Operators Supplement, Mathematical 2A00
Operators, Database Theory 27D5
Operators, Dotted Mathematical 2234
@@ -3728,6 +3748,7 @@
PAGE, NEXT 2398
PAGE, PREVIOUS 2397
Pahlavi 10B60
+Palaeotype Transliteration Symbols 2E32
PALATAL HOOK, LATIN SMALL LETTER T WITH 01AB
PALATALIZED HOOK BELOW, COMBINING 0321
PALM BRANCH 2E19
@@ -4498,6 +4519,7 @@
SHAMROCK 2618
shamrock 2663
Shapes, Geometric 25A0
+Sharada 11180
SHARP S, LATIN SMALL LETTER 00DF
SHARP SIGN, MUSIC 266F
Shavian 10450
@@ -4640,6 +4662,7 @@
SOLIDUS, BIG 29F8
SOLIDUS, BIG REVERSE 29F9
SOLIDUS, REVERSE 005C
+Sora Sompeng 110D0
sound 1F50A
SOUND RECORDING COPYRIGHT 2117
SOURCE, INFORMATION 2139
@@ -4805,6 +4828,7 @@
SUN WITH RAYS, BLACK 2600
SUN WITH RAYS, WHITE 263C
Sundanese 1B80
+Sundanese Supplement 1CC0
sunna, telugu 0C02
Superscript Digits 2070
Superscript Letter Diacritics, Latin Medieval 1DD3
@@ -4995,6 +5019,7 @@
Tails, Fish 297C
tainome japanese bullet 25C9
TAKE, PRESCRIPTION 211E
+Takri 11680
Tamil 0B80
TAMIL AS ABOVE SIGN 0BF8
tamil aytham 0B83
@@ -5224,8 +5249,7 @@
TURBAN, MAN WITH 1F473
turbofan 274B
Turkic, Old 10C00
-turkish currency 20A4
-turkish lira 00A3
+TURKISH LIRA SIGN 20BA
TURNED A, LATIN SMALL LETTER 0250
TURNED AE, LATIN SMALL LETTER 1D02
TURNED ALPHA, LATIN SMALL LETTER 0252
@@ -5275,6 +5299,7 @@
TWO DOT LEADER 2025
TWO DOT PUNCTUATION 205A
TWO, SUPERSCRIPT 00B2
+TWO-EM DASH 2E3A
U BAR, LATIN CAPITAL LETTER 0244
U BAR, LATIN SMALL LETTER 0289
U WITH ACUTE, LATIN CAPITAL LETTER 00DA
@@ -5369,9 +5394,9 @@
uranus 26E2
urdu paragraph separator 203B
URN, FUNERAL 26B1
-User interface Input Status Symbols 1F520
+User Interface Input Status Symbols 1F520
User Interface Symbols 1F500
-User interface Symbols 1F53A
+User Interface Symbols 1F53A
v above 030C
V WITH DOT BELOW, LATIN SMALL LETTER 1E7F
V WITH HOOK, LATIN CAPITAL LETTER 01B2
Property changes on: trunk/contrib/perl/lib/unicore/Index.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/IndicMatraCategory.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/IndicMatraCategory.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/IndicMatraCategory.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,8 +1,8 @@
-# IndicMatraCategory-6.0.0.txt
-# Date: 2010-07-14, 15:03:00 PDT [KW]
+# IndicMatraCategory-6.2.0.txt
+# Date: 2012-05-15, 21:10:00 GMT [KW]
#
# Unicode Character Database
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
# For documentation, see UAX #44.
#
@@ -63,7 +63,7 @@
# Tagalog, Hanunoo, Buhid, Tagbanwa, Khmer, Limbu, New Tai Lue,
# Buginese, Tai Tham, Balinese, Sundanese, Batak, Lepcha,
# Syloti Nagri, Saurashtra, Rejang, Javanese, Cham, Tai Viet,
-# Meetei Mayek, Karoshthi, Brahmi, Kaithi
+# Meetei Mayek, Kharoshthi, Brahmi, Kaithi, Chakma, Sharada, Takri
#
# All characters for all other scripts not in that list
# take the default value for this property.
@@ -157,6 +157,7 @@
AAB1 ; Right # Lo TAI VIET VOWEL AA
AABA ; Right # Lo TAI VIET VOWEL UA
AABD ; Right # Lo TAI VIET VOWEL AN
+AAEF ; Right # Mc MEETEI MAYEK VOWEL SIGN AAU
ABE3..ABE4 ; Right # Mc [2] MEETEI MAYEK VOWEL SIGN ONAP..MEETEI MAYEK VOWEL SIGN INAP
ABE6..ABE7 ; Right # Mc [2] MEETEI MAYEK VOWEL SIGN YENAP..MEETEI MAYEK VOWEL SIGN SOUNAP
ABE9..ABEA ; Right # Mc [2] MEETEI MAYEK VOWEL SIGN CHEINAP..MEETEI MAYEK VOWEL SIGN NUNG
@@ -163,6 +164,10 @@
110B0 ; Right # Mc KAITHI VOWEL SIGN AA
110B2 ; Right # Mc KAITHI VOWEL SIGN II
110B7..110B8 ; Right # Mc [2] KAITHI VOWEL SIGN O..KAITHI VOWEL SIGN AU
+111B3 ; Right # Mc SHARADA VOWEL SIGN AA
+111B5 ; Right # Mc SHARADA VOWEL SIGN II
+111C0 ; Right # Mc SHARADA SIGN VIRAMA
+116AF ; Right # Mc TAKRI VOWEL SIGN II
# Indic_Matra_Category=Left
@@ -190,7 +195,12 @@
1C27..1C28 ; Left # Mc [2] LEPCHA VOWEL SIGN I..LEPCHA VOWEL SIGN O
A9BA..A9BB ; Left # Mc [2] JAVANESE VOWEL SIGN TALING..JAVANESE VOWEL SIGN DIRGA MURE
AA2F..AA30 ; Left # Mc [2] CHAM VOWEL SIGN O..CHAM VOWEL SIGN AI
+AAEB ; Left # Mc MEETEI MAYEK VOWEL SIGN II
+AAEE ; Left # Mc MEETEI MAYEK VOWEL SIGN AU
110B1 ; Left # Mc KAITHI VOWEL SIGN I
+1112C ; Left # Mc CHAKMA VOWEL SIGN E
+111B4 ; Left # Mc SHARADA VOWEL SIGN I
+116AE ; Left # Mc TAKRI VOWEL SIGN I
# Indic_Matra_Category=Visual_Order_Left
@@ -289,6 +299,7 @@
AAB2..AAB3 ; Top # Mn [2] TAI VIET VOWEL I..TAI VIET VOWEL UE
AAB7..AAB8 ; Top # Mn [2] TAI VIET MAI KHIT..TAI VIET VOWEL IA
AABE ; Top # Mn TAI VIET VOWEL AM
+AAED ; Top # Mn MEETEI MAYEK VOWEL SIGN AAI
ABE5 ; Top # Mn MEETEI MAYEK VOWEL SIGN ANAP
10A05 ; Top # Mn KHAROSHTHI VOWEL SIGN E
11038..1103B ; Top # Mn [4] BRAHMI VOWEL SIGN AA..BRAHMI VOWEL SIGN II
@@ -295,6 +306,14 @@
11042..11045 ; Top # Mn [4] BRAHMI VOWEL SIGN E..BRAHMI VOWEL SIGN AU
11046 ; Top # Mn BRAHMI VIRAMA
110B5..110B6 ; Top # Mn [2] KAITHI VOWEL SIGN E..KAITHI VOWEL SIGN AI
+11127..11129 ; Top # Mn [3] CHAKMA VOWEL SIGN A..CHAKMA VOWEL SIGN II
+1112D ; Top # Mn CHAKMA VOWEL SIGN AI
+11130 ; Top # Mn CHAKMA VOWEL SIGN OI
+11134 ; Top # Mn CHAKMA MAAYYAA
+111BC..111BE ; Top # Mn [3] SHARADA VOWEL SIGN E..SHARADA VOWEL SIGN O
+116AD ; Top # Mn TAKRI VOWEL SIGN AA
+116B2..116B5 ; Top # Mn [4] TAKRI VOWEL SIGN E..TAKRI VOWEL SIGN AU
+116B6 ; Top # Mn TAKRI SIGN VIRAMA
# Indic_Matra_Category=Bottom
@@ -352,6 +371,7 @@
AA2D ; Bottom # Mn CHAM VOWEL SIGN U
AA32 ; Bottom # Mn CHAM VOWEL SIGN UE
AAB4 ; Bottom # Mn TAI VIET VOWEL U
+AAEC ; Bottom # Mn MEETEI MAYEK VOWEL SIGN UU
ABE8 ; Bottom # Mn MEETEI MAYEK VOWEL SIGN UNAP
ABED ; Bottom # Mn MEETEI MAYEK APUN IYEK
10A02..10A03 ; Bottom # Mn [2] KHAROSHTHI VOWEL SIGN U..KHAROSHTHI VOWEL SIGN VOCALIC R
@@ -359,6 +379,10 @@
1103C..11041 ; Bottom # Mn [6] BRAHMI VOWEL SIGN U..BRAHMI VOWEL SIGN VOCALIC LL
110B3..110B4 ; Bottom # Mn [2] KAITHI VOWEL SIGN U..KAITHI VOWEL SIGN UU
110B9 ; Bottom # Mn KAITHI SIGN VIRAMA
+1112A..1112B ; Bottom # Mn [2] CHAKMA VOWEL SIGN U..CHAKMA VOWEL SIGN UU
+11131..11132 ; Bottom # Mn [2] CHAKMA O MARK..CHAKMA AU MARK
+111B6..111BB ; Bottom # Mn [6] SHARADA VOWEL SIGN U..SHARADA VOWEL SIGN VOCALIC LL
+116B0..116B1 ; Bottom # Mn [2] TAKRI VOWEL SIGN U..TAKRI VOWEL SIGN UU
# Indic_Matra_Category=Top_And_Bottom
@@ -367,6 +391,7 @@
0F76..0F79 ; Top_And_Bottom # Mn [4] TIBETAN VOWEL SIGN VOCALIC R..TIBETAN VOWEL SIGN VOCALIC LL
0F81 ; Top_And_Bottom # Mn TIBETAN VOWEL SIGN REVERSED II
1B3C ; Top_And_Bottom # Mn BALINESE VOWEL SIGN LA LENGA
+1112E..1112F ; Top_And_Bottom # Mn [2] CHAKMA VOWEL SIGN O..CHAKMA VOWEL SIGN AU
# Indic_Matra_Category=Top_And_Right
@@ -377,6 +402,7 @@
0CCA..0CCB ; Top_And_Right # Mc [2] KANNADA VOWEL SIGN O..KANNADA VOWEL SIGN OO
1925..1926 ; Top_And_Right # Mc [2] LIMBU VOWEL SIGN OO..LIMBU VOWEL SIGN AU
1B43 ; Top_And_Right # Mc BALINESE VOWEL SIGN PEPET TEDUNG
+111BF ; Top_And_Right # Mc SHARADA VOWEL SIGN AU
# Indic_Matra_Category=Top_And_Left
@@ -413,6 +439,8 @@
1039 ; Invisible # Mn MYANMAR SIGN VIRAMA
17D2 ; Invisible # Mn KHMER SIGN COENG
1A60 ; Invisible # Mn TAI THAM SIGN SAKOT
+AAF6 ; Invisible # Mn MEETEI MAYEK VIRAMA
10A3F ; Invisible # Mn KHAROSHTHI VIRAMA
+11133 ; Invisible # Mn CHAKMA VIRAMA
# EOF
Property changes on: trunk/contrib/perl/lib/unicore/IndicMatraCategory.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/IndicSyllabicCategory.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/IndicSyllabicCategory.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/IndicSyllabicCategory.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,8 +1,8 @@
-# IndicSyllabicCategory-6.0.0.txt
-# Date: 2010-05-25, 11:45:00 PDT [KW]
+# IndicSyllabicCategory-6.2.0.txt
+# Date: 2012-05-15, 21:12:00 GMT [KW]
#
# Unicode Character Database
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
# For documentation, see UAX #44.
#
@@ -43,7 +43,7 @@
# Tagalog, Hanunoo, Buhid, Tagbanwa, Khmer, Limbu, Tai Le, New Tai Lue,
# Buginese, Tai Tham, Balinese, Sundanese, Batak, Lepcha,
# Syloti Nagri, Phags-Pa, Saurashtra, Kayah Li, Rejang, Javanese, Cham, Tai Viet,
-# Meetei Mayek, Karoshthi, Brahmi, Kaithi
+# Meetei Mayek, Kharoshthi, Brahmi, Kaithi, Chakma, Sharada, Takri
#
# All characters for all other scripts not in that list
# take the default value for this property, unless they
@@ -99,6 +99,9 @@
11000 ; Bindu # Mc BRAHMI SIGN CANDRABINDU
11001 ; Bindu # Mn BRAHMI SIGN ANUSVARA
11080..11081 ; Bindu # Mn [2] KAITHI SIGN CANDRABINDU..KAITHI SIGN ANUSVARA
+11100..11101 ; Bindu # Mn CHAKMA SIGN CANDRABINDU..CHAKMA SIGN ANUSVARA
+11180..11181 ; Bindu # Mn SHARADA SIGN CANDRABINDU..SHARADA SIGN ANUSVARA
+116AB ; Bindu # Mn TAKRI SIGN ANUSVARA
# ================================================
@@ -105,6 +108,9 @@
# Indic_Syllabic_Category=Visarga
# Visarga (-h)
+# Includes specialized case for Sanskrit: ardhavisarga
+# Excludes letters for jihvamuliya and upadhmaniya, which are
+# related, but structured somewhat differently.
# [Not derivable]
@@ -122,11 +128,17 @@
17C7 ; Visarga # Mc KHMER SIGN REAHMUK
1B04 ; Visarga # Mc BALINESE SIGN BISAH
1B82 ; Visarga # Mc SUNDANESE SIGN PANGWISAD
+1CF2 ; Visarga # Mc VEDIC SIGN ARDHAVISARGA
+1CF3 ; Visarga # Mc VEDIC SIGN ROTATED ARDHAVISARGA
A881 ; Visarga # Mc SAURASHTRA SIGN VISARGA
A983 ; Visarga # Mc JAVANESE SIGN WIGNYAN
+AAF5 ; Visarga # Mc MEETEI MAYEK VOWEL SIGN VISARGA
10A0F ; Visarga # Mn KHAROSHTHI SIGN VISARGA
11002 ; Visarga # Mc BRAHMI SIGN VISARGA
11082 ; Visarga # Mc KAITHI SIGN VISARGA
+11102 ; Visarga # Mn CHAKMA SIGN VISARGA
+11182 ; Visarga # Mn SHARADA SIGN VISARGA
+116AC ; Visarga # Mc TAKRI SIGN VISARGA
# ================================================
@@ -145,6 +157,8 @@
0D3D ; Avagraha # Lo MALAYALAM SIGN AVAGRAHA
0F85 ; Avagraha # Po TIBETAN MARK PALUTA
17DC ; Avagraha # Lo KHMER SIGN AVAKRAHASANYA
+1BBA ; Avagraha # Lo SUNDANESE AVAGRAHA
+111C1 ; Avagraha # Lo SHARADA SIGN AVAGRAHA
# ================================================
@@ -165,6 +179,7 @@
1C37 ; Nukta # Mn LEPCHA SIGN NUKTA
A9B3 ; Nukta # Mn JAVANESE SIGN CECAK TELU
110BA ; Nukta # Mn KAITHI SIGN NUKTA
+116B7 ; Nukta # Mn TAKRI SIGN NUKTA
# ================================================
@@ -196,15 +211,20 @@
1A60 ; Virama # Mn TAI THAM SIGN SAKOT
1B44 ; Virama # Mc BALINESE ADEG ADEG
1BAA ; Virama # Mc SUNDANESE SIGN PAMAAEH
+1BAB ; Virama # Mc SUNDANESE SIGN VIRAMA
1BF2..1BF3 ; Virama # Mc [2] BATAK PANGOLAT..BATAK PANONGONAN
A806 ; Virama # Mn SYLOTI NAGRI SIGN HASANTA
A8C4 ; Virama # Mn SAURASHTRA SIGN VIRAMA
A953 ; Virama # Mc REJANG VIRAMA
A9C0 ; Virama # Mc JAVANESE PANGKON
+AAF6 ; Virama # Mn MEETEI MAYEK VIRAMA
ABED ; Virama # Mn MEETEI MAYEK APUN IYEK
10A3F ; Virama # Mn KHAROSHTHI VIRAMA
11046 ; Virama # Mn BRAHMI VIRAMA
110B9 ; Virama # Mn KAITHI SIGN VIRAMA
+11133..11134 ; Virama # Mn CHAKMA VIRAMA..CHAKMA MAAYYAA
+111C0 ; Virama # Mc SHARADA SIGN VIRAMA
+116B6 ; Virama # Mn TAKRI SIGN VIRAMA
# ================================================
@@ -265,8 +285,14 @@
A984..A988 ; Vowel_Independent # Lo [5] JAVANESE LETTER A..JAVANESE LETTER U
A98C..A98E ; Vowel_Independent # Lo [3] JAVANESE LETTER E..JAVANESE LETTER O
AA00..AA05 ; Vowel_Independent # Lo [6] CHAM LETTER A..CHAM LETTER O
+AAE0..AAE1 ; Vowel_Independent # Lo [2] MEETEI MAYEK LETTER E..MEETEI MAYEK LETTER O
+ABCE..ABCF ; Vowel_Independent # Lo [2] MEETEI MAYEK LETTER UN..MEETEI MAYEK LETTER I
+ABD1 ; Vowel_Independent # Lo MEETEI MAYEK LETTER ATIYA
11005..11012 ; Vowel_Independent # Lo [14] BRAHMI LETTER A..BRAHMI LETTER AU
11083..1108C ; Vowel_Independent # Lo [10] KAITHI LETTER A..KAITHI LETTER AU
+11103..11106 ; Vowel_Independent # Lo [4] CHAKMA LETTER AA..CHAKMA LETTER E
+11183..11190 ; Vowel_Independent # Lo [14] SHARADA LETTER A..SHARADA LETTER AU
+11680..11689 ; Vowel_Independent # Lo [10] TAKRI LETTER A..TAKRI LETTER AU
# ================================================
@@ -426,6 +452,7 @@
AAB7..AAB8 ; Vowel_Dependent # Mn [2] TAI VIET MAI KHIT..TAI VIET VOWEL IA
AAB9..AABD ; Vowel_Dependent # Lo [5] TAI VIET VOWEL UEA..TAI VIET VOWEL AN
AABE ; Vowel_Dependent # Mn TAI VIET VOWEL AM
+AAEB..AAEF ; Vowel_Dependent # Mc [5] MEETEI MAYEK VOWEL SIGN II..MEETEI MAYEK VOWEL SIGN AAU
ABE3..ABE4 ; Vowel_Dependent # Mc [2] MEETEI MAYEK VOWEL SIGN ONAP..MEETEI MAYEK VOWEL SIGN INAP
ABE5 ; Vowel_Dependent # Mn MEETEI MAYEK VOWEL SIGN ANAP
ABE6..ABE7 ; Vowel_Dependent # Mc [2] MEETEI MAYEK VOWEL SIGN YENAP..MEETEI MAYEK VOWEL SIGN SOUNAP
@@ -438,6 +465,9 @@
110B0..110B2 ; Vowel_Dependent # Mc [3] KAITHI VOWEL SIGN AA..KAITHI VOWEL SIGN II
110B3..110B6 ; Vowel_Dependent # Mn [4] KAITHI VOWEL SIGN U..KAITHI VOWEL SIGN AI
110B7..110B8 ; Vowel_Dependent # Mc [2] KAITHI VOWEL SIGN O..KAITHI VOWEL SIGN AU
+11127..11132 ; Vowel_Dependent # Mn [12] CHAKMA VOWEL SIGN A..CHAKMA AU MARK
+111B3..111BF ; Vowel_Dependent # Mn [13] SHARADA VOWEL SIGN AA..SHARADA VOWEL SIGN AU
+116AD..116B5 ; Vowel_Dependent # Mn [9] TAKRI VOWEL SIGN AA..TAKRI VOWEL SIGN AU
# ================================================
@@ -568,6 +598,7 @@
1B45..1B4B ; Consonant # Lo [7] BALINESE LETTER KAF SASAK..BALINESE LETTER ASYURA SASAK
1B8A..1BA0 ; Consonant # Lo [23] SUNDANESE LETTER KA..SUNDANESE LETTER HA
1BAE..1BAF ; Consonant # Lo [2] SUNDANESE LETTER KHA..SUNDANESE LETTER SYA
+1BBB..1BBD ; Consonant # Lo [3] SUNDANESE LETTER REU..SUNDANESE LETTER BHA
1BC0..1BE3 ; Consonant # Lo [36] BATAK LETTER A..BATAK LETTER MBA
1C00..1C23 ; Consonant # Lo [36] LEPCHA LETTER KA..LEPCHA LETTER A
1C4D..1C4F ; Consonant # Lo [3] LEPCHA LETTER TTA..LEPCHA LETTER DDA
@@ -587,7 +618,10 @@
AA71..AA73 ; Consonant # Lo [3] MYANMAR LETTER KHAMTI XA..MYAMNAR LETTER KHAMTI RA
AA7A ; Consonant # Lo MYANMAR LETTER AITON RA
AA80..AAAF ; Consonant # Lo [48] TAI VIET LETTER LOW KO..TAI VIET LETTER HIGH O
-ABC0..ABDA ; Consonant # Lo [27] MEETEI MAYEK LETTER KOK..MEETEI MAYEK LETTER BHAM
+AAE2..AAEA ; Consonant # Lo [9] MEETEI MAYEK LETTER CHA..MEETEI MAYEK LETTER SSA
+ABC0..ABCD ; Consonant # Lo [14] MEETEI MAYEK LETTER KOK..MEETEI MAYEK LETTER HUK
+ABD0 ; Consonant # Lo MEETEI MAYEK LETTER PHAM
+ABD2..ABDA ; Consonant # Lo [9] MEETEI MAYEK LETTER GOK..MEETEI MAYEK LETTER BHAM
10A00 ; Consonant # Lo KHAROSHTHI LETTER A
10A10..10A13 ; Consonant # Lo [4] KHAROSHTHI LETTER KA..KHAROSHTHI LETTER GHA
10A15..10A17 ; Consonant # Lo [3] KHAROSHTHI LETTER CA..KHAROSHTHI LETTER JA
@@ -594,6 +628,9 @@
10A19..10A33 ; Consonant # Lo [27] KHAROSHTHI LETTER NYA..KHAROSHTHI LETTER TTTHA
11013..11037 ; Consonant # Lo [37] BRAHMI LETTER KA..BRAHMI LETTER OLD TAMIL NNNA
1108D..110AF ; Consonant # Lo [35] KAITHI LETTER KA..KAITHI LETTER HA
+11107..11126 ; Consonant # Lo [32] CHAKMA LETTER KAA..CHAKMA LETTER HAA
+11191..111B2 ; Consonant # Lo [34] SHARADA LETTER KA..SHARADA LETTER HA
+1168A..116AA ; Consonant # Lo [34] TAKRI LETTER KA..TAKRI LETTER RRA
# ================================================
@@ -633,6 +670,7 @@
1929..192B ; Consonant_Subjoined # Mc [3] LIMBU SUBJOINED LETTER YA..LIMBU SUBJOINED LETTER WA
1BA1 ; Consonant_Subjoined # Mc SUNDANESE CONSONANT SIGN PAMINGKAL
1BA2..1BA3 ; Consonant_Subjoined # Mn [2] SUNDANESE CONSONANT SIGN PANYAKRA..SUNDANESE CONSONANT SIGN PANYIKU
+1BAC..1BAD ; Consonant_Subjoined # Mc [2] SUNDANESE CONSONANT SIGN PASANGAN MA..SUNDANESE CONSONANT SIGN PASANGAN WA
1C24..1C25 ; Consonant_Subjoined # Mc [2] LEPCHA SUBJOINED LETTER YA..LEPCHA SUBJOINED LETTER RA
A867..A868 ; Consonant_Subjoined # Lo [2] PHAGS-PA SUBJOINED LETTER WA..PHAGS-PA SUBJOINED LETTER YA
A871 ; Consonant_Subjoined # Lo PHAGS-PA SUBJOINED LETTER RA
@@ -672,6 +710,7 @@
19C1..19C7 ; Consonant_Final # Lo [7] NEW TAI LUE LETTER FINAL V..NEW TAI LUE LETTER FINAL B
1A57 ; Consonant_Final # Mc TAI THAM CONSONANT SIGN LA TANG LAI
1A58..1A5E ; Consonant_Final # Mn [7] TAI THAM SIGN MAI KANG LAI..TAI THAM CONSONANT SIGN SA
+1BBE..1BBF ; Consonant_Final # Lo [2] SUNDANESE LETTER FINAL K..SUNDANESE LETTER FINAL M
1BF0..1BF1 ; Consonant_Final # Mn [2] BATAK CONSONANT SIGN NG..BATAK CONSONANT SIGN H
1C2D..1C33 ; Consonant_Final # Mn [7] LEPCHA CONSONANT SIGN K..LEPCHA CONSONANT SIGN T
A8B4 ; Consonant_Final # Mc SAURASHTRA CONSONANT SIGN HAARU
Property changes on: trunk/contrib/perl/lib/unicore/IndicSyllabicCategory.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/Jamo.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/Jamo.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/Jamo.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,22 +1,22 @@
-# Jamo-6.0.0.txt
-# Date: 2010-05-19, 11:19:00 PDT [KW]
+# Jamo-6.2.0.txt
+# Date: 2012-05-15, 22:23:00 GMT [KW, LI]
#
# Unicode Character Database
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
# For documentation, see http://www.unicode.org/reports/tr44/
#
-# This file defines the Jamo Short Name property.
+# This file defines the Jamo_Short_Name property.
#
-# See Section 3.12 of The Unicode Standard, Version 6.0
+# See Section 3.12 of The Unicode Standard, Version 6.2
# for more information.
#
# Each line contains two fields, separated by a semicolon.
#
# The first field gives the code point, in 4-digit hexadecimal
-# form, of a combining jamo character that participates in
-# the algorithmic determination Hangul syllable character names.
-# The second field gives the Jamo Short Name as a one-, two-,
+# form, of a conjoining jamo character that participates in the
+# algorithmic determination of Hangul syllable character names.
+# The second field gives the Jamo_Short_Name as a one-, two-,
# or three-character ASCII string (or in one case, for U+110B,
# the null string).
#
@@ -90,3 +90,4 @@
11C1; P # HANGUL JONGSEONG PHIEUPH
11C2; H # HANGUL JONGSEONG HIEUH
+# EOF
Property changes on: trunk/contrib/perl/lib/unicore/Jamo.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/LineBreak.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/LineBreak.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/LineBreak.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,5 +1,5 @@
-# LineBreak-6.0.0.txt
-# Date: 2010-08-18, 17:25:00 PDT [KW]
+# LineBreak-6.2.0.txt
+# Date: 2012-08-08, 19:26:00 GMT [KW]
#
# Line Break Properties
#
@@ -7,7 +7,7 @@
# Unicode Character Database.
# It contains both normative and informative data.
#
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
#
# The format is two fields separated by a semicolon.
@@ -19,7 +19,7 @@
# Informative:
# "XX", "OP", "CL", "CP", "QU", "NS", "EX", "SY",
# "IS", "PR", "PO", "NU", "AL", "ID", "IN", "HY",
-# "BB", "BA", "SA", "AI", "B2"
+# "BB", "BA", "SA", "AI", "B2", "HL", "CJ", "RI"
# - All code points, assigned and unassigned, that are not listed
# explicitly are given the value "XX".
# The unassigned code points that default to "ID" include ranges in the
@@ -1439,6 +1439,7 @@
0587;AL # ARMENIAN SMALL LIGATURE ECH YIWN
0589;IS # ARMENIAN FULL STOP
058A;BA # ARMENIAN HYPHEN
+058F;PR # ARMENIAN DRAM SIGN
0591;CM # HEBREW ACCENT ETNAHTA
0592;CM # HEBREW ACCENT SEGOL
0593;CM # HEBREW ACCENT SHALSHELET
@@ -1494,36 +1495,36 @@
05C5;CM # HEBREW MARK LOWER DOT
05C6;EX # HEBREW PUNCTUATION NUN HAFUKHA
05C7;CM # HEBREW POINT QAMATS QATAN
-05D0;AL # HEBREW LETTER ALEF
-05D1;AL # HEBREW LETTER BET
-05D2;AL # HEBREW LETTER GIMEL
-05D3;AL # HEBREW LETTER DALET
-05D4;AL # HEBREW LETTER HE
-05D5;AL # HEBREW LETTER VAV
-05D6;AL # HEBREW LETTER ZAYIN
-05D7;AL # HEBREW LETTER HET
-05D8;AL # HEBREW LETTER TET
-05D9;AL # HEBREW LETTER YOD
-05DA;AL # HEBREW LETTER FINAL KAF
-05DB;AL # HEBREW LETTER KAF
-05DC;AL # HEBREW LETTER LAMED
-05DD;AL # HEBREW LETTER FINAL MEM
-05DE;AL # HEBREW LETTER MEM
-05DF;AL # HEBREW LETTER FINAL NUN
-05E0;AL # HEBREW LETTER NUN
-05E1;AL # HEBREW LETTER SAMEKH
-05E2;AL # HEBREW LETTER AYIN
-05E3;AL # HEBREW LETTER FINAL PE
-05E4;AL # HEBREW LETTER PE
-05E5;AL # HEBREW LETTER FINAL TSADI
-05E6;AL # HEBREW LETTER TSADI
-05E7;AL # HEBREW LETTER QOF
-05E8;AL # HEBREW LETTER RESH
-05E9;AL # HEBREW LETTER SHIN
-05EA;AL # HEBREW LETTER TAV
-05F0;AL # HEBREW LIGATURE YIDDISH DOUBLE VAV
-05F1;AL # HEBREW LIGATURE YIDDISH VAV YOD
-05F2;AL # HEBREW LIGATURE YIDDISH DOUBLE YOD
+05D0;HL # HEBREW LETTER ALEF
+05D1;HL # HEBREW LETTER BET
+05D2;HL # HEBREW LETTER GIMEL
+05D3;HL # HEBREW LETTER DALET
+05D4;HL # HEBREW LETTER HE
+05D5;HL # HEBREW LETTER VAV
+05D6;HL # HEBREW LETTER ZAYIN
+05D7;HL # HEBREW LETTER HET
+05D8;HL # HEBREW LETTER TET
+05D9;HL # HEBREW LETTER YOD
+05DA;HL # HEBREW LETTER FINAL KAF
+05DB;HL # HEBREW LETTER KAF
+05DC;HL # HEBREW LETTER LAMED
+05DD;HL # HEBREW LETTER FINAL MEM
+05DE;HL # HEBREW LETTER MEM
+05DF;HL # HEBREW LETTER FINAL NUN
+05E0;HL # HEBREW LETTER NUN
+05E1;HL # HEBREW LETTER SAMEKH
+05E2;HL # HEBREW LETTER AYIN
+05E3;HL # HEBREW LETTER FINAL PE
+05E4;HL # HEBREW LETTER PE
+05E5;HL # HEBREW LETTER FINAL TSADI
+05E6;HL # HEBREW LETTER TSADI
+05E7;HL # HEBREW LETTER QOF
+05E8;HL # HEBREW LETTER RESH
+05E9;HL # HEBREW LETTER SHIN
+05EA;HL # HEBREW LETTER TAV
+05F0;HL # HEBREW LIGATURE YIDDISH DOUBLE VAV
+05F1;HL # HEBREW LIGATURE YIDDISH VAV YOD
+05F2;HL # HEBREW LIGATURE YIDDISH DOUBLE YOD
05F3;AL # HEBREW PUNCTUATION GERESH
05F4;AL # HEBREW PUNCTUATION GERSHAYIM
0600;AL # ARABIC NUMBER SIGN
@@ -1530,6 +1531,7 @@
0601;AL # ARABIC SIGN SANAH
0602;AL # ARABIC FOOTNOTE MARKER
0603;AL # ARABIC SIGN SAFHA
+0604;AL # ARABIC SIGN SAMVAT
0606;AL # ARABIC-INDIC CUBE ROOT
0607;AL # ARABIC-INDIC FOURTH ROOT
0608;AL # ARABIC RAY
@@ -2102,6 +2104,45 @@
085A;CM # MANDAIC VOCALIZATION MARK
085B;CM # MANDAIC GEMINATION MARK
085E;AL # MANDAIC PUNCTUATION
+08A0;AL # ARABIC LETTER BEH WITH SMALL V BELOW
+08A2;AL # ARABIC LETTER JEEM WITH TWO DOTS ABOVE
+08A3;AL # ARABIC LETTER TAH WITH TWO DOTS ABOVE
+08A4;AL # ARABIC LETTER FEH WITH DOT BELOW AND THREE DOTS ABOVE
+08A5;AL # ARABIC LETTER QAF WITH DOT BELOW
+08A6;AL # ARABIC LETTER LAM WITH DOUBLE BAR
+08A7;AL # ARABIC LETTER MEEM WITH THREE DOTS ABOVE
+08A8;AL # ARABIC LETTER YEH WITH TWO DOTS BELOW AND HAMZA ABOVE
+08A9;AL # ARABIC LETTER YEH WITH TWO DOTS BELOW AND DOT ABOVE
+08AA;AL # ARABIC LETTER REH WITH LOOP
+08AB;AL # ARABIC LETTER WAW WITH DOT WITHIN
+08AC;AL # ARABIC LETTER ROHINGYA YEH
+08E4;CM # ARABIC CURLY FATHA
+08E5;CM # ARABIC CURLY DAMMA
+08E6;CM # ARABIC CURLY KASRA
+08E7;CM # ARABIC CURLY FATHATAN
+08E8;CM # ARABIC CURLY DAMMATAN
+08E9;CM # ARABIC CURLY KASRATAN
+08EA;CM # ARABIC TONE ONE DOT ABOVE
+08EB;CM # ARABIC TONE TWO DOTS ABOVE
+08EC;CM # ARABIC TONE LOOP ABOVE
+08ED;CM # ARABIC TONE ONE DOT BELOW
+08EE;CM # ARABIC TONE TWO DOTS BELOW
+08EF;CM # ARABIC TONE LOOP BELOW
+08F0;CM # ARABIC OPEN FATHATAN
+08F1;CM # ARABIC OPEN DAMMATAN
+08F2;CM # ARABIC OPEN KASRATAN
+08F3;CM # ARABIC SMALL HIGH WAW
+08F4;CM # ARABIC FATHA WITH RING
+08F5;CM # ARABIC FATHA WITH DOT ABOVE
+08F6;CM # ARABIC KASRA WITH DOT BELOW
+08F7;CM # ARABIC LEFT ARROWHEAD ABOVE
+08F8;CM # ARABIC RIGHT ARROWHEAD ABOVE
+08F9;CM # ARABIC LEFT ARROWHEAD BELOW
+08FA;CM # ARABIC RIGHT ARROWHEAD BELOW
+08FB;CM # ARABIC DOUBLE RIGHT ARROWHEAD ABOVE
+08FC;CM # ARABIC DOUBLE RIGHT ARROWHEAD ABOVE WITH DOT
+08FD;CM # ARABIC RIGHT ARROWHEAD ABOVE WITH DOT
+08FE;CM # ARABIC DAMMA WITH DOT
0900;CM # DEVANAGARI SIGN INVERTED CANDRABINDU
0901;CM # DEVANAGARI SIGN CANDRABINDU
0902;CM # DEVANAGARI SIGN ANUSVARA
@@ -2482,6 +2523,7 @@
0AED;NU # GUJARATI DIGIT SEVEN
0AEE;NU # GUJARATI DIGIT EIGHT
0AEF;NU # GUJARATI DIGIT NINE
+0AF0;AL # GUJARATI ABBREVIATION SIGN
0AF1;PR # GUJARATI RUPEE SIGN
0B01;CM # ORIYA SIGN CANDRABINDU
0B02;CM # ORIYA SIGN ANUSVARA
@@ -3154,6 +3196,8 @@
0ED9;NU # LAO DIGIT NINE
0EDC;SA # LAO HO NO
0EDD;SA # LAO HO MO
+0EDE;SA # LAO LETTER KHMU GO
+0EDF;SA # LAO LETTER KHMU NYO
0F00;AL # TIBETAN SYLLABLE OM
0F01;BB # TIBETAN MARK GTER YIG MGO TRUNCATED A
0F02;BB # TIBETAN MARK GTER YIG MGO -UM RNAM BCAD MA
@@ -3563,6 +3607,8 @@
10C3;AL # GEORGIAN CAPITAL LETTER WE
10C4;AL # GEORGIAN CAPITAL LETTER HAR
10C5;AL # GEORGIAN CAPITAL LETTER HOE
+10C7;AL # GEORGIAN CAPITAL LETTER YN
+10CD;AL # GEORGIAN CAPITAL LETTER AEN
10D0;AL # GEORGIAN LETTER AN
10D1;AL # GEORGIAN LETTER BAN
10D2;AL # GEORGIAN LETTER GAN
@@ -3608,6 +3654,9 @@
10FA;AL # GEORGIAN LETTER AIN
10FB;AL # GEORGIAN PARAGRAPH SEPARATOR
10FC;AL # MODIFIER LETTER GEORGIAN NAR
+10FD;AL # GEORGIAN LETTER AEN
+10FE;AL # GEORGIAN LETTER HARD SIGN
+10FF;AL # GEORGIAN LETTER LABIAL SIGN
1100;JL # HANGUL CHOSEONG KIYEOK
1101;JL # HANGUL CHOSEONG SSANGKIYEOK
1102;JL # HANGUL CHOSEONG NIEUN
@@ -6041,6 +6090,9 @@
1BA8;CM # SUNDANESE VOWEL SIGN PAMEPET
1BA9;CM # SUNDANESE VOWEL SIGN PANEULEUNG
1BAA;CM # SUNDANESE SIGN PAMAAEH
+1BAB;CM # SUNDANESE SIGN VIRAMA
+1BAC;CM # SUNDANESE CONSONANT SIGN PASANGAN MA
+1BAD;CM # SUNDANESE CONSONANT SIGN PASANGAN WA
1BAE;AL # SUNDANESE LETTER KHA
1BAF;AL # SUNDANESE LETTER SYA
1BB0;NU # SUNDANESE DIGIT ZERO
@@ -6053,6 +6105,12 @@
1BB7;NU # SUNDANESE DIGIT SEVEN
1BB8;NU # SUNDANESE DIGIT EIGHT
1BB9;NU # SUNDANESE DIGIT NINE
+1BBA;AL # SUNDANESE AVAGRAHA
+1BBB;AL # SUNDANESE LETTER REU
+1BBC;AL # SUNDANESE LETTER LEU
+1BBD;AL # SUNDANESE LETTER BHA
+1BBE;AL # SUNDANESE LETTER FINAL K
+1BBF;AL # SUNDANESE LETTER FINAL M
1BC0;AL # BATAK LETTER A
1BC1;AL # BATAK LETTER SIMALUNGUN A
1BC2;AL # BATAK LETTER HA
@@ -6231,6 +6289,14 @@
1C7D;AL # OL CHIKI AHAD
1C7E;BA # OL CHIKI PUNCTUATION MUCAAD
1C7F;BA # OL CHIKI PUNCTUATION DOUBLE MUCAAD
+1CC0;AL # SUNDANESE PUNCTUATION BINDU SURYA
+1CC1;AL # SUNDANESE PUNCTUATION BINDU PANGLONG
+1CC2;AL # SUNDANESE PUNCTUATION BINDU PURNAMA
+1CC3;AL # SUNDANESE PUNCTUATION BINDU CAKRA
+1CC4;AL # SUNDANESE PUNCTUATION BINDU LEU SATANGA
+1CC5;AL # SUNDANESE PUNCTUATION BINDU KA SATANGA
+1CC6;AL # SUNDANESE PUNCTUATION BINDU DA SATANGA
+1CC7;AL # SUNDANESE PUNCTUATION BINDU BA SATANGA
1CD0;CM # VEDIC TONE KARSHANA
1CD1;CM # VEDIC TONE SHARA
1CD2;CM # VEDIC TONE PRENKHA
@@ -6266,6 +6332,10 @@
1CF0;AL # VEDIC SIGN RTHANG LONG ANUSVARA
1CF1;AL # VEDIC SIGN ANUSVARA UBHAYATO MUKHA
1CF2;CM # VEDIC SIGN ARDHAVISARGA
+1CF3;CM # VEDIC SIGN ROTATED ARDHAVISARGA
+1CF4;CM # VEDIC TONE CANDRA ABOVE
+1CF5;AL # VEDIC SIGN JIHVAMULIYA
+1CF6;AL # VEDIC SIGN UPADHMANIYA
1D00;AL # LATIN LETTER SMALL CAPITAL A
1D01;AL # LATIN LETTER SMALL CAPITAL AE
1D02;AL # LATIN SMALL LETTER TURNED AE
@@ -7165,6 +7235,7 @@
20B7;PR # SPESMILO SIGN
20B8;PR # TENGE SIGN
20B9;PR # INDIAN RUPEE SIGN
+20BA;PR # TURKISH LIRA SIGN
20D0;CM # COMBINING LEFT HARPOON ABOVE
20D1;CM # COMBINING RIGHT HARPOON ABOVE
20D2;CM # COMBINING LONG VERTICAL LINE OVERLAY
@@ -7730,8 +7801,8 @@
2317;AL # VIEWDATA SQUARE
2318;AL # PLACE OF INTEREST SIGN
2319;AL # TURNED NOT SIGN
-231A;AL # WATCH
-231B;AL # HOURGLASS
+231A;ID # WATCH
+231B;ID # HOURGLASS
231C;AL # TOP LEFT CORNER
231D;AL # TOP RIGHT CORNER
231E;AL # BOTTOM LEFT CORNER
@@ -7944,10 +8015,10 @@
23ED;AL # BLACK RIGHT-POINTING DOUBLE TRIANGLE WITH VERTICAL BAR
23EE;AL # BLACK LEFT-POINTING DOUBLE TRIANGLE WITH VERTICAL BAR
23EF;AL # BLACK RIGHT-POINTING TRIANGLE WITH DOUBLE VERTICAL BAR
-23F0;AL # ALARM CLOCK
-23F1;AL # STOPWATCH
-23F2;AL # TIMER CLOCK
-23F3;AL # HOURGLASS WITH FLOWING SAND
+23F0;ID # ALARM CLOCK
+23F1;ID # STOPWATCH
+23F2;ID # TIMER CLOCK
+23F3;ID # HOURGLASS WITH FLOWING SAND
2400;AL # SYMBOL FOR NULL
2401;AL # SYMBOL FOR START OF HEADING
2402;AL # SYMBOL FOR START OF TEXT
@@ -8414,10 +8485,10 @@
25FD;AL # WHITE MEDIUM SMALL SQUARE
25FE;AL # BLACK MEDIUM SMALL SQUARE
25FF;AL # LOWER RIGHT TRIANGLE
-2600;AL # BLACK SUN WITH RAYS
-2601;AL # CLOUD
-2602;AL # UMBRELLA
-2603;AL # SNOWMAN
+2600;ID # BLACK SUN WITH RAYS
+2601;ID # CLOUD
+2602;ID # UMBRELLA
+2603;ID # SNOWMAN
2604;AL # COMET
2605;AI # BLACK STAR
2606;AI # WHITE STAR
@@ -8434,18 +8505,18 @@
2611;AL # BALLOT BOX WITH CHECK
2612;AL # BALLOT BOX WITH X
2613;AL # SALTIRE
-2614;AI # UMBRELLA WITH RAIN DROPS
-2615;AI # HOT BEVERAGE
+2614;ID # UMBRELLA WITH RAIN DROPS
+2615;ID # HOT BEVERAGE
2616;AI # WHITE SHOGI PIECE
2617;AI # BLACK SHOGI PIECE
-2618;AL # SHAMROCK
+2618;ID # SHAMROCK
2619;AL # REVERSED ROTATED FLORAL HEART BULLET
-261A;AL # BLACK LEFT POINTING INDEX
-261B;AL # BLACK RIGHT POINTING INDEX
-261C;AI # WHITE LEFT POINTING INDEX
-261D;AL # WHITE UP POINTING INDEX
-261E;AI # WHITE RIGHT POINTING INDEX
-261F;AL # WHITE DOWN POINTING INDEX
+261A;ID # BLACK LEFT POINTING INDEX
+261B;ID # BLACK RIGHT POINTING INDEX
+261C;ID # WHITE LEFT POINTING INDEX
+261D;ID # WHITE UP POINTING INDEX
+261E;ID # WHITE RIGHT POINTING INDEX
+261F;ID # WHITE DOWN POINTING INDEX
2620;AL # SKULL AND CROSSBONES
2621;AL # CAUTION SIGN
2622;AL # RADIOACTIVE SIGN
@@ -8471,9 +8542,9 @@
2636;AL # TRIGRAM FOR MOUNTAIN
2637;AL # TRIGRAM FOR EARTH
2638;AL # WHEEL OF DHARMA
-2639;AL # WHITE FROWNING FACE
-263A;AL # WHITE SMILING FACE
-263B;AL # BLACK SMILING FACE
+2639;ID # WHITE FROWNING FACE
+263A;ID # WHITE SMILING FACE
+263B;ID # BLACK SMILING FACE
263C;AL # WHITE SUN WITH RAYS
263D;AL # FIRST QUARTER MOON
263E;AL # LAST QUARTER MOON
@@ -8518,7 +8589,7 @@
2665;AI # BLACK HEART SUIT
2666;AL # BLACK DIAMOND SUIT
2667;AI # WHITE CLUB SUIT
-2668;AI # HOT SPRINGS
+2668;ID # HOT SPRINGS
2669;AI # QUARTER NOTE
266A;AI # EIGHTH NOTE
266B;AL # BEAMED EIGHTH NOTES
@@ -8541,7 +8612,7 @@
267C;AL # RECYCLED PAPER SYMBOL
267D;AL # PARTIALLY-RECYCLED PAPER SYMBOL
267E;AL # PERMANENT PAPER SIGN
-267F;AL # WHEELCHAIR SYMBOL
+267F;ID # WHEELCHAIR SYMBOL
2680;AL # DIE FACE-1
2681;AL # DIE FACE-2
2682;AL # DIE FACE-3
@@ -8603,43 +8674,43 @@
26BA;AL # SEMISEXTILE
26BB;AL # QUINCUNX
26BC;AL # SESQUIQUADRATE
-26BD;AL # SOCCER BALL
-26BE;AI # BASEBALL
-26BF;AI # SQUARED KEY
-26C0;AL # WHITE DRAUGHTS MAN
-26C1;AL # WHITE DRAUGHTS KING
-26C2;AL # BLACK DRAUGHTS MAN
-26C3;AL # BLACK DRAUGHTS KING
-26C4;AI # SNOWMAN WITHOUT SNOW
-26C5;AI # SUN BEHIND CLOUD
-26C6;AI # RAIN
-26C7;AI # BLACK SNOWMAN
-26C8;AI # THUNDER CLOUD AND RAIN
+26BD;ID # SOCCER BALL
+26BE;ID # BASEBALL
+26BF;ID # SQUARED KEY
+26C0;ID # WHITE DRAUGHTS MAN
+26C1;ID # WHITE DRAUGHTS KING
+26C2;ID # BLACK DRAUGHTS MAN
+26C3;ID # BLACK DRAUGHTS KING
+26C4;ID # SNOWMAN WITHOUT SNOW
+26C5;ID # SUN BEHIND CLOUD
+26C6;ID # RAIN
+26C7;ID # BLACK SNOWMAN
+26C8;ID # THUNDER CLOUD AND RAIN
26C9;AI # TURNED WHITE SHOGI PIECE
26CA;AI # TURNED BLACK SHOGI PIECE
26CB;AI # WHITE DIAMOND IN SQUARE
26CC;AI # CROSSING LANES
-26CD;AI # DISABLED CAR
+26CD;ID # DISABLED CAR
26CE;AL # OPHIUCHUS
-26CF;AI # PICK
-26D0;AI # CAR SLIDING
-26D1;AI # HELMET WITH WHITE CROSS
+26CF;ID # PICK
+26D0;ID # CAR SLIDING
+26D1;ID # HELMET WITH WHITE CROSS
26D2;AI # CIRCLED CROSSING LANES
-26D3;AI # CHAINS
-26D4;AI # NO ENTRY
+26D3;ID # CHAINS
+26D4;ID # NO ENTRY
26D5;AI # ALTERNATE ONE-WAY LEFT WAY TRAFFIC
26D6;AI # BLACK TWO-WAY LEFT WAY TRAFFIC
26D7;AI # WHITE TWO-WAY LEFT WAY TRAFFIC
-26D8;AI # BLACK LEFT LANE MERGE
-26D9;AI # WHITE LEFT LANE MERGE
+26D8;ID # BLACK LEFT LANE MERGE
+26D9;ID # WHITE LEFT LANE MERGE
26DA;AI # DRIVE SLOW SIGN
26DB;AI # HEAVY WHITE DOWN-POINTING TRIANGLE
-26DC;AI # LEFT CLOSED ENTRY
+26DC;ID # LEFT CLOSED ENTRY
26DD;AI # SQUARED SALTIRE
26DE;AI # FALLING DIAGONAL IN WHITE CIRCLE IN BLACK SQUARE
-26DF;AI # BLACK TRUCK
-26E0;AI # RESTRICTED LEFT ENTRY-1
-26E1;AI # RESTRICTED LEFT ENTRY-2
+26DF;ID # BLACK TRUCK
+26E0;ID # RESTRICTED LEFT ENTRY-1
+26E1;ID # RESTRICTED LEFT ENTRY-2
26E2;AL # ASTRONOMICAL SYMBOL FOR URANUS
26E3;AI # HEAVY CIRCLE WITH STROKE AND TWO DOTS ABOVE
26E4;AL # PENTAGRAM
@@ -8648,7 +8719,7 @@
26E7;AL # INVERTED PENTAGRAM
26E8;AI # BLACK CROSS ON SHIELD
26E9;AI # SHINTO SHRINE
-26EA;AI # CHURCH
+26EA;ID # CHURCH
26EB;AI # CASTLE
26EC;AI # HISTORIC SITE
26ED;AI # GEAR WITHOUT HUB
@@ -8655,34 +8726,34 @@
26EE;AI # GEAR WITH HANDLES
26EF;AI # MAP SYMBOL FOR LIGHTHOUSE
26F0;AI # MOUNTAIN
-26F1;AI # UMBRELLA ON GROUND
-26F2;AI # FOUNTAIN
-26F3;AI # FLAG IN HOLE
-26F4;AI # FERRY
-26F5;AI # SAILBOAT
+26F1;ID # UMBRELLA ON GROUND
+26F2;ID # FOUNTAIN
+26F3;ID # FLAG IN HOLE
+26F4;ID # FERRY
+26F5;ID # SAILBOAT
26F6;AI # SQUARE FOUR CORNERS
-26F7;AI # SKIER
-26F8;AI # ICE SKATE
-26F9;AI # PERSON WITH BALL
-26FA;AI # TENT
+26F7;ID # SKIER
+26F8;ID # ICE SKATE
+26F9;ID # PERSON WITH BALL
+26FA;ID # TENT
26FB;AI # JAPANESE BANK SYMBOL
26FC;AI # HEADSTONE GRAVEYARD SYMBOL
-26FD;AI # FUEL PUMP
-26FE;AI # CUP ON BLACK SQUARE
-26FF;AI # WHITE FLAG WITH HORIZONTAL MIDDLE BLACK STRIPE
-2701;AL # UPPER BLADE SCISSORS
-2702;AL # BLACK SCISSORS
-2703;AL # LOWER BLADE SCISSORS
-2704;AL # WHITE SCISSORS
+26FD;ID # FUEL PUMP
+26FE;ID # CUP ON BLACK SQUARE
+26FF;ID # WHITE FLAG WITH HORIZONTAL MIDDLE BLACK STRIPE
+2701;ID # UPPER BLADE SCISSORS
+2702;ID # BLACK SCISSORS
+2703;ID # LOWER BLADE SCISSORS
+2704;ID # WHITE SCISSORS
2705;AL # WHITE HEAVY CHECK MARK
2706;AL # TELEPHONE LOCATION SIGN
2707;AL # TAPE DRIVE
-2708;AL # AIRPLANE
-2709;AL # ENVELOPE
-270A;AL # RAISED FIST
-270B;AL # RAISED HAND
-270C;AL # VICTORY HAND
-270D;AL # WRITING HAND
+2708;ID # AIRPLANE
+2709;ID # ENVELOPE
+270A;ID # RAISED FIST
+270B;ID # RAISED HAND
+270C;ID # VICTORY HAND
+270D;ID # WRITING HAND
270E;AL # LOWER RIGHT PENCIL
270F;AL # PENCIL
2710;AL # UPPER RIGHT PENCIL
@@ -8872,7 +8943,9 @@
27C8;AL # REVERSE SOLIDUS PRECEDING SUBSET
27C9;AL # SUPERSET PRECEDING SOLIDUS
27CA;AL # VERTICAL BAR WITH HORIZONTAL STROKE
+27CB;AL # MATHEMATICAL RISING DIAGONAL
27CC;AL # LONG DIVISION
+27CD;AL # MATHEMATICAL FALLING DIAGONAL
27CE;AL # SQUARED LOGICAL AND
27CF;AL # SQUARED LOGICAL OR
27D0;AL # WHITE DIAMOND WITH CENTRED DOT
@@ -10018,6 +10091,8 @@
2CEF;CM # COPTIC COMBINING NI ABOVE
2CF0;CM # COPTIC COMBINING SPIRITUS ASPER
2CF1;CM # COPTIC COMBINING SPIRITUS LENIS
+2CF2;AL # COPTIC CAPITAL LETTER BOHAIRIC KHEI
+2CF3;AL # COPTIC SMALL LETTER BOHAIRIC KHEI
2CF9;EX # COPTIC OLD NUBIAN FULL STOP
2CFA;BA # COPTIC OLD NUBIAN DIRECT QUESTION MARK
2CFB;BA # COPTIC OLD NUBIAN INDIRECT QUESTION MARK
@@ -10063,6 +10138,8 @@
2D23;AL # GEORGIAN SMALL LETTER WE
2D24;AL # GEORGIAN SMALL LETTER HAR
2D25;AL # GEORGIAN SMALL LETTER HOE
+2D27;AL # GEORGIAN SMALL LETTER YN
+2D2D;AL # GEORGIAN SMALL LETTER AEN
2D30;AL # TIFINAGH LETTER YA
2D31;AL # TIFINAGH LETTER YAB
2D32;AL # TIFINAGH LETTER YABH
@@ -10117,6 +10194,8 @@
2D63;AL # TIFINAGH LETTER YAZ
2D64;AL # TIFINAGH LETTER TAWELLEMET YAZ
2D65;AL # TIFINAGH LETTER YAZZ
+2D66;AL # TIFINAGH LETTER YE
+2D67;AL # TIFINAGH LETTER YO
2D6F;AL # TIFINAGH MODIFIER LETTER LABIALIZATION MARK
2D70;BA # TIFINAGH SEPARATOR MARK
2D7F;CM # TIFINAGH CONSONANT JOINER
@@ -10281,6 +10360,16 @@
2E2F;AL # VERTICAL TILDE
2E30;BA # RING POINT
2E31;BA # WORD SEPARATOR MIDDLE DOT
+2E32;AL # TURNED COMMA
+2E33;BA # RAISED DOT
+2E34;BA # RAISED COMMA
+2E35;AL # TURNED SEMICOLON
+2E36;AL # DAGGER WITH LEFT GUARD
+2E37;AL # DAGGER WITH RIGHT GUARD
+2E38;AL # TURNED DAGGER
+2E39;AL # TOP HALF SECTION SIGN
+2E3A;B2 # TWO-EM DASH
+2E3B;B2 # THREE-EM DASH
2E80;ID # CJK RADICAL REPEAT
2E81;ID # CJK RADICAL CLIFF
2E82;ID # CJK RADICAL SECOND ONE
@@ -10686,15 +10775,15 @@
303D;ID # PART ALTERNATION MARK
303E;ID # IDEOGRAPHIC VARIATION INDICATOR
303F;ID # IDEOGRAPHIC HALF FILL SPACE
-3041;NS # HIRAGANA LETTER SMALL A
+3041;CJ # HIRAGANA LETTER SMALL A
3042;ID # HIRAGANA LETTER A
-3043;NS # HIRAGANA LETTER SMALL I
+3043;CJ # HIRAGANA LETTER SMALL I
3044;ID # HIRAGANA LETTER I
-3045;NS # HIRAGANA LETTER SMALL U
+3045;CJ # HIRAGANA LETTER SMALL U
3046;ID # HIRAGANA LETTER U
-3047;NS # HIRAGANA LETTER SMALL E
+3047;CJ # HIRAGANA LETTER SMALL E
3048;ID # HIRAGANA LETTER E
-3049;NS # HIRAGANA LETTER SMALL O
+3049;CJ # HIRAGANA LETTER SMALL O
304A;ID # HIRAGANA LETTER O
304B;ID # HIRAGANA LETTER KA
304C;ID # HIRAGANA LETTER GA
@@ -10720,7 +10809,7 @@
3060;ID # HIRAGANA LETTER DA
3061;ID # HIRAGANA LETTER TI
3062;ID # HIRAGANA LETTER DI
-3063;NS # HIRAGANA LETTER SMALL TU
+3063;CJ # HIRAGANA LETTER SMALL TU
3064;ID # HIRAGANA LETTER TU
3065;ID # HIRAGANA LETTER DU
3066;ID # HIRAGANA LETTER TE
@@ -10752,11 +10841,11 @@
3080;ID # HIRAGANA LETTER MU
3081;ID # HIRAGANA LETTER ME
3082;ID # HIRAGANA LETTER MO
-3083;NS # HIRAGANA LETTER SMALL YA
+3083;CJ # HIRAGANA LETTER SMALL YA
3084;ID # HIRAGANA LETTER YA
-3085;NS # HIRAGANA LETTER SMALL YU
+3085;CJ # HIRAGANA LETTER SMALL YU
3086;ID # HIRAGANA LETTER YU
-3087;NS # HIRAGANA LETTER SMALL YO
+3087;CJ # HIRAGANA LETTER SMALL YO
3088;ID # HIRAGANA LETTER YO
3089;ID # HIRAGANA LETTER RA
308A;ID # HIRAGANA LETTER RI
@@ -10763,7 +10852,7 @@
308B;ID # HIRAGANA LETTER RU
308C;ID # HIRAGANA LETTER RE
308D;ID # HIRAGANA LETTER RO
-308E;NS # HIRAGANA LETTER SMALL WA
+308E;CJ # HIRAGANA LETTER SMALL WA
308F;ID # HIRAGANA LETTER WA
3090;ID # HIRAGANA LETTER WI
3091;ID # HIRAGANA LETTER WE
@@ -10770,8 +10859,8 @@
3092;ID # HIRAGANA LETTER WO
3093;ID # HIRAGANA LETTER N
3094;ID # HIRAGANA LETTER VU
-3095;NS # HIRAGANA LETTER SMALL KA
-3096;NS # HIRAGANA LETTER SMALL KE
+3095;CJ # HIRAGANA LETTER SMALL KA
+3096;CJ # HIRAGANA LETTER SMALL KE
3099;CM # COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK
309A;CM # COMBINING KATAKANA-HIRAGANA SEMI-VOICED SOUND MARK
309B;NS # KATAKANA-HIRAGANA VOICED SOUND MARK
@@ -10780,15 +10869,15 @@
309E;NS # HIRAGANA VOICED ITERATION MARK
309F;ID # HIRAGANA DIGRAPH YORI
30A0;NS # KATAKANA-HIRAGANA DOUBLE HYPHEN
-30A1;NS # KATAKANA LETTER SMALL A
+30A1;CJ # KATAKANA LETTER SMALL A
30A2;ID # KATAKANA LETTER A
-30A3;NS # KATAKANA LETTER SMALL I
+30A3;CJ # KATAKANA LETTER SMALL I
30A4;ID # KATAKANA LETTER I
-30A5;NS # KATAKANA LETTER SMALL U
+30A5;CJ # KATAKANA LETTER SMALL U
30A6;ID # KATAKANA LETTER U
-30A7;NS # KATAKANA LETTER SMALL E
+30A7;CJ # KATAKANA LETTER SMALL E
30A8;ID # KATAKANA LETTER E
-30A9;NS # KATAKANA LETTER SMALL O
+30A9;CJ # KATAKANA LETTER SMALL O
30AA;ID # KATAKANA LETTER O
30AB;ID # KATAKANA LETTER KA
30AC;ID # KATAKANA LETTER GA
@@ -10814,7 +10903,7 @@
30C0;ID # KATAKANA LETTER DA
30C1;ID # KATAKANA LETTER TI
30C2;ID # KATAKANA LETTER DI
-30C3;NS # KATAKANA LETTER SMALL TU
+30C3;CJ # KATAKANA LETTER SMALL TU
30C4;ID # KATAKANA LETTER TU
30C5;ID # KATAKANA LETTER DU
30C6;ID # KATAKANA LETTER TE
@@ -10846,11 +10935,11 @@
30E0;ID # KATAKANA LETTER MU
30E1;ID # KATAKANA LETTER ME
30E2;ID # KATAKANA LETTER MO
-30E3;NS # KATAKANA LETTER SMALL YA
+30E3;CJ # KATAKANA LETTER SMALL YA
30E4;ID # KATAKANA LETTER YA
-30E5;NS # KATAKANA LETTER SMALL YU
+30E5;CJ # KATAKANA LETTER SMALL YU
30E6;ID # KATAKANA LETTER YU
-30E7;NS # KATAKANA LETTER SMALL YO
+30E7;CJ # KATAKANA LETTER SMALL YO
30E8;ID # KATAKANA LETTER YO
30E9;ID # KATAKANA LETTER RA
30EA;ID # KATAKANA LETTER RI
@@ -10857,7 +10946,7 @@
30EB;ID # KATAKANA LETTER RU
30EC;ID # KATAKANA LETTER RE
30ED;ID # KATAKANA LETTER RO
-30EE;NS # KATAKANA LETTER SMALL WA
+30EE;CJ # KATAKANA LETTER SMALL WA
30EF;ID # KATAKANA LETTER WA
30F0;ID # KATAKANA LETTER WI
30F1;ID # KATAKANA LETTER WE
@@ -10864,14 +10953,14 @@
30F2;ID # KATAKANA LETTER WO
30F3;ID # KATAKANA LETTER N
30F4;ID # KATAKANA LETTER VU
-30F5;NS # KATAKANA LETTER SMALL KA
-30F6;NS # KATAKANA LETTER SMALL KE
+30F5;CJ # KATAKANA LETTER SMALL KA
+30F6;CJ # KATAKANA LETTER SMALL KE
30F7;ID # KATAKANA LETTER VA
30F8;ID # KATAKANA LETTER VI
30F9;ID # KATAKANA LETTER VE
30FA;ID # KATAKANA LETTER VO
30FB;NS # KATAKANA MIDDLE DOT
-30FC;NS # KATAKANA-HIRAGANA PROLONGED SOUND MARK
+30FC;CJ # KATAKANA-HIRAGANA PROLONGED SOUND MARK
30FD;NS # KATAKANA ITERATION MARK
30FE;NS # KATAKANA VOICED ITERATION MARK
30FF;ID # KATAKANA DIGRAPH KOTO
@@ -11089,22 +11178,22 @@
31E1;ID # CJK STROKE HZZZG
31E2;ID # CJK STROKE PG
31E3;ID # CJK STROKE Q
-31F0;NS # KATAKANA LETTER SMALL KU
-31F1;NS # KATAKANA LETTER SMALL SI
-31F2;NS # KATAKANA LETTER SMALL SU
-31F3;NS # KATAKANA LETTER SMALL TO
-31F4;NS # KATAKANA LETTER SMALL NU
-31F5;NS # KATAKANA LETTER SMALL HA
-31F6;NS # KATAKANA LETTER SMALL HI
-31F7;NS # KATAKANA LETTER SMALL HU
-31F8;NS # KATAKANA LETTER SMALL HE
-31F9;NS # KATAKANA LETTER SMALL HO
-31FA;NS # KATAKANA LETTER SMALL MU
-31FB;NS # KATAKANA LETTER SMALL RA
-31FC;NS # KATAKANA LETTER SMALL RI
-31FD;NS # KATAKANA LETTER SMALL RU
-31FE;NS # KATAKANA LETTER SMALL RE
-31FF;NS # KATAKANA LETTER SMALL RO
+31F0;CJ # KATAKANA LETTER SMALL KU
+31F1;CJ # KATAKANA LETTER SMALL SI
+31F2;CJ # KATAKANA LETTER SMALL SU
+31F3;CJ # KATAKANA LETTER SMALL TO
+31F4;CJ # KATAKANA LETTER SMALL NU
+31F5;CJ # KATAKANA LETTER SMALL HA
+31F6;CJ # KATAKANA LETTER SMALL HI
+31F7;CJ # KATAKANA LETTER SMALL HU
+31F8;CJ # KATAKANA LETTER SMALL HE
+31F9;CJ # KATAKANA LETTER SMALL HO
+31FA;CJ # KATAKANA LETTER SMALL MU
+31FB;CJ # KATAKANA LETTER SMALL RA
+31FC;CJ # KATAKANA LETTER SMALL RI
+31FD;CJ # KATAKANA LETTER SMALL RU
+31FE;CJ # KATAKANA LETTER SMALL RE
+31FF;CJ # KATAKANA LETTER SMALL RO
3200;ID # PARENTHESIZED HANGUL KIYEOK
3201;ID # PARENTHESIZED HANGUL NIEUN
3202;ID # PARENTHESIZED HANGUL TIKEUT
@@ -11681,8 +11770,8 @@
4DFD;AL # HEXAGRAM FOR SMALL PREPONDERANCE
4DFE;AL # HEXAGRAM FOR AFTER COMPLETION
4DFF;AL # HEXAGRAM FOR BEFORE COMPLETION
-4E00..9FCB;ID # <CJK Ideograph, First>..<CJK Ideograph, Last>
-9FCC..9FFF;ID # <reserved-9FCC>..<reserved-9FFF>
+4E00..9FCC;ID # <CJK Ideograph, First>..<CJK Ideograph, Last>
+9FCD..9FFF;ID # <reserved-9FCD>..<reserved-9FFF>
A000;ID # YI SYLLABLE IT
A001;ID # YI SYLLABLE IX
A002;ID # YI SYLLABLE I
@@ -13303,6 +13392,14 @@
A671;CM # COMBINING CYRILLIC HUNDRED MILLIONS SIGN
A672;CM # COMBINING CYRILLIC THOUSAND MILLIONS SIGN
A673;AL # SLAVONIC ASTERISK
+A674;CM # COMBINING CYRILLIC LETTER UKRAINIAN IE
+A675;CM # COMBINING CYRILLIC LETTER I
+A676;CM # COMBINING CYRILLIC LETTER YI
+A677;CM # COMBINING CYRILLIC LETTER U
+A678;CM # COMBINING CYRILLIC LETTER HARD SIGN
+A679;CM # COMBINING CYRILLIC LETTER YERU
+A67A;CM # COMBINING CYRILLIC LETTER SOFT SIGN
+A67B;CM # COMBINING CYRILLIC LETTER OMEGA
A67C;CM # COMBINING CYRILLIC KAVYKA
A67D;CM # COMBINING CYRILLIC PAYEROK
A67E;AL # CYRILLIC KAVYKA
@@ -13331,6 +13428,7 @@
A695;AL # CYRILLIC SMALL LETTER HWE
A696;AL # CYRILLIC CAPITAL LETTER SHWE
A697;AL # CYRILLIC SMALL LETTER SHWE
+A69F;CM # COMBINING CYRILLIC LETTER IOTIFIED E
A6A0;AL # BAMUM LETTER A
A6A1;AL # BAMUM LETTER KA
A6A2;AL # BAMUM LETTER U
@@ -13564,6 +13662,8 @@
A78E;AL # LATIN SMALL LETTER L WITH RETROFLEX HOOK AND BELT
A790;AL # LATIN CAPITAL LETTER N WITH DESCENDER
A791;AL # LATIN SMALL LETTER N WITH DESCENDER
+A792;AL # LATIN CAPITAL LETTER C WITH BAR
+A793;AL # LATIN SMALL LETTER C WITH BAR
A7A0;AL # LATIN CAPITAL LETTER G WITH OBLIQUE STROKE
A7A1;AL # LATIN SMALL LETTER G WITH OBLIQUE STROKE
A7A2;AL # LATIN CAPITAL LETTER K WITH OBLIQUE STROKE
@@ -13574,6 +13674,9 @@
A7A7;AL # LATIN SMALL LETTER R WITH OBLIQUE STROKE
A7A8;AL # LATIN CAPITAL LETTER S WITH OBLIQUE STROKE
A7A9;AL # LATIN SMALL LETTER S WITH OBLIQUE STROKE
+A7AA;AL # LATIN CAPITAL LETTER H WITH HOOK
+A7F8;AL # MODIFIER LETTER CAPITAL H WITH STROKE
+A7F9;AL # MODIFIER LETTER SMALL LIGATURE OE
A7FA;AL # LATIN LETTER SMALL CAPITAL TURNED M
A7FB;AL # LATIN EPIGRAPHIC LETTER REVERSED F
A7FC;AL # LATIN EPIGRAPHIC LETTER REVERSED P
@@ -14187,6 +14290,29 @@
AADD;SA # TAI VIET SYMBOL SAM
AADE;SA # TAI VIET SYMBOL HO HOI
AADF;SA # TAI VIET SYMBOL KOI KOI
+AAE0;AL # MEETEI MAYEK LETTER E
+AAE1;AL # MEETEI MAYEK LETTER O
+AAE2;AL # MEETEI MAYEK LETTER CHA
+AAE3;AL # MEETEI MAYEK LETTER NYA
+AAE4;AL # MEETEI MAYEK LETTER TTA
+AAE5;AL # MEETEI MAYEK LETTER TTHA
+AAE6;AL # MEETEI MAYEK LETTER DDA
+AAE7;AL # MEETEI MAYEK LETTER DDHA
+AAE8;AL # MEETEI MAYEK LETTER NNA
+AAE9;AL # MEETEI MAYEK LETTER SHA
+AAEA;AL # MEETEI MAYEK LETTER SSA
+AAEB;CM # MEETEI MAYEK VOWEL SIGN II
+AAEC;CM # MEETEI MAYEK VOWEL SIGN UU
+AAED;CM # MEETEI MAYEK VOWEL SIGN AAI
+AAEE;CM # MEETEI MAYEK VOWEL SIGN AU
+AAEF;CM # MEETEI MAYEK VOWEL SIGN AAU
+AAF0;BA # MEETEI MAYEK CHEIKHAN
+AAF1;BA # MEETEI MAYEK AHANG KHUDAM
+AAF2;AL # MEETEI MAYEK ANJI
+AAF3;AL # MEETEI MAYEK SYLLABLE REPETITION MARK
+AAF4;AL # MEETEI MAYEK WORD REPETITION MARK
+AAF5;CM # MEETEI MAYEK VOWEL SIGN VISARGA
+AAF6;CM # MEETEI MAYEK VIRAMA
AB01;AL # ETHIOPIC SYLLABLE TTHU
AB02;AL # ETHIOPIC SYLLABLE TTHI
AB03;AL # ETHIOPIC SYLLABLE TTHAA
@@ -15451,7 +15577,8 @@
FA2B;ID # CJK COMPATIBILITY IDEOGRAPH-FA2B
FA2C;ID # CJK COMPATIBILITY IDEOGRAPH-FA2C
FA2D;ID # CJK COMPATIBILITY IDEOGRAPH-FA2D
-FA2E..FA2F;ID # <reserved-FA2E>..<reserved-FA2F>
+FA2E;ID # CJK COMPATIBILITY IDEOGRAPH-FA2E
+FA2F;ID # CJK COMPATIBILITY IDEOGRAPH-FA2F
FA30;ID # CJK COMPATIBILITY IDEOGRAPH-FA30
FA31;ID # CJK COMPATIBILITY IDEOGRAPH-FA31
FA32;ID # CJK COMPATIBILITY IDEOGRAPH-FA32
@@ -15634,52 +15761,52 @@
FB15;AL # ARMENIAN SMALL LIGATURE MEN INI
FB16;AL # ARMENIAN SMALL LIGATURE VEW NOW
FB17;AL # ARMENIAN SMALL LIGATURE MEN XEH
-FB1D;AL # HEBREW LETTER YOD WITH HIRIQ
+FB1D;HL # HEBREW LETTER YOD WITH HIRIQ
FB1E;CM # HEBREW POINT JUDEO-SPANISH VARIKA
-FB1F;AL # HEBREW LIGATURE YIDDISH YOD YOD PATAH
-FB20;AL # HEBREW LETTER ALTERNATIVE AYIN
-FB21;AL # HEBREW LETTER WIDE ALEF
-FB22;AL # HEBREW LETTER WIDE DALET
-FB23;AL # HEBREW LETTER WIDE HE
-FB24;AL # HEBREW LETTER WIDE KAF
-FB25;AL # HEBREW LETTER WIDE LAMED
-FB26;AL # HEBREW LETTER WIDE FINAL MEM
-FB27;AL # HEBREW LETTER WIDE RESH
-FB28;AL # HEBREW LETTER WIDE TAV
+FB1F;HL # HEBREW LIGATURE YIDDISH YOD YOD PATAH
+FB20;HL # HEBREW LETTER ALTERNATIVE AYIN
+FB21;HL # HEBREW LETTER WIDE ALEF
+FB22;HL # HEBREW LETTER WIDE DALET
+FB23;HL # HEBREW LETTER WIDE HE
+FB24;HL # HEBREW LETTER WIDE KAF
+FB25;HL # HEBREW LETTER WIDE LAMED
+FB26;HL # HEBREW LETTER WIDE FINAL MEM
+FB27;HL # HEBREW LETTER WIDE RESH
+FB28;HL # HEBREW LETTER WIDE TAV
FB29;AL # HEBREW LETTER ALTERNATIVE PLUS SIGN
-FB2A;AL # HEBREW LETTER SHIN WITH SHIN DOT
-FB2B;AL # HEBREW LETTER SHIN WITH SIN DOT
-FB2C;AL # HEBREW LETTER SHIN WITH DAGESH AND SHIN DOT
-FB2D;AL # HEBREW LETTER SHIN WITH DAGESH AND SIN DOT
-FB2E;AL # HEBREW LETTER ALEF WITH PATAH
-FB2F;AL # HEBREW LETTER ALEF WITH QAMATS
-FB30;AL # HEBREW LETTER ALEF WITH MAPIQ
-FB31;AL # HEBREW LETTER BET WITH DAGESH
-FB32;AL # HEBREW LETTER GIMEL WITH DAGESH
-FB33;AL # HEBREW LETTER DALET WITH DAGESH
-FB34;AL # HEBREW LETTER HE WITH MAPIQ
-FB35;AL # HEBREW LETTER VAV WITH DAGESH
-FB36;AL # HEBREW LETTER ZAYIN WITH DAGESH
-FB38;AL # HEBREW LETTER TET WITH DAGESH
-FB39;AL # HEBREW LETTER YOD WITH DAGESH
-FB3A;AL # HEBREW LETTER FINAL KAF WITH DAGESH
-FB3B;AL # HEBREW LETTER KAF WITH DAGESH
-FB3C;AL # HEBREW LETTER LAMED WITH DAGESH
-FB3E;AL # HEBREW LETTER MEM WITH DAGESH
-FB40;AL # HEBREW LETTER NUN WITH DAGESH
-FB41;AL # HEBREW LETTER SAMEKH WITH DAGESH
-FB43;AL # HEBREW LETTER FINAL PE WITH DAGESH
-FB44;AL # HEBREW LETTER PE WITH DAGESH
-FB46;AL # HEBREW LETTER TSADI WITH DAGESH
-FB47;AL # HEBREW LETTER QOF WITH DAGESH
-FB48;AL # HEBREW LETTER RESH WITH DAGESH
-FB49;AL # HEBREW LETTER SHIN WITH DAGESH
-FB4A;AL # HEBREW LETTER TAV WITH DAGESH
-FB4B;AL # HEBREW LETTER VAV WITH HOLAM
-FB4C;AL # HEBREW LETTER BET WITH RAFE
-FB4D;AL # HEBREW LETTER KAF WITH RAFE
-FB4E;AL # HEBREW LETTER PE WITH RAFE
-FB4F;AL # HEBREW LIGATURE ALEF LAMED
+FB2A;HL # HEBREW LETTER SHIN WITH SHIN DOT
+FB2B;HL # HEBREW LETTER SHIN WITH SIN DOT
+FB2C;HL # HEBREW LETTER SHIN WITH DAGESH AND SHIN DOT
+FB2D;HL # HEBREW LETTER SHIN WITH DAGESH AND SIN DOT
+FB2E;HL # HEBREW LETTER ALEF WITH PATAH
+FB2F;HL # HEBREW LETTER ALEF WITH QAMATS
+FB30;HL # HEBREW LETTER ALEF WITH MAPIQ
+FB31;HL # HEBREW LETTER BET WITH DAGESH
+FB32;HL # HEBREW LETTER GIMEL WITH DAGESH
+FB33;HL # HEBREW LETTER DALET WITH DAGESH
+FB34;HL # HEBREW LETTER HE WITH MAPIQ
+FB35;HL # HEBREW LETTER VAV WITH DAGESH
+FB36;HL # HEBREW LETTER ZAYIN WITH DAGESH
+FB38;HL # HEBREW LETTER TET WITH DAGESH
+FB39;HL # HEBREW LETTER YOD WITH DAGESH
+FB3A;HL # HEBREW LETTER FINAL KAF WITH DAGESH
+FB3B;HL # HEBREW LETTER KAF WITH DAGESH
+FB3C;HL # HEBREW LETTER LAMED WITH DAGESH
+FB3E;HL # HEBREW LETTER MEM WITH DAGESH
+FB40;HL # HEBREW LETTER NUN WITH DAGESH
+FB41;HL # HEBREW LETTER SAMEKH WITH DAGESH
+FB43;HL # HEBREW LETTER FINAL PE WITH DAGESH
+FB44;HL # HEBREW LETTER PE WITH DAGESH
+FB46;HL # HEBREW LETTER TSADI WITH DAGESH
+FB47;HL # HEBREW LETTER QOF WITH DAGESH
+FB48;HL # HEBREW LETTER RESH WITH DAGESH
+FB49;HL # HEBREW LETTER SHIN WITH DAGESH
+FB4A;HL # HEBREW LETTER TAV WITH DAGESH
+FB4B;HL # HEBREW LETTER VAV WITH HOLAM
+FB4C;HL # HEBREW LETTER BET WITH RAFE
+FB4D;HL # HEBREW LETTER KAF WITH RAFE
+FB4E;HL # HEBREW LETTER PE WITH RAFE
+FB4F;HL # HEBREW LIGATURE ALEF LAMED
FB50;AL # ARABIC LETTER ALEF WASLA ISOLATED FORM
FB51;AL # ARABIC LETTER ALEF WASLA FINAL FORM
FB52;AL # ARABIC LETTER BEEH ISOLATED FORM
@@ -16625,16 +16752,16 @@
FF64;CL # HALFWIDTH IDEOGRAPHIC COMMA
FF65;NS # HALFWIDTH KATAKANA MIDDLE DOT
FF66;AL # HALFWIDTH KATAKANA LETTER WO
-FF67;NS # HALFWIDTH KATAKANA LETTER SMALL A
-FF68;NS # HALFWIDTH KATAKANA LETTER SMALL I
-FF69;NS # HALFWIDTH KATAKANA LETTER SMALL U
-FF6A;NS # HALFWIDTH KATAKANA LETTER SMALL E
-FF6B;NS # HALFWIDTH KATAKANA LETTER SMALL O
-FF6C;NS # HALFWIDTH KATAKANA LETTER SMALL YA
-FF6D;NS # HALFWIDTH KATAKANA LETTER SMALL YU
-FF6E;NS # HALFWIDTH KATAKANA LETTER SMALL YO
-FF6F;NS # HALFWIDTH KATAKANA LETTER SMALL TU
-FF70;NS # HALFWIDTH KATAKANA-HIRAGANA PROLONGED SOUND MARK
+FF67;CJ # HALFWIDTH KATAKANA LETTER SMALL A
+FF68;CJ # HALFWIDTH KATAKANA LETTER SMALL I
+FF69;CJ # HALFWIDTH KATAKANA LETTER SMALL U
+FF6A;CJ # HALFWIDTH KATAKANA LETTER SMALL E
+FF6B;CJ # HALFWIDTH KATAKANA LETTER SMALL O
+FF6C;CJ # HALFWIDTH KATAKANA LETTER SMALL YA
+FF6D;CJ # HALFWIDTH KATAKANA LETTER SMALL YU
+FF6E;CJ # HALFWIDTH KATAKANA LETTER SMALL YO
+FF6F;CJ # HALFWIDTH KATAKANA LETTER SMALL TU
+FF70;CJ # HALFWIDTH KATAKANA-HIRAGANA PROLONGED SOUND MARK
FF71;AL # HALFWIDTH KATAKANA LETTER A
FF72;AL # HALFWIDTH KATAKANA LETTER I
FF73;AL # HALFWIDTH KATAKANA LETTER U
@@ -17685,6 +17812,64 @@
10938;AL # LYDIAN LETTER NN
10939;AL # LYDIAN LETTER C
1093F;AL # LYDIAN TRIANGULAR MARK
+10980;AL # MEROITIC HIEROGLYPHIC LETTER A
+10981;AL # MEROITIC HIEROGLYPHIC LETTER E
+10982;AL # MEROITIC HIEROGLYPHIC LETTER I
+10983;AL # MEROITIC HIEROGLYPHIC LETTER O
+10984;AL # MEROITIC HIEROGLYPHIC LETTER YA
+10985;AL # MEROITIC HIEROGLYPHIC LETTER WA
+10986;AL # MEROITIC HIEROGLYPHIC LETTER BA
+10987;AL # MEROITIC HIEROGLYPHIC LETTER BA-2
+10988;AL # MEROITIC HIEROGLYPHIC LETTER PA
+10989;AL # MEROITIC HIEROGLYPHIC LETTER MA
+1098A;AL # MEROITIC HIEROGLYPHIC LETTER NA
+1098B;AL # MEROITIC HIEROGLYPHIC LETTER NA-2
+1098C;AL # MEROITIC HIEROGLYPHIC LETTER NE
+1098D;AL # MEROITIC HIEROGLYPHIC LETTER NE-2
+1098E;AL # MEROITIC HIEROGLYPHIC LETTER RA
+1098F;AL # MEROITIC HIEROGLYPHIC LETTER RA-2
+10990;AL # MEROITIC HIEROGLYPHIC LETTER LA
+10991;AL # MEROITIC HIEROGLYPHIC LETTER KHA
+10992;AL # MEROITIC HIEROGLYPHIC LETTER HHA
+10993;AL # MEROITIC HIEROGLYPHIC LETTER SA
+10994;AL # MEROITIC HIEROGLYPHIC LETTER SA-2
+10995;AL # MEROITIC HIEROGLYPHIC LETTER SE
+10996;AL # MEROITIC HIEROGLYPHIC LETTER KA
+10997;AL # MEROITIC HIEROGLYPHIC LETTER QA
+10998;AL # MEROITIC HIEROGLYPHIC LETTER TA
+10999;AL # MEROITIC HIEROGLYPHIC LETTER TA-2
+1099A;AL # MEROITIC HIEROGLYPHIC LETTER TE
+1099B;AL # MEROITIC HIEROGLYPHIC LETTER TE-2
+1099C;AL # MEROITIC HIEROGLYPHIC LETTER TO
+1099D;AL # MEROITIC HIEROGLYPHIC LETTER DA
+1099E;AL # MEROITIC HIEROGLYPHIC SYMBOL VIDJ
+1099F;AL # MEROITIC HIEROGLYPHIC SYMBOL VIDJ-2
+109A0;AL # MEROITIC CURSIVE LETTER A
+109A1;AL # MEROITIC CURSIVE LETTER E
+109A2;AL # MEROITIC CURSIVE LETTER I
+109A3;AL # MEROITIC CURSIVE LETTER O
+109A4;AL # MEROITIC CURSIVE LETTER YA
+109A5;AL # MEROITIC CURSIVE LETTER WA
+109A6;AL # MEROITIC CURSIVE LETTER BA
+109A7;AL # MEROITIC CURSIVE LETTER PA
+109A8;AL # MEROITIC CURSIVE LETTER MA
+109A9;AL # MEROITIC CURSIVE LETTER NA
+109AA;AL # MEROITIC CURSIVE LETTER NE
+109AB;AL # MEROITIC CURSIVE LETTER RA
+109AC;AL # MEROITIC CURSIVE LETTER LA
+109AD;AL # MEROITIC CURSIVE LETTER KHA
+109AE;AL # MEROITIC CURSIVE LETTER HHA
+109AF;AL # MEROITIC CURSIVE LETTER SA
+109B0;AL # MEROITIC CURSIVE LETTER ARCHAIC SA
+109B1;AL # MEROITIC CURSIVE LETTER SE
+109B2;AL # MEROITIC CURSIVE LETTER KA
+109B3;AL # MEROITIC CURSIVE LETTER QA
+109B4;AL # MEROITIC CURSIVE LETTER TA
+109B5;AL # MEROITIC CURSIVE LETTER TE
+109B6;AL # MEROITIC CURSIVE LETTER TO
+109B7;AL # MEROITIC CURSIVE LETTER DA
+109BE;AL # MEROITIC CURSIVE LOGOGRAM RMT
+109BF;AL # MEROITIC CURSIVE LOGOGRAM IMN
10A00;AL # KHAROSHTHI LETTER A
10A01;CM # KHAROSHTHI VOWEL SIGN I
10A02;CM # KHAROSHTHI VOWEL SIGN U
@@ -18178,6 +18363,257 @@
110BF;BA # KAITHI DOUBLE SECTION MARK
110C0;BA # KAITHI DANDA
110C1;BA # KAITHI DOUBLE DANDA
+110D0;AL # SORA SOMPENG LETTER SAH
+110D1;AL # SORA SOMPENG LETTER TAH
+110D2;AL # SORA SOMPENG LETTER BAH
+110D3;AL # SORA SOMPENG LETTER CAH
+110D4;AL # SORA SOMPENG LETTER DAH
+110D5;AL # SORA SOMPENG LETTER GAH
+110D6;AL # SORA SOMPENG LETTER MAH
+110D7;AL # SORA SOMPENG LETTER NGAH
+110D8;AL # SORA SOMPENG LETTER LAH
+110D9;AL # SORA SOMPENG LETTER NAH
+110DA;AL # SORA SOMPENG LETTER VAH
+110DB;AL # SORA SOMPENG LETTER PAH
+110DC;AL # SORA SOMPENG LETTER YAH
+110DD;AL # SORA SOMPENG LETTER RAH
+110DE;AL # SORA SOMPENG LETTER HAH
+110DF;AL # SORA SOMPENG LETTER KAH
+110E0;AL # SORA SOMPENG LETTER JAH
+110E1;AL # SORA SOMPENG LETTER NYAH
+110E2;AL # SORA SOMPENG LETTER AH
+110E3;AL # SORA SOMPENG LETTER EEH
+110E4;AL # SORA SOMPENG LETTER IH
+110E5;AL # SORA SOMPENG LETTER UH
+110E6;AL # SORA SOMPENG LETTER OH
+110E7;AL # SORA SOMPENG LETTER EH
+110E8;AL # SORA SOMPENG LETTER MAE
+110F0;NU # SORA SOMPENG DIGIT ZERO
+110F1;NU # SORA SOMPENG DIGIT ONE
+110F2;NU # SORA SOMPENG DIGIT TWO
+110F3;NU # SORA SOMPENG DIGIT THREE
+110F4;NU # SORA SOMPENG DIGIT FOUR
+110F5;NU # SORA SOMPENG DIGIT FIVE
+110F6;NU # SORA SOMPENG DIGIT SIX
+110F7;NU # SORA SOMPENG DIGIT SEVEN
+110F8;NU # SORA SOMPENG DIGIT EIGHT
+110F9;NU # SORA SOMPENG DIGIT NINE
+11100;CM # CHAKMA SIGN CANDRABINDU
+11101;CM # CHAKMA SIGN ANUSVARA
+11102;CM # CHAKMA SIGN VISARGA
+11103;AL # CHAKMA LETTER AA
+11104;AL # CHAKMA LETTER I
+11105;AL # CHAKMA LETTER U
+11106;AL # CHAKMA LETTER E
+11107;AL # CHAKMA LETTER KAA
+11108;AL # CHAKMA LETTER KHAA
+11109;AL # CHAKMA LETTER GAA
+1110A;AL # CHAKMA LETTER GHAA
+1110B;AL # CHAKMA LETTER NGAA
+1110C;AL # CHAKMA LETTER CAA
+1110D;AL # CHAKMA LETTER CHAA
+1110E;AL # CHAKMA LETTER JAA
+1110F;AL # CHAKMA LETTER JHAA
+11110;AL # CHAKMA LETTER NYAA
+11111;AL # CHAKMA LETTER TTAA
+11112;AL # CHAKMA LETTER TTHAA
+11113;AL # CHAKMA LETTER DDAA
+11114;AL # CHAKMA LETTER DDHAA
+11115;AL # CHAKMA LETTER NNAA
+11116;AL # CHAKMA LETTER TAA
+11117;AL # CHAKMA LETTER THAA
+11118;AL # CHAKMA LETTER DAA
+11119;AL # CHAKMA LETTER DHAA
+1111A;AL # CHAKMA LETTER NAA
+1111B;AL # CHAKMA LETTER PAA
+1111C;AL # CHAKMA LETTER PHAA
+1111D;AL # CHAKMA LETTER BAA
+1111E;AL # CHAKMA LETTER BHAA
+1111F;AL # CHAKMA LETTER MAA
+11120;AL # CHAKMA LETTER YYAA
+11121;AL # CHAKMA LETTER YAA
+11122;AL # CHAKMA LETTER RAA
+11123;AL # CHAKMA LETTER LAA
+11124;AL # CHAKMA LETTER WAA
+11125;AL # CHAKMA LETTER SAA
+11126;AL # CHAKMA LETTER HAA
+11127;CM # CHAKMA VOWEL SIGN A
+11128;CM # CHAKMA VOWEL SIGN I
+11129;CM # CHAKMA VOWEL SIGN II
+1112A;CM # CHAKMA VOWEL SIGN U
+1112B;CM # CHAKMA VOWEL SIGN UU
+1112C;CM # CHAKMA VOWEL SIGN E
+1112D;CM # CHAKMA VOWEL SIGN AI
+1112E;CM # CHAKMA VOWEL SIGN O
+1112F;CM # CHAKMA VOWEL SIGN AU
+11130;CM # CHAKMA VOWEL SIGN OI
+11131;CM # CHAKMA O MARK
+11132;CM # CHAKMA AU MARK
+11133;CM # CHAKMA VIRAMA
+11134;CM # CHAKMA MAAYYAA
+11136;NU # CHAKMA DIGIT ZERO
+11137;NU # CHAKMA DIGIT ONE
+11138;NU # CHAKMA DIGIT TWO
+11139;NU # CHAKMA DIGIT THREE
+1113A;NU # CHAKMA DIGIT FOUR
+1113B;NU # CHAKMA DIGIT FIVE
+1113C;NU # CHAKMA DIGIT SIX
+1113D;NU # CHAKMA DIGIT SEVEN
+1113E;NU # CHAKMA DIGIT EIGHT
+1113F;NU # CHAKMA DIGIT NINE
+11140;BA # CHAKMA SECTION MARK
+11141;BA # CHAKMA DANDA
+11142;BA # CHAKMA DOUBLE DANDA
+11143;BA # CHAKMA QUESTION MARK
+11180;CM # SHARADA SIGN CANDRABINDU
+11181;CM # SHARADA SIGN ANUSVARA
+11182;CM # SHARADA SIGN VISARGA
+11183;AL # SHARADA LETTER A
+11184;AL # SHARADA LETTER AA
+11185;AL # SHARADA LETTER I
+11186;AL # SHARADA LETTER II
+11187;AL # SHARADA LETTER U
+11188;AL # SHARADA LETTER UU
+11189;AL # SHARADA LETTER VOCALIC R
+1118A;AL # SHARADA LETTER VOCALIC RR
+1118B;AL # SHARADA LETTER VOCALIC L
+1118C;AL # SHARADA LETTER VOCALIC LL
+1118D;AL # SHARADA LETTER E
+1118E;AL # SHARADA LETTER AI
+1118F;AL # SHARADA LETTER O
+11190;AL # SHARADA LETTER AU
+11191;AL # SHARADA LETTER KA
+11192;AL # SHARADA LETTER KHA
+11193;AL # SHARADA LETTER GA
+11194;AL # SHARADA LETTER GHA
+11195;AL # SHARADA LETTER NGA
+11196;AL # SHARADA LETTER CA
+11197;AL # SHARADA LETTER CHA
+11198;AL # SHARADA LETTER JA
+11199;AL # SHARADA LETTER JHA
+1119A;AL # SHARADA LETTER NYA
+1119B;AL # SHARADA LETTER TTA
+1119C;AL # SHARADA LETTER TTHA
+1119D;AL # SHARADA LETTER DDA
+1119E;AL # SHARADA LETTER DDHA
+1119F;AL # SHARADA LETTER NNA
+111A0;AL # SHARADA LETTER TA
+111A1;AL # SHARADA LETTER THA
+111A2;AL # SHARADA LETTER DA
+111A3;AL # SHARADA LETTER DHA
+111A4;AL # SHARADA LETTER NA
+111A5;AL # SHARADA LETTER PA
+111A6;AL # SHARADA LETTER PHA
+111A7;AL # SHARADA LETTER BA
+111A8;AL # SHARADA LETTER BHA
+111A9;AL # SHARADA LETTER MA
+111AA;AL # SHARADA LETTER YA
+111AB;AL # SHARADA LETTER RA
+111AC;AL # SHARADA LETTER LA
+111AD;AL # SHARADA LETTER LLA
+111AE;AL # SHARADA LETTER VA
+111AF;AL # SHARADA LETTER SHA
+111B0;AL # SHARADA LETTER SSA
+111B1;AL # SHARADA LETTER SA
+111B2;AL # SHARADA LETTER HA
+111B3;CM # SHARADA VOWEL SIGN AA
+111B4;CM # SHARADA VOWEL SIGN I
+111B5;CM # SHARADA VOWEL SIGN II
+111B6;CM # SHARADA VOWEL SIGN U
+111B7;CM # SHARADA VOWEL SIGN UU
+111B8;CM # SHARADA VOWEL SIGN VOCALIC R
+111B9;CM # SHARADA VOWEL SIGN VOCALIC RR
+111BA;CM # SHARADA VOWEL SIGN VOCALIC L
+111BB;CM # SHARADA VOWEL SIGN VOCALIC LL
+111BC;CM # SHARADA VOWEL SIGN E
+111BD;CM # SHARADA VOWEL SIGN AI
+111BE;CM # SHARADA VOWEL SIGN O
+111BF;CM # SHARADA VOWEL SIGN AU
+111C0;CM # SHARADA SIGN VIRAMA
+111C1;AL # SHARADA SIGN AVAGRAHA
+111C2;AL # SHARADA SIGN JIHVAMULIYA
+111C3;AL # SHARADA SIGN UPADHMANIYA
+111C4;AL # SHARADA OM
+111C5;BA # SHARADA DANDA
+111C6;BA # SHARADA DOUBLE DANDA
+111C7;AL # SHARADA ABBREVIATION SIGN
+111C8;BA # SHARADA SEPARATOR
+111D0;NU # SHARADA DIGIT ZERO
+111D1;NU # SHARADA DIGIT ONE
+111D2;NU # SHARADA DIGIT TWO
+111D3;NU # SHARADA DIGIT THREE
+111D4;NU # SHARADA DIGIT FOUR
+111D5;NU # SHARADA DIGIT FIVE
+111D6;NU # SHARADA DIGIT SIX
+111D7;NU # SHARADA DIGIT SEVEN
+111D8;NU # SHARADA DIGIT EIGHT
+111D9;NU # SHARADA DIGIT NINE
+11680;AL # TAKRI LETTER A
+11681;AL # TAKRI LETTER AA
+11682;AL # TAKRI LETTER I
+11683;AL # TAKRI LETTER II
+11684;AL # TAKRI LETTER U
+11685;AL # TAKRI LETTER UU
+11686;AL # TAKRI LETTER E
+11687;AL # TAKRI LETTER AI
+11688;AL # TAKRI LETTER O
+11689;AL # TAKRI LETTER AU
+1168A;AL # TAKRI LETTER KA
+1168B;AL # TAKRI LETTER KHA
+1168C;AL # TAKRI LETTER GA
+1168D;AL # TAKRI LETTER GHA
+1168E;AL # TAKRI LETTER NGA
+1168F;AL # TAKRI LETTER CA
+11690;AL # TAKRI LETTER CHA
+11691;AL # TAKRI LETTER JA
+11692;AL # TAKRI LETTER JHA
+11693;AL # TAKRI LETTER NYA
+11694;AL # TAKRI LETTER TTA
+11695;AL # TAKRI LETTER TTHA
+11696;AL # TAKRI LETTER DDA
+11697;AL # TAKRI LETTER DDHA
+11698;AL # TAKRI LETTER NNA
+11699;AL # TAKRI LETTER TA
+1169A;AL # TAKRI LETTER THA
+1169B;AL # TAKRI LETTER DA
+1169C;AL # TAKRI LETTER DHA
+1169D;AL # TAKRI LETTER NA
+1169E;AL # TAKRI LETTER PA
+1169F;AL # TAKRI LETTER PHA
+116A0;AL # TAKRI LETTER BA
+116A1;AL # TAKRI LETTER BHA
+116A2;AL # TAKRI LETTER MA
+116A3;AL # TAKRI LETTER YA
+116A4;AL # TAKRI LETTER RA
+116A5;AL # TAKRI LETTER LA
+116A6;AL # TAKRI LETTER VA
+116A7;AL # TAKRI LETTER SHA
+116A8;AL # TAKRI LETTER SA
+116A9;AL # TAKRI LETTER HA
+116AA;AL # TAKRI LETTER RRA
+116AB;CM # TAKRI SIGN ANUSVARA
+116AC;CM # TAKRI SIGN VISARGA
+116AD;CM # TAKRI VOWEL SIGN AA
+116AE;CM # TAKRI VOWEL SIGN I
+116AF;CM # TAKRI VOWEL SIGN II
+116B0;CM # TAKRI VOWEL SIGN U
+116B1;CM # TAKRI VOWEL SIGN UU
+116B2;CM # TAKRI VOWEL SIGN E
+116B3;CM # TAKRI VOWEL SIGN AI
+116B4;CM # TAKRI VOWEL SIGN O
+116B5;CM # TAKRI VOWEL SIGN AU
+116B6;CM # TAKRI SIGN VIRAMA
+116B7;CM # TAKRI SIGN NUKTA
+116C0;NU # TAKRI DIGIT ZERO
+116C1;NU # TAKRI DIGIT ONE
+116C2;NU # TAKRI DIGIT TWO
+116C3;NU # TAKRI DIGIT THREE
+116C4;NU # TAKRI DIGIT FOUR
+116C5;NU # TAKRI DIGIT FIVE
+116C6;NU # TAKRI DIGIT SIX
+116C7;NU # TAKRI DIGIT SEVEN
+116C8;NU # TAKRI DIGIT EIGHT
+116C9;NU # TAKRI DIGIT NINE
12000;AL # CUNEIFORM SIGN A
12001;AL # CUNEIFORM SIGN A TIMES A
12002;AL # CUNEIFORM SIGN A TIMES BAD
@@ -20800,6 +21236,139 @@
16A36;AL # BAMUM LETTER PHASE-F KPA
16A37;AL # BAMUM LETTER PHASE-F SAMBA
16A38;AL # BAMUM LETTER PHASE-F VUEQ
+16F00;AL # MIAO LETTER PA
+16F01;AL # MIAO LETTER BA
+16F02;AL # MIAO LETTER YI PA
+16F03;AL # MIAO LETTER PLA
+16F04;AL # MIAO LETTER MA
+16F05;AL # MIAO LETTER MHA
+16F06;AL # MIAO LETTER ARCHAIC MA
+16F07;AL # MIAO LETTER FA
+16F08;AL # MIAO LETTER VA
+16F09;AL # MIAO LETTER VFA
+16F0A;AL # MIAO LETTER TA
+16F0B;AL # MIAO LETTER DA
+16F0C;AL # MIAO LETTER YI TTA
+16F0D;AL # MIAO LETTER YI TA
+16F0E;AL # MIAO LETTER TTA
+16F0F;AL # MIAO LETTER DDA
+16F10;AL # MIAO LETTER NA
+16F11;AL # MIAO LETTER NHA
+16F12;AL # MIAO LETTER YI NNA
+16F13;AL # MIAO LETTER ARCHAIC NA
+16F14;AL # MIAO LETTER NNA
+16F15;AL # MIAO LETTER NNHA
+16F16;AL # MIAO LETTER LA
+16F17;AL # MIAO LETTER LYA
+16F18;AL # MIAO LETTER LHA
+16F19;AL # MIAO LETTER LHYA
+16F1A;AL # MIAO LETTER TLHA
+16F1B;AL # MIAO LETTER DLHA
+16F1C;AL # MIAO LETTER TLHYA
+16F1D;AL # MIAO LETTER DLHYA
+16F1E;AL # MIAO LETTER KA
+16F1F;AL # MIAO LETTER GA
+16F20;AL # MIAO LETTER YI KA
+16F21;AL # MIAO LETTER QA
+16F22;AL # MIAO LETTER QGA
+16F23;AL # MIAO LETTER NGA
+16F24;AL # MIAO LETTER NGHA
+16F25;AL # MIAO LETTER ARCHAIC NGA
+16F26;AL # MIAO LETTER HA
+16F27;AL # MIAO LETTER XA
+16F28;AL # MIAO LETTER GHA
+16F29;AL # MIAO LETTER GHHA
+16F2A;AL # MIAO LETTER TSSA
+16F2B;AL # MIAO LETTER DZZA
+16F2C;AL # MIAO LETTER NYA
+16F2D;AL # MIAO LETTER NYHA
+16F2E;AL # MIAO LETTER TSHA
+16F2F;AL # MIAO LETTER DZHA
+16F30;AL # MIAO LETTER YI TSHA
+16F31;AL # MIAO LETTER YI DZHA
+16F32;AL # MIAO LETTER REFORMED TSHA
+16F33;AL # MIAO LETTER SHA
+16F34;AL # MIAO LETTER SSA
+16F35;AL # MIAO LETTER ZHA
+16F36;AL # MIAO LETTER ZSHA
+16F37;AL # MIAO LETTER TSA
+16F38;AL # MIAO LETTER DZA
+16F39;AL # MIAO LETTER YI TSA
+16F3A;AL # MIAO LETTER SA
+16F3B;AL # MIAO LETTER ZA
+16F3C;AL # MIAO LETTER ZSA
+16F3D;AL # MIAO LETTER ZZA
+16F3E;AL # MIAO LETTER ZZSA
+16F3F;AL # MIAO LETTER ARCHAIC ZZA
+16F40;AL # MIAO LETTER ZZYA
+16F41;AL # MIAO LETTER ZZSYA
+16F42;AL # MIAO LETTER WA
+16F43;AL # MIAO LETTER AH
+16F44;AL # MIAO LETTER HHA
+16F50;AL # MIAO LETTER NASALIZATION
+16F51;CM # MIAO SIGN ASPIRATION
+16F52;CM # MIAO SIGN REFORMED VOICING
+16F53;CM # MIAO SIGN REFORMED ASPIRATION
+16F54;CM # MIAO VOWEL SIGN A
+16F55;CM # MIAO VOWEL SIGN AA
+16F56;CM # MIAO VOWEL SIGN AHH
+16F57;CM # MIAO VOWEL SIGN AN
+16F58;CM # MIAO VOWEL SIGN ANG
+16F59;CM # MIAO VOWEL SIGN O
+16F5A;CM # MIAO VOWEL SIGN OO
+16F5B;CM # MIAO VOWEL SIGN WO
+16F5C;CM # MIAO VOWEL SIGN W
+16F5D;CM # MIAO VOWEL SIGN E
+16F5E;CM # MIAO VOWEL SIGN EN
+16F5F;CM # MIAO VOWEL SIGN ENG
+16F60;CM # MIAO VOWEL SIGN OEY
+16F61;CM # MIAO VOWEL SIGN I
+16F62;CM # MIAO VOWEL SIGN IA
+16F63;CM # MIAO VOWEL SIGN IAN
+16F64;CM # MIAO VOWEL SIGN IANG
+16F65;CM # MIAO VOWEL SIGN IO
+16F66;CM # MIAO VOWEL SIGN IE
+16F67;CM # MIAO VOWEL SIGN II
+16F68;CM # MIAO VOWEL SIGN IU
+16F69;CM # MIAO VOWEL SIGN ING
+16F6A;CM # MIAO VOWEL SIGN U
+16F6B;CM # MIAO VOWEL SIGN UA
+16F6C;CM # MIAO VOWEL SIGN UAN
+16F6D;CM # MIAO VOWEL SIGN UANG
+16F6E;CM # MIAO VOWEL SIGN UU
+16F6F;CM # MIAO VOWEL SIGN UEI
+16F70;CM # MIAO VOWEL SIGN UNG
+16F71;CM # MIAO VOWEL SIGN Y
+16F72;CM # MIAO VOWEL SIGN YI
+16F73;CM # MIAO VOWEL SIGN AE
+16F74;CM # MIAO VOWEL SIGN AEE
+16F75;CM # MIAO VOWEL SIGN ERR
+16F76;CM # MIAO VOWEL SIGN ROUNDED ERR
+16F77;CM # MIAO VOWEL SIGN ER
+16F78;CM # MIAO VOWEL SIGN ROUNDED ER
+16F79;CM # MIAO VOWEL SIGN AI
+16F7A;CM # MIAO VOWEL SIGN EI
+16F7B;CM # MIAO VOWEL SIGN AU
+16F7C;CM # MIAO VOWEL SIGN OU
+16F7D;CM # MIAO VOWEL SIGN N
+16F7E;CM # MIAO VOWEL SIGN NG
+16F8F;CM # MIAO TONE RIGHT
+16F90;CM # MIAO TONE TOP RIGHT
+16F91;CM # MIAO TONE ABOVE
+16F92;CM # MIAO TONE BELOW
+16F93;AL # MIAO LETTER TONE-2
+16F94;AL # MIAO LETTER TONE-3
+16F95;AL # MIAO LETTER TONE-4
+16F96;AL # MIAO LETTER TONE-5
+16F97;AL # MIAO LETTER TONE-6
+16F98;AL # MIAO LETTER TONE-7
+16F99;AL # MIAO LETTER TONE-8
+16F9A;AL # MIAO LETTER REFORMED TONE-1
+16F9B;AL # MIAO LETTER REFORMED TONE-2
+16F9C;AL # MIAO LETTER REFORMED TONE-4
+16F9D;AL # MIAO LETTER REFORMED TONE-5
+16F9E;AL # MIAO LETTER REFORMED TONE-6
+16F9F;AL # MIAO LETTER REFORMED TONE-8
1B000;ID # KATAKANA LETTER ARCHAIC E
1B001;ID # HIRAGANA LETTER ARCHAIC YE
1D000;AL # BYZANTINE MUSICAL SYMBOL PSILI
@@ -22439,209 +23008,352 @@
1D7FD;NU # MATHEMATICAL MONOSPACE DIGIT SEVEN
1D7FE;NU # MATHEMATICAL MONOSPACE DIGIT EIGHT
1D7FF;NU # MATHEMATICAL MONOSPACE DIGIT NINE
-1F000;AL # MAHJONG TILE EAST WIND
-1F001;AL # MAHJONG TILE SOUTH WIND
-1F002;AL # MAHJONG TILE WEST WIND
-1F003;AL # MAHJONG TILE NORTH WIND
-1F004;AL # MAHJONG TILE RED DRAGON
-1F005;AL # MAHJONG TILE GREEN DRAGON
-1F006;AL # MAHJONG TILE WHITE DRAGON
-1F007;AL # MAHJONG TILE ONE OF CHARACTERS
-1F008;AL # MAHJONG TILE TWO OF CHARACTERS
-1F009;AL # MAHJONG TILE THREE OF CHARACTERS
-1F00A;AL # MAHJONG TILE FOUR OF CHARACTERS
-1F00B;AL # MAHJONG TILE FIVE OF CHARACTERS
-1F00C;AL # MAHJONG TILE SIX OF CHARACTERS
-1F00D;AL # MAHJONG TILE SEVEN OF CHARACTERS
-1F00E;AL # MAHJONG TILE EIGHT OF CHARACTERS
-1F00F;AL # MAHJONG TILE NINE OF CHARACTERS
-1F010;AL # MAHJONG TILE ONE OF BAMBOOS
-1F011;AL # MAHJONG TILE TWO OF BAMBOOS
-1F012;AL # MAHJONG TILE THREE OF BAMBOOS
-1F013;AL # MAHJONG TILE FOUR OF BAMBOOS
-1F014;AL # MAHJONG TILE FIVE OF BAMBOOS
-1F015;AL # MAHJONG TILE SIX OF BAMBOOS
-1F016;AL # MAHJONG TILE SEVEN OF BAMBOOS
-1F017;AL # MAHJONG TILE EIGHT OF BAMBOOS
-1F018;AL # MAHJONG TILE NINE OF BAMBOOS
-1F019;AL # MAHJONG TILE ONE OF CIRCLES
-1F01A;AL # MAHJONG TILE TWO OF CIRCLES
-1F01B;AL # MAHJONG TILE THREE OF CIRCLES
-1F01C;AL # MAHJONG TILE FOUR OF CIRCLES
-1F01D;AL # MAHJONG TILE FIVE OF CIRCLES
-1F01E;AL # MAHJONG TILE SIX OF CIRCLES
-1F01F;AL # MAHJONG TILE SEVEN OF CIRCLES
-1F020;AL # MAHJONG TILE EIGHT OF CIRCLES
-1F021;AL # MAHJONG TILE NINE OF CIRCLES
-1F022;AL # MAHJONG TILE PLUM
-1F023;AL # MAHJONG TILE ORCHID
-1F024;AL # MAHJONG TILE BAMBOO
-1F025;AL # MAHJONG TILE CHRYSANTHEMUM
-1F026;AL # MAHJONG TILE SPRING
-1F027;AL # MAHJONG TILE SUMMER
-1F028;AL # MAHJONG TILE AUTUMN
-1F029;AL # MAHJONG TILE WINTER
-1F02A;AL # MAHJONG TILE JOKER
-1F02B;AL # MAHJONG TILE BACK
-1F030;AL # DOMINO TILE HORIZONTAL BACK
-1F031;AL # DOMINO TILE HORIZONTAL-00-00
-1F032;AL # DOMINO TILE HORIZONTAL-00-01
-1F033;AL # DOMINO TILE HORIZONTAL-00-02
-1F034;AL # DOMINO TILE HORIZONTAL-00-03
-1F035;AL # DOMINO TILE HORIZONTAL-00-04
-1F036;AL # DOMINO TILE HORIZONTAL-00-05
-1F037;AL # DOMINO TILE HORIZONTAL-00-06
-1F038;AL # DOMINO TILE HORIZONTAL-01-00
-1F039;AL # DOMINO TILE HORIZONTAL-01-01
-1F03A;AL # DOMINO TILE HORIZONTAL-01-02
-1F03B;AL # DOMINO TILE HORIZONTAL-01-03
-1F03C;AL # DOMINO TILE HORIZONTAL-01-04
-1F03D;AL # DOMINO TILE HORIZONTAL-01-05
-1F03E;AL # DOMINO TILE HORIZONTAL-01-06
-1F03F;AL # DOMINO TILE HORIZONTAL-02-00
-1F040;AL # DOMINO TILE HORIZONTAL-02-01
-1F041;AL # DOMINO TILE HORIZONTAL-02-02
-1F042;AL # DOMINO TILE HORIZONTAL-02-03
-1F043;AL # DOMINO TILE HORIZONTAL-02-04
-1F044;AL # DOMINO TILE HORIZONTAL-02-05
-1F045;AL # DOMINO TILE HORIZONTAL-02-06
-1F046;AL # DOMINO TILE HORIZONTAL-03-00
-1F047;AL # DOMINO TILE HORIZONTAL-03-01
-1F048;AL # DOMINO TILE HORIZONTAL-03-02
-1F049;AL # DOMINO TILE HORIZONTAL-03-03
-1F04A;AL # DOMINO TILE HORIZONTAL-03-04
-1F04B;AL # DOMINO TILE HORIZONTAL-03-05
-1F04C;AL # DOMINO TILE HORIZONTAL-03-06
-1F04D;AL # DOMINO TILE HORIZONTAL-04-00
-1F04E;AL # DOMINO TILE HORIZONTAL-04-01
-1F04F;AL # DOMINO TILE HORIZONTAL-04-02
-1F050;AL # DOMINO TILE HORIZONTAL-04-03
-1F051;AL # DOMINO TILE HORIZONTAL-04-04
-1F052;AL # DOMINO TILE HORIZONTAL-04-05
-1F053;AL # DOMINO TILE HORIZONTAL-04-06
-1F054;AL # DOMINO TILE HORIZONTAL-05-00
-1F055;AL # DOMINO TILE HORIZONTAL-05-01
-1F056;AL # DOMINO TILE HORIZONTAL-05-02
-1F057;AL # DOMINO TILE HORIZONTAL-05-03
-1F058;AL # DOMINO TILE HORIZONTAL-05-04
-1F059;AL # DOMINO TILE HORIZONTAL-05-05
-1F05A;AL # DOMINO TILE HORIZONTAL-05-06
-1F05B;AL # DOMINO TILE HORIZONTAL-06-00
-1F05C;AL # DOMINO TILE HORIZONTAL-06-01
-1F05D;AL # DOMINO TILE HORIZONTAL-06-02
-1F05E;AL # DOMINO TILE HORIZONTAL-06-03
-1F05F;AL # DOMINO TILE HORIZONTAL-06-04
-1F060;AL # DOMINO TILE HORIZONTAL-06-05
-1F061;AL # DOMINO TILE HORIZONTAL-06-06
-1F062;AL # DOMINO TILE VERTICAL BACK
-1F063;AL # DOMINO TILE VERTICAL-00-00
-1F064;AL # DOMINO TILE VERTICAL-00-01
-1F065;AL # DOMINO TILE VERTICAL-00-02
-1F066;AL # DOMINO TILE VERTICAL-00-03
-1F067;AL # DOMINO TILE VERTICAL-00-04
-1F068;AL # DOMINO TILE VERTICAL-00-05
-1F069;AL # DOMINO TILE VERTICAL-00-06
-1F06A;AL # DOMINO TILE VERTICAL-01-00
-1F06B;AL # DOMINO TILE VERTICAL-01-01
-1F06C;AL # DOMINO TILE VERTICAL-01-02
-1F06D;AL # DOMINO TILE VERTICAL-01-03
-1F06E;AL # DOMINO TILE VERTICAL-01-04
-1F06F;AL # DOMINO TILE VERTICAL-01-05
-1F070;AL # DOMINO TILE VERTICAL-01-06
-1F071;AL # DOMINO TILE VERTICAL-02-00
-1F072;AL # DOMINO TILE VERTICAL-02-01
-1F073;AL # DOMINO TILE VERTICAL-02-02
-1F074;AL # DOMINO TILE VERTICAL-02-03
-1F075;AL # DOMINO TILE VERTICAL-02-04
-1F076;AL # DOMINO TILE VERTICAL-02-05
-1F077;AL # DOMINO TILE VERTICAL-02-06
-1F078;AL # DOMINO TILE VERTICAL-03-00
-1F079;AL # DOMINO TILE VERTICAL-03-01
-1F07A;AL # DOMINO TILE VERTICAL-03-02
-1F07B;AL # DOMINO TILE VERTICAL-03-03
-1F07C;AL # DOMINO TILE VERTICAL-03-04
-1F07D;AL # DOMINO TILE VERTICAL-03-05
-1F07E;AL # DOMINO TILE VERTICAL-03-06
-1F07F;AL # DOMINO TILE VERTICAL-04-00
-1F080;AL # DOMINO TILE VERTICAL-04-01
-1F081;AL # DOMINO TILE VERTICAL-04-02
-1F082;AL # DOMINO TILE VERTICAL-04-03
-1F083;AL # DOMINO TILE VERTICAL-04-04
-1F084;AL # DOMINO TILE VERTICAL-04-05
-1F085;AL # DOMINO TILE VERTICAL-04-06
-1F086;AL # DOMINO TILE VERTICAL-05-00
-1F087;AL # DOMINO TILE VERTICAL-05-01
-1F088;AL # DOMINO TILE VERTICAL-05-02
-1F089;AL # DOMINO TILE VERTICAL-05-03
-1F08A;AL # DOMINO TILE VERTICAL-05-04
-1F08B;AL # DOMINO TILE VERTICAL-05-05
-1F08C;AL # DOMINO TILE VERTICAL-05-06
-1F08D;AL # DOMINO TILE VERTICAL-06-00
-1F08E;AL # DOMINO TILE VERTICAL-06-01
-1F08F;AL # DOMINO TILE VERTICAL-06-02
-1F090;AL # DOMINO TILE VERTICAL-06-03
-1F091;AL # DOMINO TILE VERTICAL-06-04
-1F092;AL # DOMINO TILE VERTICAL-06-05
-1F093;AL # DOMINO TILE VERTICAL-06-06
-1F0A0;AL # PLAYING CARD BACK
-1F0A1;AL # PLAYING CARD ACE OF SPADES
-1F0A2;AL # PLAYING CARD TWO OF SPADES
-1F0A3;AL # PLAYING CARD THREE OF SPADES
-1F0A4;AL # PLAYING CARD FOUR OF SPADES
-1F0A5;AL # PLAYING CARD FIVE OF SPADES
-1F0A6;AL # PLAYING CARD SIX OF SPADES
-1F0A7;AL # PLAYING CARD SEVEN OF SPADES
-1F0A8;AL # PLAYING CARD EIGHT OF SPADES
-1F0A9;AL # PLAYING CARD NINE OF SPADES
-1F0AA;AL # PLAYING CARD TEN OF SPADES
-1F0AB;AL # PLAYING CARD JACK OF SPADES
-1F0AC;AL # PLAYING CARD KNIGHT OF SPADES
-1F0AD;AL # PLAYING CARD QUEEN OF SPADES
-1F0AE;AL # PLAYING CARD KING OF SPADES
-1F0B1;AL # PLAYING CARD ACE OF HEARTS
-1F0B2;AL # PLAYING CARD TWO OF HEARTS
-1F0B3;AL # PLAYING CARD THREE OF HEARTS
-1F0B4;AL # PLAYING CARD FOUR OF HEARTS
-1F0B5;AL # PLAYING CARD FIVE OF HEARTS
-1F0B6;AL # PLAYING CARD SIX OF HEARTS
-1F0B7;AL # PLAYING CARD SEVEN OF HEARTS
-1F0B8;AL # PLAYING CARD EIGHT OF HEARTS
-1F0B9;AL # PLAYING CARD NINE OF HEARTS
-1F0BA;AL # PLAYING CARD TEN OF HEARTS
-1F0BB;AL # PLAYING CARD JACK OF HEARTS
-1F0BC;AL # PLAYING CARD KNIGHT OF HEARTS
-1F0BD;AL # PLAYING CARD QUEEN OF HEARTS
-1F0BE;AL # PLAYING CARD KING OF HEARTS
-1F0C1;AL # PLAYING CARD ACE OF DIAMONDS
-1F0C2;AL # PLAYING CARD TWO OF DIAMONDS
-1F0C3;AL # PLAYING CARD THREE OF DIAMONDS
-1F0C4;AL # PLAYING CARD FOUR OF DIAMONDS
-1F0C5;AL # PLAYING CARD FIVE OF DIAMONDS
-1F0C6;AL # PLAYING CARD SIX OF DIAMONDS
-1F0C7;AL # PLAYING CARD SEVEN OF DIAMONDS
-1F0C8;AL # PLAYING CARD EIGHT OF DIAMONDS
-1F0C9;AL # PLAYING CARD NINE OF DIAMONDS
-1F0CA;AL # PLAYING CARD TEN OF DIAMONDS
-1F0CB;AL # PLAYING CARD JACK OF DIAMONDS
-1F0CC;AL # PLAYING CARD KNIGHT OF DIAMONDS
-1F0CD;AL # PLAYING CARD QUEEN OF DIAMONDS
-1F0CE;AL # PLAYING CARD KING OF DIAMONDS
-1F0CF;AL # PLAYING CARD BLACK JOKER
-1F0D1;AL # PLAYING CARD ACE OF CLUBS
-1F0D2;AL # PLAYING CARD TWO OF CLUBS
-1F0D3;AL # PLAYING CARD THREE OF CLUBS
-1F0D4;AL # PLAYING CARD FOUR OF CLUBS
-1F0D5;AL # PLAYING CARD FIVE OF CLUBS
-1F0D6;AL # PLAYING CARD SIX OF CLUBS
-1F0D7;AL # PLAYING CARD SEVEN OF CLUBS
-1F0D8;AL # PLAYING CARD EIGHT OF CLUBS
-1F0D9;AL # PLAYING CARD NINE OF CLUBS
-1F0DA;AL # PLAYING CARD TEN OF CLUBS
-1F0DB;AL # PLAYING CARD JACK OF CLUBS
-1F0DC;AL # PLAYING CARD KNIGHT OF CLUBS
-1F0DD;AL # PLAYING CARD QUEEN OF CLUBS
-1F0DE;AL # PLAYING CARD KING OF CLUBS
-1F0DF;AL # PLAYING CARD WHITE JOKER
+1EE00;AL # ARABIC MATHEMATICAL ALEF
+1EE01;AL # ARABIC MATHEMATICAL BEH
+1EE02;AL # ARABIC MATHEMATICAL JEEM
+1EE03;AL # ARABIC MATHEMATICAL DAL
+1EE05;AL # ARABIC MATHEMATICAL WAW
+1EE06;AL # ARABIC MATHEMATICAL ZAIN
+1EE07;AL # ARABIC MATHEMATICAL HAH
+1EE08;AL # ARABIC MATHEMATICAL TAH
+1EE09;AL # ARABIC MATHEMATICAL YEH
+1EE0A;AL # ARABIC MATHEMATICAL KAF
+1EE0B;AL # ARABIC MATHEMATICAL LAM
+1EE0C;AL # ARABIC MATHEMATICAL MEEM
+1EE0D;AL # ARABIC MATHEMATICAL NOON
+1EE0E;AL # ARABIC MATHEMATICAL SEEN
+1EE0F;AL # ARABIC MATHEMATICAL AIN
+1EE10;AL # ARABIC MATHEMATICAL FEH
+1EE11;AL # ARABIC MATHEMATICAL SAD
+1EE12;AL # ARABIC MATHEMATICAL QAF
+1EE13;AL # ARABIC MATHEMATICAL REH
+1EE14;AL # ARABIC MATHEMATICAL SHEEN
+1EE15;AL # ARABIC MATHEMATICAL TEH
+1EE16;AL # ARABIC MATHEMATICAL THEH
+1EE17;AL # ARABIC MATHEMATICAL KHAH
+1EE18;AL # ARABIC MATHEMATICAL THAL
+1EE19;AL # ARABIC MATHEMATICAL DAD
+1EE1A;AL # ARABIC MATHEMATICAL ZAH
+1EE1B;AL # ARABIC MATHEMATICAL GHAIN
+1EE1C;AL # ARABIC MATHEMATICAL DOTLESS BEH
+1EE1D;AL # ARABIC MATHEMATICAL DOTLESS NOON
+1EE1E;AL # ARABIC MATHEMATICAL DOTLESS FEH
+1EE1F;AL # ARABIC MATHEMATICAL DOTLESS QAF
+1EE21;AL # ARABIC MATHEMATICAL INITIAL BEH
+1EE22;AL # ARABIC MATHEMATICAL INITIAL JEEM
+1EE24;AL # ARABIC MATHEMATICAL INITIAL HEH
+1EE27;AL # ARABIC MATHEMATICAL INITIAL HAH
+1EE29;AL # ARABIC MATHEMATICAL INITIAL YEH
+1EE2A;AL # ARABIC MATHEMATICAL INITIAL KAF
+1EE2B;AL # ARABIC MATHEMATICAL INITIAL LAM
+1EE2C;AL # ARABIC MATHEMATICAL INITIAL MEEM
+1EE2D;AL # ARABIC MATHEMATICAL INITIAL NOON
+1EE2E;AL # ARABIC MATHEMATICAL INITIAL SEEN
+1EE2F;AL # ARABIC MATHEMATICAL INITIAL AIN
+1EE30;AL # ARABIC MATHEMATICAL INITIAL FEH
+1EE31;AL # ARABIC MATHEMATICAL INITIAL SAD
+1EE32;AL # ARABIC MATHEMATICAL INITIAL QAF
+1EE34;AL # ARABIC MATHEMATICAL INITIAL SHEEN
+1EE35;AL # ARABIC MATHEMATICAL INITIAL TEH
+1EE36;AL # ARABIC MATHEMATICAL INITIAL THEH
+1EE37;AL # ARABIC MATHEMATICAL INITIAL KHAH
+1EE39;AL # ARABIC MATHEMATICAL INITIAL DAD
+1EE3B;AL # ARABIC MATHEMATICAL INITIAL GHAIN
+1EE42;AL # ARABIC MATHEMATICAL TAILED JEEM
+1EE47;AL # ARABIC MATHEMATICAL TAILED HAH
+1EE49;AL # ARABIC MATHEMATICAL TAILED YEH
+1EE4B;AL # ARABIC MATHEMATICAL TAILED LAM
+1EE4D;AL # ARABIC MATHEMATICAL TAILED NOON
+1EE4E;AL # ARABIC MATHEMATICAL TAILED SEEN
+1EE4F;AL # ARABIC MATHEMATICAL TAILED AIN
+1EE51;AL # ARABIC MATHEMATICAL TAILED SAD
+1EE52;AL # ARABIC MATHEMATICAL TAILED QAF
+1EE54;AL # ARABIC MATHEMATICAL TAILED SHEEN
+1EE57;AL # ARABIC MATHEMATICAL TAILED KHAH
+1EE59;AL # ARABIC MATHEMATICAL TAILED DAD
+1EE5B;AL # ARABIC MATHEMATICAL TAILED GHAIN
+1EE5D;AL # ARABIC MATHEMATICAL TAILED DOTLESS NOON
+1EE5F;AL # ARABIC MATHEMATICAL TAILED DOTLESS QAF
+1EE61;AL # ARABIC MATHEMATICAL STRETCHED BEH
+1EE62;AL # ARABIC MATHEMATICAL STRETCHED JEEM
+1EE64;AL # ARABIC MATHEMATICAL STRETCHED HEH
+1EE67;AL # ARABIC MATHEMATICAL STRETCHED HAH
+1EE68;AL # ARABIC MATHEMATICAL STRETCHED TAH
+1EE69;AL # ARABIC MATHEMATICAL STRETCHED YEH
+1EE6A;AL # ARABIC MATHEMATICAL STRETCHED KAF
+1EE6C;AL # ARABIC MATHEMATICAL STRETCHED MEEM
+1EE6D;AL # ARABIC MATHEMATICAL STRETCHED NOON
+1EE6E;AL # ARABIC MATHEMATICAL STRETCHED SEEN
+1EE6F;AL # ARABIC MATHEMATICAL STRETCHED AIN
+1EE70;AL # ARABIC MATHEMATICAL STRETCHED FEH
+1EE71;AL # ARABIC MATHEMATICAL STRETCHED SAD
+1EE72;AL # ARABIC MATHEMATICAL STRETCHED QAF
+1EE74;AL # ARABIC MATHEMATICAL STRETCHED SHEEN
+1EE75;AL # ARABIC MATHEMATICAL STRETCHED TEH
+1EE76;AL # ARABIC MATHEMATICAL STRETCHED THEH
+1EE77;AL # ARABIC MATHEMATICAL STRETCHED KHAH
+1EE79;AL # ARABIC MATHEMATICAL STRETCHED DAD
+1EE7A;AL # ARABIC MATHEMATICAL STRETCHED ZAH
+1EE7B;AL # ARABIC MATHEMATICAL STRETCHED GHAIN
+1EE7C;AL # ARABIC MATHEMATICAL STRETCHED DOTLESS BEH
+1EE7E;AL # ARABIC MATHEMATICAL STRETCHED DOTLESS FEH
+1EE80;AL # ARABIC MATHEMATICAL LOOPED ALEF
+1EE81;AL # ARABIC MATHEMATICAL LOOPED BEH
+1EE82;AL # ARABIC MATHEMATICAL LOOPED JEEM
+1EE83;AL # ARABIC MATHEMATICAL LOOPED DAL
+1EE84;AL # ARABIC MATHEMATICAL LOOPED HEH
+1EE85;AL # ARABIC MATHEMATICAL LOOPED WAW
+1EE86;AL # ARABIC MATHEMATICAL LOOPED ZAIN
+1EE87;AL # ARABIC MATHEMATICAL LOOPED HAH
+1EE88;AL # ARABIC MATHEMATICAL LOOPED TAH
+1EE89;AL # ARABIC MATHEMATICAL LOOPED YEH
+1EE8B;AL # ARABIC MATHEMATICAL LOOPED LAM
+1EE8C;AL # ARABIC MATHEMATICAL LOOPED MEEM
+1EE8D;AL # ARABIC MATHEMATICAL LOOPED NOON
+1EE8E;AL # ARABIC MATHEMATICAL LOOPED SEEN
+1EE8F;AL # ARABIC MATHEMATICAL LOOPED AIN
+1EE90;AL # ARABIC MATHEMATICAL LOOPED FEH
+1EE91;AL # ARABIC MATHEMATICAL LOOPED SAD
+1EE92;AL # ARABIC MATHEMATICAL LOOPED QAF
+1EE93;AL # ARABIC MATHEMATICAL LOOPED REH
+1EE94;AL # ARABIC MATHEMATICAL LOOPED SHEEN
+1EE95;AL # ARABIC MATHEMATICAL LOOPED TEH
+1EE96;AL # ARABIC MATHEMATICAL LOOPED THEH
+1EE97;AL # ARABIC MATHEMATICAL LOOPED KHAH
+1EE98;AL # ARABIC MATHEMATICAL LOOPED THAL
+1EE99;AL # ARABIC MATHEMATICAL LOOPED DAD
+1EE9A;AL # ARABIC MATHEMATICAL LOOPED ZAH
+1EE9B;AL # ARABIC MATHEMATICAL LOOPED GHAIN
+1EEA1;AL # ARABIC MATHEMATICAL DOUBLE-STRUCK BEH
+1EEA2;AL # ARABIC MATHEMATICAL DOUBLE-STRUCK JEEM
+1EEA3;AL # ARABIC MATHEMATICAL DOUBLE-STRUCK DAL
+1EEA5;AL # ARABIC MATHEMATICAL DOUBLE-STRUCK WAW
+1EEA6;AL # ARABIC MATHEMATICAL DOUBLE-STRUCK ZAIN
+1EEA7;AL # ARABIC MATHEMATICAL DOUBLE-STRUCK HAH
+1EEA8;AL # ARABIC MATHEMATICAL DOUBLE-STRUCK TAH
+1EEA9;AL # ARABIC MATHEMATICAL DOUBLE-STRUCK YEH
+1EEAB;AL # ARABIC MATHEMATICAL DOUBLE-STRUCK LAM
+1EEAC;AL # ARABIC MATHEMATICAL DOUBLE-STRUCK MEEM
+1EEAD;AL # ARABIC MATHEMATICAL DOUBLE-STRUCK NOON
+1EEAE;AL # ARABIC MATHEMATICAL DOUBLE-STRUCK SEEN
+1EEAF;AL # ARABIC MATHEMATICAL DOUBLE-STRUCK AIN
+1EEB0;AL # ARABIC MATHEMATICAL DOUBLE-STRUCK FEH
+1EEB1;AL # ARABIC MATHEMATICAL DOUBLE-STRUCK SAD
+1EEB2;AL # ARABIC MATHEMATICAL DOUBLE-STRUCK QAF
+1EEB3;AL # ARABIC MATHEMATICAL DOUBLE-STRUCK REH
+1EEB4;AL # ARABIC MATHEMATICAL DOUBLE-STRUCK SHEEN
+1EEB5;AL # ARABIC MATHEMATICAL DOUBLE-STRUCK TEH
+1EEB6;AL # ARABIC MATHEMATICAL DOUBLE-STRUCK THEH
+1EEB7;AL # ARABIC MATHEMATICAL DOUBLE-STRUCK KHAH
+1EEB8;AL # ARABIC MATHEMATICAL DOUBLE-STRUCK THAL
+1EEB9;AL # ARABIC MATHEMATICAL DOUBLE-STRUCK DAD
+1EEBA;AL # ARABIC MATHEMATICAL DOUBLE-STRUCK ZAH
+1EEBB;AL # ARABIC MATHEMATICAL DOUBLE-STRUCK GHAIN
+1EEF0;AL # ARABIC MATHEMATICAL OPERATOR MEEM WITH HAH WITH TATWEEL
+1EEF1;AL # ARABIC MATHEMATICAL OPERATOR HAH WITH DAL
+1F000;ID # MAHJONG TILE EAST WIND
+1F001;ID # MAHJONG TILE SOUTH WIND
+1F002;ID # MAHJONG TILE WEST WIND
+1F003;ID # MAHJONG TILE NORTH WIND
+1F004;ID # MAHJONG TILE RED DRAGON
+1F005;ID # MAHJONG TILE GREEN DRAGON
+1F006;ID # MAHJONG TILE WHITE DRAGON
+1F007;ID # MAHJONG TILE ONE OF CHARACTERS
+1F008;ID # MAHJONG TILE TWO OF CHARACTERS
+1F009;ID # MAHJONG TILE THREE OF CHARACTERS
+1F00A;ID # MAHJONG TILE FOUR OF CHARACTERS
+1F00B;ID # MAHJONG TILE FIVE OF CHARACTERS
+1F00C;ID # MAHJONG TILE SIX OF CHARACTERS
+1F00D;ID # MAHJONG TILE SEVEN OF CHARACTERS
+1F00E;ID # MAHJONG TILE EIGHT OF CHARACTERS
+1F00F;ID # MAHJONG TILE NINE OF CHARACTERS
+1F010;ID # MAHJONG TILE ONE OF BAMBOOS
+1F011;ID # MAHJONG TILE TWO OF BAMBOOS
+1F012;ID # MAHJONG TILE THREE OF BAMBOOS
+1F013;ID # MAHJONG TILE FOUR OF BAMBOOS
+1F014;ID # MAHJONG TILE FIVE OF BAMBOOS
+1F015;ID # MAHJONG TILE SIX OF BAMBOOS
+1F016;ID # MAHJONG TILE SEVEN OF BAMBOOS
+1F017;ID # MAHJONG TILE EIGHT OF BAMBOOS
+1F018;ID # MAHJONG TILE NINE OF BAMBOOS
+1F019;ID # MAHJONG TILE ONE OF CIRCLES
+1F01A;ID # MAHJONG TILE TWO OF CIRCLES
+1F01B;ID # MAHJONG TILE THREE OF CIRCLES
+1F01C;ID # MAHJONG TILE FOUR OF CIRCLES
+1F01D;ID # MAHJONG TILE FIVE OF CIRCLES
+1F01E;ID # MAHJONG TILE SIX OF CIRCLES
+1F01F;ID # MAHJONG TILE SEVEN OF CIRCLES
+1F020;ID # MAHJONG TILE EIGHT OF CIRCLES
+1F021;ID # MAHJONG TILE NINE OF CIRCLES
+1F022;ID # MAHJONG TILE PLUM
+1F023;ID # MAHJONG TILE ORCHID
+1F024;ID # MAHJONG TILE BAMBOO
+1F025;ID # MAHJONG TILE CHRYSANTHEMUM
+1F026;ID # MAHJONG TILE SPRING
+1F027;ID # MAHJONG TILE SUMMER
+1F028;ID # MAHJONG TILE AUTUMN
+1F029;ID # MAHJONG TILE WINTER
+1F02A;ID # MAHJONG TILE JOKER
+1F02B;ID # MAHJONG TILE BACK
+1F030;ID # DOMINO TILE HORIZONTAL BACK
+1F031;ID # DOMINO TILE HORIZONTAL-00-00
+1F032;ID # DOMINO TILE HORIZONTAL-00-01
+1F033;ID # DOMINO TILE HORIZONTAL-00-02
+1F034;ID # DOMINO TILE HORIZONTAL-00-03
+1F035;ID # DOMINO TILE HORIZONTAL-00-04
+1F036;ID # DOMINO TILE HORIZONTAL-00-05
+1F037;ID # DOMINO TILE HORIZONTAL-00-06
+1F038;ID # DOMINO TILE HORIZONTAL-01-00
+1F039;ID # DOMINO TILE HORIZONTAL-01-01
+1F03A;ID # DOMINO TILE HORIZONTAL-01-02
+1F03B;ID # DOMINO TILE HORIZONTAL-01-03
+1F03C;ID # DOMINO TILE HORIZONTAL-01-04
+1F03D;ID # DOMINO TILE HORIZONTAL-01-05
+1F03E;ID # DOMINO TILE HORIZONTAL-01-06
+1F03F;ID # DOMINO TILE HORIZONTAL-02-00
+1F040;ID # DOMINO TILE HORIZONTAL-02-01
+1F041;ID # DOMINO TILE HORIZONTAL-02-02
+1F042;ID # DOMINO TILE HORIZONTAL-02-03
+1F043;ID # DOMINO TILE HORIZONTAL-02-04
+1F044;ID # DOMINO TILE HORIZONTAL-02-05
+1F045;ID # DOMINO TILE HORIZONTAL-02-06
+1F046;ID # DOMINO TILE HORIZONTAL-03-00
+1F047;ID # DOMINO TILE HORIZONTAL-03-01
+1F048;ID # DOMINO TILE HORIZONTAL-03-02
+1F049;ID # DOMINO TILE HORIZONTAL-03-03
+1F04A;ID # DOMINO TILE HORIZONTAL-03-04
+1F04B;ID # DOMINO TILE HORIZONTAL-03-05
+1F04C;ID # DOMINO TILE HORIZONTAL-03-06
+1F04D;ID # DOMINO TILE HORIZONTAL-04-00
+1F04E;ID # DOMINO TILE HORIZONTAL-04-01
+1F04F;ID # DOMINO TILE HORIZONTAL-04-02
+1F050;ID # DOMINO TILE HORIZONTAL-04-03
+1F051;ID # DOMINO TILE HORIZONTAL-04-04
+1F052;ID # DOMINO TILE HORIZONTAL-04-05
+1F053;ID # DOMINO TILE HORIZONTAL-04-06
+1F054;ID # DOMINO TILE HORIZONTAL-05-00
+1F055;ID # DOMINO TILE HORIZONTAL-05-01
+1F056;ID # DOMINO TILE HORIZONTAL-05-02
+1F057;ID # DOMINO TILE HORIZONTAL-05-03
+1F058;ID # DOMINO TILE HORIZONTAL-05-04
+1F059;ID # DOMINO TILE HORIZONTAL-05-05
+1F05A;ID # DOMINO TILE HORIZONTAL-05-06
+1F05B;ID # DOMINO TILE HORIZONTAL-06-00
+1F05C;ID # DOMINO TILE HORIZONTAL-06-01
+1F05D;ID # DOMINO TILE HORIZONTAL-06-02
+1F05E;ID # DOMINO TILE HORIZONTAL-06-03
+1F05F;ID # DOMINO TILE HORIZONTAL-06-04
+1F060;ID # DOMINO TILE HORIZONTAL-06-05
+1F061;ID # DOMINO TILE HORIZONTAL-06-06
+1F062;ID # DOMINO TILE VERTICAL BACK
+1F063;ID # DOMINO TILE VERTICAL-00-00
+1F064;ID # DOMINO TILE VERTICAL-00-01
+1F065;ID # DOMINO TILE VERTICAL-00-02
+1F066;ID # DOMINO TILE VERTICAL-00-03
+1F067;ID # DOMINO TILE VERTICAL-00-04
+1F068;ID # DOMINO TILE VERTICAL-00-05
+1F069;ID # DOMINO TILE VERTICAL-00-06
+1F06A;ID # DOMINO TILE VERTICAL-01-00
+1F06B;ID # DOMINO TILE VERTICAL-01-01
+1F06C;ID # DOMINO TILE VERTICAL-01-02
+1F06D;ID # DOMINO TILE VERTICAL-01-03
+1F06E;ID # DOMINO TILE VERTICAL-01-04
+1F06F;ID # DOMINO TILE VERTICAL-01-05
+1F070;ID # DOMINO TILE VERTICAL-01-06
+1F071;ID # DOMINO TILE VERTICAL-02-00
+1F072;ID # DOMINO TILE VERTICAL-02-01
+1F073;ID # DOMINO TILE VERTICAL-02-02
+1F074;ID # DOMINO TILE VERTICAL-02-03
+1F075;ID # DOMINO TILE VERTICAL-02-04
+1F076;ID # DOMINO TILE VERTICAL-02-05
+1F077;ID # DOMINO TILE VERTICAL-02-06
+1F078;ID # DOMINO TILE VERTICAL-03-00
+1F079;ID # DOMINO TILE VERTICAL-03-01
+1F07A;ID # DOMINO TILE VERTICAL-03-02
+1F07B;ID # DOMINO TILE VERTICAL-03-03
+1F07C;ID # DOMINO TILE VERTICAL-03-04
+1F07D;ID # DOMINO TILE VERTICAL-03-05
+1F07E;ID # DOMINO TILE VERTICAL-03-06
+1F07F;ID # DOMINO TILE VERTICAL-04-00
+1F080;ID # DOMINO TILE VERTICAL-04-01
+1F081;ID # DOMINO TILE VERTICAL-04-02
+1F082;ID # DOMINO TILE VERTICAL-04-03
+1F083;ID # DOMINO TILE VERTICAL-04-04
+1F084;ID # DOMINO TILE VERTICAL-04-05
+1F085;ID # DOMINO TILE VERTICAL-04-06
+1F086;ID # DOMINO TILE VERTICAL-05-00
+1F087;ID # DOMINO TILE VERTICAL-05-01
+1F088;ID # DOMINO TILE VERTICAL-05-02
+1F089;ID # DOMINO TILE VERTICAL-05-03
+1F08A;ID # DOMINO TILE VERTICAL-05-04
+1F08B;ID # DOMINO TILE VERTICAL-05-05
+1F08C;ID # DOMINO TILE VERTICAL-05-06
+1F08D;ID # DOMINO TILE VERTICAL-06-00
+1F08E;ID # DOMINO TILE VERTICAL-06-01
+1F08F;ID # DOMINO TILE VERTICAL-06-02
+1F090;ID # DOMINO TILE VERTICAL-06-03
+1F091;ID # DOMINO TILE VERTICAL-06-04
+1F092;ID # DOMINO TILE VERTICAL-06-05
+1F093;ID # DOMINO TILE VERTICAL-06-06
+1F0A0;ID # PLAYING CARD BACK
+1F0A1;ID # PLAYING CARD ACE OF SPADES
+1F0A2;ID # PLAYING CARD TWO OF SPADES
+1F0A3;ID # PLAYING CARD THREE OF SPADES
+1F0A4;ID # PLAYING CARD FOUR OF SPADES
+1F0A5;ID # PLAYING CARD FIVE OF SPADES
+1F0A6;ID # PLAYING CARD SIX OF SPADES
+1F0A7;ID # PLAYING CARD SEVEN OF SPADES
+1F0A8;ID # PLAYING CARD EIGHT OF SPADES
+1F0A9;ID # PLAYING CARD NINE OF SPADES
+1F0AA;ID # PLAYING CARD TEN OF SPADES
+1F0AB;ID # PLAYING CARD JACK OF SPADES
+1F0AC;ID # PLAYING CARD KNIGHT OF SPADES
+1F0AD;ID # PLAYING CARD QUEEN OF SPADES
+1F0AE;ID # PLAYING CARD KING OF SPADES
+1F0B1;ID # PLAYING CARD ACE OF HEARTS
+1F0B2;ID # PLAYING CARD TWO OF HEARTS
+1F0B3;ID # PLAYING CARD THREE OF HEARTS
+1F0B4;ID # PLAYING CARD FOUR OF HEARTS
+1F0B5;ID # PLAYING CARD FIVE OF HEARTS
+1F0B6;ID # PLAYING CARD SIX OF HEARTS
+1F0B7;ID # PLAYING CARD SEVEN OF HEARTS
+1F0B8;ID # PLAYING CARD EIGHT OF HEARTS
+1F0B9;ID # PLAYING CARD NINE OF HEARTS
+1F0BA;ID # PLAYING CARD TEN OF HEARTS
+1F0BB;ID # PLAYING CARD JACK OF HEARTS
+1F0BC;ID # PLAYING CARD KNIGHT OF HEARTS
+1F0BD;ID # PLAYING CARD QUEEN OF HEARTS
+1F0BE;ID # PLAYING CARD KING OF HEARTS
+1F0C1;ID # PLAYING CARD ACE OF DIAMONDS
+1F0C2;ID # PLAYING CARD TWO OF DIAMONDS
+1F0C3;ID # PLAYING CARD THREE OF DIAMONDS
+1F0C4;ID # PLAYING CARD FOUR OF DIAMONDS
+1F0C5;ID # PLAYING CARD FIVE OF DIAMONDS
+1F0C6;ID # PLAYING CARD SIX OF DIAMONDS
+1F0C7;ID # PLAYING CARD SEVEN OF DIAMONDS
+1F0C8;ID # PLAYING CARD EIGHT OF DIAMONDS
+1F0C9;ID # PLAYING CARD NINE OF DIAMONDS
+1F0CA;ID # PLAYING CARD TEN OF DIAMONDS
+1F0CB;ID # PLAYING CARD JACK OF DIAMONDS
+1F0CC;ID # PLAYING CARD KNIGHT OF DIAMONDS
+1F0CD;ID # PLAYING CARD QUEEN OF DIAMONDS
+1F0CE;ID # PLAYING CARD KING OF DIAMONDS
+1F0CF;ID # PLAYING CARD BLACK JOKER
+1F0D1;ID # PLAYING CARD ACE OF CLUBS
+1F0D2;ID # PLAYING CARD TWO OF CLUBS
+1F0D3;ID # PLAYING CARD THREE OF CLUBS
+1F0D4;ID # PLAYING CARD FOUR OF CLUBS
+1F0D5;ID # PLAYING CARD FIVE OF CLUBS
+1F0D6;ID # PLAYING CARD SIX OF CLUBS
+1F0D7;ID # PLAYING CARD SEVEN OF CLUBS
+1F0D8;ID # PLAYING CARD EIGHT OF CLUBS
+1F0D9;ID # PLAYING CARD NINE OF CLUBS
+1F0DA;ID # PLAYING CARD TEN OF CLUBS
+1F0DB;ID # PLAYING CARD JACK OF CLUBS
+1F0DC;ID # PLAYING CARD KNIGHT OF CLUBS
+1F0DD;ID # PLAYING CARD QUEEN OF CLUBS
+1F0DE;ID # PLAYING CARD KING OF CLUBS
+1F0DF;ID # PLAYING CARD WHITE JOKER
1F100;AI # DIGIT ZERO FULL STOP
1F101;AI # DIGIT ZERO COMMA
1F102;AI # DIGIT ONE COMMA
@@ -22742,6 +23454,8 @@
1F167;AI # NEGATIVE CIRCLED LATIN CAPITAL LETTER X
1F168;AI # NEGATIVE CIRCLED LATIN CAPITAL LETTER Y
1F169;AI # NEGATIVE CIRCLED LATIN CAPITAL LETTER Z
+1F16A;AL # RAISED MC SIGN
+1F16B;AL # RAISED MD SIGN
1F170;AI # NEGATIVE SQUARED LATIN CAPITAL LETTER A
1F171;AI # NEGATIVE SQUARED LATIN CAPITAL LETTER B
1F172;AI # NEGATIVE SQUARED LATIN CAPITAL LETTER C
@@ -22785,32 +23499,32 @@
1F198;AI # SQUARED SOS
1F199;AI # SQUARED UP WITH EXCLAMATION MARK
1F19A;AI # SQUARED VS
-1F1E6;AL # REGIONAL INDICATOR SYMBOL LETTER A
-1F1E7;AL # REGIONAL INDICATOR SYMBOL LETTER B
-1F1E8;AL # REGIONAL INDICATOR SYMBOL LETTER C
-1F1E9;AL # REGIONAL INDICATOR SYMBOL LETTER D
-1F1EA;AL # REGIONAL INDICATOR SYMBOL LETTER E
-1F1EB;AL # REGIONAL INDICATOR SYMBOL LETTER F
-1F1EC;AL # REGIONAL INDICATOR SYMBOL LETTER G
-1F1ED;AL # REGIONAL INDICATOR SYMBOL LETTER H
-1F1EE;AL # REGIONAL INDICATOR SYMBOL LETTER I
-1F1EF;AL # REGIONAL INDICATOR SYMBOL LETTER J
-1F1F0;AL # REGIONAL INDICATOR SYMBOL LETTER K
-1F1F1;AL # REGIONAL INDICATOR SYMBOL LETTER L
-1F1F2;AL # REGIONAL INDICATOR SYMBOL LETTER M
-1F1F3;AL # REGIONAL INDICATOR SYMBOL LETTER N
-1F1F4;AL # REGIONAL INDICATOR SYMBOL LETTER O
-1F1F5;AL # REGIONAL INDICATOR SYMBOL LETTER P
-1F1F6;AL # REGIONAL INDICATOR SYMBOL LETTER Q
-1F1F7;AL # REGIONAL INDICATOR SYMBOL LETTER R
-1F1F8;AL # REGIONAL INDICATOR SYMBOL LETTER S
-1F1F9;AL # REGIONAL INDICATOR SYMBOL LETTER T
-1F1FA;AL # REGIONAL INDICATOR SYMBOL LETTER U
-1F1FB;AL # REGIONAL INDICATOR SYMBOL LETTER V
-1F1FC;AL # REGIONAL INDICATOR SYMBOL LETTER W
-1F1FD;AL # REGIONAL INDICATOR SYMBOL LETTER X
-1F1FE;AL # REGIONAL INDICATOR SYMBOL LETTER Y
-1F1FF;AL # REGIONAL INDICATOR SYMBOL LETTER Z
+1F1E6;RI # REGIONAL INDICATOR SYMBOL LETTER A
+1F1E7;RI # REGIONAL INDICATOR SYMBOL LETTER B
+1F1E8;RI # REGIONAL INDICATOR SYMBOL LETTER C
+1F1E9;RI # REGIONAL INDICATOR SYMBOL LETTER D
+1F1EA;RI # REGIONAL INDICATOR SYMBOL LETTER E
+1F1EB;RI # REGIONAL INDICATOR SYMBOL LETTER F
+1F1EC;RI # REGIONAL INDICATOR SYMBOL LETTER G
+1F1ED;RI # REGIONAL INDICATOR SYMBOL LETTER H
+1F1EE;RI # REGIONAL INDICATOR SYMBOL LETTER I
+1F1EF;RI # REGIONAL INDICATOR SYMBOL LETTER J
+1F1F0;RI # REGIONAL INDICATOR SYMBOL LETTER K
+1F1F1;RI # REGIONAL INDICATOR SYMBOL LETTER L
+1F1F2;RI # REGIONAL INDICATOR SYMBOL LETTER M
+1F1F3;RI # REGIONAL INDICATOR SYMBOL LETTER N
+1F1F4;RI # REGIONAL INDICATOR SYMBOL LETTER O
+1F1F5;RI # REGIONAL INDICATOR SYMBOL LETTER P
+1F1F6;RI # REGIONAL INDICATOR SYMBOL LETTER Q
+1F1F7;RI # REGIONAL INDICATOR SYMBOL LETTER R
+1F1F8;RI # REGIONAL INDICATOR SYMBOL LETTER S
+1F1F9;RI # REGIONAL INDICATOR SYMBOL LETTER T
+1F1FA;RI # REGIONAL INDICATOR SYMBOL LETTER U
+1F1FB;RI # REGIONAL INDICATOR SYMBOL LETTER V
+1F1FC;RI # REGIONAL INDICATOR SYMBOL LETTER W
+1F1FD;RI # REGIONAL INDICATOR SYMBOL LETTER X
+1F1FE;RI # REGIONAL INDICATOR SYMBOL LETTER Y
+1F1FF;RI # REGIONAL INDICATOR SYMBOL LETTER Z
1F200;ID # SQUARE HIRAGANA HOKA
1F201;ID # SQUARED KATAKANA KOKO
1F202;ID # SQUARED KATAKANA SA
@@ -22868,444 +23582,444 @@
1F248;ID # TORTOISE SHELL BRACKETED CJK UNIFIED IDEOGRAPH-6557
1F250;ID # CIRCLED IDEOGRAPH ADVANTAGE
1F251;ID # CIRCLED IDEOGRAPH ACCEPT
-1F300;AL # CYCLONE
-1F301;AL # FOGGY
-1F302;AL # CLOSED UMBRELLA
-1F303;AL # NIGHT WITH STARS
-1F304;AL # SUNRISE OVER MOUNTAINS
-1F305;AL # SUNRISE
-1F306;AL # CITYSCAPE AT DUSK
-1F307;AL # SUNSET OVER BUILDINGS
-1F308;AL # RAINBOW
-1F309;AL # BRIDGE AT NIGHT
-1F30A;AL # WATER WAVE
-1F30B;AL # VOLCANO
-1F30C;AL # MILKY WAY
-1F30D;AL # EARTH GLOBE EUROPE-AFRICA
-1F30E;AL # EARTH GLOBE AMERICAS
-1F30F;AL # EARTH GLOBE ASIA-AUSTRALIA
-1F310;AL # GLOBE WITH MERIDIANS
-1F311;AL # NEW MOON SYMBOL
-1F312;AL # WAXING CRESCENT MOON SYMBOL
-1F313;AL # FIRST QUARTER MOON SYMBOL
-1F314;AL # WAXING GIBBOUS MOON SYMBOL
-1F315;AL # FULL MOON SYMBOL
-1F316;AL # WANING GIBBOUS MOON SYMBOL
-1F317;AL # LAST QUARTER MOON SYMBOL
-1F318;AL # WANING CRESCENT MOON SYMBOL
-1F319;AL # CRESCENT MOON
-1F31A;AL # NEW MOON WITH FACE
-1F31B;AL # FIRST QUARTER MOON WITH FACE
-1F31C;AL # LAST QUARTER MOON WITH FACE
-1F31D;AL # FULL MOON WITH FACE
-1F31E;AL # SUN WITH FACE
-1F31F;AL # GLOWING STAR
-1F320;AL # SHOOTING STAR
-1F330;AL # CHESTNUT
-1F331;AL # SEEDLING
-1F332;AL # EVERGREEN TREE
-1F333;AL # DECIDUOUS TREE
-1F334;AL # PALM TREE
-1F335;AL # CACTUS
-1F337;AL # TULIP
-1F338;AL # CHERRY BLOSSOM
-1F339;AL # ROSE
-1F33A;AL # HIBISCUS
-1F33B;AL # SUNFLOWER
-1F33C;AL # BLOSSOM
-1F33D;AL # EAR OF MAIZE
-1F33E;AL # EAR OF RICE
-1F33F;AL # HERB
-1F340;AL # FOUR LEAF CLOVER
-1F341;AL # MAPLE LEAF
-1F342;AL # FALLEN LEAF
-1F343;AL # LEAF FLUTTERING IN WIND
-1F344;AL # MUSHROOM
-1F345;AL # TOMATO
-1F346;AL # AUBERGINE
-1F347;AL # GRAPES
-1F348;AL # MELON
-1F349;AL # WATERMELON
-1F34A;AL # TANGERINE
-1F34B;AL # LEMON
-1F34C;AL # BANANA
-1F34D;AL # PINEAPPLE
-1F34E;AL # RED APPLE
-1F34F;AL # GREEN APPLE
-1F350;AL # PEAR
-1F351;AL # PEACH
-1F352;AL # CHERRIES
-1F353;AL # STRAWBERRY
-1F354;AL # HAMBURGER
-1F355;AL # SLICE OF PIZZA
-1F356;AL # MEAT ON BONE
-1F357;AL # POULTRY LEG
-1F358;AL # RICE CRACKER
-1F359;AL # RICE BALL
-1F35A;AL # COOKED RICE
-1F35B;AL # CURRY AND RICE
-1F35C;AL # STEAMING BOWL
-1F35D;AL # SPAGHETTI
-1F35E;AL # BREAD
-1F35F;AL # FRENCH FRIES
-1F360;AL # ROASTED SWEET POTATO
-1F361;AL # DANGO
-1F362;AL # ODEN
-1F363;AL # SUSHI
-1F364;AL # FRIED SHRIMP
-1F365;AL # FISH CAKE WITH SWIRL DESIGN
-1F366;AL # SOFT ICE CREAM
-1F367;AL # SHAVED ICE
-1F368;AL # ICE CREAM
-1F369;AL # DOUGHNUT
-1F36A;AL # COOKIE
-1F36B;AL # CHOCOLATE BAR
-1F36C;AL # CANDY
-1F36D;AL # LOLLIPOP
-1F36E;AL # CUSTARD
-1F36F;AL # HONEY POT
-1F370;AL # SHORTCAKE
-1F371;AL # BENTO BOX
-1F372;AL # POT OF FOOD
-1F373;AL # COOKING
-1F374;AL # FORK AND KNIFE
-1F375;AL # TEACUP WITHOUT HANDLE
-1F376;AL # SAKE BOTTLE AND CUP
-1F377;AL # WINE GLASS
-1F378;AL # COCKTAIL GLASS
-1F379;AL # TROPICAL DRINK
-1F37A;AL # BEER MUG
-1F37B;AL # CLINKING BEER MUGS
-1F37C;AL # BABY BOTTLE
-1F380;AL # RIBBON
-1F381;AL # WRAPPED PRESENT
-1F382;AL # BIRTHDAY CAKE
-1F383;AL # JACK-O-LANTERN
-1F384;AL # CHRISTMAS TREE
-1F385;AL # FATHER CHRISTMAS
-1F386;AL # FIREWORKS
-1F387;AL # FIREWORK SPARKLER
-1F388;AL # BALLOON
-1F389;AL # PARTY POPPER
-1F38A;AL # CONFETTI BALL
-1F38B;AL # TANABATA TREE
-1F38C;AL # CROSSED FLAGS
-1F38D;AL # PINE DECORATION
-1F38E;AL # JAPANESE DOLLS
-1F38F;AL # CARP STREAMER
-1F390;AL # WIND CHIME
-1F391;AL # MOON VIEWING CEREMONY
-1F392;AL # SCHOOL SATCHEL
-1F393;AL # GRADUATION CAP
-1F3A0;AL # CAROUSEL HORSE
-1F3A1;AL # FERRIS WHEEL
-1F3A2;AL # ROLLER COASTER
-1F3A3;AL # FISHING POLE AND FISH
-1F3A4;AL # MICROPHONE
-1F3A5;AL # MOVIE CAMERA
-1F3A6;AL # CINEMA
-1F3A7;AL # HEADPHONE
-1F3A8;AL # ARTIST PALETTE
-1F3A9;AL # TOP HAT
-1F3AA;AL # CIRCUS TENT
-1F3AB;AL # TICKET
-1F3AC;AL # CLAPPER BOARD
-1F3AD;AL # PERFORMING ARTS
-1F3AE;AL # VIDEO GAME
-1F3AF;AL # DIRECT HIT
-1F3B0;AL # SLOT MACHINE
-1F3B1;AL # BILLIARDS
-1F3B2;AL # GAME DIE
-1F3B3;AL # BOWLING
-1F3B4;AL # FLOWER PLAYING CARDS
+1F300;ID # CYCLONE
+1F301;ID # FOGGY
+1F302;ID # CLOSED UMBRELLA
+1F303;ID # NIGHT WITH STARS
+1F304;ID # SUNRISE OVER MOUNTAINS
+1F305;ID # SUNRISE
+1F306;ID # CITYSCAPE AT DUSK
+1F307;ID # SUNSET OVER BUILDINGS
+1F308;ID # RAINBOW
+1F309;ID # BRIDGE AT NIGHT
+1F30A;ID # WATER WAVE
+1F30B;ID # VOLCANO
+1F30C;ID # MILKY WAY
+1F30D;ID # EARTH GLOBE EUROPE-AFRICA
+1F30E;ID # EARTH GLOBE AMERICAS
+1F30F;ID # EARTH GLOBE ASIA-AUSTRALIA
+1F310;ID # GLOBE WITH MERIDIANS
+1F311;ID # NEW MOON SYMBOL
+1F312;ID # WAXING CRESCENT MOON SYMBOL
+1F313;ID # FIRST QUARTER MOON SYMBOL
+1F314;ID # WAXING GIBBOUS MOON SYMBOL
+1F315;ID # FULL MOON SYMBOL
+1F316;ID # WANING GIBBOUS MOON SYMBOL
+1F317;ID # LAST QUARTER MOON SYMBOL
+1F318;ID # WANING CRESCENT MOON SYMBOL
+1F319;ID # CRESCENT MOON
+1F31A;ID # NEW MOON WITH FACE
+1F31B;ID # FIRST QUARTER MOON WITH FACE
+1F31C;ID # LAST QUARTER MOON WITH FACE
+1F31D;ID # FULL MOON WITH FACE
+1F31E;ID # SUN WITH FACE
+1F31F;ID # GLOWING STAR
+1F320;ID # SHOOTING STAR
+1F330;ID # CHESTNUT
+1F331;ID # SEEDLING
+1F332;ID # EVERGREEN TREE
+1F333;ID # DECIDUOUS TREE
+1F334;ID # PALM TREE
+1F335;ID # CACTUS
+1F337;ID # TULIP
+1F338;ID # CHERRY BLOSSOM
+1F339;ID # ROSE
+1F33A;ID # HIBISCUS
+1F33B;ID # SUNFLOWER
+1F33C;ID # BLOSSOM
+1F33D;ID # EAR OF MAIZE
+1F33E;ID # EAR OF RICE
+1F33F;ID # HERB
+1F340;ID # FOUR LEAF CLOVER
+1F341;ID # MAPLE LEAF
+1F342;ID # FALLEN LEAF
+1F343;ID # LEAF FLUTTERING IN WIND
+1F344;ID # MUSHROOM
+1F345;ID # TOMATO
+1F346;ID # AUBERGINE
+1F347;ID # GRAPES
+1F348;ID # MELON
+1F349;ID # WATERMELON
+1F34A;ID # TANGERINE
+1F34B;ID # LEMON
+1F34C;ID # BANANA
+1F34D;ID # PINEAPPLE
+1F34E;ID # RED APPLE
+1F34F;ID # GREEN APPLE
+1F350;ID # PEAR
+1F351;ID # PEACH
+1F352;ID # CHERRIES
+1F353;ID # STRAWBERRY
+1F354;ID # HAMBURGER
+1F355;ID # SLICE OF PIZZA
+1F356;ID # MEAT ON BONE
+1F357;ID # POULTRY LEG
+1F358;ID # RICE CRACKER
+1F359;ID # RICE BALL
+1F35A;ID # COOKED RICE
+1F35B;ID # CURRY AND RICE
+1F35C;ID # STEAMING BOWL
+1F35D;ID # SPAGHETTI
+1F35E;ID # BREAD
+1F35F;ID # FRENCH FRIES
+1F360;ID # ROASTED SWEET POTATO
+1F361;ID # DANGO
+1F362;ID # ODEN
+1F363;ID # SUSHI
+1F364;ID # FRIED SHRIMP
+1F365;ID # FISH CAKE WITH SWIRL DESIGN
+1F366;ID # SOFT ICE CREAM
+1F367;ID # SHAVED ICE
+1F368;ID # ICE CREAM
+1F369;ID # DOUGHNUT
+1F36A;ID # COOKIE
+1F36B;ID # CHOCOLATE BAR
+1F36C;ID # CANDY
+1F36D;ID # LOLLIPOP
+1F36E;ID # CUSTARD
+1F36F;ID # HONEY POT
+1F370;ID # SHORTCAKE
+1F371;ID # BENTO BOX
+1F372;ID # POT OF FOOD
+1F373;ID # COOKING
+1F374;ID # FORK AND KNIFE
+1F375;ID # TEACUP WITHOUT HANDLE
+1F376;ID # SAKE BOTTLE AND CUP
+1F377;ID # WINE GLASS
+1F378;ID # COCKTAIL GLASS
+1F379;ID # TROPICAL DRINK
+1F37A;ID # BEER MUG
+1F37B;ID # CLINKING BEER MUGS
+1F37C;ID # BABY BOTTLE
+1F380;ID # RIBBON
+1F381;ID # WRAPPED PRESENT
+1F382;ID # BIRTHDAY CAKE
+1F383;ID # JACK-O-LANTERN
+1F384;ID # CHRISTMAS TREE
+1F385;ID # FATHER CHRISTMAS
+1F386;ID # FIREWORKS
+1F387;ID # FIREWORK SPARKLER
+1F388;ID # BALLOON
+1F389;ID # PARTY POPPER
+1F38A;ID # CONFETTI BALL
+1F38B;ID # TANABATA TREE
+1F38C;ID # CROSSED FLAGS
+1F38D;ID # PINE DECORATION
+1F38E;ID # JAPANESE DOLLS
+1F38F;ID # CARP STREAMER
+1F390;ID # WIND CHIME
+1F391;ID # MOON VIEWING CEREMONY
+1F392;ID # SCHOOL SATCHEL
+1F393;ID # GRADUATION CAP
+1F3A0;ID # CAROUSEL HORSE
+1F3A1;ID # FERRIS WHEEL
+1F3A2;ID # ROLLER COASTER
+1F3A3;ID # FISHING POLE AND FISH
+1F3A4;ID # MICROPHONE
+1F3A5;ID # MOVIE CAMERA
+1F3A6;ID # CINEMA
+1F3A7;ID # HEADPHONE
+1F3A8;ID # ARTIST PALETTE
+1F3A9;ID # TOP HAT
+1F3AA;ID # CIRCUS TENT
+1F3AB;ID # TICKET
+1F3AC;ID # CLAPPER BOARD
+1F3AD;ID # PERFORMING ARTS
+1F3AE;ID # VIDEO GAME
+1F3AF;ID # DIRECT HIT
+1F3B0;ID # SLOT MACHINE
+1F3B1;ID # BILLIARDS
+1F3B2;ID # GAME DIE
+1F3B3;ID # BOWLING
+1F3B4;ID # FLOWER PLAYING CARDS
1F3B5;AL # MUSICAL NOTE
1F3B6;AL # MULTIPLE MUSICAL NOTES
-1F3B7;AL # SAXOPHONE
-1F3B8;AL # GUITAR
-1F3B9;AL # MUSICAL KEYBOARD
-1F3BA;AL # TRUMPET
-1F3BB;AL # VIOLIN
+1F3B7;ID # SAXOPHONE
+1F3B8;ID # GUITAR
+1F3B9;ID # MUSICAL KEYBOARD
+1F3BA;ID # TRUMPET
+1F3BB;ID # VIOLIN
1F3BC;AL # MUSICAL SCORE
-1F3BD;AL # RUNNING SHIRT WITH SASH
-1F3BE;AL # TENNIS RACQUET AND BALL
-1F3BF;AL # SKI AND SKI BOOT
-1F3C0;AL # BASKETBALL AND HOOP
-1F3C1;AL # CHEQUERED FLAG
-1F3C2;AL # SNOWBOARDER
-1F3C3;AL # RUNNER
-1F3C4;AL # SURFER
-1F3C6;AL # TROPHY
-1F3C7;AL # HORSE RACING
-1F3C8;AL # AMERICAN FOOTBALL
-1F3C9;AL # RUGBY FOOTBALL
-1F3CA;AL # SWIMMER
-1F3E0;AL # HOUSE BUILDING
-1F3E1;AL # HOUSE WITH GARDEN
-1F3E2;AL # OFFICE BUILDING
-1F3E3;AL # JAPANESE POST OFFICE
-1F3E4;AL # EUROPEAN POST OFFICE
-1F3E5;AL # HOSPITAL
-1F3E6;AL # BANK
-1F3E7;AL # AUTOMATED TELLER MACHINE
-1F3E8;AL # HOTEL
-1F3E9;AL # LOVE HOTEL
-1F3EA;AL # CONVENIENCE STORE
-1F3EB;AL # SCHOOL
-1F3EC;AL # DEPARTMENT STORE
-1F3ED;AL # FACTORY
-1F3EE;AL # IZAKAYA LANTERN
-1F3EF;AL # JAPANESE CASTLE
-1F3F0;AL # EUROPEAN CASTLE
-1F400;AL # RAT
-1F401;AL # MOUSE
-1F402;AL # OX
-1F403;AL # WATER BUFFALO
-1F404;AL # COW
-1F405;AL # TIGER
-1F406;AL # LEOPARD
-1F407;AL # RABBIT
-1F408;AL # CAT
-1F409;AL # DRAGON
-1F40A;AL # CROCODILE
-1F40B;AL # WHALE
-1F40C;AL # SNAIL
-1F40D;AL # SNAKE
-1F40E;AL # HORSE
-1F40F;AL # RAM
-1F410;AL # GOAT
-1F411;AL # SHEEP
-1F412;AL # MONKEY
-1F413;AL # ROOSTER
-1F414;AL # CHICKEN
-1F415;AL # DOG
-1F416;AL # PIG
-1F417;AL # BOAR
-1F418;AL # ELEPHANT
-1F419;AL # OCTOPUS
-1F41A;AL # SPIRAL SHELL
-1F41B;AL # BUG
-1F41C;AL # ANT
-1F41D;AL # HONEYBEE
-1F41E;AL # LADY BEETLE
-1F41F;AL # FISH
-1F420;AL # TROPICAL FISH
-1F421;AL # BLOWFISH
-1F422;AL # TURTLE
-1F423;AL # HATCHING CHICK
-1F424;AL # BABY CHICK
-1F425;AL # FRONT-FACING BABY CHICK
-1F426;AL # BIRD
-1F427;AL # PENGUIN
-1F428;AL # KOALA
-1F429;AL # POODLE
-1F42A;AL # DROMEDARY CAMEL
-1F42B;AL # BACTRIAN CAMEL
-1F42C;AL # DOLPHIN
-1F42D;AL # MOUSE FACE
-1F42E;AL # COW FACE
-1F42F;AL # TIGER FACE
-1F430;AL # RABBIT FACE
-1F431;AL # CAT FACE
-1F432;AL # DRAGON FACE
-1F433;AL # SPOUTING WHALE
-1F434;AL # HORSE FACE
-1F435;AL # MONKEY FACE
-1F436;AL # DOG FACE
-1F437;AL # PIG FACE
-1F438;AL # FROG FACE
-1F439;AL # HAMSTER FACE
-1F43A;AL # WOLF FACE
-1F43B;AL # BEAR FACE
-1F43C;AL # PANDA FACE
-1F43D;AL # PIG NOSE
-1F43E;AL # PAW PRINTS
-1F440;AL # EYES
-1F442;AL # EAR
-1F443;AL # NOSE
-1F444;AL # MOUTH
-1F445;AL # TONGUE
-1F446;AL # WHITE UP POINTING BACKHAND INDEX
-1F447;AL # WHITE DOWN POINTING BACKHAND INDEX
-1F448;AL # WHITE LEFT POINTING BACKHAND INDEX
-1F449;AL # WHITE RIGHT POINTING BACKHAND INDEX
-1F44A;AL # FISTED HAND SIGN
-1F44B;AL # WAVING HAND SIGN
-1F44C;AL # OK HAND SIGN
-1F44D;AL # THUMBS UP SIGN
-1F44E;AL # THUMBS DOWN SIGN
-1F44F;AL # CLAPPING HANDS SIGN
-1F450;AL # OPEN HANDS SIGN
-1F451;AL # CROWN
-1F452;AL # WOMANS HAT
-1F453;AL # EYEGLASSES
-1F454;AL # NECKTIE
-1F455;AL # T-SHIRT
-1F456;AL # JEANS
-1F457;AL # DRESS
-1F458;AL # KIMONO
-1F459;AL # BIKINI
-1F45A;AL # WOMANS CLOTHES
-1F45B;AL # PURSE
-1F45C;AL # HANDBAG
-1F45D;AL # POUCH
-1F45E;AL # MANS SHOE
-1F45F;AL # ATHLETIC SHOE
-1F460;AL # HIGH-HEELED SHOE
-1F461;AL # WOMANS SANDAL
-1F462;AL # WOMANS BOOTS
-1F463;AL # FOOTPRINTS
-1F464;AL # BUST IN SILHOUETTE
-1F465;AL # BUSTS IN SILHOUETTE
-1F466;AL # BOY
-1F467;AL # GIRL
-1F468;AL # MAN
-1F469;AL # WOMAN
-1F46A;AL # FAMILY
-1F46B;AL # MAN AND WOMAN HOLDING HANDS
-1F46C;AL # TWO MEN HOLDING HANDS
-1F46D;AL # TWO WOMEN HOLDING HANDS
-1F46E;AL # POLICE OFFICER
-1F46F;AL # WOMAN WITH BUNNY EARS
-1F470;AL # BRIDE WITH VEIL
-1F471;AL # PERSON WITH BLOND HAIR
-1F472;AL # MAN WITH GUA PI MAO
-1F473;AL # MAN WITH TURBAN
-1F474;AL # OLDER MAN
-1F475;AL # OLDER WOMAN
-1F476;AL # BABY
-1F477;AL # CONSTRUCTION WORKER
-1F478;AL # PRINCESS
-1F479;AL # JAPANESE OGRE
-1F47A;AL # JAPANESE GOBLIN
-1F47B;AL # GHOST
-1F47C;AL # BABY ANGEL
-1F47D;AL # EXTRATERRESTRIAL ALIEN
-1F47E;AL # ALIEN MONSTER
-1F47F;AL # IMP
-1F480;AL # SKULL
-1F481;AL # INFORMATION DESK PERSON
-1F482;AL # GUARDSMAN
-1F483;AL # DANCER
-1F484;AL # LIPSTICK
-1F485;AL # NAIL POLISH
-1F486;AL # FACE MASSAGE
-1F487;AL # HAIRCUT
-1F488;AL # BARBER POLE
-1F489;AL # SYRINGE
-1F48A;AL # PILL
-1F48B;AL # KISS MARK
-1F48C;AL # LOVE LETTER
-1F48D;AL # RING
-1F48E;AL # GEM STONE
-1F48F;AL # KISS
-1F490;AL # BOUQUET
-1F491;AL # COUPLE WITH HEART
-1F492;AL # WEDDING
-1F493;AL # BEATING HEART
-1F494;AL # BROKEN HEART
-1F495;AL # TWO HEARTS
-1F496;AL # SPARKLING HEART
-1F497;AL # GROWING HEART
-1F498;AL # HEART WITH ARROW
-1F499;AL # BLUE HEART
-1F49A;AL # GREEN HEART
-1F49B;AL # YELLOW HEART
-1F49C;AL # PURPLE HEART
-1F49D;AL # HEART WITH RIBBON
-1F49E;AL # REVOLVING HEARTS
-1F49F;AL # HEART DECORATION
+1F3BD;ID # RUNNING SHIRT WITH SASH
+1F3BE;ID # TENNIS RACQUET AND BALL
+1F3BF;ID # SKI AND SKI BOOT
+1F3C0;ID # BASKETBALL AND HOOP
+1F3C1;ID # CHEQUERED FLAG
+1F3C2;ID # SNOWBOARDER
+1F3C3;ID # RUNNER
+1F3C4;ID # SURFER
+1F3C6;ID # TROPHY
+1F3C7;ID # HORSE RACING
+1F3C8;ID # AMERICAN FOOTBALL
+1F3C9;ID # RUGBY FOOTBALL
+1F3CA;ID # SWIMMER
+1F3E0;ID # HOUSE BUILDING
+1F3E1;ID # HOUSE WITH GARDEN
+1F3E2;ID # OFFICE BUILDING
+1F3E3;ID # JAPANESE POST OFFICE
+1F3E4;ID # EUROPEAN POST OFFICE
+1F3E5;ID # HOSPITAL
+1F3E6;ID # BANK
+1F3E7;ID # AUTOMATED TELLER MACHINE
+1F3E8;ID # HOTEL
+1F3E9;ID # LOVE HOTEL
+1F3EA;ID # CONVENIENCE STORE
+1F3EB;ID # SCHOOL
+1F3EC;ID # DEPARTMENT STORE
+1F3ED;ID # FACTORY
+1F3EE;ID # IZAKAYA LANTERN
+1F3EF;ID # JAPANESE CASTLE
+1F3F0;ID # EUROPEAN CASTLE
+1F400;ID # RAT
+1F401;ID # MOUSE
+1F402;ID # OX
+1F403;ID # WATER BUFFALO
+1F404;ID # COW
+1F405;ID # TIGER
+1F406;ID # LEOPARD
+1F407;ID # RABBIT
+1F408;ID # CAT
+1F409;ID # DRAGON
+1F40A;ID # CROCODILE
+1F40B;ID # WHALE
+1F40C;ID # SNAIL
+1F40D;ID # SNAKE
+1F40E;ID # HORSE
+1F40F;ID # RAM
+1F410;ID # GOAT
+1F411;ID # SHEEP
+1F412;ID # MONKEY
+1F413;ID # ROOSTER
+1F414;ID # CHICKEN
+1F415;ID # DOG
+1F416;ID # PIG
+1F417;ID # BOAR
+1F418;ID # ELEPHANT
+1F419;ID # OCTOPUS
+1F41A;ID # SPIRAL SHELL
+1F41B;ID # BUG
+1F41C;ID # ANT
+1F41D;ID # HONEYBEE
+1F41E;ID # LADY BEETLE
+1F41F;ID # FISH
+1F420;ID # TROPICAL FISH
+1F421;ID # BLOWFISH
+1F422;ID # TURTLE
+1F423;ID # HATCHING CHICK
+1F424;ID # BABY CHICK
+1F425;ID # FRONT-FACING BABY CHICK
+1F426;ID # BIRD
+1F427;ID # PENGUIN
+1F428;ID # KOALA
+1F429;ID # POODLE
+1F42A;ID # DROMEDARY CAMEL
+1F42B;ID # BACTRIAN CAMEL
+1F42C;ID # DOLPHIN
+1F42D;ID # MOUSE FACE
+1F42E;ID # COW FACE
+1F42F;ID # TIGER FACE
+1F430;ID # RABBIT FACE
+1F431;ID # CAT FACE
+1F432;ID # DRAGON FACE
+1F433;ID # SPOUTING WHALE
+1F434;ID # HORSE FACE
+1F435;ID # MONKEY FACE
+1F436;ID # DOG FACE
+1F437;ID # PIG FACE
+1F438;ID # FROG FACE
+1F439;ID # HAMSTER FACE
+1F43A;ID # WOLF FACE
+1F43B;ID # BEAR FACE
+1F43C;ID # PANDA FACE
+1F43D;ID # PIG NOSE
+1F43E;ID # PAW PRINTS
+1F440;ID # EYES
+1F442;ID # EAR
+1F443;ID # NOSE
+1F444;ID # MOUTH
+1F445;ID # TONGUE
+1F446;ID # WHITE UP POINTING BACKHAND INDEX
+1F447;ID # WHITE DOWN POINTING BACKHAND INDEX
+1F448;ID # WHITE LEFT POINTING BACKHAND INDEX
+1F449;ID # WHITE RIGHT POINTING BACKHAND INDEX
+1F44A;ID # FISTED HAND SIGN
+1F44B;ID # WAVING HAND SIGN
+1F44C;ID # OK HAND SIGN
+1F44D;ID # THUMBS UP SIGN
+1F44E;ID # THUMBS DOWN SIGN
+1F44F;ID # CLAPPING HANDS SIGN
+1F450;ID # OPEN HANDS SIGN
+1F451;ID # CROWN
+1F452;ID # WOMANS HAT
+1F453;ID # EYEGLASSES
+1F454;ID # NECKTIE
+1F455;ID # T-SHIRT
+1F456;ID # JEANS
+1F457;ID # DRESS
+1F458;ID # KIMONO
+1F459;ID # BIKINI
+1F45A;ID # WOMANS CLOTHES
+1F45B;ID # PURSE
+1F45C;ID # HANDBAG
+1F45D;ID # POUCH
+1F45E;ID # MANS SHOE
+1F45F;ID # ATHLETIC SHOE
+1F460;ID # HIGH-HEELED SHOE
+1F461;ID # WOMANS SANDAL
+1F462;ID # WOMANS BOOTS
+1F463;ID # FOOTPRINTS
+1F464;ID # BUST IN SILHOUETTE
+1F465;ID # BUSTS IN SILHOUETTE
+1F466;ID # BOY
+1F467;ID # GIRL
+1F468;ID # MAN
+1F469;ID # WOMAN
+1F46A;ID # FAMILY
+1F46B;ID # MAN AND WOMAN HOLDING HANDS
+1F46C;ID # TWO MEN HOLDING HANDS
+1F46D;ID # TWO WOMEN HOLDING HANDS
+1F46E;ID # POLICE OFFICER
+1F46F;ID # WOMAN WITH BUNNY EARS
+1F470;ID # BRIDE WITH VEIL
+1F471;ID # PERSON WITH BLOND HAIR
+1F472;ID # MAN WITH GUA PI MAO
+1F473;ID # MAN WITH TURBAN
+1F474;ID # OLDER MAN
+1F475;ID # OLDER WOMAN
+1F476;ID # BABY
+1F477;ID # CONSTRUCTION WORKER
+1F478;ID # PRINCESS
+1F479;ID # JAPANESE OGRE
+1F47A;ID # JAPANESE GOBLIN
+1F47B;ID # GHOST
+1F47C;ID # BABY ANGEL
+1F47D;ID # EXTRATERRESTRIAL ALIEN
+1F47E;ID # ALIEN MONSTER
+1F47F;ID # IMP
+1F480;ID # SKULL
+1F481;ID # INFORMATION DESK PERSON
+1F482;ID # GUARDSMAN
+1F483;ID # DANCER
+1F484;ID # LIPSTICK
+1F485;ID # NAIL POLISH
+1F486;ID # FACE MASSAGE
+1F487;ID # HAIRCUT
+1F488;ID # BARBER POLE
+1F489;ID # SYRINGE
+1F48A;ID # PILL
+1F48B;ID # KISS MARK
+1F48C;ID # LOVE LETTER
+1F48D;ID # RING
+1F48E;ID # GEM STONE
+1F48F;ID # KISS
+1F490;ID # BOUQUET
+1F491;ID # COUPLE WITH HEART
+1F492;ID # WEDDING
+1F493;ID # BEATING HEART
+1F494;ID # BROKEN HEART
+1F495;ID # TWO HEARTS
+1F496;ID # SPARKLING HEART
+1F497;ID # GROWING HEART
+1F498;ID # HEART WITH ARROW
+1F499;ID # BLUE HEART
+1F49A;ID # GREEN HEART
+1F49B;ID # YELLOW HEART
+1F49C;ID # PURPLE HEART
+1F49D;ID # HEART WITH RIBBON
+1F49E;ID # REVOLVING HEARTS
+1F49F;ID # HEART DECORATION
1F4A0;AL # DIAMOND SHAPE WITH A DOT INSIDE
-1F4A1;AL # ELECTRIC LIGHT BULB
+1F4A1;ID # ELECTRIC LIGHT BULB
1F4A2;AL # ANGER SYMBOL
-1F4A3;AL # BOMB
+1F4A3;ID # BOMB
1F4A4;AL # SLEEPING SYMBOL
-1F4A5;AL # COLLISION SYMBOL
-1F4A6;AL # SPLASHING SWEAT SYMBOL
-1F4A7;AL # DROPLET
-1F4A8;AL # DASH SYMBOL
-1F4A9;AL # PILE OF POO
-1F4AA;AL # FLEXED BICEPS
-1F4AB;AL # DIZZY SYMBOL
-1F4AC;AL # SPEECH BALLOON
-1F4AD;AL # THOUGHT BALLOON
-1F4AE;AL # WHITE FLOWER
+1F4A5;ID # COLLISION SYMBOL
+1F4A6;ID # SPLASHING SWEAT SYMBOL
+1F4A7;ID # DROPLET
+1F4A8;ID # DASH SYMBOL
+1F4A9;ID # PILE OF POO
+1F4AA;ID # FLEXED BICEPS
+1F4AB;ID # DIZZY SYMBOL
+1F4AC;ID # SPEECH BALLOON
+1F4AD;ID # THOUGHT BALLOON
+1F4AE;ID # WHITE FLOWER
1F4AF;AL # HUNDRED POINTS SYMBOL
-1F4B0;AL # MONEY BAG
+1F4B0;ID # MONEY BAG
1F4B1;AL # CURRENCY EXCHANGE
1F4B2;AL # HEAVY DOLLAR SIGN
-1F4B3;AL # CREDIT CARD
-1F4B4;AL # BANKNOTE WITH YEN SIGN
-1F4B5;AL # BANKNOTE WITH DOLLAR SIGN
-1F4B6;AL # BANKNOTE WITH EURO SIGN
-1F4B7;AL # BANKNOTE WITH POUND SIGN
-1F4B8;AL # MONEY WITH WINGS
-1F4B9;AL # CHART WITH UPWARDS TREND AND YEN SIGN
-1F4BA;AL # SEAT
-1F4BB;AL # PERSONAL COMPUTER
-1F4BC;AL # BRIEFCASE
-1F4BD;AL # MINIDISC
-1F4BE;AL # FLOPPY DISK
-1F4BF;AL # OPTICAL DISC
-1F4C0;AL # DVD
-1F4C1;AL # FILE FOLDER
-1F4C2;AL # OPEN FILE FOLDER
-1F4C3;AL # PAGE WITH CURL
-1F4C4;AL # PAGE FACING UP
-1F4C5;AL # CALENDAR
-1F4C6;AL # TEAR-OFF CALENDAR
-1F4C7;AL # CARD INDEX
-1F4C8;AL # CHART WITH UPWARDS TREND
-1F4C9;AL # CHART WITH DOWNWARDS TREND
-1F4CA;AL # BAR CHART
-1F4CB;AL # CLIPBOARD
-1F4CC;AL # PUSHPIN
-1F4CD;AL # ROUND PUSHPIN
-1F4CE;AL # PAPERCLIP
-1F4CF;AL # STRAIGHT RULER
-1F4D0;AL # TRIANGULAR RULER
-1F4D1;AL # BOOKMARK TABS
-1F4D2;AL # LEDGER
-1F4D3;AL # NOTEBOOK
-1F4D4;AL # NOTEBOOK WITH DECORATIVE COVER
-1F4D5;AL # CLOSED BOOK
-1F4D6;AL # OPEN BOOK
-1F4D7;AL # GREEN BOOK
-1F4D8;AL # BLUE BOOK
-1F4D9;AL # ORANGE BOOK
-1F4DA;AL # BOOKS
-1F4DB;AL # NAME BADGE
-1F4DC;AL # SCROLL
-1F4DD;AL # MEMO
-1F4DE;AL # TELEPHONE RECEIVER
-1F4DF;AL # PAGER
-1F4E0;AL # FAX MACHINE
-1F4E1;AL # SATELLITE ANTENNA
-1F4E2;AL # PUBLIC ADDRESS LOUDSPEAKER
-1F4E3;AL # CHEERING MEGAPHONE
-1F4E4;AL # OUTBOX TRAY
-1F4E5;AL # INBOX TRAY
-1F4E6;AL # PACKAGE
-1F4E7;AL # E-MAIL SYMBOL
-1F4E8;AL # INCOMING ENVELOPE
-1F4E9;AL # ENVELOPE WITH DOWNWARDS ARROW ABOVE
-1F4EA;AL # CLOSED MAILBOX WITH LOWERED FLAG
-1F4EB;AL # CLOSED MAILBOX WITH RAISED FLAG
-1F4EC;AL # OPEN MAILBOX WITH RAISED FLAG
-1F4ED;AL # OPEN MAILBOX WITH LOWERED FLAG
-1F4EE;AL # POSTBOX
-1F4EF;AL # POSTAL HORN
-1F4F0;AL # NEWSPAPER
-1F4F1;AL # MOBILE PHONE
-1F4F2;AL # MOBILE PHONE WITH RIGHTWARDS ARROW AT LEFT
-1F4F3;AL # VIBRATION MODE
-1F4F4;AL # MOBILE PHONE OFF
-1F4F5;AL # NO MOBILE PHONES
-1F4F6;AL # ANTENNA WITH BARS
-1F4F7;AL # CAMERA
-1F4F9;AL # VIDEO CAMERA
-1F4FA;AL # TELEVISION
-1F4FB;AL # RADIO
-1F4FC;AL # VIDEOCASSETTE
+1F4B3;ID # CREDIT CARD
+1F4B4;ID # BANKNOTE WITH YEN SIGN
+1F4B5;ID # BANKNOTE WITH DOLLAR SIGN
+1F4B6;ID # BANKNOTE WITH EURO SIGN
+1F4B7;ID # BANKNOTE WITH POUND SIGN
+1F4B8;ID # MONEY WITH WINGS
+1F4B9;ID # CHART WITH UPWARDS TREND AND YEN SIGN
+1F4BA;ID # SEAT
+1F4BB;ID # PERSONAL COMPUTER
+1F4BC;ID # BRIEFCASE
+1F4BD;ID # MINIDISC
+1F4BE;ID # FLOPPY DISK
+1F4BF;ID # OPTICAL DISC
+1F4C0;ID # DVD
+1F4C1;ID # FILE FOLDER
+1F4C2;ID # OPEN FILE FOLDER
+1F4C3;ID # PAGE WITH CURL
+1F4C4;ID # PAGE FACING UP
+1F4C5;ID # CALENDAR
+1F4C6;ID # TEAR-OFF CALENDAR
+1F4C7;ID # CARD INDEX
+1F4C8;ID # CHART WITH UPWARDS TREND
+1F4C9;ID # CHART WITH DOWNWARDS TREND
+1F4CA;ID # BAR CHART
+1F4CB;ID # CLIPBOARD
+1F4CC;ID # PUSHPIN
+1F4CD;ID # ROUND PUSHPIN
+1F4CE;ID # PAPERCLIP
+1F4CF;ID # STRAIGHT RULER
+1F4D0;ID # TRIANGULAR RULER
+1F4D1;ID # BOOKMARK TABS
+1F4D2;ID # LEDGER
+1F4D3;ID # NOTEBOOK
+1F4D4;ID # NOTEBOOK WITH DECORATIVE COVER
+1F4D5;ID # CLOSED BOOK
+1F4D6;ID # OPEN BOOK
+1F4D7;ID # GREEN BOOK
+1F4D8;ID # BLUE BOOK
+1F4D9;ID # ORANGE BOOK
+1F4DA;ID # BOOKS
+1F4DB;ID # NAME BADGE
+1F4DC;ID # SCROLL
+1F4DD;ID # MEMO
+1F4DE;ID # TELEPHONE RECEIVER
+1F4DF;ID # PAGER
+1F4E0;ID # FAX MACHINE
+1F4E1;ID # SATELLITE ANTENNA
+1F4E2;ID # PUBLIC ADDRESS LOUDSPEAKER
+1F4E3;ID # CHEERING MEGAPHONE
+1F4E4;ID # OUTBOX TRAY
+1F4E5;ID # INBOX TRAY
+1F4E6;ID # PACKAGE
+1F4E7;ID # E-MAIL SYMBOL
+1F4E8;ID # INCOMING ENVELOPE
+1F4E9;ID # ENVELOPE WITH DOWNWARDS ARROW ABOVE
+1F4EA;ID # CLOSED MAILBOX WITH LOWERED FLAG
+1F4EB;ID # CLOSED MAILBOX WITH RAISED FLAG
+1F4EC;ID # OPEN MAILBOX WITH RAISED FLAG
+1F4ED;ID # OPEN MAILBOX WITH LOWERED FLAG
+1F4EE;ID # POSTBOX
+1F4EF;ID # POSTAL HORN
+1F4F0;ID # NEWSPAPER
+1F4F1;ID # MOBILE PHONE
+1F4F2;ID # MOBILE PHONE WITH RIGHTWARDS ARROW AT LEFT
+1F4F3;ID # VIBRATION MODE
+1F4F4;ID # MOBILE PHONE OFF
+1F4F5;ID # NO MOBILE PHONES
+1F4F6;ID # ANTENNA WITH BARS
+1F4F7;ID # CAMERA
+1F4F9;ID # VIDEO CAMERA
+1F4FA;ID # TELEVISION
+1F4FB;ID # RADIO
+1F4FC;ID # VIDEOCASSETTE
1F500;AL # TWISTED RIGHTWARDS ARROWS
1F501;AL # CLOCKWISE RIGHTWARDS AND LEFTWARDS OPEN CIRCLE ARROWS
1F502;AL # CLOCKWISE RIGHTWARDS AND LEFTWARDS OPEN CIRCLE ARROWS WITH CIRCLED ONE OVERLAY
@@ -23313,22 +24027,22 @@
1F504;AL # ANTICLOCKWISE DOWNWARDS AND UPWARDS OPEN CIRCLE ARROWS
1F505;AL # LOW BRIGHTNESS SYMBOL
1F506;AL # HIGH BRIGHTNESS SYMBOL
-1F507;AL # SPEAKER WITH CANCELLATION STROKE
-1F508;AL # SPEAKER
-1F509;AL # SPEAKER WITH ONE SOUND WAVE
-1F50A;AL # SPEAKER WITH THREE SOUND WAVES
-1F50B;AL # BATTERY
-1F50C;AL # ELECTRIC PLUG
-1F50D;AL # LEFT-POINTING MAGNIFYING GLASS
-1F50E;AL # RIGHT-POINTING MAGNIFYING GLASS
-1F50F;AL # LOCK WITH INK PEN
-1F510;AL # CLOSED LOCK WITH KEY
-1F511;AL # KEY
-1F512;AL # LOCK
-1F513;AL # OPEN LOCK
-1F514;AL # BELL
-1F515;AL # BELL WITH CANCELLATION STROKE
-1F516;AL # BOOKMARK
+1F507;ID # SPEAKER WITH CANCELLATION STROKE
+1F508;ID # SPEAKER
+1F509;ID # SPEAKER WITH ONE SOUND WAVE
+1F50A;ID # SPEAKER WITH THREE SOUND WAVES
+1F50B;ID # BATTERY
+1F50C;ID # ELECTRIC PLUG
+1F50D;ID # LEFT-POINTING MAGNIFYING GLASS
+1F50E;ID # RIGHT-POINTING MAGNIFYING GLASS
+1F50F;ID # LOCK WITH INK PEN
+1F510;ID # CLOSED LOCK WITH KEY
+1F511;ID # KEY
+1F512;ID # LOCK
+1F513;ID # OPEN LOCK
+1F514;ID # BELL
+1F515;ID # BELL WITH CANCELLATION STROKE
+1F516;ID # BOOKMARK
1F517;AL # LINK SYMBOL
1F518;AL # RADIO BUTTON
1F519;AL # BACK WITH LEFTWARDS ARROW ABOVE
@@ -23343,19 +24057,19 @@
1F522;AL # INPUT SYMBOL FOR NUMBERS
1F523;AL # INPUT SYMBOL FOR SYMBOLS
1F524;AL # INPUT SYMBOL FOR LATIN LETTERS
-1F525;AL # FIRE
-1F526;AL # ELECTRIC TORCH
-1F527;AL # WRENCH
-1F528;AL # HAMMER
-1F529;AL # NUT AND BOLT
-1F52A;AL # HOCHO
-1F52B;AL # PISTOL
-1F52C;AL # MICROSCOPE
-1F52D;AL # TELESCOPE
-1F52E;AL # CRYSTAL BALL
-1F52F;AL # SIX POINTED STAR WITH MIDDLE DOT
-1F530;AL # JAPANESE SYMBOL FOR BEGINNER
-1F531;AL # TRIDENT EMBLEM
+1F525;ID # FIRE
+1F526;ID # ELECTRIC TORCH
+1F527;ID # WRENCH
+1F528;ID # HAMMER
+1F529;ID # NUT AND BOLT
+1F52A;ID # HOCHO
+1F52B;ID # PISTOL
+1F52C;ID # MICROSCOPE
+1F52D;ID # TELESCOPE
+1F52E;ID # CRYSTAL BALL
+1F52F;ID # SIX POINTED STAR WITH MIDDLE DOT
+1F530;ID # JAPANESE SYMBOL FOR BEGINNER
+1F531;ID # TRIDENT EMBLEM
1F532;AL # BLACK SQUARE BUTTON
1F533;AL # WHITE SQUARE BUTTON
1F534;AL # LARGE RED CIRCLE
@@ -23368,168 +24082,185 @@
1F53B;AL # DOWN-POINTING RED TRIANGLE
1F53C;AL # UP-POINTING SMALL RED TRIANGLE
1F53D;AL # DOWN-POINTING SMALL RED TRIANGLE
-1F550;AL # CLOCK FACE ONE OCLOCK
-1F551;AL # CLOCK FACE TWO OCLOCK
-1F552;AL # CLOCK FACE THREE OCLOCK
-1F553;AL # CLOCK FACE FOUR OCLOCK
-1F554;AL # CLOCK FACE FIVE OCLOCK
-1F555;AL # CLOCK FACE SIX OCLOCK
-1F556;AL # CLOCK FACE SEVEN OCLOCK
-1F557;AL # CLOCK FACE EIGHT OCLOCK
-1F558;AL # CLOCK FACE NINE OCLOCK
-1F559;AL # CLOCK FACE TEN OCLOCK
-1F55A;AL # CLOCK FACE ELEVEN OCLOCK
-1F55B;AL # CLOCK FACE TWELVE OCLOCK
-1F55C;AL # CLOCK FACE ONE-THIRTY
-1F55D;AL # CLOCK FACE TWO-THIRTY
-1F55E;AL # CLOCK FACE THREE-THIRTY
-1F55F;AL # CLOCK FACE FOUR-THIRTY
-1F560;AL # CLOCK FACE FIVE-THIRTY
-1F561;AL # CLOCK FACE SIX-THIRTY
-1F562;AL # CLOCK FACE SEVEN-THIRTY
-1F563;AL # CLOCK FACE EIGHT-THIRTY
-1F564;AL # CLOCK FACE NINE-THIRTY
-1F565;AL # CLOCK FACE TEN-THIRTY
-1F566;AL # CLOCK FACE ELEVEN-THIRTY
-1F567;AL # CLOCK FACE TWELVE-THIRTY
-1F5FB;AL # MOUNT FUJI
-1F5FC;AL # TOKYO TOWER
-1F5FD;AL # STATUE OF LIBERTY
-1F5FE;AL # SILHOUETTE OF JAPAN
-1F5FF;AL # MOYAI
-1F601;AL # GRINNING FACE WITH SMILING EYES
-1F602;AL # FACE WITH TEARS OF JOY
-1F603;AL # SMILING FACE WITH OPEN MOUTH
-1F604;AL # SMILING FACE WITH OPEN MOUTH AND SMILING EYES
-1F605;AL # SMILING FACE WITH OPEN MOUTH AND COLD SWEAT
-1F606;AL # SMILING FACE WITH OPEN MOUTH AND TIGHTLY-CLOSED EYES
-1F607;AL # SMILING FACE WITH HALO
-1F608;AL # SMILING FACE WITH HORNS
-1F609;AL # WINKING FACE
-1F60A;AL # SMILING FACE WITH SMILING EYES
-1F60B;AL # FACE SAVOURING DELICIOUS FOOD
-1F60C;AL # RELIEVED FACE
-1F60D;AL # SMILING FACE WITH HEART-SHAPED EYES
-1F60E;AL # SMILING FACE WITH SUNGLASSES
-1F60F;AL # SMIRKING FACE
-1F610;AL # NEUTRAL FACE
-1F612;AL # UNAMUSED FACE
-1F613;AL # FACE WITH COLD SWEAT
-1F614;AL # PENSIVE FACE
-1F616;AL # CONFOUNDED FACE
-1F618;AL # FACE THROWING A KISS
-1F61A;AL # KISSING FACE WITH CLOSED EYES
-1F61C;AL # FACE WITH STUCK-OUT TONGUE AND WINKING EYE
-1F61D;AL # FACE WITH STUCK-OUT TONGUE AND TIGHTLY-CLOSED EYES
-1F61E;AL # DISAPPOINTED FACE
-1F620;AL # ANGRY FACE
-1F621;AL # POUTING FACE
-1F622;AL # CRYING FACE
-1F623;AL # PERSEVERING FACE
-1F624;AL # FACE WITH LOOK OF TRIUMPH
-1F625;AL # DISAPPOINTED BUT RELIEVED FACE
-1F628;AL # FEARFUL FACE
-1F629;AL # WEARY FACE
-1F62A;AL # SLEEPY FACE
-1F62B;AL # TIRED FACE
-1F62D;AL # LOUDLY CRYING FACE
-1F630;AL # FACE WITH OPEN MOUTH AND COLD SWEAT
-1F631;AL # FACE SCREAMING IN FEAR
-1F632;AL # ASTONISHED FACE
-1F633;AL # FLUSHED FACE
-1F635;AL # DIZZY FACE
-1F636;AL # FACE WITHOUT MOUTH
-1F637;AL # FACE WITH MEDICAL MASK
-1F638;AL # GRINNING CAT FACE WITH SMILING EYES
-1F639;AL # CAT FACE WITH TEARS OF JOY
-1F63A;AL # SMILING CAT FACE WITH OPEN MOUTH
-1F63B;AL # SMILING CAT FACE WITH HEART-SHAPED EYES
-1F63C;AL # CAT FACE WITH WRY SMILE
-1F63D;AL # KISSING CAT FACE WITH CLOSED EYES
-1F63E;AL # POUTING CAT FACE
-1F63F;AL # CRYING CAT FACE
-1F640;AL # WEARY CAT FACE
-1F645;AL # FACE WITH NO GOOD GESTURE
-1F646;AL # FACE WITH OK GESTURE
-1F647;AL # PERSON BOWING DEEPLY
-1F648;AL # SEE-NO-EVIL MONKEY
-1F649;AL # HEAR-NO-EVIL MONKEY
-1F64A;AL # SPEAK-NO-EVIL MONKEY
-1F64B;AL # HAPPY PERSON RAISING ONE HAND
-1F64C;AL # PERSON RAISING BOTH HANDS IN CELEBRATION
-1F64D;AL # PERSON FROWNING
-1F64E;AL # PERSON WITH POUTING FACE
-1F64F;AL # PERSON WITH FOLDED HANDS
-1F680;AL # ROCKET
-1F681;AL # HELICOPTER
-1F682;AL # STEAM LOCOMOTIVE
-1F683;AL # RAILWAY CAR
-1F684;AL # HIGH-SPEED TRAIN
-1F685;AL # HIGH-SPEED TRAIN WITH BULLET NOSE
-1F686;AL # TRAIN
-1F687;AL # METRO
-1F688;AL # LIGHT RAIL
-1F689;AL # STATION
-1F68A;AL # TRAM
-1F68B;AL # TRAM CAR
-1F68C;AL # BUS
-1F68D;AL # ONCOMING BUS
-1F68E;AL # TROLLEYBUS
-1F68F;AL # BUS STOP
-1F690;AL # MINIBUS
-1F691;AL # AMBULANCE
-1F692;AL # FIRE ENGINE
-1F693;AL # POLICE CAR
-1F694;AL # ONCOMING POLICE CAR
-1F695;AL # TAXI
-1F696;AL # ONCOMING TAXI
-1F697;AL # AUTOMOBILE
-1F698;AL # ONCOMING AUTOMOBILE
-1F699;AL # RECREATIONAL VEHICLE
-1F69A;AL # DELIVERY TRUCK
-1F69B;AL # ARTICULATED LORRY
-1F69C;AL # TRACTOR
-1F69D;AL # MONORAIL
-1F69E;AL # MOUNTAIN RAILWAY
-1F69F;AL # SUSPENSION RAILWAY
-1F6A0;AL # MOUNTAIN CABLEWAY
-1F6A1;AL # AERIAL TRAMWAY
-1F6A2;AL # SHIP
-1F6A3;AL # ROWBOAT
-1F6A4;AL # SPEEDBOAT
-1F6A5;AL # HORIZONTAL TRAFFIC LIGHT
-1F6A6;AL # VERTICAL TRAFFIC LIGHT
-1F6A7;AL # CONSTRUCTION SIGN
-1F6A8;AL # POLICE CARS REVOLVING LIGHT
-1F6A9;AL # TRIANGULAR FLAG ON POST
-1F6AA;AL # DOOR
-1F6AB;AL # NO ENTRY SIGN
-1F6AC;AL # SMOKING SYMBOL
-1F6AD;AL # NO SMOKING SYMBOL
-1F6AE;AL # PUT LITTER IN ITS PLACE SYMBOL
-1F6AF;AL # DO NOT LITTER SYMBOL
-1F6B0;AL # POTABLE WATER SYMBOL
-1F6B1;AL # NON-POTABLE WATER SYMBOL
-1F6B2;AL # BICYCLE
-1F6B3;AL # NO BICYCLES
-1F6B4;AL # BICYCLIST
-1F6B5;AL # MOUNTAIN BICYCLIST
-1F6B6;AL # PEDESTRIAN
-1F6B7;AL # NO PEDESTRIANS
-1F6B8;AL # CHILDREN CROSSING
-1F6B9;AL # MENS SYMBOL
-1F6BA;AL # WOMENS SYMBOL
-1F6BB;AL # RESTROOM
-1F6BC;AL # BABY SYMBOL
-1F6BD;AL # TOILET
-1F6BE;AL # WATER CLOSET
-1F6BF;AL # SHOWER
-1F6C0;AL # BATH
-1F6C1;AL # BATHTUB
-1F6C2;AL # PASSPORT CONTROL
-1F6C3;AL # CUSTOMS
-1F6C4;AL # BAGGAGE CLAIM
-1F6C5;AL # LEFT LUGGAGE
+1F540;AL # CIRCLED CROSS POMMEE
+1F541;AL # CROSS POMMEE WITH HALF-CIRCLE BELOW
+1F542;AL # CROSS POMMEE
+1F543;AL # NOTCHED LEFT SEMICIRCLE WITH THREE DOTS
+1F550;ID # CLOCK FACE ONE OCLOCK
+1F551;ID # CLOCK FACE TWO OCLOCK
+1F552;ID # CLOCK FACE THREE OCLOCK
+1F553;ID # CLOCK FACE FOUR OCLOCK
+1F554;ID # CLOCK FACE FIVE OCLOCK
+1F555;ID # CLOCK FACE SIX OCLOCK
+1F556;ID # CLOCK FACE SEVEN OCLOCK
+1F557;ID # CLOCK FACE EIGHT OCLOCK
+1F558;ID # CLOCK FACE NINE OCLOCK
+1F559;ID # CLOCK FACE TEN OCLOCK
+1F55A;ID # CLOCK FACE ELEVEN OCLOCK
+1F55B;ID # CLOCK FACE TWELVE OCLOCK
+1F55C;ID # CLOCK FACE ONE-THIRTY
+1F55D;ID # CLOCK FACE TWO-THIRTY
+1F55E;ID # CLOCK FACE THREE-THIRTY
+1F55F;ID # CLOCK FACE FOUR-THIRTY
+1F560;ID # CLOCK FACE FIVE-THIRTY
+1F561;ID # CLOCK FACE SIX-THIRTY
+1F562;ID # CLOCK FACE SEVEN-THIRTY
+1F563;ID # CLOCK FACE EIGHT-THIRTY
+1F564;ID # CLOCK FACE NINE-THIRTY
+1F565;ID # CLOCK FACE TEN-THIRTY
+1F566;ID # CLOCK FACE ELEVEN-THIRTY
+1F567;ID # CLOCK FACE TWELVE-THIRTY
+1F5FB;ID # MOUNT FUJI
+1F5FC;ID # TOKYO TOWER
+1F5FD;ID # STATUE OF LIBERTY
+1F5FE;ID # SILHOUETTE OF JAPAN
+1F5FF;ID # MOYAI
+1F600;ID # GRINNING FACE
+1F601;ID # GRINNING FACE WITH SMILING EYES
+1F602;ID # FACE WITH TEARS OF JOY
+1F603;ID # SMILING FACE WITH OPEN MOUTH
+1F604;ID # SMILING FACE WITH OPEN MOUTH AND SMILING EYES
+1F605;ID # SMILING FACE WITH OPEN MOUTH AND COLD SWEAT
+1F606;ID # SMILING FACE WITH OPEN MOUTH AND TIGHTLY-CLOSED EYES
+1F607;ID # SMILING FACE WITH HALO
+1F608;ID # SMILING FACE WITH HORNS
+1F609;ID # WINKING FACE
+1F60A;ID # SMILING FACE WITH SMILING EYES
+1F60B;ID # FACE SAVOURING DELICIOUS FOOD
+1F60C;ID # RELIEVED FACE
+1F60D;ID # SMILING FACE WITH HEART-SHAPED EYES
+1F60E;ID # SMILING FACE WITH SUNGLASSES
+1F60F;ID # SMIRKING FACE
+1F610;ID # NEUTRAL FACE
+1F611;ID # EXPRESSIONLESS FACE
+1F612;ID # UNAMUSED FACE
+1F613;ID # FACE WITH COLD SWEAT
+1F614;ID # PENSIVE FACE
+1F615;ID # CONFUSED FACE
+1F616;ID # CONFOUNDED FACE
+1F617;ID # KISSING FACE
+1F618;ID # FACE THROWING A KISS
+1F619;ID # KISSING FACE WITH SMILING EYES
+1F61A;ID # KISSING FACE WITH CLOSED EYES
+1F61B;ID # FACE WITH STUCK-OUT TONGUE
+1F61C;ID # FACE WITH STUCK-OUT TONGUE AND WINKING EYE
+1F61D;ID # FACE WITH STUCK-OUT TONGUE AND TIGHTLY-CLOSED EYES
+1F61E;ID # DISAPPOINTED FACE
+1F61F;ID # WORRIED FACE
+1F620;ID # ANGRY FACE
+1F621;ID # POUTING FACE
+1F622;ID # CRYING FACE
+1F623;ID # PERSEVERING FACE
+1F624;ID # FACE WITH LOOK OF TRIUMPH
+1F625;ID # DISAPPOINTED BUT RELIEVED FACE
+1F626;ID # FROWNING FACE WITH OPEN MOUTH
+1F627;ID # ANGUISHED FACE
+1F628;ID # FEARFUL FACE
+1F629;ID # WEARY FACE
+1F62A;ID # SLEEPY FACE
+1F62B;ID # TIRED FACE
+1F62C;ID # GRIMACING FACE
+1F62D;ID # LOUDLY CRYING FACE
+1F62E;ID # FACE WITH OPEN MOUTH
+1F62F;ID # HUSHED FACE
+1F630;ID # FACE WITH OPEN MOUTH AND COLD SWEAT
+1F631;ID # FACE SCREAMING IN FEAR
+1F632;ID # ASTONISHED FACE
+1F633;ID # FLUSHED FACE
+1F634;ID # SLEEPING FACE
+1F635;ID # DIZZY FACE
+1F636;ID # FACE WITHOUT MOUTH
+1F637;ID # FACE WITH MEDICAL MASK
+1F638;ID # GRINNING CAT FACE WITH SMILING EYES
+1F639;ID # CAT FACE WITH TEARS OF JOY
+1F63A;ID # SMILING CAT FACE WITH OPEN MOUTH
+1F63B;ID # SMILING CAT FACE WITH HEART-SHAPED EYES
+1F63C;ID # CAT FACE WITH WRY SMILE
+1F63D;ID # KISSING CAT FACE WITH CLOSED EYES
+1F63E;ID # POUTING CAT FACE
+1F63F;ID # CRYING CAT FACE
+1F640;ID # WEARY CAT FACE
+1F645;ID # FACE WITH NO GOOD GESTURE
+1F646;ID # FACE WITH OK GESTURE
+1F647;ID # PERSON BOWING DEEPLY
+1F648;ID # SEE-NO-EVIL MONKEY
+1F649;ID # HEAR-NO-EVIL MONKEY
+1F64A;ID # SPEAK-NO-EVIL MONKEY
+1F64B;ID # HAPPY PERSON RAISING ONE HAND
+1F64C;ID # PERSON RAISING BOTH HANDS IN CELEBRATION
+1F64D;ID # PERSON FROWNING
+1F64E;ID # PERSON WITH POUTING FACE
+1F64F;ID # PERSON WITH FOLDED HANDS
+1F680;ID # ROCKET
+1F681;ID # HELICOPTER
+1F682;ID # STEAM LOCOMOTIVE
+1F683;ID # RAILWAY CAR
+1F684;ID # HIGH-SPEED TRAIN
+1F685;ID # HIGH-SPEED TRAIN WITH BULLET NOSE
+1F686;ID # TRAIN
+1F687;ID # METRO
+1F688;ID # LIGHT RAIL
+1F689;ID # STATION
+1F68A;ID # TRAM
+1F68B;ID # TRAM CAR
+1F68C;ID # BUS
+1F68D;ID # ONCOMING BUS
+1F68E;ID # TROLLEYBUS
+1F68F;ID # BUS STOP
+1F690;ID # MINIBUS
+1F691;ID # AMBULANCE
+1F692;ID # FIRE ENGINE
+1F693;ID # POLICE CAR
+1F694;ID # ONCOMING POLICE CAR
+1F695;ID # TAXI
+1F696;ID # ONCOMING TAXI
+1F697;ID # AUTOMOBILE
+1F698;ID # ONCOMING AUTOMOBILE
+1F699;ID # RECREATIONAL VEHICLE
+1F69A;ID # DELIVERY TRUCK
+1F69B;ID # ARTICULATED LORRY
+1F69C;ID # TRACTOR
+1F69D;ID # MONORAIL
+1F69E;ID # MOUNTAIN RAILWAY
+1F69F;ID # SUSPENSION RAILWAY
+1F6A0;ID # MOUNTAIN CABLEWAY
+1F6A1;ID # AERIAL TRAMWAY
+1F6A2;ID # SHIP
+1F6A3;ID # ROWBOAT
+1F6A4;ID # SPEEDBOAT
+1F6A5;ID # HORIZONTAL TRAFFIC LIGHT
+1F6A6;ID # VERTICAL TRAFFIC LIGHT
+1F6A7;ID # CONSTRUCTION SIGN
+1F6A8;ID # POLICE CARS REVOLVING LIGHT
+1F6A9;ID # TRIANGULAR FLAG ON POST
+1F6AA;ID # DOOR
+1F6AB;ID # NO ENTRY SIGN
+1F6AC;ID # SMOKING SYMBOL
+1F6AD;ID # NO SMOKING SYMBOL
+1F6AE;ID # PUT LITTER IN ITS PLACE SYMBOL
+1F6AF;ID # DO NOT LITTER SYMBOL
+1F6B0;ID # POTABLE WATER SYMBOL
+1F6B1;ID # NON-POTABLE WATER SYMBOL
+1F6B2;ID # BICYCLE
+1F6B3;ID # NO BICYCLES
+1F6B4;ID # BICYCLIST
+1F6B5;ID # MOUNTAIN BICYCLIST
+1F6B6;ID # PEDESTRIAN
+1F6B7;ID # NO PEDESTRIANS
+1F6B8;ID # CHILDREN CROSSING
+1F6B9;ID # MENS SYMBOL
+1F6BA;ID # WOMENS SYMBOL
+1F6BB;ID # RESTROOM
+1F6BC;ID # BABY SYMBOL
+1F6BD;ID # TOILET
+1F6BE;ID # WATER CLOSET
+1F6BF;ID # SHOWER
+1F6C0;ID # BATH
+1F6C1;ID # BATHTUB
+1F6C2;ID # PASSPORT CONTROL
+1F6C3;ID # CUSTOMS
+1F6C4;ID # BAGGAGE CLAIM
+1F6C5;ID # LEFT LUGGAGE
1F700;AL # ALCHEMICAL SYMBOL FOR QUINTESSENCE
1F701;AL # ALCHEMICAL SYMBOL FOR AIR
1F702;AL # ALCHEMICAL SYMBOL FOR FIRE
Property changes on: trunk/contrib/perl/lib/unicore/LineBreak.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/Makefile
===================================================================
--- trunk/contrib/perl/lib/unicore/Makefile 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/Makefile 2013-12-02 21:26:09 UTC (rev 6439)
@@ -2,5 +2,5 @@
../../miniperl -I../../lib ./mktables -P ../../pod -maketest -makelist -p
clean:
- rm -fr *.pl To lib
+ rm -fr *.pl *.pm To lib
rm -f ../../pod/perluniprops.pod mktables.lst
Property changes on: trunk/contrib/perl/lib/unicore/Makefile
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/NameAliases.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/NameAliases.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/NameAliases.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,10 +1,10 @@
-# NameAliases-6.0.0.txt
-# Date: 2010-05-10, 11:58:00 PDT [KW]
+# NameAliases-6.2.0.txt
+# Date: 2012-05-15, 18:44:00 GMT [KW]
#
# This file is a normative contributory data file in the
# Unicode Character Database.
#
-# Copyright (c) 2005-2010 Unicode, Inc.
+# Copyright (c) 2005-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
#
# This file defines the formal name aliases for Unicode characters.
@@ -11,30 +11,499 @@
#
# For informative aliases see NamesList.txt
#
+# The formal name aliases are divided into five types.
+#
+# 1. Corrections for serious problems in the character names
+# 2. ISO 6429 names for C0 and C1 control functions, and other
+# commonly occurring names for control codes
+# 3. A few widely used alternate names for format characters
+# 4. Several documented labels for C1 control code points which
+# were never actually approved in any standard
+# 5. Commonly occurring abbreviations (or acronyms) for control codes,
+# format characters, spaces, and variation selectors
+#
+# The formal name aliases are part of the Unicode character namespace, which
+# includes the character names and the names of named character sequences.
+# The inclusion of ISO 6429 names and other commonly occurring names and
+# abbreviations for control codes and format characters as formal name aliases
+# is to help avoid name collisions between Unicode character names and the
+# labels which commonly appear in text and/or in implementations such as regex, for
+# control codes (which have no Unicode character name) or for format characters.
+#
# For documentation, see NamesList.html and http://www.unicode.org/reports/tr44/
#
# FORMAT
#
-# Each line has two fields
-# First field: Code point
+# Each line has three fields, as described here:
+#
+# First field: Code point
# Second field: Alias
+# Third field: Type
#
+# The Type labels used are: correction, control, alternate, figment, abbreviation
+#
+# Those Type labels can be mapped to other strings for display, if desired.
+#
# In case multiple aliases are assigned, additional aliases
-# would be provided on separate lines
+# are provided on separate lines. Parsers of this data file should
+# take note that the same code point can (and does) occur more than once.
#
#-----------------------------------------------------------------
-01A2;LATIN CAPITAL LETTER GHA
-01A3;LATIN SMALL LETTER GHA
-0CDE;KANNADA LETTER LLLA
-0E9D;LAO LETTER FO FON
-0E9F;LAO LETTER FO FAY
-0EA3;LAO LETTER RO
-0EA5;LAO LETTER LO
-0FD0;TIBETAN MARK BKA- SHOG GI MGO RGYAN
-A015;YI SYLLABLE ITERATION MARK
-FE18;PRESENTATION FORM FOR VERTICAL RIGHT WHITE LENTICULAR BRACKET
-1D0C5;BYZANTINE MUSICAL SYMBOL FTHORA SKLIRON CHROMA VASIS
-# Total code points: 11
+0000;NULL;control
+0000;NUL;abbreviation
+0001;START OF HEADING;control
+0001;SOH;abbreviation
+0002;START OF TEXT;control
+0002;STX;abbreviation
+0003;END OF TEXT;control
+0003;ETX;abbreviation
+0004;END OF TRANSMISSION;control
+0004;EOT;abbreviation
+0005;ENQUIRY;control
+0005;ENQ;abbreviation
+0006;ACKNOWLEDGE;control
+0006;ACK;abbreviation
+# Note that no formal name alias for the ISO 6429 "BELL" is
+# provided for U+0007, because of the existing name collision
+# with U+1F514 BELL.
+
+0007;ALERT;control
+0007;BEL;abbreviation
+0008;BACKSPACE;control
+0008;BS;abbreviation
+0009;CHARACTER TABULATION;control
+0009;HORIZONTAL TABULATION;control
+0009;HT;abbreviation
+0009;TAB;abbreviation
+000A;LINE FEED;control
+000A;NEW LINE;control
+000A;END OF LINE;control
+000A;LF;abbreviation
+000A;NL;abbreviation
+000A;EOL;abbreviation
+000B;LINE TABULATION;control
+000B;VERTICAL TABULATION;control
+000B;VT;abbreviation
+000C;FORM FEED;control
+000C;FF;abbreviation
+000D;CARRIAGE RETURN;control
+000D;CR;abbreviation
+000E;SHIFT OUT;control
+000E;LOCKING-SHIFT ONE;control
+000E;SO;abbreviation
+000F;SHIFT IN;control
+000F;LOCKING-SHIFT ZERO;control
+000F;SI;abbreviation
+0010;DATA LINK ESCAPE;control
+0010;DLE;abbreviation
+0011;DEVICE CONTROL ONE;control
+0011;DC1;abbreviation
+0012;DEVICE CONTROL TWO;control
+0012;DC2;abbreviation
+0013;DEVICE CONTROL THREE;control
+0013;DC3;abbreviation
+0014;DEVICE CONTROL FOUR;control
+0014;DC4;abbreviation
+0015;NEGATIVE ACKNOWLEDGE;control
+0015;NAK;abbreviation
+0016;SYNCHRONOUS IDLE;control
+0016;SYN;abbreviation
+0017;END OF TRANSMISSION BLOCK;control
+0017;ETB;abbreviation
+0018;CANCEL;control
+0018;CAN;abbreviation
+0019;END OF MEDIUM;control
+0019;EOM;abbreviation
+001A;SUBSTITUTE;control
+001A;SUB;abbreviation
+001B;ESCAPE;control
+001B;ESC;abbreviation
+001C;INFORMATION SEPARATOR FOUR;control
+001C;FILE SEPARATOR;control
+001C;FS;abbreviation
+001D;INFORMATION SEPARATOR THREE;control
+001D;GROUP SEPARATOR;control
+001D;GS;abbreviation
+001E;INFORMATION SEPARATOR TWO;control
+001E;RECORD SEPARATOR;control
+001E;RS;abbreviation
+001F;INFORMATION SEPARATOR ONE;control
+001F;UNIT SEPARATOR;control
+001F;US;abbreviation
+0020;SP;abbreviation
+007F;DELETE;control
+007F;DEL;abbreviation
+0080;PADDING CHARACTER;figment
+0080;PAD;abbreviation
+0081;HIGH OCTET PRESET;figment
+0081;HOP;abbreviation
+0082;BREAK PERMITTED HERE;control
+0082;BPH;abbreviation
+0083;NO BREAK HERE;control
+0083;NBH;abbreviation
+0084;INDEX;control
+0084;IND;abbreviation
+0085;NEXT LINE;control
+0085;NEL;abbreviation
+0086;START OF SELECTED AREA;control
+0086;SSA;abbreviation
+0087;END OF SELECTED AREA;control
+0087;ESA;abbreviation
+0088;CHARACTER TABULATION SET;control
+0088;HORIZONTAL TABULATION SET;control
+0088;HTS;abbreviation
+0089;CHARACTER TABULATION WITH JUSTIFICATION;control
+0089;HORIZONTAL TABULATION WITH JUSTIFICATION;control
+0089;HTJ;abbreviation
+008A;LINE TABULATION SET;control
+008A;VERTICAL TABULATION SET;control
+008A;VTS;abbreviation
+008B;PARTIAL LINE FORWARD;control
+008B;PARTIAL LINE DOWN;control
+008B;PLD;abbreviation
+008C;PARTIAL LINE BACKWARD;control
+008C;PARTIAL LINE UP;control
+008C;PLU;abbreviation
+008D;REVERSE LINE FEED;control
+008D;REVERSE INDEX;control
+008D;RI;abbreviation
+008E;SINGLE SHIFT TWO;control
+008E;SINGLE-SHIFT-2;control
+008E;SS2;abbreviation
+008F;SINGLE SHIFT THREE;control
+008F;SINGLE-SHIFT-3;control
+008F;SS3;abbreviation
+0090;DEVICE CONTROL STRING;control
+0090;DCS;abbreviation
+0091;PRIVATE USE ONE;control
+0091;PRIVATE USE-1;control
+0091;PU1;abbreviation
+0092;PRIVATE USE TWO;control
+0092;PRIVATE USE-2;control
+0092;PU2;abbreviation
+0093;SET TRANSMIT STATE;control
+0093;STS;abbreviation
+0094;CANCEL CHARACTER;control
+0094;CCH;abbreviation
+0095;MESSAGE WAITING;control
+0095;MW;abbreviation
+0096;START OF GUARDED AREA;control
+0096;START OF PROTECTED AREA;control
+0096;SPA;abbreviation
+0097;END OF GUARDED AREA;control
+0097;END OF PROTECTED AREA;control
+0097;EPA;abbreviation
+0098;START OF STRING;control
+0098;SOS;abbreviation
+0099;SINGLE GRAPHIC CHARACTER INTRODUCER;figment
+0099;SGC;abbreviation
+009A;SINGLE CHARACTER INTRODUCER;control
+009A;SCI;abbreviation
+009B;CONTROL SEQUENCE INTRODUCER;control
+009B;CSI;abbreviation
+009C;STRING TERMINATOR;control
+009C;ST;abbreviation
+009D;OPERATING SYSTEM COMMAND;control
+009D;OSC;abbreviation
+009E;PRIVACY MESSAGE;control
+009E;PM;abbreviation
+009F;APPLICATION PROGRAM COMMAND;control
+009F;APC;abbreviation
+00A0;NBSP;abbreviation
+00AD;SHY;abbreviation
+01A2;LATIN CAPITAL LETTER GHA;correction
+01A3;LATIN SMALL LETTER GHA;correction
+034F;CGJ;abbreviation
+0709;SYRIAC SUBLINEAR COLON SKEWED LEFT;correction
+0CDE;KANNADA LETTER LLLA;correction
+0E9D;LAO LETTER FO FON;correction
+0E9F;LAO LETTER FO FAY;correction
+0EA3;LAO LETTER RO;correction
+0EA5;LAO LETTER LO;correction
+0FD0;TIBETAN MARK BKA- SHOG GI MGO RGYAN;correction
+180B;FVS1;abbreviation
+180C;FVS2;abbreviation
+180D;FVS3;abbreviation
+180E;MVS;abbreviation
+200B;ZWSP;abbreviation
+200C;ZWNJ;abbreviation
+200D;ZWJ;abbreviation
+200E;LRM;abbreviation
+200F;RLM;abbreviation
+202A;LRE;abbreviation
+202B;RLE;abbreviation
+202C;PDF;abbreviation
+202D;LRO;abbreviation
+202E;RLO;abbreviation
+202F;NNBSP;abbreviation
+205F;MMSP;abbreviation
+2060;WJ;abbreviation
+2118;WEIERSTRASS ELLIPTIC FUNCTION;correction
+2448;MICR ON US SYMBOL;correction
+2449;MICR DASH SYMBOL;correction
+A015;YI SYLLABLE ITERATION MARK;correction
+FE18;PRESENTATION FORM FOR VERTICAL RIGHT WHITE LENTICULAR BRACKET;correction
+FE00;VS1;abbreviation
+FE01;VS2;abbreviation
+FE02;VS3;abbreviation
+FE03;VS4;abbreviation
+FE04;VS5;abbreviation
+FE05;VS6;abbreviation
+FE06;VS7;abbreviation
+FE07;VS8;abbreviation
+FE08;VS9;abbreviation
+FE09;VS10;abbreviation
+FE0A;VS11;abbreviation
+FE0B;VS12;abbreviation
+FE0C;VS13;abbreviation
+FE0D;VS14;abbreviation
+FE0E;VS15;abbreviation
+FE0F;VS16;abbreviation
+FEFF;BYTE ORDER MARK;alternate
+FEFF;BOM;abbreviation
+FEFF;ZWNBSP;abbreviation
+1D0C5;BYZANTINE MUSICAL SYMBOL FTHORA SKLIRON CHROMA VASIS;correction
+E0100;VS17;abbreviation
+E0101;VS18;abbreviation
+E0102;VS19;abbreviation
+E0103;VS20;abbreviation
+E0104;VS21;abbreviation
+E0105;VS22;abbreviation
+E0106;VS23;abbreviation
+E0107;VS24;abbreviation
+E0108;VS25;abbreviation
+E0109;VS26;abbreviation
+E010A;VS27;abbreviation
+E010B;VS28;abbreviation
+E010C;VS29;abbreviation
+E010D;VS30;abbreviation
+E010E;VS31;abbreviation
+E010F;VS32;abbreviation
+E0110;VS33;abbreviation
+E0111;VS34;abbreviation
+E0112;VS35;abbreviation
+E0113;VS36;abbreviation
+E0114;VS37;abbreviation
+E0115;VS38;abbreviation
+E0116;VS39;abbreviation
+E0117;VS40;abbreviation
+E0118;VS41;abbreviation
+E0119;VS42;abbreviation
+E011A;VS43;abbreviation
+E011B;VS44;abbreviation
+E011C;VS45;abbreviation
+E011D;VS46;abbreviation
+E011E;VS47;abbreviation
+E011F;VS48;abbreviation
+E0120;VS49;abbreviation
+E0121;VS50;abbreviation
+E0122;VS51;abbreviation
+E0123;VS52;abbreviation
+E0124;VS53;abbreviation
+E0125;VS54;abbreviation
+E0126;VS55;abbreviation
+E0127;VS56;abbreviation
+E0128;VS57;abbreviation
+E0129;VS58;abbreviation
+E012A;VS59;abbreviation
+E012B;VS60;abbreviation
+E012C;VS61;abbreviation
+E012D;VS62;abbreviation
+E012E;VS63;abbreviation
+E012F;VS64;abbreviation
+E0130;VS65;abbreviation
+E0131;VS66;abbreviation
+E0132;VS67;abbreviation
+E0133;VS68;abbreviation
+E0134;VS69;abbreviation
+E0135;VS70;abbreviation
+E0136;VS71;abbreviation
+E0137;VS72;abbreviation
+E0138;VS73;abbreviation
+E0139;VS74;abbreviation
+E013A;VS75;abbreviation
+E013B;VS76;abbreviation
+E013C;VS77;abbreviation
+E013D;VS78;abbreviation
+E013E;VS79;abbreviation
+E013F;VS80;abbreviation
+E0140;VS81;abbreviation
+E0141;VS82;abbreviation
+E0142;VS83;abbreviation
+E0143;VS84;abbreviation
+E0144;VS85;abbreviation
+E0145;VS86;abbreviation
+E0146;VS87;abbreviation
+E0147;VS88;abbreviation
+E0148;VS89;abbreviation
+E0149;VS90;abbreviation
+E014A;VS91;abbreviation
+E014B;VS92;abbreviation
+E014C;VS93;abbreviation
+E014D;VS94;abbreviation
+E014E;VS95;abbreviation
+E014F;VS96;abbreviation
+E0150;VS97;abbreviation
+E0151;VS98;abbreviation
+E0152;VS99;abbreviation
+E0153;VS100;abbreviation
+E0154;VS101;abbreviation
+E0155;VS102;abbreviation
+E0156;VS103;abbreviation
+E0157;VS104;abbreviation
+E0158;VS105;abbreviation
+E0159;VS106;abbreviation
+E015A;VS107;abbreviation
+E015B;VS108;abbreviation
+E015C;VS109;abbreviation
+E015D;VS110;abbreviation
+E015E;VS111;abbreviation
+E015F;VS112;abbreviation
+E0160;VS113;abbreviation
+E0161;VS114;abbreviation
+E0162;VS115;abbreviation
+E0163;VS116;abbreviation
+E0164;VS117;abbreviation
+E0165;VS118;abbreviation
+E0166;VS119;abbreviation
+E0167;VS120;abbreviation
+E0168;VS121;abbreviation
+E0169;VS122;abbreviation
+E016A;VS123;abbreviation
+E016B;VS124;abbreviation
+E016C;VS125;abbreviation
+E016D;VS126;abbreviation
+E016E;VS127;abbreviation
+E016F;VS128;abbreviation
+E0170;VS129;abbreviation
+E0171;VS130;abbreviation
+E0172;VS131;abbreviation
+E0173;VS132;abbreviation
+E0174;VS133;abbreviation
+E0175;VS134;abbreviation
+E0176;VS135;abbreviation
+E0177;VS136;abbreviation
+E0178;VS137;abbreviation
+E0179;VS138;abbreviation
+E017A;VS139;abbreviation
+E017B;VS140;abbreviation
+E017C;VS141;abbreviation
+E017D;VS142;abbreviation
+E017E;VS143;abbreviation
+E017F;VS144;abbreviation
+E0180;VS145;abbreviation
+E0181;VS146;abbreviation
+E0182;VS147;abbreviation
+E0183;VS148;abbreviation
+E0184;VS149;abbreviation
+E0185;VS150;abbreviation
+E0186;VS151;abbreviation
+E0187;VS152;abbreviation
+E0188;VS153;abbreviation
+E0189;VS154;abbreviation
+E018A;VS155;abbreviation
+E018B;VS156;abbreviation
+E018C;VS157;abbreviation
+E018D;VS158;abbreviation
+E018E;VS159;abbreviation
+E018F;VS160;abbreviation
+E0190;VS161;abbreviation
+E0191;VS162;abbreviation
+E0192;VS163;abbreviation
+E0193;VS164;abbreviation
+E0194;VS165;abbreviation
+E0195;VS166;abbreviation
+E0196;VS167;abbreviation
+E0197;VS168;abbreviation
+E0198;VS169;abbreviation
+E0199;VS170;abbreviation
+E019A;VS171;abbreviation
+E019B;VS172;abbreviation
+E019C;VS173;abbreviation
+E019D;VS174;abbreviation
+E019E;VS175;abbreviation
+E019F;VS176;abbreviation
+E01A0;VS177;abbreviation
+E01A1;VS178;abbreviation
+E01A2;VS179;abbreviation
+E01A3;VS180;abbreviation
+E01A4;VS181;abbreviation
+E01A5;VS182;abbreviation
+E01A6;VS183;abbreviation
+E01A7;VS184;abbreviation
+E01A8;VS185;abbreviation
+E01A9;VS186;abbreviation
+E01AA;VS187;abbreviation
+E01AB;VS188;abbreviation
+E01AC;VS189;abbreviation
+E01AD;VS190;abbreviation
+E01AE;VS191;abbreviation
+E01AF;VS192;abbreviation
+E01B0;VS193;abbreviation
+E01B1;VS194;abbreviation
+E01B2;VS195;abbreviation
+E01B3;VS196;abbreviation
+E01B4;VS197;abbreviation
+E01B5;VS198;abbreviation
+E01B6;VS199;abbreviation
+E01B7;VS200;abbreviation
+E01B8;VS201;abbreviation
+E01B9;VS202;abbreviation
+E01BA;VS203;abbreviation
+E01BB;VS204;abbreviation
+E01BC;VS205;abbreviation
+E01BD;VS206;abbreviation
+E01BE;VS207;abbreviation
+E01BF;VS208;abbreviation
+E01C0;VS209;abbreviation
+E01C1;VS210;abbreviation
+E01C2;VS211;abbreviation
+E01C3;VS212;abbreviation
+E01C4;VS213;abbreviation
+E01C5;VS214;abbreviation
+E01C6;VS215;abbreviation
+E01C7;VS216;abbreviation
+E01C8;VS217;abbreviation
+E01C9;VS218;abbreviation
+E01CA;VS219;abbreviation
+E01CB;VS220;abbreviation
+E01CC;VS221;abbreviation
+E01CD;VS222;abbreviation
+E01CE;VS223;abbreviation
+E01CF;VS224;abbreviation
+E01D0;VS225;abbreviation
+E01D1;VS226;abbreviation
+E01D2;VS227;abbreviation
+E01D3;VS228;abbreviation
+E01D4;VS229;abbreviation
+E01D5;VS230;abbreviation
+E01D6;VS231;abbreviation
+E01D7;VS232;abbreviation
+E01D8;VS233;abbreviation
+E01D9;VS234;abbreviation
+E01DA;VS235;abbreviation
+E01DB;VS236;abbreviation
+E01DC;VS237;abbreviation
+E01DD;VS238;abbreviation
+E01DE;VS239;abbreviation
+E01DF;VS240;abbreviation
+E01E0;VS241;abbreviation
+E01E1;VS242;abbreviation
+E01E2;VS243;abbreviation
+E01E3;VS244;abbreviation
+E01E4;VS245;abbreviation
+E01E5;VS246;abbreviation
+E01E6;VS247;abbreviation
+E01E7;VS248;abbreviation
+E01E8;VS249;abbreviation
+E01E9;VS250;abbreviation
+E01EA;VS251;abbreviation
+E01EB;VS252;abbreviation
+E01EC;VS253;abbreviation
+E01ED;VS254;abbreviation
+E01EE;VS255;abbreviation
+E01EF;VS256;abbreviation
+
# EOF
Property changes on: trunk/contrib/perl/lib/unicore/NameAliases.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/NamedSequences.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/NamedSequences.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/NamedSequences.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,8 +1,8 @@
-# NamedSequences-6.0.0.txt
-# Date: 2010-05-18, 10:48:00 PDT [KW]
+# NamedSequences-6.2.0.txt
+# Date: 2012-05-15, 21:23:00 GMT [KW]
#
# Unicode Character Database
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
# For documentation, see http://www.unicode.org/reports/tr44/
#
@@ -112,8 +112,8 @@
# Additions for Tamil. Provisional 2008-02-08, Approved 2009-08-14
#
# A visual display of the Tamil named sequences is available
-# in the documentation for Unicode 5.2. See:
-# http://www.unicode.org/versions/Unicode5.2.0/
+# in the documentation for the Unicode Standard. See Section 9.6, Tamil in
+# http://www.unicode.org/versions/latest/
TAMIL CONSONANT K; 0B95 0BCD
TAMIL CONSONANT NG; 0B99 0BCD
@@ -431,6 +431,13 @@
TAMIL SYLLABLE SHRII; 0BB6 0BCD 0BB0 0BC0
+# Sinhala medial consonants and "reph" form
+# Provisional 2010-05-13, Approved 2011-08-05
+
+SINHALA CONSONANT SIGN YANSAYA;0DCA 200D 0DBA
+SINHALA CONSONANT SIGN RAKAARAANSAYA;0DCA 200D 0DBB
+SINHALA CONSONANT SIGN REPAYA;0DBB 0DCA 200D
+
GEORGIAN LETTER U-BRJGU;10E3 0302
KHMER CONSONANT SIGN COENG KA;17D2 1780
KHMER CONSONANT SIGN COENG KHA;17D2 1781
@@ -493,3 +500,5 @@
KATAKANA LETTER AINU P;31F7 309A
MODIFIER LETTER EXTRA-HIGH EXTRA-LOW CONTOUR TONE BAR;02E5 02E9
MODIFIER LETTER EXTRA-LOW EXTRA-HIGH CONTOUR TONE BAR;02E9 02E5
+
+# EOF
Property changes on: trunk/contrib/perl/lib/unicore/NamedSequences.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/NamedSqProv.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/NamedSqProv.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/NamedSqProv.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,8 +1,8 @@
-# NamedSequencesProv-6.0.0.txt
-# Date: 2010-05-18, 10:49:00 PDT [KW]
+# NamedSequencesProv-6.2.0.txt
+# Date: 2012-05-15, 21:29:00 GMT [KW]
#
# Unicode Character Database
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
# For documentation, see http://www.unicode.org/reports/tr44/
#
@@ -34,13 +34,8 @@
# Provisional entries for NamedSequences.txt.
-# Sinhala medial consonants and "reph" form
-# Added to provisional named sequences, 2010-05-13
+# There are currently no provisional named sequences.
-SINHALA CONSONANT SIGN YANSAYA;0DCA 200D 0DBA
-SINHALA CONSONANT SIGN RAKAARAANSAYA;0DCA 200D 0DBB
-SINHALA CONSONANT SIGN REPAYA;0DBB 0DCA 200D
-
# ================================================
# Entries from Unicode 4.1.0 version of NamedSequences.txt,
@@ -59,3 +54,4 @@
# the sequence, based on the Lithuanian additions accepted
# for Unicode 5.0.
+# EOF
Property changes on: trunk/contrib/perl/lib/unicore/NamedSqProv.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/NamesList.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/NamesList.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/NamesList.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,6 +1,10 @@
-@@@ The Unicode Standard 6.0
-@@@+ U60M100817.lst
- Final Unicode 6.0 names list.
+; charset=UTF-8
+@@@ The Unicode Standard 6.2
+@@@+ U62M120808.lst
+ Unicode 6.2 names list, third delta (converted to UTF-8).
+ Updated more annotations in the Bengali block.
+ Added clarifying annotations for 0342.
+ Updated alias for 1110E.
This file is semi-automatically derived from UnicodeData.txt and
a set of manually created annotations using a script to select
or suppress information from the data file. The rules used
@@ -7,7 +11,7 @@
for this process are aimed at readability for the human reader,
at the expense of some details; therefore, this file should not
be parsed for machine-readable information.
- at + Copyright (c) 1991-2010 Unicode, Inc.
+ at + Copyright (c) 1991-2012 Unicode, Inc.
For terms of use, see http://www.unicode.org/terms_of_use.html
@@ 0000 C0 Controls and Basic Latin (Basic Latin) 007F
@@+
@@ -117,11 +121,15 @@
= pound sign, hash, crosshatch, octothorpe
x (l b bar symbol - 2114)
x (music sharp sign - 266F)
+ ~ 0023 FE0E text style
+ ~ 0023 FE0F emoji style
0024 DOLLAR SIGN
- = milreis, escudo
+ = milréis, escudo
+ * used for many peso currencies in Latin America and elsewhere
* glyph may have one or two vertical bars
- * other currency symbol characters: 20A0-20B8
+ * other currency symbol characters: 20A0-20BA
x (currency sign - 00A4)
+ x (peso sign - 20B1)
x (heavy dollar sign - 1F4B2)
0025 PERCENT SIGN
x (arabic percent sign - 066A)
@@ -184,15 +192,35 @@
x (division slash - 2215)
@ ASCII digits
0030 DIGIT ZERO
+ ~ 0030 FE0E text style
+ ~ 0030 FE0F emoji style
0031 DIGIT ONE
+ ~ 0031 FE0E text style
+ ~ 0031 FE0F emoji style
0032 DIGIT TWO
+ ~ 0032 FE0E text style
+ ~ 0032 FE0F emoji style
0033 DIGIT THREE
+ ~ 0033 FE0E text style
+ ~ 0033 FE0F emoji style
0034 DIGIT FOUR
+ ~ 0034 FE0E text style
+ ~ 0034 FE0F emoji style
0035 DIGIT FIVE
+ ~ 0035 FE0E text style
+ ~ 0035 FE0F emoji style
0036 DIGIT SIX
+ ~ 0036 FE0E text style
+ ~ 0036 FE0F emoji style
0037 DIGIT SEVEN
+ ~ 0037 FE0E text style
+ ~ 0037 FE0F emoji style
0038 DIGIT EIGHT
+ ~ 0038 FE0E text style
+ ~ 0038 FE0F emoji style
0039 DIGIT NINE
+ ~ 0039 FE0E text style
+ ~ 0039 FE0F emoji style
@ ASCII punctuation and symbols
003A COLON
x (armenian full stop - 0589)
@@ -381,6 +409,7 @@
@ Control character
007F <control>
= DELETE
+@~ Standardized Variation Sequences
@@ 0080 C1 Controls and Latin-1 Supplement (Latin-1 Supplement) 00FF
@ C1 controls
@+ Alias names are those for ISO/IEC 6429:1992.
@@ -464,9 +493,10 @@
00A3 POUND SIGN
= pound sterling, Irish punt, Italian lira, Turkish lira, etc.
x (lira sign - 20A4)
+ x (turkish lira sign - 20BA)
x (roman semuncia sign - 10192)
00A4 CURRENCY SIGN
- * other currency symbol characters: 20A0-20B5
+ * other currency symbol characters: 20A0-20BA
x (dollar sign - 0024)
00A5 YEN SIGN
= yuan sign
@@ -551,6 +581,7 @@
x (bullet operator - 2219)
x (dot operator - 22C5)
x (word separator middle dot - 2E31)
+ x (raised dot - 2E33)
x (katakana middle dot - 30FB)
00B8 CEDILLA
* this is a spacing character
@@ -657,7 +688,7 @@
= Eszett
* German
* uppercase is "SS"
- * in origin a ligature of 017F and 0073
+ * typographically the glyph for this character can be based on a ligature of 017F with either 0073 or with an old-style glyph for 007A (the latter similar in appearance to 0292). Both forms exist interchangeably today.
x (greek small letter beta - 03B2)
x (latin capital letter sharp s - 1E9E)
00E0 LATIN SMALL LETTER A WITH GRAVE
@@ -676,7 +707,7 @@
: 0061 030A
00E6 LATIN SMALL LETTER AE
= latin small ligature ae (1.0)
- = ash (from Old English \xE6sc)
+ = ash (from Old English æsc)
* Danish, Norwegian, Icelandic, Faroese, Old English, French, IPA
x (latin small ligature oe - 0153)
x (cyrillic small ligature a ie - 04D5)
@@ -848,6 +879,7 @@
* there are three major glyph variants
: 0067 0327
0124 LATIN CAPITAL LETTER H WITH CIRCUMFLEX
+ * lowercase in Nawdm is 0266
: 0048 0302
0125 LATIN SMALL LETTER H WITH CIRCUMFLEX
* Esperanto
@@ -979,7 +1011,7 @@
: 006F 030B
0152 LATIN CAPITAL LIGATURE OE
0153 LATIN SMALL LIGATURE OE
- = ethel (from Old English e\xF0el)
+ = ethel (from Old English eðel)
* French, IPA, Old Icelandic, Old English, ...
x (latin small letter ae - 00E6)
x (latin letter small capital oe - 0276)
@@ -1747,10 +1779,12 @@
* uppercase is A78D
0266 LATIN SMALL LETTER H WITH HOOK
* breathy-voiced glottal fricative
+ * uppercase is A7AA
+ * uppercase in Nawdm is 0124
x (modifier letter small h with hook - 02B1)
0267 LATIN SMALL LETTER HENG WITH HOOK
* voiceless coarticulated velar and palatoalveolar fricative
- * "tj" or "kj" or "sj" in some Swedish dialects
+ * "sj" in some Swedish dialects
0268 LATIN SMALL LETTER I WITH STROKE
= barred i, i bar
* high central unrounded vowel
@@ -2017,11 +2051,13 @@
02B9 MODIFIER LETTER PRIME
* primary stress, emphasis
* transliteration of mjagkij znak (Cyrillic soft sign: palatalization)
+ * transliteration of Hebrew geresh
x (apostrophe - 0027)
x (acute accent - 00B4)
x (modifier letter acute accent - 02CA)
x (combining acute accent - 0301)
x (greek numeral sign - 0374)
+ x (hebrew punctuation geresh - 05F3)
x (prime - 2032)
02BA MODIFIER LETTER DOUBLE PRIME
* exaggerated stress, contrastive stress
@@ -2056,11 +2092,15 @@
x (single high-reversed-9 quotation mark - 201B)
02BE MODIFIER LETTER RIGHT HALF RING
* transliteration of Arabic hamza (glottal stop)
+ * transliteration of Hebrew alef
x (armenian apostrophe - 055A)
+ x (hebrew letter alef - 05D0)
x (arabic letter hamza - 0621)
02BF MODIFIER LETTER LEFT HALF RING
* transliteration of Arabic ain (voiced pharyngeal fricative)
+ * transliteration of Hebrew ayin
x (armenian modifier letter left half ring - 0559)
+ x (hebrew letter ayin - 05E2)
x (arabic letter ain - 0639)
02C0 MODIFIER LETTER GLOTTAL STOP
* ejective or glottalized
@@ -2438,6 +2478,10 @@
: 0301 combining acute accent
@ Additions for Greek
0342 COMBINING GREEK PERISPOMENI
+ * Greek-specific form of circumflex for rising-falling accent
+ * alternative glyph is similar to an inverted breve
+ x (combining tilde - 0303)
+ x (combining inverted breve - 0311)
0343 COMBINING GREEK KORONIS
: 0313 combining comma above
0344 COMBINING GREEK DIALYTIKA TONOS
@@ -3405,6 +3449,8 @@
x (colon - 003A)
058A ARMENIAN HYPHEN
= yentamna
+@ Currency symbol
+058F ARMENIAN DRAM SIGN
@@ 0590 Hebrew 05FF
@ Cantillation marks
0591 HEBREW ACCENT ETNAHTA
@@ -3550,6 +3596,8 @@
0601 ARABIC SIGN SANAH
0602 ARABIC FOOTNOTE MARKER
0603 ARABIC SIGN SAFHA
+0604 ARABIC SIGN SAMVAT
+ * used for writing Samvat era dates in Urdu
@ Radix symbols
0606 ARABIC-INDIC CUBE ROOT
x (cube root - 221B)
@@ -3568,6 +3616,7 @@
060C ARABIC COMMA
* also used with Thaana and Syriac in modern text
x (comma - 002C)
+ x (turned comma - 2E32)
060D ARABIC DATE SEPARATOR
@ Poetic marks
060E ARABIC POETIC VERSE SIGN
@@ -3602,6 +3651,7 @@
061B ARABIC SEMICOLON
* also used with Thaana and Syriac in modern text
x (semicolon - 003B)
+ x (turned semicolon - 2E35)
061E ARABIC TRIPLE DOT PUNCTUATION MARK
061F ARABIC QUESTION MARK
* also used with Thaana and Syriac in modern text
@@ -3610,6 +3660,7 @@
@ Addition for Kashmiri
0620 ARABIC LETTER KASHMIRI YEH
@ Based on ISO 8859-6
+ at + Arabic letter names follow romanization conventions derived from ISO 8859-6. These differ from the Literary Arabic pronunciation of the letter names. For example, U+0628 ARABIC LETTER BEH has a Literary Arabic pronunciation of ba'.
0621 ARABIC LETTER HAMZA
x (modifier letter right half ring - 02BE)
0622 ARABIC LETTER ALEF WITH MADDA ABOVE
@@ -3666,7 +3717,11 @@
0648 ARABIC LETTER WAW
0649 ARABIC LETTER ALEF MAKSURA
* represents YEH-shaped letter with no dots in any positional form
+ * not intended for use in combination with 0654
+ x (arabic letter yeh with hamza above - 0626)
064A ARABIC LETTER YEH
+ * loses its dots when used in combination with 0654
+ * retains its dots when used in combination with other combining marks
@ Points from ISO 8859-6
064B ARABIC FATHATAN
064C ARABIC DAMMATAN
@@ -3683,6 +3738,8 @@
@ Combining maddah and hamza
0653 ARABIC MADDAH ABOVE
0654 ARABIC HAMZA ABOVE
+ * not restricted to hamza semantics
+ * may also occur as a diacritic forming new letters
0655 ARABIC HAMZA BELOW
@ Other combining marks
0656 ARABIC SUBSCRIPT ALEF
@@ -3739,8 +3796,12 @@
* Koranic Arabic
0672 ARABIC LETTER ALEF WITH WAVY HAMZA ABOVE
* Baluchi, Kashmiri
+@ Deprecated letter
0673 ARABIC LETTER ALEF WITH WAVY HAMZA BELOW
* Kashmiri
+ * this character is deprecated and its use is strongly discouraged
+ * use the sequence 0627 065F instead
+@ Extended Arabic letters
0674 ARABIC LETTER HIGH HAMZA
* Kazakh
* forms digraphs
@@ -4037,6 +4098,7 @@
0708 SYRIAC SUPRALINEAR COLON SKEWED LEFT
* marks a minor phrase division
0709 SYRIAC SUBLINEAR COLON SKEWED RIGHT
+ % SYRIAC SUBLINEAR COLON SKEWED LEFT
* marks the end of a real or rhetorical question
070A SYRIAC CONTRACTION
* a contraction mark, mostly used in East Syriac
@@ -4461,6 +4523,60 @@
085B MANDAIC GEMINATION MARK
@ Punctuation
085E MANDAIC PUNCTUATION
+@@ 08A0 Arabic Extended-A 08FF
+@ Extended Arabic letters for African languages
+08A0 ARABIC LETTER BEH WITH SMALL V BELOW
+08A2 ARABIC LETTER JEEM WITH TWO DOTS ABOVE
+08A3 ARABIC LETTER TAH WITH TWO DOTS ABOVE
+08A4 ARABIC LETTER FEH WITH DOT BELOW AND THREE DOTS ABOVE
+08A5 ARABIC LETTER QAF WITH DOT BELOW
+08A6 ARABIC LETTER LAM WITH DOUBLE BAR
+08A7 ARABIC LETTER MEEM WITH THREE DOTS ABOVE
+08A8 ARABIC LETTER YEH WITH TWO DOTS BELOW AND HAMZA ABOVE
+08A9 ARABIC LETTER YEH WITH TWO DOTS BELOW AND DOT ABOVE
+@ Dependent consonants for Rohingya
+08AA ARABIC LETTER REH WITH LOOP
+ = bottya-reh
+08AB ARABIC LETTER WAW WITH DOT WITHIN
+ = nota-wa
+08AC ARABIC LETTER ROHINGYA YEH
+ = bottya-yeh
+@ Extended vowel signs for Rohingya
+08E4 ARABIC CURLY FATHA
+08E5 ARABIC CURLY DAMMA
+08E6 ARABIC CURLY KASRA
+08E7 ARABIC CURLY FATHATAN
+08E8 ARABIC CURLY DAMMATAN
+08E9 ARABIC CURLY KASRATAN
+@ Tone marks for Rohingya
+08EA ARABIC TONE ONE DOT ABOVE
+08EB ARABIC TONE TWO DOTS ABOVE
+08EC ARABIC TONE LOOP ABOVE
+08ED ARABIC TONE ONE DOT BELOW
+08EE ARABIC TONE TWO DOTS BELOW
+08EF ARABIC TONE LOOP BELOW
+@ Koranic annotation signs
+08F0 ARABIC OPEN FATHATAN
+ = successive fathatan
+08F1 ARABIC OPEN DAMMATAN
+ = successive dammatan
+08F2 ARABIC OPEN KASRATAN
+ = successive kasratan
+08F3 ARABIC SMALL HIGH WAW
+@ Extended vowel signs for African languages
+08F4 ARABIC FATHA WITH RING
+08F5 ARABIC FATHA WITH DOT ABOVE
+08F6 ARABIC KASRA WITH DOT BELOW
+ * also used in Philippine languages
+08F7 ARABIC LEFT ARROWHEAD ABOVE
+08F8 ARABIC RIGHT ARROWHEAD ABOVE
+08F9 ARABIC LEFT ARROWHEAD BELOW
+08FA ARABIC RIGHT ARROWHEAD BELOW
+08FB ARABIC DOUBLE RIGHT ARROWHEAD ABOVE
+08FC ARABIC DOUBLE RIGHT ARROWHEAD ABOVE WITH DOT
+08FD ARABIC RIGHT ARROWHEAD ABOVE WITH DOT
+@ Extended vowel sign for Philippine languages
+08FE ARABIC DAMMA WITH DOT
@@ 0900 Devanagari 097F
@@+
@ Various signs
@@ -4591,6 +4707,7 @@
x (combining grave accent - 0300)
0954 DEVANAGARI ACUTE ACCENT
x (combining acute accent - 0301)
+@ Dependent vowel sign
0955 DEVANAGARI VOWEL SIGN CANDRA LONG E
* used in transliteration of Avestan
@ Dependent vowel signs for Kashmiri
@@ -4775,14 +4892,18 @@
09ED BENGALI DIGIT SEVEN
09EE BENGALI DIGIT EIGHT
09EF BENGALI DIGIT NINE
-@ Bengali-specific additions
+@ Additions for Assamese
09F0 BENGALI LETTER RA WITH MIDDLE DIAGONAL
- * Assamese
09F1 BENGALI LETTER RA WITH LOWER DIAGONAL
= bengali letter va with lower diagonal (1.0)
- * Assamese
+@ Currency signs
09F2 BENGALI RUPEE MARK
+ = taka
+ * historic currency sign
09F3 BENGALI RUPEE SIGN
+ = Bangladeshi taka
+@ Historic symbols for fractional values
+ at + The use of these signs is not limited to currency, despite the character names.
09F4 BENGALI CURRENCY NUMERATOR ONE
* not in current usage
09F5 BENGALI CURRENCY NUMERATOR TWO
@@ -4792,7 +4913,13 @@
09F7 BENGALI CURRENCY NUMERATOR FOUR
09F8 BENGALI CURRENCY NUMERATOR ONE LESS THAN THE DENOMINATOR
09F9 BENGALI CURRENCY DENOMINATOR SIXTEEN
+@ Sign
09FA BENGALI ISSHAR
+ = ishvar
+ * represents the name of a deity
+ = svargiya
+ * written before the name of a deceased person
+@ Historic currency sign
09FB BENGALI GANDA MARK
@@ 0A00 Gurmukhi 0A7F
@ Various signs
@@ -5015,8 +5142,11 @@
0AED GUJARATI DIGIT SEVEN
0AEE GUJARATI DIGIT EIGHT
0AEF GUJARATI DIGIT NINE
+@ Abbreviation sign
+0AF0 GUJARATI ABBREVIATION SIGN
@ Currency sign
0AF1 GUJARATI RUPEE SIGN
+ * preferred spelling is 0AB0 0AC2 0AF0
@@ 0B00 Oriya 0B7F
@ Various signs
0B01 ORIYA SIGN CANDRABINDU
@@ -5133,8 +5263,9 @@
0B6D ORIYA DIGIT SEVEN
0B6E ORIYA DIGIT EIGHT
0B6F ORIYA DIGIT NINE
-@ Oriya-specific additions
+@ Sign
0B70 ORIYA ISSHAR
+@ Additional consonant
0B71 ORIYA LETTER WA
x (oriya letter o - 0B13)
x (oriya letter va - 0B35)
@@ -5147,10 +5278,12 @@
0B77 ORIYA FRACTION THREE SIXTEENTHS
@@ 0B80 Tamil 0BFF
@ Various signs
+ at + The anusvara should not be confused with the use of a circular glyph for the pulli.
0B82 TAMIL SIGN ANUSVARA
* not used in Tamil
0B83 TAMIL SIGN VISARGA
= aytham
+ * in fonts which display the Tamil pulli as a ring shape, the glyph for aytham also uses rings
@ Independent vowels
0B85 TAMIL LETTER A
0B86 TAMIL LETTER AA
@@ -5210,7 +5343,9 @@
0BCC TAMIL VOWEL SIGN AU
: 0BC6 0BD7
@ Virama
+ at + The Tamil pulli usually displays as a dot above, but in some fonts displays as a ring above. Do not use 0B82 to represent a ring-shaped pulli.
0BCD TAMIL SIGN VIRAMA
+ = pulli
@ Various signs
0BD0 TAMIL OM
0BD7 TAMIL AU LENGTH MARK
@@ -5483,12 +5618,9 @@
0CEF KANNADA DIGIT NINE
@ Signs used in Sanskrit
0CF1 KANNADA SIGN JIHVAMULIYA
- * marks a velar fricative occurring only before unvoiced velar stops
- x (tibetan sign lce tsa can - 0F88)
+ x (vedic sign jihvamuliya - 1CF5)
0CF2 KANNADA SIGN UPADHMANIYA
- * marks a bilabial fricative occurring only before unvoiced labial stops
- x (tibetan sign mchu can - 0F89)
- x (vedic sign ardhavisarga - 1CF2)
+ x (vedic sign upadhmaniya - 1CF6)
@@ 0D00 Malayalam 0D7F
@ Various signs
0D02 MALAYALAM SIGN ANUSVARA
@@ -6075,6 +6207,9 @@
# 0EAB 0E99
0EDD LAO HO MO
# 0EAB 0EA1
+@ Consonants for Khmu
+0EDE LAO LETTER KHMU GO
+0EDF LAO LETTER KHMU NYO
@@ 0F00 Tibetan 0FFF
@+ The Tibetan script is called the Bodhi script in Bhutan.
@ Syllable
@@ -6290,10 +6425,10 @@
0F87 TIBETAN SIGN YANG RTAGS
@ Transliteration head letters
0F88 TIBETAN SIGN LCE TSA CAN
- x (kannada sign jihvamuliya - 0CF1)
+ x (vedic sign jihvamuliya - 1CF5)
x (mongolian letter ali gali damaru - 1882)
0F89 TIBETAN SIGN MCHU CAN
- x (kannada sign upadhmaniya - 0CF2)
+ x (vedic sign upadhmaniya - 1CF6)
x (mongolian letter ali gali inverted ubadama - 1884)
0F8A TIBETAN SIGN GRU CAN RGYINGS
* always followed by 0F82
@@ -6663,6 +6798,10 @@
10C3 GEORGIAN CAPITAL LETTER WE
10C4 GEORGIAN CAPITAL LETTER HAR
10C5 GEORGIAN CAPITAL LETTER HOE
+@ Additional letter
+10C7 GEORGIAN CAPITAL LETTER YN
+@ Additional letter for Ossetian
+10CD GEORGIAN CAPITAL LETTER AEN
@ Mkhedruli
@+ This is the modern secular alphabet, which is caseless.
10D0 GEORGIAN LETTER AN
@@ -6716,6 +6855,10 @@
@ Modifier letter
10FC MODIFIER LETTER GEORGIAN NAR
# <super> 10DC
+@ Additional letters for Ossetian and Abkhaz
+10FD GEORGIAN LETTER AEN
+10FE GEORGIAN LETTER HARD SIGN
+10FF GEORGIAN LETTER LABIAL SIGN
@@ 1100 Hangul Jamo 11FF
@+ The aliases in this block represent the Jamo short names.
@ Initial consonants
@@ -6739,15 +6882,21 @@
= BB
1109 HANGUL CHOSEONG SIOS
= S
+ * voiceless lenis alveolar fricative
110A HANGUL CHOSEONG SSANGSIOS
= SS
+ * voiceless fortis alveolar fricative
110B HANGUL CHOSEONG IEUNG
+ * zero sound
110C HANGUL CHOSEONG CIEUC
= J
+ * voiceless or voiced lenis alveolar affricate
110D HANGUL CHOSEONG SSANGCIEUC
= JJ
+ * voiceless unaspirated fortis alveolar affricate
110E HANGUL CHOSEONG CHIEUCH
= C
+ * voiceless aspirated alveolar affricate
110F HANGUL CHOSEONG KHIEUKH
= K
1110 HANGUL CHOSEONG THIEUTH
@@ -6756,6 +6905,7 @@
= P
1112 HANGUL CHOSEONG HIEUH
= H
+ * voiceless glottal fricative
1113 HANGUL CHOSEONG NIEUN-KIYEOK
1114 HANGUL CHOSEONG SSANGNIEUN
1115 HANGUL CHOSEONG NIEUN-TIKEUT
@@ -6798,10 +6948,15 @@
113A HANGUL CHOSEONG SIOS-PHIEUPH
113B HANGUL CHOSEONG SIOS-HIEUH
113C HANGUL CHOSEONG CHITUEUMSIOS
+ * voiceless lenis dental fricative
113D HANGUL CHOSEONG CHITUEUMSSANGSIOS
+ * voicless fortis dental fricative
113E HANGUL CHOSEONG CEONGCHIEUMSIOS
+ * voiceless lenis retroflex fricative
113F HANGUL CHOSEONG CEONGCHIEUMSSANGSIOS
+ * voiceless fortis retroflex fricative
1140 HANGUL CHOSEONG PANSIOS
+ * voiced alveolar fricative
1141 HANGUL CHOSEONG IEUNG-KIYEOK
1142 HANGUL CHOSEONG IEUNG-TIKEUT
1143 HANGUL CHOSEONG IEUNG-MIEUM
@@ -6814,19 +6969,27 @@
114A HANGUL CHOSEONG IEUNG-THIEUTH
114B HANGUL CHOSEONG IEUNG-PHIEUPH
114C HANGUL CHOSEONG YESIEUNG
+ * velar nasal consonant
114D HANGUL CHOSEONG CIEUC-IEUNG
114E HANGUL CHOSEONG CHITUEUMCIEUC
+ * voiceless or voiced lenis dental affricate
114F HANGUL CHOSEONG CHITUEUMSSANGCIEUC
+ * voiceless unaspirated fortis dental affricate
1150 HANGUL CHOSEONG CEONGCHIEUMCIEUC
+ * voiceless or voiced lenis retroflex affricate
1151 HANGUL CHOSEONG CEONGCHIEUMSSANGCIEUC
+ * voiceless unaspirated fortis retroflex affricate
1152 HANGUL CHOSEONG CHIEUCH-KHIEUKH
1153 HANGUL CHOSEONG CHIEUCH-HIEUH
1154 HANGUL CHOSEONG CHITUEUMCHIEUCH
+ * voiceless aspirated dental affricate
1155 HANGUL CHOSEONG CEONGCHIEUMCHIEUCH
+ * voiceless aspirated retroflex affricate
1156 HANGUL CHOSEONG PHIEUPH-PIEUP
1157 HANGUL CHOSEONG KAPYEOUNPHIEUPH
1158 HANGUL CHOSEONG SSANGHIEUH
1159 HANGUL CHOSEONG YEORINHIEUH
+ * glottal stop
115A HANGUL CHOSEONG KIYEOK-TIKEUT
115B HANGUL CHOSEONG NIEUN-SIOS
115C HANGUL CHOSEONG NIEUN-CIEUC
@@ -6918,6 +7081,7 @@
119C HANGUL JUNGSEONG I-EU
119D HANGUL JUNGSEONG I-ARAEA
119E HANGUL JUNGSEONG ARAEA
+ * rounded open-mid back vowel
119F HANGUL JUNGSEONG ARAEA-EO
11A0 HANGUL JUNGSEONG ARAEA-U
11A1 HANGUL JUNGSEONG ARAEA-I
@@ -6970,6 +7134,7 @@
= SS
11BC HANGUL JONGSEONG IEUNG
= NG
+ * velar nasal consonant
11BD HANGUL JONGSEONG CIEUC
= J
11BE HANGUL JONGSEONG CHIEUCH
@@ -8599,7 +8764,7 @@
* 17B1 is the normal variant of this vowel
17B3 KHMER INDEPENDENT VOWEL QAU
@ Inherent vowels
- at + These are for phonetic transcription to distinguish Indic language inherent vowels from Khmer inherent vowels. These characters are included solely for compatibility with particular applications; their use in other contexts is discouraged.
+ at + These are invisible combining marks for phonetic transcription to distinguish Indic language inherent vowels from Khmer inherent vowels. These characters are included solely for compatibility with particular applications; their use in other contexts is discouraged.
17B4 KHMER VOWEL INHERENT AQ
17B5 KHMER VOWEL INHERENT AA
@ Dependent vowel signs
@@ -8777,30 +8942,62 @@
@ Basic letters
1820 MONGOLIAN LETTER A
x (cyrillic small letter a - 0430)
+ ~ 1820 180B second form (isolate)
+ ~ 1820 180B second form (medial)
+ ~ 1820 180B second form (final)
+ ~ 1820 180C third form (medial)
1821 MONGOLIAN LETTER E
x (cyrillic small letter e - 044D)
+ ~ 1821 180B second form (initial)
+ ~ 1821 180B second form (final)
1822 MONGOLIAN LETTER I
x (cyrillic small letter i - 0438)
+ ~ 1822 180B second form (medial)
1823 MONGOLIAN LETTER O
x (cyrillic small letter o - 043E)
+ ~ 1823 180B second form (medial)
+ ~ 1823 180B second form (final)
1824 MONGOLIAN LETTER U
x (cyrillic small letter u - 0443)
+ ~ 1824 180B second form (medial)
1825 MONGOLIAN LETTER OE
x (cyrillic small letter barred o - 04E9)
+ ~ 1825 180B second form (medial)
+ ~ 1825 180B second form (final)
+ ~ 1825 180C third form (medial)
1826 MONGOLIAN LETTER UE
x (cyrillic small letter straight u - 04AF)
+ ~ 1826 180B second form (isolate)
+ ~ 1826 180B second form (medial)
+ ~ 1826 180B second form (final)
+ ~ 1826 180C third form (medial)
1827 MONGOLIAN LETTER EE
1828 MONGOLIAN LETTER NA
x (cyrillic small letter en - 043D)
+ ~ 1828 180B second form (initial)
+ ~ 1828 180B second form (medial)
+ ~ 1828 180C third form (medial)
+ ~ 1828 180D separate form (medial)
1829 MONGOLIAN LETTER ANG
182A MONGOLIAN LETTER BA
x (cyrillic small letter be - 0431)
+ ~ 182A 180B alternative form (final)
182B MONGOLIAN LETTER PA
x (cyrillic small letter pe - 043F)
182C MONGOLIAN LETTER QA
x (cyrillic small letter ha - 0445)
+ ~ 182C 180B second form (initial)
+ ~ 182C 180B second form (medial)
+ ~ 182C 180B feminine second form (isolate)
+ ~ 182C 180C third form (medial)
+ ~ 182C 180D fourth form (medial)
182D MONGOLIAN LETTER GA
x (cyrillic small letter ghe - 0433)
+ ~ 182D 180B second form (initial)
+ ~ 182D 180B second form (medial)
+ ~ 182D 180B feminine form (final)
+ ~ 182D 180C third form (medial)
+ ~ 182D 180D feminine form (medial)
182E MONGOLIAN LETTER MA
x (cyrillic small letter em - 043C)
182F MONGOLIAN LETTER LA
@@ -8807,22 +9004,33 @@
x (cyrillic small letter el - 043B)
1830 MONGOLIAN LETTER SA
x (cyrillic small letter es - 0441)
+ ~ 1830 180B second form (final)
+ ~ 1830 180C third form (final)
1831 MONGOLIAN LETTER SHA
x (cyrillic small letter sha - 0448)
1832 MONGOLIAN LETTER TA
x (cyrillic small letter te - 0442)
+ ~ 1832 180B second form (medial)
1833 MONGOLIAN LETTER DA
x (cyrillic small letter de - 0434)
+ ~ 1833 180B second form (initial)
+ ~ 1833 180B second form (medial)
+ ~ 1833 180B second form (final)
1834 MONGOLIAN LETTER CHA
x (cyrillic small letter che - 0447)
1835 MONGOLIAN LETTER JA
x (cyrillic small letter zhe - 0436)
+ ~ 1835 180B second form (medial)
1836 MONGOLIAN LETTER YA
x (cyrillic small letter short i - 0439)
+ ~ 1836 180B second form (initial)
+ ~ 1836 180B second form (medial)
+ ~ 1836 180C third form (medial)
1837 MONGOLIAN LETTER RA
x (cyrillic small letter er - 0440)
1838 MONGOLIAN LETTER WA
x (cyrillic small letter ve - 0432)
+ ~ 1838 180B second form (final)
1839 MONGOLIAN LETTER FA
x (cyrillic small letter ef - 0444)
183A MONGOLIAN LETTER KA
@@ -8843,16 +9051,29 @@
@ Todo letters
1843 MONGOLIAN LETTER TODO LONG VOWEL SIGN
1844 MONGOLIAN LETTER TODO E
+ ~ 1844 180B second form (medial)
1845 MONGOLIAN LETTER TODO I
+ ~ 1845 180B second form (medial)
1846 MONGOLIAN LETTER TODO O
+ ~ 1846 180B second form (medial)
1847 MONGOLIAN LETTER TODO U
+ ~ 1847 180B second form (isolate)
+ ~ 1847 180B second form (medial)
+ ~ 1847 180B second form (final)
+ ~ 1847 180C third form (medial)
1848 MONGOLIAN LETTER TODO OE
+ ~ 1848 180B second form (medial)
1849 MONGOLIAN LETTER TODO UE
+ ~ 1849 180B second form (isolate)
+ ~ 1849 180B second form (medial)
184A MONGOLIAN LETTER TODO ANG
184B MONGOLIAN LETTER TODO BA
184C MONGOLIAN LETTER TODO PA
184D MONGOLIAN LETTER TODO QA
+ ~ 184D 180B feminine form (initial)
+ ~ 184D 180B feminine form (medial)
184E MONGOLIAN LETTER TODO GA
+ ~ 184E 180B second form (medial)
184F MONGOLIAN LETTER TODO MA
1850 MONGOLIAN LETTER TODO TA
1851 MONGOLIAN LETTER TODO DA
@@ -8869,18 +9090,32 @@
185C MONGOLIAN LETTER TODO DZA
@ Sibe letters
185D MONGOLIAN LETTER SIBE E
+ ~ 185D 180B second form (medial)
+ ~ 185D 180B second form (final)
185E MONGOLIAN LETTER SIBE I
+ ~ 185E 180B second form (medial)
+ ~ 185E 180B second form (final)
+ ~ 185E 180C third form (medial)
+ ~ 185E 180C third form (final)
185F MONGOLIAN LETTER SIBE IY
1860 MONGOLIAN LETTER SIBE UE
+ ~ 1860 180B second form (medial)
+ ~ 1860 180B second form (final)
1861 MONGOLIAN LETTER SIBE U
1862 MONGOLIAN LETTER SIBE ANG
1863 MONGOLIAN LETTER SIBE KA
+ ~ 1863 180B second form (medial)
1864 MONGOLIAN LETTER SIBE GA
1865 MONGOLIAN LETTER SIBE HA
1866 MONGOLIAN LETTER SIBE PA
1867 MONGOLIAN LETTER SIBE SHA
1868 MONGOLIAN LETTER SIBE TA
+ ~ 1868 180B second form (initial)
+ ~ 1868 180B second form (medial)
+ ~ 1868 180C third form (medial)
1869 MONGOLIAN LETTER SIBE DA
+ ~ 1869 180B second form (initial)
+ ~ 1869 180B second form (medial)
186A MONGOLIAN LETTER SIBE JA
186B MONGOLIAN LETTER SIBE FA
186C MONGOLIAN LETTER SIBE GAA
@@ -8887,20 +9122,36 @@
186D MONGOLIAN LETTER SIBE HAA
186E MONGOLIAN LETTER SIBE TSA
186F MONGOLIAN LETTER SIBE ZA
+ ~ 186F 180B second form (initial)
+ ~ 186F 180B second form (medial)
1870 MONGOLIAN LETTER SIBE RAA
1871 MONGOLIAN LETTER SIBE CHA
1872 MONGOLIAN LETTER SIBE ZHA
@ Manchu letters
1873 MONGOLIAN LETTER MANCHU I
+ ~ 1873 180B second form (medial)
+ ~ 1873 180B second form (final)
+ ~ 1873 180C third form (medial)
+ ~ 1873 180C third form (final)
+ ~ 1873 180D fourth form (medial)
1874 MONGOLIAN LETTER MANCHU KA
+ ~ 1874 180B second form (medial)
+ ~ 1874 180B feminine first final form (final)
+ ~ 1874 180C feminine first medial form (medial)
+ ~ 1874 180C feminine second final form (final)
+ ~ 1874 180D feminine second medial form (medial)
1875 MONGOLIAN LETTER MANCHU RA
1876 MONGOLIAN LETTER MANCHU FA
+ ~ 1876 180B second form (initial)
+ ~ 1876 180B second form (medial)
1877 MONGOLIAN LETTER MANCHU ZHA
@ Extensions for Sanskrit and Tibetan
1880 MONGOLIAN LETTER ALI GALI ANUSVARA ONE
x (tibetan sign sna ldan - 0F83)
+ ~ 1880 180B second form
1881 MONGOLIAN LETTER ALI GALI VISARGA ONE
x (tibetan sign rnam bcad - 0F7F)
+ ~ 1881 180B second form
1882 MONGOLIAN LETTER ALI GALI DAMARU
x (tibetan sign lce tsa can - 0F88)
1883 MONGOLIAN LETTER ALI GALI UBADAMA
@@ -8910,9 +9161,16 @@
x (tibetan mark paluta - 0F85)
1886 MONGOLIAN LETTER ALI GALI THREE BALUDA
1887 MONGOLIAN LETTER ALI GALI A
+ ~ 1887 180B second form (isolate)
+ ~ 1887 180B second form (final)
+ ~ 1887 180C third form (final)
+ ~ 1887 180D fourth form (final)
1888 MONGOLIAN LETTER ALI GALI I
+ ~ 1888 180B second form (final)
1889 MONGOLIAN LETTER ALI GALI KA
188A MONGOLIAN LETTER ALI GALI NGA
+ ~ 188A 180B second form (initial)
+ ~ 188A 180B second form (medial)
188B MONGOLIAN LETTER ALI GALI CA
188C MONGOLIAN LETTER ALI GALI TTA
188D MONGOLIAN LETTER ALI GALI TTHA
@@ -8945,6 +9203,8 @@
18A8 MONGOLIAN LETTER MANCHU ALI GALI BHA
18A9 MONGOLIAN LETTER ALI GALI DAGALGA
18AA MONGOLIAN LETTER MANCHU ALI GALI LHA
+@~ Standarized Variation Sequences
+ at + Unlike other blocks, these variation sequences use the script-specific variation selectors for Mongolian.
@@ 18B0 Unified Canadian Aboriginal Syllabics Extended 18FF
@ Syllables for Moose Cree
18B0 CANADIAN SYLLABICS OY
@@ -9250,7 +9510,7 @@
@@ 19E0 Khmer Symbols 19FF
@ Lunar date symbols
19E0 KHMER SYMBOL PATHAMASAT
- * represents the first August in a leap year
+ * represents the first Ashadha (eighth month of the lunar calendar)
@+ The following fifteen characters represent the first through the fifteenth waxing days, respectively.
19E1 KHMER SYMBOL MUOY KOET
19E2 KHMER SYMBOL PII KOET
@@ -9268,7 +9528,7 @@
19EE KHMER SYMBOL DAP-BUON KOET
19EF KHMER SYMBOL DAP-PRAM KOET
19F0 KHMER SYMBOL TUTEYASAT
- * represents the second August in a leap year
+ * represents the second Ashadha in the lunar calendar during the Adhikameas leap year
@+ The following fifteen characters represent the first through the fifteenth waning days, respectively.
19F1 KHMER SYMBOL MUOY ROC
19F2 KHMER SYMBOL PII ROC
@@ -9338,6 +9598,8 @@
1A2C TAI THAM LETTER NYA
1A2D TAI THAM LETTER RATA
1A2E TAI THAM LETTER HIGH RATHA
+ * an alternative glyph with the upper part shaped like 1A33 is used in Thailand and Laos
+ * contrast the sequence 1A2D 1A5B
1A2F TAI THAM LETTER DA
1A30 TAI THAM LETTER LOW RATHA
1A31 TAI THAM LETTER RANA
@@ -9744,10 +10006,17 @@
= e
1BA9 SUNDANESE VOWEL SIGN PANEULEUNG
= eu
-@ Virama
+@ Viramas
1BAA SUNDANESE SIGN PAMAAEH
= virama
* does not form conjuncts
+1BAB SUNDANESE SIGN VIRAMA
+ * forms conjuncts in older orthography
+@ Consonant signs
+1BAC SUNDANESE CONSONANT SIGN PASANGAN MA
+ = subjoined ma
+1BAD SUNDANESE CONSONANT SIGN PASANGAN WA
+ = subjoined wa
@ Additional consonants
1BAE SUNDANESE LETTER KHA
1BAF SUNDANESE LETTER SYA
@@ -9762,11 +10031,21 @@
1BB7 SUNDANESE DIGIT SEVEN
1BB8 SUNDANESE DIGIT EIGHT
1BB9 SUNDANESE DIGIT NINE
+@ Sign
+1BBA SUNDANESE AVAGRAHA
+@ Historic letters
+1BBB SUNDANESE LETTER REU
+ * vocalic r
+1BBC SUNDANESE LETTER LEU
+ * vocalic l
+1BBD SUNDANESE LETTER BHA
+1BBE SUNDANESE LETTER FINAL K
+1BBF SUNDANESE LETTER FINAL M
@@ 1BC0 Batak 1BFF
@ Letters
@+ Annotations for letters indicate different usage among the various alphabets sharing the Batak script.
1BC0 BATAK LETTER A
- * letter a or ha for Karo and Pakpak
+ * letter a or ha for Karo and Pakpak
1BC1 BATAK LETTER SIMALUNGUN A
1BC2 BATAK LETTER HA
* Toba letter ha or ka
@@ -9989,6 +10268,20 @@
@ Punctuation
1C7E OL CHIKI PUNCTUATION MUCAAD
1C7F OL CHIKI PUNCTUATION DOUBLE MUCAAD
+@@ 1CC0 Sundanese Supplement 1CCF
+@ Punctuation
+1CC0 SUNDANESE PUNCTUATION BINDU SURYA
+ * sun
+1CC1 SUNDANESE PUNCTUATION BINDU PANGLONG
+ * half moon
+1CC2 SUNDANESE PUNCTUATION BINDU PURNAMA
+ * full moon
+1CC3 SUNDANESE PUNCTUATION BINDU CAKRA
+ * wheel
+1CC4 SUNDANESE PUNCTUATION BINDU LEU SATANGA
+1CC5 SUNDANESE PUNCTUATION BINDU KA SATANGA
+1CC6 SUNDANESE PUNCTUATION BINDU DA SATANGA
+1CC7 SUNDANESE PUNCTUATION BINDU BA SATANGA
@@ 1CD0 Vedic Extensions 1CFF
@ Tone marks for the Samaveda
1CD0 VEDIC TONE KARSHANA
@@ -10074,8 +10367,18 @@
@+ Ardhavisarga denotes the sounds jihvamuliya and upadhmaniya (velar and bilabial voicelss fricatives) in Sanskrit. Its use is not limited to Vedic.
1CF2 VEDIC SIGN ARDHAVISARGA
= vaidika jihvaamuuliiya upadhmaaniiya
+1CF3 VEDIC SIGN ROTATED ARDHAVISARGA
+@ Sign for Yajurvedic
+1CF4 VEDIC TONE CANDRA ABOVE
+@ Signs
+1CF5 VEDIC SIGN JIHVAMULIYA
+ * marks a velar fricative occurring only before unvoiced velar stops
x (kannada sign jihvamuliya - 0CF1)
+ x (tibetan sign lce tsa can - 0F88)
+1CF6 VEDIC SIGN UPADHMANIYA
+ * marks a bilabial fricative occurring only before unvoiced labial stops
x (kannada sign upadhmaniya - 0CF2)
+ x (tibetan sign mchu can - 0F89)
@@ 1D00 Phonetic Extensions 1D7F
@+ These are non-IPA phonetic extensions, mostly for the Uralic Phonetic Alphabet (UPA).
@+ The small capitals, superscript, and subscript forms are for phonetic representations where style variations are semantically important.
@@ -11594,6 +11897,7 @@
2013 EN DASH
2014 EM DASH
* may be used in pairs to offset parenthetical text
+ x (two-em dash - 2E3A)
x (katakana-hiragana prolonged sound mark - 30FC)
2015 HORIZONTAL BAR
= quotation dash
@@ -11608,6 +11912,8 @@
x (low line - 005F)
x (combining double low line - 0333)
# 0020 0333
+@ Quotation marks and apostrophe
+ at + Use of quotation marks differs by language. The character names cannot reflect actual usage for all languages.
2018 LEFT SINGLE QUOTATION MARK
= single turned comma quotation mark
* this is the preferred character (as opposed to 201B)
@@ -11646,8 +11952,10 @@
201F DOUBLE HIGH-REVERSED-9 QUOTATION MARK
= double reversed comma quotation mark
* has same semantic as 201C, but differs in appearance
+@ General punctuation
2020 DAGGER
= obelisk, obelus, long cross
+ x (turned dagger - 2E38)
2021 DOUBLE DAGGER
= diesis, double obelisk
2022 BULLET
@@ -11674,6 +11982,7 @@
x (presentation form for vertical horizontal ellipsis - FE19)
# 002E 002E 002E
2027 HYPHENATION POINT
+ * visible symbol used to indicate correct positions for word breaking, as in dic·tion·ar·ies
@ Format characters
2028 LINE SEPARATOR
* may be used to represent this semantic unambiguously
@@ -11733,6 +12042,7 @@
2038 CARET
x (up arrowhead - 2303)
x (modifier letter low circumflex accent - A788)
+@ Quotation marks
2039 SINGLE LEFT-POINTING ANGLE QUOTATION MARK
= left pointing single guillemet
* usually opening, sometimes closing
@@ -11745,6 +12055,7 @@
x (greater-than sign - 003E)
x (right-pointing angle bracket - 232A)
x (right angle bracket - 3009)
+@ General punctuation
203B REFERENCE MARK
= Japanese kome
= Urdu paragraph separator
@@ -11753,6 +12064,8 @@
@ Double punctuation for vertical text
203C DOUBLE EXCLAMATION MARK
x (exclamation mark - 0021)
+ ~ 203C FE0E text style
+ ~ 203C FE0F emoji style
# 0021 0021
@ General punctuation
203D INTERROBANG
@@ -11786,6 +12099,8 @@
2048 QUESTION EXCLAMATION MARK
# 003F 0021
2049 EXCLAMATION QUESTION MARK
+ ~ 2049 FE0E text style
+ ~ 2049 FE0F emoji style
# 0021 003F
@ General punctuation
204A TIRONIAN SIGN ET
@@ -11804,7 +12119,7 @@
* editing mark
2051 TWO ASTERISKS ALIGNED VERTICALLY
2052 COMMERCIAL MINUS SIGN
- = abz\xFCglich (German), med avdrag av (Swedish), piska (Swedish, "whip")
+ = abzüglich (German), med avdrag av (Swedish), piska (Swedish, "whip")
* a common glyph variant and fallback representation looks like ./.
* may also be used as a dingbat to indicate correctness
* used in Finno-Ugric Phonetic Alphabet to indicate a related borrowed form with different sound
@@ -11875,6 +12190,7 @@
206D ACTIVATE ARABIC FORM SHAPING
206E NATIONAL DIGIT SHAPES
206F NOMINAL DIGIT SHAPES
+@~ Standardized Variation Sequences
@@ 2070 Superscripts and Subscripts 209F
@ Superscripts
@+ See also superscript Latin letters in the Spacing Modifier Letters block starting at 02B0.
@@ -12006,6 +12322,7 @@
* intended for lira, but not widely used
* preferred character for lira is 00A3
x (pound sign - 00A3)
+ x (turkish lira sign - 20BA)
20A5 MILL SIGN
* USA (1/10 cent)
20A6 NAIRA SIGN
@@ -12031,13 +12348,15 @@
* Laos
20AE TUGRIK SIGN
* Mongolia
- * also transliterated as tugrug, tugric, tugrog, togrog, t\xF6gr\xF6g
+ * also transliterated as tugrug, tugric, tugrog, togrog, tögrög
20AF DRACHMA SIGN
* Greece
20B0 GERMAN PENNY SIGN
20B1 PESO SIGN
+ = Filipino peso sign
* Philippines
- * the Mexican peso is indicated with the dollar sign
+ * extant and discontinued Latin-American peso currencies (Mexican, Chilean, Colombian, etc.) use the dollar sign
+ x (dollar sign - 0024)
x (peseta sign - 20A7)
20B2 GUARANI SIGN
* Paraguay
@@ -12061,9 +12380,11 @@
x (box drawings down single and horizontal double - 2564)
x (postal mark - 3012)
20B9 INDIAN RUPEE SIGN
- * official Rupee currency sign for India
- * contrasts with script-specific Rupee signs and abbreviations
+ * official rupee currency sign for India
+ * contrasts with script-specific rupee signs and abbreviations
x (devanagari letter ra - 0930)
+20BA TURKISH LIRA SIGN
+ * official lira currency sign for Turkey
@@ 20D0 Combining Diacritical Marks for Symbols 20FF
@ Combining diacritical marks for symbols
20D0 COMBINING LEFT HARPOON ABOVE
@@ -12205,7 +12526,7 @@
x (copyright sign - 00A9)
x (circled latin capital letter p - 24C5)
2118 SCRIPT CAPITAL P
- = Weierstrass elliptic function
+ % WEIERSTRASS ELLIPTIC FUNCTION
* actually this has the form of a lowercase calligraphic p, despite its name
2119 DOUBLE-STRUCK CAPITAL P
# <font> 0050 latin capital letter p
@@ -12263,7 +12584,7 @@
212A KELVIN SIGN
: 004B latin capital letter k
212B ANGSTROM SIGN
- * non SI length unit (=0.1 nm) named after A. J. \xC5ngstr\xF6m, Swedish physicist
+ * non SI length unit (=0.1 nm) named after A. J. Ångström, Swedish physicist
* preferred representation is 00C5
: 00C5 latin capital letter a with ring above
212C SCRIPT CAPITAL B
@@ -12314,6 +12635,8 @@
@ Additional letterlike symbols
2139 INFORMATION SOURCE
* intended for use with 20DD
+ ~ 2139 FE0E text style
+ ~ 2139 FE0F emoji style
# <font> 0069 latin small letter i
213A ROTATED CAPITAL Q
* a binding signature mark
@@ -12372,6 +12695,7 @@
x (greek small letter digamma - 03DD)
@ Biblical editorial symbol
214F SYMBOL FOR SAMARITAN SOURCE
+@~ Standardized Variation Sequences
@@ 2150 Number Forms 218F
@ Fractions
@+ Other fraction number forms are found in the Latin-1 Supplement block.
@@ -12513,11 +12837,23 @@
* IPA: ingressive airflow
2194 LEFT RIGHT ARROW
= z notation relation
+ ~ 2194 FE0E text style
+ ~ 2194 FE0F emoji style
2195 UP DOWN ARROW
+ ~ 2195 FE0E text style
+ ~ 2195 FE0F emoji style
2196 NORTH WEST ARROW
+ ~ 2196 FE0E text style
+ ~ 2196 FE0F emoji style
2197 NORTH EAST ARROW
+ ~ 2197 FE0E text style
+ ~ 2197 FE0F emoji style
2198 SOUTH EAST ARROW
+ ~ 2198 FE0E text style
+ ~ 2198 FE0F emoji style
2199 SOUTH WEST ARROW
+ ~ 2199 FE0E text style
+ ~ 2199 FE0F emoji style
@ Arrows with modifications
219A LEFTWARDS ARROW WITH STROKE
* negation of 2190
@@ -12549,7 +12885,11 @@
= depth symbol
21A8 UP DOWN ARROW WITH BASE
21A9 LEFTWARDS ARROW WITH HOOK
+ ~ 21A9 FE0E text style
+ ~ 21A9 FE0F emoji style
21AA RIGHTWARDS ARROW WITH HOOK
+ ~ 21AA FE0E text style
+ ~ 21AA FE0F emoji style
21AB LEFTWARDS ARROW WITH LOOP
21AC RIGHTWARDS ARROW WITH LOOP
21AD LEFT RIGHT WAVE ARROW
@@ -12640,7 +12980,9 @@
x (north east white arrow - 2B00)
21E7 UPWARDS WHITE ARROW
= shift
+ = level 2 select (ISO 9995-7)
21E8 RIGHTWARDS WHITE ARROW
+ = group select (ISO 9995-7)
21E9 DOWNWARDS WHITE ARROW
21EA UPWARDS WHITE ARROW FROM BAR
= caps lock
@@ -12647,9 +12989,9 @@
21EB UPWARDS WHITE ARROW ON PEDESTAL
= level 2 lock
21EC UPWARDS WHITE ARROW ON PEDESTAL WITH HORIZONTAL BAR
- = caps lock
+ = capitals (caps) lock
21ED UPWARDS WHITE ARROW ON PEDESTAL WITH VERTICAL BAR
- = numerics lock
+ = numeric lock
21EE UPWARDS WHITE DOUBLE ARROW
= level 3 select
21EF UPWARDS WHITE DOUBLE ARROW ON PEDESTAL
@@ -12682,6 +13024,7 @@
21FD LEFTWARDS OPEN-HEADED ARROW
21FE RIGHTWARDS OPEN-HEADED ARROW
21FF LEFT RIGHT OPEN-HEADED ARROW
+@~ Standardized Variation Sequences
@@ 2200 Mathematical Operators 22FF
@@+
@ Miscellaneous mathematical symbols
@@ -12750,8 +13093,11 @@
* generic division operator
x (solidus - 002F)
x (fraction slash - 2044)
+ x (mathematical rising diagonal - 27CB)
2216 SET MINUS
x (reverse solidus - 005C)
+ x (mathematical falling diagonal - 27CD)
+ x (reverse solidus operator - 29F5)
2217 ASTERISK OPERATOR
x (asterisk - 002A)
2218 RING OPERATOR
@@ -12781,7 +13127,7 @@
2221 MEASURED ANGLE
2222 SPHERICAL ANGLE
= angle arc
-@ Operators
+@ Relations
2223 DIVIDES
= such that
= APL stile
@@ -12806,13 +13152,19 @@
2229 INTERSECTION
= cap, hat
x (n-ary intersection - 22C2)
+ ~ 2229 FE00 with serifs
222A UNION
= cup
x (n-ary union - 22C3)
+ ~ 222A FE00 with serifs
@ Integrals
222B INTEGRAL
x (latin small letter esh - 0283)
+;experimenting with variant syntax
+ ~ 222B ALT1 slanted style
222C DOUBLE INTEGRAL
+;experimenting with variant syntax
+ ~ 222C ALT1 slanted style
# 222B 222B
222D TRIPLE INTEGRAL
x (quadruple integral operator - 2A0C)
@@ -12922,7 +13274,9 @@
2266 LESS-THAN OVER EQUAL TO
2267 GREATER-THAN OVER EQUAL TO
2268 LESS-THAN BUT NOT EQUAL TO
+ ~ 2268 FE00 with vertical stroke
2269 GREATER-THAN BUT NOT EQUAL TO
+ ~ 2269 FE00 with vertical stroke
226A MUCH LESS-THAN
x (left-pointing double angle quotation mark - 00AB)
226B MUCH GREATER-THAN
@@ -12940,7 +13294,9 @@
2271 NEITHER GREATER-THAN NOR EQUAL TO
: 2265 0338
2272 LESS-THAN OR EQUIVALENT TO
+ ~ 2272 FE00 following the slant of the lower leg
2273 GREATER-THAN OR EQUIVALENT TO
+ ~ 2273 FE00 following the slant of the lower leg
2274 NEITHER LESS-THAN NOR EQUIVALENT TO
: 2272 0338
2275 NEITHER GREATER-THAN NOR EQUIVALENT TO
@@ -12982,7 +13338,9 @@
2289 NEITHER A SUPERSET OF NOR EQUAL TO
: 2287 0338
228A SUBSET OF WITH NOT EQUAL TO
+ ~ 228A FE00 with stroke through bottom members
228B SUPERSET OF WITH NOT EQUAL TO
+ ~ 228B FE00 with stroke through bottom members
@ Operators
228C MULTISET
228D MULTISET MULTIPLICATION
@@ -12999,12 +13357,15 @@
@ Operators
2293 SQUARE CAP
x (n-ary square intersection operator - 2A05)
+ ~ 2293 FE00 with serifs
2294 SQUARE CUP
+ ~ 2294 FE00 with serifs
2295 CIRCLED PLUS
= direct sum
= vector pointing into page
x (n-ary circled plus operator - 2A01)
x (alchemical symbol for verdigris - 1F728)
+ ~ 2295 FE00 with white rim
2296 CIRCLED MINUS
= symmetric difference
x (circle with horizontal bar - 29B5)
@@ -13014,6 +13375,7 @@
= vector pointing into page
x (circled crossing lanes - 26D2)
x (n-ary circled times operator - 2A02)
+ ~ 2297 FE00 with white rim
2298 CIRCLED DIVISION SLASH
2299 CIRCLED DOT OPERATOR
= direct product
@@ -13027,6 +13389,7 @@
229B CIRCLED ASTERISK OPERATOR
x (apl functional symbol circle star - 235F)
229C CIRCLED EQUALS
+ ~ 229C FE00 with equal sign touching the circle
229D CIRCLED DASH
229E SQUARED PLUS
229F SQUARED MINUS
@@ -13151,7 +13514,9 @@
22D8 VERY MUCH LESS-THAN
22D9 VERY MUCH GREATER-THAN
22DA LESS-THAN EQUAL TO OR GREATER-THAN
+ ~ 22DA FE00 with slanted equal
22DB GREATER-THAN EQUAL TO OR LESS-THAN
+ ~ 22DB FE00 with slanted equal
22DC EQUAL TO OR LESS-THAN
22DD EQUAL TO OR GREATER-THAN
22DE EQUAL TO OR PRECEDES
@@ -13200,6 +13565,10 @@
22FD CONTAINS WITH OVERBAR
22FE SMALL CONTAINS WITH OVERBAR
22FF Z NOTATION BAG MEMBERSHIP
+@@~ Alternative Glyph Listing
+ at + Experimental listing
+@~ Standarized Variation Sequences
+ at + Experimental listing
@@ 2300 Miscellaneous Technical 23FF
@ Miscellaneous technical
2300 DIAMETER SIGN
@@ -13263,6 +13632,7 @@
x (equal and parallel to - 22D5)
2318 PLACE OF INTEREST SIGN
= command key (1.0)
+ = operating system key (ISO 9995-7)
2319 TURNED NOT SIGN
= line marker
@ User interface symbols
@@ -13269,8 +13639,12 @@
231A WATCH
x (alarm clock - 23F0)
x (clock face one oclock - 1F550)
+ ~ 231A FE0E text style
+ ~ 231A FE0F emoji style
231B HOURGLASS
= alchemical symbol for hour
+ ~ 231B FE0E text style
+ ~ 231B FE0F emoji style
@ Quine corners
@+ These form a set of four quine corners, for quincuncial arrangement. They are also used in upper and lower pairs in mathematic, or more rarely in editorial usage as alternatives to half brackets.
231C TOP LEFT CORNER
@@ -13631,6 +14005,7 @@
23F2 TIMER CLOCK
23F3 HOURGLASS WITH FLOWING SAND
x (hourglass - 231B)
+@~ Standardized Variation Sequences
@@ 2400 Control Pictures 243F
@+ The diagonal lettering glyphs are only exemplary; alternate representations may be, and often are used in the visible display of control codes.
@ Graphic pictures for control codes
@@ -13686,7 +14061,7 @@
@+ * from ISO 2047
x (arabic question mark - 061F)
@@ 2440 Optical Character Recognition 245F
-@ OCR
+@ OCR-A
2440 OCR HOOK
2441 OCR CHAIR
2442 OCR FORK
@@ -13693,14 +14068,21 @@
2443 OCR INVERTED FORK
2444 OCR BELT BUCKLE
2445 OCR BOW TIE
+ = unique asterisk
x (bowtie - 22C8)
+@ MICR
+ at + These magnetic ink character recognition symbols are used on checks. The are derived from the E-13B font and are standardized in ISO 1004:1995. The Unicode character names include several misnomers.
2446 OCR BRANCH BANK IDENTIFICATION
= transit
2447 OCR AMOUNT OF CHECK
+ = amount
2448 OCR DASH
+ % MICR ON US SYMBOL
= on us
2449 OCR CUSTOMER ACCOUNT NUMBER
+ % MICR DASH SYMBOL
= dash
+@ OCR
244A OCR DOUBLE BACKSLASH
@@ 2460 Enclosed Alphanumerics 24FF
@ Circled numbers
@@ -13908,6 +14290,8 @@
24C1 CIRCLED LATIN CAPITAL LETTER L
# <circle> 004C
24C2 CIRCLED LATIN CAPITAL LETTER M
+ ~ 24C2 FE0E text style
+ ~ 24C2 FE0F emoji style
# <circle> 004D
24C3 CIRCLED LATIN CAPITAL LETTER N
# <circle> 004E
@@ -14017,6 +14401,7 @@
@ Additional white on black circled number
24FF NEGATIVE CIRCLED DIGIT ZERO
x (dingbat negative circled digit one - 2776)
+@~ Standardized Variation Sequences
@@ 2500 Box Drawing 257F
@+ All of these characters are intended for compatibility with old sets oriented toward character cell graphics.
@ Light and heavy solid lines
@@ -14249,9 +14634,14 @@
25A8 SQUARE WITH UPPER RIGHT TO LOWER LEFT FILL
25A9 SQUARE WITH DIAGONAL CROSSHATCH FILL
25AA BLACK SMALL SQUARE
+ = square bullet
x (black very small square - 2B1D)
+ ~ 25AA FE0E text style
+ ~ 25AA FE0F emoji style
25AB WHITE SMALL SQUARE
x (white very small square - 2B1E)
+ ~ 25AB FE0E text style
+ ~ 25AB FE0F emoji style
25AC BLACK RECTANGLE
25AD WHITE RECTANGLE
25AE BLACK VERTICAL RECTANGLE
@@ -14274,6 +14664,8 @@
x (up-pointing small red triangle - 1F53C)
25B5 WHITE UP-POINTING SMALL TRIANGLE
25B6 BLACK RIGHT-POINTING TRIANGLE
+ ~ 25B6 FE0E text style
+ ~ 25B6 FE0F emoji style
25B7 WHITE RIGHT-POINTING TRIANGLE
= z notation range restriction
25B8 BLACK RIGHT-POINTING SMALL TRIANGLE
@@ -14294,6 +14686,8 @@
x (down-pointing small red triangle - 1F53D)
25BF WHITE DOWN-POINTING SMALL TRIANGLE
25C0 BLACK LEFT-POINTING TRIANGLE
+ ~ 25C0 FE0E text style
+ ~ 25C0 FE0F emoji style
25C1 WHITE LEFT-POINTING TRIANGLE
= z notation domain restriction
25C2 BLACK LEFT-POINTING SMALL TRIANGLE
@@ -14397,14 +14791,24 @@
25FB WHITE MEDIUM SQUARE
= always (modal operator)
x (white square - 25A1)
+ ~ 25FB FE0E text style
+ ~ 25FB FE0F emoji style
25FC BLACK MEDIUM SQUARE
x (black square - 25A0)
+ ~ 25FC FE0E text style
+ ~ 25FC FE0F emoji style
25FD WHITE MEDIUM SMALL SQUARE
x (white small square - 25AB)
+ ~ 25FD FE0E text style
+ ~ 25FD FE0F emoji style
25FE BLACK MEDIUM SMALL SQUARE
x (black small square - 25AA)
+ ~ 25FE FE0E text style
+ ~ 25FE FE0F emoji style
25FF LOWER RIGHT TRIANGLE
x (right triangle - 22BF)
+@~ Standarized Variation Sequences
+ at + Emoji style variants include rendering of characters in ways not achievable with traditional or even digital typography. The sample glyphs shown here cannot faithfully represent the range of intended appearances.
@@ 2600 Miscellaneous Symbols 26FF
@@+
@ Weather and astrological symbols
@@ -14412,8 +14816,12 @@
= clear weather
x (sun - 2609)
x (high brightness symbol - 1F506)
+ ~ 2600 FE0E text style
+ ~ 2600 FE0F emoji style
2601 CLOUD
= cloudy weather
+ ~ 2601 FE0E text style
+ ~ 2601 FE0F emoji style
2602 UMBRELLA
= rainy weather
x (closed umbrella - 1F302)
@@ -14446,10 +14854,14 @@
x (telephone sign - 2121)
x (telephone location sign - 2706)
x (telephone receiver - 1F4DE)
+ ~ 260E FE0E text style
+ ~ 260E FE0F emoji style
260F WHITE TELEPHONE
2610 BALLOT BOX
x (white square - 25A1)
2611 BALLOT BOX WITH CHECK
+ ~ 2611 FE0E text style
+ ~ 2611 FE0F emoji style
2612 BALLOT BOX WITH X
x (squared times - 22A0)
2613 SALTIRE
@@ -14458,6 +14870,8 @@
@ Weather symbol
2614 UMBRELLA WITH RAIN DROPS
= showery weather
+ ~ 2614 FE0E text style
+ ~ 2614 FE0F emoji style
@ Miscellaneous symbol
2615 HOT BEVERAGE
= tea or coffee, depending on locale
@@ -14465,6 +14879,8 @@
x (watch - 231A)
x (hourglass - 231B)
x (teacup without handle - 1F375)
+ ~ 2615 FE0E text style
+ ~ 2615 FE0F emoji style
@ Japanese chess symbols
2616 WHITE SHOGI PIECE
2617 BLACK SHOGI PIECE
@@ -14480,6 +14896,8 @@
261C WHITE LEFT POINTING INDEX
x (white left pointing backhand index - 1F448)
261D WHITE UP POINTING INDEX
+ ~ 261D FE0E text style
+ ~ 261D FE0F emoji style
261E WHITE RIGHT POINTING INDEX
= fist (typographic term)
261F WHITE DOWN POINTING INDEX
@@ -14536,6 +14954,8 @@
2639 WHITE FROWNING FACE
263A WHITE SMILING FACE
= have a nice day!
+ ~ 263A FE0E text style
+ ~ 263A FE0F emoji style
263B BLACK SMILING FACE
@ Miscellaneous symbol
263C WHITE SUN WITH RAYS
@@ -14574,21 +14994,45 @@
2647 PLUTO
@ Zodiacal symbols
2648 ARIES
+ ~ 2648 FE0E text style
+ ~ 2648 FE0F emoji style
2649 TAURUS
+ ~ 2649 FE0E text style
+ ~ 2649 FE0F emoji style
264A GEMINI
+ ~ 264A FE0E text style
+ ~ 264A FE0F emoji style
264B CANCER
+ ~ 264B FE0E text style
+ ~ 264B FE0F emoji style
264C LEO
+ ~ 264C FE0E text style
+ ~ 264C FE0F emoji style
264D VIRGO
= minim (alternate glyph)
+ ~ 264D FE0E text style
+ ~ 264D FE0F emoji style
264E LIBRA
x (alchemical symbol for sublimation - 1F75E)
+ ~ 264E FE0E text style
+ ~ 264E FE0F emoji style
264F SCORPIUS
= scorpio
= minim, drop
+ ~ 264F FE0E text style
+ ~ 264F FE0F emoji style
2650 SAGITTARIUS
+ ~ 2650 FE0E text style
+ ~ 2650 FE0F emoji style
2651 CAPRICORN
+ ~ 2651 FE0E text style
+ ~ 2651 FE0F emoji style
2652 AQUARIUS
+ ~ 2652 FE0E text style
+ ~ 2652 FE0F emoji style
2653 PISCES
+ ~ 2653 FE0E text style
+ ~ 2653 FE0F emoji style
@ Chess symbols
2654 WHITE CHESS KING
2655 WHITE CHESS QUEEN
@@ -14604,6 +15048,8 @@
265F BLACK CHESS PAWN
@ Playing card symbols
2660 BLACK SPADE SUIT
+ ~ 2660 FE0E text style
+ ~ 2660 FE0F emoji style
2661 WHITE HEART SUIT
2662 WHITE DIAMOND SUIT
x (white diamond - 25C7)
@@ -14610,16 +15056,24 @@
x (lozenge - 25CA)
2663 BLACK CLUB SUIT
x (shamrock - 2618)
+ ~ 2663 FE0E text style
+ ~ 2663 FE0F emoji style
2664 WHITE SPADE SUIT
2665 BLACK HEART SUIT
= valentine
x (heavy black heart - 2764)
x (blue heart - 1F499)
+ ~ 2665 FE0E text style
+ ~ 2665 FE0F emoji style
2666 BLACK DIAMOND SUIT
x (black diamond - 25C6)
+ ~ 2666 FE0E text style
+ ~ 2666 FE0F emoji style
2667 WHITE CLUB SUIT
@ Miscellaneous symbol
2668 HOT SPRINGS
+ ~ 2668 FE0E text style
+ ~ 2668 FE0F emoji style
@ Musical symbols
2669 QUARTER NOTE
= crotchet
@@ -14663,6 +15117,8 @@
* used together with other text and labels to indicate the type of material to be recycled
267B BLACK UNIVERSAL RECYCLING SYMBOL
x (clockwise rightwards and leftwards open circle arrows - 1F501)
+ ~ 267B FE0E text style
+ ~ 267B FE0F emoji style
267C RECYCLED PAPER SYMBOL
* used to indicate 100% recycled paper content
267D PARTIALLY-RECYCLED PAPER SYMBOL
@@ -14670,6 +15126,8 @@
@ Miscellaneous symbols
267E PERMANENT PAPER SIGN
267F WHEELCHAIR SYMBOL
+ ~ 267F FE0E text style
+ ~ 267F FE0F emoji style
@ Dice
2680 DIE FACE-1
x (game die - 1F3B2)
@@ -14700,6 +15158,8 @@
x (pick - 26CF)
2693 ANCHOR
= nautical term, harbor (on maps)
+ ~ 2693 FE0E text style
+ ~ 2693 FE0F emoji style
2694 CROSSED SWORDS
= military term, battleground (on maps), killed in action
2695 STAFF OF AESCULAPIUS
@@ -14710,6 +15170,7 @@
= legal term, jurisprudence
2697 ALEMBIC
= chemical term, chemistry
+ x (alchemical symbol for retort - 1F76D)
2698 FLOWER
= botanical term
x (flower punctuation mark - 2055)
@@ -14734,9 +15195,13 @@
= background speaking
@ Miscellaneous symbols
26A0 WARNING SIGN
+ ~ 26A0 FE0E text style
+ ~ 26A0 FE0F emoji style
26A1 HIGH VOLTAGE SIGN
= thunder
= lightning symbol
+ ~ 26A1 FE0E text style
+ ~ 26A1 FE0F emoji style
@ Gender symbols
26A2 DOUBLED FEMALE SIGN
= lesbianism
@@ -14765,8 +15230,12 @@
= asexuality, sexless, genderless
= engaged, betrothed
* base for male or female sign
+ ~ 26AA FE0E text style
+ ~ 26AA FE0F emoji style
26AB MEDIUM BLACK CIRCLE
* UI symbol for record function
+ ~ 26AB FE0E text style
+ ~ 26AB FE0F emoji style
26AC MEDIUM SMALL WHITE CIRCLE
= engaged, betrothed (genealogy)
* can represent wedding ring
@@ -14803,7 +15272,11 @@
@ Sport symbols
@+ See other sport symbols in the Miscellaneous Symbols and Pictographs block.
26BD SOCCER BALL
+ ~ 26BD FE0E text style
+ ~ 26BD FE0F emoji style
26BE BASEBALL
+ ~ 26BE FE0E text style
+ ~ 26BE FE0F emoji style
@ Miscellaneous symbol from ARIB STD B24
26BF SQUARED KEY
= parental lock
@@ -14816,8 +15289,12 @@
@ Weather symbols from ARIB STD B24
26C4 SNOWMAN WITHOUT SNOW
= light snow
+ ~ 26C4 FE0E text style
+ ~ 26C4 FE0F emoji style
26C5 SUN BEHIND CLOUD
= partly cloudy
+ ~ 26C5 FE0E text style
+ ~ 26C5 FE0F emoji style
26C6 RAIN
= rainy weather
26C7 BLACK SNOWMAN
@@ -14852,6 +15329,8 @@
= tyre chains required
26D4 NO ENTRY
x (no entry sign - 1F6AB)
+ ~ 26D4 FE0E text style
+ ~ 26D4 FE0F emoji style
26D5 ALTERNATE ONE-WAY LEFT WAY TRAFFIC
* left side traffic
26D6 BLACK TWO-WAY LEFT WAY TRAFFIC
@@ -14903,6 +15382,8 @@
26E9 SHINTO SHRINE
= torii
26EA CHURCH
+ ~ 26EA FE0E text style
+ ~ 26EA FE0F emoji style
26EB CASTLE
x (european castle - 1F3F0)
26EC HISTORIC SITE
@@ -14921,9 +15402,13 @@
x (umbrella - 2602)
26F2 FOUNTAIN
= park
+ ~ 26F2 FE0E text style
+ ~ 26F2 FE0F emoji style
26F3 FLAG IN HOLE
= golf course
x (triangular flag on post - 1F6A9)
+ ~ 26F3 FE0E text style
+ ~ 26F3 FE0F emoji style
26F4 FERRY
= ferry boat terminal
x (ship - 1F6A2)
@@ -14930,6 +15415,8 @@
26F5 SAILBOAT
= marina or yacht harbour
x (rowboat - 1F6A3)
+ ~ 26F5 FE0E text style
+ ~ 26F5 FE0F emoji style
26F6 SQUARE FOUR CORNERS
= intersection
26F7 SKIER
@@ -14941,6 +15428,8 @@
= track and field, gymnasium
26FA TENT
= camping site
+ ~ 26FA FE0E text style
+ ~ 26FA FE0F emoji style
26FB JAPANESE BANK SYMBOL
x (bank - 1F3E6)
26FC HEADSTONE GRAVEYARD SYMBOL
@@ -14947,6 +15436,8 @@
= graveyard, memorial park, cemetery
26FD FUEL PUMP
= petrol station, gas station
+ ~ 26FD FE0E text style
+ ~ 26FD FE0F emoji style
26FE CUP ON BLACK SQUARE
= drive-in restaurant
x (hot beverage - 2615)
@@ -14953,6 +15444,7 @@
x (teacup without handle - 1F375)
26FF WHITE FLAG WITH HORIZONTAL MIDDLE BLACK STRIPE
= Japanese self-defence force site
+@~ Standardized Variation Sequences
@@ 2700 Dingbats 27BF
@+ ITC Zapf dingbats series 100. Some of the ITC Zapf dingbats have been unified with geometric shape characters. Gaps in the chart have subsequently been filled with other dingbat-like symbols.
x (black telephone - 260E)
@@ -14970,6 +15462,8 @@
@ Miscellaneous
2701 UPPER BLADE SCISSORS
2702 BLACK SCISSORS
+ ~ 2702 FE0E text style
+ ~ 2702 FE0F emoji style
2703 LOWER BLADE SCISSORS
2704 WHITE SCISSORS
2705 WHITE HEAVY CHECK MARK
@@ -14979,8 +15473,12 @@
x (telephone receiver - 1F4DE)
2707 TAPE DRIVE
2708 AIRPLANE
+ ~ 2708 FE0E text style
+ ~ 2708 FE0F emoji style
2709 ENVELOPE
x (incoming envelope - 1F4E8)
+ ~ 2709 FE0E text style
+ ~ 2709 FE0F emoji style
270A RAISED FIST
= rock in Rock, Paper, Scissors game
x (fisted hand sign - 1F44A)
@@ -14989,19 +15487,29 @@
x (waving hand sign - 1F44B)
270C VICTORY HAND
= scissors in Rock, Paper, Scissors game
+ ~ 270C FE0E text style
+ ~ 270C FE0F emoji style
270D WRITING HAND
270E LOWER RIGHT PENCIL
270F PENCIL
+ ~ 270F FE0E text style
+ ~ 270F FE0F emoji style
2710 UPPER RIGHT PENCIL
2711 WHITE NIB
2712 BLACK NIB
+ ~ 2712 FE0E text style
+ ~ 2712 FE0F emoji style
2713 CHECK MARK
x (square root - 221A)
2714 HEAVY CHECK MARK
+ ~ 2714 FE0E text style
+ ~ 2714 FE0F emoji style
2715 MULTIPLICATION X
x (multiplication sign - 00D7)
x (box drawings light diagonal cross - 2573)
2716 HEAVY MULTIPLICATION X
+ ~ 2716 FE0E text style
+ ~ 2716 FE0F emoji style
2717 BALLOT X
x (saltire - 2613)
2718 HEAVY BALLOT X
@@ -15014,7 +15522,7 @@
271E SHADOWED WHITE LATIN CROSS
271F OUTLINED LATIN CROSS
2720 MALTESE CROSS
- * Historically, the Maltese cross took many forms; the shape shown in the Zapf Dingbats is similar to one known as the Cross Form\xE9e.
+ * Historically, the Maltese cross took many forms; the shape shown in the Zapf Dingbats is similar to one known as the Cross Formée.
@ Stars, asterisks and snowflakes
2721 STAR OF DAVID
x (six pointed star with middle dot - 1F52F)
@@ -15038,7 +15546,11 @@
x (asterisk - 002A)
2732 OPEN CENTRE ASTERISK
2733 EIGHT SPOKED ASTERISK
+ ~ 2733 FE0E text style
+ ~ 2733 FE0F emoji style
2734 EIGHT POINTED BLACK STAR
+ ~ 2734 FE0E text style
+ ~ 2734 FE0F emoji style
2735 EIGHT POINTED PINWHEEL STAR
2736 SIX POINTED BLACK STAR
= sextile
@@ -15058,9 +15570,13 @@
2742 CIRCLED OPEN CENTRE EIGHT POINTED STAR
2743 HEAVY TEARDROP-SPOKED PINWHEEL ASTERISK
2744 SNOWFLAKE
+ ~ 2744 FE0E text style
+ ~ 2744 FE0F emoji style
2745 TIGHT TRIFOLIATE SNOWFLAKE
2746 HEAVY CHEVRON SNOWFLAKE
2747 SPARKLE
+ ~ 2747 FE0E text style
+ ~ 2747 FE0F emoji style
2748 HEAVY SPARKLE
2749 BALLOON-SPOKED ASTERISK
= jack
@@ -15083,6 +15599,8 @@
2756 BLACK DIAMOND MINUS WHITE X
2757 HEAVY EXCLAMATION MARK SYMBOL
= obstacles on the road, ARIB STD B24
+ ~ 2757 FE0E text style
+ ~ 2757 FE0F emoji style
2758 LIGHT VERTICAL BAR
x (vertical line - 007C)
2759 MEDIUM VERTICAL BAR
@@ -15107,6 +15625,8 @@
2763 HEAVY HEART EXCLAMATION MARK ORNAMENT
2764 HEAVY BLACK HEART
x (black heart suit - 2665)
+ ~ 2764 FE0E text style
+ ~ 2764 FE0F emoji style
2765 ROTATED HEAVY BLACK HEART BULLET
2766 FLORAL HEART
= Aldus leaf
@@ -15191,6 +15711,8 @@
27A1 BLACK RIGHTWARDS ARROW
* fonts may harmonize this glyph with the style for other black arrows
x (leftwards black arrow - 2B05)
+ ~ 27A1 FE0E text style
+ ~ 27A1 FE0F emoji style
27A2 THREE-D TOP-LIGHTED RIGHTWARDS ARROWHEAD
27A3 THREE-D BOTTOM-LIGHTED RIGHTWARDS ARROWHEAD
27A4 BLACK RIGHTWARDS ARROWHEAD
@@ -15225,6 +15747,7 @@
27BE OPEN-OUTLINED RIGHTWARDS ARROW
@ Miscellaneous
27BF DOUBLE CURLY LOOP
+@~ Standardized Variation Sequences
@@ 27C0 Miscellaneous Mathematical Symbols-A 27EF
@ Miscellaneous symbols
27C0 THREE DIMENSIONAL ANGLE
@@ -15246,6 +15769,10 @@
27CA VERTICAL BAR WITH HORIZONTAL STROKE
x (parallel with horizontal stroke - 2AF2)
x (triple vertical bar with horizontal stroke - 2AF5)
+@ Miscellaneous symbol
+27CB MATHEMATICAL RISING DIAGONAL
+ = \diagup
+ x (division slash - 2215)
@ Division operator
27CC LONG DIVISION
* graphically extends over the dividend
@@ -15252,6 +15779,11 @@
x (division sign - 00F7)
x (division slash - 2215)
x (square root - 221A)
+@ Miscellaneous symbol
+27CD MATHEMATICAL FALLING DIAGONAL
+ = \diagdown
+ x (set minus - 2216)
+ x (reverse solidus operator - 29F5)
@ Operators
27CE SQUARED LOGICAL AND
= box min
@@ -15318,6 +15850,7 @@
27E5 WHITE SQUARE WITH RIGHTWARDS TICK
= will always be (modal operator)
@ Mathematical brackets
+ at + These bracket characters are also used as punctuation outside of a mathematical context.
27E6 MATHEMATICAL LEFT WHITE SQUARE BRACKET
= z notation left bag bracket
x (left white square bracket - 301A)
@@ -15741,7 +16274,11 @@
x (rightwards wave arrow - 219D)
x (wave arrow pointing directly left - 2B3F)
2934 ARROW POINTING RIGHTWARDS THEN CURVING UPWARDS
+ ~ 2934 FE0E text style
+ ~ 2934 FE0F emoji style
2935 ARROW POINTING RIGHTWARDS THEN CURVING DOWNWARDS
+ ~ 2935 FE0E text style
+ ~ 2935 FE0F emoji style
2936 ARROW POINTING DOWNWARDS THEN CURVING LEFTWARDS
2937 ARROW POINTING DOWNWARDS THEN CURVING RIGHTWARDS
2938 RIGHT-SIDE ARC CLOCKWISE ARROW
@@ -15834,6 +16371,7 @@
297D RIGHT FISH TAIL
297E UP FISH TAIL
297F DOWN FISH TAIL
+@~ Standardized Variation Sequences
@@ 2980 Miscellaneous Mathematical Symbols-B 29FF
@ Miscellaneous mathematical symbols
2980 TRIPLE VERTICAL BAR DELIMITER
@@ -16032,6 +16570,7 @@
29F5 REVERSE SOLIDUS OPERATOR
x (reverse solidus - 005C)
x (set minus - 2216)
+ x (mathematical falling diagonal - 27CD)
29F6 SOLIDUS WITH OVERBAR
29F7 REVERSE SOLIDUS WITH HORIZONTAL STROKE
x (apl functional symbol backslash bar - 2340)
@@ -16158,9 +16697,11 @@
2A3B MULTIPLICATION SIGN IN TRIANGLE
2A3C INTERIOR PRODUCT
x (right floor - 230B)
+ ~ 2A3C FE00 tall variant with narrow foot
2A3D RIGHTHAND INTERIOR PRODUCT
x (left floor - 230A)
x (turned not sign - 2319)
+ ~ 2A3D FE00 tall variant with narrow foot
2A3E Z NOTATION RELATIONAL COMPOSITION
x (z notation schema composition - 2A1F)
2A3F AMALGAMATION OR COPRODUCT
@@ -16298,7 +16839,9 @@
2A9B DOUBLE-LINE SLANTED EQUAL TO OR LESS-THAN
2A9C DOUBLE-LINE SLANTED EQUAL TO OR GREATER-THAN
2A9D SIMILAR OR LESS-THAN
+ ~ 2A9D FE00 with similar following the slant of the upper leg
2A9E SIMILAR OR GREATER-THAN
+ ~ 2A9E FE00 with similar following the slant of the upper leg
2A9F SIMILAR ABOVE LESS-THAN ABOVE EQUALS SIGN
2AA0 SIMILAR ABOVE GREATER-THAN ABOVE EQUALS SIGN
2AA1 DOUBLE NESTED LESS-THAN
@@ -16316,7 +16859,9 @@
2AAA SMALLER THAN
2AAB LARGER THAN
2AAC SMALLER THAN OR EQUAL TO
+ ~ 2AAC FE00 with slanted equal
2AAD LARGER THAN OR EQUAL TO
+ ~ 2AAD FE00 with slanted equal
2AAE EQUALS SIGN WITH BUMPY ABOVE
x (difference between - 224F)
2AAF PRECEDES ABOVE SINGLE-LINE EQUALS SIGN
@@ -16351,7 +16896,9 @@
2AC9 SUBSET OF ABOVE ALMOST EQUAL TO
2ACA SUPERSET OF ABOVE ALMOST EQUAL TO
2ACB SUBSET OF ABOVE NOT EQUAL TO
+ ~ 2ACB FE00 with stroke through bottom members
2ACC SUPERSET OF ABOVE NOT EQUAL TO
+ ~ 2ACC FE00 with stroke through bottom members
2ACD SQUARE LEFT OPEN BOX OPERATOR
2ACE SQUARE RIGHT OPEN BOX OPERATOR
2ACF CLOSED SUBSET
@@ -16459,6 +17006,7 @@
= Dijkstra choice
2AFF N-ARY WHITE VERTICAL BAR
= n-ary Dijkstra choice
+@~ Standardized Variation Sequences
@@ 2B00 Miscellaneous Symbols and Arrows 2BFF
@ White and black arrows
@+ Other white and black arrows to complete this set can be found in the Arrows and Dingbats blocks.
@@ -16471,8 +17019,14 @@
x (up down white arrow - 21F3)
2B05 LEFTWARDS BLACK ARROW
x (black rightwards arrow - 27A1)
+ ~ 2B05 FE0E text style
+ ~ 2B05 FE0F emoji style
2B06 UPWARDS BLACK ARROW
+ ~ 2B06 FE0E text style
+ ~ 2B06 FE0F emoji style
2B07 DOWNWARDS BLACK ARROW
+ ~ 2B07 FE0E text style
+ ~ 2B07 FE0F emoji style
2B08 NORTH EAST BLACK ARROW
2B09 NORTH WEST BLACK ARROW
2B0A SOUTH EAST BLACK ARROW
@@ -16500,8 +17054,12 @@
2B1A DOTTED SQUARE
2B1B BLACK LARGE SQUARE
x (black square - 25A0)
+ ~ 2B1B FE0E text style
+ ~ 2B1B FE0F emoji style
2B1C WHITE LARGE SQUARE
x (white square - 25A1)
+ ~ 2B1C FE0E text style
+ ~ 2B1C FE0F emoji style
2B1D BLACK VERY SMALL SQUARE
x (black small square - 25AA)
2B1E WHITE VERY SMALL SQUARE
@@ -16603,6 +17161,8 @@
@ Stars
2B50 WHITE MEDIUM STAR
x (star operator - 22C6)
+ ~ 2B50 FE0E text style
+ ~ 2B50 FE0F emoji style
2B51 BLACK SMALL STAR
x (arabic five pointed star - 066D)
2B52 WHITE SMALL STAR
@@ -16614,6 +17174,8 @@
= basic symbol for speed limit
* forms a game tally pair with 274C
x (large circle - 25EF)
+ ~ 2B55 FE0E text style
+ ~ 2B55 FE0F emoji style
@ Dictionary and map symbols from ARIB STD B24
2B56 HEAVY OVAL WITH OVAL INSIDE
= prefectural office
@@ -16626,6 +17188,7 @@
2B59 HEAVY CIRCLED SALTIRE
= police station
x (n-ary circled times operator - 2A02)
+@~ Standardized Variation Sequences
@@ 2C00 Glagolitic 2C5F
@ Capital letters
2C00 GLAGOLITIC CAPITAL LETTER AZU
@@ -16911,6 +17474,11 @@
2CF1 COPTIC COMBINING SPIRITUS LENIS
x (combining comma above - 0313)
x (combining cyrillic psili pneumata - 0486)
+@ Bohairic Coptic letters
+2CF2 COPTIC CAPITAL LETTER BOHAIRIC KHEI
+ x (coptic capital letter khei - 03E6)
+2CF3 COPTIC SMALL LETTER BOHAIRIC KHEI
+ x (coptic small letter khei - 03E7)
@ Old Nubian punctuation
2CF9 COPTIC OLD NUBIAN FULL STOP
2CFA COPTIC OLD NUBIAN DIRECT QUESTION MARK
@@ -16962,6 +17530,10 @@
2D23 GEORGIAN SMALL LETTER WE
2D24 GEORGIAN SMALL LETTER HAR
2D25 GEORGIAN SMALL LETTER HOE
+@ Additional letter
+2D27 GEORGIAN SMALL LETTER YN
+@ Additional letter for Ossetian
+2D2D GEORGIAN SMALL LETTER AEN
@@ 2D30 Tifinagh 2D7F
@ Letters
2D30 TIFINAGH LETTER YA
@@ -17022,6 +17594,8 @@
2D64 TIFINAGH LETTER TAWELLEMET YAZ
= harpoon yaz
2D65 TIFINAGH LETTER YAZZ
+2D66 TIFINAGH LETTER YE
+2D67 TIFINAGH LETTER YO
@ Modifier letter
2D6F TIFINAGH MODIFIER LETTER LABIALIZATION MARK
= tamatart
@@ -17265,6 +17839,36 @@
2E31 WORD SEPARATOR MIDDLE DOT
* used in Avestan, Samaritan, ...
x (middle dot - 00B7)
+@ Palaeotype transliteration symbol
+2E32 TURNED COMMA
+ * indicates nasalization
+ x (arabic comma - 060C)
+@ Historic punctuation
+2E33 RAISED DOT
+ * glyph position intermediate between 002E and 00B7
+ x (full stop - 002E)
+ x (middle dot - 00B7)
+2E34 RAISED COMMA
+ x (comma - 002C)
+@ Palaeotype transliteration symbols
+2E35 TURNED SEMICOLON
+ * indicates sudden glottal closure
+ x (arabic semicolon - 061B)
+2E36 DAGGER WITH LEFT GUARD
+ * indicates retracted pronunciation
+2E37 DAGGER WITH RIGHT GUARD
+ * indicates advanced pronunciation
+2E38 TURNED DAGGER
+ * indicates retroflex pronunciation
+ x (dagger - 2020)
+2E39 TOP HALF SECTION SIGN
+ * indicates pronunciation on one side of the mouth only
+ x (section sign - 00A7)
+@ Dashes
+2E3A TWO-EM DASH
+ = omission dash
+ x (em dash - 2014)
+2E3B THREE-EM DASH
@@ 2E80 CJK Radicals Supplement 2EFF
@ CJK radicals supplement
2E80 CJK RADICAL REPEAT
@@ -18114,6 +18718,8 @@
x (squared rising diagonal slash - 29C4)
303D PART ALTERNATION MARK
* marks the start of a song part in Japanese
+ ~ 303D FE0E text style
+ ~ 303D FE0F emoji style
@ Special CJK indicators
@+ These are visibly displayed graphic characters, not invisible format control characters.
303E IDEOGRAPHIC VARIATION INDICATOR
@@ -18120,6 +18726,7 @@
* visual indicator that the following ideograph is to be taken as a variant of the intended character
303F IDEOGRAPHIC HALF FILL SPACE
* visual indicator of a screen space for half of an ideograph
+@~ Standardized Variation Sequences
@@ 3040 Hiragana 309F
@ Hiragana letters
3041 HIRAGANA LETTER SMALL A
@@ -18499,6 +19106,7 @@
3146 HANGUL LETTER SSANGSIOS
# 110A hangul choseong ssangsios
3147 HANGUL LETTER IEUNG
+ * zero sound as initial or velar nasal consonant as final
# 110B hangul choseong ieung
3148 HANGUL LETTER CIEUC
# 110C hangul choseong cieuc
@@ -18513,6 +19121,7 @@
314D HANGUL LETTER PHIEUPH
# 1111 hangul choseong phieuph
314E HANGUL LETTER HIEUH
+ * voiceless glottal fricative
# 1112 hangul choseong hieuh
314F HANGUL LETTER A
# 1161 hangul jungseong a
@@ -18614,12 +19223,13 @@
317E HANGUL LETTER SIOS-CIEUC
# 1136 hangul choseong sios-cieuc
317F HANGUL LETTER PANSIOS
+ * voiced alveolar fricative
# 1140 hangul choseong pansios
3180 HANGUL LETTER SSANGIEUNG
= ssangyesieung
# 1147 hangul choseong ssangieung
3181 HANGUL LETTER YESIEUNG
- * old velar nasal
+ * velar nasal consonant
# 114C hangul choseong yesieung
3182 HANGUL LETTER YESIEUNG-SIOS
# 11F1 hangul jongseong yesieung-sios
@@ -18630,7 +19240,7 @@
3185 HANGUL LETTER SSANGHIEUH
# 1158 hangul choseong ssanghieuh
3186 HANGUL LETTER YEORINHIEUH
- * old glottal stop
+ * glottal stop
# 1159 hangul choseong yeorinhieuh
3187 HANGUL LETTER YO-YA
# 1184 hangul jungseong yo-ya
@@ -18645,6 +19255,7 @@
318C HANGUL LETTER YU-I
# 1194 hangul jungseong yu-i
318D HANGUL LETTER ARAEA
+ * rounded open-mid back vowel
# 119E hangul jungseong araea
318E HANGUL LETTER ARAEAE
# 11A1 hangul jungseong araea-i
@@ -19162,10 +19773,14 @@
3296 CIRCLED IDEOGRAPH FINANCIAL
# <circle> 8CA1
3297 CIRCLED IDEOGRAPH CONGRATULATION
+ ~ 3297 FE0E text style
+ ~ 3297 FE0F emoji style
# <circle> 795D
3298 CIRCLED IDEOGRAPH LABOR
# <circle> 52B4
3299 CIRCLED IDEOGRAPH SECRET
+ ~ 3299 FE0E text style
+ ~ 3299 FE0F emoji style
# <circle> 79D8
329A CIRCLED IDEOGRAPH MALE
# <circle> 7537
@@ -19375,6 +19990,7 @@
# <circle> 30F1
32FE CIRCLED KATAKANA WO
# <circle> 30F2
+@~ Standardized Variation Sequences
@@ 3300 CJK Compatibility 33FF
@ Squared Katakana words
3300 SQUARE APAATO
@@ -19770,6 +20386,8 @@
# <square> 0047 0048 007A
3394 SQUARE THZ
# <square> 0054 0048 007A
+@ Abbreviations involving liter symbols
+ at + The glyphs for these squared abbreviations may use the SI symbol for liter, "l" or "L", instead of a script l.
3395 SQUARE MU L
# <square> 03BC 2113
3396 SQUARE ML
@@ -19778,6 +20396,7 @@
# <square> 0064 2113
3398 SQUARE KL
# <square> 006B 2113
+@ Squared Latin abbreviations
3399 SQUARE FM
# <square> 0066 006D
339A SQUARE NM
@@ -20054,7 +20673,7 @@
4DFD HEXAGRAM FOR SMALL PREPONDERANCE
4DFE HEXAGRAM FOR AFTER COMPLETION
4DFF HEXAGRAM FOR BEFORE COMPLETION
-@@ 4E00 CJK Unified Ideographs 9FCB
+@@ 4E00 CJK Unified Ideographs 9FCC
@@ A000 Yi Syllables A48F
@@+
@ Syllables
@@ -21767,6 +22386,14 @@
@ Punctuation mark
A673 SLAVONIC ASTERISK
@ Combining marks for Old Cyrillic
+A674 COMBINING CYRILLIC LETTER UKRAINIAN IE
+A675 COMBINING CYRILLIC LETTER I
+A676 COMBINING CYRILLIC LETTER YI
+A677 COMBINING CYRILLIC LETTER U
+A678 COMBINING CYRILLIC LETTER HARD SIGN
+A679 COMBINING CYRILLIC LETTER YERU
+A67A COMBINING CYRILLIC LETTER SOFT SIGN
+A67B COMBINING CYRILLIC LETTER OMEGA
A67C COMBINING CYRILLIC KAVYKA
* indicates an alternative reading to part of a word
x (combining breve - 0306)
@@ -21805,6 +22432,8 @@
A695 CYRILLIC SMALL LETTER HWE
A696 CYRILLIC CAPITAL LETTER SHWE
A697 CYRILLIC SMALL LETTER SHWE
+@ Combining mark for Old Cyrillic
+A69F COMBINING CYRILLIC LETTER IOTIFIED E
@@ A6A0 Bamum A6FF
@ Syllables
A6A0 BAMUM LETTER A
@@ -21882,12 +22511,12 @@
A6E7 BAMUM LETTER MBAA
* also used for digit two
A6E8 BAMUM LETTER TET
- * t\xE8t
+ * tèt
* also used for digit three
A6E9 BAMUM LETTER KPA
* also used for digit four
A6EA BAMUM LETTER TEN
- * t\xE8n
+ * tèn
* also used for digit five
A6EB BAMUM LETTER NTUU
* also used for digit six
@@ -22086,7 +22715,7 @@
x (latin letter glottal stop - 0294)
x (modifier letter apostrophe - 02BC)
x (modifier letter glottal stop - 02C0)
-@ African letter
+@ Additional letter
A78D LATIN CAPITAL LETTER TURNED H
* used in the Dan/Gio orthography in Liberia
* lowercase is 0265
@@ -22094,9 +22723,14 @@
A78E LATIN SMALL LETTER L WITH RETROFLEX HOOK AND BELT
* voiceless lateral retroflex fricative
* used to transcribe Toda
-@ Janalif letters
+@ Additional letters
A790 LATIN CAPITAL LETTER N WITH DESCENDER
A791 LATIN SMALL LETTER N WITH DESCENDER
+ * Janalif
+A792 LATIN CAPITAL LETTER C WITH BAR
+ = Cambrian symbol
+A793 LATIN SMALL LETTER C WITH BAR
+ * Nanai
@ Latvian letters for pre-1921 orthography
A7A0 LATIN CAPITAL LETTER G WITH OBLIQUE STROKE
A7A1 LATIN SMALL LETTER G WITH OBLIQUE STROKE
@@ -22110,6 +22744,17 @@
A7A9 LATIN SMALL LETTER S WITH OBLIQUE STROKE
* also used in pre-1950 Lower Sorbian orthography
x (latin small letter long s with diagonal stroke - 1E9C)
+@ Additional letter
+A7AA LATIN CAPITAL LETTER H WITH HOOK
+ * lowercase is 0266
+ * used in Chad
+@ Additions for Extended IPA
+A7F8 MODIFIER LETTER CAPITAL H WITH STROKE
+ * faucalized
+ # <super> 0126
+A7F9 MODIFIER LETTER SMALL LIGATURE OE
+ * labialized: open-rounded
+ # <super> 0153
@ Addition for UPA
A7FA LATIN LETTER SMALL CAPITAL TURNED M
@ Ancient Roman epigraphic letters
@@ -22250,6 +22895,7 @@
x (tibetan letter za - 0F5F)
A856 PHAGS-PA LETTER SMALL A
x (tibetan letter -a - 0F60)
+ ~ A856 FE00 phags-pa letter reversed shaping small a
A857 PHAGS-PA LETTER YA
x (tibetan letter ya - 0F61)
A858 PHAGS-PA LETTER RA
@@ -22263,6 +22909,7 @@
x (tibetan letter sa - 0F66)
A85C PHAGS-PA LETTER HA
x (tibetan letter ha - 0F67)
+ ~ A85C FE00 phags-pa letter reversed shaping ha
@ Letter A
A85D PHAGS-PA LETTER A
x (tibetan letter a - 0F68)
@@ -22269,10 +22916,13 @@
@ Vowels
A85E PHAGS-PA LETTER I
x (tibetan vowel sign i - 0F72)
+ ~ A85E FE00 phags-pa letter reversed shaping i
A85F PHAGS-PA LETTER U
x (tibetan vowel sign u - 0F74)
+ ~ A85F FE00 phags-pa letter reversed shaping u
A860 PHAGS-PA LETTER E
x (tibetan vowel sign e - 0F7A)
+ ~ A860 FE00 phags-pa letter reversed shaping e
A861 PHAGS-PA LETTER O
x (tibetan vowel sign o - 0F7C)
@ Consonants
@@ -22296,6 +22946,7 @@
A868 PHAGS-PA SUBJOINED LETTER YA
* Chinese, Tibetan, Sanskrit
x (tibetan subjoined letter ya - 0FB1)
+ ~ A868 FE00 phags-pa letter reversed shaping subjoined ya
@ Consonant additions for Sanskrit
A869 PHAGS-PA LETTER TTA
* Sanskrit
@@ -22352,6 +23003,7 @@
A877 PHAGS-PA MARK DOUBLE SHAD
* Tibetan
x (tibetan mark nyis shad - 0F0E)
+@~ Standardized Variation Sequences
@@ A880 Saurashtra A8DF
@ Various signs
A880 SAURASHTRA SIGN ANUSVARA
@@ -23002,6 +23654,46 @@
* marks start of text in songs and poems
AADF TAI VIET SYMBOL KOI KOI
* marks end of text in songs and poems
+@@ AAE0 Meetei Mayek Extensions AAFF
+ at + The characters in this block are extensions for historical orthographies of Meetei and are not specified in the Manipuri Government order No. 1/2/78-SS/E.
+@ Independent vowel signs
+AAE0 MEETEI MAYEK LETTER E
+AAE1 MEETEI MAYEK LETTER O
+@ Consonants
+AAE2 MEETEI MAYEK LETTER CHA
+AAE3 MEETEI MAYEK LETTER NYA
+AAE4 MEETEI MAYEK LETTER TTA
+AAE5 MEETEI MAYEK LETTER TTHA
+AAE6 MEETEI MAYEK LETTER DDA
+AAE7 MEETEI MAYEK LETTER DDHA
+AAE8 MEETEI MAYEK LETTER NNA
+AAE9 MEETEI MAYEK LETTER SHA
+AAEA MEETEI MAYEK LETTER SSA
+@ Dependent vowel signs
+AAEB MEETEI MAYEK VOWEL SIGN II
+AAEC MEETEI MAYEK VOWEL SIGN UU
+AAED MEETEI MAYEK VOWEL SIGN AAI
+AAEE MEETEI MAYEK VOWEL SIGN AU
+AAEF MEETEI MAYEK VOWEL SIGN AAU
+@ Punctuation
+AAF0 MEETEI MAYEK CHEIKHAN
+ = danda
+AAF1 MEETEI MAYEK AHANG KHUDAM
+ = question mark
+@ Sign
+AAF2 MEETEI MAYEK ANJI
+ * a philosophical sign
+ x (devanagari om - 0950)
+@ Repetition marks
+ at + These marks have fallen into disuse.
+AAF3 MEETEI MAYEK SYLLABLE REPETITION MARK
+AAF4 MEETEI MAYEK WORD REPETITION MARK
+@ Sign
+AAF5 MEETEI MAYEK VOWEL SIGN VISARGA
+@ Virama
+AAF6 MEETEI MAYEK VIRAMA
+ * used to form conjuncts in historical orthographies
+ x (myanmar sign virama - 1039)
@@ AB00 Ethiopic Extended-A AB2F
@ Gamo-Gofa-Dawro and Basketo
AB01 ETHIOPIC SYLLABLE TTHU
@@ -23238,7 +23930,8 @@
@@ F900 CJK Compatibility Ideographs FAFF
@@+
@+ This block, despite its name, contains a number of unified CJK ideographs. Those characters are individually identified by annotations.
-@ Pronunciation variants from KS\xA0X\xA01001:1998
+ at + Subheaders identifying sources for subranges do not indicate required usage or preclude mappings to other sources. For example, many pronunciation variants from KS X 1001:1998 are also mapped to a J source.
+@ Pronunciation variants from KS X 1001:1998
F900 CJK COMPATIBILITY IDEOGRAPH-F900
: 8C48
F901 CJK COMPATIBILITY IDEOGRAPH-F901
@@ -23847,6 +24540,11 @@
: 9928
FA2D CJK COMPATIBILITY IDEOGRAPH-FA2D
: 9DB4
+@ Korean compatibility ideographs
+FA2E CJK COMPATIBILITY IDEOGRAPH-FA2E
+ : 90DE
+FA2F CJK COMPATIBILITY IDEOGRAPH-FA2F
+ : 96B7
@ JIS X 0213 compatibility ideographs
FA30 CJK COMPATIBILITY IDEOGRAPH-FA30
: 4FAE
@@ -25589,7 +26287,7 @@
FE0D VARIATION SELECTOR-14
FE0E VARIATION SELECTOR-15
FE0F VARIATION SELECTOR-16
-@@ FE10 Vertical forms FE1F
+@@ FE10 Vertical Forms FE1F
@+ These characters are compatibility characters needed to map to GB 18030.
@ Glyphs for vertical variants
FE10 PRESENTATION FORM FOR VERTICAL COMMA
@@ -27624,6 +28322,102 @@
10939 LYDIAN LETTER C
@ Punctuation
1093F LYDIAN TRIANGULAR MARK
+@@ 10980 Meroitic Hieroglyphs 1099F
+@ Vowel letters
+10980 MEROITIC HIEROGLYPHIC LETTER A
+ x (egyptian hieroglyph a001 - 13000)
+10981 MEROITIC HIEROGLYPHIC LETTER E
+ x (egyptian hieroglyph h006 - 13184)
+10982 MEROITIC HIEROGLYPHIC LETTER I
+ x (egyptian hieroglyph a026 - 1301E)
+10983 MEROITIC HIEROGLYPHIC LETTER O
+ x (egyptian hieroglyph f001 - 130FE)
+@ Consonant letters
+10984 MEROITIC HIEROGLYPHIC LETTER YA
+ x (egyptian hieroglyph m017a - 131CC)
+10985 MEROITIC HIEROGLYPHIC LETTER WA
+ x (egyptian hieroglyph v004 - 1336F)
+10986 MEROITIC HIEROGLYPHIC LETTER BA
+ x (egyptian hieroglyph e011 - 130DE)
+10987 MEROITIC HIEROGLYPHIC LETTER BA-2
+ x (egyptian hieroglyph d058 - 130C0)
+10988 MEROITIC HIEROGLYPHIC LETTER PA
+ x (egyptian hieroglyph q003 - 132AA)
+10989 MEROITIC HIEROGLYPHIC LETTER MA
+ x (egyptian hieroglyph g017 - 13153)
+1098A MEROITIC HIEROGLYPHIC LETTER NA
+ x (egyptian hieroglyph n035 - 13216)
+1098B MEROITIC HIEROGLYPHIC LETTER NA-2
+1098C MEROITIC HIEROGLYPHIC LETTER NE
+ x (egyptian hieroglyph m022a - 131D2)
+1098D MEROITIC HIEROGLYPHIC LETTER NE-2
+1098E MEROITIC HIEROGLYPHIC LETTER RA
+ x (egyptian hieroglyph d021 - 1308B)
+1098F MEROITIC HIEROGLYPHIC LETTER RA-2
+10990 MEROITIC HIEROGLYPHIC LETTER LA
+ x (egyptian hieroglyph e023 - 130ED)
+10991 MEROITIC HIEROGLYPHIC LETTER KHA
+ x (egyptian hieroglyph aa001 - 1340D)
+10992 MEROITIC HIEROGLYPHIC LETTER HHA
+ x (egyptian hieroglyph w011 - 133BC)
+10993 MEROITIC HIEROGLYPHIC LETTER SA
+ x (egyptian hieroglyph m008 - 131B7)
+10994 MEROITIC HIEROGLYPHIC LETTER SA-2
+ x (egyptian hieroglyph o034 - 13283)
+10995 MEROITIC HIEROGLYPHIC LETTER SE
+ x (egyptian hieroglyph o034 - 13283)
+10996 MEROITIC HIEROGLYPHIC LETTER KA
+ x (egyptian hieroglyph g038 - 1316C)
+10997 MEROITIC HIEROGLYPHIC LETTER QA
+ x (egyptian hieroglyph n029 - 1320E)
+10998 MEROITIC HIEROGLYPHIC LETTER TA
+ x (egyptian hieroglyph v013 - 1337F)
+10999 MEROITIC HIEROGLYPHIC LETTER TA-2
+ x (egyptian hieroglyph n016 - 131FE)
+1099A MEROITIC HIEROGLYPHIC LETTER TE
+ x (egyptian hieroglyph n016 - 131FE)
+ x (egyptian hieroglyph o004 - 13254)
+1099B MEROITIC HIEROGLYPHIC LETTER TE-2
+ x (egyptian hieroglyph o004 - 13254)
+1099C MEROITIC HIEROGLYPHIC LETTER TO
+ x (egyptian hieroglyph n021 - 13205)
+1099D MEROITIC HIEROGLYPHIC LETTER DA
+ x (egyptian hieroglyph d006 - 1307B)
+@ Symbols
+1099E MEROITIC HIEROGLYPHIC SYMBOL VIDJ
+ x (ankh - 2625)
+ x (egyptian hieroglyph s034 - 132F9)
+1099F MEROITIC HIEROGLYPHIC SYMBOL VIDJ-2
+@@ 109A0 Meroitic Cursive 109FF
+@ Vowel letters
+109A0 MEROITIC CURSIVE LETTER A
+109A1 MEROITIC CURSIVE LETTER E
+109A2 MEROITIC CURSIVE LETTER I
+109A3 MEROITIC CURSIVE LETTER O
+@ Consonant letters
+109A4 MEROITIC CURSIVE LETTER YA
+109A5 MEROITIC CURSIVE LETTER WA
+109A6 MEROITIC CURSIVE LETTER BA
+109A7 MEROITIC CURSIVE LETTER PA
+109A8 MEROITIC CURSIVE LETTER MA
+109A9 MEROITIC CURSIVE LETTER NA
+109AA MEROITIC CURSIVE LETTER NE
+109AB MEROITIC CURSIVE LETTER RA
+109AC MEROITIC CURSIVE LETTER LA
+109AD MEROITIC CURSIVE LETTER KHA
+109AE MEROITIC CURSIVE LETTER HHA
+109AF MEROITIC CURSIVE LETTER SA
+109B0 MEROITIC CURSIVE LETTER ARCHAIC SA
+109B1 MEROITIC CURSIVE LETTER SE
+109B2 MEROITIC CURSIVE LETTER KA
+109B3 MEROITIC CURSIVE LETTER QA
+109B4 MEROITIC CURSIVE LETTER TA
+109B5 MEROITIC CURSIVE LETTER TE
+109B6 MEROITIC CURSIVE LETTER TO
+109B7 MEROITIC CURSIVE LETTER DA
+@ Logograms
+109BE MEROITIC CURSIVE LOGOGRAM RMT
+109BF MEROITIC CURSIVE LOGOGRAM IMN
@@ 10A00 Kharoshthi 10A5F
@ Vowels
10A00 KHAROSHTHI LETTER A
@@ -28255,6 +29049,346 @@
* paragraph delimiter
110C0 KAITHI DANDA
110C1 KAITHI DOUBLE DANDA
+@@ 110D0 Sora Sompeng 110FF
+@ Consonants
+110D0 SORA SOMPENG LETTER SAH
+110D1 SORA SOMPENG LETTER TAH
+110D2 SORA SOMPENG LETTER BAH
+110D3 SORA SOMPENG LETTER CAH
+110D4 SORA SOMPENG LETTER DAH
+110D5 SORA SOMPENG LETTER GAH
+110D6 SORA SOMPENG LETTER MAH
+110D7 SORA SOMPENG LETTER NGAH
+110D8 SORA SOMPENG LETTER LAH
+110D9 SORA SOMPENG LETTER NAH
+110DA SORA SOMPENG LETTER VAH
+110DB SORA SOMPENG LETTER PAH
+110DC SORA SOMPENG LETTER YAH
+110DD SORA SOMPENG LETTER RAH
+110DE SORA SOMPENG LETTER HAH
+110DF SORA SOMPENG LETTER KAH
+110E0 SORA SOMPENG LETTER JAH
+110E1 SORA SOMPENG LETTER NYAH
+@ Vowels
+110E2 SORA SOMPENG LETTER AH
+110E3 SORA SOMPENG LETTER EEH
+110E4 SORA SOMPENG LETTER IH
+110E5 SORA SOMPENG LETTER UH
+110E6 SORA SOMPENG LETTER OH
+110E7 SORA SOMPENG LETTER EH
+@ Other letter
+110E8 SORA SOMPENG LETTER MAE
+@ Digits
+110F0 SORA SOMPENG DIGIT ZERO
+110F1 SORA SOMPENG DIGIT ONE
+110F2 SORA SOMPENG DIGIT TWO
+110F3 SORA SOMPENG DIGIT THREE
+110F4 SORA SOMPENG DIGIT FOUR
+110F5 SORA SOMPENG DIGIT FIVE
+110F6 SORA SOMPENG DIGIT SIX
+110F7 SORA SOMPENG DIGIT SEVEN
+110F8 SORA SOMPENG DIGIT EIGHT
+110F9 SORA SOMPENG DIGIT NINE
+@@ 11100 Chakma 1114F
+@ Various signs
+11100 CHAKMA SIGN CANDRABINDU
+ = caanaphupudaa
+11101 CHAKMA SIGN ANUSVARA
+ = ekaphudaa
+11102 CHAKMA SIGN VISARGA
+ = dviphudaa
+@ Independent vowels
+11103 CHAKMA LETTER AA
+ = pichapujhaa aa
+11104 CHAKMA LETTER I
+ = delabhaangagaa i
+11105 CHAKMA LETTER U
+ = bacacu u
+11106 CHAKMA LETTER E
+ = lejaubaa e
+@ Consonants
+11107 CHAKMA LETTER KAA
+ = cucyaangyaa kaa
+11108 CHAKMA LETTER KHAA
+ = grajaangyaa khaa
+11109 CHAKMA LETTER GAA
+ = caandyaa gaa
+1110A CHAKMA LETTER GHAA
+ = tinaddaalyaa ghaa
+1110B CHAKMA LETTER NGAA
+ = cilaama ngaa
+1110C CHAKMA LETTER CAA
+ = dvibhalyaa caa
+1110D CHAKMA LETTER CHAA
+ = majaraa chaa
+1110E CHAKMA LETTER JAA
+ = dvipadalaa jaa
+1110F CHAKMA LETTER JHAA
+ = uraauraa jhaa
+11110 CHAKMA LETTER NYAA
+ = silaacyaa nyaa
+11111 CHAKMA LETTER TTAA
+ = dviyaadaat ttaa
+11112 CHAKMA LETTER TTHAA
+ = phudaadviyaat tthaa
+11113 CHAKMA LETTER DDAA
+ = aadudaangaat ddaa
+11114 CHAKMA LETTER DDHAA
+ = lejabharaat ddhaa
+11115 CHAKMA LETTER NNAA
+ = pettttuyaa nnaa
+11116 CHAKMA LETTER TAA
+ = ghangadaat taa
+11117 CHAKMA LETTER THAA
+ = jagadaat thaa
+11118 CHAKMA LETTER DAA
+ = dolaniit daa
+11119 CHAKMA LETTER DHAA
+ = talamuyaat dhaa
+1111A CHAKMA LETTER NAA
+ = phaarabaanyaa naa
+1111B CHAKMA LETTER PAA
+ = paalyaa paa
+1111C CHAKMA LETTER PHAA
+ = ubaraphudaa phaa
+1111D CHAKMA LETTER BAA
+ = ubaramuyaa baa
+1111E CHAKMA LETTER BHAA
+ = ciraddaalyaa bhaa
+1111F CHAKMA LETTER MAA
+ = bugatpadalaa maa
+11120 CHAKMA LETTER YYAA
+ = cimayyaa yyaa
+11121 CHAKMA LETTER YAA
+ = jilyaa yaa
+11122 CHAKMA LETTER RAA
+ = dvidaayyaa raa
+11123 CHAKMA LETTER LAA
+ = talamuyaa laa
+11124 CHAKMA LETTER WAA
+ = bajhonyaa waa
+11125 CHAKMA LETTER SAA
+ = bhudibukyaa saa
+11126 CHAKMA LETTER HAA
+ = ubaramuyaa haa
+@ Dependent vowel signs
+11127 CHAKMA VOWEL SIGN A
+ = ubaratulyaa a
+11128 CHAKMA VOWEL SIGN I
+ = bahryaa i
+11129 CHAKMA VOWEL SIGN II
+ = baaniiphadaa ii
+1112A CHAKMA VOWEL SIGN U
+ = ekattaana u
+1112B CHAKMA VOWEL SIGN UU
+ = dvittaana uu
+1112C CHAKMA VOWEL SIGN E
+ = ekaara e
+1112D CHAKMA VOWEL SIGN AI
+ = delabhaanga ai
+1112E CHAKMA VOWEL SIGN O
+ = okaara o
+ : 11131 11127
+1112F CHAKMA VOWEL SIGN AU
+ = aukaara au
+ : 11132 11127
+11130 CHAKMA VOWEL SIGN OI
+ = oikaara oi
+11131 CHAKMA O MARK
+11132 CHAKMA AU MARK
+@ Various signs
+11133 CHAKMA VIRAMA
+ * used to form conjuncts
+ x (myanmar sign virama - 1039)
+11134 CHAKMA MAAYYAA
+ * killer
+ x (myanmar sign asat - 103A)
+@ Digits
+11136 CHAKMA DIGIT ZERO
+11137 CHAKMA DIGIT ONE
+11138 CHAKMA DIGIT TWO
+11139 CHAKMA DIGIT THREE
+1113A CHAKMA DIGIT FOUR
+1113B CHAKMA DIGIT FIVE
+1113C CHAKMA DIGIT SIX
+1113D CHAKMA DIGIT SEVEN
+1113E CHAKMA DIGIT EIGHT
+1113F CHAKMA DIGIT NINE
+@ Punctuation
+11140 CHAKMA SECTION MARK
+ = phulacihna
+11141 CHAKMA DANDA
+ = ekacilyaa
+11142 CHAKMA DOUBLE DANDA
+ = dvicilyaa
+11143 CHAKMA QUESTION MARK
+ = pujhaar
+@@ 11180 Sharada 111DF
+@ Various signs
+11180 SHARADA SIGN CANDRABINDU
+11181 SHARADA SIGN ANUSVARA
+11182 SHARADA SIGN VISARGA
+@ Independent vowels
+11183 SHARADA LETTER A
+11184 SHARADA LETTER AA
+11185 SHARADA LETTER I
+11186 SHARADA LETTER II
+11187 SHARADA LETTER U
+11188 SHARADA LETTER UU
+11189 SHARADA LETTER VOCALIC R
+1118A SHARADA LETTER VOCALIC RR
+1118B SHARADA LETTER VOCALIC L
+1118C SHARADA LETTER VOCALIC LL
+1118D SHARADA LETTER E
+1118E SHARADA LETTER AI
+1118F SHARADA LETTER O
+11190 SHARADA LETTER AU
+@ Consonants
+11191 SHARADA LETTER KA
+11192 SHARADA LETTER KHA
+11193 SHARADA LETTER GA
+11194 SHARADA LETTER GHA
+11195 SHARADA LETTER NGA
+11196 SHARADA LETTER CA
+11197 SHARADA LETTER CHA
+11198 SHARADA LETTER JA
+11199 SHARADA LETTER JHA
+1119A SHARADA LETTER NYA
+1119B SHARADA LETTER TTA
+1119C SHARADA LETTER TTHA
+1119D SHARADA LETTER DDA
+1119E SHARADA LETTER DDHA
+1119F SHARADA LETTER NNA
+111A0 SHARADA LETTER TA
+111A1 SHARADA LETTER THA
+111A2 SHARADA LETTER DA
+111A3 SHARADA LETTER DHA
+111A4 SHARADA LETTER NA
+111A5 SHARADA LETTER PA
+111A6 SHARADA LETTER PHA
+111A7 SHARADA LETTER BA
+111A8 SHARADA LETTER BHA
+111A9 SHARADA LETTER MA
+111AA SHARADA LETTER YA
+111AB SHARADA LETTER RA
+111AC SHARADA LETTER LA
+111AD SHARADA LETTER LLA
+111AE SHARADA LETTER VA
+111AF SHARADA LETTER SHA
+111B0 SHARADA LETTER SSA
+111B1 SHARADA LETTER SA
+111B2 SHARADA LETTER HA
+@ Dependent vowel signs
+111B3 SHARADA VOWEL SIGN AA
+111B4 SHARADA VOWEL SIGN I
+111B5 SHARADA VOWEL SIGN II
+111B6 SHARADA VOWEL SIGN U
+111B7 SHARADA VOWEL SIGN UU
+111B8 SHARADA VOWEL SIGN VOCALIC R
+111B9 SHARADA VOWEL SIGN VOCALIC RR
+111BA SHARADA VOWEL SIGN VOCALIC L
+111BB SHARADA VOWEL SIGN VOCALIC LL
+111BC SHARADA VOWEL SIGN E
+111BD SHARADA VOWEL SIGN AI
+111BE SHARADA VOWEL SIGN O
+111BF SHARADA VOWEL SIGN AU
+@ Virama
+111C0 SHARADA SIGN VIRAMA
+@ Various signs
+111C1 SHARADA SIGN AVAGRAHA
+111C2 SHARADA SIGN JIHVAMULIYA
+111C3 SHARADA SIGN UPADHMANIYA
+111C4 SHARADA OM
+@ Punctuation
+111C5 SHARADA DANDA
+111C6 SHARADA DOUBLE DANDA
+111C7 SHARADA ABBREVIATION SIGN
+111C8 SHARADA SEPARATOR
+@ Digits
+111D0 SHARADA DIGIT ZERO
+111D1 SHARADA DIGIT ONE
+111D2 SHARADA DIGIT TWO
+111D3 SHARADA DIGIT THREE
+111D4 SHARADA DIGIT FOUR
+111D5 SHARADA DIGIT FIVE
+111D6 SHARADA DIGIT SIX
+111D7 SHARADA DIGIT SEVEN
+111D8 SHARADA DIGIT EIGHT
+111D9 SHARADA DIGIT NINE
+@@ 11680 Takri 116CF
+@ Independent vowels
+11680 TAKRI LETTER A
+11681 TAKRI LETTER AA
+11682 TAKRI LETTER I
+11683 TAKRI LETTER II
+11684 TAKRI LETTER U
+11685 TAKRI LETTER UU
+11686 TAKRI LETTER E
+11687 TAKRI LETTER AI
+11688 TAKRI LETTER O
+11689 TAKRI LETTER AU
+@ Consonants
+1168A TAKRI LETTER KA
+1168B TAKRI LETTER KHA
+1168C TAKRI LETTER GA
+1168D TAKRI LETTER GHA
+1168E TAKRI LETTER NGA
+1168F TAKRI LETTER CA
+11690 TAKRI LETTER CHA
+11691 TAKRI LETTER JA
+11692 TAKRI LETTER JHA
+11693 TAKRI LETTER NYA
+11694 TAKRI LETTER TTA
+11695 TAKRI LETTER TTHA
+11696 TAKRI LETTER DDA
+11697 TAKRI LETTER DDHA
+11698 TAKRI LETTER NNA
+11699 TAKRI LETTER TA
+1169A TAKRI LETTER THA
+1169B TAKRI LETTER DA
+1169C TAKRI LETTER DHA
+1169D TAKRI LETTER NA
+1169E TAKRI LETTER PA
+1169F TAKRI LETTER PHA
+116A0 TAKRI LETTER BA
+116A1 TAKRI LETTER BHA
+116A2 TAKRI LETTER MA
+116A3 TAKRI LETTER YA
+116A4 TAKRI LETTER RA
+116A5 TAKRI LETTER LA
+116A6 TAKRI LETTER VA
+116A7 TAKRI LETTER SHA
+116A8 TAKRI LETTER SA
+116A9 TAKRI LETTER HA
+116AA TAKRI LETTER RRA
+@ Various signs
+116AB TAKRI SIGN ANUSVARA
+116AC TAKRI SIGN VISARGA
+@ Dependent vowel signs
+116AD TAKRI VOWEL SIGN AA
+116AE TAKRI VOWEL SIGN I
+116AF TAKRI VOWEL SIGN II
+116B0 TAKRI VOWEL SIGN U
+116B1 TAKRI VOWEL SIGN UU
+116B2 TAKRI VOWEL SIGN E
+116B3 TAKRI VOWEL SIGN AI
+116B4 TAKRI VOWEL SIGN O
+116B5 TAKRI VOWEL SIGN AU
+@ Virama
+116B6 TAKRI SIGN VIRAMA
+@ Nukta
+116B7 TAKRI SIGN NUKTA
+@ Digits
+116C0 TAKRI DIGIT ZERO
+116C1 TAKRI DIGIT ONE
+116C2 TAKRI DIGIT TWO
+116C3 TAKRI DIGIT THREE
+116C4 TAKRI DIGIT FOUR
+116C5 TAKRI DIGIT FIVE
+116C6 TAKRI DIGIT SIX
+116C7 TAKRI DIGIT SEVEN
+116C8 TAKRI DIGIT EIGHT
+116C9 TAKRI DIGIT NINE
@@ 12000 Cuneiform 123FF
@ Signs
12000 CUNEIFORM SIGN A
@@ -30499,7 +31633,7 @@
1342D EGYPTIAN HIEROGLYPH AA031
1342E EGYPTIAN HIEROGLYPH AA032
@@ 16800 Bamum Supplement 16A3F
-@ Characters found through Phase A
+@ Characters found through Phase A
16800 BAMUM LETTER PHASE-A NGKUE MFON
16801 BAMUM LETTER PHASE-A GBIEE FON
16802 BAMUM LETTER PHASE-A PON MFON PIPAEMGBIEE
@@ -30587,7 +31721,7 @@
16854 BAMUM LETTER PHASE-A NEN
16855 BAMUM LETTER PHASE-A NAQ
16856 BAMUM LETTER PHASE-A MBAQ
-@ Characters found through Phase B
+@ Characters found through Phase B
16857 BAMUM LETTER PHASE-B NSHUET
16858 BAMUM LETTER PHASE-B TU MAEMGBIEE
16859 BAMUM LETTER PHASE-B SIEE
@@ -30645,7 +31779,7 @@
1688C BAMUM LETTER PHASE-B MA
1688D BAMUM LETTER PHASE-B KIQ
1688E BAMUM LETTER PHASE-B NGOM
-@ Characters found through Phase C
+@ Characters found through Phase C
1688F BAMUM LETTER PHASE-C NGKUE MAEMBA
16890 BAMUM LETTER PHASE-C NZA
16891 BAMUM LETTER PHASE-C YUM
@@ -30745,7 +31879,7 @@
168EE BAMUM LETTER PHASE-C PIN
168EF BAMUM LETTER PHASE-C PEN
168F0 BAMUM LETTER PHASE-C TET
-@ Characters found through Phase D
+@ Characters found through Phase D
168F1 BAMUM LETTER PHASE-D MBUO
168F2 BAMUM LETTER PHASE-D WAP
168F3 BAMUM LETTER PHASE-D NJI
@@ -30870,7 +32004,7 @@
16964 BAMUM LETTER PHASE-D SAQ
16965 BAMUM LETTER PHASE-D FAA
* used before 169B8 for faamae '8' in Phases A-D
-@ Characters found through Phase E
+@ Characters found through Phase E
16966 BAMUM LETTER PHASE-E NDAP
* i in Phase F
16967 BAMUM LETTER PHASE-E TOON
@@ -31045,7 +32179,7 @@
16A01 BAMUM LETTER PHASE-E FAQ
16A02 BAMUM LETTER PHASE-E GHOM
* used after 169F9 for koghom '10' in Phases A-D
-@ Characters found through Phase F
+@ Characters found through Phase F
16A03 BAMUM LETTER PHASE-F KA
16A04 BAMUM LETTER PHASE-F U
16A05 BAMUM LETTER PHASE-F KU
@@ -31101,6 +32235,194 @@
16A37 BAMUM LETTER PHASE-F SAMBA
16A38 BAMUM LETTER PHASE-F VUEQ
* used after 169F9 for kovue '9' in Phases A-D
+@@ 16F00 Miao 16F9F
+@ Consonant onsets
+16F00 MIAO LETTER PA
+ * used for ba in Dry Yi
+16F01 MIAO LETTER BA
+16F02 MIAO LETTER YI PA
+ * used for pa in Dry Yi
+16F03 MIAO LETTER PLA
+ * used in Sichuan Hmong
+16F04 MIAO LETTER MA
+16F05 MIAO LETTER MHA
+16F06 MIAO LETTER ARCHAIC MA
+ * used in Pollard's early orthography
+16F07 MIAO LETTER FA
+16F08 MIAO LETTER VA
+16F09 MIAO LETTER VFA
+ * used in Black Yi
+16F0A MIAO LETTER TA
+ * used for da in Dry Yi
+16F0B MIAO LETTER DA
+16F0C MIAO LETTER YI TTA
+ * used in Hei Yi
+16F0D MIAO LETTER YI TA
+ * used for ta in Dry Yi
+16F0E MIAO LETTER TTA
+16F0F MIAO LETTER DDA
+16F10 MIAO LETTER NA
+16F11 MIAO LETTER NHA
+16F12 MIAO LETTER YI NNA
+ * used in Hei Yi
+16F13 MIAO LETTER ARCHAIC NA
+ * used in Pollard's early orthography
+16F14 MIAO LETTER NNA
+16F15 MIAO LETTER NNHA
+16F16 MIAO LETTER LA
+16F17 MIAO LETTER LYA
+ * used in Black Yi
+16F18 MIAO LETTER LHA
+16F19 MIAO LETTER LHYA
+ * used in Black Yi
+16F1A MIAO LETTER TLHA
+16F1B MIAO LETTER DLHA
+16F1C MIAO LETTER TLHYA
+16F1D MIAO LETTER DLHYA
+16F1E MIAO LETTER KA
+ * used for ga in Dry Yi
+16F1F MIAO LETTER GA
+16F20 MIAO LETTER YI KA
+ * used for ka in Dry Yi
+16F21 MIAO LETTER QA
+16F22 MIAO LETTER QGA
+16F23 MIAO LETTER NGA
+16F24 MIAO LETTER NGHA
+16F25 MIAO LETTER ARCHAIC NGA
+ * used in Pollard's early orthography
+16F26 MIAO LETTER HA
+16F27 MIAO LETTER XA
+ at + * archaic character used in a post-1949 reformed orthography
+16F28 MIAO LETTER GHA
+16F29 MIAO LETTER GHHA
+16F2A MIAO LETTER TSSA
+16F2B MIAO LETTER DZZA
+16F2C MIAO LETTER NYA
+16F2D MIAO LETTER NYHA
+16F2E MIAO LETTER TSHA
+ * used for dzha in Dry Yi
+16F2F MIAO LETTER DZHA
+16F30 MIAO LETTER YI TSHA
+ * used for tsha in Dry Yi
+16F31 MIAO LETTER YI DZHA
+ * used in Hei Yi
+16F32 MIAO LETTER REFORMED TSHA
+ at + * archaic character used in a post-1949 reformed orthography
+16F33 MIAO LETTER SHA
+16F34 MIAO LETTER SSA
+16F35 MIAO LETTER ZHA
+ * used in Black Yi
+16F36 MIAO LETTER ZSHA
+ * used in Black Yi
+16F37 MIAO LETTER TSA
+ * used for dza in Dry Yi
+16F38 MIAO LETTER DZA
+16F39 MIAO LETTER YI TSA
+ * used for tsa in Dry Yi
+16F3A MIAO LETTER SA
+16F3B MIAO LETTER ZA
+16F3C MIAO LETTER ZSA
+ * used in Black Yi
+16F3D MIAO LETTER ZZA
+16F3E MIAO LETTER ZZSA
+ * used in Black Yi
+16F3F MIAO LETTER ARCHAIC ZZA
+ * used in Pollard's early orthography
+16F40 MIAO LETTER ZZYA
+ * used in Black Yi
+16F41 MIAO LETTER ZZSYA
+ * used in Black Yi
+16F42 MIAO LETTER WA
+16F43 MIAO LETTER AH
+ * glottal stop
+16F44 MIAO LETTER HHA
+ * used in Black Yi
+@ Modifiers
+16F50 MIAO LETTER NASALIZATION
+16F51 MIAO SIGN ASPIRATION
+16F52 MIAO SIGN REFORMED VOICING
+ at + * archaic character used in a post-1949 reformed orthography
+16F53 MIAO SIGN REFORMED ASPIRATION
+ at + * archaic character used in a post-1949 reformed orthography
+@ Vowels and finals
+16F54 MIAO VOWEL SIGN A
+16F55 MIAO VOWEL SIGN AA
+ * used in Eastern Lisu
+16F56 MIAO VOWEL SIGN AHH
+ * used in Gan Yi
+16F57 MIAO VOWEL SIGN AN
+16F58 MIAO VOWEL SIGN ANG
+ * also used for aw
+16F59 MIAO VOWEL SIGN O
+16F5A MIAO VOWEL SIGN OO
+16F5B MIAO VOWEL SIGN WO
+ * used in Hei Yi
+16F5C MIAO VOWEL SIGN W
+16F5D MIAO VOWEL SIGN E
+16F5E MIAO VOWEL SIGN EN
+16F5F MIAO VOWEL SIGN ENG
+16F60 MIAO VOWEL SIGN OEY
+16F61 MIAO VOWEL SIGN I
+16F62 MIAO VOWEL SIGN IA
+16F63 MIAO VOWEL SIGN IAN
+16F64 MIAO VOWEL SIGN IANG
+ * also used for iaw
+16F65 MIAO VOWEL SIGN IO
+16F66 MIAO VOWEL SIGN IE
+16F67 MIAO VOWEL SIGN II
+ * used in Eastern Lisu
+16F68 MIAO VOWEL SIGN IU
+16F69 MIAO VOWEL SIGN ING
+ * also used for in
+16F6A MIAO VOWEL SIGN U
+16F6B MIAO VOWEL SIGN UA
+16F6C MIAO VOWEL SIGN UAN
+16F6D MIAO VOWEL SIGN UANG
+ * also used for uaw
+16F6E MIAO VOWEL SIGN UU
+ * used in Eastern Lisu
+16F6F MIAO VOWEL SIGN UEI
+16F70 MIAO VOWEL SIGN UNG
+16F71 MIAO VOWEL SIGN Y
+16F72 MIAO VOWEL SIGN YI
+16F73 MIAO VOWEL SIGN AE
+16F74 MIAO VOWEL SIGN AEE
+ * used in Eastern Lisu
+16F75 MIAO VOWEL SIGN ERR
+16F76 MIAO VOWEL SIGN ROUNDED ERR
+ * used in Eastern Lisu
+16F77 MIAO VOWEL SIGN ER
+16F78 MIAO VOWEL SIGN ROUNDED ER
+ * used in Eastern Lisu
+16F79 MIAO VOWEL SIGN AI
+16F7A MIAO VOWEL SIGN EI
+16F7B MIAO VOWEL SIGN AU
+16F7C MIAO VOWEL SIGN OU
+16F7D MIAO VOWEL SIGN N
+16F7E MIAO VOWEL SIGN NG
+@ Positioning tone marks
+ at + These are used to position the vowel off of the baseline position to indicate a changed tone.
+16F8F MIAO TONE RIGHT
+16F90 MIAO TONE TOP RIGHT
+16F91 MIAO TONE ABOVE
+16F92 MIAO TONE BELOW
+@ Baseline tone marks
+ at + These are used in Chuxiong Ahmao instead of the positioning tone marks.
+16F93 MIAO LETTER TONE-2
+16F94 MIAO LETTER TONE-3
+16F95 MIAO LETTER TONE-4
+16F96 MIAO LETTER TONE-5
+16F97 MIAO LETTER TONE-6
+16F98 MIAO LETTER TONE-7
+16F99 MIAO LETTER TONE-8
+@ Archaic baseline tone marks
+ at + These are archaic characters used in a post-1949 reformed orthography.
+16F9A MIAO LETTER REFORMED TONE-1
+16F9B MIAO LETTER REFORMED TONE-2
+16F9C MIAO LETTER REFORMED TONE-4
+16F9D MIAO LETTER REFORMED TONE-5
+16F9E MIAO LETTER REFORMED TONE-6
+16F9F MIAO LETTER REFORMED TONE-8
@@ 1B000 Kana Supplement 1B0FF
@ Historic Katakana
1B000 KATAKANA LETTER ARCHAIC E
@@ -31704,7 +33026,7 @@
1D208 GREEK VOCAL NOTATION SYMBOL-9
= Greek instrumental notation symbol-44
* vocal second sharp of G
- * instrumental first sharp of e\xB4
+ * instrumental first sharp of e´
1D209 GREEK VOCAL NOTATION SYMBOL-10
* vocal A
* this is a modification of 039F and is therefore not the same as 03D8
@@ -31717,7 +33039,7 @@
1D20D GREEK VOCAL NOTATION SYMBOL-14
= Greek instrumental notation symbol-41
* vocal first sharp of B
- * instrumental first sharp of d\xB4
+ * instrumental first sharp of d´
x (latin capital letter v - 0056)
1D20E GREEK VOCAL NOTATION SYMBOL-15
= Greek instrumental notation symbol-35
@@ -31749,16 +33071,16 @@
1D217 GREEK VOCAL NOTATION SYMBOL-24
* vocal second sharp of e
1D218 GREEK VOCAL NOTATION SYMBOL-50
- * vocal first sharp of g\xB4
+ * vocal first sharp of g´
1D219 GREEK VOCAL NOTATION SYMBOL-51
- * vocal second sharp of g\xB4
+ * vocal second sharp of g´
1D21A GREEK VOCAL NOTATION SYMBOL-52
- * vocal a\xB4
+ * vocal a´
1D21B GREEK VOCAL NOTATION SYMBOL-53
- * vocal first sharp of a\xB4
+ * vocal first sharp of a´
1D21C GREEK VOCAL NOTATION SYMBOL-54
= Greek instrumental notation symbol-20
- * vocal second sharp of a\xB4
+ * vocal second sharp of a´
* instrumental first sharp of d
@ Ancient Greek instrumental notation
1D21D GREEK INSTRUMENTAL NOTATION SYMBOL-1
@@ -31806,37 +33128,37 @@
1D232 GREEK INSTRUMENTAL NOTATION SYMBOL-36
* instrumental second sharp of b
1D233 GREEK INSTRUMENTAL NOTATION SYMBOL-37
- * instrumental c\xB4
+ * instrumental c´
1D234 GREEK INSTRUMENTAL NOTATION SYMBOL-38
- * instrumental first sharp of c\xB4
+ * instrumental first sharp of c´
1D235 GREEK INSTRUMENTAL NOTATION SYMBOL-39
- * instrumental second sharp of c\xB4
+ * instrumental second sharp of c´
1D236 GREEK INSTRUMENTAL NOTATION SYMBOL-40
- * instrumental d\xB4
+ * instrumental d´
1D237 GREEK INSTRUMENTAL NOTATION SYMBOL-42
- * instrumental second sharp of d\xB4
+ * instrumental second sharp of d´
1D238 GREEK INSTRUMENTAL NOTATION SYMBOL-43
- * instrumental e\xB4
+ * instrumental e´
1D239 GREEK INSTRUMENTAL NOTATION SYMBOL-45
- * instrumental second sharp of e\xB4
+ * instrumental second sharp of e´
1D23A GREEK INSTRUMENTAL NOTATION SYMBOL-47
- * instrumental first sharp of f\xB4
+ * instrumental first sharp of f´
* similar but not identical to 002F
1D23B GREEK INSTRUMENTAL NOTATION SYMBOL-48
- * instrumental second sharp of f\xB4
+ * instrumental second sharp of f´
* similar but not identical to 005C
1D23C GREEK INSTRUMENTAL NOTATION SYMBOL-49
- * instrumental g\xB4
+ * instrumental g´
1D23D GREEK INSTRUMENTAL NOTATION SYMBOL-50
- * instrumental first sharp of g\xB4
+ * instrumental first sharp of g´
1D23E GREEK INSTRUMENTAL NOTATION SYMBOL-51
- * instrumental second sharp of g\xB4
+ * instrumental second sharp of g´
1D23F GREEK INSTRUMENTAL NOTATION SYMBOL-52
- * instrumental a\xB4
+ * instrumental a´
1D240 GREEK INSTRUMENTAL NOTATION SYMBOL-53
- * instrumental first sharp of a\xB4
+ * instrumental first sharp of a´
1D241 GREEK INSTRUMENTAL NOTATION SYMBOL-54
- * instrumental second sharp of a\xB4
+ * instrumental second sharp of a´
@ Further Greek musical notation symbols
1D242 COMBINING GREEK MUSICAL TRISEME
x (metrical triseme - 23D7)
@@ -34056,6 +35378,355 @@
# <font> 0038 digit eight
1D7FF MATHEMATICAL MONOSPACE DIGIT NINE
# <font> 0039 digit nine
+@@ 1EE00 Arabic Mathematical Alphabetic Symbols 1EEFF
+@ Isolated symbols
+1EE00 ARABIC MATHEMATICAL ALEF
+ x (arabic letter alef isolated form - FE8D)
+ # <font> 0627 arabic letter alef
+1EE01 ARABIC MATHEMATICAL BEH
+ x (arabic letter beh isolated form - FE8F)
+ # <font> 0628 arabic letter beh
+1EE02 ARABIC MATHEMATICAL JEEM
+ x (arabic letter jeem isolated form - FE9D)
+ # <font> 062C arabic letter jeem
+1EE03 ARABIC MATHEMATICAL DAL
+ x (arabic letter dal isolated form - FEA9)
+ # <font> 062F arabic letter dal
+1EE05 ARABIC MATHEMATICAL WAW
+ x (arabic letter waw isolated form - FEED)
+ # <font> 0648 arabic letter waw
+1EE06 ARABIC MATHEMATICAL ZAIN
+ x (arabic letter zain isolated form - FEAF)
+ # <font> 0632 arabic letter zain
+1EE07 ARABIC MATHEMATICAL HAH
+ x (arabic letter hah isolated form - FEA1)
+ # <font> 062D arabic letter hah
+1EE08 ARABIC MATHEMATICAL TAH
+ x (arabic letter tah isolated form - FEC1)
+ # <font> 0637 arabic letter tah
+1EE09 ARABIC MATHEMATICAL YEH
+ x (arabic letter yeh isolated form - FEF1)
+ # <font> 064A arabic letter yeh
+1EE0A ARABIC MATHEMATICAL KAF
+ x (arabic letter kaf isolated form - FED9)
+ # <font> 0643 arabic letter kaf
+1EE0B ARABIC MATHEMATICAL LAM
+ x (arabic letter lam isolated form - FEDD)
+ # <font> 0644 arabic letter lam
+1EE0C ARABIC MATHEMATICAL MEEM
+ x (arabic letter meem isolated form - FEE1)
+ # <font> 0645 arabic letter meem
+1EE0D ARABIC MATHEMATICAL NOON
+ x (arabic letter noon isolated form - FEE5)
+ # <font> 0646 arabic letter noon
+1EE0E ARABIC MATHEMATICAL SEEN
+ x (arabic letter seen isolated form - FEB1)
+ # <font> 0633 arabic letter seen
+1EE0F ARABIC MATHEMATICAL AIN
+ x (arabic letter ain isolated form - FEC9)
+ # <font> 0639 arabic letter ain
+1EE10 ARABIC MATHEMATICAL FEH
+ x (arabic letter feh isolated form - FED1)
+ # <font> 0641 arabic letter feh
+1EE11 ARABIC MATHEMATICAL SAD
+ x (arabic letter sad isolated form - FEB9)
+ # <font> 0635 arabic letter sad
+1EE12 ARABIC MATHEMATICAL QAF
+ x (arabic letter qaf isolated form - FED5)
+ # <font> 0642 arabic letter qaf
+1EE13 ARABIC MATHEMATICAL REH
+ x (arabic letter reh isolated form - FEAD)
+ # <font> 0631 arabic letter reh
+1EE14 ARABIC MATHEMATICAL SHEEN
+ x (arabic letter sheen isolated form - FEB5)
+ # <font> 0634 arabic letter sheen
+1EE15 ARABIC MATHEMATICAL TEH
+ x (arabic letter teh isolated form - FE95)
+ # <font> 062A arabic letter teh
+1EE16 ARABIC MATHEMATICAL THEH
+ x (arabic letter theh isolated form - FE99)
+ # <font> 062B arabic letter theh
+1EE17 ARABIC MATHEMATICAL KHAH
+ x (arabic letter khah isolated form - FEA5)
+ # <font> 062E arabic letter khah
+1EE18 ARABIC MATHEMATICAL THAL
+ x (arabic letter thal isolated form - FEAB)
+ # <font> 0630 arabic letter thal
+1EE19 ARABIC MATHEMATICAL DAD
+ x (arabic letter dad isolated form - FEBD)
+ # <font> 0636 arabic letter dad
+1EE1A ARABIC MATHEMATICAL ZAH
+ x (arabic letter zah isolated form - FEC5)
+ # <font> 0638 arabic letter zah
+1EE1B ARABIC MATHEMATICAL GHAIN
+ x (arabic letter ghain isolated form - FECD)
+ # <font> 063A arabic letter ghain
+1EE1C ARABIC MATHEMATICAL DOTLESS BEH
+ x (arabic letter dotless beh - 066E)
+ # <font> 066E arabic letter dotless beh
+1EE1D ARABIC MATHEMATICAL DOTLESS NOON
+ x (arabic letter noon ghunna isolated form - FB9E)
+ # <font> 06BA arabic letter noon ghunna
+1EE1E ARABIC MATHEMATICAL DOTLESS FEH
+ x (arabic letter dotless feh - 06A1)
+ # <font> 06A1 arabic letter dotless feh
+1EE1F ARABIC MATHEMATICAL DOTLESS QAF
+ x (arabic letter dotless qaf - 066F)
+ # <font> 066F arabic letter dotless qaf
+@ Initial symbols
+1EE21 ARABIC MATHEMATICAL INITIAL BEH
+ x (arabic letter beh initial form - FE91)
+ # <font> 0628 arabic letter beh
+1EE22 ARABIC MATHEMATICAL INITIAL JEEM
+ x (arabic letter jeem initial form - FE9F)
+ # <font> 062C arabic letter jeem
+1EE24 ARABIC MATHEMATICAL INITIAL HEH
+ x (arabic letter heh initial form - FEEB)
+ # <font> 0647 arabic letter heh
+1EE27 ARABIC MATHEMATICAL INITIAL HAH
+ x (arabic letter hah initial form - FEA3)
+ # <font> 062D arabic letter hah
+1EE29 ARABIC MATHEMATICAL INITIAL YEH
+ x (arabic letter yeh initial form - FEF3)
+ # <font> 064A arabic letter yeh
+1EE2A ARABIC MATHEMATICAL INITIAL KAF
+ x (arabic letter kaf initial form - FEDB)
+ # <font> 0643 arabic letter kaf
+1EE2B ARABIC MATHEMATICAL INITIAL LAM
+ x (arabic letter lam initial form - FEDF)
+ # <font> 0644 arabic letter lam
+1EE2C ARABIC MATHEMATICAL INITIAL MEEM
+ x (arabic letter meem initial form - FEE3)
+ # <font> 0645 arabic letter meem
+1EE2D ARABIC MATHEMATICAL INITIAL NOON
+ x (arabic letter noon initial form - FEE7)
+ # <font> 0646 arabic letter noon
+1EE2E ARABIC MATHEMATICAL INITIAL SEEN
+ x (arabic letter seen initial form - FEB3)
+ # <font> 0633 arabic letter seen
+1EE2F ARABIC MATHEMATICAL INITIAL AIN
+ x (arabic letter ain initial form - FECB)
+ # <font> 0639 arabic letter ain
+1EE30 ARABIC MATHEMATICAL INITIAL FEH
+ x (arabic letter feh initial form - FED3)
+ # <font> 0641 arabic letter feh
+1EE31 ARABIC MATHEMATICAL INITIAL SAD
+ x (arabic letter sad initial form - FEBB)
+ # <font> 0635 arabic letter sad
+1EE32 ARABIC MATHEMATICAL INITIAL QAF
+ x (arabic letter qaf initial form - FED7)
+ # <font> 0642 arabic letter qaf
+1EE34 ARABIC MATHEMATICAL INITIAL SHEEN
+ x (arabic letter sheen initial form - FEB7)
+ # <font> 0634 arabic letter sheen
+1EE35 ARABIC MATHEMATICAL INITIAL TEH
+ x (arabic letter teh initial form - FE97)
+ # <font> 062A arabic letter teh
+1EE36 ARABIC MATHEMATICAL INITIAL THEH
+ x (arabic letter theh initial form - FE9B)
+ # <font> 062B arabic letter theh
+1EE37 ARABIC MATHEMATICAL INITIAL KHAH
+ x (arabic letter khah initial form - FEA7)
+ # <font> 062E arabic letter khah
+1EE39 ARABIC MATHEMATICAL INITIAL DAD
+ x (arabic letter dad initial form - FEBF)
+ # <font> 0636 arabic letter dad
+1EE3B ARABIC MATHEMATICAL INITIAL GHAIN
+ x (arabic letter ghain initial form - FECF)
+ # <font> 063A arabic letter ghain
+@ Tailed symbols
+1EE42 ARABIC MATHEMATICAL TAILED JEEM
+ # <font> 062C arabic letter jeem
+1EE47 ARABIC MATHEMATICAL TAILED HAH
+ # <font> 062D arabic letter hah
+1EE49 ARABIC MATHEMATICAL TAILED YEH
+ # <font> 064A arabic letter yeh
+1EE4B ARABIC MATHEMATICAL TAILED LAM
+ # <font> 0644 arabic letter lam
+1EE4D ARABIC MATHEMATICAL TAILED NOON
+ # <font> 0646 arabic letter noon
+1EE4E ARABIC MATHEMATICAL TAILED SEEN
+ # <font> 0633 arabic letter seen
+1EE4F ARABIC MATHEMATICAL TAILED AIN
+ # <font> 0639 arabic letter ain
+1EE51 ARABIC MATHEMATICAL TAILED SAD
+ # <font> 0635 arabic letter sad
+1EE52 ARABIC MATHEMATICAL TAILED QAF
+ # <font> 0642 arabic letter qaf
+1EE54 ARABIC MATHEMATICAL TAILED SHEEN
+ # <font> 0634 arabic letter sheen
+1EE57 ARABIC MATHEMATICAL TAILED KHAH
+ # <font> 062E arabic letter khah
+1EE59 ARABIC MATHEMATICAL TAILED DAD
+ # <font> 0636 arabic letter dad
+1EE5B ARABIC MATHEMATICAL TAILED GHAIN
+ # <font> 063A arabic letter ghain
+1EE5D ARABIC MATHEMATICAL TAILED DOTLESS NOON
+ # <font> 06BA arabic letter noon ghunna
+1EE5F ARABIC MATHEMATICAL TAILED DOTLESS QAF
+ # <font> 066F arabic letter dotless qaf
+@ Stretched symbols
+1EE61 ARABIC MATHEMATICAL STRETCHED BEH
+ # <font> 0628 arabic letter beh
+1EE62 ARABIC MATHEMATICAL STRETCHED JEEM
+ # <font> 062C arabic letter jeem
+1EE64 ARABIC MATHEMATICAL STRETCHED HEH
+ # <font> 0647 arabic letter heh
+1EE67 ARABIC MATHEMATICAL STRETCHED HAH
+ # <font> 062D arabic letter hah
+1EE68 ARABIC MATHEMATICAL STRETCHED TAH
+ # <font> 0637 arabic letter tah
+1EE69 ARABIC MATHEMATICAL STRETCHED YEH
+ # <font> 064A arabic letter yeh
+1EE6A ARABIC MATHEMATICAL STRETCHED KAF
+ # <font> 0643 arabic letter kaf
+1EE6C ARABIC MATHEMATICAL STRETCHED MEEM
+ # <font> 0645 arabic letter meem
+1EE6D ARABIC MATHEMATICAL STRETCHED NOON
+ # <font> 0646 arabic letter noon
+1EE6E ARABIC MATHEMATICAL STRETCHED SEEN
+ # <font> 0633 arabic letter seen
+1EE6F ARABIC MATHEMATICAL STRETCHED AIN
+ # <font> 0639 arabic letter ain
+1EE70 ARABIC MATHEMATICAL STRETCHED FEH
+ # <font> 0641 arabic letter feh
+1EE71 ARABIC MATHEMATICAL STRETCHED SAD
+ # <font> 0635 arabic letter sad
+1EE72 ARABIC MATHEMATICAL STRETCHED QAF
+ # <font> 0642 arabic letter qaf
+1EE74 ARABIC MATHEMATICAL STRETCHED SHEEN
+ # <font> 0634 arabic letter sheen
+1EE75 ARABIC MATHEMATICAL STRETCHED TEH
+ # <font> 062A arabic letter teh
+1EE76 ARABIC MATHEMATICAL STRETCHED THEH
+ # <font> 062B arabic letter theh
+1EE77 ARABIC MATHEMATICAL STRETCHED KHAH
+ # <font> 062E arabic letter khah
+1EE79 ARABIC MATHEMATICAL STRETCHED DAD
+ # <font> 0636 arabic letter dad
+1EE7A ARABIC MATHEMATICAL STRETCHED ZAH
+ # <font> 0638 arabic letter zah
+1EE7B ARABIC MATHEMATICAL STRETCHED GHAIN
+ # <font> 063A arabic letter ghain
+1EE7C ARABIC MATHEMATICAL STRETCHED DOTLESS BEH
+ # <font> 066E arabic letter dotless beh
+1EE7E ARABIC MATHEMATICAL STRETCHED DOTLESS FEH
+ # <font> 06A1 arabic letter dotless feh
+@ Looped symbols
+1EE80 ARABIC MATHEMATICAL LOOPED ALEF
+ # <font> 0627 arabic letter alef
+1EE81 ARABIC MATHEMATICAL LOOPED BEH
+ # <font> 0628 arabic letter beh
+1EE82 ARABIC MATHEMATICAL LOOPED JEEM
+ # <font> 062C arabic letter jeem
+1EE83 ARABIC MATHEMATICAL LOOPED DAL
+ # <font> 062F arabic letter dal
+1EE84 ARABIC MATHEMATICAL LOOPED HEH
+ # <font> 0647 arabic letter heh
+1EE85 ARABIC MATHEMATICAL LOOPED WAW
+ # <font> 0648 arabic letter waw
+1EE86 ARABIC MATHEMATICAL LOOPED ZAIN
+ # <font> 0632 arabic letter zain
+1EE87 ARABIC MATHEMATICAL LOOPED HAH
+ # <font> 062D arabic letter hah
+1EE88 ARABIC MATHEMATICAL LOOPED TAH
+ # <font> 0637 arabic letter tah
+1EE89 ARABIC MATHEMATICAL LOOPED YEH
+ # <font> 064A arabic letter yeh
+1EE8B ARABIC MATHEMATICAL LOOPED LAM
+ # <font> 0644 arabic letter lam
+1EE8C ARABIC MATHEMATICAL LOOPED MEEM
+ # <font> 0645 arabic letter meem
+1EE8D ARABIC MATHEMATICAL LOOPED NOON
+ # <font> 0646 arabic letter noon
+1EE8E ARABIC MATHEMATICAL LOOPED SEEN
+ # <font> 0633 arabic letter seen
+1EE8F ARABIC MATHEMATICAL LOOPED AIN
+ # <font> 0639 arabic letter ain
+1EE90 ARABIC MATHEMATICAL LOOPED FEH
+ # <font> 0641 arabic letter feh
+1EE91 ARABIC MATHEMATICAL LOOPED SAD
+ # <font> 0635 arabic letter sad
+1EE92 ARABIC MATHEMATICAL LOOPED QAF
+ # <font> 0642 arabic letter qaf
+1EE93 ARABIC MATHEMATICAL LOOPED REH
+ # <font> 0631 arabic letter reh
+1EE94 ARABIC MATHEMATICAL LOOPED SHEEN
+ # <font> 0634 arabic letter sheen
+1EE95 ARABIC MATHEMATICAL LOOPED TEH
+ # <font> 062A arabic letter teh
+1EE96 ARABIC MATHEMATICAL LOOPED THEH
+ # <font> 062B arabic letter theh
+1EE97 ARABIC MATHEMATICAL LOOPED KHAH
+ # <font> 062E arabic letter khah
+1EE98 ARABIC MATHEMATICAL LOOPED THAL
+ # <font> 0630 arabic letter thal
+1EE99 ARABIC MATHEMATICAL LOOPED DAD
+ # <font> 0636 arabic letter dad
+1EE9A ARABIC MATHEMATICAL LOOPED ZAH
+ # <font> 0638 arabic letter zah
+1EE9B ARABIC MATHEMATICAL LOOPED GHAIN
+ # <font> 063A arabic letter ghain
+@ Double-struck symbols
+1EEA1 ARABIC MATHEMATICAL DOUBLE-STRUCK BEH
+ # <font> 0628 arabic letter beh
+1EEA2 ARABIC MATHEMATICAL DOUBLE-STRUCK JEEM
+ # <font> 062C arabic letter jeem
+1EEA3 ARABIC MATHEMATICAL DOUBLE-STRUCK DAL
+ # <font> 062F arabic letter dal
+1EEA5 ARABIC MATHEMATICAL DOUBLE-STRUCK WAW
+ # <font> 0648 arabic letter waw
+1EEA6 ARABIC MATHEMATICAL DOUBLE-STRUCK ZAIN
+ # <font> 0632 arabic letter zain
+1EEA7 ARABIC MATHEMATICAL DOUBLE-STRUCK HAH
+ # <font> 062D arabic letter hah
+1EEA8 ARABIC MATHEMATICAL DOUBLE-STRUCK TAH
+ # <font> 0637 arabic letter tah
+1EEA9 ARABIC MATHEMATICAL DOUBLE-STRUCK YEH
+ # <font> 064A arabic letter yeh
+1EEAB ARABIC MATHEMATICAL DOUBLE-STRUCK LAM
+ # <font> 0644 arabic letter lam
+1EEAC ARABIC MATHEMATICAL DOUBLE-STRUCK MEEM
+ # <font> 0645 arabic letter meem
+1EEAD ARABIC MATHEMATICAL DOUBLE-STRUCK NOON
+ # <font> 0646 arabic letter noon
+1EEAE ARABIC MATHEMATICAL DOUBLE-STRUCK SEEN
+ # <font> 0633 arabic letter seen
+1EEAF ARABIC MATHEMATICAL DOUBLE-STRUCK AIN
+ # <font> 0639 arabic letter ain
+1EEB0 ARABIC MATHEMATICAL DOUBLE-STRUCK FEH
+ # <font> 0641 arabic letter feh
+1EEB1 ARABIC MATHEMATICAL DOUBLE-STRUCK SAD
+ # <font> 0635 arabic letter sad
+1EEB2 ARABIC MATHEMATICAL DOUBLE-STRUCK QAF
+ # <font> 0642 arabic letter qaf
+1EEB3 ARABIC MATHEMATICAL DOUBLE-STRUCK REH
+ # <font> 0631 arabic letter reh
+1EEB4 ARABIC MATHEMATICAL DOUBLE-STRUCK SHEEN
+ # <font> 0634 arabic letter sheen
+1EEB5 ARABIC MATHEMATICAL DOUBLE-STRUCK TEH
+ # <font> 062A arabic letter teh
+1EEB6 ARABIC MATHEMATICAL DOUBLE-STRUCK THEH
+ # <font> 062B arabic letter theh
+1EEB7 ARABIC MATHEMATICAL DOUBLE-STRUCK KHAH
+ # <font> 062E arabic letter khah
+1EEB8 ARABIC MATHEMATICAL DOUBLE-STRUCK THAL
+ # <font> 0630 arabic letter thal
+1EEB9 ARABIC MATHEMATICAL DOUBLE-STRUCK DAD
+ # <font> 0636 arabic letter dad
+1EEBA ARABIC MATHEMATICAL DOUBLE-STRUCK ZAH
+ # <font> 0638 arabic letter zah
+1EEBB ARABIC MATHEMATICAL DOUBLE-STRUCK GHAIN
+ # <font> 063A arabic letter ghain
+@ Stretching operators
+ at + The following operators stretch based on the width of the text that is displayed below or above them.
+1EEF0 ARABIC MATHEMATICAL OPERATOR MEEM WITH HAH WITH TATWEEL
+ * used in Arabic mathematics to denote summation
+ * stretched at the tatweel
+ x (n-ary summation - 2211)
+1EEF1 ARABIC MATHEMATICAL OPERATOR HAH WITH DAL
+ * used in Persian mathematics to denote limits
+ * stretched between the hah and the dal
@@ 1F000 Mahjong Tiles 1F02F
@ Prevailing wind tiles
1F000 MAHJONG TILE EAST WIND
@@ -34065,6 +35736,8 @@
@ Dragon tiles
1F004 MAHJONG TILE RED DRAGON
= hongzhong
+ ~ 1F004 FE0E text style
+ ~ 1F004 FE0F emoji style
1F005 MAHJONG TILE GREEN DRAGON
= qingfa
1F006 MAHJONG TILE WHITE DRAGON
@@ -34120,6 +35793,7 @@
1F02A MAHJONG TILE JOKER
= baida
1F02B MAHJONG TILE BACK
+@~ Standardized Variation Sequences
@@ 1F030 Domino Tiles 1F09F
@ Horizontal tiles
1F030 DOMINO TILE HORIZONTAL BACK
@@ -34238,7 +35912,8 @@
1F092 DOMINO TILE VERTICAL-06-05
1F093 DOMINO TILE VERTICAL-06-06
@@ 1F0A0 Playing Cards 1F0FF
- at + These characters are used to represent the 52-card and 56-card variants of modern playing cards, as well as the 56-card Minor Arcana of the Western Tarot.
+ at + These characters are used to represent the 52-card and 56-card variants of modern playing cards, as well as the 56-card Minor Arcana of the Western Tarot. The glyphs shown in the charts have only a symbolic and schematic equivalence to particular varieties of actual playing cards.
+@ Back of card
1F0A0 PLAYING CARD BACK
@ Spades or swords
1F0A1 PLAYING CARD ACE OF SPADES
@@ -34258,10 +35933,10 @@
= chevalier, Ober, Ritter, cavall, cavaliere
= knight of swords
1F0AD PLAYING CARD QUEEN OF SPADES
- = dame, Dame, K\xF6nigin, regina
+ = dame, Dame, Königin, regina
= queen of swords
1F0AE PLAYING CARD KING OF SPADES
- = roi, K\xF6nig, re
+ = roi, König, re
= king of swords
@ Hearts or cups
1F0B1 PLAYING CARD ACE OF HEARTS
@@ -34293,6 +35968,7 @@
1F0CC PLAYING CARD KNIGHT OF DIAMONDS
1F0CD PLAYING CARD QUEEN OF DIAMONDS
1F0CE PLAYING CARD KING OF DIAMONDS
+@ Joker
1F0CF PLAYING CARD BLACK JOKER
@ Clubs or wands
1F0D1 PLAYING CARD ACE OF CLUBS
@@ -34309,6 +35985,7 @@
1F0DC PLAYING CARD KNIGHT OF CLUBS
1F0DD PLAYING CARD QUEEN OF CLUBS
1F0DE PLAYING CARD KING OF CLUBS
+@ Joker
1F0DF PLAYING CARD WHITE JOKER
* may also be red
@@ 1F100 Enclosed Alphanumeric Supplement 1F1FF
@@ -34519,7 +36196,7 @@
= parking space (ARIB STD B24)
1F160 NEGATIVE CIRCLED LATIN CAPITAL LETTER Q
1F161 NEGATIVE CIRCLED LATIN CAPITAL LETTER R
- = Rastst\xE4tte (rest stop)
+ = Raststätte (rest stop)
1F162 NEGATIVE CIRCLED LATIN CAPITAL LETTER S
= Stadtbahn (metropolitan railway)
1F163 NEGATIVE CIRCLED LATIN CAPITAL LETTER T
@@ -34533,6 +36210,17 @@
1F167 NEGATIVE CIRCLED LATIN CAPITAL LETTER X
1F168 NEGATIVE CIRCLED LATIN CAPITAL LETTER Y
1F169 NEGATIVE CIRCLED LATIN CAPITAL LETTER Z
+@ Raised squared Latin sequences
+1F16A RAISED MC SIGN
+ = marque de commerce
+ * used in Canada
+ x (trade mark sign - 2122)
+ # <super> 004D 0043
+1F16B RAISED MD SIGN
+ = marque déposée
+ * used in Canada
+ x (registered sign - 00AE)
+ # <super> 004D 0044
@ White on black squared Latin letters
@+ The square edges may be slightly rounded.
1F170 NEGATIVE SQUARED LATIN CAPITAL LETTER A
@@ -34562,6 +36250,8 @@
= blood type O
1F17F NEGATIVE SQUARED LATIN CAPITAL LETTER P
= parking space empty-full (ARIB STD B24)
+ ~ 1F17F FE0E text style
+ ~ 1F17F FE0F emoji style
1F180 NEGATIVE SQUARED LATIN CAPITAL LETTER Q
1F181 NEGATIVE SQUARED LATIN CAPITAL LETTER R
1F182 NEGATIVE SQUARED LATIN CAPITAL LETTER S
@@ -34633,6 +36323,7 @@
1F1FD REGIONAL INDICATOR SYMBOL LETTER X
1F1FE REGIONAL INDICATOR SYMBOL LETTER Y
1F1FF REGIONAL INDICATOR SYMBOL LETTER Z
+@~ Standardized Variation Sequences
@@ 1F200 Enclosed Ideographic Supplement 1F2FF
@ Squared hiragana from ARIB STD B24
1F200 SQUARE HIRAGANA HOKA
@@ -34681,6 +36372,8 @@
1F21A SQUARED CJK UNIFIED IDEOGRAPH-7121
= free broadcasting service
= non-existence sign
+ ~ 1F21A FE0E text style
+ ~ 1F21A FE0F emoji style
# <square> 7121
1F21B SQUARED CJK UNIFIED IDEOGRAPH-6599
= pay broadcasting service
@@ -34745,6 +36438,8 @@
1F22F SQUARED CJK UNIFIED IDEOGRAPH-6307
= designated hitter
= reserved sign
+ ~ 1F22F FE0E text style
+ ~ 1F22F FE0F emoji style
# <square> 6307
1F230 SQUARED CJK UNIFIED IDEOGRAPH-8D70
= runner
@@ -34817,6 +36512,7 @@
1F251 CIRCLED IDEOGRAPH ACCEPT
= accept sign
# <circle> 53EF
+@~ Standardized Variation Sequences
@@ 1F300 Miscellaneous Symbols and Pictographs 1F5FF
@ Weather, landscape, and sky symbols
1F300 CYCLONE
@@ -35330,6 +37026,7 @@
@ Comic style symbols
1F4A0 DIAMOND SHAPE WITH A DOT INSIDE
= kawaii, cute
+ * meaning of cuteness is based on association of glyph with shape of a flower
x (white diamond with centred dot - 27D0)
1F4A1 ELECTRIC LIGHT BULB
= idea
@@ -35565,6 +37262,16 @@
1F53D DOWN-POINTING SMALL RED TRIANGLE
= play arrow down
x (black down-pointing small triangle - 25BE)
+@ Religious symbols
+1F540 CIRCLED CROSS POMMEE
+ * Orthodox typikon symbol for great feast service
+1F541 CROSS POMMEE WITH HALF-CIRCLE BELOW
+ * Orthodox typikon symbol for vigil service
+1F542 CROSS POMMEE
+ * Orthodox typikon symbol for Polyeleos
+ x (four teardrop-spoked asterisk - 2722)
+1F543 NOTCHED LEFT SEMICIRCLE WITH THREE DOTS
+ * Orthodox typikon symbol for lower rank feast
@ Clock face symbols
1F550 CLOCK FACE ONE OCLOCK
x (watch - 231A)
@@ -35602,6 +37309,7 @@
@@ 1F600 Emoticons 1F64F
@+ The emoticons have been organized by mouth shape to make it easier to locate the different characters in the code chart.
@ Faces
+1F600 GRINNING FACE
1F601 GRINNING FACE WITH SMILING EYES
1F602 FACE WITH TEARS OF JOY
1F603 SMILING FACE WITH OPEN MOUTH
@@ -35620,12 +37328,17 @@
1F60F SMIRKING FACE
1F610 NEUTRAL FACE
* used for the West Wind in some Mahjong annotation
+1F611 EXPRESSIONLESS FACE
1F612 UNAMUSED FACE
1F613 FACE WITH COLD SWEAT
1F614 PENSIVE FACE
+1F615 CONFUSED FACE
1F616 CONFOUNDED FACE
+1F617 KISSING FACE
1F618 FACE THROWING A KISS
+1F619 KISSING FACE WITH SMILING EYES
1F61A KISSING FACE WITH CLOSED EYES
+1F61B FACE WITH STUCK-OUT TONGUE
1F61C FACE WITH STUCK-OUT TONGUE AND WINKING EYE
* kidding, not serious
1F61D FACE WITH STUCK-OUT TONGUE AND TIGHTLY-CLOSED EYES
@@ -35632,6 +37345,7 @@
* kidding, not serious
1F61E DISAPPOINTED FACE
x (white frowning face - 2639)
+1F61F WORRIED FACE
1F620 ANGRY FACE
1F621 POUTING FACE
1F622 CRYING FACE
@@ -35638,15 +37352,21 @@
1F623 PERSEVERING FACE
1F624 FACE WITH LOOK OF TRIUMPH
1F625 DISAPPOINTED BUT RELIEVED FACE
+1F626 FROWNING FACE WITH OPEN MOUTH
+1F627 ANGUISHED FACE
1F628 FEARFUL FACE
1F629 WEARY FACE
1F62A SLEEPY FACE
1F62B TIRED FACE
+1F62C GRIMACING FACE
1F62D LOUDLY CRYING FACE
+1F62E FACE WITH OPEN MOUTH
+1F62F HUSHED FACE
1F630 FACE WITH OPEN MOUTH AND COLD SWEAT
1F631 FACE SCREAMING IN FEAR
1F632 ASTONISHED FACE
1F633 FLUSHED FACE
+1F634 SLEEPING FACE
1F635 DIZZY FACE
1F636 FACE WITHOUT MOUTH
* used for the South Wind in some Mahjong annotation
@@ -35981,6 +37701,7 @@
1F76C ALCHEMICAL SYMBOL FOR BATH OF VAPOURS
= balneum vaporis
1F76D ALCHEMICAL SYMBOL FOR RETORT
+ x (alembic - 2697)
@ Time
1F76E ALCHEMICAL SYMBOL FOR HOUR
x (hourglass - 231B)
@@ -36007,7 +37728,7 @@
@@ 2A700 CJK Unified Ideographs Extension C 2B734
@@ 2B740 CJK Unified Ideographs Extension D 2B81D
@@ 2F800 CJK Compatibility Ideographs Supplement 2FA1F
-@ Duplicate characters from CNS\xA011643-1992
+@ Duplicate characters from CNS 11643-1992
2F800 CJK COMPATIBILITY IDEOGRAPH-2F800
: 4E3D
2F801 CJK COMPATIBILITY IDEOGRAPH-2F801
Property changes on: trunk/contrib/perl/lib/unicore/NamesList.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/NormalizationCorrections.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/NormalizationCorrections.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/NormalizationCorrections.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,14 +1,14 @@
-# NormalizationCorrections-6.0.0.txt
-# Date: 2010-05-19, 11:21:00 PDT [KW]
+# NormalizationCorrections-6.2.0.txt
+# Date: 2012-05-15, 22:25:00 GMT [KW, LI]
#
# This file is a normative contributory data file in the
# Unicode Character Database.
#
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
#
-# The normalization stabilization policy of the Unicode
-# Consortium ordinarily precludes any change to the decomposition
+# The normalization stability policy of the Unicode Consortium
+# ordinarily precludes any change to the decomposition
# for any character, once established in a relevant version
# of the UnicodeData.txt data file. However, under certain
# exceptional (and rare) conditions, an error in a decomposition
@@ -46,3 +46,5 @@
2F91F;43AB;243AB;4.0.0 # Corrigendum 4
2F95F;7AAE;7AEE;4.0.0 # Corrigendum 4
2F9BF;4D57;45D7;4.0.0 # Corrigendum 4
+
+# EOF
Property changes on: trunk/contrib/perl/lib/unicore/NormalizationCorrections.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/PropList.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/PropList.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/PropList.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,8 +1,8 @@
-# PropList-6.0.0.txt
-# Date: 2010-08-19, 00:48:28 GMT [MD]
+# PropList-6.2.0.txt
+# Date: 2012-05-23, 20:34:59 GMT [MD]
#
# Unicode Character Database
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
# For documentation, see http://www.unicode.org/reports/tr44/
@@ -50,6 +50,7 @@
2212 ; Dash # Sm MINUS SIGN
2E17 ; Dash # Pd DOUBLE OBLIQUE HYPHEN
2E1A ; Dash # Pd HYPHEN WITH DIAERESIS
+2E3A..2E3B ; Dash # Pd [2] TWO-EM DASH..THREE-EM DASH
301C ; Dash # Pd WAVE DASH
3030 ; Dash # Pd WAVY DASH
30A0 ; Dash # Pd KATAKANA-HIRAGANA DOUBLE HYPHEN
@@ -58,7 +59,7 @@
FE63 ; Dash # Pd SMALL HYPHEN-MINUS
FF0D ; Dash # Pd FULLWIDTH HYPHEN-MINUS
-# Total code points: 25
+# Total code points: 27
# ================================================
@@ -158,6 +159,7 @@
A9C7..A9C9 ; Terminal_Punctuation # Po [3] JAVANESE PADA PANGKAT..JAVANESE PADA LUNGSI
AA5D..AA5F ; Terminal_Punctuation # Po [3] CHAM PUNCTUATION DANDA..CHAM PUNCTUATION TRIPLE DANDA
AADF ; Terminal_Punctuation # Po TAI VIET SYMBOL KOI KOI
+AAF0..AAF1 ; Terminal_Punctuation # Po [2] MEETEI MAYEK CHEIKHAN..MEETEI MAYEK AHANG KHUDAM
ABEB ; Terminal_Punctuation # Po MEETEI MAYEK CHEIKHEI
FE50..FE52 ; Terminal_Punctuation # Po [3] SMALL COMMA..SMALL FULL STOP
FE54..FE57 ; Terminal_Punctuation # Po [4] SMALL SEMICOLON..SMALL EXCLAMATION MARK
@@ -175,9 +177,11 @@
10B3A..10B3F ; Terminal_Punctuation # Po [6] TINY TWO DOTS OVER ONE DOT PUNCTUATION..LARGE ONE RING OVER TWO RINGS PUNCTUATION
11047..1104D ; Terminal_Punctuation # Po [7] BRAHMI DANDA..BRAHMI PUNCTUATION LOTUS
110BE..110C1 ; Terminal_Punctuation # Po [4] KAITHI SECTION MARK..KAITHI DOUBLE DANDA
+11141..11143 ; Terminal_Punctuation # Po [3] CHAKMA DANDA..CHAKMA QUESTION MARK
+111C5..111C6 ; Terminal_Punctuation # Po [2] SHARADA DANDA..SHARADA DOUBLE DANDA
12470..12473 ; Terminal_Punctuation # Po [4] CUNEIFORM PUNCTUATION SIGN OLD ASSYRIAN WORD DIVIDER..CUNEIFORM PUNCTUATION SIGN DIAGONAL TRICOLON
-# Total code points: 169
+# Total code points: 176
# ================================================
@@ -320,8 +324,41 @@
1D7AA..1D7C2 ; Other_Math # L& [25] MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL ALPHA..MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL OMEGA
1D7C4..1D7CB ; Other_Math # L& [8] MATHEMATICAL SANS-SERIF BOLD ITALIC EPSILON SYMBOL..MATHEMATICAL BOLD SMALL DIGAMMA
1D7CE..1D7FF ; Other_Math # Nd [50] MATHEMATICAL BOLD DIGIT ZERO..MATHEMATICAL MONOSPACE DIGIT NINE
+1EE00..1EE03 ; Other_Math # Lo [4] ARABIC MATHEMATICAL ALEF..ARABIC MATHEMATICAL DAL
+1EE05..1EE1F ; Other_Math # Lo [27] ARABIC MATHEMATICAL WAW..ARABIC MATHEMATICAL DOTLESS QAF
+1EE21..1EE22 ; Other_Math # Lo [2] ARABIC MATHEMATICAL INITIAL BEH..ARABIC MATHEMATICAL INITIAL JEEM
+1EE24 ; Other_Math # Lo ARABIC MATHEMATICAL INITIAL HEH
+1EE27 ; Other_Math # Lo ARABIC MATHEMATICAL INITIAL HAH
+1EE29..1EE32 ; Other_Math # Lo [10] ARABIC MATHEMATICAL INITIAL YEH..ARABIC MATHEMATICAL INITIAL QAF
+1EE34..1EE37 ; Other_Math # Lo [4] ARABIC MATHEMATICAL INITIAL SHEEN..ARABIC MATHEMATICAL INITIAL KHAH
+1EE39 ; Other_Math # Lo ARABIC MATHEMATICAL INITIAL DAD
+1EE3B ; Other_Math # Lo ARABIC MATHEMATICAL INITIAL GHAIN
+1EE42 ; Other_Math # Lo ARABIC MATHEMATICAL TAILED JEEM
+1EE47 ; Other_Math # Lo ARABIC MATHEMATICAL TAILED HAH
+1EE49 ; Other_Math # Lo ARABIC MATHEMATICAL TAILED YEH
+1EE4B ; Other_Math # Lo ARABIC MATHEMATICAL TAILED LAM
+1EE4D..1EE4F ; Other_Math # Lo [3] ARABIC MATHEMATICAL TAILED NOON..ARABIC MATHEMATICAL TAILED AIN
+1EE51..1EE52 ; Other_Math # Lo [2] ARABIC MATHEMATICAL TAILED SAD..ARABIC MATHEMATICAL TAILED QAF
+1EE54 ; Other_Math # Lo ARABIC MATHEMATICAL TAILED SHEEN
+1EE57 ; Other_Math # Lo ARABIC MATHEMATICAL TAILED KHAH
+1EE59 ; Other_Math # Lo ARABIC MATHEMATICAL TAILED DAD
+1EE5B ; Other_Math # Lo ARABIC MATHEMATICAL TAILED GHAIN
+1EE5D ; Other_Math # Lo ARABIC MATHEMATICAL TAILED DOTLESS NOON
+1EE5F ; Other_Math # Lo ARABIC MATHEMATICAL TAILED DOTLESS QAF
+1EE61..1EE62 ; Other_Math # Lo [2] ARABIC MATHEMATICAL STRETCHED BEH..ARABIC MATHEMATICAL STRETCHED JEEM
+1EE64 ; Other_Math # Lo ARABIC MATHEMATICAL STRETCHED HEH
+1EE67..1EE6A ; Other_Math # Lo [4] ARABIC MATHEMATICAL STRETCHED HAH..ARABIC MATHEMATICAL STRETCHED KAF
+1EE6C..1EE72 ; Other_Math # Lo [7] ARABIC MATHEMATICAL STRETCHED MEEM..ARABIC MATHEMATICAL STRETCHED QAF
+1EE74..1EE77 ; Other_Math # Lo [4] ARABIC MATHEMATICAL STRETCHED SHEEN..ARABIC MATHEMATICAL STRETCHED KHAH
+1EE79..1EE7C ; Other_Math # Lo [4] ARABIC MATHEMATICAL STRETCHED DAD..ARABIC MATHEMATICAL STRETCHED DOTLESS BEH
+1EE7E ; Other_Math # Lo ARABIC MATHEMATICAL STRETCHED DOTLESS FEH
+1EE80..1EE89 ; Other_Math # Lo [10] ARABIC MATHEMATICAL LOOPED ALEF..ARABIC MATHEMATICAL LOOPED YEH
+1EE8B..1EE9B ; Other_Math # Lo [17] ARABIC MATHEMATICAL LOOPED LAM..ARABIC MATHEMATICAL LOOPED GHAIN
+1EEA1..1EEA3 ; Other_Math # Lo [3] ARABIC MATHEMATICAL DOUBLE-STRUCK BEH..ARABIC MATHEMATICAL DOUBLE-STRUCK DAL
+1EEA5..1EEA9 ; Other_Math # Lo [5] ARABIC MATHEMATICAL DOUBLE-STRUCK WAW..ARABIC MATHEMATICAL DOUBLE-STRUCK YEH
+1EEAB..1EEBB ; Other_Math # Lo [17] ARABIC MATHEMATICAL DOUBLE-STRUCK LAM..ARABIC MATHEMATICAL DOUBLE-STRUCK GHAIN
-# Total code points: 1217
+# Total code points: 1358
# ================================================
@@ -365,6 +402,8 @@
081B..0823 ; Other_Alphabetic # Mn [9] SAMARITAN MARK EPENTHETIC YUT..SAMARITAN VOWEL SIGN A
0825..0827 ; Other_Alphabetic # Mn [3] SAMARITAN VOWEL SIGN SHORT A..SAMARITAN VOWEL SIGN U
0829..082C ; Other_Alphabetic # Mn [4] SAMARITAN VOWEL SIGN LONG I..SAMARITAN VOWEL SIGN SUKUN
+08E4..08E9 ; Other_Alphabetic # Mn [6] ARABIC CURLY FATHA..ARABIC CURLY KASRATAN
+08F0..08FE ; Other_Alphabetic # Mn [15] ARABIC OPEN FATHATAN..ARABIC DAMMA WITH DOT
0900..0902 ; Other_Alphabetic # Mn [3] DEVANAGARI SIGN INVERTED CANDRABINDU..DEVANAGARI SIGN ANUSVARA
0903 ; Other_Alphabetic # Mc DEVANAGARI SIGN VISARGA
093A ; Other_Alphabetic # Mn DEVANAGARI VOWEL SIGN OE
@@ -525,6 +564,7 @@
1BA2..1BA5 ; Other_Alphabetic # Mn [4] SUNDANESE CONSONANT SIGN PANYAKRA..SUNDANESE VOWEL SIGN PANYUKU
1BA6..1BA7 ; Other_Alphabetic # Mc [2] SUNDANESE VOWEL SIGN PANAELAENG..SUNDANESE VOWEL SIGN PANOLONG
1BA8..1BA9 ; Other_Alphabetic # Mn [2] SUNDANESE VOWEL SIGN PAMEPET..SUNDANESE VOWEL SIGN PANEULEUNG
+1BAC..1BAD ; Other_Alphabetic # Mc [2] SUNDANESE CONSONANT SIGN PASANGAN MA..SUNDANESE CONSONANT SIGN PASANGAN WA
1BE7 ; Other_Alphabetic # Mc BATAK VOWEL SIGN E
1BE8..1BE9 ; Other_Alphabetic # Mn [2] BATAK VOWEL SIGN PAKPAK E..BATAK VOWEL SIGN EE
1BEA..1BEC ; Other_Alphabetic # Mc [3] BATAK VOWEL SIGN I..BATAK VOWEL SIGN O
@@ -534,9 +574,11 @@
1C24..1C2B ; Other_Alphabetic # Mc [8] LEPCHA SUBJOINED LETTER YA..LEPCHA VOWEL SIGN UU
1C2C..1C33 ; Other_Alphabetic # Mn [8] LEPCHA VOWEL SIGN E..LEPCHA CONSONANT SIGN T
1C34..1C35 ; Other_Alphabetic # Mc [2] LEPCHA CONSONANT SIGN NYIN-DO..LEPCHA CONSONANT SIGN KANG
-1CF2 ; Other_Alphabetic # Mc VEDIC SIGN ARDHAVISARGA
+1CF2..1CF3 ; Other_Alphabetic # Mc [2] VEDIC SIGN ARDHAVISARGA..VEDIC SIGN ROTATED ARDHAVISARGA
24B6..24E9 ; Other_Alphabetic # So [52] CIRCLED LATIN CAPITAL LETTER A..CIRCLED LATIN SMALL LETTER Z
2DE0..2DFF ; Other_Alphabetic # Mn [32] COMBINING CYRILLIC LETTER BE..COMBINING CYRILLIC LETTER IOTIFIED BIG YUS
+A674..A67B ; Other_Alphabetic # Mn [8] COMBINING CYRILLIC LETTER UKRAINIAN IE..COMBINING CYRILLIC LETTER OMEGA
+A69F ; Other_Alphabetic # Mn COMBINING CYRILLIC LETTER IOTIFIED E
A823..A824 ; Other_Alphabetic # Mc [2] SYLOTI NAGRI VOWEL SIGN A..SYLOTI NAGRI VOWEL SIGN I
A825..A826 ; Other_Alphabetic # Mn [2] SYLOTI NAGRI VOWEL SIGN U..SYLOTI NAGRI VOWEL SIGN E
A827 ; Other_Alphabetic # Mc SYLOTI NAGRI VOWEL SIGN OO
@@ -564,6 +606,10 @@
AAB2..AAB4 ; Other_Alphabetic # Mn [3] TAI VIET VOWEL I..TAI VIET VOWEL U
AAB7..AAB8 ; Other_Alphabetic # Mn [2] TAI VIET MAI KHIT..TAI VIET VOWEL IA
AABE ; Other_Alphabetic # Mn TAI VIET VOWEL AM
+AAEB ; Other_Alphabetic # Mc MEETEI MAYEK VOWEL SIGN II
+AAEC..AAED ; Other_Alphabetic # Mn [2] MEETEI MAYEK VOWEL SIGN UU..MEETEI MAYEK VOWEL SIGN AAI
+AAEE..AAEF ; Other_Alphabetic # Mc [2] MEETEI MAYEK VOWEL SIGN AU..MEETEI MAYEK VOWEL SIGN AAU
+AAF5 ; Other_Alphabetic # Mc MEETEI MAYEK VOWEL SIGN VISARGA
ABE3..ABE4 ; Other_Alphabetic # Mc [2] MEETEI MAYEK VOWEL SIGN ONAP..MEETEI MAYEK VOWEL SIGN INAP
ABE5 ; Other_Alphabetic # Mn MEETEI MAYEK VOWEL SIGN ANAP
ABE6..ABE7 ; Other_Alphabetic # Mc [2] MEETEI MAYEK VOWEL SIGN YENAP..MEETEI MAYEK VOWEL SIGN SOUNAP
@@ -581,8 +627,23 @@
110B0..110B2 ; Other_Alphabetic # Mc [3] KAITHI VOWEL SIGN AA..KAITHI VOWEL SIGN II
110B3..110B6 ; Other_Alphabetic # Mn [4] KAITHI VOWEL SIGN U..KAITHI VOWEL SIGN AI
110B7..110B8 ; Other_Alphabetic # Mc [2] KAITHI VOWEL SIGN O..KAITHI VOWEL SIGN AU
+11100..11102 ; Other_Alphabetic # Mn [3] CHAKMA SIGN CANDRABINDU..CHAKMA SIGN VISARGA
+11127..1112B ; Other_Alphabetic # Mn [5] CHAKMA VOWEL SIGN A..CHAKMA VOWEL SIGN UU
+1112C ; Other_Alphabetic # Mc CHAKMA VOWEL SIGN E
+1112D..11132 ; Other_Alphabetic # Mn [6] CHAKMA VOWEL SIGN AI..CHAKMA AU MARK
+11180..11181 ; Other_Alphabetic # Mn [2] SHARADA SIGN CANDRABINDU..SHARADA SIGN ANUSVARA
+11182 ; Other_Alphabetic # Mc SHARADA SIGN VISARGA
+111B3..111B5 ; Other_Alphabetic # Mc [3] SHARADA VOWEL SIGN AA..SHARADA VOWEL SIGN II
+111B6..111BE ; Other_Alphabetic # Mn [9] SHARADA VOWEL SIGN U..SHARADA VOWEL SIGN O
+111BF ; Other_Alphabetic # Mc SHARADA VOWEL SIGN AU
+116AB ; Other_Alphabetic # Mn TAKRI SIGN ANUSVARA
+116AC ; Other_Alphabetic # Mc TAKRI SIGN VISARGA
+116AD ; Other_Alphabetic # Mn TAKRI VOWEL SIGN AA
+116AE..116AF ; Other_Alphabetic # Mc [2] TAKRI VOWEL SIGN I..TAKRI VOWEL SIGN II
+116B0..116B5 ; Other_Alphabetic # Mn [6] TAKRI VOWEL SIGN U..TAKRI VOWEL SIGN AU
+16F51..16F7E ; Other_Alphabetic # Mc [46] MIAO SIGN ASPIRATION..MIAO VOWEL SIGN NG
-# Total code points: 795
+# Total code points: 922
# ================================================
@@ -591,9 +652,8 @@
3021..3029 ; Ideographic # Nl [9] HANGZHOU NUMERAL ONE..HANGZHOU NUMERAL NINE
3038..303A ; Ideographic # Nl [3] HANGZHOU NUMERAL TEN..HANGZHOU NUMERAL THIRTY
3400..4DB5 ; Ideographic # Lo [6582] CJK UNIFIED IDEOGRAPH-3400..CJK UNIFIED IDEOGRAPH-4DB5
-4E00..9FCB ; Ideographic # Lo [20940] CJK UNIFIED IDEOGRAPH-4E00..CJK UNIFIED IDEOGRAPH-9FCB
-F900..FA2D ; Ideographic # Lo [302] CJK COMPATIBILITY IDEOGRAPH-F900..CJK COMPATIBILITY IDEOGRAPH-FA2D
-FA30..FA6D ; Ideographic # Lo [62] CJK COMPATIBILITY IDEOGRAPH-FA30..CJK COMPATIBILITY IDEOGRAPH-FA6D
+4E00..9FCC ; Ideographic # Lo [20941] CJK UNIFIED IDEOGRAPH-4E00..CJK UNIFIED IDEOGRAPH-9FCC
+F900..FA6D ; Ideographic # Lo [366] CJK COMPATIBILITY IDEOGRAPH-F900..CJK COMPATIBILITY IDEOGRAPH-FA6D
FA70..FAD9 ; Ideographic # Lo [106] CJK COMPATIBILITY IDEOGRAPH-FA70..CJK COMPATIBILITY IDEOGRAPH-FAD9
20000..2A6D6 ; Ideographic # Lo [42711] CJK UNIFIED IDEOGRAPH-20000..CJK UNIFIED IDEOGRAPH-2A6D6
2A700..2B734 ; Ideographic # Lo [4149] CJK UNIFIED IDEOGRAPH-2A700..CJK UNIFIED IDEOGRAPH-2B734
@@ -600,7 +660,7 @@
2B740..2B81D ; Ideographic # Lo [222] CJK UNIFIED IDEOGRAPH-2B740..CJK UNIFIED IDEOGRAPH-2B81D
2F800..2FA1D ; Ideographic # Lo [542] CJK COMPATIBILITY IDEOGRAPH-2F800..CJK COMPATIBILITY IDEOGRAPH-2FA1D
-# Total code points: 75630
+# Total code points: 75633
# ================================================
@@ -645,6 +705,7 @@
07EB..07F3 ; Diacritic # Mn [9] NKO COMBINING SHORT HIGH TONE..NKO COMBINING DOUBLE DOT ABOVE
07F4..07F5 ; Diacritic # Lm [2] NKO HIGH TONE APOSTROPHE..NKO LOW TONE APOSTROPHE
0818..0819 ; Diacritic # Mn [2] SAMARITAN MARK OCCLUSION..SAMARITAN MARK DAGESH
+08E4..08FE ; Diacritic # Mn [27] ARABIC CURLY FATHA..ARABIC DAMMA WITH DOT
093C ; Diacritic # Mn DEVANAGARI SIGN NUKTA
094D ; Diacritic # Mn DEVANAGARI SIGN VIRAMA
0951..0954 ; Diacritic # Mn [4] DEVANAGARI STRESS SIGN UDATTA..DEVANAGARI ACUTE ACCENT
@@ -689,6 +750,7 @@
1B44 ; Diacritic # Mc BALINESE ADEG ADEG
1B6B..1B73 ; Diacritic # Mn [9] BALINESE MUSICAL SYMBOL COMBINING TEGEH..BALINESE MUSICAL SYMBOL COMBINING GONG
1BAA ; Diacritic # Mc SUNDANESE SIGN PAMAAEH
+1BAB ; Diacritic # Mn SUNDANESE SIGN VIRAMA
1C36..1C37 ; Diacritic # Mn [2] LEPCHA SIGN RAN..LEPCHA SIGN NUKTA
1C78..1C7D ; Diacritic # Lm [6] OL CHIKI MU TTUDDAG..OL CHIKI AHAD
1CD0..1CD2 ; Diacritic # Mn [3] VEDIC TONE KARSHANA..VEDIC TONE PRENKHA
@@ -697,8 +759,8 @@
1CE1 ; Diacritic # Mc VEDIC TONE ATHARVAVEDIC INDEPENDENT SVARITA
1CE2..1CE8 ; Diacritic # Mn [7] VEDIC SIGN VISARGA SVARITA..VEDIC SIGN VISARGA ANUDATTA WITH TAIL
1CED ; Diacritic # Mn VEDIC SIGN TIRYAK
-1D2C..1D61 ; Diacritic # Lm [54] MODIFIER LETTER CAPITAL A..MODIFIER LETTER SMALL CHI
-1D62..1D6A ; Diacritic # L& [9] LATIN SUBSCRIPT SMALL LETTER I..GREEK SUBSCRIPT SMALL LETTER CHI
+1CF4 ; Diacritic # Mn VEDIC TONE CANDRA ABOVE
+1D2C..1D6A ; Diacritic # Lm [63] MODIFIER LETTER CAPITAL A..GREEK SUBSCRIPT SMALL LETTER CHI
1DC4..1DCF ; Diacritic # Mn [12] COMBINING MACRON-ACUTE..COMBINING ZIGZAG BELOW
1DFD..1DFF ; Diacritic # Mn [3] COMBINING ALMOST EQUAL TO BELOW..COMBINING RIGHT ARROWHEAD AND DOWN ARROWHEAD BELOW
1FBD ; Diacritic # Sk GREEK KORONIS
@@ -709,7 +771,8 @@
1FFD..1FFE ; Diacritic # Sk [2] GREEK OXIA..GREEK DASIA
2CEF..2CF1 ; Diacritic # Mn [3] COPTIC COMBINING NI ABOVE..COPTIC COMBINING SPIRITUS LENIS
2E2F ; Diacritic # Lm VERTICAL TILDE
-302A..302F ; Diacritic # Mn [6] IDEOGRAPHIC LEVEL TONE MARK..HANGUL DOUBLE DOT TONE MARK
+302A..302D ; Diacritic # Mn [4] IDEOGRAPHIC LEVEL TONE MARK..IDEOGRAPHIC ENTERING TONE MARK
+302E..302F ; Diacritic # Mc [2] HANGUL SINGLE DOT TONE MARK..HANGUL DOUBLE DOT TONE MARK
3099..309A ; Diacritic # Mn [2] COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK..COMBINING KATAKANA-HIRAGANA SEMI-VOICED SOUND MARK
309B..309C ; Diacritic # Sk [2] KATAKANA-HIRAGANA VOICED SOUND MARK..KATAKANA-HIRAGANA SEMI-VOICED SOUND MARK
30FC ; Diacritic # Lm KATAKANA-HIRAGANA PROLONGED SOUND MARK
@@ -720,6 +783,7 @@
A717..A71F ; Diacritic # Lm [9] MODIFIER LETTER DOT VERTICAL BAR..MODIFIER LETTER LOW INVERTED EXCLAMATION MARK
A720..A721 ; Diacritic # Sk [2] MODIFIER LETTER STRESS AND HIGH TONE..MODIFIER LETTER STRESS AND LOW TONE
A788 ; Diacritic # Lm MODIFIER LETTER LOW CIRCUMFLEX ACCENT
+A7F8..A7F9 ; Diacritic # Lm [2] MODIFIER LETTER CAPITAL H WITH STROKE..MODIFIER LETTER SMALL LIGATURE OE
A8C4 ; Diacritic # Mn SAURASHTRA SIGN VIRAMA
A8E0..A8F1 ; Diacritic # Mn [18] COMBINING DEVANAGARI DIGIT ZERO..COMBINING DEVANAGARI SIGN AVAGRAHA
A92B..A92D ; Diacritic # Mn [3] KAYAH LI TONE PLOPHU..KAYAH LI TONE CALYA PLOPHU
@@ -732,6 +796,7 @@
AAC0 ; Diacritic # Lo TAI VIET TONE MAI NUENG
AAC1 ; Diacritic # Mn TAI VIET TONE MAI THO
AAC2 ; Diacritic # Lo TAI VIET TONE MAI SONG
+AAF6 ; Diacritic # Mn MEETEI MAYEK VIRAMA
ABEC ; Diacritic # Mc MEETEI MAYEK LUM IYEK
ABED ; Diacritic # Mn MEETEI MAYEK APUN IYEK
FB1E ; Diacritic # Mn HEBREW POINT JUDEO-SPANISH VARIKA
@@ -742,6 +807,12 @@
FF9E..FF9F ; Diacritic # Lm [2] HALFWIDTH KATAKANA VOICED SOUND MARK..HALFWIDTH KATAKANA SEMI-VOICED SOUND MARK
FFE3 ; Diacritic # Sk FULLWIDTH MACRON
110B9..110BA ; Diacritic # Mn [2] KAITHI SIGN VIRAMA..KAITHI SIGN NUKTA
+11133..11134 ; Diacritic # Mn [2] CHAKMA VIRAMA..CHAKMA MAAYYAA
+111C0 ; Diacritic # Mc SHARADA SIGN VIRAMA
+116B6 ; Diacritic # Mc TAKRI SIGN VIRAMA
+116B7 ; Diacritic # Mn TAKRI SIGN NUKTA
+16F8F..16F92 ; Diacritic # Mn [4] MIAO TONE RIGHT..MIAO TONE BELOW
+16F93..16F9F ; Diacritic # Lm [13] MIAO LETTER TONE-2..MIAO LETTER REFORMED TONE-8
1D167..1D169 ; Diacritic # Mn [3] MUSICAL SYMBOL COMBINING TREMOLO-1..MUSICAL SYMBOL COMBINING TREMOLO-3
1D16D..1D172 ; Diacritic # Mc [6] MUSICAL SYMBOL COMBINING AUGMENTATION DOT..MUSICAL SYMBOL COMBINING FLAG-5
1D17B..1D182 ; Diacritic # Mn [8] MUSICAL SYMBOL COMBINING ACCENT..MUSICAL SYMBOL COMBINING LOURE
@@ -748,7 +819,7 @@
1D185..1D18B ; Diacritic # Mn [7] MUSICAL SYMBOL COMBINING DOIT..MUSICAL SYMBOL COMBINING TRIPLE TONGUE
1D1AA..1D1AD ; Diacritic # Mn [4] MUSICAL SYMBOL COMBINING DOWN BOW..MUSICAL SYMBOL COMBINING SNAP PIZZICATO
-# Total code points: 639
+# Total code points: 693
# ================================================
@@ -758,6 +829,7 @@
07FA ; Extender # Lm NKO LAJANYALAN
0E46 ; Extender # Lm THAI CHARACTER MAIYAMOK
0EC6 ; Extender # Lm LAO KO LA
+180A ; Extender # Po MONGOLIAN NIRUGU
1843 ; Extender # Lm MONGOLIAN LETTER TODO LONG VOWEL SIGN
1AA7 ; Extender # Lm TAI THAM SIGN MAI YAMOK
1C36 ; Extender # Mn LEPCHA SIGN RAN
@@ -771,27 +843,33 @@
A9CF ; Extender # Lm JAVANESE PANGRANGKEP
AA70 ; Extender # Lm MYANMAR MODIFIER LETTER KHAMTI REDUPLICATION
AADD ; Extender # Lm TAI VIET SYMBOL SAM
+AAF3..AAF4 ; Extender # Lm [2] MEETEI MAYEK SYLLABLE REPETITION MARK..MEETEI MAYEK WORD REPETITION MARK
FF70 ; Extender # Lm HALFWIDTH KATAKANA-HIRAGANA PROLONGED SOUND MARK
-# Total code points: 28
+# Total code points: 31
# ================================================
+00AA ; Other_Lowercase # Lo FEMININE ORDINAL INDICATOR
+00BA ; Other_Lowercase # Lo MASCULINE ORDINAL INDICATOR
02B0..02B8 ; Other_Lowercase # Lm [9] MODIFIER LETTER SMALL H..MODIFIER LETTER SMALL Y
02C0..02C1 ; Other_Lowercase # Lm [2] MODIFIER LETTER GLOTTAL STOP..MODIFIER LETTER REVERSED GLOTTAL STOP
02E0..02E4 ; Other_Lowercase # Lm [5] MODIFIER LETTER SMALL GAMMA..MODIFIER LETTER SMALL REVERSED GLOTTAL STOP
0345 ; Other_Lowercase # Mn COMBINING GREEK YPOGEGRAMMENI
037A ; Other_Lowercase # Lm GREEK YPOGEGRAMMENI
-1D2C..1D61 ; Other_Lowercase # Lm [54] MODIFIER LETTER CAPITAL A..MODIFIER LETTER SMALL CHI
+1D2C..1D6A ; Other_Lowercase # Lm [63] MODIFIER LETTER CAPITAL A..GREEK SUBSCRIPT SMALL LETTER CHI
1D78 ; Other_Lowercase # Lm MODIFIER LETTER CYRILLIC EN
1D9B..1DBF ; Other_Lowercase # Lm [37] MODIFIER LETTER SMALL TURNED ALPHA..MODIFIER LETTER SMALL THETA
-2090..2094 ; Other_Lowercase # Lm [5] LATIN SUBSCRIPT SMALL LETTER A..LATIN SUBSCRIPT SMALL LETTER SCHWA
+2071 ; Other_Lowercase # Lm SUPERSCRIPT LATIN SMALL LETTER I
+207F ; Other_Lowercase # Lm SUPERSCRIPT LATIN SMALL LETTER N
+2090..209C ; Other_Lowercase # Lm [13] LATIN SUBSCRIPT SMALL LETTER A..LATIN SUBSCRIPT SMALL LETTER T
2170..217F ; Other_Lowercase # Nl [16] SMALL ROMAN NUMERAL ONE..SMALL ROMAN NUMERAL ONE THOUSAND
24D0..24E9 ; Other_Lowercase # So [26] CIRCLED LATIN SMALL LETTER A..CIRCLED LATIN SMALL LETTER Z
-2C7D ; Other_Lowercase # Lm MODIFIER LETTER CAPITAL V
+2C7C..2C7D ; Other_Lowercase # Lm [2] LATIN SUBSCRIPT SMALL LETTER J..MODIFIER LETTER CAPITAL V
A770 ; Other_Lowercase # Lm MODIFIER LETTER US
+A7F8..A7F9 ; Other_Lowercase # Lm [2] MODIFIER LETTER CAPITAL H WITH STROKE..MODIFIER LETTER SMALL LIGATURE OE
-# Total code points: 159
+# Total code points: 183
# ================================================
@@ -838,11 +916,12 @@
0DCF ; Other_Grapheme_Extend # Mc SINHALA VOWEL SIGN AELA-PILLA
0DDF ; Other_Grapheme_Extend # Mc SINHALA VOWEL SIGN GAYANUKITTA
200C..200D ; Other_Grapheme_Extend # Cf [2] ZERO WIDTH NON-JOINER..ZERO WIDTH JOINER
+302E..302F ; Other_Grapheme_Extend # Mc [2] HANGUL SINGLE DOT TONE MARK..HANGUL DOUBLE DOT TONE MARK
FF9E..FF9F ; Other_Grapheme_Extend # Lm [2] HALFWIDTH KATAKANA VOICED SOUND MARK..HALFWIDTH KATAKANA SEMI-VOICED SOUND MARK
1D165 ; Other_Grapheme_Extend # Mc MUSICAL SYMBOL COMBINING STEM
1D16E..1D172 ; Other_Grapheme_Extend # Mc [5] MUSICAL SYMBOL COMBINING FLAG-1..MUSICAL SYMBOL COMBINING FLAG-5
-# Total code points: 23
+# Total code points: 25
# ================================================
@@ -868,7 +947,7 @@
# ================================================
3400..4DB5 ; Unified_Ideograph # Lo [6582] CJK UNIFIED IDEOGRAPH-3400..CJK UNIFIED IDEOGRAPH-4DB5
-4E00..9FCB ; Unified_Ideograph # Lo [20940] CJK UNIFIED IDEOGRAPH-4E00..CJK UNIFIED IDEOGRAPH-9FCB
+4E00..9FCC ; Unified_Ideograph # Lo [20941] CJK UNIFIED IDEOGRAPH-4E00..CJK UNIFIED IDEOGRAPH-9FCC
FA0E..FA0F ; Unified_Ideograph # Lo [2] CJK COMPATIBILITY IDEOGRAPH-FA0E..CJK COMPATIBILITY IDEOGRAPH-FA0F
FA11 ; Unified_Ideograph # Lo CJK COMPATIBILITY IDEOGRAPH-FA11
FA13..FA14 ; Unified_Ideograph # Lo [2] CJK COMPATIBILITY IDEOGRAPH-FA13..CJK COMPATIBILITY IDEOGRAPH-FA14
@@ -880,12 +959,13 @@
2A700..2B734 ; Unified_Ideograph # Lo [4149] CJK UNIFIED IDEOGRAPH-2A700..CJK UNIFIED IDEOGRAPH-2B734
2B740..2B81D ; Unified_Ideograph # Lo [222] CJK UNIFIED IDEOGRAPH-2B740..CJK UNIFIED IDEOGRAPH-2B81D
-# Total code points: 74616
+# Total code points: 74617
# ================================================
034F ; Other_Default_Ignorable_Code_Point # Mn COMBINING GRAPHEME JOINER
115F..1160 ; Other_Default_Ignorable_Code_Point # Lo [2] HANGUL CHOSEONG FILLER..HANGUL JUNGSEONG FILLER
+17B4..17B5 ; Other_Default_Ignorable_Code_Point # Mn [2] KHMER VOWEL INHERENT AQ..KHMER VOWEL INHERENT AA
2065..2069 ; Other_Default_Ignorable_Code_Point # Cn [5] <reserved-2065>..<reserved-2069>
3164 ; Other_Default_Ignorable_Code_Point # Lo HANGUL FILLER
FFA0 ; Other_Default_Ignorable_Code_Point # Lo HALFWIDTH HANGUL FILLER
@@ -895,7 +975,7 @@
E0080..E00FF ; Other_Default_Ignorable_Code_Point # Cn [128] <reserved-E0080>..<reserved-E00FF>
E01F0..E0FFF ; Other_Default_Ignorable_Code_Point # Cn [3600] <reserved-E01F0>..<reserved-E0FFF>
-# Total code points: 3778
+# Total code points: 3780
# ================================================
@@ -923,7 +1003,7 @@
03F3 ; Soft_Dotted # L& GREEK LETTER YOT
0456 ; Soft_Dotted # L& CYRILLIC SMALL LETTER BYELORUSSIAN-UKRAINIAN I
0458 ; Soft_Dotted # L& CYRILLIC SMALL LETTER JE
-1D62 ; Soft_Dotted # L& LATIN SUBSCRIPT SMALL LETTER I
+1D62 ; Soft_Dotted # Lm LATIN SUBSCRIPT SMALL LETTER I
1D96 ; Soft_Dotted # L& LATIN SMALL LETTER I WITH RETROFLEX HOOK
1DA4 ; Soft_Dotted # Lm MODIFIER LETTER SMALL I WITH STROKE
1DA8 ; Soft_Dotted # Lm MODIFIER LETTER SMALL J WITH CROSSED-TAIL
@@ -931,7 +1011,7 @@
1ECB ; Soft_Dotted # L& LATIN SMALL LETTER I WITH DOT BELOW
2071 ; Soft_Dotted # Lm SUPERSCRIPT LATIN SMALL LETTER I
2148..2149 ; Soft_Dotted # L& [2] DOUBLE-STRUCK ITALIC SMALL I..DOUBLE-STRUCK ITALIC SMALL J
-2C7C ; Soft_Dotted # L& LATIN SUBSCRIPT SMALL LETTER J
+2C7C ; Soft_Dotted # Lm LATIN SUBSCRIPT SMALL LETTER J
1D422..1D423 ; Soft_Dotted # L& [2] MATHEMATICAL BOLD SMALL I..MATHEMATICAL BOLD SMALL J
1D456..1D457 ; Soft_Dotted # L& [2] MATHEMATICAL ITALIC SMALL I..MATHEMATICAL ITALIC SMALL J
1D48A..1D48B ; Soft_Dotted # L& [2] MATHEMATICAL BOLD ITALIC SMALL I..MATHEMATICAL BOLD ITALIC SMALL J
@@ -1014,6 +1094,7 @@
A92F ; STerm # Po KAYAH LI SIGN SHYA
A9C8..A9C9 ; STerm # Po [2] JAVANESE PADA LINGSA..JAVANESE PADA LUNGSI
AA5D..AA5F ; STerm # Po [3] CHAM PUNCTUATION DANDA..CHAM PUNCTUATION TRIPLE DANDA
+AAF0..AAF1 ; STerm # Po [2] MEETEI MAYEK CHEIKHAN..MEETEI MAYEK AHANG KHUDAM
ABEB ; STerm # Po MEETEI MAYEK CHEIKHEI
FE52 ; STerm # Po SMALL FULL STOP
FE56..FE57 ; STerm # Po [2] SMALL QUESTION MARK..SMALL EXCLAMATION MARK
@@ -1024,8 +1105,10 @@
10A56..10A57 ; STerm # Po [2] KHAROSHTHI PUNCTUATION DANDA..KHAROSHTHI PUNCTUATION DOUBLE DANDA
11047..11048 ; STerm # Po [2] BRAHMI DANDA..BRAHMI DOUBLE DANDA
110BE..110C1 ; STerm # Po [4] KAITHI SECTION MARK..KAITHI DOUBLE DANDA
+11141..11143 ; STerm # Po [3] CHAKMA DANDA..CHAKMA QUESTION MARK
+111C5..111C6 ; STerm # Po [2] SHARADA DANDA..SHARADA DOUBLE DANDA
-# Total code points: 76
+# Total code points: 83
# ================================================
@@ -1072,7 +1155,8 @@
007E ; Pattern_Syntax # Sm TILDE
00A1 ; Pattern_Syntax # Po INVERTED EXCLAMATION MARK
00A2..00A5 ; Pattern_Syntax # Sc [4] CENT SIGN..YEN SIGN
-00A6..00A7 ; Pattern_Syntax # So [2] BROKEN BAR..SECTION SIGN
+00A6 ; Pattern_Syntax # So BROKEN BAR
+00A7 ; Pattern_Syntax # Po SECTION SIGN
00A9 ; Pattern_Syntax # So COPYRIGHT SIGN
00AB ; Pattern_Syntax # Pi LEFT-POINTING DOUBLE ANGLE QUOTATION MARK
00AC ; Pattern_Syntax # Sm NOT SIGN
@@ -1079,7 +1163,7 @@
00AE ; Pattern_Syntax # So REGISTERED SIGN
00B0 ; Pattern_Syntax # So DEGREE SIGN
00B1 ; Pattern_Syntax # Sm PLUS-MINUS SIGN
-00B6 ; Pattern_Syntax # So PILCROW SIGN
+00B6 ; Pattern_Syntax # Po PILCROW SIGN
00BB ; Pattern_Syntax # Pf RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK
00BF ; Pattern_Syntax # Po INVERTED QUESTION MARK
00D7 ; Pattern_Syntax # Sm MULTIPLICATION SIGN
@@ -1173,11 +1257,7 @@
27C0..27C4 ; Pattern_Syntax # Sm [5] THREE DIMENSIONAL ANGLE..OPEN SUPERSET
27C5 ; Pattern_Syntax # Ps LEFT S-SHAPED BAG DELIMITER
27C6 ; Pattern_Syntax # Pe RIGHT S-SHAPED BAG DELIMITER
-27C7..27CA ; Pattern_Syntax # Sm [4] OR WITH DOT INSIDE..VERTICAL BAR WITH HORIZONTAL STROKE
-27CB ; Pattern_Syntax # Cn <reserved-27CB>
-27CC ; Pattern_Syntax # Sm LONG DIVISION
-27CD ; Pattern_Syntax # Cn <reserved-27CD>
-27CE..27E5 ; Pattern_Syntax # Sm [24] SQUARED LOGICAL AND..WHITE SQUARE WITH RIGHTWARDS TICK
+27C7..27E5 ; Pattern_Syntax # Sm [31] OR WITH DOT INSIDE..WHITE SQUARE WITH RIGHTWARDS TICK
27E6 ; Pattern_Syntax # Ps MATHEMATICAL LEFT WHITE SQUARE BRACKET
27E7 ; Pattern_Syntax # Pe MATHEMATICAL RIGHT WHITE SQUARE BRACKET
27E8 ; Pattern_Syntax # Ps MATHEMATICAL LEFT ANGLE BRACKET
@@ -1260,8 +1340,9 @@
2E29 ; Pattern_Syntax # Pe RIGHT DOUBLE PARENTHESIS
2E2A..2E2E ; Pattern_Syntax # Po [5] TWO DOTS OVER ONE DOT PUNCTUATION..REVERSED QUESTION MARK
2E2F ; Pattern_Syntax # Lm VERTICAL TILDE
-2E30..2E31 ; Pattern_Syntax # Po [2] RING POINT..WORD SEPARATOR MIDDLE DOT
-2E32..2E7F ; Pattern_Syntax # Cn [78] <reserved-2E32>..<reserved-2E7F>
+2E30..2E39 ; Pattern_Syntax # Po [10] RING POINT..TOP HALF SECTION SIGN
+2E3A..2E3B ; Pattern_Syntax # Pd [2] TWO-EM DASH..THREE-EM DASH
+2E3C..2E7F ; Pattern_Syntax # Cn [68] <reserved-2E3C>..<reserved-2E7F>
3001..3003 ; Pattern_Syntax # Po [3] IDEOGRAPHIC COMMA..DITTO MARK
3008 ; Pattern_Syntax # Ps LEFT ANGLE BRACKET
3009 ; Pattern_Syntax # Pe RIGHT ANGLE BRACKET
Property changes on: trunk/contrib/perl/lib/unicore/PropList.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/PropValueAliases.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/PropValueAliases.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/PropValueAliases.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,8 +1,8 @@
-# PropertyValueAliases-6.0.0.txt
-# Date: 2010-07-17, 22:44:06 GMT [MD]
+# PropertyValueAliases-6.2.0.txt
+# Date: 2012-08-14, 16:05:11 GMT [MD]
#
# Unicode Character Database
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
# For documentation, see http://www.unicode.org/reports/tr44/
#
@@ -9,7 +9,6 @@
# This file contains aliases for property values used in the UCD.
# These names can be used for XML formats of UCD data, for regular-expression
# property tests, and other programmatic textual descriptions of Unicode data.
-# For information on which properties are normative, see UCD.html.
#
# The names may be translated in appropriate environments, and additional
# aliases may be useful.
@@ -23,7 +22,6 @@
# property value name is used.
#
# Second Field: The second field is an abbreviated name.
-# If there is no abbreviated name available, the field is marked with "n/a".
#
# Third Field: The third field is a long name.
#
@@ -35,7 +33,7 @@
# Loose matching should be applied to all property names and property values, with
# the exception of String Property values. With loose matching of property names and
# values, the case distinctions, whitespace, and '_' are ignored. For Numeric Property
-# values, numeric equivalences are applied: thus "01.00" is equivalent to "1".
+# values, numeric equivalencies are applied: thus "01.00" is equivalent to "1".
#
# NOTE: Property value names are NOT unique across properties. For example:
#
@@ -57,61 +55,63 @@
# ASCII_Hex_Digit (AHex)
-AHex; N ; No ; F ; False
-AHex; Y ; Yes ; T ; True
+AHex; N ; No ; F ; False
+AHex; Y ; Yes ; T ; True
# Age (age)
-age; n/a ; 1.1
-age; n/a ; 2.0
-age; n/a ; 2.1
-age; n/a ; 3.0
-age; n/a ; 3.1
-age; n/a ; 3.2
-age; n/a ; 4.0
-age; n/a ; 4.1
-age; n/a ; 5.0
-age; n/a ; 5.1
-age; n/a ; 5.2
-age; n/a ; 6.0
-age; n/a ; unassigned
+age; 1.1 ; V1_1
+age; 2.0 ; V2_0
+age; 2.1 ; V2_1
+age; 3.0 ; V3_0
+age; 3.1 ; V3_1
+age; 3.2 ; V3_2
+age; 4.0 ; V4_0
+age; 4.1 ; V4_1
+age; 5.0 ; V5_0
+age; 5.1 ; V5_1
+age; 5.2 ; V5_2
+age; 6.0 ; V6_0
+age; 6.1 ; V6_1
+age; 6.2 ; V6_2
+age; NA ; Unassigned
# Alphabetic (Alpha)
-Alpha; N ; No ; F ; False
-Alpha; Y ; Yes ; T ; True
+Alpha; N ; No ; F ; False
+Alpha; Y ; Yes ; T ; True
# Bidi_Class (bc)
-bc ; AL ; Arabic_Letter
-bc ; AN ; Arabic_Number
-bc ; B ; Paragraph_Separator
-bc ; BN ; Boundary_Neutral
-bc ; CS ; Common_Separator
-bc ; EN ; European_Number
-bc ; ES ; European_Separator
-bc ; ET ; European_Terminator
-bc ; L ; Left_To_Right
-bc ; LRE ; Left_To_Right_Embedding
-bc ; LRO ; Left_To_Right_Override
-bc ; NSM ; Nonspacing_Mark
-bc ; ON ; Other_Neutral
-bc ; PDF ; Pop_Directional_Format
-bc ; R ; Right_To_Left
-bc ; RLE ; Right_To_Left_Embedding
-bc ; RLO ; Right_To_Left_Override
-bc ; S ; Segment_Separator
-bc ; WS ; White_Space
+bc ; AL ; Arabic_Letter
+bc ; AN ; Arabic_Number
+bc ; B ; Paragraph_Separator
+bc ; BN ; Boundary_Neutral
+bc ; CS ; Common_Separator
+bc ; EN ; European_Number
+bc ; ES ; European_Separator
+bc ; ET ; European_Terminator
+bc ; L ; Left_To_Right
+bc ; LRE ; Left_To_Right_Embedding
+bc ; LRO ; Left_To_Right_Override
+bc ; NSM ; Nonspacing_Mark
+bc ; ON ; Other_Neutral
+bc ; PDF ; Pop_Directional_Format
+bc ; R ; Right_To_Left
+bc ; RLE ; Right_To_Left_Embedding
+bc ; RLO ; Right_To_Left_Override
+bc ; S ; Segment_Separator
+bc ; WS ; White_Space
# Bidi_Control (Bidi_C)
-Bidi_C; N ; No ; F ; False
-Bidi_C; Y ; Yes ; T ; True
+Bidi_C; N ; No ; F ; False
+Bidi_C; Y ; Yes ; T ; True
# Bidi_Mirrored (Bidi_M)
-Bidi_M; N ; No ; F ; False
-Bidi_M; Y ; Yes ; T ; True
+Bidi_M; N ; No ; F ; False
+Bidi_M; Y ; Yes ; T ; True
# Bidi_Mirroring_Glyph (bmg)
@@ -119,239 +119,287 @@
# Block (blk)
-blk; n/a ; Aegean_Numbers
-blk; n/a ; Alchemical_Symbols
-blk; n/a ; Alphabetic_Presentation_Forms
-blk; n/a ; Ancient_Greek_Musical_Notation
-blk; n/a ; Ancient_Greek_Numbers
-blk; n/a ; Ancient_Symbols
-blk; n/a ; Arabic
-blk; n/a ; Arabic_Presentation_Forms_A ; Arabic_Presentation_Forms-A
-blk; n/a ; Arabic_Presentation_Forms_B
-blk; n/a ; Arabic_Supplement
-blk; n/a ; Armenian
-blk; n/a ; Arrows
-blk; n/a ; Avestan
-blk; n/a ; Balinese
-blk; n/a ; Bamum
-blk; n/a ; Bamum_Supplement
-blk; n/a ; Basic_Latin ; ASCII
-blk; n/a ; Batak
-blk; n/a ; Bengali
-blk; n/a ; Block_Elements
-blk; n/a ; Bopomofo
-blk; n/a ; Bopomofo_Extended
-blk; n/a ; Box_Drawing
-blk; n/a ; Brahmi
-blk; n/a ; Braille_Patterns
-blk; n/a ; Buginese
-blk; n/a ; Buhid
-blk; n/a ; Byzantine_Musical_Symbols
-blk; n/a ; Carian
-blk; n/a ; Cham
-blk; n/a ; Cherokee
-blk; n/a ; CJK_Compatibility
-blk; n/a ; CJK_Compatibility_Forms
-blk; n/a ; CJK_Compatibility_Ideographs
-blk; n/a ; CJK_Compatibility_Ideographs_Supplement
-blk; n/a ; CJK_Radicals_Supplement
-blk; n/a ; CJK_Strokes
-blk; n/a ; CJK_Symbols_And_Punctuation
-blk; n/a ; CJK_Unified_Ideographs
-blk; n/a ; CJK_Unified_Ideographs_Extension_A
-blk; n/a ; CJK_Unified_Ideographs_Extension_B
-blk; n/a ; CJK_Unified_Ideographs_Extension_C
-blk; n/a ; CJK_Unified_Ideographs_Extension_D
-blk; n/a ; Combining_Diacritical_Marks
-blk; n/a ; Combining_Diacritical_Marks_For_Symbols; Combining_Marks_For_Symbols
-blk; n/a ; Combining_Diacritical_Marks_Supplement
-blk; n/a ; Combining_Half_Marks
-blk; n/a ; Common_Indic_Number_Forms
-blk; n/a ; Control_Pictures
-blk; n/a ; Coptic
-blk; n/a ; Counting_Rod_Numerals
-blk; n/a ; Cuneiform
-blk; n/a ; Cuneiform_Numbers_And_Punctuation
-blk; n/a ; Currency_Symbols
-blk; n/a ; Cypriot_Syllabary
-blk; n/a ; Cyrillic
-blk; n/a ; Cyrillic_Extended_A
-blk; n/a ; Cyrillic_Extended_B
-blk; n/a ; Cyrillic_Supplement ; Cyrillic_Supplementary
-blk; n/a ; Deseret
-blk; n/a ; Devanagari
-blk; n/a ; Devanagari_Extended
-blk; n/a ; Dingbats
-blk; n/a ; Domino_Tiles
-blk; n/a ; Egyptian_Hieroglyphs
-blk; n/a ; Emoticons
-blk; n/a ; Enclosed_Alphanumeric_Supplement
-blk; n/a ; Enclosed_Alphanumerics
-blk; n/a ; Enclosed_CJK_Letters_And_Months
-blk; n/a ; Enclosed_Ideographic_Supplement
-blk; n/a ; Ethiopic
-blk; n/a ; Ethiopic_Extended
-blk; n/a ; Ethiopic_Extended_A
-blk; n/a ; Ethiopic_Supplement
-blk; n/a ; General_Punctuation
-blk; n/a ; Geometric_Shapes
-blk; n/a ; Georgian
-blk; n/a ; Georgian_Supplement
-blk; n/a ; Glagolitic
-blk; n/a ; Gothic
-blk; n/a ; Greek_And_Coptic ; Greek
-blk; n/a ; Greek_Extended
-blk; n/a ; Gujarati
-blk; n/a ; Gurmukhi
-blk; n/a ; Halfwidth_And_Fullwidth_Forms
-blk; n/a ; Hangul_Compatibility_Jamo
-blk; n/a ; Hangul_Jamo
-blk; n/a ; Hangul_Jamo_Extended_A
-blk; n/a ; Hangul_Jamo_Extended_B
-blk; n/a ; Hangul_Syllables
-blk; n/a ; Hanunoo
-blk; n/a ; Hebrew
-blk; n/a ; High_Private_Use_Surrogates
-blk; n/a ; High_Surrogates
-blk; n/a ; Hiragana
-blk; n/a ; Ideographic_Description_Characters
-blk; n/a ; Imperial_Aramaic
-blk; n/a ; Inscriptional_Pahlavi
-blk; n/a ; Inscriptional_Parthian
-blk; n/a ; IPA_Extensions
-blk; n/a ; Javanese
-blk; n/a ; Kaithi
-blk; n/a ; Kana_Supplement
-blk; n/a ; Kanbun
-blk; n/a ; Kangxi_Radicals
-blk; n/a ; Kannada
-blk; n/a ; Katakana
-blk; n/a ; Katakana_Phonetic_Extensions
-blk; n/a ; Kayah_Li
-blk; n/a ; Kharoshthi
-blk; n/a ; Khmer
-blk; n/a ; Khmer_Symbols
-blk; n/a ; Lao
-blk; n/a ; Latin_1_Supplement ; Latin_1
-blk; n/a ; Latin_Extended_A
-blk; n/a ; Latin_Extended_Additional
-blk; n/a ; Latin_Extended_B
-blk; n/a ; Latin_Extended_C
-blk; n/a ; Latin_Extended_D
-blk; n/a ; Lepcha
-blk; n/a ; Letterlike_Symbols
-blk; n/a ; Limbu
-blk; n/a ; Linear_B_Ideograms
-blk; n/a ; Linear_B_Syllabary
-blk; n/a ; Lisu
-blk; n/a ; Low_Surrogates
-blk; n/a ; Lycian
-blk; n/a ; Lydian
-blk; n/a ; Mahjong_Tiles
-blk; n/a ; Malayalam
-blk; n/a ; Mandaic
-blk; n/a ; Mathematical_Alphanumeric_Symbols
-blk; n/a ; Mathematical_Operators
-blk; n/a ; Meetei_Mayek
-blk; n/a ; Miscellaneous_Mathematical_Symbols_A
-blk; n/a ; Miscellaneous_Mathematical_Symbols_B
-blk; n/a ; Miscellaneous_Symbols
-blk; n/a ; Miscellaneous_Symbols_And_Arrows
-blk; n/a ; Miscellaneous_Symbols_And_Pictographs
-blk; n/a ; Miscellaneous_Technical
-blk; n/a ; Modifier_Tone_Letters
-blk; n/a ; Mongolian
-blk; n/a ; Musical_Symbols
-blk; n/a ; Myanmar
-blk; n/a ; Myanmar_Extended_A
-blk; n/a ; New_Tai_Lue
-blk; n/a ; NKo
-blk; n/a ; No_Block
-blk; n/a ; Number_Forms
-blk; n/a ; Ogham
-blk; n/a ; Ol_Chiki
-blk; n/a ; Old_Italic
-blk; n/a ; Old_Persian
-blk; n/a ; Old_South_Arabian
-blk; n/a ; Old_Turkic
-blk; n/a ; Optical_Character_Recognition
-blk; n/a ; Oriya
-blk; n/a ; Osmanya
-blk; n/a ; Phags_Pa
-blk; n/a ; Phaistos_Disc
-blk; n/a ; Phoenician
-blk; n/a ; Phonetic_Extensions
-blk; n/a ; Phonetic_Extensions_Supplement
-blk; n/a ; Playing_Cards
-blk; n/a ; Private_Use_Area ; Private_Use
-blk; n/a ; Rejang
-blk; n/a ; Rumi_Numeral_Symbols
-blk; n/a ; Runic
-blk; n/a ; Samaritan
-blk; n/a ; Saurashtra
-blk; n/a ; Shavian
-blk; n/a ; Sinhala
-blk; n/a ; Small_Form_Variants
-blk; n/a ; Spacing_Modifier_Letters
-blk; n/a ; Specials
-blk; n/a ; Sundanese
-blk; n/a ; Superscripts_And_Subscripts
-blk; n/a ; Supplemental_Arrows_A
-blk; n/a ; Supplemental_Arrows_B
-blk; n/a ; Supplemental_Mathematical_Operators
-blk; n/a ; Supplemental_Punctuation
-blk; n/a ; Supplementary_Private_Use_Area_A
-blk; n/a ; Supplementary_Private_Use_Area_B
-blk; n/a ; Syloti_Nagri
-blk; n/a ; Syriac
-blk; n/a ; Tagalog
-blk; n/a ; Tagbanwa
-blk; n/a ; Tags
-blk; n/a ; Tai_Le
-blk; n/a ; Tai_Tham
-blk; n/a ; Tai_Viet
-blk; n/a ; Tai_Xuan_Jing_Symbols
-blk; n/a ; Tamil
-blk; n/a ; Telugu
-blk; n/a ; Thaana
-blk; n/a ; Thai
-blk; n/a ; Tibetan
-blk; n/a ; Tifinagh
-blk; n/a ; Transport_And_Map_Symbols
-blk; n/a ; Ugaritic
-blk; n/a ; Unified_Canadian_Aboriginal_Syllabics; Canadian_Syllabics
-blk; n/a ; Unified_Canadian_Aboriginal_Syllabics_Extended
-blk; n/a ; Vai
-blk; n/a ; Variation_Selectors
-blk; n/a ; Variation_Selectors_Supplement
-blk; n/a ; Vedic_Extensions
-blk; n/a ; Vertical_Forms
-blk; n/a ; Yi_Radicals
-blk; n/a ; Yi_Syllables
-blk; n/a ; Yijing_Hexagram_Symbols
+blk; Aegean_Numbers ; Aegean_Numbers
+blk; Alchemical ; Alchemical_Symbols
+blk; Alphabetic_PF ; Alphabetic_Presentation_Forms
+blk; Ancient_Greek_Music ; Ancient_Greek_Musical_Notation
+blk; Ancient_Greek_Numbers ; Ancient_Greek_Numbers
+blk; Ancient_Symbols ; Ancient_Symbols
+blk; Arabic ; Arabic
+blk; Arabic_Ext_A ; Arabic_Extended_A
+blk; Arabic_Math ; Arabic_Mathematical_Alphabetic_Symbols
+blk; Arabic_PF_A ; Arabic_Presentation_Forms_A ; Arabic_Presentation_Forms-A
+blk; Arabic_PF_B ; Arabic_Presentation_Forms_B
+blk; Arabic_Sup ; Arabic_Supplement
+blk; Armenian ; Armenian
+blk; Arrows ; Arrows
+blk; ASCII ; Basic_Latin
+blk; Avestan ; Avestan
+blk; Balinese ; Balinese
+blk; Bamum ; Bamum
+blk; Bamum_Sup ; Bamum_Supplement
+blk; Batak ; Batak
+blk; Bengali ; Bengali
+blk; Block_Elements ; Block_Elements
+blk; Bopomofo ; Bopomofo
+blk; Bopomofo_Ext ; Bopomofo_Extended
+blk; Box_Drawing ; Box_Drawing
+blk; Brahmi ; Brahmi
+blk; Braille ; Braille_Patterns
+blk; Buginese ; Buginese
+blk; Buhid ; Buhid
+blk; Byzantine_Music ; Byzantine_Musical_Symbols
+blk; Carian ; Carian
+blk; Chakma ; Chakma
+blk; Cham ; Cham
+blk; Cherokee ; Cherokee
+blk; CJK ; CJK_Unified_Ideographs
+blk; CJK_Compat ; CJK_Compatibility
+blk; CJK_Compat_Forms ; CJK_Compatibility_Forms
+blk; CJK_Compat_Ideographs ; CJK_Compatibility_Ideographs
+blk; CJK_Compat_Ideographs_Sup ; CJK_Compatibility_Ideographs_Supplement
+blk; CJK_Ext_A ; CJK_Unified_Ideographs_Extension_A
+blk; CJK_Ext_B ; CJK_Unified_Ideographs_Extension_B
+blk; CJK_Ext_C ; CJK_Unified_Ideographs_Extension_C
+blk; CJK_Ext_D ; CJK_Unified_Ideographs_Extension_D
+blk; CJK_Radicals_Sup ; CJK_Radicals_Supplement
+blk; CJK_Strokes ; CJK_Strokes
+blk; CJK_Symbols ; CJK_Symbols_And_Punctuation
+blk; Compat_Jamo ; Hangul_Compatibility_Jamo
+blk; Control_Pictures ; Control_Pictures
+blk; Coptic ; Coptic
+blk; Counting_Rod ; Counting_Rod_Numerals
+blk; Cuneiform ; Cuneiform
+blk; Cuneiform_Numbers ; Cuneiform_Numbers_And_Punctuation
+blk; Currency_Symbols ; Currency_Symbols
+blk; Cypriot_Syllabary ; Cypriot_Syllabary
+blk; Cyrillic ; Cyrillic
+blk; Cyrillic_Ext_A ; Cyrillic_Extended_A
+blk; Cyrillic_Ext_B ; Cyrillic_Extended_B
+blk; Cyrillic_Sup ; Cyrillic_Supplement ; Cyrillic_Supplementary
+blk; Deseret ; Deseret
+blk; Devanagari ; Devanagari
+blk; Devanagari_Ext ; Devanagari_Extended
+blk; Diacriticals ; Combining_Diacritical_Marks
+blk; Diacriticals_For_Symbols ; Combining_Diacritical_Marks_For_Symbols; Combining_Marks_For_Symbols
+blk; Diacriticals_Sup ; Combining_Diacritical_Marks_Supplement
+blk; Dingbats ; Dingbats
+blk; Domino ; Domino_Tiles
+blk; Egyptian_Hieroglyphs ; Egyptian_Hieroglyphs
+blk; Emoticons ; Emoticons
+blk; Enclosed_Alphanum ; Enclosed_Alphanumerics
+blk; Enclosed_Alphanum_Sup ; Enclosed_Alphanumeric_Supplement
+blk; Enclosed_CJK ; Enclosed_CJK_Letters_And_Months
+blk; Enclosed_Ideographic_Sup ; Enclosed_Ideographic_Supplement
+blk; Ethiopic ; Ethiopic
+blk; Ethiopic_Ext ; Ethiopic_Extended
+blk; Ethiopic_Ext_A ; Ethiopic_Extended_A
+blk; Ethiopic_Sup ; Ethiopic_Supplement
+blk; Geometric_Shapes ; Geometric_Shapes
+blk; Georgian ; Georgian
+blk; Georgian_Sup ; Georgian_Supplement
+blk; Glagolitic ; Glagolitic
+blk; Gothic ; Gothic
+blk; Greek ; Greek_And_Coptic
+blk; Greek_Ext ; Greek_Extended
+blk; Gujarati ; Gujarati
+blk; Gurmukhi ; Gurmukhi
+blk; Half_And_Full_Forms ; Halfwidth_And_Fullwidth_Forms
+blk; Half_Marks ; Combining_Half_Marks
+blk; Hangul ; Hangul_Syllables
+blk; Hanunoo ; Hanunoo
+blk; Hebrew ; Hebrew
+blk; High_PU_Surrogates ; High_Private_Use_Surrogates
+blk; High_Surrogates ; High_Surrogates
+blk; Hiragana ; Hiragana
+blk; IDC ; Ideographic_Description_Characters
+blk; Imperial_Aramaic ; Imperial_Aramaic
+blk; Indic_Number_Forms ; Common_Indic_Number_Forms
+blk; Inscriptional_Pahlavi ; Inscriptional_Pahlavi
+blk; Inscriptional_Parthian ; Inscriptional_Parthian
+blk; IPA_Ext ; IPA_Extensions
+blk; Jamo ; Hangul_Jamo
+blk; Jamo_Ext_A ; Hangul_Jamo_Extended_A
+blk; Jamo_Ext_B ; Hangul_Jamo_Extended_B
+blk; Javanese ; Javanese
+blk; Kaithi ; Kaithi
+blk; Kana_Sup ; Kana_Supplement
+blk; Kanbun ; Kanbun
+blk; Kangxi ; Kangxi_Radicals
+blk; Kannada ; Kannada
+blk; Katakana ; Katakana
+blk; Katakana_Ext ; Katakana_Phonetic_Extensions
+blk; Kayah_Li ; Kayah_Li
+blk; Kharoshthi ; Kharoshthi
+blk; Khmer ; Khmer
+blk; Khmer_Symbols ; Khmer_Symbols
+blk; Lao ; Lao
+blk; Latin_1_Sup ; Latin_1_Supplement ; Latin_1
+blk; Latin_Ext_A ; Latin_Extended_A
+blk; Latin_Ext_Additional ; Latin_Extended_Additional
+blk; Latin_Ext_B ; Latin_Extended_B
+blk; Latin_Ext_C ; Latin_Extended_C
+blk; Latin_Ext_D ; Latin_Extended_D
+blk; Lepcha ; Lepcha
+blk; Letterlike_Symbols ; Letterlike_Symbols
+blk; Limbu ; Limbu
+blk; Linear_B_Ideograms ; Linear_B_Ideograms
+blk; Linear_B_Syllabary ; Linear_B_Syllabary
+blk; Lisu ; Lisu
+blk; Low_Surrogates ; Low_Surrogates
+blk; Lycian ; Lycian
+blk; Lydian ; Lydian
+blk; Mahjong ; Mahjong_Tiles
+blk; Malayalam ; Malayalam
+blk; Mandaic ; Mandaic
+blk; Math_Alphanum ; Mathematical_Alphanumeric_Symbols
+blk; Math_Operators ; Mathematical_Operators
+blk; Meetei_Mayek ; Meetei_Mayek
+blk; Meetei_Mayek_Ext ; Meetei_Mayek_Extensions
+blk; Meroitic_Cursive ; Meroitic_Cursive
+blk; Meroitic_Hieroglyphs ; Meroitic_Hieroglyphs
+blk; Miao ; Miao
+blk; Misc_Arrows ; Miscellaneous_Symbols_And_Arrows
+blk; Misc_Math_Symbols_A ; Miscellaneous_Mathematical_Symbols_A
+blk; Misc_Math_Symbols_B ; Miscellaneous_Mathematical_Symbols_B
+blk; Misc_Pictographs ; Miscellaneous_Symbols_And_Pictographs
+blk; Misc_Symbols ; Miscellaneous_Symbols
+blk; Misc_Technical ; Miscellaneous_Technical
+blk; Modifier_Letters ; Spacing_Modifier_Letters
+blk; Modifier_Tone_Letters ; Modifier_Tone_Letters
+blk; Mongolian ; Mongolian
+blk; Music ; Musical_Symbols
+blk; Myanmar ; Myanmar
+blk; Myanmar_Ext_A ; Myanmar_Extended_A
+blk; NB ; No_Block
+blk; New_Tai_Lue ; New_Tai_Lue
+blk; NKo ; NKo
+blk; Number_Forms ; Number_Forms
+blk; OCR ; Optical_Character_Recognition
+blk; Ogham ; Ogham
+blk; Ol_Chiki ; Ol_Chiki
+blk; Old_Italic ; Old_Italic
+blk; Old_Persian ; Old_Persian
+blk; Old_South_Arabian ; Old_South_Arabian
+blk; Old_Turkic ; Old_Turkic
+blk; Oriya ; Oriya
+blk; Osmanya ; Osmanya
+blk; Phags_Pa ; Phags_Pa
+blk; Phaistos ; Phaistos_Disc
+blk; Phoenician ; Phoenician
+blk; Phonetic_Ext ; Phonetic_Extensions
+blk; Phonetic_Ext_Sup ; Phonetic_Extensions_Supplement
+blk; Playing_Cards ; Playing_Cards
+blk; PUA ; Private_Use_Area ; Private_Use
+blk; Punctuation ; General_Punctuation
+blk; Rejang ; Rejang
+blk; Rumi ; Rumi_Numeral_Symbols
+blk; Runic ; Runic
+blk; Samaritan ; Samaritan
+blk; Saurashtra ; Saurashtra
+blk; Sharada ; Sharada
+blk; Shavian ; Shavian
+blk; Sinhala ; Sinhala
+blk; Small_Forms ; Small_Form_Variants
+blk; Sora_Sompeng ; Sora_Sompeng
+blk; Specials ; Specials
+blk; Sundanese ; Sundanese
+blk; Sundanese_Sup ; Sundanese_Supplement
+blk; Sup_Arrows_A ; Supplemental_Arrows_A
+blk; Sup_Arrows_B ; Supplemental_Arrows_B
+blk; Sup_Math_Operators ; Supplemental_Mathematical_Operators
+blk; Sup_PUA_A ; Supplementary_Private_Use_Area_A
+blk; Sup_PUA_B ; Supplementary_Private_Use_Area_B
+blk; Sup_Punctuation ; Supplemental_Punctuation
+blk; Super_And_Sub ; Superscripts_And_Subscripts
+blk; Syloti_Nagri ; Syloti_Nagri
+blk; Syriac ; Syriac
+blk; Tagalog ; Tagalog
+blk; Tagbanwa ; Tagbanwa
+blk; Tags ; Tags
+blk; Tai_Le ; Tai_Le
+blk; Tai_Tham ; Tai_Tham
+blk; Tai_Viet ; Tai_Viet
+blk; Tai_Xuan_Jing ; Tai_Xuan_Jing_Symbols
+blk; Takri ; Takri
+blk; Tamil ; Tamil
+blk; Telugu ; Telugu
+blk; Thaana ; Thaana
+blk; Thai ; Thai
+blk; Tibetan ; Tibetan
+blk; Tifinagh ; Tifinagh
+blk; Transport_And_Map ; Transport_And_Map_Symbols
+blk; UCAS ; Unified_Canadian_Aboriginal_Syllabics; Canadian_Syllabics
+blk; UCAS_Ext ; Unified_Canadian_Aboriginal_Syllabics_Extended
+blk; Ugaritic ; Ugaritic
+blk; Vai ; Vai
+blk; Vedic_Ext ; Vedic_Extensions
+blk; Vertical_Forms ; Vertical_Forms
+blk; VS ; Variation_Selectors
+blk; VS_Sup ; Variation_Selectors_Supplement
+blk; Yi_Radicals ; Yi_Radicals
+blk; Yi_Syllables ; Yi_Syllables
+blk; Yijing ; Yijing_Hexagram_Symbols
# Canonical_Combining_Class (ccc)
-ccc; 0; NR ; Not_Reordered
-ccc; 1; OV ; Overlay
-ccc; 7; NK ; Nukta
-ccc; 8; KV ; Kana_Voicing
-ccc; 9; VR ; Virama
-ccc; 200; ATBL ; Attached_Below_Left
-ccc; 202; ATB ; Attached_Below
-ccc; 214; ATA ; Attached_Above
-ccc; 216; ATAR ; Attached_Above_Right
-ccc; 218; BL ; Below_Left
-ccc; 220; B ; Below
-ccc; 222; BR ; Below_Right
-ccc; 224; L ; Left
-ccc; 226; R ; Right
-ccc; 228; AL ; Above_Left
-ccc; 230; A ; Above
-ccc; 232; AR ; Above_Right
-ccc; 233; DB ; Double_Below
-ccc; 234; DA ; Double_Above
-ccc; 240; IS ; Iota_Subscript
+ccc; 0; NR ; Not_Reordered
+ccc; 1; OV ; Overlay
+ccc; 7; NK ; Nukta
+ccc; 8; KV ; Kana_Voicing
+ccc; 9; VR ; Virama
+ccc; 10; CCC10 ; CCC10
+ccc; 11; CCC11 ; CCC11
+ccc; 12; CCC12 ; CCC12
+ccc; 13; CCC13 ; CCC13
+ccc; 14; CCC14 ; CCC14
+ccc; 15; CCC15 ; CCC15
+ccc; 16; CCC16 ; CCC16
+ccc; 17; CCC17 ; CCC17
+ccc; 18; CCC18 ; CCC18
+ccc; 19; CCC19 ; CCC19
+ccc; 20; CCC20 ; CCC20
+ccc; 21; CCC21 ; CCC21
+ccc; 22; CCC22 ; CCC22
+ccc; 23; CCC23 ; CCC23
+ccc; 24; CCC24 ; CCC24
+ccc; 25; CCC25 ; CCC25
+ccc; 26; CCC26 ; CCC26
+ccc; 27; CCC27 ; CCC27
+ccc; 28; CCC28 ; CCC28
+ccc; 29; CCC29 ; CCC29
+ccc; 30; CCC30 ; CCC30
+ccc; 31; CCC31 ; CCC31
+ccc; 32; CCC32 ; CCC32
+ccc; 33; CCC33 ; CCC33
+ccc; 34; CCC34 ; CCC34
+ccc; 35; CCC35 ; CCC35
+ccc; 36; CCC36 ; CCC36
+ccc; 84; CCC84 ; CCC84
+ccc; 91; CCC91 ; CCC91
+ccc; 103; CCC103 ; CCC103
+ccc; 107; CCC107 ; CCC107
+ccc; 118; CCC118 ; CCC118
+ccc; 122; CCC122 ; CCC122
+ccc; 129; CCC129 ; CCC129
+ccc; 130; CCC130 ; CCC130
+ccc; 132; CCC132 ; CCC132
+ccc; 133; CCC133 ; CCC133 # RESERVED
+ccc; 200; ATBL ; Attached_Below_Left
+ccc; 202; ATB ; Attached_Below
+ccc; 214; ATA ; Attached_Above
+ccc; 216; ATAR ; Attached_Above_Right
+ccc; 218; BL ; Below_Left
+ccc; 220; B ; Below
+ccc; 222; BR ; Below_Right
+ccc; 224; L ; Left
+ccc; 226; R ; Right
+ccc; 228; AL ; Above_Left
+ccc; 230; A ; Above
+ccc; 232; AR ; Above_Right
+ccc; 233; DB ; Double_Below
+ccc; 234; DA ; Double_Above
+ccc; 240; IS ; Iota_Subscript
# Case_Folding (cf)
@@ -359,53 +407,53 @@
# Case_Ignorable (CI)
-CI ; N ; No ; F ; False
-CI ; Y ; Yes ; T ; True
+CI ; N ; No ; F ; False
+CI ; Y ; Yes ; T ; True
# Cased (Cased)
-Cased; N ; No ; F ; False
-Cased; Y ; Yes ; T ; True
+Cased; N ; No ; F ; False
+Cased; Y ; Yes ; T ; True
# Changes_When_Casefolded (CWCF)
-CWCF; N ; No ; F ; False
-CWCF; Y ; Yes ; T ; True
+CWCF; N ; No ; F ; False
+CWCF; Y ; Yes ; T ; True
# Changes_When_Casemapped (CWCM)
-CWCM; N ; No ; F ; False
-CWCM; Y ; Yes ; T ; True
+CWCM; N ; No ; F ; False
+CWCM; Y ; Yes ; T ; True
# Changes_When_Lowercased (CWL)
-CWL; N ; No ; F ; False
-CWL; Y ; Yes ; T ; True
+CWL; N ; No ; F ; False
+CWL; Y ; Yes ; T ; True
# Changes_When_NFKC_Casefolded (CWKCF)
-CWKCF; N ; No ; F ; False
-CWKCF; Y ; Yes ; T ; True
+CWKCF; N ; No ; F ; False
+CWKCF; Y ; Yes ; T ; True
# Changes_When_Titlecased (CWT)
-CWT; N ; No ; F ; False
-CWT; Y ; Yes ; T ; True
+CWT; N ; No ; F ; False
+CWT; Y ; Yes ; T ; True
# Changes_When_Uppercased (CWU)
-CWU; N ; No ; F ; False
-CWU; Y ; Yes ; T ; True
+CWU; N ; No ; F ; False
+CWU; Y ; Yes ; T ; True
# Composition_Exclusion (CE)
-CE ; N ; No ; F ; False
-CE ; Y ; Yes ; T ; True
+CE ; N ; No ; F ; False
+CE ; Y ; Yes ; T ; True
# Dash (Dash)
-Dash; N ; No ; F ; False
-Dash; Y ; Yes ; T ; True
+Dash; N ; No ; F ; False
+Dash; Y ; Yes ; T ; True
# Decomposition_Mapping (dm)
@@ -413,73 +461,73 @@
# Decomposition_Type (dt)
-dt ; Can ; Canonical ; can
-dt ; Com ; Compat ; com
-dt ; Enc ; Circle ; enc
-dt ; Fin ; Final ; fin
-dt ; Font ; font
-dt ; Fra ; Fraction ; fra
-dt ; Init ; Initial ; init
-dt ; Iso ; Isolated ; iso
-dt ; Med ; Medial ; med
-dt ; Nar ; Narrow ; nar
-dt ; Nb ; Nobreak ; nb
-dt ; None ; none
-dt ; Sml ; Small ; sml
-dt ; Sqr ; Square ; sqr
-dt ; Sub ; sub
-dt ; Sup ; Super ; sup
-dt ; Vert ; Vertical ; vert
-dt ; Wide ; wide
+dt ; Can ; Canonical ; can
+dt ; Com ; Compat ; com
+dt ; Enc ; Circle ; enc
+dt ; Fin ; Final ; fin
+dt ; Font ; Font ; font
+dt ; Fra ; Fraction ; fra
+dt ; Init ; Initial ; init
+dt ; Iso ; Isolated ; iso
+dt ; Med ; Medial ; med
+dt ; Nar ; Narrow ; nar
+dt ; Nb ; Nobreak ; nb
+dt ; None ; None ; none
+dt ; Sml ; Small ; sml
+dt ; Sqr ; Square ; sqr
+dt ; Sub ; Sub ; sub
+dt ; Sup ; Super ; sup
+dt ; Vert ; Vertical ; vert
+dt ; Wide ; Wide ; wide
# Default_Ignorable_Code_Point (DI)
-DI ; N ; No ; F ; False
-DI ; Y ; Yes ; T ; True
+DI ; N ; No ; F ; False
+DI ; Y ; Yes ; T ; True
# Deprecated (Dep)
-Dep; N ; No ; F ; False
-Dep; Y ; Yes ; T ; True
+Dep; N ; No ; F ; False
+Dep; Y ; Yes ; T ; True
# Diacritic (Dia)
-Dia; N ; No ; F ; False
-Dia; Y ; Yes ; T ; True
+Dia; N ; No ; F ; False
+Dia; Y ; Yes ; T ; True
# East_Asian_Width (ea)
-ea ; A ; Ambiguous
-ea ; F ; Fullwidth
-ea ; H ; Halfwidth
-ea ; N ; Neutral
-ea ; Na ; Narrow
-ea ; W ; Wide
+ea ; A ; Ambiguous
+ea ; F ; Fullwidth
+ea ; H ; Halfwidth
+ea ; N ; Neutral
+ea ; Na ; Narrow
+ea ; W ; Wide
# Expands_On_NFC (XO_NFC)
-XO_NFC; N ; No ; F ; False
-XO_NFC; Y ; Yes ; T ; True
+XO_NFC; N ; No ; F ; False
+XO_NFC; Y ; Yes ; T ; True
# Expands_On_NFD (XO_NFD)
-XO_NFD; N ; No ; F ; False
-XO_NFD; Y ; Yes ; T ; True
+XO_NFD; N ; No ; F ; False
+XO_NFD; Y ; Yes ; T ; True
# Expands_On_NFKC (XO_NFKC)
-XO_NFKC; N ; No ; F ; False
-XO_NFKC; Y ; Yes ; T ; True
+XO_NFKC; N ; No ; F ; False
+XO_NFKC; Y ; Yes ; T ; True
# Expands_On_NFKD (XO_NFKD)
-XO_NFKD; N ; No ; F ; False
-XO_NFKD; Y ; Yes ; T ; True
+XO_NFKD; N ; No ; F ; False
+XO_NFKD; Y ; Yes ; T ; True
# Extender (Ext)
-Ext; N ; No ; F ; False
-Ext; Y ; Yes ; T ; True
+Ext; N ; No ; F ; False
+Ext; Y ; Yes ; T ; True
# FC_NFKC_Closure (FC_NFKC)
@@ -487,118 +535,119 @@
# Full_Composition_Exclusion (Comp_Ex)
-Comp_Ex; N ; No ; F ; False
-Comp_Ex; Y ; Yes ; T ; True
+Comp_Ex; N ; No ; F ; False
+Comp_Ex; Y ; Yes ; T ; True
# General_Category (gc)
-gc ; C ; Other # Cc | Cf | Cn | Co | Cs
-gc ; Cc ; Control ; cntrl
-gc ; Cf ; Format
-gc ; Cn ; Unassigned
-gc ; Co ; Private_Use
-gc ; Cs ; Surrogate
-gc ; L ; Letter # Ll | Lm | Lo | Lt | Lu
-gc ; LC ; Cased_Letter # Ll | Lt | Lu
-gc ; Ll ; Lowercase_Letter
-gc ; Lm ; Modifier_Letter
-gc ; Lo ; Other_Letter
-gc ; Lt ; Titlecase_Letter
-gc ; Lu ; Uppercase_Letter
-gc ; M ; Mark # Mc | Me | Mn
-gc ; Mc ; Spacing_Mark
-gc ; Me ; Enclosing_Mark
-gc ; Mn ; Nonspacing_Mark
-gc ; N ; Number # Nd | Nl | No
-gc ; Nd ; Decimal_Number ; digit
-gc ; Nl ; Letter_Number
-gc ; No ; Other_Number
-gc ; P ; Punctuation ; punct # Pc | Pd | Pe | Pf | Pi | Po | Ps
-gc ; Pc ; Connector_Punctuation
-gc ; Pd ; Dash_Punctuation
-gc ; Pe ; Close_Punctuation
-gc ; Pf ; Final_Punctuation
-gc ; Pi ; Initial_Punctuation
-gc ; Po ; Other_Punctuation
-gc ; Ps ; Open_Punctuation
-gc ; S ; Symbol # Sc | Sk | Sm | So
-gc ; Sc ; Currency_Symbol
-gc ; Sk ; Modifier_Symbol
-gc ; Sm ; Math_Symbol
-gc ; So ; Other_Symbol
-gc ; Z ; Separator # Zl | Zp | Zs
-gc ; Zl ; Line_Separator
-gc ; Zp ; Paragraph_Separator
-gc ; Zs ; Space_Separator
+gc ; C ; Other # Cc | Cf | Cn | Co | Cs
+gc ; Cc ; Control ; cntrl
+gc ; Cf ; Format
+gc ; Cn ; Unassigned
+gc ; Co ; Private_Use
+gc ; Cs ; Surrogate
+gc ; L ; Letter # Ll | Lm | Lo | Lt | Lu
+gc ; LC ; Cased_Letter # Ll | Lt | Lu
+gc ; Ll ; Lowercase_Letter
+gc ; Lm ; Modifier_Letter
+gc ; Lo ; Other_Letter
+gc ; Lt ; Titlecase_Letter
+gc ; Lu ; Uppercase_Letter
+gc ; M ; Mark ; Combining_Mark # Mc | Me | Mn
+gc ; Mc ; Spacing_Mark
+gc ; Me ; Enclosing_Mark
+gc ; Mn ; Nonspacing_Mark
+gc ; N ; Number # Nd | Nl | No
+gc ; Nd ; Decimal_Number ; digit
+gc ; Nl ; Letter_Number
+gc ; No ; Other_Number
+gc ; P ; Punctuation ; punct # Pc | Pd | Pe | Pf | Pi | Po | Ps
+gc ; Pc ; Connector_Punctuation
+gc ; Pd ; Dash_Punctuation
+gc ; Pe ; Close_Punctuation
+gc ; Pf ; Final_Punctuation
+gc ; Pi ; Initial_Punctuation
+gc ; Po ; Other_Punctuation
+gc ; Ps ; Open_Punctuation
+gc ; S ; Symbol # Sc | Sk | Sm | So
+gc ; Sc ; Currency_Symbol
+gc ; Sk ; Modifier_Symbol
+gc ; Sm ; Math_Symbol
+gc ; So ; Other_Symbol
+gc ; Z ; Separator # Zl | Zp | Zs
+gc ; Zl ; Line_Separator
+gc ; Zp ; Paragraph_Separator
+gc ; Zs ; Space_Separator
# Grapheme_Base (Gr_Base)
-Gr_Base; N ; No ; F ; False
-Gr_Base; Y ; Yes ; T ; True
+Gr_Base; N ; No ; F ; False
+Gr_Base; Y ; Yes ; T ; True
# Grapheme_Cluster_Break (GCB)
-GCB; CN ; Control
-GCB; CR ; CR
-GCB; EX ; Extend
-GCB; L ; L
-GCB; LF ; LF
-GCB; LV ; LV
-GCB; LVT ; LVT
-GCB; PP ; Prepend
-GCB; SM ; SpacingMark
-GCB; T ; T
-GCB; V ; V
-GCB; XX ; Other
+GCB; CN ; Control
+GCB; CR ; CR
+GCB; EX ; Extend
+GCB; L ; L
+GCB; LF ; LF
+GCB; LV ; LV
+GCB; LVT ; LVT
+GCB; PP ; Prepend
+GCB; RI ; Regional_Indicator
+GCB; SM ; SpacingMark
+GCB; T ; T
+GCB; V ; V
+GCB; XX ; Other
# Grapheme_Extend (Gr_Ext)
-Gr_Ext; N ; No ; F ; False
-Gr_Ext; Y ; Yes ; T ; True
+Gr_Ext; N ; No ; F ; False
+Gr_Ext; Y ; Yes ; T ; True
# Grapheme_Link (Gr_Link)
-Gr_Link; N ; No ; F ; False
-Gr_Link; Y ; Yes ; T ; True
+Gr_Link; N ; No ; F ; False
+Gr_Link; Y ; Yes ; T ; True
# Hangul_Syllable_Type (hst)
-hst; L ; Leading_Jamo
-hst; LV ; LV_Syllable
-hst; LVT ; LVT_Syllable
-hst; NA ; Not_Applicable
-hst; T ; Trailing_Jamo
-hst; V ; Vowel_Jamo
+hst; L ; Leading_Jamo
+hst; LV ; LV_Syllable
+hst; LVT ; LVT_Syllable
+hst; NA ; Not_Applicable
+hst; T ; Trailing_Jamo
+hst; V ; Vowel_Jamo
# Hex_Digit (Hex)
-Hex; N ; No ; F ; False
-Hex; Y ; Yes ; T ; True
+Hex; N ; No ; F ; False
+Hex; Y ; Yes ; T ; True
# Hyphen (Hyphen)
-Hyphen; N ; No ; F ; False
-Hyphen; Y ; Yes ; T ; True
+Hyphen; N ; No ; F ; False
+Hyphen; Y ; Yes ; T ; True
# IDS_Binary_Operator (IDSB)
-IDSB; N ; No ; F ; False
-IDSB; Y ; Yes ; T ; True
+IDSB; N ; No ; F ; False
+IDSB; Y ; Yes ; T ; True
# IDS_Trinary_Operator (IDST)
-IDST; N ; No ; F ; False
-IDST; Y ; Yes ; T ; True
+IDST; N ; No ; F ; False
+IDST; Y ; Yes ; T ; True
# ID_Continue (IDC)
-IDC; N ; No ; F ; False
-IDC; Y ; Yes ; T ; True
+IDC; N ; No ; F ; False
+IDC; Y ; Yes ; T ; True
# ID_Start (IDS)
-IDS; N ; No ; F ; False
-IDS; Y ; Yes ; T ; True
+IDS; N ; No ; F ; False
+IDS; Y ; Yes ; T ; True
# ISO_Comment (isc)
@@ -606,208 +655,250 @@
# Ideographic (Ideo)
-Ideo; N ; No ; F ; False
-Ideo; Y ; Yes ; T ; True
+Ideo; N ; No ; F ; False
+Ideo; Y ; Yes ; T ; True
+# Indic_Matra_Category (InMC)
+
+InMC; Bottom ; Bottom
+InMC; Bottom_And_Right ; Bottom_And_Right
+InMC; Invisible ; Invisible
+InMC; Left ; Left
+InMC; Left_And_Right ; Left_And_Right
+InMC; NA ; NA
+InMC; Overstruck ; Overstruck
+InMC; Right ; Right
+InMC; Top ; Top
+InMC; Top_And_Bottom ; Top_And_Bottom
+InMC; Top_And_Bottom_And_Right ; Top_And_Bottom_And_Right
+InMC; Top_And_Left ; Top_And_Left
+InMC; Top_And_Left_And_Right ; Top_And_Left_And_Right
+InMC; Top_And_Right ; Top_And_Right
+InMC; Visual_Order_Left ; Visual_Order_Left
+
+# Indic_Syllabic_Category (InSC)
+
+InSC; Avagraha ; Avagraha
+InSC; Bindu ; Bindu
+InSC; Consonant ; Consonant
+InSC; Consonant_Dead ; Consonant_Dead
+InSC; Consonant_Final ; Consonant_Final
+InSC; Consonant_Head_Letter ; Consonant_Head_Letter
+InSC; Consonant_Medial ; Consonant_Medial
+InSC; Consonant_Placeholder ; Consonant_Placeholder
+InSC; Consonant_Repha ; Consonant_Repha
+InSC; Consonant_Subjoined ; Consonant_Subjoined
+InSC; Modifying_Letter ; Modifying_Letter
+InSC; Nukta ; Nukta
+InSC; Other ; Other
+InSC; Register_Shifter ; Register_Shifter
+InSC; Tone_Letter ; Tone_Letter
+InSC; Tone_Mark ; Tone_Mark
+InSC; Virama ; Virama
+InSC; Visarga ; Visarga
+InSC; Vowel ; Vowel
+InSC; Vowel_Dependent ; Vowel_Dependent
+InSC; Vowel_Independent ; Vowel_Independent
+
# Jamo_Short_Name (JSN)
# @missing: 0000..10FFFF; Jamo_Short_Name; <none>
-JSN; A ; A
-JSN; AE ; AE
-JSN; B ; B
-JSN; BB ; BB
-JSN; BS ; BS
-JSN; C ; C
-JSN; D ; D
-JSN; DD ; DD
-JSN; E ; E
-JSN; EO ; EO
-JSN; EU ; EU
-JSN; G ; G
-JSN; GG ; GG
-JSN; GS ; GS
-JSN; H ; H
-JSN; I ; I
-JSN; J ; J
-JSN; JJ ; JJ
-JSN; K ; K
-JSN; L ; L
-JSN; LB ; LB
-JSN; LG ; LG
-JSN; LH ; LH
-JSN; LM ; LM
-JSN; LP ; LP
-JSN; LS ; LS
-JSN; LT ; LT
-JSN; M ; M
-JSN; N ; N
-JSN; NG ; NG
-JSN; NH ; NH
-JSN; NJ ; NJ
-JSN; O ; O
-JSN; OE ; OE
-JSN; P ; P
-JSN; R ; R
-JSN; S ; S
-JSN; SS ; SS
-JSN; T ; T
-JSN; U ; U
-JSN; WA ; WA
-JSN; WAE ; WAE
-JSN; WE ; WE
-JSN; WEO ; WEO
-JSN; WI ; WI
-JSN; YA ; YA
-JSN; YAE ; YAE
-JSN; YE ; YE
-JSN; YEO ; YEO
-JSN; YI ; YI
-JSN; YO ; YO
-JSN; YU ; YU
+JSN; A ; A
+JSN; AE ; AE
+JSN; B ; B
+JSN; BB ; BB
+JSN; BS ; BS
+JSN; C ; C
+JSN; D ; D
+JSN; DD ; DD
+JSN; E ; E
+JSN; EO ; EO
+JSN; EU ; EU
+JSN; G ; G
+JSN; GG ; GG
+JSN; GS ; GS
+JSN; H ; H
+JSN; I ; I
+JSN; J ; J
+JSN; JJ ; JJ
+JSN; K ; K
+JSN; L ; L
+JSN; LB ; LB
+JSN; LG ; LG
+JSN; LH ; LH
+JSN; LM ; LM
+JSN; LP ; LP
+JSN; LS ; LS
+JSN; LT ; LT
+JSN; M ; M
+JSN; N ; N
+JSN; NG ; NG
+JSN; NH ; NH
+JSN; NJ ; NJ
+JSN; O ; O
+JSN; OE ; OE
+JSN; P ; P
+JSN; R ; R
+JSN; S ; S
+JSN; SS ; SS
+JSN; T ; T
+JSN; U ; U
+JSN; WA ; WA
+JSN; WAE ; WAE
+JSN; WE ; WE
+JSN; WEO ; WEO
+JSN; WI ; WI
+JSN; YA ; YA
+JSN; YAE ; YAE
+JSN; YE ; YE
+JSN; YEO ; YEO
+JSN; YI ; YI
+JSN; YO ; YO
+JSN; YU ; YU
# Join_Control (Join_C)
-Join_C; N ; No ; F ; False
-Join_C; Y ; Yes ; T ; True
+Join_C; N ; No ; F ; False
+Join_C; Y ; Yes ; T ; True
# Joining_Group (jg)
-jg ; n/a ; Ain
-jg ; n/a ; Alaph
-jg ; n/a ; Alef
-jg ; n/a ; Beh
-jg ; n/a ; Beth
-jg ; n/a ; Burushaski_Yeh_Barree
-jg ; n/a ; Dal
-jg ; n/a ; Dalath_Rish
-jg ; n/a ; E
-jg ; n/a ; Farsi_Yeh
-jg ; n/a ; Fe
-jg ; n/a ; Feh
-jg ; n/a ; Final_Semkath
-jg ; n/a ; Gaf
-jg ; n/a ; Gamal
-jg ; n/a ; Hah
-jg ; n/a ; He
-jg ; n/a ; Heh
-jg ; n/a ; Heh_Goal
-jg ; n/a ; Heth
-jg ; n/a ; Kaf
-jg ; n/a ; Kaph
-jg ; n/a ; Khaph
-jg ; n/a ; Knotted_Heh
-jg ; n/a ; Lam
-jg ; n/a ; Lamadh
-jg ; n/a ; Meem
-jg ; n/a ; Mim
-jg ; n/a ; No_Joining_Group
-jg ; n/a ; Noon
-jg ; n/a ; Nun
-jg ; n/a ; Nya
-jg ; n/a ; Pe
-jg ; n/a ; Qaf
-jg ; n/a ; Qaph
-jg ; n/a ; Reh
-jg ; n/a ; Reversed_Pe
-jg ; n/a ; Sad
-jg ; n/a ; Sadhe
-jg ; n/a ; Seen
-jg ; n/a ; Semkath
-jg ; n/a ; Shin
-jg ; n/a ; Swash_Kaf
-jg ; n/a ; Syriac_Waw
-jg ; n/a ; Tah
-jg ; n/a ; Taw
-jg ; n/a ; Teh_Marbuta
-jg ; n/a ; Teh_Marbuta_Goal ; Hamza_On_Heh_Goal
-jg ; n/a ; Teth
-jg ; n/a ; Waw
-jg ; n/a ; Yeh
-jg ; n/a ; Yeh_Barree
-jg ; n/a ; Yeh_With_Tail
-jg ; n/a ; Yudh
-jg ; n/a ; Yudh_He
-jg ; n/a ; Zain
-jg ; n/a ; Zhain
+jg ; Ain ; Ain
+jg ; Alaph ; Alaph
+jg ; Alef ; Alef
+jg ; Beh ; Beh
+jg ; Beth ; Beth
+jg ; Burushaski_Yeh_Barree ; Burushaski_Yeh_Barree
+jg ; Dal ; Dal
+jg ; Dalath_Rish ; Dalath_Rish
+jg ; E ; E
+jg ; Farsi_Yeh ; Farsi_Yeh
+jg ; Fe ; Fe
+jg ; Feh ; Feh
+jg ; Final_Semkath ; Final_Semkath
+jg ; Gaf ; Gaf
+jg ; Gamal ; Gamal
+jg ; Hah ; Hah
+jg ; He ; He
+jg ; Heh ; Heh
+jg ; Heh_Goal ; Heh_Goal
+jg ; Heth ; Heth
+jg ; Kaf ; Kaf
+jg ; Kaph ; Kaph
+jg ; Khaph ; Khaph
+jg ; Knotted_Heh ; Knotted_Heh
+jg ; Lam ; Lam
+jg ; Lamadh ; Lamadh
+jg ; Meem ; Meem
+jg ; Mim ; Mim
+jg ; No_Joining_Group ; No_Joining_Group
+jg ; Noon ; Noon
+jg ; Nun ; Nun
+jg ; Nya ; Nya
+jg ; Pe ; Pe
+jg ; Qaf ; Qaf
+jg ; Qaph ; Qaph
+jg ; Reh ; Reh
+jg ; Reversed_Pe ; Reversed_Pe
+jg ; Rohingya_Yeh ; Rohingya_Yeh
+jg ; Sad ; Sad
+jg ; Sadhe ; Sadhe
+jg ; Seen ; Seen
+jg ; Semkath ; Semkath
+jg ; Shin ; Shin
+jg ; Swash_Kaf ; Swash_Kaf
+jg ; Syriac_Waw ; Syriac_Waw
+jg ; Tah ; Tah
+jg ; Taw ; Taw
+jg ; Teh_Marbuta ; Teh_Marbuta
+jg ; Teh_Marbuta_Goal ; Hamza_On_Heh_Goal
+jg ; Teth ; Teth
+jg ; Waw ; Waw
+jg ; Yeh ; Yeh
+jg ; Yeh_Barree ; Yeh_Barree
+jg ; Yeh_With_Tail ; Yeh_With_Tail
+jg ; Yudh ; Yudh
+jg ; Yudh_He ; Yudh_He
+jg ; Zain ; Zain
+jg ; Zhain ; Zhain
# Joining_Type (jt)
-jt ; C ; Join_Causing
-jt ; D ; Dual_Joining
-jt ; L ; Left_Joining
-jt ; R ; Right_Joining
-jt ; T ; Transparent
-jt ; U ; Non_Joining
+jt ; C ; Join_Causing
+jt ; D ; Dual_Joining
+jt ; L ; Left_Joining
+jt ; R ; Right_Joining
+jt ; T ; Transparent
+jt ; U ; Non_Joining
# Line_Break (lb)
-lb ; AI ; Ambiguous
-lb ; AL ; Alphabetic
-lb ; B2 ; Break_Both
-lb ; BA ; Break_After
-lb ; BB ; Break_Before
-lb ; BK ; Mandatory_Break
-lb ; CB ; Contingent_Break
-lb ; CL ; Close_Punctuation
-lb ; CM ; Combining_Mark
-lb ; CP ; Close_Parenthesis
-lb ; CR ; Carriage_Return
-lb ; EX ; Exclamation
-lb ; GL ; Glue
-lb ; H2 ; H2
-lb ; H3 ; H3
-lb ; HY ; Hyphen
-lb ; ID ; Ideographic
-lb ; IN ; Inseparable ; Inseperable
-lb ; IS ; Infix_Numeric
-lb ; JL ; JL
-lb ; JT ; JT
-lb ; JV ; JV
-lb ; LF ; Line_Feed
-lb ; NL ; Next_Line
-lb ; NS ; Nonstarter
-lb ; NU ; Numeric
-lb ; OP ; Open_Punctuation
-lb ; PO ; Postfix_Numeric
-lb ; PR ; Prefix_Numeric
-lb ; QU ; Quotation
-lb ; SA ; Complex_Context
-lb ; SG ; Surrogate
-lb ; SP ; Space
-lb ; SY ; Break_Symbols
-lb ; WJ ; Word_Joiner
-lb ; XX ; Unknown
-lb ; ZW ; ZWSpace
+lb ; AI ; Ambiguous
+lb ; AL ; Alphabetic
+lb ; B2 ; Break_Both
+lb ; BA ; Break_After
+lb ; BB ; Break_Before
+lb ; BK ; Mandatory_Break
+lb ; CB ; Contingent_Break
+lb ; CJ ; Conditional_Japanese_Starter
+lb ; CL ; Close_Punctuation
+lb ; CM ; Combining_Mark
+lb ; CP ; Close_Parenthesis
+lb ; CR ; Carriage_Return
+lb ; EX ; Exclamation
+lb ; GL ; Glue
+lb ; H2 ; H2
+lb ; H3 ; H3
+lb ; HL ; Hebrew_Letter
+lb ; HY ; Hyphen
+lb ; ID ; Ideographic
+lb ; IN ; Inseparable ; Inseperable
+lb ; IS ; Infix_Numeric
+lb ; JL ; JL
+lb ; JT ; JT
+lb ; JV ; JV
+lb ; LF ; Line_Feed
+lb ; NL ; Next_Line
+lb ; NS ; Nonstarter
+lb ; NU ; Numeric
+lb ; OP ; Open_Punctuation
+lb ; PO ; Postfix_Numeric
+lb ; PR ; Prefix_Numeric
+lb ; QU ; Quotation
+lb ; RI ; Regional_Indicator
+lb ; SA ; Complex_Context
+lb ; SG ; Surrogate
+lb ; SP ; Space
+lb ; SY ; Break_Symbols
+lb ; WJ ; Word_Joiner
+lb ; XX ; Unknown
+lb ; ZW ; ZWSpace
# Logical_Order_Exception (LOE)
-LOE; N ; No ; F ; False
-LOE; Y ; Yes ; T ; True
+LOE; N ; No ; F ; False
+LOE; Y ; Yes ; T ; True
# Lowercase (Lower)
-Lower; N ; No ; F ; False
-Lower; Y ; Yes ; T ; True
+Lower; N ; No ; F ; False
+Lower; Y ; Yes ; T ; True
-# Lowercase_Mapping (lc)
-
-# @missing: 0000..10FFFF; Lowercase_Mapping; <code point>
-
# Math (Math)
-Math; N ; No ; F ; False
-Math; Y ; Yes ; T ; True
+Math; N ; No ; F ; False
+Math; Y ; Yes ; T ; True
# NFC_Quick_Check (NFC_QC)
-NFC_QC; M ; Maybe
-NFC_QC; N ; No
-NFC_QC; Y ; Yes
+NFC_QC; M ; Maybe
+NFC_QC; N ; No
+NFC_QC; Y ; Yes
# NFD_Quick_Check (NFD_QC)
-NFD_QC; N ; No
-NFD_QC; Y ; Yes
+NFD_QC; N ; No
+NFD_QC; Y ; Yes
# NFKC_Casefold (NFKC_CF)
@@ -815,14 +906,14 @@
# NFKC_Quick_Check (NFKC_QC)
-NFKC_QC; M ; Maybe
-NFKC_QC; N ; No
-NFKC_QC; Y ; Yes
+NFKC_QC; M ; Maybe
+NFKC_QC; N ; No
+NFKC_QC; Y ; Yes
# NFKD_Quick_Check (NFKD_QC)
-NFKD_QC; N ; No
-NFKD_QC; Y ; Yes
+NFKD_QC; N ; No
+NFKD_QC; Y ; Yes
# Name (na)
@@ -834,15 +925,15 @@
# Noncharacter_Code_Point (NChar)
-NChar; N ; No ; F ; False
-NChar; Y ; Yes ; T ; True
+NChar; N ; No ; F ; False
+NChar; Y ; Yes ; T ; True
# Numeric_Type (nt)
-nt ; De ; Decimal
-nt ; Di ; Digit
-nt ; None ; None
-nt ; Nu ; Numeric
+nt ; De ; Decimal
+nt ; Di ; Digit
+nt ; None ; None
+nt ; Nu ; Numeric
# Numeric_Value (nv)
@@ -850,186 +941,197 @@
# Other_Alphabetic (OAlpha)
-OAlpha; N ; No ; F ; False
-OAlpha; Y ; Yes ; T ; True
+OAlpha; N ; No ; F ; False
+OAlpha; Y ; Yes ; T ; True
# Other_Default_Ignorable_Code_Point (ODI)
-ODI; N ; No ; F ; False
-ODI; Y ; Yes ; T ; True
+ODI; N ; No ; F ; False
+ODI; Y ; Yes ; T ; True
# Other_Grapheme_Extend (OGr_Ext)
-OGr_Ext; N ; No ; F ; False
-OGr_Ext; Y ; Yes ; T ; True
+OGr_Ext; N ; No ; F ; False
+OGr_Ext; Y ; Yes ; T ; True
# Other_ID_Continue (OIDC)
-OIDC; N ; No ; F ; False
-OIDC; Y ; Yes ; T ; True
+OIDC; N ; No ; F ; False
+OIDC; Y ; Yes ; T ; True
# Other_ID_Start (OIDS)
-OIDS; N ; No ; F ; False
-OIDS; Y ; Yes ; T ; True
+OIDS; N ; No ; F ; False
+OIDS; Y ; Yes ; T ; True
# Other_Lowercase (OLower)
-OLower; N ; No ; F ; False
-OLower; Y ; Yes ; T ; True
+OLower; N ; No ; F ; False
+OLower; Y ; Yes ; T ; True
# Other_Math (OMath)
-OMath; N ; No ; F ; False
-OMath; Y ; Yes ; T ; True
+OMath; N ; No ; F ; False
+OMath; Y ; Yes ; T ; True
# Other_Uppercase (OUpper)
-OUpper; N ; No ; F ; False
-OUpper; Y ; Yes ; T ; True
+OUpper; N ; No ; F ; False
+OUpper; Y ; Yes ; T ; True
# Pattern_Syntax (Pat_Syn)
-Pat_Syn; N ; No ; F ; False
-Pat_Syn; Y ; Yes ; T ; True
+Pat_Syn; N ; No ; F ; False
+Pat_Syn; Y ; Yes ; T ; True
# Pattern_White_Space (Pat_WS)
-Pat_WS; N ; No ; F ; False
-Pat_WS; Y ; Yes ; T ; True
+Pat_WS; N ; No ; F ; False
+Pat_WS; Y ; Yes ; T ; True
# Quotation_Mark (QMark)
-QMark; N ; No ; F ; False
-QMark; Y ; Yes ; T ; True
+QMark; N ; No ; F ; False
+QMark; Y ; Yes ; T ; True
# Radical (Radical)
-Radical; N ; No ; F ; False
-Radical; Y ; Yes ; T ; True
+Radical; N ; No ; F ; False
+Radical; Y ; Yes ; T ; True
# STerm (STerm)
-STerm; N ; No ; F ; False
-STerm; Y ; Yes ; T ; True
+STerm; N ; No ; F ; False
+STerm; Y ; Yes ; T ; True
# Script (sc)
-sc ; Arab ; Arabic
-sc ; Armi ; Imperial_Aramaic
-sc ; Armn ; Armenian
-sc ; Avst ; Avestan
-sc ; Bali ; Balinese
-sc ; Bamu ; Bamum
-sc ; Batk ; Batak
-sc ; Beng ; Bengali
-sc ; Bopo ; Bopomofo
-sc ; Brah ; Brahmi
-sc ; Brai ; Braille
-sc ; Bugi ; Buginese
-sc ; Buhd ; Buhid
-sc ; Cans ; Canadian_Aboriginal
-sc ; Cari ; Carian
-sc ; Cham ; Cham
-sc ; Cher ; Cherokee
-sc ; Copt ; Coptic ; Qaac
-sc ; Cprt ; Cypriot
-sc ; Cyrl ; Cyrillic
-sc ; Deva ; Devanagari
-sc ; Dsrt ; Deseret
-sc ; Egyp ; Egyptian_Hieroglyphs
-sc ; Ethi ; Ethiopic
-sc ; Geor ; Georgian
-sc ; Glag ; Glagolitic
-sc ; Goth ; Gothic
-sc ; Grek ; Greek
-sc ; Gujr ; Gujarati
-sc ; Guru ; Gurmukhi
-sc ; Hang ; Hangul
-sc ; Hani ; Han
-sc ; Hano ; Hanunoo
-sc ; Hebr ; Hebrew
-sc ; Hira ; Hiragana
-sc ; Hrkt ; Katakana_Or_Hiragana
-sc ; Ital ; Old_Italic
-sc ; Java ; Javanese
-sc ; Kali ; Kayah_Li
-sc ; Kana ; Katakana
-sc ; Khar ; Kharoshthi
-sc ; Khmr ; Khmer
-sc ; Knda ; Kannada
-sc ; Kthi ; Kaithi
-sc ; Lana ; Tai_Tham
-sc ; Laoo ; Lao
-sc ; Latn ; Latin
-sc ; Lepc ; Lepcha
-sc ; Limb ; Limbu
-sc ; Linb ; Linear_B
-sc ; Lisu ; Lisu
-sc ; Lyci ; Lycian
-sc ; Lydi ; Lydian
-sc ; Mand ; Mandaic
-sc ; Mlym ; Malayalam
-sc ; Mong ; Mongolian
-sc ; Mtei ; Meetei_Mayek
-sc ; Mymr ; Myanmar
-sc ; Nkoo ; Nko
-sc ; Ogam ; Ogham
-sc ; Olck ; Ol_Chiki
-sc ; Orkh ; Old_Turkic
-sc ; Orya ; Oriya
-sc ; Osma ; Osmanya
-sc ; Phag ; Phags_Pa
-sc ; Phli ; Inscriptional_Pahlavi
-sc ; Phnx ; Phoenician
-sc ; Prti ; Inscriptional_Parthian
-sc ; Rjng ; Rejang
-sc ; Runr ; Runic
-sc ; Samr ; Samaritan
-sc ; Sarb ; Old_South_Arabian
-sc ; Saur ; Saurashtra
-sc ; Shaw ; Shavian
-sc ; Sinh ; Sinhala
-sc ; Sund ; Sundanese
-sc ; Sylo ; Syloti_Nagri
-sc ; Syrc ; Syriac
-sc ; Tagb ; Tagbanwa
-sc ; Tale ; Tai_Le
-sc ; Talu ; New_Tai_Lue
-sc ; Taml ; Tamil
-sc ; Tavt ; Tai_Viet
-sc ; Telu ; Telugu
-sc ; Tfng ; Tifinagh
-sc ; Tglg ; Tagalog
-sc ; Thaa ; Thaana
-sc ; Thai ; Thai
-sc ; Tibt ; Tibetan
-sc ; Ugar ; Ugaritic
-sc ; Vaii ; Vai
-sc ; Xpeo ; Old_Persian
-sc ; Xsux ; Cuneiform
-sc ; Yiii ; Yi
-sc ; Zinh ; Inherited ; Qaai
-sc ; Zyyy ; Common
-sc ; Zzzz ; Unknown
+sc ; Arab ; Arabic
+sc ; Armi ; Imperial_Aramaic
+sc ; Armn ; Armenian
+sc ; Avst ; Avestan
+sc ; Bali ; Balinese
+sc ; Bamu ; Bamum
+sc ; Batk ; Batak
+sc ; Beng ; Bengali
+sc ; Bopo ; Bopomofo
+sc ; Brah ; Brahmi
+sc ; Brai ; Braille
+sc ; Bugi ; Buginese
+sc ; Buhd ; Buhid
+sc ; Cakm ; Chakma
+sc ; Cans ; Canadian_Aboriginal
+sc ; Cari ; Carian
+sc ; Cham ; Cham
+sc ; Cher ; Cherokee
+sc ; Copt ; Coptic ; Qaac
+sc ; Cprt ; Cypriot
+sc ; Cyrl ; Cyrillic
+sc ; Deva ; Devanagari
+sc ; Dsrt ; Deseret
+sc ; Egyp ; Egyptian_Hieroglyphs
+sc ; Ethi ; Ethiopic
+sc ; Geor ; Georgian
+sc ; Glag ; Glagolitic
+sc ; Goth ; Gothic
+sc ; Grek ; Greek
+sc ; Gujr ; Gujarati
+sc ; Guru ; Gurmukhi
+sc ; Hang ; Hangul
+sc ; Hani ; Han
+sc ; Hano ; Hanunoo
+sc ; Hebr ; Hebrew
+sc ; Hira ; Hiragana
+sc ; Hrkt ; Katakana_Or_Hiragana
+sc ; Ital ; Old_Italic
+sc ; Java ; Javanese
+sc ; Kali ; Kayah_Li
+sc ; Kana ; Katakana
+sc ; Khar ; Kharoshthi
+sc ; Khmr ; Khmer
+sc ; Knda ; Kannada
+sc ; Kthi ; Kaithi
+sc ; Lana ; Tai_Tham
+sc ; Laoo ; Lao
+sc ; Latn ; Latin
+sc ; Lepc ; Lepcha
+sc ; Limb ; Limbu
+sc ; Linb ; Linear_B
+sc ; Lisu ; Lisu
+sc ; Lyci ; Lycian
+sc ; Lydi ; Lydian
+sc ; Mand ; Mandaic
+sc ; Merc ; Meroitic_Cursive
+sc ; Mero ; Meroitic_Hieroglyphs
+sc ; Mlym ; Malayalam
+sc ; Mong ; Mongolian
+sc ; Mtei ; Meetei_Mayek
+sc ; Mymr ; Myanmar
+sc ; Nkoo ; Nko
+sc ; Ogam ; Ogham
+sc ; Olck ; Ol_Chiki
+sc ; Orkh ; Old_Turkic
+sc ; Orya ; Oriya
+sc ; Osma ; Osmanya
+sc ; Phag ; Phags_Pa
+sc ; Phli ; Inscriptional_Pahlavi
+sc ; Phnx ; Phoenician
+sc ; Plrd ; Miao
+sc ; Prti ; Inscriptional_Parthian
+sc ; Rjng ; Rejang
+sc ; Runr ; Runic
+sc ; Samr ; Samaritan
+sc ; Sarb ; Old_South_Arabian
+sc ; Saur ; Saurashtra
+sc ; Shaw ; Shavian
+sc ; Shrd ; Sharada
+sc ; Sinh ; Sinhala
+sc ; Sora ; Sora_Sompeng
+sc ; Sund ; Sundanese
+sc ; Sylo ; Syloti_Nagri
+sc ; Syrc ; Syriac
+sc ; Tagb ; Tagbanwa
+sc ; Takr ; Takri
+sc ; Tale ; Tai_Le
+sc ; Talu ; New_Tai_Lue
+sc ; Taml ; Tamil
+sc ; Tavt ; Tai_Viet
+sc ; Telu ; Telugu
+sc ; Tfng ; Tifinagh
+sc ; Tglg ; Tagalog
+sc ; Thaa ; Thaana
+sc ; Thai ; Thai
+sc ; Tibt ; Tibetan
+sc ; Ugar ; Ugaritic
+sc ; Vaii ; Vai
+sc ; Xpeo ; Old_Persian
+sc ; Xsux ; Cuneiform
+sc ; Yiii ; Yi
+sc ; Zinh ; Inherited ; Qaai
+sc ; Zyyy ; Common
+sc ; Zzzz ; Unknown
+# Script_Extensions (scx)
+
+# @missing: 0000..10FFFF; Script_Extensions; <script>
+
# Sentence_Break (SB)
-SB ; AT ; ATerm
-SB ; CL ; Close
-SB ; CR ; CR
-SB ; EX ; Extend
-SB ; FO ; Format
-SB ; LE ; OLetter
-SB ; LF ; LF
-SB ; LO ; Lower
-SB ; NU ; Numeric
-SB ; SC ; SContinue
-SB ; SE ; Sep
-SB ; SP ; Sp
-SB ; ST ; STerm
-SB ; UP ; Upper
-SB ; XX ; Other
+SB ; AT ; ATerm
+SB ; CL ; Close
+SB ; CR ; CR
+SB ; EX ; Extend
+SB ; FO ; Format
+SB ; LE ; OLetter
+SB ; LF ; LF
+SB ; LO ; Lower
+SB ; NU ; Numeric
+SB ; SC ; SContinue
+SB ; SE ; Sep
+SB ; SP ; Sp
+SB ; ST ; STerm
+SB ; UP ; Upper
+SB ; XX ; Other
# Simple_Case_Folding (scf)
@@ -1049,18 +1151,14 @@
# Soft_Dotted (SD)
-SD ; N ; No ; F ; False
-SD ; Y ; Yes ; T ; True
+SD ; N ; No ; F ; False
+SD ; Y ; Yes ; T ; True
# Terminal_Punctuation (Term)
-Term; N ; No ; F ; False
-Term; Y ; Yes ; T ; True
+Term; N ; No ; F ; False
+Term; Y ; Yes ; T ; True
-# Titlecase_Mapping (tc)
-
-# @missing: 0000..10FFFF; Titlecase_Mapping; <code point>
-
# Unicode_1_Name (na1)
# @missing: 0000..10FFFF; Unicode_1_Name; <none>
@@ -1067,53 +1165,50 @@
# Unified_Ideograph (UIdeo)
-UIdeo; N ; No ; F ; False
-UIdeo; Y ; Yes ; T ; True
+UIdeo; N ; No ; F ; False
+UIdeo; Y ; Yes ; T ; True
# Uppercase (Upper)
-Upper; N ; No ; F ; False
-Upper; Y ; Yes ; T ; True
+Upper; N ; No ; F ; False
+Upper; Y ; Yes ; T ; True
-# Uppercase_Mapping (uc)
-
-# @missing: 0000..10FFFF; Uppercase_Mapping; <code point>
-
# Variation_Selector (VS)
-VS ; N ; No ; F ; False
-VS ; Y ; Yes ; T ; True
+VS ; N ; No ; F ; False
+VS ; Y ; Yes ; T ; True
# White_Space (WSpace)
-WSpace; N ; No ; F ; False
-WSpace; Y ; Yes ; T ; True
+WSpace; N ; No ; F ; False
+WSpace; Y ; Yes ; T ; True
# Word_Break (WB)
-WB ; CR ; CR
-WB ; EX ; ExtendNumLet
-WB ; Extend ; Extend
-WB ; FO ; Format
-WB ; KA ; Katakana
-WB ; LE ; ALetter
-WB ; LF ; LF
-WB ; MB ; MidNumLet
-WB ; ML ; MidLetter
-WB ; MN ; MidNum
-WB ; NL ; Newline
-WB ; NU ; Numeric
-WB ; XX ; Other
+WB ; CR ; CR
+WB ; EX ; ExtendNumLet
+WB ; Extend ; Extend
+WB ; FO ; Format
+WB ; KA ; Katakana
+WB ; LE ; ALetter
+WB ; LF ; LF
+WB ; MB ; MidNumLet
+WB ; ML ; MidLetter
+WB ; MN ; MidNum
+WB ; NL ; Newline
+WB ; NU ; Numeric
+WB ; RI ; Regional_Indicator
+WB ; XX ; Other
# XID_Continue (XIDC)
-XIDC; N ; No ; F ; False
-XIDC; Y ; Yes ; T ; True
+XIDC; N ; No ; F ; False
+XIDC; Y ; Yes ; T ; True
# XID_Start (XIDS)
-XIDS; N ; No ; F ; False
-XIDS; Y ; Yes ; T ; True
+XIDS; N ; No ; F ; False
+XIDS; Y ; Yes ; T ; True
# cjkAccountingNumeric (cjkAccountingNumeric)
Property changes on: trunk/contrib/perl/lib/unicore/PropValueAliases.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/PropertyAliases.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/PropertyAliases.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/PropertyAliases.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,8 +1,8 @@
-# PropertyAliases-6.0.0.txt
-# Date: 2010-05-18, 00:49:38 GMT [MD]
+# PropertyAliases-6.2.0.txt
+# Date: 2012-05-20, 17:41:20 GMT [MD]
#
# Unicode Character Database
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
# For documentation, see http://www.unicode.org/reports/tr44/
#
@@ -9,7 +9,6 @@
# This file contains aliases for properties used in the UCD.
# These names can be used for XML formats of UCD data, for regular-expression
# property tests, and other programmatic textual descriptions of Unicode data.
-# For information on which properties are normative, see UCD.html.
#
# The names may be translated in appropriate environments, and additional
# aliases may be useful.
@@ -27,7 +26,7 @@
# Loose matching should be applied to all property names and property values, with
# the exception of String Property values. With loose matching of property names and
# values, the case distinctions, whitespace, and '_' are ignored. For Numeric Property
-# values, numeric equivalences are applied: thus "01.00" is equivalent to "1".
+# values, numeric equivalencies are applied: thus "01.00" is equivalent to "1".
#
# NOTE: Property value names are NOT unique across properties. For example:
#
@@ -50,140 +49,143 @@
# ================================================
# Numeric Properties
# ================================================
-cjkAccountingNumeric; kAccountingNumeric
-cjkOtherNumeric; kOtherNumeric
-cjkPrimaryNumeric; kPrimaryNumeric
-nv ; Numeric_Value
+cjkAccountingNumeric ; kAccountingNumeric
+cjkOtherNumeric ; kOtherNumeric
+cjkPrimaryNumeric ; kPrimaryNumeric
+nv ; Numeric_Value
# ================================================
# String Properties
# ================================================
-bmg ; Bidi_Mirroring_Glyph
-cf ; Case_Folding
-cjkCompatibilityVariant; kCompatibilityVariant
-dm ; Decomposition_Mapping
-FC_NFKC ; FC_NFKC_Closure
-lc ; Lowercase_Mapping
-NFKC_CF ; NFKC_Casefold
-scf ; Simple_Case_Folding ; sfc
-slc ; Simple_Lowercase_Mapping
-stc ; Simple_Titlecase_Mapping
-suc ; Simple_Uppercase_Mapping
-tc ; Titlecase_Mapping
-uc ; Uppercase_Mapping
+cf ; Case_Folding
+cjkCompatibilityVariant ; kCompatibilityVariant
+dm ; Decomposition_Mapping
+FC_NFKC ; FC_NFKC_Closure
+lc ; Lowercase_Mapping
+NFKC_CF ; NFKC_Casefold
+scf ; Simple_Case_Folding ; sfc
+slc ; Simple_Lowercase_Mapping
+stc ; Simple_Titlecase_Mapping
+suc ; Simple_Uppercase_Mapping
+tc ; Titlecase_Mapping
+uc ; Uppercase_Mapping
# ================================================
# Miscellaneous Properties
# ================================================
-cjkIICore ; kIICore
-cjkIRG_GSource; kIRG_GSource
-cjkIRG_HSource; kIRG_HSource
-cjkIRG_JSource; kIRG_JSource
-cjkIRG_KPSource; kIRG_KPSource
-cjkIRG_KSource; kIRG_KSource
-cjkIRG_MSource; kIRG_MSource
-cjkIRG_TSource; kIRG_TSource
-cjkIRG_USource; kIRG_USource
-cjkIRG_VSource; kIRG_VSource
-cjkRSUnicode; kRSUnicode ; Unicode_Radical_Stroke; URS
-isc ; ISO_Comment
-JSN ; Jamo_Short_Name
-na ; Name
-na1 ; Unicode_1_Name
-Name_Alias; Name_Alias
+bmg ; Bidi_Mirroring_Glyph
+cjkIICore ; kIICore
+cjkIRG_GSource ; kIRG_GSource
+cjkIRG_HSource ; kIRG_HSource
+cjkIRG_JSource ; kIRG_JSource
+cjkIRG_KPSource ; kIRG_KPSource
+cjkIRG_KSource ; kIRG_KSource
+cjkIRG_MSource ; kIRG_MSource
+cjkIRG_TSource ; kIRG_TSource
+cjkIRG_USource ; kIRG_USource
+cjkIRG_VSource ; kIRG_VSource
+cjkRSUnicode ; kRSUnicode ; Unicode_Radical_Stroke; URS
+isc ; ISO_Comment
+JSN ; Jamo_Short_Name
+na ; Name
+na1 ; Unicode_1_Name
+Name_Alias ; Name_Alias
+scx ; Script_Extensions
# ================================================
# Catalog Properties
# ================================================
-age ; Age
-blk ; Block
-sc ; Script
+age ; Age
+blk ; Block
+sc ; Script
# ================================================
# Enumerated Properties
# ================================================
-bc ; Bidi_Class
-ccc ; Canonical_Combining_Class
-dt ; Decomposition_Type
-ea ; East_Asian_Width
-gc ; General_Category
-GCB ; Grapheme_Cluster_Break
-hst ; Hangul_Syllable_Type
-jg ; Joining_Group
-jt ; Joining_Type
-lb ; Line_Break
-NFC_QC ; NFC_Quick_Check
-NFD_QC ; NFD_Quick_Check
-NFKC_QC ; NFKC_Quick_Check
-NFKD_QC ; NFKD_Quick_Check
-nt ; Numeric_Type
-SB ; Sentence_Break
-WB ; Word_Break
+bc ; Bidi_Class
+ccc ; Canonical_Combining_Class
+dt ; Decomposition_Type
+ea ; East_Asian_Width
+gc ; General_Category
+GCB ; Grapheme_Cluster_Break
+hst ; Hangul_Syllable_Type
+InMC ; Indic_Matra_Category
+InSC ; Indic_Syllabic_Category
+jg ; Joining_Group
+jt ; Joining_Type
+lb ; Line_Break
+NFC_QC ; NFC_Quick_Check
+NFD_QC ; NFD_Quick_Check
+NFKC_QC ; NFKC_Quick_Check
+NFKD_QC ; NFKD_Quick_Check
+nt ; Numeric_Type
+SB ; Sentence_Break
+WB ; Word_Break
# ================================================
# Binary Properties
# ================================================
-AHex ; ASCII_Hex_Digit
-Alpha ; Alphabetic
-Bidi_C ; Bidi_Control
-Bidi_M ; Bidi_Mirrored
-Cased ; Cased
-CE ; Composition_Exclusion
-CI ; Case_Ignorable
-Comp_Ex ; Full_Composition_Exclusion
-CWCF ; Changes_When_Casefolded
-CWCM ; Changes_When_Casemapped
-CWKCF ; Changes_When_NFKC_Casefolded
-CWL ; Changes_When_Lowercased
-CWT ; Changes_When_Titlecased
-CWU ; Changes_When_Uppercased
-Dash ; Dash
-Dep ; Deprecated
-DI ; Default_Ignorable_Code_Point
-Dia ; Diacritic
-Ext ; Extender
-Gr_Base ; Grapheme_Base
-Gr_Ext ; Grapheme_Extend
-Gr_Link ; Grapheme_Link
-Hex ; Hex_Digit
-Hyphen ; Hyphen
-IDC ; ID_Continue
-Ideo ; Ideographic
-IDS ; ID_Start
-IDSB ; IDS_Binary_Operator
-IDST ; IDS_Trinary_Operator
-Join_C ; Join_Control
-LOE ; Logical_Order_Exception
-Lower ; Lowercase
-Math ; Math
-NChar ; Noncharacter_Code_Point
-OAlpha ; Other_Alphabetic
-ODI ; Other_Default_Ignorable_Code_Point
-OGr_Ext ; Other_Grapheme_Extend
-OIDC ; Other_ID_Continue
-OIDS ; Other_ID_Start
-OLower ; Other_Lowercase
-OMath ; Other_Math
-OUpper ; Other_Uppercase
-Pat_Syn ; Pattern_Syntax
-Pat_WS ; Pattern_White_Space
-QMark ; Quotation_Mark
-Radical ; Radical
-SD ; Soft_Dotted
-STerm ; STerm
-Term ; Terminal_Punctuation
-UIdeo ; Unified_Ideograph
-Upper ; Uppercase
-VS ; Variation_Selector
-WSpace ; White_Space ; space
-XIDC ; XID_Continue
-XIDS ; XID_Start
-XO_NFC ; Expands_On_NFC
-XO_NFD ; Expands_On_NFD
-XO_NFKC ; Expands_On_NFKC
-XO_NFKD ; Expands_On_NFKD
+AHex ; ASCII_Hex_Digit
+Alpha ; Alphabetic
+Bidi_C ; Bidi_Control
+Bidi_M ; Bidi_Mirrored
+Cased ; Cased
+CE ; Composition_Exclusion
+CI ; Case_Ignorable
+Comp_Ex ; Full_Composition_Exclusion
+CWCF ; Changes_When_Casefolded
+CWCM ; Changes_When_Casemapped
+CWKCF ; Changes_When_NFKC_Casefolded
+CWL ; Changes_When_Lowercased
+CWT ; Changes_When_Titlecased
+CWU ; Changes_When_Uppercased
+Dash ; Dash
+Dep ; Deprecated
+DI ; Default_Ignorable_Code_Point
+Dia ; Diacritic
+Ext ; Extender
+Gr_Base ; Grapheme_Base
+Gr_Ext ; Grapheme_Extend
+Gr_Link ; Grapheme_Link
+Hex ; Hex_Digit
+Hyphen ; Hyphen
+IDC ; ID_Continue
+Ideo ; Ideographic
+IDS ; ID_Start
+IDSB ; IDS_Binary_Operator
+IDST ; IDS_Trinary_Operator
+Join_C ; Join_Control
+LOE ; Logical_Order_Exception
+Lower ; Lowercase
+Math ; Math
+NChar ; Noncharacter_Code_Point
+OAlpha ; Other_Alphabetic
+ODI ; Other_Default_Ignorable_Code_Point
+OGr_Ext ; Other_Grapheme_Extend
+OIDC ; Other_ID_Continue
+OIDS ; Other_ID_Start
+OLower ; Other_Lowercase
+OMath ; Other_Math
+OUpper ; Other_Uppercase
+Pat_Syn ; Pattern_Syntax
+Pat_WS ; Pattern_White_Space
+QMark ; Quotation_Mark
+Radical ; Radical
+SD ; Soft_Dotted
+STerm ; STerm
+Term ; Terminal_Punctuation
+UIdeo ; Unified_Ideograph
+Upper ; Uppercase
+VS ; Variation_Selector
+WSpace ; White_Space ; space
+XIDC ; XID_Continue
+XIDS ; XID_Start
+XO_NFC ; Expands_On_NFC
+XO_NFD ; Expands_On_NFD
+XO_NFKC ; Expands_On_NFKC
+XO_NFKD ; Expands_On_NFKD
# ================================================
-# Total: 112
+# Total: 115
# EOF
Property changes on: trunk/contrib/perl/lib/unicore/PropertyAliases.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/README.perl
===================================================================
--- trunk/contrib/perl/lib/unicore/README.perl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/README.perl 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,27 +1,49 @@
-The *.txt files were copied from
+# Perl should compile and reasonably run any version of Unicode. That doesn't
+# mean that the test suite will run without showing errors. A few of the
+# very-Unicode specific test files have been modified to account for different
+# versions, but most have not. For example, some tests use characters that
+# aren't encoded in all Unicode versions; others have hard-coded the General
+# Categories that were correct at the time the test was written. Perl itself
+# will not compile under Unicode releases prior to 3.0 without a simple change to
+# Unicode::Normalize. mktables contains instructions for this, as well as other
+# hints for using older Unicode versions.
- ftp://www.unicode.org/Public/UNIDATA
+# The *.txt files were copied from
-with subdirectories 'extracted' and 'auxiliary'
+# ftp://www.unicode.org/Public/UNIDATA
-The Unihan files were not included due to space considerations. Also NOT
-included were any *.html files. It is possible to add the Unihan files, and
-edit mktables (see instructions near its beginning) to look at them.
+# (which always points to the latest version) with subdirectories 'extracted' and
+# 'auxiliary'. Older versions are located under Public with an appropriate name.
-The file 'version' should exist and be a single line with the Unicode version,
-like:
-5.2.0
+# The Unihan files were not included due to space considerations. Also NOT
+# included were any *.html files. It is possible to add the Unihan files, and
+# edit mktables (see instructions near its beginning) to look at them.
-To be 8.3 filesystem friendly, the names of some of the input files have been
-changed from the values that are in the Unicode DB. Not all of the Test files
-are currently used, so may not be present, so some of the mv's can fail. The
-.html Test files are not touched.
+# The file named 'version' should exist and be a single line with the Unicode
+# version, like:
+# 5.2.0
+# To be 8.3 filesystem friendly, the names of some of the input files have been
+# changed from the values that are in the Unicode DB. Not all of the Test
+# files are currently used, so may not be present, so some of the mv's can
+# fail. The .html Test files are not touched.
+
mv PropertyValueAliases.txt PropValueAliases.txt
mv NamedSequencesProv.txt NamedSqProv.txt
+mv NormalizationTest.txt NormTest.txt
mv DerivedAge.txt DAge.txt
mv DerivedCoreProperties.txt DCoreProperties.txt
mv DerivedNormalizationProps.txt DNormalizationProps.txt
+
+# Some early releases don't have the extracted directory, and hence these files
+# should be moved to it.
+mkdir extracted 2>/dev/null
+mv DerivedBidiClass.txt DerivedBinaryProperties.txt extracted 2>/dev/null
+mv DerivedCombiningClass.txt DerivedDecompositionType.txt extracted 2>/dev/null
+mv DerivedEastAsianWidth.txt DerivedGeneralCategory.txt extracted 2>/dev/null
+mv DerivedJoiningGroup.txt DerivedJoiningType.txt extracted 2>/dev/null
+mv DerivedLineBreak.txt DerivedNumericType.txt DerivedNumericValues.txt extracted 2>/dev/null
+
mv extracted/DerivedBidiClass.txt extracted/DBidiClass.txt
mv extracted/DerivedBinaryProperties.txt extracted/DBinaryProperties.txt
mv extracted/DerivedCombiningClass.txt extracted/DCombiningClass.txt
@@ -39,8 +61,8 @@
mv auxiliary/SentenceBreakTest.txt auxiliary/SBTest.txt
mv auxiliary/WordBreakTest.txt auxiliary/WBTest.txt
-If you have the Unihan database (5.2 and above), you should also do the
-following:
+# If you have the Unihan database (5.2 and above), you should also do the
+# following:
mv Unihan_DictionaryIndices.txt UnihanIndicesDictionary.txt
mv Unihan_DictionaryLikeData.txt UnihanDataDictionaryLike.txt
@@ -51,68 +73,74 @@
mv Unihan_Readings.txt UnihanReadings.txt
mv Unihan_Variants.txt UnihanVariants.txt
-If you download everything, the names of files that are not used by mktables
-are not changed by the above, and will not work correctly as-is on 8.3
-filesystems.
+# If you download everything, the names of files that are not used by mktables
+# are not changed by the above, and hence may not work correctly as-is on 8.3
+# filesystems.
-mktables is used to generate the tables used by the rest of Perl. It will warn
-you about any *.txt files in the directory substructure that it doesn't know
-about. You should remove any so-identified, or edit mktables to add them to
-its lists to process. You can run
-
- mktables -globlist
-
-to have it try to process these tables generically.
-
-FOR PUMPKINS
-
-The files are inter-related. If you take the latest UnicodeData.txt, for
-example, but leave the older versions of other files, there can be subtle
-problems. So get everything available from Unicode, and delete those which
-aren't needed.
-
-When moving to a new version of Unicode, you need to update 'version' by hand
-
- p4 edit version
- ...
-
-You should look in the Unicode release notes (which are probably towards the
-bottom of http://www.unicode.org/reports/tr44/) to see if any properties have
-newly been moved to be Obsolete, Deprecated, or Stabilized. The full names for
-these should be added to the respective lists near the beginning of mktables,
-using an 'if' to add them for just this Unicode version going forward, so that
-mktables can continue to be used for earlier Unicode versions.
-
-When putting out a new Perl release, think about if any of the Deprecated
-properties should be moved to Suppressed.
-
-perlrecharclass.pod has a list of all the characters that are white space,
-which needs to be updated if there are changes. A quick way to check if there
-have been changes would be to see if the number of such characters listed in
-perluniprops.pod (generated by running mktables) for the property
-\p{White_Space} is no longer 26. Further investigation would then be necessary
-to classify the new characters as horizontal and vertical.
-
-The code in regexec.c for the \X match construct is intimately tied to the
-regular expression in UAX #29 (http://www.unicode.org/reports/tr29/). You
-should see if it has changed, and if so regexec.c should be modified. The
-current one is
-( CRLF
-| Prepend* ( Hangul-syllable | !Control )
- ( Grapheme_Extend | Spacing_Mark)*
-| . )
-
-mktables has many checks to warn you if there are unexpected or novel things
-that it doesn't know how to handle.
-
-pod.lst should be changed so that it gives the new name (which includes the
-Unicode release number) for perluniprops.pod
-
-Module::CoreList should be changed to include the new release
-
-Finally:
-
- p4 submit
-
---
-jhi at iki.fi; updated by nick at ccl4.org, public at khwilliamson.com
+# mktables is used to generate the tables used by the rest of Perl. It will
+# warn you about any *.txt files in the directory substructure that it doesn't
+# know about. You should remove any so-identified, or edit mktables to add
+# them to its lists to process. You can run
+#
+# mktables -globlist
+#
+#to have it try to process these tables generically.
+#
+# FOR PUMPKINS
+#
+# The files are inter-related. If you take the latest UnicodeData.txt, for
+# example, but leave the older versions of other files, there can be subtle
+# problems. So get everything available from Unicode, and delete those which
+# aren't needed.
+#
+# When moving to a new version of Unicode, you need to update 'version' by hand
+#
+# p4 edit version
+# ...
+#
+# You should look in the Unicode release notes (which are probably towards the
+# bottom of http://www.unicode.org/reports/tr44/) to see if any properties have
+# newly been moved to be Obsolete, Deprecated, or Stabilized. The full names
+# for these should be added to the respective lists near the beginning of
+# mktables, using an 'if' to add them for just this Unicode version going
+# forward, so that mktables can continue to be used for earlier Unicode
+# versions.
+#
+# When putting out a new Perl release, think about if any of the Deprecated
+# properties should be moved to Suppressed.
+#
+# perlrecharclass.pod has a list of all the characters that are white space,
+# which needs to be updated if there are changes. A quick way to check if
+# there have been changes would be to see if the number of such characters
+# listed in perluniprops.pod (generated by running mktables) for the property
+# \p{White_Space} is no longer 26. Further investigation would then be
+# necessary to classify the new characters as horizontal and vertical.
+#
+# The code in regexec.c for the \X match construct is intimately tied to the
+# regular expression in UAX #29 (http://www.unicode.org/reports/tr29/). You
+# should see if it has changed, and if so regexec.c should be modified. The
+# current one is
+# ( CRLF
+# | Prepend* ( Hangul-syllable | !Control )
+# ( Grapheme_Extend | Spacing_Mark)*
+# | . )
+#
+# mktables has many checks to warn you if there are unexpected or novel things
+# that it doesn't know how to handle.
+#
+# Module::CoreList should be changed to include the new release
+#
+# Also, you should regen l1_char_class_tab.h, by
+#
+# perl regen/mk_L_charclass.pl
+#
+# and, regen charclass_invlists.h by
+#
+# perl regen/mk_invlists.pl
+#
+# Finally:
+#
+# p4 submit
+#
+# --
+# jhi at iki.fi; updated by nick at ccl4.org, public at khwilliamson.com
Property changes on: trunk/contrib/perl/lib/unicore/README.perl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/ReadMe.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/ReadMe.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/ReadMe.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,7 +1,7 @@
-# Date: 2010-10-05, 16:26:38 PDT [KW]
+# Date: 2012-09-24, 22:40:00 GMT [KW]
#
# Unicode Character Database
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
#
# For documentation, see NamesList.html,
@@ -10,4 +10,6 @@
#
This directory contains final data files
-for the Unicode Character Database (UCD) for Unicode 6.0.0.
+for the Unicode Character Database (UCD) for Unicode 6.2.0.
+
+
Property changes on: trunk/contrib/perl/lib/unicore/ReadMe.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/ScriptExtensions.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/ScriptExtensions.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/ScriptExtensions.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,15 +1,21 @@
-# ScriptExtensions-6.0.0.txt
-# Date: 2010-08-30, 01:48:36 GMT [MD]
+# ScriptExtensions-6.2.0.txt
+# Date: 2012-08-13, 20:52:17 GMT [MD]
#
# Unicode Character Database
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
# For documentation, see http://www.unicode.org/reports/tr44/
+# The Script_Extensions property indicates which characters are commonly used
+# with more than one script, but with a limited number of scripts.
+# For each code point, there is one or more property values. Each such value is a Script property value.
+# For more information, see:
+# UAX #24: http://www.unicode.org/reports/tr24/ and
+# UAX #44: http://www.unicode.org/reports/tr44/
#
-# The Script Extensions contain data about characters that belong to multiple scripts.
-# This data is provisional, and expected to change over time, as more information becomes available.
-# The script values are space-delimited short values, such as Hang for Hangul.
-# For more information, see UAX #24: http://www.unicode.org/reports/tr24/.
+# All code points not explicitly listed for Script_Extensions
+# have as their value the corresponding Script property value
+#
+# @missing: 0000..10FFFF; <script>
# ================================================
@@ -17,13 +23,44 @@
# ================================================
+# Script_Extensions=Deva
+
+1CD0..1CD2 ; Deva # Mn [3] VEDIC TONE KARSHANA..VEDIC TONE PRENKHA
+1CD4..1CE0 ; Deva # Mn [13] VEDIC SIGN YAJURVEDIC MIDLINE SVARITA..VEDIC TONE RIGVEDIC KASHMIRI INDEPENDENT SVARITA
+1CE1 ; Deva # Mc VEDIC TONE ATHARVAVEDIC INDEPENDENT SVARITA
+1CE2..1CE8 ; Deva # Mn [7] VEDIC SIGN VISARGA SVARITA..VEDIC SIGN VISARGA ANUDATTA WITH TAIL
+1CED ; Deva # Mn VEDIC SIGN TIRYAK
+1CF2..1CF3 ; Deva # Mc [2] VEDIC SIGN ARDHAVISARGA..VEDIC SIGN ROTATED ARDHAVISARGA
+1CF4 ; Deva # Mn VEDIC TONE CANDRA ABOVE
+
+# Total code points: 28
+
+# ================================================
+
+# Script_Extensions=Grek
+
+0342 ; Grek # Mn COMBINING GREEK PERISPOMENI
+0345 ; Grek # Mn COMBINING GREEK YPOGEGRAMMENI
+1DC0..1DC1 ; Grek # Mn [2] COMBINING DOTTED GRAVE ACCENT..COMBINING DOTTED ACUTE ACCENT
+
+# Total code points: 4
+
+# ================================================
+
+# Script_Extensions=Latn
+
+0363..036F ; Latn # Mn [13] COMBINING LATIN SMALL LETTER A..COMBINING LATIN SMALL LETTER X
+
+# Total code points: 13
+
+# ================================================
+
# Script_Extensions=Arab Syrc
-0640 ; Arab Syrc # Lm ARABIC TATWEEL
064B..0655 ; Arab Syrc # Mn [11] ARABIC FATHATAN..ARABIC HAMZA BELOW
0670 ; Arab Syrc # Mn ARABIC LETTER SUPERSCRIPT ALEF
-# Total code points: 13
+# Total code points: 12
# ================================================
@@ -53,6 +90,32 @@
# ================================================
+# Script_Extensions=Cprt Linb
+
+10100..10102 ; Cprt Linb # Po [3] AEGEAN WORD SEPARATOR LINE..AEGEAN CHECK MARK
+10107..10133 ; Cprt Linb # No [45] AEGEAN NUMBER ONE..AEGEAN NUMBER NINETY THOUSAND
+10137..1013F ; Cprt Linb # So [9] AEGEAN WEIGHT BASE UNIT..AEGEAN MEASURE THIRD SUBUNIT
+
+# Total code points: 57
+
+# ================================================
+
+# Script_Extensions=Cyrl Latn
+
+0485..0486 ; Cyrl Latn # Mn [2] COMBINING CYRILLIC DASIA PNEUMATA..COMBINING CYRILLIC PSILI PNEUMATA
+
+# Total code points: 2
+
+# ================================================
+
+# Script_Extensions=Deva Latn
+
+0951..0952 ; Deva Latn # Mn [2] DEVANAGARI STRESS SIGN UDATTA..DEVANAGARI STRESS SIGN ANUDATTA
+
+# Total code points: 2
+
+# ================================================
+
# Script_Extensions=Hira Kana
3031..3035 ; Hira Kana # Lm [5] VERTICAL KANA REPEAT MARK..VERTICAL KANA REPEAT MARK LOWER HALF
@@ -76,6 +139,14 @@
# ================================================
+# Script_Extensions=Arab Mand Syrc
+
+0640 ; Arab Mand Syrc # Lm ARABIC TATWEEL
+
+# Total code points: 1
+
+# ================================================
+
# Script_Extensions=Arab Syrc Thaa
060C ; Arab Syrc Thaa # Po ARABIC COMMA
@@ -99,17 +170,17 @@
# ================================================
-# Script_Extensions=Beng Deva Guru Orya
+# Script_Extensions=Buhd Hano Tagb Tglg
-0964..0965 ; Beng Deva Guru Orya # Po [2] DEVANAGARI DANDA..DEVANAGARI DOUBLE DANDA
+1735..1736 ; Buhd Hano Tagb Tglg # Po [2] PHILIPPINE SINGLE PUNCTUATION..PHILIPPINE DOUBLE PUNCTUATION
# Total code points: 2
# ================================================
-# Script_Extensions=Buhd Hano Tagb Tglg
+# Script_Extensions=Beng Deva Guru Orya Takr
-1735..1736 ; Buhd Hano Tagb Tglg # Po [2] PHILIPPINE SINGLE PUNCTUATION..PHILIPPINE DOUBLE PUNCTUATION
+0964..0965 ; Beng Deva Guru Orya Takr # Po [2] DEVANAGARI DANDA..DEVANAGARI DOUBLE DANDA
# Total code points: 2
@@ -140,6 +211,17 @@
# ================================================
+# Script_Extensions=Deva Gujr Guru Kthi Takr
+
+A830..A835 ; Deva Gujr Guru Kthi Takr # No [6] NORTH INDIC FRACTION ONE QUARTER..NORTH INDIC FRACTION THREE SIXTEENTHS
+A836..A837 ; Deva Gujr Guru Kthi Takr # So [2] NORTH INDIC QUARTER MARK..NORTH INDIC PLACEHOLDER MARK
+A838 ; Deva Gujr Guru Kthi Takr # Sc NORTH INDIC RUPEE MARK
+A839 ; Deva Gujr Guru Kthi Takr # So NORTH INDIC QUANTITY MARK
+
+# Total code points: 10
+
+# ================================================
+
# Script_Extensions=Bopo Hang Hani Hira Kana Yiii
3001..3002 ; Bopo Hang Hani Hira Kana Yiii # Po [2] IDEOGRAPHIC COMMA..IDEOGRAPHIC FULL STOP
Property changes on: trunk/contrib/perl/lib/unicore/ScriptExtensions.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/Scripts.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/Scripts.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/Scripts.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,8 +1,8 @@
-# Scripts-6.0.0.txt
-# Date: 2010-08-19, 00:48:47 GMT [MD]
+# Scripts-6.2.0.txt
+# Date: 2012-06-04, 17:21:29 GMT [MD]
#
# Unicode Character Database
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
# For documentation, see http://www.unicode.org/reports/tr44/
@@ -47,7 +47,8 @@
00A0 ; Common # Zs NO-BREAK SPACE
00A1 ; Common # Po INVERTED EXCLAMATION MARK
00A2..00A5 ; Common # Sc [4] CENT SIGN..YEN SIGN
-00A6..00A7 ; Common # So [2] BROKEN BAR..SECTION SIGN
+00A6 ; Common # So BROKEN BAR
+00A7 ; Common # Po SECTION SIGN
00A8 ; Common # Sk DIAERESIS
00A9 ; Common # So COPYRIGHT SIGN
00AB ; Common # Pi LEFT-POINTING DOUBLE ANGLE QUOTATION MARK
@@ -60,8 +61,7 @@
00B2..00B3 ; Common # No [2] SUPERSCRIPT TWO..SUPERSCRIPT THREE
00B4 ; Common # Sk ACUTE ACCENT
00B5 ; Common # L& MICRO SIGN
-00B6 ; Common # So PILCROW SIGN
-00B7 ; Common # Po MIDDLE DOT
+00B6..00B7 ; Common # Po [2] PILCROW SIGN..MIDDLE DOT
00B8 ; Common # Sk CEDILLA
00B9 ; Common # No SUPERSCRIPT ONE
00BB ; Common # Pf RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK
@@ -90,7 +90,6 @@
0660..0669 ; Common # Nd [10] ARABIC-INDIC DIGIT ZERO..ARABIC-INDIC DIGIT NINE
06DD ; Common # Cf ARABIC END OF AYAH
0964..0965 ; Common # Po [2] DEVANAGARI DANDA..DEVANAGARI DOUBLE DANDA
-0970 ; Common # Po DEVANAGARI ABBREVIATION SIGN
0E3F ; Common # Sc THAI CURRENCY SYMBOL BAHT
0FD5..0FD8 ; Common # So [4] RIGHT-FACING SVASTI SIGN..LEFT-FACING SVASTI SIGN WITH DOTS
10FB ; Common # Po GEORGIAN PARAGRAPH SEPARATOR
@@ -102,7 +101,8 @@
1CE1 ; Common # Mc VEDIC TONE ATHARVAVEDIC INDEPENDENT SVARITA
1CE9..1CEC ; Common # Lo [4] VEDIC SIGN ANUSVARA ANTARGOMUKHA..VEDIC SIGN ANUSVARA VAMAGOMUKHA WITH TAIL
1CEE..1CF1 ; Common # Lo [4] VEDIC SIGN HEXIFORM LONG ANUSVARA..VEDIC SIGN ANUSVARA UBHAYATO MUKHA
-1CF2 ; Common # Mc VEDIC SIGN ARDHAVISARGA
+1CF2..1CF3 ; Common # Mc [2] VEDIC SIGN ARDHAVISARGA..VEDIC SIGN ROTATED ARDHAVISARGA
+1CF5..1CF6 ; Common # Lo [2] VEDIC SIGN JIHVAMULIYA..VEDIC SIGN UPADHMANIYA
2000..200A ; Common # Zs [11] EN QUAD..HAIR SPACE
200B ; Common # Cf ZERO WIDTH SPACE
200E..200F ; Common # Cf [2] LEFT-TO-RIGHT MARK..RIGHT-TO-LEFT MARK
@@ -146,7 +146,7 @@
208A..208C ; Common # Sm [3] SUBSCRIPT PLUS SIGN..SUBSCRIPT EQUALS SIGN
208D ; Common # Ps SUBSCRIPT LEFT PARENTHESIS
208E ; Common # Pe SUBSCRIPT RIGHT PARENTHESIS
-20A0..20B9 ; Common # Sc [26] EURO-CURRENCY SIGN..INDIAN RUPEE SIGN
+20A0..20BA ; Common # Sc [27] EURO-CURRENCY SIGN..TURKISH LIRA SIGN
2100..2101 ; Common # So [2] ACCOUNT OF..ADDRESSED TO THE SUBJECT
2102 ; Common # L& DOUBLE-STRUCK CAPITAL C
2103..2106 ; Common # So [4] DEGREE CELSIUS..CADA UNA
@@ -247,9 +247,7 @@
27C0..27C4 ; Common # Sm [5] THREE DIMENSIONAL ANGLE..OPEN SUPERSET
27C5 ; Common # Ps LEFT S-SHAPED BAG DELIMITER
27C6 ; Common # Pe RIGHT S-SHAPED BAG DELIMITER
-27C7..27CA ; Common # Sm [4] OR WITH DOT INSIDE..VERTICAL BAR WITH HORIZONTAL STROKE
-27CC ; Common # Sm LONG DIVISION
-27CE..27E5 ; Common # Sm [24] SQUARED LOGICAL AND..WHITE SQUARE WITH RIGHTWARDS TICK
+27C7..27E5 ; Common # Sm [31] OR WITH DOT INSIDE..WHITE SQUARE WITH RIGHTWARDS TICK
27E6 ; Common # Ps MATHEMATICAL LEFT WHITE SQUARE BRACKET
27E7 ; Common # Pe MATHEMATICAL RIGHT WHITE SQUARE BRACKET
27E8 ; Common # Ps MATHEMATICAL LEFT ANGLE BRACKET
@@ -329,7 +327,8 @@
2E29 ; Common # Pe RIGHT DOUBLE PARENTHESIS
2E2A..2E2E ; Common # Po [5] TWO DOTS OVER ONE DOT PUNCTUATION..REVERSED QUESTION MARK
2E2F ; Common # Lm VERTICAL TILDE
-2E30..2E31 ; Common # Po [2] RING POINT..WORD SEPARATOR MIDDLE DOT
+2E30..2E39 ; Common # Po [10] RING POINT..TOP HALF SECTION SIGN
+2E3A..2E3B ; Common # Pd [2] TWO-EM DASH..THREE-EM DASH
2FF0..2FFB ; Common # So [12] IDEOGRAPHIC DESCRIPTION CHARACTER LEFT TO RIGHT..IDEOGRAPHIC DESCRIPTION CHARACTER OVERLAID
3000 ; Common # Zs IDEOGRAPHIC SPACE
3001..3003 ; Common # Po [3] IDEOGRAPHIC COMMA..DITTO MARK
@@ -373,7 +372,9 @@
3196..319F ; Common # So [10] IDEOGRAPHIC ANNOTATION TOP MARK..IDEOGRAPHIC ANNOTATION MAN MARK
31C0..31E3 ; Common # So [36] CJK STROKE T..CJK STROKE Q
3220..3229 ; Common # No [10] PARENTHESIZED IDEOGRAPH ONE..PARENTHESIZED IDEOGRAPH TEN
-322A..3250 ; Common # So [39] PARENTHESIZED IDEOGRAPH MOON..PARTNERSHIP SIGN
+322A..3247 ; Common # So [30] PARENTHESIZED IDEOGRAPH MOON..CIRCLED IDEOGRAPH KOTO
+3248..324F ; Common # No [8] CIRCLED NUMBER TEN ON BLACK SQUARE..CIRCLED NUMBER EIGHTY ON BLACK SQUARE
+3250 ; Common # So PARTNERSHIP SIGN
3251..325F ; Common # No [15] CIRCLED NUMBER TWENTY ONE..CIRCLED NUMBER THIRTY FIVE
327F ; Common # So KOREAN STANDARD SYMBOL
3280..3289 ; Common # No [10] CIRCLED IDEOGRAPH ONE..CIRCLED IDEOGRAPH TEN
@@ -481,8 +482,7 @@
FFED..FFEE ; Common # So [2] HALFWIDTH BLACK SQUARE..HALFWIDTH WHITE CIRCLE
FFF9..FFFB ; Common # Cf [3] INTERLINEAR ANNOTATION ANCHOR..INTERLINEAR ANNOTATION TERMINATOR
FFFC..FFFD ; Common # So [2] OBJECT REPLACEMENT CHARACTER..REPLACEMENT CHARACTER
-10100..10101 ; Common # Po [2] AEGEAN WORD SEPARATOR LINE..AEGEAN WORD SEPARATOR DOT
-10102 ; Common # So AEGEAN CHECK MARK
+10100..10102 ; Common # Po [3] AEGEAN WORD SEPARATOR LINE..AEGEAN CHECK MARK
10107..10133 ; Common # No [45] AEGEAN NUMBER ONE..AEGEAN NUMBER NINETY THOUSAND
10137..1013F ; Common # So [9] AEGEAN WEIGHT BASE UNIT..AEGEAN MEASURE THIRD SUBUNIT
10190..1019B ; Common # So [12] ROMAN SEXTANS SIGN..ROMAN CENTURIAL SIGN
@@ -548,7 +548,7 @@
1F0D1..1F0DF ; Common # So [15] PLAYING CARD ACE OF CLUBS..PLAYING CARD WHITE JOKER
1F100..1F10A ; Common # No [11] DIGIT ZERO FULL STOP..DIGIT NINE COMMA
1F110..1F12E ; Common # So [31] PARENTHESIZED LATIN CAPITAL LETTER A..CIRCLED WZ
-1F130..1F169 ; Common # So [58] SQUARED LATIN CAPITAL LETTER A..NEGATIVE CIRCLED LATIN CAPITAL LETTER Z
+1F130..1F16B ; Common # So [60] SQUARED LATIN CAPITAL LETTER A..RAISED MD SIGN
1F170..1F19A ; Common # So [43] NEGATIVE SQUARED LATIN CAPITAL LETTER A..SQUARED VS
1F1E6..1F1FF ; Common # So [26] REGIONAL INDICATOR SYMBOL LETTER A..REGIONAL INDICATOR SYMBOL LETTER Z
1F201..1F202 ; Common # So [2] SQUARED KATAKANA KOKO..SQUARED KATAKANA SA
@@ -567,19 +567,9 @@
1F442..1F4F7 ; Common # So [182] EAR..CAMERA
1F4F9..1F4FC ; Common # So [4] VIDEO CAMERA..VIDEOCASSETTE
1F500..1F53D ; Common # So [62] TWISTED RIGHTWARDS ARROWS..DOWN-POINTING SMALL RED TRIANGLE
+1F540..1F543 ; Common # So [4] CIRCLED CROSS POMMEE..NOTCHED LEFT SEMICIRCLE WITH THREE DOTS
1F550..1F567 ; Common # So [24] CLOCK FACE ONE OCLOCK..CLOCK FACE TWELVE-THIRTY
-1F5FB..1F5FF ; Common # So [5] MOUNT FUJI..MOYAI
-1F601..1F610 ; Common # So [16] GRINNING FACE WITH SMILING EYES..NEUTRAL FACE
-1F612..1F614 ; Common # So [3] UNAMUSED FACE..PENSIVE FACE
-1F616 ; Common # So CONFOUNDED FACE
-1F618 ; Common # So FACE THROWING A KISS
-1F61A ; Common # So KISSING FACE WITH CLOSED EYES
-1F61C..1F61E ; Common # So [3] FACE WITH STUCK-OUT TONGUE AND WINKING EYE..DISAPPOINTED FACE
-1F620..1F625 ; Common # So [6] ANGRY FACE..DISAPPOINTED BUT RELIEVED FACE
-1F628..1F62B ; Common # So [4] FEARFUL FACE..TIRED FACE
-1F62D ; Common # So LOUDLY CRYING FACE
-1F630..1F633 ; Common # So [4] FACE WITH OPEN MOUTH AND COLD SWEAT..FLUSHED FACE
-1F635..1F640 ; Common # So [12] DIZZY FACE..WEARY CAT FACE
+1F5FB..1F640 ; Common # So [70] MOUNT FUJI..WEARY CAT FACE
1F645..1F64F ; Common # So [11] FACE WITH NO GOOD GESTURE..PERSON WITH FOLDED HANDS
1F680..1F6C5 ; Common # So [70] ROCKET..LEFT LUGGAGE
1F700..1F773 ; Common # So [116] ALCHEMICAL SYMBOL FOR QUINTESSENCE..ALCHEMICAL SYMBOL FOR HALF OUNCE
@@ -586,14 +576,14 @@
E0001 ; Common # Cf LANGUAGE TAG
E0020..E007F ; Common # Cf [96] TAG SPACE..CANCEL TAG
-# Total code points: 6379
+# Total code points: 6413
# ================================================
0041..005A ; Latin # L& [26] LATIN CAPITAL LETTER A..LATIN CAPITAL LETTER Z
0061..007A ; Latin # L& [26] LATIN SMALL LETTER A..LATIN SMALL LETTER Z
-00AA ; Latin # L& FEMININE ORDINAL INDICATOR
-00BA ; Latin # L& MASCULINE ORDINAL INDICATOR
+00AA ; Latin # Lo FEMININE ORDINAL INDICATOR
+00BA ; Latin # Lo MASCULINE ORDINAL INDICATOR
00C0..00D6 ; Latin # L& [23] LATIN CAPITAL LETTER A WITH GRAVE..LATIN CAPITAL LETTER O WITH DIAERESIS
00D8..00F6 ; Latin # L& [31] LATIN CAPITAL LETTER O WITH STROKE..LATIN SMALL LETTER O WITH DIAERESIS
00F8..01BA ; Latin # L& [195] LATIN SMALL LETTER O WITH STROKE..LATIN SMALL LETTER EZH WITH TAIL
@@ -607,7 +597,7 @@
02E0..02E4 ; Latin # Lm [5] MODIFIER LETTER SMALL GAMMA..MODIFIER LETTER SMALL REVERSED GLOTTAL STOP
1D00..1D25 ; Latin # L& [38] LATIN LETTER SMALL CAPITAL A..LATIN LETTER AIN
1D2C..1D5C ; Latin # Lm [49] MODIFIER LETTER CAPITAL A..MODIFIER LETTER SMALL AIN
-1D62..1D65 ; Latin # L& [4] LATIN SUBSCRIPT SMALL LETTER I..LATIN SUBSCRIPT SMALL LETTER V
+1D62..1D65 ; Latin # Lm [4] LATIN SUBSCRIPT SMALL LETTER I..LATIN SUBSCRIPT SMALL LETTER V
1D6B..1D77 ; Latin # L& [13] LATIN SMALL LETTER UE..LATIN SMALL LETTER TURNED G
1D79..1D9A ; Latin # L& [34] LATIN SMALL LETTER INSULAR G..LATIN SMALL LETTER EZH WITH RETROFLEX HOOK
1D9B..1DBE ; Latin # Lm [36] MODIFIER LETTER SMALL TURNED ALPHA..MODIFIER LETTER SMALL EZH
@@ -621,15 +611,16 @@
2160..2182 ; Latin # Nl [35] ROMAN NUMERAL ONE..ROMAN NUMERAL TEN THOUSAND
2183..2184 ; Latin # L& [2] ROMAN NUMERAL REVERSED ONE HUNDRED..LATIN SMALL LETTER REVERSED C
2185..2188 ; Latin # Nl [4] ROMAN NUMERAL SIX LATE FORM..ROMAN NUMERAL ONE HUNDRED THOUSAND
-2C60..2C7C ; Latin # L& [29] LATIN CAPITAL LETTER L WITH DOUBLE BAR..LATIN SUBSCRIPT SMALL LETTER J
-2C7D ; Latin # Lm MODIFIER LETTER CAPITAL V
+2C60..2C7B ; Latin # L& [28] LATIN CAPITAL LETTER L WITH DOUBLE BAR..LATIN LETTER SMALL CAPITAL TURNED E
+2C7C..2C7D ; Latin # Lm [2] LATIN SUBSCRIPT SMALL LETTER J..MODIFIER LETTER CAPITAL V
2C7E..2C7F ; Latin # L& [2] LATIN CAPITAL LETTER S WITH SWASH TAIL..LATIN CAPITAL LETTER Z WITH SWASH TAIL
A722..A76F ; Latin # L& [78] LATIN CAPITAL LETTER EGYPTOLOGICAL ALEF..LATIN SMALL LETTER CON
A770 ; Latin # Lm MODIFIER LETTER US
A771..A787 ; Latin # L& [23] LATIN SMALL LETTER DUM..LATIN SMALL LETTER INSULAR T
A78B..A78E ; Latin # L& [4] LATIN CAPITAL LETTER SALTILLO..LATIN SMALL LETTER L WITH RETROFLEX HOOK AND BELT
-A790..A791 ; Latin # L& [2] LATIN CAPITAL LETTER N WITH DESCENDER..LATIN SMALL LETTER N WITH DESCENDER
-A7A0..A7A9 ; Latin # L& [10] LATIN CAPITAL LETTER G WITH OBLIQUE STROKE..LATIN SMALL LETTER S WITH OBLIQUE STROKE
+A790..A793 ; Latin # L& [4] LATIN CAPITAL LETTER N WITH DESCENDER..LATIN SMALL LETTER C WITH BAR
+A7A0..A7AA ; Latin # L& [11] LATIN CAPITAL LETTER G WITH OBLIQUE STROKE..LATIN CAPITAL LETTER H WITH HOOK
+A7F8..A7F9 ; Latin # Lm [2] MODIFIER LETTER CAPITAL H WITH STROKE..MODIFIER LETTER SMALL LIGATURE OE
A7FA ; Latin # L& LATIN LETTER SMALL CAPITAL TURNED M
A7FB..A7FF ; Latin # Lo [5] LATIN EPIGRAPHIC LETTER REVERSED F..LATIN EPIGRAPHIC LETTER ARCHAIC M
FB00..FB06 ; Latin # L& [7] LATIN SMALL LIGATURE FF..LATIN SMALL LIGATURE ST
@@ -636,7 +627,7 @@
FF21..FF3A ; Latin # L& [26] FULLWIDTH LATIN CAPITAL LETTER A..FULLWIDTH LATIN CAPITAL LETTER Z
FF41..FF5A ; Latin # L& [26] FULLWIDTH LATIN SMALL LETTER A..FULLWIDTH LATIN SMALL LETTER Z
-# Total code points: 1267
+# Total code points: 1272
# ================================================
@@ -656,7 +647,7 @@
03F7..03FF ; Greek # L& [9] GREEK CAPITAL LETTER SHO..GREEK CAPITAL REVERSED DOTTED LUNATE SIGMA SYMBOL
1D26..1D2A ; Greek # L& [5] GREEK LETTER SMALL CAPITAL GAMMA..GREEK LETTER SMALL CAPITAL PSI
1D5D..1D61 ; Greek # Lm [5] MODIFIER LETTER SMALL BETA..MODIFIER LETTER SMALL CHI
-1D66..1D6A ; Greek # L& [5] GREEK SUBSCRIPT SMALL LETTER BETA..GREEK SUBSCRIPT SMALL LETTER CHI
+1D66..1D6A ; Greek # Lm [5] GREEK SUBSCRIPT SMALL LETTER BETA..GREEK SUBSCRIPT SMALL LETTER CHI
1DBF ; Greek # Lm MODIFIER LETTER SMALL THETA
1F00..1F15 ; Greek # L& [22] GREEK SMALL LETTER ALPHA WITH PSILI..GREEK SMALL LETTER EPSILON WITH DASIA AND OXIA
1F18..1F1D ; Greek # L& [6] GREEK CAPITAL LETTER EPSILON WITH PSILI..GREEK CAPITAL LETTER EPSILON WITH DASIA AND OXIA
@@ -710,12 +701,13 @@
A66F ; Cyrillic # Mn COMBINING CYRILLIC VZMET
A670..A672 ; Cyrillic # Me [3] COMBINING CYRILLIC TEN MILLIONS SIGN..COMBINING CYRILLIC THOUSAND MILLIONS SIGN
A673 ; Cyrillic # Po SLAVONIC ASTERISK
-A67C..A67D ; Cyrillic # Mn [2] COMBINING CYRILLIC KAVYKA..COMBINING CYRILLIC PAYEROK
+A674..A67D ; Cyrillic # Mn [10] COMBINING CYRILLIC LETTER UKRAINIAN IE..COMBINING CYRILLIC PAYEROK
A67E ; Cyrillic # Po CYRILLIC KAVYKA
A67F ; Cyrillic # Lm CYRILLIC PAYEROK
A680..A697 ; Cyrillic # L& [24] CYRILLIC CAPITAL LETTER DWE..CYRILLIC SMALL LETTER SHWE
+A69F ; Cyrillic # Mn COMBINING CYRILLIC LETTER IOTIFIED E
-# Total code points: 408
+# Total code points: 417
# ================================================
@@ -724,9 +716,10 @@
055A..055F ; Armenian # Po [6] ARMENIAN APOSTROPHE..ARMENIAN ABBREVIATION MARK
0561..0587 ; Armenian # L& [39] ARMENIAN SMALL LETTER AYB..ARMENIAN SMALL LIGATURE ECH YIWN
058A ; Armenian # Pd ARMENIAN HYPHEN
+058F ; Armenian # Sc ARMENIAN DRAM SIGN
FB13..FB17 ; Armenian # L& [5] ARMENIAN SMALL LIGATURE MEN NOW..ARMENIAN SMALL LIGATURE MEN XEH
-# Total code points: 90
+# Total code points: 91
# ================================================
@@ -757,7 +750,7 @@
# ================================================
-0600..0603 ; Arabic # Cf [4] ARABIC NUMBER SIGN..ARABIC SIGN SAFHA
+0600..0604 ; Arabic # Cf [5] ARABIC NUMBER SIGN..ARABIC SIGN SAMVAT
0606..0608 ; Arabic # Sm [3] ARABIC-INDIC CUBE ROOT..ARABIC RAY
0609..060A ; Arabic # Po [2] ARABIC-INDIC PER MILLE SIGN..ARABIC-INDIC PER TEN THOUSAND SIGN
060B ; Arabic # Sc AFGHANI SIGN
@@ -767,7 +760,7 @@
061E ; Arabic # Po ARABIC TRIPLE DOT PUNCTUATION MARK
0620..063F ; Arabic # Lo [32] ARABIC LETTER KASHMIRI YEH..ARABIC LETTER FARSI YEH WITH THREE DOTS ABOVE
0641..064A ; Arabic # Lo [10] ARABIC LETTER FEH..ARABIC LETTER YEH
-0656..065E ; Arabic # Mn [9] ARABIC SUBSCRIPT ALEF..ARABIC FATHA WITH TWO DOTS
+0656..065F ; Arabic # Mn [10] ARABIC SUBSCRIPT ALEF..ARABIC WAVY HAMZA BELOW
066A..066D ; Arabic # Po [4] ARABIC PERCENT SIGN..ARABIC FIVE POINTED STAR
066E..066F ; Arabic # Lo [2] ARABIC LETTER DOTLESS BEH..ARABIC LETTER DOTLESS QAF
0671..06D3 ; Arabic # Lo [99] ARABIC LETTER ALEF WASLA..ARABIC LETTER YEH BARREE WITH HAMZA ABOVE
@@ -786,6 +779,9 @@
06FD..06FE ; Arabic # So [2] ARABIC SIGN SINDHI AMPERSAND..ARABIC SIGN SINDHI POSTPOSITION MEN
06FF ; Arabic # Lo ARABIC LETTER HEH WITH INVERTED V
0750..077F ; Arabic # Lo [48] ARABIC LETTER BEH WITH THREE DOTS HORIZONTALLY BELOW..ARABIC LETTER KAF WITH TWO DOTS ABOVE
+08A0 ; Arabic # Lo ARABIC LETTER BEH WITH SMALL V BELOW
+08A2..08AC ; Arabic # Lo [11] ARABIC LETTER JEEM WITH TWO DOTS ABOVE..ARABIC LETTER ROHINGYA YEH
+08E4..08FE ; Arabic # Mn [27] ARABIC CURLY FATHA..ARABIC DAMMA WITH DOT
FB50..FBB1 ; Arabic # Lo [98] ARABIC LETTER ALEF WASLA ISOLATED FORM..ARABIC LETTER YEH BARREE WITH HAMZA ABOVE FINAL FORM
FBB2..FBC1 ; Arabic # Sk [16] ARABIC SYMBOL DOT ABOVE..ARABIC SYMBOL SMALL TAH BELOW
FBD3..FD3D ; Arabic # Lo [363] ARABIC LETTER NG ISOLATED FORM..ARABIC LIGATURE ALEF WITH FATHATAN ISOLATED FORM
@@ -796,8 +792,42 @@
FE70..FE74 ; Arabic # Lo [5] ARABIC FATHATAN ISOLATED FORM..ARABIC KASRATAN ISOLATED FORM
FE76..FEFC ; Arabic # Lo [135] ARABIC FATHA ISOLATED FORM..ARABIC LIGATURE LAM WITH ALEF FINAL FORM
10E60..10E7E ; Arabic # No [31] RUMI DIGIT ONE..RUMI FRACTION TWO THIRDS
+1EE00..1EE03 ; Arabic # Lo [4] ARABIC MATHEMATICAL ALEF..ARABIC MATHEMATICAL DAL
+1EE05..1EE1F ; Arabic # Lo [27] ARABIC MATHEMATICAL WAW..ARABIC MATHEMATICAL DOTLESS QAF
+1EE21..1EE22 ; Arabic # Lo [2] ARABIC MATHEMATICAL INITIAL BEH..ARABIC MATHEMATICAL INITIAL JEEM
+1EE24 ; Arabic # Lo ARABIC MATHEMATICAL INITIAL HEH
+1EE27 ; Arabic # Lo ARABIC MATHEMATICAL INITIAL HAH
+1EE29..1EE32 ; Arabic # Lo [10] ARABIC MATHEMATICAL INITIAL YEH..ARABIC MATHEMATICAL INITIAL QAF
+1EE34..1EE37 ; Arabic # Lo [4] ARABIC MATHEMATICAL INITIAL SHEEN..ARABIC MATHEMATICAL INITIAL KHAH
+1EE39 ; Arabic # Lo ARABIC MATHEMATICAL INITIAL DAD
+1EE3B ; Arabic # Lo ARABIC MATHEMATICAL INITIAL GHAIN
+1EE42 ; Arabic # Lo ARABIC MATHEMATICAL TAILED JEEM
+1EE47 ; Arabic # Lo ARABIC MATHEMATICAL TAILED HAH
+1EE49 ; Arabic # Lo ARABIC MATHEMATICAL TAILED YEH
+1EE4B ; Arabic # Lo ARABIC MATHEMATICAL TAILED LAM
+1EE4D..1EE4F ; Arabic # Lo [3] ARABIC MATHEMATICAL TAILED NOON..ARABIC MATHEMATICAL TAILED AIN
+1EE51..1EE52 ; Arabic # Lo [2] ARABIC MATHEMATICAL TAILED SAD..ARABIC MATHEMATICAL TAILED QAF
+1EE54 ; Arabic # Lo ARABIC MATHEMATICAL TAILED SHEEN
+1EE57 ; Arabic # Lo ARABIC MATHEMATICAL TAILED KHAH
+1EE59 ; Arabic # Lo ARABIC MATHEMATICAL TAILED DAD
+1EE5B ; Arabic # Lo ARABIC MATHEMATICAL TAILED GHAIN
+1EE5D ; Arabic # Lo ARABIC MATHEMATICAL TAILED DOTLESS NOON
+1EE5F ; Arabic # Lo ARABIC MATHEMATICAL TAILED DOTLESS QAF
+1EE61..1EE62 ; Arabic # Lo [2] ARABIC MATHEMATICAL STRETCHED BEH..ARABIC MATHEMATICAL STRETCHED JEEM
+1EE64 ; Arabic # Lo ARABIC MATHEMATICAL STRETCHED HEH
+1EE67..1EE6A ; Arabic # Lo [4] ARABIC MATHEMATICAL STRETCHED HAH..ARABIC MATHEMATICAL STRETCHED KAF
+1EE6C..1EE72 ; Arabic # Lo [7] ARABIC MATHEMATICAL STRETCHED MEEM..ARABIC MATHEMATICAL STRETCHED QAF
+1EE74..1EE77 ; Arabic # Lo [4] ARABIC MATHEMATICAL STRETCHED SHEEN..ARABIC MATHEMATICAL STRETCHED KHAH
+1EE79..1EE7C ; Arabic # Lo [4] ARABIC MATHEMATICAL STRETCHED DAD..ARABIC MATHEMATICAL STRETCHED DOTLESS BEH
+1EE7E ; Arabic # Lo ARABIC MATHEMATICAL STRETCHED DOTLESS FEH
+1EE80..1EE89 ; Arabic # Lo [10] ARABIC MATHEMATICAL LOOPED ALEF..ARABIC MATHEMATICAL LOOPED YEH
+1EE8B..1EE9B ; Arabic # Lo [17] ARABIC MATHEMATICAL LOOPED LAM..ARABIC MATHEMATICAL LOOPED GHAIN
+1EEA1..1EEA3 ; Arabic # Lo [3] ARABIC MATHEMATICAL DOUBLE-STRUCK BEH..ARABIC MATHEMATICAL DOUBLE-STRUCK DAL
+1EEA5..1EEA9 ; Arabic # Lo [5] ARABIC MATHEMATICAL DOUBLE-STRUCK WAW..ARABIC MATHEMATICAL DOUBLE-STRUCK YEH
+1EEAB..1EEBB ; Arabic # Lo [17] ARABIC MATHEMATICAL DOUBLE-STRUCK LAM..ARABIC MATHEMATICAL DOUBLE-STRUCK GHAIN
+1EEF0..1EEF1 ; Arabic # Sm [2] ARABIC MATHEMATICAL OPERATOR MEEM WITH HAH WITH TATWEEL..ARABIC MATHEMATICAL OPERATOR HAH WITH DAL
-# Total code points: 1051
+# Total code points: 1235
# ================================================
@@ -838,6 +868,7 @@
0958..0961 ; Devanagari # Lo [10] DEVANAGARI LETTER QA..DEVANAGARI LETTER VOCALIC LL
0962..0963 ; Devanagari # Mn [2] DEVANAGARI VOWEL SIGN VOCALIC L..DEVANAGARI VOWEL SIGN VOCALIC LL
0966..096F ; Devanagari # Nd [10] DEVANAGARI DIGIT ZERO..DEVANAGARI DIGIT NINE
+0970 ; Devanagari # Po DEVANAGARI ABBREVIATION SIGN
0971 ; Devanagari # Lm DEVANAGARI SIGN HIGH SPACING DOT
0972..0977 ; Devanagari # Lo [6] DEVANAGARI LETTER CANDRA A..DEVANAGARI LETTER UUE
0979..097F ; Devanagari # Lo [7] DEVANAGARI LETTER ZHA..DEVANAGARI LETTER BBA
@@ -846,7 +877,7 @@
A8F8..A8FA ; Devanagari # Po [3] DEVANAGARI SIGN PUSHPIKA..DEVANAGARI CARET
A8FB ; Devanagari # Lo DEVANAGARI HEADSTROKE
-# Total code points: 150
+# Total code points: 151
# ================================================
@@ -927,9 +958,10 @@
0AE0..0AE1 ; Gujarati # Lo [2] GUJARATI LETTER VOCALIC RR..GUJARATI LETTER VOCALIC LL
0AE2..0AE3 ; Gujarati # Mn [2] GUJARATI VOWEL SIGN VOCALIC L..GUJARATI VOWEL SIGN VOCALIC LL
0AE6..0AEF ; Gujarati # Nd [10] GUJARATI DIGIT ZERO..GUJARATI DIGIT NINE
+0AF0 ; Gujarati # Po GUJARATI ABBREVIATION SIGN
0AF1 ; Gujarati # Sc GUJARATI RUPEE SIGN
-# Total code points: 83
+# Total code points: 84
# ================================================
@@ -1119,9 +1151,9 @@
0EC6 ; Lao # Lm LAO KO LA
0EC8..0ECD ; Lao # Mn [6] LAO TONE MAI EK..LAO NIGGAHITA
0ED0..0ED9 ; Lao # Nd [10] LAO DIGIT ZERO..LAO DIGIT NINE
-0EDC..0EDD ; Lao # Lo [2] LAO HO NO..LAO HO MO
+0EDC..0EDF ; Lao # Lo [4] LAO HO NO..LAO LETTER KHMU NYO
-# Total code points: 65
+# Total code points: 67
# ================================================
@@ -1128,7 +1160,9 @@
0F00 ; Tibetan # Lo TIBETAN SYLLABLE OM
0F01..0F03 ; Tibetan # So [3] TIBETAN MARK GTER YIG MGO TRUNCATED A..TIBETAN MARK GTER YIG MGO -UM GTER TSHEG MA
0F04..0F12 ; Tibetan # Po [15] TIBETAN MARK INITIAL YIG MGO MDUN MA..TIBETAN MARK RGYA GRAM SHAD
-0F13..0F17 ; Tibetan # So [5] TIBETAN MARK CARET -DZUD RTAGS ME LONG CAN..TIBETAN ASTROLOGICAL SIGN SGRA GCAN -CHAR RTAGS
+0F13 ; Tibetan # So TIBETAN MARK CARET -DZUD RTAGS ME LONG CAN
+0F14 ; Tibetan # Po TIBETAN MARK GTER TSHEG
+0F15..0F17 ; Tibetan # So [3] TIBETAN LOGOTYPE SIGN CHAD RTAGS..TIBETAN ASTROLOGICAL SIGN SGRA GCAN -CHAR RTAGS
0F18..0F19 ; Tibetan # Mn [2] TIBETAN ASTROLOGICAL SIGN -KHYUD PA..TIBETAN ASTROLOGICAL SIGN SDONG TSHUGS
0F1A..0F1F ; Tibetan # So [6] TIBETAN SIGN RDEL DKAR GCIG..TIBETAN SIGN RDEL DKAR RDEL NAG
0F20..0F29 ; Tibetan # Nd [10] TIBETAN DIGIT ZERO..TIBETAN DIGIT NINE
@@ -1212,16 +1246,21 @@
# ================================================
10A0..10C5 ; Georgian # L& [38] GEORGIAN CAPITAL LETTER AN..GEORGIAN CAPITAL LETTER HOE
+10C7 ; Georgian # L& GEORGIAN CAPITAL LETTER YN
+10CD ; Georgian # L& GEORGIAN CAPITAL LETTER AEN
10D0..10FA ; Georgian # Lo [43] GEORGIAN LETTER AN..GEORGIAN LETTER AIN
10FC ; Georgian # Lm MODIFIER LETTER GEORGIAN NAR
+10FD..10FF ; Georgian # Lo [3] GEORGIAN LETTER AEN..GEORGIAN LETTER LABIAL SIGN
2D00..2D25 ; Georgian # L& [38] GEORGIAN SMALL LETTER AN..GEORGIAN SMALL LETTER HOE
+2D27 ; Georgian # L& GEORGIAN SMALL LETTER YN
+2D2D ; Georgian # L& GEORGIAN SMALL LETTER AEN
-# Total code points: 120
+# Total code points: 127
# ================================================
1100..11FF ; Hangul # Lo [256] HANGUL CHOSEONG KIYEOK..HANGUL JONGSEONG SSANGNIEUN
-302E..302F ; Hangul # Mn [2] HANGUL SINGLE DOT TONE MARK..HANGUL DOUBLE DOT TONE MARK
+302E..302F ; Hangul # Mc [2] HANGUL SINGLE DOT TONE MARK..HANGUL DOUBLE DOT TONE MARK
3131..318E ; Hangul # Lo [94] HANGUL LETTER KIYEOK..HANGUL LETTER ARAEAE
3200..321E ; Hangul # So [31] PARENTHESIZED HANGUL KIYEOK..PARENTHESIZED KOREAN CHARACTER O HU
3260..327E ; Hangul # So [31] CIRCLED HANGUL KIYEOK..CIRCLED HANGUL IEUNG U
@@ -1256,8 +1295,7 @@
1312..1315 ; Ethiopic # Lo [4] ETHIOPIC SYLLABLE GWI..ETHIOPIC SYLLABLE GWE
1318..135A ; Ethiopic # Lo [67] ETHIOPIC SYLLABLE GGA..ETHIOPIC SYLLABLE FYA
135D..135F ; Ethiopic # Mn [3] ETHIOPIC COMBINING GEMINATION AND VOWEL LENGTH MARK..ETHIOPIC COMBINING GEMINATION MARK
-1360 ; Ethiopic # So ETHIOPIC SECTION MARK
-1361..1368 ; Ethiopic # Po [8] ETHIOPIC WORDSPACE..ETHIOPIC PARAGRAPH SEPARATOR
+1360..1368 ; Ethiopic # Po [9] ETHIOPIC SECTION MARK..ETHIOPIC PARAGRAPH SEPARATOR
1369..137C ; Ethiopic # No [20] ETHIOPIC DIGIT ONE..ETHIOPIC NUMBER TEN THOUSAND
1380..138F ; Ethiopic # Lo [16] ETHIOPIC SYLLABLE SEBATBEIT MWA..ETHIOPIC SYLLABLE PWE
1390..1399 ; Ethiopic # So [10] ETHIOPIC TONAL MARK YIZET..ETHIOPIC TONAL MARK KURT
@@ -1313,7 +1351,7 @@
# ================================================
1780..17B3 ; Khmer # Lo [52] KHMER LETTER KA..KHMER INDEPENDENT VOWEL QAU
-17B4..17B5 ; Khmer # Cf [2] KHMER VOWEL INHERENT AQ..KHMER VOWEL INHERENT AA
+17B4..17B5 ; Khmer # Mn [2] KHMER VOWEL INHERENT AQ..KHMER VOWEL INHERENT AA
17B6 ; Khmer # Mc KHMER VOWEL SIGN AA
17B7..17BD ; Khmer # Mn [7] KHMER VOWEL SIGN I..KHMER VOWEL SIGN UA
17BE..17C5 ; Khmer # Mc [8] KHMER VOWEL SIGN OE..KHMER VOWEL SIGN AU
@@ -1393,9 +1431,8 @@
3038..303A ; Han # Nl [3] HANGZHOU NUMERAL TEN..HANGZHOU NUMERAL THIRTY
303B ; Han # Lm VERTICAL IDEOGRAPHIC ITERATION MARK
3400..4DB5 ; Han # Lo [6582] CJK UNIFIED IDEOGRAPH-3400..CJK UNIFIED IDEOGRAPH-4DB5
-4E00..9FCB ; Han # Lo [20940] CJK UNIFIED IDEOGRAPH-4E00..CJK UNIFIED IDEOGRAPH-9FCB
-F900..FA2D ; Han # Lo [302] CJK COMPATIBILITY IDEOGRAPH-F900..CJK COMPATIBILITY IDEOGRAPH-FA2D
-FA30..FA6D ; Han # Lo [62] CJK COMPATIBILITY IDEOGRAPH-FA30..CJK COMPATIBILITY IDEOGRAPH-FA6D
+4E00..9FCC ; Han # Lo [20941] CJK UNIFIED IDEOGRAPH-4E00..CJK UNIFIED IDEOGRAPH-9FCC
+F900..FA6D ; Han # Lo [366] CJK COMPATIBILITY IDEOGRAPH-F900..CJK COMPATIBILITY IDEOGRAPH-FA6D
FA70..FAD9 ; Han # Lo [106] CJK COMPATIBILITY IDEOGRAPH-FA70..CJK COMPATIBILITY IDEOGRAPH-FAD9
20000..2A6D6 ; Han # Lo [42711] CJK UNIFIED IDEOGRAPH-20000..CJK UNIFIED IDEOGRAPH-2A6D6
2A700..2B734 ; Han # Lo [4149] CJK UNIFIED IDEOGRAPH-2A700..CJK UNIFIED IDEOGRAPH-2B734
@@ -1402,7 +1439,7 @@
2B740..2B81D ; Han # Lo [222] CJK UNIFIED IDEOGRAPH-2B740..CJK UNIFIED IDEOGRAPH-2B81D
2F800..2FA1D ; Han # Lo [542] CJK COMPATIBILITY IDEOGRAPH-2F800..CJK COMPATIBILITY IDEOGRAPH-2FA1D
-# Total code points: 75960
+# Total code points: 75963
# ================================================
@@ -1440,7 +1477,6 @@
0300..036F ; Inherited # Mn [112] COMBINING GRAVE ACCENT..COMBINING LATIN SMALL LETTER X
0485..0486 ; Inherited # Mn [2] COMBINING CYRILLIC DASIA PNEUMATA..COMBINING CYRILLIC PSILI PNEUMATA
064B..0655 ; Inherited # Mn [11] ARABIC FATHATAN..ARABIC HAMZA BELOW
-065F ; Inherited # Mn ARABIC WAVY HAMZA BELOW
0670 ; Inherited # Mn ARABIC LETTER SUPERSCRIPT ALEF
0951..0952 ; Inherited # Mn [2] DEVANAGARI STRESS SIGN UDATTA..DEVANAGARI STRESS SIGN ANUDATTA
1CD0..1CD2 ; Inherited # Mn [3] VEDIC TONE KARSHANA..VEDIC TONE PRENKHA
@@ -1447,6 +1483,7 @@
1CD4..1CE0 ; Inherited # Mn [13] VEDIC SIGN YAJURVEDIC MIDLINE SVARITA..VEDIC TONE RIGVEDIC KASHMIRI INDEPENDENT SVARITA
1CE2..1CE8 ; Inherited # Mn [7] VEDIC SIGN VISARGA SVARITA..VEDIC SIGN VISARGA ANUDATTA WITH TAIL
1CED ; Inherited # Mn VEDIC SIGN TIRYAK
+1CF4 ; Inherited # Mn VEDIC TONE CANDRA ABOVE
1DC0..1DE6 ; Inherited # Mn [39] COMBINING DOTTED GRAVE ACCENT..COMBINING LATIN SMALL LETTER Z
1DFC..1DFF ; Inherited # Mn [4] COMBINING DOUBLE INVERTED BREVE BELOW..COMBINING RIGHT ARROWHEAD AND DOWN ARROWHEAD BELOW
200C..200D ; Inherited # Cf [2] ZERO WIDTH NON-JOINER..ZERO WIDTH JOINER
@@ -1587,11 +1624,12 @@
2CE5..2CEA ; Coptic # So [6] COPTIC SYMBOL MI RO..COPTIC SYMBOL SHIMA SIMA
2CEB..2CEE ; Coptic # L& [4] COPTIC CAPITAL LETTER CRYPTOGRAMMIC SHEI..COPTIC SMALL LETTER CRYPTOGRAMMIC GANGIA
2CEF..2CF1 ; Coptic # Mn [3] COPTIC COMBINING NI ABOVE..COPTIC COMBINING SPIRITUS LENIS
+2CF2..2CF3 ; Coptic # L& [2] COPTIC CAPITAL LETTER BOHAIRIC KHEI..COPTIC SMALL LETTER BOHAIRIC KHEI
2CF9..2CFC ; Coptic # Po [4] COPTIC OLD NUBIAN FULL STOP..COPTIC OLD NUBIAN VERSE DIVIDER
2CFD ; Coptic # No COPTIC FRACTION ONE HALF
2CFE..2CFF ; Coptic # Po [2] COPTIC FULL STOP..COPTIC MORPHOLOGICAL DIVIDER
-# Total code points: 135
+# Total code points: 137
# ================================================
@@ -1614,12 +1652,12 @@
# ================================================
-2D30..2D65 ; Tifinagh # Lo [54] TIFINAGH LETTER YA..TIFINAGH LETTER YAZZ
+2D30..2D67 ; Tifinagh # Lo [56] TIFINAGH LETTER YA..TIFINAGH LETTER YO
2D6F ; Tifinagh # Lm TIFINAGH MODIFIER LETTER LABIALIZATION MARK
2D70 ; Tifinagh # Po TIFINAGH SEPARATOR MARK
2D7F ; Tifinagh # Mn TIFINAGH CONSONANT JOINER
-# Total code points: 57
+# Total code points: 59
# ================================================
@@ -1729,10 +1767,14 @@
1BA6..1BA7 ; Sundanese # Mc [2] SUNDANESE VOWEL SIGN PANAELAENG..SUNDANESE VOWEL SIGN PANOLONG
1BA8..1BA9 ; Sundanese # Mn [2] SUNDANESE VOWEL SIGN PAMEPET..SUNDANESE VOWEL SIGN PANEULEUNG
1BAA ; Sundanese # Mc SUNDANESE SIGN PAMAAEH
+1BAB ; Sundanese # Mn SUNDANESE SIGN VIRAMA
+1BAC..1BAD ; Sundanese # Mc [2] SUNDANESE CONSONANT SIGN PASANGAN MA..SUNDANESE CONSONANT SIGN PASANGAN WA
1BAE..1BAF ; Sundanese # Lo [2] SUNDANESE LETTER KHA..SUNDANESE LETTER SYA
1BB0..1BB9 ; Sundanese # Nd [10] SUNDANESE DIGIT ZERO..SUNDANESE DIGIT NINE
+1BBA..1BBF ; Sundanese # Lo [6] SUNDANESE AVAGRAHA..SUNDANESE LETTER FINAL M
+1CC0..1CC7 ; Sundanese # Po [8] SUNDANESE PUNCTUATION BINDU SURYA..SUNDANESE PUNCTUATION BINDU BA SATANGA
-# Total code points: 55
+# Total code points: 72
# ================================================
@@ -1940,6 +1982,15 @@
# ================================================
+AAE0..AAEA ; Meetei_Mayek # Lo [11] MEETEI MAYEK LETTER E..MEETEI MAYEK LETTER SSA
+AAEB ; Meetei_Mayek # Mc MEETEI MAYEK VOWEL SIGN II
+AAEC..AAED ; Meetei_Mayek # Mn [2] MEETEI MAYEK VOWEL SIGN UU..MEETEI MAYEK VOWEL SIGN AAI
+AAEE..AAEF ; Meetei_Mayek # Mc [2] MEETEI MAYEK VOWEL SIGN AU..MEETEI MAYEK VOWEL SIGN AAU
+AAF0..AAF1 ; Meetei_Mayek # Po [2] MEETEI MAYEK CHEIKHAN..MEETEI MAYEK AHANG KHUDAM
+AAF2 ; Meetei_Mayek # Lo MEETEI MAYEK ANJI
+AAF3..AAF4 ; Meetei_Mayek # Lm [2] MEETEI MAYEK SYLLABLE REPETITION MARK..MEETEI MAYEK WORD REPETITION MARK
+AAF5 ; Meetei_Mayek # Mc MEETEI MAYEK VOWEL SIGN VISARGA
+AAF6 ; Meetei_Mayek # Mn MEETEI MAYEK VIRAMA
ABC0..ABE2 ; Meetei_Mayek # Lo [35] MEETEI MAYEK LETTER KOK..MEETEI MAYEK LETTER I LONSUM
ABE3..ABE4 ; Meetei_Mayek # Mc [2] MEETEI MAYEK VOWEL SIGN ONAP..MEETEI MAYEK VOWEL SIGN INAP
ABE5 ; Meetei_Mayek # Mn MEETEI MAYEK VOWEL SIGN ANAP
@@ -1951,7 +2002,7 @@
ABED ; Meetei_Mayek # Mn MEETEI MAYEK APUN IYEK
ABF0..ABF9 ; Meetei_Mayek # Nd [10] MEETEI MAYEK DIGIT ZERO..MEETEI MAYEK DIGIT NINE
-# Total code points: 56
+# Total code points: 79
# ================================================
@@ -2040,4 +2091,74 @@
# Total code points: 29
+# ================================================
+
+11100..11102 ; Chakma # Mn [3] CHAKMA SIGN CANDRABINDU..CHAKMA SIGN VISARGA
+11103..11126 ; Chakma # Lo [36] CHAKMA LETTER AA..CHAKMA LETTER HAA
+11127..1112B ; Chakma # Mn [5] CHAKMA VOWEL SIGN A..CHAKMA VOWEL SIGN UU
+1112C ; Chakma # Mc CHAKMA VOWEL SIGN E
+1112D..11134 ; Chakma # Mn [8] CHAKMA VOWEL SIGN AI..CHAKMA MAAYYAA
+11136..1113F ; Chakma # Nd [10] CHAKMA DIGIT ZERO..CHAKMA DIGIT NINE
+11140..11143 ; Chakma # Po [4] CHAKMA SECTION MARK..CHAKMA QUESTION MARK
+
+# Total code points: 67
+
+# ================================================
+
+109A0..109B7 ; Meroitic_Cursive # Lo [24] MEROITIC CURSIVE LETTER A..MEROITIC CURSIVE LETTER DA
+109BE..109BF ; Meroitic_Cursive # Lo [2] MEROITIC CURSIVE LOGOGRAM RMT..MEROITIC CURSIVE LOGOGRAM IMN
+
+# Total code points: 26
+
+# ================================================
+
+10980..1099F ; Meroitic_Hieroglyphs # Lo [32] MEROITIC HIEROGLYPHIC LETTER A..MEROITIC HIEROGLYPHIC SYMBOL VIDJ-2
+
+# Total code points: 32
+
+# ================================================
+
+16F00..16F44 ; Miao # Lo [69] MIAO LETTER PA..MIAO LETTER HHA
+16F50 ; Miao # Lo MIAO LETTER NASALIZATION
+16F51..16F7E ; Miao # Mc [46] MIAO SIGN ASPIRATION..MIAO VOWEL SIGN NG
+16F8F..16F92 ; Miao # Mn [4] MIAO TONE RIGHT..MIAO TONE BELOW
+16F93..16F9F ; Miao # Lm [13] MIAO LETTER TONE-2..MIAO LETTER REFORMED TONE-8
+
+# Total code points: 133
+
+# ================================================
+
+11180..11181 ; Sharada # Mn [2] SHARADA SIGN CANDRABINDU..SHARADA SIGN ANUSVARA
+11182 ; Sharada # Mc SHARADA SIGN VISARGA
+11183..111B2 ; Sharada # Lo [48] SHARADA LETTER A..SHARADA LETTER HA
+111B3..111B5 ; Sharada # Mc [3] SHARADA VOWEL SIGN AA..SHARADA VOWEL SIGN II
+111B6..111BE ; Sharada # Mn [9] SHARADA VOWEL SIGN U..SHARADA VOWEL SIGN O
+111BF..111C0 ; Sharada # Mc [2] SHARADA VOWEL SIGN AU..SHARADA SIGN VIRAMA
+111C1..111C4 ; Sharada # Lo [4] SHARADA SIGN AVAGRAHA..SHARADA OM
+111C5..111C8 ; Sharada # Po [4] SHARADA DANDA..SHARADA SEPARATOR
+111D0..111D9 ; Sharada # Nd [10] SHARADA DIGIT ZERO..SHARADA DIGIT NINE
+
+# Total code points: 83
+
+# ================================================
+
+110D0..110E8 ; Sora_Sompeng # Lo [25] SORA SOMPENG LETTER SAH..SORA SOMPENG LETTER MAE
+110F0..110F9 ; Sora_Sompeng # Nd [10] SORA SOMPENG DIGIT ZERO..SORA SOMPENG DIGIT NINE
+
+# Total code points: 35
+
+# ================================================
+
+11680..116AA ; Takri # Lo [43] TAKRI LETTER A..TAKRI LETTER RRA
+116AB ; Takri # Mn TAKRI SIGN ANUSVARA
+116AC ; Takri # Mc TAKRI SIGN VISARGA
+116AD ; Takri # Mn TAKRI VOWEL SIGN AA
+116AE..116AF ; Takri # Mc [2] TAKRI VOWEL SIGN I..TAKRI VOWEL SIGN II
+116B0..116B5 ; Takri # Mn [6] TAKRI VOWEL SIGN U..TAKRI VOWEL SIGN AU
+116B6 ; Takri # Mc TAKRI SIGN VIRAMA
+116B7 ; Takri # Mn TAKRI SIGN NUKTA
+116C0..116C9 ; Takri # Nd [10] TAKRI DIGIT ZERO..TAKRI DIGIT NINE
+
+# Total code points: 66
+
# EOF
Property changes on: trunk/contrib/perl/lib/unicore/Scripts.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/SpecialCasing.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/SpecialCasing.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/SpecialCasing.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,8 +1,8 @@
-# SpecialCasing-6.0.0.txt
-# Date: 2010-05-18, 00:49:39 GMT [MD]
+# SpecialCasing-6.2.0.txt
+# Date: 2012-05-23, 20:35:15 GMT [MD]
#
# Unicode Character Database
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
# For documentation, see http://www.unicode.org/reports/tr44/
#
@@ -47,7 +47,9 @@
# * Additional contexts
# * Additional fields
# ================================================================================
-# @missing 0000..10FFFF; <slc>; <stc>; <suc>
+
+# @missing: 0000..10FFFF; <slc>; <stc>; <suc>;
+
# ================================================================================
# Unconditional mappings
# ================================================================================
Property changes on: trunk/contrib/perl/lib/unicore/SpecialCasing.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/StandardizedVariants.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/StandardizedVariants.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/StandardizedVariants.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,13 +1,13 @@
-# StandardizedVariants-6.0.0.txt
-# Date: 2010-05-19, 11:22:00 PDT [KW]
+# StandardizedVariants-6.2.0.txt
+# Date: 2012-05-15, 21:53:00 GMT [KW, LI]
#
-# Specification of the variant sequences that are defined in the
+# Specification of the variation sequences that are defined in the
# Unicode Standard.
#
# This file is a normative contributory data file in the
# Unicode Character Database.
#
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
#
# Standardized variation sequences are defined in this file.
@@ -21,9 +21,9 @@
#
# For more information on standardized variation sequences,
# see Section 16.4, Variation Selectors,
-# in The Unicode Standard, Version 6.0.
+# in The Unicode Standard, Version 6.2.
#
-# For more information on the Ideographic Variation Database
+# For more information on the Ideographic Variation Database,
# see http://www.unicode.org/ivd/
#
# Format:
@@ -44,7 +44,7 @@
2273 FE00; following the slant of the lower leg; # GREATER-THAN OR EQUIVALENT TO
# The following two entries were originally defined for Unicode 3.2
# but were determined to be in error and were removed from the list
-# of standardized variation sequences. The entries are left commented
+# of standardized variation sequences. The entries are left commented out
# in the file for the historical record of changes made to the data.
#2278 FE00; with vertical stroke; # NEITHER LESS-THAN NOR GREATER-THAN
#2279 FE00; with vertical stroke; # NEITHER GREATER-THAN NOR LESS-THAN
@@ -141,3 +141,225 @@
1887 180D; fourth form; final # MONGOLIAN LETTER ALI GALI A
1888 180B; second form; final # MONGOLIAN LETTER ALI GALI I
188A 180B; second form; initial medial # MONGOLIAN LETTER ALI GALI NGA
+
+# Emoji variation sequences for use as part of keycap symbols
+
+0023 FE0E; text style; # NUMBER SIGN
+0023 FE0F; emoji style; # NUMBER SIGN
+0030 FE0E; text style; # DIGIT ZERO
+0030 FE0F; emoji style; # DIGIT ZERO
+0031 FE0E; text style; # DIGIT ONE
+0031 FE0F; emoji style; # DIGIT ONE
+0032 FE0E; text style; # DIGIT TWO
+0032 FE0F; emoji style; # DIGIT TWO
+0033 FE0E; text style; # DIGIT THREE
+0033 FE0F; emoji style; # DIGIT THREE
+0034 FE0E; text style; # DIGIT FOUR
+0034 FE0F; emoji style; # DIGIT FOUR
+0035 FE0E; text style; # DIGIT FIVE
+0035 FE0F; emoji style; # DIGIT FIVE
+0036 FE0E; text style; # DIGIT SIX
+0036 FE0F; emoji style; # DIGIT SIX
+0037 FE0E; text style; # DIGIT SEVEN
+0037 FE0F; emoji style; # DIGIT SEVEN
+0038 FE0E; text style; # DIGIT EIGHT
+0038 FE0F; emoji style; # DIGIT EIGHT
+0039 FE0E; text style; # DIGIT NINE
+0039 FE0F; emoji style; # DIGIT NINE
+
+# Emoji variation sequences
+
+203C FE0E; text style; # DOUBLE EXCLAMATION MARK
+203C FE0F; emoji style; # DOUBLE EXCLAMATION MARK
+2049 FE0E; text style; # EXCLAMATION QUESTION MARK
+2049 FE0F; emoji style; # EXCLAMATION QUESTION MARK
+2139 FE0E; text style; # INFORMATION SOURCE
+2139 FE0F; emoji style; # INFORMATION SOURCE
+2194 FE0E; text style; # LEFT RIGHT ARROW
+2194 FE0F; emoji style; # LEFT RIGHT ARROW
+2195 FE0E; text style; # UP DOWN ARROW
+2195 FE0F; emoji style; # UP DOWN ARROW
+2196 FE0E; text style; # NORTH WEST ARROW
+2196 FE0F; emoji style; # NORTH WEST ARROW
+2197 FE0E; text style; # NORTH EAST ARROW
+2197 FE0F; emoji style; # NORTH EAST ARROW
+2198 FE0E; text style; # SOUTH EAST ARROW
+2198 FE0F; emoji style; # SOUTH EAST ARROW
+2199 FE0E; text style; # SOUTH WEST ARROW
+2199 FE0F; emoji style; # SOUTH WEST ARROW
+21A9 FE0E; text style; # LEFTWARDS ARROW WITH HOOK
+21A9 FE0F; emoji style; # LEFTWARDS ARROW WITH HOOK
+21AA FE0E; text style; # RIGHTWARDS ARROW WITH HOOK
+21AA FE0F; emoji style; # RIGHTWARDS ARROW WITH HOOK
+231A FE0E; text style; # WATCH
+231A FE0F; emoji style; # WATCH
+231B FE0E; text style; # HOURGLASS
+231B FE0F; emoji style; # HOURGLASS
+24C2 FE0E; text style; # CIRCLED LATIN CAPITAL LETTER M
+24C2 FE0F; emoji style; # CIRCLED LATIN CAPITAL LETTER M
+25AA FE0E; text style; # BLACK SMALL SQUARE
+25AA FE0F; emoji style; # BLACK SMALL SQUARE
+25AB FE0E; text style; # WHITE SMALL SQUARE
+25AB FE0F; emoji style; # WHITE SMALL SQUARE
+25B6 FE0E; text style; # BLACK RIGHT-POINTING TRIANGLE
+25B6 FE0F; emoji style; # BLACK RIGHT-POINTING TRIANGLE
+25C0 FE0E; text style; # BLACK LEFT-POINTING TRIANGLE
+25C0 FE0F; emoji style; # BLACK LEFT-POINTING TRIANGLE
+25FB FE0E; text style; # WHITE MEDIUM SQUARE
+25FB FE0F; emoji style; # WHITE MEDIUM SQUARE
+25FC FE0E; text style; # BLACK MEDIUM SQUARE
+25FC FE0F; emoji style; # BLACK MEDIUM SQUARE
+25FD FE0E; text style; # WHITE MEDIUM SMALL SQUARE
+25FD FE0F; emoji style; # WHITE MEDIUM SMALL SQUARE
+25FE FE0E; text style; # BLACK MEDIUM SMALL SQUARE
+25FE FE0F; emoji style; # BLACK MEDIUM SMALL SQUARE
+2600 FE0E; text style; # BLACK SUN WITH RAYS
+2600 FE0F; emoji style; # BLACK SUN WITH RAYS
+2601 FE0E; text style; # CLOUD
+2601 FE0F; emoji style; # CLOUD
+260E FE0E; text style; # BLACK TELEPHONE
+260E FE0F; emoji style; # BLACK TELEPHONE
+2611 FE0E; text style; # BALLOT BOX WITH CHECK
+2611 FE0F; emoji style; # BALLOT BOX WITH CHECK
+2614 FE0E; text style; # UMBRELLA WITH RAIN DROPS
+2614 FE0F; emoji style; # UMBRELLA WITH RAIN DROPS
+2615 FE0E; text style; # HOT BEVERAGE
+2615 FE0F; emoji style; # HOT BEVERAGE
+261D FE0E; text style; # WHITE UP POINTING INDEX
+261D FE0F; emoji style; # WHITE UP POINTING INDEX
+263A FE0E; text style; # WHITE SMILING FACE
+263A FE0F; emoji style; # WHITE SMILING FACE
+2648 FE0E; text style; # ARIES
+2648 FE0F; emoji style; # ARIES
+2649 FE0E; text style; # TAURUS
+2649 FE0F; emoji style; # TAURUS
+264A FE0E; text style; # GEMINI
+264A FE0F; emoji style; # GEMINI
+264B FE0E; text style; # CANCER
+264B FE0F; emoji style; # CANCER
+264C FE0E; text style; # LEO
+264C FE0F; emoji style; # LEO
+264D FE0E; text style; # VIRGO
+264D FE0F; emoji style; # VIRGO
+264E FE0E; text style; # LIBRA
+264E FE0F; emoji style; # LIBRA
+264F FE0E; text style; # SCORPIUS
+264F FE0F; emoji style; # SCORPIUS
+2650 FE0E; text style; # SAGITTARIUS
+2650 FE0F; emoji style; # SAGITTARIUS
+2651 FE0E; text style; # CAPRICORN
+2651 FE0F; emoji style; # CAPRICORN
+2652 FE0E; text style; # AQUARIUS
+2652 FE0F; emoji style; # AQUARIUS
+2653 FE0E; text style; # PISCES
+2653 FE0F; emoji style; # PISCES
+2660 FE0E; text style; # BLACK SPADE SUIT
+2660 FE0F; emoji style; # BLACK SPADE SUIT
+2663 FE0E; text style; # BLACK CLUB SUIT
+2663 FE0F; emoji style; # BLACK CLUB SUIT
+2665 FE0E; text style; # BLACK HEART SUIT
+2665 FE0F; emoji style; # BLACK HEART SUIT
+2666 FE0E; text style; # BLACK DIAMOND SUIT
+2666 FE0F; emoji style; # BLACK DIAMOND SUIT
+2668 FE0E; text style; # HOT SPRINGS
+2668 FE0F; emoji style; # HOT SPRINGS
+267B FE0E; text style; # BLACK UNIVERSAL RECYCLING SYMBOL
+267B FE0F; emoji style; # BLACK UNIVERSAL RECYCLING SYMBOL
+267F FE0E; text style; # WHEELCHAIR SYMBOL
+267F FE0F; emoji style; # WHEELCHAIR SYMBOL
+2693 FE0E; text style; # ANCHOR
+2693 FE0F; emoji style; # ANCHOR
+26A0 FE0E; text style; # WARNING SIGN
+26A0 FE0F; emoji style; # WARNING SIGN
+26A1 FE0E; text style; # HIGH VOLTAGE SIGN
+26A1 FE0F; emoji style; # HIGH VOLTAGE SIGN
+26AA FE0E; text style; # MEDIUM WHITE CIRCLE
+26AA FE0F; emoji style; # MEDIUM WHITE CIRCLE
+26AB FE0E; text style; # MEDIUM BLACK CIRCLE
+26AB FE0F; emoji style; # MEDIUM BLACK CIRCLE
+26BD FE0E; text style; # SOCCER BALL
+26BD FE0F; emoji style; # SOCCER BALL
+26BE FE0E; text style; # BASEBALL
+26BE FE0F; emoji style; # BASEBALL
+26C4 FE0E; text style; # SNOWMAN WITHOUT SNOW
+26C4 FE0F; emoji style; # SNOWMAN WITHOUT SNOW
+26C5 FE0E; text style; # SUN BEHIND CLOUD
+26C5 FE0F; emoji style; # SUN BEHIND CLOUD
+26D4 FE0E; text style; # NO ENTRY
+26D4 FE0F; emoji style; # NO ENTRY
+26EA FE0E; text style; # CHURCH
+26EA FE0F; emoji style; # CHURCH
+26F2 FE0E; text style; # FOUNTAIN
+26F2 FE0F; emoji style; # FOUNTAIN
+26F3 FE0E; text style; # FLAG IN HOLE
+26F3 FE0F; emoji style; # FLAG IN HOLE
+26F5 FE0E; text style; # SAILBOAT
+26F5 FE0F; emoji style; # SAILBOAT
+26FA FE0E; text style; # TENT
+26FA FE0F; emoji style; # TENT
+26FD FE0E; text style; # FUEL PUMP
+26FD FE0F; emoji style; # FUEL PUMP
+2702 FE0E; text style; # BLACK SCISSORS
+2702 FE0F; emoji style; # BLACK SCISSORS
+2708 FE0E; text style; # AIRPLANE
+2708 FE0F; emoji style; # AIRPLANE
+2709 FE0E; text style; # ENVELOPE
+2709 FE0F; emoji style; # ENVELOPE
+270C FE0E; text style; # VICTORY HAND
+270C FE0F; emoji style; # VICTORY HAND
+270F FE0E; text style; # PENCIL
+270F FE0F; emoji style; # PENCIL
+2712 FE0E; text style; # BLACK NIB
+2712 FE0F; emoji style; # BLACK NIB
+2714 FE0E; text style; # HEAVY CHECK MARK
+2714 FE0F; emoji style; # HEAVY CHECK MARK
+2716 FE0E; text style; # HEAVY MULTIPLICATION X
+2716 FE0F; emoji style; # HEAVY MULTIPLICATION X
+2733 FE0E; text style; # EIGHT SPOKED ASTERISK
+2733 FE0F; emoji style; # EIGHT SPOKED ASTERISK
+2734 FE0E; text style; # EIGHT POINTED BLACK STAR
+2734 FE0F; emoji style; # EIGHT POINTED BLACK STAR
+2744 FE0E; text style; # SNOWFLAKE
+2744 FE0F; emoji style; # SNOWFLAKE
+2747 FE0E; text style; # SPARKLE
+2747 FE0F; emoji style; # SPARKLE
+2757 FE0E; text style; # HEAVY EXCLAMATION MARK SYMBOL
+2757 FE0F; emoji style; # HEAVY EXCLAMATION MARK SYMBOL
+2764 FE0E; text style; # HEAVY BLACK HEART
+2764 FE0F; emoji style; # HEAVY BLACK HEART
+27A1 FE0E; text style; # BLACK RIGHTWARDS ARROW
+27A1 FE0F; emoji style; # BLACK RIGHTWARDS ARROW
+2934 FE0E; text style; # ARROW POINTING RIGHTWARDS THEN CURVING UPWARDS
+2934 FE0F; emoji style; # ARROW POINTING RIGHTWARDS THEN CURVING UPWARDS
+2935 FE0E; text style; # ARROW POINTING RIGHTWARDS THEN CURVING DOWNWARDS
+2935 FE0F; emoji style; # ARROW POINTING RIGHTWARDS THEN CURVING DOWNWARDS
+2B05 FE0E; text style; # LEFTWARDS BLACK ARROW
+2B05 FE0F; emoji style; # LEFTWARDS BLACK ARROW
+2B06 FE0E; text style; # UPWARDS BLACK ARROW
+2B06 FE0F; emoji style; # UPWARDS BLACK ARROW
+2B07 FE0E; text style; # DOWNWARDS BLACK ARROW
+2B07 FE0F; emoji style; # DOWNWARDS BLACK ARROW
+2B1B FE0E; text style; # BLACK LARGE SQUARE
+2B1B FE0F; emoji style; # BLACK LARGE SQUARE
+2B1C FE0E; text style; # WHITE LARGE SQUARE
+2B1C FE0F; emoji style; # WHITE LARGE SQUARE
+2B50 FE0E; text style; # WHITE MEDIUM STAR
+2B50 FE0F; emoji style; # WHITE MEDIUM STAR
+2B55 FE0E; text style; # HEAVY LARGE CIRCLE
+2B55 FE0F; emoji style; # HEAVY LARGE CIRCLE
+303D FE0E; text style; # PART ALTERNATION MARK
+303D FE0F; emoji style; # PART ALTERNATION MARK
+3297 FE0E; text style; # CIRCLED IDEOGRAPH CONGRATULATION
+3297 FE0F; emoji style; # CIRCLED IDEOGRAPH CONGRATULATION
+3299 FE0E; text style; # CIRCLED IDEOGRAPH SECRET
+3299 FE0F; emoji style; # CIRCLED IDEOGRAPH SECRET
+1F004 FE0E; text style; # MAHJONG TILE RED DRAGON
+1F004 FE0F; emoji style; # MAHJONG TILE RED DRAGON
+1F17F FE0E; text style; # NEGATIVE SQUARED LATIN CAPITAL LETTER P
+1F17F FE0F; emoji style; # NEGATIVE SQUARED LATIN CAPITAL LETTER P
+1F21A FE0E; text style; # SQUARED CJK UNIFIED IDEOGRAPH-7121
+1F21A FE0F; emoji style; # SQUARED CJK UNIFIED IDEOGRAPH-7121
+1F22F FE0E; text style; # SQUARED CJK UNIFIED IDEOGRAPH-6307
+1F22F FE0F; emoji style; # SQUARED CJK UNIFIED IDEOGRAPH-6307
+
+# EOF
Property changes on: trunk/contrib/perl/lib/unicore/StandardizedVariants.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/UnicodeData.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/UnicodeData.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/UnicodeData.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -165,10 +165,10 @@
00A4;CURRENCY SIGN;Sc;0;ET;;;;;N;;;;;
00A5;YEN SIGN;Sc;0;ET;;;;;N;;;;;
00A6;BROKEN BAR;So;0;ON;;;;;N;BROKEN VERTICAL BAR;;;;
-00A7;SECTION SIGN;So;0;ON;;;;;N;;;;;
+00A7;SECTION SIGN;Po;0;ON;;;;;N;;;;;
00A8;DIAERESIS;Sk;0;ON;<compat> 0020 0308;;;;N;SPACING DIAERESIS;;;;
00A9;COPYRIGHT SIGN;So;0;ON;;;;;N;;;;;
-00AA;FEMININE ORDINAL INDICATOR;Ll;0;L;<super> 0061;;;;N;;;;;
+00AA;FEMININE ORDINAL INDICATOR;Lo;0;L;<super> 0061;;;;N;;;;;
00AB;LEFT-POINTING DOUBLE ANGLE QUOTATION MARK;Pi;0;ON;;;;;Y;LEFT POINTING GUILLEMET;;;;
00AC;NOT SIGN;Sm;0;ON;;;;;N;;;;;
00AD;SOFT HYPHEN;Cf;0;BN;;;;;N;;;;;
@@ -180,11 +180,11 @@
00B3;SUPERSCRIPT THREE;No;0;EN;<super> 0033;;3;3;N;SUPERSCRIPT DIGIT THREE;;;;
00B4;ACUTE ACCENT;Sk;0;ON;<compat> 0020 0301;;;;N;SPACING ACUTE;;;;
00B5;MICRO SIGN;Ll;0;L;<compat> 03BC;;;;N;;;039C;;039C
-00B6;PILCROW SIGN;So;0;ON;;;;;N;PARAGRAPH SIGN;;;;
+00B6;PILCROW SIGN;Po;0;ON;;;;;N;PARAGRAPH SIGN;;;;
00B7;MIDDLE DOT;Po;0;ON;;;;;N;;;;;
00B8;CEDILLA;Sk;0;ON;<compat> 0020 0327;;;;N;SPACING CEDILLA;;;;
00B9;SUPERSCRIPT ONE;No;0;EN;<super> 0031;;1;1;N;SUPERSCRIPT DIGIT ONE;;;;
-00BA;MASCULINE ORDINAL INDICATOR;Ll;0;L;<super> 006F;;;;N;;;;;
+00BA;MASCULINE ORDINAL INDICATOR;Lo;0;L;<super> 006F;;;;N;;;;;
00BB;RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK;Pf;0;ON;;;;;Y;RIGHT POINTING GUILLEMET;;;;
00BC;VULGAR FRACTION ONE QUARTER;No;0;ON;<fraction> 0031 2044 0034;;;1/4;N;FRACTION ONE QUARTER;;;;
00BD;VULGAR FRACTION ONE HALF;No;0;ON;<fraction> 0031 2044 0032;;;1/2;N;FRACTION ONE HALF;;;;
@@ -612,7 +612,7 @@
0263;LATIN SMALL LETTER GAMMA;Ll;0;L;;;;;N;;;0194;;0194
0264;LATIN SMALL LETTER RAMS HORN;Ll;0;L;;;;;N;LATIN SMALL LETTER BABY GAMMA;;;;
0265;LATIN SMALL LETTER TURNED H;Ll;0;L;;;;;N;;;A78D;;A78D
-0266;LATIN SMALL LETTER H WITH HOOK;Ll;0;L;;;;;N;LATIN SMALL LETTER H HOOK;;;;
+0266;LATIN SMALL LETTER H WITH HOOK;Ll;0;L;;;;;N;LATIN SMALL LETTER H HOOK;;A7AA;;A7AA
0267;LATIN SMALL LETTER HENG WITH HOOK;Ll;0;L;;;;;N;LATIN SMALL LETTER HENG HOOK;;;;
0268;LATIN SMALL LETTER I WITH STROKE;Ll;0;L;;;;;N;LATIN SMALL LETTER BARRED I;;0197;;0197
0269;LATIN SMALL LETTER IOTA;Ll;0;L;;;;;N;;;0196;;0196
@@ -1394,6 +1394,7 @@
0587;ARMENIAN SMALL LIGATURE ECH YIWN;Ll;0;L;<compat> 0565 0582;;;;N;;;;;
0589;ARMENIAN FULL STOP;Po;0;L;;;;;N;ARMENIAN PERIOD;;;;
058A;ARMENIAN HYPHEN;Pd;0;ON;;;;;N;;;;;
+058F;ARMENIAN DRAM SIGN;Sc;0;ET;;;;;N;;;;;
0591;HEBREW ACCENT ETNAHTA;Mn;220;NSM;;;;;N;;;;;
0592;HEBREW ACCENT SEGOL;Mn;230;NSM;;;;;N;;;;;
0593;HEBREW ACCENT SHALSHELET;Mn;230;NSM;;;;;N;;;;;
@@ -1485,6 +1486,7 @@
0601;ARABIC SIGN SANAH;Cf;0;AN;;;;;N;;;;;
0602;ARABIC FOOTNOTE MARKER;Cf;0;AN;;;;;N;;;;;
0603;ARABIC SIGN SAFHA;Cf;0;AN;;;;;N;;;;;
+0604;ARABIC SIGN SAMVAT;Cf;0;AN;;;;;N;;;;;
0606;ARABIC-INDIC CUBE ROOT;Sm;0;ON;;;;;N;;;;;
0607;ARABIC-INDIC FOURTH ROOT;Sm;0;ON;;;;;N;;;;;
0608;ARABIC RAY;Sm;0;AL;;;;;N;;;;;
@@ -1747,7 +1749,7 @@
070B;SYRIAC HARKLEAN OBELUS;Po;0;AL;;;;;N;;;;;
070C;SYRIAC HARKLEAN METOBELUS;Po;0;AL;;;;;N;;;;;
070D;SYRIAC HARKLEAN ASTERISCUS;Po;0;AL;;;;;N;;;;;
-070F;SYRIAC ABBREVIATION MARK;Cf;0;AN;;;;;N;;;;;
+070F;SYRIAC ABBREVIATION MARK;Cf;0;AL;;;;;N;;;;;
0710;SYRIAC LETTER ALAPH;Lo;0;AL;;;;;N;;;;;
0711;SYRIAC LETTER SUPERSCRIPT ALAPH;Mn;36;NSM;;;;;N;;;;;
0712;SYRIAC LETTER BETH;Lo;0;AL;;;;;N;;;;;
@@ -2057,6 +2059,45 @@
085A;MANDAIC VOCALIZATION MARK;Mn;220;NSM;;;;;N;;;;;
085B;MANDAIC GEMINATION MARK;Mn;220;NSM;;;;;N;;;;;
085E;MANDAIC PUNCTUATION;Po;0;R;;;;;N;;;;;
+08A0;ARABIC LETTER BEH WITH SMALL V BELOW;Lo;0;AL;;;;;N;;;;;
+08A2;ARABIC LETTER JEEM WITH TWO DOTS ABOVE;Lo;0;AL;;;;;N;;;;;
+08A3;ARABIC LETTER TAH WITH TWO DOTS ABOVE;Lo;0;AL;;;;;N;;;;;
+08A4;ARABIC LETTER FEH WITH DOT BELOW AND THREE DOTS ABOVE;Lo;0;AL;;;;;N;;;;;
+08A5;ARABIC LETTER QAF WITH DOT BELOW;Lo;0;AL;;;;;N;;;;;
+08A6;ARABIC LETTER LAM WITH DOUBLE BAR;Lo;0;AL;;;;;N;;;;;
+08A7;ARABIC LETTER MEEM WITH THREE DOTS ABOVE;Lo;0;AL;;;;;N;;;;;
+08A8;ARABIC LETTER YEH WITH TWO DOTS BELOW AND HAMZA ABOVE;Lo;0;AL;;;;;N;;;;;
+08A9;ARABIC LETTER YEH WITH TWO DOTS BELOW AND DOT ABOVE;Lo;0;AL;;;;;N;;;;;
+08AA;ARABIC LETTER REH WITH LOOP;Lo;0;AL;;;;;N;;;;;
+08AB;ARABIC LETTER WAW WITH DOT WITHIN;Lo;0;AL;;;;;N;;;;;
+08AC;ARABIC LETTER ROHINGYA YEH;Lo;0;AL;;;;;N;;;;;
+08E4;ARABIC CURLY FATHA;Mn;230;NSM;;;;;N;;;;;
+08E5;ARABIC CURLY DAMMA;Mn;230;NSM;;;;;N;;;;;
+08E6;ARABIC CURLY KASRA;Mn;220;NSM;;;;;N;;;;;
+08E7;ARABIC CURLY FATHATAN;Mn;230;NSM;;;;;N;;;;;
+08E8;ARABIC CURLY DAMMATAN;Mn;230;NSM;;;;;N;;;;;
+08E9;ARABIC CURLY KASRATAN;Mn;220;NSM;;;;;N;;;;;
+08EA;ARABIC TONE ONE DOT ABOVE;Mn;230;NSM;;;;;N;;;;;
+08EB;ARABIC TONE TWO DOTS ABOVE;Mn;230;NSM;;;;;N;;;;;
+08EC;ARABIC TONE LOOP ABOVE;Mn;230;NSM;;;;;N;;;;;
+08ED;ARABIC TONE ONE DOT BELOW;Mn;220;NSM;;;;;N;;;;;
+08EE;ARABIC TONE TWO DOTS BELOW;Mn;220;NSM;;;;;N;;;;;
+08EF;ARABIC TONE LOOP BELOW;Mn;220;NSM;;;;;N;;;;;
+08F0;ARABIC OPEN FATHATAN;Mn;27;NSM;;;;;N;;;;;
+08F1;ARABIC OPEN DAMMATAN;Mn;28;NSM;;;;;N;;;;;
+08F2;ARABIC OPEN KASRATAN;Mn;29;NSM;;;;;N;;;;;
+08F3;ARABIC SMALL HIGH WAW;Mn;230;NSM;;;;;N;;;;;
+08F4;ARABIC FATHA WITH RING;Mn;230;NSM;;;;;N;;;;;
+08F5;ARABIC FATHA WITH DOT ABOVE;Mn;230;NSM;;;;;N;;;;;
+08F6;ARABIC KASRA WITH DOT BELOW;Mn;220;NSM;;;;;N;;;;;
+08F7;ARABIC LEFT ARROWHEAD ABOVE;Mn;230;NSM;;;;;N;;;;;
+08F8;ARABIC RIGHT ARROWHEAD ABOVE;Mn;230;NSM;;;;;N;;;;;
+08F9;ARABIC LEFT ARROWHEAD BELOW;Mn;220;NSM;;;;;N;;;;;
+08FA;ARABIC RIGHT ARROWHEAD BELOW;Mn;220;NSM;;;;;N;;;;;
+08FB;ARABIC DOUBLE RIGHT ARROWHEAD ABOVE;Mn;230;NSM;;;;;N;;;;;
+08FC;ARABIC DOUBLE RIGHT ARROWHEAD ABOVE WITH DOT;Mn;230;NSM;;;;;N;;;;;
+08FD;ARABIC RIGHT ARROWHEAD ABOVE WITH DOT;Mn;230;NSM;;;;;N;;;;;
+08FE;ARABIC DAMMA WITH DOT;Mn;230;NSM;;;;;N;;;;;
0900;DEVANAGARI SIGN INVERTED CANDRABINDU;Mn;0;NSM;;;;;N;;;;;
0901;DEVANAGARI SIGN CANDRABINDU;Mn;0;NSM;;;;;N;;;;;
0902;DEVANAGARI SIGN ANUSVARA;Mn;0;NSM;;;;;N;;;;;
@@ -2437,6 +2478,7 @@
0AED;GUJARATI DIGIT SEVEN;Nd;0;L;;7;7;7;N;;;;;
0AEE;GUJARATI DIGIT EIGHT;Nd;0;L;;8;8;8;N;;;;;
0AEF;GUJARATI DIGIT NINE;Nd;0;L;;9;9;9;N;;;;;
+0AF0;GUJARATI ABBREVIATION SIGN;Po;0;L;;;;;N;;;;;
0AF1;GUJARATI RUPEE SIGN;Sc;0;ET;;;;;N;;;;;
0B01;ORIYA SIGN CANDRABINDU;Mn;0;NSM;;;;;N;;;;;
0B02;ORIYA SIGN ANUSVARA;Mc;0;L;;;;;N;;;;;
@@ -3109,6 +3151,8 @@
0ED9;LAO DIGIT NINE;Nd;0;L;;9;9;9;N;;;;;
0EDC;LAO HO NO;Lo;0;L;<compat> 0EAB 0E99;;;;N;;;;;
0EDD;LAO HO MO;Lo;0;L;<compat> 0EAB 0EA1;;;;N;;;;;
+0EDE;LAO LETTER KHMU GO;Lo;0;L;;;;;N;;;;;
+0EDF;LAO LETTER KHMU NYO;Lo;0;L;;;;;N;;;;;
0F00;TIBETAN SYLLABLE OM;Lo;0;L;;;;;N;;;;;
0F01;TIBETAN MARK GTER YIG MGO TRUNCATED A;So;0;L;;;;;N;;;;;
0F02;TIBETAN MARK GTER YIG MGO -UM RNAM BCAD MA;So;0;L;;;;;N;;;;;
@@ -3129,7 +3173,7 @@
0F11;TIBETAN MARK RIN CHEN SPUNGS SHAD;Po;0;L;;;;;N;TIBETAN RINCHANPHUNGSHAD;;;;
0F12;TIBETAN MARK RGYA GRAM SHAD;Po;0;L;;;;;N;;;;;
0F13;TIBETAN MARK CARET -DZUD RTAGS ME LONG CAN;So;0;L;;;;;N;;;;;
-0F14;TIBETAN MARK GTER TSHEG;So;0;L;;;;;N;TIBETAN COMMA;;;;
+0F14;TIBETAN MARK GTER TSHEG;Po;0;L;;;;;N;TIBETAN COMMA;;;;
0F15;TIBETAN LOGOTYPE SIGN CHAD RTAGS;So;0;L;;;;;N;;;;;
0F16;TIBETAN LOGOTYPE SIGN LHAG RTAGS;So;0;L;;;;;N;;;;;
0F17;TIBETAN ASTROLOGICAL SIGN SGRA GCAN -CHAR RTAGS;So;0;L;;;;;N;;;;;
@@ -3518,6 +3562,8 @@
10C3;GEORGIAN CAPITAL LETTER WE;Lu;0;L;;;;;N;;;;2D23;
10C4;GEORGIAN CAPITAL LETTER HAR;Lu;0;L;;;;;N;;;;2D24;
10C5;GEORGIAN CAPITAL LETTER HOE;Lu;0;L;;;;;N;;;;2D25;
+10C7;GEORGIAN CAPITAL LETTER YN;Lu;0;L;;;;;N;;;;2D27;
+10CD;GEORGIAN CAPITAL LETTER AEN;Lu;0;L;;;;;N;;;;2D2D;
10D0;GEORGIAN LETTER AN;Lo;0;L;;;;;N;GEORGIAN SMALL LETTER AN;;;;
10D1;GEORGIAN LETTER BAN;Lo;0;L;;;;;N;GEORGIAN SMALL LETTER BAN;;;;
10D2;GEORGIAN LETTER GAN;Lo;0;L;;;;;N;GEORGIAN SMALL LETTER GAN;;;;
@@ -3563,6 +3609,9 @@
10FA;GEORGIAN LETTER AIN;Lo;0;L;;;;;N;;;;;
10FB;GEORGIAN PARAGRAPH SEPARATOR;Po;0;L;;;;;N;;;;;
10FC;MODIFIER LETTER GEORGIAN NAR;Lm;0;L;<super> 10DC;;;;N;;;;;
+10FD;GEORGIAN LETTER AEN;Lo;0;L;;;;;N;;;;;
+10FE;GEORGIAN LETTER HARD SIGN;Lo;0;L;;;;;N;;;;;
+10FF;GEORGIAN LETTER LABIAL SIGN;Lo;0;L;;;;;N;;;;;
1100;HANGUL CHOSEONG KIYEOK;Lo;0;L;;;;;N;;;;;
1101;HANGUL CHOSEONG SSANGKIYEOK;Lo;0;L;;;;;N;;;;;
1102;HANGUL CHOSEONG NIEUN;Lo;0;L;;;;;N;;;;;
@@ -4148,7 +4197,7 @@
135D;ETHIOPIC COMBINING GEMINATION AND VOWEL LENGTH MARK;Mn;230;NSM;;;;;N;;;;;
135E;ETHIOPIC COMBINING VOWEL LENGTH MARK;Mn;230;NSM;;;;;N;;;;;
135F;ETHIOPIC COMBINING GEMINATION MARK;Mn;230;NSM;;;;;N;;;;;
-1360;ETHIOPIC SECTION MARK;So;0;L;;;;;N;;;;;
+1360;ETHIOPIC SECTION MARK;Po;0;L;;;;;N;;;;;
1361;ETHIOPIC WORDSPACE;Po;0;L;;;;;N;;;;;
1362;ETHIOPIC FULL STOP;Po;0;L;;;;;N;;;;;
1363;ETHIOPIC COMMA;Po;0;L;;;;;N;;;;;
@@ -5171,8 +5220,8 @@
17B1;KHMER INDEPENDENT VOWEL QOO TYPE ONE;Lo;0;L;;;;;N;;;;;
17B2;KHMER INDEPENDENT VOWEL QOO TYPE TWO;Lo;0;L;;;;;N;;;;;
17B3;KHMER INDEPENDENT VOWEL QAU;Lo;0;L;;;;;N;;;;;
-17B4;KHMER VOWEL INHERENT AQ;Cf;0;L;;;;;N;;;;;
-17B5;KHMER VOWEL INHERENT AA;Cf;0;L;;;;;N;;;;;
+17B4;KHMER VOWEL INHERENT AQ;Mn;0;NSM;;;;;N;;;;;
+17B5;KHMER VOWEL INHERENT AA;Mn;0;NSM;;;;;N;;;;;
17B6;KHMER VOWEL SIGN AA;Mc;0;L;;;;;N;;;;;
17B7;KHMER VOWEL SIGN I;Mn;0;NSM;;;;;N;;;;;
17B8;KHMER VOWEL SIGN II;Mn;0;NSM;;;;;N;;;;;
@@ -5996,6 +6045,9 @@
1BA8;SUNDANESE VOWEL SIGN PAMEPET;Mn;0;NSM;;;;;N;;;;;
1BA9;SUNDANESE VOWEL SIGN PANEULEUNG;Mn;0;NSM;;;;;N;;;;;
1BAA;SUNDANESE SIGN PAMAAEH;Mc;9;L;;;;;N;;;;;
+1BAB;SUNDANESE SIGN VIRAMA;Mn;9;NSM;;;;;N;;;;;
+1BAC;SUNDANESE CONSONANT SIGN PASANGAN MA;Mc;0;L;;;;;N;;;;;
+1BAD;SUNDANESE CONSONANT SIGN PASANGAN WA;Mc;0;L;;;;;N;;;;;
1BAE;SUNDANESE LETTER KHA;Lo;0;L;;;;;N;;;;;
1BAF;SUNDANESE LETTER SYA;Lo;0;L;;;;;N;;;;;
1BB0;SUNDANESE DIGIT ZERO;Nd;0;L;;0;0;0;N;;;;;
@@ -6008,6 +6060,12 @@
1BB7;SUNDANESE DIGIT SEVEN;Nd;0;L;;7;7;7;N;;;;;
1BB8;SUNDANESE DIGIT EIGHT;Nd;0;L;;8;8;8;N;;;;;
1BB9;SUNDANESE DIGIT NINE;Nd;0;L;;9;9;9;N;;;;;
+1BBA;SUNDANESE AVAGRAHA;Lo;0;L;;;;;N;;;;;
+1BBB;SUNDANESE LETTER REU;Lo;0;L;;;;;N;;;;;
+1BBC;SUNDANESE LETTER LEU;Lo;0;L;;;;;N;;;;;
+1BBD;SUNDANESE LETTER BHA;Lo;0;L;;;;;N;;;;;
+1BBE;SUNDANESE LETTER FINAL K;Lo;0;L;;;;;N;;;;;
+1BBF;SUNDANESE LETTER FINAL M;Lo;0;L;;;;;N;;;;;
1BC0;BATAK LETTER A;Lo;0;L;;;;;N;;;;;
1BC1;BATAK LETTER SIMALUNGUN A;Lo;0;L;;;;;N;;;;;
1BC2;BATAK LETTER HA;Lo;0;L;;;;;N;;;;;
@@ -6186,6 +6244,14 @@
1C7D;OL CHIKI AHAD;Lm;0;L;;;;;N;;;;;
1C7E;OL CHIKI PUNCTUATION MUCAAD;Po;0;L;;;;;N;;;;;
1C7F;OL CHIKI PUNCTUATION DOUBLE MUCAAD;Po;0;L;;;;;N;;;;;
+1CC0;SUNDANESE PUNCTUATION BINDU SURYA;Po;0;L;;;;;N;;;;;
+1CC1;SUNDANESE PUNCTUATION BINDU PANGLONG;Po;0;L;;;;;N;;;;;
+1CC2;SUNDANESE PUNCTUATION BINDU PURNAMA;Po;0;L;;;;;N;;;;;
+1CC3;SUNDANESE PUNCTUATION BINDU CAKRA;Po;0;L;;;;;N;;;;;
+1CC4;SUNDANESE PUNCTUATION BINDU LEU SATANGA;Po;0;L;;;;;N;;;;;
+1CC5;SUNDANESE PUNCTUATION BINDU KA SATANGA;Po;0;L;;;;;N;;;;;
+1CC6;SUNDANESE PUNCTUATION BINDU DA SATANGA;Po;0;L;;;;;N;;;;;
+1CC7;SUNDANESE PUNCTUATION BINDU BA SATANGA;Po;0;L;;;;;N;;;;;
1CD0;VEDIC TONE KARSHANA;Mn;230;NSM;;;;;N;;;;;
1CD1;VEDIC TONE SHARA;Mn;230;NSM;;;;;N;;;;;
1CD2;VEDIC TONE PRENKHA;Mn;230;NSM;;;;;N;;;;;
@@ -6221,6 +6287,10 @@
1CF0;VEDIC SIGN RTHANG LONG ANUSVARA;Lo;0;L;;;;;N;;;;;
1CF1;VEDIC SIGN ANUSVARA UBHAYATO MUKHA;Lo;0;L;;;;;N;;;;;
1CF2;VEDIC SIGN ARDHAVISARGA;Mc;0;L;;;;;N;;;;;
+1CF3;VEDIC SIGN ROTATED ARDHAVISARGA;Mc;0;L;;;;;N;;;;;
+1CF4;VEDIC TONE CANDRA ABOVE;Mn;230;NSM;;;;;N;;;;;
+1CF5;VEDIC SIGN JIHVAMULIYA;Lo;0;L;;;;;N;;;;;
+1CF6;VEDIC SIGN UPADHMANIYA;Lo;0;L;;;;;N;;;;;
1D00;LATIN LETTER SMALL CAPITAL A;Ll;0;L;;;;;N;;;;;
1D01;LATIN LETTER SMALL CAPITAL AE;Ll;0;L;;;;;N;;;;;
1D02;LATIN SMALL LETTER TURNED AE;Ll;0;L;;;;;N;;;;;
@@ -6319,15 +6389,15 @@
1D5F;MODIFIER LETTER SMALL DELTA;Lm;0;L;<super> 03B4;;;;N;;;;;
1D60;MODIFIER LETTER SMALL GREEK PHI;Lm;0;L;<super> 03C6;;;;N;;;;;
1D61;MODIFIER LETTER SMALL CHI;Lm;0;L;<super> 03C7;;;;N;;;;;
-1D62;LATIN SUBSCRIPT SMALL LETTER I;Ll;0;L;<sub> 0069;;;;N;;;;;
-1D63;LATIN SUBSCRIPT SMALL LETTER R;Ll;0;L;<sub> 0072;;;;N;;;;;
-1D64;LATIN SUBSCRIPT SMALL LETTER U;Ll;0;L;<sub> 0075;;;;N;;;;;
-1D65;LATIN SUBSCRIPT SMALL LETTER V;Ll;0;L;<sub> 0076;;;;N;;;;;
-1D66;GREEK SUBSCRIPT SMALL LETTER BETA;Ll;0;L;<sub> 03B2;;;;N;;;;;
-1D67;GREEK SUBSCRIPT SMALL LETTER GAMMA;Ll;0;L;<sub> 03B3;;;;N;;;;;
-1D68;GREEK SUBSCRIPT SMALL LETTER RHO;Ll;0;L;<sub> 03C1;;;;N;;;;;
-1D69;GREEK SUBSCRIPT SMALL LETTER PHI;Ll;0;L;<sub> 03C6;;;;N;;;;;
-1D6A;GREEK SUBSCRIPT SMALL LETTER CHI;Ll;0;L;<sub> 03C7;;;;N;;;;;
+1D62;LATIN SUBSCRIPT SMALL LETTER I;Lm;0;L;<sub> 0069;;;;N;;;;;
+1D63;LATIN SUBSCRIPT SMALL LETTER R;Lm;0;L;<sub> 0072;;;;N;;;;;
+1D64;LATIN SUBSCRIPT SMALL LETTER U;Lm;0;L;<sub> 0075;;;;N;;;;;
+1D65;LATIN SUBSCRIPT SMALL LETTER V;Lm;0;L;<sub> 0076;;;;N;;;;;
+1D66;GREEK SUBSCRIPT SMALL LETTER BETA;Lm;0;L;<sub> 03B2;;;;N;;;;;
+1D67;GREEK SUBSCRIPT SMALL LETTER GAMMA;Lm;0;L;<sub> 03B3;;;;N;;;;;
+1D68;GREEK SUBSCRIPT SMALL LETTER RHO;Lm;0;L;<sub> 03C1;;;;N;;;;;
+1D69;GREEK SUBSCRIPT SMALL LETTER PHI;Lm;0;L;<sub> 03C6;;;;N;;;;;
+1D6A;GREEK SUBSCRIPT SMALL LETTER CHI;Lm;0;L;<sub> 03C7;;;;N;;;;;
1D6B;LATIN SMALL LETTER UE;Ll;0;L;;;;;N;;;;;
1D6C;LATIN SMALL LETTER B WITH MIDDLE TILDE;Ll;0;L;;;;;N;;;;;
1D6D;LATIN SMALL LETTER D WITH MIDDLE TILDE;Ll;0;L;;;;;N;;;;;
@@ -7120,6 +7190,7 @@
20B7;SPESMILO SIGN;Sc;0;ET;;;;;N;;;;;
20B8;TENGE SIGN;Sc;0;ET;;;;;N;;;;;
20B9;INDIAN RUPEE SIGN;Sc;0;ET;;;;;N;;;;;
+20BA;TURKISH LIRA SIGN;Sc;0;ET;;;;;N;;;;;
20D0;COMBINING LEFT HARPOON ABOVE;Mn;230;NSM;;;;;N;NON-SPACING LEFT HARPOON ABOVE;;;;
20D1;COMBINING RIGHT HARPOON ABOVE;Mn;230;NSM;;;;;N;NON-SPACING RIGHT HARPOON ABOVE;;;;
20D2;COMBINING LONG VERTICAL LINE OVERLAY;Mn;1;NSM;;;;;N;NON-SPACING LONG VERTICAL BAR OVERLAY;;;;
@@ -8827,7 +8898,9 @@
27C8;REVERSE SOLIDUS PRECEDING SUBSET;Sm;0;ON;;;;;Y;;;;;
27C9;SUPERSET PRECEDING SOLIDUS;Sm;0;ON;;;;;Y;;;;;
27CA;VERTICAL BAR WITH HORIZONTAL STROKE;Sm;0;ON;;;;;N;;;;;
+27CB;MATHEMATICAL RISING DIAGONAL;Sm;0;ON;;;;;Y;;;;;
27CC;LONG DIVISION;Sm;0;ON;;;;;Y;;;;;
+27CD;MATHEMATICAL FALLING DIAGONAL;Sm;0;ON;;;;;Y;;;;;
27CE;SQUARED LOGICAL AND;Sm;0;ON;;;;;N;;;;;
27CF;SQUARED LOGICAL OR;Sm;0;ON;;;;;N;;;;;
27D0;WHITE DIAMOND WITH CENTRED DOT;Sm;0;ON;;;;;N;;;;;
@@ -9855,7 +9928,7 @@
2C79;LATIN SMALL LETTER TURNED R WITH TAIL;Ll;0;L;;;;;N;;;;;
2C7A;LATIN SMALL LETTER O WITH LOW RING INSIDE;Ll;0;L;;;;;N;;;;;
2C7B;LATIN LETTER SMALL CAPITAL TURNED E;Ll;0;L;;;;;N;;;;;
-2C7C;LATIN SUBSCRIPT SMALL LETTER J;Ll;0;L;<sub> 006A;;;;N;;;;;
+2C7C;LATIN SUBSCRIPT SMALL LETTER J;Lm;0;L;<sub> 006A;;;;N;;;;;
2C7D;MODIFIER LETTER CAPITAL V;Lm;0;L;<super> 0056;;;;N;;;;;
2C7E;LATIN CAPITAL LETTER S WITH SWASH TAIL;Lu;0;L;;;;;N;;;;023F;
2C7F;LATIN CAPITAL LETTER Z WITH SWASH TAIL;Lu;0;L;;;;;N;;;;0240;
@@ -9973,6 +10046,8 @@
2CEF;COPTIC COMBINING NI ABOVE;Mn;230;NSM;;;;;N;;;;;
2CF0;COPTIC COMBINING SPIRITUS ASPER;Mn;230;NSM;;;;;N;;;;;
2CF1;COPTIC COMBINING SPIRITUS LENIS;Mn;230;NSM;;;;;N;;;;;
+2CF2;COPTIC CAPITAL LETTER BOHAIRIC KHEI;Lu;0;L;;;;;N;;;;2CF3;
+2CF3;COPTIC SMALL LETTER BOHAIRIC KHEI;Ll;0;L;;;;;N;;;2CF2;;2CF2
2CF9;COPTIC OLD NUBIAN FULL STOP;Po;0;ON;;;;;N;;;;;
2CFA;COPTIC OLD NUBIAN DIRECT QUESTION MARK;Po;0;ON;;;;;N;;;;;
2CFB;COPTIC OLD NUBIAN INDIRECT QUESTION MARK;Po;0;ON;;;;;N;;;;;
@@ -10018,6 +10093,8 @@
2D23;GEORGIAN SMALL LETTER WE;Ll;0;L;;;;;N;;;10C3;;10C3
2D24;GEORGIAN SMALL LETTER HAR;Ll;0;L;;;;;N;;;10C4;;10C4
2D25;GEORGIAN SMALL LETTER HOE;Ll;0;L;;;;;N;;;10C5;;10C5
+2D27;GEORGIAN SMALL LETTER YN;Ll;0;L;;;;;N;;;10C7;;10C7
+2D2D;GEORGIAN SMALL LETTER AEN;Ll;0;L;;;;;N;;;10CD;;10CD
2D30;TIFINAGH LETTER YA;Lo;0;L;;;;;N;;;;;
2D31;TIFINAGH LETTER YAB;Lo;0;L;;;;;N;;;;;
2D32;TIFINAGH LETTER YABH;Lo;0;L;;;;;N;;;;;
@@ -10072,6 +10149,8 @@
2D63;TIFINAGH LETTER YAZ;Lo;0;L;;;;;N;;;;;
2D64;TIFINAGH LETTER TAWELLEMET YAZ;Lo;0;L;;;;;N;;;;;
2D65;TIFINAGH LETTER YAZZ;Lo;0;L;;;;;N;;;;;
+2D66;TIFINAGH LETTER YE;Lo;0;L;;;;;N;;;;;
+2D67;TIFINAGH LETTER YO;Lo;0;L;;;;;N;;;;;
2D6F;TIFINAGH MODIFIER LETTER LABIALIZATION MARK;Lm;0;L;<super> 2D61;;;;N;;;;;
2D70;TIFINAGH SEPARATOR MARK;Po;0;L;;;;;N;;;;;
2D7F;TIFINAGH CONSONANT JOINER;Mn;9;NSM;;;;;N;;;;;
@@ -10236,6 +10315,16 @@
2E2F;VERTICAL TILDE;Lm;0;ON;;;;;N;;;;;
2E30;RING POINT;Po;0;ON;;;;;N;;;;;
2E31;WORD SEPARATOR MIDDLE DOT;Po;0;ON;;;;;N;;;;;
+2E32;TURNED COMMA;Po;0;ON;;;;;N;;;;;
+2E33;RAISED DOT;Po;0;ON;;;;;N;;;;;
+2E34;RAISED COMMA;Po;0;ON;;;;;N;;;;;
+2E35;TURNED SEMICOLON;Po;0;ON;;;;;N;;;;;
+2E36;DAGGER WITH LEFT GUARD;Po;0;ON;;;;;N;;;;;
+2E37;DAGGER WITH RIGHT GUARD;Po;0;ON;;;;;N;;;;;
+2E38;TURNED DAGGER;Po;0;ON;;;;;N;;;;;
+2E39;TOP HALF SECTION SIGN;Po;0;ON;;;;;N;;;;;
+2E3A;TWO-EM DASH;Pd;0;ON;;;;;N;;;;;
+2E3B;THREE-EM DASH;Pd;0;ON;;;;;N;;;;;
2E80;CJK RADICAL REPEAT;So;0;ON;;;;;N;;;;;
2E81;CJK RADICAL CLIFF;So;0;ON;;;;;N;;;;;
2E82;CJK RADICAL SECOND ONE;So;0;ON;;;;;N;;;;;
@@ -10623,8 +10712,8 @@
302B;IDEOGRAPHIC RISING TONE MARK;Mn;228;NSM;;;;;N;;;;;
302C;IDEOGRAPHIC DEPARTING TONE MARK;Mn;232;NSM;;;;;N;;;;;
302D;IDEOGRAPHIC ENTERING TONE MARK;Mn;222;NSM;;;;;N;;;;;
-302E;HANGUL SINGLE DOT TONE MARK;Mn;224;NSM;;;;;N;;;;;
-302F;HANGUL DOUBLE DOT TONE MARK;Mn;224;NSM;;;;;N;;;;;
+302E;HANGUL SINGLE DOT TONE MARK;Mc;224;L;;;;;N;;;;;
+302F;HANGUL DOUBLE DOT TONE MARK;Mc;224;L;;;;;N;;;;;
3030;WAVY DASH;Pd;0;ON;;;;;N;;;;;
3031;VERTICAL KANA REPEAT MARK;Lm;0;L;;;;;N;;;;;
3032;VERTICAL KANA REPEAT WITH VOICED SOUND MARK;Lm;0;L;;;;;N;;;;;
@@ -11131,14 +11220,14 @@
3245;CIRCLED IDEOGRAPH KINDERGARTEN;So;0;L;<circle> 5E7C;;;;N;;;;;
3246;CIRCLED IDEOGRAPH SCHOOL;So;0;L;<circle> 6587;;;;N;;;;;
3247;CIRCLED IDEOGRAPH KOTO;So;0;L;<circle> 7B8F;;;;N;;;;;
-3248;CIRCLED NUMBER TEN ON BLACK SQUARE;So;0;L;;;;;N;;;;;
-3249;CIRCLED NUMBER TWENTY ON BLACK SQUARE;So;0;L;;;;;N;;;;;
-324A;CIRCLED NUMBER THIRTY ON BLACK SQUARE;So;0;L;;;;;N;;;;;
-324B;CIRCLED NUMBER FORTY ON BLACK SQUARE;So;0;L;;;;;N;;;;;
-324C;CIRCLED NUMBER FIFTY ON BLACK SQUARE;So;0;L;;;;;N;;;;;
-324D;CIRCLED NUMBER SIXTY ON BLACK SQUARE;So;0;L;;;;;N;;;;;
-324E;CIRCLED NUMBER SEVENTY ON BLACK SQUARE;So;0;L;;;;;N;;;;;
-324F;CIRCLED NUMBER EIGHTY ON BLACK SQUARE;So;0;L;;;;;N;;;;;
+3248;CIRCLED NUMBER TEN ON BLACK SQUARE;No;0;L;;;;10;N;;;;;
+3249;CIRCLED NUMBER TWENTY ON BLACK SQUARE;No;0;L;;;;20;N;;;;;
+324A;CIRCLED NUMBER THIRTY ON BLACK SQUARE;No;0;L;;;;30;N;;;;;
+324B;CIRCLED NUMBER FORTY ON BLACK SQUARE;No;0;L;;;;40;N;;;;;
+324C;CIRCLED NUMBER FIFTY ON BLACK SQUARE;No;0;L;;;;50;N;;;;;
+324D;CIRCLED NUMBER SIXTY ON BLACK SQUARE;No;0;L;;;;60;N;;;;;
+324E;CIRCLED NUMBER SEVENTY ON BLACK SQUARE;No;0;L;;;;70;N;;;;;
+324F;CIRCLED NUMBER EIGHTY ON BLACK SQUARE;No;0;L;;;;80;N;;;;;
3250;PARTNERSHIP SIGN;So;0;ON;<square> 0050 0054 0045;;;;N;;;;;
3251;CIRCLED NUMBER TWENTY ONE;No;0;ON;<circle> 0032 0031;;;21;N;;;;;
3252;CIRCLED NUMBER TWENTY TWO;No;0;ON;<circle> 0032 0032;;;22;N;;;;;
@@ -11637,7 +11726,7 @@
4DFE;HEXAGRAM FOR AFTER COMPLETION;So;0;ON;;;;;N;;;;;
4DFF;HEXAGRAM FOR BEFORE COMPLETION;So;0;ON;;;;;N;;;;;
4E00;<CJK Ideograph, First>;Lo;0;L;;;;;N;;;;;
-9FCB;<CJK Ideograph, Last>;Lo;0;L;;;;;N;;;;;
+9FCC;<CJK Ideograph, Last>;Lo;0;L;;;;;N;;;;;
A000;YI SYLLABLE IT;Lo;0;L;;;;;N;;;;;
A001;YI SYLLABLE IX;Lo;0;L;;;;;N;;;;;
A002;YI SYLLABLE I;Lo;0;L;;;;;N;;;;;
@@ -13258,6 +13347,14 @@
A671;COMBINING CYRILLIC HUNDRED MILLIONS SIGN;Me;0;NSM;;;;;N;;;;;
A672;COMBINING CYRILLIC THOUSAND MILLIONS SIGN;Me;0;NSM;;;;;N;;;;;
A673;SLAVONIC ASTERISK;Po;0;ON;;;;;N;;;;;
+A674;COMBINING CYRILLIC LETTER UKRAINIAN IE;Mn;230;NSM;;;;;N;;;;;
+A675;COMBINING CYRILLIC LETTER I;Mn;230;NSM;;;;;N;;;;;
+A676;COMBINING CYRILLIC LETTER YI;Mn;230;NSM;;;;;N;;;;;
+A677;COMBINING CYRILLIC LETTER U;Mn;230;NSM;;;;;N;;;;;
+A678;COMBINING CYRILLIC LETTER HARD SIGN;Mn;230;NSM;;;;;N;;;;;
+A679;COMBINING CYRILLIC LETTER YERU;Mn;230;NSM;;;;;N;;;;;
+A67A;COMBINING CYRILLIC LETTER SOFT SIGN;Mn;230;NSM;;;;;N;;;;;
+A67B;COMBINING CYRILLIC LETTER OMEGA;Mn;230;NSM;;;;;N;;;;;
A67C;COMBINING CYRILLIC KAVYKA;Mn;230;NSM;;;;;N;;;;;
A67D;COMBINING CYRILLIC PAYEROK;Mn;230;NSM;;;;;N;;;;;
A67E;CYRILLIC KAVYKA;Po;0;ON;;;;;N;;;;;
@@ -13286,6 +13383,7 @@
A695;CYRILLIC SMALL LETTER HWE;Ll;0;L;;;;;N;;;A694;;A694
A696;CYRILLIC CAPITAL LETTER SHWE;Lu;0;L;;;;;N;;;;A697;
A697;CYRILLIC SMALL LETTER SHWE;Ll;0;L;;;;;N;;;A696;;A696
+A69F;COMBINING CYRILLIC LETTER IOTIFIED E;Mn;230;NSM;;;;;N;;;;;
A6A0;BAMUM LETTER A;Lo;0;L;;;;;N;;;;;
A6A1;BAMUM LETTER KA;Lo;0;L;;;;;N;;;;;
A6A2;BAMUM LETTER U;Lo;0;L;;;;;N;;;;;
@@ -13519,6 +13617,8 @@
A78E;LATIN SMALL LETTER L WITH RETROFLEX HOOK AND BELT;Ll;0;L;;;;;N;;;;;
A790;LATIN CAPITAL LETTER N WITH DESCENDER;Lu;0;L;;;;;N;;;;A791;
A791;LATIN SMALL LETTER N WITH DESCENDER;Ll;0;L;;;;;N;;;A790;;A790
+A792;LATIN CAPITAL LETTER C WITH BAR;Lu;0;L;;;;;N;;;;A793;
+A793;LATIN SMALL LETTER C WITH BAR;Ll;0;L;;;;;N;;;A792;;A792
A7A0;LATIN CAPITAL LETTER G WITH OBLIQUE STROKE;Lu;0;L;;;;;N;;;;A7A1;
A7A1;LATIN SMALL LETTER G WITH OBLIQUE STROKE;Ll;0;L;;;;;N;;;A7A0;;A7A0
A7A2;LATIN CAPITAL LETTER K WITH OBLIQUE STROKE;Lu;0;L;;;;;N;;;;A7A3;
@@ -13529,6 +13629,9 @@
A7A7;LATIN SMALL LETTER R WITH OBLIQUE STROKE;Ll;0;L;;;;;N;;;A7A6;;A7A6
A7A8;LATIN CAPITAL LETTER S WITH OBLIQUE STROKE;Lu;0;L;;;;;N;;;;A7A9;
A7A9;LATIN SMALL LETTER S WITH OBLIQUE STROKE;Ll;0;L;;;;;N;;;A7A8;;A7A8
+A7AA;LATIN CAPITAL LETTER H WITH HOOK;Lu;0;L;;;;;N;;;;0266;
+A7F8;MODIFIER LETTER CAPITAL H WITH STROKE;Lm;0;L;<super> 0126;;;;N;;;;;
+A7F9;MODIFIER LETTER SMALL LIGATURE OE;Lm;0;L;<super> 0153;;;;N;;;;;
A7FA;LATIN LETTER SMALL CAPITAL TURNED M;Ll;0;L;;;;;N;;;;;
A7FB;LATIN EPIGRAPHIC LETTER REVERSED F;Lo;0;L;;;;;N;;;;;
A7FC;LATIN EPIGRAPHIC LETTER REVERSED P;Lo;0;L;;;;;N;;;;;
@@ -14142,6 +14245,29 @@
AADD;TAI VIET SYMBOL SAM;Lm;0;L;;;;;N;;;;;
AADE;TAI VIET SYMBOL HO HOI;Po;0;L;;;;;N;;;;;
AADF;TAI VIET SYMBOL KOI KOI;Po;0;L;;;;;N;;;;;
+AAE0;MEETEI MAYEK LETTER E;Lo;0;L;;;;;N;;;;;
+AAE1;MEETEI MAYEK LETTER O;Lo;0;L;;;;;N;;;;;
+AAE2;MEETEI MAYEK LETTER CHA;Lo;0;L;;;;;N;;;;;
+AAE3;MEETEI MAYEK LETTER NYA;Lo;0;L;;;;;N;;;;;
+AAE4;MEETEI MAYEK LETTER TTA;Lo;0;L;;;;;N;;;;;
+AAE5;MEETEI MAYEK LETTER TTHA;Lo;0;L;;;;;N;;;;;
+AAE6;MEETEI MAYEK LETTER DDA;Lo;0;L;;;;;N;;;;;
+AAE7;MEETEI MAYEK LETTER DDHA;Lo;0;L;;;;;N;;;;;
+AAE8;MEETEI MAYEK LETTER NNA;Lo;0;L;;;;;N;;;;;
+AAE9;MEETEI MAYEK LETTER SHA;Lo;0;L;;;;;N;;;;;
+AAEA;MEETEI MAYEK LETTER SSA;Lo;0;L;;;;;N;;;;;
+AAEB;MEETEI MAYEK VOWEL SIGN II;Mc;0;L;;;;;N;;;;;
+AAEC;MEETEI MAYEK VOWEL SIGN UU;Mn;0;NSM;;;;;N;;;;;
+AAED;MEETEI MAYEK VOWEL SIGN AAI;Mn;0;NSM;;;;;N;;;;;
+AAEE;MEETEI MAYEK VOWEL SIGN AU;Mc;0;L;;;;;N;;;;;
+AAEF;MEETEI MAYEK VOWEL SIGN AAU;Mc;0;L;;;;;N;;;;;
+AAF0;MEETEI MAYEK CHEIKHAN;Po;0;L;;;;;N;;;;;
+AAF1;MEETEI MAYEK AHANG KHUDAM;Po;0;L;;;;;N;;;;;
+AAF2;MEETEI MAYEK ANJI;Lo;0;L;;;;;N;;;;;
+AAF3;MEETEI MAYEK SYLLABLE REPETITION MARK;Lm;0;L;;;;;N;;;;;
+AAF4;MEETEI MAYEK WORD REPETITION MARK;Lm;0;L;;;;;N;;;;;
+AAF5;MEETEI MAYEK VOWEL SIGN VISARGA;Mc;0;L;;;;;N;;;;;
+AAF6;MEETEI MAYEK VIRAMA;Mn;9;NSM;;;;;N;;;;;
AB01;ETHIOPIC SYLLABLE TTHU;Lo;0;L;;;;;N;;;;;
AB02;ETHIOPIC SYLLABLE TTHI;Lo;0;L;;;;;N;;;;;
AB03;ETHIOPIC SYLLABLE TTHAA;Lo;0;L;;;;;N;;;;;
@@ -14614,6 +14740,8 @@
FA2B;CJK COMPATIBILITY IDEOGRAPH-FA2B;Lo;0;L;98FC;;;;N;;;;;
FA2C;CJK COMPATIBILITY IDEOGRAPH-FA2C;Lo;0;L;9928;;;;N;;;;;
FA2D;CJK COMPATIBILITY IDEOGRAPH-FA2D;Lo;0;L;9DB4;;;;N;;;;;
+FA2E;CJK COMPATIBILITY IDEOGRAPH-FA2E;Lo;0;L;90DE;;;;N;;;;;
+FA2F;CJK COMPATIBILITY IDEOGRAPH-FA2F;Lo;0;L;96B7;;;;N;;;;;
FA30;CJK COMPATIBILITY IDEOGRAPH-FA30;Lo;0;L;4FAE;;;;N;;;;;
FA31;CJK COMPATIBILITY IDEOGRAPH-FA31;Lo;0;L;50E7;;;;N;;;;;
FA32;CJK COMPATIBILITY IDEOGRAPH-FA32;Lo;0;L;514D;;;;N;;;;;
@@ -16126,7 +16254,7 @@
100FA;LINEAR B IDEOGRAM VESSEL B305;Lo;0;L;;;;;N;;;;;
10100;AEGEAN WORD SEPARATOR LINE;Po;0;L;;;;;N;;;;;
10101;AEGEAN WORD SEPARATOR DOT;Po;0;ON;;;;;N;;;;;
-10102;AEGEAN CHECK MARK;So;0;L;;;;;N;;;;;
+10102;AEGEAN CHECK MARK;Po;0;L;;;;;N;;;;;
10107;AEGEAN NUMBER ONE;No;0;L;;;;1;N;;;;;
10108;AEGEAN NUMBER TWO;No;0;L;;;;2;N;;;;;
10109;AEGEAN NUMBER THREE;No;0;L;;;;3;N;;;;;
@@ -16845,6 +16973,64 @@
10938;LYDIAN LETTER NN;Lo;0;R;;;;;N;;;;;
10939;LYDIAN LETTER C;Lo;0;R;;;;;N;;;;;
1093F;LYDIAN TRIANGULAR MARK;Po;0;R;;;;;N;;;;;
+10980;MEROITIC HIEROGLYPHIC LETTER A;Lo;0;R;;;;;N;;;;;
+10981;MEROITIC HIEROGLYPHIC LETTER E;Lo;0;R;;;;;N;;;;;
+10982;MEROITIC HIEROGLYPHIC LETTER I;Lo;0;R;;;;;N;;;;;
+10983;MEROITIC HIEROGLYPHIC LETTER O;Lo;0;R;;;;;N;;;;;
+10984;MEROITIC HIEROGLYPHIC LETTER YA;Lo;0;R;;;;;N;;;;;
+10985;MEROITIC HIEROGLYPHIC LETTER WA;Lo;0;R;;;;;N;;;;;
+10986;MEROITIC HIEROGLYPHIC LETTER BA;Lo;0;R;;;;;N;;;;;
+10987;MEROITIC HIEROGLYPHIC LETTER BA-2;Lo;0;R;;;;;N;;;;;
+10988;MEROITIC HIEROGLYPHIC LETTER PA;Lo;0;R;;;;;N;;;;;
+10989;MEROITIC HIEROGLYPHIC LETTER MA;Lo;0;R;;;;;N;;;;;
+1098A;MEROITIC HIEROGLYPHIC LETTER NA;Lo;0;R;;;;;N;;;;;
+1098B;MEROITIC HIEROGLYPHIC LETTER NA-2;Lo;0;R;;;;;N;;;;;
+1098C;MEROITIC HIEROGLYPHIC LETTER NE;Lo;0;R;;;;;N;;;;;
+1098D;MEROITIC HIEROGLYPHIC LETTER NE-2;Lo;0;R;;;;;N;;;;;
+1098E;MEROITIC HIEROGLYPHIC LETTER RA;Lo;0;R;;;;;N;;;;;
+1098F;MEROITIC HIEROGLYPHIC LETTER RA-2;Lo;0;R;;;;;N;;;;;
+10990;MEROITIC HIEROGLYPHIC LETTER LA;Lo;0;R;;;;;N;;;;;
+10991;MEROITIC HIEROGLYPHIC LETTER KHA;Lo;0;R;;;;;N;;;;;
+10992;MEROITIC HIEROGLYPHIC LETTER HHA;Lo;0;R;;;;;N;;;;;
+10993;MEROITIC HIEROGLYPHIC LETTER SA;Lo;0;R;;;;;N;;;;;
+10994;MEROITIC HIEROGLYPHIC LETTER SA-2;Lo;0;R;;;;;N;;;;;
+10995;MEROITIC HIEROGLYPHIC LETTER SE;Lo;0;R;;;;;N;;;;;
+10996;MEROITIC HIEROGLYPHIC LETTER KA;Lo;0;R;;;;;N;;;;;
+10997;MEROITIC HIEROGLYPHIC LETTER QA;Lo;0;R;;;;;N;;;;;
+10998;MEROITIC HIEROGLYPHIC LETTER TA;Lo;0;R;;;;;N;;;;;
+10999;MEROITIC HIEROGLYPHIC LETTER TA-2;Lo;0;R;;;;;N;;;;;
+1099A;MEROITIC HIEROGLYPHIC LETTER TE;Lo;0;R;;;;;N;;;;;
+1099B;MEROITIC HIEROGLYPHIC LETTER TE-2;Lo;0;R;;;;;N;;;;;
+1099C;MEROITIC HIEROGLYPHIC LETTER TO;Lo;0;R;;;;;N;;;;;
+1099D;MEROITIC HIEROGLYPHIC LETTER DA;Lo;0;R;;;;;N;;;;;
+1099E;MEROITIC HIEROGLYPHIC SYMBOL VIDJ;Lo;0;R;;;;;N;;;;;
+1099F;MEROITIC HIEROGLYPHIC SYMBOL VIDJ-2;Lo;0;R;;;;;N;;;;;
+109A0;MEROITIC CURSIVE LETTER A;Lo;0;R;;;;;N;;;;;
+109A1;MEROITIC CURSIVE LETTER E;Lo;0;R;;;;;N;;;;;
+109A2;MEROITIC CURSIVE LETTER I;Lo;0;R;;;;;N;;;;;
+109A3;MEROITIC CURSIVE LETTER O;Lo;0;R;;;;;N;;;;;
+109A4;MEROITIC CURSIVE LETTER YA;Lo;0;R;;;;;N;;;;;
+109A5;MEROITIC CURSIVE LETTER WA;Lo;0;R;;;;;N;;;;;
+109A6;MEROITIC CURSIVE LETTER BA;Lo;0;R;;;;;N;;;;;
+109A7;MEROITIC CURSIVE LETTER PA;Lo;0;R;;;;;N;;;;;
+109A8;MEROITIC CURSIVE LETTER MA;Lo;0;R;;;;;N;;;;;
+109A9;MEROITIC CURSIVE LETTER NA;Lo;0;R;;;;;N;;;;;
+109AA;MEROITIC CURSIVE LETTER NE;Lo;0;R;;;;;N;;;;;
+109AB;MEROITIC CURSIVE LETTER RA;Lo;0;R;;;;;N;;;;;
+109AC;MEROITIC CURSIVE LETTER LA;Lo;0;R;;;;;N;;;;;
+109AD;MEROITIC CURSIVE LETTER KHA;Lo;0;R;;;;;N;;;;;
+109AE;MEROITIC CURSIVE LETTER HHA;Lo;0;R;;;;;N;;;;;
+109AF;MEROITIC CURSIVE LETTER SA;Lo;0;R;;;;;N;;;;;
+109B0;MEROITIC CURSIVE LETTER ARCHAIC SA;Lo;0;R;;;;;N;;;;;
+109B1;MEROITIC CURSIVE LETTER SE;Lo;0;R;;;;;N;;;;;
+109B2;MEROITIC CURSIVE LETTER KA;Lo;0;R;;;;;N;;;;;
+109B3;MEROITIC CURSIVE LETTER QA;Lo;0;R;;;;;N;;;;;
+109B4;MEROITIC CURSIVE LETTER TA;Lo;0;R;;;;;N;;;;;
+109B5;MEROITIC CURSIVE LETTER TE;Lo;0;R;;;;;N;;;;;
+109B6;MEROITIC CURSIVE LETTER TO;Lo;0;R;;;;;N;;;;;
+109B7;MEROITIC CURSIVE LETTER DA;Lo;0;R;;;;;N;;;;;
+109BE;MEROITIC CURSIVE LOGOGRAM RMT;Lo;0;R;;;;;N;;;;;
+109BF;MEROITIC CURSIVE LOGOGRAM IMN;Lo;0;R;;;;;N;;;;;
10A00;KHAROSHTHI LETTER A;Lo;0;R;;;;;N;;;;;
10A01;KHAROSHTHI VOWEL SIGN I;Mn;0;NSM;;;;;N;;;;;
10A02;KHAROSHTHI VOWEL SIGN U;Mn;0;NSM;;;;;N;;;;;
@@ -17338,6 +17524,257 @@
110BF;KAITHI DOUBLE SECTION MARK;Po;0;L;;;;;N;;;;;
110C0;KAITHI DANDA;Po;0;L;;;;;N;;;;;
110C1;KAITHI DOUBLE DANDA;Po;0;L;;;;;N;;;;;
+110D0;SORA SOMPENG LETTER SAH;Lo;0;L;;;;;N;;;;;
+110D1;SORA SOMPENG LETTER TAH;Lo;0;L;;;;;N;;;;;
+110D2;SORA SOMPENG LETTER BAH;Lo;0;L;;;;;N;;;;;
+110D3;SORA SOMPENG LETTER CAH;Lo;0;L;;;;;N;;;;;
+110D4;SORA SOMPENG LETTER DAH;Lo;0;L;;;;;N;;;;;
+110D5;SORA SOMPENG LETTER GAH;Lo;0;L;;;;;N;;;;;
+110D6;SORA SOMPENG LETTER MAH;Lo;0;L;;;;;N;;;;;
+110D7;SORA SOMPENG LETTER NGAH;Lo;0;L;;;;;N;;;;;
+110D8;SORA SOMPENG LETTER LAH;Lo;0;L;;;;;N;;;;;
+110D9;SORA SOMPENG LETTER NAH;Lo;0;L;;;;;N;;;;;
+110DA;SORA SOMPENG LETTER VAH;Lo;0;L;;;;;N;;;;;
+110DB;SORA SOMPENG LETTER PAH;Lo;0;L;;;;;N;;;;;
+110DC;SORA SOMPENG LETTER YAH;Lo;0;L;;;;;N;;;;;
+110DD;SORA SOMPENG LETTER RAH;Lo;0;L;;;;;N;;;;;
+110DE;SORA SOMPENG LETTER HAH;Lo;0;L;;;;;N;;;;;
+110DF;SORA SOMPENG LETTER KAH;Lo;0;L;;;;;N;;;;;
+110E0;SORA SOMPENG LETTER JAH;Lo;0;L;;;;;N;;;;;
+110E1;SORA SOMPENG LETTER NYAH;Lo;0;L;;;;;N;;;;;
+110E2;SORA SOMPENG LETTER AH;Lo;0;L;;;;;N;;;;;
+110E3;SORA SOMPENG LETTER EEH;Lo;0;L;;;;;N;;;;;
+110E4;SORA SOMPENG LETTER IH;Lo;0;L;;;;;N;;;;;
+110E5;SORA SOMPENG LETTER UH;Lo;0;L;;;;;N;;;;;
+110E6;SORA SOMPENG LETTER OH;Lo;0;L;;;;;N;;;;;
+110E7;SORA SOMPENG LETTER EH;Lo;0;L;;;;;N;;;;;
+110E8;SORA SOMPENG LETTER MAE;Lo;0;L;;;;;N;;;;;
+110F0;SORA SOMPENG DIGIT ZERO;Nd;0;L;;0;0;0;N;;;;;
+110F1;SORA SOMPENG DIGIT ONE;Nd;0;L;;1;1;1;N;;;;;
+110F2;SORA SOMPENG DIGIT TWO;Nd;0;L;;2;2;2;N;;;;;
+110F3;SORA SOMPENG DIGIT THREE;Nd;0;L;;3;3;3;N;;;;;
+110F4;SORA SOMPENG DIGIT FOUR;Nd;0;L;;4;4;4;N;;;;;
+110F5;SORA SOMPENG DIGIT FIVE;Nd;0;L;;5;5;5;N;;;;;
+110F6;SORA SOMPENG DIGIT SIX;Nd;0;L;;6;6;6;N;;;;;
+110F7;SORA SOMPENG DIGIT SEVEN;Nd;0;L;;7;7;7;N;;;;;
+110F8;SORA SOMPENG DIGIT EIGHT;Nd;0;L;;8;8;8;N;;;;;
+110F9;SORA SOMPENG DIGIT NINE;Nd;0;L;;9;9;9;N;;;;;
+11100;CHAKMA SIGN CANDRABINDU;Mn;230;NSM;;;;;N;;;;;
+11101;CHAKMA SIGN ANUSVARA;Mn;230;NSM;;;;;N;;;;;
+11102;CHAKMA SIGN VISARGA;Mn;230;NSM;;;;;N;;;;;
+11103;CHAKMA LETTER AA;Lo;0;L;;;;;N;;;;;
+11104;CHAKMA LETTER I;Lo;0;L;;;;;N;;;;;
+11105;CHAKMA LETTER U;Lo;0;L;;;;;N;;;;;
+11106;CHAKMA LETTER E;Lo;0;L;;;;;N;;;;;
+11107;CHAKMA LETTER KAA;Lo;0;L;;;;;N;;;;;
+11108;CHAKMA LETTER KHAA;Lo;0;L;;;;;N;;;;;
+11109;CHAKMA LETTER GAA;Lo;0;L;;;;;N;;;;;
+1110A;CHAKMA LETTER GHAA;Lo;0;L;;;;;N;;;;;
+1110B;CHAKMA LETTER NGAA;Lo;0;L;;;;;N;;;;;
+1110C;CHAKMA LETTER CAA;Lo;0;L;;;;;N;;;;;
+1110D;CHAKMA LETTER CHAA;Lo;0;L;;;;;N;;;;;
+1110E;CHAKMA LETTER JAA;Lo;0;L;;;;;N;;;;;
+1110F;CHAKMA LETTER JHAA;Lo;0;L;;;;;N;;;;;
+11110;CHAKMA LETTER NYAA;Lo;0;L;;;;;N;;;;;
+11111;CHAKMA LETTER TTAA;Lo;0;L;;;;;N;;;;;
+11112;CHAKMA LETTER TTHAA;Lo;0;L;;;;;N;;;;;
+11113;CHAKMA LETTER DDAA;Lo;0;L;;;;;N;;;;;
+11114;CHAKMA LETTER DDHAA;Lo;0;L;;;;;N;;;;;
+11115;CHAKMA LETTER NNAA;Lo;0;L;;;;;N;;;;;
+11116;CHAKMA LETTER TAA;Lo;0;L;;;;;N;;;;;
+11117;CHAKMA LETTER THAA;Lo;0;L;;;;;N;;;;;
+11118;CHAKMA LETTER DAA;Lo;0;L;;;;;N;;;;;
+11119;CHAKMA LETTER DHAA;Lo;0;L;;;;;N;;;;;
+1111A;CHAKMA LETTER NAA;Lo;0;L;;;;;N;;;;;
+1111B;CHAKMA LETTER PAA;Lo;0;L;;;;;N;;;;;
+1111C;CHAKMA LETTER PHAA;Lo;0;L;;;;;N;;;;;
+1111D;CHAKMA LETTER BAA;Lo;0;L;;;;;N;;;;;
+1111E;CHAKMA LETTER BHAA;Lo;0;L;;;;;N;;;;;
+1111F;CHAKMA LETTER MAA;Lo;0;L;;;;;N;;;;;
+11120;CHAKMA LETTER YYAA;Lo;0;L;;;;;N;;;;;
+11121;CHAKMA LETTER YAA;Lo;0;L;;;;;N;;;;;
+11122;CHAKMA LETTER RAA;Lo;0;L;;;;;N;;;;;
+11123;CHAKMA LETTER LAA;Lo;0;L;;;;;N;;;;;
+11124;CHAKMA LETTER WAA;Lo;0;L;;;;;N;;;;;
+11125;CHAKMA LETTER SAA;Lo;0;L;;;;;N;;;;;
+11126;CHAKMA LETTER HAA;Lo;0;L;;;;;N;;;;;
+11127;CHAKMA VOWEL SIGN A;Mn;0;NSM;;;;;N;;;;;
+11128;CHAKMA VOWEL SIGN I;Mn;0;NSM;;;;;N;;;;;
+11129;CHAKMA VOWEL SIGN II;Mn;0;NSM;;;;;N;;;;;
+1112A;CHAKMA VOWEL SIGN U;Mn;0;NSM;;;;;N;;;;;
+1112B;CHAKMA VOWEL SIGN UU;Mn;0;NSM;;;;;N;;;;;
+1112C;CHAKMA VOWEL SIGN E;Mc;0;L;;;;;N;;;;;
+1112D;CHAKMA VOWEL SIGN AI;Mn;0;NSM;;;;;N;;;;;
+1112E;CHAKMA VOWEL SIGN O;Mn;0;NSM;11131 11127;;;;N;;;;;
+1112F;CHAKMA VOWEL SIGN AU;Mn;0;NSM;11132 11127;;;;N;;;;;
+11130;CHAKMA VOWEL SIGN OI;Mn;0;NSM;;;;;N;;;;;
+11131;CHAKMA O MARK;Mn;0;NSM;;;;;N;;;;;
+11132;CHAKMA AU MARK;Mn;0;NSM;;;;;N;;;;;
+11133;CHAKMA VIRAMA;Mn;9;NSM;;;;;N;;;;;
+11134;CHAKMA MAAYYAA;Mn;9;NSM;;;;;N;;;;;
+11136;CHAKMA DIGIT ZERO;Nd;0;L;;0;0;0;N;;;;;
+11137;CHAKMA DIGIT ONE;Nd;0;L;;1;1;1;N;;;;;
+11138;CHAKMA DIGIT TWO;Nd;0;L;;2;2;2;N;;;;;
+11139;CHAKMA DIGIT THREE;Nd;0;L;;3;3;3;N;;;;;
+1113A;CHAKMA DIGIT FOUR;Nd;0;L;;4;4;4;N;;;;;
+1113B;CHAKMA DIGIT FIVE;Nd;0;L;;5;5;5;N;;;;;
+1113C;CHAKMA DIGIT SIX;Nd;0;L;;6;6;6;N;;;;;
+1113D;CHAKMA DIGIT SEVEN;Nd;0;L;;7;7;7;N;;;;;
+1113E;CHAKMA DIGIT EIGHT;Nd;0;L;;8;8;8;N;;;;;
+1113F;CHAKMA DIGIT NINE;Nd;0;L;;9;9;9;N;;;;;
+11140;CHAKMA SECTION MARK;Po;0;L;;;;;N;;;;;
+11141;CHAKMA DANDA;Po;0;L;;;;;N;;;;;
+11142;CHAKMA DOUBLE DANDA;Po;0;L;;;;;N;;;;;
+11143;CHAKMA QUESTION MARK;Po;0;L;;;;;N;;;;;
+11180;SHARADA SIGN CANDRABINDU;Mn;0;NSM;;;;;N;;;;;
+11181;SHARADA SIGN ANUSVARA;Mn;0;NSM;;;;;N;;;;;
+11182;SHARADA SIGN VISARGA;Mc;0;L;;;;;N;;;;;
+11183;SHARADA LETTER A;Lo;0;L;;;;;N;;;;;
+11184;SHARADA LETTER AA;Lo;0;L;;;;;N;;;;;
+11185;SHARADA LETTER I;Lo;0;L;;;;;N;;;;;
+11186;SHARADA LETTER II;Lo;0;L;;;;;N;;;;;
+11187;SHARADA LETTER U;Lo;0;L;;;;;N;;;;;
+11188;SHARADA LETTER UU;Lo;0;L;;;;;N;;;;;
+11189;SHARADA LETTER VOCALIC R;Lo;0;L;;;;;N;;;;;
+1118A;SHARADA LETTER VOCALIC RR;Lo;0;L;;;;;N;;;;;
+1118B;SHARADA LETTER VOCALIC L;Lo;0;L;;;;;N;;;;;
+1118C;SHARADA LETTER VOCALIC LL;Lo;0;L;;;;;N;;;;;
+1118D;SHARADA LETTER E;Lo;0;L;;;;;N;;;;;
+1118E;SHARADA LETTER AI;Lo;0;L;;;;;N;;;;;
+1118F;SHARADA LETTER O;Lo;0;L;;;;;N;;;;;
+11190;SHARADA LETTER AU;Lo;0;L;;;;;N;;;;;
+11191;SHARADA LETTER KA;Lo;0;L;;;;;N;;;;;
+11192;SHARADA LETTER KHA;Lo;0;L;;;;;N;;;;;
+11193;SHARADA LETTER GA;Lo;0;L;;;;;N;;;;;
+11194;SHARADA LETTER GHA;Lo;0;L;;;;;N;;;;;
+11195;SHARADA LETTER NGA;Lo;0;L;;;;;N;;;;;
+11196;SHARADA LETTER CA;Lo;0;L;;;;;N;;;;;
+11197;SHARADA LETTER CHA;Lo;0;L;;;;;N;;;;;
+11198;SHARADA LETTER JA;Lo;0;L;;;;;N;;;;;
+11199;SHARADA LETTER JHA;Lo;0;L;;;;;N;;;;;
+1119A;SHARADA LETTER NYA;Lo;0;L;;;;;N;;;;;
+1119B;SHARADA LETTER TTA;Lo;0;L;;;;;N;;;;;
+1119C;SHARADA LETTER TTHA;Lo;0;L;;;;;N;;;;;
+1119D;SHARADA LETTER DDA;Lo;0;L;;;;;N;;;;;
+1119E;SHARADA LETTER DDHA;Lo;0;L;;;;;N;;;;;
+1119F;SHARADA LETTER NNA;Lo;0;L;;;;;N;;;;;
+111A0;SHARADA LETTER TA;Lo;0;L;;;;;N;;;;;
+111A1;SHARADA LETTER THA;Lo;0;L;;;;;N;;;;;
+111A2;SHARADA LETTER DA;Lo;0;L;;;;;N;;;;;
+111A3;SHARADA LETTER DHA;Lo;0;L;;;;;N;;;;;
+111A4;SHARADA LETTER NA;Lo;0;L;;;;;N;;;;;
+111A5;SHARADA LETTER PA;Lo;0;L;;;;;N;;;;;
+111A6;SHARADA LETTER PHA;Lo;0;L;;;;;N;;;;;
+111A7;SHARADA LETTER BA;Lo;0;L;;;;;N;;;;;
+111A8;SHARADA LETTER BHA;Lo;0;L;;;;;N;;;;;
+111A9;SHARADA LETTER MA;Lo;0;L;;;;;N;;;;;
+111AA;SHARADA LETTER YA;Lo;0;L;;;;;N;;;;;
+111AB;SHARADA LETTER RA;Lo;0;L;;;;;N;;;;;
+111AC;SHARADA LETTER LA;Lo;0;L;;;;;N;;;;;
+111AD;SHARADA LETTER LLA;Lo;0;L;;;;;N;;;;;
+111AE;SHARADA LETTER VA;Lo;0;L;;;;;N;;;;;
+111AF;SHARADA LETTER SHA;Lo;0;L;;;;;N;;;;;
+111B0;SHARADA LETTER SSA;Lo;0;L;;;;;N;;;;;
+111B1;SHARADA LETTER SA;Lo;0;L;;;;;N;;;;;
+111B2;SHARADA LETTER HA;Lo;0;L;;;;;N;;;;;
+111B3;SHARADA VOWEL SIGN AA;Mc;0;L;;;;;N;;;;;
+111B4;SHARADA VOWEL SIGN I;Mc;0;L;;;;;N;;;;;
+111B5;SHARADA VOWEL SIGN II;Mc;0;L;;;;;N;;;;;
+111B6;SHARADA VOWEL SIGN U;Mn;0;NSM;;;;;N;;;;;
+111B7;SHARADA VOWEL SIGN UU;Mn;0;NSM;;;;;N;;;;;
+111B8;SHARADA VOWEL SIGN VOCALIC R;Mn;0;NSM;;;;;N;;;;;
+111B9;SHARADA VOWEL SIGN VOCALIC RR;Mn;0;NSM;;;;;N;;;;;
+111BA;SHARADA VOWEL SIGN VOCALIC L;Mn;0;NSM;;;;;N;;;;;
+111BB;SHARADA VOWEL SIGN VOCALIC LL;Mn;0;NSM;;;;;N;;;;;
+111BC;SHARADA VOWEL SIGN E;Mn;0;NSM;;;;;N;;;;;
+111BD;SHARADA VOWEL SIGN AI;Mn;0;NSM;;;;;N;;;;;
+111BE;SHARADA VOWEL SIGN O;Mn;0;NSM;;;;;N;;;;;
+111BF;SHARADA VOWEL SIGN AU;Mc;0;L;;;;;N;;;;;
+111C0;SHARADA SIGN VIRAMA;Mc;9;L;;;;;N;;;;;
+111C1;SHARADA SIGN AVAGRAHA;Lo;0;L;;;;;N;;;;;
+111C2;SHARADA SIGN JIHVAMULIYA;Lo;0;L;;;;;N;;;;;
+111C3;SHARADA SIGN UPADHMANIYA;Lo;0;L;;;;;N;;;;;
+111C4;SHARADA OM;Lo;0;L;;;;;N;;;;;
+111C5;SHARADA DANDA;Po;0;L;;;;;N;;;;;
+111C6;SHARADA DOUBLE DANDA;Po;0;L;;;;;N;;;;;
+111C7;SHARADA ABBREVIATION SIGN;Po;0;L;;;;;N;;;;;
+111C8;SHARADA SEPARATOR;Po;0;L;;;;;N;;;;;
+111D0;SHARADA DIGIT ZERO;Nd;0;L;;0;0;0;N;;;;;
+111D1;SHARADA DIGIT ONE;Nd;0;L;;1;1;1;N;;;;;
+111D2;SHARADA DIGIT TWO;Nd;0;L;;2;2;2;N;;;;;
+111D3;SHARADA DIGIT THREE;Nd;0;L;;3;3;3;N;;;;;
+111D4;SHARADA DIGIT FOUR;Nd;0;L;;4;4;4;N;;;;;
+111D5;SHARADA DIGIT FIVE;Nd;0;L;;5;5;5;N;;;;;
+111D6;SHARADA DIGIT SIX;Nd;0;L;;6;6;6;N;;;;;
+111D7;SHARADA DIGIT SEVEN;Nd;0;L;;7;7;7;N;;;;;
+111D8;SHARADA DIGIT EIGHT;Nd;0;L;;8;8;8;N;;;;;
+111D9;SHARADA DIGIT NINE;Nd;0;L;;9;9;9;N;;;;;
+11680;TAKRI LETTER A;Lo;0;L;;;;;N;;;;;
+11681;TAKRI LETTER AA;Lo;0;L;;;;;N;;;;;
+11682;TAKRI LETTER I;Lo;0;L;;;;;N;;;;;
+11683;TAKRI LETTER II;Lo;0;L;;;;;N;;;;;
+11684;TAKRI LETTER U;Lo;0;L;;;;;N;;;;;
+11685;TAKRI LETTER UU;Lo;0;L;;;;;N;;;;;
+11686;TAKRI LETTER E;Lo;0;L;;;;;N;;;;;
+11687;TAKRI LETTER AI;Lo;0;L;;;;;N;;;;;
+11688;TAKRI LETTER O;Lo;0;L;;;;;N;;;;;
+11689;TAKRI LETTER AU;Lo;0;L;;;;;N;;;;;
+1168A;TAKRI LETTER KA;Lo;0;L;;;;;N;;;;;
+1168B;TAKRI LETTER KHA;Lo;0;L;;;;;N;;;;;
+1168C;TAKRI LETTER GA;Lo;0;L;;;;;N;;;;;
+1168D;TAKRI LETTER GHA;Lo;0;L;;;;;N;;;;;
+1168E;TAKRI LETTER NGA;Lo;0;L;;;;;N;;;;;
+1168F;TAKRI LETTER CA;Lo;0;L;;;;;N;;;;;
+11690;TAKRI LETTER CHA;Lo;0;L;;;;;N;;;;;
+11691;TAKRI LETTER JA;Lo;0;L;;;;;N;;;;;
+11692;TAKRI LETTER JHA;Lo;0;L;;;;;N;;;;;
+11693;TAKRI LETTER NYA;Lo;0;L;;;;;N;;;;;
+11694;TAKRI LETTER TTA;Lo;0;L;;;;;N;;;;;
+11695;TAKRI LETTER TTHA;Lo;0;L;;;;;N;;;;;
+11696;TAKRI LETTER DDA;Lo;0;L;;;;;N;;;;;
+11697;TAKRI LETTER DDHA;Lo;0;L;;;;;N;;;;;
+11698;TAKRI LETTER NNA;Lo;0;L;;;;;N;;;;;
+11699;TAKRI LETTER TA;Lo;0;L;;;;;N;;;;;
+1169A;TAKRI LETTER THA;Lo;0;L;;;;;N;;;;;
+1169B;TAKRI LETTER DA;Lo;0;L;;;;;N;;;;;
+1169C;TAKRI LETTER DHA;Lo;0;L;;;;;N;;;;;
+1169D;TAKRI LETTER NA;Lo;0;L;;;;;N;;;;;
+1169E;TAKRI LETTER PA;Lo;0;L;;;;;N;;;;;
+1169F;TAKRI LETTER PHA;Lo;0;L;;;;;N;;;;;
+116A0;TAKRI LETTER BA;Lo;0;L;;;;;N;;;;;
+116A1;TAKRI LETTER BHA;Lo;0;L;;;;;N;;;;;
+116A2;TAKRI LETTER MA;Lo;0;L;;;;;N;;;;;
+116A3;TAKRI LETTER YA;Lo;0;L;;;;;N;;;;;
+116A4;TAKRI LETTER RA;Lo;0;L;;;;;N;;;;;
+116A5;TAKRI LETTER LA;Lo;0;L;;;;;N;;;;;
+116A6;TAKRI LETTER VA;Lo;0;L;;;;;N;;;;;
+116A7;TAKRI LETTER SHA;Lo;0;L;;;;;N;;;;;
+116A8;TAKRI LETTER SA;Lo;0;L;;;;;N;;;;;
+116A9;TAKRI LETTER HA;Lo;0;L;;;;;N;;;;;
+116AA;TAKRI LETTER RRA;Lo;0;L;;;;;N;;;;;
+116AB;TAKRI SIGN ANUSVARA;Mn;0;NSM;;;;;N;;;;;
+116AC;TAKRI SIGN VISARGA;Mc;0;L;;;;;N;;;;;
+116AD;TAKRI VOWEL SIGN AA;Mn;0;NSM;;;;;N;;;;;
+116AE;TAKRI VOWEL SIGN I;Mc;0;L;;;;;N;;;;;
+116AF;TAKRI VOWEL SIGN II;Mc;0;L;;;;;N;;;;;
+116B0;TAKRI VOWEL SIGN U;Mn;0;NSM;;;;;N;;;;;
+116B1;TAKRI VOWEL SIGN UU;Mn;0;NSM;;;;;N;;;;;
+116B2;TAKRI VOWEL SIGN E;Mn;0;NSM;;;;;N;;;;;
+116B3;TAKRI VOWEL SIGN AI;Mn;0;NSM;;;;;N;;;;;
+116B4;TAKRI VOWEL SIGN O;Mn;0;NSM;;;;;N;;;;;
+116B5;TAKRI VOWEL SIGN AU;Mn;0;NSM;;;;;N;;;;;
+116B6;TAKRI SIGN VIRAMA;Mc;9;L;;;;;N;;;;;
+116B7;TAKRI SIGN NUKTA;Mn;7;NSM;;;;;N;;;;;
+116C0;TAKRI DIGIT ZERO;Nd;0;L;;0;0;0;N;;;;;
+116C1;TAKRI DIGIT ONE;Nd;0;L;;1;1;1;N;;;;;
+116C2;TAKRI DIGIT TWO;Nd;0;L;;2;2;2;N;;;;;
+116C3;TAKRI DIGIT THREE;Nd;0;L;;3;3;3;N;;;;;
+116C4;TAKRI DIGIT FOUR;Nd;0;L;;4;4;4;N;;;;;
+116C5;TAKRI DIGIT FIVE;Nd;0;L;;5;5;5;N;;;;;
+116C6;TAKRI DIGIT SIX;Nd;0;L;;6;6;6;N;;;;;
+116C7;TAKRI DIGIT SEVEN;Nd;0;L;;7;7;7;N;;;;;
+116C8;TAKRI DIGIT EIGHT;Nd;0;L;;8;8;8;N;;;;;
+116C9;TAKRI DIGIT NINE;Nd;0;L;;9;9;9;N;;;;;
12000;CUNEIFORM SIGN A;Lo;0;L;;;;;N;;;;;
12001;CUNEIFORM SIGN A TIMES A;Lo;0;L;;;;;N;;;;;
12002;CUNEIFORM SIGN A TIMES BAD;Lo;0;L;;;;;N;;;;;
@@ -18267,8 +18704,8 @@
1242F;CUNEIFORM NUMERIC SIGN THREE SHARU VARIANT FORM;Nl;0;L;;;;3;N;;;;;
12430;CUNEIFORM NUMERIC SIGN FOUR SHARU;Nl;0;L;;;;4;N;;;;;
12431;CUNEIFORM NUMERIC SIGN FIVE SHARU;Nl;0;L;;;;5;N;;;;;
-12432;CUNEIFORM NUMERIC SIGN SHAR2 TIMES GAL PLUS DISH;Nl;0;L;;;;;N;;;;;
-12433;CUNEIFORM NUMERIC SIGN SHAR2 TIMES GAL PLUS MIN;Nl;0;L;;;;;N;;;;;
+12432;CUNEIFORM NUMERIC SIGN SHAR2 TIMES GAL PLUS DISH;Nl;0;L;;;;216000;N;;;;;
+12433;CUNEIFORM NUMERIC SIGN SHAR2 TIMES GAL PLUS MIN;Nl;0;L;;;;432000;N;;;;;
12434;CUNEIFORM NUMERIC SIGN ONE BURU;Nl;0;L;;;;1;N;;;;;
12435;CUNEIFORM NUMERIC SIGN TWO BURU;Nl;0;L;;;;2;N;;;;;
12436;CUNEIFORM NUMERIC SIGN THREE BURU;Nl;0;L;;;;3;N;;;;;
@@ -18303,8 +18740,8 @@
12453;CUNEIFORM NUMERIC SIGN FOUR BAN2 VARIANT FORM;Nl;0;L;;;;4;N;;;;;
12454;CUNEIFORM NUMERIC SIGN FIVE BAN2;Nl;0;L;;;;5;N;;;;;
12455;CUNEIFORM NUMERIC SIGN FIVE BAN2 VARIANT FORM;Nl;0;L;;;;5;N;;;;;
-12456;CUNEIFORM NUMERIC SIGN NIGIDAMIN;Nl;0;L;;;;;N;;;;;
-12457;CUNEIFORM NUMERIC SIGN NIGIDAESH;Nl;0;L;;;;;N;;;;;
+12456;CUNEIFORM NUMERIC SIGN NIGIDAMIN;Nl;0;L;;;;-1;N;;;;;
+12457;CUNEIFORM NUMERIC SIGN NIGIDAESH;Nl;0;L;;;;-1;N;;;;;
12458;CUNEIFORM NUMERIC SIGN ONE ESHE3;Nl;0;L;;;;1;N;;;;;
12459;CUNEIFORM NUMERIC SIGN TWO ESHE3;Nl;0;L;;;;2;N;;;;;
1245A;CUNEIFORM NUMERIC SIGN ONE THIRD DISH;Nl;0;L;;;;1/3;N;;;;;
@@ -19960,6 +20397,139 @@
16A36;BAMUM LETTER PHASE-F KPA;Lo;0;L;;;;;N;;;;;
16A37;BAMUM LETTER PHASE-F SAMBA;Lo;0;L;;;;;N;;;;;
16A38;BAMUM LETTER PHASE-F VUEQ;Lo;0;L;;;;;N;;;;;
+16F00;MIAO LETTER PA;Lo;0;L;;;;;N;;;;;
+16F01;MIAO LETTER BA;Lo;0;L;;;;;N;;;;;
+16F02;MIAO LETTER YI PA;Lo;0;L;;;;;N;;;;;
+16F03;MIAO LETTER PLA;Lo;0;L;;;;;N;;;;;
+16F04;MIAO LETTER MA;Lo;0;L;;;;;N;;;;;
+16F05;MIAO LETTER MHA;Lo;0;L;;;;;N;;;;;
+16F06;MIAO LETTER ARCHAIC MA;Lo;0;L;;;;;N;;;;;
+16F07;MIAO LETTER FA;Lo;0;L;;;;;N;;;;;
+16F08;MIAO LETTER VA;Lo;0;L;;;;;N;;;;;
+16F09;MIAO LETTER VFA;Lo;0;L;;;;;N;;;;;
+16F0A;MIAO LETTER TA;Lo;0;L;;;;;N;;;;;
+16F0B;MIAO LETTER DA;Lo;0;L;;;;;N;;;;;
+16F0C;MIAO LETTER YI TTA;Lo;0;L;;;;;N;;;;;
+16F0D;MIAO LETTER YI TA;Lo;0;L;;;;;N;;;;;
+16F0E;MIAO LETTER TTA;Lo;0;L;;;;;N;;;;;
+16F0F;MIAO LETTER DDA;Lo;0;L;;;;;N;;;;;
+16F10;MIAO LETTER NA;Lo;0;L;;;;;N;;;;;
+16F11;MIAO LETTER NHA;Lo;0;L;;;;;N;;;;;
+16F12;MIAO LETTER YI NNA;Lo;0;L;;;;;N;;;;;
+16F13;MIAO LETTER ARCHAIC NA;Lo;0;L;;;;;N;;;;;
+16F14;MIAO LETTER NNA;Lo;0;L;;;;;N;;;;;
+16F15;MIAO LETTER NNHA;Lo;0;L;;;;;N;;;;;
+16F16;MIAO LETTER LA;Lo;0;L;;;;;N;;;;;
+16F17;MIAO LETTER LYA;Lo;0;L;;;;;N;;;;;
+16F18;MIAO LETTER LHA;Lo;0;L;;;;;N;;;;;
+16F19;MIAO LETTER LHYA;Lo;0;L;;;;;N;;;;;
+16F1A;MIAO LETTER TLHA;Lo;0;L;;;;;N;;;;;
+16F1B;MIAO LETTER DLHA;Lo;0;L;;;;;N;;;;;
+16F1C;MIAO LETTER TLHYA;Lo;0;L;;;;;N;;;;;
+16F1D;MIAO LETTER DLHYA;Lo;0;L;;;;;N;;;;;
+16F1E;MIAO LETTER KA;Lo;0;L;;;;;N;;;;;
+16F1F;MIAO LETTER GA;Lo;0;L;;;;;N;;;;;
+16F20;MIAO LETTER YI KA;Lo;0;L;;;;;N;;;;;
+16F21;MIAO LETTER QA;Lo;0;L;;;;;N;;;;;
+16F22;MIAO LETTER QGA;Lo;0;L;;;;;N;;;;;
+16F23;MIAO LETTER NGA;Lo;0;L;;;;;N;;;;;
+16F24;MIAO LETTER NGHA;Lo;0;L;;;;;N;;;;;
+16F25;MIAO LETTER ARCHAIC NGA;Lo;0;L;;;;;N;;;;;
+16F26;MIAO LETTER HA;Lo;0;L;;;;;N;;;;;
+16F27;MIAO LETTER XA;Lo;0;L;;;;;N;;;;;
+16F28;MIAO LETTER GHA;Lo;0;L;;;;;N;;;;;
+16F29;MIAO LETTER GHHA;Lo;0;L;;;;;N;;;;;
+16F2A;MIAO LETTER TSSA;Lo;0;L;;;;;N;;;;;
+16F2B;MIAO LETTER DZZA;Lo;0;L;;;;;N;;;;;
+16F2C;MIAO LETTER NYA;Lo;0;L;;;;;N;;;;;
+16F2D;MIAO LETTER NYHA;Lo;0;L;;;;;N;;;;;
+16F2E;MIAO LETTER TSHA;Lo;0;L;;;;;N;;;;;
+16F2F;MIAO LETTER DZHA;Lo;0;L;;;;;N;;;;;
+16F30;MIAO LETTER YI TSHA;Lo;0;L;;;;;N;;;;;
+16F31;MIAO LETTER YI DZHA;Lo;0;L;;;;;N;;;;;
+16F32;MIAO LETTER REFORMED TSHA;Lo;0;L;;;;;N;;;;;
+16F33;MIAO LETTER SHA;Lo;0;L;;;;;N;;;;;
+16F34;MIAO LETTER SSA;Lo;0;L;;;;;N;;;;;
+16F35;MIAO LETTER ZHA;Lo;0;L;;;;;N;;;;;
+16F36;MIAO LETTER ZSHA;Lo;0;L;;;;;N;;;;;
+16F37;MIAO LETTER TSA;Lo;0;L;;;;;N;;;;;
+16F38;MIAO LETTER DZA;Lo;0;L;;;;;N;;;;;
+16F39;MIAO LETTER YI TSA;Lo;0;L;;;;;N;;;;;
+16F3A;MIAO LETTER SA;Lo;0;L;;;;;N;;;;;
+16F3B;MIAO LETTER ZA;Lo;0;L;;;;;N;;;;;
+16F3C;MIAO LETTER ZSA;Lo;0;L;;;;;N;;;;;
+16F3D;MIAO LETTER ZZA;Lo;0;L;;;;;N;;;;;
+16F3E;MIAO LETTER ZZSA;Lo;0;L;;;;;N;;;;;
+16F3F;MIAO LETTER ARCHAIC ZZA;Lo;0;L;;;;;N;;;;;
+16F40;MIAO LETTER ZZYA;Lo;0;L;;;;;N;;;;;
+16F41;MIAO LETTER ZZSYA;Lo;0;L;;;;;N;;;;;
+16F42;MIAO LETTER WA;Lo;0;L;;;;;N;;;;;
+16F43;MIAO LETTER AH;Lo;0;L;;;;;N;;;;;
+16F44;MIAO LETTER HHA;Lo;0;L;;;;;N;;;;;
+16F50;MIAO LETTER NASALIZATION;Lo;0;L;;;;;N;;;;;
+16F51;MIAO SIGN ASPIRATION;Mc;0;L;;;;;N;;;;;
+16F52;MIAO SIGN REFORMED VOICING;Mc;0;L;;;;;N;;;;;
+16F53;MIAO SIGN REFORMED ASPIRATION;Mc;0;L;;;;;N;;;;;
+16F54;MIAO VOWEL SIGN A;Mc;0;L;;;;;N;;;;;
+16F55;MIAO VOWEL SIGN AA;Mc;0;L;;;;;N;;;;;
+16F56;MIAO VOWEL SIGN AHH;Mc;0;L;;;;;N;;;;;
+16F57;MIAO VOWEL SIGN AN;Mc;0;L;;;;;N;;;;;
+16F58;MIAO VOWEL SIGN ANG;Mc;0;L;;;;;N;;;;;
+16F59;MIAO VOWEL SIGN O;Mc;0;L;;;;;N;;;;;
+16F5A;MIAO VOWEL SIGN OO;Mc;0;L;;;;;N;;;;;
+16F5B;MIAO VOWEL SIGN WO;Mc;0;L;;;;;N;;;;;
+16F5C;MIAO VOWEL SIGN W;Mc;0;L;;;;;N;;;;;
+16F5D;MIAO VOWEL SIGN E;Mc;0;L;;;;;N;;;;;
+16F5E;MIAO VOWEL SIGN EN;Mc;0;L;;;;;N;;;;;
+16F5F;MIAO VOWEL SIGN ENG;Mc;0;L;;;;;N;;;;;
+16F60;MIAO VOWEL SIGN OEY;Mc;0;L;;;;;N;;;;;
+16F61;MIAO VOWEL SIGN I;Mc;0;L;;;;;N;;;;;
+16F62;MIAO VOWEL SIGN IA;Mc;0;L;;;;;N;;;;;
+16F63;MIAO VOWEL SIGN IAN;Mc;0;L;;;;;N;;;;;
+16F64;MIAO VOWEL SIGN IANG;Mc;0;L;;;;;N;;;;;
+16F65;MIAO VOWEL SIGN IO;Mc;0;L;;;;;N;;;;;
+16F66;MIAO VOWEL SIGN IE;Mc;0;L;;;;;N;;;;;
+16F67;MIAO VOWEL SIGN II;Mc;0;L;;;;;N;;;;;
+16F68;MIAO VOWEL SIGN IU;Mc;0;L;;;;;N;;;;;
+16F69;MIAO VOWEL SIGN ING;Mc;0;L;;;;;N;;;;;
+16F6A;MIAO VOWEL SIGN U;Mc;0;L;;;;;N;;;;;
+16F6B;MIAO VOWEL SIGN UA;Mc;0;L;;;;;N;;;;;
+16F6C;MIAO VOWEL SIGN UAN;Mc;0;L;;;;;N;;;;;
+16F6D;MIAO VOWEL SIGN UANG;Mc;0;L;;;;;N;;;;;
+16F6E;MIAO VOWEL SIGN UU;Mc;0;L;;;;;N;;;;;
+16F6F;MIAO VOWEL SIGN UEI;Mc;0;L;;;;;N;;;;;
+16F70;MIAO VOWEL SIGN UNG;Mc;0;L;;;;;N;;;;;
+16F71;MIAO VOWEL SIGN Y;Mc;0;L;;;;;N;;;;;
+16F72;MIAO VOWEL SIGN YI;Mc;0;L;;;;;N;;;;;
+16F73;MIAO VOWEL SIGN AE;Mc;0;L;;;;;N;;;;;
+16F74;MIAO VOWEL SIGN AEE;Mc;0;L;;;;;N;;;;;
+16F75;MIAO VOWEL SIGN ERR;Mc;0;L;;;;;N;;;;;
+16F76;MIAO VOWEL SIGN ROUNDED ERR;Mc;0;L;;;;;N;;;;;
+16F77;MIAO VOWEL SIGN ER;Mc;0;L;;;;;N;;;;;
+16F78;MIAO VOWEL SIGN ROUNDED ER;Mc;0;L;;;;;N;;;;;
+16F79;MIAO VOWEL SIGN AI;Mc;0;L;;;;;N;;;;;
+16F7A;MIAO VOWEL SIGN EI;Mc;0;L;;;;;N;;;;;
+16F7B;MIAO VOWEL SIGN AU;Mc;0;L;;;;;N;;;;;
+16F7C;MIAO VOWEL SIGN OU;Mc;0;L;;;;;N;;;;;
+16F7D;MIAO VOWEL SIGN N;Mc;0;L;;;;;N;;;;;
+16F7E;MIAO VOWEL SIGN NG;Mc;0;L;;;;;N;;;;;
+16F8F;MIAO TONE RIGHT;Mn;0;NSM;;;;;N;;;;;
+16F90;MIAO TONE TOP RIGHT;Mn;0;NSM;;;;;N;;;;;
+16F91;MIAO TONE ABOVE;Mn;0;NSM;;;;;N;;;;;
+16F92;MIAO TONE BELOW;Mn;0;NSM;;;;;N;;;;;
+16F93;MIAO LETTER TONE-2;Lm;0;L;;;;;N;;;;;
+16F94;MIAO LETTER TONE-3;Lm;0;L;;;;;N;;;;;
+16F95;MIAO LETTER TONE-4;Lm;0;L;;;;;N;;;;;
+16F96;MIAO LETTER TONE-5;Lm;0;L;;;;;N;;;;;
+16F97;MIAO LETTER TONE-6;Lm;0;L;;;;;N;;;;;
+16F98;MIAO LETTER TONE-7;Lm;0;L;;;;;N;;;;;
+16F99;MIAO LETTER TONE-8;Lm;0;L;;;;;N;;;;;
+16F9A;MIAO LETTER REFORMED TONE-1;Lm;0;L;;;;;N;;;;;
+16F9B;MIAO LETTER REFORMED TONE-2;Lm;0;L;;;;;N;;;;;
+16F9C;MIAO LETTER REFORMED TONE-4;Lm;0;L;;;;;N;;;;;
+16F9D;MIAO LETTER REFORMED TONE-5;Lm;0;L;;;;;N;;;;;
+16F9E;MIAO LETTER REFORMED TONE-6;Lm;0;L;;;;;N;;;;;
+16F9F;MIAO LETTER REFORMED TONE-8;Lm;0;L;;;;;N;;;;;
1B000;KATAKANA LETTER ARCHAIC E;Lo;0;L;;;;;N;;;;;
1B001;HIRAGANA LETTER ARCHAIC YE;Lo;0;L;;;;;N;;;;;
1D000;BYZANTINE MUSICAL SYMBOL PSILI;So;0;L;;;;;N;;;;;
@@ -21599,6 +22169,149 @@
1D7FD;MATHEMATICAL MONOSPACE DIGIT SEVEN;Nd;0;EN;<font> 0037;7;7;7;N;;;;;
1D7FE;MATHEMATICAL MONOSPACE DIGIT EIGHT;Nd;0;EN;<font> 0038;8;8;8;N;;;;;
1D7FF;MATHEMATICAL MONOSPACE DIGIT NINE;Nd;0;EN;<font> 0039;9;9;9;N;;;;;
+1EE00;ARABIC MATHEMATICAL ALEF;Lo;0;AL;<font> 0627;;;;N;;;;;
+1EE01;ARABIC MATHEMATICAL BEH;Lo;0;AL;<font> 0628;;;;N;;;;;
+1EE02;ARABIC MATHEMATICAL JEEM;Lo;0;AL;<font> 062C;;;;N;;;;;
+1EE03;ARABIC MATHEMATICAL DAL;Lo;0;AL;<font> 062F;;;;N;;;;;
+1EE05;ARABIC MATHEMATICAL WAW;Lo;0;AL;<font> 0648;;;;N;;;;;
+1EE06;ARABIC MATHEMATICAL ZAIN;Lo;0;AL;<font> 0632;;;;N;;;;;
+1EE07;ARABIC MATHEMATICAL HAH;Lo;0;AL;<font> 062D;;;;N;;;;;
+1EE08;ARABIC MATHEMATICAL TAH;Lo;0;AL;<font> 0637;;;;N;;;;;
+1EE09;ARABIC MATHEMATICAL YEH;Lo;0;AL;<font> 064A;;;;N;;;;;
+1EE0A;ARABIC MATHEMATICAL KAF;Lo;0;AL;<font> 0643;;;;N;;;;;
+1EE0B;ARABIC MATHEMATICAL LAM;Lo;0;AL;<font> 0644;;;;N;;;;;
+1EE0C;ARABIC MATHEMATICAL MEEM;Lo;0;AL;<font> 0645;;;;N;;;;;
+1EE0D;ARABIC MATHEMATICAL NOON;Lo;0;AL;<font> 0646;;;;N;;;;;
+1EE0E;ARABIC MATHEMATICAL SEEN;Lo;0;AL;<font> 0633;;;;N;;;;;
+1EE0F;ARABIC MATHEMATICAL AIN;Lo;0;AL;<font> 0639;;;;N;;;;;
+1EE10;ARABIC MATHEMATICAL FEH;Lo;0;AL;<font> 0641;;;;N;;;;;
+1EE11;ARABIC MATHEMATICAL SAD;Lo;0;AL;<font> 0635;;;;N;;;;;
+1EE12;ARABIC MATHEMATICAL QAF;Lo;0;AL;<font> 0642;;;;N;;;;;
+1EE13;ARABIC MATHEMATICAL REH;Lo;0;AL;<font> 0631;;;;N;;;;;
+1EE14;ARABIC MATHEMATICAL SHEEN;Lo;0;AL;<font> 0634;;;;N;;;;;
+1EE15;ARABIC MATHEMATICAL TEH;Lo;0;AL;<font> 062A;;;;N;;;;;
+1EE16;ARABIC MATHEMATICAL THEH;Lo;0;AL;<font> 062B;;;;N;;;;;
+1EE17;ARABIC MATHEMATICAL KHAH;Lo;0;AL;<font> 062E;;;;N;;;;;
+1EE18;ARABIC MATHEMATICAL THAL;Lo;0;AL;<font> 0630;;;;N;;;;;
+1EE19;ARABIC MATHEMATICAL DAD;Lo;0;AL;<font> 0636;;;;N;;;;;
+1EE1A;ARABIC MATHEMATICAL ZAH;Lo;0;AL;<font> 0638;;;;N;;;;;
+1EE1B;ARABIC MATHEMATICAL GHAIN;Lo;0;AL;<font> 063A;;;;N;;;;;
+1EE1C;ARABIC MATHEMATICAL DOTLESS BEH;Lo;0;AL;<font> 066E;;;;N;;;;;
+1EE1D;ARABIC MATHEMATICAL DOTLESS NOON;Lo;0;AL;<font> 06BA;;;;N;;;;;
+1EE1E;ARABIC MATHEMATICAL DOTLESS FEH;Lo;0;AL;<font> 06A1;;;;N;;;;;
+1EE1F;ARABIC MATHEMATICAL DOTLESS QAF;Lo;0;AL;<font> 066F;;;;N;;;;;
+1EE21;ARABIC MATHEMATICAL INITIAL BEH;Lo;0;AL;<font> 0628;;;;N;;;;;
+1EE22;ARABIC MATHEMATICAL INITIAL JEEM;Lo;0;AL;<font> 062C;;;;N;;;;;
+1EE24;ARABIC MATHEMATICAL INITIAL HEH;Lo;0;AL;<font> 0647;;;;N;;;;;
+1EE27;ARABIC MATHEMATICAL INITIAL HAH;Lo;0;AL;<font> 062D;;;;N;;;;;
+1EE29;ARABIC MATHEMATICAL INITIAL YEH;Lo;0;AL;<font> 064A;;;;N;;;;;
+1EE2A;ARABIC MATHEMATICAL INITIAL KAF;Lo;0;AL;<font> 0643;;;;N;;;;;
+1EE2B;ARABIC MATHEMATICAL INITIAL LAM;Lo;0;AL;<font> 0644;;;;N;;;;;
+1EE2C;ARABIC MATHEMATICAL INITIAL MEEM;Lo;0;AL;<font> 0645;;;;N;;;;;
+1EE2D;ARABIC MATHEMATICAL INITIAL NOON;Lo;0;AL;<font> 0646;;;;N;;;;;
+1EE2E;ARABIC MATHEMATICAL INITIAL SEEN;Lo;0;AL;<font> 0633;;;;N;;;;;
+1EE2F;ARABIC MATHEMATICAL INITIAL AIN;Lo;0;AL;<font> 0639;;;;N;;;;;
+1EE30;ARABIC MATHEMATICAL INITIAL FEH;Lo;0;AL;<font> 0641;;;;N;;;;;
+1EE31;ARABIC MATHEMATICAL INITIAL SAD;Lo;0;AL;<font> 0635;;;;N;;;;;
+1EE32;ARABIC MATHEMATICAL INITIAL QAF;Lo;0;AL;<font> 0642;;;;N;;;;;
+1EE34;ARABIC MATHEMATICAL INITIAL SHEEN;Lo;0;AL;<font> 0634;;;;N;;;;;
+1EE35;ARABIC MATHEMATICAL INITIAL TEH;Lo;0;AL;<font> 062A;;;;N;;;;;
+1EE36;ARABIC MATHEMATICAL INITIAL THEH;Lo;0;AL;<font> 062B;;;;N;;;;;
+1EE37;ARABIC MATHEMATICAL INITIAL KHAH;Lo;0;AL;<font> 062E;;;;N;;;;;
+1EE39;ARABIC MATHEMATICAL INITIAL DAD;Lo;0;AL;<font> 0636;;;;N;;;;;
+1EE3B;ARABIC MATHEMATICAL INITIAL GHAIN;Lo;0;AL;<font> 063A;;;;N;;;;;
+1EE42;ARABIC MATHEMATICAL TAILED JEEM;Lo;0;AL;<font> 062C;;;;N;;;;;
+1EE47;ARABIC MATHEMATICAL TAILED HAH;Lo;0;AL;<font> 062D;;;;N;;;;;
+1EE49;ARABIC MATHEMATICAL TAILED YEH;Lo;0;AL;<font> 064A;;;;N;;;;;
+1EE4B;ARABIC MATHEMATICAL TAILED LAM;Lo;0;AL;<font> 0644;;;;N;;;;;
+1EE4D;ARABIC MATHEMATICAL TAILED NOON;Lo;0;AL;<font> 0646;;;;N;;;;;
+1EE4E;ARABIC MATHEMATICAL TAILED SEEN;Lo;0;AL;<font> 0633;;;;N;;;;;
+1EE4F;ARABIC MATHEMATICAL TAILED AIN;Lo;0;AL;<font> 0639;;;;N;;;;;
+1EE51;ARABIC MATHEMATICAL TAILED SAD;Lo;0;AL;<font> 0635;;;;N;;;;;
+1EE52;ARABIC MATHEMATICAL TAILED QAF;Lo;0;AL;<font> 0642;;;;N;;;;;
+1EE54;ARABIC MATHEMATICAL TAILED SHEEN;Lo;0;AL;<font> 0634;;;;N;;;;;
+1EE57;ARABIC MATHEMATICAL TAILED KHAH;Lo;0;AL;<font> 062E;;;;N;;;;;
+1EE59;ARABIC MATHEMATICAL TAILED DAD;Lo;0;AL;<font> 0636;;;;N;;;;;
+1EE5B;ARABIC MATHEMATICAL TAILED GHAIN;Lo;0;AL;<font> 063A;;;;N;;;;;
+1EE5D;ARABIC MATHEMATICAL TAILED DOTLESS NOON;Lo;0;AL;<font> 06BA;;;;N;;;;;
+1EE5F;ARABIC MATHEMATICAL TAILED DOTLESS QAF;Lo;0;AL;<font> 066F;;;;N;;;;;
+1EE61;ARABIC MATHEMATICAL STRETCHED BEH;Lo;0;AL;<font> 0628;;;;N;;;;;
+1EE62;ARABIC MATHEMATICAL STRETCHED JEEM;Lo;0;AL;<font> 062C;;;;N;;;;;
+1EE64;ARABIC MATHEMATICAL STRETCHED HEH;Lo;0;AL;<font> 0647;;;;N;;;;;
+1EE67;ARABIC MATHEMATICAL STRETCHED HAH;Lo;0;AL;<font> 062D;;;;N;;;;;
+1EE68;ARABIC MATHEMATICAL STRETCHED TAH;Lo;0;AL;<font> 0637;;;;N;;;;;
+1EE69;ARABIC MATHEMATICAL STRETCHED YEH;Lo;0;AL;<font> 064A;;;;N;;;;;
+1EE6A;ARABIC MATHEMATICAL STRETCHED KAF;Lo;0;AL;<font> 0643;;;;N;;;;;
+1EE6C;ARABIC MATHEMATICAL STRETCHED MEEM;Lo;0;AL;<font> 0645;;;;N;;;;;
+1EE6D;ARABIC MATHEMATICAL STRETCHED NOON;Lo;0;AL;<font> 0646;;;;N;;;;;
+1EE6E;ARABIC MATHEMATICAL STRETCHED SEEN;Lo;0;AL;<font> 0633;;;;N;;;;;
+1EE6F;ARABIC MATHEMATICAL STRETCHED AIN;Lo;0;AL;<font> 0639;;;;N;;;;;
+1EE70;ARABIC MATHEMATICAL STRETCHED FEH;Lo;0;AL;<font> 0641;;;;N;;;;;
+1EE71;ARABIC MATHEMATICAL STRETCHED SAD;Lo;0;AL;<font> 0635;;;;N;;;;;
+1EE72;ARABIC MATHEMATICAL STRETCHED QAF;Lo;0;AL;<font> 0642;;;;N;;;;;
+1EE74;ARABIC MATHEMATICAL STRETCHED SHEEN;Lo;0;AL;<font> 0634;;;;N;;;;;
+1EE75;ARABIC MATHEMATICAL STRETCHED TEH;Lo;0;AL;<font> 062A;;;;N;;;;;
+1EE76;ARABIC MATHEMATICAL STRETCHED THEH;Lo;0;AL;<font> 062B;;;;N;;;;;
+1EE77;ARABIC MATHEMATICAL STRETCHED KHAH;Lo;0;AL;<font> 062E;;;;N;;;;;
+1EE79;ARABIC MATHEMATICAL STRETCHED DAD;Lo;0;AL;<font> 0636;;;;N;;;;;
+1EE7A;ARABIC MATHEMATICAL STRETCHED ZAH;Lo;0;AL;<font> 0638;;;;N;;;;;
+1EE7B;ARABIC MATHEMATICAL STRETCHED GHAIN;Lo;0;AL;<font> 063A;;;;N;;;;;
+1EE7C;ARABIC MATHEMATICAL STRETCHED DOTLESS BEH;Lo;0;AL;<font> 066E;;;;N;;;;;
+1EE7E;ARABIC MATHEMATICAL STRETCHED DOTLESS FEH;Lo;0;AL;<font> 06A1;;;;N;;;;;
+1EE80;ARABIC MATHEMATICAL LOOPED ALEF;Lo;0;AL;<font> 0627;;;;N;;;;;
+1EE81;ARABIC MATHEMATICAL LOOPED BEH;Lo;0;AL;<font> 0628;;;;N;;;;;
+1EE82;ARABIC MATHEMATICAL LOOPED JEEM;Lo;0;AL;<font> 062C;;;;N;;;;;
+1EE83;ARABIC MATHEMATICAL LOOPED DAL;Lo;0;AL;<font> 062F;;;;N;;;;;
+1EE84;ARABIC MATHEMATICAL LOOPED HEH;Lo;0;AL;<font> 0647;;;;N;;;;;
+1EE85;ARABIC MATHEMATICAL LOOPED WAW;Lo;0;AL;<font> 0648;;;;N;;;;;
+1EE86;ARABIC MATHEMATICAL LOOPED ZAIN;Lo;0;AL;<font> 0632;;;;N;;;;;
+1EE87;ARABIC MATHEMATICAL LOOPED HAH;Lo;0;AL;<font> 062D;;;;N;;;;;
+1EE88;ARABIC MATHEMATICAL LOOPED TAH;Lo;0;AL;<font> 0637;;;;N;;;;;
+1EE89;ARABIC MATHEMATICAL LOOPED YEH;Lo;0;AL;<font> 064A;;;;N;;;;;
+1EE8B;ARABIC MATHEMATICAL LOOPED LAM;Lo;0;AL;<font> 0644;;;;N;;;;;
+1EE8C;ARABIC MATHEMATICAL LOOPED MEEM;Lo;0;AL;<font> 0645;;;;N;;;;;
+1EE8D;ARABIC MATHEMATICAL LOOPED NOON;Lo;0;AL;<font> 0646;;;;N;;;;;
+1EE8E;ARABIC MATHEMATICAL LOOPED SEEN;Lo;0;AL;<font> 0633;;;;N;;;;;
+1EE8F;ARABIC MATHEMATICAL LOOPED AIN;Lo;0;AL;<font> 0639;;;;N;;;;;
+1EE90;ARABIC MATHEMATICAL LOOPED FEH;Lo;0;AL;<font> 0641;;;;N;;;;;
+1EE91;ARABIC MATHEMATICAL LOOPED SAD;Lo;0;AL;<font> 0635;;;;N;;;;;
+1EE92;ARABIC MATHEMATICAL LOOPED QAF;Lo;0;AL;<font> 0642;;;;N;;;;;
+1EE93;ARABIC MATHEMATICAL LOOPED REH;Lo;0;AL;<font> 0631;;;;N;;;;;
+1EE94;ARABIC MATHEMATICAL LOOPED SHEEN;Lo;0;AL;<font> 0634;;;;N;;;;;
+1EE95;ARABIC MATHEMATICAL LOOPED TEH;Lo;0;AL;<font> 062A;;;;N;;;;;
+1EE96;ARABIC MATHEMATICAL LOOPED THEH;Lo;0;AL;<font> 062B;;;;N;;;;;
+1EE97;ARABIC MATHEMATICAL LOOPED KHAH;Lo;0;AL;<font> 062E;;;;N;;;;;
+1EE98;ARABIC MATHEMATICAL LOOPED THAL;Lo;0;AL;<font> 0630;;;;N;;;;;
+1EE99;ARABIC MATHEMATICAL LOOPED DAD;Lo;0;AL;<font> 0636;;;;N;;;;;
+1EE9A;ARABIC MATHEMATICAL LOOPED ZAH;Lo;0;AL;<font> 0638;;;;N;;;;;
+1EE9B;ARABIC MATHEMATICAL LOOPED GHAIN;Lo;0;AL;<font> 063A;;;;N;;;;;
+1EEA1;ARABIC MATHEMATICAL DOUBLE-STRUCK BEH;Lo;0;AL;<font> 0628;;;;N;;;;;
+1EEA2;ARABIC MATHEMATICAL DOUBLE-STRUCK JEEM;Lo;0;AL;<font> 062C;;;;N;;;;;
+1EEA3;ARABIC MATHEMATICAL DOUBLE-STRUCK DAL;Lo;0;AL;<font> 062F;;;;N;;;;;
+1EEA5;ARABIC MATHEMATICAL DOUBLE-STRUCK WAW;Lo;0;AL;<font> 0648;;;;N;;;;;
+1EEA6;ARABIC MATHEMATICAL DOUBLE-STRUCK ZAIN;Lo;0;AL;<font> 0632;;;;N;;;;;
+1EEA7;ARABIC MATHEMATICAL DOUBLE-STRUCK HAH;Lo;0;AL;<font> 062D;;;;N;;;;;
+1EEA8;ARABIC MATHEMATICAL DOUBLE-STRUCK TAH;Lo;0;AL;<font> 0637;;;;N;;;;;
+1EEA9;ARABIC MATHEMATICAL DOUBLE-STRUCK YEH;Lo;0;AL;<font> 064A;;;;N;;;;;
+1EEAB;ARABIC MATHEMATICAL DOUBLE-STRUCK LAM;Lo;0;AL;<font> 0644;;;;N;;;;;
+1EEAC;ARABIC MATHEMATICAL DOUBLE-STRUCK MEEM;Lo;0;AL;<font> 0645;;;;N;;;;;
+1EEAD;ARABIC MATHEMATICAL DOUBLE-STRUCK NOON;Lo;0;AL;<font> 0646;;;;N;;;;;
+1EEAE;ARABIC MATHEMATICAL DOUBLE-STRUCK SEEN;Lo;0;AL;<font> 0633;;;;N;;;;;
+1EEAF;ARABIC MATHEMATICAL DOUBLE-STRUCK AIN;Lo;0;AL;<font> 0639;;;;N;;;;;
+1EEB0;ARABIC MATHEMATICAL DOUBLE-STRUCK FEH;Lo;0;AL;<font> 0641;;;;N;;;;;
+1EEB1;ARABIC MATHEMATICAL DOUBLE-STRUCK SAD;Lo;0;AL;<font> 0635;;;;N;;;;;
+1EEB2;ARABIC MATHEMATICAL DOUBLE-STRUCK QAF;Lo;0;AL;<font> 0642;;;;N;;;;;
+1EEB3;ARABIC MATHEMATICAL DOUBLE-STRUCK REH;Lo;0;AL;<font> 0631;;;;N;;;;;
+1EEB4;ARABIC MATHEMATICAL DOUBLE-STRUCK SHEEN;Lo;0;AL;<font> 0634;;;;N;;;;;
+1EEB5;ARABIC MATHEMATICAL DOUBLE-STRUCK TEH;Lo;0;AL;<font> 062A;;;;N;;;;;
+1EEB6;ARABIC MATHEMATICAL DOUBLE-STRUCK THEH;Lo;0;AL;<font> 062B;;;;N;;;;;
+1EEB7;ARABIC MATHEMATICAL DOUBLE-STRUCK KHAH;Lo;0;AL;<font> 062E;;;;N;;;;;
+1EEB8;ARABIC MATHEMATICAL DOUBLE-STRUCK THAL;Lo;0;AL;<font> 0630;;;;N;;;;;
+1EEB9;ARABIC MATHEMATICAL DOUBLE-STRUCK DAD;Lo;0;AL;<font> 0636;;;;N;;;;;
+1EEBA;ARABIC MATHEMATICAL DOUBLE-STRUCK ZAH;Lo;0;AL;<font> 0638;;;;N;;;;;
+1EEBB;ARABIC MATHEMATICAL DOUBLE-STRUCK GHAIN;Lo;0;AL;<font> 063A;;;;N;;;;;
+1EEF0;ARABIC MATHEMATICAL OPERATOR MEEM WITH HAH WITH TATWEEL;Sm;0;ON;;;;;N;;;;;
+1EEF1;ARABIC MATHEMATICAL OPERATOR HAH WITH DAL;Sm;0;ON;;;;;N;;;;;
1F000;MAHJONG TILE EAST WIND;So;0;ON;;;;;N;;;;;
1F001;MAHJONG TILE SOUTH WIND;So;0;ON;;;;;N;;;;;
1F002;MAHJONG TILE WEST WIND;So;0;ON;;;;;N;;;;;
@@ -21902,6 +22615,8 @@
1F167;NEGATIVE CIRCLED LATIN CAPITAL LETTER X;So;0;L;;;;;N;;;;;
1F168;NEGATIVE CIRCLED LATIN CAPITAL LETTER Y;So;0;L;;;;;N;;;;;
1F169;NEGATIVE CIRCLED LATIN CAPITAL LETTER Z;So;0;L;;;;;N;;;;;
+1F16A;RAISED MC SIGN;So;0;ON;<super> 004D 0043;;;;N;;;;;
+1F16B;RAISED MD SIGN;So;0;ON;<super> 004D 0044;;;;N;;;;;
1F170;NEGATIVE SQUARED LATIN CAPITAL LETTER A;So;0;L;;;;;N;;;;;
1F171;NEGATIVE SQUARED LATIN CAPITAL LETTER B;So;0;L;;;;;N;;;;;
1F172;NEGATIVE SQUARED LATIN CAPITAL LETTER C;So;0;L;;;;;N;;;;;
@@ -22354,7 +23069,7 @@
1F489;SYRINGE;So;0;ON;;;;;N;;;;;
1F48A;PILL;So;0;ON;;;;;N;;;;;
1F48B;KISS MARK;So;0;ON;;;;;N;;;;;
-1F48C;LOVE LETTER;So;0;L;;;;;N;;;;;
+1F48C;LOVE LETTER;So;0;ON;;;;;N;;;;;
1F48D;RING;So;0;ON;;;;;N;;;;;
1F48E;GEM STONE;So;0;ON;;;;;N;;;;;
1F48F;KISS;So;0;ON;;;;;N;;;;;
@@ -22502,7 +23217,7 @@
1F521;INPUT SYMBOL FOR LATIN SMALL LETTERS;So;0;ON;;;;;N;;;;;
1F522;INPUT SYMBOL FOR NUMBERS;So;0;ON;;;;;N;;;;;
1F523;INPUT SYMBOL FOR SYMBOLS;So;0;ON;;;;;N;;;;;
-1F524;INPUT SYMBOL FOR LATIN LETTERS;So;0;L;;;;;N;;;;;
+1F524;INPUT SYMBOL FOR LATIN LETTERS;So;0;ON;;;;;N;;;;;
1F525;FIRE;So;0;ON;;;;;N;;;;;
1F526;ELECTRIC TORCH;So;0;ON;;;;;N;;;;;
1F527;WRENCH;So;0;ON;;;;;N;;;;;
@@ -22528,6 +23243,10 @@
1F53B;DOWN-POINTING RED TRIANGLE;So;0;ON;;;;;N;;;;;
1F53C;UP-POINTING SMALL RED TRIANGLE;So;0;ON;;;;;N;;;;;
1F53D;DOWN-POINTING SMALL RED TRIANGLE;So;0;ON;;;;;N;;;;;
+1F540;CIRCLED CROSS POMMEE;So;0;ON;;;;;N;;;;;
+1F541;CROSS POMMEE WITH HALF-CIRCLE BELOW;So;0;ON;;;;;N;;;;;
+1F542;CROSS POMMEE;So;0;ON;;;;;N;;;;;
+1F543;NOTCHED LEFT SEMICIRCLE WITH THREE DOTS;So;0;ON;;;;;N;;;;;
1F550;CLOCK FACE ONE OCLOCK;So;0;ON;;;;;N;;;;;
1F551;CLOCK FACE TWO OCLOCK;So;0;ON;;;;;N;;;;;
1F552;CLOCK FACE THREE OCLOCK;So;0;ON;;;;;N;;;;;
@@ -22557,6 +23276,7 @@
1F5FD;STATUE OF LIBERTY;So;0;ON;;;;;N;;;;;
1F5FE;SILHOUETTE OF JAPAN;So;0;ON;;;;;N;;;;;
1F5FF;MOYAI;So;0;ON;;;;;N;;;;;
+1F600;GRINNING FACE;So;0;ON;;;;;N;;;;;
1F601;GRINNING FACE WITH SMILING EYES;So;0;ON;;;;;N;;;;;
1F602;FACE WITH TEARS OF JOY;So;0;ON;;;;;N;;;;;
1F603;SMILING FACE WITH OPEN MOUTH;So;0;ON;;;;;N;;;;;
@@ -22573,15 +23293,21 @@
1F60E;SMILING FACE WITH SUNGLASSES;So;0;ON;;;;;N;;;;;
1F60F;SMIRKING FACE;So;0;ON;;;;;N;;;;;
1F610;NEUTRAL FACE;So;0;ON;;;;;N;;;;;
+1F611;EXPRESSIONLESS FACE;So;0;ON;;;;;N;;;;;
1F612;UNAMUSED FACE;So;0;ON;;;;;N;;;;;
1F613;FACE WITH COLD SWEAT;So;0;ON;;;;;N;;;;;
1F614;PENSIVE FACE;So;0;ON;;;;;N;;;;;
+1F615;CONFUSED FACE;So;0;ON;;;;;N;;;;;
1F616;CONFOUNDED FACE;So;0;ON;;;;;N;;;;;
+1F617;KISSING FACE;So;0;ON;;;;;N;;;;;
1F618;FACE THROWING A KISS;So;0;ON;;;;;N;;;;;
+1F619;KISSING FACE WITH SMILING EYES;So;0;ON;;;;;N;;;;;
1F61A;KISSING FACE WITH CLOSED EYES;So;0;ON;;;;;N;;;;;
+1F61B;FACE WITH STUCK-OUT TONGUE;So;0;ON;;;;;N;;;;;
1F61C;FACE WITH STUCK-OUT TONGUE AND WINKING EYE;So;0;ON;;;;;N;;;;;
1F61D;FACE WITH STUCK-OUT TONGUE AND TIGHTLY-CLOSED EYES;So;0;ON;;;;;N;;;;;
1F61E;DISAPPOINTED FACE;So;0;ON;;;;;N;;;;;
+1F61F;WORRIED FACE;So;0;ON;;;;;N;;;;;
1F620;ANGRY FACE;So;0;ON;;;;;N;;;;;
1F621;POUTING FACE;So;0;ON;;;;;N;;;;;
1F622;CRYING FACE;So;0;ON;;;;;N;;;;;
@@ -22588,15 +23314,21 @@
1F623;PERSEVERING FACE;So;0;ON;;;;;N;;;;;
1F624;FACE WITH LOOK OF TRIUMPH;So;0;ON;;;;;N;;;;;
1F625;DISAPPOINTED BUT RELIEVED FACE;So;0;ON;;;;;N;;;;;
+1F626;FROWNING FACE WITH OPEN MOUTH;So;0;ON;;;;;N;;;;;
+1F627;ANGUISHED FACE;So;0;ON;;;;;N;;;;;
1F628;FEARFUL FACE;So;0;ON;;;;;N;;;;;
1F629;WEARY FACE;So;0;ON;;;;;N;;;;;
1F62A;SLEEPY FACE;So;0;ON;;;;;N;;;;;
1F62B;TIRED FACE;So;0;ON;;;;;N;;;;;
+1F62C;GRIMACING FACE;So;0;ON;;;;;N;;;;;
1F62D;LOUDLY CRYING FACE;So;0;ON;;;;;N;;;;;
+1F62E;FACE WITH OPEN MOUTH;So;0;ON;;;;;N;;;;;
+1F62F;HUSHED FACE;So;0;ON;;;;;N;;;;;
1F630;FACE WITH OPEN MOUTH AND COLD SWEAT;So;0;ON;;;;;N;;;;;
1F631;FACE SCREAMING IN FEAR;So;0;ON;;;;;N;;;;;
1F632;ASTONISHED FACE;So;0;ON;;;;;N;;;;;
1F633;FLUSHED FACE;So;0;ON;;;;;N;;;;;
+1F634;SLEEPING FACE;So;0;ON;;;;;N;;;;;
1F635;DIZZY FACE;So;0;ON;;;;;N;;;;;
1F636;FACE WITHOUT MOUTH;So;0;ON;;;;;N;;;;;
1F637;FACE WITH MEDICAL MASK;So;0;ON;;;;;N;;;;;
Property changes on: trunk/contrib/perl/lib/unicore/UnicodeData.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/auxiliary/GCBTest.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/auxiliary/GCBTest.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/auxiliary/GCBTest.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,8 +1,8 @@
-# GraphemeBreakTest-6.0.0.txt
-# Date: 2010-05-18, 00:49:27 GMT [MD]
+# GraphemeBreakTest-6.2.0.txt
+# Date: 2012-08-22, 12:41:15 GMT [MD]
#
# Unicode Character Database
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
# For documentation, see http://www.unicode.org/reports/tr44/
#
@@ -15,7 +15,7 @@
# × wherever there is not.
# <comment> the format can change, but currently it shows:
# - the sample character name
-# - (x) the Grapheme_Break property* for the sample character
+# - (x) the Grapheme_Cluster_Break property value for the sample character
# - [x] the rule that determines whether there is a break or not
#
# These samples may be extended or changed in the future.
@@ -30,8 +30,6 @@
÷ 0020 × 0308 ÷ 0001 ÷ # ÷ [0.2] SPACE (Other) × [9.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <START OF HEADING> (Control) ÷ [0.3]
÷ 0020 × 0300 ÷ # ÷ [0.2] SPACE (Other) × [9.0] COMBINING GRAVE ACCENT (Extend) ÷ [0.3]
÷ 0020 × 0308 × 0300 ÷ # ÷ [0.2] SPACE (Other) × [9.0] COMBINING DIAERESIS (Extend) × [9.0] COMBINING GRAVE ACCENT (Extend) ÷ [0.3]
-÷ 0020 ÷ 0E40 ÷ # ÷ [0.2] SPACE (Other) ÷ [999.0] THAI CHARACTER SARA E (Prepend) ÷ [0.3]
-÷ 0020 × 0308 ÷ 0E40 ÷ # ÷ [0.2] SPACE (Other) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] THAI CHARACTER SARA E (Prepend) ÷ [0.3]
÷ 0020 × 0903 ÷ # ÷ [0.2] SPACE (Other) × [9.1] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [0.3]
÷ 0020 × 0308 × 0903 ÷ # ÷ [0.2] SPACE (Other) × [9.0] COMBINING DIAERESIS (Extend) × [9.1] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [0.3]
÷ 0020 ÷ 1100 ÷ # ÷ [0.2] SPACE (Other) ÷ [999.0] HANGUL CHOSEONG KIYEOK (L) ÷ [0.3]
@@ -44,6 +42,12 @@
÷ 0020 × 0308 ÷ AC00 ÷ # ÷ [0.2] SPACE (Other) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL SYLLABLE GA (LV) ÷ [0.3]
÷ 0020 ÷ AC01 ÷ # ÷ [0.2] SPACE (Other) ÷ [999.0] HANGUL SYLLABLE GAG (LVT) ÷ [0.3]
÷ 0020 × 0308 ÷ AC01 ÷ # ÷ [0.2] SPACE (Other) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL SYLLABLE GAG (LVT) ÷ [0.3]
+÷ 0020 ÷ 1F1E6 ÷ # ÷ [0.2] SPACE (Other) ÷ [999.0] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) ÷ [0.3]
+÷ 0020 × 0308 ÷ 1F1E6 ÷ # ÷ [0.2] SPACE (Other) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) ÷ [0.3]
+÷ 0020 ÷ 0378 ÷ # ÷ [0.2] SPACE (Other) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3]
+÷ 0020 × 0308 ÷ 0378 ÷ # ÷ [0.2] SPACE (Other) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3]
+÷ 0020 ÷ D800 ÷ # ÷ [0.2] SPACE (Other) ÷ [5.0] <surrogate-D800> (Control) ÷ [0.3]
+÷ 0020 × 0308 ÷ D800 ÷ # ÷ [0.2] SPACE (Other) × [9.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <surrogate-D800> (Control) ÷ [0.3]
÷ 000D ÷ 0020 ÷ # ÷ [0.2] <CARRIAGE RETURN (CR)> (CR) ÷ [4.0] SPACE (Other) ÷ [0.3]
÷ 000D ÷ 0308 ÷ 0020 ÷ # ÷ [0.2] <CARRIAGE RETURN (CR)> (CR) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] SPACE (Other) ÷ [0.3]
÷ 000D ÷ 000D ÷ # ÷ [0.2] <CARRIAGE RETURN (CR)> (CR) ÷ [4.0] <CARRIAGE RETURN (CR)> (CR) ÷ [0.3]
@@ -54,8 +58,6 @@
÷ 000D ÷ 0308 ÷ 0001 ÷ # ÷ [0.2] <CARRIAGE RETURN (CR)> (CR) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <START OF HEADING> (Control) ÷ [0.3]
÷ 000D ÷ 0300 ÷ # ÷ [0.2] <CARRIAGE RETURN (CR)> (CR) ÷ [4.0] COMBINING GRAVE ACCENT (Extend) ÷ [0.3]
÷ 000D ÷ 0308 × 0300 ÷ # ÷ [0.2] <CARRIAGE RETURN (CR)> (CR) ÷ [4.0] COMBINING DIAERESIS (Extend) × [9.0] COMBINING GRAVE ACCENT (Extend) ÷ [0.3]
-÷ 000D ÷ 0E40 ÷ # ÷ [0.2] <CARRIAGE RETURN (CR)> (CR) ÷ [4.0] THAI CHARACTER SARA E (Prepend) ÷ [0.3]
-÷ 000D ÷ 0308 ÷ 0E40 ÷ # ÷ [0.2] <CARRIAGE RETURN (CR)> (CR) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] THAI CHARACTER SARA E (Prepend) ÷ [0.3]
÷ 000D ÷ 0903 ÷ # ÷ [0.2] <CARRIAGE RETURN (CR)> (CR) ÷ [4.0] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [0.3]
÷ 000D ÷ 0308 × 0903 ÷ # ÷ [0.2] <CARRIAGE RETURN (CR)> (CR) ÷ [4.0] COMBINING DIAERESIS (Extend) × [9.1] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [0.3]
÷ 000D ÷ 1100 ÷ # ÷ [0.2] <CARRIAGE RETURN (CR)> (CR) ÷ [4.0] HANGUL CHOSEONG KIYEOK (L) ÷ [0.3]
@@ -68,6 +70,12 @@
÷ 000D ÷ 0308 ÷ AC00 ÷ # ÷ [0.2] <CARRIAGE RETURN (CR)> (CR) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL SYLLABLE GA (LV) ÷ [0.3]
÷ 000D ÷ AC01 ÷ # ÷ [0.2] <CARRIAGE RETURN (CR)> (CR) ÷ [4.0] HANGUL SYLLABLE GAG (LVT) ÷ [0.3]
÷ 000D ÷ 0308 ÷ AC01 ÷ # ÷ [0.2] <CARRIAGE RETURN (CR)> (CR) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL SYLLABLE GAG (LVT) ÷ [0.3]
+÷ 000D ÷ 1F1E6 ÷ # ÷ [0.2] <CARRIAGE RETURN (CR)> (CR) ÷ [4.0] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) ÷ [0.3]
+÷ 000D ÷ 0308 ÷ 1F1E6 ÷ # ÷ [0.2] <CARRIAGE RETURN (CR)> (CR) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) ÷ [0.3]
+÷ 000D ÷ 0378 ÷ # ÷ [0.2] <CARRIAGE RETURN (CR)> (CR) ÷ [4.0] <reserved-0378> (Other) ÷ [0.3]
+÷ 000D ÷ 0308 ÷ 0378 ÷ # ÷ [0.2] <CARRIAGE RETURN (CR)> (CR) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3]
+÷ 000D ÷ D800 ÷ # ÷ [0.2] <CARRIAGE RETURN (CR)> (CR) ÷ [4.0] <surrogate-D800> (Control) ÷ [0.3]
+÷ 000D ÷ 0308 ÷ D800 ÷ # ÷ [0.2] <CARRIAGE RETURN (CR)> (CR) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <surrogate-D800> (Control) ÷ [0.3]
÷ 000A ÷ 0020 ÷ # ÷ [0.2] <LINE FEED (LF)> (LF) ÷ [4.0] SPACE (Other) ÷ [0.3]
÷ 000A ÷ 0308 ÷ 0020 ÷ # ÷ [0.2] <LINE FEED (LF)> (LF) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] SPACE (Other) ÷ [0.3]
÷ 000A ÷ 000D ÷ # ÷ [0.2] <LINE FEED (LF)> (LF) ÷ [4.0] <CARRIAGE RETURN (CR)> (CR) ÷ [0.3]
@@ -78,8 +86,6 @@
÷ 000A ÷ 0308 ÷ 0001 ÷ # ÷ [0.2] <LINE FEED (LF)> (LF) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <START OF HEADING> (Control) ÷ [0.3]
÷ 000A ÷ 0300 ÷ # ÷ [0.2] <LINE FEED (LF)> (LF) ÷ [4.0] COMBINING GRAVE ACCENT (Extend) ÷ [0.3]
÷ 000A ÷ 0308 × 0300 ÷ # ÷ [0.2] <LINE FEED (LF)> (LF) ÷ [4.0] COMBINING DIAERESIS (Extend) × [9.0] COMBINING GRAVE ACCENT (Extend) ÷ [0.3]
-÷ 000A ÷ 0E40 ÷ # ÷ [0.2] <LINE FEED (LF)> (LF) ÷ [4.0] THAI CHARACTER SARA E (Prepend) ÷ [0.3]
-÷ 000A ÷ 0308 ÷ 0E40 ÷ # ÷ [0.2] <LINE FEED (LF)> (LF) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] THAI CHARACTER SARA E (Prepend) ÷ [0.3]
÷ 000A ÷ 0903 ÷ # ÷ [0.2] <LINE FEED (LF)> (LF) ÷ [4.0] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [0.3]
÷ 000A ÷ 0308 × 0903 ÷ # ÷ [0.2] <LINE FEED (LF)> (LF) ÷ [4.0] COMBINING DIAERESIS (Extend) × [9.1] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [0.3]
÷ 000A ÷ 1100 ÷ # ÷ [0.2] <LINE FEED (LF)> (LF) ÷ [4.0] HANGUL CHOSEONG KIYEOK (L) ÷ [0.3]
@@ -92,6 +98,12 @@
÷ 000A ÷ 0308 ÷ AC00 ÷ # ÷ [0.2] <LINE FEED (LF)> (LF) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL SYLLABLE GA (LV) ÷ [0.3]
÷ 000A ÷ AC01 ÷ # ÷ [0.2] <LINE FEED (LF)> (LF) ÷ [4.0] HANGUL SYLLABLE GAG (LVT) ÷ [0.3]
÷ 000A ÷ 0308 ÷ AC01 ÷ # ÷ [0.2] <LINE FEED (LF)> (LF) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL SYLLABLE GAG (LVT) ÷ [0.3]
+÷ 000A ÷ 1F1E6 ÷ # ÷ [0.2] <LINE FEED (LF)> (LF) ÷ [4.0] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) ÷ [0.3]
+÷ 000A ÷ 0308 ÷ 1F1E6 ÷ # ÷ [0.2] <LINE FEED (LF)> (LF) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) ÷ [0.3]
+÷ 000A ÷ 0378 ÷ # ÷ [0.2] <LINE FEED (LF)> (LF) ÷ [4.0] <reserved-0378> (Other) ÷ [0.3]
+÷ 000A ÷ 0308 ÷ 0378 ÷ # ÷ [0.2] <LINE FEED (LF)> (LF) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3]
+÷ 000A ÷ D800 ÷ # ÷ [0.2] <LINE FEED (LF)> (LF) ÷ [4.0] <surrogate-D800> (Control) ÷ [0.3]
+÷ 000A ÷ 0308 ÷ D800 ÷ # ÷ [0.2] <LINE FEED (LF)> (LF) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <surrogate-D800> (Control) ÷ [0.3]
÷ 0001 ÷ 0020 ÷ # ÷ [0.2] <START OF HEADING> (Control) ÷ [4.0] SPACE (Other) ÷ [0.3]
÷ 0001 ÷ 0308 ÷ 0020 ÷ # ÷ [0.2] <START OF HEADING> (Control) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] SPACE (Other) ÷ [0.3]
÷ 0001 ÷ 000D ÷ # ÷ [0.2] <START OF HEADING> (Control) ÷ [4.0] <CARRIAGE RETURN (CR)> (CR) ÷ [0.3]
@@ -102,8 +114,6 @@
÷ 0001 ÷ 0308 ÷ 0001 ÷ # ÷ [0.2] <START OF HEADING> (Control) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <START OF HEADING> (Control) ÷ [0.3]
÷ 0001 ÷ 0300 ÷ # ÷ [0.2] <START OF HEADING> (Control) ÷ [4.0] COMBINING GRAVE ACCENT (Extend) ÷ [0.3]
÷ 0001 ÷ 0308 × 0300 ÷ # ÷ [0.2] <START OF HEADING> (Control) ÷ [4.0] COMBINING DIAERESIS (Extend) × [9.0] COMBINING GRAVE ACCENT (Extend) ÷ [0.3]
-÷ 0001 ÷ 0E40 ÷ # ÷ [0.2] <START OF HEADING> (Control) ÷ [4.0] THAI CHARACTER SARA E (Prepend) ÷ [0.3]
-÷ 0001 ÷ 0308 ÷ 0E40 ÷ # ÷ [0.2] <START OF HEADING> (Control) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] THAI CHARACTER SARA E (Prepend) ÷ [0.3]
÷ 0001 ÷ 0903 ÷ # ÷ [0.2] <START OF HEADING> (Control) ÷ [4.0] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [0.3]
÷ 0001 ÷ 0308 × 0903 ÷ # ÷ [0.2] <START OF HEADING> (Control) ÷ [4.0] COMBINING DIAERESIS (Extend) × [9.1] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [0.3]
÷ 0001 ÷ 1100 ÷ # ÷ [0.2] <START OF HEADING> (Control) ÷ [4.0] HANGUL CHOSEONG KIYEOK (L) ÷ [0.3]
@@ -116,6 +126,12 @@
÷ 0001 ÷ 0308 ÷ AC00 ÷ # ÷ [0.2] <START OF HEADING> (Control) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL SYLLABLE GA (LV) ÷ [0.3]
÷ 0001 ÷ AC01 ÷ # ÷ [0.2] <START OF HEADING> (Control) ÷ [4.0] HANGUL SYLLABLE GAG (LVT) ÷ [0.3]
÷ 0001 ÷ 0308 ÷ AC01 ÷ # ÷ [0.2] <START OF HEADING> (Control) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL SYLLABLE GAG (LVT) ÷ [0.3]
+÷ 0001 ÷ 1F1E6 ÷ # ÷ [0.2] <START OF HEADING> (Control) ÷ [4.0] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) ÷ [0.3]
+÷ 0001 ÷ 0308 ÷ 1F1E6 ÷ # ÷ [0.2] <START OF HEADING> (Control) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) ÷ [0.3]
+÷ 0001 ÷ 0378 ÷ # ÷ [0.2] <START OF HEADING> (Control) ÷ [4.0] <reserved-0378> (Other) ÷ [0.3]
+÷ 0001 ÷ 0308 ÷ 0378 ÷ # ÷ [0.2] <START OF HEADING> (Control) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3]
+÷ 0001 ÷ D800 ÷ # ÷ [0.2] <START OF HEADING> (Control) ÷ [4.0] <surrogate-D800> (Control) ÷ [0.3]
+÷ 0001 ÷ 0308 ÷ D800 ÷ # ÷ [0.2] <START OF HEADING> (Control) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <surrogate-D800> (Control) ÷ [0.3]
÷ 0300 ÷ 0020 ÷ # ÷ [0.2] COMBINING GRAVE ACCENT (Extend) ÷ [999.0] SPACE (Other) ÷ [0.3]
÷ 0300 × 0308 ÷ 0020 ÷ # ÷ [0.2] COMBINING GRAVE ACCENT (Extend) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] SPACE (Other) ÷ [0.3]
÷ 0300 ÷ 000D ÷ # ÷ [0.2] COMBINING GRAVE ACCENT (Extend) ÷ [5.0] <CARRIAGE RETURN (CR)> (CR) ÷ [0.3]
@@ -126,8 +142,6 @@
÷ 0300 × 0308 ÷ 0001 ÷ # ÷ [0.2] COMBINING GRAVE ACCENT (Extend) × [9.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <START OF HEADING> (Control) ÷ [0.3]
÷ 0300 × 0300 ÷ # ÷ [0.2] COMBINING GRAVE ACCENT (Extend) × [9.0] COMBINING GRAVE ACCENT (Extend) ÷ [0.3]
÷ 0300 × 0308 × 0300 ÷ # ÷ [0.2] COMBINING GRAVE ACCENT (Extend) × [9.0] COMBINING DIAERESIS (Extend) × [9.0] COMBINING GRAVE ACCENT (Extend) ÷ [0.3]
-÷ 0300 ÷ 0E40 ÷ # ÷ [0.2] COMBINING GRAVE ACCENT (Extend) ÷ [999.0] THAI CHARACTER SARA E (Prepend) ÷ [0.3]
-÷ 0300 × 0308 ÷ 0E40 ÷ # ÷ [0.2] COMBINING GRAVE ACCENT (Extend) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] THAI CHARACTER SARA E (Prepend) ÷ [0.3]
÷ 0300 × 0903 ÷ # ÷ [0.2] COMBINING GRAVE ACCENT (Extend) × [9.1] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [0.3]
÷ 0300 × 0308 × 0903 ÷ # ÷ [0.2] COMBINING GRAVE ACCENT (Extend) × [9.0] COMBINING DIAERESIS (Extend) × [9.1] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [0.3]
÷ 0300 ÷ 1100 ÷ # ÷ [0.2] COMBINING GRAVE ACCENT (Extend) ÷ [999.0] HANGUL CHOSEONG KIYEOK (L) ÷ [0.3]
@@ -140,30 +154,12 @@
÷ 0300 × 0308 ÷ AC00 ÷ # ÷ [0.2] COMBINING GRAVE ACCENT (Extend) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL SYLLABLE GA (LV) ÷ [0.3]
÷ 0300 ÷ AC01 ÷ # ÷ [0.2] COMBINING GRAVE ACCENT (Extend) ÷ [999.0] HANGUL SYLLABLE GAG (LVT) ÷ [0.3]
÷ 0300 × 0308 ÷ AC01 ÷ # ÷ [0.2] COMBINING GRAVE ACCENT (Extend) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL SYLLABLE GAG (LVT) ÷ [0.3]
-÷ 0E40 × 0020 ÷ # ÷ [0.2] THAI CHARACTER SARA E (Prepend) × [9.2] SPACE (Other) ÷ [0.3]
-÷ 0E40 × 0308 ÷ 0020 ÷ # ÷ [0.2] THAI CHARACTER SARA E (Prepend) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] SPACE (Other) ÷ [0.3]
-÷ 0E40 ÷ 000D ÷ # ÷ [0.2] THAI CHARACTER SARA E (Prepend) ÷ [5.0] <CARRIAGE RETURN (CR)> (CR) ÷ [0.3]
-÷ 0E40 × 0308 ÷ 000D ÷ # ÷ [0.2] THAI CHARACTER SARA E (Prepend) × [9.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <CARRIAGE RETURN (CR)> (CR) ÷ [0.3]
-÷ 0E40 ÷ 000A ÷ # ÷ [0.2] THAI CHARACTER SARA E (Prepend) ÷ [5.0] <LINE FEED (LF)> (LF) ÷ [0.3]
-÷ 0E40 × 0308 ÷ 000A ÷ # ÷ [0.2] THAI CHARACTER SARA E (Prepend) × [9.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <LINE FEED (LF)> (LF) ÷ [0.3]
-÷ 0E40 ÷ 0001 ÷ # ÷ [0.2] THAI CHARACTER SARA E (Prepend) ÷ [5.0] <START OF HEADING> (Control) ÷ [0.3]
-÷ 0E40 × 0308 ÷ 0001 ÷ # ÷ [0.2] THAI CHARACTER SARA E (Prepend) × [9.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <START OF HEADING> (Control) ÷ [0.3]
-÷ 0E40 × 0300 ÷ # ÷ [0.2] THAI CHARACTER SARA E (Prepend) × [9.0] COMBINING GRAVE ACCENT (Extend) ÷ [0.3]
-÷ 0E40 × 0308 × 0300 ÷ # ÷ [0.2] THAI CHARACTER SARA E (Prepend) × [9.0] COMBINING DIAERESIS (Extend) × [9.0] COMBINING GRAVE ACCENT (Extend) ÷ [0.3]
-÷ 0E40 × 0E40 ÷ # ÷ [0.2] THAI CHARACTER SARA E (Prepend) × [9.2] THAI CHARACTER SARA E (Prepend) ÷ [0.3]
-÷ 0E40 × 0308 ÷ 0E40 ÷ # ÷ [0.2] THAI CHARACTER SARA E (Prepend) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] THAI CHARACTER SARA E (Prepend) ÷ [0.3]
-÷ 0E40 × 0903 ÷ # ÷ [0.2] THAI CHARACTER SARA E (Prepend) × [9.1] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [0.3]
-÷ 0E40 × 0308 × 0903 ÷ # ÷ [0.2] THAI CHARACTER SARA E (Prepend) × [9.0] COMBINING DIAERESIS (Extend) × [9.1] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [0.3]
-÷ 0E40 × 1100 ÷ # ÷ [0.2] THAI CHARACTER SARA E (Prepend) × [9.2] HANGUL CHOSEONG KIYEOK (L) ÷ [0.3]
-÷ 0E40 × 0308 ÷ 1100 ÷ # ÷ [0.2] THAI CHARACTER SARA E (Prepend) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL CHOSEONG KIYEOK (L) ÷ [0.3]
-÷ 0E40 × 1160 ÷ # ÷ [0.2] THAI CHARACTER SARA E (Prepend) × [9.2] HANGUL JUNGSEONG FILLER (V) ÷ [0.3]
-÷ 0E40 × 0308 ÷ 1160 ÷ # ÷ [0.2] THAI CHARACTER SARA E (Prepend) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL JUNGSEONG FILLER (V) ÷ [0.3]
-÷ 0E40 × 11A8 ÷ # ÷ [0.2] THAI CHARACTER SARA E (Prepend) × [9.2] HANGUL JONGSEONG KIYEOK (T) ÷ [0.3]
-÷ 0E40 × 0308 ÷ 11A8 ÷ # ÷ [0.2] THAI CHARACTER SARA E (Prepend) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL JONGSEONG KIYEOK (T) ÷ [0.3]
-÷ 0E40 × AC00 ÷ # ÷ [0.2] THAI CHARACTER SARA E (Prepend) × [9.2] HANGUL SYLLABLE GA (LV) ÷ [0.3]
-÷ 0E40 × 0308 ÷ AC00 ÷ # ÷ [0.2] THAI CHARACTER SARA E (Prepend) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL SYLLABLE GA (LV) ÷ [0.3]
-÷ 0E40 × AC01 ÷ # ÷ [0.2] THAI CHARACTER SARA E (Prepend) × [9.2] HANGUL SYLLABLE GAG (LVT) ÷ [0.3]
-÷ 0E40 × 0308 ÷ AC01 ÷ # ÷ [0.2] THAI CHARACTER SARA E (Prepend) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL SYLLABLE GAG (LVT) ÷ [0.3]
+÷ 0300 ÷ 1F1E6 ÷ # ÷ [0.2] COMBINING GRAVE ACCENT (Extend) ÷ [999.0] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) ÷ [0.3]
+÷ 0300 × 0308 ÷ 1F1E6 ÷ # ÷ [0.2] COMBINING GRAVE ACCENT (Extend) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) ÷ [0.3]
+÷ 0300 ÷ 0378 ÷ # ÷ [0.2] COMBINING GRAVE ACCENT (Extend) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3]
+÷ 0300 × 0308 ÷ 0378 ÷ # ÷ [0.2] COMBINING GRAVE ACCENT (Extend) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3]
+÷ 0300 ÷ D800 ÷ # ÷ [0.2] COMBINING GRAVE ACCENT (Extend) ÷ [5.0] <surrogate-D800> (Control) ÷ [0.3]
+÷ 0300 × 0308 ÷ D800 ÷ # ÷ [0.2] COMBINING GRAVE ACCENT (Extend) × [9.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <surrogate-D800> (Control) ÷ [0.3]
÷ 0903 ÷ 0020 ÷ # ÷ [0.2] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [999.0] SPACE (Other) ÷ [0.3]
÷ 0903 × 0308 ÷ 0020 ÷ # ÷ [0.2] DEVANAGARI SIGN VISARGA (SpacingMark) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] SPACE (Other) ÷ [0.3]
÷ 0903 ÷ 000D ÷ # ÷ [0.2] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [5.0] <CARRIAGE RETURN (CR)> (CR) ÷ [0.3]
@@ -174,8 +170,6 @@
÷ 0903 × 0308 ÷ 0001 ÷ # ÷ [0.2] DEVANAGARI SIGN VISARGA (SpacingMark) × [9.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <START OF HEADING> (Control) ÷ [0.3]
÷ 0903 × 0300 ÷ # ÷ [0.2] DEVANAGARI SIGN VISARGA (SpacingMark) × [9.0] COMBINING GRAVE ACCENT (Extend) ÷ [0.3]
÷ 0903 × 0308 × 0300 ÷ # ÷ [0.2] DEVANAGARI SIGN VISARGA (SpacingMark) × [9.0] COMBINING DIAERESIS (Extend) × [9.0] COMBINING GRAVE ACCENT (Extend) ÷ [0.3]
-÷ 0903 ÷ 0E40 ÷ # ÷ [0.2] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [999.0] THAI CHARACTER SARA E (Prepend) ÷ [0.3]
-÷ 0903 × 0308 ÷ 0E40 ÷ # ÷ [0.2] DEVANAGARI SIGN VISARGA (SpacingMark) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] THAI CHARACTER SARA E (Prepend) ÷ [0.3]
÷ 0903 × 0903 ÷ # ÷ [0.2] DEVANAGARI SIGN VISARGA (SpacingMark) × [9.1] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [0.3]
÷ 0903 × 0308 × 0903 ÷ # ÷ [0.2] DEVANAGARI SIGN VISARGA (SpacingMark) × [9.0] COMBINING DIAERESIS (Extend) × [9.1] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [0.3]
÷ 0903 ÷ 1100 ÷ # ÷ [0.2] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [999.0] HANGUL CHOSEONG KIYEOK (L) ÷ [0.3]
@@ -188,6 +182,12 @@
÷ 0903 × 0308 ÷ AC00 ÷ # ÷ [0.2] DEVANAGARI SIGN VISARGA (SpacingMark) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL SYLLABLE GA (LV) ÷ [0.3]
÷ 0903 ÷ AC01 ÷ # ÷ [0.2] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [999.0] HANGUL SYLLABLE GAG (LVT) ÷ [0.3]
÷ 0903 × 0308 ÷ AC01 ÷ # ÷ [0.2] DEVANAGARI SIGN VISARGA (SpacingMark) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL SYLLABLE GAG (LVT) ÷ [0.3]
+÷ 0903 ÷ 1F1E6 ÷ # ÷ [0.2] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [999.0] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) ÷ [0.3]
+÷ 0903 × 0308 ÷ 1F1E6 ÷ # ÷ [0.2] DEVANAGARI SIGN VISARGA (SpacingMark) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) ÷ [0.3]
+÷ 0903 ÷ 0378 ÷ # ÷ [0.2] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3]
+÷ 0903 × 0308 ÷ 0378 ÷ # ÷ [0.2] DEVANAGARI SIGN VISARGA (SpacingMark) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3]
+÷ 0903 ÷ D800 ÷ # ÷ [0.2] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [5.0] <surrogate-D800> (Control) ÷ [0.3]
+÷ 0903 × 0308 ÷ D800 ÷ # ÷ [0.2] DEVANAGARI SIGN VISARGA (SpacingMark) × [9.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <surrogate-D800> (Control) ÷ [0.3]
÷ 1100 ÷ 0020 ÷ # ÷ [0.2] HANGUL CHOSEONG KIYEOK (L) ÷ [999.0] SPACE (Other) ÷ [0.3]
÷ 1100 × 0308 ÷ 0020 ÷ # ÷ [0.2] HANGUL CHOSEONG KIYEOK (L) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] SPACE (Other) ÷ [0.3]
÷ 1100 ÷ 000D ÷ # ÷ [0.2] HANGUL CHOSEONG KIYEOK (L) ÷ [5.0] <CARRIAGE RETURN (CR)> (CR) ÷ [0.3]
@@ -198,8 +198,6 @@
÷ 1100 × 0308 ÷ 0001 ÷ # ÷ [0.2] HANGUL CHOSEONG KIYEOK (L) × [9.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <START OF HEADING> (Control) ÷ [0.3]
÷ 1100 × 0300 ÷ # ÷ [0.2] HANGUL CHOSEONG KIYEOK (L) × [9.0] COMBINING GRAVE ACCENT (Extend) ÷ [0.3]
÷ 1100 × 0308 × 0300 ÷ # ÷ [0.2] HANGUL CHOSEONG KIYEOK (L) × [9.0] COMBINING DIAERESIS (Extend) × [9.0] COMBINING GRAVE ACCENT (Extend) ÷ [0.3]
-÷ 1100 ÷ 0E40 ÷ # ÷ [0.2] HANGUL CHOSEONG KIYEOK (L) ÷ [999.0] THAI CHARACTER SARA E (Prepend) ÷ [0.3]
-÷ 1100 × 0308 ÷ 0E40 ÷ # ÷ [0.2] HANGUL CHOSEONG KIYEOK (L) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] THAI CHARACTER SARA E (Prepend) ÷ [0.3]
÷ 1100 × 0903 ÷ # ÷ [0.2] HANGUL CHOSEONG KIYEOK (L) × [9.1] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [0.3]
÷ 1100 × 0308 × 0903 ÷ # ÷ [0.2] HANGUL CHOSEONG KIYEOK (L) × [9.0] COMBINING DIAERESIS (Extend) × [9.1] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [0.3]
÷ 1100 × 1100 ÷ # ÷ [0.2] HANGUL CHOSEONG KIYEOK (L) × [6.0] HANGUL CHOSEONG KIYEOK (L) ÷ [0.3]
@@ -212,6 +210,12 @@
÷ 1100 × 0308 ÷ AC00 ÷ # ÷ [0.2] HANGUL CHOSEONG KIYEOK (L) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL SYLLABLE GA (LV) ÷ [0.3]
÷ 1100 × AC01 ÷ # ÷ [0.2] HANGUL CHOSEONG KIYEOK (L) × [6.0] HANGUL SYLLABLE GAG (LVT) ÷ [0.3]
÷ 1100 × 0308 ÷ AC01 ÷ # ÷ [0.2] HANGUL CHOSEONG KIYEOK (L) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL SYLLABLE GAG (LVT) ÷ [0.3]
+÷ 1100 ÷ 1F1E6 ÷ # ÷ [0.2] HANGUL CHOSEONG KIYEOK (L) ÷ [999.0] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) ÷ [0.3]
+÷ 1100 × 0308 ÷ 1F1E6 ÷ # ÷ [0.2] HANGUL CHOSEONG KIYEOK (L) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) ÷ [0.3]
+÷ 1100 ÷ 0378 ÷ # ÷ [0.2] HANGUL CHOSEONG KIYEOK (L) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3]
+÷ 1100 × 0308 ÷ 0378 ÷ # ÷ [0.2] HANGUL CHOSEONG KIYEOK (L) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3]
+÷ 1100 ÷ D800 ÷ # ÷ [0.2] HANGUL CHOSEONG KIYEOK (L) ÷ [5.0] <surrogate-D800> (Control) ÷ [0.3]
+÷ 1100 × 0308 ÷ D800 ÷ # ÷ [0.2] HANGUL CHOSEONG KIYEOK (L) × [9.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <surrogate-D800> (Control) ÷ [0.3]
÷ 1160 ÷ 0020 ÷ # ÷ [0.2] HANGUL JUNGSEONG FILLER (V) ÷ [999.0] SPACE (Other) ÷ [0.3]
÷ 1160 × 0308 ÷ 0020 ÷ # ÷ [0.2] HANGUL JUNGSEONG FILLER (V) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] SPACE (Other) ÷ [0.3]
÷ 1160 ÷ 000D ÷ # ÷ [0.2] HANGUL JUNGSEONG FILLER (V) ÷ [5.0] <CARRIAGE RETURN (CR)> (CR) ÷ [0.3]
@@ -222,8 +226,6 @@
÷ 1160 × 0308 ÷ 0001 ÷ # ÷ [0.2] HANGUL JUNGSEONG FILLER (V) × [9.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <START OF HEADING> (Control) ÷ [0.3]
÷ 1160 × 0300 ÷ # ÷ [0.2] HANGUL JUNGSEONG FILLER (V) × [9.0] COMBINING GRAVE ACCENT (Extend) ÷ [0.3]
÷ 1160 × 0308 × 0300 ÷ # ÷ [0.2] HANGUL JUNGSEONG FILLER (V) × [9.0] COMBINING DIAERESIS (Extend) × [9.0] COMBINING GRAVE ACCENT (Extend) ÷ [0.3]
-÷ 1160 ÷ 0E40 ÷ # ÷ [0.2] HANGUL JUNGSEONG FILLER (V) ÷ [999.0] THAI CHARACTER SARA E (Prepend) ÷ [0.3]
-÷ 1160 × 0308 ÷ 0E40 ÷ # ÷ [0.2] HANGUL JUNGSEONG FILLER (V) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] THAI CHARACTER SARA E (Prepend) ÷ [0.3]
÷ 1160 × 0903 ÷ # ÷ [0.2] HANGUL JUNGSEONG FILLER (V) × [9.1] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [0.3]
÷ 1160 × 0308 × 0903 ÷ # ÷ [0.2] HANGUL JUNGSEONG FILLER (V) × [9.0] COMBINING DIAERESIS (Extend) × [9.1] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [0.3]
÷ 1160 ÷ 1100 ÷ # ÷ [0.2] HANGUL JUNGSEONG FILLER (V) ÷ [999.0] HANGUL CHOSEONG KIYEOK (L) ÷ [0.3]
@@ -236,6 +238,12 @@
÷ 1160 × 0308 ÷ AC00 ÷ # ÷ [0.2] HANGUL JUNGSEONG FILLER (V) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL SYLLABLE GA (LV) ÷ [0.3]
÷ 1160 ÷ AC01 ÷ # ÷ [0.2] HANGUL JUNGSEONG FILLER (V) ÷ [999.0] HANGUL SYLLABLE GAG (LVT) ÷ [0.3]
÷ 1160 × 0308 ÷ AC01 ÷ # ÷ [0.2] HANGUL JUNGSEONG FILLER (V) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL SYLLABLE GAG (LVT) ÷ [0.3]
+÷ 1160 ÷ 1F1E6 ÷ # ÷ [0.2] HANGUL JUNGSEONG FILLER (V) ÷ [999.0] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) ÷ [0.3]
+÷ 1160 × 0308 ÷ 1F1E6 ÷ # ÷ [0.2] HANGUL JUNGSEONG FILLER (V) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) ÷ [0.3]
+÷ 1160 ÷ 0378 ÷ # ÷ [0.2] HANGUL JUNGSEONG FILLER (V) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3]
+÷ 1160 × 0308 ÷ 0378 ÷ # ÷ [0.2] HANGUL JUNGSEONG FILLER (V) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3]
+÷ 1160 ÷ D800 ÷ # ÷ [0.2] HANGUL JUNGSEONG FILLER (V) ÷ [5.0] <surrogate-D800> (Control) ÷ [0.3]
+÷ 1160 × 0308 ÷ D800 ÷ # ÷ [0.2] HANGUL JUNGSEONG FILLER (V) × [9.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <surrogate-D800> (Control) ÷ [0.3]
÷ 11A8 ÷ 0020 ÷ # ÷ [0.2] HANGUL JONGSEONG KIYEOK (T) ÷ [999.0] SPACE (Other) ÷ [0.3]
÷ 11A8 × 0308 ÷ 0020 ÷ # ÷ [0.2] HANGUL JONGSEONG KIYEOK (T) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] SPACE (Other) ÷ [0.3]
÷ 11A8 ÷ 000D ÷ # ÷ [0.2] HANGUL JONGSEONG KIYEOK (T) ÷ [5.0] <CARRIAGE RETURN (CR)> (CR) ÷ [0.3]
@@ -246,8 +254,6 @@
÷ 11A8 × 0308 ÷ 0001 ÷ # ÷ [0.2] HANGUL JONGSEONG KIYEOK (T) × [9.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <START OF HEADING> (Control) ÷ [0.3]
÷ 11A8 × 0300 ÷ # ÷ [0.2] HANGUL JONGSEONG KIYEOK (T) × [9.0] COMBINING GRAVE ACCENT (Extend) ÷ [0.3]
÷ 11A8 × 0308 × 0300 ÷ # ÷ [0.2] HANGUL JONGSEONG KIYEOK (T) × [9.0] COMBINING DIAERESIS (Extend) × [9.0] COMBINING GRAVE ACCENT (Extend) ÷ [0.3]
-÷ 11A8 ÷ 0E40 ÷ # ÷ [0.2] HANGUL JONGSEONG KIYEOK (T) ÷ [999.0] THAI CHARACTER SARA E (Prepend) ÷ [0.3]
-÷ 11A8 × 0308 ÷ 0E40 ÷ # ÷ [0.2] HANGUL JONGSEONG KIYEOK (T) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] THAI CHARACTER SARA E (Prepend) ÷ [0.3]
÷ 11A8 × 0903 ÷ # ÷ [0.2] HANGUL JONGSEONG KIYEOK (T) × [9.1] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [0.3]
÷ 11A8 × 0308 × 0903 ÷ # ÷ [0.2] HANGUL JONGSEONG KIYEOK (T) × [9.0] COMBINING DIAERESIS (Extend) × [9.1] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [0.3]
÷ 11A8 ÷ 1100 ÷ # ÷ [0.2] HANGUL JONGSEONG KIYEOK (T) ÷ [999.0] HANGUL CHOSEONG KIYEOK (L) ÷ [0.3]
@@ -260,6 +266,12 @@
÷ 11A8 × 0308 ÷ AC00 ÷ # ÷ [0.2] HANGUL JONGSEONG KIYEOK (T) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL SYLLABLE GA (LV) ÷ [0.3]
÷ 11A8 ÷ AC01 ÷ # ÷ [0.2] HANGUL JONGSEONG KIYEOK (T) ÷ [999.0] HANGUL SYLLABLE GAG (LVT) ÷ [0.3]
÷ 11A8 × 0308 ÷ AC01 ÷ # ÷ [0.2] HANGUL JONGSEONG KIYEOK (T) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL SYLLABLE GAG (LVT) ÷ [0.3]
+÷ 11A8 ÷ 1F1E6 ÷ # ÷ [0.2] HANGUL JONGSEONG KIYEOK (T) ÷ [999.0] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) ÷ [0.3]
+÷ 11A8 × 0308 ÷ 1F1E6 ÷ # ÷ [0.2] HANGUL JONGSEONG KIYEOK (T) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) ÷ [0.3]
+÷ 11A8 ÷ 0378 ÷ # ÷ [0.2] HANGUL JONGSEONG KIYEOK (T) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3]
+÷ 11A8 × 0308 ÷ 0378 ÷ # ÷ [0.2] HANGUL JONGSEONG KIYEOK (T) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3]
+÷ 11A8 ÷ D800 ÷ # ÷ [0.2] HANGUL JONGSEONG KIYEOK (T) ÷ [5.0] <surrogate-D800> (Control) ÷ [0.3]
+÷ 11A8 × 0308 ÷ D800 ÷ # ÷ [0.2] HANGUL JONGSEONG KIYEOK (T) × [9.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <surrogate-D800> (Control) ÷ [0.3]
÷ AC00 ÷ 0020 ÷ # ÷ [0.2] HANGUL SYLLABLE GA (LV) ÷ [999.0] SPACE (Other) ÷ [0.3]
÷ AC00 × 0308 ÷ 0020 ÷ # ÷ [0.2] HANGUL SYLLABLE GA (LV) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] SPACE (Other) ÷ [0.3]
÷ AC00 ÷ 000D ÷ # ÷ [0.2] HANGUL SYLLABLE GA (LV) ÷ [5.0] <CARRIAGE RETURN (CR)> (CR) ÷ [0.3]
@@ -270,8 +282,6 @@
÷ AC00 × 0308 ÷ 0001 ÷ # ÷ [0.2] HANGUL SYLLABLE GA (LV) × [9.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <START OF HEADING> (Control) ÷ [0.3]
÷ AC00 × 0300 ÷ # ÷ [0.2] HANGUL SYLLABLE GA (LV) × [9.0] COMBINING GRAVE ACCENT (Extend) ÷ [0.3]
÷ AC00 × 0308 × 0300 ÷ # ÷ [0.2] HANGUL SYLLABLE GA (LV) × [9.0] COMBINING DIAERESIS (Extend) × [9.0] COMBINING GRAVE ACCENT (Extend) ÷ [0.3]
-÷ AC00 ÷ 0E40 ÷ # ÷ [0.2] HANGUL SYLLABLE GA (LV) ÷ [999.0] THAI CHARACTER SARA E (Prepend) ÷ [0.3]
-÷ AC00 × 0308 ÷ 0E40 ÷ # ÷ [0.2] HANGUL SYLLABLE GA (LV) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] THAI CHARACTER SARA E (Prepend) ÷ [0.3]
÷ AC00 × 0903 ÷ # ÷ [0.2] HANGUL SYLLABLE GA (LV) × [9.1] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [0.3]
÷ AC00 × 0308 × 0903 ÷ # ÷ [0.2] HANGUL SYLLABLE GA (LV) × [9.0] COMBINING DIAERESIS (Extend) × [9.1] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [0.3]
÷ AC00 ÷ 1100 ÷ # ÷ [0.2] HANGUL SYLLABLE GA (LV) ÷ [999.0] HANGUL CHOSEONG KIYEOK (L) ÷ [0.3]
@@ -284,6 +294,12 @@
÷ AC00 × 0308 ÷ AC00 ÷ # ÷ [0.2] HANGUL SYLLABLE GA (LV) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL SYLLABLE GA (LV) ÷ [0.3]
÷ AC00 ÷ AC01 ÷ # ÷ [0.2] HANGUL SYLLABLE GA (LV) ÷ [999.0] HANGUL SYLLABLE GAG (LVT) ÷ [0.3]
÷ AC00 × 0308 ÷ AC01 ÷ # ÷ [0.2] HANGUL SYLLABLE GA (LV) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL SYLLABLE GAG (LVT) ÷ [0.3]
+÷ AC00 ÷ 1F1E6 ÷ # ÷ [0.2] HANGUL SYLLABLE GA (LV) ÷ [999.0] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) ÷ [0.3]
+÷ AC00 × 0308 ÷ 1F1E6 ÷ # ÷ [0.2] HANGUL SYLLABLE GA (LV) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) ÷ [0.3]
+÷ AC00 ÷ 0378 ÷ # ÷ [0.2] HANGUL SYLLABLE GA (LV) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3]
+÷ AC00 × 0308 ÷ 0378 ÷ # ÷ [0.2] HANGUL SYLLABLE GA (LV) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3]
+÷ AC00 ÷ D800 ÷ # ÷ [0.2] HANGUL SYLLABLE GA (LV) ÷ [5.0] <surrogate-D800> (Control) ÷ [0.3]
+÷ AC00 × 0308 ÷ D800 ÷ # ÷ [0.2] HANGUL SYLLABLE GA (LV) × [9.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <surrogate-D800> (Control) ÷ [0.3]
÷ AC01 ÷ 0020 ÷ # ÷ [0.2] HANGUL SYLLABLE GAG (LVT) ÷ [999.0] SPACE (Other) ÷ [0.3]
÷ AC01 × 0308 ÷ 0020 ÷ # ÷ [0.2] HANGUL SYLLABLE GAG (LVT) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] SPACE (Other) ÷ [0.3]
÷ AC01 ÷ 000D ÷ # ÷ [0.2] HANGUL SYLLABLE GAG (LVT) ÷ [5.0] <CARRIAGE RETURN (CR)> (CR) ÷ [0.3]
@@ -294,8 +310,6 @@
÷ AC01 × 0308 ÷ 0001 ÷ # ÷ [0.2] HANGUL SYLLABLE GAG (LVT) × [9.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <START OF HEADING> (Control) ÷ [0.3]
÷ AC01 × 0300 ÷ # ÷ [0.2] HANGUL SYLLABLE GAG (LVT) × [9.0] COMBINING GRAVE ACCENT (Extend) ÷ [0.3]
÷ AC01 × 0308 × 0300 ÷ # ÷ [0.2] HANGUL SYLLABLE GAG (LVT) × [9.0] COMBINING DIAERESIS (Extend) × [9.0] COMBINING GRAVE ACCENT (Extend) ÷ [0.3]
-÷ AC01 ÷ 0E40 ÷ # ÷ [0.2] HANGUL SYLLABLE GAG (LVT) ÷ [999.0] THAI CHARACTER SARA E (Prepend) ÷ [0.3]
-÷ AC01 × 0308 ÷ 0E40 ÷ # ÷ [0.2] HANGUL SYLLABLE GAG (LVT) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] THAI CHARACTER SARA E (Prepend) ÷ [0.3]
÷ AC01 × 0903 ÷ # ÷ [0.2] HANGUL SYLLABLE GAG (LVT) × [9.1] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [0.3]
÷ AC01 × 0308 × 0903 ÷ # ÷ [0.2] HANGUL SYLLABLE GAG (LVT) × [9.0] COMBINING DIAERESIS (Extend) × [9.1] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [0.3]
÷ AC01 ÷ 1100 ÷ # ÷ [0.2] HANGUL SYLLABLE GAG (LVT) ÷ [999.0] HANGUL CHOSEONG KIYEOK (L) ÷ [0.3]
@@ -308,4 +322,107 @@
÷ AC01 × 0308 ÷ AC00 ÷ # ÷ [0.2] HANGUL SYLLABLE GAG (LVT) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL SYLLABLE GA (LV) ÷ [0.3]
÷ AC01 ÷ AC01 ÷ # ÷ [0.2] HANGUL SYLLABLE GAG (LVT) ÷ [999.0] HANGUL SYLLABLE GAG (LVT) ÷ [0.3]
÷ AC01 × 0308 ÷ AC01 ÷ # ÷ [0.2] HANGUL SYLLABLE GAG (LVT) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL SYLLABLE GAG (LVT) ÷ [0.3]
-# Lines: 288
+÷ AC01 ÷ 1F1E6 ÷ # ÷ [0.2] HANGUL SYLLABLE GAG (LVT) ÷ [999.0] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) ÷ [0.3]
+÷ AC01 × 0308 ÷ 1F1E6 ÷ # ÷ [0.2] HANGUL SYLLABLE GAG (LVT) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) ÷ [0.3]
+÷ AC01 ÷ 0378 ÷ # ÷ [0.2] HANGUL SYLLABLE GAG (LVT) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3]
+÷ AC01 × 0308 ÷ 0378 ÷ # ÷ [0.2] HANGUL SYLLABLE GAG (LVT) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3]
+÷ AC01 ÷ D800 ÷ # ÷ [0.2] HANGUL SYLLABLE GAG (LVT) ÷ [5.0] <surrogate-D800> (Control) ÷ [0.3]
+÷ AC01 × 0308 ÷ D800 ÷ # ÷ [0.2] HANGUL SYLLABLE GAG (LVT) × [9.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <surrogate-D800> (Control) ÷ [0.3]
+÷ 1F1E6 ÷ 0020 ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) ÷ [999.0] SPACE (Other) ÷ [0.3]
+÷ 1F1E6 × 0308 ÷ 0020 ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] SPACE (Other) ÷ [0.3]
+÷ 1F1E6 ÷ 000D ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) ÷ [5.0] <CARRIAGE RETURN (CR)> (CR) ÷ [0.3]
+÷ 1F1E6 × 0308 ÷ 000D ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) × [9.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <CARRIAGE RETURN (CR)> (CR) ÷ [0.3]
+÷ 1F1E6 ÷ 000A ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) ÷ [5.0] <LINE FEED (LF)> (LF) ÷ [0.3]
+÷ 1F1E6 × 0308 ÷ 000A ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) × [9.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <LINE FEED (LF)> (LF) ÷ [0.3]
+÷ 1F1E6 ÷ 0001 ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) ÷ [5.0] <START OF HEADING> (Control) ÷ [0.3]
+÷ 1F1E6 × 0308 ÷ 0001 ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) × [9.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <START OF HEADING> (Control) ÷ [0.3]
+÷ 1F1E6 × 0300 ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) × [9.0] COMBINING GRAVE ACCENT (Extend) ÷ [0.3]
+÷ 1F1E6 × 0308 × 0300 ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) × [9.0] COMBINING DIAERESIS (Extend) × [9.0] COMBINING GRAVE ACCENT (Extend) ÷ [0.3]
+÷ 1F1E6 × 0903 ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) × [9.1] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [0.3]
+÷ 1F1E6 × 0308 × 0903 ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) × [9.0] COMBINING DIAERESIS (Extend) × [9.1] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [0.3]
+÷ 1F1E6 ÷ 1100 ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) ÷ [999.0] HANGUL CHOSEONG KIYEOK (L) ÷ [0.3]
+÷ 1F1E6 × 0308 ÷ 1100 ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL CHOSEONG KIYEOK (L) ÷ [0.3]
+÷ 1F1E6 ÷ 1160 ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) ÷ [999.0] HANGUL JUNGSEONG FILLER (V) ÷ [0.3]
+÷ 1F1E6 × 0308 ÷ 1160 ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL JUNGSEONG FILLER (V) ÷ [0.3]
+÷ 1F1E6 ÷ 11A8 ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) ÷ [999.0] HANGUL JONGSEONG KIYEOK (T) ÷ [0.3]
+÷ 1F1E6 × 0308 ÷ 11A8 ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL JONGSEONG KIYEOK (T) ÷ [0.3]
+÷ 1F1E6 ÷ AC00 ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) ÷ [999.0] HANGUL SYLLABLE GA (LV) ÷ [0.3]
+÷ 1F1E6 × 0308 ÷ AC00 ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL SYLLABLE GA (LV) ÷ [0.3]
+÷ 1F1E6 ÷ AC01 ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) ÷ [999.0] HANGUL SYLLABLE GAG (LVT) ÷ [0.3]
+÷ 1F1E6 × 0308 ÷ AC01 ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL SYLLABLE GAG (LVT) ÷ [0.3]
+÷ 1F1E6 × 1F1E6 ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) × [8.1] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) ÷ [0.3]
+÷ 1F1E6 × 0308 ÷ 1F1E6 ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) ÷ [0.3]
+÷ 1F1E6 ÷ 0378 ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3]
+÷ 1F1E6 × 0308 ÷ 0378 ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3]
+÷ 1F1E6 ÷ D800 ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) ÷ [5.0] <surrogate-D800> (Control) ÷ [0.3]
+÷ 1F1E6 × 0308 ÷ D800 ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) × [9.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <surrogate-D800> (Control) ÷ [0.3]
+÷ 0378 ÷ 0020 ÷ # ÷ [0.2] <reserved-0378> (Other) ÷ [999.0] SPACE (Other) ÷ [0.3]
+÷ 0378 × 0308 ÷ 0020 ÷ # ÷ [0.2] <reserved-0378> (Other) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] SPACE (Other) ÷ [0.3]
+÷ 0378 ÷ 000D ÷ # ÷ [0.2] <reserved-0378> (Other) ÷ [5.0] <CARRIAGE RETURN (CR)> (CR) ÷ [0.3]
+÷ 0378 × 0308 ÷ 000D ÷ # ÷ [0.2] <reserved-0378> (Other) × [9.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <CARRIAGE RETURN (CR)> (CR) ÷ [0.3]
+÷ 0378 ÷ 000A ÷ # ÷ [0.2] <reserved-0378> (Other) ÷ [5.0] <LINE FEED (LF)> (LF) ÷ [0.3]
+÷ 0378 × 0308 ÷ 000A ÷ # ÷ [0.2] <reserved-0378> (Other) × [9.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <LINE FEED (LF)> (LF) ÷ [0.3]
+÷ 0378 ÷ 0001 ÷ # ÷ [0.2] <reserved-0378> (Other) ÷ [5.0] <START OF HEADING> (Control) ÷ [0.3]
+÷ 0378 × 0308 ÷ 0001 ÷ # ÷ [0.2] <reserved-0378> (Other) × [9.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <START OF HEADING> (Control) ÷ [0.3]
+÷ 0378 × 0300 ÷ # ÷ [0.2] <reserved-0378> (Other) × [9.0] COMBINING GRAVE ACCENT (Extend) ÷ [0.3]
+÷ 0378 × 0308 × 0300 ÷ # ÷ [0.2] <reserved-0378> (Other) × [9.0] COMBINING DIAERESIS (Extend) × [9.0] COMBINING GRAVE ACCENT (Extend) ÷ [0.3]
+÷ 0378 × 0903 ÷ # ÷ [0.2] <reserved-0378> (Other) × [9.1] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [0.3]
+÷ 0378 × 0308 × 0903 ÷ # ÷ [0.2] <reserved-0378> (Other) × [9.0] COMBINING DIAERESIS (Extend) × [9.1] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [0.3]
+÷ 0378 ÷ 1100 ÷ # ÷ [0.2] <reserved-0378> (Other) ÷ [999.0] HANGUL CHOSEONG KIYEOK (L) ÷ [0.3]
+÷ 0378 × 0308 ÷ 1100 ÷ # ÷ [0.2] <reserved-0378> (Other) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL CHOSEONG KIYEOK (L) ÷ [0.3]
+÷ 0378 ÷ 1160 ÷ # ÷ [0.2] <reserved-0378> (Other) ÷ [999.0] HANGUL JUNGSEONG FILLER (V) ÷ [0.3]
+÷ 0378 × 0308 ÷ 1160 ÷ # ÷ [0.2] <reserved-0378> (Other) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL JUNGSEONG FILLER (V) ÷ [0.3]
+÷ 0378 ÷ 11A8 ÷ # ÷ [0.2] <reserved-0378> (Other) ÷ [999.0] HANGUL JONGSEONG KIYEOK (T) ÷ [0.3]
+÷ 0378 × 0308 ÷ 11A8 ÷ # ÷ [0.2] <reserved-0378> (Other) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL JONGSEONG KIYEOK (T) ÷ [0.3]
+÷ 0378 ÷ AC00 ÷ # ÷ [0.2] <reserved-0378> (Other) ÷ [999.0] HANGUL SYLLABLE GA (LV) ÷ [0.3]
+÷ 0378 × 0308 ÷ AC00 ÷ # ÷ [0.2] <reserved-0378> (Other) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL SYLLABLE GA (LV) ÷ [0.3]
+÷ 0378 ÷ AC01 ÷ # ÷ [0.2] <reserved-0378> (Other) ÷ [999.0] HANGUL SYLLABLE GAG (LVT) ÷ [0.3]
+÷ 0378 × 0308 ÷ AC01 ÷ # ÷ [0.2] <reserved-0378> (Other) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL SYLLABLE GAG (LVT) ÷ [0.3]
+÷ 0378 ÷ 1F1E6 ÷ # ÷ [0.2] <reserved-0378> (Other) ÷ [999.0] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) ÷ [0.3]
+÷ 0378 × 0308 ÷ 1F1E6 ÷ # ÷ [0.2] <reserved-0378> (Other) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) ÷ [0.3]
+÷ 0378 ÷ 0378 ÷ # ÷ [0.2] <reserved-0378> (Other) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3]
+÷ 0378 × 0308 ÷ 0378 ÷ # ÷ [0.2] <reserved-0378> (Other) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3]
+÷ 0378 ÷ D800 ÷ # ÷ [0.2] <reserved-0378> (Other) ÷ [5.0] <surrogate-D800> (Control) ÷ [0.3]
+÷ 0378 × 0308 ÷ D800 ÷ # ÷ [0.2] <reserved-0378> (Other) × [9.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <surrogate-D800> (Control) ÷ [0.3]
+÷ D800 ÷ 0020 ÷ # ÷ [0.2] <surrogate-D800> (Control) ÷ [4.0] SPACE (Other) ÷ [0.3]
+÷ D800 ÷ 0308 ÷ 0020 ÷ # ÷ [0.2] <surrogate-D800> (Control) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] SPACE (Other) ÷ [0.3]
+÷ D800 ÷ 000D ÷ # ÷ [0.2] <surrogate-D800> (Control) ÷ [4.0] <CARRIAGE RETURN (CR)> (CR) ÷ [0.3]
+÷ D800 ÷ 0308 ÷ 000D ÷ # ÷ [0.2] <surrogate-D800> (Control) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <CARRIAGE RETURN (CR)> (CR) ÷ [0.3]
+÷ D800 ÷ 000A ÷ # ÷ [0.2] <surrogate-D800> (Control) ÷ [4.0] <LINE FEED (LF)> (LF) ÷ [0.3]
+÷ D800 ÷ 0308 ÷ 000A ÷ # ÷ [0.2] <surrogate-D800> (Control) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <LINE FEED (LF)> (LF) ÷ [0.3]
+÷ D800 ÷ 0001 ÷ # ÷ [0.2] <surrogate-D800> (Control) ÷ [4.0] <START OF HEADING> (Control) ÷ [0.3]
+÷ D800 ÷ 0308 ÷ 0001 ÷ # ÷ [0.2] <surrogate-D800> (Control) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <START OF HEADING> (Control) ÷ [0.3]
+÷ D800 ÷ 0300 ÷ # ÷ [0.2] <surrogate-D800> (Control) ÷ [4.0] COMBINING GRAVE ACCENT (Extend) ÷ [0.3]
+÷ D800 ÷ 0308 × 0300 ÷ # ÷ [0.2] <surrogate-D800> (Control) ÷ [4.0] COMBINING DIAERESIS (Extend) × [9.0] COMBINING GRAVE ACCENT (Extend) ÷ [0.3]
+÷ D800 ÷ 0903 ÷ # ÷ [0.2] <surrogate-D800> (Control) ÷ [4.0] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [0.3]
+÷ D800 ÷ 0308 × 0903 ÷ # ÷ [0.2] <surrogate-D800> (Control) ÷ [4.0] COMBINING DIAERESIS (Extend) × [9.1] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [0.3]
+÷ D800 ÷ 1100 ÷ # ÷ [0.2] <surrogate-D800> (Control) ÷ [4.0] HANGUL CHOSEONG KIYEOK (L) ÷ [0.3]
+÷ D800 ÷ 0308 ÷ 1100 ÷ # ÷ [0.2] <surrogate-D800> (Control) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL CHOSEONG KIYEOK (L) ÷ [0.3]
+÷ D800 ÷ 1160 ÷ # ÷ [0.2] <surrogate-D800> (Control) ÷ [4.0] HANGUL JUNGSEONG FILLER (V) ÷ [0.3]
+÷ D800 ÷ 0308 ÷ 1160 ÷ # ÷ [0.2] <surrogate-D800> (Control) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL JUNGSEONG FILLER (V) ÷ [0.3]
+÷ D800 ÷ 11A8 ÷ # ÷ [0.2] <surrogate-D800> (Control) ÷ [4.0] HANGUL JONGSEONG KIYEOK (T) ÷ [0.3]
+÷ D800 ÷ 0308 ÷ 11A8 ÷ # ÷ [0.2] <surrogate-D800> (Control) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL JONGSEONG KIYEOK (T) ÷ [0.3]
+÷ D800 ÷ AC00 ÷ # ÷ [0.2] <surrogate-D800> (Control) ÷ [4.0] HANGUL SYLLABLE GA (LV) ÷ [0.3]
+÷ D800 ÷ 0308 ÷ AC00 ÷ # ÷ [0.2] <surrogate-D800> (Control) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL SYLLABLE GA (LV) ÷ [0.3]
+÷ D800 ÷ AC01 ÷ # ÷ [0.2] <surrogate-D800> (Control) ÷ [4.0] HANGUL SYLLABLE GAG (LVT) ÷ [0.3]
+÷ D800 ÷ 0308 ÷ AC01 ÷ # ÷ [0.2] <surrogate-D800> (Control) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL SYLLABLE GAG (LVT) ÷ [0.3]
+÷ D800 ÷ 1F1E6 ÷ # ÷ [0.2] <surrogate-D800> (Control) ÷ [4.0] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) ÷ [0.3]
+÷ D800 ÷ 0308 ÷ 1F1E6 ÷ # ÷ [0.2] <surrogate-D800> (Control) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) ÷ [0.3]
+÷ D800 ÷ 0378 ÷ # ÷ [0.2] <surrogate-D800> (Control) ÷ [4.0] <reserved-0378> (Other) ÷ [0.3]
+÷ D800 ÷ 0308 ÷ 0378 ÷ # ÷ [0.2] <surrogate-D800> (Control) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3]
+÷ D800 ÷ D800 ÷ # ÷ [0.2] <surrogate-D800> (Control) ÷ [4.0] <surrogate-D800> (Control) ÷ [0.3]
+÷ D800 ÷ 0308 ÷ D800 ÷ # ÷ [0.2] <surrogate-D800> (Control) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <surrogate-D800> (Control) ÷ [0.3]
+÷ 0061 ÷ 1F1E6 ÷ 0062 ÷ # ÷ [0.2] LATIN SMALL LETTER A (Other) ÷ [999.0] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) ÷ [999.0] LATIN SMALL LETTER B (Other) ÷ [0.3]
+÷ 1F1F7 × 1F1FA ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER R (Regional_Indicator) × [8.1] REGIONAL INDICATOR SYMBOL LETTER U (Regional_Indicator) ÷ [0.3]
+÷ 1F1F7 × 1F1FA × 1F1F8 ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER R (Regional_Indicator) × [8.1] REGIONAL INDICATOR SYMBOL LETTER U (Regional_Indicator) × [8.1] REGIONAL INDICATOR SYMBOL LETTER S (Regional_Indicator) ÷ [0.3]
+÷ 1F1F7 × 1F1FA × 1F1F8 × 1F1EA ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER R (Regional_Indicator) × [8.1] REGIONAL INDICATOR SYMBOL LETTER U (Regional_Indicator) × [8.1] REGIONAL INDICATOR SYMBOL LETTER S (Regional_Indicator) × [8.1] REGIONAL INDICATOR SYMBOL LETTER E (Regional_Indicator) ÷ [0.3]
+÷ 1F1F7 × 1F1FA ÷ 200B ÷ 1F1F8 × 1F1EA ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER R (Regional_Indicator) × [8.1] REGIONAL INDICATOR SYMBOL LETTER U (Regional_Indicator) ÷ [5.0] ZERO WIDTH SPACE (Control) ÷ [4.0] REGIONAL INDICATOR SYMBOL LETTER S (Regional_Indicator) × [8.1] REGIONAL INDICATOR SYMBOL LETTER E (Regional_Indicator) ÷ [0.3]
+÷ 1F1E6 × 1F1E7 × 1F1E8 ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) × [8.1] REGIONAL INDICATOR SYMBOL LETTER B (Regional_Indicator) × [8.1] REGIONAL INDICATOR SYMBOL LETTER C (Regional_Indicator) ÷ [0.3]
+÷ 1F1E6 × 200D ÷ 1F1E7 × 1F1E8 ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) × [9.0] ZERO WIDTH JOINER (Extend) ÷ [999.0] REGIONAL INDICATOR SYMBOL LETTER B (Regional_Indicator) × [8.1] REGIONAL INDICATOR SYMBOL LETTER C (Regional_Indicator) ÷ [0.3]
+÷ 1F1E6 × 1F1E7 × 200D ÷ 1F1E8 ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER A (Regional_Indicator) × [8.1] REGIONAL INDICATOR SYMBOL LETTER B (Regional_Indicator) × [9.0] ZERO WIDTH JOINER (Extend) ÷ [999.0] REGIONAL INDICATOR SYMBOL LETTER C (Regional_Indicator) ÷ [0.3]
+÷ 0020 × 200D ÷ 0646 ÷ # ÷ [0.2] SPACE (Other) × [9.0] ZERO WIDTH JOINER (Extend) ÷ [999.0] ARABIC LETTER NOON (Other) ÷ [0.3]
+÷ 0646 × 200D ÷ 0020 ÷ # ÷ [0.2] ARABIC LETTER NOON (Other) × [9.0] ZERO WIDTH JOINER (Extend) ÷ [999.0] SPACE (Other) ÷ [0.3]
+#
+# Lines: 402
+#
+# EOF
Property changes on: trunk/contrib/perl/lib/unicore/auxiliary/GCBTest.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/auxiliary/GraphemeBreakProperty.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/auxiliary/GraphemeBreakProperty.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/auxiliary/GraphemeBreakProperty.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,8 +1,8 @@
-# GraphemeBreakProperty-6.0.0.txt
-# Date: 2010-09-01, 18:48:17 GMT [MD]
+# GraphemeBreakProperty-6.2.0.txt
+# Date: 2012-08-13, 19:12:02 GMT [MD]
#
# Unicode Character Database
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
# For documentation, see http://www.unicode.org/reports/tr44/
@@ -34,10 +34,9 @@
000E..001F ; Control # Cc [18] <control-000E>..<control-001F>
007F..009F ; Control # Cc [33] <control-007F>..<control-009F>
00AD ; Control # Cf SOFT HYPHEN
-0600..0603 ; Control # Cf [4] ARABIC NUMBER SIGN..ARABIC SIGN SAFHA
+0600..0604 ; Control # Cf [5] ARABIC NUMBER SIGN..ARABIC SIGN SAMVAT
06DD ; Control # Cf ARABIC END OF AYAH
070F ; Control # Cf SYRIAC ABBREVIATION MARK
-17B4..17B5 ; Control # Cf [2] KHMER VOWEL INHERENT AQ..KHMER VOWEL INHERENT AA
200B ; Control # Cf ZERO WIDTH SPACE
200E..200F ; Control # Cf [2] LEFT-TO-RIGHT MARK..RIGHT-TO-LEFT MARK
2028 ; Control # Zl LINE SEPARATOR
@@ -44,15 +43,22 @@
2029 ; Control # Zp PARAGRAPH SEPARATOR
202A..202E ; Control # Cf [5] LEFT-TO-RIGHT EMBEDDING..RIGHT-TO-LEFT OVERRIDE
2060..2064 ; Control # Cf [5] WORD JOINER..INVISIBLE PLUS
+2065..2069 ; Control # Cn [5] <reserved-2065>..<reserved-2069>
206A..206F ; Control # Cf [6] INHIBIT SYMMETRIC SWAPPING..NOMINAL DIGIT SHAPES
+D800..DFFF ; Control # Cs [2048] <surrogate-D800>..<surrogate-DFFF>
FEFF ; Control # Cf ZERO WIDTH NO-BREAK SPACE
+FFF0..FFF8 ; Control # Cn [9] <reserved-FFF0>..<reserved-FFF8>
FFF9..FFFB ; Control # Cf [3] INTERLINEAR ANNOTATION ANCHOR..INTERLINEAR ANNOTATION TERMINATOR
110BD ; Control # Cf KAITHI NUMBER SIGN
1D173..1D17A ; Control # Cf [8] MUSICAL SYMBOL BEGIN BEAM..MUSICAL SYMBOL END PHRASE
+E0000 ; Control # Cn <reserved-E0000>
E0001 ; Control # Cf LANGUAGE TAG
+E0002..E001F ; Control # Cn [30] <reserved-E0002>..<reserved-E001F>
E0020..E007F ; Control # Cf [96] TAG SPACE..CANCEL TAG
+E0080..E00FF ; Control # Cn [128] <reserved-E0080>..<reserved-E00FF>
+E01F0..E0FFF ; Control # Cn [3600] <reserved-E01F0>..<reserved-E0FFF>
-# Total code points: 203
+# Total code points: 6023
# ================================================
@@ -80,6 +86,7 @@
0825..0827 ; Extend # Mn [3] SAMARITAN VOWEL SIGN SHORT A..SAMARITAN VOWEL SIGN U
0829..082D ; Extend # Mn [5] SAMARITAN VOWEL SIGN LONG I..SAMARITAN MARK NEQUDAA
0859..085B ; Extend # Mn [3] MANDAIC AFFRICATION MARK..MANDAIC GEMINATION MARK
+08E4..08FE ; Extend # Mn [27] ARABIC CURLY FATHA..ARABIC DAMMA WITH DOT
0900..0902 ; Extend # Mn [3] DEVANAGARI SIGN INVERTED CANDRABINDU..DEVANAGARI SIGN ANUSVARA
093A ; Extend # Mn DEVANAGARI VOWEL SIGN OE
093C ; Extend # Mn DEVANAGARI SIGN NUKTA
@@ -177,6 +184,7 @@
1732..1734 ; Extend # Mn [3] HANUNOO VOWEL SIGN I..HANUNOO SIGN PAMUDPOD
1752..1753 ; Extend # Mn [2] BUHID VOWEL SIGN I..BUHID VOWEL SIGN U
1772..1773 ; Extend # Mn [2] TAGBANWA VOWEL SIGN I..TAGBANWA VOWEL SIGN U
+17B4..17B5 ; Extend # Mn [2] KHMER VOWEL INHERENT AQ..KHMER VOWEL INHERENT AA
17B7..17BD ; Extend # Mn [7] KHMER VOWEL SIGN I..KHMER VOWEL SIGN UA
17C6 ; Extend # Mn KHMER SIGN NIKAHIT
17C9..17D3 ; Extend # Mn [11] KHMER SIGN MUUSIKATOAN..KHMER SIGN BATHAMASAT
@@ -204,6 +212,7 @@
1B80..1B81 ; Extend # Mn [2] SUNDANESE SIGN PANYECEK..SUNDANESE SIGN PANGLAYAR
1BA2..1BA5 ; Extend # Mn [4] SUNDANESE CONSONANT SIGN PANYAKRA..SUNDANESE VOWEL SIGN PANYUKU
1BA8..1BA9 ; Extend # Mn [2] SUNDANESE VOWEL SIGN PAMEPET..SUNDANESE VOWEL SIGN PANEULEUNG
+1BAB ; Extend # Mn SUNDANESE SIGN VIRAMA
1BE6 ; Extend # Mn BATAK SIGN TOMPI
1BE8..1BE9 ; Extend # Mn [2] BATAK VOWEL SIGN PAKPAK E..BATAK VOWEL SIGN EE
1BED ; Extend # Mn BATAK VOWEL SIGN KARO O
@@ -214,6 +223,7 @@
1CD4..1CE0 ; Extend # Mn [13] VEDIC SIGN YAJURVEDIC MIDLINE SVARITA..VEDIC TONE RIGVEDIC KASHMIRI INDEPENDENT SVARITA
1CE2..1CE8 ; Extend # Mn [7] VEDIC SIGN VISARGA SVARITA..VEDIC SIGN VISARGA ANUDATTA WITH TAIL
1CED ; Extend # Mn VEDIC SIGN TIRYAK
+1CF4 ; Extend # Mn VEDIC TONE CANDRA ABOVE
1DC0..1DE6 ; Extend # Mn [39] COMBINING DOTTED GRAVE ACCENT..COMBINING LATIN SMALL LETTER Z
1DFC..1DFF ; Extend # Mn [4] COMBINING DOUBLE INVERTED BREVE BELOW..COMBINING RIGHT ARROWHEAD AND DOWN ARROWHEAD BELOW
200C..200D ; Extend # Cf [2] ZERO WIDTH NON-JOINER..ZERO WIDTH JOINER
@@ -225,11 +235,13 @@
2CEF..2CF1 ; Extend # Mn [3] COPTIC COMBINING NI ABOVE..COPTIC COMBINING SPIRITUS LENIS
2D7F ; Extend # Mn TIFINAGH CONSONANT JOINER
2DE0..2DFF ; Extend # Mn [32] COMBINING CYRILLIC LETTER BE..COMBINING CYRILLIC LETTER IOTIFIED BIG YUS
-302A..302F ; Extend # Mn [6] IDEOGRAPHIC LEVEL TONE MARK..HANGUL DOUBLE DOT TONE MARK
+302A..302D ; Extend # Mn [4] IDEOGRAPHIC LEVEL TONE MARK..IDEOGRAPHIC ENTERING TONE MARK
+302E..302F ; Extend # Mc [2] HANGUL SINGLE DOT TONE MARK..HANGUL DOUBLE DOT TONE MARK
3099..309A ; Extend # Mn [2] COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK..COMBINING KATAKANA-HIRAGANA SEMI-VOICED SOUND MARK
A66F ; Extend # Mn COMBINING CYRILLIC VZMET
A670..A672 ; Extend # Me [3] COMBINING CYRILLIC TEN MILLIONS SIGN..COMBINING CYRILLIC THOUSAND MILLIONS SIGN
-A67C..A67D ; Extend # Mn [2] COMBINING CYRILLIC KAVYKA..COMBINING CYRILLIC PAYEROK
+A674..A67D ; Extend # Mn [10] COMBINING CYRILLIC LETTER UKRAINIAN IE..COMBINING CYRILLIC PAYEROK
+A69F ; Extend # Mn COMBINING CYRILLIC LETTER IOTIFIED E
A6F0..A6F1 ; Extend # Mn [2] BAMUM COMBINING MARK KOQNDON..BAMUM COMBINING MARK TUKWENTIS
A802 ; Extend # Mn SYLOTI NAGRI SIGN DVISVARA
A806 ; Extend # Mn SYLOTI NAGRI SIGN HASANTA
@@ -253,6 +265,8 @@
AAB7..AAB8 ; Extend # Mn [2] TAI VIET MAI KHIT..TAI VIET VOWEL IA
AABE..AABF ; Extend # Mn [2] TAI VIET VOWEL AM..TAI VIET TONE MAI EK
AAC1 ; Extend # Mn TAI VIET TONE MAI THO
+AAEC..AAED ; Extend # Mn [2] MEETEI MAYEK VOWEL SIGN UU..MEETEI MAYEK VOWEL SIGN AAI
+AAF6 ; Extend # Mn MEETEI MAYEK VIRAMA
ABE5 ; Extend # Mn MEETEI MAYEK VOWEL SIGN ANAP
ABE8 ; Extend # Mn MEETEI MAYEK VOWEL SIGN UNAP
ABED ; Extend # Mn MEETEI MAYEK APUN IYEK
@@ -271,6 +285,16 @@
11080..11081 ; Extend # Mn [2] KAITHI SIGN CANDRABINDU..KAITHI SIGN ANUSVARA
110B3..110B6 ; Extend # Mn [4] KAITHI VOWEL SIGN U..KAITHI VOWEL SIGN AI
110B9..110BA ; Extend # Mn [2] KAITHI SIGN VIRAMA..KAITHI SIGN NUKTA
+11100..11102 ; Extend # Mn [3] CHAKMA SIGN CANDRABINDU..CHAKMA SIGN VISARGA
+11127..1112B ; Extend # Mn [5] CHAKMA VOWEL SIGN A..CHAKMA VOWEL SIGN UU
+1112D..11134 ; Extend # Mn [8] CHAKMA VOWEL SIGN AI..CHAKMA MAAYYAA
+11180..11181 ; Extend # Mn [2] SHARADA SIGN CANDRABINDU..SHARADA SIGN ANUSVARA
+111B6..111BE ; Extend # Mn [9] SHARADA VOWEL SIGN U..SHARADA VOWEL SIGN O
+116AB ; Extend # Mn TAKRI SIGN ANUSVARA
+116AD ; Extend # Mn TAKRI VOWEL SIGN AA
+116B0..116B5 ; Extend # Mn [6] TAKRI VOWEL SIGN U..TAKRI VOWEL SIGN AU
+116B7 ; Extend # Mn TAKRI SIGN NUKTA
+16F8F..16F92 ; Extend # Mn [4] MIAO TONE RIGHT..MIAO TONE BELOW
1D165 ; Extend # Mc MUSICAL SYMBOL COMBINING STEM
1D167..1D169 ; Extend # Mn [3] MUSICAL SYMBOL COMBINING TREMOLO-1..MUSICAL SYMBOL COMBINING TREMOLO-3
1D16E..1D172 ; Extend # Mc [5] MUSICAL SYMBOL COMBINING FLAG-1..MUSICAL SYMBOL COMBINING FLAG-5
@@ -280,17 +304,13 @@
1D242..1D244 ; Extend # Mn [3] COMBINING GREEK MUSICAL TRISEME..COMBINING GREEK MUSICAL PENTASEME
E0100..E01EF ; Extend # Mn [240] VARIATION SELECTOR-17..VARIATION SELECTOR-256
-# Total code points: 1234
+# Total code points: 1317
# ================================================
-0E40..0E44 ; Prepend # Lo [5] THAI CHARACTER SARA E..THAI CHARACTER SARA AI MAIMALAI
-0EC0..0EC4 ; Prepend # Lo [5] LAO VOWEL SIGN E..LAO VOWEL SIGN AI
-AAB5..AAB6 ; Prepend # Lo [2] TAI VIET VOWEL E..TAI VIET VOWEL O
-AAB9 ; Prepend # Lo TAI VIET VOWEL UEA
-AABB..AABC ; Prepend # Lo [2] TAI VIET VOWEL AUE..TAI VIET VOWEL AY
+1F1E6..1F1FF ; Regional_Indicator # So [26] REGIONAL INDICATOR SYMBOL LETTER A..REGIONAL INDICATOR SYMBOL LETTER Z
-# Total code points: 15
+# Total code points: 26
# ================================================
@@ -333,24 +353,14 @@
0DD0..0DD1 ; SpacingMark # Mc [2] SINHALA VOWEL SIGN KETTI AEDA-PILLA..SINHALA VOWEL SIGN DIGA AEDA-PILLA
0DD8..0DDE ; SpacingMark # Mc [7] SINHALA VOWEL SIGN GAETTA-PILLA..SINHALA VOWEL SIGN KOMBUVA HAA GAYANUKITTA
0DF2..0DF3 ; SpacingMark # Mc [2] SINHALA VOWEL SIGN DIGA GAETTA-PILLA..SINHALA VOWEL SIGN DIGA GAYANUKITTA
-0E30 ; SpacingMark # Lo THAI CHARACTER SARA A
-0E32..0E33 ; SpacingMark # Lo [2] THAI CHARACTER SARA AA..THAI CHARACTER SARA AM
-0E45 ; SpacingMark # Lo THAI CHARACTER LAKKHANGYAO
-0EB0 ; SpacingMark # Lo LAO VOWEL SIGN A
-0EB2..0EB3 ; SpacingMark # Lo [2] LAO VOWEL SIGN AA..LAO VOWEL SIGN AM
+0E33 ; SpacingMark # Lo THAI CHARACTER SARA AM
+0EB3 ; SpacingMark # Lo LAO VOWEL SIGN AM
0F3E..0F3F ; SpacingMark # Mc [2] TIBETAN SIGN YAR TSHES..TIBETAN SIGN MAR TSHES
0F7F ; SpacingMark # Mc TIBETAN SIGN RNAM BCAD
-102B..102C ; SpacingMark # Mc [2] MYANMAR VOWEL SIGN TALL AA..MYANMAR VOWEL SIGN AA
1031 ; SpacingMark # Mc MYANMAR VOWEL SIGN E
-1038 ; SpacingMark # Mc MYANMAR SIGN VISARGA
103B..103C ; SpacingMark # Mc [2] MYANMAR CONSONANT SIGN MEDIAL YA..MYANMAR CONSONANT SIGN MEDIAL RA
1056..1057 ; SpacingMark # Mc [2] MYANMAR VOWEL SIGN VOCALIC R..MYANMAR VOWEL SIGN VOCALIC RR
-1062..1064 ; SpacingMark # Mc [3] MYANMAR VOWEL SIGN SGAW KAREN EU..MYANMAR TONE MARK SGAW KAREN KE PHO
-1067..106D ; SpacingMark # Mc [7] MYANMAR VOWEL SIGN WESTERN PWO KAREN EU..MYANMAR SIGN WESTERN PWO KAREN TONE-5
-1083..1084 ; SpacingMark # Mc [2] MYANMAR VOWEL SIGN SHAN AA..MYANMAR VOWEL SIGN SHAN E
-1087..108C ; SpacingMark # Mc [6] MYANMAR SIGN SHAN TONE-2..MYANMAR SIGN SHAN COUNCIL TONE-3
-108F ; SpacingMark # Mc MYANMAR SIGN RUMAI PALAUNG TONE-5
-109A..109C ; SpacingMark # Mc [3] MYANMAR SIGN KHAMTI TONE-1..MYANMAR VOWEL SIGN AITON A
+1084 ; SpacingMark # Mc MYANMAR VOWEL SIGN SHAN E
17B6 ; SpacingMark # Mc KHMER VOWEL SIGN AA
17BE..17C5 ; SpacingMark # Mc [8] KHMER VOWEL SIGN OE..KHMER VOWEL SIGN AU
17C7..17C8 ; SpacingMark # Mc [2] KHMER SIGN REAHMUK..KHMER SIGN YUUKALEAPINTU
@@ -358,13 +368,11 @@
1929..192B ; SpacingMark # Mc [3] LIMBU SUBJOINED LETTER YA..LIMBU SUBJOINED LETTER WA
1930..1931 ; SpacingMark # Mc [2] LIMBU SMALL LETTER KA..LIMBU SMALL LETTER NGA
1933..1938 ; SpacingMark # Mc [6] LIMBU SMALL LETTER TA..LIMBU SMALL LETTER LA
-19B0..19C0 ; SpacingMark # Mc [17] NEW TAI LUE VOWEL SIGN VOWEL SHORTENER..NEW TAI LUE VOWEL SIGN IY
-19C8..19C9 ; SpacingMark # Mc [2] NEW TAI LUE TONE MARK-1..NEW TAI LUE TONE MARK-2
+19B5..19B7 ; SpacingMark # Mc [3] NEW TAI LUE VOWEL SIGN E..NEW TAI LUE VOWEL SIGN O
+19BA ; SpacingMark # Mc NEW TAI LUE VOWEL SIGN AY
1A19..1A1B ; SpacingMark # Mc [3] BUGINESE VOWEL SIGN E..BUGINESE VOWEL SIGN AE
1A55 ; SpacingMark # Mc TAI THAM CONSONANT SIGN MEDIAL RA
1A57 ; SpacingMark # Mc TAI THAM CONSONANT SIGN LA TANG LAI
-1A61 ; SpacingMark # Mc TAI THAM VOWEL SIGN A
-1A63..1A64 ; SpacingMark # Mc [2] TAI THAM VOWEL SIGN AA..TAI THAM VOWEL SIGN TALL AA
1A6D..1A72 ; SpacingMark # Mc [6] TAI THAM VOWEL SIGN OY..TAI THAM VOWEL SIGN THAM AI
1B04 ; SpacingMark # Mc BALINESE SIGN BISAH
1B35 ; SpacingMark # Mc BALINESE VOWEL SIGN TEDUNG
@@ -375,6 +383,7 @@
1BA1 ; SpacingMark # Mc SUNDANESE CONSONANT SIGN PAMINGKAL
1BA6..1BA7 ; SpacingMark # Mc [2] SUNDANESE VOWEL SIGN PANAELAENG..SUNDANESE VOWEL SIGN PANOLONG
1BAA ; SpacingMark # Mc SUNDANESE SIGN PAMAAEH
+1BAC..1BAD ; SpacingMark # Mc [2] SUNDANESE CONSONANT SIGN PASANGAN MA..SUNDANESE CONSONANT SIGN PASANGAN WA
1BE7 ; SpacingMark # Mc BATAK VOWEL SIGN E
1BEA..1BEC ; SpacingMark # Mc [3] BATAK VOWEL SIGN I..BATAK VOWEL SIGN O
1BEE ; SpacingMark # Mc BATAK VOWEL SIGN U
@@ -382,7 +391,7 @@
1C24..1C2B ; SpacingMark # Mc [8] LEPCHA SUBJOINED LETTER YA..LEPCHA VOWEL SIGN UU
1C34..1C35 ; SpacingMark # Mc [2] LEPCHA CONSONANT SIGN NYIN-DO..LEPCHA CONSONANT SIGN KANG
1CE1 ; SpacingMark # Mc VEDIC TONE ATHARVAVEDIC INDEPENDENT SVARITA
-1CF2 ; SpacingMark # Mc VEDIC SIGN ARDHAVISARGA
+1CF2..1CF3 ; SpacingMark # Mc [2] VEDIC SIGN ARDHAVISARGA..VEDIC SIGN ROTATED ARDHAVISARGA
A823..A824 ; SpacingMark # Mc [2] SYLOTI NAGRI VOWEL SIGN A..SYLOTI NAGRI VOWEL SIGN I
A827 ; SpacingMark # Mc SYLOTI NAGRI VOWEL SIGN OO
A880..A881 ; SpacingMark # Mc [2] SAURASHTRA SIGN ANUSVARA..SAURASHTRA SIGN VISARGA
@@ -395,7 +404,9 @@
AA2F..AA30 ; SpacingMark # Mc [2] CHAM VOWEL SIGN O..CHAM VOWEL SIGN AI
AA33..AA34 ; SpacingMark # Mc [2] CHAM CONSONANT SIGN YA..CHAM CONSONANT SIGN RA
AA4D ; SpacingMark # Mc CHAM CONSONANT SIGN FINAL H
-AA7B ; SpacingMark # Mc MYANMAR SIGN PAO KAREN TONE
+AAEB ; SpacingMark # Mc MEETEI MAYEK VOWEL SIGN II
+AAEE..AAEF ; SpacingMark # Mc [2] MEETEI MAYEK VOWEL SIGN AU..MEETEI MAYEK VOWEL SIGN AAU
+AAF5 ; SpacingMark # Mc MEETEI MAYEK VOWEL SIGN VISARGA
ABE3..ABE4 ; SpacingMark # Mc [2] MEETEI MAYEK VOWEL SIGN ONAP..MEETEI MAYEK VOWEL SIGN INAP
ABE6..ABE7 ; SpacingMark # Mc [2] MEETEI MAYEK VOWEL SIGN YENAP..MEETEI MAYEK VOWEL SIGN SOUNAP
ABE9..ABEA ; SpacingMark # Mc [2] MEETEI MAYEK VOWEL SIGN CHEINAP..MEETEI MAYEK VOWEL SIGN NUNG
@@ -405,10 +416,18 @@
11082 ; SpacingMark # Mc KAITHI SIGN VISARGA
110B0..110B2 ; SpacingMark # Mc [3] KAITHI VOWEL SIGN AA..KAITHI VOWEL SIGN II
110B7..110B8 ; SpacingMark # Mc [2] KAITHI VOWEL SIGN O..KAITHI VOWEL SIGN AU
+1112C ; SpacingMark # Mc CHAKMA VOWEL SIGN E
+11182 ; SpacingMark # Mc SHARADA SIGN VISARGA
+111B3..111B5 ; SpacingMark # Mc [3] SHARADA VOWEL SIGN AA..SHARADA VOWEL SIGN II
+111BF..111C0 ; SpacingMark # Mc [2] SHARADA VOWEL SIGN AU..SHARADA SIGN VIRAMA
+116AC ; SpacingMark # Mc TAKRI SIGN VISARGA
+116AE..116AF ; SpacingMark # Mc [2] TAKRI VOWEL SIGN I..TAKRI VOWEL SIGN II
+116B6 ; SpacingMark # Mc TAKRI SIGN VIRAMA
+16F51..16F7E ; SpacingMark # Mc [46] MIAO SIGN ASPIRATION..MIAO VOWEL SIGN NG
1D166 ; SpacingMark # Mc MUSICAL SYMBOL COMBINING SPRECHGESANG STEM
1D16D ; SpacingMark # Mc MUSICAL SYMBOL COMBINING AUGMENTATION DOT
-# Total code points: 275
+# Total code points: 291
# ================================================
Property changes on: trunk/contrib/perl/lib/unicore/auxiliary/GraphemeBreakProperty.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/auxiliary/SentenceBreakProperty.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/auxiliary/SentenceBreakProperty.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/auxiliary/SentenceBreakProperty.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,8 +1,8 @@
-# SentenceBreakProperty-6.0.0.txt
-# Date: 2010-08-19, 00:48:47 GMT [MD]
+# SentenceBreakProperty-6.2.0.txt
+# Date: 2012-05-23, 20:35:14 GMT [MD]
#
# Unicode Character Database
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
# For documentation, see http://www.unicode.org/reports/tr44/
@@ -53,6 +53,7 @@
0825..0827 ; Extend # Mn [3] SAMARITAN VOWEL SIGN SHORT A..SAMARITAN VOWEL SIGN U
0829..082D ; Extend # Mn [5] SAMARITAN VOWEL SIGN LONG I..SAMARITAN MARK NEQUDAA
0859..085B ; Extend # Mn [3] MANDAIC AFFRICATION MARK..MANDAIC GEMINATION MARK
+08E4..08FE ; Extend # Mn [27] ARABIC CURLY FATHA..ARABIC DAMMA WITH DOT
0900..0902 ; Extend # Mn [3] DEVANAGARI SIGN INVERTED CANDRABINDU..DEVANAGARI SIGN ANUSVARA
0903 ; Extend # Mc DEVANAGARI SIGN VISARGA
093A ; Extend # Mn DEVANAGARI VOWEL SIGN OE
@@ -195,6 +196,7 @@
1732..1734 ; Extend # Mn [3] HANUNOO VOWEL SIGN I..HANUNOO SIGN PAMUDPOD
1752..1753 ; Extend # Mn [2] BUHID VOWEL SIGN I..BUHID VOWEL SIGN U
1772..1773 ; Extend # Mn [2] TAGBANWA VOWEL SIGN I..TAGBANWA VOWEL SIGN U
+17B4..17B5 ; Extend # Mn [2] KHMER VOWEL INHERENT AQ..KHMER VOWEL INHERENT AA
17B6 ; Extend # Mc KHMER VOWEL SIGN AA
17B7..17BD ; Extend # Mn [7] KHMER VOWEL SIGN I..KHMER VOWEL SIGN UA
17BE..17C5 ; Extend # Mc [8] KHMER VOWEL SIGN OE..KHMER VOWEL SIGN AU
@@ -246,6 +248,8 @@
1BA6..1BA7 ; Extend # Mc [2] SUNDANESE VOWEL SIGN PANAELAENG..SUNDANESE VOWEL SIGN PANOLONG
1BA8..1BA9 ; Extend # Mn [2] SUNDANESE VOWEL SIGN PAMEPET..SUNDANESE VOWEL SIGN PANEULEUNG
1BAA ; Extend # Mc SUNDANESE SIGN PAMAAEH
+1BAB ; Extend # Mn SUNDANESE SIGN VIRAMA
+1BAC..1BAD ; Extend # Mc [2] SUNDANESE CONSONANT SIGN PASANGAN MA..SUNDANESE CONSONANT SIGN PASANGAN WA
1BE6 ; Extend # Mn BATAK SIGN TOMPI
1BE7 ; Extend # Mc BATAK VOWEL SIGN E
1BE8..1BE9 ; Extend # Mn [2] BATAK VOWEL SIGN PAKPAK E..BATAK VOWEL SIGN EE
@@ -263,7 +267,8 @@
1CE1 ; Extend # Mc VEDIC TONE ATHARVAVEDIC INDEPENDENT SVARITA
1CE2..1CE8 ; Extend # Mn [7] VEDIC SIGN VISARGA SVARITA..VEDIC SIGN VISARGA ANUDATTA WITH TAIL
1CED ; Extend # Mn VEDIC SIGN TIRYAK
-1CF2 ; Extend # Mc VEDIC SIGN ARDHAVISARGA
+1CF2..1CF3 ; Extend # Mc [2] VEDIC SIGN ARDHAVISARGA..VEDIC SIGN ROTATED ARDHAVISARGA
+1CF4 ; Extend # Mn VEDIC TONE CANDRA ABOVE
1DC0..1DE6 ; Extend # Mn [39] COMBINING DOTTED GRAVE ACCENT..COMBINING LATIN SMALL LETTER Z
1DFC..1DFF ; Extend # Mn [4] COMBINING DOUBLE INVERTED BREVE BELOW..COMBINING RIGHT ARROWHEAD AND DOWN ARROWHEAD BELOW
200C..200D ; Extend # Cf [2] ZERO WIDTH NON-JOINER..ZERO WIDTH JOINER
@@ -275,11 +280,13 @@
2CEF..2CF1 ; Extend # Mn [3] COPTIC COMBINING NI ABOVE..COPTIC COMBINING SPIRITUS LENIS
2D7F ; Extend # Mn TIFINAGH CONSONANT JOINER
2DE0..2DFF ; Extend # Mn [32] COMBINING CYRILLIC LETTER BE..COMBINING CYRILLIC LETTER IOTIFIED BIG YUS
-302A..302F ; Extend # Mn [6] IDEOGRAPHIC LEVEL TONE MARK..HANGUL DOUBLE DOT TONE MARK
+302A..302D ; Extend # Mn [4] IDEOGRAPHIC LEVEL TONE MARK..IDEOGRAPHIC ENTERING TONE MARK
+302E..302F ; Extend # Mc [2] HANGUL SINGLE DOT TONE MARK..HANGUL DOUBLE DOT TONE MARK
3099..309A ; Extend # Mn [2] COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK..COMBINING KATAKANA-HIRAGANA SEMI-VOICED SOUND MARK
A66F ; Extend # Mn COMBINING CYRILLIC VZMET
A670..A672 ; Extend # Me [3] COMBINING CYRILLIC TEN MILLIONS SIGN..COMBINING CYRILLIC THOUSAND MILLIONS SIGN
-A67C..A67D ; Extend # Mn [2] COMBINING CYRILLIC KAVYKA..COMBINING CYRILLIC PAYEROK
+A674..A67D ; Extend # Mn [10] COMBINING CYRILLIC LETTER UKRAINIAN IE..COMBINING CYRILLIC PAYEROK
+A69F ; Extend # Mn COMBINING CYRILLIC LETTER IOTIFIED E
A6F0..A6F1 ; Extend # Mn [2] BAMUM COMBINING MARK KOQNDON..BAMUM COMBINING MARK TUKWENTIS
A802 ; Extend # Mn SYLOTI NAGRI SIGN DVISVARA
A806 ; Extend # Mn SYLOTI NAGRI SIGN HASANTA
@@ -316,6 +323,11 @@
AAB7..AAB8 ; Extend # Mn [2] TAI VIET MAI KHIT..TAI VIET VOWEL IA
AABE..AABF ; Extend # Mn [2] TAI VIET VOWEL AM..TAI VIET TONE MAI EK
AAC1 ; Extend # Mn TAI VIET TONE MAI THO
+AAEB ; Extend # Mc MEETEI MAYEK VOWEL SIGN II
+AAEC..AAED ; Extend # Mn [2] MEETEI MAYEK VOWEL SIGN UU..MEETEI MAYEK VOWEL SIGN AAI
+AAEE..AAEF ; Extend # Mc [2] MEETEI MAYEK VOWEL SIGN AU..MEETEI MAYEK VOWEL SIGN AAU
+AAF5 ; Extend # Mc MEETEI MAYEK VOWEL SIGN VISARGA
+AAF6 ; Extend # Mn MEETEI MAYEK VIRAMA
ABE3..ABE4 ; Extend # Mc [2] MEETEI MAYEK VOWEL SIGN ONAP..MEETEI MAYEK VOWEL SIGN INAP
ABE5 ; Extend # Mn MEETEI MAYEK VOWEL SIGN ANAP
ABE6..ABE7 ; Extend # Mc [2] MEETEI MAYEK VOWEL SIGN YENAP..MEETEI MAYEK VOWEL SIGN SOUNAP
@@ -343,6 +355,24 @@
110B3..110B6 ; Extend # Mn [4] KAITHI VOWEL SIGN U..KAITHI VOWEL SIGN AI
110B7..110B8 ; Extend # Mc [2] KAITHI VOWEL SIGN O..KAITHI VOWEL SIGN AU
110B9..110BA ; Extend # Mn [2] KAITHI SIGN VIRAMA..KAITHI SIGN NUKTA
+11100..11102 ; Extend # Mn [3] CHAKMA SIGN CANDRABINDU..CHAKMA SIGN VISARGA
+11127..1112B ; Extend # Mn [5] CHAKMA VOWEL SIGN A..CHAKMA VOWEL SIGN UU
+1112C ; Extend # Mc CHAKMA VOWEL SIGN E
+1112D..11134 ; Extend # Mn [8] CHAKMA VOWEL SIGN AI..CHAKMA MAAYYAA
+11180..11181 ; Extend # Mn [2] SHARADA SIGN CANDRABINDU..SHARADA SIGN ANUSVARA
+11182 ; Extend # Mc SHARADA SIGN VISARGA
+111B3..111B5 ; Extend # Mc [3] SHARADA VOWEL SIGN AA..SHARADA VOWEL SIGN II
+111B6..111BE ; Extend # Mn [9] SHARADA VOWEL SIGN U..SHARADA VOWEL SIGN O
+111BF..111C0 ; Extend # Mc [2] SHARADA VOWEL SIGN AU..SHARADA SIGN VIRAMA
+116AB ; Extend # Mn TAKRI SIGN ANUSVARA
+116AC ; Extend # Mc TAKRI SIGN VISARGA
+116AD ; Extend # Mn TAKRI VOWEL SIGN AA
+116AE..116AF ; Extend # Mc [2] TAKRI VOWEL SIGN I..TAKRI VOWEL SIGN II
+116B0..116B5 ; Extend # Mn [6] TAKRI VOWEL SIGN U..TAKRI VOWEL SIGN AU
+116B6 ; Extend # Mc TAKRI SIGN VIRAMA
+116B7 ; Extend # Mn TAKRI SIGN NUKTA
+16F51..16F7E ; Extend # Mc [46] MIAO SIGN ASPIRATION..MIAO VOWEL SIGN NG
+16F8F..16F92 ; Extend # Mn [4] MIAO TONE RIGHT..MIAO TONE BELOW
1D165..1D166 ; Extend # Mc [2] MUSICAL SYMBOL COMBINING STEM..MUSICAL SYMBOL COMBINING SPRECHGESANG STEM
1D167..1D169 ; Extend # Mn [3] MUSICAL SYMBOL COMBINING TREMOLO-1..MUSICAL SYMBOL COMBINING TREMOLO-3
1D16D..1D172 ; Extend # Mc [6] MUSICAL SYMBOL COMBINING AUGMENTATION DOT..MUSICAL SYMBOL COMBINING FLAG-5
@@ -352,7 +382,7 @@
1D242..1D244 ; Extend # Mn [3] COMBINING GREEK MUSICAL TRISEME..COMBINING GREEK MUSICAL PENTASEME
E0100..E01EF ; Extend # Mn [240] VARIATION SELECTOR-17..VARIATION SELECTOR-256
-# Total code points: 1502
+# Total code points: 1649
# ================================================
@@ -365,10 +395,9 @@
# ================================================
00AD ; Format # Cf SOFT HYPHEN
-0600..0603 ; Format # Cf [4] ARABIC NUMBER SIGN..ARABIC SIGN SAFHA
+0600..0604 ; Format # Cf [5] ARABIC NUMBER SIGN..ARABIC SIGN SAMVAT
06DD ; Format # Cf ARABIC END OF AYAH
070F ; Format # Cf SYRIAC ABBREVIATION MARK
-17B4..17B5 ; Format # Cf [2] KHMER VOWEL INHERENT AQ..KHMER VOWEL INHERENT AA
200B ; Format # Cf ZERO WIDTH SPACE
200E..200F ; Format # Cf [2] LEFT-TO-RIGHT MARK..RIGHT-TO-LEFT MARK
202A..202E ; Format # Cf [5] LEFT-TO-RIGHT EMBEDDING..RIGHT-TO-LEFT OVERRIDE
@@ -381,7 +410,7 @@
E0001 ; Format # Cf LANGUAGE TAG
E0020..E007F ; Format # Cf [96] TAG SPACE..CANCEL TAG
-# Total code points: 138
+# Total code points: 137
# ================================================
@@ -401,9 +430,9 @@
# ================================================
0061..007A ; Lower # L& [26] LATIN SMALL LETTER A..LATIN SMALL LETTER Z
-00AA ; Lower # L& FEMININE ORDINAL INDICATOR
+00AA ; Lower # Lo FEMININE ORDINAL INDICATOR
00B5 ; Lower # L& MICRO SIGN
-00BA ; Lower # L& MASCULINE ORDINAL INDICATOR
+00BA ; Lower # Lo MASCULINE ORDINAL INDICATOR
00DF..00F6 ; Lower # L& [24] LATIN SMALL LETTER SHARP S..LATIN SMALL LETTER O WITH DIAERESIS
00F8..00FF ; Lower # L& [8] LATIN SMALL LETTER O WITH STROKE..LATIN SMALL LETTER Y WITH DIAERESIS
0101 ; Lower # L& LATIN SMALL LETTER A WITH MACRON
@@ -673,8 +702,8 @@
0527 ; Lower # L& CYRILLIC SMALL LETTER SHHA WITH DESCENDER
0561..0587 ; Lower # L& [39] ARMENIAN SMALL LETTER AYB..ARMENIAN SMALL LIGATURE ECH YIWN
1D00..1D2B ; Lower # L& [44] LATIN LETTER SMALL CAPITAL A..CYRILLIC LETTER SMALL CAPITAL EL
-1D2C..1D61 ; Lower # Lm [54] MODIFIER LETTER CAPITAL A..MODIFIER LETTER SMALL CHI
-1D62..1D77 ; Lower # L& [22] LATIN SUBSCRIPT SMALL LETTER I..LATIN SMALL LETTER TURNED G
+1D2C..1D6A ; Lower # Lm [63] MODIFIER LETTER CAPITAL A..GREEK SUBSCRIPT SMALL LETTER CHI
+1D6B..1D77 ; Lower # L& [13] LATIN SMALL LETTER UE..LATIN SMALL LETTER TURNED G
1D78 ; Lower # Lm MODIFIER LETTER CYRILLIC EN
1D79..1D9A ; Lower # L& [34] LATIN SMALL LETTER INSULAR G..LATIN SMALL LETTER EZH WITH RETROFLEX HOOK
1D9B..1DBF ; Lower # Lm [37] MODIFIER LETTER SMALL TURNED ALPHA..MODIFIER LETTER SMALL THETA
@@ -822,7 +851,9 @@
1FE0..1FE7 ; Lower # L& [8] GREEK SMALL LETTER UPSILON WITH VRACHY..GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI
1FF2..1FF4 ; Lower # L& [3] GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI..GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI
1FF6..1FF7 ; Lower # L& [2] GREEK SMALL LETTER OMEGA WITH PERISPOMENI..GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI
-2090..2094 ; Lower # Lm [5] LATIN SUBSCRIPT SMALL LETTER A..LATIN SUBSCRIPT SMALL LETTER SCHWA
+2071 ; Lower # Lm SUPERSCRIPT LATIN SMALL LETTER I
+207F ; Lower # Lm SUPERSCRIPT LATIN SMALL LETTER N
+2090..209C ; Lower # Lm [13] LATIN SUBSCRIPT SMALL LETTER A..LATIN SUBSCRIPT SMALL LETTER T
210A ; Lower # L& SCRIPT SMALL G
210E..210F ; Lower # L& [2] PLANCK CONSTANT..PLANCK CONSTANT OVER TWO PI
2113 ; Lower # L& SCRIPT SMALL L
@@ -843,8 +874,8 @@
2C6C ; Lower # L& LATIN SMALL LETTER Z WITH DESCENDER
2C71 ; Lower # L& LATIN SMALL LETTER V WITH RIGHT HOOK
2C73..2C74 ; Lower # L& [2] LATIN SMALL LETTER W WITH HOOK..LATIN SMALL LETTER V WITH CURL
-2C76..2C7C ; Lower # L& [7] LATIN SMALL LETTER HALF H..LATIN SUBSCRIPT SMALL LETTER J
-2C7D ; Lower # Lm MODIFIER LETTER CAPITAL V
+2C76..2C7B ; Lower # L& [6] LATIN SMALL LETTER HALF H..LATIN LETTER SMALL CAPITAL TURNED E
+2C7C..2C7D ; Lower # Lm [2] LATIN SUBSCRIPT SMALL LETTER J..MODIFIER LETTER CAPITAL V
2C81 ; Lower # L& COPTIC SMALL LETTER ALFA
2C83 ; Lower # L& COPTIC SMALL LETTER VIDA
2C85 ; Lower # L& COPTIC SMALL LETTER GAMMA
@@ -897,7 +928,10 @@
2CE3..2CE4 ; Lower # L& [2] COPTIC SMALL LETTER OLD NUBIAN WAU..COPTIC SYMBOL KAI
2CEC ; Lower # L& COPTIC SMALL LETTER CRYPTOGRAMMIC SHEI
2CEE ; Lower # L& COPTIC SMALL LETTER CRYPTOGRAMMIC GANGIA
+2CF3 ; Lower # L& COPTIC SMALL LETTER BOHAIRIC KHEI
2D00..2D25 ; Lower # L& [38] GEORGIAN SMALL LETTER AN..GEORGIAN SMALL LETTER HOE
+2D27 ; Lower # L& GEORGIAN SMALL LETTER YN
+2D2D ; Lower # L& GEORGIAN SMALL LETTER AEN
A641 ; Lower # L& CYRILLIC SMALL LETTER ZEMLYA
A643 ; Lower # L& CYRILLIC SMALL LETTER DZELO
A645 ; Lower # L& CYRILLIC SMALL LETTER REVERSED DZE
@@ -983,11 +1017,13 @@
A78C ; Lower # L& LATIN SMALL LETTER SALTILLO
A78E ; Lower # L& LATIN SMALL LETTER L WITH RETROFLEX HOOK AND BELT
A791 ; Lower # L& LATIN SMALL LETTER N WITH DESCENDER
+A793 ; Lower # L& LATIN SMALL LETTER C WITH BAR
A7A1 ; Lower # L& LATIN SMALL LETTER G WITH OBLIQUE STROKE
A7A3 ; Lower # L& LATIN SMALL LETTER K WITH OBLIQUE STROKE
A7A5 ; Lower # L& LATIN SMALL LETTER N WITH OBLIQUE STROKE
A7A7 ; Lower # L& LATIN SMALL LETTER R WITH OBLIQUE STROKE
A7A9 ; Lower # L& LATIN SMALL LETTER S WITH OBLIQUE STROKE
+A7F8..A7F9 ; Lower # Lm [2] MODIFIER LETTER CAPITAL H WITH STROKE..MODIFIER LETTER SMALL LIGATURE OE
A7FA ; Lower # L& LATIN LETTER SMALL CAPITAL TURNED M
FB00..FB06 ; Lower # L& [7] LATIN SMALL LIGATURE FF..LATIN SMALL LIGATURE ST
FB13..FB17 ; Lower # L& [5] ARMENIAN SMALL LIGATURE MEN NOW..ARMENIAN SMALL LIGATURE MEN XEH
@@ -1022,7 +1058,7 @@
1D7C4..1D7C9 ; Lower # L& [6] MATHEMATICAL SANS-SERIF BOLD ITALIC EPSILON SYMBOL..MATHEMATICAL SANS-SERIF BOLD ITALIC PI SYMBOL
1D7CB ; Lower # L& MATHEMATICAL BOLD SMALL DIGAMMA
-# Total code points: 1917
+# Total code points: 1933
# ================================================
@@ -1294,6 +1330,8 @@
0526 ; Upper # L& CYRILLIC CAPITAL LETTER SHHA WITH DESCENDER
0531..0556 ; Upper # L& [38] ARMENIAN CAPITAL LETTER AYB..ARMENIAN CAPITAL LETTER FEH
10A0..10C5 ; Upper # L& [38] GEORGIAN CAPITAL LETTER AN..GEORGIAN CAPITAL LETTER HOE
+10C7 ; Upper # L& GEORGIAN CAPITAL LETTER YN
+10CD ; Upper # L& GEORGIAN CAPITAL LETTER AEN
1E00 ; Upper # L& LATIN CAPITAL LETTER A WITH RING BELOW
1E02 ; Upper # L& LATIN CAPITAL LETTER B WITH DOT ABOVE
1E04 ; Upper # L& LATIN CAPITAL LETTER B WITH DOT BELOW
@@ -1513,6 +1551,7 @@
2CE2 ; Upper # L& COPTIC CAPITAL LETTER OLD NUBIAN WAU
2CEB ; Upper # L& COPTIC CAPITAL LETTER CRYPTOGRAMMIC SHEI
2CED ; Upper # L& COPTIC CAPITAL LETTER CRYPTOGRAMMIC GANGIA
+2CF2 ; Upper # L& COPTIC CAPITAL LETTER BOHAIRIC KHEI
A640 ; Upper # L& CYRILLIC CAPITAL LETTER ZEMLYA
A642 ; Upper # L& CYRILLIC CAPITAL LETTER DZELO
A644 ; Upper # L& CYRILLIC CAPITAL LETTER REVERSED DZE
@@ -1596,11 +1635,13 @@
A78B ; Upper # L& LATIN CAPITAL LETTER SALTILLO
A78D ; Upper # L& LATIN CAPITAL LETTER TURNED H
A790 ; Upper # L& LATIN CAPITAL LETTER N WITH DESCENDER
+A792 ; Upper # L& LATIN CAPITAL LETTER C WITH BAR
A7A0 ; Upper # L& LATIN CAPITAL LETTER G WITH OBLIQUE STROKE
A7A2 ; Upper # L& LATIN CAPITAL LETTER K WITH OBLIQUE STROKE
A7A4 ; Upper # L& LATIN CAPITAL LETTER N WITH OBLIQUE STROKE
A7A6 ; Upper # L& LATIN CAPITAL LETTER R WITH OBLIQUE STROKE
A7A8 ; Upper # L& LATIN CAPITAL LETTER S WITH OBLIQUE STROKE
+A7AA ; Upper # L& LATIN CAPITAL LETTER H WITH HOOK
FF21..FF3A ; Upper # L& [26] FULLWIDTH LATIN CAPITAL LETTER A..FULLWIDTH LATIN CAPITAL LETTER Z
10400..10427 ; Upper # L& [40] DESERET CAPITAL LETTER LONG I..DESERET CAPITAL LETTER EW
1D400..1D419 ; Upper # L& [26] MATHEMATICAL BOLD CAPITAL A..MATHEMATICAL BOLD CAPITAL Z
@@ -1635,7 +1676,7 @@
1D790..1D7A8 ; Upper # L& [25] MATHEMATICAL SANS-SERIF BOLD ITALIC CAPITAL ALPHA..MATHEMATICAL SANS-SERIF BOLD ITALIC CAPITAL OMEGA
1D7CA ; Upper # L& MATHEMATICAL BOLD CAPITAL DIGAMMA
-# Total code points: 1509
+# Total code points: 1514
# ================================================
@@ -1673,6 +1714,8 @@
0824 ; OLetter # Lm SAMARITAN MODIFIER LETTER SHORT A
0828 ; OLetter # Lm SAMARITAN MODIFIER LETTER I
0840..0858 ; OLetter # Lo [25] MANDAIC LETTER HALQA..MANDAIC LETTER AIN
+08A0 ; OLetter # Lo ARABIC LETTER BEH WITH SMALL V BELOW
+08A2..08AC ; OLetter # Lo [11] ARABIC LETTER JEEM WITH TWO DOTS ABOVE..ARABIC LETTER ROHINGYA YEH
0904..0939 ; OLetter # Lo [54] DEVANAGARI LETTER SHORT A..DEVANAGARI LETTER HA
093D ; OLetter # Lo DEVANAGARI SIGN AVAGRAHA
0950 ; OLetter # Lo DEVANAGARI OM
@@ -1780,7 +1823,7 @@
0EBD ; OLetter # Lo LAO SEMIVOWEL SIGN NYO
0EC0..0EC4 ; OLetter # Lo [5] LAO VOWEL SIGN E..LAO VOWEL SIGN AI
0EC6 ; OLetter # Lm LAO KO LA
-0EDC..0EDD ; OLetter # Lo [2] LAO HO NO..LAO HO MO
+0EDC..0EDF ; OLetter # Lo [4] LAO HO NO..LAO LETTER KHMU NYO
0F00 ; OLetter # Lo TIBETAN SYLLABLE OM
0F40..0F47 ; OLetter # Lo [8] TIBETAN LETTER KA..TIBETAN LETTER JA
0F49..0F6C ; OLetter # Lo [36] TIBETAN LETTER NYA..TIBETAN LETTER RRA
@@ -1796,7 +1839,7 @@
108E ; OLetter # Lo MYANMAR LETTER RUMAI PALAUNG FA
10D0..10FA ; OLetter # Lo [43] GEORGIAN LETTER AN..GEORGIAN LETTER AIN
10FC ; OLetter # Lm MODIFIER LETTER GEORGIAN NAR
-1100..1248 ; OLetter # Lo [329] HANGUL CHOSEONG KIYEOK..ETHIOPIC SYLLABLE QWA
+10FD..1248 ; OLetter # Lo [332] GEORGIAN LETTER AEN..ETHIOPIC SYLLABLE QWA
124A..124D ; OLetter # Lo [4] ETHIOPIC SYLLABLE QWI..ETHIOPIC SYLLABLE QWE
1250..1256 ; OLetter # Lo [7] ETHIOPIC SYLLABLE QHA..ETHIOPIC SYLLABLE QHO
1258 ; OLetter # Lo ETHIOPIC SYLLABLE QHWA
@@ -1846,7 +1889,7 @@
1B45..1B4B ; OLetter # Lo [7] BALINESE LETTER KAF SASAK..BALINESE LETTER ASYURA SASAK
1B83..1BA0 ; OLetter # Lo [30] SUNDANESE LETTER A..SUNDANESE LETTER HA
1BAE..1BAF ; OLetter # Lo [2] SUNDANESE LETTER KHA..SUNDANESE LETTER SYA
-1BC0..1BE5 ; OLetter # Lo [38] BATAK LETTER A..BATAK LETTER U
+1BBA..1BE5 ; OLetter # Lo [44] SUNDANESE AVAGRAHA..BATAK LETTER U
1C00..1C23 ; OLetter # Lo [36] LEPCHA LETTER KA..LEPCHA LETTER A
1C4D..1C4F ; OLetter # Lo [3] LEPCHA LETTER TTA..LEPCHA LETTER DDA
1C5A..1C77 ; OLetter # Lo [30] OL CHIKI LETTER LA..OL CHIKI LETTER OH
@@ -1853,13 +1896,11 @@
1C78..1C7D ; OLetter # Lm [6] OL CHIKI MU TTUDDAG..OL CHIKI AHAD
1CE9..1CEC ; OLetter # Lo [4] VEDIC SIGN ANUSVARA ANTARGOMUKHA..VEDIC SIGN ANUSVARA VAMAGOMUKHA WITH TAIL
1CEE..1CF1 ; OLetter # Lo [4] VEDIC SIGN HEXIFORM LONG ANUSVARA..VEDIC SIGN ANUSVARA UBHAYATO MUKHA
-2071 ; OLetter # Lm SUPERSCRIPT LATIN SMALL LETTER I
-207F ; OLetter # Lm SUPERSCRIPT LATIN SMALL LETTER N
-2095..209C ; OLetter # Lm [8] LATIN SUBSCRIPT SMALL LETTER H..LATIN SUBSCRIPT SMALL LETTER T
+1CF5..1CF6 ; OLetter # Lo [2] VEDIC SIGN JIHVAMULIYA..VEDIC SIGN UPADHMANIYA
2135..2138 ; OLetter # Lo [4] ALEF SYMBOL..DALET SYMBOL
2180..2182 ; OLetter # Nl [3] ROMAN NUMERAL ONE THOUSAND C D..ROMAN NUMERAL TEN THOUSAND
2185..2188 ; OLetter # Nl [4] ROMAN NUMERAL SIX LATE FORM..ROMAN NUMERAL ONE HUNDRED THOUSAND
-2D30..2D65 ; OLetter # Lo [54] TIFINAGH LETTER YA..TIFINAGH LETTER YAZZ
+2D30..2D67 ; OLetter # Lo [56] TIFINAGH LETTER YA..TIFINAGH LETTER YO
2D6F ; OLetter # Lm TIFINAGH MODIFIER LETTER LABIALIZATION MARK
2D80..2D96 ; OLetter # Lo [23] ETHIOPIC SYLLABLE LOA..ETHIOPIC SYLLABLE GGWE
2DA0..2DA6 ; OLetter # Lo [7] ETHIOPIC SYLLABLE SSA..ETHIOPIC SYLLABLE SSO
@@ -1890,7 +1931,7 @@
31A0..31BA ; OLetter # Lo [27] BOPOMOFO LETTER BU..BOPOMOFO LETTER ZY
31F0..31FF ; OLetter # Lo [16] KATAKANA LETTER SMALL KU..KATAKANA LETTER SMALL RO
3400..4DB5 ; OLetter # Lo [6582] CJK UNIFIED IDEOGRAPH-3400..CJK UNIFIED IDEOGRAPH-4DB5
-4E00..9FCB ; OLetter # Lo [20940] CJK UNIFIED IDEOGRAPH-4E00..CJK UNIFIED IDEOGRAPH-9FCB
+4E00..9FCC ; OLetter # Lo [20941] CJK UNIFIED IDEOGRAPH-4E00..CJK UNIFIED IDEOGRAPH-9FCC
A000..A014 ; OLetter # Lo [21] YI SYLLABLE IT..YI SYLLABLE E
A015 ; OLetter # Lm YI SYLLABLE WU
A016..A48C ; OLetter # Lo [1143] YI SYLLABLE BIT..YI SYLLABLE YYR
@@ -1934,6 +1975,9 @@
AAC2 ; OLetter # Lo TAI VIET TONE MAI SONG
AADB..AADC ; OLetter # Lo [2] TAI VIET SYMBOL KON..TAI VIET SYMBOL NUENG
AADD ; OLetter # Lm TAI VIET SYMBOL SAM
+AAE0..AAEA ; OLetter # Lo [11] MEETEI MAYEK LETTER E..MEETEI MAYEK LETTER SSA
+AAF2 ; OLetter # Lo MEETEI MAYEK ANJI
+AAF3..AAF4 ; OLetter # Lm [2] MEETEI MAYEK SYLLABLE REPETITION MARK..MEETEI MAYEK WORD REPETITION MARK
AB01..AB06 ; OLetter # Lo [6] ETHIOPIC SYLLABLE TTHU..ETHIOPIC SYLLABLE TTHO
AB09..AB0E ; OLetter # Lo [6] ETHIOPIC SYLLABLE DDHU..ETHIOPIC SYLLABLE DDHO
AB11..AB16 ; OLetter # Lo [6] ETHIOPIC SYLLABLE DZU..ETHIOPIC SYLLABLE DZO
@@ -1943,8 +1987,7 @@
AC00..D7A3 ; OLetter # Lo [11172] HANGUL SYLLABLE GA..HANGUL SYLLABLE HIH
D7B0..D7C6 ; OLetter # Lo [23] HANGUL JUNGSEONG O-YEO..HANGUL JUNGSEONG ARAEA-E
D7CB..D7FB ; OLetter # Lo [49] HANGUL JONGSEONG NIEUN-RIEUL..HANGUL JONGSEONG PHIEUPH-THIEUTH
-F900..FA2D ; OLetter # Lo [302] CJK COMPATIBILITY IDEOGRAPH-F900..CJK COMPATIBILITY IDEOGRAPH-FA2D
-FA30..FA6D ; OLetter # Lo [62] CJK COMPATIBILITY IDEOGRAPH-FA30..CJK COMPATIBILITY IDEOGRAPH-FA6D
+F900..FA6D ; OLetter # Lo [366] CJK COMPATIBILITY IDEOGRAPH-F900..CJK COMPATIBILITY IDEOGRAPH-FA6D
FA70..FAD9 ; OLetter # Lo [106] CJK COMPATIBILITY IDEOGRAPH-FA70..CJK COMPATIBILITY IDEOGRAPH-FAD9
FB1D ; OLetter # Lo HEBREW LETTER YOD WITH HIRIQ
FB1F..FB28 ; OLetter # Lo [10] HEBREW LIGATURE YIDDISH YOD YOD PATAH..HEBREW LETTER WIDE TAV
@@ -1996,6 +2039,8 @@
1083F..10855 ; OLetter # Lo [23] CYPRIOT SYLLABLE ZO..IMPERIAL ARAMAIC LETTER TAW
10900..10915 ; OLetter # Lo [22] PHOENICIAN LETTER ALF..PHOENICIAN LETTER TAU
10920..10939 ; OLetter # Lo [26] LYDIAN LETTER A..LYDIAN LETTER C
+10980..109B7 ; OLetter # Lo [56] MEROITIC HIEROGLYPHIC LETTER A..MEROITIC CURSIVE LETTER DA
+109BE..109BF ; OLetter # Lo [2] MEROITIC CURSIVE LOGOGRAM RMT..MEROITIC CURSIVE LOGOGRAM IMN
10A00 ; OLetter # Lo KHAROSHTHI LETTER A
10A10..10A13 ; OLetter # Lo [4] KHAROSHTHI LETTER KA..KHAROSHTHI LETTER GHA
10A15..10A17 ; OLetter # Lo [3] KHAROSHTHI LETTER CA..KHAROSHTHI LETTER JA
@@ -2007,17 +2052,58 @@
10C00..10C48 ; OLetter # Lo [73] OLD TURKIC LETTER ORKHON A..OLD TURKIC LETTER ORKHON BASH
11003..11037 ; OLetter # Lo [53] BRAHMI SIGN JIHVAMULIYA..BRAHMI LETTER OLD TAMIL NNNA
11083..110AF ; OLetter # Lo [45] KAITHI LETTER A..KAITHI LETTER HA
+110D0..110E8 ; OLetter # Lo [25] SORA SOMPENG LETTER SAH..SORA SOMPENG LETTER MAE
+11103..11126 ; OLetter # Lo [36] CHAKMA LETTER AA..CHAKMA LETTER HAA
+11183..111B2 ; OLetter # Lo [48] SHARADA LETTER A..SHARADA LETTER HA
+111C1..111C4 ; OLetter # Lo [4] SHARADA SIGN AVAGRAHA..SHARADA OM
+11680..116AA ; OLetter # Lo [43] TAKRI LETTER A..TAKRI LETTER RRA
12000..1236E ; OLetter # Lo [879] CUNEIFORM SIGN A..CUNEIFORM SIGN ZUM
12400..12462 ; OLetter # Nl [99] CUNEIFORM NUMERIC SIGN TWO ASH..CUNEIFORM NUMERIC SIGN OLD ASSYRIAN ONE QUARTER
13000..1342E ; OLetter # Lo [1071] EGYPTIAN HIEROGLYPH A001..EGYPTIAN HIEROGLYPH AA032
16800..16A38 ; OLetter # Lo [569] BAMUM LETTER PHASE-A NGKUE MFON..BAMUM LETTER PHASE-F VUEQ
+16F00..16F44 ; OLetter # Lo [69] MIAO LETTER PA..MIAO LETTER HHA
+16F50 ; OLetter # Lo MIAO LETTER NASALIZATION
+16F93..16F9F ; OLetter # Lm [13] MIAO LETTER TONE-2..MIAO LETTER REFORMED TONE-8
1B000..1B001 ; OLetter # Lo [2] KATAKANA LETTER ARCHAIC E..HIRAGANA LETTER ARCHAIC YE
+1EE00..1EE03 ; OLetter # Lo [4] ARABIC MATHEMATICAL ALEF..ARABIC MATHEMATICAL DAL
+1EE05..1EE1F ; OLetter # Lo [27] ARABIC MATHEMATICAL WAW..ARABIC MATHEMATICAL DOTLESS QAF
+1EE21..1EE22 ; OLetter # Lo [2] ARABIC MATHEMATICAL INITIAL BEH..ARABIC MATHEMATICAL INITIAL JEEM
+1EE24 ; OLetter # Lo ARABIC MATHEMATICAL INITIAL HEH
+1EE27 ; OLetter # Lo ARABIC MATHEMATICAL INITIAL HAH
+1EE29..1EE32 ; OLetter # Lo [10] ARABIC MATHEMATICAL INITIAL YEH..ARABIC MATHEMATICAL INITIAL QAF
+1EE34..1EE37 ; OLetter # Lo [4] ARABIC MATHEMATICAL INITIAL SHEEN..ARABIC MATHEMATICAL INITIAL KHAH
+1EE39 ; OLetter # Lo ARABIC MATHEMATICAL INITIAL DAD
+1EE3B ; OLetter # Lo ARABIC MATHEMATICAL INITIAL GHAIN
+1EE42 ; OLetter # Lo ARABIC MATHEMATICAL TAILED JEEM
+1EE47 ; OLetter # Lo ARABIC MATHEMATICAL TAILED HAH
+1EE49 ; OLetter # Lo ARABIC MATHEMATICAL TAILED YEH
+1EE4B ; OLetter # Lo ARABIC MATHEMATICAL TAILED LAM
+1EE4D..1EE4F ; OLetter # Lo [3] ARABIC MATHEMATICAL TAILED NOON..ARABIC MATHEMATICAL TAILED AIN
+1EE51..1EE52 ; OLetter # Lo [2] ARABIC MATHEMATICAL TAILED SAD..ARABIC MATHEMATICAL TAILED QAF
+1EE54 ; OLetter # Lo ARABIC MATHEMATICAL TAILED SHEEN
+1EE57 ; OLetter # Lo ARABIC MATHEMATICAL TAILED KHAH
+1EE59 ; OLetter # Lo ARABIC MATHEMATICAL TAILED DAD
+1EE5B ; OLetter # Lo ARABIC MATHEMATICAL TAILED GHAIN
+1EE5D ; OLetter # Lo ARABIC MATHEMATICAL TAILED DOTLESS NOON
+1EE5F ; OLetter # Lo ARABIC MATHEMATICAL TAILED DOTLESS QAF
+1EE61..1EE62 ; OLetter # Lo [2] ARABIC MATHEMATICAL STRETCHED BEH..ARABIC MATHEMATICAL STRETCHED JEEM
+1EE64 ; OLetter # Lo ARABIC MATHEMATICAL STRETCHED HEH
+1EE67..1EE6A ; OLetter # Lo [4] ARABIC MATHEMATICAL STRETCHED HAH..ARABIC MATHEMATICAL STRETCHED KAF
+1EE6C..1EE72 ; OLetter # Lo [7] ARABIC MATHEMATICAL STRETCHED MEEM..ARABIC MATHEMATICAL STRETCHED QAF
+1EE74..1EE77 ; OLetter # Lo [4] ARABIC MATHEMATICAL STRETCHED SHEEN..ARABIC MATHEMATICAL STRETCHED KHAH
+1EE79..1EE7C ; OLetter # Lo [4] ARABIC MATHEMATICAL STRETCHED DAD..ARABIC MATHEMATICAL STRETCHED DOTLESS BEH
+1EE7E ; OLetter # Lo ARABIC MATHEMATICAL STRETCHED DOTLESS FEH
+1EE80..1EE89 ; OLetter # Lo [10] ARABIC MATHEMATICAL LOOPED ALEF..ARABIC MATHEMATICAL LOOPED YEH
+1EE8B..1EE9B ; OLetter # Lo [17] ARABIC MATHEMATICAL LOOPED LAM..ARABIC MATHEMATICAL LOOPED GHAIN
+1EEA1..1EEA3 ; OLetter # Lo [3] ARABIC MATHEMATICAL DOUBLE-STRUCK BEH..ARABIC MATHEMATICAL DOUBLE-STRUCK DAL
+1EEA5..1EEA9 ; OLetter # Lo [5] ARABIC MATHEMATICAL DOUBLE-STRUCK WAW..ARABIC MATHEMATICAL DOUBLE-STRUCK YEH
+1EEAB..1EEBB ; OLetter # Lo [17] ARABIC MATHEMATICAL DOUBLE-STRUCK LAM..ARABIC MATHEMATICAL DOUBLE-STRUCK GHAIN
20000..2A6D6 ; OLetter # Lo [42711] CJK UNIFIED IDEOGRAPH-20000..CJK UNIFIED IDEOGRAPH-2A6D6
2A700..2B734 ; OLetter # Lo [4149] CJK UNIFIED IDEOGRAPH-2A700..CJK UNIFIED IDEOGRAPH-2B734
2B740..2B81D ; OLetter # Lo [222] CJK UNIFIED IDEOGRAPH-2B740..CJK UNIFIED IDEOGRAPH-2B81D
2F800..2FA1D ; OLetter # Lo [542] CJK COMPATIBILITY IDEOGRAPH-2F800..CJK COMPATIBILITY IDEOGRAPH-2FA1D
-# Total code points: 97369
+# Total code points: 97841
# ================================================
@@ -2058,9 +2144,13 @@
ABF0..ABF9 ; Numeric # Nd [10] MEETEI MAYEK DIGIT ZERO..MEETEI MAYEK DIGIT NINE
104A0..104A9 ; Numeric # Nd [10] OSMANYA DIGIT ZERO..OSMANYA DIGIT NINE
11066..1106F ; Numeric # Nd [10] BRAHMI DIGIT ZERO..BRAHMI DIGIT NINE
+110F0..110F9 ; Numeric # Nd [10] SORA SOMPENG DIGIT ZERO..SORA SOMPENG DIGIT NINE
+11136..1113F ; Numeric # Nd [10] CHAKMA DIGIT ZERO..CHAKMA DIGIT NINE
+111D0..111D9 ; Numeric # Nd [10] SHARADA DIGIT ZERO..SHARADA DIGIT NINE
+116C0..116C9 ; Numeric # Nd [10] TAKRI DIGIT ZERO..TAKRI DIGIT NINE
1D7CE..1D7FF ; Numeric # Nd [50] MATHEMATICAL BOLD DIGIT ZERO..MATHEMATICAL MONOSPACE DIGIT NINE
-# Total code points: 412
+# Total code points: 452
# ================================================
@@ -2109,6 +2199,7 @@
A92F ; STerm # Po KAYAH LI SIGN SHYA
A9C8..A9C9 ; STerm # Po [2] JAVANESE PADA LINGSA..JAVANESE PADA LUNGSI
AA5D..AA5F ; STerm # Po [3] CHAM PUNCTUATION DANDA..CHAM PUNCTUATION TRIPLE DANDA
+AAF0..AAF1 ; STerm # Po [2] MEETEI MAYEK CHEIKHAN..MEETEI MAYEK AHANG KHUDAM
ABEB ; STerm # Po MEETEI MAYEK CHEIKHEI
FE56..FE57 ; STerm # Po [2] SMALL QUESTION MARK..SMALL EXCLAMATION MARK
FF01 ; STerm # Po FULLWIDTH EXCLAMATION MARK
@@ -2117,8 +2208,10 @@
10A56..10A57 ; STerm # Po [2] KHAROSHTHI PUNCTUATION DANDA..KHAROSHTHI PUNCTUATION DOUBLE DANDA
11047..11048 ; STerm # Po [2] BRAHMI DANDA..BRAHMI DOUBLE DANDA
110BE..110C1 ; STerm # Po [4] KAITHI SECTION MARK..KAITHI DOUBLE DANDA
+11141..11143 ; STerm # Po [3] CHAKMA DANDA..CHAKMA QUESTION MARK
+111C5..111C6 ; STerm # Po [2] SHARADA DANDA..SHARADA DOUBLE DANDA
-# Total code points: 73
+# Total code points: 80
# ================================================
Property changes on: trunk/contrib/perl/lib/unicore/auxiliary/SentenceBreakProperty.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/auxiliary/WordBreakProperty.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/auxiliary/WordBreakProperty.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/auxiliary/WordBreakProperty.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,8 +1,8 @@
-# WordBreakProperty-6.0.0.txt
-# Date: 2010-08-19, 00:48:48 GMT [MD]
+# WordBreakProperty-6.2.0.txt
+# Date: 2012-08-13, 19:12:09 GMT [MD]
#
# Unicode Character Database
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
# For documentation, see http://www.unicode.org/reports/tr44/
@@ -62,6 +62,7 @@
0825..0827 ; Extend # Mn [3] SAMARITAN VOWEL SIGN SHORT A..SAMARITAN VOWEL SIGN U
0829..082D ; Extend # Mn [5] SAMARITAN VOWEL SIGN LONG I..SAMARITAN MARK NEQUDAA
0859..085B ; Extend # Mn [3] MANDAIC AFFRICATION MARK..MANDAIC GEMINATION MARK
+08E4..08FE ; Extend # Mn [27] ARABIC CURLY FATHA..ARABIC DAMMA WITH DOT
0900..0902 ; Extend # Mn [3] DEVANAGARI SIGN INVERTED CANDRABINDU..DEVANAGARI SIGN ANUSVARA
0903 ; Extend # Mc DEVANAGARI SIGN VISARGA
093A ; Extend # Mn DEVANAGARI VOWEL SIGN OE
@@ -204,6 +205,7 @@
1732..1734 ; Extend # Mn [3] HANUNOO VOWEL SIGN I..HANUNOO SIGN PAMUDPOD
1752..1753 ; Extend # Mn [2] BUHID VOWEL SIGN I..BUHID VOWEL SIGN U
1772..1773 ; Extend # Mn [2] TAGBANWA VOWEL SIGN I..TAGBANWA VOWEL SIGN U
+17B4..17B5 ; Extend # Mn [2] KHMER VOWEL INHERENT AQ..KHMER VOWEL INHERENT AA
17B6 ; Extend # Mc KHMER VOWEL SIGN AA
17B7..17BD ; Extend # Mn [7] KHMER VOWEL SIGN I..KHMER VOWEL SIGN UA
17BE..17C5 ; Extend # Mc [8] KHMER VOWEL SIGN OE..KHMER VOWEL SIGN AU
@@ -255,6 +257,8 @@
1BA6..1BA7 ; Extend # Mc [2] SUNDANESE VOWEL SIGN PANAELAENG..SUNDANESE VOWEL SIGN PANOLONG
1BA8..1BA9 ; Extend # Mn [2] SUNDANESE VOWEL SIGN PAMEPET..SUNDANESE VOWEL SIGN PANEULEUNG
1BAA ; Extend # Mc SUNDANESE SIGN PAMAAEH
+1BAB ; Extend # Mn SUNDANESE SIGN VIRAMA
+1BAC..1BAD ; Extend # Mc [2] SUNDANESE CONSONANT SIGN PASANGAN MA..SUNDANESE CONSONANT SIGN PASANGAN WA
1BE6 ; Extend # Mn BATAK SIGN TOMPI
1BE7 ; Extend # Mc BATAK VOWEL SIGN E
1BE8..1BE9 ; Extend # Mn [2] BATAK VOWEL SIGN PAKPAK E..BATAK VOWEL SIGN EE
@@ -272,7 +276,8 @@
1CE1 ; Extend # Mc VEDIC TONE ATHARVAVEDIC INDEPENDENT SVARITA
1CE2..1CE8 ; Extend # Mn [7] VEDIC SIGN VISARGA SVARITA..VEDIC SIGN VISARGA ANUDATTA WITH TAIL
1CED ; Extend # Mn VEDIC SIGN TIRYAK
-1CF2 ; Extend # Mc VEDIC SIGN ARDHAVISARGA
+1CF2..1CF3 ; Extend # Mc [2] VEDIC SIGN ARDHAVISARGA..VEDIC SIGN ROTATED ARDHAVISARGA
+1CF4 ; Extend # Mn VEDIC TONE CANDRA ABOVE
1DC0..1DE6 ; Extend # Mn [39] COMBINING DOTTED GRAVE ACCENT..COMBINING LATIN SMALL LETTER Z
1DFC..1DFF ; Extend # Mn [4] COMBINING DOUBLE INVERTED BREVE BELOW..COMBINING RIGHT ARROWHEAD AND DOWN ARROWHEAD BELOW
200C..200D ; Extend # Cf [2] ZERO WIDTH NON-JOINER..ZERO WIDTH JOINER
@@ -284,11 +289,13 @@
2CEF..2CF1 ; Extend # Mn [3] COPTIC COMBINING NI ABOVE..COPTIC COMBINING SPIRITUS LENIS
2D7F ; Extend # Mn TIFINAGH CONSONANT JOINER
2DE0..2DFF ; Extend # Mn [32] COMBINING CYRILLIC LETTER BE..COMBINING CYRILLIC LETTER IOTIFIED BIG YUS
-302A..302F ; Extend # Mn [6] IDEOGRAPHIC LEVEL TONE MARK..HANGUL DOUBLE DOT TONE MARK
+302A..302D ; Extend # Mn [4] IDEOGRAPHIC LEVEL TONE MARK..IDEOGRAPHIC ENTERING TONE MARK
+302E..302F ; Extend # Mc [2] HANGUL SINGLE DOT TONE MARK..HANGUL DOUBLE DOT TONE MARK
3099..309A ; Extend # Mn [2] COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK..COMBINING KATAKANA-HIRAGANA SEMI-VOICED SOUND MARK
A66F ; Extend # Mn COMBINING CYRILLIC VZMET
A670..A672 ; Extend # Me [3] COMBINING CYRILLIC TEN MILLIONS SIGN..COMBINING CYRILLIC THOUSAND MILLIONS SIGN
-A67C..A67D ; Extend # Mn [2] COMBINING CYRILLIC KAVYKA..COMBINING CYRILLIC PAYEROK
+A674..A67D ; Extend # Mn [10] COMBINING CYRILLIC LETTER UKRAINIAN IE..COMBINING CYRILLIC PAYEROK
+A69F ; Extend # Mn COMBINING CYRILLIC LETTER IOTIFIED E
A6F0..A6F1 ; Extend # Mn [2] BAMUM COMBINING MARK KOQNDON..BAMUM COMBINING MARK TUKWENTIS
A802 ; Extend # Mn SYLOTI NAGRI SIGN DVISVARA
A806 ; Extend # Mn SYLOTI NAGRI SIGN HASANTA
@@ -325,6 +332,11 @@
AAB7..AAB8 ; Extend # Mn [2] TAI VIET MAI KHIT..TAI VIET VOWEL IA
AABE..AABF ; Extend # Mn [2] TAI VIET VOWEL AM..TAI VIET TONE MAI EK
AAC1 ; Extend # Mn TAI VIET TONE MAI THO
+AAEB ; Extend # Mc MEETEI MAYEK VOWEL SIGN II
+AAEC..AAED ; Extend # Mn [2] MEETEI MAYEK VOWEL SIGN UU..MEETEI MAYEK VOWEL SIGN AAI
+AAEE..AAEF ; Extend # Mc [2] MEETEI MAYEK VOWEL SIGN AU..MEETEI MAYEK VOWEL SIGN AAU
+AAF5 ; Extend # Mc MEETEI MAYEK VOWEL SIGN VISARGA
+AAF6 ; Extend # Mn MEETEI MAYEK VIRAMA
ABE3..ABE4 ; Extend # Mc [2] MEETEI MAYEK VOWEL SIGN ONAP..MEETEI MAYEK VOWEL SIGN INAP
ABE5 ; Extend # Mn MEETEI MAYEK VOWEL SIGN ANAP
ABE6..ABE7 ; Extend # Mc [2] MEETEI MAYEK VOWEL SIGN YENAP..MEETEI MAYEK VOWEL SIGN SOUNAP
@@ -352,6 +364,24 @@
110B3..110B6 ; Extend # Mn [4] KAITHI VOWEL SIGN U..KAITHI VOWEL SIGN AI
110B7..110B8 ; Extend # Mc [2] KAITHI VOWEL SIGN O..KAITHI VOWEL SIGN AU
110B9..110BA ; Extend # Mn [2] KAITHI SIGN VIRAMA..KAITHI SIGN NUKTA
+11100..11102 ; Extend # Mn [3] CHAKMA SIGN CANDRABINDU..CHAKMA SIGN VISARGA
+11127..1112B ; Extend # Mn [5] CHAKMA VOWEL SIGN A..CHAKMA VOWEL SIGN UU
+1112C ; Extend # Mc CHAKMA VOWEL SIGN E
+1112D..11134 ; Extend # Mn [8] CHAKMA VOWEL SIGN AI..CHAKMA MAAYYAA
+11180..11181 ; Extend # Mn [2] SHARADA SIGN CANDRABINDU..SHARADA SIGN ANUSVARA
+11182 ; Extend # Mc SHARADA SIGN VISARGA
+111B3..111B5 ; Extend # Mc [3] SHARADA VOWEL SIGN AA..SHARADA VOWEL SIGN II
+111B6..111BE ; Extend # Mn [9] SHARADA VOWEL SIGN U..SHARADA VOWEL SIGN O
+111BF..111C0 ; Extend # Mc [2] SHARADA VOWEL SIGN AU..SHARADA SIGN VIRAMA
+116AB ; Extend # Mn TAKRI SIGN ANUSVARA
+116AC ; Extend # Mc TAKRI SIGN VISARGA
+116AD ; Extend # Mn TAKRI VOWEL SIGN AA
+116AE..116AF ; Extend # Mc [2] TAKRI VOWEL SIGN I..TAKRI VOWEL SIGN II
+116B0..116B5 ; Extend # Mn [6] TAKRI VOWEL SIGN U..TAKRI VOWEL SIGN AU
+116B6 ; Extend # Mc TAKRI SIGN VIRAMA
+116B7 ; Extend # Mn TAKRI SIGN NUKTA
+16F51..16F7E ; Extend # Mc [46] MIAO SIGN ASPIRATION..MIAO VOWEL SIGN NG
+16F8F..16F92 ; Extend # Mn [4] MIAO TONE RIGHT..MIAO TONE BELOW
1D165..1D166 ; Extend # Mc [2] MUSICAL SYMBOL COMBINING STEM..MUSICAL SYMBOL COMBINING SPRECHGESANG STEM
1D167..1D169 ; Extend # Mn [3] MUSICAL SYMBOL COMBINING TREMOLO-1..MUSICAL SYMBOL COMBINING TREMOLO-3
1D16D..1D172 ; Extend # Mc [6] MUSICAL SYMBOL COMBINING AUGMENTATION DOT..MUSICAL SYMBOL COMBINING FLAG-5
@@ -361,15 +391,20 @@
1D242..1D244 ; Extend # Mn [3] COMBINING GREEK MUSICAL TRISEME..COMBINING GREEK MUSICAL PENTASEME
E0100..E01EF ; Extend # Mn [240] VARIATION SELECTOR-17..VARIATION SELECTOR-256
-# Total code points: 1502
+# Total code points: 1649
# ================================================
+1F1E6..1F1FF ; Regional_Indicator # So [26] REGIONAL INDICATOR SYMBOL LETTER A..REGIONAL INDICATOR SYMBOL LETTER Z
+
+# Total code points: 26
+
+# ================================================
+
00AD ; Format # Cf SOFT HYPHEN
-0600..0603 ; Format # Cf [4] ARABIC NUMBER SIGN..ARABIC SIGN SAFHA
+0600..0604 ; Format # Cf [5] ARABIC NUMBER SIGN..ARABIC SIGN SAMVAT
06DD ; Format # Cf ARABIC END OF AYAH
070F ; Format # Cf SYRIAC ABBREVIATION MARK
-17B4..17B5 ; Format # Cf [2] KHMER VOWEL INHERENT AQ..KHMER VOWEL INHERENT AA
200E..200F ; Format # Cf [2] LEFT-TO-RIGHT MARK..RIGHT-TO-LEFT MARK
202A..202E ; Format # Cf [5] LEFT-TO-RIGHT EMBEDDING..RIGHT-TO-LEFT OVERRIDE
2060..2064 ; Format # Cf [5] WORD JOINER..INVISIBLE PLUS
@@ -381,7 +416,7 @@
E0001 ; Format # Cf LANGUAGE TAG
E0020..E007F ; Format # Cf [96] TAG SPACE..CANCEL TAG
-# Total code points: 137
+# Total code points: 136
# ================================================
@@ -405,9 +440,9 @@
0041..005A ; ALetter # L& [26] LATIN CAPITAL LETTER A..LATIN CAPITAL LETTER Z
0061..007A ; ALetter # L& [26] LATIN SMALL LETTER A..LATIN SMALL LETTER Z
-00AA ; ALetter # L& FEMININE ORDINAL INDICATOR
+00AA ; ALetter # Lo FEMININE ORDINAL INDICATOR
00B5 ; ALetter # L& MICRO SIGN
-00BA ; ALetter # L& MASCULINE ORDINAL INDICATOR
+00BA ; ALetter # Lo MASCULINE ORDINAL INDICATOR
00C0..00D6 ; ALetter # L& [23] LATIN CAPITAL LETTER A WITH GRAVE..LATIN CAPITAL LETTER O WITH DIAERESIS
00D8..00F6 ; ALetter # L& [31] LATIN CAPITAL LETTER O WITH STROKE..LATIN SMALL LETTER O WITH DIAERESIS
00F8..01BA ; ALetter # L& [195] LATIN SMALL LETTER O WITH STROKE..LATIN SMALL LETTER EZH WITH TAIL
@@ -462,6 +497,8 @@
0824 ; ALetter # Lm SAMARITAN MODIFIER LETTER SHORT A
0828 ; ALetter # Lm SAMARITAN MODIFIER LETTER I
0840..0858 ; ALetter # Lo [25] MANDAIC LETTER HALQA..MANDAIC LETTER AIN
+08A0 ; ALetter # Lo ARABIC LETTER BEH WITH SMALL V BELOW
+08A2..08AC ; ALetter # Lo [11] ARABIC LETTER JEEM WITH TWO DOTS ABOVE..ARABIC LETTER ROHINGYA YEH
0904..0939 ; ALetter # Lo [54] DEVANAGARI LETTER SHORT A..DEVANAGARI LETTER HA
093D ; ALetter # Lo DEVANAGARI SIGN AVAGRAHA
0950 ; ALetter # Lo DEVANAGARI OM
@@ -554,9 +591,11 @@
0F49..0F6C ; ALetter # Lo [36] TIBETAN LETTER NYA..TIBETAN LETTER RRA
0F88..0F8C ; ALetter # Lo [5] TIBETAN SIGN LCE TSA CAN..TIBETAN SIGN INVERTED MCHU CAN
10A0..10C5 ; ALetter # L& [38] GEORGIAN CAPITAL LETTER AN..GEORGIAN CAPITAL LETTER HOE
+10C7 ; ALetter # L& GEORGIAN CAPITAL LETTER YN
+10CD ; ALetter # L& GEORGIAN CAPITAL LETTER AEN
10D0..10FA ; ALetter # Lo [43] GEORGIAN LETTER AN..GEORGIAN LETTER AIN
10FC ; ALetter # Lm MODIFIER LETTER GEORGIAN NAR
-1100..1248 ; ALetter # Lo [329] HANGUL CHOSEONG KIYEOK..ETHIOPIC SYLLABLE QWA
+10FD..1248 ; ALetter # Lo [332] GEORGIAN LETTER AEN..ETHIOPIC SYLLABLE QWA
124A..124D ; ALetter # Lo [4] ETHIOPIC SYLLABLE QWI..ETHIOPIC SYLLABLE QWE
1250..1256 ; ALetter # Lo [7] ETHIOPIC SYLLABLE QHA..ETHIOPIC SYLLABLE QHO
1258 ; ALetter # Lo ETHIOPIC SYLLABLE QHWA
@@ -597,7 +636,7 @@
1B45..1B4B ; ALetter # Lo [7] BALINESE LETTER KAF SASAK..BALINESE LETTER ASYURA SASAK
1B83..1BA0 ; ALetter # Lo [30] SUNDANESE LETTER A..SUNDANESE LETTER HA
1BAE..1BAF ; ALetter # Lo [2] SUNDANESE LETTER KHA..SUNDANESE LETTER SYA
-1BC0..1BE5 ; ALetter # Lo [38] BATAK LETTER A..BATAK LETTER U
+1BBA..1BE5 ; ALetter # Lo [44] SUNDANESE AVAGRAHA..BATAK LETTER U
1C00..1C23 ; ALetter # Lo [36] LEPCHA LETTER KA..LEPCHA LETTER A
1C4D..1C4F ; ALetter # Lo [3] LEPCHA LETTER TTA..LEPCHA LETTER DDA
1C5A..1C77 ; ALetter # Lo [30] OL CHIKI LETTER LA..OL CHIKI LETTER OH
@@ -604,9 +643,10 @@
1C78..1C7D ; ALetter # Lm [6] OL CHIKI MU TTUDDAG..OL CHIKI AHAD
1CE9..1CEC ; ALetter # Lo [4] VEDIC SIGN ANUSVARA ANTARGOMUKHA..VEDIC SIGN ANUSVARA VAMAGOMUKHA WITH TAIL
1CEE..1CF1 ; ALetter # Lo [4] VEDIC SIGN HEXIFORM LONG ANUSVARA..VEDIC SIGN ANUSVARA UBHAYATO MUKHA
+1CF5..1CF6 ; ALetter # Lo [2] VEDIC SIGN JIHVAMULIYA..VEDIC SIGN UPADHMANIYA
1D00..1D2B ; ALetter # L& [44] LATIN LETTER SMALL CAPITAL A..CYRILLIC LETTER SMALL CAPITAL EL
-1D2C..1D61 ; ALetter # Lm [54] MODIFIER LETTER CAPITAL A..MODIFIER LETTER SMALL CHI
-1D62..1D77 ; ALetter # L& [22] LATIN SUBSCRIPT SMALL LETTER I..LATIN SMALL LETTER TURNED G
+1D2C..1D6A ; ALetter # Lm [63] MODIFIER LETTER CAPITAL A..GREEK SUBSCRIPT SMALL LETTER CHI
+1D6B..1D77 ; ALetter # L& [13] LATIN SMALL LETTER UE..LATIN SMALL LETTER TURNED G
1D78 ; ALetter # Lm MODIFIER LETTER CYRILLIC EN
1D79..1D9A ; ALetter # L& [34] LATIN SMALL LETTER INSULAR G..LATIN SMALL LETTER EZH WITH RETROFLEX HOOK
1D9B..1DBF ; ALetter # Lm [37] MODIFIER LETTER SMALL TURNED ALPHA..MODIFIER LETTER SMALL THETA
@@ -653,12 +693,15 @@
24B6..24E9 ; ALetter # So [52] CIRCLED LATIN CAPITAL LETTER A..CIRCLED LATIN SMALL LETTER Z
2C00..2C2E ; ALetter # L& [47] GLAGOLITIC CAPITAL LETTER AZU..GLAGOLITIC CAPITAL LETTER LATINATE MYSLITE
2C30..2C5E ; ALetter # L& [47] GLAGOLITIC SMALL LETTER AZU..GLAGOLITIC SMALL LETTER LATINATE MYSLITE
-2C60..2C7C ; ALetter # L& [29] LATIN CAPITAL LETTER L WITH DOUBLE BAR..LATIN SUBSCRIPT SMALL LETTER J
-2C7D ; ALetter # Lm MODIFIER LETTER CAPITAL V
+2C60..2C7B ; ALetter # L& [28] LATIN CAPITAL LETTER L WITH DOUBLE BAR..LATIN LETTER SMALL CAPITAL TURNED E
+2C7C..2C7D ; ALetter # Lm [2] LATIN SUBSCRIPT SMALL LETTER J..MODIFIER LETTER CAPITAL V
2C7E..2CE4 ; ALetter # L& [103] LATIN CAPITAL LETTER S WITH SWASH TAIL..COPTIC SYMBOL KAI
2CEB..2CEE ; ALetter # L& [4] COPTIC CAPITAL LETTER CRYPTOGRAMMIC SHEI..COPTIC SMALL LETTER CRYPTOGRAMMIC GANGIA
+2CF2..2CF3 ; ALetter # L& [2] COPTIC CAPITAL LETTER BOHAIRIC KHEI..COPTIC SMALL LETTER BOHAIRIC KHEI
2D00..2D25 ; ALetter # L& [38] GEORGIAN SMALL LETTER AN..GEORGIAN SMALL LETTER HOE
-2D30..2D65 ; ALetter # Lo [54] TIFINAGH LETTER YA..TIFINAGH LETTER YAZZ
+2D27 ; ALetter # L& GEORGIAN SMALL LETTER YN
+2D2D ; ALetter # L& GEORGIAN SMALL LETTER AEN
+2D30..2D67 ; ALetter # Lo [56] TIFINAGH LETTER YA..TIFINAGH LETTER YO
2D6F ; ALetter # Lm TIFINAGH MODIFIER LETTER LABIALIZATION MARK
2D80..2D96 ; ALetter # Lo [23] ETHIOPIC SYLLABLE LOA..ETHIOPIC SYLLABLE GGWE
2DA0..2DA6 ; ALetter # Lo [7] ETHIOPIC SYLLABLE SSA..ETHIOPIC SYLLABLE SSO
@@ -697,8 +740,9 @@
A771..A787 ; ALetter # L& [23] LATIN SMALL LETTER DUM..LATIN SMALL LETTER INSULAR T
A788 ; ALetter # Lm MODIFIER LETTER LOW CIRCUMFLEX ACCENT
A78B..A78E ; ALetter # L& [4] LATIN CAPITAL LETTER SALTILLO..LATIN SMALL LETTER L WITH RETROFLEX HOOK AND BELT
-A790..A791 ; ALetter # L& [2] LATIN CAPITAL LETTER N WITH DESCENDER..LATIN SMALL LETTER N WITH DESCENDER
-A7A0..A7A9 ; ALetter # L& [10] LATIN CAPITAL LETTER G WITH OBLIQUE STROKE..LATIN SMALL LETTER S WITH OBLIQUE STROKE
+A790..A793 ; ALetter # L& [4] LATIN CAPITAL LETTER N WITH DESCENDER..LATIN SMALL LETTER C WITH BAR
+A7A0..A7AA ; ALetter # L& [11] LATIN CAPITAL LETTER G WITH OBLIQUE STROKE..LATIN CAPITAL LETTER H WITH HOOK
+A7F8..A7F9 ; ALetter # Lm [2] MODIFIER LETTER CAPITAL H WITH STROKE..MODIFIER LETTER SMALL LIGATURE OE
A7FA ; ALetter # L& LATIN LETTER SMALL CAPITAL TURNED M
A7FB..A801 ; ALetter # Lo [7] LATIN EPIGRAPHIC LETTER REVERSED F..SYLOTI NAGRI LETTER I
A803..A805 ; ALetter # Lo [3] SYLOTI NAGRI LETTER U..SYLOTI NAGRI LETTER O
@@ -716,6 +760,9 @@
AA00..AA28 ; ALetter # Lo [41] CHAM LETTER A..CHAM LETTER HA
AA40..AA42 ; ALetter # Lo [3] CHAM LETTER FINAL K..CHAM LETTER FINAL NG
AA44..AA4B ; ALetter # Lo [8] CHAM LETTER FINAL CH..CHAM LETTER FINAL SS
+AAE0..AAEA ; ALetter # Lo [11] MEETEI MAYEK LETTER E..MEETEI MAYEK LETTER SSA
+AAF2 ; ALetter # Lo MEETEI MAYEK ANJI
+AAF3..AAF4 ; ALetter # Lm [2] MEETEI MAYEK SYLLABLE REPETITION MARK..MEETEI MAYEK WORD REPETITION MARK
AB01..AB06 ; ALetter # Lo [6] ETHIOPIC SYLLABLE TTHU..ETHIOPIC SYLLABLE TTHO
AB09..AB0E ; ALetter # Lo [6] ETHIOPIC SYLLABLE DDHU..ETHIOPIC SYLLABLE DDHO
AB11..AB16 ; ALetter # Lo [6] ETHIOPIC SYLLABLE DZU..ETHIOPIC SYLLABLE DZO
@@ -777,6 +824,8 @@
1083F..10855 ; ALetter # Lo [23] CYPRIOT SYLLABLE ZO..IMPERIAL ARAMAIC LETTER TAW
10900..10915 ; ALetter # Lo [22] PHOENICIAN LETTER ALF..PHOENICIAN LETTER TAU
10920..10939 ; ALetter # Lo [26] LYDIAN LETTER A..LYDIAN LETTER C
+10980..109B7 ; ALetter # Lo [56] MEROITIC HIEROGLYPHIC LETTER A..MEROITIC CURSIVE LETTER DA
+109BE..109BF ; ALetter # Lo [2] MEROITIC CURSIVE LOGOGRAM RMT..MEROITIC CURSIVE LOGOGRAM IMN
10A00 ; ALetter # Lo KHAROSHTHI LETTER A
10A10..10A13 ; ALetter # Lo [4] KHAROSHTHI LETTER KA..KHAROSHTHI LETTER GHA
10A15..10A17 ; ALetter # Lo [3] KHAROSHTHI LETTER CA..KHAROSHTHI LETTER JA
@@ -788,10 +837,18 @@
10C00..10C48 ; ALetter # Lo [73] OLD TURKIC LETTER ORKHON A..OLD TURKIC LETTER ORKHON BASH
11003..11037 ; ALetter # Lo [53] BRAHMI SIGN JIHVAMULIYA..BRAHMI LETTER OLD TAMIL NNNA
11083..110AF ; ALetter # Lo [45] KAITHI LETTER A..KAITHI LETTER HA
+110D0..110E8 ; ALetter # Lo [25] SORA SOMPENG LETTER SAH..SORA SOMPENG LETTER MAE
+11103..11126 ; ALetter # Lo [36] CHAKMA LETTER AA..CHAKMA LETTER HAA
+11183..111B2 ; ALetter # Lo [48] SHARADA LETTER A..SHARADA LETTER HA
+111C1..111C4 ; ALetter # Lo [4] SHARADA SIGN AVAGRAHA..SHARADA OM
+11680..116AA ; ALetter # Lo [43] TAKRI LETTER A..TAKRI LETTER RRA
12000..1236E ; ALetter # Lo [879] CUNEIFORM SIGN A..CUNEIFORM SIGN ZUM
12400..12462 ; ALetter # Nl [99] CUNEIFORM NUMERIC SIGN TWO ASH..CUNEIFORM NUMERIC SIGN OLD ASSYRIAN ONE QUARTER
13000..1342E ; ALetter # Lo [1071] EGYPTIAN HIEROGLYPH A001..EGYPTIAN HIEROGLYPH AA032
16800..16A38 ; ALetter # Lo [569] BAMUM LETTER PHASE-A NGKUE MFON..BAMUM LETTER PHASE-F VUEQ
+16F00..16F44 ; ALetter # Lo [69] MIAO LETTER PA..MIAO LETTER HHA
+16F50 ; ALetter # Lo MIAO LETTER NASALIZATION
+16F93..16F9F ; ALetter # Lm [13] MIAO LETTER TONE-2..MIAO LETTER REFORMED TONE-8
1D400..1D454 ; ALetter # L& [85] MATHEMATICAL BOLD CAPITAL A..MATHEMATICAL ITALIC SMALL G
1D456..1D49C ; ALetter # L& [71] MATHEMATICAL ITALIC SMALL I..MATHEMATICAL SCRIPT CAPITAL A
1D49E..1D49F ; ALetter # L& [2] MATHEMATICAL SCRIPT CAPITAL C..MATHEMATICAL SCRIPT CAPITAL D
@@ -822,8 +879,41 @@
1D78A..1D7A8 ; ALetter # L& [31] MATHEMATICAL SANS-SERIF BOLD EPSILON SYMBOL..MATHEMATICAL SANS-SERIF BOLD ITALIC CAPITAL OMEGA
1D7AA..1D7C2 ; ALetter # L& [25] MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL ALPHA..MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL OMEGA
1D7C4..1D7CB ; ALetter # L& [8] MATHEMATICAL SANS-SERIF BOLD ITALIC EPSILON SYMBOL..MATHEMATICAL BOLD SMALL DIGAMMA
+1EE00..1EE03 ; ALetter # Lo [4] ARABIC MATHEMATICAL ALEF..ARABIC MATHEMATICAL DAL
+1EE05..1EE1F ; ALetter # Lo [27] ARABIC MATHEMATICAL WAW..ARABIC MATHEMATICAL DOTLESS QAF
+1EE21..1EE22 ; ALetter # Lo [2] ARABIC MATHEMATICAL INITIAL BEH..ARABIC MATHEMATICAL INITIAL JEEM
+1EE24 ; ALetter # Lo ARABIC MATHEMATICAL INITIAL HEH
+1EE27 ; ALetter # Lo ARABIC MATHEMATICAL INITIAL HAH
+1EE29..1EE32 ; ALetter # Lo [10] ARABIC MATHEMATICAL INITIAL YEH..ARABIC MATHEMATICAL INITIAL QAF
+1EE34..1EE37 ; ALetter # Lo [4] ARABIC MATHEMATICAL INITIAL SHEEN..ARABIC MATHEMATICAL INITIAL KHAH
+1EE39 ; ALetter # Lo ARABIC MATHEMATICAL INITIAL DAD
+1EE3B ; ALetter # Lo ARABIC MATHEMATICAL INITIAL GHAIN
+1EE42 ; ALetter # Lo ARABIC MATHEMATICAL TAILED JEEM
+1EE47 ; ALetter # Lo ARABIC MATHEMATICAL TAILED HAH
+1EE49 ; ALetter # Lo ARABIC MATHEMATICAL TAILED YEH
+1EE4B ; ALetter # Lo ARABIC MATHEMATICAL TAILED LAM
+1EE4D..1EE4F ; ALetter # Lo [3] ARABIC MATHEMATICAL TAILED NOON..ARABIC MATHEMATICAL TAILED AIN
+1EE51..1EE52 ; ALetter # Lo [2] ARABIC MATHEMATICAL TAILED SAD..ARABIC MATHEMATICAL TAILED QAF
+1EE54 ; ALetter # Lo ARABIC MATHEMATICAL TAILED SHEEN
+1EE57 ; ALetter # Lo ARABIC MATHEMATICAL TAILED KHAH
+1EE59 ; ALetter # Lo ARABIC MATHEMATICAL TAILED DAD
+1EE5B ; ALetter # Lo ARABIC MATHEMATICAL TAILED GHAIN
+1EE5D ; ALetter # Lo ARABIC MATHEMATICAL TAILED DOTLESS NOON
+1EE5F ; ALetter # Lo ARABIC MATHEMATICAL TAILED DOTLESS QAF
+1EE61..1EE62 ; ALetter # Lo [2] ARABIC MATHEMATICAL STRETCHED BEH..ARABIC MATHEMATICAL STRETCHED JEEM
+1EE64 ; ALetter # Lo ARABIC MATHEMATICAL STRETCHED HEH
+1EE67..1EE6A ; ALetter # Lo [4] ARABIC MATHEMATICAL STRETCHED HAH..ARABIC MATHEMATICAL STRETCHED KAF
+1EE6C..1EE72 ; ALetter # Lo [7] ARABIC MATHEMATICAL STRETCHED MEEM..ARABIC MATHEMATICAL STRETCHED QAF
+1EE74..1EE77 ; ALetter # Lo [4] ARABIC MATHEMATICAL STRETCHED SHEEN..ARABIC MATHEMATICAL STRETCHED KHAH
+1EE79..1EE7C ; ALetter # Lo [4] ARABIC MATHEMATICAL STRETCHED DAD..ARABIC MATHEMATICAL STRETCHED DOTLESS BEH
+1EE7E ; ALetter # Lo ARABIC MATHEMATICAL STRETCHED DOTLESS FEH
+1EE80..1EE89 ; ALetter # Lo [10] ARABIC MATHEMATICAL LOOPED ALEF..ARABIC MATHEMATICAL LOOPED YEH
+1EE8B..1EE9B ; ALetter # Lo [17] ARABIC MATHEMATICAL LOOPED LAM..ARABIC MATHEMATICAL LOOPED GHAIN
+1EEA1..1EEA3 ; ALetter # Lo [3] ARABIC MATHEMATICAL DOUBLE-STRUCK BEH..ARABIC MATHEMATICAL DOUBLE-STRUCK DAL
+1EEA5..1EEA9 ; ALetter # Lo [5] ARABIC MATHEMATICAL DOUBLE-STRUCK WAW..ARABIC MATHEMATICAL DOUBLE-STRUCK YEH
+1EEAB..1EEBB ; ALetter # Lo [17] ARABIC MATHEMATICAL DOUBLE-STRUCK LAM..ARABIC MATHEMATICAL DOUBLE-STRUCK GHAIN
-# Total code points: 24453
+# Total code points: 24941
# ================================================
@@ -909,9 +999,13 @@
ABF0..ABF9 ; Numeric # Nd [10] MEETEI MAYEK DIGIT ZERO..MEETEI MAYEK DIGIT NINE
104A0..104A9 ; Numeric # Nd [10] OSMANYA DIGIT ZERO..OSMANYA DIGIT NINE
11066..1106F ; Numeric # Nd [10] BRAHMI DIGIT ZERO..BRAHMI DIGIT NINE
+110F0..110F9 ; Numeric # Nd [10] SORA SOMPENG DIGIT ZERO..SORA SOMPENG DIGIT NINE
+11136..1113F ; Numeric # Nd [10] CHAKMA DIGIT ZERO..CHAKMA DIGIT NINE
+111D0..111D9 ; Numeric # Nd [10] SHARADA DIGIT ZERO..SHARADA DIGIT NINE
+116C0..116C9 ; Numeric # Nd [10] TAKRI DIGIT ZERO..TAKRI DIGIT NINE
1D7CE..1D7FF ; Numeric # Nd [50] MATHEMATICAL BOLD DIGIT ZERO..MATHEMATICAL MONOSPACE DIGIT NINE
-# Total code points: 411
+# Total code points: 451
# ================================================
Property changes on: trunk/contrib/perl/lib/unicore/auxiliary/WordBreakProperty.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/extracted/DBidiClass.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/extracted/DBidiClass.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/extracted/DBidiClass.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,8 +1,8 @@
-# DerivedBidiClass-6.0.0.txt
-# Date: 2010-08-19, 00:48:03 GMT [MD]
+# DerivedBidiClass-6.2.0.txt
+# Date: 2012-05-20, 00:42:30 GMT [MD]
#
# Unicode Character Database
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
# For documentation, see http://www.unicode.org/reports/tr44/
@@ -13,20 +13,23 @@
# reserved for right-to-left scripts are given either types R or AL.
#
# The unassigned code points that default to AL are in the ranges:
-# [\u0600-\u07BF \uFB50-\uFDFF \uFE70-\uFEFF]
+# [\u0600-\u07BF \u08A0-\u08FF \uFB50-\uFDCF \uFDF0-\uFDFF \uFE70-\uFEFF \U0001EE00-\U0001EEFF]
#
# Arabic: U+0600 - U+06FF
# Syriac: U+0700 - U+074F
# Arabic_Supplement: U+0750 - U+077F
# Thaana: U+0780 - U+07BF
+# Arabic Extended-A: U+08A0 - U+08FF
# Arabic_Presentation_Forms_A:
-# U+FB50 - U+FDFF
+# U+FB50 - U+FDCF
+# U+FDF0 - U+FDFF
# Arabic_Presentation_Forms_B:
# U+FE70 - U+FEFF
-# minus noncharacter code points.
+# Arabic Mathematical Alphabetic Symbols:
+# U+1EE00 - U+1EEFF
#
# The unassigned code points that default to R are in the ranges:
-# [\u0590-\u05FF \u07C0-\u08FF \uFB1D-\uFB4F \U00010800-\U00010FFF \U0001E800-\U0001EFFF]
+# [\u0590-\u05FF \u07C0-\u089F \uFB1D-\uFB4F \U00010800-\U00010FFF \U0001E800-\U0001EDFF \U0001EF00-\U0001EFFF]
#
# Hebrew: U+0590 - U+05FF
# NKo: U+07C0 - U+07FF
@@ -33,12 +36,16 @@
# Cypriot_Syllabary: U+10800 - U+1083F
# Phoenician: U+10900 - U+1091F
# Lydian: U+10920 - U+1093F
+# Meroitic Hieroglyphs:
+# U+10980 - U+1099F
+# Meroitic Cursive: U+109A0 - U+109FF
# Kharoshthi: U+10A00 - U+10A5F
# and any others in the ranges:
-# U+0800 - U+08FF,
+# U+0800 - U+089F,
# U+FB1D - U+FB4F,
# U+10840 - U+10FFF,
-# U+1E800 - U+1EFFF
+# U+1E800 - U+1EDFF,
+# U+1EF00 - U+1EFFF
#
# For all other cases:
@@ -53,9 +60,9 @@
0041..005A ; L # L& [26] LATIN CAPITAL LETTER A..LATIN CAPITAL LETTER Z
0061..007A ; L # L& [26] LATIN SMALL LETTER A..LATIN SMALL LETTER Z
-00AA ; L # L& FEMININE ORDINAL INDICATOR
+00AA ; L # Lo FEMININE ORDINAL INDICATOR
00B5 ; L # L& MICRO SIGN
-00BA ; L # L& MASCULINE ORDINAL INDICATOR
+00BA ; L # Lo MASCULINE ORDINAL INDICATOR
00C0..00D6 ; L # L& [23] LATIN CAPITAL LETTER A WITH GRAVE..LATIN CAPITAL LETTER O WITH DIAERESIS
00D8..00F6 ; L # L& [31] LATIN CAPITAL LETTER O WITH STROKE..LATIN SMALL LETTER O WITH DIAERESIS
00F8..01BA ; L # L& [195] LATIN SMALL LETTER O WITH STROKE..LATIN SMALL LETTER EZH WITH TAIL
@@ -148,6 +155,7 @@
0AD0 ; L # Lo GUJARATI OM
0AE0..0AE1 ; L # Lo [2] GUJARATI LETTER VOCALIC RR..GUJARATI LETTER VOCALIC LL
0AE6..0AEF ; L # Nd [10] GUJARATI DIGIT ZERO..GUJARATI DIGIT NINE
+0AF0 ; L # Po GUJARATI ABBREVIATION SIGN
0B02..0B03 ; L # Mc [2] ORIYA SIGN ANUSVARA..ORIYA SIGN VISARGA
0B05..0B0C ; L # Lo [8] ORIYA LETTER A..ORIYA LETTER VOCALIC L
0B0F..0B10 ; L # Lo [2] ORIYA LETTER E..ORIYA LETTER AI
@@ -264,11 +272,13 @@
0EC0..0EC4 ; L # Lo [5] LAO VOWEL SIGN E..LAO VOWEL SIGN AI
0EC6 ; L # Lm LAO KO LA
0ED0..0ED9 ; L # Nd [10] LAO DIGIT ZERO..LAO DIGIT NINE
-0EDC..0EDD ; L # Lo [2] LAO HO NO..LAO HO MO
+0EDC..0EDF ; L # Lo [4] LAO HO NO..LAO LETTER KHMU NYO
0F00 ; L # Lo TIBETAN SYLLABLE OM
0F01..0F03 ; L # So [3] TIBETAN MARK GTER YIG MGO TRUNCATED A..TIBETAN MARK GTER YIG MGO -UM GTER TSHEG MA
0F04..0F12 ; L # Po [15] TIBETAN MARK INITIAL YIG MGO MDUN MA..TIBETAN MARK RGYA GRAM SHAD
-0F13..0F17 ; L # So [5] TIBETAN MARK CARET -DZUD RTAGS ME LONG CAN..TIBETAN ASTROLOGICAL SIGN SGRA GCAN -CHAR RTAGS
+0F13 ; L # So TIBETAN MARK CARET -DZUD RTAGS ME LONG CAN
+0F14 ; L # Po TIBETAN MARK GTER TSHEG
+0F15..0F17 ; L # So [3] TIBETAN LOGOTYPE SIGN CHAD RTAGS..TIBETAN ASTROLOGICAL SIGN SGRA GCAN -CHAR RTAGS
0F1A..0F1F ; L # So [6] TIBETAN SIGN RDEL DKAR GCIG..TIBETAN SIGN RDEL DKAR RDEL NAG
0F20..0F29 ; L # Nd [10] TIBETAN DIGIT ZERO..TIBETAN DIGIT NINE
0F2A..0F33 ; L # No [10] TIBETAN DIGIT HALF ONE..TIBETAN DIGIT HALF ZERO
@@ -312,10 +322,12 @@
109A..109C ; L # Mc [3] MYANMAR SIGN KHAMTI TONE-1..MYANMAR VOWEL SIGN AITON A
109E..109F ; L # So [2] MYANMAR SYMBOL SHAN ONE..MYANMAR SYMBOL SHAN EXCLAMATION
10A0..10C5 ; L # L& [38] GEORGIAN CAPITAL LETTER AN..GEORGIAN CAPITAL LETTER HOE
+10C7 ; L # L& GEORGIAN CAPITAL LETTER YN
+10CD ; L # L& GEORGIAN CAPITAL LETTER AEN
10D0..10FA ; L # Lo [43] GEORGIAN LETTER AN..GEORGIAN LETTER AIN
10FB ; L # Po GEORGIAN PARAGRAPH SEPARATOR
10FC ; L # Lm MODIFIER LETTER GEORGIAN NAR
-1100..1248 ; L # Lo [329] HANGUL CHOSEONG KIYEOK..ETHIOPIC SYLLABLE QWA
+10FD..1248 ; L # Lo [332] GEORGIAN LETTER AEN..ETHIOPIC SYLLABLE QWA
124A..124D ; L # Lo [4] ETHIOPIC SYLLABLE QWI..ETHIOPIC SYLLABLE QWE
1250..1256 ; L # Lo [7] ETHIOPIC SYLLABLE QHA..ETHIOPIC SYLLABLE QHO
1258 ; L # Lo ETHIOPIC SYLLABLE QHWA
@@ -331,8 +343,7 @@
12D8..1310 ; L # Lo [57] ETHIOPIC SYLLABLE ZA..ETHIOPIC SYLLABLE GWA
1312..1315 ; L # Lo [4] ETHIOPIC SYLLABLE GWI..ETHIOPIC SYLLABLE GWE
1318..135A ; L # Lo [67] ETHIOPIC SYLLABLE GGA..ETHIOPIC SYLLABLE FYA
-1360 ; L # So ETHIOPIC SECTION MARK
-1361..1368 ; L # Po [8] ETHIOPIC WORDSPACE..ETHIOPIC PARAGRAPH SEPARATOR
+1360..1368 ; L # Po [9] ETHIOPIC SECTION MARK..ETHIOPIC PARAGRAPH SEPARATOR
1369..137C ; L # No [20] ETHIOPIC DIGIT ONE..ETHIOPIC NUMBER TEN THOUSAND
1380..138F ; L # Lo [16] ETHIOPIC SYLLABLE SEBATBEIT MWA..ETHIOPIC SYLLABLE PWE
13A0..13F4 ; L # Lo [85] CHEROKEE LETTER A..CHEROKEE LETTER YV
@@ -351,7 +362,6 @@
1760..176C ; L # Lo [13] TAGBANWA LETTER A..TAGBANWA LETTER YA
176E..1770 ; L # Lo [3] TAGBANWA LETTER LA..TAGBANWA LETTER SA
1780..17B3 ; L # Lo [52] KHMER LETTER KA..KHMER INDEPENDENT VOWEL QAU
-17B4..17B5 ; L # Cf [2] KHMER VOWEL INHERENT AQ..KHMER VOWEL INHERENT AA
17B6 ; L # Mc KHMER VOWEL SIGN AA
17BE..17C5 ; L # Mc [8] KHMER VOWEL SIGN OE..KHMER VOWEL SIGN AU
17C7..17C8 ; L # Mc [2] KHMER SIGN REAHMUK..KHMER SIGN YUUKALEAPINTU
@@ -411,9 +421,10 @@
1BA1 ; L # Mc SUNDANESE CONSONANT SIGN PAMINGKAL
1BA6..1BA7 ; L # Mc [2] SUNDANESE VOWEL SIGN PANAELAENG..SUNDANESE VOWEL SIGN PANOLONG
1BAA ; L # Mc SUNDANESE SIGN PAMAAEH
+1BAC..1BAD ; L # Mc [2] SUNDANESE CONSONANT SIGN PASANGAN MA..SUNDANESE CONSONANT SIGN PASANGAN WA
1BAE..1BAF ; L # Lo [2] SUNDANESE LETTER KHA..SUNDANESE LETTER SYA
1BB0..1BB9 ; L # Nd [10] SUNDANESE DIGIT ZERO..SUNDANESE DIGIT NINE
-1BC0..1BE5 ; L # Lo [38] BATAK LETTER A..BATAK LETTER U
+1BBA..1BE5 ; L # Lo [44] SUNDANESE AVAGRAHA..BATAK LETTER U
1BE7 ; L # Mc BATAK VOWEL SIGN E
1BEA..1BEC ; L # Mc [3] BATAK VOWEL SIGN I..BATAK VOWEL SIGN O
1BEE ; L # Mc BATAK VOWEL SIGN U
@@ -429,14 +440,16 @@
1C5A..1C77 ; L # Lo [30] OL CHIKI LETTER LA..OL CHIKI LETTER OH
1C78..1C7D ; L # Lm [6] OL CHIKI MU TTUDDAG..OL CHIKI AHAD
1C7E..1C7F ; L # Po [2] OL CHIKI PUNCTUATION MUCAAD..OL CHIKI PUNCTUATION DOUBLE MUCAAD
+1CC0..1CC7 ; L # Po [8] SUNDANESE PUNCTUATION BINDU SURYA..SUNDANESE PUNCTUATION BINDU BA SATANGA
1CD3 ; L # Po VEDIC SIGN NIHSHVASA
1CE1 ; L # Mc VEDIC TONE ATHARVAVEDIC INDEPENDENT SVARITA
1CE9..1CEC ; L # Lo [4] VEDIC SIGN ANUSVARA ANTARGOMUKHA..VEDIC SIGN ANUSVARA VAMAGOMUKHA WITH TAIL
1CEE..1CF1 ; L # Lo [4] VEDIC SIGN HEXIFORM LONG ANUSVARA..VEDIC SIGN ANUSVARA UBHAYATO MUKHA
-1CF2 ; L # Mc VEDIC SIGN ARDHAVISARGA
+1CF2..1CF3 ; L # Mc [2] VEDIC SIGN ARDHAVISARGA..VEDIC SIGN ROTATED ARDHAVISARGA
+1CF5..1CF6 ; L # Lo [2] VEDIC SIGN JIHVAMULIYA..VEDIC SIGN UPADHMANIYA
1D00..1D2B ; L # L& [44] LATIN LETTER SMALL CAPITAL A..CYRILLIC LETTER SMALL CAPITAL EL
-1D2C..1D61 ; L # Lm [54] MODIFIER LETTER CAPITAL A..MODIFIER LETTER SMALL CHI
-1D62..1D77 ; L # L& [22] LATIN SUBSCRIPT SMALL LETTER I..LATIN SMALL LETTER TURNED G
+1D2C..1D6A ; L # Lm [63] MODIFIER LETTER CAPITAL A..GREEK SUBSCRIPT SMALL LETTER CHI
+1D6B..1D77 ; L # L& [13] LATIN SMALL LETTER UE..LATIN SMALL LETTER TURNED G
1D78 ; L # Lm MODIFIER LETTER CYRILLIC EN
1D79..1D9A ; L # L& [34] LATIN SMALL LETTER INSULAR G..LATIN SMALL LETTER EZH WITH RETROFLEX HOOK
1D9B..1DBF ; L # Lm [37] MODIFIER LETTER SMALL TURNED ALPHA..MODIFIER LETTER SMALL THETA
@@ -489,12 +502,15 @@
2800..28FF ; L # So [256] BRAILLE PATTERN BLANK..BRAILLE PATTERN DOTS-12345678
2C00..2C2E ; L # L& [47] GLAGOLITIC CAPITAL LETTER AZU..GLAGOLITIC CAPITAL LETTER LATINATE MYSLITE
2C30..2C5E ; L # L& [47] GLAGOLITIC SMALL LETTER AZU..GLAGOLITIC SMALL LETTER LATINATE MYSLITE
-2C60..2C7C ; L # L& [29] LATIN CAPITAL LETTER L WITH DOUBLE BAR..LATIN SUBSCRIPT SMALL LETTER J
-2C7D ; L # Lm MODIFIER LETTER CAPITAL V
+2C60..2C7B ; L # L& [28] LATIN CAPITAL LETTER L WITH DOUBLE BAR..LATIN LETTER SMALL CAPITAL TURNED E
+2C7C..2C7D ; L # Lm [2] LATIN SUBSCRIPT SMALL LETTER J..MODIFIER LETTER CAPITAL V
2C7E..2CE4 ; L # L& [103] LATIN CAPITAL LETTER S WITH SWASH TAIL..COPTIC SYMBOL KAI
2CEB..2CEE ; L # L& [4] COPTIC CAPITAL LETTER CRYPTOGRAMMIC SHEI..COPTIC SMALL LETTER CRYPTOGRAMMIC GANGIA
+2CF2..2CF3 ; L # L& [2] COPTIC CAPITAL LETTER BOHAIRIC KHEI..COPTIC SMALL LETTER BOHAIRIC KHEI
2D00..2D25 ; L # L& [38] GEORGIAN SMALL LETTER AN..GEORGIAN SMALL LETTER HOE
-2D30..2D65 ; L # Lo [54] TIFINAGH LETTER YA..TIFINAGH LETTER YAZZ
+2D27 ; L # L& GEORGIAN SMALL LETTER YN
+2D2D ; L # L& GEORGIAN SMALL LETTER AEN
+2D30..2D67 ; L # Lo [56] TIFINAGH LETTER YA..TIFINAGH LETTER YO
2D6F ; L # Lm TIFINAGH MODIFIER LETTER LABIALIZATION MARK
2D70 ; L # Po TIFINAGH SEPARATOR MARK
2D80..2D96 ; L # Lo [23] ETHIOPIC SYLLABLE LOA..ETHIOPIC SYLLABLE GGWE
@@ -510,6 +526,7 @@
3006 ; L # Lo IDEOGRAPHIC CLOSING MARK
3007 ; L # Nl IDEOGRAPHIC NUMBER ZERO
3021..3029 ; L # Nl [9] HANGZHOU NUMERAL ONE..HANGZHOU NUMERAL NINE
+302E..302F ; L # Mc [2] HANGUL SINGLE DOT TONE MARK..HANGUL DOUBLE DOT TONE MARK
3031..3035 ; L # Lm [5] VERTICAL KANA REPEAT MARK..VERTICAL KANA REPEAT MARK LOWER HALF
3038..303A ; L # Nl [3] HANGZHOU NUMERAL TEN..HANGZHOU NUMERAL THIRTY
303B ; L # Lm VERTICAL IDEOGRAPHIC ITERATION MARK
@@ -529,7 +546,8 @@
31F0..31FF ; L # Lo [16] KATAKANA LETTER SMALL KU..KATAKANA LETTER SMALL RO
3200..321C ; L # So [29] PARENTHESIZED HANGUL KIYEOK..PARENTHESIZED HANGUL CIEUC U
3220..3229 ; L # No [10] PARENTHESIZED IDEOGRAPH ONE..PARENTHESIZED IDEOGRAPH TEN
-322A..324F ; L # So [38] PARENTHESIZED IDEOGRAPH MOON..CIRCLED NUMBER EIGHTY ON BLACK SQUARE
+322A..3247 ; L # So [30] PARENTHESIZED IDEOGRAPH MOON..CIRCLED IDEOGRAPH KOTO
+3248..324F ; L # No [8] CIRCLED NUMBER TEN ON BLACK SQUARE..CIRCLED NUMBER EIGHTY ON BLACK SQUARE
3260..327B ; L # So [28] CIRCLED HANGUL KIYEOK..CIRCLED HANGUL HIEUH A
327F ; L # So KOREAN STANDARD SYMBOL
3280..3289 ; L # No [10] CIRCLED IDEOGRAPH ONE..CIRCLED IDEOGRAPH TEN
@@ -540,7 +558,7 @@
337B..33DD ; L # So [99] SQUARE ERA NAME HEISEI..SQUARE WB
33E0..33FE ; L # So [31] IDEOGRAPHIC TELEGRAPH SYMBOL FOR DAY ONE..IDEOGRAPHIC TELEGRAPH SYMBOL FOR DAY THIRTY-ONE
3400..4DB5 ; L # Lo [6582] CJK UNIFIED IDEOGRAPH-3400..CJK UNIFIED IDEOGRAPH-4DB5
-4E00..9FCB ; L # Lo [20940] CJK UNIFIED IDEOGRAPH-4E00..CJK UNIFIED IDEOGRAPH-9FCB
+4E00..9FCC ; L # Lo [20941] CJK UNIFIED IDEOGRAPH-4E00..CJK UNIFIED IDEOGRAPH-9FCC
A000..A014 ; L # Lo [21] YI SYLLABLE IT..YI SYLLABLE E
A015 ; L # Lm YI SYLLABLE WU
A016..A48C ; L # Lo [1143] YI SYLLABLE BIT..YI SYLLABLE YYR
@@ -563,8 +581,9 @@
A771..A787 ; L # L& [23] LATIN SMALL LETTER DUM..LATIN SMALL LETTER INSULAR T
A789..A78A ; L # Sk [2] MODIFIER LETTER COLON..MODIFIER LETTER SHORT EQUALS SIGN
A78B..A78E ; L # L& [4] LATIN CAPITAL LETTER SALTILLO..LATIN SMALL LETTER L WITH RETROFLEX HOOK AND BELT
-A790..A791 ; L # L& [2] LATIN CAPITAL LETTER N WITH DESCENDER..LATIN SMALL LETTER N WITH DESCENDER
-A7A0..A7A9 ; L # L& [10] LATIN CAPITAL LETTER G WITH OBLIQUE STROKE..LATIN SMALL LETTER S WITH OBLIQUE STROKE
+A790..A793 ; L # L& [4] LATIN CAPITAL LETTER N WITH DESCENDER..LATIN SMALL LETTER C WITH BAR
+A7A0..A7AA ; L # L& [11] LATIN CAPITAL LETTER G WITH OBLIQUE STROKE..LATIN CAPITAL LETTER H WITH HOOK
+A7F8..A7F9 ; L # Lm [2] MODIFIER LETTER CAPITAL H WITH STROKE..MODIFIER LETTER SMALL LIGATURE OE
A7FA ; L # L& LATIN LETTER SMALL CAPITAL TURNED M
A7FB..A801 ; L # Lo [7] LATIN EPIGRAPHIC LETTER REVERSED F..SYLOTI NAGRI LETTER I
A803..A805 ; L # Lo [3] SYLOTI NAGRI LETTER U..SYLOTI NAGRI LETTER O
@@ -622,6 +641,13 @@
AADB..AADC ; L # Lo [2] TAI VIET SYMBOL KON..TAI VIET SYMBOL NUENG
AADD ; L # Lm TAI VIET SYMBOL SAM
AADE..AADF ; L # Po [2] TAI VIET SYMBOL HO HOI..TAI VIET SYMBOL KOI KOI
+AAE0..AAEA ; L # Lo [11] MEETEI MAYEK LETTER E..MEETEI MAYEK LETTER SSA
+AAEB ; L # Mc MEETEI MAYEK VOWEL SIGN II
+AAEE..AAEF ; L # Mc [2] MEETEI MAYEK VOWEL SIGN AU..MEETEI MAYEK VOWEL SIGN AAU
+AAF0..AAF1 ; L # Po [2] MEETEI MAYEK CHEIKHAN..MEETEI MAYEK AHANG KHUDAM
+AAF2 ; L # Lo MEETEI MAYEK ANJI
+AAF3..AAF4 ; L # Lm [2] MEETEI MAYEK SYLLABLE REPETITION MARK..MEETEI MAYEK WORD REPETITION MARK
+AAF5 ; L # Mc MEETEI MAYEK VOWEL SIGN VISARGA
AB01..AB06 ; L # Lo [6] ETHIOPIC SYLLABLE TTHU..ETHIOPIC SYLLABLE TTHO
AB09..AB0E ; L # Lo [6] ETHIOPIC SYLLABLE DDHU..ETHIOPIC SYLLABLE DDHO
AB11..AB16 ; L # Lo [6] ETHIOPIC SYLLABLE DZU..ETHIOPIC SYLLABLE DZO
@@ -638,8 +664,7 @@
D7B0..D7C6 ; L # Lo [23] HANGUL JUNGSEONG O-YEO..HANGUL JUNGSEONG ARAEA-E
D7CB..D7FB ; L # Lo [49] HANGUL JONGSEONG NIEUN-RIEUL..HANGUL JONGSEONG PHIEUPH-THIEUTH
E000..F8FF ; L # Co [6400] <private-use-E000>..<private-use-F8FF>
-F900..FA2D ; L # Lo [302] CJK COMPATIBILITY IDEOGRAPH-F900..CJK COMPATIBILITY IDEOGRAPH-FA2D
-FA30..FA6D ; L # Lo [62] CJK COMPATIBILITY IDEOGRAPH-FA30..CJK COMPATIBILITY IDEOGRAPH-FA6D
+F900..FA6D ; L # Lo [366] CJK COMPATIBILITY IDEOGRAPH-F900..CJK COMPATIBILITY IDEOGRAPH-FA6D
FA70..FAD9 ; L # Lo [106] CJK COMPATIBILITY IDEOGRAPH-FA70..CJK COMPATIBILITY IDEOGRAPH-FAD9
FB00..FB06 ; L # L& [7] LATIN SMALL LIGATURE FF..LATIN SMALL LIGATURE ST
FB13..FB17 ; L # L& [5] ARMENIAN SMALL LIGATURE MEN NOW..ARMENIAN SMALL LIGATURE MEN XEH
@@ -662,7 +687,7 @@
10050..1005D ; L # Lo [14] LINEAR B SYMBOL B018..LINEAR B SYMBOL B089
10080..100FA ; L # Lo [123] LINEAR B IDEOGRAM B100 MAN..LINEAR B IDEOGRAM VESSEL B305
10100 ; L # Po AEGEAN WORD SEPARATOR LINE
-10102 ; L # So AEGEAN CHECK MARK
+10102 ; L # Po AEGEAN CHECK MARK
10107..10133 ; L # No [45] AEGEAN NUMBER ONE..AEGEAN NUMBER NINETY THOUSAND
10137..1013F ; L # So [9] AEGEAN WEIGHT BASE UNIT..AEGEAN MEASURE THIRD SUBUNIT
101D0..101FC ; L # So [45] PHAISTOS DISC SIGN PEDESTRIAN..PHAISTOS DISC SIGN WAVY BAND
@@ -695,11 +720,33 @@
110BB..110BC ; L # Po [2] KAITHI ABBREVIATION SIGN..KAITHI ENUMERATION SIGN
110BD ; L # Cf KAITHI NUMBER SIGN
110BE..110C1 ; L # Po [4] KAITHI SECTION MARK..KAITHI DOUBLE DANDA
+110D0..110E8 ; L # Lo [25] SORA SOMPENG LETTER SAH..SORA SOMPENG LETTER MAE
+110F0..110F9 ; L # Nd [10] SORA SOMPENG DIGIT ZERO..SORA SOMPENG DIGIT NINE
+11103..11126 ; L # Lo [36] CHAKMA LETTER AA..CHAKMA LETTER HAA
+1112C ; L # Mc CHAKMA VOWEL SIGN E
+11136..1113F ; L # Nd [10] CHAKMA DIGIT ZERO..CHAKMA DIGIT NINE
+11140..11143 ; L # Po [4] CHAKMA SECTION MARK..CHAKMA QUESTION MARK
+11182 ; L # Mc SHARADA SIGN VISARGA
+11183..111B2 ; L # Lo [48] SHARADA LETTER A..SHARADA LETTER HA
+111B3..111B5 ; L # Mc [3] SHARADA VOWEL SIGN AA..SHARADA VOWEL SIGN II
+111BF..111C0 ; L # Mc [2] SHARADA VOWEL SIGN AU..SHARADA SIGN VIRAMA
+111C1..111C4 ; L # Lo [4] SHARADA SIGN AVAGRAHA..SHARADA OM
+111C5..111C8 ; L # Po [4] SHARADA DANDA..SHARADA SEPARATOR
+111D0..111D9 ; L # Nd [10] SHARADA DIGIT ZERO..SHARADA DIGIT NINE
+11680..116AA ; L # Lo [43] TAKRI LETTER A..TAKRI LETTER RRA
+116AC ; L # Mc TAKRI SIGN VISARGA
+116AE..116AF ; L # Mc [2] TAKRI VOWEL SIGN I..TAKRI VOWEL SIGN II
+116B6 ; L # Mc TAKRI SIGN VIRAMA
+116C0..116C9 ; L # Nd [10] TAKRI DIGIT ZERO..TAKRI DIGIT NINE
12000..1236E ; L # Lo [879] CUNEIFORM SIGN A..CUNEIFORM SIGN ZUM
12400..12462 ; L # Nl [99] CUNEIFORM NUMERIC SIGN TWO ASH..CUNEIFORM NUMERIC SIGN OLD ASSYRIAN ONE QUARTER
12470..12473 ; L # Po [4] CUNEIFORM PUNCTUATION SIGN OLD ASSYRIAN WORD DIVIDER..CUNEIFORM PUNCTUATION SIGN DIAGONAL TRICOLON
13000..1342E ; L # Lo [1071] EGYPTIAN HIEROGLYPH A001..EGYPTIAN HIEROGLYPH AA032
16800..16A38 ; L # Lo [569] BAMUM LETTER PHASE-A NGKUE MFON..BAMUM LETTER PHASE-F VUEQ
+16F00..16F44 ; L # Lo [69] MIAO LETTER PA..MIAO LETTER HHA
+16F50 ; L # Lo MIAO LETTER NASALIZATION
+16F51..16F7E ; L # Mc [46] MIAO SIGN ASPIRATION..MIAO VOWEL SIGN NG
+16F93..16F9F ; L # Lm [13] MIAO LETTER TONE-2..MIAO LETTER REFORMED TONE-8
1B000..1B001 ; L # Lo [2] KATAKANA LETTER ARCHAIC E..HIRAGANA LETTER ARCHAIC YE
1D000..1D0F5 ; L # So [246] BYZANTINE MUSICAL SYMBOL PSILI..BYZANTINE MUSICAL SYMBOL GORGON NEO KATO
1D100..1D126 ; L # So [39] MUSICAL SYMBOL SINGLE BARLINE..MUSICAL SYMBOL DRUM CLEF-2
@@ -753,8 +800,6 @@
1F210..1F23A ; L # So [43] SQUARED CJK UNIFIED IDEOGRAPH-624B..SQUARED CJK UNIFIED IDEOGRAPH-55B6
1F240..1F248 ; L # So [9] TORTOISE SHELL BRACKETED CJK UNIFIED IDEOGRAPH-672C..TORTOISE SHELL BRACKETED CJK UNIFIED IDEOGRAPH-6557
1F250..1F251 ; L # So [2] CIRCLED IDEOGRAPH ADVANTAGE..CIRCLED IDEOGRAPH ACCEPT
-1F48C ; L # So LOVE LETTER
-1F524 ; L # So INPUT SYMBOL FOR LATIN LETTERS
20000..2A6D6 ; L # Lo [42711] CJK UNIFIED IDEOGRAPH-20000..CJK UNIFIED IDEOGRAPH-2A6D6
2A700..2B734 ; L # Lo [4149] CJK UNIFIED IDEOGRAPH-2A700..CJK UNIFIED IDEOGRAPH-2B734
2B740..2B81D ; L # Lo [222] CJK UNIFIED IDEOGRAPH-2B740..CJK UNIFIED IDEOGRAPH-2B81D
@@ -762,8 +807,8 @@
F0000..FFFFD ; L # Co [65534] <private-use-F0000>..<private-use-FFFFD>
100000..10FFFD; L # Co [65534] <private-use-100000>..<private-use-10FFFD>
-# The above property value applies to 859451 code points not listed here.
-# Total code points: 1098619
+# The above property value applies to 858959 code points not listed here.
+# Total code points: 1098530
# ================================================
@@ -795,7 +840,7 @@
0840..0858 ; R # Lo [25] MANDAIC LETTER HALQA..MANDAIC LETTER AIN
085C..085D ; R # Cn [2] <reserved-085C>..<reserved-085D>
085E ; R # Po MANDAIC PUNCTUATION
-085F..08FF ; R # Cn [161] <reserved-085F>..<reserved-08FF>
+085F..089F ; R # Cn [65] <reserved-085F>..<reserved-089F>
200F ; R # Cf RIGHT-TO-LEFT MARK
FB1D ; R # Lo HEBREW LETTER YOD WITH HIRIQ
FB1F..FB28 ; R # Lo [10] HEBREW LIGATURE YIDDISH YOD YOD PATAH..HEBREW LETTER WIDE TAV
@@ -831,7 +876,11 @@
10920..10939 ; R # Lo [26] LYDIAN LETTER A..LYDIAN LETTER C
1093A..1093E ; R # Cn [5] <reserved-1093A>..<reserved-1093E>
1093F ; R # Po LYDIAN TRIANGULAR MARK
-10940..109FF ; R # Cn [192] <reserved-10940>..<reserved-109FF>
+10940..1097F ; R # Cn [64] <reserved-10940>..<reserved-1097F>
+10980..109B7 ; R # Lo [56] MEROITIC HIEROGLYPHIC LETTER A..MEROITIC CURSIVE LETTER DA
+109B8..109BD ; R # Cn [6] <reserved-109B8>..<reserved-109BD>
+109BE..109BF ; R # Lo [2] MEROITIC CURSIVE LOGOGRAM RMT..MEROITIC CURSIVE LOGOGRAM IMN
+109C0..109FF ; R # Cn [64] <reserved-109C0>..<reserved-109FF>
10A00 ; R # Lo KHAROSHTHI LETTER A
10A04 ; R # Cn <reserved-10A04>
10A07..10A0B ; R # Cn [5] <reserved-10A07>..<reserved-10A0B>
@@ -862,9 +911,10 @@
10C00..10C48 ; R # Lo [73] OLD TURKIC LETTER ORKHON A..OLD TURKIC LETTER ORKHON BASH
10C49..10E5F ; R # Cn [535] <reserved-10C49>..<reserved-10E5F>
10E7F..10FFF ; R # Cn [385] <reserved-10E7F>..<reserved-10FFF>
-1E800..1EFFF ; R # Cn [2048] <reserved-1E800>..<reserved-1EFFF>
+1E800..1EDFF ; R # Cn [1536] <reserved-1E800>..<reserved-1EDFF>
+1EF00..1EFFF ; R # Cn [256] <reserved-1EF00>..<reserved-1EFFF>
-# Total code points: 4438
+# Total code points: 4086
# ================================================
@@ -911,6 +961,7 @@
00A2..00A5 ; ET # Sc [4] CENT SIGN..YEN SIGN
00B0 ; ET # So DEGREE SIGN
00B1 ; ET # Sm PLUS-MINUS SIGN
+058F ; ET # Sc ARMENIAN DRAM SIGN
0609..060A ; ET # Po [2] ARABIC-INDIC PER MILLE SIGN..ARABIC-INDIC PER TEN THOUSAND SIGN
066A ; ET # Po ARABIC PERCENT SIGN
09F2..09F3 ; ET # Sc [2] BENGALI RUPEE MARK..BENGALI RUPEE SIGN
@@ -920,7 +971,7 @@
0E3F ; ET # Sc THAI CURRENCY SYMBOL BAHT
17DB ; ET # Sc KHMER CURRENCY SYMBOL RIEL
2030..2034 ; ET # Po [5] PER MILLE SIGN..TRIPLE PRIME
-20A0..20B9 ; ET # Sc [26] EURO-CURRENCY SIGN..INDIAN RUPEE SIGN
+20A0..20BA ; ET # Sc [27] EURO-CURRENCY SIGN..TURKISH LIRA SIGN
212E ; ET # So ESTIMATED SYMBOL
2213 ; ET # Sm MINUS-OR-PLUS SIGN
A838 ; ET # Sc NORTH INDIC RUPEE MARK
@@ -934,17 +985,16 @@
FFE0..FFE1 ; ET # Sc [2] FULLWIDTH CENT SIGN..FULLWIDTH POUND SIGN
FFE5..FFE6 ; ET # Sc [2] FULLWIDTH YEN SIGN..FULLWIDTH WON SIGN
-# Total code points: 64
+# Total code points: 66
# ================================================
# Bidi_Class=Arabic_Number
-0600..0603 ; AN # Cf [4] ARABIC NUMBER SIGN..ARABIC SIGN SAFHA
+0600..0604 ; AN # Cf [5] ARABIC NUMBER SIGN..ARABIC SIGN SAMVAT
0660..0669 ; AN # Nd [10] ARABIC-INDIC DIGIT ZERO..ARABIC-INDIC DIGIT NINE
066B..066C ; AN # Po [2] ARABIC DECIMAL SEPARATOR..ARABIC THOUSANDS SEPARATOR
06DD ; AN # Cf ARABIC END OF AYAH
-070F ; AN # Cf SYRIAC ABBREVIATION MARK
10E60..10E7E ; AN # No [31] RUMI DIGIT ONE..RUMI FRACTION TWO THIRDS
# Total code points: 49
@@ -1029,7 +1079,8 @@
007D ; ON # Pe RIGHT CURLY BRACKET
007E ; ON # Sm TILDE
00A1 ; ON # Po INVERTED EXCLAMATION MARK
-00A6..00A7 ; ON # So [2] BROKEN BAR..SECTION SIGN
+00A6 ; ON # So BROKEN BAR
+00A7 ; ON # Po SECTION SIGN
00A8 ; ON # Sk DIAERESIS
00A9 ; ON # So COPYRIGHT SIGN
00AB ; ON # Pi LEFT-POINTING DOUBLE ANGLE QUOTATION MARK
@@ -1037,8 +1088,7 @@
00AE ; ON # So REGISTERED SIGN
00AF ; ON # Sk MACRON
00B4 ; ON # Sk ACUTE ACCENT
-00B6 ; ON # So PILCROW SIGN
-00B7 ; ON # Po MIDDLE DOT
+00B6..00B7 ; ON # Po [2] PILCROW SIGN..MIDDLE DOT
00B8 ; ON # Sk CEDILLA
00BB ; ON # Pf RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK
00BC..00BE ; ON # No [3] VULGAR FRACTION ONE QUARTER..VULGAR FRACTION THREE QUARTERS
@@ -1206,9 +1256,7 @@
27C0..27C4 ; ON # Sm [5] THREE DIMENSIONAL ANGLE..OPEN SUPERSET
27C5 ; ON # Ps LEFT S-SHAPED BAG DELIMITER
27C6 ; ON # Pe RIGHT S-SHAPED BAG DELIMITER
-27C7..27CA ; ON # Sm [4] OR WITH DOT INSIDE..VERTICAL BAR WITH HORIZONTAL STROKE
-27CC ; ON # Sm LONG DIVISION
-27CE..27E5 ; ON # Sm [24] SQUARED LOGICAL AND..WHITE SQUARE WITH RIGHTWARDS TICK
+27C7..27E5 ; ON # Sm [31] OR WITH DOT INSIDE..WHITE SQUARE WITH RIGHTWARDS TICK
27E6 ; ON # Ps MATHEMATICAL LEFT WHITE SQUARE BRACKET
27E7 ; ON # Pe MATHEMATICAL RIGHT WHITE SQUARE BRACKET
27E8 ; ON # Ps MATHEMATICAL LEFT ANGLE BRACKET
@@ -1292,7 +1340,8 @@
2E29 ; ON # Pe RIGHT DOUBLE PARENTHESIS
2E2A..2E2E ; ON # Po [5] TWO DOTS OVER ONE DOT PUNCTUATION..REVERSED QUESTION MARK
2E2F ; ON # Lm VERTICAL TILDE
-2E30..2E31 ; ON # Po [2] RING POINT..WORD SEPARATOR MIDDLE DOT
+2E30..2E39 ; ON # Po [10] RING POINT..TOP HALF SECTION SIGN
+2E3A..2E3B ; ON # Pd [2] TWO-EM DASH..THREE-EM DASH
2E80..2E99 ; ON # So [26] CJK RADICAL REPEAT..CJK RADICAL RAP
2E9B..2EF3 ; ON # So [89] CJK RADICAL CHOKE..CJK RADICAL C-SIMPLIFIED TURTLE
2F00..2FD5 ; ON # So [214] KANGXI RADICAL ONE..KANGXI RADICAL FLUTE
@@ -1445,6 +1494,7 @@
1D74F ; ON # Sm MATHEMATICAL BOLD ITALIC PARTIAL DIFFERENTIAL
1D789 ; ON # Sm MATHEMATICAL SANS-SERIF BOLD PARTIAL DIFFERENTIAL
1D7C3 ; ON # Sm MATHEMATICAL SANS-SERIF BOLD ITALIC PARTIAL DIFFERENTIAL
+1EEF0..1EEF1 ; ON # Sm [2] ARABIC MATHEMATICAL OPERATOR MEEM WITH HAH WITH TATWEEL..ARABIC MATHEMATICAL OPERATOR HAH WITH DAL
1F000..1F02B ; ON # So [44] MAHJONG TILE EAST WIND..MAHJONG TILE BACK
1F030..1F093 ; ON # So [100] DOMINO TILE HORIZONTAL BACK..DOMINO TILE VERTICAL-06-06
1F0A0..1F0AE ; ON # So [15] PLAYING CARD BACK..PLAYING CARD KING OF SPADES
@@ -1451,6 +1501,7 @@
1F0B1..1F0BE ; ON # So [14] PLAYING CARD ACE OF HEARTS..PLAYING CARD KING OF HEARTS
1F0C1..1F0CF ; ON # So [15] PLAYING CARD ACE OF DIAMONDS..PLAYING CARD BLACK JOKER
1F0D1..1F0DF ; ON # So [15] PLAYING CARD ACE OF CLUBS..PLAYING CARD WHITE JOKER
+1F16A..1F16B ; ON # So [2] RAISED MC SIGN..RAISED MD SIGN
1F300..1F320 ; ON # So [33] CYCLONE..SHOOTING STAR
1F330..1F335 ; ON # So [6] CHESTNUT..CACTUS
1F337..1F37C ; ON # So [70] TULIP..BABY BOTTLE
@@ -1460,29 +1511,17 @@
1F3E0..1F3F0 ; ON # So [17] HOUSE BUILDING..EUROPEAN CASTLE
1F400..1F43E ; ON # So [63] RAT..PAW PRINTS
1F440 ; ON # So EYES
-1F442..1F48B ; ON # So [74] EAR..KISS MARK
-1F48D..1F4F7 ; ON # So [107] RING..CAMERA
+1F442..1F4F7 ; ON # So [182] EAR..CAMERA
1F4F9..1F4FC ; ON # So [4] VIDEO CAMERA..VIDEOCASSETTE
-1F500..1F523 ; ON # So [36] TWISTED RIGHTWARDS ARROWS..INPUT SYMBOL FOR SYMBOLS
-1F525..1F53D ; ON # So [25] FIRE..DOWN-POINTING SMALL RED TRIANGLE
+1F500..1F53D ; ON # So [62] TWISTED RIGHTWARDS ARROWS..DOWN-POINTING SMALL RED TRIANGLE
+1F540..1F543 ; ON # So [4] CIRCLED CROSS POMMEE..NOTCHED LEFT SEMICIRCLE WITH THREE DOTS
1F550..1F567 ; ON # So [24] CLOCK FACE ONE OCLOCK..CLOCK FACE TWELVE-THIRTY
-1F5FB..1F5FF ; ON # So [5] MOUNT FUJI..MOYAI
-1F601..1F610 ; ON # So [16] GRINNING FACE WITH SMILING EYES..NEUTRAL FACE
-1F612..1F614 ; ON # So [3] UNAMUSED FACE..PENSIVE FACE
-1F616 ; ON # So CONFOUNDED FACE
-1F618 ; ON # So FACE THROWING A KISS
-1F61A ; ON # So KISSING FACE WITH CLOSED EYES
-1F61C..1F61E ; ON # So [3] FACE WITH STUCK-OUT TONGUE AND WINKING EYE..DISAPPOINTED FACE
-1F620..1F625 ; ON # So [6] ANGRY FACE..DISAPPOINTED BUT RELIEVED FACE
-1F628..1F62B ; ON # So [4] FEARFUL FACE..TIRED FACE
-1F62D ; ON # So LOUDLY CRYING FACE
-1F630..1F633 ; ON # So [4] FACE WITH OPEN MOUTH AND COLD SWEAT..FLUSHED FACE
-1F635..1F640 ; ON # So [12] DIZZY FACE..WEARY CAT FACE
+1F5FB..1F640 ; ON # So [70] MOUNT FUJI..WEARY CAT FACE
1F645..1F64F ; ON # So [11] FACE WITH NO GOOD GESTURE..PERSON WITH FOLDED HANDS
1F680..1F6C5 ; ON # So [70] ROCKET..LEFT LUGGAGE
1F700..1F773 ; ON # So [116] ALCHEMICAL SYMBOL FOR QUINTESSENCE..ALCHEMICAL SYMBOL FOR HALF OUNCE
-# Total code points: 4412
+# Total code points: 4447
# ================================================
@@ -1554,6 +1593,7 @@
0825..0827 ; NSM # Mn [3] SAMARITAN VOWEL SIGN SHORT A..SAMARITAN VOWEL SIGN U
0829..082D ; NSM # Mn [5] SAMARITAN VOWEL SIGN LONG I..SAMARITAN MARK NEQUDAA
0859..085B ; NSM # Mn [3] MANDAIC AFFRICATION MARK..MANDAIC GEMINATION MARK
+08E4..08FE ; NSM # Mn [27] ARABIC CURLY FATHA..ARABIC DAMMA WITH DOT
0900..0902 ; NSM # Mn [3] DEVANAGARI SIGN INVERTED CANDRABINDU..DEVANAGARI SIGN ANUSVARA
093A ; NSM # Mn DEVANAGARI VOWEL SIGN OE
093C ; NSM # Mn DEVANAGARI SIGN NUKTA
@@ -1637,6 +1677,7 @@
1732..1734 ; NSM # Mn [3] HANUNOO VOWEL SIGN I..HANUNOO SIGN PAMUDPOD
1752..1753 ; NSM # Mn [2] BUHID VOWEL SIGN I..BUHID VOWEL SIGN U
1772..1773 ; NSM # Mn [2] TAGBANWA VOWEL SIGN I..TAGBANWA VOWEL SIGN U
+17B4..17B5 ; NSM # Mn [2] KHMER VOWEL INHERENT AQ..KHMER VOWEL INHERENT AA
17B7..17BD ; NSM # Mn [7] KHMER VOWEL SIGN I..KHMER VOWEL SIGN UA
17C6 ; NSM # Mn KHMER SIGN NIKAHIT
17C9..17D3 ; NSM # Mn [11] KHMER SIGN MUUSIKATOAN..KHMER SIGN BATHAMASAT
@@ -1664,6 +1705,7 @@
1B80..1B81 ; NSM # Mn [2] SUNDANESE SIGN PANYECEK..SUNDANESE SIGN PANGLAYAR
1BA2..1BA5 ; NSM # Mn [4] SUNDANESE CONSONANT SIGN PANYAKRA..SUNDANESE VOWEL SIGN PANYUKU
1BA8..1BA9 ; NSM # Mn [2] SUNDANESE VOWEL SIGN PAMEPET..SUNDANESE VOWEL SIGN PANEULEUNG
+1BAB ; NSM # Mn SUNDANESE SIGN VIRAMA
1BE6 ; NSM # Mn BATAK SIGN TOMPI
1BE8..1BE9 ; NSM # Mn [2] BATAK VOWEL SIGN PAKPAK E..BATAK VOWEL SIGN EE
1BED ; NSM # Mn BATAK VOWEL SIGN KARO O
@@ -1674,6 +1716,7 @@
1CD4..1CE0 ; NSM # Mn [13] VEDIC SIGN YAJURVEDIC MIDLINE SVARITA..VEDIC TONE RIGVEDIC KASHMIRI INDEPENDENT SVARITA
1CE2..1CE8 ; NSM # Mn [7] VEDIC SIGN VISARGA SVARITA..VEDIC SIGN VISARGA ANUDATTA WITH TAIL
1CED ; NSM # Mn VEDIC SIGN TIRYAK
+1CF4 ; NSM # Mn VEDIC TONE CANDRA ABOVE
1DC0..1DE6 ; NSM # Mn [39] COMBINING DOTTED GRAVE ACCENT..COMBINING LATIN SMALL LETTER Z
1DFC..1DFF ; NSM # Mn [4] COMBINING DOUBLE INVERTED BREVE BELOW..COMBINING RIGHT ARROWHEAD AND DOWN ARROWHEAD BELOW
20D0..20DC ; NSM # Mn [13] COMBINING LEFT HARPOON ABOVE..COMBINING FOUR DOTS ABOVE
@@ -1684,11 +1727,12 @@
2CEF..2CF1 ; NSM # Mn [3] COPTIC COMBINING NI ABOVE..COPTIC COMBINING SPIRITUS LENIS
2D7F ; NSM # Mn TIFINAGH CONSONANT JOINER
2DE0..2DFF ; NSM # Mn [32] COMBINING CYRILLIC LETTER BE..COMBINING CYRILLIC LETTER IOTIFIED BIG YUS
-302A..302F ; NSM # Mn [6] IDEOGRAPHIC LEVEL TONE MARK..HANGUL DOUBLE DOT TONE MARK
+302A..302D ; NSM # Mn [4] IDEOGRAPHIC LEVEL TONE MARK..IDEOGRAPHIC ENTERING TONE MARK
3099..309A ; NSM # Mn [2] COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK..COMBINING KATAKANA-HIRAGANA SEMI-VOICED SOUND MARK
A66F ; NSM # Mn COMBINING CYRILLIC VZMET
A670..A672 ; NSM # Me [3] COMBINING CYRILLIC TEN MILLIONS SIGN..COMBINING CYRILLIC THOUSAND MILLIONS SIGN
-A67C..A67D ; NSM # Mn [2] COMBINING CYRILLIC KAVYKA..COMBINING CYRILLIC PAYEROK
+A674..A67D ; NSM # Mn [10] COMBINING CYRILLIC LETTER UKRAINIAN IE..COMBINING CYRILLIC PAYEROK
+A69F ; NSM # Mn COMBINING CYRILLIC LETTER IOTIFIED E
A6F0..A6F1 ; NSM # Mn [2] BAMUM COMBINING MARK KOQNDON..BAMUM COMBINING MARK TUKWENTIS
A802 ; NSM # Mn SYLOTI NAGRI SIGN DVISVARA
A806 ; NSM # Mn SYLOTI NAGRI SIGN HASANTA
@@ -1712,6 +1756,8 @@
AAB7..AAB8 ; NSM # Mn [2] TAI VIET MAI KHIT..TAI VIET VOWEL IA
AABE..AABF ; NSM # Mn [2] TAI VIET VOWEL AM..TAI VIET TONE MAI EK
AAC1 ; NSM # Mn TAI VIET TONE MAI THO
+AAEC..AAED ; NSM # Mn [2] MEETEI MAYEK VOWEL SIGN UU..MEETEI MAYEK VOWEL SIGN AAI
+AAF6 ; NSM # Mn MEETEI MAYEK VIRAMA
ABE5 ; NSM # Mn MEETEI MAYEK VOWEL SIGN ANAP
ABE8 ; NSM # Mn MEETEI MAYEK VOWEL SIGN UNAP
ABED ; NSM # Mn MEETEI MAYEK APUN IYEK
@@ -1729,6 +1775,16 @@
11080..11081 ; NSM # Mn [2] KAITHI SIGN CANDRABINDU..KAITHI SIGN ANUSVARA
110B3..110B6 ; NSM # Mn [4] KAITHI VOWEL SIGN U..KAITHI VOWEL SIGN AI
110B9..110BA ; NSM # Mn [2] KAITHI SIGN VIRAMA..KAITHI SIGN NUKTA
+11100..11102 ; NSM # Mn [3] CHAKMA SIGN CANDRABINDU..CHAKMA SIGN VISARGA
+11127..1112B ; NSM # Mn [5] CHAKMA VOWEL SIGN A..CHAKMA VOWEL SIGN UU
+1112D..11134 ; NSM # Mn [8] CHAKMA VOWEL SIGN AI..CHAKMA MAAYYAA
+11180..11181 ; NSM # Mn [2] SHARADA SIGN CANDRABINDU..SHARADA SIGN ANUSVARA
+111B6..111BE ; NSM # Mn [9] SHARADA VOWEL SIGN U..SHARADA VOWEL SIGN O
+116AB ; NSM # Mn TAKRI SIGN ANUSVARA
+116AD ; NSM # Mn TAKRI VOWEL SIGN AA
+116B0..116B5 ; NSM # Mn [6] TAKRI VOWEL SIGN U..TAKRI VOWEL SIGN AU
+116B7 ; NSM # Mn TAKRI SIGN NUKTA
+16F8F..16F92 ; NSM # Mn [4] MIAO TONE RIGHT..MIAO TONE BELOW
1D167..1D169 ; NSM # Mn [3] MUSICAL SYMBOL COMBINING TREMOLO-1..MUSICAL SYMBOL COMBINING TREMOLO-3
1D17B..1D182 ; NSM # Mn [8] MUSICAL SYMBOL COMBINING ACCENT..MUSICAL SYMBOL COMBINING LOURE
1D185..1D18B ; NSM # Mn [7] MUSICAL SYMBOL COMBINING DOIT..MUSICAL SYMBOL COMBINING TRIPLE TONGUE
@@ -1736,13 +1792,13 @@
1D242..1D244 ; NSM # Mn [3] COMBINING GREEK MUSICAL TRISEME..COMBINING GREEK MUSICAL PENTASEME
E0100..E01EF ; NSM # Mn [240] VARIATION SELECTOR-17..VARIATION SELECTOR-256
-# Total code points: 1209
+# Total code points: 1290
# ================================================
# Bidi_Class=Arabic_Letter
-0604..0605 ; AL # Cn [2] <reserved-0604>..<reserved-0605>
+0605 ; AL # Cn <reserved-0605>
0608 ; AL # Sm ARABIC RAY
060B ; AL # Sc AFGHANI SIGN
060D ; AL # Po ARABIC DATE SEPARATOR
@@ -1764,6 +1820,7 @@
06FF ; AL # Lo ARABIC LETTER HEH WITH INVERTED V
0700..070D ; AL # Po [14] SYRIAC END OF PARAGRAPH..SYRIAC HARKLEAN ASTERISCUS
070E ; AL # Cn <reserved-070E>
+070F ; AL # Cf SYRIAC ABBREVIATION MARK
0710 ; AL # Lo SYRIAC LETTER ALAPH
0712..072F ; AL # Lo [30] SYRIAC LETTER BETH..SYRIAC LETTER PERSIAN DHALATH
074B..074C ; AL # Cn [2] <reserved-074B>..<reserved-074C>
@@ -1770,6 +1827,11 @@
074D..07A5 ; AL # Lo [89] SYRIAC LETTER SOGDIAN ZHAIN..THAANA LETTER WAAVU
07B1 ; AL # Lo THAANA LETTER NAA
07B2..07BF ; AL # Cn [14] <reserved-07B2>..<reserved-07BF>
+08A0 ; AL # Lo ARABIC LETTER BEH WITH SMALL V BELOW
+08A1 ; AL # Cn <reserved-08A1>
+08A2..08AC ; AL # Lo [11] ARABIC LETTER JEEM WITH TWO DOTS ABOVE..ARABIC LETTER ROHINGYA YEH
+08AD..08E3 ; AL # Cn [55] <reserved-08AD>..<reserved-08E3>
+08FF ; AL # Cn <reserved-08FF>
FB50..FBB1 ; AL # Lo [98] ARABIC LETTER ALEF WASLA ISOLATED FORM..ARABIC LETTER YEH BARREE WITH HAMZA ABOVE FINAL FORM
FBB2..FBC1 ; AL # Sk [16] ARABIC SYMBOL DOT ABOVE..ARABIC SYMBOL SMALL TAH BELOW
FBC2..FBD2 ; AL # Cn [17] <reserved-FBC2>..<reserved-FBD2>
@@ -1786,8 +1848,75 @@
FE75 ; AL # Cn <reserved-FE75>
FE76..FEFC ; AL # Lo [135] ARABIC FATHA ISOLATED FORM..ARABIC LIGATURE LAM WITH ALEF FINAL FORM
FEFD..FEFE ; AL # Cn [2] <reserved-FEFD>..<reserved-FEFE>
+1EE00..1EE03 ; AL # Lo [4] ARABIC MATHEMATICAL ALEF..ARABIC MATHEMATICAL DAL
+1EE04 ; AL # Cn <reserved-1EE04>
+1EE05..1EE1F ; AL # Lo [27] ARABIC MATHEMATICAL WAW..ARABIC MATHEMATICAL DOTLESS QAF
+1EE20 ; AL # Cn <reserved-1EE20>
+1EE21..1EE22 ; AL # Lo [2] ARABIC MATHEMATICAL INITIAL BEH..ARABIC MATHEMATICAL INITIAL JEEM
+1EE23 ; AL # Cn <reserved-1EE23>
+1EE24 ; AL # Lo ARABIC MATHEMATICAL INITIAL HEH
+1EE25..1EE26 ; AL # Cn [2] <reserved-1EE25>..<reserved-1EE26>
+1EE27 ; AL # Lo ARABIC MATHEMATICAL INITIAL HAH
+1EE28 ; AL # Cn <reserved-1EE28>
+1EE29..1EE32 ; AL # Lo [10] ARABIC MATHEMATICAL INITIAL YEH..ARABIC MATHEMATICAL INITIAL QAF
+1EE33 ; AL # Cn <reserved-1EE33>
+1EE34..1EE37 ; AL # Lo [4] ARABIC MATHEMATICAL INITIAL SHEEN..ARABIC MATHEMATICAL INITIAL KHAH
+1EE38 ; AL # Cn <reserved-1EE38>
+1EE39 ; AL # Lo ARABIC MATHEMATICAL INITIAL DAD
+1EE3A ; AL # Cn <reserved-1EE3A>
+1EE3B ; AL # Lo ARABIC MATHEMATICAL INITIAL GHAIN
+1EE3C..1EE41 ; AL # Cn [6] <reserved-1EE3C>..<reserved-1EE41>
+1EE42 ; AL # Lo ARABIC MATHEMATICAL TAILED JEEM
+1EE43..1EE46 ; AL # Cn [4] <reserved-1EE43>..<reserved-1EE46>
+1EE47 ; AL # Lo ARABIC MATHEMATICAL TAILED HAH
+1EE48 ; AL # Cn <reserved-1EE48>
+1EE49 ; AL # Lo ARABIC MATHEMATICAL TAILED YEH
+1EE4A ; AL # Cn <reserved-1EE4A>
+1EE4B ; AL # Lo ARABIC MATHEMATICAL TAILED LAM
+1EE4C ; AL # Cn <reserved-1EE4C>
+1EE4D..1EE4F ; AL # Lo [3] ARABIC MATHEMATICAL TAILED NOON..ARABIC MATHEMATICAL TAILED AIN
+1EE50 ; AL # Cn <reserved-1EE50>
+1EE51..1EE52 ; AL # Lo [2] ARABIC MATHEMATICAL TAILED SAD..ARABIC MATHEMATICAL TAILED QAF
+1EE53 ; AL # Cn <reserved-1EE53>
+1EE54 ; AL # Lo ARABIC MATHEMATICAL TAILED SHEEN
+1EE55..1EE56 ; AL # Cn [2] <reserved-1EE55>..<reserved-1EE56>
+1EE57 ; AL # Lo ARABIC MATHEMATICAL TAILED KHAH
+1EE58 ; AL # Cn <reserved-1EE58>
+1EE59 ; AL # Lo ARABIC MATHEMATICAL TAILED DAD
+1EE5A ; AL # Cn <reserved-1EE5A>
+1EE5B ; AL # Lo ARABIC MATHEMATICAL TAILED GHAIN
+1EE5C ; AL # Cn <reserved-1EE5C>
+1EE5D ; AL # Lo ARABIC MATHEMATICAL TAILED DOTLESS NOON
+1EE5E ; AL # Cn <reserved-1EE5E>
+1EE5F ; AL # Lo ARABIC MATHEMATICAL TAILED DOTLESS QAF
+1EE60 ; AL # Cn <reserved-1EE60>
+1EE61..1EE62 ; AL # Lo [2] ARABIC MATHEMATICAL STRETCHED BEH..ARABIC MATHEMATICAL STRETCHED JEEM
+1EE63 ; AL # Cn <reserved-1EE63>
+1EE64 ; AL # Lo ARABIC MATHEMATICAL STRETCHED HEH
+1EE65..1EE66 ; AL # Cn [2] <reserved-1EE65>..<reserved-1EE66>
+1EE67..1EE6A ; AL # Lo [4] ARABIC MATHEMATICAL STRETCHED HAH..ARABIC MATHEMATICAL STRETCHED KAF
+1EE6B ; AL # Cn <reserved-1EE6B>
+1EE6C..1EE72 ; AL # Lo [7] ARABIC MATHEMATICAL STRETCHED MEEM..ARABIC MATHEMATICAL STRETCHED QAF
+1EE73 ; AL # Cn <reserved-1EE73>
+1EE74..1EE77 ; AL # Lo [4] ARABIC MATHEMATICAL STRETCHED SHEEN..ARABIC MATHEMATICAL STRETCHED KHAH
+1EE78 ; AL # Cn <reserved-1EE78>
+1EE79..1EE7C ; AL # Lo [4] ARABIC MATHEMATICAL STRETCHED DAD..ARABIC MATHEMATICAL STRETCHED DOTLESS BEH
+1EE7D ; AL # Cn <reserved-1EE7D>
+1EE7E ; AL # Lo ARABIC MATHEMATICAL STRETCHED DOTLESS FEH
+1EE7F ; AL # Cn <reserved-1EE7F>
+1EE80..1EE89 ; AL # Lo [10] ARABIC MATHEMATICAL LOOPED ALEF..ARABIC MATHEMATICAL LOOPED YEH
+1EE8A ; AL # Cn <reserved-1EE8A>
+1EE8B..1EE9B ; AL # Lo [17] ARABIC MATHEMATICAL LOOPED LAM..ARABIC MATHEMATICAL LOOPED GHAIN
+1EE9C..1EEA0 ; AL # Cn [5] <reserved-1EE9C>..<reserved-1EEA0>
+1EEA1..1EEA3 ; AL # Lo [3] ARABIC MATHEMATICAL DOUBLE-STRUCK BEH..ARABIC MATHEMATICAL DOUBLE-STRUCK DAL
+1EEA4 ; AL # Cn <reserved-1EEA4>
+1EEA5..1EEA9 ; AL # Lo [5] ARABIC MATHEMATICAL DOUBLE-STRUCK WAW..ARABIC MATHEMATICAL DOUBLE-STRUCK YEH
+1EEAA ; AL # Cn <reserved-1EEAA>
+1EEAB..1EEBB ; AL # Lo [17] ARABIC MATHEMATICAL DOUBLE-STRUCK LAM..ARABIC MATHEMATICAL DOUBLE-STRUCK GHAIN
+1EEBC..1EEEF ; AL # Cn [52] <reserved-1EEBC>..<reserved-1EEEF>
+1EEF2..1EEFF ; AL # Cn [14] <reserved-1EEF2>..<reserved-1EEFF>
-# Total code points: 1115
+# Total code points: 1438
# ================================================
Property changes on: trunk/contrib/perl/lib/unicore/extracted/DBidiClass.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/extracted/DBinaryProperties.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/extracted/DBinaryProperties.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/extracted/DBinaryProperties.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,8 +1,8 @@
-# DerivedBinaryProperties-6.0.0.txt
-# Date: 2010-05-18, 00:49:04 GMT [MD]
+# DerivedBinaryProperties-6.2.0.txt
+# Date: 2012-05-23, 20:34:43 GMT [MD]
#
# Unicode Character Database
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
# For documentation, see http://www.unicode.org/reports/tr44/
@@ -83,7 +83,7 @@
27C5 ; Bidi_Mirrored # Ps LEFT S-SHAPED BAG DELIMITER
27C6 ; Bidi_Mirrored # Pe RIGHT S-SHAPED BAG DELIMITER
27C8..27C9 ; Bidi_Mirrored # Sm [2] REVERSE SOLIDUS PRECEDING SUBSET..SUPERSET PRECEDING SOLIDUS
-27CC ; Bidi_Mirrored # Sm LONG DIVISION
+27CB..27CD ; Bidi_Mirrored # Sm [3] MATHEMATICAL RISING DIAGONAL..MATHEMATICAL FALLING DIAGONAL
27D3..27D6 ; Bidi_Mirrored # Sm [4] LOWER RIGHT CORNER WITH DOT..RIGHT OUTER JOIN
27DC..27DE ; Bidi_Mirrored # Sm [3] LEFT MULTIMAP..LONG LEFT TACK
27E2..27E5 ; Bidi_Mirrored # Sm [4] WHITE CONCAVE-SIDED DIAMOND WITH LEFTWARDS TICK..WHITE SQUARE WITH RIGHTWARDS TICK
@@ -222,6 +222,6 @@
1D789 ; Bidi_Mirrored # Sm MATHEMATICAL SANS-SERIF BOLD PARTIAL DIFFERENTIAL
1D7C3 ; Bidi_Mirrored # Sm MATHEMATICAL SANS-SERIF BOLD ITALIC PARTIAL DIFFERENTIAL
-# Total code points: 543
+# Total code points: 545
# EOF
Property changes on: trunk/contrib/perl/lib/unicore/extracted/DBinaryProperties.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/extracted/DCombiningClass.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/extracted/DCombiningClass.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/extracted/DCombiningClass.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,8 +1,8 @@
-# DerivedCombiningClass-6.0.0.txt
-# Date: 2010-08-19, 00:48:04 GMT [MD]
+# DerivedCombiningClass-6.2.0.txt
+# Date: 2012-08-13, 19:56:56 GMT [MD]
#
# Unicode Character Database
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
# For documentation, see http://www.unicode.org/reports/tr44/
@@ -51,10 +51,11 @@
00A0 ; 0 # Zs NO-BREAK SPACE
00A1 ; 0 # Po INVERTED EXCLAMATION MARK
00A2..00A5 ; 0 # Sc [4] CENT SIGN..YEN SIGN
-00A6..00A7 ; 0 # So [2] BROKEN BAR..SECTION SIGN
+00A6 ; 0 # So BROKEN BAR
+00A7 ; 0 # Po SECTION SIGN
00A8 ; 0 # Sk DIAERESIS
00A9 ; 0 # So COPYRIGHT SIGN
-00AA ; 0 # L& FEMININE ORDINAL INDICATOR
+00AA ; 0 # Lo FEMININE ORDINAL INDICATOR
00AB ; 0 # Pi LEFT-POINTING DOUBLE ANGLE QUOTATION MARK
00AC ; 0 # Sm NOT SIGN
00AD ; 0 # Cf SOFT HYPHEN
@@ -65,11 +66,10 @@
00B2..00B3 ; 0 # No [2] SUPERSCRIPT TWO..SUPERSCRIPT THREE
00B4 ; 0 # Sk ACUTE ACCENT
00B5 ; 0 # L& MICRO SIGN
-00B6 ; 0 # So PILCROW SIGN
-00B7 ; 0 # Po MIDDLE DOT
+00B6..00B7 ; 0 # Po [2] PILCROW SIGN..MIDDLE DOT
00B8 ; 0 # Sk CEDILLA
00B9 ; 0 # No SUPERSCRIPT ONE
-00BA ; 0 # L& MASCULINE ORDINAL INDICATOR
+00BA ; 0 # Lo MASCULINE ORDINAL INDICATOR
00BB ; 0 # Pf RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK
00BC..00BE ; 0 # No [3] VULGAR FRACTION ONE QUARTER..VULGAR FRACTION THREE QUARTERS
00BF ; 0 # Po INVERTED QUESTION MARK
@@ -120,6 +120,7 @@
0561..0587 ; 0 # L& [39] ARMENIAN SMALL LETTER AYB..ARMENIAN SMALL LIGATURE ECH YIWN
0589 ; 0 # Po ARMENIAN FULL STOP
058A ; 0 # Pd ARMENIAN HYPHEN
+058F ; 0 # Sc ARMENIAN DRAM SIGN
05BE ; 0 # Pd HEBREW PUNCTUATION MAQAF
05C0 ; 0 # Po HEBREW PUNCTUATION PASEQ
05C3 ; 0 # Po HEBREW PUNCTUATION SOF PASUQ
@@ -127,7 +128,7 @@
05D0..05EA ; 0 # Lo [27] HEBREW LETTER ALEF..HEBREW LETTER TAV
05F0..05F2 ; 0 # Lo [3] HEBREW LIGATURE YIDDISH DOUBLE VAV..HEBREW LIGATURE YIDDISH DOUBLE YOD
05F3..05F4 ; 0 # Po [2] HEBREW PUNCTUATION GERESH..HEBREW PUNCTUATION GERSHAYIM
-0600..0603 ; 0 # Cf [4] ARABIC NUMBER SIGN..ARABIC SIGN SAFHA
+0600..0604 ; 0 # Cf [5] ARABIC NUMBER SIGN..ARABIC SIGN SAMVAT
0606..0608 ; 0 # Sm [3] ARABIC-INDIC CUBE ROOT..ARABIC RAY
0609..060A ; 0 # Po [2] ARABIC-INDIC PER MILLE SIGN..ARABIC-INDIC PER TEN THOUSAND SIGN
060B ; 0 # Sc AFGHANI SIGN
@@ -173,6 +174,8 @@
0830..083E ; 0 # Po [15] SAMARITAN PUNCTUATION NEQUDAA..SAMARITAN PUNCTUATION ANNAAU
0840..0858 ; 0 # Lo [25] MANDAIC LETTER HALQA..MANDAIC LETTER AIN
085E ; 0 # Po MANDAIC PUNCTUATION
+08A0 ; 0 # Lo ARABIC LETTER BEH WITH SMALL V BELOW
+08A2..08AC ; 0 # Lo [11] ARABIC LETTER JEEM WITH TWO DOTS ABOVE..ARABIC LETTER ROHINGYA YEH
0900..0902 ; 0 # Mn [3] DEVANAGARI SIGN INVERTED CANDRABINDU..DEVANAGARI SIGN ANUSVARA
0903 ; 0 # Mc DEVANAGARI SIGN VISARGA
0904..0939 ; 0 # Lo [54] DEVANAGARI LETTER SHORT A..DEVANAGARI LETTER HA
@@ -255,6 +258,7 @@
0AE0..0AE1 ; 0 # Lo [2] GUJARATI LETTER VOCALIC RR..GUJARATI LETTER VOCALIC LL
0AE2..0AE3 ; 0 # Mn [2] GUJARATI VOWEL SIGN VOCALIC L..GUJARATI VOWEL SIGN VOCALIC LL
0AE6..0AEF ; 0 # Nd [10] GUJARATI DIGIT ZERO..GUJARATI DIGIT NINE
+0AF0 ; 0 # Po GUJARATI ABBREVIATION SIGN
0AF1 ; 0 # Sc GUJARATI RUPEE SIGN
0B01 ; 0 # Mn ORIYA SIGN CANDRABINDU
0B02..0B03 ; 0 # Mc [2] ORIYA SIGN ANUSVARA..ORIYA SIGN VISARGA
@@ -402,11 +406,13 @@
0EC6 ; 0 # Lm LAO KO LA
0ECC..0ECD ; 0 # Mn [2] LAO CANCELLATION MARK..LAO NIGGAHITA
0ED0..0ED9 ; 0 # Nd [10] LAO DIGIT ZERO..LAO DIGIT NINE
-0EDC..0EDD ; 0 # Lo [2] LAO HO NO..LAO HO MO
+0EDC..0EDF ; 0 # Lo [4] LAO HO NO..LAO LETTER KHMU NYO
0F00 ; 0 # Lo TIBETAN SYLLABLE OM
0F01..0F03 ; 0 # So [3] TIBETAN MARK GTER YIG MGO TRUNCATED A..TIBETAN MARK GTER YIG MGO -UM GTER TSHEG MA
0F04..0F12 ; 0 # Po [15] TIBETAN MARK INITIAL YIG MGO MDUN MA..TIBETAN MARK RGYA GRAM SHAD
-0F13..0F17 ; 0 # So [5] TIBETAN MARK CARET -DZUD RTAGS ME LONG CAN..TIBETAN ASTROLOGICAL SIGN SGRA GCAN -CHAR RTAGS
+0F13 ; 0 # So TIBETAN MARK CARET -DZUD RTAGS ME LONG CAN
+0F14 ; 0 # Po TIBETAN MARK GTER TSHEG
+0F15..0F17 ; 0 # So [3] TIBETAN LOGOTYPE SIGN CHAD RTAGS..TIBETAN ASTROLOGICAL SIGN SGRA GCAN -CHAR RTAGS
0F1A..0F1F ; 0 # So [6] TIBETAN SIGN RDEL DKAR GCIG..TIBETAN SIGN RDEL DKAR RDEL NAG
0F20..0F29 ; 0 # Nd [10] TIBETAN DIGIT ZERO..TIBETAN DIGIT NINE
0F2A..0F33 ; 0 # No [10] TIBETAN DIGIT HALF ONE..TIBETAN DIGIT HALF ZERO
@@ -469,10 +475,12 @@
109D ; 0 # Mn MYANMAR VOWEL SIGN AITON AI
109E..109F ; 0 # So [2] MYANMAR SYMBOL SHAN ONE..MYANMAR SYMBOL SHAN EXCLAMATION
10A0..10C5 ; 0 # L& [38] GEORGIAN CAPITAL LETTER AN..GEORGIAN CAPITAL LETTER HOE
+10C7 ; 0 # L& GEORGIAN CAPITAL LETTER YN
+10CD ; 0 # L& GEORGIAN CAPITAL LETTER AEN
10D0..10FA ; 0 # Lo [43] GEORGIAN LETTER AN..GEORGIAN LETTER AIN
10FB ; 0 # Po GEORGIAN PARAGRAPH SEPARATOR
10FC ; 0 # Lm MODIFIER LETTER GEORGIAN NAR
-1100..1248 ; 0 # Lo [329] HANGUL CHOSEONG KIYEOK..ETHIOPIC SYLLABLE QWA
+10FD..1248 ; 0 # Lo [332] GEORGIAN LETTER AEN..ETHIOPIC SYLLABLE QWA
124A..124D ; 0 # Lo [4] ETHIOPIC SYLLABLE QWI..ETHIOPIC SYLLABLE QWE
1250..1256 ; 0 # Lo [7] ETHIOPIC SYLLABLE QHA..ETHIOPIC SYLLABLE QHO
1258 ; 0 # Lo ETHIOPIC SYLLABLE QHWA
@@ -488,8 +496,7 @@
12D8..1310 ; 0 # Lo [57] ETHIOPIC SYLLABLE ZA..ETHIOPIC SYLLABLE GWA
1312..1315 ; 0 # Lo [4] ETHIOPIC SYLLABLE GWI..ETHIOPIC SYLLABLE GWE
1318..135A ; 0 # Lo [67] ETHIOPIC SYLLABLE GGA..ETHIOPIC SYLLABLE FYA
-1360 ; 0 # So ETHIOPIC SECTION MARK
-1361..1368 ; 0 # Po [8] ETHIOPIC WORDSPACE..ETHIOPIC PARAGRAPH SEPARATOR
+1360..1368 ; 0 # Po [9] ETHIOPIC SECTION MARK..ETHIOPIC PARAGRAPH SEPARATOR
1369..137C ; 0 # No [20] ETHIOPIC DIGIT ONE..ETHIOPIC NUMBER TEN THOUSAND
1380..138F ; 0 # Lo [16] ETHIOPIC SYLLABLE SEBATBEIT MWA..ETHIOPIC SYLLABLE PWE
1390..1399 ; 0 # So [10] ETHIOPIC TONAL MARK YIZET..ETHIOPIC TONAL MARK KURT
@@ -517,7 +524,7 @@
176E..1770 ; 0 # Lo [3] TAGBANWA LETTER LA..TAGBANWA LETTER SA
1772..1773 ; 0 # Mn [2] TAGBANWA VOWEL SIGN I..TAGBANWA VOWEL SIGN U
1780..17B3 ; 0 # Lo [52] KHMER LETTER KA..KHMER INDEPENDENT VOWEL QAU
-17B4..17B5 ; 0 # Cf [2] KHMER VOWEL INHERENT AQ..KHMER VOWEL INHERENT AA
+17B4..17B5 ; 0 # Mn [2] KHMER VOWEL INHERENT AQ..KHMER VOWEL INHERENT AA
17B6 ; 0 # Mc KHMER VOWEL SIGN AA
17B7..17BD ; 0 # Mn [7] KHMER VOWEL SIGN I..KHMER VOWEL SIGN UA
17BE..17C5 ; 0 # Mc [8] KHMER VOWEL SIGN OE..KHMER VOWEL SIGN AU
@@ -605,9 +612,10 @@
1BA2..1BA5 ; 0 # Mn [4] SUNDANESE CONSONANT SIGN PANYAKRA..SUNDANESE VOWEL SIGN PANYUKU
1BA6..1BA7 ; 0 # Mc [2] SUNDANESE VOWEL SIGN PANAELAENG..SUNDANESE VOWEL SIGN PANOLONG
1BA8..1BA9 ; 0 # Mn [2] SUNDANESE VOWEL SIGN PAMEPET..SUNDANESE VOWEL SIGN PANEULEUNG
+1BAC..1BAD ; 0 # Mc [2] SUNDANESE CONSONANT SIGN PASANGAN MA..SUNDANESE CONSONANT SIGN PASANGAN WA
1BAE..1BAF ; 0 # Lo [2] SUNDANESE LETTER KHA..SUNDANESE LETTER SYA
1BB0..1BB9 ; 0 # Nd [10] SUNDANESE DIGIT ZERO..SUNDANESE DIGIT NINE
-1BC0..1BE5 ; 0 # Lo [38] BATAK LETTER A..BATAK LETTER U
+1BBA..1BE5 ; 0 # Lo [44] SUNDANESE AVAGRAHA..BATAK LETTER U
1BE7 ; 0 # Mc BATAK VOWEL SIGN E
1BE8..1BE9 ; 0 # Mn [2] BATAK VOWEL SIGN PAKPAK E..BATAK VOWEL SIGN EE
1BEA..1BEC ; 0 # Mc [3] BATAK VOWEL SIGN I..BATAK VOWEL SIGN O
@@ -627,14 +635,16 @@
1C5A..1C77 ; 0 # Lo [30] OL CHIKI LETTER LA..OL CHIKI LETTER OH
1C78..1C7D ; 0 # Lm [6] OL CHIKI MU TTUDDAG..OL CHIKI AHAD
1C7E..1C7F ; 0 # Po [2] OL CHIKI PUNCTUATION MUCAAD..OL CHIKI PUNCTUATION DOUBLE MUCAAD
+1CC0..1CC7 ; 0 # Po [8] SUNDANESE PUNCTUATION BINDU SURYA..SUNDANESE PUNCTUATION BINDU BA SATANGA
1CD3 ; 0 # Po VEDIC SIGN NIHSHVASA
1CE1 ; 0 # Mc VEDIC TONE ATHARVAVEDIC INDEPENDENT SVARITA
1CE9..1CEC ; 0 # Lo [4] VEDIC SIGN ANUSVARA ANTARGOMUKHA..VEDIC SIGN ANUSVARA VAMAGOMUKHA WITH TAIL
1CEE..1CF1 ; 0 # Lo [4] VEDIC SIGN HEXIFORM LONG ANUSVARA..VEDIC SIGN ANUSVARA UBHAYATO MUKHA
-1CF2 ; 0 # Mc VEDIC SIGN ARDHAVISARGA
+1CF2..1CF3 ; 0 # Mc [2] VEDIC SIGN ARDHAVISARGA..VEDIC SIGN ROTATED ARDHAVISARGA
+1CF5..1CF6 ; 0 # Lo [2] VEDIC SIGN JIHVAMULIYA..VEDIC SIGN UPADHMANIYA
1D00..1D2B ; 0 # L& [44] LATIN LETTER SMALL CAPITAL A..CYRILLIC LETTER SMALL CAPITAL EL
-1D2C..1D61 ; 0 # Lm [54] MODIFIER LETTER CAPITAL A..MODIFIER LETTER SMALL CHI
-1D62..1D77 ; 0 # L& [22] LATIN SUBSCRIPT SMALL LETTER I..LATIN SMALL LETTER TURNED G
+1D2C..1D6A ; 0 # Lm [63] MODIFIER LETTER CAPITAL A..GREEK SUBSCRIPT SMALL LETTER CHI
+1D6B..1D77 ; 0 # L& [13] LATIN SMALL LETTER UE..LATIN SMALL LETTER TURNED G
1D78 ; 0 # Lm MODIFIER LETTER CYRILLIC EN
1D79..1D9A ; 0 # L& [34] LATIN SMALL LETTER INSULAR G..LATIN SMALL LETTER EZH WITH RETROFLEX HOOK
1D9B..1DBF ; 0 # Lm [37] MODIFIER LETTER SMALL TURNED ALPHA..MODIFIER LETTER SMALL THETA
@@ -708,7 +718,7 @@
208D ; 0 # Ps SUBSCRIPT LEFT PARENTHESIS
208E ; 0 # Pe SUBSCRIPT RIGHT PARENTHESIS
2090..209C ; 0 # Lm [13] LATIN SUBSCRIPT SMALL LETTER A..LATIN SUBSCRIPT SMALL LETTER T
-20A0..20B9 ; 0 # Sc [26] EURO-CURRENCY SIGN..INDIAN RUPEE SIGN
+20A0..20BA ; 0 # Sc [27] EURO-CURRENCY SIGN..TURKISH LIRA SIGN
20DD..20E0 ; 0 # Me [4] COMBINING ENCLOSING CIRCLE..COMBINING ENCLOSING CIRCLE BACKSLASH
20E2..20E4 ; 0 # Me [3] COMBINING ENCLOSING SCREEN..COMBINING ENCLOSING UPWARD POINTING TRIANGLE
2100..2101 ; 0 # So [2] ACCOUNT OF..ADDRESSED TO THE SUBJECT
@@ -815,9 +825,7 @@
27C0..27C4 ; 0 # Sm [5] THREE DIMENSIONAL ANGLE..OPEN SUPERSET
27C5 ; 0 # Ps LEFT S-SHAPED BAG DELIMITER
27C6 ; 0 # Pe RIGHT S-SHAPED BAG DELIMITER
-27C7..27CA ; 0 # Sm [4] OR WITH DOT INSIDE..VERTICAL BAR WITH HORIZONTAL STROKE
-27CC ; 0 # Sm LONG DIVISION
-27CE..27E5 ; 0 # Sm [24] SQUARED LOGICAL AND..WHITE SQUARE WITH RIGHTWARDS TICK
+27C7..27E5 ; 0 # Sm [31] OR WITH DOT INSIDE..WHITE SQUARE WITH RIGHTWARDS TICK
27E6 ; 0 # Ps MATHEMATICAL LEFT WHITE SQUARE BRACKET
27E7 ; 0 # Pe MATHEMATICAL RIGHT WHITE SQUARE BRACKET
27E8 ; 0 # Ps MATHEMATICAL LEFT ANGLE BRACKET
@@ -869,16 +877,19 @@
2B50..2B59 ; 0 # So [10] WHITE MEDIUM STAR..HEAVY CIRCLED SALTIRE
2C00..2C2E ; 0 # L& [47] GLAGOLITIC CAPITAL LETTER AZU..GLAGOLITIC CAPITAL LETTER LATINATE MYSLITE
2C30..2C5E ; 0 # L& [47] GLAGOLITIC SMALL LETTER AZU..GLAGOLITIC SMALL LETTER LATINATE MYSLITE
-2C60..2C7C ; 0 # L& [29] LATIN CAPITAL LETTER L WITH DOUBLE BAR..LATIN SUBSCRIPT SMALL LETTER J
-2C7D ; 0 # Lm MODIFIER LETTER CAPITAL V
+2C60..2C7B ; 0 # L& [28] LATIN CAPITAL LETTER L WITH DOUBLE BAR..LATIN LETTER SMALL CAPITAL TURNED E
+2C7C..2C7D ; 0 # Lm [2] LATIN SUBSCRIPT SMALL LETTER J..MODIFIER LETTER CAPITAL V
2C7E..2CE4 ; 0 # L& [103] LATIN CAPITAL LETTER S WITH SWASH TAIL..COPTIC SYMBOL KAI
2CE5..2CEA ; 0 # So [6] COPTIC SYMBOL MI RO..COPTIC SYMBOL SHIMA SIMA
2CEB..2CEE ; 0 # L& [4] COPTIC CAPITAL LETTER CRYPTOGRAMMIC SHEI..COPTIC SMALL LETTER CRYPTOGRAMMIC GANGIA
+2CF2..2CF3 ; 0 # L& [2] COPTIC CAPITAL LETTER BOHAIRIC KHEI..COPTIC SMALL LETTER BOHAIRIC KHEI
2CF9..2CFC ; 0 # Po [4] COPTIC OLD NUBIAN FULL STOP..COPTIC OLD NUBIAN VERSE DIVIDER
2CFD ; 0 # No COPTIC FRACTION ONE HALF
2CFE..2CFF ; 0 # Po [2] COPTIC FULL STOP..COPTIC MORPHOLOGICAL DIVIDER
2D00..2D25 ; 0 # L& [38] GEORGIAN SMALL LETTER AN..GEORGIAN SMALL LETTER HOE
-2D30..2D65 ; 0 # Lo [54] TIFINAGH LETTER YA..TIFINAGH LETTER YAZZ
+2D27 ; 0 # L& GEORGIAN SMALL LETTER YN
+2D2D ; 0 # L& GEORGIAN SMALL LETTER AEN
+2D30..2D67 ; 0 # Lo [56] TIFINAGH LETTER YA..TIFINAGH LETTER YO
2D6F ; 0 # Lm TIFINAGH MODIFIER LETTER LABIALIZATION MARK
2D70 ; 0 # Po TIFINAGH SEPARATOR MARK
2D80..2D96 ; 0 # Lo [23] ETHIOPIC SYLLABLE LOA..ETHIOPIC SYLLABLE GGWE
@@ -921,7 +932,8 @@
2E29 ; 0 # Pe RIGHT DOUBLE PARENTHESIS
2E2A..2E2E ; 0 # Po [5] TWO DOTS OVER ONE DOT PUNCTUATION..REVERSED QUESTION MARK
2E2F ; 0 # Lm VERTICAL TILDE
-2E30..2E31 ; 0 # Po [2] RING POINT..WORD SEPARATOR MIDDLE DOT
+2E30..2E39 ; 0 # Po [10] RING POINT..TOP HALF SECTION SIGN
+2E3A..2E3B ; 0 # Pd [2] TWO-EM DASH..THREE-EM DASH
2E80..2E99 ; 0 # So [26] CJK RADICAL REPEAT..CJK RADICAL RAP
2E9B..2EF3 ; 0 # So [89] CJK RADICAL CHOKE..CJK RADICAL C-SIMPLIFIED TURTLE
2F00..2FD5 ; 0 # So [214] KANGXI RADICAL ONE..KANGXI RADICAL FLUTE
@@ -983,7 +995,9 @@
31F0..31FF ; 0 # Lo [16] KATAKANA LETTER SMALL KU..KATAKANA LETTER SMALL RO
3200..321E ; 0 # So [31] PARENTHESIZED HANGUL KIYEOK..PARENTHESIZED KOREAN CHARACTER O HU
3220..3229 ; 0 # No [10] PARENTHESIZED IDEOGRAPH ONE..PARENTHESIZED IDEOGRAPH TEN
-322A..3250 ; 0 # So [39] PARENTHESIZED IDEOGRAPH MOON..PARTNERSHIP SIGN
+322A..3247 ; 0 # So [30] PARENTHESIZED IDEOGRAPH MOON..CIRCLED IDEOGRAPH KOTO
+3248..324F ; 0 # No [8] CIRCLED NUMBER TEN ON BLACK SQUARE..CIRCLED NUMBER EIGHTY ON BLACK SQUARE
+3250 ; 0 # So PARTNERSHIP SIGN
3251..325F ; 0 # No [15] CIRCLED NUMBER TWENTY ONE..CIRCLED NUMBER THIRTY FIVE
3260..327F ; 0 # So [32] CIRCLED HANGUL KIYEOK..KOREAN STANDARD SYMBOL
3280..3289 ; 0 # No [10] CIRCLED IDEOGRAPH ONE..CIRCLED IDEOGRAPH TEN
@@ -993,7 +1007,7 @@
3300..33FF ; 0 # So [256] SQUARE APAATO..SQUARE GAL
3400..4DB5 ; 0 # Lo [6582] CJK UNIFIED IDEOGRAPH-3400..CJK UNIFIED IDEOGRAPH-4DB5
4DC0..4DFF ; 0 # So [64] HEXAGRAM FOR THE CREATIVE HEAVEN..HEXAGRAM FOR BEFORE COMPLETION
-4E00..9FCB ; 0 # Lo [20940] CJK UNIFIED IDEOGRAPH-4E00..CJK UNIFIED IDEOGRAPH-9FCB
+4E00..9FCC ; 0 # Lo [20941] CJK UNIFIED IDEOGRAPH-4E00..CJK UNIFIED IDEOGRAPH-9FCC
A000..A014 ; 0 # Lo [21] YI SYLLABLE IT..YI SYLLABLE E
A015 ; 0 # Lm YI SYLLABLE WU
A016..A48C ; 0 # Lo [1143] YI SYLLABLE BIT..YI SYLLABLE YYR
@@ -1026,8 +1040,9 @@
A788 ; 0 # Lm MODIFIER LETTER LOW CIRCUMFLEX ACCENT
A789..A78A ; 0 # Sk [2] MODIFIER LETTER COLON..MODIFIER LETTER SHORT EQUALS SIGN
A78B..A78E ; 0 # L& [4] LATIN CAPITAL LETTER SALTILLO..LATIN SMALL LETTER L WITH RETROFLEX HOOK AND BELT
-A790..A791 ; 0 # L& [2] LATIN CAPITAL LETTER N WITH DESCENDER..LATIN SMALL LETTER N WITH DESCENDER
-A7A0..A7A9 ; 0 # L& [10] LATIN CAPITAL LETTER G WITH OBLIQUE STROKE..LATIN SMALL LETTER S WITH OBLIQUE STROKE
+A790..A793 ; 0 # L& [4] LATIN CAPITAL LETTER N WITH DESCENDER..LATIN SMALL LETTER C WITH BAR
+A7A0..A7AA ; 0 # L& [11] LATIN CAPITAL LETTER G WITH OBLIQUE STROKE..LATIN CAPITAL LETTER H WITH HOOK
+A7F8..A7F9 ; 0 # Lm [2] MODIFIER LETTER CAPITAL H WITH STROKE..MODIFIER LETTER SMALL LIGATURE OE
A7FA ; 0 # L& LATIN LETTER SMALL CAPITAL TURNED M
A7FB..A801 ; 0 # Lo [7] LATIN EPIGRAPHIC LETTER REVERSED F..SYLOTI NAGRI LETTER I
A802 ; 0 # Mn SYLOTI NAGRI SIGN DVISVARA
@@ -1102,6 +1117,14 @@
AADB..AADC ; 0 # Lo [2] TAI VIET SYMBOL KON..TAI VIET SYMBOL NUENG
AADD ; 0 # Lm TAI VIET SYMBOL SAM
AADE..AADF ; 0 # Po [2] TAI VIET SYMBOL HO HOI..TAI VIET SYMBOL KOI KOI
+AAE0..AAEA ; 0 # Lo [11] MEETEI MAYEK LETTER E..MEETEI MAYEK LETTER SSA
+AAEB ; 0 # Mc MEETEI MAYEK VOWEL SIGN II
+AAEC..AAED ; 0 # Mn [2] MEETEI MAYEK VOWEL SIGN UU..MEETEI MAYEK VOWEL SIGN AAI
+AAEE..AAEF ; 0 # Mc [2] MEETEI MAYEK VOWEL SIGN AU..MEETEI MAYEK VOWEL SIGN AAU
+AAF0..AAF1 ; 0 # Po [2] MEETEI MAYEK CHEIKHAN..MEETEI MAYEK AHANG KHUDAM
+AAF2 ; 0 # Lo MEETEI MAYEK ANJI
+AAF3..AAF4 ; 0 # Lm [2] MEETEI MAYEK SYLLABLE REPETITION MARK..MEETEI MAYEK WORD REPETITION MARK
+AAF5 ; 0 # Mc MEETEI MAYEK VOWEL SIGN VISARGA
AB01..AB06 ; 0 # Lo [6] ETHIOPIC SYLLABLE TTHU..ETHIOPIC SYLLABLE TTHO
AB09..AB0E ; 0 # Lo [6] ETHIOPIC SYLLABLE DDHU..ETHIOPIC SYLLABLE DDHO
AB11..AB16 ; 0 # Lo [6] ETHIOPIC SYLLABLE DZU..ETHIOPIC SYLLABLE DZO
@@ -1120,8 +1143,7 @@
D7B0..D7C6 ; 0 # Lo [23] HANGUL JUNGSEONG O-YEO..HANGUL JUNGSEONG ARAEA-E
D7CB..D7FB ; 0 # Lo [49] HANGUL JONGSEONG NIEUN-RIEUL..HANGUL JONGSEONG PHIEUPH-THIEUTH
E000..F8FF ; 0 # Co [6400] <private-use-E000>..<private-use-F8FF>
-F900..FA2D ; 0 # Lo [302] CJK COMPATIBILITY IDEOGRAPH-F900..CJK COMPATIBILITY IDEOGRAPH-FA2D
-FA30..FA6D ; 0 # Lo [62] CJK COMPATIBILITY IDEOGRAPH-FA30..CJK COMPATIBILITY IDEOGRAPH-FA6D
+F900..FA6D ; 0 # Lo [366] CJK COMPATIBILITY IDEOGRAPH-F900..CJK COMPATIBILITY IDEOGRAPH-FA6D
FA70..FAD9 ; 0 # Lo [106] CJK COMPATIBILITY IDEOGRAPH-FA70..CJK COMPATIBILITY IDEOGRAPH-FAD9
FB00..FB06 ; 0 # L& [7] LATIN SMALL LIGATURE FF..LATIN SMALL LIGATURE ST
FB13..FB17 ; 0 # L& [5] ARMENIAN SMALL LIGATURE MEN NOW..ARMENIAN SMALL LIGATURE MEN XEH
@@ -1249,8 +1271,7 @@
1003F..1004D ; 0 # Lo [15] LINEAR B SYLLABLE B020 ZO..LINEAR B SYLLABLE B091 TWO
10050..1005D ; 0 # Lo [14] LINEAR B SYMBOL B018..LINEAR B SYMBOL B089
10080..100FA ; 0 # Lo [123] LINEAR B IDEOGRAM B100 MAN..LINEAR B IDEOGRAM VESSEL B305
-10100..10101 ; 0 # Po [2] AEGEAN WORD SEPARATOR LINE..AEGEAN WORD SEPARATOR DOT
-10102 ; 0 # So AEGEAN CHECK MARK
+10100..10102 ; 0 # Po [3] AEGEAN WORD SEPARATOR LINE..AEGEAN CHECK MARK
10107..10133 ; 0 # No [45] AEGEAN NUMBER ONE..AEGEAN NUMBER NINETY THOUSAND
10137..1013F ; 0 # So [9] AEGEAN WEIGHT BASE UNIT..AEGEAN MEASURE THIRD SUBUNIT
10140..10174 ; 0 # Nl [53] GREEK ACROPHONIC ATTIC ONE QUARTER..GREEK ACROPHONIC STRATIAN FIFTY MNAS
@@ -1289,6 +1310,8 @@
1091F ; 0 # Po PHOENICIAN WORD SEPARATOR
10920..10939 ; 0 # Lo [26] LYDIAN LETTER A..LYDIAN LETTER C
1093F ; 0 # Po LYDIAN TRIANGULAR MARK
+10980..109B7 ; 0 # Lo [56] MEROITIC HIEROGLYPHIC LETTER A..MEROITIC CURSIVE LETTER DA
+109BE..109BF ; 0 # Lo [2] MEROITIC CURSIVE LOGOGRAM RMT..MEROITIC CURSIVE LOGOGRAM IMN
10A00 ; 0 # Lo KHAROSHTHI LETTER A
10A01..10A03 ; 0 # Mn [3] KHAROSHTHI VOWEL SIGN I..KHAROSHTHI VOWEL SIGN VOCALIC R
10A05..10A06 ; 0 # Mn [2] KHAROSHTHI VOWEL SIGN E..KHAROSHTHI VOWEL SIGN O
@@ -1327,11 +1350,40 @@
110BB..110BC ; 0 # Po [2] KAITHI ABBREVIATION SIGN..KAITHI ENUMERATION SIGN
110BD ; 0 # Cf KAITHI NUMBER SIGN
110BE..110C1 ; 0 # Po [4] KAITHI SECTION MARK..KAITHI DOUBLE DANDA
+110D0..110E8 ; 0 # Lo [25] SORA SOMPENG LETTER SAH..SORA SOMPENG LETTER MAE
+110F0..110F9 ; 0 # Nd [10] SORA SOMPENG DIGIT ZERO..SORA SOMPENG DIGIT NINE
+11103..11126 ; 0 # Lo [36] CHAKMA LETTER AA..CHAKMA LETTER HAA
+11127..1112B ; 0 # Mn [5] CHAKMA VOWEL SIGN A..CHAKMA VOWEL SIGN UU
+1112C ; 0 # Mc CHAKMA VOWEL SIGN E
+1112D..11132 ; 0 # Mn [6] CHAKMA VOWEL SIGN AI..CHAKMA AU MARK
+11136..1113F ; 0 # Nd [10] CHAKMA DIGIT ZERO..CHAKMA DIGIT NINE
+11140..11143 ; 0 # Po [4] CHAKMA SECTION MARK..CHAKMA QUESTION MARK
+11180..11181 ; 0 # Mn [2] SHARADA SIGN CANDRABINDU..SHARADA SIGN ANUSVARA
+11182 ; 0 # Mc SHARADA SIGN VISARGA
+11183..111B2 ; 0 # Lo [48] SHARADA LETTER A..SHARADA LETTER HA
+111B3..111B5 ; 0 # Mc [3] SHARADA VOWEL SIGN AA..SHARADA VOWEL SIGN II
+111B6..111BE ; 0 # Mn [9] SHARADA VOWEL SIGN U..SHARADA VOWEL SIGN O
+111BF ; 0 # Mc SHARADA VOWEL SIGN AU
+111C1..111C4 ; 0 # Lo [4] SHARADA SIGN AVAGRAHA..SHARADA OM
+111C5..111C8 ; 0 # Po [4] SHARADA DANDA..SHARADA SEPARATOR
+111D0..111D9 ; 0 # Nd [10] SHARADA DIGIT ZERO..SHARADA DIGIT NINE
+11680..116AA ; 0 # Lo [43] TAKRI LETTER A..TAKRI LETTER RRA
+116AB ; 0 # Mn TAKRI SIGN ANUSVARA
+116AC ; 0 # Mc TAKRI SIGN VISARGA
+116AD ; 0 # Mn TAKRI VOWEL SIGN AA
+116AE..116AF ; 0 # Mc [2] TAKRI VOWEL SIGN I..TAKRI VOWEL SIGN II
+116B0..116B5 ; 0 # Mn [6] TAKRI VOWEL SIGN U..TAKRI VOWEL SIGN AU
+116C0..116C9 ; 0 # Nd [10] TAKRI DIGIT ZERO..TAKRI DIGIT NINE
12000..1236E ; 0 # Lo [879] CUNEIFORM SIGN A..CUNEIFORM SIGN ZUM
12400..12462 ; 0 # Nl [99] CUNEIFORM NUMERIC SIGN TWO ASH..CUNEIFORM NUMERIC SIGN OLD ASSYRIAN ONE QUARTER
12470..12473 ; 0 # Po [4] CUNEIFORM PUNCTUATION SIGN OLD ASSYRIAN WORD DIVIDER..CUNEIFORM PUNCTUATION SIGN DIAGONAL TRICOLON
13000..1342E ; 0 # Lo [1071] EGYPTIAN HIEROGLYPH A001..EGYPTIAN HIEROGLYPH AA032
16800..16A38 ; 0 # Lo [569] BAMUM LETTER PHASE-A NGKUE MFON..BAMUM LETTER PHASE-F VUEQ
+16F00..16F44 ; 0 # Lo [69] MIAO LETTER PA..MIAO LETTER HHA
+16F50 ; 0 # Lo MIAO LETTER NASALIZATION
+16F51..16F7E ; 0 # Mc [46] MIAO SIGN ASPIRATION..MIAO VOWEL SIGN NG
+16F8F..16F92 ; 0 # Mn [4] MIAO TONE RIGHT..MIAO TONE BELOW
+16F93..16F9F ; 0 # Lm [13] MIAO LETTER TONE-2..MIAO LETTER REFORMED TONE-8
1B000..1B001 ; 0 # Lo [2] KATAKANA LETTER ARCHAIC E..HIRAGANA LETTER ARCHAIC YE
1D000..1D0F5 ; 0 # So [246] BYZANTINE MUSICAL SYMBOL PSILI..BYZANTINE MUSICAL SYMBOL GORGON NEO KATO
1D100..1D126 ; 0 # So [39] MUSICAL SYMBOL SINGLE BARLINE..MUSICAL SYMBOL DRUM CLEF-2
@@ -1386,6 +1438,40 @@
1D7C3 ; 0 # Sm MATHEMATICAL SANS-SERIF BOLD ITALIC PARTIAL DIFFERENTIAL
1D7C4..1D7CB ; 0 # L& [8] MATHEMATICAL SANS-SERIF BOLD ITALIC EPSILON SYMBOL..MATHEMATICAL BOLD SMALL DIGAMMA
1D7CE..1D7FF ; 0 # Nd [50] MATHEMATICAL BOLD DIGIT ZERO..MATHEMATICAL MONOSPACE DIGIT NINE
+1EE00..1EE03 ; 0 # Lo [4] ARABIC MATHEMATICAL ALEF..ARABIC MATHEMATICAL DAL
+1EE05..1EE1F ; 0 # Lo [27] ARABIC MATHEMATICAL WAW..ARABIC MATHEMATICAL DOTLESS QAF
+1EE21..1EE22 ; 0 # Lo [2] ARABIC MATHEMATICAL INITIAL BEH..ARABIC MATHEMATICAL INITIAL JEEM
+1EE24 ; 0 # Lo ARABIC MATHEMATICAL INITIAL HEH
+1EE27 ; 0 # Lo ARABIC MATHEMATICAL INITIAL HAH
+1EE29..1EE32 ; 0 # Lo [10] ARABIC MATHEMATICAL INITIAL YEH..ARABIC MATHEMATICAL INITIAL QAF
+1EE34..1EE37 ; 0 # Lo [4] ARABIC MATHEMATICAL INITIAL SHEEN..ARABIC MATHEMATICAL INITIAL KHAH
+1EE39 ; 0 # Lo ARABIC MATHEMATICAL INITIAL DAD
+1EE3B ; 0 # Lo ARABIC MATHEMATICAL INITIAL GHAIN
+1EE42 ; 0 # Lo ARABIC MATHEMATICAL TAILED JEEM
+1EE47 ; 0 # Lo ARABIC MATHEMATICAL TAILED HAH
+1EE49 ; 0 # Lo ARABIC MATHEMATICAL TAILED YEH
+1EE4B ; 0 # Lo ARABIC MATHEMATICAL TAILED LAM
+1EE4D..1EE4F ; 0 # Lo [3] ARABIC MATHEMATICAL TAILED NOON..ARABIC MATHEMATICAL TAILED AIN
+1EE51..1EE52 ; 0 # Lo [2] ARABIC MATHEMATICAL TAILED SAD..ARABIC MATHEMATICAL TAILED QAF
+1EE54 ; 0 # Lo ARABIC MATHEMATICAL TAILED SHEEN
+1EE57 ; 0 # Lo ARABIC MATHEMATICAL TAILED KHAH
+1EE59 ; 0 # Lo ARABIC MATHEMATICAL TAILED DAD
+1EE5B ; 0 # Lo ARABIC MATHEMATICAL TAILED GHAIN
+1EE5D ; 0 # Lo ARABIC MATHEMATICAL TAILED DOTLESS NOON
+1EE5F ; 0 # Lo ARABIC MATHEMATICAL TAILED DOTLESS QAF
+1EE61..1EE62 ; 0 # Lo [2] ARABIC MATHEMATICAL STRETCHED BEH..ARABIC MATHEMATICAL STRETCHED JEEM
+1EE64 ; 0 # Lo ARABIC MATHEMATICAL STRETCHED HEH
+1EE67..1EE6A ; 0 # Lo [4] ARABIC MATHEMATICAL STRETCHED HAH..ARABIC MATHEMATICAL STRETCHED KAF
+1EE6C..1EE72 ; 0 # Lo [7] ARABIC MATHEMATICAL STRETCHED MEEM..ARABIC MATHEMATICAL STRETCHED QAF
+1EE74..1EE77 ; 0 # Lo [4] ARABIC MATHEMATICAL STRETCHED SHEEN..ARABIC MATHEMATICAL STRETCHED KHAH
+1EE79..1EE7C ; 0 # Lo [4] ARABIC MATHEMATICAL STRETCHED DAD..ARABIC MATHEMATICAL STRETCHED DOTLESS BEH
+1EE7E ; 0 # Lo ARABIC MATHEMATICAL STRETCHED DOTLESS FEH
+1EE80..1EE89 ; 0 # Lo [10] ARABIC MATHEMATICAL LOOPED ALEF..ARABIC MATHEMATICAL LOOPED YEH
+1EE8B..1EE9B ; 0 # Lo [17] ARABIC MATHEMATICAL LOOPED LAM..ARABIC MATHEMATICAL LOOPED GHAIN
+1EEA1..1EEA3 ; 0 # Lo [3] ARABIC MATHEMATICAL DOUBLE-STRUCK BEH..ARABIC MATHEMATICAL DOUBLE-STRUCK DAL
+1EEA5..1EEA9 ; 0 # Lo [5] ARABIC MATHEMATICAL DOUBLE-STRUCK WAW..ARABIC MATHEMATICAL DOUBLE-STRUCK YEH
+1EEAB..1EEBB ; 0 # Lo [17] ARABIC MATHEMATICAL DOUBLE-STRUCK LAM..ARABIC MATHEMATICAL DOUBLE-STRUCK GHAIN
+1EEF0..1EEF1 ; 0 # Sm [2] ARABIC MATHEMATICAL OPERATOR MEEM WITH HAH WITH TATWEEL..ARABIC MATHEMATICAL OPERATOR HAH WITH DAL
1F000..1F02B ; 0 # So [44] MAHJONG TILE EAST WIND..MAHJONG TILE BACK
1F030..1F093 ; 0 # So [100] DOMINO TILE HORIZONTAL BACK..DOMINO TILE VERTICAL-06-06
1F0A0..1F0AE ; 0 # So [15] PLAYING CARD BACK..PLAYING CARD KING OF SPADES
@@ -1394,7 +1480,7 @@
1F0D1..1F0DF ; 0 # So [15] PLAYING CARD ACE OF CLUBS..PLAYING CARD WHITE JOKER
1F100..1F10A ; 0 # No [11] DIGIT ZERO FULL STOP..DIGIT NINE COMMA
1F110..1F12E ; 0 # So [31] PARENTHESIZED LATIN CAPITAL LETTER A..CIRCLED WZ
-1F130..1F169 ; 0 # So [58] SQUARED LATIN CAPITAL LETTER A..NEGATIVE CIRCLED LATIN CAPITAL LETTER Z
+1F130..1F16B ; 0 # So [60] SQUARED LATIN CAPITAL LETTER A..RAISED MD SIGN
1F170..1F19A ; 0 # So [43] NEGATIVE SQUARED LATIN CAPITAL LETTER A..SQUARED VS
1F1E6..1F202 ; 0 # So [29] REGIONAL INDICATOR SYMBOL LETTER A..SQUARED KATAKANA SA
1F210..1F23A ; 0 # So [43] SQUARED CJK UNIFIED IDEOGRAPH-624B..SQUARED CJK UNIFIED IDEOGRAPH-55B6
@@ -1412,19 +1498,9 @@
1F442..1F4F7 ; 0 # So [182] EAR..CAMERA
1F4F9..1F4FC ; 0 # So [4] VIDEO CAMERA..VIDEOCASSETTE
1F500..1F53D ; 0 # So [62] TWISTED RIGHTWARDS ARROWS..DOWN-POINTING SMALL RED TRIANGLE
+1F540..1F543 ; 0 # So [4] CIRCLED CROSS POMMEE..NOTCHED LEFT SEMICIRCLE WITH THREE DOTS
1F550..1F567 ; 0 # So [24] CLOCK FACE ONE OCLOCK..CLOCK FACE TWELVE-THIRTY
-1F5FB..1F5FF ; 0 # So [5] MOUNT FUJI..MOYAI
-1F601..1F610 ; 0 # So [16] GRINNING FACE WITH SMILING EYES..NEUTRAL FACE
-1F612..1F614 ; 0 # So [3] UNAMUSED FACE..PENSIVE FACE
-1F616 ; 0 # So CONFOUNDED FACE
-1F618 ; 0 # So FACE THROWING A KISS
-1F61A ; 0 # So KISSING FACE WITH CLOSED EYES
-1F61C..1F61E ; 0 # So [3] FACE WITH STUCK-OUT TONGUE AND WINKING EYE..DISAPPOINTED FACE
-1F620..1F625 ; 0 # So [6] ANGRY FACE..DISAPPOINTED BUT RELIEVED FACE
-1F628..1F62B ; 0 # So [4] FEARFUL FACE..TIRED FACE
-1F62D ; 0 # So LOUDLY CRYING FACE
-1F630..1F633 ; 0 # So [4] FACE WITH OPEN MOUTH AND COLD SWEAT..FLUSHED FACE
-1F635..1F640 ; 0 # So [12] DIZZY FACE..WEARY CAT FACE
+1F5FB..1F640 ; 0 # So [70] MOUNT FUJI..WEARY CAT FACE
1F645..1F64F ; 0 # So [11] FACE WITH NO GOOD GESTURE..PERSON WITH FOLDED HANDS
1F680..1F6C5 ; 0 # So [70] ROCKET..LEFT LUGGAGE
1F700..1F773 ; 0 # So [116] ALCHEMICAL SYMBOL FOR QUINTESSENCE..ALCHEMICAL SYMBOL FOR HALF OUNCE
@@ -1438,8 +1514,8 @@
F0000..FFFFD ; 0 # Co [65534] <private-use-F0000>..<private-use-FFFFD>
100000..10FFFD; 0 # Co [65534] <private-use-100000>..<private-use-10FFFD>
-# The above property value applies to 867195 code points not listed here.
-# Total code points: 1113506
+# The above property value applies to 866462 code points not listed here.
+# Total code points: 1113459
# ================================================
@@ -1473,8 +1549,9 @@
1C37 ; 7 # Mn LEPCHA SIGN NUKTA
A9B3 ; 7 # Mn JAVANESE SIGN CECAK TELU
110BA ; 7 # Mn KAITHI SIGN NUKTA
+116B7 ; 7 # Mn TAKRI SIGN NUKTA
-# Total code points: 12
+# Total code points: 13
# ================================================
@@ -1507,6 +1584,7 @@
1A60 ; 9 # Mn TAI THAM SIGN SAKOT
1B44 ; 9 # Mc BALINESE ADEG ADEG
1BAA ; 9 # Mc SUNDANESE SIGN PAMAAEH
+1BAB ; 9 # Mn SUNDANESE SIGN VIRAMA
1BF2..1BF3 ; 9 # Mc [2] BATAK PANGOLAT..BATAK PANONGONAN
2D7F ; 9 # Mn TIFINAGH CONSONANT JOINER
A806 ; 9 # Mn SYLOTI NAGRI SIGN HASANTA
@@ -1513,16 +1591,20 @@
A8C4 ; 9 # Mn SAURASHTRA SIGN VIRAMA
A953 ; 9 # Mc REJANG VIRAMA
A9C0 ; 9 # Mc JAVANESE PANGKON
+AAF6 ; 9 # Mn MEETEI MAYEK VIRAMA
ABED ; 9 # Mn MEETEI MAYEK APUN IYEK
10A3F ; 9 # Mn KHAROSHTHI VIRAMA
11046 ; 9 # Mn BRAHMI VIRAMA
110B9 ; 9 # Mn KAITHI SIGN VIRAMA
+11133..11134 ; 9 # Mn [2] CHAKMA VIRAMA..CHAKMA MAAYYAA
+111C0 ; 9 # Mc SHARADA SIGN VIRAMA
+116B6 ; 9 # Mc TAKRI SIGN VIRAMA
-# Total code points: 31
+# Total code points: 37
# ================================================
-# Canonical_Combining_Class=10
+# Canonical_Combining_Class=CCC10
05B0 ; 10 # Mn HEBREW POINT SHEVA
@@ -1530,7 +1612,7 @@
# ================================================
-# Canonical_Combining_Class=11
+# Canonical_Combining_Class=CCC11
05B1 ; 11 # Mn HEBREW POINT HATAF SEGOL
@@ -1538,7 +1620,7 @@
# ================================================
-# Canonical_Combining_Class=12
+# Canonical_Combining_Class=CCC12
05B2 ; 12 # Mn HEBREW POINT HATAF PATAH
@@ -1546,7 +1628,7 @@
# ================================================
-# Canonical_Combining_Class=13
+# Canonical_Combining_Class=CCC13
05B3 ; 13 # Mn HEBREW POINT HATAF QAMATS
@@ -1554,7 +1636,7 @@
# ================================================
-# Canonical_Combining_Class=14
+# Canonical_Combining_Class=CCC14
05B4 ; 14 # Mn HEBREW POINT HIRIQ
@@ -1562,7 +1644,7 @@
# ================================================
-# Canonical_Combining_Class=15
+# Canonical_Combining_Class=CCC15
05B5 ; 15 # Mn HEBREW POINT TSERE
@@ -1570,7 +1652,7 @@
# ================================================
-# Canonical_Combining_Class=16
+# Canonical_Combining_Class=CCC16
05B6 ; 16 # Mn HEBREW POINT SEGOL
@@ -1578,7 +1660,7 @@
# ================================================
-# Canonical_Combining_Class=17
+# Canonical_Combining_Class=CCC17
05B7 ; 17 # Mn HEBREW POINT PATAH
@@ -1586,7 +1668,7 @@
# ================================================
-# Canonical_Combining_Class=18
+# Canonical_Combining_Class=CCC18
05B8 ; 18 # Mn HEBREW POINT QAMATS
05C7 ; 18 # Mn HEBREW POINT QAMATS QATAN
@@ -1595,7 +1677,7 @@
# ================================================
-# Canonical_Combining_Class=19
+# Canonical_Combining_Class=CCC19
05B9..05BA ; 19 # Mn [2] HEBREW POINT HOLAM..HEBREW POINT HOLAM HASER FOR VAV
@@ -1603,7 +1685,7 @@
# ================================================
-# Canonical_Combining_Class=20
+# Canonical_Combining_Class=CCC20
05BB ; 20 # Mn HEBREW POINT QUBUTS
@@ -1611,7 +1693,7 @@
# ================================================
-# Canonical_Combining_Class=21
+# Canonical_Combining_Class=CCC21
05BC ; 21 # Mn HEBREW POINT DAGESH OR MAPIQ
@@ -1619,7 +1701,7 @@
# ================================================
-# Canonical_Combining_Class=22
+# Canonical_Combining_Class=CCC22
05BD ; 22 # Mn HEBREW POINT METEG
@@ -1627,7 +1709,7 @@
# ================================================
-# Canonical_Combining_Class=23
+# Canonical_Combining_Class=CCC23
05BF ; 23 # Mn HEBREW POINT RAFE
@@ -1635,7 +1717,7 @@
# ================================================
-# Canonical_Combining_Class=24
+# Canonical_Combining_Class=CCC24
05C1 ; 24 # Mn HEBREW POINT SHIN DOT
@@ -1643,7 +1725,7 @@
# ================================================
-# Canonical_Combining_Class=25
+# Canonical_Combining_Class=CCC25
05C2 ; 25 # Mn HEBREW POINT SIN DOT
@@ -1651,7 +1733,7 @@
# ================================================
-# Canonical_Combining_Class=26
+# Canonical_Combining_Class=CCC26
FB1E ; 26 # Mn HEBREW POINT JUDEO-SPANISH VARIKA
@@ -1659,31 +1741,34 @@
# ================================================
-# Canonical_Combining_Class=27
+# Canonical_Combining_Class=CCC27
064B ; 27 # Mn ARABIC FATHATAN
+08F0 ; 27 # Mn ARABIC OPEN FATHATAN
-# Total code points: 1
+# Total code points: 2
# ================================================
-# Canonical_Combining_Class=28
+# Canonical_Combining_Class=CCC28
064C ; 28 # Mn ARABIC DAMMATAN
+08F1 ; 28 # Mn ARABIC OPEN DAMMATAN
-# Total code points: 1
+# Total code points: 2
# ================================================
-# Canonical_Combining_Class=29
+# Canonical_Combining_Class=CCC29
064D ; 29 # Mn ARABIC KASRATAN
+08F2 ; 29 # Mn ARABIC OPEN KASRATAN
-# Total code points: 1
+# Total code points: 2
# ================================================
-# Canonical_Combining_Class=30
+# Canonical_Combining_Class=CCC30
0618 ; 30 # Mn ARABIC SMALL FATHA
064E ; 30 # Mn ARABIC FATHA
@@ -1692,7 +1777,7 @@
# ================================================
-# Canonical_Combining_Class=31
+# Canonical_Combining_Class=CCC31
0619 ; 31 # Mn ARABIC SMALL DAMMA
064F ; 31 # Mn ARABIC DAMMA
@@ -1701,7 +1786,7 @@
# ================================================
-# Canonical_Combining_Class=32
+# Canonical_Combining_Class=CCC32
061A ; 32 # Mn ARABIC SMALL KASRA
0650 ; 32 # Mn ARABIC KASRA
@@ -1710,7 +1795,7 @@
# ================================================
-# Canonical_Combining_Class=33
+# Canonical_Combining_Class=CCC33
0651 ; 33 # Mn ARABIC SHADDA
@@ -1718,7 +1803,7 @@
# ================================================
-# Canonical_Combining_Class=34
+# Canonical_Combining_Class=CCC34
0652 ; 34 # Mn ARABIC SUKUN
@@ -1726,7 +1811,7 @@
# ================================================
-# Canonical_Combining_Class=35
+# Canonical_Combining_Class=CCC35
0670 ; 35 # Mn ARABIC LETTER SUPERSCRIPT ALEF
@@ -1734,7 +1819,7 @@
# ================================================
-# Canonical_Combining_Class=36
+# Canonical_Combining_Class=CCC36
0711 ; 36 # Mn SYRIAC LETTER SUPERSCRIPT ALAPH
@@ -1742,7 +1827,7 @@
# ================================================
-# Canonical_Combining_Class=84
+# Canonical_Combining_Class=CCC84
0C55 ; 84 # Mn TELUGU LENGTH MARK
@@ -1750,7 +1835,7 @@
# ================================================
-# Canonical_Combining_Class=91
+# Canonical_Combining_Class=CCC91
0C56 ; 91 # Mn TELUGU AI LENGTH MARK
@@ -1758,7 +1843,7 @@
# ================================================
-# Canonical_Combining_Class=103
+# Canonical_Combining_Class=CCC103
0E38..0E39 ; 103 # Mn [2] THAI CHARACTER SARA U..THAI CHARACTER SARA UU
@@ -1766,7 +1851,7 @@
# ================================================
-# Canonical_Combining_Class=107
+# Canonical_Combining_Class=CCC107
0E48..0E4B ; 107 # Mn [4] THAI CHARACTER MAI EK..THAI CHARACTER MAI CHATTAWA
@@ -1774,7 +1859,7 @@
# ================================================
-# Canonical_Combining_Class=118
+# Canonical_Combining_Class=CCC118
0EB8..0EB9 ; 118 # Mn [2] LAO VOWEL SIGN U..LAO VOWEL SIGN UU
@@ -1782,7 +1867,7 @@
# ================================================
-# Canonical_Combining_Class=122
+# Canonical_Combining_Class=CCC122
0EC8..0ECB ; 122 # Mn [4] LAO TONE MAI EK..LAO TONE MAI CATAWA
@@ -1790,7 +1875,7 @@
# ================================================
-# Canonical_Combining_Class=129
+# Canonical_Combining_Class=CCC129
0F71 ; 129 # Mn TIBETAN VOWEL SIGN AA
@@ -1798,7 +1883,7 @@
# ================================================
-# Canonical_Combining_Class=130
+# Canonical_Combining_Class=CCC130
0F72 ; 130 # Mn TIBETAN VOWEL SIGN I
0F7A..0F7D ; 130 # Mn [4] TIBETAN VOWEL SIGN E..TIBETAN VOWEL SIGN OO
@@ -1808,7 +1893,7 @@
# ================================================
-# Canonical_Combining_Class=132
+# Canonical_Combining_Class=CCC132
0F74 ; 132 # Mn TIBETAN VOWEL SIGN U
@@ -1887,6 +1972,11 @@
0748 ; 220 # Mn SYRIAC OBLIQUE LINE BELOW
07F2 ; 220 # Mn NKO COMBINING NASALIZATION MARK
0859..085B ; 220 # Mn [3] MANDAIC AFFRICATION MARK..MANDAIC GEMINATION MARK
+08E6 ; 220 # Mn ARABIC CURLY KASRA
+08E9 ; 220 # Mn ARABIC CURLY KASRATAN
+08ED..08EF ; 220 # Mn [3] ARABIC TONE ONE DOT BELOW..ARABIC TONE LOOP BELOW
+08F6 ; 220 # Mn ARABIC KASRA WITH DOT BELOW
+08F9..08FA ; 220 # Mn [2] ARABIC LEFT ARROWHEAD BELOW..ARABIC RIGHT ARROWHEAD BELOW
0952 ; 220 # Mn DEVANAGARI STRESS SIGN ANUDATTA
0F18..0F19 ; 220 # Mn [2] TIBETAN ASTROLOGICAL SIGN -KHYUD PA..TIBETAN ASTROLOGICAL SIGN SDONG TSHUGS
0F35 ; 220 # Mn TIBETAN MARK NGAS BZUNG NYI ZLA
@@ -1915,7 +2005,7 @@
1D17B..1D182 ; 220 # Mn [8] MUSICAL SYMBOL COMBINING ACCENT..MUSICAL SYMBOL COMBINING LOURE
1D18A..1D18B ; 220 # Mn [2] MUSICAL SYMBOL COMBINING DOUBLE TONGUE..MUSICAL SYMBOL COMBINING TRIPLE TONGUE
-# Total code points: 121
+# Total code points: 129
# ================================================
@@ -1932,7 +2022,7 @@
# Canonical_Combining_Class=Left
-302E..302F ; 224 # Mn [2] HANGUL SINGLE DOT TONE MARK..HANGUL DOUBLE DOT TONE MARK
+302E..302F ; 224 # Mc [2] HANGUL SINGLE DOT TONE MARK..HANGUL DOUBLE DOT TONE MARK
# Total code points: 2
@@ -1999,6 +2089,12 @@
081B..0823 ; 230 # Mn [9] SAMARITAN MARK EPENTHETIC YUT..SAMARITAN VOWEL SIGN A
0825..0827 ; 230 # Mn [3] SAMARITAN VOWEL SIGN SHORT A..SAMARITAN VOWEL SIGN U
0829..082D ; 230 # Mn [5] SAMARITAN VOWEL SIGN LONG I..SAMARITAN MARK NEQUDAA
+08E4..08E5 ; 230 # Mn [2] ARABIC CURLY FATHA..ARABIC CURLY DAMMA
+08E7..08E8 ; 230 # Mn [2] ARABIC CURLY FATHATAN..ARABIC CURLY DAMMATAN
+08EA..08EC ; 230 # Mn [3] ARABIC TONE ONE DOT ABOVE..ARABIC TONE LOOP ABOVE
+08F3..08F5 ; 230 # Mn [3] ARABIC SMALL HIGH WAW..ARABIC FATHA WITH DOT ABOVE
+08F7..08F8 ; 230 # Mn [2] ARABIC LEFT ARROWHEAD ABOVE..ARABIC RIGHT ARROWHEAD ABOVE
+08FB..08FE ; 230 # Mn [4] ARABIC DOUBLE RIGHT ARROWHEAD ABOVE..ARABIC DAMMA WITH DOT
0951 ; 230 # Mn DEVANAGARI STRESS SIGN UDATTA
0953..0954 ; 230 # Mn [2] DEVANAGARI GRAVE ACCENT..DEVANAGARI ACUTE ACCENT
0F82..0F83 ; 230 # Mn [2] TIBETAN SIGN NYI ZLA NAA DA..TIBETAN SIGN SNA LDAN
@@ -2013,6 +2109,7 @@
1CD0..1CD2 ; 230 # Mn [3] VEDIC TONE KARSHANA..VEDIC TONE PRENKHA
1CDA..1CDB ; 230 # Mn [2] VEDIC TONE DOUBLE SVARITA..VEDIC TONE TRIPLE SVARITA
1CE0 ; 230 # Mn VEDIC TONE RIGVEDIC KASHMIRI INDEPENDENT SVARITA
+1CF4 ; 230 # Mn VEDIC TONE CANDRA ABOVE
1DC0..1DC1 ; 230 # Mn [2] COMBINING DOTTED GRAVE ACCENT..COMBINING DOTTED ACUTE ACCENT
1DC3..1DC9 ; 230 # Mn [7] COMBINING SUSPENSION MARK..COMBINING ACUTE-GRAVE-ACUTE
1DCB..1DCC ; 230 # Mn [2] COMBINING BREVE-MACRON..COMBINING MACRON-BREVE
@@ -2028,7 +2125,8 @@
2CEF..2CF1 ; 230 # Mn [3] COPTIC COMBINING NI ABOVE..COPTIC COMBINING SPIRITUS LENIS
2DE0..2DFF ; 230 # Mn [32] COMBINING CYRILLIC LETTER BE..COMBINING CYRILLIC LETTER IOTIFIED BIG YUS
A66F ; 230 # Mn COMBINING CYRILLIC VZMET
-A67C..A67D ; 230 # Mn [2] COMBINING CYRILLIC KAVYKA..COMBINING CYRILLIC PAYEROK
+A674..A67D ; 230 # Mn [10] COMBINING CYRILLIC LETTER UKRAINIAN IE..COMBINING CYRILLIC PAYEROK
+A69F ; 230 # Mn COMBINING CYRILLIC LETTER IOTIFIED E
A6F0..A6F1 ; 230 # Mn [2] BAMUM COMBINING MARK KOQNDON..BAMUM COMBINING MARK TUKWENTIS
A8E0..A8F1 ; 230 # Mn [18] COMBINING DEVANAGARI DIGIT ZERO..COMBINING DEVANAGARI SIGN AVAGRAHA
AAB0 ; 230 # Mn TAI VIET MAI KANG
@@ -2039,11 +2137,12 @@
FE20..FE26 ; 230 # Mn [7] COMBINING LIGATURE LEFT HALF..COMBINING CONJOINING MACRON
10A0F ; 230 # Mn KHAROSHTHI SIGN VISARGA
10A38 ; 230 # Mn KHAROSHTHI SIGN BAR ABOVE
+11100..11102 ; 230 # Mn [3] CHAKMA SIGN CANDRABINDU..CHAKMA SIGN VISARGA
1D185..1D189 ; 230 # Mn [5] MUSICAL SYMBOL COMBINING DOIT..MUSICAL SYMBOL COMBINING BEND
1D1AA..1D1AD ; 230 # Mn [4] MUSICAL SYMBOL COMBINING DOWN BOW..MUSICAL SYMBOL COMBINING SNAP PIZZICATO
1D242..1D244 ; 230 # Mn [3] COMBINING GREEK MUSICAL TRISEME..COMBINING GREEK MUSICAL PENTASEME
-# Total code points: 320
+# Total code points: 349
# ================================================
Property changes on: trunk/contrib/perl/lib/unicore/extracted/DCombiningClass.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/extracted/DDecompositionType.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/extracted/DDecompositionType.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/extracted/DDecompositionType.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,8 +1,8 @@
-# DerivedDecompositionType-6.0.0.txt
-# Date: 2010-05-18, 00:49:11 GMT [MD]
+# DerivedDecompositionType-6.2.0.txt
+# Date: 2012-05-23, 20:34:46 GMT [MD]
#
# Unicode Character Database
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
# For documentation, see http://www.unicode.org/reports/tr44/
@@ -238,8 +238,7 @@
FA20 ; Canonical # Lo CJK COMPATIBILITY IDEOGRAPH-FA20
FA22 ; Canonical # Lo CJK COMPATIBILITY IDEOGRAPH-FA22
FA25..FA26 ; Canonical # Lo [2] CJK COMPATIBILITY IDEOGRAPH-FA25..CJK COMPATIBILITY IDEOGRAPH-FA26
-FA2A..FA2D ; Canonical # Lo [4] CJK COMPATIBILITY IDEOGRAPH-FA2A..CJK COMPATIBILITY IDEOGRAPH-FA2D
-FA30..FA6D ; Canonical # Lo [62] CJK COMPATIBILITY IDEOGRAPH-FA30..CJK COMPATIBILITY IDEOGRAPH-FA6D
+FA2A..FA6D ; Canonical # Lo [68] CJK COMPATIBILITY IDEOGRAPH-FA2A..CJK COMPATIBILITY IDEOGRAPH-FA6D
FA70..FAD9 ; Canonical # Lo [106] CJK COMPATIBILITY IDEOGRAPH-FA70..CJK COMPATIBILITY IDEOGRAPH-FAD9
FB1D ; Canonical # Lo HEBREW LETTER YOD WITH HIRIQ
FB1F ; Canonical # Lo HEBREW LIGATURE YIDDISH YOD YOD PATAH
@@ -252,11 +251,12 @@
1109A ; Canonical # Lo KAITHI LETTER DDDHA
1109C ; Canonical # Lo KAITHI LETTER RHA
110AB ; Canonical # Lo KAITHI LETTER VA
+1112E..1112F ; Canonical # Mn [2] CHAKMA VOWEL SIGN O..CHAKMA VOWEL SIGN AU
1D15E..1D164 ; Canonical # So [7] MUSICAL SYMBOL HALF NOTE..MUSICAL SYMBOL ONE HUNDRED TWENTY-EIGHTH NOTE
1D1BB..1D1C0 ; Canonical # So [6] MUSICAL SYMBOL MINIMA..MUSICAL SYMBOL FUSA BLACK
2F800..2FA1D ; Canonical # Lo [542] CJK COMPATIBILITY IDEOGRAPH-2F800..CJK COMPATIBILITY IDEOGRAPH-2FA1D
-# Total code points: 13221
+# Total code points: 13225
# ================================================
@@ -400,8 +400,41 @@
1D7C3 ; Font # Sm MATHEMATICAL SANS-SERIF BOLD ITALIC PARTIAL DIFFERENTIAL
1D7C4..1D7CB ; Font # L& [8] MATHEMATICAL SANS-SERIF BOLD ITALIC EPSILON SYMBOL..MATHEMATICAL BOLD SMALL DIGAMMA
1D7CE..1D7FF ; Font # Nd [50] MATHEMATICAL BOLD DIGIT ZERO..MATHEMATICAL MONOSPACE DIGIT NINE
+1EE00..1EE03 ; Font # Lo [4] ARABIC MATHEMATICAL ALEF..ARABIC MATHEMATICAL DAL
+1EE05..1EE1F ; Font # Lo [27] ARABIC MATHEMATICAL WAW..ARABIC MATHEMATICAL DOTLESS QAF
+1EE21..1EE22 ; Font # Lo [2] ARABIC MATHEMATICAL INITIAL BEH..ARABIC MATHEMATICAL INITIAL JEEM
+1EE24 ; Font # Lo ARABIC MATHEMATICAL INITIAL HEH
+1EE27 ; Font # Lo ARABIC MATHEMATICAL INITIAL HAH
+1EE29..1EE32 ; Font # Lo [10] ARABIC MATHEMATICAL INITIAL YEH..ARABIC MATHEMATICAL INITIAL QAF
+1EE34..1EE37 ; Font # Lo [4] ARABIC MATHEMATICAL INITIAL SHEEN..ARABIC MATHEMATICAL INITIAL KHAH
+1EE39 ; Font # Lo ARABIC MATHEMATICAL INITIAL DAD
+1EE3B ; Font # Lo ARABIC MATHEMATICAL INITIAL GHAIN
+1EE42 ; Font # Lo ARABIC MATHEMATICAL TAILED JEEM
+1EE47 ; Font # Lo ARABIC MATHEMATICAL TAILED HAH
+1EE49 ; Font # Lo ARABIC MATHEMATICAL TAILED YEH
+1EE4B ; Font # Lo ARABIC MATHEMATICAL TAILED LAM
+1EE4D..1EE4F ; Font # Lo [3] ARABIC MATHEMATICAL TAILED NOON..ARABIC MATHEMATICAL TAILED AIN
+1EE51..1EE52 ; Font # Lo [2] ARABIC MATHEMATICAL TAILED SAD..ARABIC MATHEMATICAL TAILED QAF
+1EE54 ; Font # Lo ARABIC MATHEMATICAL TAILED SHEEN
+1EE57 ; Font # Lo ARABIC MATHEMATICAL TAILED KHAH
+1EE59 ; Font # Lo ARABIC MATHEMATICAL TAILED DAD
+1EE5B ; Font # Lo ARABIC MATHEMATICAL TAILED GHAIN
+1EE5D ; Font # Lo ARABIC MATHEMATICAL TAILED DOTLESS NOON
+1EE5F ; Font # Lo ARABIC MATHEMATICAL TAILED DOTLESS QAF
+1EE61..1EE62 ; Font # Lo [2] ARABIC MATHEMATICAL STRETCHED BEH..ARABIC MATHEMATICAL STRETCHED JEEM
+1EE64 ; Font # Lo ARABIC MATHEMATICAL STRETCHED HEH
+1EE67..1EE6A ; Font # Lo [4] ARABIC MATHEMATICAL STRETCHED HAH..ARABIC MATHEMATICAL STRETCHED KAF
+1EE6C..1EE72 ; Font # Lo [7] ARABIC MATHEMATICAL STRETCHED MEEM..ARABIC MATHEMATICAL STRETCHED QAF
+1EE74..1EE77 ; Font # Lo [4] ARABIC MATHEMATICAL STRETCHED SHEEN..ARABIC MATHEMATICAL STRETCHED KHAH
+1EE79..1EE7C ; Font # Lo [4] ARABIC MATHEMATICAL STRETCHED DAD..ARABIC MATHEMATICAL STRETCHED DOTLESS BEH
+1EE7E ; Font # Lo ARABIC MATHEMATICAL STRETCHED DOTLESS FEH
+1EE80..1EE89 ; Font # Lo [10] ARABIC MATHEMATICAL LOOPED ALEF..ARABIC MATHEMATICAL LOOPED YEH
+1EE8B..1EE9B ; Font # Lo [17] ARABIC MATHEMATICAL LOOPED LAM..ARABIC MATHEMATICAL LOOPED GHAIN
+1EEA1..1EEA3 ; Font # Lo [3] ARABIC MATHEMATICAL DOUBLE-STRUCK BEH..ARABIC MATHEMATICAL DOUBLE-STRUCK DAL
+1EEA5..1EEA9 ; Font # Lo [5] ARABIC MATHEMATICAL DOUBLE-STRUCK WAW..ARABIC MATHEMATICAL DOUBLE-STRUCK YEH
+1EEAB..1EEBB ; Font # Lo [17] ARABIC MATHEMATICAL DOUBLE-STRUCK LAM..ARABIC MATHEMATICAL DOUBLE-STRUCK GHAIN
-# Total code points: 1043
+# Total code points: 1184
# ================================================
@@ -793,10 +826,10 @@
# ================================================
-00AA ; Super # L& FEMININE ORDINAL INDICATOR
+00AA ; Super # Lo FEMININE ORDINAL INDICATOR
00B2..00B3 ; Super # No [2] SUPERSCRIPT TWO..SUPERSCRIPT THREE
00B9 ; Super # No SUPERSCRIPT ONE
-00BA ; Super # L& MASCULINE ORDINAL INDICATOR
+00BA ; Super # Lo MASCULINE ORDINAL INDICATOR
02B0..02B8 ; Super # Lm [9] MODIFIER LETTER SMALL H..MODIFIER LETTER SMALL Y
02E0..02E4 ; Super # Lm [5] MODIFIER LETTER SMALL GAMMA..MODIFIER LETTER SMALL REVERSED GLOTTAL STOP
10FC ; Super # Lm MODIFIER LETTER GEORGIAN NAR
@@ -820,18 +853,20 @@
3192..3195 ; Super # No [4] IDEOGRAPHIC ANNOTATION ONE MARK..IDEOGRAPHIC ANNOTATION FOUR MARK
3196..319F ; Super # So [10] IDEOGRAPHIC ANNOTATION TOP MARK..IDEOGRAPHIC ANNOTATION MAN MARK
A770 ; Super # Lm MODIFIER LETTER US
+A7F8..A7F9 ; Super # Lm [2] MODIFIER LETTER CAPITAL H WITH STROKE..MODIFIER LETTER SMALL LIGATURE OE
+1F16A..1F16B ; Super # So [2] RAISED MC SIGN..RAISED MD SIGN
-# Total code points: 142
+# Total code points: 146
# ================================================
-1D62..1D6A ; Sub # L& [9] LATIN SUBSCRIPT SMALL LETTER I..GREEK SUBSCRIPT SMALL LETTER CHI
+1D62..1D6A ; Sub # Lm [9] LATIN SUBSCRIPT SMALL LETTER I..GREEK SUBSCRIPT SMALL LETTER CHI
2080..2089 ; Sub # No [10] SUBSCRIPT ZERO..SUBSCRIPT NINE
208A..208C ; Sub # Sm [3] SUBSCRIPT PLUS SIGN..SUBSCRIPT EQUALS SIGN
208D ; Sub # Ps SUBSCRIPT LEFT PARENTHESIS
208E ; Sub # Pe SUBSCRIPT RIGHT PARENTHESIS
2090..209C ; Sub # Lm [13] LATIN SUBSCRIPT SMALL LETTER A..LATIN SUBSCRIPT SMALL LETTER T
-2C7C ; Sub # L& LATIN SUBSCRIPT SMALL LETTER J
+2C7C ; Sub # Lm LATIN SUBSCRIPT SMALL LETTER J
# Total code points: 38
Property changes on: trunk/contrib/perl/lib/unicore/extracted/DDecompositionType.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/extracted/DEastAsianWidth.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/extracted/DEastAsianWidth.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/extracted/DEastAsianWidth.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,8 +1,8 @@
-# DerivedEastAsianWidth-6.0.0.txt
-# Date: 2010-08-19, 00:48:08 GMT [MD]
+# DerivedEastAsianWidth-6.2.0.txt
+# Date: 2012-05-20, 00:42:33 GMT [MD]
#
# Unicode Character Database
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
# For documentation, see http://www.unicode.org/reports/tr44/
@@ -118,6 +118,7 @@
0561..0587 ; N # L& [39] ARMENIAN SMALL LETTER AYB..ARMENIAN SMALL LIGATURE ECH YIWN
0589 ; N # Po ARMENIAN FULL STOP
058A ; N # Pd ARMENIAN HYPHEN
+058F ; N # Sc ARMENIAN DRAM SIGN
0591..05BD ; N # Mn [45] HEBREW ACCENT ETNAHTA..HEBREW POINT METEG
05BE ; N # Pd HEBREW PUNCTUATION MAQAF
05BF ; N # Mn HEBREW POINT RAFE
@@ -130,7 +131,7 @@
05D0..05EA ; N # Lo [27] HEBREW LETTER ALEF..HEBREW LETTER TAV
05F0..05F2 ; N # Lo [3] HEBREW LIGATURE YIDDISH DOUBLE VAV..HEBREW LIGATURE YIDDISH DOUBLE YOD
05F3..05F4 ; N # Po [2] HEBREW PUNCTUATION GERESH..HEBREW PUNCTUATION GERSHAYIM
-0600..0603 ; N # Cf [4] ARABIC NUMBER SIGN..ARABIC SIGN SAFHA
+0600..0604 ; N # Cf [5] ARABIC NUMBER SIGN..ARABIC SIGN SAMVAT
0606..0608 ; N # Sm [3] ARABIC-INDIC CUBE ROOT..ARABIC RAY
0609..060A ; N # Po [2] ARABIC-INDIC PER MILLE SIGN..ARABIC-INDIC PER TEN THOUSAND SIGN
060B ; N # Sc AFGHANI SIGN
@@ -191,6 +192,9 @@
0840..0858 ; N # Lo [25] MANDAIC LETTER HALQA..MANDAIC LETTER AIN
0859..085B ; N # Mn [3] MANDAIC AFFRICATION MARK..MANDAIC GEMINATION MARK
085E ; N # Po MANDAIC PUNCTUATION
+08A0 ; N # Lo ARABIC LETTER BEH WITH SMALL V BELOW
+08A2..08AC ; N # Lo [11] ARABIC LETTER JEEM WITH TWO DOTS ABOVE..ARABIC LETTER ROHINGYA YEH
+08E4..08FE ; N # Mn [27] ARABIC CURLY FATHA..ARABIC DAMMA WITH DOT
0900..0902 ; N # Mn [3] DEVANAGARI SIGN INVERTED CANDRABINDU..DEVANAGARI SIGN ANUSVARA
0903 ; N # Mc DEVANAGARI SIGN VISARGA
0904..0939 ; N # Lo [54] DEVANAGARI LETTER SHORT A..DEVANAGARI LETTER HA
@@ -280,6 +284,7 @@
0AE0..0AE1 ; N # Lo [2] GUJARATI LETTER VOCALIC RR..GUJARATI LETTER VOCALIC LL
0AE2..0AE3 ; N # Mn [2] GUJARATI VOWEL SIGN VOCALIC L..GUJARATI VOWEL SIGN VOCALIC LL
0AE6..0AEF ; N # Nd [10] GUJARATI DIGIT ZERO..GUJARATI DIGIT NINE
+0AF0 ; N # Po GUJARATI ABBREVIATION SIGN
0AF1 ; N # Sc GUJARATI RUPEE SIGN
0B01 ; N # Mn ORIYA SIGN CANDRABINDU
0B02..0B03 ; N # Mc [2] ORIYA SIGN ANUSVARA..ORIYA SIGN VISARGA
@@ -433,11 +438,13 @@
0EC6 ; N # Lm LAO KO LA
0EC8..0ECD ; N # Mn [6] LAO TONE MAI EK..LAO NIGGAHITA
0ED0..0ED9 ; N # Nd [10] LAO DIGIT ZERO..LAO DIGIT NINE
-0EDC..0EDD ; N # Lo [2] LAO HO NO..LAO HO MO
+0EDC..0EDF ; N # Lo [4] LAO HO NO..LAO LETTER KHMU NYO
0F00 ; N # Lo TIBETAN SYLLABLE OM
0F01..0F03 ; N # So [3] TIBETAN MARK GTER YIG MGO TRUNCATED A..TIBETAN MARK GTER YIG MGO -UM GTER TSHEG MA
0F04..0F12 ; N # Po [15] TIBETAN MARK INITIAL YIG MGO MDUN MA..TIBETAN MARK RGYA GRAM SHAD
-0F13..0F17 ; N # So [5] TIBETAN MARK CARET -DZUD RTAGS ME LONG CAN..TIBETAN ASTROLOGICAL SIGN SGRA GCAN -CHAR RTAGS
+0F13 ; N # So TIBETAN MARK CARET -DZUD RTAGS ME LONG CAN
+0F14 ; N # Po TIBETAN MARK GTER TSHEG
+0F15..0F17 ; N # So [3] TIBETAN LOGOTYPE SIGN CHAD RTAGS..TIBETAN ASTROLOGICAL SIGN SGRA GCAN -CHAR RTAGS
0F18..0F19 ; N # Mn [2] TIBETAN ASTROLOGICAL SIGN -KHYUD PA..TIBETAN ASTROLOGICAL SIGN SDONG TSHUGS
0F1A..0F1F ; N # So [6] TIBETAN SIGN RDEL DKAR GCIG..TIBETAN SIGN RDEL DKAR RDEL NAG
0F20..0F29 ; N # Nd [10] TIBETAN DIGIT ZERO..TIBETAN DIGIT NINE
@@ -506,12 +513,13 @@
109D ; N # Mn MYANMAR VOWEL SIGN AITON AI
109E..109F ; N # So [2] MYANMAR SYMBOL SHAN ONE..MYANMAR SYMBOL SHAN EXCLAMATION
10A0..10C5 ; N # L& [38] GEORGIAN CAPITAL LETTER AN..GEORGIAN CAPITAL LETTER HOE
+10C7 ; N # L& GEORGIAN CAPITAL LETTER YN
+10CD ; N # L& GEORGIAN CAPITAL LETTER AEN
10D0..10FA ; N # Lo [43] GEORGIAN LETTER AN..GEORGIAN LETTER AIN
10FB ; N # Po GEORGIAN PARAGRAPH SEPARATOR
10FC ; N # Lm MODIFIER LETTER GEORGIAN NAR
-1160..11A2 ; N # Lo [67] HANGUL JUNGSEONG FILLER..HANGUL JUNGSEONG SSANGARAEA
-11A8..11F9 ; N # Lo [82] HANGUL JONGSEONG KIYEOK..HANGUL JONGSEONG YEORINHIEUH
-1200..1248 ; N # Lo [73] ETHIOPIC SYLLABLE HA..ETHIOPIC SYLLABLE QWA
+10FD..10FF ; N # Lo [3] GEORGIAN LETTER AEN..GEORGIAN LETTER LABIAL SIGN
+1160..1248 ; N # Lo [233] HANGUL JUNGSEONG FILLER..ETHIOPIC SYLLABLE QWA
124A..124D ; N # Lo [4] ETHIOPIC SYLLABLE QWI..ETHIOPIC SYLLABLE QWE
1250..1256 ; N # Lo [7] ETHIOPIC SYLLABLE QHA..ETHIOPIC SYLLABLE QHO
1258 ; N # Lo ETHIOPIC SYLLABLE QHWA
@@ -528,8 +536,7 @@
1312..1315 ; N # Lo [4] ETHIOPIC SYLLABLE GWI..ETHIOPIC SYLLABLE GWE
1318..135A ; N # Lo [67] ETHIOPIC SYLLABLE GGA..ETHIOPIC SYLLABLE FYA
135D..135F ; N # Mn [3] ETHIOPIC COMBINING GEMINATION AND VOWEL LENGTH MARK..ETHIOPIC COMBINING GEMINATION MARK
-1360 ; N # So ETHIOPIC SECTION MARK
-1361..1368 ; N # Po [8] ETHIOPIC WORDSPACE..ETHIOPIC PARAGRAPH SEPARATOR
+1360..1368 ; N # Po [9] ETHIOPIC SECTION MARK..ETHIOPIC PARAGRAPH SEPARATOR
1369..137C ; N # No [20] ETHIOPIC DIGIT ONE..ETHIOPIC NUMBER TEN THOUSAND
1380..138F ; N # Lo [16] ETHIOPIC SYLLABLE SEBATBEIT MWA..ETHIOPIC SYLLABLE PWE
1390..1399 ; N # So [10] ETHIOPIC TONAL MARK YIZET..ETHIOPIC TONAL MARK KURT
@@ -557,7 +564,7 @@
176E..1770 ; N # Lo [3] TAGBANWA LETTER LA..TAGBANWA LETTER SA
1772..1773 ; N # Mn [2] TAGBANWA VOWEL SIGN I..TAGBANWA VOWEL SIGN U
1780..17B3 ; N # Lo [52] KHMER LETTER KA..KHMER INDEPENDENT VOWEL QAU
-17B4..17B5 ; N # Cf [2] KHMER VOWEL INHERENT AQ..KHMER VOWEL INHERENT AA
+17B4..17B5 ; N # Mn [2] KHMER VOWEL INHERENT AQ..KHMER VOWEL INHERENT AA
17B6 ; N # Mc KHMER VOWEL SIGN AA
17B7..17BD ; N # Mn [7] KHMER VOWEL SIGN I..KHMER VOWEL SIGN UA
17BE..17C5 ; N # Mc [8] KHMER VOWEL SIGN OE..KHMER VOWEL SIGN AU
@@ -653,9 +660,11 @@
1BA6..1BA7 ; N # Mc [2] SUNDANESE VOWEL SIGN PANAELAENG..SUNDANESE VOWEL SIGN PANOLONG
1BA8..1BA9 ; N # Mn [2] SUNDANESE VOWEL SIGN PAMEPET..SUNDANESE VOWEL SIGN PANEULEUNG
1BAA ; N # Mc SUNDANESE SIGN PAMAAEH
+1BAB ; N # Mn SUNDANESE SIGN VIRAMA
+1BAC..1BAD ; N # Mc [2] SUNDANESE CONSONANT SIGN PASANGAN MA..SUNDANESE CONSONANT SIGN PASANGAN WA
1BAE..1BAF ; N # Lo [2] SUNDANESE LETTER KHA..SUNDANESE LETTER SYA
1BB0..1BB9 ; N # Nd [10] SUNDANESE DIGIT ZERO..SUNDANESE DIGIT NINE
-1BC0..1BE5 ; N # Lo [38] BATAK LETTER A..BATAK LETTER U
+1BBA..1BE5 ; N # Lo [44] SUNDANESE AVAGRAHA..BATAK LETTER U
1BE6 ; N # Mn BATAK SIGN TOMPI
1BE7 ; N # Mc BATAK VOWEL SIGN E
1BE8..1BE9 ; N # Mn [2] BATAK VOWEL SIGN PAKPAK E..BATAK VOWEL SIGN EE
@@ -677,6 +686,7 @@
1C5A..1C77 ; N # Lo [30] OL CHIKI LETTER LA..OL CHIKI LETTER OH
1C78..1C7D ; N # Lm [6] OL CHIKI MU TTUDDAG..OL CHIKI AHAD
1C7E..1C7F ; N # Po [2] OL CHIKI PUNCTUATION MUCAAD..OL CHIKI PUNCTUATION DOUBLE MUCAAD
+1CC0..1CC7 ; N # Po [8] SUNDANESE PUNCTUATION BINDU SURYA..SUNDANESE PUNCTUATION BINDU BA SATANGA
1CD0..1CD2 ; N # Mn [3] VEDIC TONE KARSHANA..VEDIC TONE PRENKHA
1CD3 ; N # Po VEDIC SIGN NIHSHVASA
1CD4..1CE0 ; N # Mn [13] VEDIC SIGN YAJURVEDIC MIDLINE SVARITA..VEDIC TONE RIGVEDIC KASHMIRI INDEPENDENT SVARITA
@@ -685,10 +695,12 @@
1CE9..1CEC ; N # Lo [4] VEDIC SIGN ANUSVARA ANTARGOMUKHA..VEDIC SIGN ANUSVARA VAMAGOMUKHA WITH TAIL
1CED ; N # Mn VEDIC SIGN TIRYAK
1CEE..1CF1 ; N # Lo [4] VEDIC SIGN HEXIFORM LONG ANUSVARA..VEDIC SIGN ANUSVARA UBHAYATO MUKHA
-1CF2 ; N # Mc VEDIC SIGN ARDHAVISARGA
+1CF2..1CF3 ; N # Mc [2] VEDIC SIGN ARDHAVISARGA..VEDIC SIGN ROTATED ARDHAVISARGA
+1CF4 ; N # Mn VEDIC TONE CANDRA ABOVE
+1CF5..1CF6 ; N # Lo [2] VEDIC SIGN JIHVAMULIYA..VEDIC SIGN UPADHMANIYA
1D00..1D2B ; N # L& [44] LATIN LETTER SMALL CAPITAL A..CYRILLIC LETTER SMALL CAPITAL EL
-1D2C..1D61 ; N # Lm [54] MODIFIER LETTER CAPITAL A..MODIFIER LETTER SMALL CHI
-1D62..1D77 ; N # L& [22] LATIN SUBSCRIPT SMALL LETTER I..LATIN SMALL LETTER TURNED G
+1D2C..1D6A ; N # Lm [63] MODIFIER LETTER CAPITAL A..GREEK SUBSCRIPT SMALL LETTER CHI
+1D6B..1D77 ; N # L& [13] LATIN SMALL LETTER UE..LATIN SMALL LETTER TURNED G
1D78 ; N # Lm MODIFIER LETTER CYRILLIC EN
1D79..1D9A ; N # L& [34] LATIN SMALL LETTER INSULAR G..LATIN SMALL LETTER EZH WITH RETROFLEX HOOK
1D9B..1DBF ; N # Lm [37] MODIFIER LETTER SMALL TURNED ALPHA..MODIFIER LETTER SMALL THETA
@@ -765,7 +777,7 @@
2090..209C ; N # Lm [13] LATIN SUBSCRIPT SMALL LETTER A..LATIN SUBSCRIPT SMALL LETTER T
20A0..20A8 ; N # Sc [9] EURO-CURRENCY SIGN..RUPEE SIGN
20AA..20AB ; N # Sc [2] NEW SHEQEL SIGN..DONG SIGN
-20AD..20B9 ; N # Sc [13] KIP SIGN..INDIAN RUPEE SIGN
+20AD..20BA ; N # Sc [14] KIP SIGN..TURKISH LIRA SIGN
20D0..20DC ; N # Mn [13] COMBINING LEFT HARPOON ABOVE..COMBINING FOUR DOTS ABOVE
20DD..20E0 ; N # Me [4] COMBINING ENCLOSING CIRCLE..COMBINING ENCLOSING CIRCLE BACKSLASH
20E1 ; N # Mn COMBINING LEFT RIGHT ARROW ABOVE
@@ -930,9 +942,7 @@
27C0..27C4 ; N # Sm [5] THREE DIMENSIONAL ANGLE..OPEN SUPERSET
27C5 ; N # Ps LEFT S-SHAPED BAG DELIMITER
27C6 ; N # Pe RIGHT S-SHAPED BAG DELIMITER
-27C7..27CA ; N # Sm [4] OR WITH DOT INSIDE..VERTICAL BAR WITH HORIZONTAL STROKE
-27CC ; N # Sm LONG DIVISION
-27CE..27E5 ; N # Sm [24] SQUARED LOGICAL AND..WHITE SQUARE WITH RIGHTWARDS TICK
+27C7..27E5 ; N # Sm [31] OR WITH DOT INSIDE..WHITE SQUARE WITH RIGHTWARDS TICK
27EE ; N # Ps MATHEMATICAL LEFT FLATTENED PARENTHESIS
27EF ; N # Pe MATHEMATICAL RIGHT FLATTENED PARENTHESIS
27F0..27FF ; N # Sm [16] UPWARDS QUADRUPLE ARROW..LONG RIGHTWARDS SQUIGGLE ARROW
@@ -974,17 +984,20 @@
2B50..2B54 ; N # So [5] WHITE MEDIUM STAR..WHITE RIGHT-POINTING PENTAGON
2C00..2C2E ; N # L& [47] GLAGOLITIC CAPITAL LETTER AZU..GLAGOLITIC CAPITAL LETTER LATINATE MYSLITE
2C30..2C5E ; N # L& [47] GLAGOLITIC SMALL LETTER AZU..GLAGOLITIC SMALL LETTER LATINATE MYSLITE
-2C60..2C7C ; N # L& [29] LATIN CAPITAL LETTER L WITH DOUBLE BAR..LATIN SUBSCRIPT SMALL LETTER J
-2C7D ; N # Lm MODIFIER LETTER CAPITAL V
+2C60..2C7B ; N # L& [28] LATIN CAPITAL LETTER L WITH DOUBLE BAR..LATIN LETTER SMALL CAPITAL TURNED E
+2C7C..2C7D ; N # Lm [2] LATIN SUBSCRIPT SMALL LETTER J..MODIFIER LETTER CAPITAL V
2C7E..2CE4 ; N # L& [103] LATIN CAPITAL LETTER S WITH SWASH TAIL..COPTIC SYMBOL KAI
2CE5..2CEA ; N # So [6] COPTIC SYMBOL MI RO..COPTIC SYMBOL SHIMA SIMA
2CEB..2CEE ; N # L& [4] COPTIC CAPITAL LETTER CRYPTOGRAMMIC SHEI..COPTIC SMALL LETTER CRYPTOGRAMMIC GANGIA
2CEF..2CF1 ; N # Mn [3] COPTIC COMBINING NI ABOVE..COPTIC COMBINING SPIRITUS LENIS
+2CF2..2CF3 ; N # L& [2] COPTIC CAPITAL LETTER BOHAIRIC KHEI..COPTIC SMALL LETTER BOHAIRIC KHEI
2CF9..2CFC ; N # Po [4] COPTIC OLD NUBIAN FULL STOP..COPTIC OLD NUBIAN VERSE DIVIDER
2CFD ; N # No COPTIC FRACTION ONE HALF
2CFE..2CFF ; N # Po [2] COPTIC FULL STOP..COPTIC MORPHOLOGICAL DIVIDER
2D00..2D25 ; N # L& [38] GEORGIAN SMALL LETTER AN..GEORGIAN SMALL LETTER HOE
-2D30..2D65 ; N # Lo [54] TIFINAGH LETTER YA..TIFINAGH LETTER YAZZ
+2D27 ; N # L& GEORGIAN SMALL LETTER YN
+2D2D ; N # L& GEORGIAN SMALL LETTER AEN
+2D30..2D67 ; N # Lo [56] TIFINAGH LETTER YA..TIFINAGH LETTER YO
2D6F ; N # Lm TIFINAGH MODIFIER LETTER LABIALIZATION MARK
2D70 ; N # Po TIFINAGH SEPARATOR MARK
2D7F ; N # Mn TIFINAGH CONSONANT JOINER
@@ -1029,7 +1042,8 @@
2E29 ; N # Pe RIGHT DOUBLE PARENTHESIS
2E2A..2E2E ; N # Po [5] TWO DOTS OVER ONE DOT PUNCTUATION..REVERSED QUESTION MARK
2E2F ; N # Lm VERTICAL TILDE
-2E30..2E31 ; N # Po [2] RING POINT..WORD SEPARATOR MIDDLE DOT
+2E30..2E39 ; N # Po [10] RING POINT..TOP HALF SECTION SIGN
+2E3A..2E3B ; N # Pd [2] TWO-EM DASH..THREE-EM DASH
303F ; N # So IDEOGRAPHIC HALF FILL SPACE
4DC0..4DFF ; N # So [64] HEXAGRAM FOR THE CREATIVE HEAVEN..HEXAGRAM FOR BEFORE COMPLETION
A4D0..A4F7 ; N # Lo [40] LISU LETTER BA..LISU LETTER OE
@@ -1046,10 +1060,11 @@
A66F ; N # Mn COMBINING CYRILLIC VZMET
A670..A672 ; N # Me [3] COMBINING CYRILLIC TEN MILLIONS SIGN..COMBINING CYRILLIC THOUSAND MILLIONS SIGN
A673 ; N # Po SLAVONIC ASTERISK
-A67C..A67D ; N # Mn [2] COMBINING CYRILLIC KAVYKA..COMBINING CYRILLIC PAYEROK
+A674..A67D ; N # Mn [10] COMBINING CYRILLIC LETTER UKRAINIAN IE..COMBINING CYRILLIC PAYEROK
A67E ; N # Po CYRILLIC KAVYKA
A67F ; N # Lm CYRILLIC PAYEROK
A680..A697 ; N # L& [24] CYRILLIC CAPITAL LETTER DWE..CYRILLIC SMALL LETTER SHWE
+A69F ; N # Mn COMBINING CYRILLIC LETTER IOTIFIED E
A6A0..A6E5 ; N # Lo [70] BAMUM LETTER A..BAMUM LETTER KI
A6E6..A6EF ; N # Nl [10] BAMUM LETTER MO..BAMUM LETTER KOGHOM
A6F0..A6F1 ; N # Mn [2] BAMUM COMBINING MARK KOQNDON..BAMUM COMBINING MARK TUKWENTIS
@@ -1063,8 +1078,9 @@
A788 ; N # Lm MODIFIER LETTER LOW CIRCUMFLEX ACCENT
A789..A78A ; N # Sk [2] MODIFIER LETTER COLON..MODIFIER LETTER SHORT EQUALS SIGN
A78B..A78E ; N # L& [4] LATIN CAPITAL LETTER SALTILLO..LATIN SMALL LETTER L WITH RETROFLEX HOOK AND BELT
-A790..A791 ; N # L& [2] LATIN CAPITAL LETTER N WITH DESCENDER..LATIN SMALL LETTER N WITH DESCENDER
-A7A0..A7A9 ; N # L& [10] LATIN CAPITAL LETTER G WITH OBLIQUE STROKE..LATIN SMALL LETTER S WITH OBLIQUE STROKE
+A790..A793 ; N # L& [4] LATIN CAPITAL LETTER N WITH DESCENDER..LATIN SMALL LETTER C WITH BAR
+A7A0..A7AA ; N # L& [11] LATIN CAPITAL LETTER G WITH OBLIQUE STROKE..LATIN CAPITAL LETTER H WITH HOOK
+A7F8..A7F9 ; N # Lm [2] MODIFIER LETTER CAPITAL H WITH STROKE..MODIFIER LETTER SMALL LIGATURE OE
A7FA ; N # L& LATIN LETTER SMALL CAPITAL TURNED M
A7FB..A801 ; N # Lo [7] LATIN EPIGRAPHIC LETTER REVERSED F..SYLOTI NAGRI LETTER I
A802 ; N # Mn SYLOTI NAGRI SIGN DVISVARA
@@ -1147,6 +1163,15 @@
AADB..AADC ; N # Lo [2] TAI VIET SYMBOL KON..TAI VIET SYMBOL NUENG
AADD ; N # Lm TAI VIET SYMBOL SAM
AADE..AADF ; N # Po [2] TAI VIET SYMBOL HO HOI..TAI VIET SYMBOL KOI KOI
+AAE0..AAEA ; N # Lo [11] MEETEI MAYEK LETTER E..MEETEI MAYEK LETTER SSA
+AAEB ; N # Mc MEETEI MAYEK VOWEL SIGN II
+AAEC..AAED ; N # Mn [2] MEETEI MAYEK VOWEL SIGN UU..MEETEI MAYEK VOWEL SIGN AAI
+AAEE..AAEF ; N # Mc [2] MEETEI MAYEK VOWEL SIGN AU..MEETEI MAYEK VOWEL SIGN AAU
+AAF0..AAF1 ; N # Po [2] MEETEI MAYEK CHEIKHAN..MEETEI MAYEK AHANG KHUDAM
+AAF2 ; N # Lo MEETEI MAYEK ANJI
+AAF3..AAF4 ; N # Lm [2] MEETEI MAYEK SYLLABLE REPETITION MARK..MEETEI MAYEK WORD REPETITION MARK
+AAF5 ; N # Mc MEETEI MAYEK VOWEL SIGN VISARGA
+AAF6 ; N # Mn MEETEI MAYEK VIRAMA
AB01..AB06 ; N # Lo [6] ETHIOPIC SYLLABLE TTHU..ETHIOPIC SYLLABLE TTHO
AB09..AB0E ; N # Lo [6] ETHIOPIC SYLLABLE DDHU..ETHIOPIC SYLLABLE DDHO
AB11..AB16 ; N # Lo [6] ETHIOPIC SYLLABLE DZU..ETHIOPIC SYLLABLE DZO
@@ -1162,6 +1187,8 @@
ABEC ; N # Mc MEETEI MAYEK LUM IYEK
ABED ; N # Mn MEETEI MAYEK APUN IYEK
ABF0..ABF9 ; N # Nd [10] MEETEI MAYEK DIGIT ZERO..MEETEI MAYEK DIGIT NINE
+D7B0..D7C6 ; N # Lo [23] HANGUL JUNGSEONG O-YEO..HANGUL JUNGSEONG ARAEA-E
+D7CB..D7FB ; N # Lo [49] HANGUL JONGSEONG NIEUN-RIEUL..HANGUL JONGSEONG PHIEUPH-THIEUTH
FB00..FB06 ; N # L& [7] LATIN SMALL LIGATURE FF..LATIN SMALL LIGATURE ST
FB13..FB17 ; N # L& [5] ARMENIAN SMALL LIGATURE MEN NOW..ARMENIAN SMALL LIGATURE MEN XEH
FB1D ; N # Lo HEBREW LETTER YOD WITH HIRIQ
@@ -1196,8 +1223,7 @@
1003F..1004D ; N # Lo [15] LINEAR B SYLLABLE B020 ZO..LINEAR B SYLLABLE B091 TWO
10050..1005D ; N # Lo [14] LINEAR B SYMBOL B018..LINEAR B SYMBOL B089
10080..100FA ; N # Lo [123] LINEAR B IDEOGRAM B100 MAN..LINEAR B IDEOGRAM VESSEL B305
-10100..10101 ; N # Po [2] AEGEAN WORD SEPARATOR LINE..AEGEAN WORD SEPARATOR DOT
-10102 ; N # So AEGEAN CHECK MARK
+10100..10102 ; N # Po [3] AEGEAN WORD SEPARATOR LINE..AEGEAN CHECK MARK
10107..10133 ; N # No [45] AEGEAN NUMBER ONE..AEGEAN NUMBER NINETY THOUSAND
10137..1013F ; N # So [9] AEGEAN WEIGHT BASE UNIT..AEGEAN MEASURE THIRD SUBUNIT
10140..10174 ; N # Nl [53] GREEK ACROPHONIC ATTIC ONE QUARTER..GREEK ACROPHONIC STRATIAN FIFTY MNAS
@@ -1237,6 +1263,8 @@
1091F ; N # Po PHOENICIAN WORD SEPARATOR
10920..10939 ; N # Lo [26] LYDIAN LETTER A..LYDIAN LETTER C
1093F ; N # Po LYDIAN TRIANGULAR MARK
+10980..109B7 ; N # Lo [56] MEROITIC HIEROGLYPHIC LETTER A..MEROITIC CURSIVE LETTER DA
+109BE..109BF ; N # Lo [2] MEROITIC CURSIVE LOGOGRAM RMT..MEROITIC CURSIVE LOGOGRAM IMN
10A00 ; N # Lo KHAROSHTHI LETTER A
10A01..10A03 ; N # Mn [3] KHAROSHTHI VOWEL SIGN I..KHAROSHTHI VOWEL SIGN VOCALIC R
10A05..10A06 ; N # Mn [2] KHAROSHTHI VOWEL SIGN E..KHAROSHTHI VOWEL SIGN O
@@ -1277,11 +1305,43 @@
110BB..110BC ; N # Po [2] KAITHI ABBREVIATION SIGN..KAITHI ENUMERATION SIGN
110BD ; N # Cf KAITHI NUMBER SIGN
110BE..110C1 ; N # Po [4] KAITHI SECTION MARK..KAITHI DOUBLE DANDA
+110D0..110E8 ; N # Lo [25] SORA SOMPENG LETTER SAH..SORA SOMPENG LETTER MAE
+110F0..110F9 ; N # Nd [10] SORA SOMPENG DIGIT ZERO..SORA SOMPENG DIGIT NINE
+11100..11102 ; N # Mn [3] CHAKMA SIGN CANDRABINDU..CHAKMA SIGN VISARGA
+11103..11126 ; N # Lo [36] CHAKMA LETTER AA..CHAKMA LETTER HAA
+11127..1112B ; N # Mn [5] CHAKMA VOWEL SIGN A..CHAKMA VOWEL SIGN UU
+1112C ; N # Mc CHAKMA VOWEL SIGN E
+1112D..11134 ; N # Mn [8] CHAKMA VOWEL SIGN AI..CHAKMA MAAYYAA
+11136..1113F ; N # Nd [10] CHAKMA DIGIT ZERO..CHAKMA DIGIT NINE
+11140..11143 ; N # Po [4] CHAKMA SECTION MARK..CHAKMA QUESTION MARK
+11180..11181 ; N # Mn [2] SHARADA SIGN CANDRABINDU..SHARADA SIGN ANUSVARA
+11182 ; N # Mc SHARADA SIGN VISARGA
+11183..111B2 ; N # Lo [48] SHARADA LETTER A..SHARADA LETTER HA
+111B3..111B5 ; N # Mc [3] SHARADA VOWEL SIGN AA..SHARADA VOWEL SIGN II
+111B6..111BE ; N # Mn [9] SHARADA VOWEL SIGN U..SHARADA VOWEL SIGN O
+111BF..111C0 ; N # Mc [2] SHARADA VOWEL SIGN AU..SHARADA SIGN VIRAMA
+111C1..111C4 ; N # Lo [4] SHARADA SIGN AVAGRAHA..SHARADA OM
+111C5..111C8 ; N # Po [4] SHARADA DANDA..SHARADA SEPARATOR
+111D0..111D9 ; N # Nd [10] SHARADA DIGIT ZERO..SHARADA DIGIT NINE
+11680..116AA ; N # Lo [43] TAKRI LETTER A..TAKRI LETTER RRA
+116AB ; N # Mn TAKRI SIGN ANUSVARA
+116AC ; N # Mc TAKRI SIGN VISARGA
+116AD ; N # Mn TAKRI VOWEL SIGN AA
+116AE..116AF ; N # Mc [2] TAKRI VOWEL SIGN I..TAKRI VOWEL SIGN II
+116B0..116B5 ; N # Mn [6] TAKRI VOWEL SIGN U..TAKRI VOWEL SIGN AU
+116B6 ; N # Mc TAKRI SIGN VIRAMA
+116B7 ; N # Mn TAKRI SIGN NUKTA
+116C0..116C9 ; N # Nd [10] TAKRI DIGIT ZERO..TAKRI DIGIT NINE
12000..1236E ; N # Lo [879] CUNEIFORM SIGN A..CUNEIFORM SIGN ZUM
12400..12462 ; N # Nl [99] CUNEIFORM NUMERIC SIGN TWO ASH..CUNEIFORM NUMERIC SIGN OLD ASSYRIAN ONE QUARTER
12470..12473 ; N # Po [4] CUNEIFORM PUNCTUATION SIGN OLD ASSYRIAN WORD DIVIDER..CUNEIFORM PUNCTUATION SIGN DIAGONAL TRICOLON
13000..1342E ; N # Lo [1071] EGYPTIAN HIEROGLYPH A001..EGYPTIAN HIEROGLYPH AA032
16800..16A38 ; N # Lo [569] BAMUM LETTER PHASE-A NGKUE MFON..BAMUM LETTER PHASE-F VUEQ
+16F00..16F44 ; N # Lo [69] MIAO LETTER PA..MIAO LETTER HHA
+16F50 ; N # Lo MIAO LETTER NASALIZATION
+16F51..16F7E ; N # Mc [46] MIAO SIGN ASPIRATION..MIAO VOWEL SIGN NG
+16F8F..16F92 ; N # Mn [4] MIAO TONE RIGHT..MIAO TONE BELOW
+16F93..16F9F ; N # Lm [13] MIAO LETTER TONE-2..MIAO LETTER REFORMED TONE-8
1D000..1D0F5 ; N # So [246] BYZANTINE MUSICAL SYMBOL PSILI..BYZANTINE MUSICAL SYMBOL GORGON NEO KATO
1D100..1D126 ; N # So [39] MUSICAL SYMBOL SINGLE BARLINE..MUSICAL SYMBOL DRUM CLEF-2
1D129..1D164 ; N # So [60] MUSICAL SYMBOL MULTIPLE MEASURE REST..MUSICAL SYMBOL ONE HUNDRED TWENTY-EIGHTH NOTE
@@ -1342,6 +1402,40 @@
1D7C3 ; N # Sm MATHEMATICAL SANS-SERIF BOLD ITALIC PARTIAL DIFFERENTIAL
1D7C4..1D7CB ; N # L& [8] MATHEMATICAL SANS-SERIF BOLD ITALIC EPSILON SYMBOL..MATHEMATICAL BOLD SMALL DIGAMMA
1D7CE..1D7FF ; N # Nd [50] MATHEMATICAL BOLD DIGIT ZERO..MATHEMATICAL MONOSPACE DIGIT NINE
+1EE00..1EE03 ; N # Lo [4] ARABIC MATHEMATICAL ALEF..ARABIC MATHEMATICAL DAL
+1EE05..1EE1F ; N # Lo [27] ARABIC MATHEMATICAL WAW..ARABIC MATHEMATICAL DOTLESS QAF
+1EE21..1EE22 ; N # Lo [2] ARABIC MATHEMATICAL INITIAL BEH..ARABIC MATHEMATICAL INITIAL JEEM
+1EE24 ; N # Lo ARABIC MATHEMATICAL INITIAL HEH
+1EE27 ; N # Lo ARABIC MATHEMATICAL INITIAL HAH
+1EE29..1EE32 ; N # Lo [10] ARABIC MATHEMATICAL INITIAL YEH..ARABIC MATHEMATICAL INITIAL QAF
+1EE34..1EE37 ; N # Lo [4] ARABIC MATHEMATICAL INITIAL SHEEN..ARABIC MATHEMATICAL INITIAL KHAH
+1EE39 ; N # Lo ARABIC MATHEMATICAL INITIAL DAD
+1EE3B ; N # Lo ARABIC MATHEMATICAL INITIAL GHAIN
+1EE42 ; N # Lo ARABIC MATHEMATICAL TAILED JEEM
+1EE47 ; N # Lo ARABIC MATHEMATICAL TAILED HAH
+1EE49 ; N # Lo ARABIC MATHEMATICAL TAILED YEH
+1EE4B ; N # Lo ARABIC MATHEMATICAL TAILED LAM
+1EE4D..1EE4F ; N # Lo [3] ARABIC MATHEMATICAL TAILED NOON..ARABIC MATHEMATICAL TAILED AIN
+1EE51..1EE52 ; N # Lo [2] ARABIC MATHEMATICAL TAILED SAD..ARABIC MATHEMATICAL TAILED QAF
+1EE54 ; N # Lo ARABIC MATHEMATICAL TAILED SHEEN
+1EE57 ; N # Lo ARABIC MATHEMATICAL TAILED KHAH
+1EE59 ; N # Lo ARABIC MATHEMATICAL TAILED DAD
+1EE5B ; N # Lo ARABIC MATHEMATICAL TAILED GHAIN
+1EE5D ; N # Lo ARABIC MATHEMATICAL TAILED DOTLESS NOON
+1EE5F ; N # Lo ARABIC MATHEMATICAL TAILED DOTLESS QAF
+1EE61..1EE62 ; N # Lo [2] ARABIC MATHEMATICAL STRETCHED BEH..ARABIC MATHEMATICAL STRETCHED JEEM
+1EE64 ; N # Lo ARABIC MATHEMATICAL STRETCHED HEH
+1EE67..1EE6A ; N # Lo [4] ARABIC MATHEMATICAL STRETCHED HAH..ARABIC MATHEMATICAL STRETCHED KAF
+1EE6C..1EE72 ; N # Lo [7] ARABIC MATHEMATICAL STRETCHED MEEM..ARABIC MATHEMATICAL STRETCHED QAF
+1EE74..1EE77 ; N # Lo [4] ARABIC MATHEMATICAL STRETCHED SHEEN..ARABIC MATHEMATICAL STRETCHED KHAH
+1EE79..1EE7C ; N # Lo [4] ARABIC MATHEMATICAL STRETCHED DAD..ARABIC MATHEMATICAL STRETCHED DOTLESS BEH
+1EE7E ; N # Lo ARABIC MATHEMATICAL STRETCHED DOTLESS FEH
+1EE80..1EE89 ; N # Lo [10] ARABIC MATHEMATICAL LOOPED ALEF..ARABIC MATHEMATICAL LOOPED YEH
+1EE8B..1EE9B ; N # Lo [17] ARABIC MATHEMATICAL LOOPED LAM..ARABIC MATHEMATICAL LOOPED GHAIN
+1EEA1..1EEA3 ; N # Lo [3] ARABIC MATHEMATICAL DOUBLE-STRUCK BEH..ARABIC MATHEMATICAL DOUBLE-STRUCK DAL
+1EEA5..1EEA9 ; N # Lo [5] ARABIC MATHEMATICAL DOUBLE-STRUCK WAW..ARABIC MATHEMATICAL DOUBLE-STRUCK YEH
+1EEAB..1EEBB ; N # Lo [17] ARABIC MATHEMATICAL DOUBLE-STRUCK LAM..ARABIC MATHEMATICAL DOUBLE-STRUCK GHAIN
+1EEF0..1EEF1 ; N # Sm [2] ARABIC MATHEMATICAL OPERATOR MEEM WITH HAH WITH TATWEEL..ARABIC MATHEMATICAL OPERATOR HAH WITH DAL
1F000..1F02B ; N # So [44] MAHJONG TILE EAST WIND..MAHJONG TILE BACK
1F030..1F093 ; N # So [100] DOMINO TILE HORIZONTAL BACK..DOMINO TILE VERTICAL-06-06
1F0A0..1F0AE ; N # So [15] PLAYING CARD BACK..PLAYING CARD KING OF SPADES
@@ -1349,6 +1443,7 @@
1F0C1..1F0CF ; N # So [15] PLAYING CARD ACE OF DIAMONDS..PLAYING CARD BLACK JOKER
1F0D1..1F0DF ; N # So [15] PLAYING CARD ACE OF CLUBS..PLAYING CARD WHITE JOKER
1F12E ; N # So CIRCLED WZ
+1F16A..1F16B ; N # So [2] RAISED MC SIGN..RAISED MD SIGN
1F1E6..1F1FF ; N # So [26] REGIONAL INDICATOR SYMBOL LETTER A..REGIONAL INDICATOR SYMBOL LETTER Z
1F300..1F320 ; N # So [33] CYCLONE..SHOOTING STAR
1F330..1F335 ; N # So [6] CHESTNUT..CACTUS
@@ -1362,19 +1457,9 @@
1F442..1F4F7 ; N # So [182] EAR..CAMERA
1F4F9..1F4FC ; N # So [4] VIDEO CAMERA..VIDEOCASSETTE
1F500..1F53D ; N # So [62] TWISTED RIGHTWARDS ARROWS..DOWN-POINTING SMALL RED TRIANGLE
+1F540..1F543 ; N # So [4] CIRCLED CROSS POMMEE..NOTCHED LEFT SEMICIRCLE WITH THREE DOTS
1F550..1F567 ; N # So [24] CLOCK FACE ONE OCLOCK..CLOCK FACE TWELVE-THIRTY
-1F5FB..1F5FF ; N # So [5] MOUNT FUJI..MOYAI
-1F601..1F610 ; N # So [16] GRINNING FACE WITH SMILING EYES..NEUTRAL FACE
-1F612..1F614 ; N # So [3] UNAMUSED FACE..PENSIVE FACE
-1F616 ; N # So CONFOUNDED FACE
-1F618 ; N # So FACE THROWING A KISS
-1F61A ; N # So KISSING FACE WITH CLOSED EYES
-1F61C..1F61E ; N # So [3] FACE WITH STUCK-OUT TONGUE AND WINKING EYE..DISAPPOINTED FACE
-1F620..1F625 ; N # So [6] ANGRY FACE..DISAPPOINTED BUT RELIEVED FACE
-1F628..1F62B ; N # So [4] FEARFUL FACE..TIRED FACE
-1F62D ; N # So LOUDLY CRYING FACE
-1F630..1F633 ; N # So [4] FACE WITH OPEN MOUTH AND COLD SWEAT..FLUSHED FACE
-1F635..1F640 ; N # So [12] DIZZY FACE..WEARY CAT FACE
+1F5FB..1F640 ; N # So [70] MOUNT FUJI..WEARY CAT FACE
1F645..1F64F ; N # So [11] FACE WITH NO GOOD GESTURE..PERSON WITH FOLDED HANDS
1F680..1F6C5 ; N # So [70] ROCKET..LEFT LUGGAGE
1F700..1F773 ; N # So [116] ALCHEMICAL SYMBOL FOR QUINTESSENCE..ALCHEMICAL SYMBOL FOR HALF OUNCE
@@ -1381,8 +1466,8 @@
E0001 ; N # Cf LANGUAGE TAG
E0020..E007F ; N # Cf [96] TAG SPACE..CANCEL TAG
-# The above property value applies to 783647 code points not listed here.
-# Total code points: 801811
+# The above property value applies to 782917 code points not listed here.
+# Total code points: 801894
# ================================================
@@ -1390,9 +1475,9 @@
00A1 ; A # Po INVERTED EXCLAMATION MARK
00A4 ; A # Sc CURRENCY SIGN
-00A7 ; A # So SECTION SIGN
+00A7 ; A # Po SECTION SIGN
00A8 ; A # Sk DIAERESIS
-00AA ; A # L& FEMININE ORDINAL INDICATOR
+00AA ; A # Lo FEMININE ORDINAL INDICATOR
00AD ; A # Cf SOFT HYPHEN
00AE ; A # So REGISTERED SIGN
00B0 ; A # So DEGREE SIGN
@@ -1399,11 +1484,10 @@
00B1 ; A # Sm PLUS-MINUS SIGN
00B2..00B3 ; A # No [2] SUPERSCRIPT TWO..SUPERSCRIPT THREE
00B4 ; A # Sk ACUTE ACCENT
-00B6 ; A # So PILCROW SIGN
-00B7 ; A # Po MIDDLE DOT
+00B6..00B7 ; A # Po [2] PILCROW SIGN..MIDDLE DOT
00B8 ; A # Sk CEDILLA
00B9 ; A # No SUPERSCRIPT ONE
-00BA ; A # L& MASCULINE ORDINAL INDICATOR
+00BA ; A # Lo MASCULINE ORDINAL INDICATOR
00BC..00BE ; A # No [3] VULGAR FRACTION ONE QUARTER..VULGAR FRACTION THREE QUARTERS
00BF ; A # Po INVERTED QUESTION MARK
00C6 ; A # L& LATIN CAPITAL LETTER AE
@@ -1570,7 +1654,7 @@
2757 ; A # So HEAVY EXCLAMATION MARK SYMBOL
2776..277F ; A # No [10] DINGBAT NEGATIVE CIRCLED DIGIT ONE..DINGBAT NEGATIVE CIRCLED NUMBER TEN
2B55..2B59 ; A # So [5] HEAVY LARGE CIRCLE..HEAVY CIRCLED SALTIRE
-3248..324F ; A # So [8] CIRCLED NUMBER TEN ON BLACK SQUARE..CIRCLED NUMBER EIGHTY ON BLACK SQUARE
+3248..324F ; A # No [8] CIRCLED NUMBER TEN ON BLACK SQUARE..CIRCLED NUMBER EIGHTY ON BLACK SQUARE
E000..F8FF ; A # Co [6400] <private-use-E000>..<private-use-F8FF>
FE00..FE0F ; A # Mn [16] VARIATION SELECTOR-1..VARIATION SELECTOR-16
FFFD ; A # So REPLACEMENT CHARACTER
@@ -1613,8 +1697,6 @@
# East_Asian_Width=Wide
1100..115F ; W # Lo [96] HANGUL CHOSEONG KIYEOK..HANGUL CHOSEONG FILLER
-11A3..11A7 ; W # Lo [5] HANGUL JUNGSEONG A-EU..HANGUL JUNGSEONG O-YAE
-11FA..11FF ; W # Lo [6] HANGUL JONGSEONG KIYEOK-NIEUN..HANGUL JONGSEONG SSANGNIEUN
2329 ; W # Ps LEFT-POINTING ANGLE BRACKET
232A ; W # Pe RIGHT-POINTING ANGLE BRACKET
2E80..2E99 ; W # So [26] CJK RADICAL REPEAT..CJK RADICAL RAP
@@ -1650,7 +1732,8 @@
301E..301F ; W # Pe [2] DOUBLE PRIME QUOTATION MARK..LOW DOUBLE PRIME QUOTATION MARK
3020 ; W # So POSTAL MARK FACE
3021..3029 ; W # Nl [9] HANGZHOU NUMERAL ONE..HANGZHOU NUMERAL NINE
-302A..302F ; W # Mn [6] IDEOGRAPHIC LEVEL TONE MARK..HANGUL DOUBLE DOT TONE MARK
+302A..302D ; W # Mn [4] IDEOGRAPHIC LEVEL TONE MARK..IDEOGRAPHIC ENTERING TONE MARK
+302E..302F ; W # Mc [2] HANGUL SINGLE DOT TONE MARK..HANGUL DOUBLE DOT TONE MARK
3030 ; W # Pd WAVY DASH
3031..3035 ; W # Lm [5] VERTICAL KANA REPEAT MARK..VERTICAL KANA REPEAT MARK LOWER HALF
3036..3037 ; W # So [2] CIRCLED POSTAL MARK..IDEOGRAPHIC TELEGRAPH LINE FEED SEPARATOR SYMBOL
@@ -1690,8 +1773,8 @@
3300..33FF ; W # So [256] SQUARE APAATO..SQUARE GAL
3400..4DB5 ; W # Lo [6582] CJK UNIFIED IDEOGRAPH-3400..CJK UNIFIED IDEOGRAPH-4DB5
4DB6..4DBF ; W # Cn [10] <reserved-4DB6>..<reserved-4DBF>
-4E00..9FCB ; W # Lo [20940] CJK UNIFIED IDEOGRAPH-4E00..CJK UNIFIED IDEOGRAPH-9FCB
-9FCC..9FFF ; W # Cn [52] <reserved-9FCC>..<reserved-9FFF>
+4E00..9FCC ; W # Lo [20941] CJK UNIFIED IDEOGRAPH-4E00..CJK UNIFIED IDEOGRAPH-9FCC
+9FCD..9FFF ; W # Cn [51] <reserved-9FCD>..<reserved-9FFF>
A000..A014 ; W # Lo [21] YI SYLLABLE IT..YI SYLLABLE E
A015 ; W # Lm YI SYLLABLE WU
A016..A48C ; W # Lo [1143] YI SYLLABLE BIT..YI SYLLABLE YYR
@@ -1698,11 +1781,7 @@
A490..A4C6 ; W # So [55] YI RADICAL QOT..YI RADICAL KE
A960..A97C ; W # Lo [29] HANGUL CHOSEONG TIKEUT-MIEUM..HANGUL CHOSEONG SSANGYEORINHIEUH
AC00..D7A3 ; W # Lo [11172] HANGUL SYLLABLE GA..HANGUL SYLLABLE HIH
-D7B0..D7C6 ; W # Lo [23] HANGUL JUNGSEONG O-YEO..HANGUL JUNGSEONG ARAEA-E
-D7CB..D7FB ; W # Lo [49] HANGUL JONGSEONG NIEUN-RIEUL..HANGUL JONGSEONG PHIEUPH-THIEUTH
-F900..FA2D ; W # Lo [302] CJK COMPATIBILITY IDEOGRAPH-F900..CJK COMPATIBILITY IDEOGRAPH-FA2D
-FA2E..FA2F ; W # Cn [2] <reserved-FA2E>..<reserved-FA2F>
-FA30..FA6D ; W # Lo [62] CJK COMPATIBILITY IDEOGRAPH-FA30..CJK COMPATIBILITY IDEOGRAPH-FA6D
+F900..FA6D ; W # Lo [366] CJK COMPATIBILITY IDEOGRAPH-F900..CJK COMPATIBILITY IDEOGRAPH-FA6D
FA6E..FA6F ; W # Cn [2] <reserved-FA6E>..<reserved-FA6F>
FA70..FAD9 ; W # Lo [106] CJK COMPATIBILITY IDEOGRAPH-FA70..CJK COMPATIBILITY IDEOGRAPH-FAD9
FADA..FAFF ; W # Cn [38] <reserved-FADA>..<reserved-FAFF>
@@ -1765,7 +1844,7 @@
2FA1E..2FFFD ; W # Cn [1504] <reserved-2FA1E>..<reserved-2FFFD>
30000..3FFFD ; W # Cn [65534] <reserved-30000>..<reserved-3FFFD>
-# Total code points: 173217
+# Total code points: 173134
# ================================================
Property changes on: trunk/contrib/perl/lib/unicore/extracted/DEastAsianWidth.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/extracted/DGeneralCategory.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/extracted/DGeneralCategory.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/extracted/DGeneralCategory.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,8 +1,8 @@
-# DerivedGeneralCategory-6.0.0.txt
-# Date: 2010-08-19, 00:48:09 GMT [MD]
+# DerivedGeneralCategory-6.2.0.txt
+# Date: 2012-05-20, 00:42:34 GMT [MD]
#
# Unicode Character Database
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
# For documentation, see http://www.unicode.org/reports/tr44/
@@ -23,11 +23,12 @@
0557..0558 ; Cn # [2] <reserved-0557>..<reserved-0558>
0560 ; Cn # <reserved-0560>
0588 ; Cn # <reserved-0588>
-058B..0590 ; Cn # [6] <reserved-058B>..<reserved-0590>
+058B..058E ; Cn # [4] <reserved-058B>..<reserved-058E>
+0590 ; Cn # <reserved-0590>
05C8..05CF ; Cn # [8] <reserved-05C8>..<reserved-05CF>
05EB..05EF ; Cn # [5] <reserved-05EB>..<reserved-05EF>
05F5..05FF ; Cn # [11] <reserved-05F5>..<reserved-05FF>
-0604..0605 ; Cn # [2] <reserved-0604>..<reserved-0605>
+0605 ; Cn # <reserved-0605>
061C..061D ; Cn # [2] <reserved-061C>..<reserved-061D>
070E ; Cn # <reserved-070E>
074B..074C ; Cn # [2] <reserved-074B>..<reserved-074C>
@@ -36,7 +37,10 @@
082E..082F ; Cn # [2] <reserved-082E>..<reserved-082F>
083F ; Cn # <reserved-083F>
085C..085D ; Cn # [2] <reserved-085C>..<reserved-085D>
-085F..08FF ; Cn # [161] <reserved-085F>..<reserved-08FF>
+085F..089F ; Cn # [65] <reserved-085F>..<reserved-089F>
+08A1 ; Cn # <reserved-08A1>
+08AD..08E3 ; Cn # [55] <reserved-08AD>..<reserved-08E3>
+08FF ; Cn # <reserved-08FF>
0978 ; Cn # <reserved-0978>
0980 ; Cn # <reserved-0980>
0984 ; Cn # <reserved-0984>
@@ -81,7 +85,6 @@
0ACE..0ACF ; Cn # [2] <reserved-0ACE>..<reserved-0ACF>
0AD1..0ADF ; Cn # [15] <reserved-0AD1>..<reserved-0ADF>
0AE4..0AE5 ; Cn # [2] <reserved-0AE4>..<reserved-0AE5>
-0AF0 ; Cn # <reserved-0AF0>
0AF2..0B00 ; Cn # [15] <reserved-0AF2>..<reserved-0B00>
0B04 ; Cn # <reserved-0B04>
0B0D..0B0E ; Cn # [2] <reserved-0B0D>..<reserved-0B0E>
@@ -182,7 +185,7 @@
0EC7 ; Cn # <reserved-0EC7>
0ECE..0ECF ; Cn # [2] <reserved-0ECE>..<reserved-0ECF>
0EDA..0EDB ; Cn # [2] <reserved-0EDA>..<reserved-0EDB>
-0EDE..0EFF ; Cn # [34] <reserved-0EDE>..<reserved-0EFF>
+0EE0..0EFF ; Cn # [32] <reserved-0EE0>..<reserved-0EFF>
0F48 ; Cn # <reserved-0F48>
0F6D..0F70 ; Cn # [4] <reserved-0F6D>..<reserved-0F70>
0F98 ; Cn # <reserved-0F98>
@@ -189,8 +192,9 @@
0FBD ; Cn # <reserved-0FBD>
0FCD ; Cn # <reserved-0FCD>
0FDB..0FFF ; Cn # [37] <reserved-0FDB>..<reserved-0FFF>
-10C6..10CF ; Cn # [10] <reserved-10C6>..<reserved-10CF>
-10FD..10FF ; Cn # [3] <reserved-10FD>..<reserved-10FF>
+10C6 ; Cn # <reserved-10C6>
+10C8..10CC ; Cn # [5] <reserved-10C8>..<reserved-10CC>
+10CE..10CF ; Cn # [2] <reserved-10CE>..<reserved-10CF>
1249 ; Cn # <reserved-1249>
124E..124F ; Cn # [2] <reserved-124E>..<reserved-124F>
1257 ; Cn # <reserved-1257>
@@ -244,13 +248,12 @@
1AAE..1AFF ; Cn # [82] <reserved-1AAE>..<reserved-1AFF>
1B4C..1B4F ; Cn # [4] <reserved-1B4C>..<reserved-1B4F>
1B7D..1B7F ; Cn # [3] <reserved-1B7D>..<reserved-1B7F>
-1BAB..1BAD ; Cn # [3] <reserved-1BAB>..<reserved-1BAD>
-1BBA..1BBF ; Cn # [6] <reserved-1BBA>..<reserved-1BBF>
1BF4..1BFB ; Cn # [8] <reserved-1BF4>..<reserved-1BFB>
1C38..1C3A ; Cn # [3] <reserved-1C38>..<reserved-1C3A>
1C4A..1C4C ; Cn # [3] <reserved-1C4A>..<reserved-1C4C>
-1C80..1CCF ; Cn # [80] <reserved-1C80>..<reserved-1CCF>
-1CF3..1CFF ; Cn # [13] <reserved-1CF3>..<reserved-1CFF>
+1C80..1CBF ; Cn # [64] <reserved-1C80>..<reserved-1CBF>
+1CC8..1CCF ; Cn # [8] <reserved-1CC8>..<reserved-1CCF>
+1CF7..1CFF ; Cn # [9] <reserved-1CF7>..<reserved-1CFF>
1DE7..1DFB ; Cn # [21] <reserved-1DE7>..<reserved-1DFB>
1F16..1F17 ; Cn # [2] <reserved-1F16>..<reserved-1F17>
1F1E..1F1F ; Cn # [2] <reserved-1F1E>..<reserved-1F1F>
@@ -272,7 +275,7 @@
2072..2073 ; Cn # [2] <reserved-2072>..<reserved-2073>
208F ; Cn # <reserved-208F>
209D..209F ; Cn # [3] <reserved-209D>..<reserved-209F>
-20BA..20CF ; Cn # [22] <reserved-20BA>..<reserved-20CF>
+20BB..20CF ; Cn # [21] <reserved-20BB>..<reserved-20CF>
20F1..20FF ; Cn # [15] <reserved-20F1>..<reserved-20FF>
218A..218F ; Cn # [6] <reserved-218A>..<reserved-218F>
23F4..23FF ; Cn # [12] <reserved-23F4>..<reserved-23FF>
@@ -279,15 +282,15 @@
2427..243F ; Cn # [25] <reserved-2427>..<reserved-243F>
244B..245F ; Cn # [21] <reserved-244B>..<reserved-245F>
2700 ; Cn # <reserved-2700>
-27CB ; Cn # <reserved-27CB>
-27CD ; Cn # <reserved-27CD>
2B4D..2B4F ; Cn # [3] <reserved-2B4D>..<reserved-2B4F>
2B5A..2BFF ; Cn # [166] <reserved-2B5A>..<reserved-2BFF>
2C2F ; Cn # <reserved-2C2F>
2C5F ; Cn # <reserved-2C5F>
-2CF2..2CF8 ; Cn # [7] <reserved-2CF2>..<reserved-2CF8>
-2D26..2D2F ; Cn # [10] <reserved-2D26>..<reserved-2D2F>
-2D66..2D6E ; Cn # [9] <reserved-2D66>..<reserved-2D6E>
+2CF4..2CF8 ; Cn # [5] <reserved-2CF4>..<reserved-2CF8>
+2D26 ; Cn # <reserved-2D26>
+2D28..2D2C ; Cn # [5] <reserved-2D28>..<reserved-2D2C>
+2D2E..2D2F ; Cn # [2] <reserved-2D2E>..<reserved-2D2F>
+2D68..2D6E ; Cn # [7] <reserved-2D68>..<reserved-2D6E>
2D71..2D7E ; Cn # [14] <reserved-2D71>..<reserved-2D7E>
2D97..2D9F ; Cn # [9] <reserved-2D97>..<reserved-2D9F>
2DA7 ; Cn # <reserved-2DA7>
@@ -298,7 +301,7 @@
2DCF ; Cn # <reserved-2DCF>
2DD7 ; Cn # <reserved-2DD7>
2DDF ; Cn # <reserved-2DDF>
-2E32..2E7F ; Cn # [78] <reserved-2E32>..<reserved-2E7F>
+2E3C..2E7F ; Cn # [68] <reserved-2E3C>..<reserved-2E7F>
2E9A ; Cn # <reserved-2E9A>
2EF4..2EFF ; Cn # [12] <reserved-2EF4>..<reserved-2EFF>
2FD6..2FEF ; Cn # [26] <reserved-2FD6>..<reserved-2FEF>
@@ -313,16 +316,15 @@
321F ; Cn # <reserved-321F>
32FF ; Cn # <reserved-32FF>
4DB6..4DBF ; Cn # [10] <reserved-4DB6>..<reserved-4DBF>
-9FCC..9FFF ; Cn # [52] <reserved-9FCC>..<reserved-9FFF>
+9FCD..9FFF ; Cn # [51] <reserved-9FCD>..<reserved-9FFF>
A48D..A48F ; Cn # [3] <reserved-A48D>..<reserved-A48F>
A4C7..A4CF ; Cn # [9] <reserved-A4C7>..<reserved-A4CF>
A62C..A63F ; Cn # [20] <reserved-A62C>..<reserved-A63F>
-A674..A67B ; Cn # [8] <reserved-A674>..<reserved-A67B>
-A698..A69F ; Cn # [8] <reserved-A698>..<reserved-A69F>
+A698..A69E ; Cn # [7] <reserved-A698>..<reserved-A69E>
A6F8..A6FF ; Cn # [8] <reserved-A6F8>..<reserved-A6FF>
A78F ; Cn # <reserved-A78F>
-A792..A79F ; Cn # [14] <reserved-A792>..<reserved-A79F>
-A7AA..A7F9 ; Cn # [80] <reserved-A7AA>..<reserved-A7F9>
+A794..A79F ; Cn # [12] <reserved-A794>..<reserved-A79F>
+A7AB..A7F7 ; Cn # [77] <reserved-A7AB>..<reserved-A7F7>
A82C..A82F ; Cn # [4] <reserved-A82C>..<reserved-A82F>
A83A..A83F ; Cn # [6] <reserved-A83A>..<reserved-A83F>
A878..A87F ; Cn # [8] <reserved-A878>..<reserved-A87F>
@@ -339,7 +341,7 @@
AA5A..AA5B ; Cn # [2] <reserved-AA5A>..<reserved-AA5B>
AA7C..AA7F ; Cn # [4] <reserved-AA7C>..<reserved-AA7F>
AAC3..AADA ; Cn # [24] <reserved-AAC3>..<reserved-AADA>
-AAE0..AB00 ; Cn # [33] <reserved-AAE0>..<reserved-AB00>
+AAF7..AB00 ; Cn # [10] <reserved-AAF7>..<reserved-AB00>
AB07..AB08 ; Cn # [2] <reserved-AB07>..<reserved-AB08>
AB0F..AB10 ; Cn # [2] <reserved-AB0F>..<reserved-AB10>
AB17..AB1F ; Cn # [9] <reserved-AB17>..<reserved-AB1F>
@@ -350,7 +352,6 @@
D7A4..D7AF ; Cn # [12] <reserved-D7A4>..<reserved-D7AF>
D7C7..D7CA ; Cn # [4] <reserved-D7C7>..<reserved-D7CA>
D7FC..D7FF ; Cn # [4] <reserved-D7FC>..<reserved-D7FF>
-FA2E..FA2F ; Cn # [2] <reserved-FA2E>..<reserved-FA2F>
FA6E..FA6F ; Cn # [2] <reserved-FA6E>..<reserved-FA6F>
FADA..FAFF ; Cn # [38] <reserved-FADA>..<reserved-FAFF>
FB07..FB12 ; Cn # [12] <reserved-FB07>..<reserved-FB12>
@@ -412,7 +413,9 @@
10860..108FF ; Cn # [160] <reserved-10860>..<reserved-108FF>
1091C..1091E ; Cn # [3] <reserved-1091C>..<reserved-1091E>
1093A..1093E ; Cn # [5] <reserved-1093A>..<reserved-1093E>
-10940..109FF ; Cn # [192] <reserved-10940>..<reserved-109FF>
+10940..1097F ; Cn # [64] <reserved-10940>..<reserved-1097F>
+109B8..109BD ; Cn # [6] <reserved-109B8>..<reserved-109BD>
+109C0..109FF ; Cn # [64] <reserved-109C0>..<reserved-109FF>
10A04 ; Cn # <reserved-10A04>
10A07..10A0B ; Cn # [5] <reserved-10A07>..<reserved-10A0B>
10A14 ; Cn # <reserved-10A14>
@@ -430,12 +433,23 @@
10E7F..10FFF ; Cn # [385] <reserved-10E7F>..<reserved-10FFF>
1104E..11051 ; Cn # [4] <reserved-1104E>..<reserved-11051>
11070..1107F ; Cn # [16] <reserved-11070>..<reserved-1107F>
-110C2..11FFF ; Cn # [3902] <reserved-110C2>..<reserved-11FFF>
+110C2..110CF ; Cn # [14] <reserved-110C2>..<reserved-110CF>
+110E9..110EF ; Cn # [7] <reserved-110E9>..<reserved-110EF>
+110FA..110FF ; Cn # [6] <reserved-110FA>..<reserved-110FF>
+11135 ; Cn # <reserved-11135>
+11144..1117F ; Cn # [60] <reserved-11144>..<reserved-1117F>
+111C9..111CF ; Cn # [7] <reserved-111C9>..<reserved-111CF>
+111DA..1167F ; Cn # [1190] <reserved-111DA>..<reserved-1167F>
+116B8..116BF ; Cn # [8] <reserved-116B8>..<reserved-116BF>
+116CA..11FFF ; Cn # [2358] <reserved-116CA>..<reserved-11FFF>
1236F..123FF ; Cn # [145] <reserved-1236F>..<reserved-123FF>
12463..1246F ; Cn # [13] <reserved-12463>..<reserved-1246F>
12474..12FFF ; Cn # [2956] <reserved-12474>..<reserved-12FFF>
1342F..167FF ; Cn # [13265] <reserved-1342F>..<reserved-167FF>
-16A39..1AFFF ; Cn # [17863] <reserved-16A39>..<reserved-1AFFF>
+16A39..16EFF ; Cn # [1223] <reserved-16A39>..<reserved-16EFF>
+16F45..16F4F ; Cn # [11] <reserved-16F45>..<reserved-16F4F>
+16F7F..16F8E ; Cn # [16] <reserved-16F7F>..<reserved-16F8E>
+16FA0..1AFFF ; Cn # [16480] <reserved-16FA0>..<reserved-1AFFF>
1B002..1CFFF ; Cn # [8190] <reserved-1B002>..<reserved-1CFFF>
1D0F6..1D0FF ; Cn # [10] <reserved-1D0F6>..<reserved-1D0FF>
1D127..1D128 ; Cn # [2] <reserved-1D127>..<reserved-1D128>
@@ -463,7 +477,41 @@
1D551 ; Cn # <reserved-1D551>
1D6A6..1D6A7 ; Cn # [2] <reserved-1D6A6>..<reserved-1D6A7>
1D7CC..1D7CD ; Cn # [2] <reserved-1D7CC>..<reserved-1D7CD>
-1D800..1EFFF ; Cn # [6144] <reserved-1D800>..<reserved-1EFFF>
+1D800..1EDFF ; Cn # [5632] <reserved-1D800>..<reserved-1EDFF>
+1EE04 ; Cn # <reserved-1EE04>
+1EE20 ; Cn # <reserved-1EE20>
+1EE23 ; Cn # <reserved-1EE23>
+1EE25..1EE26 ; Cn # [2] <reserved-1EE25>..<reserved-1EE26>
+1EE28 ; Cn # <reserved-1EE28>
+1EE33 ; Cn # <reserved-1EE33>
+1EE38 ; Cn # <reserved-1EE38>
+1EE3A ; Cn # <reserved-1EE3A>
+1EE3C..1EE41 ; Cn # [6] <reserved-1EE3C>..<reserved-1EE41>
+1EE43..1EE46 ; Cn # [4] <reserved-1EE43>..<reserved-1EE46>
+1EE48 ; Cn # <reserved-1EE48>
+1EE4A ; Cn # <reserved-1EE4A>
+1EE4C ; Cn # <reserved-1EE4C>
+1EE50 ; Cn # <reserved-1EE50>
+1EE53 ; Cn # <reserved-1EE53>
+1EE55..1EE56 ; Cn # [2] <reserved-1EE55>..<reserved-1EE56>
+1EE58 ; Cn # <reserved-1EE58>
+1EE5A ; Cn # <reserved-1EE5A>
+1EE5C ; Cn # <reserved-1EE5C>
+1EE5E ; Cn # <reserved-1EE5E>
+1EE60 ; Cn # <reserved-1EE60>
+1EE63 ; Cn # <reserved-1EE63>
+1EE65..1EE66 ; Cn # [2] <reserved-1EE65>..<reserved-1EE66>
+1EE6B ; Cn # <reserved-1EE6B>
+1EE73 ; Cn # <reserved-1EE73>
+1EE78 ; Cn # <reserved-1EE78>
+1EE7D ; Cn # <reserved-1EE7D>
+1EE7F ; Cn # <reserved-1EE7F>
+1EE8A ; Cn # <reserved-1EE8A>
+1EE9C..1EEA0 ; Cn # [5] <reserved-1EE9C>..<reserved-1EEA0>
+1EEA4 ; Cn # <reserved-1EEA4>
+1EEAA ; Cn # <reserved-1EEAA>
+1EEBC..1EEEF ; Cn # [52] <reserved-1EEBC>..<reserved-1EEEF>
+1EEF2..1EFFF ; Cn # [270] <reserved-1EEF2>..<reserved-1EFFF>
1F02C..1F02F ; Cn # [4] <reserved-1F02C>..<reserved-1F02F>
1F094..1F09F ; Cn # [12] <reserved-1F094>..<reserved-1F09F>
1F0AF..1F0B0 ; Cn # [2] <reserved-1F0AF>..<reserved-1F0B0>
@@ -472,7 +520,7 @@
1F0E0..1F0FF ; Cn # [32] <reserved-1F0E0>..<reserved-1F0FF>
1F10B..1F10F ; Cn # [5] <reserved-1F10B>..<reserved-1F10F>
1F12F ; Cn # <reserved-1F12F>
-1F16A..1F16F ; Cn # [6] <reserved-1F16A>..<reserved-1F16F>
+1F16C..1F16F ; Cn # [4] <reserved-1F16C>..<reserved-1F16F>
1F19B..1F1E5 ; Cn # [75] <reserved-1F19B>..<reserved-1F1E5>
1F203..1F20F ; Cn # [13] <reserved-1F203>..<reserved-1F20F>
1F23B..1F23F ; Cn # [5] <reserved-1F23B>..<reserved-1F23F>
@@ -489,19 +537,9 @@
1F441 ; Cn # <reserved-1F441>
1F4F8 ; Cn # <reserved-1F4F8>
1F4FD..1F4FF ; Cn # [3] <reserved-1F4FD>..<reserved-1F4FF>
-1F53E..1F54F ; Cn # [18] <reserved-1F53E>..<reserved-1F54F>
+1F53E..1F53F ; Cn # [2] <reserved-1F53E>..<reserved-1F53F>
+1F544..1F54F ; Cn # [12] <reserved-1F544>..<reserved-1F54F>
1F568..1F5FA ; Cn # [147] <reserved-1F568>..<reserved-1F5FA>
-1F600 ; Cn # <reserved-1F600>
-1F611 ; Cn # <reserved-1F611>
-1F615 ; Cn # <reserved-1F615>
-1F617 ; Cn # <reserved-1F617>
-1F619 ; Cn # <reserved-1F619>
-1F61B ; Cn # <reserved-1F61B>
-1F61F ; Cn # <reserved-1F61F>
-1F626..1F627 ; Cn # [2] <reserved-1F626>..<reserved-1F627>
-1F62C ; Cn # <reserved-1F62C>
-1F62E..1F62F ; Cn # [2] <reserved-1F62E>..<reserved-1F62F>
-1F634 ; Cn # <reserved-1F634>
1F641..1F644 ; Cn # [4] <reserved-1F641>..<reserved-1F644>
1F650..1F67F ; Cn # [48] <reserved-1F650>..<reserved-1F67F>
1F6C6..1F6FF ; Cn # [58] <reserved-1F6C6>..<reserved-1F6FF>
@@ -516,7 +554,7 @@
FFFFE..FFFFF ; Cn # [2] <noncharacter-FFFFE>..<noncharacter-FFFFF>
10FFFE..10FFFF; Cn # [2] <noncharacter-10FFFE>..<noncharacter-10FFFF>
-# Total code points: 865147
+# Total code points: 864414
# ================================================
@@ -790,6 +828,8 @@
0526 ; Lu # CYRILLIC CAPITAL LETTER SHHA WITH DESCENDER
0531..0556 ; Lu # [38] ARMENIAN CAPITAL LETTER AYB..ARMENIAN CAPITAL LETTER FEH
10A0..10C5 ; Lu # [38] GEORGIAN CAPITAL LETTER AN..GEORGIAN CAPITAL LETTER HOE
+10C7 ; Lu # GEORGIAN CAPITAL LETTER YN
+10CD ; Lu # GEORGIAN CAPITAL LETTER AEN
1E00 ; Lu # LATIN CAPITAL LETTER A WITH RING BELOW
1E02 ; Lu # LATIN CAPITAL LETTER B WITH DOT ABOVE
1E04 ; Lu # LATIN CAPITAL LETTER B WITH DOT BELOW
@@ -1004,6 +1044,7 @@
2CE2 ; Lu # COPTIC CAPITAL LETTER OLD NUBIAN WAU
2CEB ; Lu # COPTIC CAPITAL LETTER CRYPTOGRAMMIC SHEI
2CED ; Lu # COPTIC CAPITAL LETTER CRYPTOGRAMMIC GANGIA
+2CF2 ; Lu # COPTIC CAPITAL LETTER BOHAIRIC KHEI
A640 ; Lu # CYRILLIC CAPITAL LETTER ZEMLYA
A642 ; Lu # CYRILLIC CAPITAL LETTER DZELO
A644 ; Lu # CYRILLIC CAPITAL LETTER REVERSED DZE
@@ -1087,11 +1128,13 @@
A78B ; Lu # LATIN CAPITAL LETTER SALTILLO
A78D ; Lu # LATIN CAPITAL LETTER TURNED H
A790 ; Lu # LATIN CAPITAL LETTER N WITH DESCENDER
+A792 ; Lu # LATIN CAPITAL LETTER C WITH BAR
A7A0 ; Lu # LATIN CAPITAL LETTER G WITH OBLIQUE STROKE
A7A2 ; Lu # LATIN CAPITAL LETTER K WITH OBLIQUE STROKE
A7A4 ; Lu # LATIN CAPITAL LETTER N WITH OBLIQUE STROKE
A7A6 ; Lu # LATIN CAPITAL LETTER R WITH OBLIQUE STROKE
A7A8 ; Lu # LATIN CAPITAL LETTER S WITH OBLIQUE STROKE
+A7AA ; Lu # LATIN CAPITAL LETTER H WITH HOOK
FF21..FF3A ; Lu # [26] FULLWIDTH LATIN CAPITAL LETTER A..FULLWIDTH LATIN CAPITAL LETTER Z
10400..10427 ; Lu # [40] DESERET CAPITAL LETTER LONG I..DESERET CAPITAL LETTER EW
1D400..1D419 ; Lu # [26] MATHEMATICAL BOLD CAPITAL A..MATHEMATICAL BOLD CAPITAL Z
@@ -1126,7 +1169,7 @@
1D790..1D7A8 ; Lu # [25] MATHEMATICAL SANS-SERIF BOLD ITALIC CAPITAL ALPHA..MATHEMATICAL SANS-SERIF BOLD ITALIC CAPITAL OMEGA
1D7CA ; Lu # MATHEMATICAL BOLD CAPITAL DIGAMMA
-# Total code points: 1436
+# Total code points: 1441
# ================================================
@@ -1133,9 +1176,7 @@
# General_Category=Lowercase_Letter
0061..007A ; Ll # [26] LATIN SMALL LETTER A..LATIN SMALL LETTER Z
-00AA ; Ll # FEMININE ORDINAL INDICATOR
00B5 ; Ll # MICRO SIGN
-00BA ; Ll # MASCULINE ORDINAL INDICATOR
00DF..00F6 ; Ll # [24] LATIN SMALL LETTER SHARP S..LATIN SMALL LETTER O WITH DIAERESIS
00F8..00FF ; Ll # [8] LATIN SMALL LETTER O WITH STROKE..LATIN SMALL LETTER Y WITH DIAERESIS
0101 ; Ll # LATIN SMALL LETTER A WITH MACRON
@@ -1401,7 +1442,7 @@
0527 ; Ll # CYRILLIC SMALL LETTER SHHA WITH DESCENDER
0561..0587 ; Ll # [39] ARMENIAN SMALL LETTER AYB..ARMENIAN SMALL LIGATURE ECH YIWN
1D00..1D2B ; Ll # [44] LATIN LETTER SMALL CAPITAL A..CYRILLIC LETTER SMALL CAPITAL EL
-1D62..1D77 ; Ll # [22] LATIN SUBSCRIPT SMALL LETTER I..LATIN SMALL LETTER TURNED G
+1D6B..1D77 ; Ll # [13] LATIN SMALL LETTER UE..LATIN SMALL LETTER TURNED G
1D79..1D9A ; Ll # [34] LATIN SMALL LETTER INSULAR G..LATIN SMALL LETTER EZH WITH RETROFLEX HOOK
1E01 ; Ll # LATIN SMALL LETTER A WITH RING BELOW
1E03 ; Ll # LATIN SMALL LETTER B WITH DOT ABOVE
@@ -1565,7 +1606,7 @@
2C6C ; Ll # LATIN SMALL LETTER Z WITH DESCENDER
2C71 ; Ll # LATIN SMALL LETTER V WITH RIGHT HOOK
2C73..2C74 ; Ll # [2] LATIN SMALL LETTER W WITH HOOK..LATIN SMALL LETTER V WITH CURL
-2C76..2C7C ; Ll # [7] LATIN SMALL LETTER HALF H..LATIN SUBSCRIPT SMALL LETTER J
+2C76..2C7B ; Ll # [6] LATIN SMALL LETTER HALF H..LATIN LETTER SMALL CAPITAL TURNED E
2C81 ; Ll # COPTIC SMALL LETTER ALFA
2C83 ; Ll # COPTIC SMALL LETTER VIDA
2C85 ; Ll # COPTIC SMALL LETTER GAMMA
@@ -1618,7 +1659,10 @@
2CE3..2CE4 ; Ll # [2] COPTIC SMALL LETTER OLD NUBIAN WAU..COPTIC SYMBOL KAI
2CEC ; Ll # COPTIC SMALL LETTER CRYPTOGRAMMIC SHEI
2CEE ; Ll # COPTIC SMALL LETTER CRYPTOGRAMMIC GANGIA
+2CF3 ; Ll # COPTIC SMALL LETTER BOHAIRIC KHEI
2D00..2D25 ; Ll # [38] GEORGIAN SMALL LETTER AN..GEORGIAN SMALL LETTER HOE
+2D27 ; Ll # GEORGIAN SMALL LETTER YN
+2D2D ; Ll # GEORGIAN SMALL LETTER AEN
A641 ; Ll # CYRILLIC SMALL LETTER ZEMLYA
A643 ; Ll # CYRILLIC SMALL LETTER DZELO
A645 ; Ll # CYRILLIC SMALL LETTER REVERSED DZE
@@ -1703,6 +1747,7 @@
A78C ; Ll # LATIN SMALL LETTER SALTILLO
A78E ; Ll # LATIN SMALL LETTER L WITH RETROFLEX HOOK AND BELT
A791 ; Ll # LATIN SMALL LETTER N WITH DESCENDER
+A793 ; Ll # LATIN SMALL LETTER C WITH BAR
A7A1 ; Ll # LATIN SMALL LETTER G WITH OBLIQUE STROKE
A7A3 ; Ll # LATIN SMALL LETTER K WITH OBLIQUE STROKE
A7A5 ; Ll # LATIN SMALL LETTER N WITH OBLIQUE STROKE
@@ -1742,7 +1787,7 @@
1D7C4..1D7C9 ; Ll # [6] MATHEMATICAL SANS-SERIF BOLD ITALIC EPSILON SYMBOL..MATHEMATICAL SANS-SERIF BOLD ITALIC PI SYMBOL
1D7CB ; Ll # MATHEMATICAL BOLD SMALL DIGAMMA
-# Total code points: 1759
+# Total code points: 1751
# ================================================
@@ -1788,13 +1833,13 @@
1843 ; Lm # MONGOLIAN LETTER TODO LONG VOWEL SIGN
1AA7 ; Lm # TAI THAM SIGN MAI YAMOK
1C78..1C7D ; Lm # [6] OL CHIKI MU TTUDDAG..OL CHIKI AHAD
-1D2C..1D61 ; Lm # [54] MODIFIER LETTER CAPITAL A..MODIFIER LETTER SMALL CHI
+1D2C..1D6A ; Lm # [63] MODIFIER LETTER CAPITAL A..GREEK SUBSCRIPT SMALL LETTER CHI
1D78 ; Lm # MODIFIER LETTER CYRILLIC EN
1D9B..1DBF ; Lm # [37] MODIFIER LETTER SMALL TURNED ALPHA..MODIFIER LETTER SMALL THETA
2071 ; Lm # SUPERSCRIPT LATIN SMALL LETTER I
207F ; Lm # SUPERSCRIPT LATIN SMALL LETTER N
2090..209C ; Lm # [13] LATIN SUBSCRIPT SMALL LETTER A..LATIN SUBSCRIPT SMALL LETTER T
-2C7D ; Lm # MODIFIER LETTER CAPITAL V
+2C7C..2C7D ; Lm # [2] LATIN SUBSCRIPT SMALL LETTER J..MODIFIER LETTER CAPITAL V
2D6F ; Lm # TIFINAGH MODIFIER LETTER LABIALIZATION MARK
2E2F ; Lm # VERTICAL TILDE
3005 ; Lm # IDEOGRAPHIC ITERATION MARK
@@ -1809,18 +1854,23 @@
A717..A71F ; Lm # [9] MODIFIER LETTER DOT VERTICAL BAR..MODIFIER LETTER LOW INVERTED EXCLAMATION MARK
A770 ; Lm # MODIFIER LETTER US
A788 ; Lm # MODIFIER LETTER LOW CIRCUMFLEX ACCENT
+A7F8..A7F9 ; Lm # [2] MODIFIER LETTER CAPITAL H WITH STROKE..MODIFIER LETTER SMALL LIGATURE OE
A9CF ; Lm # JAVANESE PANGRANGKEP
AA70 ; Lm # MYANMAR MODIFIER LETTER KHAMTI REDUPLICATION
AADD ; Lm # TAI VIET SYMBOL SAM
+AAF3..AAF4 ; Lm # [2] MEETEI MAYEK SYLLABLE REPETITION MARK..MEETEI MAYEK WORD REPETITION MARK
FF70 ; Lm # HALFWIDTH KATAKANA-HIRAGANA PROLONGED SOUND MARK
FF9E..FF9F ; Lm # [2] HALFWIDTH KATAKANA VOICED SOUND MARK..HALFWIDTH KATAKANA SEMI-VOICED SOUND MARK
+16F93..16F9F ; Lm # [13] MIAO LETTER TONE-2..MIAO LETTER REFORMED TONE-8
-# Total code points: 210
+# Total code points: 237
# ================================================
# General_Category=Other_Letter
+00AA ; Lo # FEMININE ORDINAL INDICATOR
+00BA ; Lo # MASCULINE ORDINAL INDICATOR
01BB ; Lo # LATIN LETTER TWO WITH STROKE
01C0..01C3 ; Lo # [4] LATIN LETTER DENTAL CLICK..LATIN LETTER RETROFLEX CLICK
0294 ; Lo # LATIN LETTER GLOTTAL STOP
@@ -1841,6 +1891,8 @@
07CA..07EA ; Lo # [33] NKO LETTER A..NKO LETTER JONA RA
0800..0815 ; Lo # [22] SAMARITAN LETTER ALAF..SAMARITAN LETTER TAAF
0840..0858 ; Lo # [25] MANDAIC LETTER HALQA..MANDAIC LETTER AIN
+08A0 ; Lo # ARABIC LETTER BEH WITH SMALL V BELOW
+08A2..08AC ; Lo # [11] ARABIC LETTER JEEM WITH TWO DOTS ABOVE..ARABIC LETTER ROHINGYA YEH
0904..0939 ; Lo # [54] DEVANAGARI LETTER SHORT A..DEVANAGARI LETTER HA
093D ; Lo # DEVANAGARI SIGN AVAGRAHA
0950 ; Lo # DEVANAGARI OM
@@ -1945,7 +1997,7 @@
0EB2..0EB3 ; Lo # [2] LAO VOWEL SIGN AA..LAO VOWEL SIGN AM
0EBD ; Lo # LAO SEMIVOWEL SIGN NYO
0EC0..0EC4 ; Lo # [5] LAO VOWEL SIGN E..LAO VOWEL SIGN AI
-0EDC..0EDD ; Lo # [2] LAO HO NO..LAO HO MO
+0EDC..0EDF ; Lo # [4] LAO HO NO..LAO LETTER KHMU NYO
0F00 ; Lo # TIBETAN SYLLABLE OM
0F40..0F47 ; Lo # [8] TIBETAN LETTER KA..TIBETAN LETTER JA
0F49..0F6C ; Lo # [36] TIBETAN LETTER NYA..TIBETAN LETTER RRA
@@ -1960,7 +2012,7 @@
1075..1081 ; Lo # [13] MYANMAR LETTER SHAN KA..MYANMAR LETTER SHAN HA
108E ; Lo # MYANMAR LETTER RUMAI PALAUNG FA
10D0..10FA ; Lo # [43] GEORGIAN LETTER AN..GEORGIAN LETTER AIN
-1100..1248 ; Lo # [329] HANGUL CHOSEONG KIYEOK..ETHIOPIC SYLLABLE QWA
+10FD..1248 ; Lo # [332] GEORGIAN LETTER AEN..ETHIOPIC SYLLABLE QWA
124A..124D ; Lo # [4] ETHIOPIC SYLLABLE QWI..ETHIOPIC SYLLABLE QWE
1250..1256 ; Lo # [7] ETHIOPIC SYLLABLE QHA..ETHIOPIC SYLLABLE QHO
1258 ; Lo # ETHIOPIC SYLLABLE QHWA
@@ -2006,14 +2058,15 @@
1B45..1B4B ; Lo # [7] BALINESE LETTER KAF SASAK..BALINESE LETTER ASYURA SASAK
1B83..1BA0 ; Lo # [30] SUNDANESE LETTER A..SUNDANESE LETTER HA
1BAE..1BAF ; Lo # [2] SUNDANESE LETTER KHA..SUNDANESE LETTER SYA
-1BC0..1BE5 ; Lo # [38] BATAK LETTER A..BATAK LETTER U
+1BBA..1BE5 ; Lo # [44] SUNDANESE AVAGRAHA..BATAK LETTER U
1C00..1C23 ; Lo # [36] LEPCHA LETTER KA..LEPCHA LETTER A
1C4D..1C4F ; Lo # [3] LEPCHA LETTER TTA..LEPCHA LETTER DDA
1C5A..1C77 ; Lo # [30] OL CHIKI LETTER LA..OL CHIKI LETTER OH
1CE9..1CEC ; Lo # [4] VEDIC SIGN ANUSVARA ANTARGOMUKHA..VEDIC SIGN ANUSVARA VAMAGOMUKHA WITH TAIL
1CEE..1CF1 ; Lo # [4] VEDIC SIGN HEXIFORM LONG ANUSVARA..VEDIC SIGN ANUSVARA UBHAYATO MUKHA
+1CF5..1CF6 ; Lo # [2] VEDIC SIGN JIHVAMULIYA..VEDIC SIGN UPADHMANIYA
2135..2138 ; Lo # [4] ALEF SYMBOL..DALET SYMBOL
-2D30..2D65 ; Lo # [54] TIFINAGH LETTER YA..TIFINAGH LETTER YAZZ
+2D30..2D67 ; Lo # [56] TIFINAGH LETTER YA..TIFINAGH LETTER YO
2D80..2D96 ; Lo # [23] ETHIOPIC SYLLABLE LOA..ETHIOPIC SYLLABLE GGWE
2DA0..2DA6 ; Lo # [7] ETHIOPIC SYLLABLE SSA..ETHIOPIC SYLLABLE SSO
2DA8..2DAE ; Lo # [7] ETHIOPIC SYLLABLE CCA..ETHIOPIC SYLLABLE CCO
@@ -2034,7 +2087,7 @@
31A0..31BA ; Lo # [27] BOPOMOFO LETTER BU..BOPOMOFO LETTER ZY
31F0..31FF ; Lo # [16] KATAKANA LETTER SMALL KU..KATAKANA LETTER SMALL RO
3400..4DB5 ; Lo # [6582] CJK UNIFIED IDEOGRAPH-3400..CJK UNIFIED IDEOGRAPH-4DB5
-4E00..9FCB ; Lo # [20940] CJK UNIFIED IDEOGRAPH-4E00..CJK UNIFIED IDEOGRAPH-9FCB
+4E00..9FCC ; Lo # [20941] CJK UNIFIED IDEOGRAPH-4E00..CJK UNIFIED IDEOGRAPH-9FCC
A000..A014 ; Lo # [21] YI SYLLABLE IT..YI SYLLABLE E
A016..A48C ; Lo # [1143] YI SYLLABLE BIT..YI SYLLABLE YYR
A4D0..A4F7 ; Lo # [40] LISU LETTER BA..LISU LETTER OE
@@ -2068,6 +2121,8 @@
AAC0 ; Lo # TAI VIET TONE MAI NUENG
AAC2 ; Lo # TAI VIET TONE MAI SONG
AADB..AADC ; Lo # [2] TAI VIET SYMBOL KON..TAI VIET SYMBOL NUENG
+AAE0..AAEA ; Lo # [11] MEETEI MAYEK LETTER E..MEETEI MAYEK LETTER SSA
+AAF2 ; Lo # MEETEI MAYEK ANJI
AB01..AB06 ; Lo # [6] ETHIOPIC SYLLABLE TTHU..ETHIOPIC SYLLABLE TTHO
AB09..AB0E ; Lo # [6] ETHIOPIC SYLLABLE DDHU..ETHIOPIC SYLLABLE DDHO
AB11..AB16 ; Lo # [6] ETHIOPIC SYLLABLE DZU..ETHIOPIC SYLLABLE DZO
@@ -2077,8 +2132,7 @@
AC00..D7A3 ; Lo # [11172] HANGUL SYLLABLE GA..HANGUL SYLLABLE HIH
D7B0..D7C6 ; Lo # [23] HANGUL JUNGSEONG O-YEO..HANGUL JUNGSEONG ARAEA-E
D7CB..D7FB ; Lo # [49] HANGUL JONGSEONG NIEUN-RIEUL..HANGUL JONGSEONG PHIEUPH-THIEUTH
-F900..FA2D ; Lo # [302] CJK COMPATIBILITY IDEOGRAPH-F900..CJK COMPATIBILITY IDEOGRAPH-FA2D
-FA30..FA6D ; Lo # [62] CJK COMPATIBILITY IDEOGRAPH-FA30..CJK COMPATIBILITY IDEOGRAPH-FA6D
+F900..FA6D ; Lo # [366] CJK COMPATIBILITY IDEOGRAPH-F900..CJK COMPATIBILITY IDEOGRAPH-FA6D
FA70..FAD9 ; Lo # [106] CJK COMPATIBILITY IDEOGRAPH-FA70..CJK COMPATIBILITY IDEOGRAPH-FAD9
FB1D ; Lo # HEBREW LETTER YOD WITH HIRIQ
FB1F..FB28 ; Lo # [10] HEBREW LIGATURE YIDDISH YOD YOD PATAH..HEBREW LETTER WIDE TAV
@@ -2125,6 +2179,8 @@
1083F..10855 ; Lo # [23] CYPRIOT SYLLABLE ZO..IMPERIAL ARAMAIC LETTER TAW
10900..10915 ; Lo # [22] PHOENICIAN LETTER ALF..PHOENICIAN LETTER TAU
10920..10939 ; Lo # [26] LYDIAN LETTER A..LYDIAN LETTER C
+10980..109B7 ; Lo # [56] MEROITIC HIEROGLYPHIC LETTER A..MEROITIC CURSIVE LETTER DA
+109BE..109BF ; Lo # [2] MEROITIC CURSIVE LOGOGRAM RMT..MEROITIC CURSIVE LOGOGRAM IMN
10A00 ; Lo # KHAROSHTHI LETTER A
10A10..10A13 ; Lo # [4] KHAROSHTHI LETTER KA..KHAROSHTHI LETTER GHA
10A15..10A17 ; Lo # [3] KHAROSHTHI LETTER CA..KHAROSHTHI LETTER JA
@@ -2136,16 +2192,56 @@
10C00..10C48 ; Lo # [73] OLD TURKIC LETTER ORKHON A..OLD TURKIC LETTER ORKHON BASH
11003..11037 ; Lo # [53] BRAHMI SIGN JIHVAMULIYA..BRAHMI LETTER OLD TAMIL NNNA
11083..110AF ; Lo # [45] KAITHI LETTER A..KAITHI LETTER HA
+110D0..110E8 ; Lo # [25] SORA SOMPENG LETTER SAH..SORA SOMPENG LETTER MAE
+11103..11126 ; Lo # [36] CHAKMA LETTER AA..CHAKMA LETTER HAA
+11183..111B2 ; Lo # [48] SHARADA LETTER A..SHARADA LETTER HA
+111C1..111C4 ; Lo # [4] SHARADA SIGN AVAGRAHA..SHARADA OM
+11680..116AA ; Lo # [43] TAKRI LETTER A..TAKRI LETTER RRA
12000..1236E ; Lo # [879] CUNEIFORM SIGN A..CUNEIFORM SIGN ZUM
13000..1342E ; Lo # [1071] EGYPTIAN HIEROGLYPH A001..EGYPTIAN HIEROGLYPH AA032
16800..16A38 ; Lo # [569] BAMUM LETTER PHASE-A NGKUE MFON..BAMUM LETTER PHASE-F VUEQ
+16F00..16F44 ; Lo # [69] MIAO LETTER PA..MIAO LETTER HHA
+16F50 ; Lo # MIAO LETTER NASALIZATION
1B000..1B001 ; Lo # [2] KATAKANA LETTER ARCHAIC E..HIRAGANA LETTER ARCHAIC YE
+1EE00..1EE03 ; Lo # [4] ARABIC MATHEMATICAL ALEF..ARABIC MATHEMATICAL DAL
+1EE05..1EE1F ; Lo # [27] ARABIC MATHEMATICAL WAW..ARABIC MATHEMATICAL DOTLESS QAF
+1EE21..1EE22 ; Lo # [2] ARABIC MATHEMATICAL INITIAL BEH..ARABIC MATHEMATICAL INITIAL JEEM
+1EE24 ; Lo # ARABIC MATHEMATICAL INITIAL HEH
+1EE27 ; Lo # ARABIC MATHEMATICAL INITIAL HAH
+1EE29..1EE32 ; Lo # [10] ARABIC MATHEMATICAL INITIAL YEH..ARABIC MATHEMATICAL INITIAL QAF
+1EE34..1EE37 ; Lo # [4] ARABIC MATHEMATICAL INITIAL SHEEN..ARABIC MATHEMATICAL INITIAL KHAH
+1EE39 ; Lo # ARABIC MATHEMATICAL INITIAL DAD
+1EE3B ; Lo # ARABIC MATHEMATICAL INITIAL GHAIN
+1EE42 ; Lo # ARABIC MATHEMATICAL TAILED JEEM
+1EE47 ; Lo # ARABIC MATHEMATICAL TAILED HAH
+1EE49 ; Lo # ARABIC MATHEMATICAL TAILED YEH
+1EE4B ; Lo # ARABIC MATHEMATICAL TAILED LAM
+1EE4D..1EE4F ; Lo # [3] ARABIC MATHEMATICAL TAILED NOON..ARABIC MATHEMATICAL TAILED AIN
+1EE51..1EE52 ; Lo # [2] ARABIC MATHEMATICAL TAILED SAD..ARABIC MATHEMATICAL TAILED QAF
+1EE54 ; Lo # ARABIC MATHEMATICAL TAILED SHEEN
+1EE57 ; Lo # ARABIC MATHEMATICAL TAILED KHAH
+1EE59 ; Lo # ARABIC MATHEMATICAL TAILED DAD
+1EE5B ; Lo # ARABIC MATHEMATICAL TAILED GHAIN
+1EE5D ; Lo # ARABIC MATHEMATICAL TAILED DOTLESS NOON
+1EE5F ; Lo # ARABIC MATHEMATICAL TAILED DOTLESS QAF
+1EE61..1EE62 ; Lo # [2] ARABIC MATHEMATICAL STRETCHED BEH..ARABIC MATHEMATICAL STRETCHED JEEM
+1EE64 ; Lo # ARABIC MATHEMATICAL STRETCHED HEH
+1EE67..1EE6A ; Lo # [4] ARABIC MATHEMATICAL STRETCHED HAH..ARABIC MATHEMATICAL STRETCHED KAF
+1EE6C..1EE72 ; Lo # [7] ARABIC MATHEMATICAL STRETCHED MEEM..ARABIC MATHEMATICAL STRETCHED QAF
+1EE74..1EE77 ; Lo # [4] ARABIC MATHEMATICAL STRETCHED SHEEN..ARABIC MATHEMATICAL STRETCHED KHAH
+1EE79..1EE7C ; Lo # [4] ARABIC MATHEMATICAL STRETCHED DAD..ARABIC MATHEMATICAL STRETCHED DOTLESS BEH
+1EE7E ; Lo # ARABIC MATHEMATICAL STRETCHED DOTLESS FEH
+1EE80..1EE89 ; Lo # [10] ARABIC MATHEMATICAL LOOPED ALEF..ARABIC MATHEMATICAL LOOPED YEH
+1EE8B..1EE9B ; Lo # [17] ARABIC MATHEMATICAL LOOPED LAM..ARABIC MATHEMATICAL LOOPED GHAIN
+1EEA1..1EEA3 ; Lo # [3] ARABIC MATHEMATICAL DOUBLE-STRUCK BEH..ARABIC MATHEMATICAL DOUBLE-STRUCK DAL
+1EEA5..1EEA9 ; Lo # [5] ARABIC MATHEMATICAL DOUBLE-STRUCK WAW..ARABIC MATHEMATICAL DOUBLE-STRUCK YEH
+1EEAB..1EEBB ; Lo # [17] ARABIC MATHEMATICAL DOUBLE-STRUCK LAM..ARABIC MATHEMATICAL DOUBLE-STRUCK GHAIN
20000..2A6D6 ; Lo # [42711] CJK UNIFIED IDEOGRAPH-20000..CJK UNIFIED IDEOGRAPH-2A6D6
2A700..2B734 ; Lo # [4149] CJK UNIFIED IDEOGRAPH-2A700..CJK UNIFIED IDEOGRAPH-2B734
2B740..2B81D ; Lo # [222] CJK UNIFIED IDEOGRAPH-2B740..CJK UNIFIED IDEOGRAPH-2B81D
2F800..2FA1D ; Lo # [542] CJK COMPATIBILITY IDEOGRAPH-2F800..CJK COMPATIBILITY IDEOGRAPH-2FA1D
-# Total code points: 97084
+# Total code points: 97553
# ================================================
@@ -2174,6 +2270,7 @@
0825..0827 ; Mn # [3] SAMARITAN VOWEL SIGN SHORT A..SAMARITAN VOWEL SIGN U
0829..082D ; Mn # [5] SAMARITAN VOWEL SIGN LONG I..SAMARITAN MARK NEQUDAA
0859..085B ; Mn # [3] MANDAIC AFFRICATION MARK..MANDAIC GEMINATION MARK
+08E4..08FE ; Mn # [27] ARABIC CURLY FATHA..ARABIC DAMMA WITH DOT
0900..0902 ; Mn # [3] DEVANAGARI SIGN INVERTED CANDRABINDU..DEVANAGARI SIGN ANUSVARA
093A ; Mn # DEVANAGARI VOWEL SIGN OE
093C ; Mn # DEVANAGARI SIGN NUKTA
@@ -2259,6 +2356,7 @@
1732..1734 ; Mn # [3] HANUNOO VOWEL SIGN I..HANUNOO SIGN PAMUDPOD
1752..1753 ; Mn # [2] BUHID VOWEL SIGN I..BUHID VOWEL SIGN U
1772..1773 ; Mn # [2] TAGBANWA VOWEL SIGN I..TAGBANWA VOWEL SIGN U
+17B4..17B5 ; Mn # [2] KHMER VOWEL INHERENT AQ..KHMER VOWEL INHERENT AA
17B7..17BD ; Mn # [7] KHMER VOWEL SIGN I..KHMER VOWEL SIGN UA
17C6 ; Mn # KHMER SIGN NIKAHIT
17C9..17D3 ; Mn # [11] KHMER SIGN MUUSIKATOAN..KHMER SIGN BATHAMASAT
@@ -2286,6 +2384,7 @@
1B80..1B81 ; Mn # [2] SUNDANESE SIGN PANYECEK..SUNDANESE SIGN PANGLAYAR
1BA2..1BA5 ; Mn # [4] SUNDANESE CONSONANT SIGN PANYAKRA..SUNDANESE VOWEL SIGN PANYUKU
1BA8..1BA9 ; Mn # [2] SUNDANESE VOWEL SIGN PAMEPET..SUNDANESE VOWEL SIGN PANEULEUNG
+1BAB ; Mn # SUNDANESE SIGN VIRAMA
1BE6 ; Mn # BATAK SIGN TOMPI
1BE8..1BE9 ; Mn # [2] BATAK VOWEL SIGN PAKPAK E..BATAK VOWEL SIGN EE
1BED ; Mn # BATAK VOWEL SIGN KARO O
@@ -2296,6 +2395,7 @@
1CD4..1CE0 ; Mn # [13] VEDIC SIGN YAJURVEDIC MIDLINE SVARITA..VEDIC TONE RIGVEDIC KASHMIRI INDEPENDENT SVARITA
1CE2..1CE8 ; Mn # [7] VEDIC SIGN VISARGA SVARITA..VEDIC SIGN VISARGA ANUDATTA WITH TAIL
1CED ; Mn # VEDIC SIGN TIRYAK
+1CF4 ; Mn # VEDIC TONE CANDRA ABOVE
1DC0..1DE6 ; Mn # [39] COMBINING DOTTED GRAVE ACCENT..COMBINING LATIN SMALL LETTER Z
1DFC..1DFF ; Mn # [4] COMBINING DOUBLE INVERTED BREVE BELOW..COMBINING RIGHT ARROWHEAD AND DOWN ARROWHEAD BELOW
20D0..20DC ; Mn # [13] COMBINING LEFT HARPOON ABOVE..COMBINING FOUR DOTS ABOVE
@@ -2304,10 +2404,11 @@
2CEF..2CF1 ; Mn # [3] COPTIC COMBINING NI ABOVE..COPTIC COMBINING SPIRITUS LENIS
2D7F ; Mn # TIFINAGH CONSONANT JOINER
2DE0..2DFF ; Mn # [32] COMBINING CYRILLIC LETTER BE..COMBINING CYRILLIC LETTER IOTIFIED BIG YUS
-302A..302F ; Mn # [6] IDEOGRAPHIC LEVEL TONE MARK..HANGUL DOUBLE DOT TONE MARK
+302A..302D ; Mn # [4] IDEOGRAPHIC LEVEL TONE MARK..IDEOGRAPHIC ENTERING TONE MARK
3099..309A ; Mn # [2] COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK..COMBINING KATAKANA-HIRAGANA SEMI-VOICED SOUND MARK
A66F ; Mn # COMBINING CYRILLIC VZMET
-A67C..A67D ; Mn # [2] COMBINING CYRILLIC KAVYKA..COMBINING CYRILLIC PAYEROK
+A674..A67D ; Mn # [10] COMBINING CYRILLIC LETTER UKRAINIAN IE..COMBINING CYRILLIC PAYEROK
+A69F ; Mn # COMBINING CYRILLIC LETTER IOTIFIED E
A6F0..A6F1 ; Mn # [2] BAMUM COMBINING MARK KOQNDON..BAMUM COMBINING MARK TUKWENTIS
A802 ; Mn # SYLOTI NAGRI SIGN DVISVARA
A806 ; Mn # SYLOTI NAGRI SIGN HASANTA
@@ -2331,6 +2432,8 @@
AAB7..AAB8 ; Mn # [2] TAI VIET MAI KHIT..TAI VIET VOWEL IA
AABE..AABF ; Mn # [2] TAI VIET VOWEL AM..TAI VIET TONE MAI EK
AAC1 ; Mn # TAI VIET TONE MAI THO
+AAEC..AAED ; Mn # [2] MEETEI MAYEK VOWEL SIGN UU..MEETEI MAYEK VOWEL SIGN AAI
+AAF6 ; Mn # MEETEI MAYEK VIRAMA
ABE5 ; Mn # MEETEI MAYEK VOWEL SIGN ANAP
ABE8 ; Mn # MEETEI MAYEK VOWEL SIGN UNAP
ABED ; Mn # MEETEI MAYEK APUN IYEK
@@ -2348,6 +2451,16 @@
11080..11081 ; Mn # [2] KAITHI SIGN CANDRABINDU..KAITHI SIGN ANUSVARA
110B3..110B6 ; Mn # [4] KAITHI VOWEL SIGN U..KAITHI VOWEL SIGN AI
110B9..110BA ; Mn # [2] KAITHI SIGN VIRAMA..KAITHI SIGN NUKTA
+11100..11102 ; Mn # [3] CHAKMA SIGN CANDRABINDU..CHAKMA SIGN VISARGA
+11127..1112B ; Mn # [5] CHAKMA VOWEL SIGN A..CHAKMA VOWEL SIGN UU
+1112D..11134 ; Mn # [8] CHAKMA VOWEL SIGN AI..CHAKMA MAAYYAA
+11180..11181 ; Mn # [2] SHARADA SIGN CANDRABINDU..SHARADA SIGN ANUSVARA
+111B6..111BE ; Mn # [9] SHARADA VOWEL SIGN U..SHARADA VOWEL SIGN O
+116AB ; Mn # TAKRI SIGN ANUSVARA
+116AD ; Mn # TAKRI VOWEL SIGN AA
+116B0..116B5 ; Mn # [6] TAKRI VOWEL SIGN U..TAKRI VOWEL SIGN AU
+116B7 ; Mn # TAKRI SIGN NUKTA
+16F8F..16F92 ; Mn # [4] MIAO TONE RIGHT..MIAO TONE BELOW
1D167..1D169 ; Mn # [3] MUSICAL SYMBOL COMBINING TREMOLO-1..MUSICAL SYMBOL COMBINING TREMOLO-3
1D17B..1D182 ; Mn # [8] MUSICAL SYMBOL COMBINING ACCENT..MUSICAL SYMBOL COMBINING LOURE
1D185..1D18B ; Mn # [7] MUSICAL SYMBOL COMBINING DOIT..MUSICAL SYMBOL COMBINING TRIPLE TONGUE
@@ -2355,7 +2468,7 @@
1D242..1D244 ; Mn # [3] COMBINING GREEK MUSICAL TRISEME..COMBINING GREEK MUSICAL PENTASEME
E0100..E01EF ; Mn # [240] VARIATION SELECTOR-17..VARIATION SELECTOR-256
-# Total code points: 1199
+# Total code points: 1280
# ================================================
@@ -2453,6 +2566,7 @@
1BA1 ; Mc # SUNDANESE CONSONANT SIGN PAMINGKAL
1BA6..1BA7 ; Mc # [2] SUNDANESE VOWEL SIGN PANAELAENG..SUNDANESE VOWEL SIGN PANOLONG
1BAA ; Mc # SUNDANESE SIGN PAMAAEH
+1BAC..1BAD ; Mc # [2] SUNDANESE CONSONANT SIGN PASANGAN MA..SUNDANESE CONSONANT SIGN PASANGAN WA
1BE7 ; Mc # BATAK VOWEL SIGN E
1BEA..1BEC ; Mc # [3] BATAK VOWEL SIGN I..BATAK VOWEL SIGN O
1BEE ; Mc # BATAK VOWEL SIGN U
@@ -2460,7 +2574,8 @@
1C24..1C2B ; Mc # [8] LEPCHA SUBJOINED LETTER YA..LEPCHA VOWEL SIGN UU
1C34..1C35 ; Mc # [2] LEPCHA CONSONANT SIGN NYIN-DO..LEPCHA CONSONANT SIGN KANG
1CE1 ; Mc # VEDIC TONE ATHARVAVEDIC INDEPENDENT SVARITA
-1CF2 ; Mc # VEDIC SIGN ARDHAVISARGA
+1CF2..1CF3 ; Mc # [2] VEDIC SIGN ARDHAVISARGA..VEDIC SIGN ROTATED ARDHAVISARGA
+302E..302F ; Mc # [2] HANGUL SINGLE DOT TONE MARK..HANGUL DOUBLE DOT TONE MARK
A823..A824 ; Mc # [2] SYLOTI NAGRI VOWEL SIGN A..SYLOTI NAGRI VOWEL SIGN I
A827 ; Mc # SYLOTI NAGRI VOWEL SIGN OO
A880..A881 ; Mc # [2] SAURASHTRA SIGN ANUSVARA..SAURASHTRA SIGN VISARGA
@@ -2474,6 +2589,9 @@
AA33..AA34 ; Mc # [2] CHAM CONSONANT SIGN YA..CHAM CONSONANT SIGN RA
AA4D ; Mc # CHAM CONSONANT SIGN FINAL H
AA7B ; Mc # MYANMAR SIGN PAO KAREN TONE
+AAEB ; Mc # MEETEI MAYEK VOWEL SIGN II
+AAEE..AAEF ; Mc # [2] MEETEI MAYEK VOWEL SIGN AU..MEETEI MAYEK VOWEL SIGN AAU
+AAF5 ; Mc # MEETEI MAYEK VOWEL SIGN VISARGA
ABE3..ABE4 ; Mc # [2] MEETEI MAYEK VOWEL SIGN ONAP..MEETEI MAYEK VOWEL SIGN INAP
ABE6..ABE7 ; Mc # [2] MEETEI MAYEK VOWEL SIGN YENAP..MEETEI MAYEK VOWEL SIGN SOUNAP
ABE9..ABEA ; Mc # [2] MEETEI MAYEK VOWEL SIGN CHEINAP..MEETEI MAYEK VOWEL SIGN NUNG
@@ -2483,10 +2601,18 @@
11082 ; Mc # KAITHI SIGN VISARGA
110B0..110B2 ; Mc # [3] KAITHI VOWEL SIGN AA..KAITHI VOWEL SIGN II
110B7..110B8 ; Mc # [2] KAITHI VOWEL SIGN O..KAITHI VOWEL SIGN AU
+1112C ; Mc # CHAKMA VOWEL SIGN E
+11182 ; Mc # SHARADA SIGN VISARGA
+111B3..111B5 ; Mc # [3] SHARADA VOWEL SIGN AA..SHARADA VOWEL SIGN II
+111BF..111C0 ; Mc # [2] SHARADA VOWEL SIGN AU..SHARADA SIGN VIRAMA
+116AC ; Mc # TAKRI SIGN VISARGA
+116AE..116AF ; Mc # [2] TAKRI VOWEL SIGN I..TAKRI VOWEL SIGN II
+116B6 ; Mc # TAKRI SIGN VIRAMA
+16F51..16F7E ; Mc # [46] MIAO SIGN ASPIRATION..MIAO VOWEL SIGN NG
1D165..1D166 ; Mc # [2] MUSICAL SYMBOL COMBINING STEM..MUSICAL SYMBOL COMBINING SPRECHGESANG STEM
1D16D..1D172 ; Mc # [6] MUSICAL SYMBOL COMBINING AUGMENTATION DOT..MUSICAL SYMBOL COMBINING FLAG-5
-# Total code points: 287
+# Total code points: 353
# ================================================
@@ -2529,9 +2655,13 @@
FF10..FF19 ; Nd # [10] FULLWIDTH DIGIT ZERO..FULLWIDTH DIGIT NINE
104A0..104A9 ; Nd # [10] OSMANYA DIGIT ZERO..OSMANYA DIGIT NINE
11066..1106F ; Nd # [10] BRAHMI DIGIT ZERO..BRAHMI DIGIT NINE
+110F0..110F9 ; Nd # [10] SORA SOMPENG DIGIT ZERO..SORA SOMPENG DIGIT NINE
+11136..1113F ; Nd # [10] CHAKMA DIGIT ZERO..CHAKMA DIGIT NINE
+111D0..111D9 ; Nd # [10] SHARADA DIGIT ZERO..SHARADA DIGIT NINE
+116C0..116C9 ; Nd # [10] TAKRI DIGIT ZERO..TAKRI DIGIT NINE
1D7CE..1D7FF ; Nd # [50] MATHEMATICAL BOLD DIGIT ZERO..MATHEMATICAL MONOSPACE DIGIT NINE
-# Total code points: 420
+# Total code points: 460
# ================================================
@@ -2579,6 +2709,7 @@
2CFD ; No # COPTIC FRACTION ONE HALF
3192..3195 ; No # [4] IDEOGRAPHIC ANNOTATION ONE MARK..IDEOGRAPHIC ANNOTATION FOUR MARK
3220..3229 ; No # [10] PARENTHESIZED IDEOGRAPH ONE..PARENTHESIZED IDEOGRAPH TEN
+3248..324F ; No # [8] CIRCLED NUMBER TEN ON BLACK SQUARE..CIRCLED NUMBER EIGHTY ON BLACK SQUARE
3251..325F ; No # [15] CIRCLED NUMBER TWENTY ONE..CIRCLED NUMBER THIRTY FIVE
3280..3289 ; No # [10] CIRCLED IDEOGRAPH ONE..CIRCLED IDEOGRAPH TEN
32B1..32BF ; No # [15] CIRCLED NUMBER THIRTY SIX..CIRCLED NUMBER FIFTY
@@ -2598,7 +2729,7 @@
1D360..1D371 ; No # [18] COUNTING ROD UNIT DIGIT ONE..COUNTING ROD TENS DIGIT NINE
1F100..1F10A ; No # [11] DIGIT ZERO FULL STOP..DIGIT NINE COMMA
-# Total code points: 456
+# Total code points: 464
# ================================================
@@ -2645,10 +2776,9 @@
# General_Category=Format
00AD ; Cf # SOFT HYPHEN
-0600..0603 ; Cf # [4] ARABIC NUMBER SIGN..ARABIC SIGN SAFHA
+0600..0604 ; Cf # [5] ARABIC NUMBER SIGN..ARABIC SIGN SAMVAT
06DD ; Cf # ARABIC END OF AYAH
070F ; Cf # SYRIAC ABBREVIATION MARK
-17B4..17B5 ; Cf # [2] KHMER VOWEL INHERENT AQ..KHMER VOWEL INHERENT AA
200B..200F ; Cf # [5] ZERO WIDTH SPACE..RIGHT-TO-LEFT MARK
202A..202E ; Cf # [5] LEFT-TO-RIGHT EMBEDDING..RIGHT-TO-LEFT OVERRIDE
2060..2064 ; Cf # [5] WORD JOINER..INVISIBLE PLUS
@@ -2660,7 +2790,7 @@
E0001 ; Cf # LANGUAGE TAG
E0020..E007F ; Cf # [96] TAG SPACE..CANCEL TAG
-# Total code points: 140
+# Total code points: 139
# ================================================
@@ -2692,6 +2822,7 @@
2010..2015 ; Pd # [6] HYPHEN..HORIZONTAL BAR
2E17 ; Pd # DOUBLE OBLIQUE HYPHEN
2E1A ; Pd # HYPHEN WITH DIAERESIS
+2E3A..2E3B ; Pd # [2] TWO-EM DASH..THREE-EM DASH
301C ; Pd # WAVE DASH
3030 ; Pd # WAVY DASH
30A0 ; Pd # KATAKANA-HIRAGANA DOUBLE HYPHEN
@@ -2700,7 +2831,7 @@
FE63 ; Pd # SMALL HYPHEN-MINUS
FF0D ; Pd # FULLWIDTH HYPHEN-MINUS
-# Total code points: 21
+# Total code points: 23
# ================================================
@@ -2884,7 +3015,8 @@
003F..0040 ; Po # [2] QUESTION MARK..COMMERCIAL AT
005C ; Po # REVERSE SOLIDUS
00A1 ; Po # INVERTED EXCLAMATION MARK
-00B7 ; Po # MIDDLE DOT
+00A7 ; Po # SECTION SIGN
+00B6..00B7 ; Po # [2] PILCROW SIGN..MIDDLE DOT
00BF ; Po # INVERTED QUESTION MARK
037E ; Po # GREEK QUESTION MARK
0387 ; Po # GREEK ANO TELEIA
@@ -2906,16 +3038,18 @@
085E ; Po # MANDAIC PUNCTUATION
0964..0965 ; Po # [2] DEVANAGARI DANDA..DEVANAGARI DOUBLE DANDA
0970 ; Po # DEVANAGARI ABBREVIATION SIGN
+0AF0 ; Po # GUJARATI ABBREVIATION SIGN
0DF4 ; Po # SINHALA PUNCTUATION KUNDDALIYA
0E4F ; Po # THAI CHARACTER FONGMAN
0E5A..0E5B ; Po # [2] THAI CHARACTER ANGKHANKHU..THAI CHARACTER KHOMUT
0F04..0F12 ; Po # [15] TIBETAN MARK INITIAL YIG MGO MDUN MA..TIBETAN MARK RGYA GRAM SHAD
+0F14 ; Po # TIBETAN MARK GTER TSHEG
0F85 ; Po # TIBETAN MARK PALUTA
0FD0..0FD4 ; Po # [5] TIBETAN MARK BSKA- SHOG GI MGO RGYAN..TIBETAN MARK CLOSING BRDA RNYING YIG MGO SGAB MA
0FD9..0FDA ; Po # [2] TIBETAN MARK LEADING MCHAN RTAGS..TIBETAN MARK TRAILING MCHAN RTAGS
104A..104F ; Po # [6] MYANMAR SIGN LITTLE SECTION..MYANMAR SYMBOL GENITIVE
10FB ; Po # GEORGIAN PARAGRAPH SEPARATOR
-1361..1368 ; Po # [8] ETHIOPIC WORDSPACE..ETHIOPIC PARAGRAPH SEPARATOR
+1360..1368 ; Po # [9] ETHIOPIC SECTION MARK..ETHIOPIC PARAGRAPH SEPARATOR
166D..166E ; Po # [2] CANADIAN SYLLABICS CHI SIGN..CANADIAN SYLLABICS FULL STOP
16EB..16ED ; Po # [3] RUNIC SINGLE PUNCTUATION..RUNIC CROSS PUNCTUATION
1735..1736 ; Po # [2] PHILIPPINE SINGLE PUNCTUATION..PHILIPPINE DOUBLE PUNCTUATION
@@ -2931,6 +3065,7 @@
1BFC..1BFF ; Po # [4] BATAK SYMBOL BINDU NA METEK..BATAK SYMBOL BINDU PANGOLAT
1C3B..1C3F ; Po # [5] LEPCHA PUNCTUATION TA-ROL..LEPCHA PUNCTUATION TSHOOK
1C7E..1C7F ; Po # [2] OL CHIKI PUNCTUATION MUCAAD..OL CHIKI PUNCTUATION DOUBLE MUCAAD
+1CC0..1CC7 ; Po # [8] SUNDANESE PUNCTUATION BINDU SURYA..SUNDANESE PUNCTUATION BINDU BA SATANGA
1CD3 ; Po # VEDIC SIGN NIHSHVASA
2016..2017 ; Po # [2] DOUBLE VERTICAL LINE..DOUBLE LOW LINE
2020..2027 ; Po # [8] DAGGER..HYPHENATION POINT
@@ -2951,7 +3086,7 @@
2E1B ; Po # TILDE WITH RING ABOVE
2E1E..2E1F ; Po # [2] TILDE WITH DOT ABOVE..TILDE WITH DOT BELOW
2E2A..2E2E ; Po # [5] TWO DOTS OVER ONE DOT PUNCTUATION..REVERSED QUESTION MARK
-2E30..2E31 ; Po # [2] RING POINT..WORD SEPARATOR MIDDLE DOT
+2E30..2E39 ; Po # [10] RING POINT..TOP HALF SECTION SIGN
3001..3003 ; Po # [3] IDEOGRAPHIC COMMA..DITTO MARK
303D ; Po # PART ALTERNATION MARK
30FB ; Po # KATAKANA MIDDLE DOT
@@ -2969,6 +3104,7 @@
A9DE..A9DF ; Po # [2] JAVANESE PADA TIRTA TUMETES..JAVANESE PADA ISEN-ISEN
AA5C..AA5F ; Po # [4] CHAM PUNCTUATION SPIRAL..CHAM PUNCTUATION TRIPLE DANDA
AADE..AADF ; Po # [2] TAI VIET SYMBOL HO HOI..TAI VIET SYMBOL KOI KOI
+AAF0..AAF1 ; Po # [2] MEETEI MAYEK CHEIKHAN..MEETEI MAYEK AHANG KHUDAM
ABEB ; Po # MEETEI MAYEK CHEIKHEI
FE10..FE16 ; Po # [7] PRESENTATION FORM FOR VERTICAL COMMA..PRESENTATION FORM FOR VERTICAL QUESTION MARK
FE19 ; Po # PRESENTATION FORM FOR VERTICAL HORIZONTAL ELLIPSIS
@@ -2990,7 +3126,7 @@
FF3C ; Po # FULLWIDTH REVERSE SOLIDUS
FF61 ; Po # HALFWIDTH IDEOGRAPHIC FULL STOP
FF64..FF65 ; Po # [2] HALFWIDTH IDEOGRAPHIC COMMA..HALFWIDTH KATAKANA MIDDLE DOT
-10100..10101 ; Po # [2] AEGEAN WORD SEPARATOR LINE..AEGEAN WORD SEPARATOR DOT
+10100..10102 ; Po # [3] AEGEAN WORD SEPARATOR LINE..AEGEAN CHECK MARK
1039F ; Po # UGARITIC WORD DIVIDER
103D0 ; Po # OLD PERSIAN WORD DIVIDER
10857 ; Po # IMPERIAL ARAMAIC SECTION SIGN
@@ -3002,9 +3138,11 @@
11047..1104D ; Po # [7] BRAHMI DANDA..BRAHMI PUNCTUATION LOTUS
110BB..110BC ; Po # [2] KAITHI ABBREVIATION SIGN..KAITHI ENUMERATION SIGN
110BE..110C1 ; Po # [4] KAITHI SECTION MARK..KAITHI DOUBLE DANDA
+11140..11143 ; Po # [4] CHAKMA SECTION MARK..CHAKMA QUESTION MARK
+111C5..111C8 ; Po # [4] SHARADA DANDA..SHARADA SEPARATOR
12470..12473 ; Po # [4] CUNEIFORM PUNCTUATION SIGN OLD ASSYRIAN WORD DIVIDER..CUNEIFORM PUNCTUATION SIGN DIAGONAL TRICOLON
-# Total code points: 402
+# Total code points: 434
# ================================================
@@ -3047,9 +3185,7 @@
25F8..25FF ; Sm # [8] UPPER LEFT TRIANGLE..LOWER RIGHT TRIANGLE
266F ; Sm # MUSIC SHARP SIGN
27C0..27C4 ; Sm # [5] THREE DIMENSIONAL ANGLE..OPEN SUPERSET
-27C7..27CA ; Sm # [4] OR WITH DOT INSIDE..VERTICAL BAR WITH HORIZONTAL STROKE
-27CC ; Sm # LONG DIVISION
-27CE..27E5 ; Sm # [24] SQUARED LOGICAL AND..WHITE SQUARE WITH RIGHTWARDS TICK
+27C7..27E5 ; Sm # [31] OR WITH DOT INSIDE..WHITE SQUARE WITH RIGHTWARDS TICK
27F0..27FF ; Sm # [16] UPWARDS QUADRUPLE ARROW..LONG RIGHTWARDS SQUIGGLE ARROW
2900..2982 ; Sm # [131] RIGHTWARDS TWO-HEADED ARROW WITH VERTICAL STROKE..Z NOTATION TYPE COLON
2999..29D7 ; Sm # [63] DOTTED FENCE..BLACK HOURGLASS
@@ -3076,8 +3212,9 @@
1D789 ; Sm # MATHEMATICAL SANS-SERIF BOLD PARTIAL DIFFERENTIAL
1D7A9 ; Sm # MATHEMATICAL SANS-SERIF BOLD ITALIC NABLA
1D7C3 ; Sm # MATHEMATICAL SANS-SERIF BOLD ITALIC PARTIAL DIFFERENTIAL
+1EEF0..1EEF1 ; Sm # [2] ARABIC MATHEMATICAL OPERATOR MEEM WITH HAH WITH TATWEEL..ARABIC MATHEMATICAL OPERATOR HAH WITH DAL
-# Total code points: 948
+# Total code points: 952
# ================================================
@@ -3085,6 +3222,7 @@
0024 ; Sc # DOLLAR SIGN
00A2..00A5 ; Sc # [4] CENT SIGN..YEN SIGN
+058F ; Sc # ARMENIAN DRAM SIGN
060B ; Sc # AFGHANI SIGN
09F2..09F3 ; Sc # [2] BENGALI RUPEE MARK..BENGALI RUPEE SIGN
09FB ; Sc # BENGALI GANDA MARK
@@ -3092,7 +3230,7 @@
0BF9 ; Sc # TAMIL RUPEE SIGN
0E3F ; Sc # THAI CURRENCY SYMBOL BAHT
17DB ; Sc # KHMER CURRENCY SYMBOL RIEL
-20A0..20B9 ; Sc # [26] EURO-CURRENCY SIGN..INDIAN RUPEE SIGN
+20A0..20BA ; Sc # [27] EURO-CURRENCY SIGN..TURKISH LIRA SIGN
A838 ; Sc # NORTH INDIC RUPEE MARK
FDFC ; Sc # RIAL SIGN
FE69 ; Sc # SMALL DOLLAR SIGN
@@ -3100,7 +3238,7 @@
FFE0..FFE1 ; Sc # [2] FULLWIDTH CENT SIGN..FULLWIDTH POUND SIGN
FFE5..FFE6 ; Sc # [2] FULLWIDTH YEN SIGN..FULLWIDTH WON SIGN
-# Total code points: 47
+# Total code points: 49
# ================================================
@@ -3140,11 +3278,10 @@
# General_Category=Other_Symbol
-00A6..00A7 ; So # [2] BROKEN BAR..SECTION SIGN
+00A6 ; So # BROKEN BAR
00A9 ; So # COPYRIGHT SIGN
00AE ; So # REGISTERED SIGN
00B0 ; So # DEGREE SIGN
-00B6 ; So # PILCROW SIGN
0482 ; So # CYRILLIC THOUSANDS SIGN
060E..060F ; So # [2] ARABIC POETIC VERSE SIGN..ARABIC SIGN MISRA
06DE ; So # ARABIC START OF RUB EL HIZB
@@ -3158,7 +3295,8 @@
0C7F ; So # TELUGU SIGN TUUMU
0D79 ; So # MALAYALAM DATE MARK
0F01..0F03 ; So # [3] TIBETAN MARK GTER YIG MGO TRUNCATED A..TIBETAN MARK GTER YIG MGO -UM GTER TSHEG MA
-0F13..0F17 ; So # [5] TIBETAN MARK CARET -DZUD RTAGS ME LONG CAN..TIBETAN ASTROLOGICAL SIGN SGRA GCAN -CHAR RTAGS
+0F13 ; So # TIBETAN MARK CARET -DZUD RTAGS ME LONG CAN
+0F15..0F17 ; So # [3] TIBETAN LOGOTYPE SIGN CHAD RTAGS..TIBETAN ASTROLOGICAL SIGN SGRA GCAN -CHAR RTAGS
0F1A..0F1F ; So # [6] TIBETAN SIGN RDEL DKAR GCIG..TIBETAN SIGN RDEL DKAR RDEL NAG
0F34 ; So # TIBETAN MARK BSDUS RTAGS
0F36 ; So # TIBETAN MARK CARET -DZUD RTAGS BZHI MIG CAN
@@ -3168,7 +3306,6 @@
0FCE..0FCF ; So # [2] TIBETAN SIGN RDEL NAG RDEL DKAR..TIBETAN SIGN RDEL NAG GSUM
0FD5..0FD8 ; So # [4] RIGHT-FACING SVASTI SIGN..LEFT-FACING SVASTI SIGN WITH DOTS
109E..109F ; So # [2] MYANMAR SYMBOL SHAN ONE..MYANMAR SYMBOL SHAN EXCLAMATION
-1360 ; So # ETHIOPIC SECTION MARK
1390..1399 ; So # [10] ETHIOPIC TONAL MARK YIZET..ETHIOPIC TONAL MARK KURT
1940 ; So # LIMBU SIGN LOO
19DE..19FF ; So # [34] NEW TAI LUE SIGN LAE..KHMER SYMBOL DAP-PRAM ROC
@@ -3232,7 +3369,8 @@
3196..319F ; So # [10] IDEOGRAPHIC ANNOTATION TOP MARK..IDEOGRAPHIC ANNOTATION MAN MARK
31C0..31E3 ; So # [36] CJK STROKE T..CJK STROKE Q
3200..321E ; So # [31] PARENTHESIZED HANGUL KIYEOK..PARENTHESIZED KOREAN CHARACTER O HU
-322A..3250 ; So # [39] PARENTHESIZED IDEOGRAPH MOON..PARTNERSHIP SIGN
+322A..3247 ; So # [30] PARENTHESIZED IDEOGRAPH MOON..CIRCLED IDEOGRAPH KOTO
+3250 ; So # PARTNERSHIP SIGN
3260..327F ; So # [32] CIRCLED HANGUL KIYEOK..KOREAN STANDARD SYMBOL
328A..32B0 ; So # [39] CIRCLED IDEOGRAPH MOON..CIRCLED IDEOGRAPH NIGHT
32C0..32FE ; So # [63] IDEOGRAPHIC TELEGRAPH SYMBOL FOR JANUARY..CIRCLED KATAKANA WO
@@ -3248,7 +3386,6 @@
FFE8 ; So # HALFWIDTH FORMS LIGHT VERTICAL
FFED..FFEE ; So # [2] HALFWIDTH BLACK SQUARE..HALFWIDTH WHITE CIRCLE
FFFC..FFFD ; So # [2] OBJECT REPLACEMENT CHARACTER..REPLACEMENT CHARACTER
-10102 ; So # AEGEAN CHECK MARK
10137..1013F ; So # [9] AEGEAN WEIGHT BASE UNIT..AEGEAN MEASURE THIRD SUBUNIT
10179..10189 ; So # [17] GREEK YEAR SIGN..GREEK TRYBLION BASE SIGN
10190..1019B ; So # [12] ROMAN SEXTANS SIGN..ROMAN CENTURIAL SIGN
@@ -3270,7 +3407,7 @@
1F0C1..1F0CF ; So # [15] PLAYING CARD ACE OF DIAMONDS..PLAYING CARD BLACK JOKER
1F0D1..1F0DF ; So # [15] PLAYING CARD ACE OF CLUBS..PLAYING CARD WHITE JOKER
1F110..1F12E ; So # [31] PARENTHESIZED LATIN CAPITAL LETTER A..CIRCLED WZ
-1F130..1F169 ; So # [58] SQUARED LATIN CAPITAL LETTER A..NEGATIVE CIRCLED LATIN CAPITAL LETTER Z
+1F130..1F16B ; So # [60] SQUARED LATIN CAPITAL LETTER A..RAISED MD SIGN
1F170..1F19A ; So # [43] NEGATIVE SQUARED LATIN CAPITAL LETTER A..SQUARED VS
1F1E6..1F202 ; So # [29] REGIONAL INDICATOR SYMBOL LETTER A..SQUARED KATAKANA SA
1F210..1F23A ; So # [43] SQUARED CJK UNIFIED IDEOGRAPH-624B..SQUARED CJK UNIFIED IDEOGRAPH-55B6
@@ -3288,24 +3425,14 @@
1F442..1F4F7 ; So # [182] EAR..CAMERA
1F4F9..1F4FC ; So # [4] VIDEO CAMERA..VIDEOCASSETTE
1F500..1F53D ; So # [62] TWISTED RIGHTWARDS ARROWS..DOWN-POINTING SMALL RED TRIANGLE
+1F540..1F543 ; So # [4] CIRCLED CROSS POMMEE..NOTCHED LEFT SEMICIRCLE WITH THREE DOTS
1F550..1F567 ; So # [24] CLOCK FACE ONE OCLOCK..CLOCK FACE TWELVE-THIRTY
-1F5FB..1F5FF ; So # [5] MOUNT FUJI..MOYAI
-1F601..1F610 ; So # [16] GRINNING FACE WITH SMILING EYES..NEUTRAL FACE
-1F612..1F614 ; So # [3] UNAMUSED FACE..PENSIVE FACE
-1F616 ; So # CONFOUNDED FACE
-1F618 ; So # FACE THROWING A KISS
-1F61A ; So # KISSING FACE WITH CLOSED EYES
-1F61C..1F61E ; So # [3] FACE WITH STUCK-OUT TONGUE AND WINKING EYE..DISAPPOINTED FACE
-1F620..1F625 ; So # [6] ANGRY FACE..DISAPPOINTED BUT RELIEVED FACE
-1F628..1F62B ; So # [4] FEARFUL FACE..TIRED FACE
-1F62D ; So # LOUDLY CRYING FACE
-1F630..1F633 ; So # [4] FACE WITH OPEN MOUTH AND COLD SWEAT..FLUSHED FACE
-1F635..1F640 ; So # [12] DIZZY FACE..WEARY CAT FACE
+1F5FB..1F640 ; So # [70] MOUNT FUJI..WEARY CAT FACE
1F645..1F64F ; So # [11] FACE WITH NO GOOD GESTURE..PERSON WITH FOLDED HANDS
1F680..1F6C5 ; So # [70] ROCKET..LEFT LUGGAGE
1F700..1F773 ; So # [116] ALCHEMICAL SYMBOL FOR QUINTESSENCE..ALCHEMICAL SYMBOL FOR HALF OUNCE
-# Total code points: 4398
+# Total code points: 4404
# ================================================
Property changes on: trunk/contrib/perl/lib/unicore/extracted/DGeneralCategory.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/extracted/DJoinGroup.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/extracted/DJoinGroup.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/extracted/DJoinGroup.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,8 +1,8 @@
-# DerivedJoiningGroup-6.0.0.txt
-# Date: 2010-07-17, 22:46:14 GMT [MD]
+# DerivedJoiningGroup-6.2.0.txt
+# Date: 2012-05-23, 20:34:47 GMT [MD]
#
# Unicode Character Database
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
# For documentation, see http://www.unicode.org/reports/tr44/
@@ -48,8 +48,9 @@
066E ; Beh # Lo ARABIC LETTER DOTLESS BEH
0679..0680 ; Beh # Lo [8] ARABIC LETTER TTEH..ARABIC LETTER BEHEH
0750..0756 ; Beh # Lo [7] ARABIC LETTER BEH WITH THREE DOTS HORIZONTALLY BELOW..ARABIC LETTER BEH WITH SMALL V
+08A0 ; Beh # Lo ARABIC LETTER BEH WITH SMALL V BELOW
-# Total code points: 19
+# Total code points: 20
# ================================================
@@ -86,8 +87,9 @@
0641 ; Feh # Lo ARABIC LETTER FEH
06A1..06A6 ; Feh # Lo [6] ARABIC LETTER DOTLESS FEH..ARABIC LETTER PEHEH
0760..0761 ; Feh # Lo [2] ARABIC LETTER FEH WITH TWO DOTS BELOW..ARABIC LETTER FEH WITH THREE DOTS POINTING UPWARDS BELOW
+08A4 ; Feh # Lo ARABIC LETTER FEH WITH DOT BELOW AND THREE DOTS ABOVE
-# Total code points: 9
+# Total code points: 10
# ================================================
@@ -121,8 +123,9 @@
076E..076F ; Hah # Lo [2] ARABIC LETTER HAH WITH SMALL ARABIC LETTER TAH BELOW..ARABIC LETTER HAH WITH SMALL ARABIC LETTER TAH AND TWO DOTS
0772 ; Hah # Lo ARABIC LETTER HAH WITH SMALL ARABIC LETTER TAH ABOVE
077C ; Hah # Lo ARABIC LETTER HAH WITH EXTENDED ARABIC-INDIC DIGIT FOUR BELOW
+08A2 ; Hah # Lo ARABIC LETTER JEEM WITH TWO DOTS ABOVE
-# Total code points: 17
+# Total code points: 18
# ================================================
@@ -180,8 +183,9 @@
0644 ; Lam # Lo ARABIC LETTER LAM
06B5..06B8 ; Lam # Lo [4] ARABIC LETTER LAM WITH SMALL V..ARABIC LETTER LAM WITH THREE DOTS BELOW
076A ; Lam # Lo ARABIC LETTER LAM WITH BAR
+08A6 ; Lam # Lo ARABIC LETTER LAM WITH DOUBLE BAR
-# Total code points: 6
+# Total code points: 7
# ================================================
@@ -193,8 +197,9 @@
0645 ; Meem # Lo ARABIC LETTER MEEM
0765..0766 ; Meem # Lo [2] ARABIC LETTER MEEM WITH DOT ABOVE..ARABIC LETTER MEEM WITH DOT BELOW
+08A7 ; Meem # Lo ARABIC LETTER MEEM WITH THREE DOTS ABOVE
-# Total code points: 3
+# Total code points: 4
# ================================================
@@ -227,8 +232,9 @@
0642 ; Qaf # Lo ARABIC LETTER QAF
066F ; Qaf # Lo ARABIC LETTER DOTLESS QAF
06A7..06A8 ; Qaf # Lo [2] ARABIC LETTER QAF WITH DOT ABOVE..ARABIC LETTER QAF WITH THREE DOTS ABOVE
+08A5 ; Qaf # Lo ARABIC LETTER QAF WITH DOT BELOW
-# Total code points: 4
+# Total code points: 5
# ================================================
@@ -244,8 +250,9 @@
075B ; Reh # Lo ARABIC LETTER REH WITH STROKE
076B..076C ; Reh # Lo [2] ARABIC LETTER REH WITH TWO DOTS VERTICALLY ABOVE..ARABIC LETTER REH WITH HAMZA ABOVE
0771 ; Reh # Lo ARABIC LETTER REH WITH SMALL ARABIC LETTER TAH AND TWO DOTS
+08AA ; Reh # Lo ARABIC LETTER REH WITH LOOP
-# Total code points: 16
+# Total code points: 17
# ================================================
@@ -301,8 +308,9 @@
0637..0638 ; Tah # Lo [2] ARABIC LETTER TAH..ARABIC LETTER ZAH
069F ; Tah # Lo ARABIC LETTER TAH WITH THREE DOTS ABOVE
+08A3 ; Tah # Lo ARABIC LETTER TAH WITH TWO DOTS ABOVE
-# Total code points: 3
+# Total code points: 4
# ================================================
@@ -332,8 +340,9 @@
06C4..06CB ; Waw # Lo [8] ARABIC LETTER WAW WITH RING..ARABIC LETTER VE
06CF ; Waw # Lo ARABIC LETTER WAW WITH DOT ABOVE
0778..0779 ; Waw # Lo [2] ARABIC LETTER WAW WITH EXTENDED ARABIC-INDIC DIGIT TWO ABOVE..ARABIC LETTER WAW WITH EXTENDED ARABIC-INDIC DIGIT THREE ABOVE
+08AB ; Waw # Lo ARABIC LETTER WAW WITH DOT WITHIN
-# Total code points: 15
+# Total code points: 16
# ================================================
@@ -349,8 +358,9 @@
0678 ; Yeh # Lo ARABIC LETTER HIGH HAMZA YEH
06D0..06D1 ; Yeh # Lo [2] ARABIC LETTER E..ARABIC LETTER YEH WITH THREE DOTS BELOW
0777 ; Yeh # Lo ARABIC LETTER FARSI YEH WITH EXTENDED ARABIC-INDIC DIGIT FOUR BELOW
+08A8..08A9 ; Yeh # Lo [2] ARABIC LETTER YEH WITH TWO DOTS BELOW AND HAMZA ABOVE..ARABIC LETTER YEH WITH TWO DOTS BELOW AND DOT ABOVE
-# Total code points: 8
+# Total code points: 10
# ================================================
@@ -421,4 +431,10 @@
# Total code points: 1
+# ================================================
+
+08AC ; Rohingya_Yeh # Lo ARABIC LETTER ROHINGYA YEH
+
+# Total code points: 1
+
# EOF
Property changes on: trunk/contrib/perl/lib/unicore/extracted/DJoinGroup.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/extracted/DJoinType.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/extracted/DJoinType.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/extracted/DJoinType.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,8 +1,8 @@
-# DerivedJoiningType-6.0.0.txt
-# Date: 2010-08-19, 00:48:10 GMT [MD]
+# DerivedJoiningType-6.2.0.txt
+# Date: 2012-05-23, 20:34:48 GMT [MD]
#
# Unicode Character Database
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
# For documentation, see http://www.unicode.org/reports/tr44/
@@ -58,8 +58,15 @@
0775..0777 ; D # Lo [3] ARABIC LETTER FARSI YEH WITH EXTENDED ARABIC-INDIC DIGIT TWO ABOVE..ARABIC LETTER FARSI YEH WITH EXTENDED ARABIC-INDIC DIGIT FOUR BELOW
077A..077F ; D # Lo [6] ARABIC LETTER YEH BARREE WITH EXTENDED ARABIC-INDIC DIGIT TWO ABOVE..ARABIC LETTER KAF WITH TWO DOTS ABOVE
07CA..07EA ; D # Lo [33] NKO LETTER A..NKO LETTER JONA RA
+0841..0845 ; D # Lo [5] MANDAIC LETTER AB..MANDAIC LETTER USHENNA
+0847..0848 ; D # Lo [2] MANDAIC LETTER IT..MANDAIC LETTER ATT
+084A..084E ; D # Lo [5] MANDAIC LETTER AK..MANDAIC LETTER AS
+0850..0853 ; D # Lo [4] MANDAIC LETTER AP..MANDAIC LETTER AR
+0855 ; D # Lo MANDAIC LETTER AT
+08A0 ; D # Lo ARABIC LETTER BEH WITH SMALL V BELOW
+08A2..08A9 ; D # Lo [8] ARABIC LETTER JEEM WITH TWO DOTS ABOVE..ARABIC LETTER YEH WITH TWO DOTS BELOW AND DOT ABOVE
-# Total code points: 189
+# Total code points: 215
# ================================================
@@ -93,8 +100,14 @@
0771 ; R # Lo ARABIC LETTER REH WITH SMALL ARABIC LETTER TAH AND TWO DOTS
0773..0774 ; R # Lo [2] ARABIC LETTER ALEF WITH EXTENDED ARABIC-INDIC DIGIT TWO ABOVE..ARABIC LETTER ALEF WITH EXTENDED ARABIC-INDIC DIGIT THREE ABOVE
0778..0779 ; R # Lo [2] ARABIC LETTER WAW WITH EXTENDED ARABIC-INDIC DIGIT TWO ABOVE..ARABIC LETTER WAW WITH EXTENDED ARABIC-INDIC DIGIT THREE ABOVE
+0840 ; R # Lo MANDAIC LETTER HALQA
+0846 ; R # Lo MANDAIC LETTER AZ
+0849 ; R # Lo MANDAIC LETTER AKSA
+084F ; R # Lo MANDAIC LETTER IN
+0854 ; R # Lo MANDAIC LETTER ASH
+08AA..08AC ; R # Lo [3] ARABIC LETTER REH WITH LOOP..ARABIC LETTER ROHINGYA YEH
-# Total code points: 74
+# Total code points: 82
# ================================================
@@ -126,6 +139,7 @@
0825..0827 ; T # Mn [3] SAMARITAN VOWEL SIGN SHORT A..SAMARITAN VOWEL SIGN U
0829..082D ; T # Mn [5] SAMARITAN VOWEL SIGN LONG I..SAMARITAN MARK NEQUDAA
0859..085B ; T # Mn [3] MANDAIC AFFRICATION MARK..MANDAIC GEMINATION MARK
+08E4..08FE ; T # Mn [27] ARABIC CURLY FATHA..ARABIC DAMMA WITH DOT
0900..0902 ; T # Mn [3] DEVANAGARI SIGN INVERTED CANDRABINDU..DEVANAGARI SIGN ANUSVARA
093A ; T # Mn DEVANAGARI VOWEL SIGN OE
093C ; T # Mn DEVANAGARI SIGN NUKTA
@@ -211,7 +225,7 @@
1732..1734 ; T # Mn [3] HANUNOO VOWEL SIGN I..HANUNOO SIGN PAMUDPOD
1752..1753 ; T # Mn [2] BUHID VOWEL SIGN I..BUHID VOWEL SIGN U
1772..1773 ; T # Mn [2] TAGBANWA VOWEL SIGN I..TAGBANWA VOWEL SIGN U
-17B4..17B5 ; T # Cf [2] KHMER VOWEL INHERENT AQ..KHMER VOWEL INHERENT AA
+17B4..17B5 ; T # Mn [2] KHMER VOWEL INHERENT AQ..KHMER VOWEL INHERENT AA
17B7..17BD ; T # Mn [7] KHMER VOWEL SIGN I..KHMER VOWEL SIGN UA
17C6 ; T # Mn KHMER SIGN NIKAHIT
17C9..17D3 ; T # Mn [11] KHMER SIGN MUUSIKATOAN..KHMER SIGN BATHAMASAT
@@ -239,6 +253,7 @@
1B80..1B81 ; T # Mn [2] SUNDANESE SIGN PANYECEK..SUNDANESE SIGN PANGLAYAR
1BA2..1BA5 ; T # Mn [4] SUNDANESE CONSONANT SIGN PANYAKRA..SUNDANESE VOWEL SIGN PANYUKU
1BA8..1BA9 ; T # Mn [2] SUNDANESE VOWEL SIGN PAMEPET..SUNDANESE VOWEL SIGN PANEULEUNG
+1BAB ; T # Mn SUNDANESE SIGN VIRAMA
1BE6 ; T # Mn BATAK SIGN TOMPI
1BE8..1BE9 ; T # Mn [2] BATAK VOWEL SIGN PAKPAK E..BATAK VOWEL SIGN EE
1BED ; T # Mn BATAK VOWEL SIGN KARO O
@@ -249,6 +264,7 @@
1CD4..1CE0 ; T # Mn [13] VEDIC SIGN YAJURVEDIC MIDLINE SVARITA..VEDIC TONE RIGVEDIC KASHMIRI INDEPENDENT SVARITA
1CE2..1CE8 ; T # Mn [7] VEDIC SIGN VISARGA SVARITA..VEDIC SIGN VISARGA ANUDATTA WITH TAIL
1CED ; T # Mn VEDIC SIGN TIRYAK
+1CF4 ; T # Mn VEDIC TONE CANDRA ABOVE
1DC0..1DE6 ; T # Mn [39] COMBINING DOTTED GRAVE ACCENT..COMBINING LATIN SMALL LETTER Z
1DFC..1DFF ; T # Mn [4] COMBINING DOUBLE INVERTED BREVE BELOW..COMBINING RIGHT ARROWHEAD AND DOWN ARROWHEAD BELOW
200B ; T # Cf ZERO WIDTH SPACE
@@ -264,11 +280,12 @@
2CEF..2CF1 ; T # Mn [3] COPTIC COMBINING NI ABOVE..COPTIC COMBINING SPIRITUS LENIS
2D7F ; T # Mn TIFINAGH CONSONANT JOINER
2DE0..2DFF ; T # Mn [32] COMBINING CYRILLIC LETTER BE..COMBINING CYRILLIC LETTER IOTIFIED BIG YUS
-302A..302F ; T # Mn [6] IDEOGRAPHIC LEVEL TONE MARK..HANGUL DOUBLE DOT TONE MARK
+302A..302D ; T # Mn [4] IDEOGRAPHIC LEVEL TONE MARK..IDEOGRAPHIC ENTERING TONE MARK
3099..309A ; T # Mn [2] COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK..COMBINING KATAKANA-HIRAGANA SEMI-VOICED SOUND MARK
A66F ; T # Mn COMBINING CYRILLIC VZMET
A670..A672 ; T # Me [3] COMBINING CYRILLIC TEN MILLIONS SIGN..COMBINING CYRILLIC THOUSAND MILLIONS SIGN
-A67C..A67D ; T # Mn [2] COMBINING CYRILLIC KAVYKA..COMBINING CYRILLIC PAYEROK
+A674..A67D ; T # Mn [10] COMBINING CYRILLIC LETTER UKRAINIAN IE..COMBINING CYRILLIC PAYEROK
+A69F ; T # Mn COMBINING CYRILLIC LETTER IOTIFIED E
A6F0..A6F1 ; T # Mn [2] BAMUM COMBINING MARK KOQNDON..BAMUM COMBINING MARK TUKWENTIS
A802 ; T # Mn SYLOTI NAGRI SIGN DVISVARA
A806 ; T # Mn SYLOTI NAGRI SIGN HASANTA
@@ -292,6 +309,8 @@
AAB7..AAB8 ; T # Mn [2] TAI VIET MAI KHIT..TAI VIET VOWEL IA
AABE..AABF ; T # Mn [2] TAI VIET VOWEL AM..TAI VIET TONE MAI EK
AAC1 ; T # Mn TAI VIET TONE MAI THO
+AAEC..AAED ; T # Mn [2] MEETEI MAYEK VOWEL SIGN UU..MEETEI MAYEK VOWEL SIGN AAI
+AAF6 ; T # Mn MEETEI MAYEK VIRAMA
ABE5 ; T # Mn MEETEI MAYEK VOWEL SIGN ANAP
ABE8 ; T # Mn MEETEI MAYEK VOWEL SIGN UNAP
ABED ; T # Mn MEETEI MAYEK APUN IYEK
@@ -312,6 +331,16 @@
110B3..110B6 ; T # Mn [4] KAITHI VOWEL SIGN U..KAITHI VOWEL SIGN AI
110B9..110BA ; T # Mn [2] KAITHI SIGN VIRAMA..KAITHI SIGN NUKTA
110BD ; T # Cf KAITHI NUMBER SIGN
+11100..11102 ; T # Mn [3] CHAKMA SIGN CANDRABINDU..CHAKMA SIGN VISARGA
+11127..1112B ; T # Mn [5] CHAKMA VOWEL SIGN A..CHAKMA VOWEL SIGN UU
+1112D..11134 ; T # Mn [8] CHAKMA VOWEL SIGN AI..CHAKMA MAAYYAA
+11180..11181 ; T # Mn [2] SHARADA SIGN CANDRABINDU..SHARADA SIGN ANUSVARA
+111B6..111BE ; T # Mn [9] SHARADA VOWEL SIGN U..SHARADA VOWEL SIGN O
+116AB ; T # Mn TAKRI SIGN ANUSVARA
+116AD ; T # Mn TAKRI VOWEL SIGN AA
+116B0..116B5 ; T # Mn [6] TAKRI VOWEL SIGN U..TAKRI VOWEL SIGN AU
+116B7 ; T # Mn TAKRI SIGN NUKTA
+16F8F..16F92 ; T # Mn [4] MIAO TONE RIGHT..MIAO TONE BELOW
1D167..1D169 ; T # Mn [3] MUSICAL SYMBOL COMBINING TREMOLO-1..MUSICAL SYMBOL COMBINING TREMOLO-3
1D173..1D17A ; T # Cf [8] MUSICAL SYMBOL BEGIN BEAM..MUSICAL SYMBOL END PHRASE
1D17B..1D182 ; T # Mn [8] MUSICAL SYMBOL COMBINING ACCENT..MUSICAL SYMBOL COMBINING LOURE
@@ -322,6 +351,6 @@
E0020..E007F ; T # Cf [96] TAG SPACE..CANCEL TAG
E0100..E01EF ; T # Mn [240] VARIATION SELECTOR-17..VARIATION SELECTOR-256
-# Total code points: 1344
+# Total code points: 1423
# EOF
Property changes on: trunk/contrib/perl/lib/unicore/extracted/DJoinType.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/extracted/DLineBreak.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/extracted/DLineBreak.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/extracted/DLineBreak.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,8 +1,8 @@
-# DerivedLineBreak-6.0.0.txt
-# Date: 2010-08-19, 00:48:10 GMT [MD]
+# DerivedLineBreak-6.2.0.txt
+# Date: 2012-08-13, 19:20:17 GMT [MD]
#
# Unicode Character Database
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
# For documentation, see http://www.unicode.org/reports/tr44/
@@ -23,8 +23,8 @@
F0000..FFFFD ; XX # Co [65534] <private-use-F0000>..<private-use-FFFFD>
100000..10FFFD; XX # Co [65534] <private-use-100000>..<private-use-10FFFD>
-# The above property value applies to 781599 code points not listed here.
-# Total code points: 919067
+# The above property value applies to 780869 code points not listed here.
+# Total code points: 918337
# ================================================
@@ -263,43 +263,18 @@
301C ; NS # Pd WAVE DASH
303B ; NS # Lm VERTICAL IDEOGRAPHIC ITERATION MARK
303C ; NS # Lo MASU MARK
-3041 ; NS # Lo HIRAGANA LETTER SMALL A
-3043 ; NS # Lo HIRAGANA LETTER SMALL I
-3045 ; NS # Lo HIRAGANA LETTER SMALL U
-3047 ; NS # Lo HIRAGANA LETTER SMALL E
-3049 ; NS # Lo HIRAGANA LETTER SMALL O
-3063 ; NS # Lo HIRAGANA LETTER SMALL TU
-3083 ; NS # Lo HIRAGANA LETTER SMALL YA
-3085 ; NS # Lo HIRAGANA LETTER SMALL YU
-3087 ; NS # Lo HIRAGANA LETTER SMALL YO
-308E ; NS # Lo HIRAGANA LETTER SMALL WA
-3095..3096 ; NS # Lo [2] HIRAGANA LETTER SMALL KA..HIRAGANA LETTER SMALL KE
309B..309C ; NS # Sk [2] KATAKANA-HIRAGANA VOICED SOUND MARK..KATAKANA-HIRAGANA SEMI-VOICED SOUND MARK
309D..309E ; NS # Lm [2] HIRAGANA ITERATION MARK..HIRAGANA VOICED ITERATION MARK
30A0 ; NS # Pd KATAKANA-HIRAGANA DOUBLE HYPHEN
-30A1 ; NS # Lo KATAKANA LETTER SMALL A
-30A3 ; NS # Lo KATAKANA LETTER SMALL I
-30A5 ; NS # Lo KATAKANA LETTER SMALL U
-30A7 ; NS # Lo KATAKANA LETTER SMALL E
-30A9 ; NS # Lo KATAKANA LETTER SMALL O
-30C3 ; NS # Lo KATAKANA LETTER SMALL TU
-30E3 ; NS # Lo KATAKANA LETTER SMALL YA
-30E5 ; NS # Lo KATAKANA LETTER SMALL YU
-30E7 ; NS # Lo KATAKANA LETTER SMALL YO
-30EE ; NS # Lo KATAKANA LETTER SMALL WA
-30F5..30F6 ; NS # Lo [2] KATAKANA LETTER SMALL KA..KATAKANA LETTER SMALL KE
30FB ; NS # Po KATAKANA MIDDLE DOT
-30FC..30FE ; NS # Lm [3] KATAKANA-HIRAGANA PROLONGED SOUND MARK..KATAKANA VOICED ITERATION MARK
-31F0..31FF ; NS # Lo [16] KATAKANA LETTER SMALL KU..KATAKANA LETTER SMALL RO
+30FD..30FE ; NS # Lm [2] KATAKANA ITERATION MARK..KATAKANA VOICED ITERATION MARK
A015 ; NS # Lm YI SYLLABLE WU
FE54..FE55 ; NS # Po [2] SMALL SEMICOLON..SMALL COLON
FF1A..FF1B ; NS # Po [2] FULLWIDTH COLON..FULLWIDTH SEMICOLON
FF65 ; NS # Po HALFWIDTH KATAKANA MIDDLE DOT
-FF67..FF6F ; NS # Lo [9] HALFWIDTH KATAKANA LETTER SMALL A..HALFWIDTH KATAKANA LETTER SMALL TU
-FF70 ; NS # Lm HALFWIDTH KATAKANA-HIRAGANA PROLONGED SOUND MARK
FF9E..FF9F ; NS # Lm [2] HALFWIDTH KATAKANA VOICED SOUND MARK..HALFWIDTH KATAKANA SEMI-VOICED SOUND MARK
-# Total code points: 77
+# Total code points: 26
# ================================================
@@ -313,7 +288,7 @@
06D4 ; EX # Po ARABIC FULL STOP
07F9 ; EX # Po NKO EXCLAMATION MARK
0F0D..0F11 ; EX # Po [5] TIBETAN MARK SHAD..TIBETAN MARK RIN CHEN SPUNGS SHAD
-0F14 ; EX # So TIBETAN MARK GTER TSHEG
+0F14 ; EX # Po TIBETAN MARK GTER TSHEG
1802..1803 ; EX # Po [2] MONGOLIAN COMMA..MONGOLIAN FULL STOP
1808..1809 ; EX # Po [2] MONGOLIAN MANCHU COMMA..MONGOLIAN MANCHU FULL STOP
1944..1945 ; EX # Po [2] LIMBU EXCLAMATION MARK..LIMBU QUESTION MARK
@@ -364,6 +339,7 @@
005C ; PR # Po REVERSE SOLIDUS
00A3..00A5 ; PR # Sc [3] POUND SIGN..YEN SIGN
00B1 ; PR # Sm PLUS-MINUS SIGN
+058F ; PR # Sc ARMENIAN DRAM SIGN
09FB ; PR # Sc BENGALI GANDA MARK
0AF1 ; PR # Sc GUJARATI RUPEE SIGN
0BF9 ; PR # Sc TAMIL RUPEE SIGN
@@ -371,7 +347,7 @@
17DB ; PR # Sc KHMER CURRENCY SYMBOL RIEL
20A0..20A6 ; PR # Sc [7] EURO-CURRENCY SIGN..NAIRA SIGN
20A8..20B5 ; PR # Sc [14] RUPEE SIGN..CEDI SIGN
-20B7..20B9 ; PR # Sc [3] SPESMILO SIGN..INDIAN RUPEE SIGN
+20B7..20BA ; PR # Sc [4] SPESMILO SIGN..TURKISH LIRA SIGN
2116 ; PR # So NUMERO SIGN
2212..2213 ; PR # Sm [2] MINUS SIGN..MINUS-OR-PLUS SIGN
FE69 ; PR # Sc SMALL DOLLAR SIGN
@@ -379,7 +355,7 @@
FFE1 ; PR # Sc FULLWIDTH POUND SIGN
FFE5..FFE6 ; PR # Sc [2] FULLWIDTH YEN SIGN..FULLWIDTH WON SIGN
-# Total code points: 44
+# Total code points: 46
# ================================================
@@ -448,9 +424,13 @@
ABF0..ABF9 ; NU # Nd [10] MEETEI MAYEK DIGIT ZERO..MEETEI MAYEK DIGIT NINE
104A0..104A9 ; NU # Nd [10] OSMANYA DIGIT ZERO..OSMANYA DIGIT NINE
11066..1106F ; NU # Nd [10] BRAHMI DIGIT ZERO..BRAHMI DIGIT NINE
+110F0..110F9 ; NU # Nd [10] SORA SOMPENG DIGIT ZERO..SORA SOMPENG DIGIT NINE
+11136..1113F ; NU # Nd [10] CHAKMA DIGIT ZERO..CHAKMA DIGIT NINE
+111D0..111D9 ; NU # Nd [10] SHARADA DIGIT ZERO..SHARADA DIGIT NINE
+116C0..116C9 ; NU # Nd [10] TAKRI DIGIT ZERO..TAKRI DIGIT NINE
1D7CE..1D7FF ; NU # Nd [50] MATHEMATICAL BOLD DIGIT ZERO..MATHEMATICAL MONOSPACE DIGIT NINE
-# Total code points: 412
+# Total code points: 452
# ================================================
@@ -519,10 +499,8 @@
0561..0587 ; AL # L& [39] ARMENIAN SMALL LETTER AYB..ARMENIAN SMALL LIGATURE ECH YIWN
05C0 ; AL # Po HEBREW PUNCTUATION PASEQ
05C3 ; AL # Po HEBREW PUNCTUATION SOF PASUQ
-05D0..05EA ; AL # Lo [27] HEBREW LETTER ALEF..HEBREW LETTER TAV
-05F0..05F2 ; AL # Lo [3] HEBREW LIGATURE YIDDISH DOUBLE VAV..HEBREW LIGATURE YIDDISH DOUBLE YOD
05F3..05F4 ; AL # Po [2] HEBREW PUNCTUATION GERESH..HEBREW PUNCTUATION GERSHAYIM
-0600..0603 ; AL # Cf [4] ARABIC NUMBER SIGN..ARABIC SIGN SAFHA
+0600..0604 ; AL # Cf [5] ARABIC NUMBER SIGN..ARABIC SIGN SAMVAT
0606..0608 ; AL # Sm [3] ARABIC-INDIC CUBE ROOT..ARABIC RAY
060E..060F ; AL # So [2] ARABIC POETIC VERSE SIGN..ARABIC SIGN MISRA
0620..063F ; AL # Lo [32] ARABIC LETTER KASHMIRI YEH..ARABIC LETTER FARSI YEH WITH THREE DOTS ABOVE
@@ -558,6 +536,8 @@
0830..083E ; AL # Po [15] SAMARITAN PUNCTUATION NEQUDAA..SAMARITAN PUNCTUATION ANNAAU
0840..0858 ; AL # Lo [25] MANDAIC LETTER HALQA..MANDAIC LETTER AIN
085E ; AL # Po MANDAIC PUNCTUATION
+08A0 ; AL # Lo ARABIC LETTER BEH WITH SMALL V BELOW
+08A2..08AC ; AL # Lo [11] ARABIC LETTER JEEM WITH TWO DOTS ABOVE..ARABIC LETTER ROHINGYA YEH
0904..0939 ; AL # Lo [54] DEVANAGARI LETTER SHORT A..DEVANAGARI LETTER HA
093D ; AL # Lo DEVANAGARI SIGN AVAGRAHA
0950 ; AL # Lo DEVANAGARI OM
@@ -598,6 +578,7 @@
0ABD ; AL # Lo GUJARATI SIGN AVAGRAHA
0AD0 ; AL # Lo GUJARATI OM
0AE0..0AE1 ; AL # Lo [2] GUJARATI LETTER VOCALIC RR..GUJARATI LETTER VOCALIC LL
+0AF0 ; AL # Po GUJARATI ABBREVIATION SIGN
0B05..0B0C ; AL # Lo [8] ORIYA LETTER A..ORIYA LETTER VOCALIC L
0B0F..0B10 ; AL # Lo [2] ORIYA LETTER E..ORIYA LETTER AI
0B13..0B28 ; AL # Lo [22] ORIYA LETTER O..ORIYA LETTER NA
@@ -676,9 +657,12 @@
0FD5..0FD8 ; AL # So [4] RIGHT-FACING SVASTI SIGN..LEFT-FACING SVASTI SIGN WITH DOTS
104C..104F ; AL # Po [4] MYANMAR SYMBOL LOCATIVE..MYANMAR SYMBOL GENITIVE
10A0..10C5 ; AL # L& [38] GEORGIAN CAPITAL LETTER AN..GEORGIAN CAPITAL LETTER HOE
+10C7 ; AL # L& GEORGIAN CAPITAL LETTER YN
+10CD ; AL # L& GEORGIAN CAPITAL LETTER AEN
10D0..10FA ; AL # Lo [43] GEORGIAN LETTER AN..GEORGIAN LETTER AIN
10FB ; AL # Po GEORGIAN PARAGRAPH SEPARATOR
10FC ; AL # Lm MODIFIER LETTER GEORGIAN NAR
+10FD..10FF ; AL # Lo [3] GEORGIAN LETTER AEN..GEORGIAN LETTER LABIAL SIGN
1200..1248 ; AL # Lo [73] ETHIOPIC SYLLABLE HA..ETHIOPIC SYLLABLE QWA
124A..124D ; AL # Lo [4] ETHIOPIC SYLLABLE QWI..ETHIOPIC SYLLABLE QWE
1250..1256 ; AL # Lo [7] ETHIOPIC SYLLABLE QHA..ETHIOPIC SYLLABLE QHO
@@ -695,7 +679,7 @@
12D8..1310 ; AL # Lo [57] ETHIOPIC SYLLABLE ZA..ETHIOPIC SYLLABLE GWA
1312..1315 ; AL # Lo [4] ETHIOPIC SYLLABLE GWI..ETHIOPIC SYLLABLE GWE
1318..135A ; AL # Lo [67] ETHIOPIC SYLLABLE GGA..ETHIOPIC SYLLABLE FYA
-1360 ; AL # So ETHIOPIC SECTION MARK
+1360 ; AL # Po ETHIOPIC SECTION MARK
1362..1368 ; AL # Po [7] ETHIOPIC FULL STOP..ETHIOPIC PARAGRAPH SEPARATOR
1369..137C ; AL # No [20] ETHIOPIC DIGIT ONE..ETHIOPIC NUMBER TEN THOUSAND
1380..138F ; AL # Lo [16] ETHIOPIC SYLLABLE SEBATBEIT MWA..ETHIOPIC SYLLABLE PWE
@@ -736,18 +720,20 @@
1B74..1B7C ; AL # So [9] BALINESE MUSICAL SYMBOL RIGHT-HAND OPEN DUG..BALINESE MUSICAL SYMBOL LEFT-HAND OPEN PING
1B83..1BA0 ; AL # Lo [30] SUNDANESE LETTER A..SUNDANESE LETTER HA
1BAE..1BAF ; AL # Lo [2] SUNDANESE LETTER KHA..SUNDANESE LETTER SYA
-1BC0..1BE5 ; AL # Lo [38] BATAK LETTER A..BATAK LETTER U
+1BBA..1BE5 ; AL # Lo [44] SUNDANESE AVAGRAHA..BATAK LETTER U
1BFC..1BFF ; AL # Po [4] BATAK SYMBOL BINDU NA METEK..BATAK SYMBOL BINDU PANGOLAT
1C00..1C23 ; AL # Lo [36] LEPCHA LETTER KA..LEPCHA LETTER A
1C4D..1C4F ; AL # Lo [3] LEPCHA LETTER TTA..LEPCHA LETTER DDA
1C5A..1C77 ; AL # Lo [30] OL CHIKI LETTER LA..OL CHIKI LETTER OH
1C78..1C7D ; AL # Lm [6] OL CHIKI MU TTUDDAG..OL CHIKI AHAD
+1CC0..1CC7 ; AL # Po [8] SUNDANESE PUNCTUATION BINDU SURYA..SUNDANESE PUNCTUATION BINDU BA SATANGA
1CD3 ; AL # Po VEDIC SIGN NIHSHVASA
1CE9..1CEC ; AL # Lo [4] VEDIC SIGN ANUSVARA ANTARGOMUKHA..VEDIC SIGN ANUSVARA VAMAGOMUKHA WITH TAIL
1CEE..1CF1 ; AL # Lo [4] VEDIC SIGN HEXIFORM LONG ANUSVARA..VEDIC SIGN ANUSVARA UBHAYATO MUKHA
+1CF5..1CF6 ; AL # Lo [2] VEDIC SIGN JIHVAMULIYA..VEDIC SIGN UPADHMANIYA
1D00..1D2B ; AL # L& [44] LATIN LETTER SMALL CAPITAL A..CYRILLIC LETTER SMALL CAPITAL EL
-1D2C..1D61 ; AL # Lm [54] MODIFIER LETTER CAPITAL A..MODIFIER LETTER SMALL CHI
-1D62..1D77 ; AL # L& [22] LATIN SUBSCRIPT SMALL LETTER I..LATIN SMALL LETTER TURNED G
+1D2C..1D6A ; AL # Lm [63] MODIFIER LETTER CAPITAL A..GREEK SUBSCRIPT SMALL LETTER CHI
+1D6B..1D77 ; AL # L& [13] LATIN SMALL LETTER UE..LATIN SMALL LETTER TURNED G
1D78 ; AL # Lm MODIFIER LETTER CYRILLIC EN
1D79..1D9A ; AL # L& [34] LATIN SMALL LETTER INSULAR G..LATIN SMALL LETTER EZH WITH RETROFLEX HOOK
1D9B..1DBF ; AL # Lm [37] MODIFIER LETTER SMALL TURNED ALPHA..MODIFIER LETTER SMALL THETA
@@ -887,7 +873,8 @@
2300..2307 ; AL # So [8] DIAMETER SIGN..WAVY LINE
2308..230B ; AL # Sm [4] LEFT CEILING..RIGHT FLOOR
230C..2311 ; AL # So [6] BOTTOM RIGHT CROP..SQUARE LOZENGE
-2313..231F ; AL # So [13] SEGMENT..BOTTOM RIGHT CORNER
+2313..2319 ; AL # So [7] SEGMENT..TURNED NOT SIGN
+231C..231F ; AL # So [4] TOP LEFT CORNER..BOTTOM RIGHT CORNER
2320..2321 ; AL # Sm [2] TOP HALF INTEGRAL..BOTTOM HALF INTEGRAL
2322..2328 ; AL # So [7] FROWN..KEYBOARD
232B..237B ; AL # So [81] ERASE TO THE LEFT..NOT CHECK MARK
@@ -896,7 +883,7 @@
239B..23B3 ; AL # Sm [25] LEFT PARENTHESIS UPPER HOOK..SUMMATION BOTTOM
23B4..23DB ; AL # So [40] TOP SQUARE BRACKET..FUSE
23DC..23E1 ; AL # Sm [6] TOP PARENTHESIS..BOTTOM TORTOISE SHELL BRACKET
-23E2..23F3 ; AL # So [18] WHITE TRAPEZIUM..HOURGLASS WITH FLOWING SAND
+23E2..23EF ; AL # So [14] WHITE TRAPEZIUM..BLACK RIGHT-POINTING TRIANGLE WITH DOUBLE VERTICAL BAR
2400..2426 ; AL # So [39] SYMBOL FOR NULL..SYMBOL FOR SUBSTITUTE FORM TWO
2440..244A ; AL # So [11] OCR HOOK..OCR DOUBLE BACKSLASH
24FF ; AL # No NEGATIVE CIRCLED DIGIT ZERO
@@ -916,13 +903,13 @@
25E6..25EE ; AL # So [9] WHITE BULLET..UP-POINTING TRIANGLE WITH RIGHT HALF BLACK
25F0..25F7 ; AL # So [8] WHITE SQUARE WITH UPPER LEFT QUADRANT..WHITE CIRCLE WITH UPPER RIGHT QUADRANT
25F8..25FF ; AL # Sm [8] UPPER LEFT TRIANGLE..LOWER RIGHT TRIANGLE
-2600..2604 ; AL # So [5] BLACK SUN WITH RAYS..COMET
+2604 ; AL # So COMET
2607..2608 ; AL # So [2] LIGHTNING..THUNDERSTORM
260A..260D ; AL # So [4] ASCENDING NODE..OPPOSITION
2610..2613 ; AL # So [4] BALLOT BOX..SALTIRE
-2618..261B ; AL # So [4] SHAMROCK..BLACK RIGHT POINTING INDEX
-261D ; AL # So WHITE UP POINTING INDEX
-261F..263F ; AL # So [33] WHITE DOWN POINTING INDEX..MERCURY
+2619 ; AL # So REVERSED ROTATED FLORAL HEART BULLET
+2620..2638 ; AL # So [25] SKULL AND CROSSBONES..WHEEL OF DHARMA
+263C..263F ; AL # So [4] WHITE SUN WITH RAYS..MERCURY
2641 ; AL # So EARTH
2643..265F ; AL # So [29] JUPITER..BLACK CHESS PAWN
2662 ; AL # So WHITE DIAMOND SUIT
@@ -929,21 +916,20 @@
2666 ; AL # So BLACK DIAMOND SUIT
266B ; AL # So BEAMED EIGHTH NOTES
266E ; AL # So MUSIC NATURAL SIGN
-2670..269D ; AL # So [46] WEST SYRIAC CROSS..OUTLINED WHITE STAR
-26A0..26BD ; AL # So [30] WARNING SIGN..SOCCER BALL
-26C0..26C3 ; AL # So [4] WHITE DRAUGHTS MAN..BLACK DRAUGHTS KING
+2670..267E ; AL # So [15] WEST SYRIAC CROSS..PERMANENT PAPER SIGN
+2680..269D ; AL # So [30] DIE FACE-1..OUTLINED WHITE STAR
+26A0..26BC ; AL # So [29] WARNING SIGN..SESQUIQUADRATE
26CE ; AL # So OPHIUCHUS
26E2 ; AL # So ASTRONOMICAL SYMBOL FOR URANUS
26E4..26E7 ; AL # So [4] PENTAGRAM..INVERTED PENTAGRAM
-2701..2756 ; AL # So [86] UPPER BLADE SCISSORS..BLACK DIAMOND MINUS WHITE X
+2705..2707 ; AL # So [3] WHITE HEAVY CHECK MARK..TAPE DRIVE
+270E..2756 ; AL # So [73] LOWER RIGHT PENCIL..BLACK DIAMOND MINUS WHITE X
2758..275A ; AL # So [3] LIGHT VERTICAL BAR..HEAVY VERTICAL BAR
275F..2761 ; AL # So [3] HEAVY LOW SINGLE COMMA QUOTATION MARK ORNAMENT..CURVED STEM PARAGRAPH SIGN ORNAMENT
2764..2767 ; AL # So [4] HEAVY BLACK HEART..ROTATED FLORAL HEART BULLET
2794..27BF ; AL # So [44] HEAVY WIDE-HEADED RIGHTWARDS ARROW..DOUBLE CURLY LOOP
27C0..27C4 ; AL # Sm [5] THREE DIMENSIONAL ANGLE..OPEN SUPERSET
-27C7..27CA ; AL # Sm [4] OR WITH DOT INSIDE..VERTICAL BAR WITH HORIZONTAL STROKE
-27CC ; AL # Sm LONG DIVISION
-27CE..27E5 ; AL # Sm [24] SQUARED LOGICAL AND..WHITE SQUARE WITH RIGHTWARDS TICK
+27C7..27E5 ; AL # Sm [31] OR WITH DOT INSIDE..WHITE SQUARE WITH RIGHTWARDS TICK
27F0..27FF ; AL # Sm [16] UPWARDS QUADRUPLE ARROW..LONG RIGHTWARDS SQUIGGLE ARROW
2800..28FF ; AL # So [256] BRAILLE PATTERN BLANK..BRAILLE PATTERN DOTS-12345678
2900..2982 ; AL # Sm [131] RIGHTWARDS TWO-HEADED ARROW WITH VERTICAL STROKE..Z NOTATION TYPE COLON
@@ -957,14 +943,17 @@
2B50..2B54 ; AL # So [5] WHITE MEDIUM STAR..WHITE RIGHT-POINTING PENTAGON
2C00..2C2E ; AL # L& [47] GLAGOLITIC CAPITAL LETTER AZU..GLAGOLITIC CAPITAL LETTER LATINATE MYSLITE
2C30..2C5E ; AL # L& [47] GLAGOLITIC SMALL LETTER AZU..GLAGOLITIC SMALL LETTER LATINATE MYSLITE
-2C60..2C7C ; AL # L& [29] LATIN CAPITAL LETTER L WITH DOUBLE BAR..LATIN SUBSCRIPT SMALL LETTER J
-2C7D ; AL # Lm MODIFIER LETTER CAPITAL V
+2C60..2C7B ; AL # L& [28] LATIN CAPITAL LETTER L WITH DOUBLE BAR..LATIN LETTER SMALL CAPITAL TURNED E
+2C7C..2C7D ; AL # Lm [2] LATIN SUBSCRIPT SMALL LETTER J..MODIFIER LETTER CAPITAL V
2C7E..2CE4 ; AL # L& [103] LATIN CAPITAL LETTER S WITH SWASH TAIL..COPTIC SYMBOL KAI
2CE5..2CEA ; AL # So [6] COPTIC SYMBOL MI RO..COPTIC SYMBOL SHIMA SIMA
2CEB..2CEE ; AL # L& [4] COPTIC CAPITAL LETTER CRYPTOGRAMMIC SHEI..COPTIC SMALL LETTER CRYPTOGRAMMIC GANGIA
+2CF2..2CF3 ; AL # L& [2] COPTIC CAPITAL LETTER BOHAIRIC KHEI..COPTIC SMALL LETTER BOHAIRIC KHEI
2CFD ; AL # No COPTIC FRACTION ONE HALF
2D00..2D25 ; AL # L& [38] GEORGIAN SMALL LETTER AN..GEORGIAN SMALL LETTER HOE
-2D30..2D65 ; AL # Lo [54] TIFINAGH LETTER YA..TIFINAGH LETTER YAZZ
+2D27 ; AL # L& GEORGIAN SMALL LETTER YN
+2D2D ; AL # L& GEORGIAN SMALL LETTER AEN
+2D30..2D67 ; AL # Lo [56] TIFINAGH LETTER YA..TIFINAGH LETTER YO
2D6F ; AL # Lm TIFINAGH MODIFIER LETTER LABIALIZATION MARK
2D80..2D96 ; AL # Lo [23] ETHIOPIC SYLLABLE LOA..ETHIOPIC SYLLABLE GGWE
2DA0..2DA6 ; AL # Lo [7] ETHIOPIC SYLLABLE SSA..ETHIOPIC SYLLABLE SSO
@@ -980,6 +969,8 @@
2E1B ; AL # Po TILDE WITH RING ABOVE
2E1E..2E1F ; AL # Po [2] TILDE WITH DOT ABOVE..TILDE WITH DOT BELOW
2E2F ; AL # Lm VERTICAL TILDE
+2E32 ; AL # Po TURNED COMMA
+2E35..2E39 ; AL # Po [5] TURNED SEMICOLON..TOP HALF SECTION SIGN
4DC0..4DFF ; AL # So [64] HEXAGRAM FOR THE CREATIVE HEAVEN..HEXAGRAM FOR BEFORE COMPLETION
A4D0..A4F7 ; AL # Lo [40] LISU LETTER BA..LISU LETTER OE
A4F8..A4FD ; AL # Lm [6] LISU LETTER TONE MYA TI..LISU LETTER TONE MYA JEU
@@ -1005,8 +996,9 @@
A788 ; AL # Lm MODIFIER LETTER LOW CIRCUMFLEX ACCENT
A789..A78A ; AL # Sk [2] MODIFIER LETTER COLON..MODIFIER LETTER SHORT EQUALS SIGN
A78B..A78E ; AL # L& [4] LATIN CAPITAL LETTER SALTILLO..LATIN SMALL LETTER L WITH RETROFLEX HOOK AND BELT
-A790..A791 ; AL # L& [2] LATIN CAPITAL LETTER N WITH DESCENDER..LATIN SMALL LETTER N WITH DESCENDER
-A7A0..A7A9 ; AL # L& [10] LATIN CAPITAL LETTER G WITH OBLIQUE STROKE..LATIN SMALL LETTER S WITH OBLIQUE STROKE
+A790..A793 ; AL # L& [4] LATIN CAPITAL LETTER N WITH DESCENDER..LATIN SMALL LETTER C WITH BAR
+A7A0..A7AA ; AL # L& [11] LATIN CAPITAL LETTER G WITH OBLIQUE STROKE..LATIN CAPITAL LETTER H WITH HOOK
+A7F8..A7F9 ; AL # Lm [2] MODIFIER LETTER CAPITAL H WITH STROKE..MODIFIER LETTER SMALL LIGATURE OE
A7FA ; AL # L& LATIN LETTER SMALL CAPITAL TURNED M
A7FB..A801 ; AL # Lo [7] LATIN EPIGRAPHIC LETTER REVERSED F..SYLOTI NAGRI LETTER I
A803..A805 ; AL # Lo [3] SYLOTI NAGRI LETTER U..SYLOTI NAGRI LETTER O
@@ -1033,6 +1025,9 @@
AA40..AA42 ; AL # Lo [3] CHAM LETTER FINAL K..CHAM LETTER FINAL NG
AA44..AA4B ; AL # Lo [8] CHAM LETTER FINAL CH..CHAM LETTER FINAL SS
AA5C ; AL # Po CHAM PUNCTUATION SPIRAL
+AAE0..AAEA ; AL # Lo [11] MEETEI MAYEK LETTER E..MEETEI MAYEK LETTER SSA
+AAF2 ; AL # Lo MEETEI MAYEK ANJI
+AAF3..AAF4 ; AL # Lm [2] MEETEI MAYEK SYLLABLE REPETITION MARK..MEETEI MAYEK WORD REPETITION MARK
AB01..AB06 ; AL # Lo [6] ETHIOPIC SYLLABLE TTHU..ETHIOPIC SYLLABLE TTHO
AB09..AB0E ; AL # Lo [6] ETHIOPIC SYLLABLE DDHU..ETHIOPIC SYLLABLE DDHO
AB11..AB16 ; AL # Lo [6] ETHIOPIC SYLLABLE DZU..ETHIOPIC SYLLABLE DZO
@@ -1041,15 +1036,8 @@
ABC0..ABE2 ; AL # Lo [35] MEETEI MAYEK LETTER KOK..MEETEI MAYEK LETTER I LONSUM
FB00..FB06 ; AL # L& [7] LATIN SMALL LIGATURE FF..LATIN SMALL LIGATURE ST
FB13..FB17 ; AL # L& [5] ARMENIAN SMALL LIGATURE MEN NOW..ARMENIAN SMALL LIGATURE MEN XEH
-FB1D ; AL # Lo HEBREW LETTER YOD WITH HIRIQ
-FB1F..FB28 ; AL # Lo [10] HEBREW LIGATURE YIDDISH YOD YOD PATAH..HEBREW LETTER WIDE TAV
FB29 ; AL # Sm HEBREW LETTER ALTERNATIVE PLUS SIGN
-FB2A..FB36 ; AL # Lo [13] HEBREW LETTER SHIN WITH SHIN DOT..HEBREW LETTER ZAYIN WITH DAGESH
-FB38..FB3C ; AL # Lo [5] HEBREW LETTER TET WITH DAGESH..HEBREW LETTER LAMED WITH DAGESH
-FB3E ; AL # Lo HEBREW LETTER MEM WITH DAGESH
-FB40..FB41 ; AL # Lo [2] HEBREW LETTER NUN WITH DAGESH..HEBREW LETTER SAMEKH WITH DAGESH
-FB43..FB44 ; AL # Lo [2] HEBREW LETTER FINAL PE WITH DAGESH..HEBREW LETTER PE WITH DAGESH
-FB46..FBB1 ; AL # Lo [108] HEBREW LETTER TSADI WITH DAGESH..ARABIC LETTER YEH BARREE WITH HAMZA ABOVE FINAL FORM
+FB50..FBB1 ; AL # Lo [98] ARABIC LETTER ALEF WASLA ISOLATED FORM..ARABIC LETTER YEH BARREE WITH HAMZA ABOVE FINAL FORM
FBB2..FBC1 ; AL # Sk [16] ARABIC SYMBOL DOT ABOVE..ARABIC SYMBOL SMALL TAH BELOW
FBD3..FD3D ; AL # Lo [363] ARABIC LETTER NG ISOLATED FORM..ARABIC LIGATURE ALEF WITH FATHATAN ISOLATED FORM
FD50..FD8F ; AL # Lo [64] ARABIC LIGATURE TEH WITH JEEM WITH MEEM INITIAL FORM..ARABIC LIGATURE MEEM WITH KHAH WITH MEEM INITIAL FORM
@@ -1108,6 +1096,8 @@
10916..1091B ; AL # No [6] PHOENICIAN NUMBER ONE..PHOENICIAN NUMBER THREE
10920..10939 ; AL # Lo [26] LYDIAN LETTER A..LYDIAN LETTER C
1093F ; AL # Po LYDIAN TRIANGULAR MARK
+10980..109B7 ; AL # Lo [56] MEROITIC HIEROGLYPHIC LETTER A..MEROITIC CURSIVE LETTER DA
+109BE..109BF ; AL # Lo [2] MEROITIC CURSIVE LOGOGRAM RMT..MEROITIC CURSIVE LOGOGRAM IMN
10A00 ; AL # Lo KHAROSHTHI LETTER A
10A10..10A13 ; AL # Lo [4] KHAROSHTHI LETTER KA..KHAROSHTHI LETTER GHA
10A15..10A17 ; AL # Lo [3] KHAROSHTHI LETTER CA..KHAROSHTHI LETTER JA
@@ -1130,6 +1120,12 @@
11083..110AF ; AL # Lo [45] KAITHI LETTER A..KAITHI LETTER HA
110BB..110BC ; AL # Po [2] KAITHI ABBREVIATION SIGN..KAITHI ENUMERATION SIGN
110BD ; AL # Cf KAITHI NUMBER SIGN
+110D0..110E8 ; AL # Lo [25] SORA SOMPENG LETTER SAH..SORA SOMPENG LETTER MAE
+11103..11126 ; AL # Lo [36] CHAKMA LETTER AA..CHAKMA LETTER HAA
+11183..111B2 ; AL # Lo [48] SHARADA LETTER A..SHARADA LETTER HA
+111C1..111C4 ; AL # Lo [4] SHARADA SIGN AVAGRAHA..SHARADA OM
+111C7 ; AL # Po SHARADA ABBREVIATION SIGN
+11680..116AA ; AL # Lo [43] TAKRI LETTER A..TAKRI LETTER RRA
12000..1236E ; AL # Lo [879] CUNEIFORM SIGN A..CUNEIFORM SIGN ZUM
12400..12462 ; AL # Nl [99] CUNEIFORM NUMERIC SIGN TWO ASH..CUNEIFORM NUMERIC SIGN OLD ASSYRIAN ONE QUARTER
13000..13257 ; AL # Lo [600] EGYPTIAN HIEROGLYPH A001..EGYPTIAN HIEROGLYPH O006
@@ -1138,6 +1134,9 @@
1328A..13378 ; AL # Lo [239] EGYPTIAN HIEROGLYPH O037..EGYPTIAN HIEROGLYPH V011
1337C..1342E ; AL # Lo [179] EGYPTIAN HIEROGLYPH V012..EGYPTIAN HIEROGLYPH AA032
16800..16A38 ; AL # Lo [569] BAMUM LETTER PHASE-A NGKUE MFON..BAMUM LETTER PHASE-F VUEQ
+16F00..16F44 ; AL # Lo [69] MIAO LETTER PA..MIAO LETTER HHA
+16F50 ; AL # Lo MIAO LETTER NASALIZATION
+16F93..16F9F ; AL # Lm [13] MIAO LETTER TONE-2..MIAO LETTER REFORMED TONE-8
1D000..1D0F5 ; AL # So [246] BYZANTINE MUSICAL SYMBOL PSILI..BYZANTINE MUSICAL SYMBOL GORGON NEO KATO
1D100..1D126 ; AL # So [39] MUSICAL SYMBOL SINGLE BARLINE..MUSICAL SYMBOL DRUM CLEF-2
1D129..1D164 ; AL # So [60] MUSICAL SYMBOL MULTIPLE MEASURE REST..MUSICAL SYMBOL ONE HUNDRED TWENTY-EIGHTH NOTE
@@ -1189,49 +1188,83 @@
1D7AA..1D7C2 ; AL # L& [25] MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL ALPHA..MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL OMEGA
1D7C3 ; AL # Sm MATHEMATICAL SANS-SERIF BOLD ITALIC PARTIAL DIFFERENTIAL
1D7C4..1D7CB ; AL # L& [8] MATHEMATICAL SANS-SERIF BOLD ITALIC EPSILON SYMBOL..MATHEMATICAL BOLD SMALL DIGAMMA
-1F000..1F02B ; AL # So [44] MAHJONG TILE EAST WIND..MAHJONG TILE BACK
-1F030..1F093 ; AL # So [100] DOMINO TILE HORIZONTAL BACK..DOMINO TILE VERTICAL-06-06
-1F0A0..1F0AE ; AL # So [15] PLAYING CARD BACK..PLAYING CARD KING OF SPADES
-1F0B1..1F0BE ; AL # So [14] PLAYING CARD ACE OF HEARTS..PLAYING CARD KING OF HEARTS
-1F0C1..1F0CF ; AL # So [15] PLAYING CARD ACE OF DIAMONDS..PLAYING CARD BLACK JOKER
-1F0D1..1F0DF ; AL # So [15] PLAYING CARD ACE OF CLUBS..PLAYING CARD WHITE JOKER
+1EE00..1EE03 ; AL # Lo [4] ARABIC MATHEMATICAL ALEF..ARABIC MATHEMATICAL DAL
+1EE05..1EE1F ; AL # Lo [27] ARABIC MATHEMATICAL WAW..ARABIC MATHEMATICAL DOTLESS QAF
+1EE21..1EE22 ; AL # Lo [2] ARABIC MATHEMATICAL INITIAL BEH..ARABIC MATHEMATICAL INITIAL JEEM
+1EE24 ; AL # Lo ARABIC MATHEMATICAL INITIAL HEH
+1EE27 ; AL # Lo ARABIC MATHEMATICAL INITIAL HAH
+1EE29..1EE32 ; AL # Lo [10] ARABIC MATHEMATICAL INITIAL YEH..ARABIC MATHEMATICAL INITIAL QAF
+1EE34..1EE37 ; AL # Lo [4] ARABIC MATHEMATICAL INITIAL SHEEN..ARABIC MATHEMATICAL INITIAL KHAH
+1EE39 ; AL # Lo ARABIC MATHEMATICAL INITIAL DAD
+1EE3B ; AL # Lo ARABIC MATHEMATICAL INITIAL GHAIN
+1EE42 ; AL # Lo ARABIC MATHEMATICAL TAILED JEEM
+1EE47 ; AL # Lo ARABIC MATHEMATICAL TAILED HAH
+1EE49 ; AL # Lo ARABIC MATHEMATICAL TAILED YEH
+1EE4B ; AL # Lo ARABIC MATHEMATICAL TAILED LAM
+1EE4D..1EE4F ; AL # Lo [3] ARABIC MATHEMATICAL TAILED NOON..ARABIC MATHEMATICAL TAILED AIN
+1EE51..1EE52 ; AL # Lo [2] ARABIC MATHEMATICAL TAILED SAD..ARABIC MATHEMATICAL TAILED QAF
+1EE54 ; AL # Lo ARABIC MATHEMATICAL TAILED SHEEN
+1EE57 ; AL # Lo ARABIC MATHEMATICAL TAILED KHAH
+1EE59 ; AL # Lo ARABIC MATHEMATICAL TAILED DAD
+1EE5B ; AL # Lo ARABIC MATHEMATICAL TAILED GHAIN
+1EE5D ; AL # Lo ARABIC MATHEMATICAL TAILED DOTLESS NOON
+1EE5F ; AL # Lo ARABIC MATHEMATICAL TAILED DOTLESS QAF
+1EE61..1EE62 ; AL # Lo [2] ARABIC MATHEMATICAL STRETCHED BEH..ARABIC MATHEMATICAL STRETCHED JEEM
+1EE64 ; AL # Lo ARABIC MATHEMATICAL STRETCHED HEH
+1EE67..1EE6A ; AL # Lo [4] ARABIC MATHEMATICAL STRETCHED HAH..ARABIC MATHEMATICAL STRETCHED KAF
+1EE6C..1EE72 ; AL # Lo [7] ARABIC MATHEMATICAL STRETCHED MEEM..ARABIC MATHEMATICAL STRETCHED QAF
+1EE74..1EE77 ; AL # Lo [4] ARABIC MATHEMATICAL STRETCHED SHEEN..ARABIC MATHEMATICAL STRETCHED KHAH
+1EE79..1EE7C ; AL # Lo [4] ARABIC MATHEMATICAL STRETCHED DAD..ARABIC MATHEMATICAL STRETCHED DOTLESS BEH
+1EE7E ; AL # Lo ARABIC MATHEMATICAL STRETCHED DOTLESS FEH
+1EE80..1EE89 ; AL # Lo [10] ARABIC MATHEMATICAL LOOPED ALEF..ARABIC MATHEMATICAL LOOPED YEH
+1EE8B..1EE9B ; AL # Lo [17] ARABIC MATHEMATICAL LOOPED LAM..ARABIC MATHEMATICAL LOOPED GHAIN
+1EEA1..1EEA3 ; AL # Lo [3] ARABIC MATHEMATICAL DOUBLE-STRUCK BEH..ARABIC MATHEMATICAL DOUBLE-STRUCK DAL
+1EEA5..1EEA9 ; AL # Lo [5] ARABIC MATHEMATICAL DOUBLE-STRUCK WAW..ARABIC MATHEMATICAL DOUBLE-STRUCK YEH
+1EEAB..1EEBB ; AL # Lo [17] ARABIC MATHEMATICAL DOUBLE-STRUCK LAM..ARABIC MATHEMATICAL DOUBLE-STRUCK GHAIN
+1EEF0..1EEF1 ; AL # Sm [2] ARABIC MATHEMATICAL OPERATOR MEEM WITH HAH WITH TATWEEL..ARABIC MATHEMATICAL OPERATOR HAH WITH DAL
1F12E ; AL # So CIRCLED WZ
-1F1E6..1F1FF ; AL # So [26] REGIONAL INDICATOR SYMBOL LETTER A..REGIONAL INDICATOR SYMBOL LETTER Z
-1F300..1F320 ; AL # So [33] CYCLONE..SHOOTING STAR
-1F330..1F335 ; AL # So [6] CHESTNUT..CACTUS
-1F337..1F37C ; AL # So [70] TULIP..BABY BOTTLE
-1F380..1F393 ; AL # So [20] RIBBON..GRADUATION CAP
-1F3A0..1F3C4 ; AL # So [37] CAROUSEL HORSE..SURFER
-1F3C6..1F3CA ; AL # So [5] TROPHY..SWIMMER
-1F3E0..1F3F0 ; AL # So [17] HOUSE BUILDING..EUROPEAN CASTLE
-1F400..1F43E ; AL # So [63] RAT..PAW PRINTS
-1F440 ; AL # So EYES
-1F442..1F4F7 ; AL # So [182] EAR..CAMERA
-1F4F9..1F4FC ; AL # So [4] VIDEO CAMERA..VIDEOCASSETTE
-1F500..1F53D ; AL # So [62] TWISTED RIGHTWARDS ARROWS..DOWN-POINTING SMALL RED TRIANGLE
-1F550..1F567 ; AL # So [24] CLOCK FACE ONE OCLOCK..CLOCK FACE TWELVE-THIRTY
-1F5FB..1F5FF ; AL # So [5] MOUNT FUJI..MOYAI
-1F601..1F610 ; AL # So [16] GRINNING FACE WITH SMILING EYES..NEUTRAL FACE
-1F612..1F614 ; AL # So [3] UNAMUSED FACE..PENSIVE FACE
-1F616 ; AL # So CONFOUNDED FACE
-1F618 ; AL # So FACE THROWING A KISS
-1F61A ; AL # So KISSING FACE WITH CLOSED EYES
-1F61C..1F61E ; AL # So [3] FACE WITH STUCK-OUT TONGUE AND WINKING EYE..DISAPPOINTED FACE
-1F620..1F625 ; AL # So [6] ANGRY FACE..DISAPPOINTED BUT RELIEVED FACE
-1F628..1F62B ; AL # So [4] FEARFUL FACE..TIRED FACE
-1F62D ; AL # So LOUDLY CRYING FACE
-1F630..1F633 ; AL # So [4] FACE WITH OPEN MOUTH AND COLD SWEAT..FLUSHED FACE
-1F635..1F640 ; AL # So [12] DIZZY FACE..WEARY CAT FACE
-1F645..1F64F ; AL # So [11] FACE WITH NO GOOD GESTURE..PERSON WITH FOLDED HANDS
-1F680..1F6C5 ; AL # So [70] ROCKET..LEFT LUGGAGE
+1F16A..1F16B ; AL # So [2] RAISED MC SIGN..RAISED MD SIGN
+1F3B5..1F3B6 ; AL # So [2] MUSICAL NOTE..MULTIPLE MUSICAL NOTES
+1F3BC ; AL # So MUSICAL SCORE
+1F4A0 ; AL # So DIAMOND SHAPE WITH A DOT INSIDE
+1F4A2 ; AL # So ANGER SYMBOL
+1F4A4 ; AL # So SLEEPING SYMBOL
+1F4AF ; AL # So HUNDRED POINTS SYMBOL
+1F4B1..1F4B2 ; AL # So [2] CURRENCY EXCHANGE..HEAVY DOLLAR SIGN
+1F500..1F506 ; AL # So [7] TWISTED RIGHTWARDS ARROWS..HIGH BRIGHTNESS SYMBOL
+1F517..1F524 ; AL # So [14] LINK SYMBOL..INPUT SYMBOL FOR LATIN LETTERS
+1F532..1F53D ; AL # So [12] BLACK SQUARE BUTTON..DOWN-POINTING SMALL RED TRIANGLE
+1F540..1F543 ; AL # So [4] CIRCLED CROSS POMMEE..NOTCHED LEFT SEMICIRCLE WITH THREE DOTS
1F700..1F773 ; AL # So [116] ALCHEMICAL SYMBOL FOR QUINTESSENCE..ALCHEMICAL SYMBOL FOR HALF OUNCE
-# Total code points: 15797
+# Total code points: 15355
# ================================================
# Line_Break=Ideographic
+231A..231B ; ID # So [2] WATCH..HOURGLASS
+23F0..23F3 ; ID # So [4] ALARM CLOCK..HOURGLASS WITH FLOWING SAND
+2600..2603 ; ID # So [4] BLACK SUN WITH RAYS..SNOWMAN
+2614..2615 ; ID # So [2] UMBRELLA WITH RAIN DROPS..HOT BEVERAGE
+2618 ; ID # So SHAMROCK
+261A..261F ; ID # So [6] BLACK LEFT POINTING INDEX..WHITE DOWN POINTING INDEX
+2639..263B ; ID # So [3] WHITE FROWNING FACE..BLACK SMILING FACE
+2668 ; ID # So HOT SPRINGS
+267F ; ID # So WHEELCHAIR SYMBOL
+26BD..26C8 ; ID # So [12] SOCCER BALL..THUNDER CLOUD AND RAIN
+26CD ; ID # So DISABLED CAR
+26CF..26D1 ; ID # So [3] PICK..HELMET WITH WHITE CROSS
+26D3..26D4 ; ID # So [2] CHAINS..NO ENTRY
+26D8..26D9 ; ID # So [2] BLACK LEFT LANE MERGE..WHITE LEFT LANE MERGE
+26DC ; ID # So LEFT CLOSED ENTRY
+26DF..26E1 ; ID # So [3] BLACK TRUCK..RESTRICTED LEFT ENTRY-2
+26EA ; ID # So CHURCH
+26F1..26F5 ; ID # So [5] UMBRELLA ON GROUND..SAILBOAT
+26F7..26FA ; ID # So [4] SKIER..TENT
+26FD..26FF ; ID # So [3] FUEL PUMP..WHITE FLAG WITH HORIZONTAL MIDDLE BLACK STRIPE
+2701..2704 ; ID # So [4] UPPER BLADE SCISSORS..WHITE SCISSORS
+2708..270D ; ID # So [6] AIRPLANE..WRITING HAND
2E80..2E99 ; ID # So [26] CJK RADICAL REPEAT..CJK RADICAL RAP
2E9B..2EF3 ; ID # So [89] CJK RADICAL CHOKE..CJK RADICAL C-SIMPLIFIED TURTLE
2F00..2FD5 ; ID # So [214] KANGXI RADICAL ONE..KANGXI RADICAL FLUTE
@@ -1293,14 +1326,12 @@
3300..33FF ; ID # So [256] SQUARE APAATO..SQUARE GAL
3400..4DB5 ; ID # Lo [6582] CJK UNIFIED IDEOGRAPH-3400..CJK UNIFIED IDEOGRAPH-4DB5
4DB6..4DBF ; ID # Cn [10] <reserved-4DB6>..<reserved-4DBF>
-4E00..9FCB ; ID # Lo [20940] CJK UNIFIED IDEOGRAPH-4E00..CJK UNIFIED IDEOGRAPH-9FCB
-9FCC..9FFF ; ID # Cn [52] <reserved-9FCC>..<reserved-9FFF>
+4E00..9FCC ; ID # Lo [20941] CJK UNIFIED IDEOGRAPH-4E00..CJK UNIFIED IDEOGRAPH-9FCC
+9FCD..9FFF ; ID # Cn [51] <reserved-9FCD>..<reserved-9FFF>
A000..A014 ; ID # Lo [21] YI SYLLABLE IT..YI SYLLABLE E
A016..A48C ; ID # Lo [1143] YI SYLLABLE BIT..YI SYLLABLE YYR
A490..A4C6 ; ID # So [55] YI RADICAL QOT..YI RADICAL KE
-F900..FA2D ; ID # Lo [302] CJK COMPATIBILITY IDEOGRAPH-F900..CJK COMPATIBILITY IDEOGRAPH-FA2D
-FA2E..FA2F ; ID # Cn [2] <reserved-FA2E>..<reserved-FA2F>
-FA30..FA6D ; ID # Lo [62] CJK COMPATIBILITY IDEOGRAPH-FA30..CJK COMPATIBILITY IDEOGRAPH-FA6D
+F900..FA6D ; ID # Lo [366] CJK COMPATIBILITY IDEOGRAPH-F900..CJK COMPATIBILITY IDEOGRAPH-FA6D
FA6E..FA6F ; ID # Cn [2] <reserved-FA6E>..<reserved-FA6F>
FA70..FAD9 ; ID # Lo [106] CJK COMPATIBILITY IDEOGRAPH-FA70..CJK COMPATIBILITY IDEOGRAPH-FAD9
FADA..FAFF ; ID # Cn [38] <reserved-FADA>..<reserved-FAFF>
@@ -1339,10 +1370,40 @@
FFE3 ; ID # Sk FULLWIDTH MACRON
FFE4 ; ID # So FULLWIDTH BROKEN BAR
1B000..1B001 ; ID # Lo [2] KATAKANA LETTER ARCHAIC E..HIRAGANA LETTER ARCHAIC YE
+1F000..1F02B ; ID # So [44] MAHJONG TILE EAST WIND..MAHJONG TILE BACK
+1F030..1F093 ; ID # So [100] DOMINO TILE HORIZONTAL BACK..DOMINO TILE VERTICAL-06-06
+1F0A0..1F0AE ; ID # So [15] PLAYING CARD BACK..PLAYING CARD KING OF SPADES
+1F0B1..1F0BE ; ID # So [14] PLAYING CARD ACE OF HEARTS..PLAYING CARD KING OF HEARTS
+1F0C1..1F0CF ; ID # So [15] PLAYING CARD ACE OF DIAMONDS..PLAYING CARD BLACK JOKER
+1F0D1..1F0DF ; ID # So [15] PLAYING CARD ACE OF CLUBS..PLAYING CARD WHITE JOKER
1F200..1F202 ; ID # So [3] SQUARE HIRAGANA HOKA..SQUARED KATAKANA SA
1F210..1F23A ; ID # So [43] SQUARED CJK UNIFIED IDEOGRAPH-624B..SQUARED CJK UNIFIED IDEOGRAPH-55B6
1F240..1F248 ; ID # So [9] TORTOISE SHELL BRACKETED CJK UNIFIED IDEOGRAPH-672C..TORTOISE SHELL BRACKETED CJK UNIFIED IDEOGRAPH-6557
1F250..1F251 ; ID # So [2] CIRCLED IDEOGRAPH ADVANTAGE..CIRCLED IDEOGRAPH ACCEPT
+1F300..1F320 ; ID # So [33] CYCLONE..SHOOTING STAR
+1F330..1F335 ; ID # So [6] CHESTNUT..CACTUS
+1F337..1F37C ; ID # So [70] TULIP..BABY BOTTLE
+1F380..1F393 ; ID # So [20] RIBBON..GRADUATION CAP
+1F3A0..1F3B4 ; ID # So [21] CAROUSEL HORSE..FLOWER PLAYING CARDS
+1F3B7..1F3BB ; ID # So [5] SAXOPHONE..VIOLIN
+1F3BD..1F3C4 ; ID # So [8] RUNNING SHIRT WITH SASH..SURFER
+1F3C6..1F3CA ; ID # So [5] TROPHY..SWIMMER
+1F3E0..1F3F0 ; ID # So [17] HOUSE BUILDING..EUROPEAN CASTLE
+1F400..1F43E ; ID # So [63] RAT..PAW PRINTS
+1F440 ; ID # So EYES
+1F442..1F49F ; ID # So [94] EAR..HEART DECORATION
+1F4A1 ; ID # So ELECTRIC LIGHT BULB
+1F4A3 ; ID # So BOMB
+1F4A5..1F4AE ; ID # So [10] COLLISION SYMBOL..WHITE FLOWER
+1F4B0 ; ID # So MONEY BAG
+1F4B3..1F4F7 ; ID # So [69] CREDIT CARD..CAMERA
+1F4F9..1F4FC ; ID # So [4] VIDEO CAMERA..VIDEOCASSETTE
+1F507..1F516 ; ID # So [16] SPEAKER WITH CANCELLATION STROKE..BOOKMARK
+1F525..1F531 ; ID # So [13] FIRE..TRIDENT EMBLEM
+1F550..1F567 ; ID # So [24] CLOCK FACE ONE OCLOCK..CLOCK FACE TWELVE-THIRTY
+1F5FB..1F640 ; ID # So [70] MOUNT FUJI..WEARY CAT FACE
+1F645..1F64F ; ID # So [11] FACE WITH NO GOOD GESTURE..PERSON WITH FOLDED HANDS
+1F680..1F6C5 ; ID # So [70] ROCKET..LEFT LUGGAGE
20000..2A6D6 ; ID # Lo [42711] CJK UNIFIED IDEOGRAPH-20000..CJK UNIFIED IDEOGRAPH-2A6D6
2A6D7..2A6FF ; ID # Cn [41] <reserved-2A6D7>..<reserved-2A6FF>
2A700..2B734 ; ID # Lo [4149] CJK UNIFIED IDEOGRAPH-2A700..CJK UNIFIED IDEOGRAPH-2B734
@@ -1353,7 +1414,7 @@
2FA1E..2FFFD ; ID # Cn [1504] <reserved-2FA1E>..<reserved-2FFFD>
30000..3FFFD ; ID # Cn [65534] <reserved-30000>..<reserved-3FFFD>
-# Total code points: 161793
+# Total code points: 162700
# ================================================
@@ -1406,6 +1467,7 @@
0825..0827 ; CM # Mn [3] SAMARITAN VOWEL SIGN SHORT A..SAMARITAN VOWEL SIGN U
0829..082D ; CM # Mn [5] SAMARITAN VOWEL SIGN LONG I..SAMARITAN MARK NEQUDAA
0859..085B ; CM # Mn [3] MANDAIC AFFRICATION MARK..MANDAIC GEMINATION MARK
+08E4..08FE ; CM # Mn [27] ARABIC CURLY FATHA..ARABIC DAMMA WITH DOT
0900..0902 ; CM # Mn [3] DEVANAGARI SIGN INVERTED CANDRABINDU..DEVANAGARI SIGN ANUSVARA
0903 ; CM # Mc DEVANAGARI SIGN VISARGA
093A ; CM # Mn DEVANAGARI VOWEL SIGN OE
@@ -1549,6 +1611,8 @@
1BA6..1BA7 ; CM # Mc [2] SUNDANESE VOWEL SIGN PANAELAENG..SUNDANESE VOWEL SIGN PANOLONG
1BA8..1BA9 ; CM # Mn [2] SUNDANESE VOWEL SIGN PAMEPET..SUNDANESE VOWEL SIGN PANEULEUNG
1BAA ; CM # Mc SUNDANESE SIGN PAMAAEH
+1BAB ; CM # Mn SUNDANESE SIGN VIRAMA
+1BAC..1BAD ; CM # Mc [2] SUNDANESE CONSONANT SIGN PASANGAN MA..SUNDANESE CONSONANT SIGN PASANGAN WA
1BE6 ; CM # Mn BATAK SIGN TOMPI
1BE7 ; CM # Mc BATAK VOWEL SIGN E
1BE8..1BE9 ; CM # Mn [2] BATAK VOWEL SIGN PAKPAK E..BATAK VOWEL SIGN EE
@@ -1566,7 +1630,8 @@
1CE1 ; CM # Mc VEDIC TONE ATHARVAVEDIC INDEPENDENT SVARITA
1CE2..1CE8 ; CM # Mn [7] VEDIC SIGN VISARGA SVARITA..VEDIC SIGN VISARGA ANUDATTA WITH TAIL
1CED ; CM # Mn VEDIC SIGN TIRYAK
-1CF2 ; CM # Mc VEDIC SIGN ARDHAVISARGA
+1CF2..1CF3 ; CM # Mc [2] VEDIC SIGN ARDHAVISARGA..VEDIC SIGN ROTATED ARDHAVISARGA
+1CF4 ; CM # Mn VEDIC TONE CANDRA ABOVE
1DC0..1DE6 ; CM # Mn [39] COMBINING DOTTED GRAVE ACCENT..COMBINING LATIN SMALL LETTER Z
1DFC..1DFF ; CM # Mn [4] COMBINING DOUBLE INVERTED BREVE BELOW..COMBINING RIGHT ARROWHEAD AND DOWN ARROWHEAD BELOW
200C..200F ; CM # Cf [4] ZERO WIDTH NON-JOINER..RIGHT-TO-LEFT MARK
@@ -1580,11 +1645,13 @@
2CEF..2CF1 ; CM # Mn [3] COPTIC COMBINING NI ABOVE..COPTIC COMBINING SPIRITUS LENIS
2D7F ; CM # Mn TIFINAGH CONSONANT JOINER
2DE0..2DFF ; CM # Mn [32] COMBINING CYRILLIC LETTER BE..COMBINING CYRILLIC LETTER IOTIFIED BIG YUS
-302A..302F ; CM # Mn [6] IDEOGRAPHIC LEVEL TONE MARK..HANGUL DOUBLE DOT TONE MARK
+302A..302D ; CM # Mn [4] IDEOGRAPHIC LEVEL TONE MARK..IDEOGRAPHIC ENTERING TONE MARK
+302E..302F ; CM # Mc [2] HANGUL SINGLE DOT TONE MARK..HANGUL DOUBLE DOT TONE MARK
3099..309A ; CM # Mn [2] COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK..COMBINING KATAKANA-HIRAGANA SEMI-VOICED SOUND MARK
A66F ; CM # Mn COMBINING CYRILLIC VZMET
A670..A672 ; CM # Me [3] COMBINING CYRILLIC TEN MILLIONS SIGN..COMBINING CYRILLIC THOUSAND MILLIONS SIGN
-A67C..A67D ; CM # Mn [2] COMBINING CYRILLIC KAVYKA..COMBINING CYRILLIC PAYEROK
+A674..A67D ; CM # Mn [10] COMBINING CYRILLIC LETTER UKRAINIAN IE..COMBINING CYRILLIC PAYEROK
+A69F ; CM # Mn COMBINING CYRILLIC LETTER IOTIFIED E
A6F0..A6F1 ; CM # Mn [2] BAMUM COMBINING MARK KOQNDON..BAMUM COMBINING MARK TUKWENTIS
A802 ; CM # Mn SYLOTI NAGRI SIGN DVISVARA
A806 ; CM # Mn SYLOTI NAGRI SIGN HASANTA
@@ -1615,6 +1682,11 @@
AA43 ; CM # Mn CHAM CONSONANT SIGN FINAL NG
AA4C ; CM # Mn CHAM CONSONANT SIGN FINAL M
AA4D ; CM # Mc CHAM CONSONANT SIGN FINAL H
+AAEB ; CM # Mc MEETEI MAYEK VOWEL SIGN II
+AAEC..AAED ; CM # Mn [2] MEETEI MAYEK VOWEL SIGN UU..MEETEI MAYEK VOWEL SIGN AAI
+AAEE..AAEF ; CM # Mc [2] MEETEI MAYEK VOWEL SIGN AU..MEETEI MAYEK VOWEL SIGN AAU
+AAF5 ; CM # Mc MEETEI MAYEK VOWEL SIGN VISARGA
+AAF6 ; CM # Mn MEETEI MAYEK VIRAMA
ABE3..ABE4 ; CM # Mc [2] MEETEI MAYEK VOWEL SIGN ONAP..MEETEI MAYEK VOWEL SIGN INAP
ABE5 ; CM # Mn MEETEI MAYEK VOWEL SIGN ANAP
ABE6..ABE7 ; CM # Mc [2] MEETEI MAYEK VOWEL SIGN YENAP..MEETEI MAYEK VOWEL SIGN SOUNAP
@@ -1642,6 +1714,24 @@
110B3..110B6 ; CM # Mn [4] KAITHI VOWEL SIGN U..KAITHI VOWEL SIGN AI
110B7..110B8 ; CM # Mc [2] KAITHI VOWEL SIGN O..KAITHI VOWEL SIGN AU
110B9..110BA ; CM # Mn [2] KAITHI SIGN VIRAMA..KAITHI SIGN NUKTA
+11100..11102 ; CM # Mn [3] CHAKMA SIGN CANDRABINDU..CHAKMA SIGN VISARGA
+11127..1112B ; CM # Mn [5] CHAKMA VOWEL SIGN A..CHAKMA VOWEL SIGN UU
+1112C ; CM # Mc CHAKMA VOWEL SIGN E
+1112D..11134 ; CM # Mn [8] CHAKMA VOWEL SIGN AI..CHAKMA MAAYYAA
+11180..11181 ; CM # Mn [2] SHARADA SIGN CANDRABINDU..SHARADA SIGN ANUSVARA
+11182 ; CM # Mc SHARADA SIGN VISARGA
+111B3..111B5 ; CM # Mc [3] SHARADA VOWEL SIGN AA..SHARADA VOWEL SIGN II
+111B6..111BE ; CM # Mn [9] SHARADA VOWEL SIGN U..SHARADA VOWEL SIGN O
+111BF..111C0 ; CM # Mc [2] SHARADA VOWEL SIGN AU..SHARADA SIGN VIRAMA
+116AB ; CM # Mn TAKRI SIGN ANUSVARA
+116AC ; CM # Mc TAKRI SIGN VISARGA
+116AD ; CM # Mn TAKRI VOWEL SIGN AA
+116AE..116AF ; CM # Mc [2] TAKRI VOWEL SIGN I..TAKRI VOWEL SIGN II
+116B0..116B5 ; CM # Mn [6] TAKRI VOWEL SIGN U..TAKRI VOWEL SIGN AU
+116B6 ; CM # Mc TAKRI SIGN VIRAMA
+116B7 ; CM # Mn TAKRI SIGN NUKTA
+16F51..16F7E ; CM # Mc [46] MIAO SIGN ASPIRATION..MIAO VOWEL SIGN NG
+16F8F..16F92 ; CM # Mn [4] MIAO TONE RIGHT..MIAO TONE BELOW
1D165..1D166 ; CM # Mc [2] MUSICAL SYMBOL COMBINING STEM..MUSICAL SYMBOL COMBINING SPRECHGESANG STEM
1D167..1D169 ; CM # Mn [3] MUSICAL SYMBOL COMBINING TREMOLO-1..MUSICAL SYMBOL COMBINING TREMOLO-3
1D16D..1D172 ; CM # Mc [6] MUSICAL SYMBOL COMBINING AUGMENTATION DOT..MUSICAL SYMBOL COMBINING FLAG-5
@@ -1654,7 +1744,7 @@
E0020..E007F ; CM # Cf [96] TAG SPACE..CANCEL TAG
E0100..E01EF ; CM # Mn [240] VARIATION SELECTOR-17..VARIATION SELECTOR-256
-# Total code points: 1483
+# Total code points: 1628
# ================================================
@@ -1724,6 +1814,7 @@
2E19 ; BA # Po PALM BRANCH
2E2A..2E2D ; BA # Po [4] TWO DOTS OVER ONE DOT PUNCTUATION..FIVE DOT MARK
2E30..2E31 ; BA # Po [2] RING POINT..WORD SEPARATOR MIDDLE DOT
+2E33..2E34 ; BA # Po [2] RAISED DOT..RAISED COMMA
A4FE..A4FF ; BA # Po [2] LISU PUNCTUATION COMMA..LISU PUNCTUATION FULL STOP
A60D ; BA # Po VAI COMMA
A60F ; BA # Po VAI QUESTION MARK
@@ -1732,9 +1823,9 @@
A92E..A92F ; BA # Po [2] KAYAH LI SIGN CWI..KAYAH LI SIGN SHYA
A9C7..A9C9 ; BA # Po [3] JAVANESE PADA PANGKAT..JAVANESE PADA LUNGSI
AA5D..AA5F ; BA # Po [3] CHAM PUNCTUATION DANDA..CHAM PUNCTUATION TRIPLE DANDA
+AAF0..AAF1 ; BA # Po [2] MEETEI MAYEK CHEIKHAN..MEETEI MAYEK AHANG KHUDAM
ABEB ; BA # Po MEETEI MAYEK CHEIKHEI
-10100..10101 ; BA # Po [2] AEGEAN WORD SEPARATOR LINE..AEGEAN WORD SEPARATOR DOT
-10102 ; BA # So AEGEAN CHECK MARK
+10100..10102 ; BA # Po [3] AEGEAN WORD SEPARATOR LINE..AEGEAN CHECK MARK
1039F ; BA # Po UGARITIC WORD DIVIDER
103D0 ; BA # Po OLD PERSIAN WORD DIVIDER
10857 ; BA # Po IMPERIAL ARAMAIC SECTION SIGN
@@ -1743,9 +1834,12 @@
10B39..10B3F ; BA # Po [7] AVESTAN ABBREVIATION MARK..LARGE ONE RING OVER TWO RINGS PUNCTUATION
11047..11048 ; BA # Po [2] BRAHMI DANDA..BRAHMI DOUBLE DANDA
110BE..110C1 ; BA # Po [4] KAITHI SECTION MARK..KAITHI DOUBLE DANDA
+11140..11143 ; BA # Po [4] CHAKMA SECTION MARK..CHAKMA QUESTION MARK
+111C5..111C6 ; BA # Po [2] SHARADA DANDA..SHARADA DOUBLE DANDA
+111C8 ; BA # Po SHARADA SEPARATOR
12470..12473 ; BA # Po [4] CUNEIFORM PUNCTUATION SIGN OLD ASSYRIAN WORD DIVIDER..CUNEIFORM PUNCTUATION SIGN DIAGONAL TRICOLON
-# Total code points: 140
+# Total code points: 151
# ================================================
@@ -1820,7 +1914,7 @@
0EC0..0EC4 ; SA # Lo [5] LAO VOWEL SIGN E..LAO VOWEL SIGN AI
0EC6 ; SA # Lm LAO KO LA
0EC8..0ECD ; SA # Mn [6] LAO TONE MAI EK..LAO NIGGAHITA
-0EDC..0EDD ; SA # Lo [2] LAO HO NO..LAO HO MO
+0EDC..0EDF ; SA # Lo [4] LAO HO NO..LAO LETTER KHMU NYO
1000..102A ; SA # Lo [43] MYANMAR LETTER KA..MYANMAR LETTER AU
102B..102C ; SA # Mc [2] MYANMAR VOWEL SIGN TALL AA..MYANMAR VOWEL SIGN AA
102D..1030 ; SA # Mn [4] MYANMAR VOWEL SIGN I..MYANMAR VOWEL SIGN UU
@@ -1854,7 +1948,7 @@
109D ; SA # Mn MYANMAR VOWEL SIGN AITON AI
109E..109F ; SA # So [2] MYANMAR SYMBOL SHAN ONE..MYANMAR SYMBOL SHAN EXCLAMATION
1780..17B3 ; SA # Lo [52] KHMER LETTER KA..KHMER INDEPENDENT VOWEL QAU
-17B4..17B5 ; SA # Cf [2] KHMER VOWEL INHERENT AQ..KHMER VOWEL INHERENT AA
+17B4..17B5 ; SA # Mn [2] KHMER VOWEL INHERENT AQ..KHMER VOWEL INHERENT AA
17B6 ; SA # Mc KHMER VOWEL SIGN AA
17B7..17BD ; SA # Mn [7] KHMER VOWEL SIGN I..KHMER VOWEL SIGN UA
17BE..17C5 ; SA # Mc [8] KHMER VOWEL SIGN OE..KHMER VOWEL SIGN AU
@@ -1908,21 +2002,20 @@
AADD ; SA # Lm TAI VIET SYMBOL SAM
AADE..AADF ; SA # Po [2] TAI VIET SYMBOL HO HOI..TAI VIET SYMBOL KOI KOI
-# Total code points: 663
+# Total code points: 665
# ================================================
# Line_Break=Ambiguous
-00A7 ; AI # So SECTION SIGN
+00A7 ; AI # Po SECTION SIGN
00A8 ; AI # Sk DIAERESIS
-00AA ; AI # L& FEMININE ORDINAL INDICATOR
+00AA ; AI # Lo FEMININE ORDINAL INDICATOR
00B2..00B3 ; AI # No [2] SUPERSCRIPT TWO..SUPERSCRIPT THREE
-00B6 ; AI # So PILCROW SIGN
-00B7 ; AI # Po MIDDLE DOT
+00B6..00B7 ; AI # Po [2] PILCROW SIGN..MIDDLE DOT
00B8 ; AI # Sk CEDILLA
00B9 ; AI # No SUPERSCRIPT ONE
-00BA ; AI # L& MASCULINE ORDINAL INDICATOR
+00BA ; AI # Lo MASCULINE ORDINAL INDICATOR
00BC..00BE ; AI # No [3] VULGAR FRACTION ONE QUARTER..VULGAR FRACTION THREE QUARTERS
00D7 ; AI # Sm MULTIPLICATION SIGN
00F7 ; AI # Sm DIVISION SIGN
@@ -2005,26 +2098,30 @@
2605..2606 ; AI # So [2] BLACK STAR..WHITE STAR
2609 ; AI # So SUN
260E..260F ; AI # So [2] BLACK TELEPHONE..WHITE TELEPHONE
-2614..2617 ; AI # So [4] UMBRELLA WITH RAIN DROPS..BLACK SHOGI PIECE
-261C ; AI # So WHITE LEFT POINTING INDEX
-261E ; AI # So WHITE RIGHT POINTING INDEX
+2616..2617 ; AI # So [2] WHITE SHOGI PIECE..BLACK SHOGI PIECE
2640 ; AI # So FEMALE SIGN
2642 ; AI # So MALE SIGN
2660..2661 ; AI # So [2] BLACK SPADE SUIT..WHITE HEART SUIT
2663..2665 ; AI # So [3] BLACK CLUB SUIT..BLACK HEART SUIT
-2667..266A ; AI # So [4] WHITE CLUB SUIT..EIGHTH NOTE
+2667 ; AI # So WHITE CLUB SUIT
+2669..266A ; AI # So [2] QUARTER NOTE..EIGHTH NOTE
266C..266D ; AI # So [2] BEAMED SIXTEENTH NOTES..MUSIC FLAT SIGN
266F ; AI # Sm MUSIC SHARP SIGN
269E..269F ; AI # So [2] THREE LINES CONVERGING RIGHT..THREE LINES CONVERGING LEFT
-26BE..26BF ; AI # So [2] BASEBALL..SQUARED KEY
-26C4..26CD ; AI # So [10] SNOWMAN WITHOUT SNOW..DISABLED CAR
-26CF..26E1 ; AI # So [19] PICK..RESTRICTED LEFT ENTRY-2
+26C9..26CC ; AI # So [4] TURNED WHITE SHOGI PIECE..CROSSING LANES
+26D2 ; AI # So CIRCLED CROSSING LANES
+26D5..26D7 ; AI # So [3] ALTERNATE ONE-WAY LEFT WAY TRAFFIC..WHITE TWO-WAY LEFT WAY TRAFFIC
+26DA..26DB ; AI # So [2] DRIVE SLOW SIGN..HEAVY WHITE DOWN-POINTING TRIANGLE
+26DD..26DE ; AI # So [2] SQUARED SALTIRE..FALLING DIAGONAL IN WHITE CIRCLE IN BLACK SQUARE
26E3 ; AI # So HEAVY CIRCLE WITH STROKE AND TWO DOTS ABOVE
-26E8..26FF ; AI # So [24] BLACK CROSS ON SHIELD..WHITE FLAG WITH HORIZONTAL MIDDLE BLACK STRIPE
+26E8..26E9 ; AI # So [2] BLACK CROSS ON SHIELD..SHINTO SHRINE
+26EB..26F0 ; AI # So [6] CASTLE..MOUNTAIN
+26F6 ; AI # So SQUARE FOUR CORNERS
+26FB..26FC ; AI # So [2] JAPANESE BANK SYMBOL..HEADSTONE GRAVEYARD SYMBOL
2757 ; AI # So HEAVY EXCLAMATION MARK SYMBOL
2776..2793 ; AI # No [30] DINGBAT NEGATIVE CIRCLED DIGIT ONE..DINGBAT NEGATIVE CIRCLED SANS-SERIF NUMBER TEN
2B55..2B59 ; AI # So [5] HEAVY LARGE CIRCLE..HEAVY CIRCLED SALTIRE
-3248..324F ; AI # So [8] CIRCLED NUMBER TEN ON BLACK SQUARE..CIRCLED NUMBER EIGHTY ON BLACK SQUARE
+3248..324F ; AI # No [8] CIRCLED NUMBER TEN ON BLACK SQUARE..CIRCLED NUMBER EIGHTY ON BLACK SQUARE
FFFD ; AI # So REPLACEMENT CHARACTER
1F100..1F10A ; AI # No [11] DIGIT ZERO FULL STOP..DIGIT NINE COMMA
1F110..1F12D ; AI # So [30] PARENTHESIZED LATIN CAPITAL LETTER A..CIRCLED CD
@@ -2031,7 +2128,7 @@
1F130..1F169 ; AI # So [58] SQUARED LATIN CAPITAL LETTER A..NEGATIVE CIRCLED LATIN CAPITAL LETTER Z
1F170..1F19A ; AI # So [43] NEGATIVE SQUARED LATIN CAPITAL LETTER A..SQUARED VS
-# Total code points: 724
+# Total code points: 687
# ================================================
@@ -2038,8 +2135,9 @@
# Line_Break=Break_Both
2014 ; B2 # Pd EM DASH
+2E3A..2E3B ; B2 # Pd [2] TWO-EM DASH..THREE-EM DASH
-# Total code points: 1
+# Total code points: 3
# ================================================
@@ -2922,4 +3020,62 @@
# Total code points: 2
+# ================================================
+
+# Line_Break=Hebrew_Letter
+
+05D0..05EA ; HL # Lo [27] HEBREW LETTER ALEF..HEBREW LETTER TAV
+05F0..05F2 ; HL # Lo [3] HEBREW LIGATURE YIDDISH DOUBLE VAV..HEBREW LIGATURE YIDDISH DOUBLE YOD
+FB1D ; HL # Lo HEBREW LETTER YOD WITH HIRIQ
+FB1F..FB28 ; HL # Lo [10] HEBREW LIGATURE YIDDISH YOD YOD PATAH..HEBREW LETTER WIDE TAV
+FB2A..FB36 ; HL # Lo [13] HEBREW LETTER SHIN WITH SHIN DOT..HEBREW LETTER ZAYIN WITH DAGESH
+FB38..FB3C ; HL # Lo [5] HEBREW LETTER TET WITH DAGESH..HEBREW LETTER LAMED WITH DAGESH
+FB3E ; HL # Lo HEBREW LETTER MEM WITH DAGESH
+FB40..FB41 ; HL # Lo [2] HEBREW LETTER NUN WITH DAGESH..HEBREW LETTER SAMEKH WITH DAGESH
+FB43..FB44 ; HL # Lo [2] HEBREW LETTER FINAL PE WITH DAGESH..HEBREW LETTER PE WITH DAGESH
+FB46..FB4F ; HL # Lo [10] HEBREW LETTER TSADI WITH DAGESH..HEBREW LIGATURE ALEF LAMED
+
+# Total code points: 74
+
+# ================================================
+
+# Line_Break=Conditional_Japanese_Starter
+
+3041 ; CJ # Lo HIRAGANA LETTER SMALL A
+3043 ; CJ # Lo HIRAGANA LETTER SMALL I
+3045 ; CJ # Lo HIRAGANA LETTER SMALL U
+3047 ; CJ # Lo HIRAGANA LETTER SMALL E
+3049 ; CJ # Lo HIRAGANA LETTER SMALL O
+3063 ; CJ # Lo HIRAGANA LETTER SMALL TU
+3083 ; CJ # Lo HIRAGANA LETTER SMALL YA
+3085 ; CJ # Lo HIRAGANA LETTER SMALL YU
+3087 ; CJ # Lo HIRAGANA LETTER SMALL YO
+308E ; CJ # Lo HIRAGANA LETTER SMALL WA
+3095..3096 ; CJ # Lo [2] HIRAGANA LETTER SMALL KA..HIRAGANA LETTER SMALL KE
+30A1 ; CJ # Lo KATAKANA LETTER SMALL A
+30A3 ; CJ # Lo KATAKANA LETTER SMALL I
+30A5 ; CJ # Lo KATAKANA LETTER SMALL U
+30A7 ; CJ # Lo KATAKANA LETTER SMALL E
+30A9 ; CJ # Lo KATAKANA LETTER SMALL O
+30C3 ; CJ # Lo KATAKANA LETTER SMALL TU
+30E3 ; CJ # Lo KATAKANA LETTER SMALL YA
+30E5 ; CJ # Lo KATAKANA LETTER SMALL YU
+30E7 ; CJ # Lo KATAKANA LETTER SMALL YO
+30EE ; CJ # Lo KATAKANA LETTER SMALL WA
+30F5..30F6 ; CJ # Lo [2] KATAKANA LETTER SMALL KA..KATAKANA LETTER SMALL KE
+30FC ; CJ # Lm KATAKANA-HIRAGANA PROLONGED SOUND MARK
+31F0..31FF ; CJ # Lo [16] KATAKANA LETTER SMALL KU..KATAKANA LETTER SMALL RO
+FF67..FF6F ; CJ # Lo [9] HALFWIDTH KATAKANA LETTER SMALL A..HALFWIDTH KATAKANA LETTER SMALL TU
+FF70 ; CJ # Lm HALFWIDTH KATAKANA-HIRAGANA PROLONGED SOUND MARK
+
+# Total code points: 51
+
+# ================================================
+
+# Line_Break=Regional_Indicator
+
+1F1E6..1F1FF ; RI # So [26] REGIONAL INDICATOR SYMBOL LETTER A..REGIONAL INDICATOR SYMBOL LETTER Z
+
+# Total code points: 26
+
# EOF
Property changes on: trunk/contrib/perl/lib/unicore/extracted/DLineBreak.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/extracted/DNumType.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/extracted/DNumType.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/extracted/DNumType.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,14 +1,22 @@
-# DerivedNumericType-6.0.0.txt
-# Date: 2010-08-19, 00:48:13 GMT [MD]
+# DerivedNumericType-6.2.0.txt
+# Date: 2012-08-13, 19:20:20 GMT [MD]
#
# Unicode Character Database
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
# For documentation, see http://www.unicode.org/reports/tr44/
# ================================================
-# Numeric Type (from UnicodeData.txt, field 6/7/8 plus Unihan Database: see UAX #44: http://www.unicode.org/reports/tr44/)
+# Derived Property: Numeric_Type
+# The values are based on fields 6-8 of UnicodeData.txt, plus the fields
+# kAccountingNumeric, kOtherNumeric, kPrimaryNumeric in the Unicode Han Database (Unihan).
+# The derivations for these values are as follows.
+# Numeric_Type=Decimal: When there is a value in field 6.
+# Numeric_Type=Digit: When there is a value in field 7, but not in field 6.
+# Numeric_Type=Numeric: When there are values for kAccountingNumeric, kOtherNumeric, kPrimaryNumeric,
+# or there is a value in field 8, but not in field 7.
+# Numeric_Type=None: Otherwise
# All code points not explicitly listed for Numeric_Type
# have the value None.
@@ -45,6 +53,7 @@
3038..303A ; Numeric # Nl [3] HANGZHOU NUMERAL TEN..HANGZHOU NUMERAL THIRTY
3192..3195 ; Numeric # No [4] IDEOGRAPHIC ANNOTATION ONE MARK..IDEOGRAPHIC ANNOTATION FOUR MARK
3220..3229 ; Numeric # No [10] PARENTHESIZED IDEOGRAPH ONE..PARENTHESIZED IDEOGRAPH TEN
+3248..324F ; Numeric # No [8] CIRCLED NUMBER TEN ON BLACK SQUARE..CIRCLED NUMBER EIGHTY ON BLACK SQUARE
3251..325F ; Numeric # No [15] CIRCLED NUMBER TWENTY ONE..CIRCLED NUMBER THIRTY FIVE
3280..3289 ; Numeric # No [10] CIRCLED IDEOGRAPH ONE..CIRCLED IDEOGRAPH TEN
32B1..32BF ; Numeric # No [15] CIRCLED NUMBER THIRTY SIX..CIRCLED NUMBER FIFTY
@@ -122,9 +131,7 @@
10B78..10B7F ; Numeric # No [8] INSCRIPTIONAL PAHLAVI NUMBER ONE..INSCRIPTIONAL PAHLAVI NUMBER ONE THOUSAND
10E69..10E7E ; Numeric # No [22] RUMI NUMBER TEN..RUMI FRACTION TWO THIRDS
1105B..11065 ; Numeric # No [11] BRAHMI NUMBER TEN..BRAHMI NUMBER ONE THOUSAND
-12400..12431 ; Numeric # Nl [50] CUNEIFORM NUMERIC SIGN TWO ASH..CUNEIFORM NUMERIC SIGN FIVE SHARU
-12434..12455 ; Numeric # Nl [34] CUNEIFORM NUMERIC SIGN ONE BURU..CUNEIFORM NUMERIC SIGN FIVE BAN2 VARIANT FORM
-12458..12462 ; Numeric # Nl [11] CUNEIFORM NUMERIC SIGN ONE ESHE3..CUNEIFORM NUMERIC SIGN OLD ASSYRIAN ONE QUARTER
+12400..12462 ; Numeric # Nl [99] CUNEIFORM NUMERIC SIGN TWO ASH..CUNEIFORM NUMERIC SIGN OLD ASSYRIAN ONE QUARTER
1D360..1D371 ; Numeric # No [18] COUNTING ROD UNIT DIGIT ONE..COUNTING ROD TENS DIGIT NINE
20001 ; Numeric # Lo CJK UNIFIED IDEOGRAPH-20001
20064 ; Numeric # Lo CJK UNIFIED IDEOGRAPH-20064
@@ -143,7 +150,7 @@
2626D ; Numeric # Lo CJK UNIFIED IDEOGRAPH-2626D
2F890 ; Numeric # Lo CJK COMPATIBILITY IDEOGRAPH-2F890
-# Total code points: 629
+# Total code points: 641
# ================================================
@@ -209,8 +216,12 @@
FF10..FF19 ; Decimal # Nd [10] FULLWIDTH DIGIT ZERO..FULLWIDTH DIGIT NINE
104A0..104A9 ; Decimal # Nd [10] OSMANYA DIGIT ZERO..OSMANYA DIGIT NINE
11066..1106F ; Decimal # Nd [10] BRAHMI DIGIT ZERO..BRAHMI DIGIT NINE
+110F0..110F9 ; Decimal # Nd [10] SORA SOMPENG DIGIT ZERO..SORA SOMPENG DIGIT NINE
+11136..1113F ; Decimal # Nd [10] CHAKMA DIGIT ZERO..CHAKMA DIGIT NINE
+111D0..111D9 ; Decimal # Nd [10] SHARADA DIGIT ZERO..SHARADA DIGIT NINE
+116C0..116C9 ; Decimal # Nd [10] TAKRI DIGIT ZERO..TAKRI DIGIT NINE
1D7CE..1D7FF ; Decimal # Nd [50] MATHEMATICAL BOLD DIGIT ZERO..MATHEMATICAL MONOSPACE DIGIT NINE
-# Total code points: 420
+# Total code points: 460
# EOF
Property changes on: trunk/contrib/perl/lib/unicore/extracted/DNumType.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/extracted/DNumValues.txt
===================================================================
--- trunk/contrib/perl/lib/unicore/extracted/DNumValues.txt 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/extracted/DNumValues.txt 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,27 +1,44 @@
-# DerivedNumericValues-6.0.0.txt
-# Date: 2010-08-19, 00:48:14 GMT [MD]
+# DerivedNumericValues-6.2.0.txt
+# Date: 2012-08-13, 19:20:22 GMT [MD]
#
# Unicode Character Database
-# Copyright (c) 1991-2010 Unicode, Inc.
+# Copyright (c) 1991-2012 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
# For documentation, see http://www.unicode.org/reports/tr44/
# ================================================
-# Numeric Values (from UnicodeData.txt, field 6/7/8)
-# WARNING: Certain values, such as 0.16666667, are repeating fractions
+# Derived Property: Numeric_Value
+# Field 1:
+# The values are based on field 8 of UnicodeData.txt, plus the fields
+# kAccountingNumeric, kOtherNumeric, kPrimaryNumeric in the Unicode Han Database (Unihan).
+# The derivations for these values are as follows.
+# Numeric_Value = the value of kAccountingNumeric, kOtherNumeric, or kPrimaryNumeric, if they exist; otherwise
+# Numeric_Value = the value of field 8, if it exists; otherwise
+# Numeric_Value = NaN
+# Field 2:
+# This field is empty; it used to be a copy of the numeric type.
+#
+# Field 3:
+# This field was added to this extracted data as of Unicode 5.1.0,
+# expressing the same numeric value either as a whole integer
+# where possible, or as a rational fraction such as "1/6".
+#
+# WARNING: Certain values, such as 0.16666667, are repeating fractions.
# Although they are only printed with a limited number of decimal places
# in this file, they should be expressed to the limits of the precision
# available when used.
-# The third field is empty; it used to be a copy of the numeric type.
-# A fourth field was added to this extracted data as of
-# Unicode 5.1.0, expressing the same numeric value either as
-# a whole integer where possible or as a rational fraction, e.g. "1/6".
#
-# @missing: 0000..10FFFF; ; NaN
+# @missing: 0000..10FFFF; NaN; ; NaN
# ================================================
+12456..12457 ; -1.0 ; ; -1 # Nl [2] CUNEIFORM NUMERIC SIGN NIGIDAMIN..CUNEIFORM NUMERIC SIGN NIGIDAESH
+
+# Total code points: 2
+
+# ================================================
+
0F33 ; -0.5 ; ; -1/2 # No TIBETAN DIGIT HALF ZERO
# Total code points: 1
@@ -77,6 +94,10 @@
1018A ; 0.0 ; ; 0 # No GREEK ZERO SIGN
104A0 ; 0.0 ; ; 0 # Nd OSMANYA DIGIT ZERO
11066 ; 0.0 ; ; 0 # Nd BRAHMI DIGIT ZERO
+110F0 ; 0.0 ; ; 0 # Nd SORA SOMPENG DIGIT ZERO
+11136 ; 0.0 ; ; 0 # Nd CHAKMA DIGIT ZERO
+111D0 ; 0.0 ; ; 0 # Nd SHARADA DIGIT ZERO
+116C0 ; 0.0 ; ; 0 # Nd TAKRI DIGIT ZERO
1D7CE ; 0.0 ; ; 0 # Nd MATHEMATICAL BOLD DIGIT ZERO
1D7D8 ; 0.0 ; ; 0 # Nd MATHEMATICAL DOUBLE-STRUCK DIGIT ZERO
1D7E2 ; 0.0 ; ; 0 # Nd MATHEMATICAL SANS-SERIF DIGIT ZERO
@@ -84,7 +105,7 @@
1D7F6 ; 0.0 ; ; 0 # Nd MATHEMATICAL MONOSPACE DIGIT ZERO
1F100..1F101 ; 0.0 ; ; 0 # No [2] DIGIT ZERO FULL STOP..DIGIT ZERO COMMA
-# Total code points: 56
+# Total code points: 60
# ================================================
@@ -323,6 +344,10 @@
10E60 ; 1.0 ; ; 1 # No RUMI DIGIT ONE
11052 ; 1.0 ; ; 1 # No BRAHMI NUMBER ONE
11067 ; 1.0 ; ; 1 # Nd BRAHMI DIGIT ONE
+110F1 ; 1.0 ; ; 1 # Nd SORA SOMPENG DIGIT ONE
+11137 ; 1.0 ; ; 1 # Nd CHAKMA DIGIT ONE
+111D1 ; 1.0 ; ; 1 # Nd SHARADA DIGIT ONE
+116C1 ; 1.0 ; ; 1 # Nd TAKRI DIGIT ONE
12415 ; 1.0 ; ; 1 # Nl CUNEIFORM NUMERIC SIGN ONE GESH2
1241E ; 1.0 ; ; 1 # Nl CUNEIFORM NUMERIC SIGN ONE GESHU
1242C ; 1.0 ; ; 1 # Nl CUNEIFORM NUMERIC SIGN ONE SHARU
@@ -338,7 +363,7 @@
1F102 ; 1.0 ; ; 1 # No DIGIT ONE COMMA
2092A ; 1.0 ; ; 1 # Lo CJK UNIFIED IDEOGRAPH-2092A
-# Total code points: 93
+# Total code points: 97
# ================================================
@@ -424,6 +449,10 @@
10E61 ; 2.0 ; ; 2 # No RUMI DIGIT TWO
11053 ; 2.0 ; ; 2 # No BRAHMI NUMBER TWO
11068 ; 2.0 ; ; 2 # Nd BRAHMI DIGIT TWO
+110F2 ; 2.0 ; ; 2 # Nd SORA SOMPENG DIGIT TWO
+11138 ; 2.0 ; ; 2 # Nd CHAKMA DIGIT TWO
+111D2 ; 2.0 ; ; 2 # Nd SHARADA DIGIT TWO
+116C2 ; 2.0 ; ; 2 # Nd TAKRI DIGIT TWO
12400 ; 2.0 ; ; 2 # Nl CUNEIFORM NUMERIC SIGN TWO ASH
12416 ; 2.0 ; ; 2 # Nl CUNEIFORM NUMERIC SIGN TWO GESH2
1241F ; 2.0 ; ; 2 # Nl CUNEIFORM NUMERIC SIGN TWO GESHU
@@ -442,7 +471,7 @@
1F103 ; 2.0 ; ; 2 # No DIGIT TWO COMMA
22390 ; 2.0 ; ; 2 # Lo CJK UNIFIED IDEOGRAPH-22390
-# Total code points: 96
+# Total code points: 100
# ================================================
@@ -522,6 +551,10 @@
10E62 ; 3.0 ; ; 3 # No RUMI DIGIT THREE
11054 ; 3.0 ; ; 3 # No BRAHMI NUMBER THREE
11069 ; 3.0 ; ; 3 # Nd BRAHMI DIGIT THREE
+110F3 ; 3.0 ; ; 3 # Nd SORA SOMPENG DIGIT THREE
+11139 ; 3.0 ; ; 3 # Nd CHAKMA DIGIT THREE
+111D3 ; 3.0 ; ; 3 # Nd SHARADA DIGIT THREE
+116C3 ; 3.0 ; ; 3 # Nd TAKRI DIGIT THREE
12401 ; 3.0 ; ; 3 # Nl CUNEIFORM NUMERIC SIGN THREE ASH
12408 ; 3.0 ; ; 3 # Nl CUNEIFORM NUMERIC SIGN THREE DISH
12417 ; 3.0 ; ; 3 # Nl CUNEIFORM NUMERIC SIGN THREE GESH2
@@ -544,7 +577,7 @@
22998 ; 3.0 ; ; 3 # Lo CJK UNIFIED IDEOGRAPH-22998
23B1B ; 3.0 ; ; 3 # Lo CJK UNIFIED IDEOGRAPH-23B1B
-# Total code points: 98
+# Total code points: 102
# ================================================
@@ -618,6 +651,10 @@
10E63 ; 4.0 ; ; 4 # No RUMI DIGIT FOUR
11055 ; 4.0 ; ; 4 # No BRAHMI NUMBER FOUR
1106A ; 4.0 ; ; 4 # Nd BRAHMI DIGIT FOUR
+110F4 ; 4.0 ; ; 4 # Nd SORA SOMPENG DIGIT FOUR
+1113A ; 4.0 ; ; 4 # Nd CHAKMA DIGIT FOUR
+111D4 ; 4.0 ; ; 4 # Nd SHARADA DIGIT FOUR
+116C4 ; 4.0 ; ; 4 # Nd TAKRI DIGIT FOUR
12402 ; 4.0 ; ; 4 # Nl CUNEIFORM NUMERIC SIGN FOUR ASH
12409 ; 4.0 ; ; 4 # Nl CUNEIFORM NUMERIC SIGN FOUR DISH
1240F ; 4.0 ; ; 4 # Nl CUNEIFORM NUMERIC SIGN FOUR U
@@ -640,7 +677,7 @@
200E2 ; 4.0 ; ; 4 # Lo CJK UNIFIED IDEOGRAPH-200E2
2626D ; 4.0 ; ; 4 # Lo CJK UNIFIED IDEOGRAPH-2626D
-# Total code points: 89
+# Total code points: 93
# ================================================
@@ -717,6 +754,10 @@
10E64 ; 5.0 ; ; 5 # No RUMI DIGIT FIVE
11056 ; 5.0 ; ; 5 # No BRAHMI NUMBER FIVE
1106B ; 5.0 ; ; 5 # Nd BRAHMI DIGIT FIVE
+110F5 ; 5.0 ; ; 5 # Nd SORA SOMPENG DIGIT FIVE
+1113B ; 5.0 ; ; 5 # Nd CHAKMA DIGIT FIVE
+111D5 ; 5.0 ; ; 5 # Nd SHARADA DIGIT FIVE
+116C5 ; 5.0 ; ; 5 # Nd TAKRI DIGIT FIVE
12403 ; 5.0 ; ; 5 # Nl CUNEIFORM NUMERIC SIGN FIVE ASH
1240A ; 5.0 ; ; 5 # Nl CUNEIFORM NUMERIC SIGN FIVE DISH
12410 ; 5.0 ; ; 5 # Nl CUNEIFORM NUMERIC SIGN FIVE U
@@ -736,7 +777,7 @@
1F106 ; 5.0 ; ; 5 # No DIGIT FIVE COMMA
20121 ; 5.0 ; ; 5 # Lo CJK UNIFIED IDEOGRAPH-20121
-# Total code points: 86
+# Total code points: 90
# ================================================
@@ -809,6 +850,10 @@
10E65 ; 6.0 ; ; 6 # No RUMI DIGIT SIX
11057 ; 6.0 ; ; 6 # No BRAHMI NUMBER SIX
1106C ; 6.0 ; ; 6 # Nd BRAHMI DIGIT SIX
+110F6 ; 6.0 ; ; 6 # Nd SORA SOMPENG DIGIT SIX
+1113C ; 6.0 ; ; 6 # Nd CHAKMA DIGIT SIX
+111D6 ; 6.0 ; ; 6 # Nd SHARADA DIGIT SIX
+116C6 ; 6.0 ; ; 6 # Nd TAKRI DIGIT SIX
12404 ; 6.0 ; ; 6 # Nl CUNEIFORM NUMERIC SIGN SIX ASH
1240B ; 6.0 ; ; 6 # Nl CUNEIFORM NUMERIC SIGN SIX DISH
12411 ; 6.0 ; ; 6 # Nl CUNEIFORM NUMERIC SIGN SIX U
@@ -825,7 +870,7 @@
1F107 ; 6.0 ; ; 6 # No DIGIT SIX COMMA
20AEA ; 6.0 ; ; 6 # Lo CJK UNIFIED IDEOGRAPH-20AEA
-# Total code points: 78
+# Total code points: 82
# ================================================
@@ -896,6 +941,10 @@
10E66 ; 7.0 ; ; 7 # No RUMI DIGIT SEVEN
11058 ; 7.0 ; ; 7 # No BRAHMI NUMBER SEVEN
1106D ; 7.0 ; ; 7 # Nd BRAHMI DIGIT SEVEN
+110F7 ; 7.0 ; ; 7 # Nd SORA SOMPENG DIGIT SEVEN
+1113D ; 7.0 ; ; 7 # Nd CHAKMA DIGIT SEVEN
+111D7 ; 7.0 ; ; 7 # Nd SHARADA DIGIT SEVEN
+116C7 ; 7.0 ; ; 7 # Nd TAKRI DIGIT SEVEN
12405 ; 7.0 ; ; 7 # Nl CUNEIFORM NUMERIC SIGN SEVEN ASH
1240C ; 7.0 ; ; 7 # Nl CUNEIFORM NUMERIC SIGN SEVEN DISH
12412 ; 7.0 ; ; 7 # Nl CUNEIFORM NUMERIC SIGN SEVEN U
@@ -911,7 +960,7 @@
1F108 ; 7.0 ; ; 7 # No DIGIT SEVEN COMMA
20001 ; 7.0 ; ; 7 # Lo CJK UNIFIED IDEOGRAPH-20001
-# Total code points: 77
+# Total code points: 81
# ================================================
@@ -980,6 +1029,10 @@
10E67 ; 8.0 ; ; 8 # No RUMI DIGIT EIGHT
11059 ; 8.0 ; ; 8 # No BRAHMI NUMBER EIGHT
1106E ; 8.0 ; ; 8 # Nd BRAHMI DIGIT EIGHT
+110F8 ; 8.0 ; ; 8 # Nd SORA SOMPENG DIGIT EIGHT
+1113E ; 8.0 ; ; 8 # Nd CHAKMA DIGIT EIGHT
+111D8 ; 8.0 ; ; 8 # Nd SHARADA DIGIT EIGHT
+116C8 ; 8.0 ; ; 8 # Nd TAKRI DIGIT EIGHT
12406 ; 8.0 ; ; 8 # Nl CUNEIFORM NUMERIC SIGN EIGHT ASH
1240D ; 8.0 ; ; 8 # Nl CUNEIFORM NUMERIC SIGN EIGHT DISH
12413 ; 8.0 ; ; 8 # Nl CUNEIFORM NUMERIC SIGN EIGHT U
@@ -994,7 +1047,7 @@
1D7FE ; 8.0 ; ; 8 # Nd MATHEMATICAL MONOSPACE DIGIT EIGHT
1F109 ; 8.0 ; ; 8 # No DIGIT EIGHT COMMA
-# Total code points: 73
+# Total code points: 77
# ================================================
@@ -1064,6 +1117,10 @@
10E68 ; 9.0 ; ; 9 # No RUMI DIGIT NINE
1105A ; 9.0 ; ; 9 # No BRAHMI NUMBER NINE
1106F ; 9.0 ; ; 9 # Nd BRAHMI DIGIT NINE
+110F9 ; 9.0 ; ; 9 # Nd SORA SOMPENG DIGIT NINE
+1113F ; 9.0 ; ; 9 # Nd CHAKMA DIGIT NINE
+111D9 ; 9.0 ; ; 9 # Nd SHARADA DIGIT NINE
+116C9 ; 9.0 ; ; 9 # Nd TAKRI DIGIT NINE
12407 ; 9.0 ; ; 9 # Nl CUNEIFORM NUMERIC SIGN NINE ASH
1240E ; 9.0 ; ; 9 # Nl CUNEIFORM NUMERIC SIGN NINE DISH
12414 ; 9.0 ; ; 9 # Nl CUNEIFORM NUMERIC SIGN NINE U
@@ -1079,7 +1136,7 @@
1F10A ; 9.0 ; ; 9 # No DIGIT NINE COMMA
2F890 ; 9.0 ; ; 9 # Lo CJK COMPATIBILITY IDEOGRAPH-2F890
-# Total code points: 77
+# Total code points: 81
# ================================================
@@ -1097,6 +1154,7 @@
2793 ; 10.0 ; ; 10 # No DINGBAT NEGATIVE CIRCLED SANS-SERIF NUMBER TEN
3038 ; 10.0 ; ; 10 # Nl HANGZHOU NUMERAL TEN
3229 ; 10.0 ; ; 10 # No PARENTHESIZED IDEOGRAPH TEN
+3248 ; 10.0 ; ; 10 # No CIRCLED NUMBER TEN ON BLACK SQUARE
3289 ; 10.0 ; ; 10 # No CIRCLED IDEOGRAPH TEN
4EC0 ; 10.0 ; ; 10 # Lo CJK UNIFIED IDEOGRAPH-4EC0
5341 ; 10.0 ; ; 10 # Lo CJK UNIFIED IDEOGRAPH-5341
@@ -1119,7 +1177,7 @@
1105B ; 10.0 ; ; 10 # No BRAHMI NUMBER TEN
1D369 ; 10.0 ; ; 10 # No COUNTING ROD TENS DIGIT ONE
-# Total code points: 39
+# Total code points: 40
# ================================================
@@ -1218,6 +1276,7 @@
249B ; 20.0 ; ; 20 # No NUMBER TWENTY FULL STOP
24F4 ; 20.0 ; ; 20 # No NEGATIVE CIRCLED NUMBER TWENTY
3039 ; 20.0 ; ; 20 # Nl HANGZHOU NUMERAL TWENTY
+3249 ; 20.0 ; ; 20 # No CIRCLED NUMBER TWENTY ON BLACK SQUARE
5344 ; 20.0 ; ; 20 # Lo CJK UNIFIED IDEOGRAPH-5344
5EFF ; 20.0 ; ; 20 # Lo CJK UNIFIED IDEOGRAPH-5EFF
10111 ; 20.0 ; ; 20 # No AEGEAN NUMBER TWENTY
@@ -1231,7 +1290,7 @@
1105C ; 20.0 ; ; 20 # No BRAHMI NUMBER TWENTY
1D36A ; 20.0 ; ; 20 # No COUNTING ROD TENS DIGIT TWO
-# Total code points: 18
+# Total code points: 19
# ================================================
@@ -1291,6 +1350,7 @@
1374 ; 30.0 ; ; 30 # No ETHIOPIC NUMBER THIRTY
303A ; 30.0 ; ; 30 # Nl HANGZHOU NUMERAL THIRTY
+324A ; 30.0 ; ; 30 # No CIRCLED NUMBER THIRTY ON BLACK SQUARE
325A ; 30.0 ; ; 30 # No CIRCLED NUMBER THIRTY
5345 ; 30.0 ; ; 30 # Lo CJK UNIFIED IDEOGRAPH-5345
10112 ; 30.0 ; ; 30 # No AEGEAN NUMBER THIRTY
@@ -1300,7 +1360,7 @@
1D36B ; 30.0 ; ; 30 # No COUNTING ROD TENS DIGIT THREE
20983 ; 30.0 ; ; 30 # Lo CJK UNIFIED IDEOGRAPH-20983
-# Total code points: 10
+# Total code points: 11
# ================================================
@@ -1359,6 +1419,7 @@
# ================================================
1375 ; 40.0 ; ; 40 # No ETHIOPIC NUMBER FORTY
+324B ; 40.0 ; ; 40 # No CIRCLED NUMBER FORTY ON BLACK SQUARE
32B5 ; 40.0 ; ; 40 # No CIRCLED NUMBER FORTY
534C ; 40.0 ; ; 40 # Lo CJK UNIFIED IDEOGRAPH-534C
10113 ; 40.0 ; ; 40 # No AEGEAN NUMBER FORTY
@@ -1368,7 +1429,7 @@
2098C ; 40.0 ; ; 40 # Lo CJK UNIFIED IDEOGRAPH-2098C
2099C ; 40.0 ; ; 40 # Lo CJK UNIFIED IDEOGRAPH-2099C
-# Total code points: 9
+# Total code points: 10
# ================================================
@@ -1430,6 +1491,7 @@
216C ; 50.0 ; ; 50 # Nl ROMAN NUMERAL FIFTY
217C ; 50.0 ; ; 50 # Nl SMALL ROMAN NUMERAL FIFTY
2186 ; 50.0 ; ; 50 # Nl ROMAN NUMERAL FIFTY EARLY FORM
+324C ; 50.0 ; ; 50 # No CIRCLED NUMBER FIFTY ON BLACK SQUARE
32BF ; 50.0 ; ; 50 # No CIRCLED NUMBER FIFTY
10114 ; 50.0 ; ; 50 # No AEGEAN NUMBER FIFTY
10144 ; 50.0 ; ; 50 # Nl GREEK ACROPHONIC ATTIC FIFTY
@@ -1443,37 +1505,40 @@
1105F ; 50.0 ; ; 50 # No BRAHMI NUMBER FIFTY
1D36D ; 50.0 ; ; 50 # No COUNTING ROD TENS DIGIT FIVE
-# Total code points: 19
+# Total code points: 20
# ================================================
1377 ; 60.0 ; ; 60 # No ETHIOPIC NUMBER SIXTY
+324D ; 60.0 ; ; 60 # No CIRCLED NUMBER SIXTY ON BLACK SQUARE
10115 ; 60.0 ; ; 60 # No AEGEAN NUMBER SIXTY
10E6E ; 60.0 ; ; 60 # No RUMI NUMBER SIXTY
11060 ; 60.0 ; ; 60 # No BRAHMI NUMBER SIXTY
1D36E ; 60.0 ; ; 60 # No COUNTING ROD TENS DIGIT SIX
-# Total code points: 5
+# Total code points: 6
# ================================================
1378 ; 70.0 ; ; 70 # No ETHIOPIC NUMBER SEVENTY
+324E ; 70.0 ; ; 70 # No CIRCLED NUMBER SEVENTY ON BLACK SQUARE
10116 ; 70.0 ; ; 70 # No AEGEAN NUMBER SEVENTY
10E6F ; 70.0 ; ; 70 # No RUMI NUMBER SEVENTY
11061 ; 70.0 ; ; 70 # No BRAHMI NUMBER SEVENTY
1D36F ; 70.0 ; ; 70 # No COUNTING ROD TENS DIGIT SEVEN
-# Total code points: 5
+# Total code points: 6
# ================================================
1379 ; 80.0 ; ; 80 # No ETHIOPIC NUMBER EIGHTY
+324F ; 80.0 ; ; 80 # No CIRCLED NUMBER EIGHTY ON BLACK SQUARE
10117 ; 80.0 ; ; 80 # No AEGEAN NUMBER EIGHTY
10E70 ; 80.0 ; ; 80 # No RUMI NUMBER EIGHTY
11062 ; 80.0 ; ; 80 # No BRAHMI NUMBER EIGHTY
1D370 ; 80.0 ; ; 80 # No COUNTING ROD TENS DIGIT EIGHT
-# Total code points: 5
+# Total code points: 6
# ================================================
@@ -1719,6 +1784,18 @@
# ================================================
+12432 ; 216000.0 ; ; 216000 # Nl CUNEIFORM NUMERIC SIGN SHAR2 TIMES GAL PLUS DISH
+
+# Total code points: 1
+
+# ================================================
+
+12433 ; 432000.0 ; ; 432000 # Nl CUNEIFORM NUMERIC SIGN SHAR2 TIMES GAL PLUS MIN
+
+# Total code points: 1
+
+# ================================================
+
4EBF ; 100000000.0 ; ; 100000000 # Lo CJK UNIFIED IDEOGRAPH-4EBF
5104 ; 100000000.0 ; ; 100000000 # Lo CJK UNIFIED IDEOGRAPH-5104
Property changes on: trunk/contrib/perl/lib/unicore/extracted/DNumValues.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/lib/unicore/mktables
===================================================================
--- trunk/contrib/perl/lib/unicore/mktables 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/mktables 2013-12-02 21:26:09 UTC (rev 6439)
@@ -22,7 +22,6 @@
$start_time= time;
}
-
require 5.010_001;
use strict;
use warnings;
@@ -32,6 +31,7 @@
use File::Path;
use File::Spec;
use Text::Tabs;
+use re "/aa";
sub DEBUG () { 0 } # Set to 0 for production; 1 for development
my $debugging_build = $Config{"ccflags"} =~ /-DDEBUGGING/;
@@ -40,7 +40,7 @@
#
# mktables -- create the runtime Perl Unicode files (lib/unicore/.../*.pl),
# from the Unicode database files (lib/unicore/.../*.txt), It also generates
-# a pod file and a .t file
+# a pod file and .t files, depending on option parameters.
#
# The structure of this file is:
# First these introductory comments; then
@@ -52,10 +52,10 @@
# the small actual loop to process the input files and finish up; then
# a __DATA__ section, for the .t tests
#
-# This program works on all releases of Unicode through at least 6.0. The
-# outputs have been scrutinized most intently for release 5.1. The others
-# have been checked for somewhat more than just sanity. It can handle all
-# existing Unicode character properties in those releases.
+# This program works on all releases of Unicode so far. The outputs have been
+# scrutinized most intently for release 5.1. The others have been checked for
+# somewhat more than just sanity. It can handle all non-provisional Unicode
+# character properties in those releases.
#
# This program is mostly about Unicode character (or code point) properties.
# A property describes some attribute or quality of a code point, like if it
@@ -65,8 +65,8 @@
# into some corresponding value. In the case of it being lowercase or not,
# the mapping is either to 'Y' or 'N' (or various synonyms thereof). Each
# property maps each Unicode code point to a single value, called a "property
-# value". (Hence each Unicode property is a true mathematical function with
-# exactly one value per code point.)
+# value". (Some more recently defined properties, map a code point to a set
+# of values.)
#
# When using a property in a regular expression, what is desired isn't the
# mapping of the code point to its property's value, but the reverse (or the
@@ -119,7 +119,7 @@
# are for mappings that don't fit into the normal scheme of things. Mappings
# that require a hash entry to communicate with utf8.c are one example;
# another example is mappings for charnames.pm to use which indicate a name
-# that is algorithmically determinable from its code point (and vice-versa).
+# that is algorithmically determinable from its code point (and the reverse).
# These are used to significantly compact these tables, instead of listing
# each one of the tens of thousands individually.
#
@@ -131,8 +131,8 @@
#
# Actually, there are two types of range lists, "Range_Map" is the one
# associated with map tables, and "Range_List" with match tables.
-# Again, this is so that methods can be defined on one and not the other so as
-# to prevent operating on them in incorrect ways.
+# Again, this is so that methods can be defined on one and not the others so
+# as to prevent operating on them in incorrect ways.
#
# Eventually, most tables are written out to files to be read by utf8_heavy.pl
# in the perl core. All tables could in theory be written, but some are
@@ -154,20 +154,31 @@
# takes every code point and maps it to Y or N (but having ranges cuts the
# number of entries in that table way down), and two match tables, one
# which has a list of all the code points that map to Y, and one for all the
-# code points that map to N. (For each of these, a third table is also
+# code points that map to N. (For each binary property, a third table is also
# generated for the pseudo Perl property. It contains the identical code
-# points as the Y table, but can be written, not in the compound form, but in
-# a "single" form like \p{IsUppercase}.) Many properties are binary, but some
-# properties have several possible values, some have many, and properties like
-# Name have a different value for every named code point. Those will not,
-# unless the controlling lists are changed, have their match tables written
-# out. But all the ones which can be used in regular expression \p{} and \P{}
-# constructs will. Generally a property will have either its map table or its
-# match tables written but not both. Again, what gets written is controlled
-# by lists which can easily be changed. Properties have a 'Type', like
-# binary, or string, or enum depending on how many match tables there are and
-# the content of the maps. This 'Type' is different than a range 'Type', so
-# don't get confused by the two concepts having the same name.
+# points as the Y table, but can be written in regular expressions, not in the
+# compound form, but in a "single" form like \p{IsUppercase}.) Many
+# properties are binary, but some properties have several possible values,
+# some have many, and properties like Name have a different value for every
+# named code point. Those will not, unless the controlling lists are changed,
+# have their match tables written out. But all the ones which can be used in
+# regular expression \p{} and \P{} constructs will. Prior to 5.14, generally
+# a property would have either its map table or its match tables written but
+# not both. Again, what gets written is controlled by lists which can easily
+# be changed. Starting in 5.14, advantage was taken of this, and all the map
+# tables needed to reconstruct the Unicode db are now written out, while
+# suppressing the Unicode .txt files that contain the data. Our tables are
+# much more compact than the .txt files, so a significant space savings was
+# achieved. Also, tables are not written out that are trivially derivable
+# from tables that do get written. So, there typically is no file containing
+# the code points not matched by a binary property (the table for \P{} versus
+# lowercase \p{}), since you just need to invert the True table to get the
+# False table.
+
+# Properties have a 'Type', like 'binary', or 'string', or 'enum' depending on
+# how many match tables there are and the content of the maps. This 'Type' is
+# different than a range 'Type', so don't get confused by the two concepts
+# having the same name.
#
# For information about the Unicode properties, see Unicode's UAX44 document:
@@ -175,22 +186,22 @@
# As stated earlier, this program will work on any release of Unicode so far.
# Most obvious problems in earlier data have NOT been corrected except when
-# necessary to make Perl or this program work reasonably. For example, no
-# folding information was given in early releases, so this program uses the
-# substitute of lower case, just so that a regular expression with the /i
-# option will do something that actually gives the right results in many
-# cases. There are also a couple other corrections for version 1.1.5,
-# commented at the point they are made. As an example of corrections that
-# weren't made (but could be) is this statement from DerivedAge.txt: "The
-# supplementary private use code points and the non-character code points were
-# assigned in version 2.0, but not specifically listed in the UCD until
-# versions 3.0 and 3.1 respectively." (To be precise it was 3.0.1 not 3.0.0)
-# More information on Unicode version glitches is further down in these
-# introductory comments.
+# necessary to make Perl or this program work reasonably, and to keep out
+# potential security issues. For example, no folding information was given in
+# early releases, so this program substitutes lower case instead, just so that
+# a regular expression with the /i option will do something that actually
+# gives the right results in many cases. There are also a couple other
+# corrections for version 1.1.5, commented at the point they are made. As an
+# example of corrections that weren't made (but could be) is this statement
+# from DerivedAge.txt: "The supplementary private use code points and the
+# non-character code points were assigned in version 2.0, but not specifically
+# listed in the UCD until versions 3.0 and 3.1 respectively." (To be precise
+# it was 3.0.1 not 3.0.0) More information on Unicode version glitches is
+# further down in these introductory comments.
#
-# This program works on all non-provisional properties as of 6.0, though the
-# files for some are suppressed from apparent lack of demand for them. You
-# can change which are output by changing lists in this program.
+# This program works on all non-provisional properties as of the current
+# Unicode release, though the files for some are suppressed for various
+# reasons. You can change which are output by changing lists in this program.
#
# The old version of mktables emphasized the term "Fuzzy" to mean Unicode's
# loose matchings rules (from Unicode TR18):
@@ -202,6 +213,7 @@
# recognized, and that loose matching of property names be used,
# whereby the case distinctions, whitespace, hyphens, and underbar
# are ignored.
+#
# The program still allows Fuzzy to override its determination of if loose
# matching should be used, but it isn't currently used, as it is no longer
# needed; the calculations it makes are good enough.
@@ -222,12 +234,13 @@
# values. That is, they list code points and say what the mapping
# is under the given property. Some files give the mappings for
# just one property; and some for many. This program goes through
-# each file and populates the properties from them. Some properties
-# are listed in more than one file, and Unicode has set up a
-# precedence as to which has priority if there is a conflict. Thus
-# the order of processing matters, and this program handles the
-# conflict possibility by processing the overriding input files
-# last, so that if necessary they replace earlier values.
+# each file and populates the properties and their map tables from
+# them. Some properties are listed in more than one file, and
+# Unicode has set up a precedence as to which has priority if there
+# is a conflict. Thus the order of processing matters, and this
+# program handles the conflict possibility by processing the
+# overriding input files last, so that if necessary they replace
+# earlier values.
# After this is all done, the program creates the property mappings not
# furnished by Unicode, but derivable from what it does give.
# The tables of code points that match each property value in each
@@ -290,18 +303,6 @@
# warn about any that it doesn't know how to handle (the -q option suppresses
# the warning).
#
-# Why have files written out for binary 'N' matches?
-# For binary properties, if you know the mapping for either Y or N; the
-# other is trivial to construct, so could be done at Perl run-time by just
-# complementing the result, instead of having a file for it. That is, if
-# someone types in \p{foo: N}, Perl could translate that to \P{foo: Y} and
-# not need a file. The problem is communicating to Perl that a given
-# property is binary. Perl can't figure it out from looking at the N (or
-# No), as some non-binary properties have these as property values. So
-# rather than inventing a way to communicate this info back to the core,
-# which would have required changes there as well, it was simpler just to
-# add the extra tables.
-#
# Why is there more than one type of range?
# This simplified things. There are some very specialized code points that
# have to be handled specially for output, such as Hangul syllable names.
@@ -322,13 +323,10 @@
# can't just take the intersection of two map tables, for example, as that
# is nonsensical.
#
-# There are no match tables generated for matches of the null string. These
-# would look like qr/\p{JSN=}/ currently without modifying the regex code.
-# Perhaps something like them could be added if necessary. The JSN does have
-# a real code point U+110B that maps to the null string, but it is a
-# contributory property, and therefore not output by default. And it's easily
-# handled so far by making the null string the default where it is a
-# possibility.
+# What about 'fate' and 'status'. The concept of a table's fate was created
+# late when it became clear that something more was needed. The difference
+# between this and 'status' is unclean, and could be improved if someone
+# wanted to spend the effort.
#
# DEBUGGING
#
@@ -342,12 +340,12 @@
#
# local $to_trace = 1 if main::DEBUG;
#
-# can be added to enable tracing in its lexical scope or until you insert
-# another line:
+# can be added to enable tracing in its lexical scope (plus dynamic) or until
+# you insert another line:
#
# local $to_trace = 0 if main::DEBUG;
#
-# then use a line like "trace $a, @b, %c, ...;
+# To actually trace, use a line like "trace $a, @b, %c, ...;
#
# Some of the more complex subroutines already have trace statements in them.
# Permanent trace statements should be like:
@@ -360,7 +358,8 @@
# my $debug_skip = 0;
#
# to 1, and every file whose object is in @input_file_objects and doesn't have
-# a, 'non_skip => 1,' in its constructor will be skipped.
+# a, 'non_skip => 1,' in its constructor will be skipped. However, skipping
+# Jamo.txt or UnicodeData.txt will likely cause fatal errors.
#
# To compare the output tables, it may be useful to specify the -annotate
# flag. This causes the tables to expand so there is one entry for each
@@ -445,7 +444,7 @@
# ones. The program should warn you if its name will clash with others on
# restrictive file systems, like DOS. If so, figure out a better name, and
# add lines to the README.perl file giving that. If the file is a character
-# property, it should be in the format that Unicode has by default
+# property, it should be in the format that Unicode has implicitly
# standardized for such files for the more recently introduced ones.
# If so, the Input_file constructor for @input_file_objects can just be the
# file name and release it first appeared in. If not, then it should be
@@ -478,10 +477,25 @@
#
# Here are some observations about some of the issues in early versions:
#
-# The number of code points in \p{alpha} halved in 2.1.9. It turns out that
-# the reason is that the CJK block starting at 4E00 was removed from PropList,
-# and was not put back in until 3.1.0
+# Prior to version 3.0, there were 3 character decompositions. These are not
+# handled by Unicode::Normalize, nor will it compile when presented a version
+# that has them. However, you can trivially get it to compile by simply
+# ignoring those decompositions, by changing the croak to a carp. At the time
+# of this writing, the line (in cpan/Unicode-Normalize/mkheader) reads
#
+# croak("Weird Canonical Decomposition of U+$h");
+#
+# Simply change to a carp. It will compile, but will not know about any three
+# character decomposition.
+
+# The number of code points in \p{alpha=True} halved in 2.1.9. It turns out
+# that the reason is that the CJK block starting at 4E00 was removed from
+# PropList, and was not put back in until 3.1.0. The Perl extension (the
+# single property name \p{alpha}) has the correct values. But the compound
+# form is simply not generated until 3.1, as it can be argued that prior to
+# this release, this was not an official property. The comments for
+# filter_old_style_proplist() give more details.
+#
# Unicode introduced the synonym Space for White_Space in 4.1. Perl has
# always had a \p{Space}. In release 3.2 only, they are not synonymous. The
# reason is that 3.2 introduced U+205F=medium math space, which was not
@@ -489,11 +503,11 @@
# reclassified it correctly.
#
# Another change between 3.2 and 4.0 is the CCC property value ATBL. In 3.2
-# this was erroneously a synonym for 202. In 4.0, ATB became 202, and ATBL
-# was left with no code points, as all the ones that mapped to 202 stayed
-# mapped to 202. Thus if your program used the numeric name for the class,
-# it would not have been affected, but if it used the mnemonic, it would have
-# been.
+# this was erroneously a synonym for 202 (it should be 200). In 4.0, ATB
+# became 202, and ATBL was left with no code points, as all the ones that
+# mapped to 202 stayed mapped to 202. Thus if your program used the numeric
+# name for the class, it would not have been affected, but if it used the
+# mnemonic, it would have been.
#
# \p{Script=Hrkt} (Katakana_Or_Hiragana) came in 4.0.1. Before that code
# points which eventually came to have this script property value, instead
@@ -505,6 +519,12 @@
# tries to do the best it can for earlier releases. It is done in
# process_PropertyAliases()
#
+# In version 2.1.2, the entry in UnicodeData.txt:
+# 0275;LATIN SMALL LETTER BARRED O;Ll;0;L;;;;;N;;;;019F;
+# should instead be
+# 0275;LATIN SMALL LETTER BARRED O;Ll;0;L;;;;;N;;;019F;;019F
+# Without this change, there are casing problems for this character.
+#
##############################################################################
my $UNDEF = ':UNDEF:'; # String to print out for undefined values in tracing
@@ -516,9 +536,15 @@
# non_skip => 1,
# to the constructor for those files you want processed when you set this.
# Files with a first version number of 0 are special: they are always
-# processed regardless of the state of this flag.
+# processed regardless of the state of this flag. Generally, Jamo.txt and
+# UnicodeData.txt must not be skipped if you want this program to not die
+# before normal completion.
my $debug_skip = 0;
+
+# Normally these are suppressed.
+my $write_Unicode_deprecated_tables = 0;
+
# Set to 1 to enable tracing.
our $to_trace = 0;
@@ -590,16 +616,16 @@
# This is for a rarely used development feature that allows you to compare two
# versions of the Unicode standard without having to deal with changes caused
-# by the code points introduced in the later verson. Change the 0 to a SINGLE
-# dotted Unicode release number (e.g. 2.1). Only code points introduced in
-# that release and earlier will be used; later ones are thrown away. You use
-# the version number of the earliest one you want to compare; then run this
-# program on directory structures containing each release, and compare the
-# outputs. These outputs will therefore include only the code points common
-# to both releases, and you can see the changes caused just by the underlying
-# release semantic changes. For versions earlier than 3.2, you must copy a
-# version of DAge.txt into the directory.
-my $string_compare_versions = DEBUG && 0; # e.g., v2.1;
+# by the code points introduced in the later version. Change the 0 to a
+# string containing a SINGLE dotted Unicode release number (e.g. "2.1"). Only
+# code points introduced in that release and earlier will be used; later ones
+# are thrown away. You use the version number of the earliest one you want to
+# compare; then run this program on directory structures containing each
+# release, and compare the outputs. These outputs will therefore include only
+# the code points common to both releases, and you can see the changes caused
+# just by the underlying release semantic changes. For versions earlier than
+# 3.2, you must copy a version of DAge.txt into the directory.
+my $string_compare_versions = DEBUG && 0; # e.g., "2.1";
my $compare_versions = DEBUG
&& $string_compare_versions
&& pack "C*", split /\./, $string_compare_versions;
@@ -621,6 +647,7 @@
$0 = File::Spec->canonpath($0);
my $make_test_script = 0; # ? Should we output a test script
+my $make_norm_test_script = 0; # ? Should we output a normalization test script
my $write_unchanged_files = 0; # ? Should we update the output files even if
# we don't think they have changed
my $use_directory = ""; # ? Should we chdir somewhere.
@@ -681,6 +708,10 @@
{
$make_test_script = 1;
}
+ elsif ($arg eq '-makenormtest')
+ {
+ $make_norm_test_script = 1;
+ }
elsif ($arg eq '-makelist') {
$make_list = 1;
}
@@ -729,8 +760,8 @@
-makelist : Rewrite the file list $file_list based on current setup
-annotate : Output an annotation for each character in the table files;
useful for debugging mktables, looking at diffs; but is slow,
- memory intensive; resulting tables are usable but slow and
- very large.
+ memory intensive; resulting tables are usable but are slow and
+ very large (and currently fail the Unicode::UCD.t tests).
-check A B : Executes $0 only if A and B are the same
END
}
@@ -779,6 +810,12 @@
push @tables_that_may_be_empty, 'Title' if $v_version lt v2.0.0;
push @tables_that_may_be_empty, 'Script=Katakana_Or_Hiragana'
if $v_version ge v4.1.0;
+push @tables_that_may_be_empty, 'Script_Extensions=Katakana_Or_Hiragana'
+ if $v_version ge v6.0.0;
+push @tables_that_may_be_empty, 'Grapheme_Cluster_Break=Prepend'
+ if $v_version ge v6.1.0;
+push @tables_that_may_be_empty, 'Canonical_Combining_Class=CCC133'
+ if $v_version ge v6.2.0;
# The lists below are hashes, so the key is the item in the list, and the
# value is the reason why it is in the list. This makes generation of
@@ -842,6 +879,7 @@
# Enum values for to_output_map() method in the Map_Table package.
my $EXTERNAL_MAP = 1;
my $INTERNAL_MAP = 2;
+my $OUTPUT_ADJUSTED = 3;
# To override computed values for writing the map tables for these properties.
# The default for enum map tables is to write them out, so that the Unicode
@@ -849,21 +887,26 @@
# for any code point is available in a more compact form.
my %global_to_output_map = (
# Needed by UCD.pm, but don't want to publicize that it exists, so won't
- # get stuck supporting it if things change. Sinc it is a STRING property,
- # it normally would be listed in the pod, but INTERNAL_MAP suppresses
- # that.
+ # get stuck supporting it if things change. Since it is a STRING
+ # property, it normally would be listed in the pod, but INTERNAL_MAP
+ # suppresses that.
Unicode_1_Name => $INTERNAL_MAP,
Present_In => 0, # Suppress, as easily computed from Age
- Canonical_Combining_Class => 0, # Duplicate of CombiningClass.pl
Block => 0, # Suppress, as Blocks.txt is retained.
+
+ # Suppress, as mapping can be found instead from the
+ # Perl_Decomposition_Mapping file
+ Decomposition_Type => 0,
);
# Properties that this program ignores.
-my @unimplemented_properties = (
-'Unicode_Radical_Stroke' # Remove if changing to handle this one.
-);
+my @unimplemented_properties;
+# With this release, it is automatically handled if the Unihan db is
+# downloaded
+push @unimplemented_properties, 'Unicode_Radical_Stroke' if $v_version le v5.2.0;
+
# There are several types of obsolete properties defined by Unicode. These
# must be hand-edited for every new Unicode release.
my %why_deprecated; # Generates a deprecated warning message if used.
@@ -890,6 +933,10 @@
'Other_Lowercase' => $contributory,
'Other_Math' => $contributory,
'Other_Uppercase' => $contributory,
+ 'Expands_On_NFC' => $why_no_expand,
+ 'Expands_On_NFD' => $why_no_expand,
+ 'Expands_On_NFKC' => $why_no_expand,
+ 'Expands_On_NFKD' => $why_no_expand,
);
%why_suppressed = (
@@ -897,28 +944,48 @@
# contains the same information, but without the algorithmically
# determinable Hangul syllables'. This file is not published, so it's
# existence is not noted in the comment.
- 'Decomposition_Mapping' => 'Accessible via Unicode::Normalize',
+ 'Decomposition_Mapping' => 'Accessible via Unicode::Normalize or Unicode::UCD::prop_invmap()',
- 'ISO_Comment' => 'Apparently no demand for it, but can access it through Unicode::UCD::charinfo. Obsoleted, and code points for it removed in Unicode 5.2',
+ 'Indic_Matra_Category' => "Provisional",
+ 'Indic_Syllabic_Category' => "Provisional",
- 'Simple_Case_Folding' => "$simple. Can access this through Unicode::UCD::casefold",
- 'Simple_Lowercase_Mapping' => "$simple. Can access this through Unicode::UCD::charinfo",
- 'Simple_Titlecase_Mapping' => "$simple. Can access this through Unicode::UCD::charinfo",
- 'Simple_Uppercase_Mapping' => "$simple. Can access this through Unicode::UCD::charinfo",
+ # Don't suppress ISO_Comment, as otherwise special handling is needed
+ # to differentiate between it and gc=c, which can be written as 'isc',
+ # which is the same characters as ISO_Comment's short name.
- 'Name' => "Accessible via 'use charnames;'",
- 'Name_Alias' => "Accessible via 'use charnames;'",
+ 'Name' => "Accessible via \\N{...} or 'use charnames;' or Unicode::UCD::prop_invmap()",
+ 'Simple_Case_Folding' => "$simple. Can access this through Unicode::UCD::casefold or Unicode::UCD::prop_invmap()",
+ 'Simple_Lowercase_Mapping' => "$simple. Can access this through Unicode::UCD::charinfo or Unicode::UCD::prop_invmap()",
+ 'Simple_Titlecase_Mapping' => "$simple. Can access this through Unicode::UCD::charinfo or Unicode::UCD::prop_invmap()",
+ 'Simple_Uppercase_Mapping' => "$simple. Can access this through Unicode::UCD::charinfo or Unicode::UCD::prop_invmap()",
+
FC_NFKC_Closure => 'Supplanted in usage by NFKC_Casefold; otherwise not useful',
- Expands_On_NFC => $why_no_expand,
- Expands_On_NFD => $why_no_expand,
- Expands_On_NFKC => $why_no_expand,
- Expands_On_NFKD => $why_no_expand,
);
- # The following are suppressed because they were made contributory or
- # deprecated by Unicode before Perl ever thought about supporting them.
- foreach my $property ('Jamo_Short_Name', 'Grapheme_Link') {
+ foreach my $property (
+
+ # The following are suppressed because they were made contributory
+ # or deprecated by Unicode before Perl ever thought about
+ # supporting them.
+ 'Jamo_Short_Name',
+ 'Grapheme_Link',
+ 'Expands_On_NFC',
+ 'Expands_On_NFD',
+ 'Expands_On_NFKC',
+ 'Expands_On_NFKD',
+
+ # The following are suppressed because they have been marked
+ # as deprecated for a sufficient amount of time
+ 'Other_Alphabetic',
+ 'Other_Default_Ignorable_Code_Point',
+ 'Other_Grapheme_Extend',
+ 'Other_ID_Continue',
+ 'Other_ID_Start',
+ 'Other_Lowercase',
+ 'Other_Math',
+ 'Other_Uppercase',
+ ) {
$why_suppressed{$property} = $why_deprecated{$property};
}
@@ -929,6 +996,13 @@
}
}
+if ($write_Unicode_deprecated_tables) {
+ foreach my $property (keys %why_suppressed) {
+ delete $why_suppressed{$property} if $property =~
+ / ^ Other | Grapheme /x;
+ }
+}
+
if ($v_version ge 4.0.0) {
$why_stabilized{'Hyphen'} = 'Use the Line_Break property instead; see www.unicode.org/reports/tr14';
if ($v_version ge 6.0.0) {
@@ -938,14 +1012,18 @@
if ($v_version ge 5.2.0 && $v_version lt 6.0.0) {
$why_obsolete{'ISO_Comment'} = 'Code points for it have been removed';
if ($v_version ge 6.0.0) {
- $why_deprecated{'ISO_Comment'} = 'No longer needed for chart generation; otherwise not useful, and code points for it have been removed';
+ $why_deprecated{'ISO_Comment'} = 'No longer needed for Unicode\'s internal chart generation; otherwise not useful, and code points for it have been removed';
}
}
# Probably obsolete forever
if ($v_version ge v4.1.0) {
- $why_suppressed{'Script=Katakana_Or_Hiragana'} = 'Obsolete. All code points previously matched by this have been moved to "Script=Common"';
+ $why_suppressed{'Script=Katakana_Or_Hiragana'} = 'Obsolete. All code points previously matched by this have been moved to "Script=Common".';
}
+if ($v_version ge v6.0.0) {
+ $why_suppressed{'Script=Katakana_Or_Hiragana'} .= ' Consider instead using "Script_Extensions=Katakana" or "Script_Extensions=Hiragana" (or both)';
+ $why_suppressed{'Script_Extensions=Katakana_Or_Hiragana'} = 'All code points that would be matched by this are matched by either "Script_Extensions=Katakana" or "Script_Extensions=Hiragana"';
+}
# This program can create files for enumerated-like properties, such as
# 'Numeric_Type'. This file would be the same format as for a string
@@ -956,9 +1034,10 @@
my @output_mapped_properties = split "\n", <<END;
END
-# If you are using the Unihan database, you need to add the properties that
-# you want to extract from it to this table. For your convenience, the
-# properties in the 6.0 PropertyAliases.txt file are listed, commented out
+# If you are using the Unihan database in a Unicode version before 5.2, you
+# need to add the properties that you want to extract from it to this table.
+# For your convenience, the properties in the 6.0 PropertyAliases.txt file are
+# listed, commented out
my @cjk_properties = split "\n", <<'END';
#cjkAccountingNumeric; kAccountingNumeric
#cjkOtherNumeric; kOtherNumeric
@@ -978,7 +1057,7 @@
# Similarly for the property values. For your convenience, the lines in the
# 6.0 PropertyAliases.txt file are listed. Just remove the first BUT NOT both
-# '#' marks
+# '#' marks (for Unicode versions before 5.2)
my @cjk_property_values = split "\n", <<'END';
## @missing: 0000..10FFFF; cjkAccountingNumeric; NaN
## @missing: 0000..10FFFF; cjkCompatibilityVariant; <code point>
@@ -999,7 +1078,7 @@
# The input files don't list every code point. Those not listed are to be
# defaulted to some value. Below are hard-coded what those values are for
# non-binary properties as of 5.1. Starting in 5.0, there are
-# machine-parsable comment lines in the files the give the defaults; so this
+# machine-parsable comment lines in the files that give the defaults; so this
# list shouldn't have to be extended. The claim is that all missing entries
# for binary properties will default to 'N'. Unicode tried to change that in
# 5.2, but the beta period produced enough protest that they backed off.
@@ -1049,23 +1128,37 @@
Word_Break => 'Other',
);
-# Below are files that Unicode furnishes, but this program ignores, and why
+# Below are files that Unicode furnishes, but this program ignores, and why.
+# NormalizationCorrections.txt requires some more explanation. It documents
+# the cumulative fixes to erroneous normalizations in earlier Unicode
+# versions. Its main purpose is so that someone running on an earlier version
+# can use this file to override what got published in that earlier release.
+# It would be easy for mktables to read and handle this file. But all the
+# corrections in it should already be in the other files for the release it
+# is. To get it to actually mean something useful, someone would have to be
+# using an earlier Unicode release, and copy it to the files for that release
+# and recomplile. So far there has been no demand to do that, so this hasn't
+# been implemented.
my %ignored_files = (
- 'CJKRadicals.txt' => 'Unihan data',
- 'Index.txt' => 'An index, not actual data',
- 'NamedSqProv.txt' => 'Not officially part of the Unicode standard; Append it to NamedSequences.txt if you want to process the contents.',
- 'NamesList.txt' => 'Just adds commentary',
- 'NormalizationCorrections.txt' => 'Data is already in other files.',
- 'Props.txt' => 'Adds nothing to PropList.txt; only in very early releases',
- 'ReadMe.txt' => 'Just comments',
- 'README.TXT' => 'Just comments',
- 'StandardizedVariants.txt' => 'Only for glyph changes, not a Unicode character property. Does not fit into current scheme where one code point is mapped',
- 'EmojiSources.txt' => 'Not of general utility: for Japanese legacy cell-phone applications',
- 'IndicMatraCategory.txt' => 'Provisional',
- 'IndicSyllabicCategory.txt' => 'Provisional',
- 'ScriptExtensions.txt' => 'Provisional',
+ 'CJKRadicals.txt' => 'Maps the kRSUnicode property values to corresponding code points',
+ 'Index.txt' => 'Alphabetical index of Unicode characters',
+ 'NamedSqProv.txt' => 'Named sequences proposed for inclusion in a later version of the Unicode Standard; if you need them now, you can append this file to F<NamedSequences.txt> and recompile perl',
+ 'NamesList.txt' => 'Annotated list of characters',
+ 'NormalizationCorrections.txt' => 'Documentation of corrections already incorporated into the Unicode data base',
+ 'Props.txt' => 'Only in very early releases; is a subset of F<PropList.txt> (which is used instead)',
+ 'ReadMe.txt' => 'Documentation',
+ 'StandardizedVariants.txt' => 'Certain glyph variations for character display are standardized. This lists the non-Unihan ones; the Unihan ones are also not used by Perl, and are in a separate Unicode data base L<http://www.unicode.org/ivd>',
+ 'EmojiSources.txt' => 'Maps certain Unicode code points to their legacy Japanese cell-phone values',
+ 'USourceData.txt' => 'Documentation of status and cross reference of proposals for encoding by Unicode of Unihan characters',
+ 'USourceData.pdf' => 'Documentation of status and cross reference of proposals for encoding by Unicode of Unihan characters',
+ 'auxiliary/WordBreakTest.html' => 'Documentation of validation tests',
+ 'auxiliary/SentenceBreakTest.html' => 'Documentation of validation tests',
+ 'auxiliary/GraphemeBreakTest.html' => 'Documentation of validation tests',
+ 'auxiliary/LineBreakTest.html' => 'Documentation of validation tests',
);
+my %skipped_files; # List of files that we skip
+
### End of externally interesting definitions, except for @input_file_objects
my $HEADER=<<"EOF";
@@ -1074,12 +1167,12 @@
# database, Version $string_version. Any changes made here will be lost!
EOF
-my $INTERNAL_ONLY=<<"EOF";
+my $INTERNAL_ONLY_HEADER = <<"EOF";
# !!!!!!! INTERNAL PERL USE ONLY !!!!!!!
-# This file is for internal use by the Perl program only. The format and even
-# the name or existence of this file are subject to change without notice.
-# Don't use it directly.
+# This file is for internal use by core Perl only. The format and even the
+# name or existence of this file are subject to change without notice. Don't
+# use it directly.
EOF
my $DEVELOPMENT_ONLY=<<"EOF";
@@ -1091,15 +1184,19 @@
EOF
-my $LAST_UNICODE_CODEPOINT_STRING = "10FFFF";
-my $LAST_UNICODE_CODEPOINT = hex $LAST_UNICODE_CODEPOINT_STRING;
-my $MAX_UNICODE_CODEPOINTS = $LAST_UNICODE_CODEPOINT + 1;
+my $MAX_UNICODE_CODEPOINT_STRING = "10FFFF";
+my $MAX_UNICODE_CODEPOINT = hex $MAX_UNICODE_CODEPOINT_STRING;
+my $MAX_UNICODE_CODEPOINTS = $MAX_UNICODE_CODEPOINT + 1;
# Matches legal code point. 4-6 hex numbers, If there are 6, the first
# two must be 10; if there are 5, the first must not be a 0. Written this way
-# to decrease backtracking
-my $code_point_re =
- qr/ \b (?: 10[0-9A-F]{4} | [1-9A-F][0-9A-F]{4} | [0-9A-F]{4} ) \b/x;
+# to decrease backtracking. The first regex allows the code point to be at
+# the end of a word, but to work properly, the word shouldn't end with a valid
+# hex character. The second one won't match a code point at the end of a
+# word, and doesn't have the run-on issue
+my $run_on_code_point_re =
+ qr/ (?: 10[0-9A-F]{4} | [1-9A-F][0-9A-F]{4} | [0-9A-F]{4} ) \b/x;
+my $code_point_re = qr/\b$run_on_code_point_re/;
# This matches the beginning of the line in the Unicode db files that give the
# defaults for code points not listed (i.e., missing) in the file. The code
@@ -1106,7 +1203,7 @@
# depends on this ending with a semi-colon, so it can assume it is a valid
# field when the line is split() by semi-colons
my $missing_defaults_prefix =
- qr/^#\s+\@missing:\s+0000\.\.$LAST_UNICODE_CODEPOINT_STRING\s*;/;
+ qr/^#\s+\@missing:\s+0000\.\.$MAX_UNICODE_CODEPOINT_STRING\s*;/;
# Property types. Unicode has more types, but these are sufficient for our
# purposes.
@@ -1113,8 +1210,12 @@
my $UNKNOWN = -1; # initialized to illegal value
my $NON_STRING = 1; # Either binary or enum
my $BINARY = 2;
-my $ENUM = 3; # Include catalog
-my $STRING = 4; # Anything else: string or misc
+my $FORCED_BINARY = 3; # Not a binary property, but, besides its normal
+ # tables, additional true and false tables are
+ # generated so that false is anything matching the
+ # default value, and true is everything else.
+my $ENUM = 4; # Include catalog
+my $STRING = 5; # Anything else: string or misc
# Some input files have lines that give default values for code points not
# contained in the file. Sometimes these should be ignored.
@@ -1153,17 +1254,16 @@
my $IF_NOT_EQUIVALENT = 1; # Replace only under certain conditions; details in
# the comments at the subroutine definition.
my $UNCONDITIONALLY = 2; # Replace without conditions.
-my $MULTIPLE = 4; # Don't replace, but add a duplicate record if
+my $MULTIPLE_BEFORE = 4; # Don't replace, but add a duplicate record if
# already there
-my $CROAK = 5; # Die with an error if is already there
+my $MULTIPLE_AFTER = 5; # Don't replace, but add a duplicate record if
+ # already there
+my $CROAK = 6; # Die with an error if is already there
# Flags to give property statuses. The phrases are to remind maintainers that
# if the flag is changed, the indefinite article referring to it in the
# documentation may need to be as well.
my $NORMAL = "";
-my $SUPPRESSED = 'z'; # The character should never actually be seen, since
- # it is suppressed
-my $PLACEHOLDER = 'P'; # Implies no pod entry generated
my $DEPRECATED = 'D';
my $a_bold_deprecated = "a 'B<$DEPRECATED>'";
my $A_bold_deprecated = "A 'B<$DEPRECATED>'";
@@ -1182,12 +1282,28 @@
my %status_past_participles = (
$DISCOURAGED => 'discouraged',
- $SUPPRESSED => 'should never be generated',
$STABILIZED => 'stabilized',
$OBSOLETE => 'obsolete',
$DEPRECATED => 'deprecated',
);
+# Table fates. These are somewhat ordered, so that fates < $MAP_PROXIED should be
+# externally documented.
+my $ORDINARY = 0; # The normal fate.
+my $MAP_PROXIED = 1; # The map table for the property isn't written out,
+ # but there is a file written that can be used to
+ # reconstruct this table
+my $INTERNAL_ONLY = 2; # The file for this table is written out, but it is
+ # for Perl's internal use only
+my $SUPPRESSED = 3; # The file for this table is not written out, and as a
+ # result, we don't bother to do many computations on
+ # it.
+my $PLACEHOLDER = 4; # Like $SUPPRESSED, but we go through all the
+ # computations anyway, as the values are needed for
+ # things to work. This happens when we have Perl
+ # extensions that depend on Unicode tables that
+ # wouldn't normally be in a given Unicode version.
+
# The format of the values of the tables:
my $EMPTY_FORMAT = "";
my $BINARY_FORMAT = 'b';
@@ -1197,7 +1313,9 @@
my $HEX_FORMAT = 'x';
my $RATIONAL_FORMAT = 'r';
my $STRING_FORMAT = 's';
+my $ADJUST_FORMAT = 'a';
my $DECOMP_STRING_FORMAT = 'c';
+my $STRING_WHITE_SPACE_LIST = 'sw';
my %map_table_formats = (
$BINARY_FORMAT => 'binary',
@@ -1204,10 +1322,12 @@
$DECIMAL_FORMAT => 'single decimal digit',
$FLOAT_FORMAT => 'floating point number',
$INTEGER_FORMAT => 'integer',
- $HEX_FORMAT => 'positive hex whole number; a code point',
+ $HEX_FORMAT => 'non-negative hex whole number; a code point',
$RATIONAL_FORMAT => 'rational: an integer or a fraction',
$STRING_FORMAT => 'string',
+ $ADJUST_FORMAT => 'some entries need adjustment',
$DECOMP_STRING_FORMAT => 'Perl\'s internal (Normalize.pm) decomposition mapping',
+ $STRING_WHITE_SPACE_LIST => 'string, but some elements are interpreted as a list; white space occurs only as list item separators'
);
# Unicode didn't put such derived files in a separate directory at first.
@@ -1216,12 +1336,33 @@
my $AUXILIARY = 'auxiliary';
# Hashes that will eventually go into Heavy.pl for the use of utf8_heavy.pl
+# and into UCD.pl for the use of UCD.pm
my %loose_to_file_of; # loosely maps table names to their respective
# files
my %stricter_to_file_of; # same; but for stricter mapping.
+my %loose_property_to_file_of; # Maps a loose property name to its map file
+my %file_to_swash_name; # Maps the file name to its corresponding key name
+ # in the hash %utf8::SwashInfo
my %nv_floating_to_rational; # maps numeric values floating point numbers to
# their rational equivalent
-my %loose_property_name_of; # Loosely maps property names to standard form
+my %loose_property_name_of; # Loosely maps (non_string) property names to
+ # standard form
+my %string_property_loose_to_name; # Same, for string properties.
+my %loose_defaults; # keys are of form "prop=value", where 'prop' is
+ # the property name in standard loose form, and
+ # 'value' is the default value for that property,
+ # also in standard loose form.
+my %loose_to_standard_value; # loosely maps table names to the canonical
+ # alias for them
+my %ambiguous_names; # keys are alias names (in standard form) that
+ # have more than one possible meaning.
+my %prop_aliases; # Keys are standard property name; values are each
+ # one's aliases
+my %prop_value_aliases; # Keys of top level are standard property name;
+ # values are keys to another hash, Each one is
+ # one of the property's values, in standard form.
+ # The values are that prop-val's aliases.
+my %ucd_pod; # Holds entries that will go into the UCD section of the pod
# Most properties are immune to caseless matching, otherwise you would get
# nonsensical results, as properties are a function of a code point, not
@@ -1260,6 +1401,31 @@
my %Jamo_V; # Vowels
my %Jamo_T; # Trailing consonants
+# For code points whose name contains its ordinal as a '-ABCD' suffix.
+# The key is the base name of the code point, and the value is an
+# array giving all the ranges that use this base name. Each range
+# is actually a hash giving the 'low' and 'high' values of it.
+my %names_ending_in_code_point;
+my %loose_names_ending_in_code_point; # Same as above, but has blanks, dashes
+ # removed from the names
+# Inverse mapping. The list of ranges that have these kinds of
+# names. Each element contains the low, high, and base names in an
+# anonymous hash.
+my @code_points_ending_in_code_point;
+
+# To hold Unicode's normalization test suite
+my @normalization_tests;
+
+# Boolean: does this Unicode version have the hangul syllables, and are we
+# writing out a table for them?
+my $has_hangul_syllables = 0;
+
+# Does this Unicode version have code points whose names end in their
+# respective code points, and are we writing out a table for them? 0 for no;
+# otherwise points to first property that a table is needed for them, so that
+# if multiple tables are needed, we don't create duplicates
+my $needing_code_points_ending_in_code_point = 0;
+
my @backslash_X_tests; # List of tests read in for testing \X
my @unhandled_properties; # Will contain a list of properties found in
# the input that we didn't process.
@@ -1284,6 +1450,8 @@
my $block;
my $perl_charname;
my $print;
+my $Any;
+my $script;
# Are there conflicting names because of beginning with 'In_', or 'Is_'
my $has_In_conflicts = 0;
@@ -1374,20 +1542,16 @@
# point of the range.
my $end;
if (! $viacode[$i]) {
- if ($gc-> table('Surrogate')->contains($i)) {
- $viacode[$i] = 'Surrogate';
- $annotate_char_type[$i] = $SURROGATE_TYPE;
- $printable[$i] = 0;
- $end = $gc->table('Surrogate')->containing_range($i)->end;
- }
- elsif ($gc-> table('Private_use')->contains($i)) {
+ my $nonchar;
+ if ($gc-> table('Private_use')->contains($i)) {
$viacode[$i] = 'Private Use';
$annotate_char_type[$i] = $PRIVATE_USE_TYPE;
$printable[$i] = 0;
$end = $gc->table('Private_Use')->containing_range($i)->end;
}
- elsif (Property::property_ref('Noncharacter_Code_Point')-> table('Y')->
- contains($i))
+ elsif ((defined ($nonchar =
+ Property::property_ref('Noncharacter_Code_Point'))
+ && $nonchar->table('Y')->contains($i)))
{
$viacode[$i] = 'Noncharacter';
$annotate_char_type[$i] = $NONCHARACTER_TYPE;
@@ -1396,25 +1560,41 @@
containing_range($i)->end;
}
elsif ($gc-> table('Control')->contains($i)) {
- $viacode[$i] = 'Control';
+ $viacode[$i] = property_ref('Name_Alias')->value_of($i) || 'Control';
$annotate_char_type[$i] = $CONTROL_TYPE;
$printable[$i] = 0;
- $end = 0x81 if $i == 0x80; # Hard-code this one known case
}
elsif ($gc-> table('Unassigned')->contains($i)) {
- $viacode[$i] = 'Unassigned, block=' . $block-> value_of($i);
$annotate_char_type[$i] = $UNASSIGNED_TYPE;
$printable[$i] = 0;
+ if ($v_version lt v2.0.0) { # No blocks in earliest releases
+ $viacode[$i] = 'Unassigned';
+ $end = $gc-> table('Unassigned')->containing_range($i)->end;
+ }
+ else {
+ $viacode[$i] = 'Unassigned, block=' . $block-> value_of($i);
- # Because we name the unassigned by the blocks they are in, it
- # can't go past the end of that block, and it also can't go past
- # the unassigned range it is in. The special table makes sure
- # that the non-characters, which are unassigned, are separated
- # out.
- $end = min($block->containing_range($i)->end,
- $unassigned_sans_noncharacters-> containing_range($i)->
- end);
+ # Because we name the unassigned by the blocks they are in, it
+ # can't go past the end of that block, and it also can't go
+ # past the unassigned range it is in. The special table makes
+ # sure that the non-characters, which are unassigned, are
+ # separated out.
+ $end = min($block->containing_range($i)->end,
+ $unassigned_sans_noncharacters->
+ containing_range($i)->end);
+ }
}
+ elsif ($v_version lt v2.0.0) { # No surrogates in earliest releases
+ $viacode[$i] = $gc->value_of($i);
+ $annotate_char_type[$i] = $UNKNOWN_TYPE;
+ $printable[$i] = 0;
+ }
+ elsif ($gc-> table('Surrogate')->contains($i)) {
+ $viacode[$i] = 'Surrogate';
+ $annotate_char_type[$i] = $SURROGATE_TYPE;
+ $printable[$i] = 0;
+ $end = $gc->table('Surrogate')->containing_range($i)->end;
+ }
else {
Carp::my_carp_bug("Can't figure out how to annotate "
. sprintf("U+%04X", $i)
@@ -1862,10 +2042,10 @@
# basically be a while(next_line()) {...} loop.
#
# You can also set up handlers to
-# 1) call before the first line is read for pre processing
+# 1) call before the first line is read, for pre processing
# 2) call to adjust each line of the input before the main handler gets them
# 3) call upon EOF before the main handler exits its loop
-# 4) call at the end for post processing
+# 4) call at the end, for post processing
#
# $_ is used to store the input line, and is to be filtered by the
# each_line_handler()s. So, if the format of the line is not in the desired
@@ -1916,7 +2096,7 @@
my %property;
# name of property this file is for. defaults to none, meaning not
# applicable, or is otherwise determinable, for example, from each line.
- main::set_access('property', \%property, qw{ c });
+ main::set_access('property', \%property, qw{ c r });
my %optional;
# If this is true, the file is optional. If not present, no warning is
@@ -1931,12 +2111,15 @@
main::set_access('non_skip', \%non_skip, 'c');
my %skip;
- # This is used to skip processing of this input file semi-permanently.
- # It is used for files that we aren't planning to process anytime soon,
- # but want to allow to be in the directory and not raise a message that we
- # are not handling. Mostly for test files. This is in contrast to the
- # non_skip element, which is supposed to be used very temporarily for
- # debugging. Sets 'optional' to 1
+ # This is used to skip processing of this input file semi-permanently,
+ # when it evaluates to true. The value should be the reason the file is
+ # being skipped. It is used for files that we aren't planning to process
+ # anytime soon, but want to allow to be in the directory and not raise a
+ # message that we are not handling. Mostly for test files. This is in
+ # contrast to the non_skip element, which is supposed to be used very
+ # temporarily for debugging. Sets 'optional' to 1. Also, files that we
+ # pretty much will never look at can be placed in the global
+ # %ignored_files instead. Ones used here will be added to %skipped files
main::set_access('skip', \%skip, 'c');
my %each_line_handler;
@@ -2059,7 +2242,12 @@
print "Warning: " . __PACKAGE__ . " constructor for $file{$addr} has useless 'non_skip' in it\n";
}
- $optional{$addr} = 1 if $skip{$addr};
+ # If skipping, set to optional, and add to list of ignored files,
+ # including its reason
+ if ($skip{$addr}) {
+ $optional{$addr} = 1;
+ $skipped_files{$file{$addr}} = $skip{$addr}
+ }
return $self;
}
@@ -2069,6 +2257,7 @@
fallback => 0,
qw("") => "_operator_stringify",
"." => \&main::_operator_dot,
+ ".=" => \&main::_operator_dot_equal,
;
sub _operator_stringify {
@@ -2146,7 +2335,7 @@
# its name
if ($seen_non_extracted_non_age) {
if ($file =~ /$EXTRACTED/i) {
- Carp::my_carp_bug(join_lines(<<END
+ Carp::my_carp_bug(main::join_lines(<<END
$file should be processed just after the 'Prop...Alias' files, and before
anything not in the $EXTRACTED_DIR directory. Proceeding, but the results may
have subtle problems
@@ -2170,8 +2359,8 @@
# they are deleted from the hash, so any that remain at the
# end of the program are files that we didn't process.
my $fkey = File::Spec->rel2abs($file);
- my $expecting = delete $potential_files{$fkey};
- $expecting = delete $potential_files{lc($fkey)} unless defined $expecting;
+ my $expecting = delete $potential_files{lc($fkey)};
+
Carp::my_carp("Was not expecting '$file'.") if
! $expecting
&& ! defined $handle{$addr};
@@ -2334,7 +2523,8 @@
|| @defaults > 2
|| ($default =~ /^</
&& $default !~ /^<code *point>$/i
- && $default !~ /^<none>$/i))
+ && $default !~ /^<none>$/i
+ && $default !~ /^<script>$/i))
{
$self->carp_bad_line("Unrecognized \@missing line: $_. Assuming no missing entries");
}
@@ -2355,7 +2545,16 @@
elsif ($default =~ /^<code *point>$/i) {
$default = $CODE_POINT;
}
+ elsif ($default =~ /^<script>$/i) {
+ # Special case this one. Currently is from
+ # ScriptExtensions.txt, and means for all unlisted
+ # code points, use their Script property values.
+ # For the code points not listed in that file, the
+ # default value is 'Unknown'.
+ $default = "Unknown";
+ }
+
# Store them as a sub-arrays with both components.
push @{$missings{$addr}}, [ $default, $property ];
}
@@ -2619,27 +2818,29 @@
main::set_access('name', \%name, 'r');
my %loose_match;
- # Determined by the constructor code if this name should match loosely or
- # not. The constructor parameters can override this, but it isn't fully
- # implemented, as should have ability to override Unicode one's via
- # something like a set_loose_match()
+ # Should this name match loosely or not.
main::set_access('loose_match', \%loose_match, 'r');
- my %make_pod_entry;
- # Some aliases should not get their own entries because they are covered
- # by a wild-card, and some we want to discourage use of. Binary
- main::set_access('make_pod_entry', \%make_pod_entry, 'r');
+ my %make_re_pod_entry;
+ # Some aliases should not get their own entries in the re section of the
+ # pod, because they are covered by a wild-card, and some we want to
+ # discourage use of. Binary
+ main::set_access('make_re_pod_entry', \%make_re_pod_entry, 'r', 's');
+ my %ucd;
+ # Is this documented to be accessible via Unicode::UCD
+ main::set_access('ucd', \%ucd, 'r', 's');
+
my %status;
# Aliases have a status, like deprecated, or even suppressed (which means
# they don't appear in documentation). Enum
main::set_access('status', \%status, 'r');
- my %externally_ok;
+ my %ok_as_filename;
# Similarly, some aliases should not be considered as usable ones for
# external use, such as file names, or we don't want documentation to
# recommend them. Boolean
- main::set_access('externally_ok', \%externally_ok, 'r');
+ main::set_access('ok_as_filename', \%ok_as_filename, 'r');
sub new {
my $class = shift;
@@ -2649,14 +2850,15 @@
$name{$addr} = shift;
$loose_match{$addr} = shift;
- $make_pod_entry{$addr} = shift;
- $externally_ok{$addr} = shift;
+ $make_re_pod_entry{$addr} = shift;
+ $ok_as_filename{$addr} = shift;
$status{$addr} = shift;
+ $ucd{$addr} = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
# Null names are never ok externally
- $externally_ok{$addr} = 0 if $name{$addr} eq "";
+ $ok_as_filename{$addr} = 0 if $name{$addr} eq "";
return $self;
}
@@ -2722,10 +2924,6 @@
Carp::carp_extra_args(\%args) if main::DEBUG && %args;
- if (! $type{$addr}) {
- $standard_form{$addr} = main::standardize($value);
- }
-
return $self;
}
@@ -2733,6 +2931,7 @@
fallback => 0,
qw("") => "_operator_stringify",
"." => \&main::_operator_dot,
+ ".=" => \&main::_operator_dot_equal,
;
sub _operator_stringify {
@@ -2754,8 +2953,11 @@
}
sub standard_form {
- # The standard form is the value itself if the standard form is
- # undefined (that is if the value is special)
+ # Calculate the standard form only if needed, and cache the result.
+ # The standard form is the value itself if the type is special.
+ # This represents a considerable CPU and memory saving - at the time
+ # of writing there are 368676 non-special objects, but the standard
+ # form is only requested for 22047 of them - ie about 6%.
my $self = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
@@ -2763,7 +2965,10 @@
my $addr = do { no overloading; pack 'J', $self; };
return $standard_form{$addr} if defined $standard_form{$addr};
- return $value{$addr};
+
+ my $value = $value{$addr};
+ return $value if $type{$addr};
+ return $standard_form{$addr} = main::standardize($value);
}
sub dump {
@@ -2814,6 +3019,10 @@
our $addr;
+ # Max is initialized to a negative value that isn't adjacent to 0, for
+ # simpler tests
+ my $max_init = -2;
+
main::setup_package();
my %ranges;
@@ -2869,9 +3078,7 @@
Carp::carp_extra_args(\%args) if main::DEBUG && %args;
- # Max is initialized to a negative value that isn't adjacent to 0,
- # for simpler tests
- $max{$addr} = -2;
+ $max{$addr} = $max_init;
$_search_ranges_cache{$addr} = 0;
$ranges{$addr} = [];
@@ -2883,6 +3090,7 @@
fallback => 0,
qw("") => "_operator_stringify",
"." => \&main::_operator_dot,
+ ".=" => \&main::_operator_dot_equal,
;
sub _operator_stringify {
@@ -2899,7 +3107,7 @@
# either a constructor or a method. If called as a method, the result
# will be a new() instance of the calling object, containing the union
# of that object with the other parameter's code points; if called as
- # a constructor, the first parameter gives the class the new object
+ # a constructor, the first parameter gives the class that the new object
# should be, and the second parameter gives the code points to go into
# it.
# In either case, there are two parameters looked at by this routine;
@@ -2911,8 +3119,8 @@
# just a single code point.
#
# If they are ranges, this routine doesn't make any effort to preserve
- # the range values of one input over the other. Therefore this base
- # class should not allow _union to be called from other than
+ # the range values and types of one input over the other. Therefore
+ # this base class should not allow _union to be called from other than
# initialization code, so as to prevent two tables from being added
# together where the range values matter. The general form of this
# routine therefore belongs in a derived class, but it was moved here
@@ -2919,6 +3127,12 @@
# to avoid duplication of code. The failure to overload this in this
# class keeps it safe.
#
+ # It does make the effort during initialization to accept tables with
+ # multiple values for the same code point, and to preserve the order
+ # of these. If there is only one input range or range set, it doesn't
+ # sort (as it should already be sorted to the desired order), and will
+ # accept multiple values per code point. Otherwise it will merge
+ # multiple values into a single one.
my $self;
my @args; # Arguments to pass to the constructor
@@ -2939,6 +3153,7 @@
# Accumulate all records from both lists.
my @records;
+ my $input_count = 0;
for my $arg (@args) {
#local $to_trace = 0 if main::DEBUG;
trace "argument = $arg" if main::DEBUG && $to_trace;
@@ -2948,21 +3163,25 @@
no overloading;
$message .= $owner_name_of{pack 'J', $self};
}
- Carp::my_carp_bug($message .= "Undefined argument to _union. No union done.");
+ Carp::my_carp_bug($message . "Undefined argument to _union. No union done.");
return;
}
+
$arg = [ $arg ] if ! ref $arg;
my $type = ref $arg;
if ($type eq 'ARRAY') {
foreach my $element (@$arg) {
push @records, Range->new($element, $element);
+ $input_count++;
}
}
elsif ($arg->isa('Range')) {
push @records, $arg;
+ $input_count++;
}
elsif ($arg->can('ranges')) {
push @records, $arg->ranges;
+ $input_count++;
}
else {
my $message = "";
@@ -2978,7 +3197,8 @@
# Sort with the range containing the lowest ordinal first, but if
# two ranges start at the same code point, sort with the bigger range
# of the two first, because it takes fewer cycles.
- @records = sort { ($a->start <=> $b->start)
+ if ($input_count > 1) {
+ @records = sort { ($a->start <=> $b->start)
or
# if b is shorter than a, b->end will be
# less than a->end, and we want to select
@@ -2985,6 +3205,7 @@
# a, so want to return -1
($b->end <=> $a->end)
} @records;
+ }
my $new = $class->new(@_);
@@ -2992,13 +3213,21 @@
for my $set (@records) {
my $start = $set->start;
my $end = $set->end;
- my $value = $set->value;
+ my $value = $set->value;
+ my $type = $set->type;
if ($start > $new->max) {
- $new->_add_delete('+', $start, $end, $value);
+ $new->_add_delete('+', $start, $end, $value, Type => $type);
}
elsif ($end > $new->max) {
- $new->_add_delete('+', $new->max +1, $end, $value);
+ $new->_add_delete('+', $new->max +1, $end, $value,
+ Type => $type);
}
+ elsif ($input_count == 1) {
+ # Here, overlaps existing range, but is from a single input,
+ # so preserve the multiple values from that input.
+ $new->_add_delete('+', $start, $end, $value, Type => $type,
+ Replace => $MULTIPLE_AFTER);
+ }
}
return $new;
@@ -3026,7 +3255,7 @@
# If the range list is empty, return a large value that isn't adjacent
# to any that could be in the range list, for simpler tests
- return $LAST_UNICODE_CODEPOINT + 2 unless scalar @{$ranges{$addr}};
+ return $MAX_UNICODE_CODEPOINT + 2 unless scalar @{$ranges{$addr}};
return $ranges{$addr}->[0]->start;
}
@@ -3234,7 +3463,7 @@
# new and old values are identical, the
# replacement is skipped to save cycles
# => $IF_NOT_EQUIVALENT means to replace the existing values
- # with this one if they are not equivalent.
+ # (the default) with this one if they are not equivalent.
# Ranges are equivalent if their types are the
# same, and they are the same string; or if
# both are type 0 ranges, if their Unicode
@@ -3248,7 +3477,7 @@
# style when the pre-existing and replacement
# standard forms are the same, we can move to
# the modern style
- # => $MULTIPLE means that if this range duplicates an
+ # => $MULTIPLE_BEFORE means that if this range duplicates an
# existing one, but has a different value,
# don't replace the existing one, but insert
# this, one so that the same range can occur
@@ -3255,6 +3484,17 @@
# multiple times. They are stored LIFO, so
# that the final one inserted is the first one
# returned in an ordered search of the table.
+ # If this is an exact duplicate, including the
+ # value, the original will be moved to be
+ # first, before any other duplicate ranges
+ # with different values.
+ # => $MULTIPLE_AFTER is like $MULTIPLE_BEFORE, but is stored
+ # FIFO, so that this one is inserted after all
+ # others that currently exist. If this is an
+ # exact duplicate, including value, of an
+ # existing range, this one is discarded
+ # (leaving the existing one in its original,
+ # higher priority position
# => anything else is the same as => $IF_NOT_EQUIVALENT
#
# "same value" means identical for non-type-0 ranges, and it means
@@ -3294,6 +3534,9 @@
Carp::my_carp_bug("$owner_name_of{$addr}End of range (" . sprintf("%04X", $end) . ") must not be before start (" . sprintf("%04X", $start) . "). No action taken.");
return;
}
+ if ($end > $MAX_UNICODE_CODEPOINT && $operation eq '+') {
+ Carp::my_carp("$owner_name_of{$addr}Warning: Range '" . sprintf("%04X..%04X", $start, $end) . ") is above the Unicode maximum of " . sprintf("%04X", $MAX_UNICODE_CODEPOINT) . ". Adding it anyway");
+ }
#local $to_trace = 1 if main::DEBUG;
if ($operation eq '-') {
@@ -3321,7 +3564,7 @@
# structured so this is common.
if ($start > $max) {
- trace "$owner_name_of{$addr} $operation", sprintf("%04X", $start) . '..' . sprintf("%04X", $end) . " ($value) type=$type" if main::DEBUG && $to_trace;
+ trace "$owner_name_of{$addr} $operation", sprintf("%04X..%04X (%s) type=%d; prev max=%04X", $start, $end, $value, $type, $max) if main::DEBUG && $to_trace;
return if $operation eq '-'; # Deleting a non-existing range is a
# no-op
@@ -3486,11 +3729,12 @@
# Here, we have taken care of the case where $replace is $NO.
# Remember that here, r[$i-1]->end < $start <= r[$i]->end
# If inserting a multiple record, this is where it goes, before the
- # first (if any) existing one. This implies an insertion, and no
- # change to any existing ranges. Note that $i can be -1 if this new
- # range doesn't actually duplicate any existing, and comes at the
- # beginning of the list.
- if ($replace == $MULTIPLE) {
+ # first (if any) existing one if inserting LIFO. (If this is to go
+ # afterwards, FIFO, we below move the pointer to there.) These imply
+ # an insertion, and no change to any existing ranges. Note that $i
+ # can be -1 if this new range doesn't actually duplicate any existing,
+ # and comes at the beginning of the list.
+ if ($replace == $MULTIPLE_BEFORE || $replace == $MULTIPLE_AFTER) {
if ($start != $end) {
Carp::my_carp_bug("$owner_name_of{$addr}Can't cope with adding a multiple record when the range ($start..$end) contains more than one code point. No action taken.");
@@ -3497,15 +3741,72 @@
return;
}
- # Don't add an exact duplicate, as it isn't really a multiple
+ # If the new code point is within a current range ...
if ($end >= $r->[$i]->start) {
+
+ # Don't add an exact duplicate, as it isn't really a multiple
+ my $existing_value = $r->[$i]->value;
+ my $existing_type = $r->[$i]->type;
+ return if $value eq $existing_value && $type eq $existing_type;
+
+ # If the multiple value is part of an existing range, we want
+ # to split up that range, so that only the single code point
+ # is affected. To do this, we first call ourselves
+ # recursively to delete that code point from the table, having
+ # preserved its current data above. Then we call ourselves
+ # recursively again to add the new multiple, which we know by
+ # the test just above is different than the current code
+ # point's value, so it will become a range containing a single
+ # code point: just itself. Finally, we add back in the
+ # pre-existing code point, which will again be a single code
+ # point range. Because 'i' likely will have changed as a
+ # result of these operations, we can't just continue on, but
+ # do this operation recursively as well. If we are inserting
+ # LIFO, the pre-existing code point needs to go after the new
+ # one, so use MULTIPLE_AFTER; and vice versa.
if ($r->[$i]->start != $r->[$i]->end) {
- Carp::my_carp_bug("$owner_name_of{$addr}Can't cope with adding a multiple record when the other range ($r->[$i]) contains more than one code point. No action taken.");
- return;
+ $self->_add_delete('-', $start, $end, "");
+ $self->_add_delete('+', $start, $end, $value, Type => $type);
+ return $self->_add_delete('+',
+ $start, $end,
+ $existing_value,
+ Type => $existing_type,
+ Replace => ($replace == $MULTIPLE_BEFORE)
+ ? $MULTIPLE_AFTER
+ : $MULTIPLE_BEFORE);
}
- return if $value eq $r->[$i]->value && $type eq $r->[$i]->type;
}
+ # If to place this new record after, move to beyond all existing
+ # ones; but don't add this one if identical to any of them, as it
+ # isn't really a multiple. This leaves the original order, so
+ # that the current request is ignored. The reasoning is that the
+ # previous request that wanted this record to have high priority
+ # should have precedence.
+ if ($replace == $MULTIPLE_AFTER) {
+ while ($i < @$r && $r->[$i]->start == $start) {
+ return if $value eq $r->[$i]->value
+ && $type eq $r->[$i]->type;
+ $i++;
+ }
+ }
+ else {
+ # If instead we are to place this new record before any
+ # existing ones, remove any identical ones that come after it.
+ # This changes the existing order so that the new one is
+ # first, as is being requested.
+ for (my $j = $i + 1;
+ $j < @$r && $r->[$j]->start == $start;
+ $j++)
+ {
+ if ($value eq $r->[$j]->value && $type eq $r->[$j]->type) {
+ splice @$r, $j, 1;
+ last; # There should only be one instance, so no
+ # need to keep looking
+ }
+ }
+ }
+
trace "Adding multiple record at $i with $start..$end, $value" if main::DEBUG && $to_trace;
my @return = splice @$r,
$i,
@@ -3526,8 +3827,8 @@
return @return;
}
- # Here, we have taken care of $NO and $MULTIPLE replaces. This leaves
- # delete, insert, and replace either unconditionally or if not
+ # Here, we have taken care of $NO and $MULTIPLE_foo replaces. This
+ # leaves delete, insert, and replace either unconditionally or if not
# equivalent. $i still points to the first potential affected range.
# Now find the highest range affected, which will determine the length
# parameter to splice. (The input range can span multiple existing
@@ -3638,7 +3939,7 @@
$j--; # $j now points to the highest affected range.
trace "Final affected range is $j: $r->[$j]" if main::DEBUG && $to_trace;
- # Here, have taken care of $NO and $MULTIPLE replaces.
+ # Here, have taken care of $NO and $MULTIPLE_foo replaces.
# $j points to the highest affected range. But it can be < $i or even
# -1. These happen only if the insertion is entirely in the gap
# between r[$i-1] and r[$i]. Here's why: j < i means that the j loop
@@ -3862,7 +4163,12 @@
# otherwise recalculate it. This is done too rarely to worry about
# performance.
if ($operation eq '-' && @return) {
- $max{$addr} = $r->[-1]->end;
+ if (@$r) {
+ $max{$addr} = $r->[-1]->end;
+ }
+ else { # Now empty
+ $max{$addr} = $max_init;
+ }
}
return @return;
}
@@ -3966,11 +4272,41 @@
return $self->_union($other)
},
+ '+=' => sub { my $self = shift;
+ my $other = shift;
+ my $reversed = shift;
+
+ if ($reversed) {
+ Carp::my_carp_bug("Bad news. Can't cope with '"
+ . ref($other)
+ . ' += '
+ . ref($self)
+ . "'. undef returned.");
+ return;
+ }
+
+ return $self->_union($other)
+ },
'&' => sub { my $self = shift;
my $other = shift;
return $self->_intersect($other, 0);
},
+ '&=' => sub { my $self = shift;
+ my $other = shift;
+ my $reversed = shift;
+
+ if ($reversed) {
+ Carp::my_carp_bug("Bad news. Can't cope with '"
+ . ref($other)
+ . ' &= '
+ . ref($self)
+ . "'. undef returned.");
+ return;
+ }
+
+ return $self->_intersect($other, 0);
+ },
'~' => "_invert",
'-' => "_subtract",
;
@@ -3998,8 +4334,8 @@
# And finally, add the gap from the end of the table to the max
# possible code point
- if ($max < $LAST_UNICODE_CODEPOINT) {
- $new->add_range($max + 1, $LAST_UNICODE_CODEPOINT);
+ if ($max < $MAX_UNICODE_CODEPOINT) {
+ $new->add_range($max + 1, $MAX_UNICODE_CODEPOINT);
}
return $new;
}
@@ -4015,10 +4351,12 @@
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
if ($reversed) {
- Carp::my_carp_bug("Can't cope with a "
- . __PACKAGE__
- . " being the second parameter in a '-'. Subtraction ignored.");
- return $self;
+ Carp::my_carp_bug("Bad news. Can't cope with '"
+ . ref($other)
+ . ' - '
+ . ref($self)
+ . "'. undef returned.");
+ return;
}
my $new = Range_List->new(Initialize => $self);
@@ -4232,7 +4570,9 @@
my $a = $a_ranges[$i];
my $b = $b_ranges[$i];
trace "self $a; other $b" if main::DEBUG && $to_trace;
- return 0 if $a->start != $b->start || $a->end != $b->end;
+ return 0 if ! defined $b
+ || $a->start != $b->start
+ || $a->end != $b->end;
}
return 1;
}
@@ -4257,7 +4597,7 @@
return $try_hard if $code >= 0xFDD0 && $code <= 0xFDEF;
return $try_hard if ($code & 0xFFFE) == 0xFFFE; # includes FFFF
- return $try_hard if $code > $LAST_UNICODE_CODEPOINT; # keep in range
+ return $try_hard if $code > $MAX_UNICODE_CODEPOINT; # keep in range
return $try_hard if $code >= 0xD800 && $code <= 0xDFFF; # no surrogate
return 1;
@@ -4278,7 +4618,7 @@
for my $try_hard (0, 1) {
# Look through all the ranges for a usable code point.
- for my $set ($self->ranges) {
+ for my $set (reverse $self->ranges) {
# Try the edge cases first, starting with the end point of the
# range.
@@ -4337,10 +4677,12 @@
my $self = shift;
my $code_point = shift;
my $value = shift;
- Carp::carp_extra_args(\@_) if main::DEBUG && @_;
+ my %args = @_;
+ my $replace = delete $args{'Replace'} // $MULTIPLE_BEFORE;
+ Carp::carp_extra_args(\%args) if main::DEBUG && %args;
return $self->add_map($code_point, $code_point,
- $value, Replace => $MULTIPLE);
+ $value, Replace => $replace);
}
} # End of closure for package Range_Map
@@ -4388,8 +4730,8 @@
main::set_access('property', \%property, 'r');
my %aliases;
- # Ordered list of aliases of the table's name. The first ones in the list
- # are output first in comments
+ # Ordered list of alias objects of the table's name. The first ones in
+ # the list are output first in comments
main::set_access('aliases', \%aliases, 'readable_array');
my %comment;
@@ -4406,10 +4748,11 @@
# files.
main::set_access('note', \%note, 'readable_array');
- my %internal_only;
- # Boolean; if set means any file that contains this table is marked as for
- # internal-only use.
- main::set_access('internal_only', \%internal_only);
+ my %fate;
+ # Enum; there are a number of possibilities for what happens to this
+ # table: it could be normal, or suppressed, or not for external use. See
+ # values at definition for $SUPPRESSED.
+ main::set_access('fate', \%fate, 'r');
my %find_table_from_alias;
# The parent property passes this pointer to a hash which this class adds
@@ -4459,13 +4802,14 @@
my %format;
# The format of the entries of the table. This is calculated from the
# data in the table (or passed in the constructor). This is an enum e.g.,
- # $STRING_FORMAT
+ # $STRING_FORMAT. It is marked protected as it should not be generally
+ # used to override calculations.
main::set_access('format', \%format, 'r', 'p_s');
sub new {
# All arguments are key => value pairs, which you can see below, most
- # of which match fields documented above. Otherwise: Pod_Entry,
- # Externally_Ok, and Fuzzy apply to the names of the table, and are
+ # of which match fields documented above. Otherwise: Re_Pod_Entry,
+ # OK_as_Filename, and Fuzzy apply to the names of the table, and are
# documented in the Alias package
return Carp::carp_too_few_args(\@_, 2) if main::DEBUG && @_ < 2;
@@ -4483,7 +4827,6 @@
my $complete_name = $complete_name{$addr}
= delete $args{'Complete_Name'};
$format{$addr} = delete $args{'Format'};
- $internal_only{$addr} = delete $args{'Internal_Only_Warning'} || 0;
$output_range_counts{$addr} = delete $args{'Output_Range_Counts'};
$property{$addr} = delete $args{'_Property'};
$range_list{$addr} = delete $args{'_Range_List'};
@@ -4491,12 +4834,14 @@
$status_info{$addr} = delete $args{'_Status_Info'} || "";
$range_size_1{$addr} = delete $args{'Range_Size_1'} || 0;
$caseless_equivalent{$addr} = delete $args{'Caseless_Equivalent'} || 0;
+ $fate{$addr} = delete $args{'Fate'} || $ORDINARY;
+ my $ucd = delete $args{'UCD'};
my $description = delete $args{'Description'};
- my $externally_ok = delete $args{'Externally_Ok'};
+ my $ok_as_filename = delete $args{'OK_as_Filename'};
my $loose_match = delete $args{'Fuzzy'};
my $note = delete $args{'Note'};
- my $make_pod_entry = delete $args{'Pod_Entry'};
+ my $make_re_pod_entry = delete $args{'Re_Pod_Entry'};
my $perl_extension = delete $args{'Perl_Extension'};
# Shouldn't have any left over
@@ -4518,28 +4863,40 @@
push @{$description{$addr}}, $description if $description;
push @{$note{$addr}}, $note if $note;
- if ($status{$addr} eq $PLACEHOLDER) {
+ if ($fate{$addr} == $PLACEHOLDER) {
# A placeholder table doesn't get documented, is a perl extension,
# and quite likely will be empty
- $make_pod_entry = 0 if ! defined $make_pod_entry;
+ $make_re_pod_entry = 0 if ! defined $make_re_pod_entry;
$perl_extension = 1 if ! defined $perl_extension;
+ $ucd = 0 if ! defined $ucd;
push @tables_that_may_be_empty, $complete_name{$addr};
+ $self->add_comment(<<END);
+This is a placeholder because it is not in Version $string_version of Unicode,
+but is needed by the Perl core to work gracefully. Because it is not in this
+version of Unicode, it will not be listed in $pod_file.pod
+END
}
- elsif (! $status{$addr}) {
-
- # If hasn't set its status already, see if it is on one of the
- # lists of properties or tables that have particular statuses; if
- # not, is normal. The lists are prioritized so the most serious
- # ones are checked first
- if (exists $why_suppressed{$complete_name}
+ elsif (exists $why_suppressed{$complete_name}
# Don't suppress if overridden
&& ! grep { $_ eq $complete_name{$addr} }
@output_mapped_properties)
- {
- $status{$addr} = $SUPPRESSED;
- }
- elsif (exists $why_deprecated{$complete_name}) {
+ {
+ $fate{$addr} = $SUPPRESSED;
+ }
+ elsif ($fate{$addr} == $SUPPRESSED
+ && ! exists $why_suppressed{$property{$addr}->complete_name})
+ {
+ Carp::my_carp_bug("There is no current capability to set the reason for suppressing.");
+ # perhaps Fate => [ $SUPPRESSED, "reason" ]
+ }
+
+ # If hasn't set its status already, see if it is on one of the
+ # lists of properties or tables that have particular statuses; if
+ # not, is normal. The lists are prioritized so the most serious
+ # ones are checked first
+ if (! $status{$addr}) {
+ if (exists $why_deprecated{$complete_name}) {
$status{$addr} = $DEPRECATED;
}
elsif (exists $why_stabilized{$complete_name}) {
@@ -4552,12 +4909,8 @@
# Existence above doesn't necessarily mean there is a message
# associated with it. Use the most serious message.
if ($status{$addr}) {
- if ($why_suppressed{$complete_name}) {
+ if ($why_deprecated{$complete_name}) {
$status_info{$addr}
- = $why_suppressed{$complete_name};
- }
- elsif ($why_deprecated{$complete_name}) {
- $status_info{$addr}
= $why_deprecated{$complete_name};
}
elsif ($why_stabilized{$complete_name}) {
@@ -4573,24 +4926,35 @@
$perl_extension{$addr} = $perl_extension || 0;
+ # Don't list a property by default that is internal only
+ if ($fate{$addr} > $MAP_PROXIED) {
+ $make_re_pod_entry = 0 if ! defined $make_re_pod_entry;
+ $ucd = 0 if ! defined $ucd;
+ }
+ else {
+ $ucd = 1 if ! defined $ucd;
+ }
+
# By convention what typically gets printed only or first is what's
# first in the list, so put the full name there for good output
# clarity. Other routines rely on the full name being first on the
# list
$self->add_alias($full_name{$addr},
- Externally_Ok => $externally_ok,
+ OK_as_Filename => $ok_as_filename,
Fuzzy => $loose_match,
- Pod_Entry => $make_pod_entry,
+ Re_Pod_Entry => $make_re_pod_entry,
Status => $status{$addr},
+ UCD => $ucd,
);
# Then comes the other name, if meaningfully different.
if (standardize($full_name{$addr}) ne standardize($name{$addr})) {
$self->add_alias($name{$addr},
- Externally_Ok => $externally_ok,
+ OK_as_Filename => $ok_as_filename,
Fuzzy => $loose_match,
- Pod_Entry => $make_pod_entry,
+ Re_Pod_Entry => $make_re_pod_entry,
Status => $status{$addr},
+ UCD => $ucd,
);
}
@@ -4626,6 +4990,7 @@
use overload
fallback => 0,
"." => \&main::_operator_dot,
+ ".=" => \&main::_operator_dot_equal,
'!=' => \&main::_operator_not_equal,
'==' => \&main::_operator_equal,
;
@@ -4651,15 +5016,19 @@
my %args = @_;
my $loose_match = delete $args{'Fuzzy'};
- my $make_pod_entry = delete $args{'Pod_Entry'};
- $make_pod_entry = $YES unless defined $make_pod_entry;
+ my $make_re_pod_entry = delete $args{'Re_Pod_Entry'};
+ $make_re_pod_entry = $YES unless defined $make_re_pod_entry;
- my $externally_ok = delete $args{'Externally_Ok'};
- $externally_ok = 1 unless defined $externally_ok;
+ my $ok_as_filename = delete $args{'OK_as_Filename'};
+ $ok_as_filename = 1 unless defined $ok_as_filename;
my $status = delete $args{'Status'};
$status = $NORMAL unless defined $status;
+ # An internal name does not get documented, unless overridden by the
+ # input.
+ my $ucd = delete $args{'UCD'} // (($name =~ /^_/) ? 0 : 1);
+
Carp::carp_extra_args(\%args) if main::DEBUG && %args;
# Capitalize the first letter of the alias unless it is one of the CJK
@@ -4726,8 +5095,8 @@
splice @$list,
$insert_position,
0,
- Alias->new($name, $loose_match, $make_pod_entry,
- $externally_ok, $status);
+ Alias->new($name, $loose_match, $make_re_pod_entry,
+ $ok_as_filename, $status, $ucd);
# This name may be shorter than any existing ones, so clear the cache
# of the shortest, so will have to be recalculated.
@@ -4771,7 +5140,7 @@
foreach my $alias ($self->aliases()) {
# Don't use an alias that isn't ok to use for an external name.
- next if ! $alias->externally_ok;
+ next if ! $alias->ok_as_filename;
my $name = main::Standardize($alias->name);
trace $self, $name if main::DEBUG && $to_trace;
@@ -4790,6 +5159,33 @@
}
}
+ # If the short name isn't a nice one, perhaps an equivalent table has
+ # a better one.
+ if (! defined $short_name{$addr}
+ || $short_name{$addr} eq ""
+ || $short_name{$addr} eq "_")
+ {
+ my $return;
+ foreach my $follower ($self->children) { # All equivalents
+ my $follower_name = $follower->short_name;
+ next unless defined $follower_name;
+
+ # Anything (except undefined) is better than underscore or
+ # empty
+ if (! defined $return || $return eq "_") {
+ $return = $follower_name;
+ next;
+ }
+
+ # If the new follower name isn't "_" and is shorter than the
+ # current best one, prefer the new one.
+ next if $follower_name eq "_";
+ next if length $follower_name > length $return;
+ $return = $follower_name;
+ }
+ $short_name{$addr} = $return if defined $return;
+ }
+
# If no suitable external name return undef
if (! defined $short_name{$addr}) {
$$nominal_length_ptr = undef if $nominal_length_ptr;
@@ -4796,7 +5192,7 @@
return;
}
- # Don't allow a null external name.
+ # Don't allow a null short name.
if ($short_name{$addr} eq "") {
$short_name{$addr} = '_';
$nominal_short_name_length{$addr} = 1;
@@ -4812,7 +5208,9 @@
sub external_name {
# Returns the external name that this table should be known by. This
- # is usually the short_name, but not if the short_name is undefined.
+ # is usually the short_name, but not if the short_name is undefined,
+ # in which case the external_name is arbitrarily set to the
+ # underscore.
my $self = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
@@ -4914,8 +5312,6 @@
my $return = "";
$return .= $DEVELOPMENT_ONLY if $compare_versions;
$return .= $HEADER;
- no overloading;
- $return .= $INTERNAL_ONLY if $internal_only{pack 'J', $self};
return $return;
}
@@ -4923,9 +5319,11 @@
# Write a representation of the table to its file. It calls several
# functions furnished by sub-classes of this abstract base class to
# handle non-normal ranges, to add stuff before the table, and at its
- # end.
+ # end. If the table is to be written so that adjustments are
+ # required, this does that conversion.
my $self = shift;
+ my $use_adjustments = shift; # ? output in adjusted format or not
my $tab_stops = shift; # The number of tab stops over to put any
# comment.
my $suppress_value = shift; # Optional, if the value associated with
@@ -4967,8 +5365,26 @@
# utf8.c, which can't really deal with empty tables, but it can
# deal with a table that matches nothing, as the inverse of 'Any'
# does.
- push @OUT, "!utf8::IsAny\n";
+ push @OUT, "!utf8::Any\n";
}
+ elsif ($self->name eq 'N'
+
+ # To save disk space and table cache space, avoid putting out
+ # binary N tables, but instead create a file which just inverts
+ # the Y table. Since the file will still exist and occupy a
+ # certain number of blocks, might as well output the whole
+ # thing if it all will fit in one block. The number of
+ # ranges below is an approximate number for that.
+ && ($self->property->type == $BINARY
+ || $self->property->type == $FORCED_BINARY)
+ # && $self->property->tables == 2 Can't do this because the
+ # non-binary properties, like NFDQC aren't specifiable
+ # by the notation
+ && $range_list{$addr}->ranges > 15
+ && ! $annotate) # Under --annotate, want to see everything
+ {
+ push @OUT, "!utf8::" . $self->property->name . "\n";
+ }
else {
my $range_size_1 = $range_size_1{$addr};
my $format; # Used only in $annotate option
@@ -4976,7 +5392,7 @@
if ($annotate) {
- # if annotating each code point, must print 1 per line.
+ # If annotating each code point, must print 1 per line.
# The variable could point to a subroutine, and we don't want
# to lose that fact, so only set if not set already
$range_size_1 = 1 if ! $range_size_1;
@@ -4994,6 +5410,21 @@
);
}
+ # Values for previous time through the loop. Initialize to
+ # something that won't be adjacent to the first iteration;
+ # only $previous_end matters for that.
+ my $previous_start;
+ my $previous_end = -2;
+ my $previous_value;
+
+ # Values for next time through the portion of the loop that splits
+ # the range. 0 in $next_start means there is no remaining portion
+ # to deal with.
+ my $next_start = 0;
+ my $next_end;
+ my $next_value;
+ my $offset = 0;
+
# Output each range as part of the here document.
RANGE:
for my $set ($range_list{$addr}->ranges) {
@@ -5009,189 +5440,274 @@
next RANGE if defined $suppress_value
&& $value eq $suppress_value;
- # If there is a range and doesn't need a single point range
- # output
- if ($start != $end && ! $range_size_1) {
- push @OUT, sprintf "%04X\t%04X", $start, $end;
- $OUT[-1] .= "\t$value" if $value ne "";
+ { # This bare block encloses the scope where we may need to
+ # split a range (when outputting adjusteds), and each time
+ # through we handle the next portion of the original by
+ # ending the block with a 'redo'. The values to use for
+ # that next time through are set up just below in the
+ # scalars whose names begin with '$next_'.
- # Add a comment with the size of the range, if requested.
- # Expand Tabs to make sure they all start in the same
- # column, and then unexpand to use mostly tabs.
- if (! $output_range_counts{$addr}) {
- $OUT[-1] .= "\n";
+ if ($use_adjustments) {
+
+ # When converting to use adjustments, we can handle
+ # only single element ranges. Set up so that this
+ # time through the loop, we look at the first element,
+ # and the next time through, we start off with the
+ # remainder. Thus each time through we look at the
+ # first element of the range
+ if ($end != $start) {
+ $next_start = $start + 1;
+ $next_end = $end;
+ $next_value = $value;
+ $end = $start;
+ }
+
+ # The values for some of these tables are stored as
+ # hex strings. Convert those to decimal
+ $value = hex($value)
+ if $self->default_map eq $CODE_POINT
+ && $value =~ / ^ [A-Fa-f0-9]+ $ /x;
+
+ # If this range is adjacent to the previous one, and
+ # the values in each are integers that are also
+ # adjacent (differ by 1), then this range really
+ # extends the previous one that is already in element
+ # $OUT[-1]. So we pop that element, and pretend that
+ # the range starts with whatever it started with.
+ # $offset is incremented by 1 each time so that it
+ # gives the current offset from the first element in
+ # the accumulating range, and we keep in $value the
+ # value of that first element.
+ if ($start == $previous_end + 1
+ && $value =~ /^ -? \d+ $/xa
+ && $previous_value =~ /^ -? \d+ $/xa
+ && ($value == ($previous_value + ++$offset)))
+ {
+ pop @OUT;
+ $start = $previous_start;
+ $value = $previous_value;
+ }
+ else {
+ $offset = 0;
+ }
+
+ # Save the current values for the next time through
+ # the loop.
+ $previous_start = $start;
+ $previous_end = $end;
+ $previous_value = $value;
}
- else {
- $OUT[-1] = Text::Tabs::expand($OUT[-1]);
- my $count = main::clarify_number($end - $start + 1);
- use integer;
- my $width = $tab_stops * 8 - 1;
- $OUT[-1] = sprintf("%-*s # [%s]\n",
- $width,
- $OUT[-1],
- $count);
- $OUT[-1] = Text::Tabs::unexpand($OUT[-1]);
+ # If there is a range and doesn't need a single point range
+ # output
+ if ($start != $end && ! $range_size_1) {
+ push @OUT, sprintf "%04X\t%04X", $start, $end;
+ $OUT[-1] .= "\t$value" if $value ne "";
+
+ # Add a comment with the size of the range, if
+ # requested. Expand Tabs to make sure they all start
+ # in the same column, and then unexpand to use mostly
+ # tabs.
+ if (! $output_range_counts{$addr}) {
+ $OUT[-1] .= "\n";
+ }
+ else {
+ $OUT[-1] = Text::Tabs::expand($OUT[-1]);
+ my $count = main::clarify_number($end - $start + 1);
+ use integer;
+
+ my $width = $tab_stops * 8 - 1;
+ $OUT[-1] = sprintf("%-*s # [%s]\n",
+ $width,
+ $OUT[-1],
+ $count);
+ $OUT[-1] = Text::Tabs::unexpand($OUT[-1]);
+ }
}
- next RANGE;
- }
- # Here to output a single code point per line
+ # Here to output a single code point per line.
+ # If not to annotate, use the simple formats
+ elsif (! $annotate) {
- # If not to annotate, use the simple formats
- if (! $annotate) {
+ # Use any passed in subroutine to output.
+ if (ref $range_size_1 eq 'CODE') {
+ for my $i ($start .. $end) {
+ push @OUT, &{$range_size_1}($i, $value);
+ }
+ }
+ else {
- # Use any passed in subroutine to output.
- if (ref $range_size_1 eq 'CODE') {
- for my $i ($start .. $end) {
- push @OUT, &{$range_size_1}($i, $value);
+ # Here, caller is ok with default output.
+ for (my $i = $start; $i <= $end; $i++) {
+ push @OUT, sprintf "%04X\t\t%s\n", $i, $value;
+ }
}
}
else {
- # Here, caller is ok with default output.
+ # Here, wants annotation.
for (my $i = $start; $i <= $end; $i++) {
- push @OUT, sprintf "%04X\t\t%s\n", $i, $value;
- }
- }
- next RANGE;
- }
- # Here, wants annotation.
- for (my $i = $start; $i <= $end; $i++) {
+ # Get character information if don't have it already
+ main::populate_char_info($i)
+ if ! defined $viacode[$i];
+ my $type = $annotate_char_type[$i];
- # Get character information if don't have it already
- main::populate_char_info($i)
- if ! defined $viacode[$i];
- my $type = $annotate_char_type[$i];
+ # Figure out if should output the next code points
+ # as part of a range or not. If this is not in an
+ # annotation range, then won't output as a range,
+ # so returns $i. Otherwise use the end of the
+ # annotation range, but no further than the
+ # maximum possible end point of the loop.
+ my $range_end = main::min(
+ $annotate_ranges->value_of($i) || $i,
+ $end);
- # Figure out if should output the next code points as part
- # of a range or not. If this is not in an annotation
- # range, then won't output as a range, so returns $i.
- # Otherwise use the end of the annotation range, but no
- # further than the maximum possible end point of the loop.
- my $range_end = main::min($annotate_ranges->value_of($i)
- || $i,
- $end);
-
- # Use a range if it is a range, and either is one of the
- # special annotation ranges, or the range is at most 3
- # long. This last case causes the algorithmically named
- # code points to be output individually in spans of at
- # most 3, as they are the ones whose $type is > 0.
- if ($range_end != $i
- && ( $type < 0 || $range_end - $i > 2))
- {
- # Here is to output a range. We don't allow a
- # caller-specified output format--just use the
- # standard one.
- push @OUT, sprintf "%04X\t%04X\t%s\t#", $i,
+ # Use a range if it is a range, and either is one
+ # of the special annotation ranges, or the range
+ # is at most 3 long. This last case causes the
+ # algorithmically named code points to be output
+ # individually in spans of at most 3, as they are
+ # the ones whose $type is > 0.
+ if ($range_end != $i
+ && ( $type < 0 || $range_end - $i > 2))
+ {
+ # Here is to output a range. We don't allow a
+ # caller-specified output format--just use the
+ # standard one.
+ push @OUT, sprintf "%04X\t%04X\t%s\t#", $i,
$range_end,
$value;
- my $range_name = $viacode[$i];
+ my $range_name = $viacode[$i];
- # For the code points which end in their hex value, we
- # eliminate that from the output annotation, and
- # capitalize only the first letter of each word.
- if ($type == $CP_IN_NAME) {
- my $hex = sprintf "%04X", $i;
- $range_name =~ s/-$hex$//;
- my @words = split " ", $range_name;
- for my $word (@words) {
- $word = ucfirst(lc($word)) if $word ne 'CJK';
- }
- $range_name = join " ", @words;
- }
- elsif ($type == $HANGUL_SYLLABLE) {
- $range_name = "Hangul Syllable";
- }
+ # For the code points which end in their hex
+ # value, we eliminate that from the output
+ # annotation, and capitalize only the first
+ # letter of each word.
+ if ($type == $CP_IN_NAME) {
+ my $hex = sprintf "%04X", $i;
+ $range_name =~ s/-$hex$//;
+ my @words = split " ", $range_name;
+ for my $word (@words) {
+ $word =
+ ucfirst(lc($word)) if $word ne 'CJK';
+ }
+ $range_name = join " ", @words;
+ }
+ elsif ($type == $HANGUL_SYLLABLE) {
+ $range_name = "Hangul Syllable";
+ }
- $OUT[-1] .= " $range_name" if $range_name;
+ $OUT[-1] .= " $range_name" if $range_name;
- # Include the number of code points in the range
- my $count = main::clarify_number($range_end - $i + 1);
- $OUT[-1] .= " [$count]\n";
+ # Include the number of code points in the
+ # range
+ my $count =
+ main::clarify_number($range_end - $i + 1);
+ $OUT[-1] .= " [$count]\n";
- # Skip to the end of the range
- $i = $range_end;
- }
- else { # Not in a range.
- my $comment = "";
+ # Skip to the end of the range
+ $i = $range_end;
+ }
+ else { # Not in a range.
+ my $comment = "";
- # When outputting the names of each character, use
- # the character itself if printable
- $comment .= "'" . chr($i) . "' " if $printable[$i];
+ # When outputting the names of each character,
+ # use the character itself if printable
+ $comment .= "'" . chr($i) . "' "
+ if $printable[$i];
- # To make it more readable, use a minimum indentation
- my $comment_indent;
+ # To make it more readable, use a minimum
+ # indentation
+ my $comment_indent;
- # Determine the annotation
- if ($format eq $DECOMP_STRING_FORMAT) {
+ # Determine the annotation
+ if ($format eq $DECOMP_STRING_FORMAT) {
- # This is very specialized, with the type of
- # decomposition beginning the line enclosed in
- # <...>, and the code points that the code point
- # decomposes to separated by blanks. Create two
- # strings, one of the printable characters, and
- # one of their official names.
- (my $map = $value) =~ s/ \ * < .*? > \ +//x;
- my $tostr = "";
- my $to_name = "";
- my $to_chr = "";
- foreach my $to (split " ", $map) {
- $to = CORE::hex $to;
- $to_name .= " + " if $to_name;
- $to_chr .= chr($to);
- main::populate_char_info($to)
+ # This is very specialized, with the type
+ # of decomposition beginning the line
+ # enclosed in <...>, and the code points
+ # that the code point decomposes to
+ # separated by blanks. Create two
+ # strings, one of the printable
+ # characters, and one of their official
+ # names.
+ (my $map = $value) =~ s/ \ * < .*? > \ +//x;
+ my $tostr = "";
+ my $to_name = "";
+ my $to_chr = "";
+ foreach my $to (split " ", $map) {
+ $to = CORE::hex $to;
+ $to_name .= " + " if $to_name;
+ $to_chr .= chr($to);
+ main::populate_char_info($to)
if ! defined $viacode[$to];
- $to_name .= $viacode[$to];
- }
+ $to_name .= $viacode[$to];
+ }
- $comment .=
+ $comment .=
"=> '$to_chr'; $viacode[$i] => $to_name";
- $comment_indent = 25; # Determined by experiment
- }
- else {
+ $comment_indent = 25; # Determined by
+ # experiment
+ }
+ else {
- # Assume that any table that has hex format is a
- # mapping of one code point to another.
- if ($format eq $HEX_FORMAT) {
- my $decimal_value = CORE::hex $value;
- main::populate_char_info($decimal_value)
+ # Assume that any table that has hex
+ # format is a mapping of one code point to
+ # another.
+ if ($format eq $HEX_FORMAT) {
+ my $decimal_value = CORE::hex $value;
+ main::populate_char_info($decimal_value)
if ! defined $viacode[$decimal_value];
- $comment .= "=> '"
- . chr($decimal_value)
- . "'; " if $printable[$decimal_value];
- }
- $comment .= $viacode[$i] if $include_name
- && $viacode[$i];
- if ($format eq $HEX_FORMAT) {
- my $decimal_value = CORE::hex $value;
- $comment .= " => $viacode[$decimal_value]"
- if $viacode[$decimal_value];
- }
+ $comment .= "=> '"
+ . chr($decimal_value)
+ . "'; " if $printable[$decimal_value];
+ }
+ $comment .= $viacode[$i] if $include_name
+ && $viacode[$i];
+ if ($format eq $HEX_FORMAT) {
+ my $decimal_value = CORE::hex $value;
+ $comment .=
+ " => $viacode[$decimal_value]"
+ if $viacode[$decimal_value];
+ }
- # If including the name, no need to indent, as the
- # name will already be way across the line.
- $comment_indent = ($include_name) ? 0 : 60;
- }
+ # If including the name, no need to
+ # indent, as the name will already be way
+ # across the line.
+ $comment_indent = ($include_name) ? 0 : 60;
+ }
- # Use any passed in routine to output the base part of
- # the line.
- if (ref $range_size_1 eq 'CODE') {
- my $base_part = &{$range_size_1}($i, $value);
- chomp $base_part;
- push @OUT, $base_part;
+ # Use any passed in routine to output the base
+ # part of the line.
+ if (ref $range_size_1 eq 'CODE') {
+ my $base_part=&{$range_size_1}($i, $value);
+ chomp $base_part;
+ push @OUT, $base_part;
+ }
+ else {
+ push @OUT, sprintf "%04X\t\t%s", $i, $value;
+ }
+
+ # And add the annotation.
+ $OUT[-1] = sprintf "%-*s\t# %s",
+ $comment_indent,
+ $OUT[-1],
+ $comment
+ if $comment;
+ $OUT[-1] .= "\n";
+ }
}
- else {
- push @OUT, sprintf "%04X\t\t%s", $i, $value;
- }
+ }
- # And add the annotation.
- $OUT[-1] = sprintf "%-*s\t# %s", $comment_indent,
- $OUT[-1],
- $comment if $comment;
- $OUT[-1] .= "\n";
+ # If we split the range, set up so the next time through
+ # we get the remainder, and redo.
+ if ($next_start) {
+ $start = $next_start;
+ $end = $next_end;
+ $value = $next_value;
+ $next_start = 0;
+ redo;
}
}
} # End of loop through all the table's ranges
@@ -5210,10 +5726,11 @@
my $pre_body = $self->pre_body;
push @HEADER, $pre_body, "\n" if $pre_body;
- # All these files have a .pl suffix
- $file_path{$addr}->[-1] .= '.pl';
+ # All these files should have a .pl suffix added to them.
+ my @file_with_pl = @{$file_path{$addr}};
+ $file_with_pl[-1] .= '.pl';
- main::write($file_path{$addr},
+ main::write(\@file_with_pl,
$annotate, # utf8 iff annotating
\@HEADER,
\@OUT);
@@ -5233,6 +5750,41 @@
return;
}
+ sub set_fate { # Set the fate of a table
+ my $self = shift;
+ my $fate = shift;
+ my $reason = shift;
+ Carp::carp_extra_args(\@_) if main::DEBUG && @_;
+
+ my $addr = do { no overloading; pack 'J', $self; };
+
+ return if $fate{$addr} == $fate; # If no-op
+
+ # Can only change the ordinary fate, except if going to $MAP_PROXIED
+ return if $fate{$addr} != $ORDINARY && $fate != $MAP_PROXIED;
+
+ $fate{$addr} = $fate;
+
+ # Don't document anything to do with a non-normal fated table
+ if ($fate != $ORDINARY) {
+ my $put_in_pod = ($fate == $MAP_PROXIED) ? 1 : 0;
+ foreach my $alias ($self->aliases) {
+ $alias->set_ucd($put_in_pod);
+
+ # MAP_PROXIED doesn't affect the match tables
+ next if $fate == $MAP_PROXIED;
+ $alias->set_make_re_pod_entry($put_in_pod);
+ }
+ }
+
+ # Save the reason for suppression for output
+ if ($fate == $SUPPRESSED && defined $reason) {
+ $why_suppressed{$complete_name{$addr}} = $reason;
+ }
+
+ return;
+ }
+
sub lock {
# Don't allow changes to the table from now on. This stores a stack
# trace of where it was called, so that later attempts to modify it
@@ -5307,8 +5859,7 @@
*$sub = sub {
use strict "refs";
my $self = shift;
- no overloading;
- return $range_list{pack 'J', $self}->$sub(@_);
+ return $self->_range_list->$sub(@_);
}
}
@@ -5324,7 +5875,7 @@
return if $self->carp_if_locked;
no overloading;
- return $range_list{pack 'J', $self}->$sub(@_);
+ return $self->_range_list->$sub(@_);
}
}
@@ -5379,13 +5930,9 @@
\%anomalous_entries,
'readable_array');
- my %core_access;
- # This is a string, solely for documentation, indicating how one can get
- # access to this property via the Perl core.
- main::set_access('core_access', \%core_access, 'r', 's');
-
my %to_output_map;
- # Enum as to whether or not to write out this map table:
+ # Enum as to whether or not to write out this map table, and how:
+ # 0 don't output
# $EXTERNAL_MAP means its existence is noted in the documentation, and
# it should not be removed nor its format changed. This
# is done for those files that have traditionally been
@@ -5392,9 +5939,16 @@
# output.
# $INTERNAL_MAP means Perl reserves the right to do anything it wants
# with this file
+ # $OUTPUT_ADJUSTED means that it is an $INTERNAL_MAP, and instead of
+ # outputting the actual mappings as-is, we adjust things
+ # to create a much more compact table. Only those few
+ # tables where the mapping is convertible at least to an
+ # integer and compacting makes a big difference should
+ # have this. Hence, the default is to not do this
+ # unless the table's default mapping is to $CODE_POINT,
+ # and the range size is not 1.
main::set_access('to_output_map', \%to_output_map, 's');
-
sub new {
my $class = shift;
my $name = shift;
@@ -5404,10 +5958,10 @@
# Optional initialization data for the table.
my $initialize = delete $args{'Initialize'};
- my $core_access = delete $args{'Core_Access'};
my $default_map = delete $args{'Default_Map'};
my $property = delete $args{'_Property'};
my $full_name = delete $args{'Full_Name'};
+ my $to_output_map = delete $args{'To_Output_Map'};
# Rest of parameters passed on
@@ -5424,8 +5978,8 @@
my $addr = do { no overloading; pack 'J', $self; };
$anomalous_entries{$addr} = [];
- $core_access{$addr} = $core_access;
$default_map{$addr} = $default_map;
+ $to_output_map{$addr} = $to_output_map;
$self->initialize($initialize) if defined $initialize;
@@ -5599,8 +6153,10 @@
if defined $global_to_output_map{$full_name};
# If table says to output, do so; if says to suppress it, do so.
+ my $fate = $self->fate;
+ return $INTERNAL_MAP if $fate == $INTERNAL_ONLY;
return $EXTERNAL_MAP if grep { $_ eq $full_name } @output_mapped_properties;
- return 0 if $self->status eq $SUPPRESSED;
+ return 0 if $fate == $SUPPRESSED || $fate == $MAP_PROXIED;
my $type = $self->property->type;
@@ -5607,8 +6163,16 @@
# Don't want to output binary map tables even for debugging.
return 0 if $type == $BINARY;
- # But do want to output string ones.
- return $EXTERNAL_MAP if $type == $STRING;
+ # But do want to output string ones. All the ones that remain to
+ # be dealt with (i.e. which haven't explicitly been set to external)
+ # are for internal Perl use only. The default for those that map to
+ # $CODE_POINT and haven't been restricted to a single element range
+ # is to use the adjusted form.
+ if ($type == $STRING) {
+ return $INTERNAL_MAP if $self->range_size_1
+ || $default_map{$addr} ne $CODE_POINT;
+ return $OUTPUT_ADJUSTED;
+ }
# Otherwise is an $ENUM, do output it, for Perl's purposes
return $INTERNAL_MAP;
@@ -5632,7 +6196,23 @@
my $return = $self->SUPER::header();
- $return .= $INTERNAL_ONLY if $self->to_output_map == $INTERNAL_MAP;
+ if ($self->to_output_map >= $INTERNAL_MAP) {
+ $return .= $INTERNAL_ONLY_HEADER;
+ }
+ else {
+ my $property_name = $self->property->full_name =~ s/Legacy_//r;
+ $return .= <<END;
+
+# !!!!!!! IT IS DEPRECATED TO USE THIS FILE !!!!!!!
+
+# This file is for internal use by core Perl only. It is retained for
+# backwards compatibility with applications that may have come to rely on it,
+# but its format and even its name or existence are subject to change without
+# notice in a future Perl version. Don't use it directly. Instead, its
+# contents are now retrievable through a stable API in the Unicode::UCD
+# module: Unicode::UCD::prop_invmap('$property_name').
+END
+ }
return $return;
}
@@ -5658,7 +6238,7 @@
# have our own flag for just this purpose; but it works now to exclude
# Perl generated synonyms from the lists for properties, where the
# name is always the proper Unicode one.
- my @property_aliases = grep { $_->externally_ok } $self->aliases;
+ my @property_aliases = grep { $_->ok_as_filename } $self->aliases;
my $count = $self->count;
my $default_map = $default_map{$addr};
@@ -5729,7 +6309,7 @@
my $comment = "";
my $status = $self->status;
- if ($status) {
+ if ($status && $status ne $PLACEHOLDER) {
my $warn = uc $status_past_participles{$status};
$comment .= <<END;
@@ -5741,22 +6321,24 @@
}
$comment .= "This file returns the $mapping:\n";
+ my $ucd_accessible_name = "";
+ my $full_name = $self->property->full_name;
for my $i (0 .. @property_aliases - 1) {
- $comment .= sprintf("%-8s%s\n",
- " ",
- $property_aliases[$i]->name . '(cp)'
- );
+ my $name = $property_aliases[$i]->name;
+ $comment .= sprintf("%-8s%s\n", " ", $name . '(cp)');
+ if ($property_aliases[$i]->ucd) {
+ if ($name eq $full_name) {
+ $ucd_accessible_name = $full_name;
+ }
+ elsif (! $ucd_accessible_name) {
+ $ucd_accessible_name = $name;
+ }
+ }
}
- $comment .=
- "\nwhere 'cp' is $cp. Note that $these_mappings $are ";
-
- my $access = $core_access{$addr};
- if ($access) {
- $comment .= "accessible through the Perl core via $access.";
+ $comment .= "\nwhere 'cp' is $cp.";
+ if ($ucd_accessible_name) {
+ $comment .= " Note that $these_mappings $are accessible via the function prop_invmap('$full_name') in Unicode::UCD";
}
- else {
- $comment .= "not accessible through the Perl core directly.";
- }
# And append any commentary already set from the actual property.
$comment .= "\n\n" . $self->comment if $self->comment;
@@ -5812,19 +6394,8 @@
# The remaining variables are temporaries used while writing each table,
# to output special ranges.
- my $has_hangul_syllables;
my @multi_code_point_maps; # Map is to more than one code point.
- # The key is the base name of the code point, and the value is an
- # array giving all the ranges that use this base name. Each range
- # is actually a hash giving the 'low' and 'high' values of it.
- my %names_ending_in_code_point;
-
- # Inverse mapping. The list of ranges that have these kinds of
- # names. Each element contains the low, high, and base names in a
- # hash.
- my @code_points_ending_in_code_point;
-
sub handle_special_range {
# Called in the middle of write when it finds a range it doesn't know
# how to handle.
@@ -5844,6 +6415,8 @@
# No need to output the range if it maps to the default.
return if $map eq $default_map{$addr};
+ my $property = $self->property;
+
# Switch based on the map type...
if ($type == $HANGUL_SYLLABLE) {
@@ -5850,22 +6423,39 @@
# These are entirely algorithmically determinable based on
# some constants furnished by Unicode; for now, just set a
# flag to indicate that have them. After everything is figured
- # out, we will output the code that does the algorithm.
- $has_hangul_syllables = 1;
+ # out, we will output the code that does the algorithm. (Don't
+ # output them if not needed because we are suppressing this
+ # property.)
+ $has_hangul_syllables = 1 if $property->to_output_map;
}
elsif ($type == $CP_IN_NAME) {
- # Code points whose the name ends in their code point are also
+ # Code points whose name ends in their code point are also
# algorithmically determinable, but need information about the map
# to do so. Both the map and its inverse are stored in data
- # structures output in the file.
- push @{$names_ending_in_code_point{$map}->{'low'}}, $low;
- push @{$names_ending_in_code_point{$map}->{'high'}}, $high;
+ # structures output in the file. They are stored in the mean time
+ # in global lists The lists will be written out later into Name.pm,
+ # which is created only if needed. In order to prevent duplicates
+ # in the list, only add to them for one property, should multiple
+ # ones need them.
+ if ($needing_code_points_ending_in_code_point == 0) {
+ $needing_code_points_ending_in_code_point = $property;
+ }
+ if ($property == $needing_code_points_ending_in_code_point) {
+ push @{$names_ending_in_code_point{$map}->{'low'}}, $low;
+ push @{$names_ending_in_code_point{$map}->{'high'}}, $high;
- push @code_points_ending_in_code_point, { low => $low,
+ my $squeezed = $map =~ s/[-\s]+//gr;
+ push @{$loose_names_ending_in_code_point{$squeezed}->{'low'}},
+ $low;
+ push @{$loose_names_ending_in_code_point{$squeezed}->{'high'}},
+ $high;
+
+ push @code_points_ending_in_code_point, { low => $low,
high => $high,
name => $map
- };
+ };
+ }
}
elsif ($range->type == $MULTI_CP || $range->type == $NULL) {
@@ -5874,7 +6464,8 @@
# output format.
for my $code_point ($low .. $high) {
- # The pack() below can't cope with surrogates.
+ # The pack() below can't cope with surrogates. XXX This may
+ # no longer be true
if ($code_point >= 0xD800 && $code_point <= 0xDFFF) {
Carp::my_carp("Surrogate code point '$code_point' in mapping to '$map' in $self. No map created");
next;
@@ -5945,8 +6536,12 @@
my $name = $self->property->swash_name;
+ # Currently there is nothing in the pre_body unless a swash is being
+ # generated.
+ return unless defined $name;
+
if (defined $swash_keys{$name}) {
- Carp::my_carp(join_lines(<<END
+ Carp::my_carp(main::join_lines(<<END
Already created a swash name '$name' for $swash_keys{$name}. This means that
the same name desired for $self shouldn't be used. Bad News. This must be
fixed before production use, but proceeding anyway
@@ -5960,7 +6555,9 @@
# Here we assume we were called after have gone through the whole
# file. If we actually generated anything for each map type, add its
# respective header and trailer
+ my $specials_name = "";
if (@multi_code_point_maps) {
+ $specials_name = "utf8::ToSpec$name";
$pre_body .= <<END;
# Some code points require special handling because their mappings are each to
@@ -5970,233 +6567,54 @@
# Each key is the string of N bytes that together make up the UTF-8 encoding
# for the code point. (i.e. the same as looking at the code point's UTF-8
# under "use bytes"). Each value is the UTF-8 of the translation, for speed.
-%utf8::ToSpec$name = (
+\%$specials_name = (
END
$pre_body .= join("\n", @multi_code_point_maps) . "\n);\n";
}
- if ($has_hangul_syllables || @code_points_ending_in_code_point) {
+ my $format = $self->format;
- # Convert these structures to output format.
- my $code_points_ending_in_code_point =
- main::simple_dumper(\@code_points_ending_in_code_point,
- ' ' x 8);
- my $names = main::simple_dumper(\%names_ending_in_code_point,
- ' ' x 8);
+ my $return = "";
- # Do the same with the Hangul names,
- my $jamo;
- my $jamo_l;
- my $jamo_v;
- my $jamo_t;
- my $jamo_re;
- if ($has_hangul_syllables) {
-
- # Construct a regular expression of all the possible
- # combinations of the Hangul syllables.
- my @L_re; # Leading consonants
- for my $i ($LBase .. $LBase + $LCount - 1) {
- push @L_re, $Jamo{$i}
- }
- my @V_re; # Middle vowels
- for my $i ($VBase .. $VBase + $VCount - 1) {
- push @V_re, $Jamo{$i}
- }
- my @T_re; # Trailing consonants
- for my $i ($TBase + 1 .. $TBase + $TCount - 1) {
- push @T_re, $Jamo{$i}
- }
-
- # The whole re is made up of the L V T combination.
- $jamo_re = '('
- . join ('|', sort @L_re)
- . ')('
- . join ('|', sort @V_re)
- . ')('
- . join ('|', sort @T_re)
- . ')?';
-
- # These hashes needed by the algorithm were generated
- # during reading of the Jamo.txt file
- $jamo = main::simple_dumper(\%Jamo, ' ' x 8);
- $jamo_l = main::simple_dumper(\%Jamo_L, ' ' x 8);
- $jamo_v = main::simple_dumper(\%Jamo_V, ' ' x 8);
- $jamo_t = main::simple_dumper(\%Jamo_T, ' ' x 8);
- }
-
- $pre_body .= <<END;
-
-# To achieve significant memory savings when this file is read in,
-# algorithmically derivable code points are omitted from the main body below.
-# Instead, the following routines can be used to translate between name and
-# code point and vice versa
-
-{ # Closure
-
- # Matches legal code point. 4-6 hex numbers, If there are 6, the
- # first two must be '10'; if there are 5, the first must not be a '0'.
- my \$code_point_re = qr/$code_point_re/;
-
- # In the following hash, the keys are the bases of names which includes
- # the code point in the name, like CJK UNIFIED IDEOGRAPH-4E01. The values
- # of each key is another hash which is used to get the low and high ends
- # for each range of code points that apply to the name
- my %names_ending_in_code_point = (
-$names
- );
-
- # And the following array gives the inverse mapping from code points to
- # names. Lowest code points are first
- my \@code_points_ending_in_code_point = (
-$code_points_ending_in_code_point
- );
+ my $output_adjusted = ($self->to_output_map == $OUTPUT_ADJUSTED);
+ if ($output_adjusted) {
+ if ($specials_name) {
+ $return .= <<END;
+# The mappings in the non-hash portion of this file must be modified to get the
+# correct values by adding the code point ordinal number to each one that is
+# numeric.
END
- # Earlier releases didn't have Jamos. No sense outputting
- # them unless will be used.
- if ($has_hangul_syllables) {
- $pre_body .= <<END;
-
- # Convert from code point to Jamo short name for use in composing Hangul
- # syllable names
- my %Jamo = (
-$jamo
- );
-
- # Leading consonant (can be null)
- my %Jamo_L = (
-$jamo_l
- );
-
- # Vowel
- my %Jamo_V = (
-$jamo_v
- );
-
- # Optional trailing consonant
- my %Jamo_T = (
-$jamo_t
- );
-
- # Computed re that splits up a Hangul name into LVT or LV syllables
- my \$syllable_re = qr/$jamo_re/;
-
- my \$HANGUL_SYLLABLE = "HANGUL SYLLABLE ";
- my \$HANGUL_SYLLABLE_LENGTH = length \$HANGUL_SYLLABLE;
-
- # These constants names and values were taken from the Unicode standard,
- # version 5.1, section 3.12. They are used in conjunction with Hangul
- # syllables
- my \$SBase = $SBase_string;
- my \$LBase = $LBase_string;
- my \$VBase = $VBase_string;
- my \$TBase = $TBase_string;
- my \$SCount = $SCount;
- my \$LCount = $LCount;
- my \$VCount = $VCount;
- my \$TCount = $TCount;
- my \$NCount = \$VCount * \$TCount;
-END
- } # End of has Jamos
-
- $pre_body .= << 'END';
-
- sub name_to_code_point_special {
- my $name = shift;
-
- # Returns undef if not one of the specially handled names; otherwise
- # returns the code point equivalent to the input name
-END
- if ($has_hangul_syllables) {
- $pre_body .= << 'END';
-
- if (substr($name, 0, $HANGUL_SYLLABLE_LENGTH) eq $HANGUL_SYLLABLE) {
- $name = substr($name, $HANGUL_SYLLABLE_LENGTH);
- return if $name !~ qr/^$syllable_re$/;
- my $L = $Jamo_L{$1};
- my $V = $Jamo_V{$2};
- my $T = (defined $3) ? $Jamo_T{$3} : 0;
- return ($L * $VCount + $V) * $TCount + $T + $SBase;
- }
-END
}
- $pre_body .= << 'END';
-
- # Name must end in '-code_point' for this to handle.
- if ($name !~ /^ (.*) - ($code_point_re) $/x) {
- return;
- }
-
- my $base = $1;
- my $code_point = CORE::hex $2;
-
- # Name must be one of the ones which has the code point in it.
- return if ! $names_ending_in_code_point{$base};
-
- # Look through the list of ranges that apply to this name to see if
- # the code point is in one of them.
- for (my $i = 0; $i < scalar @{$names_ending_in_code_point{$base}{'low'}}; $i++) {
- return if $names_ending_in_code_point{$base}{'low'}->[$i] > $code_point;
- next if $names_ending_in_code_point{$base}{'high'}->[$i] < $code_point;
-
- # Here, the code point is in the range.
- return $code_point;
- }
-
- # Here, looked like the name had a code point number in it, but
- # did not match one of the valid ones.
- return;
- }
-
- sub code_point_to_name_special {
- my $code_point = shift;
-
- # Returns the name of a code point if algorithmically determinable;
- # undef if not
+ else {
+ $return .= <<END;
+# The mappings must be modified to get the correct values by adding the code
+# point ordinal number to each one that is numeric.
END
- if ($has_hangul_syllables) {
- $pre_body .= << 'END';
-
- # If in the Hangul range, calculate the name based on Unicode's
- # algorithm
- if ($code_point >= $SBase && $code_point <= $SBase + $SCount -1) {
- use integer;
- my $SIndex = $code_point - $SBase;
- my $L = $LBase + $SIndex / $NCount;
- my $V = $VBase + ($SIndex % $NCount) / $TCount;
- my $T = $TBase + $SIndex % $TCount;
- $name = "$HANGUL_SYLLABLE$Jamo{$L}$Jamo{$V}";
- $name .= $Jamo{$T} if $T != $TBase;
- return $name;
- }
-END
}
- $pre_body .= << 'END';
-
- # Look through list of these code points for one in range.
- foreach my $hash (@code_points_ending_in_code_point) {
- return if $code_point < $hash->{'low'};
- if ($code_point <= $hash->{'high'}) {
- return sprintf("%s-%04X", $hash->{'name'}, $code_point);
- }
}
- return; # None found
- }
-} # End closure
-END
- } # End of has hangul or code point in name maps.
+ $return .= <<END;
- my $format = $self->format;
-
- my $return = <<END;
# The name this swash is to be known by, with the format of the mappings in
# the main body of the table, and what all code points missing from this file
# map to.
\$utf8::SwashInfo{'To$name'}{'format'} = '$format'; # $map_table_formats{$format}
END
+ if ($specials_name) {
+ $return .= <<END;
+\$utf8::SwashInfo{'To$name'}{'specials_name'} = '$specials_name'; # Name of hash of special mappings
+END
+ }
my $default_map = $default_map{$addr};
- $return .= "\$utf8::SwashInfo{'To$name'}{'missing'} = '$default_map';";
+ # For $CODE_POINT default maps and using adjustments, instead the default
+ # becomes zero.
+ $return .= "\$utf8::SwashInfo{'To$name'}{'missing'} = '"
+ . (($output_adjusted && $default_map eq $CODE_POINT)
+ ? "0"
+ : $default_map)
+ . "';";
+
if ($default_map eq $CODE_POINT) {
$return .= ' # code point maps to itself';
}
@@ -6219,10 +6637,7 @@
my $addr = do { no overloading; pack 'J', $self; };
# Clear the temporaries
- $has_hangul_syllables = 0;
undef @multi_code_point_maps;
- undef %names_ending_in_code_point;
- undef @code_points_ending_in_code_point;
# Calculate the format of the table if not already done.
my $format = $self->format;
@@ -6275,8 +6690,13 @@
if $format eq $FLOAT_FORMAT
&& $map !~ / ^ -? [0-9]+ \. [0-9]* $ /x;
$format = $HEX_FORMAT
- if $format eq $RATIONAL_FORMAT
- && $map !~ / ^ -? [0-9]+ ( \/ [0-9]+ )? $ /x;
+ if ($format eq $RATIONAL_FORMAT
+ && $map !~
+ m/ ^ -? [0-9]+ ( \/ [0-9]+ )? $ /x)
+ # Assume a leading zero means hex,
+ # even if all digits are 0-9
+ || ($format eq $INTEGER_FORMAT
+ && $map =~ /^0[0-9A-F]/);
$format = $STRING_FORMAT if $format eq $HEX_FORMAT
&& $map =~ /[^0-9A-F]/;
}
@@ -6293,15 +6713,18 @@
Carp::my_carp_bug("Expecting hex format for mapping table for $self, instead got '$format'")
}
+ # If the output is to be adjusted, the format of the table that gets
+ # output is actually 'a' instead of whatever it is stored internally
+ # as.
+ my $output_adjusted = ($self->to_output_map == $OUTPUT_ADJUSTED);
+ if ($output_adjusted) {
+ $format = $ADJUST_FORMAT;
+ }
+
$self->_set_format($format);
- # Core Perl has a different definition of mapping ranges than we do,
- # that is applicable mainly to mapping code points, so for tables
- # where it is possible that core Perl could be used to read it,
- # make it range size 1 to prevent possible confusion
- $self->set_range_size_1(1) if $format eq $HEX_FORMAT;
-
return $self->SUPER::write(
+ $output_adjusted,
($self->property == $block)
? 7 # block file needs more tab stops
: 3,
@@ -6359,7 +6782,15 @@
# if the Unicode one is deprecated, the Perl one will be too. Not so for
# unrelated tables. Relatedness makes generating the documentation easier.
#
-# 2) Conflicting. It may be that there will eventually be name clashes, with
+# 2) Complement.
+# Like equivalents, two tables may be the inverses of each other, the
+# intersection between them is null, and the union is every Unicode code
+# point. The two tables that occupy a binary property are necessarily like
+# this. By specifying one table as the complement of another, we can avoid
+# storing it on disk (using the other table and performing a fast
+# transform), and some memory and calculations.
+#
+# 3) Conflicting. It may be that there will eventually be name clashes, with
# the same name meaning different things. For a while, there actually were
# conflicts, but they have so far been resolved by changing Perl's or
# Unicode's definitions to match the other, but when this code was written,
@@ -6389,9 +6820,10 @@
my %parent;
# The parent table to this one, initially $self. This allows us to
- # distinguish between equivalent tables that are related, and those which
- # may not be, but share the same output file because they match the exact
- # same set of code points in the current Unicode release.
+ # distinguish between equivalent tables that are related (for which this
+ # is set to), and those which may not be, but share the same output file
+ # because they match the exact same set of code points in the current
+ # Unicode release.
main::set_access('parent', \%parent, 'r');
my %children;
@@ -6408,6 +6840,11 @@
# points.
main::set_access('matches_all', \%matches_all, 'r');
+ my %complement;
+ # Points to the complement that this table is expressed in terms of; 0 if
+ # none.
+ main::set_access('complement', \%complement, 'r');
+
sub new {
my $class = shift;
@@ -6456,6 +6893,7 @@
$matches_all{$addr} = $matches_all;
$leader{$addr} = $self;
$parent{$addr} = $self;
+ $complement{$addr} = 0;
if (defined $format && $format ne $EMPTY_FORMAT) {
Carp::my_carp_bug("'Format' must be '$EMPTY_FORMAT' in a match table instead of '$format'. Using '$EMPTY_FORMAT'");
@@ -6490,7 +6928,17 @@
'+=' => sub {
my $self = shift;
my $other = shift;
+ my $reversed = shift;
+ if ($reversed) {
+ Carp::my_carp_bug("Bad news. Can't cope with '"
+ . ref($other)
+ . ' += '
+ . ref($self)
+ . "'. undef returned.");
+ return;
+ }
+
return if $self->carp_if_locked;
my $addr = do { no overloading; pack 'J', $self; };
@@ -6507,14 +6955,33 @@
}
return $self;
},
+ '&=' => sub {
+ my $self = shift;
+ my $other = shift;
+ my $reversed = shift;
+
+ if ($reversed) {
+ Carp::my_carp_bug("Bad news. Can't cope with '"
+ . ref($other)
+ . ' &= '
+ . ref($self)
+ . "'. undef returned.");
+ return;
+ }
+
+ return if $self->carp_if_locked;
+ $self->_set_range_list($self->_range_list & $other);
+ return $self;
+ },
'-' => sub { my $self = shift;
my $other = shift;
my $reversed = shift;
-
if ($reversed) {
- Carp::my_carp_bug("Can't cope with a "
- . __PACKAGE__
- . " being the first parameter in a '-'. Subtraction ignored.");
+ Carp::my_carp_bug("Bad news. Can't cope with '"
+ . ref($other)
+ . ' - '
+ . ref($self)
+ . "'. undef returned.");
return;
}
@@ -6532,6 +6999,20 @@
return "Table '$name'";
}
+ sub _range_list {
+ # Returns the range list associated with this table, which will be the
+ # complement's if it has one.
+
+ my $self = shift;
+ my $complement;
+ if (($complement = $self->complement) != 0) {
+ return ~ $complement->_range_list;
+ }
+ else {
+ return $self->SUPER::_range_list;
+ }
+ }
+
sub add_alias {
# Add a synonym for this table. See the comments in the base class
@@ -6654,7 +7135,14 @@
Carp::my_carp_bug("Use add_alias() to set two Perl tables '$self' and '$other', equivalent.");
return;
}
- } elsif (! $other->perl_extension) {
+ } elsif ($self->property != $other->property # Depending on
+ # situation, might
+ # be better to use
+ # add_alias()
+ # instead for same
+ # property
+ && ! $other->perl_extension)
+ {
Carp::my_carp_bug("set_equivalent_to should have 'Related => 0 for equivalencing two Unicode properties. Assuming $self is not related to $other");
$related = 0;
}
@@ -6671,11 +7159,12 @@
# Any tables that are equivalent to or children of this table must now
# instead be equivalent to or (children) to the new leader (parent),
# still equivalent. The equivalency includes their matches_all info,
- # and for related tables, their status
+ # and for related tables, their fate and status.
# All related tables are of necessity equivalent, but the converse
# isn't necessarily true
my $status = $other->status;
my $status_info = $other->status_info;
+ my $fate = $other->fate;
my $matches_all = $matches_all{other_addr};
my $caseless_equivalent = $other->caseless_equivalent;
foreach my $table ($current_leader, @{$equivalents{$leader}}) {
@@ -6691,6 +7180,11 @@
$parent{$table_addr} = $other;
push @{$children{$other_addr}}, $table;
$table->set_status($status, $status_info);
+
+ # This reason currently doesn't get exposed outside; otherwise
+ # would have to look up the parent's reason and use it instead.
+ $table->set_fate($fate, "Parent's fate");
+
$self->set_caseless_equivalent($caseless_equivalent);
}
}
@@ -6702,6 +7196,26 @@
return;
}
+ sub set_complement {
+ # Set $self to be the complement of the parameter table. $self is
+ # locked, as what it contains should all come from the other table.
+
+ my $self = shift;
+ my $other = shift;
+
+ my %args = @_;
+ Carp::carp_extra_args(\%args) if main::DEBUG && %args;
+
+ if ($other->complement != 0) {
+ Carp::my_carp_bug("Can't set $self to be the complement of $other, which itself is the complement of " . $other->complement);
+ return;
+ }
+ my $addr = do { no overloading; pack 'J', $self; };
+ $complement{$addr} = $other;
+ $self->lock;
+ return;
+ }
+
sub add_range { # Add a range to the list for this table.
my $self = shift;
# Rest of parameters passed on
@@ -6710,6 +7224,14 @@
return $self->_range_list->add_range(@_);
}
+ sub header {
+ my $self = shift;
+ Carp::carp_extra_args(\@_) if main::DEBUG && @_;
+
+ # All match tables are to be used only by the Perl core.
+ return $self->SUPER::header() . $INTERNAL_ONLY_HEADER;
+ }
+
sub pre_body { # Does nothing for match tables.
return
}
@@ -6718,11 +7240,26 @@
return
}
+ sub set_fate {
+ my $self = shift;
+ my $fate = shift;
+ my $reason = shift;
+ Carp::carp_extra_args(\@_) if main::DEBUG && @_;
+
+ $self->SUPER::set_fate($fate, $reason);
+
+ # All children share this fate
+ foreach my $child ($self->children) {
+ $child->set_fate($fate, $reason);
+ }
+ return;
+ }
+
sub write {
my $self = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- return $self->SUPER::write(2); # 2 tab stops
+ return $self->SUPER::write(0, 2); # No adjustments; 2 tab stops
}
sub set_final_comment {
@@ -6767,6 +7304,9 @@
# \p{}'s
my @global_comments; # List of all the tables' comments that are
# there before this routine was called.
+ my $has_ucd_alias = 0; # If there is an alias that is accessible via
+ # Unicode::UCD. If not, then don't say it is
+ # in the comment
# Get list of all the parent tables that are equivalent to this one
# (including itself).
@@ -6830,18 +7370,23 @@
# listing all possible combinations in the comment, we make
# sure that each synonym occurs at least once, and add
# commentary that the other combinations are possible.
+ # Because regular expressions don't recognize things like
+ # \p{jsn=}, only look at non-null right-hand-sides
my @property_aliases = $table_property->aliases;
- my @table_aliases = $table->aliases;
+ my @table_aliases = grep { $_->name ne "" } $table->aliases;
- Carp::my_carp_bug("$table doesn't have any names. Proceeding anyway.") unless @table_aliases;
-
# The alias lists above are already ordered in the order we
# want to output them. To ensure that each synonym is listed,
- # we must use the max of the two numbers.
- my $listed_combos = main::max(scalar @table_aliases,
- scalar @property_aliases);
+ # we must use the max of the two numbers. But if there are no
+ # legal synonyms (nothing in @table_aliases), then we don't
+ # list anything.
+ my $listed_combos = (@table_aliases)
+ ? main::max(scalar @table_aliases,
+ scalar @property_aliases)
+ : 0;
trace "$listed_combos, tables=", scalar @table_aliases, "; names=", scalar @property_aliases if main::DEBUG;
+
my $property_had_compound_name = 0;
for my $i (0 .. $listed_combos - 1) {
@@ -6856,6 +7401,7 @@
[$i % @table_aliases];
my $table_alias = $table_alias_object->name;
my $loose_match = $table_alias_object->loose_match;
+ $has_ucd_alias |= $table_alias_object->ucd;
if ($table_alias !~ /\D/) { # Clarify large numbers.
$table_alias = main::clarify_number($table_alias)
@@ -6877,16 +7423,8 @@
my $flag = $property->status
|| $table->status
|| $table_alias_object->status;
- if ($flag) {
- if ($flag ne $PLACEHOLDER) {
- $flags{$flag} = $status_past_participles{$flag};
- } else {
- $flags{$flag} = <<END;
-a placeholder because it is not in Version $string_version of Unicode, but is
-needed by the Perl core to work gracefully. Because it is not in this version
-of Unicode, it will not be listed in $pod_file.pod
-END
- }
+ if ($flag && $flag ne $PLACEHOLDER) {
+ $flags{$flag} = $status_past_participles{$flag};
}
$loose_count++;
@@ -6965,7 +7503,7 @@
my $synonyms;
my $entries;
- if ($total_entries <= 1) {
+ if ($total_entries == 1) {
$synonyms = "";
$entries = 'entry';
$any_of_these = 'this'
@@ -6977,6 +7515,9 @@
}
my $comment = "";
+ if ($has_ucd_alias) {
+ $comment .= "Use Unicode::UCD::prop_invlist() to access the contents of this file.\n\n";
+ }
if ($has_unrelated) {
$comment .= <<END;
This file is for tables that are not necessarily related: To conserve
@@ -6993,14 +7534,22 @@
foreach my $flag (sort keys %flags) {
$comment .= <<END;
'$flag' below means that this form is $flags{$flag}.
+Consult $pod_file.pod
END
- next if $flag eq $PLACEHOLDER;
- $comment .= "Consult $pod_file.pod\n";
}
$comment .= "\n";
}
- $comment .= <<END;
+ if ($total_entries == 0) {
+ Carp::my_carp("No regular expression construct can match $leader, as all names for it are the null string. Creating file anyway.");
+ $comment .= <<END;
+This file returns the $code_points in Unicode Version $string_version for
+$leader, but it is inaccessible through Perl regular expressions, as
+"\\p{prop=}" is not recognized.
+END
+
+ } else {
+ $comment .= <<END;
This file returns the $code_points in Unicode Version $string_version that
$match$synonyms:
@@ -7011,6 +7560,7 @@
variants. Upper/lower case distinctions never matter.
END
+ }
if ($compound_name) {
$comment .= <<END;
@@ -7212,6 +7762,12 @@
# have to keep more than three.
main::set_access('unique_maps', \%unique_maps);
+ my %pre_declared_maps;
+ # A boolean that gives whether the input data should declare all the
+ # tables used, or not. If the former, unknown ones raise a warning.
+ main::set_access('pre_declared_maps',
+ \%pre_declared_maps, 'r', 's');
+
sub new {
# The only required parameter is the positionally first, name. All
# other parameters are key => value pairs. See the documentation just
@@ -7239,6 +7795,12 @@
$full_name{$addr} = delete $args{'Full_Name'} || $name;
$type{$addr} = delete $args{'Type'} || $UNKNOWN;
$pseudo_map_type{$addr} = delete $args{'Map_Type'};
+ $pre_declared_maps{$addr} = delete $args{'Pre_Declared_Maps'}
+ # Starting in this release, property
+ # values should be defined for all
+ # properties, except those overriding this
+ // $v_version ge v5.1.0;
+
# Rest of parameters passed on.
$has_only_code_point_maps{$addr} = 1;
@@ -7261,6 +7823,7 @@
fallback => 0,
qw("") => "_operator_stringify",
"." => \&main::_operator_dot,
+ ".=" => \&main::_operator_dot_equal,
'==' => \&main::_operator_equal,
'!=' => \&main::_operator_not_equal,
'=' => sub { return shift },
@@ -7280,16 +7843,16 @@
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
if (ref $other) {
- Carp::my_carp_bug("Can't cope with a "
+ Carp::my_carp_bug("Bad news. Can't cope with a "
. ref($other)
. " argument to '-='. Subtraction ignored.");
return $self;
}
elsif ($reversed) { # Shouldn't happen in a -=, but just in case
- Carp::my_carp_bug("Can't cope with a "
- . __PACKAGE__
- . " being the first parameter in a '-='. Subtraction ignored.");
- return $self;
+ Carp::my_carp_bug("Bad news. Can't cope with subtracting a "
+ . ref $self
+ . " from a non-object. undef returned.");
+ return;
}
else {
no overloading;
@@ -7330,12 +7893,11 @@
_Alias_Hash => $table_ref{$addr},
_Property => $self,
- # gets property's status by default
+ # gets property's fate and status by default
+ Fate => $self->fate,
Status => $self->status,
_Status_Info => $self->status_info,
- %args,
- Internal_Only_Warning => 1); # Override any
- # input param
+ %args);
return unless defined $table;
}
@@ -7354,7 +7916,7 @@
Carp::my_carp("$self Added a match table '$name' to a string property '$self'. Changed it to a non-string property. Bad News.");
$type{$addr} = $NON_STRING;
}
- elsif ($type{$addr} != $ENUM) {
+ elsif ($type{$addr} != $ENUM && $type{$addr} != $FORCED_BINARY) {
if (scalar main::uniques(values %{$table_ref{$addr}}) > 2
&& $type{$addr} == $BINARY)
{
@@ -7366,6 +7928,25 @@
return $table;
}
+ sub delete_match_table {
+ # Delete the table referred to by $2 from the property $1.
+
+ my $self = shift;
+ my $table_to_remove = shift;
+ Carp::carp_extra_args(\@_) if main::DEBUG && @_;
+
+ my $addr = do { no overloading; pack 'J', $self; };
+
+ # Remove all names that refer to it.
+ foreach my $key (keys %{$table_ref{$addr}}) {
+ delete $table_ref{$addr}{$key}
+ if $table_ref{$addr}{$key} == $table_to_remove;
+ }
+
+ $table_to_remove->DESTROY;
+ return;
+ }
+
sub table {
# Return a pointer to the match table (with name given by the
# parameter) associated with this property; undef if none.
@@ -7425,6 +8006,11 @@
my $addr = do { no overloading; pack 'J', $self; };
+ # Swash names are used only on regular map tables; otherwise there
+ # should be no access to the property map table from other parts of
+ # Perl.
+ return if $map{$addr}->fate != $ORDINARY;
+
return $file{$addr} if defined $file{$addr};
return $map{$addr}->external_name;
}
@@ -7477,6 +8063,23 @@
return $map{pack 'J', $self}->map_add_or_replace_non_nulls($map{pack 'J', $other});
}
+ sub set_proxy_for {
+ # Certain tables are not generally written out to files, but
+ # Unicode::UCD has the intelligence to know that the file for $self
+ # can be used to reconstruct those tables. This routine just changes
+ # things so that UCD pod entries for those suppressed tables are
+ # generated, so the fact that a proxy is used is invisible to the
+ # user.
+
+ my $self = shift;
+
+ foreach my $property_name (@_) {
+ my $ref = property_ref($property_name);
+ next if $ref->to_output_map;
+ $ref->set_fate($MAP_PROXIED);
+ }
+ }
+
sub set_type {
# Set the type of the property. Mostly this is figured out by the
# data in the table. But this is used to set it explicitly. The
@@ -7488,27 +8091,40 @@
my $type = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- if ($type != $ENUM && $type != $BINARY && $type != $STRING) {
+ if ($type != $ENUM
+ && $type != $BINARY
+ && $type != $FORCED_BINARY
+ && $type != $STRING)
+ {
Carp::my_carp("Unrecognized type '$type'. Type not set");
return;
}
{ no overloading; $type{pack 'J', $self} = $type; }
- return if $type != $BINARY;
+ return if $type != $BINARY && $type != $FORCED_BINARY;
my $yes = $self->table('Y');
$yes = $self->table('Yes') if ! defined $yes;
- $yes = $self->add_match_table('Y') if ! defined $yes;
- $yes->add_alias('Yes');
- $yes->add_alias('T');
- $yes->add_alias('True');
+ $yes = $self->add_match_table('Y', Full_Name => 'Yes')
+ if ! defined $yes;
+ # Add aliases in order wanted, duplicates will be ignored. We use a
+ # binary property present in all releases for its ordered lists of
+ # true/false aliases. Note, that could run into problems in
+ # outputting things in that we don't distinguish between the name and
+ # full name of these. Hopefully, if the table was already created
+ # before this code is executed, it was done with these set properly.
+ my $bm = property_ref("Bidi_Mirrored");
+ foreach my $alias ($bm->table("Y")->aliases) {
+ $yes->add_alias($alias->name);
+ }
my $no = $self->table('N');
$no = $self->table('No') if ! defined $no;
- $no = $self->add_match_table('N') if ! defined $no;
- $no->add_alias('No');
- $no->add_alias('F');
- $no->add_alias('False');
+ $no = $self->add_match_table('N', Full_Name => 'No') if ! defined $no;
+ foreach my $alias ($bm->table("N")->aliases) {
+ $no->add_alias($alias->name);
+ }
+
return;
}
@@ -7582,7 +8198,9 @@
# If already have figured these out, no need to do so again, but we do
# a double check on ENUMS to make sure that a string property hasn't
# improperly been classified as an ENUM, so continue on with those.
- return if $type == $STRING || $type == $BINARY;
+ return if $type == $STRING
+ || $type == $BINARY
+ || $type == $FORCED_BINARY;
# If every map is to a code point, is a string property.
if ($type == $UNKNOWN
@@ -7627,6 +8245,29 @@
return;
}
+ sub set_fate {
+ my $self = shift;
+ my $fate = shift;
+ my $reason = shift; # Ignored unless suppressing
+ Carp::carp_extra_args(\@_) if main::DEBUG && @_;
+
+ my $addr = do { no overloading; pack 'J', $self; };
+ if ($fate == $SUPPRESSED) {
+ $why_suppressed{$self->complete_name} = $reason;
+ }
+
+ # Each table shares the property's fate, except that MAP_PROXIED
+ # doesn't affect match tables
+ $map{$addr}->set_fate($fate, $reason);
+ if ($fate != $MAP_PROXIED) {
+ foreach my $table ($map{$addr}, $self->tables) {
+ $table->set_fate($fate, $reason);
+ }
+ }
+ return;
+ }
+
+
# Most of the accessors for a property actually apply to its map table.
# Setup up accessor functions for those, referring to %map
for my $sub (qw(
@@ -7641,7 +8282,6 @@
comment
complete_name
containing_range
- core_access
count
default_map
delete_range
@@ -7648,6 +8288,7 @@
description
each_range
external_name
+ fate
file_path
format
initialize
@@ -7662,10 +8303,10 @@
range_size_1
reset_each_range
set_comment
- set_core_access
set_default_map
set_file_path
set_final_comment
+ _set_format
set_range_size_1
set_status
set_to_output_map
@@ -8064,7 +8705,7 @@
{ # Closure
- my $indent_increment = " " x 2;
+ my $indent_increment = " " x (($debugging_build) ? 2 : 0);
my %already_output;
$main::simple_dumper_nesting = 0;
@@ -8078,7 +8719,7 @@
my $item = shift;
my $indent = shift;
- $indent = "" if ! defined $indent;
+ $indent = "" if ! $debugging_build || ! defined $indent;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
@@ -8103,9 +8744,8 @@
my $copy = $item;
$copy = $UNDEF unless defined $copy;
- # Quote non-numbers (numbers also have optional leading '-' and
- # fractions)
- if ($copy eq "" || $copy !~ /^ -? \d+ ( \. \d+ )? $/x) {
+ # Quote non-integers (integers also have optional leading '-')
+ if ($copy eq "" || $copy !~ /^ -? \d+ $/x) {
# Escape apostrophe and backslash
$copy =~ s/ ( ['\\] ) /\\$1/xg;
@@ -8144,9 +8784,10 @@
# Indent array elements one level
$output .= &simple_dumper($item->[$i], $next_indent);
- $output =~ s/\n$//; # Remove trailing nl so as to
- $output .= " # [$i]\n"; # add a comment giving the
- # array index
+ next if ! $debugging_build;
+ $output =~ s/\n$//; # Remove any trailing nl so
+ $output .= " # [$i]\n"; # as to add a comment giving
+ # the array index
}
$output .= $indent; # Indent closing ']' to orig level
}
@@ -8274,6 +8915,24 @@
: "$self$other";
}
+sub _operator_dot_equal {
+ # Overloaded '.=' method that is common to all packages.
+
+ my $self = shift;
+ my $other = shift;
+ my $reversed = shift;
+ Carp::carp_extra_args(\@_) if main::DEBUG && @_;
+
+ $other = "" unless defined $other;
+
+ if ($reversed) {
+ return $other .= "$self";
+ }
+ else {
+ return "$self" . "$other";
+ }
+}
+
sub _operator_equal {
# Generic overloaded '==' routine. To be equal, they must be the exact
# same object
@@ -8328,6 +8987,11 @@
}
}
+
+ my $scf = property_ref("Simple_Case_Folding");
+ $scf->add_alias("scf");
+ $scf->add_alias("sfc");
+
return;
}
@@ -8338,56 +9002,35 @@
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
# This entry was missing from this file in earlier Unicode versions
- if (-e 'Jamo.txt') {
- my $jsn = property_ref('JSN');
- if (! defined $jsn) {
- $jsn = Property->new('JSN', Full_Name => 'Jamo_Short_Name');
- }
+ if (-e 'Jamo.txt' && ! defined property_ref('JSN')) {
+ Property->new('JSN', Full_Name => 'Jamo_Short_Name');
}
- # This entry is still missing as of 6.0, perhaps because no short name for
- # it.
- if (-e 'NameAliases.txt') {
- my $aliases = property_ref('Name_Alias');
- if (! defined $aliases) {
- $aliases = Property->new('Name_Alias');
- }
+ # These two properties must be defined in all releases so we can generate
+ # the tables from them to make regex \X work, but suppress their output so
+ # aren't application visible prior to releases where they should be
+ if (! defined property_ref('GCB')) {
+ Property->new('GCB', Full_Name => 'Grapheme_Cluster_Break',
+ Fate => $PLACEHOLDER);
}
+ if (! defined property_ref('hst')) {
+ Property->new('hst', Full_Name => 'Hangul_Syllable_Type',
+ Fate => $PLACEHOLDER);
+ }
# These are used so much, that we set globals for them.
$gc = property_ref('General_Category');
$block = property_ref('Block');
+ $script = property_ref('Script');
# Perl adds this alias.
$gc->add_alias('Category');
- # For backwards compatibility, these property files have particular names.
- my $upper = property_ref('Uppercase_Mapping');
- $upper->set_core_access('uc()');
- $upper->set_file('Upper'); # This is what utf8.c calls it
-
- my $lower = property_ref('Lowercase_Mapping');
- $lower->set_core_access('lc()');
- $lower->set_file('Lower');
-
- my $title = property_ref('Titlecase_Mapping');
- $title->set_core_access('ucfirst()');
- $title->set_file('Title');
-
- my $fold = property_ref('Case_Folding');
- $fold->set_file('Fold') if defined $fold;
-
- # utf8.c has a different meaning for non range-size-1 for map properties
- # that this program doesn't currently handle; and even if it were changed
- # to do so, some other code may be using them expecting range size 1.
- foreach my $property (qw {
- Case_Folding
- Lowercase_Mapping
- Titlecase_Mapping
- Uppercase_Mapping
- })
- {
- property_ref($property)->set_range_size_1(1);
+ # Unicode::Normalize expects this file with this name and directory.
+ my $ccc = property_ref('Canonical_Combining_Class');
+ if (defined $ccc) {
+ $ccc->set_file('CombiningClass');
+ $ccc->set_directory(File::Spec->curdir());
}
# These two properties aren't actually used in the core, but unfortunately
@@ -8508,6 +9151,22 @@
$urs->add_alias('kRSUnicode');
}
}
+
+ # For backwards compatibility with applications that may read the mapping
+ # file directly (it was documented in 5.12 and 5.14 as being thusly
+ # usable), keep it from being adjusted. (range_size_1 is
+ # used to force the traditional format.)
+ if (defined (my $nfkc_cf = property_ref('NFKC_Casefold'))) {
+ $nfkc_cf->set_to_output_map($EXTERNAL_MAP);
+ $nfkc_cf->set_range_size_1(1);
+ }
+ if (defined (my $bmg = property_ref('Bidi_Mirroring_Glyph'))) {
+ $bmg->set_to_output_map($EXTERNAL_MAP);
+ $bmg->set_range_size_1(1);
+ }
+
+ property_ref('Numeric_Value')->set_to_output_map($OUTPUT_ADJUSTED);
+
return;
}
@@ -8537,7 +9196,7 @@
na1 ; Unicode_1_Name
nt ; Numeric_Type
nv ; Numeric_Value
-sfc ; Simple_Case_Folding
+scf ; Simple_Case_Folding
slc ; Simple_Lowercase_Mapping
stc ; Simple_Titlecase_Mapping
suc ; Simple_Uppercase_Mapping
@@ -8558,7 +9217,6 @@
# This first set is in the original old-style proplist.
push @return, split /\n/, <<'END';
-Alpha ; Alphabetic
Bidi_C ; Bidi_Control
Dash ; Dash
Dia ; Diacritic
@@ -8629,6 +9287,7 @@
}
if (-e 'DCoreProperties.txt') {
push @return, split /\n/, <<'END';
+Alpha ; Alphabetic
IDS ; ID_Start
XIDC ; XID_Continue
XIDS ; XID_Start
@@ -8679,6 +9338,34 @@
$file->insert_lines(get_old_property_value_aliases());
}
+ if ($v_version lt 4.0.0) {
+ $file->insert_lines(split /\n/, <<'END'
+hst; L ; Leading_Jamo
+hst; LV ; LV_Syllable
+hst; LVT ; LVT_Syllable
+hst; NA ; Not_Applicable
+hst; T ; Trailing_Jamo
+hst; V ; Vowel_Jamo
+END
+ );
+ }
+ if ($v_version lt 4.1.0) {
+ $file->insert_lines(split /\n/, <<'END'
+GCB; CN ; Control
+GCB; CR ; CR
+GCB; EX ; Extend
+GCB; L ; L
+GCB; LF ; LF
+GCB; LV ; LV
+GCB; LVT ; LVT
+GCB; T ; T
+GCB; V ; V
+GCB; XX ; Other
+END
+ );
+ }
+
+
# Add any explicit cjk values
$file->insert_lines(@cjk_property_values);
@@ -8692,17 +9379,36 @@
# Process each line of the file ...
while ($file->next_line) {
+ # Fix typo in input file
+ s/CCC133/CCC132/g if $v_version eq v6.1.0;
+
my ($property, @data) = split /\s*;\s*/;
- # The full name for the ccc property value is in field 2 of the
- # remaining ones; field 1 for all other properties. Swap ccc fields 1
- # and 2. (Rightmost splice removes field 2, returning it; left splice
- # inserts that into field 1, thus shifting former field 1 to field 2.)
- splice (@data, 1, 0, splice(@data, 2, 1)) if $property eq 'ccc';
+ # The ccc property has an extra field at the beginning, which is the
+ # numeric value. Move it to be after the other two, mnemonic, fields,
+ # so that those will be used as the property value's names, and the
+ # number will be an extra alias. (Rightmost splice removes field 1-2,
+ # returning them in a slice; left splice inserts that before anything,
+ # thus shifting the former field 0 to after them.)
+ splice (@data, 0, 0, splice(@data, 1, 2)) if $property eq 'ccc';
- # If there is no short name, use the full one in element 1
- $data[0] = $data[1] if $data[0] eq "n/a";
+ # Field 0 is a short name unless "n/a"; field 1 is the full name. If
+ # there is no short name, use the full one in element 1
+ if ($data[0] eq "n/a") {
+ $data[0] = $data[1];
+ }
+ elsif ($data[0] ne $data[1]
+ && standardize($data[0]) eq standardize($data[1])
+ && $data[1] !~ /[[:upper:]]/)
+ {
+ # Also, there is a bug in the file in which "n/a" is omitted, and
+ # the two fields are identical except for case, and the full name
+ # is all lower case. Copy the "short" name unto the full one to
+ # give it some upper case.
+ $data[1] = $data[0];
+ }
+
# Earlier releases had the pseudo property 'qc' that should expand to
# the ones that replace it below.
if ($property eq 'qc') {
@@ -8784,6 +9490,9 @@
bc ; R ; Right_To_Left
bc ; WS ; White_Space
+Bidi_M; N; No; F; False
+Bidi_M; Y; Yes; T; True
+
# The standard combining classes are very much different in v1, so only use
# ones that look right (not checked thoroughly)
ccc; 0; NR ; Not_Reordered
@@ -9070,6 +9779,33 @@
return @return;
}
+sub process_NormalizationsTest {
+
+ # Each line looks like:
+ # source code point; NFC; NFD; NFKC; NFKD
+ # e.g.
+ # 1E0A;1E0A;0044 0307;1E0A;0044 0307;
+
+ my $file= shift;
+ Carp::carp_extra_args(\@_) if main::DEBUG && @_;
+
+ # Process each line of the file ...
+ while ($file->next_line) {
+
+ next if /^@/;
+
+ my ($c1, $c2, $c3, $c4, $c5) = split /\s*;\s*/;
+
+ foreach my $var (\$c1, \$c2, \$c3, \$c4, \$c5) {
+ $$var = pack "U0U*", map { hex } split " ", $$var;
+ $$var =~ s/(\\)/$1$1/g;
+ }
+
+ push @normalization_tests,
+ "Test_N(q$c1, q$c2, q$c3, q$c4, q$c5);\n";
+ } # End of looping through the file
+}
+
sub output_perl_charnames_line ($$) {
# Output the entries in Perl_charnames specially, using 5 digits instead
@@ -9086,6 +9822,14 @@
# the little used $compare_versions feature is enabled.
my $compare_versions_range_list;
+ # These are constants to the $property_info hash in this subroutine, to
+ # avoid using a quoted-string which might have a typo.
+ my $TYPE = 'type';
+ my $DEFAULT_MAP = 'default_map';
+ my $DEFAULT_TABLE = 'default_table';
+ my $PSEUDO_MAP_TYPE = 'pseudo_map_type';
+ my $MISSINGS = 'missings';
+
sub process_generic_property_file {
# This processes a file containing property mappings and puts them
# into internal map tables. It should be used to handle any property
@@ -9264,22 +10008,22 @@
# If not the first time for this property, retrieve info about
# it from the cache
- if (defined ($property_info{$property_addr}{'type'})) {
- $property_type = $property_info{$property_addr}{'type'};
- $default_map = $property_info{$property_addr}{'default'};
+ if (defined ($property_info{$property_addr}{$TYPE})) {
+ $property_type = $property_info{$property_addr}{$TYPE};
+ $default_map = $property_info{$property_addr}{$DEFAULT_MAP};
$map_type
- = $property_info{$property_addr}{'pseudo_map_type'};
+ = $property_info{$property_addr}{$PSEUDO_MAP_TYPE};
$default_table
- = $property_info{$property_addr}{'default_table'};
+ = $property_info{$property_addr}{$DEFAULT_TABLE};
}
else {
# Here, is the first time for this property. Set up the
# cache.
- $property_type = $property_info{$property_addr}{'type'}
+ $property_type = $property_info{$property_addr}{$TYPE}
= $property_object->type;
$map_type
- = $property_info{$property_addr}{'pseudo_map_type'}
+ = $property_info{$property_addr}{$PSEUDO_MAP_TYPE}
= $property_object->pseudo_map_type;
# The Unicode files are set up so that if the map is not
@@ -9293,7 +10037,7 @@
else {
$property_object->set_type($BINARY);
$property_type
- = $property_info{$property_addr}{'type'}
+ = $property_info{$property_addr}{$TYPE}
= $BINARY;
}
}
@@ -9318,10 +10062,10 @@
if ($property_type == $STRING
|| $property_type == $UNKNOWN)
{
- $property_info{$addr}{'missings'} = $default;
+ $property_info{$addr}{$MISSINGS} = $default;
}
else {
- $property_info{$addr}{'missings'}
+ $property_info{$addr}{$MISSINGS}
= $property_object->table($default);
}
}
@@ -9328,7 +10072,7 @@
# Finished storing all the @missings defaults in the input
# file so far. Get the one for the current property.
- my $missings = $property_info{$property_addr}{'missings'};
+ my $missings = $property_info{$property_addr}{$MISSINGS};
# But we likely have separately stored what the default
# should be. (This is to accommodate versions of the
@@ -9392,7 +10136,7 @@
$default_table = $missings;
$default_map = $missings->full_name;
}
- $property_info{$property_addr}{'default_table'}
+ $property_info{$property_addr}{$DEFAULT_TABLE}
= $default_table;
}
elsif ($default_map ne $missings) {
@@ -9405,7 +10149,7 @@
}
}
- $property_info{$property_addr}{'default'}
+ $property_info{$property_addr}{$DEFAULT_MAP}
= $default_map;
# If haven't done so already, find the table corresponding
@@ -9415,7 +10159,7 @@
&& $property_type != $UNKNOWN)
{
$default_table = $property_info{$property_addr}
- {'default_table'}
+ {$DEFAULT_TABLE}
= $property_object->table($default_map);
}
} # End of is first time for this property
@@ -9546,6 +10290,7 @@
my $input_field_count = $i;
# This routine in addition outputs these extra fields:
+
my $DECOMP_TYPE = $i++; # Decomposition type
# These fields are modifications of ones above, and are usually
@@ -9633,7 +10378,7 @@
# the code point and name on each line. This was actually the hardest
# thing to design around. The code points in those ranges may actually
# have real maps not given by these two lines. These maps will either
- # be algorithmically determinable, or in the extracted files furnished
+ # be algorithmically determinable, or be in the extracted files furnished
# with the UCD. In the event of conflicts between these extracted files,
# and this one, Unicode says that this one prevails. But it shouldn't
# prevail for conflicts that occur in these ranges. The data from the
@@ -9657,21 +10402,21 @@
# first.) A comment for it will later be constructed based on the
# actual properties present and used
$perl_charname = Property->new('Perl_Charnames',
- Core_Access => '\N{...} and "use charnames"',
Default_Map => "",
Directory => File::Spec->curdir(),
File => 'Name',
- Internal_Only_Warning => 1,
+ Fate => $INTERNAL_ONLY,
Perl_Extension => 1,
Range_Size_1 => \&output_perl_charnames_line,
Type => $STRING,
);
+ $perl_charname->set_proxy_for('Name');
my $Perl_decomp = Property->new('Perl_Decomposition_Mapping',
Directory => File::Spec->curdir(),
File => 'Decomposition',
Format => $DECOMP_STRING_FORMAT,
- Internal_Only_Warning => 1,
+ Fate => $INTERNAL_ONLY,
Perl_Extension => 1,
Default_Map => $CODE_POINT,
@@ -9686,11 +10431,13 @@
# body of the table
Map_Type => $COMPUTE_NO_MULTI_CP,
Type => $STRING,
+ To_Output_Map => $INTERNAL_MAP,
);
+ $Perl_decomp->set_proxy_for('Decomposition_Mapping', 'Decomposition_Type');
$Perl_decomp->add_comment(join_lines(<<END
This mapping is a combination of the Unicode 'Decomposition_Type' and
'Decomposition_Mapping' properties, formatted for use by normalize.pm. It is
-identical to the official Unicode 'Decomposition_Mapping' property except for
+identical to the official Unicode 'Decomposition_Mapping' property except for
two things:
1) It omits the algorithmically determinable Hangul syllable decompositions,
which normalize.pm handles algorithmically.
@@ -9704,17 +10451,17 @@
my $Decimal_Digit = Property->new("Perl_Decimal_Digit",
Default_Map => "",
Perl_Extension => 1,
- File => 'Digit', # Trad. location
Directory => $map_directory,
Type => $STRING,
- Range_Size_1 => 1,
+ To_Output_Map => $OUTPUT_ADJUSTED,
);
$Decimal_Digit->add_comment(join_lines(<<END
This file gives the mapping of all code points which represent a single
-decimal digit [0-9] to their respective digits. For example, the code point
-U+0031 (an ASCII '1') is mapped to a numeric 1. These code points are those
-that have Numeric_Type=Decimal; not special things, like subscripts nor Roman
-numerals.
+decimal digit [0-9] to their respective digits, but it has ranges of 10 code
+points, and the mapping of each non-initial element of each range is actually
+not to "0", but to the offset that element has from its corresponding DIGIT 0.
+These code points are those that have Numeric_Type=Decimal; not special
+things, like subscripts nor Roman numerals.
END
));
@@ -9830,6 +10577,7 @@
$file->carp_bad_line("'$fields[$NUMERIC]' should be a whole or rational number. Processing as if it were") if $fields[$NUMERIC] !~ qr{ ^ -? \d+ ( / \d+ )? $ }x;
if ($fields[$PERL_DECIMAL_DIGIT] ne "") {
$file->carp_bad_line("$fields[$PERL_DECIMAL_DIGIT] should equal $fields[$NUMERIC]. Processing anyway") if $fields[$PERL_DECIMAL_DIGIT] != $fields[$NUMERIC];
+ $file->carp_bad_line("$fields[$PERL_DECIMAL_DIGIT] should be empty since the general category ($fields[$CATEGORY]) isn't 'Nd'. Processing as Decimal") if $fields[$CATEGORY] ne "Nd";
$fields[$NUMERIC_TYPE_OTHER_DIGIT] = 'Decimal';
}
elsif ($fields[$NUMERIC_TYPE_OTHER_DIGIT] ne "") {
@@ -9870,9 +10618,8 @@
# Some code points in this file have the pseudo-name
# '<control>', but the official name for such ones is the null
- # string. For charnames.pm, we use the Unicode version 1 name
- $fields[$NAME] = "";
- $fields[$CHARNAME] = $fields[$UNICODE_1_NAME];
+ # string.
+ $fields[$NAME] = $fields[$CHARNAME] = "";
# We had better not be in between range lines.
if ($in_range) {
@@ -10086,7 +10833,7 @@
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
# Flush the buffers.
- foreach my $i (1 .. $last_field) {
+ foreach my $i (0 .. $last_field) {
$file->insert_adjusted_lines("$start[$i]..$previous_cp; $field_names[$i]; $previous_fields[$i]");
}
@@ -10104,8 +10851,9 @@
# into it the Hangul syllable mappings. This is to avoid having
# to publish a subroutine in it to compute them. (which would
# essentially be this code.) This uses the algorithm published by
- # Unicode.
- if (property_ref('Decomposition_Mapping')->to_output_map) {
+ # Unicode. (No hangul syllables in version 1)
+ if ($v_version ge v2.0.0
+ && property_ref('Decomposition_Mapping')->to_output_map) {
for (my $S = $SBase; $S < $SBase + $SCount; $S++) {
use integer;
my $SIndex = $S - $SBase;
@@ -10145,11 +10893,15 @@
# the syntax is changed as well as the types to their later
# terminology. Otherwise normalize.pm would be very unhappy
# 5) Many ccc classes are different. These are left intact.
- # 6) U+FF10 - U+FF19 are missing their numeric values in all three
+ # 6) U+FF10..U+FF19 are missing their numeric values in all three
# fields. These are unchanged because it doesn't really cause
# problems for Perl.
# 7) A number of code points, such as controls, don't have their
- # Unicode Version 1 Names in this file. These are unchanged.
+ # Unicode Version 1 Names in this file. These are added.
+ # 8) A number of Symbols were marked as Lm. This changes those in
+ # the Latin1 range, so that regexes work.
+ # 9) The odd characters U+03DB .. U+03E1 weren't encoded but are
+ # referred to by their lc equivalents. Not fixed.
my @corrected_lines = split /\n/, <<'END';
4E00;<CJK Ideograph, First>;Lo;0;L;;;;;N;;;;;
@@ -10178,7 +10930,12 @@
$file->insert_lines(@copy);
}
+ elsif ($code_point =~ /^00/ && $fields[$CATEGORY] eq 'Lm') {
+ # There are no Lm characters in Latin1; these should be 'Sk', but
+ # there isn't that in V1.
+ $fields[$CATEGORY] = 'So';
+ }
if ($fields[$NUMERIC] eq '-') {
$fields[$NUMERIC] = '-1'; # This is what 2.0 made it.
@@ -10208,7 +10965,7 @@
# If is like '<+circled> 0052 <-circled>', convert to
# '<circled> 0052'
$fields[$PERL_DECOMPOSITION] =~
- s/ < \+ ( .*? ) > \s* (.*?) \s* <-\1> /<$1> $2/x;
+ s/ < \+ ( .*? ) > \s* (.*?) \s* <-\1> /<$1> $2/xg;
# Convert '<join> HHHH HHHH <join>' to '<medial> HHHH HHHH', etc.
$fields[$PERL_DECOMPOSITION] =~
@@ -10232,6 +10989,9 @@
# One entry has weird braces
$fields[$PERL_DECOMPOSITION] =~ s/[{}]//g;
+
+ # One entry at U+2116 has an extra <sup>
+ $fields[$PERL_DECOMPOSITION] =~ s/( < .*? > .* ) < .*? > \ * /$1/x;
}
$_ = join ';', $code_point, @fields;
@@ -10239,6 +10999,108 @@
return;
}
+ sub filter_bad_Nd_ucd {
+ # Early versions specified a value in the decimal digit field even
+ # though the code point wasn't a decimal digit. Clear the field in
+ # that situation, so that the main code doesn't think it is a decimal
+ # digit.
+
+ my ($code_point, @fields) = split /\s*;\s*/, $_, -1;
+ if ($fields[$PERL_DECIMAL_DIGIT] ne "" && $fields[$CATEGORY] ne 'Nd') {
+ $fields[$PERL_DECIMAL_DIGIT] = "";
+ $_ = join ';', $code_point, @fields;
+ }
+ return;
+ }
+
+ my @U1_control_names = split /\n/, <<'END';
+NULL
+START OF HEADING
+START OF TEXT
+END OF TEXT
+END OF TRANSMISSION
+ENQUIRY
+ACKNOWLEDGE
+BELL
+BACKSPACE
+HORIZONTAL TABULATION
+LINE FEED
+VERTICAL TABULATION
+FORM FEED
+CARRIAGE RETURN
+SHIFT OUT
+SHIFT IN
+DATA LINK ESCAPE
+DEVICE CONTROL ONE
+DEVICE CONTROL TWO
+DEVICE CONTROL THREE
+DEVICE CONTROL FOUR
+NEGATIVE ACKNOWLEDGE
+SYNCHRONOUS IDLE
+END OF TRANSMISSION BLOCK
+CANCEL
+END OF MEDIUM
+SUBSTITUTE
+ESCAPE
+FILE SEPARATOR
+GROUP SEPARATOR
+RECORD SEPARATOR
+UNIT SEPARATOR
+DELETE
+BREAK PERMITTED HERE
+NO BREAK HERE
+INDEX
+NEXT LINE
+START OF SELECTED AREA
+END OF SELECTED AREA
+CHARACTER TABULATION SET
+CHARACTER TABULATION WITH JUSTIFICATION
+LINE TABULATION SET
+PARTIAL LINE DOWN
+PARTIAL LINE UP
+REVERSE LINE FEED
+SINGLE SHIFT TWO
+SINGLE SHIFT THREE
+DEVICE CONTROL STRING
+PRIVATE USE ONE
+PRIVATE USE TWO
+SET TRANSMIT STATE
+CANCEL CHARACTER
+MESSAGE WAITING
+START OF GUARDED AREA
+END OF GUARDED AREA
+START OF STRING
+SINGLE CHARACTER INTRODUCER
+CONTROL SEQUENCE INTRODUCER
+STRING TERMINATOR
+OPERATING SYSTEM COMMAND
+PRIVACY MESSAGE
+APPLICATION PROGRAM COMMAND
+END
+
+ sub filter_early_U1_names {
+ # Very early versions did not have the Unicode_1_name field specified.
+ # They differed in which ones were present; make sure a U1 name
+ # exists, so that Unicode::UCD::charinfo will work
+
+ my ($code_point, @fields) = split /\s*;\s*/, $_, -1;
+
+
+ # @U1_control names above are entirely positional, so we pull them out
+ # in the exact order required, with gaps for the ones that don't have
+ # names.
+ if ($code_point =~ /^00[01]/
+ || $code_point eq '007F'
+ || $code_point =~ /^008[2-9A-F]/
+ || $code_point =~ /^009[0-8A-F]/)
+ {
+ my $u1_name = shift @U1_control_names;
+ $fields[$UNICODE_1_NAME] = $u1_name unless $fields[$UNICODE_1_NAME];
+ $_ = join ';', $code_point, @fields;
+ }
+ return;
+ }
+
sub filter_v2_1_5_ucd {
# A dozen entries in this 2.1.5 file had the mirrored and numeric
# columns swapped; These all had mirrored be 'N'. So if the numeric
@@ -10255,22 +11117,21 @@
sub filter_v6_ucd {
- # Unicode 6.0 co-opted the name BELL for U+1F514, so change the input
- # to pretend that U+0007 is ALERT instead, and for Perl 5.14, don't
- # allow the BELL name for U+1F514, so that the old usage can be
- # deprecated for one cycle.
+ # Unicode 6.0 co-opted the name BELL for U+1F514, but until 5.17,
+ # it wasn't accepted, to allow for some deprecation cycles. This
+ # function is not called after 5.16
return if $_ !~ /^(?:0007|1F514|070F);/;
my ($code_point, @fields) = split /\s*;\s*/, $_, -1;
if ($code_point eq '0007') {
- $fields[$CHARNAME] = "ALERT";
+ $fields[$CHARNAME] = "";
}
elsif ($code_point eq '070F') { # Unicode Corrigendum #8; see
# http://www.unicode.org/versions/corrigendum8.html
$fields[$BIDI] = "AL";
}
- elsif ($^V lt v5.15.0) { # For 5.16 will convert to use Unicode's name
+ elsif ($^V lt v5.18.0) { # For 5.18 will convert to use Unicode's name
$fields[$CHARNAME] = "";
}
@@ -10392,6 +11253,7 @@
my $lc; # Table for lowercase mapping
my $tc;
my $uc;
+ my %special_casing_code_points;
sub setup_special_casing {
# SpecialCasing.txt contains the non-simple case change mappings. The
@@ -10398,7 +11260,7 @@
# simple ones are in UnicodeData.txt, which should already have been
# read in to the full property data structures, so as to initialize
# these with the simple ones. Then the SpecialCasing.txt entries
- # overwrite the ones which have different full mappings.
+ # add or overwrite the ones which have different full mappings.
# This routine sees if the simple mappings are to be output, and if
# so, copies what has already been put into the full mapping tables,
@@ -10418,34 +11280,66 @@
$uc = property_ref('uc');
# For each of the case change mappings...
- foreach my $case_table ($lc, $tc, $uc) {
- my $case = $case_table->name;
- my $full = property_ref($case);
- unless (defined $full && ! $full->is_empty) {
+ foreach my $full_table ($lc, $tc, $uc) {
+ my $full_name = $full_table->name;
+ unless (defined $full_table && ! $full_table->is_empty) {
Carp::my_carp_bug("Need to process UnicodeData before SpecialCasing. Only special casing will be generated.");
}
- # The simple version's name in each mapping merely has an 's' in
- # front of the full one's
- my $simple = property_ref('s' . $case);
- $simple->initialize($full) if $simple->to_output_map();
+ # Create a table in the old-style format and with the original
+ # file name for backwards compatibility with applications that
+ # read it directly. The new tables contain both the simple and
+ # full maps, and the old are missing simple maps when there is a
+ # conflicting full one. Probably it would have been ok to add
+ # those to the legacy version, as was already done in 5.14 to the
+ # case folding one, but this was not done, out of an abundance of
+ # caution. The tables are set up here before we deal with the
+ # full maps so that as we handle those, we can override the simple
+ # maps for them in the legacy table, and merely add them in the
+ # new-style one.
+ my $legacy = Property->new("Legacy_" . $full_table->full_name,
+ File => $full_table->full_name =~
+ s/case_Mapping//r,
+ Range_Size_1 => 1,
+ Format => $HEX_FORMAT,
+ Default_Map => $CODE_POINT,
+ UCD => 0,
+ Initialize => $full_table,
+ To_Output_Map => $EXTERNAL_MAP,
+ );
- my $simple_only = Property->new("_s$case",
- Type => $STRING,
- Default_Map => $CODE_POINT,
- Perl_Extension => 1,
- Description => "The simple mappings for $case for code points that have full mappings as well");
- $simple_only->set_to_output_map($INTERNAL_MAP);
- $simple_only->add_comment(join_lines( <<END
-This file is for UCD.pm so that it can construct simple mappings that would
-otherwise be lost because they are overridden by full mappings.
+ $full_table->add_comment(join_lines( <<END
+This file includes both the simple and full case changing maps. The simple
+ones are in the main body of the table below, and the full ones adding to or
+overriding them are in the hash.
END
));
+
+ # The simple version's name in each mapping merely has an 's' in
+ # front of the full one's
+ my $simple_name = 's' . $full_name;
+ my $simple = property_ref($simple_name);
+ $simple->initialize($full_table) if $simple->to_output_map();
}
return;
}
+ sub filter_2_1_8_special_casing_line {
+
+ # This version had duplicate entries in this file. Delete all but the
+ # first one
+ my @fields = split /\s*;\s*/, $_, -1; # -1 => retain trailing null
+ # fields
+ if (exists $special_casing_code_points{$fields[0]}) {
+ $_ = "";
+ return;
+ }
+
+ $special_casing_code_points{$fields[0]} = 1;
+ filter_special_casing_line(@_);
+ }
+
sub filter_special_casing_line {
# Change the format of $_ from SpecialCasing.txt into something that
# the generic handler understands. Each input line contains three
@@ -10505,28 +11399,54 @@
return;
}
- $_ = "$fields[0]; lc; $fields[1]";
- $file->insert_adjusted_lines("$fields[0]; tc; $fields[2]");
- $file->insert_adjusted_lines("$fields[0]; uc; $fields[3]");
+ my $decimal_code_point = hex $fields[0];
- # Copy any simple case change to the special tables constructed if
- # being overridden by a multi-character case change.
- if ($fields[1] ne $fields[0]
- && (my $value = $lc->value_of(hex $fields[0])) ne $CODE_POINT)
- {
- $file->insert_adjusted_lines("$fields[0]; _slc; $value");
+ # Loop to handle each of the three mappings in the input line, in
+ # order, with $i indicating the current field number.
+ my $i = 0;
+ for my $object ($lc, $tc, $uc) {
+ $i++; # First time through, $i = 0 ... 3rd time = 3
+
+ my $value = $object->value_of($decimal_code_point);
+ $value = ($value eq $CODE_POINT)
+ ? $decimal_code_point
+ : hex $value;
+
+ # If this isn't a multi-character mapping, it should already have
+ # been read in.
+ if ($fields[$i] !~ / /) {
+ if ($value != hex $fields[$i]) {
+ Carp::my_carp("Bad news. UnicodeData.txt thinks "
+ . $object->name
+ . "(0x$fields[0]) is $value"
+ . " and SpecialCasing.txt thinks it is "
+ . hex($fields[$i])
+ . ". Good luck. Retaining UnicodeData value, and proceeding anyway.");
+ }
+ }
+ else {
+
+ # The mapping goes into both the legacy table, in which it
+ # replaces the simple one...
+ $file->insert_adjusted_lines("$fields[0]; Legacy_"
+ . $object->full_name
+ . "; $fields[$i]");
+
+ # ... and, the The regular table, in which it is additional,
+ # beyond the simple mapping.
+ $file->insert_adjusted_lines("$fields[0]; "
+ . $object->name
+ . "; "
+ . $CMD_DELIM
+ . "$REPLACE_CMD=$MULTIPLE_BEFORE"
+ . $CMD_DELIM
+ . $fields[$i]);
+ }
}
- if ($fields[2] ne $fields[0]
- && (my $value = $tc->value_of(hex $fields[0])) ne $CODE_POINT)
- {
- $file->insert_adjusted_lines("$fields[0]; _stc; $value");
- }
- if ($fields[3] ne $fields[0]
- && (my $value = $uc->value_of(hex $fields[0])) ne $CODE_POINT)
- {
- $file->insert_adjusted_lines("$fields[0]; _suc; $value");
- }
+ # Everything has been handled by the insert_adjusted_lines()
+ $_ = "";
+
return;
}
}
@@ -10567,6 +11487,7 @@
# Create the map for simple only if are going to output it, for otherwise
# it takes no part in anything we do.
my $to_output_simple;
+ my $all_folds;
sub setup_case_folding($) {
# Read in the case foldings in CaseFolding.txt. This handles both
@@ -10575,6 +11496,24 @@
$to_output_simple
= property_ref('Simple_Case_Folding')->to_output_map;
+ if (! $to_output_simple) {
+ property_ref('Case_Folding')->set_proxy_for('Simple_Case_Folding');
+ }
+
+ $all_folds = $perl->add_match_table("_Perl_Any_Folds",
+ Perl_Extension => 1,
+ Fate => $INTERNAL_ONLY,
+ Description => "Code points that particpate in some fold",
+ );
+
+ # If we ever wanted to show that these tables were combined, a new
+ # property method could be created, like set_combined_props()
+ property_ref('Case_Folding')->add_comment(join_lines( <<END
+This file includes both the simple and full case folding maps. The simple
+ones are in the main body of the table below, and the full ones adding to or
+overriding them are in the hash.
+END
+ ));
return;
}
@@ -10604,7 +11543,7 @@
return;
}
- if ($type eq 'T') { # Skip Turkic case folding, is locale dependent
+ if ($type =~ / ^ [IT] $/x) { # Skip Turkic case folding, is locale dependent
$_ = "";
return;
}
@@ -10617,7 +11556,21 @@
# so that _swash_inversion_hash() is able to construct closures
# without having to worry about F mappings.
if ($type eq 'C' || $type eq 'F' || $type eq 'I' || $type eq 'S') {
- $_ = "$range; Case_Folding; $CMD_DELIM$REPLACE_CMD=$MULTIPLE$CMD_DELIM$map";
+ my $from = hex $range; # Assumes range is single
+ $all_folds->add_range($from, $from);
+ $_ = "$range; Case_Folding; "
+ . "$CMD_DELIM$REPLACE_CMD=$MULTIPLE_BEFORE$CMD_DELIM$map";
+
+ if ($type eq 'F') {
+ my @string = split " ", $map;
+ for my $i (0 .. @string - 1 -1) {
+ my $decimal = hex $string[$i];
+ $all_folds->add_range($decimal, $decimal);
+ }
+ }
+ else {
+ $all_folds->add_range(hex $map, hex $map);
+ }
}
else {
$_ = "";
@@ -10790,9 +11743,7 @@
{ # Closure
my %unihan_properties;
- my $iicore;
-
sub setup_unihan {
# Do any special setup for Unihan properties.
@@ -10800,16 +11751,23 @@
my $usource = property_ref('kIRG_USource');
$usource->set_type($STRING) if defined $usource;
- # This property is to be considered binary, so change all the values
- # to Y.
- $iicore = property_ref('kIICore');
+ # This property is to be considered binary (it says so in
+ # http://www.unicode.org/reports/tr38/)
+ my $iicore = property_ref('kIICore');
if (defined $iicore) {
- $iicore->add_match_table('Y') if ! defined $iicore->table('Y');
+ $iicore->set_type($FORCED_BINARY);
+ $iicore->table("Y")->add_note("Forced to a binary property as per unicode.org UAX #38.");
- # We have to change the default map, because the @missing line is
- # misleading, given that we are treating it as binary.
- $iicore->set_default_map('N');
- $iicore->set_type($BINARY);
+ # Unicode doesn't include the maps for this property, so don't
+ # warn that they are missing.
+ $iicore->set_pre_declared_maps(0);
+ $iicore->add_comment(join_lines( <<END
+This property contains enum values, but Unicode UAX #38 says it should be
+interpreted as binary, so Perl creates tables for both 1) its enum values,
+plus 2) true/false tables in which it is considered true for all code points
+that have a non-null value
+END
+ ));
}
return;
@@ -10844,12 +11802,6 @@
return;
}
- # The iicore property is supposed to be a boolean, so convert to our
- # standard boolean form.
- if (defined $iicore && $unihan_properties{$property} == $iicore) {
- $_ =~ s/$property.*/$property\tY/
- }
-
# Convert the tab separators to our standard semi-colons, and convert
# the U+HHHH notation to the rest of the standard's HHHH
s/\t/;/g;
@@ -10905,26 +11857,26 @@
# PropList.txt has been in Unicode since version 2.0. Until 3.1, it
# was in a completely different syntax. Ken Whistler of Unicode says
# that it was something he used as an aid for his own purposes, but
- # was never an official part of the standard. However, comments in
- # DAge.txt indicate that non-character code points were available in
- # the UCD as of 3.1. It is unclear to me (khw) how they could be
- # there except through this file (but on the other hand, they first
- # appeared there in 3.0.1), so maybe it was part of the UCD, and maybe
- # not. But the claim is that it was published as an aid to others who
- # might want some more information than was given in the official UCD
- # of the time. Many of the properties in it were incorporated into
- # the later PropList.txt, but some were not. This program uses this
- # early file to generate property tables that are otherwise not
- # accessible in the early UCD's, and most were probably not really
- # official at that time, so one could argue that it should be ignored,
- # and you can easily modify things to skip this. And there are bugs
- # in this file in various versions. (For example, the 2.1.9 version
- # removes from Alphabetic the CJK range starting at 4E00, and they
- # weren't added back in until 3.1.0.) Many of this file's properties
- # were later sanctioned, so this code generates tables for those
- # properties that aren't otherwise in the UCD of the time but
- # eventually did become official, and throws away the rest. Here is a
- # list of all the ones that are thrown away:
+ # was never an official part of the standard. Many of the properties
+ # in it were incorporated into the later PropList.txt, but some were
+ # not. This program uses this early file to generate property tables
+ # that are otherwise not accessible in the early UCD's. It does this
+ # for the ones that eventually became official, and don't appear to be
+ # too different in their contents from the later official version, and
+ # throws away the rest. It could be argued that the ones it generates
+ # were probably not really official at that time, so should be
+ # ignored. You can easily modify things to skip all of them by
+ # changing this function to just set $_ to "", and return; and to skip
+ # certain of them by by simply removing their declarations from
+ # get_old_property_aliases().
+ #
+ # Here is a list of all the ones that are thrown away:
+ # Alphabetic The definitions for this are very
+ # defective, so better to not mislead
+ # people into thinking it works.
+ # Instead the Perl extension of the
+ # same name is constructed from first
+ # principles.
# Bidi=* duplicates UnicodeData.txt
# Combining never made into official property;
# is \P{ccc=0}
@@ -10957,7 +11909,7 @@
# Space different definition than eventual
# one.
# Titlecase duplicates UnicodeData.txt: gc=lt
- # Unassigned Code Value duplicates UnicodeData.txt: gc=cc
+ # Unassigned Code Value duplicates UnicodeData.txt: gc=cn
# Zero-width never made into official property;
# subset of gc=cf
# Most of the properties have the same names in this file as in later
@@ -11041,18 +11993,506 @@
return;
}
+sub setup_script_extensions {
+ # The Script_Extensions property starts out with a clone of the Script
+ # property.
+
+ my $scx = property_ref("Script_Extensions");
+ $scx = Property->new("scx", Full_Name => "Script_Extensions")
+ if ! defined $scx;
+ $scx->_set_format($STRING_WHITE_SPACE_LIST);
+ $scx->initialize($script);
+ $scx->set_default_map($script->default_map);
+ $scx->set_pre_declared_maps(0); # PropValueAliases doesn't list these
+ $scx->add_comment(join_lines( <<END
+The values for code points that appear in one script are just the same as for
+the 'Script' property. Likewise the values for those that appear in many
+scripts are either 'Common' or 'Inherited', same as with 'Script'. But the
+values of code points that appear in a few scripts are a space separated list
+of those scripts.
+END
+ ));
+
+ # Initialize scx's tables and the aliases for them to be the same as sc's
+ foreach my $table ($script->tables) {
+ my $scx_table = $scx->add_match_table($table->name,
+ Full_Name => $table->full_name);
+ foreach my $alias ($table->aliases) {
+ $scx_table->add_alias($alias->name);
+ }
+ }
+}
+
+sub filter_script_extensions_line {
+ # The Scripts file comes with the full name for the scripts; the
+ # ScriptExtensions, with the short name. The final mapping file is a
+ # combination of these, and without adjustment, would have inconsistent
+ # entries. This filters the latter file to convert to full names.
+ # Entries look like this:
+ # 064B..0655 ; Arab Syrc # Mn [11] ARABIC FATHATAN..ARABIC HAMZA BELOW
+
+ my @fields = split /\s*;\s*/;
+
+ # This script was erroneously omitted in this Unicode version.
+ $fields[1] .= ' Takr' if $v_version eq v6.1.0 && $fields[0] =~ /^0964/;
+
+ my @full_names;
+ foreach my $short_name (split " ", $fields[1]) {
+ push @full_names, $script->table($short_name)->full_name;
+ }
+ $fields[1] = join " ", @full_names;
+ $_ = join "; ", @fields;
+
+ return;
+}
+
+sub generate_hst {
+
+ # Populates the Hangul Syllable Type property from first principles
+
+ my $file= shift;
+ Carp::carp_extra_args(\@_) if main::DEBUG && @_;
+
+ # These few ranges are hard-coded in.
+ $file->insert_lines(split /\n/, <<'END'
+1100..1159 ; L
+115F ; L
+1160..11A2 ; V
+11A8..11F9 ; T
+END
+);
+
+ # The Hangul syllables in version 1 are completely different than what came
+ # after, so just ignore them there.
+ if ($v_version lt v2.0.0) {
+ my $property = property_ref($file->property);
+ push @tables_that_may_be_empty, $property->table('LV')->complete_name;
+ push @tables_that_may_be_empty, $property->table('LVT')->complete_name;
+ return;
+ }
+
+ # The algorithmically derived syllables are almost all LVT ones, so
+ # initialize the whole range with that.
+ $file->insert_lines(sprintf "%04X..%04X; LVT\n",
+ $SBase, $SBase + $SCount -1);
+
+ # Those ones that aren't LVT are LV, and they occur at intervals of
+ # $TCount code points, starting with the first code point, at $SBase.
+ for (my $i = $SBase; $i < $SBase + $SCount; $i += $TCount) {
+ $file->insert_lines(sprintf "%04X..%04X; LV\n", $i, $i);
+ }
+
+ return;
+}
+
+sub generate_GCB {
+
+ # Populates the Grapheme Cluster Break property from first principles
+
+ my $file= shift;
+ Carp::carp_extra_args(\@_) if main::DEBUG && @_;
+
+ # All these definitions are from
+ # http://www.unicode.org/reports/tr29/tr29-3.html with confirmation
+ # from http://www.unicode.org/reports/tr29/tr29-4.html
+
+ foreach my $range ($gc->ranges) {
+
+ # Extend includes gc=Me and gc=Mn, while Control includes gc=Cc
+ # and gc=Cf
+ if ($range->value =~ / ^ M [en] $ /x) {
+ $file->insert_lines(sprintf "%04X..%04X; Extend",
+ $range->start, $range->end);
+ }
+ elsif ($range->value =~ / ^ C [cf] $ /x) {
+ $file->insert_lines(sprintf "%04X..%04X; Control",
+ $range->start, $range->end);
+ }
+ }
+ $file->insert_lines("2028; Control"); # Line Separator
+ $file->insert_lines("2029; Control"); # Paragraph Separator
+
+ $file->insert_lines("000D; CR");
+ $file->insert_lines("000A; LF");
+
+ # Also from http://www.unicode.org/reports/tr29/tr29-3.html.
+ foreach my $code_point ( qw{
+ 40000
+ 09BE 09D7 0B3E 0B57 0BBE 0BD7 0CC2 0CD5 0CD6
+ 0D3E 0D57 0DCF 0DDF FF9E FF9F 1D165 1D16E 1D16F
+ }
+ ) {
+ my $category = $gc->value_of(hex $code_point);
+ next if ! defined $category || $category eq 'Cn'; # But not if
+ # unassigned in this
+ # release
+ $file->insert_lines("$code_point; Extend");
+ }
+
+ my $hst = property_ref('Hangul_Syllable_Type');
+ if ($hst->count > 0) {
+ foreach my $range ($hst->ranges) {
+ $file->insert_lines(sprintf "%04X..%04X; %s",
+ $range->start, $range->end, $range->value);
+ }
+ }
+ else {
+ generate_hst($file);
+ }
+
+ return;
+}
+
+sub setup_early_name_alias {
+ my $file= shift;
+ Carp::carp_extra_args(\@_) if main::DEBUG && @_;
+
+ # This has the effect of pretending that the Name_Alias property was
+ # available in all Unicode releases. Strictly speaking, this property
+ # should not be availabe in early releases, but doing this allows
+ # charnames.pm to work on older releases without change. Prior to v5.16
+ # it had these names hard-coded inside it. Unicode 6.1 came along and
+ # created these names, and so they were removed from charnames.
+
+ my $aliases = property_ref('Name_Alias');
+ if (! defined $aliases) {
+ $aliases = Property->new('Name_Alias', Default_Map => "");
+ }
+
+ $file->insert_lines(get_old_name_aliases());
+
+ return;
+}
+
+sub get_old_name_aliases () {
+
+ # The Unicode_1_Name field, contains most of these names. One would
+ # expect, given the field's name, that its values would be fixed across
+ # versions, giving the true Unicode version 1 name for the character.
+ # Sadly, this is not the case. Actually Version 1.1.5 had no names for
+ # any of the controls; Version 2.0 introduced names for the C0 controls,
+ # and 3.0 introduced C1 names. 3.0.1 removed the name INDEX; and 3.2
+ # changed some names: it
+ # changed to parenthesized versions like "NEXT LINE" to
+ # "NEXT LINE (NEL)";
+ # changed PARTIAL LINE DOWN to PARTIAL LINE FORWARD
+ # changed PARTIAL LINE UP to PARTIAL LINE BACKWARD;;
+ # changed e.g. FILE SEPARATOR to INFORMATION SEPARATOR FOUR
+ # This list contains all the names that were defined so that
+ # charnames::vianame(), etc. understand them all EVEN if this version of
+ # Unicode didn't specify them (this could be construed as a bug).
+ # mktables elsewhere gives preference to the Unicode_1_Name field over
+ # these names, so that viacode() will return the correct value for that
+ # version of Unicode, except when that version doesn't define a name,
+ # viacode() will return one anyway (this also could be construed as a
+ # bug). But these potential "bugs" allow for the smooth working of code
+ # on earlier Unicode releases.
+
+ my @return = split /\n/, <<'END';
+0000;NULL;control
+0000;NUL;abbreviation
+0001;START OF HEADING;control
+0001;SOH;abbreviation
+0002;START OF TEXT;control
+0002;STX;abbreviation
+0003;END OF TEXT;control
+0003;ETX;abbreviation
+0004;END OF TRANSMISSION;control
+0004;EOT;abbreviation
+0005;ENQUIRY;control
+0005;ENQ;abbreviation
+0006;ACKNOWLEDGE;control
+0006;ACK;abbreviation
+0007;BELL;control
+0007;BEL;abbreviation
+0008;BACKSPACE;control
+0008;BS;abbreviation
+0009;CHARACTER TABULATION;control
+0009;HORIZONTAL TABULATION;control
+0009;HT;abbreviation
+0009;TAB;abbreviation
+000A;LINE FEED;control
+000A;LINE FEED (LF);control
+000A;NEW LINE;control
+000A;END OF LINE;control
+000A;LF;abbreviation
+000A;NL;abbreviation
+000A;EOL;abbreviation
+000B;LINE TABULATION;control
+000B;VERTICAL TABULATION;control
+000B;VT;abbreviation
+000C;FORM FEED;control
+000C;FORM FEED (FF);control
+000C;FF;abbreviation
+000D;CARRIAGE RETURN;control
+000D;CARRIAGE RETURN (CR);control
+000D;CR;abbreviation
+000E;SHIFT OUT;control
+000E;LOCKING-SHIFT ONE;control
+000E;SO;abbreviation
+000F;SHIFT IN;control
+000F;LOCKING-SHIFT ZERO;control
+000F;SI;abbreviation
+0010;DATA LINK ESCAPE;control
+0010;DLE;abbreviation
+0011;DEVICE CONTROL ONE;control
+0011;DC1;abbreviation
+0012;DEVICE CONTROL TWO;control
+0012;DC2;abbreviation
+0013;DEVICE CONTROL THREE;control
+0013;DC3;abbreviation
+0014;DEVICE CONTROL FOUR;control
+0014;DC4;abbreviation
+0015;NEGATIVE ACKNOWLEDGE;control
+0015;NAK;abbreviation
+0016;SYNCHRONOUS IDLE;control
+0016;SYN;abbreviation
+0017;END OF TRANSMISSION BLOCK;control
+0017;ETB;abbreviation
+0018;CANCEL;control
+0018;CAN;abbreviation
+0019;END OF MEDIUM;control
+0019;EOM;abbreviation
+001A;SUBSTITUTE;control
+001A;SUB;abbreviation
+001B;ESCAPE;control
+001B;ESC;abbreviation
+001C;INFORMATION SEPARATOR FOUR;control
+001C;FILE SEPARATOR;control
+001C;FS;abbreviation
+001D;INFORMATION SEPARATOR THREE;control
+001D;GROUP SEPARATOR;control
+001D;GS;abbreviation
+001E;INFORMATION SEPARATOR TWO;control
+001E;RECORD SEPARATOR;control
+001E;RS;abbreviation
+001F;INFORMATION SEPARATOR ONE;control
+001F;UNIT SEPARATOR;control
+001F;US;abbreviation
+0020;SP;abbreviation
+007F;DELETE;control
+007F;DEL;abbreviation
+0080;PADDING CHARACTER;figment
+0080;PAD;abbreviation
+0081;HIGH OCTET PRESET;figment
+0081;HOP;abbreviation
+0082;BREAK PERMITTED HERE;control
+0082;BPH;abbreviation
+0083;NO BREAK HERE;control
+0083;NBH;abbreviation
+0084;INDEX;control
+0084;IND;abbreviation
+0085;NEXT LINE;control
+0085;NEXT LINE (NEL);control
+0085;NEL;abbreviation
+0086;START OF SELECTED AREA;control
+0086;SSA;abbreviation
+0087;END OF SELECTED AREA;control
+0087;ESA;abbreviation
+0088;CHARACTER TABULATION SET;control
+0088;HORIZONTAL TABULATION SET;control
+0088;HTS;abbreviation
+0089;CHARACTER TABULATION WITH JUSTIFICATION;control
+0089;HORIZONTAL TABULATION WITH JUSTIFICATION;control
+0089;HTJ;abbreviation
+008A;LINE TABULATION SET;control
+008A;VERTICAL TABULATION SET;control
+008A;VTS;abbreviation
+008B;PARTIAL LINE FORWARD;control
+008B;PARTIAL LINE DOWN;control
+008B;PLD;abbreviation
+008C;PARTIAL LINE BACKWARD;control
+008C;PARTIAL LINE UP;control
+008C;PLU;abbreviation
+008D;REVERSE LINE FEED;control
+008D;REVERSE INDEX;control
+008D;RI;abbreviation
+008E;SINGLE SHIFT TWO;control
+008E;SINGLE-SHIFT-2;control
+008E;SS2;abbreviation
+008F;SINGLE SHIFT THREE;control
+008F;SINGLE-SHIFT-3;control
+008F;SS3;abbreviation
+0090;DEVICE CONTROL STRING;control
+0090;DCS;abbreviation
+0091;PRIVATE USE ONE;control
+0091;PRIVATE USE-1;control
+0091;PU1;abbreviation
+0092;PRIVATE USE TWO;control
+0092;PRIVATE USE-2;control
+0092;PU2;abbreviation
+0093;SET TRANSMIT STATE;control
+0093;STS;abbreviation
+0094;CANCEL CHARACTER;control
+0094;CCH;abbreviation
+0095;MESSAGE WAITING;control
+0095;MW;abbreviation
+0096;START OF GUARDED AREA;control
+0096;START OF PROTECTED AREA;control
+0096;SPA;abbreviation
+0097;END OF GUARDED AREA;control
+0097;END OF PROTECTED AREA;control
+0097;EPA;abbreviation
+0098;START OF STRING;control
+0098;SOS;abbreviation
+0099;SINGLE GRAPHIC CHARACTER INTRODUCER;figment
+0099;SGC;abbreviation
+009A;SINGLE CHARACTER INTRODUCER;control
+009A;SCI;abbreviation
+009B;CONTROL SEQUENCE INTRODUCER;control
+009B;CSI;abbreviation
+009C;STRING TERMINATOR;control
+009C;ST;abbreviation
+009D;OPERATING SYSTEM COMMAND;control
+009D;OSC;abbreviation
+009E;PRIVACY MESSAGE;control
+009E;PM;abbreviation
+009F;APPLICATION PROGRAM COMMAND;control
+009F;APC;abbreviation
+00A0;NBSP;abbreviation
+00AD;SHY;abbreviation
+200B;ZWSP;abbreviation
+200C;ZWNJ;abbreviation
+200D;ZWJ;abbreviation
+200E;LRM;abbreviation
+200F;RLM;abbreviation
+202A;LRE;abbreviation
+202B;RLE;abbreviation
+202C;PDF;abbreviation
+202D;LRO;abbreviation
+202E;RLO;abbreviation
+FEFF;BYTE ORDER MARK;alternate
+FEFF;BOM;abbreviation
+FEFF;ZWNBSP;abbreviation
+END
+
+ if ($v_version ge v3.0.0) {
+ push @return, split /\n/, <<'END';
+180B; FVS1; abbreviation
+180C; FVS2; abbreviation
+180D; FVS3; abbreviation
+180E; MVS; abbreviation
+202F; NNBSP; abbreviation
+END
+ }
+
+ if ($v_version ge v3.2.0) {
+ push @return, split /\n/, <<'END';
+034F; CGJ; abbreviation
+205F; MMSP; abbreviation
+2060; WJ; abbreviation
+END
+ # Add in VS1..VS16
+ my $cp = 0xFE00 - 1;
+ for my $i (1..16) {
+ push @return, sprintf("%04X; VS%d; abbreviation", $cp + $i, $i);
+ }
+ }
+ if ($v_version ge v4.0.0) { # Add in VS17..VS256
+ my $cp = 0xE0100 - 17;
+ for my $i (17..256) {
+ push @return, sprintf("%04X; VS%d; abbreviation", $cp + $i, $i);
+ }
+ }
+
+ # ALERT did not come along until 6.0, at which point it became preferred
+ # over BELL, and was never in the Unicode_1_Name field. For the same
+ # reasons, that the other names are made known to all releases by this
+ # function, we make ALERT known too. By inserting it
+ # last in early releases, BELL is preferred over it; and vice-vers in 6.0
+ my $alert = '0007; ALERT; control';
+ if ($v_version lt v6.0.0) {
+ push @return, $alert;
+ }
+ else {
+ unshift @return, $alert;
+ }
+
+ return @return;
+}
+
+sub filter_later_version_name_alias_line {
+
+ # This file has an extra entry per line for the alias type. This is
+ # handled by creating a compound entry: "$alias: $type"; First, split
+ # the line into components.
+ my ($range, $alias, $type, @remainder)
+ = split /\s*;\s*/, $_, -1; # -1 => retain trailing null fields
+
+ # This file contains multiple entries for some components, so tell the
+ # downstream code to allow this in our internal tables; the
+ # $MULTIPLE_AFTER preserves the input ordering.
+ $_ = join ";", $range, $CMD_DELIM
+ . $REPLACE_CMD
+ . '='
+ . $MULTIPLE_AFTER
+ . $CMD_DELIM
+ . "$alias: $type",
+ @remainder;
+ return;
+}
+
+sub filter_early_version_name_alias_line {
+
+ # Early versions did not have the trailing alias type field; implicitly it
+ # was 'correction'. But our synthetic lines we add in this program do
+ # have it, so test for the type field.
+ $_ .= "; correction" if $_ !~ /;.*;/;
+
+ filter_later_version_name_alias_line;
+ return;
+}
+
sub finish_Unicode() {
# This routine should be called after all the Unicode files have been read
# in. It:
- # 1) Adds the mappings for code points missing from the files which have
+ # 1) Creates properties that are missing from the version of Unicode being
+ # compiled, and which, for whatever reason, are needed for the Perl
+ # core to function properly. These are minimally populated as
+ # necessary.
+ # 2) Adds the mappings for code points missing from the files which have
# defaults specified for them.
- # 2) At this this point all mappings are known, so it computes the type of
+ # 3) At this this point all mappings are known, so it computes the type of
# each property whose type hasn't been determined yet.
- # 3) Calculates all the regular expression match tables based on the
+ # 4) Calculates all the regular expression match tables based on the
# mappings.
- # 3) Calculates and adds the tables which are defined by Unicode, but
- # which aren't derived by them
+ # 5) Calculates and adds the tables which are defined by Unicode, but
+ # which aren't derived by them, and certain derived tables that Perl
+ # uses.
+ # Folding information was introduced later into Unicode data. To get
+ # Perl's case ignore (/i) to work at all in releases that don't have
+ # folding, use the best available alternative, which is lower casing.
+ my $fold = property_ref('Case_Folding');
+ if ($fold->is_empty) {
+ $fold->initialize(property_ref('Lowercase_Mapping'));
+ $fold->add_note(join_lines(<<END
+WARNING: This table uses lower case as a substitute for missing fold
+information
+END
+ ));
+ }
+
+ # Multiple-character mapping was introduced later into Unicode data, so it
+ # is by default the simple version. If to output the simple versions and
+ # not present, just use the regular (which in these Unicode versions is
+ # the simple as well).
+ foreach my $map (qw { Uppercase_Mapping
+ Lowercase_Mapping
+ Titlecase_Mapping
+ Case_Folding
+ } )
+ {
+ my $simple = property_ref("Simple_$map");
+ next if ! $simple->is_empty;
+ if ($simple->to_output_map) {
+ $simple->initialize(property_ref($map));
+ }
+ else {
+ property_ref($map)->set_proxy_for($simple->name);
+ }
+ }
+
# For each property, fill in any missing mappings, and calculate the re
# match tables. If a property has more than one missing mapping, the
# default is a reference to a data structure, and requires data from other
@@ -11067,6 +12507,10 @@
# need to be finished up.
next if $property == $perl;
+ # Nor do we need to do anything with properties that aren't going to
+ # be output.
+ next if $property->fate == $SUPPRESSED;
+
# Handle the properties that have more than one possible default
if (ref $property->default_map) {
my $default_map = $property->default_map;
@@ -11128,64 +12572,92 @@
# Add any remaining code points to the mapping, using the default for
# missing code points.
+ my $default_table;
if (defined (my $default_map = $property->default_map)) {
- # This fills in any missing values with the default.
- $property->add_map(0, $LAST_UNICODE_CODEPOINT,
- $default_map, Replace => $NO);
-
# Make sure there is a match table for the default
- if (! defined $property->table($default_map)) {
- $property->add_match_table($default_map);
+ if (! defined ($default_table = $property->table($default_map))) {
+ $default_table = $property->add_match_table($default_map);
}
+
+ # And, if the property is binary, the default table will just
+ # be the complement of the other table.
+ if ($property_type == $BINARY) {
+ my $non_default_table;
+
+ # Find the non-default table.
+ for my $table ($property->tables) {
+ next if $table == $default_table;
+ $non_default_table = $table;
+ }
+ $default_table->set_complement($non_default_table);
+ }
+ else {
+
+ # This fills in any missing values with the default. It's not
+ # necessary to do this with binary properties, as the default
+ # is defined completely in terms of the Y table.
+ $property->add_map(0, $MAX_UNICODE_CODEPOINT,
+ $default_map, Replace => $NO);
+ }
}
# Have all we need to populate the match tables.
my $property_name = $property->name;
+ my $maps_should_be_defined = $property->pre_declared_maps;
foreach my $range ($property->ranges) {
my $map = $range->value;
- my $table = property_ref($property_name)->table($map);
+ my $table = $property->table($map);
if (! defined $table) {
# Integral and rational property values are not necessarily
- # defined in PropValueAliases, but all other ones should be,
- # starting in 5.1
- if ($v_version ge v5.1.0
+ # defined in PropValueAliases, but whether all the other ones
+ # should be depends on the property.
+ if ($maps_should_be_defined
&& $map !~ /^ -? \d+ ( \/ \d+ )? $/x)
{
Carp::my_carp("Table '$property_name=$map' should have been defined. Defining it now.")
}
- $table = property_ref($property_name)->add_match_table($map);
+ $table = $property->add_match_table($map);
}
+ next if $table->complement != 0; # Don't need to populate these
$table->add_range($range->start, $range->end);
}
- # And add the Is_ prefix synonyms for Perl 5.6 compatibility, in which
- # all properties have this optional prefix. These do not get a
- # separate entry in the pod file, because are covered by a wild-card
- # entry
+ # A forced binary property has additional true/false tables which
+ # should have been set up when it was forced into binary. The false
+ # table matches exactly the same set as the property's default table.
+ # The true table matches the complement of that. The false table is
+ # not the same as an additional set of aliases on top of the default
+ # table, so use 'set_equivalent_to'. If it were implemented as
+ # additional aliases, various things would have to be adjusted, but
+ # especially, if the user wants to get a list of names for the table
+ # using Unicode::UCD::prop_value_aliases(), s/he should get a
+ # different set depending on whether they want the default table or
+ # the false table.
+ if ($property_type == $FORCED_BINARY) {
+ $property->table('N')->set_equivalent_to($default_table,
+ Related => 1);
+ $property->table('Y')->set_complement($default_table);
+ }
+
+ # For Perl 5.6 compatibility, all properties matchable in regexes can
+ # have an optional 'Is_' prefix. This is now done in utf8_heavy.pl.
+ # But warn if this creates a conflict with a (new) Unicode property
+ # name, although it appears that Unicode has made a decision never to
+ # begin a property name with 'Is_', so this shouldn't happen.
foreach my $alias ($property->aliases) {
my $Is_name = 'Is_' . $alias->name;
- if (! defined (my $pre_existing = property_ref($Is_name))) {
- $property->add_alias($Is_name,
- Pod_Entry => 0,
- Status => $alias->status,
- Externally_Ok => 0);
- }
- else {
-
- # It seemed too much work to add in these warnings when it
- # appears that Unicode has made a decision never to begin a
- # property name with 'Is_', so this shouldn't happen, but just
- # in case, it is a warning.
+ if (defined (my $pre_existing = property_ref($Is_name))) {
Carp::my_carp(<<END
-There is already an alias named $Is_name (from " . $pre_existing . "), so not
-creating this alias for $property. The generated table and pod files do not
-warn users of this conflict.
+There is already an alias named $Is_name (from " . $pre_existing . "), so
+creating one for $property won't work. This is bad news. If it is not too
+late, get Unicode to back off. Otherwise go back to the old scheme (findable
+from the git blame log for this area of the code that suppressed individual
+aliases that conflict with the new Unicode names. Proceeding anyway.
END
);
- $has_Is_conflicts++;
}
} # End of loop through aliases for this property
} # End of loop through all Unicode properties.
@@ -11237,42 +12709,96 @@
my $Cs = $gc->table('Cs');
-
- # Folding information was introduced later into Unicode data. To get
- # Perl's case ignore (/i) to work at all in releases that don't have
- # folding, use the best available alternative, which is lower casing.
- my $fold = property_ref('Simple_Case_Folding');
- if ($fold->is_empty) {
- $fold->initialize(property_ref('Simple_Lowercase_Mapping'));
- $fold->add_note(join_lines(<<END
-WARNING: This table uses lower case as a substitute for missing fold
-information
+ # Create digit and case fold tables with the original file names for
+ # backwards compatibility with applications that read them directly.
+ my $Digit = Property->new("Legacy_Perl_Decimal_Digit",
+ Default_Map => "",
+ Perl_Extension => 1,
+ File => 'Digit', # Trad. location
+ Directory => $map_directory,
+ UCD => 0,
+ Type => $STRING,
+ To_Output_Map => $EXTERNAL_MAP,
+ Range_Size_1 => 1,
+ Initialize => property_ref('Perl_Decimal_Digit'),
+ );
+ $Digit->add_comment(join_lines(<<END
+This file gives the mapping of all code points which represent a single
+decimal digit [0-9] to their respective digits. For example, the code point
+U+0031 (an ASCII '1') is mapped to a numeric 1. These code points are those
+that have Numeric_Type=Decimal; not special things, like subscripts nor Roman
+numerals.
END
- ));
- }
+ ));
- # Multiple-character mapping was introduced later into Unicode data. If
- # missing, use the single-characters maps as best available alternative
- foreach my $map (qw { Uppercase_Mapping
- Lowercase_Mapping
- Titlecase_Mapping
- Case_Folding
- } ) {
- my $full = property_ref($map);
- if ($full->is_empty) {
- my $simple = property_ref('Simple_' . $map);
- $full->initialize($simple);
- $full->add_comment($simple->comment) if ($simple->comment);
- $full->add_note(join_lines(<<END
-WARNING: This table uses simple mapping (single-character only) as a
-substitute for missing multiple-character information
-END
- ));
+ Property->new('Legacy_Case_Folding',
+ File => "Fold",
+ Directory => $map_directory,
+ Default_Map => $CODE_POINT,
+ UCD => 0,
+ Range_Size_1 => 1,
+ Type => $STRING,
+ To_Output_Map => $EXTERNAL_MAP,
+ Format => $HEX_FORMAT,
+ Initialize => property_ref('cf'),
+ );
+
+ # The Script_Extensions property started out as a clone of the Script
+ # property. But processing its data file caused some elements to be
+ # replaced with different data. (These elements were for the Common and
+ # Inherited properties.) This data is a qw() list of all the scripts that
+ # the code points in the given range are in. An example line is:
+ # 060C ; Arab Syrc Thaa # Po ARABIC COMMA
+ #
+ # The code above has created a new match table named "Arab Syrc Thaa"
+ # which contains 060C. (The cloned table started out with this code point
+ # mapping to "Common".) Now we add 060C to each of the Arab, Syrc, and
+ # Thaa match tables. Then we delete the now spurious "Arab Syrc Thaa"
+ # match table. This is repeated for all these tables and ranges. The map
+ # data is retained in the map table for reference, but the spurious match
+ # tables are deleted.
+
+ my $scx = property_ref("Script_Extensions");
+ if (defined $scx) {
+ foreach my $table ($scx->tables) {
+ next unless $table->name =~ /\s/; # All the new and only the new
+ # tables have a space in their
+ # names
+ my @scripts = split /\s+/, $table->name;
+ foreach my $script (@scripts) {
+ my $script_table = $scx->table($script);
+ $script_table += $table;
+ }
+ $scx->delete_match_table($table);
}
}
- return
+
+ return;
}
+sub pre_3_dot_1_Nl () {
+
+ # Return a range list for gc=nl for Unicode versions prior to 3.1, which
+ # is when Unicode's became fully usable. These code points were
+ # determined by inspection and experimentation. gc=nl is important for
+ # certain Perl-extension properties that should be available in all
+ # releases.
+
+ my $Nl = Range_List->new();
+ if (defined (my $official = $gc->table('Nl'))) {
+ $Nl += $official;
+ }
+ else {
+ $Nl->add_range(0x2160, 0x2182);
+ $Nl->add_range(0x3007, 0x3007);
+ $Nl->add_range(0x3021, 0x3029);
+ }
+ $Nl->add_range(0xFE20, 0xFE23);
+ $Nl->add_range(0x16EE, 0x16F0) if $v_version ge v3.0.0; # 3.0 was when
+ # these were added
+ return $Nl;
+}
+
sub compile_perl() {
# Create perl-defined tables. Almost all are part of the pseudo-property
# named 'perl' internally to this program. Many of these are recommended
@@ -11288,8 +12814,8 @@
# 'Any' is all code points. As an error check, instead of just setting it
# to be that, construct it to be the union of all the major categories
- my $Any = $perl->add_match_table('Any',
- Description => "[\\x{0000}-\\x{$LAST_UNICODE_CODEPOINT_STRING}]",
+ $Any = $perl->add_match_table('Any',
+ Description => "[\\x{0000}-\\x{$MAX_UNICODE_CODEPOINT_STRING}]",
Matches_All => 1);
foreach my $major_table ($gc->tables) {
@@ -11300,10 +12826,10 @@
$Any += $major_table;
}
- if ($Any->max != $LAST_UNICODE_CODEPOINT) {
+ if ($Any->max != $MAX_UNICODE_CODEPOINT) {
Carp::my_carp_bug("Generated highest code point ("
. sprintf("%X", $Any->max)
- . ") doesn't match expected value $LAST_UNICODE_CODEPOINT_STRING.")
+ . ") doesn't match expected value $MAX_UNICODE_CODEPOINT_STRING.")
}
if ($Any->range_count != 1 || $Any->min != 0) {
Carp::my_carp_bug("Generated table 'Any' doesn't match all code points.")
@@ -11318,8 +12844,9 @@
);
# Our internal-only property should be treated as more than just a
- # synonym.
- $perl->add_match_table('_CombAbove')
+ # synonym; grandfather it in to the pod.
+ $perl->add_match_table('_CombAbove', Re_Pod_Entry => 1,
+ Fate => $INTERNAL_ONLY, Status => $DISCOURAGED)
->set_equivalent_to(property_ref('ccc')->table('Above'),
Related => 1);
@@ -11334,24 +12861,50 @@
# Very early releases didn't have blocks, so initialize ASCII ourselves if
# necessary
if ($ASCII->is_empty) {
- $ASCII->initialize([ 0..127 ]);
+ $ASCII->add_range(0, 127);
}
# Get the best available case definitions. Early Unicode versions didn't
# have Uppercase and Lowercase defined, so use the general category
- # instead for them.
+ # instead for them, modified by hard-coding in the code points each is
+ # missing.
my $Lower = $perl->add_match_table('Lower');
my $Unicode_Lower = property_ref('Lowercase');
if (defined $Unicode_Lower && ! $Unicode_Lower->is_empty) {
$Lower->set_equivalent_to($Unicode_Lower->table('Y'), Related => 1);
- $Unicode_Lower->table('Y')->set_caseless_equivalent(property_ref('Cased')->table('Y'));
- $Unicode_Lower->table('N')->set_caseless_equivalent(property_ref('Cased')->table('N'));
- $Lower->set_caseless_equivalent(property_ref('Cased')->table('Y'));
}
else {
- $Lower->set_equivalent_to($gc->table('Lowercase_Letter'),
- Related => 1);
+ $Lower += $gc->table('Lowercase_Letter');
+
+ # There are quite a few code points in Lower, that aren't in gc=lc,
+ # and not all are in all releases.
+ foreach my $code_point ( 0x00AA,
+ 0x00BA,
+ 0x02B0 .. 0x02B8,
+ 0x02C0 .. 0x02C1,
+ 0x02E0 .. 0x02E4,
+ 0x0345,
+ 0x037A,
+ 0x1D2C .. 0x1D6A,
+ 0x1D78,
+ 0x1D9B .. 0x1DBF,
+ 0x2071,
+ 0x207F,
+ 0x2090 .. 0x209C,
+ 0x2170 .. 0x217F,
+ 0x24D0 .. 0x24E9,
+ 0x2C7C .. 0x2C7D,
+ 0xA770,
+ 0xA7F8 .. 0xA7F9,
+ ) {
+ # Don't include the code point unless it is assigned in this
+ # release
+ my $category = $gc->value_of(hex $code_point);
+ next if ! defined $category || $category eq 'Cn';
+
+ $Lower += $code_point;
+ }
}
$Lower->add_alias('XPosixLower');
my $Posix_Lower = $perl->add_match_table("PosixLower",
@@ -11363,13 +12916,14 @@
my $Unicode_Upper = property_ref('Uppercase');
if (defined $Unicode_Upper && ! $Unicode_Upper->is_empty) {
$Upper->set_equivalent_to($Unicode_Upper->table('Y'), Related => 1);
- $Unicode_Upper->table('Y')->set_caseless_equivalent(property_ref('Cased')->table('Y'));
- $Unicode_Upper->table('N')->set_caseless_equivalent(property_ref('Cased')->table('N'));
- $Upper->set_caseless_equivalent(property_ref('Cased')->table('Y'));
}
else {
- $Upper->set_equivalent_to($gc->table('Uppercase_Letter'),
- Related => 1);
+
+ # Unlike Lower, there are only two ranges in Upper that aren't in
+ # gc=Lu, and all code points were assigned in all releases.
+ $Upper += $gc->table('Uppercase_Letter');
+ $Upper->add_range(0x2160, 0x216F); # Uppercase Roman numerals
+ $Upper->add_range(0x24B6, 0x24CF); # Circled Latin upper case letters
}
$Upper->add_alias('XPosixUpper');
my $Posix_Upper = $perl->add_match_table("PosixUpper",
@@ -11379,28 +12933,64 @@
# Earliest releases didn't have title case. Initialize it to empty if not
# otherwise present
- my $Title = $perl->add_match_table('Title');
- $Title->add_alias('Titlecase');
+ my $Title = $perl->add_match_table('Title', Full_Name => 'Titlecase',
+ Description => '(= \p{Gc=Lt})');
my $lt = $gc->table('Lt');
# Earlier versions of mktables had this related to $lt since they have
- # identical code points, but their casefolds are not equivalent, and so
- # now must be kept as separate entities.
- $Title += $lt if defined $lt;
+ # identical code points, but their caseless equivalents are not the same,
+ # one being 'Cased' and the other being 'LC', and so now must be kept as
+ # separate entities.
+ if (defined $lt) {
+ $Title += $lt;
+ }
+ else {
+ push @tables_that_may_be_empty, $Title->complete_name;
+ }
- # If this Unicode version doesn't have Cased, set up our own. From
- # Unicode 5.1: Definition D120: A character C is defined to be cased if
- # and only if C has the Lowercase or Uppercase property or has a
- # General_Category value of Titlecase_Letter.
my $Unicode_Cased = property_ref('Cased');
- unless (defined $Unicode_Cased) {
+ if (defined $Unicode_Cased) {
+ my $yes = $Unicode_Cased->table('Y');
+ my $no = $Unicode_Cased->table('N');
+ $Title->set_caseless_equivalent($yes);
+ if (defined $Unicode_Upper) {
+ $Unicode_Upper->table('Y')->set_caseless_equivalent($yes);
+ $Unicode_Upper->table('N')->set_caseless_equivalent($no);
+ }
+ $Upper->set_caseless_equivalent($yes);
+ if (defined $Unicode_Lower) {
+ $Unicode_Lower->table('Y')->set_caseless_equivalent($yes);
+ $Unicode_Lower->table('N')->set_caseless_equivalent($no);
+ }
+ $Lower->set_caseless_equivalent($yes);
+ }
+ else {
+ # If this Unicode version doesn't have Cased, set up the Perl
+ # extension from first principles. From Unicode 5.1: Definition D120:
+ # A character C is defined to be cased if and only if C has the
+ # Lowercase or Uppercase property or has a General_Category value of
+ # Titlecase_Letter.
my $cased = $perl->add_match_table('Cased',
Initialize => $Lower + $Upper + $Title,
Description => 'Uppercase or Lowercase or Titlecase',
);
- $Unicode_Cased = $cased;
+ # $notcased is purely for the caseless equivalents below
+ my $notcased = $perl->add_match_table('_Not_Cased',
+ Initialize => ~ $cased,
+ Fate => $INTERNAL_ONLY,
+ Description => 'All not-cased code points');
+ $Title->set_caseless_equivalent($cased);
+ if (defined $Unicode_Upper) {
+ $Unicode_Upper->table('Y')->set_caseless_equivalent($cased);
+ $Unicode_Upper->table('N')->set_caseless_equivalent($notcased);
+ }
+ $Upper->set_caseless_equivalent($cased);
+ if (defined $Unicode_Lower) {
+ $Unicode_Lower->table('Y')->set_caseless_equivalent($cased);
+ $Unicode_Lower->table('N')->set_caseless_equivalent($notcased);
+ }
+ $Lower->set_caseless_equivalent($cased);
}
- $Title->set_caseless_equivalent($Unicode_Cased->table('Y'));
# Similarly, set up our own Case_Ignorable property if this Unicode
# version doesn't have it. From Unicode 5.1: Definition D121: A character
@@ -11409,8 +12999,12 @@
# one of Nonspacing_Mark (Mn), Enclosing_Mark (Me), Format (Cf),
# Modifier_Letter (Lm), or Modifier_Symbol (Sk).
- # Perl has long had an internal-only alias for this property.
- my $perl_case_ignorable = $perl->add_match_table('_Case_Ignorable');
+ # Perl has long had an internal-only alias for this property; grandfather
+ # it in to the pod, but discourage its use.
+ my $perl_case_ignorable = $perl->add_match_table('_Case_Ignorable',
+ Re_Pod_Entry => 1,
+ Fate => $INTERNAL_ONLY,
+ Status => $DISCOURAGED);
my $case_ignorable = property_ref('Case_Ignorable');
if (defined $case_ignorable && ! $case_ignorable->is_empty) {
$perl_case_ignorable->set_equivalent_to($case_ignorable->table('Y'),
@@ -11461,16 +13055,83 @@
}
else {
- # For early releases, we don't get it exactly right. The below
- # includes more than it should, which in 5.2 terms is: L + Nl +
- # Other_Alphabetic. Other_Alphabetic contains many characters from
- # Mn and Mc. It's better to match more than we should, than less than
- # we should.
+ # The Alphabetic property doesn't exist for early releases, so
+ # generate it. The actual definition, in 5.2 terms is:
+ #
+ # gc=L + gc=Nl + Other_Alphabetic
+ #
+ # Other_Alphabetic is also not defined in these early releases, but it
+ # contains one gc=So range plus most of gc=Mn and gc=Mc, so we add
+ # those last two as well, then subtract the relatively few of them that
+ # shouldn't have been added. (The gc=So range is the circled capital
+ # Latin characters. Early releases mistakenly didn't also include the
+ # lower-case versions of these characters, and so we don't either, to
+ # maintain consistency with those releases that first had this
+ # property.
$Alpha->initialize($gc->table('Letter')
- + $gc->table('Mn')
- + $gc->table('Mc'));
- $Alpha += $gc->table('Nl') if defined $gc->table('Nl');
+ + pre_3_dot_1_Nl()
+ + $gc->table('Mn')
+ + $gc->table('Mc')
+ );
+ $Alpha->add_range(0x24D0, 0x24E9); # gc=So
+ foreach my $range ( [ 0x0300, 0x0344 ],
+ [ 0x0346, 0x034E ],
+ [ 0x0360, 0x0362 ],
+ [ 0x0483, 0x0486 ],
+ [ 0x0591, 0x05AF ],
+ [ 0x06DF, 0x06E0 ],
+ [ 0x06EA, 0x06EC ],
+ [ 0x0740, 0x074A ],
+ 0x093C,
+ 0x094D,
+ [ 0x0951, 0x0954 ],
+ 0x09BC,
+ 0x09CD,
+ 0x0A3C,
+ 0x0A4D,
+ 0x0ABC,
+ 0x0ACD,
+ 0x0B3C,
+ 0x0B4D,
+ 0x0BCD,
+ 0x0C4D,
+ 0x0CCD,
+ 0x0D4D,
+ 0x0DCA,
+ [ 0x0E47, 0x0E4C ],
+ 0x0E4E,
+ [ 0x0EC8, 0x0ECC ],
+ [ 0x0F18, 0x0F19 ],
+ 0x0F35,
+ 0x0F37,
+ 0x0F39,
+ [ 0x0F3E, 0x0F3F ],
+ [ 0x0F82, 0x0F84 ],
+ [ 0x0F86, 0x0F87 ],
+ 0x0FC6,
+ 0x1037,
+ 0x1039,
+ [ 0x17C9, 0x17D3 ],
+ [ 0x20D0, 0x20DC ],
+ 0x20E1,
+ [ 0x302A, 0x302F ],
+ [ 0x3099, 0x309A ],
+ [ 0xFE20, 0xFE23 ],
+ [ 0x1D165, 0x1D169 ],
+ [ 0x1D16D, 0x1D172 ],
+ [ 0x1D17B, 0x1D182 ],
+ [ 0x1D185, 0x1D18B ],
+ [ 0x1D1AA, 0x1D1AD ],
+ ) {
+ if (ref $range) {
+ $Alpha->delete_range($range->[0], $range->[1]);
+ }
+ else {
+ $Alpha->delete_range($range, $range);
+ }
+ }
$Alpha->add_description('Alphabetic');
+ $Alpha->add_alias('Alphabetic');
}
$Alpha->add_alias('XPosixAlpha');
my $Posix_Alpha = $perl->add_match_table("PosixAlpha",
@@ -11481,7 +13142,7 @@
$Posix_Lower->set_caseless_equivalent($Posix_Alpha);
my $Alnum = $perl->add_match_table('Alnum',
- Description => 'Alphabetic and (Decimal) Numeric',
+ Description => 'Alphabetic and (decimal) Numeric',
Initialize => $Alpha + $gc->table('Decimal_Number'),
);
$Alnum->add_alias('XPosixAlnum');
@@ -11497,7 +13158,19 @@
);
$Word->add_alias('XPosixWord');
my $Pc = $gc->table('Connector_Punctuation'); # 'Pc' Not in release 1
- $Word += $Pc if defined $Pc;
+ if (defined $Pc) {
+ $Word += $Pc;
+ }
+ else {
+ $Word += ord('_'); # Make sure this is a $Word
+ }
+ my $JC = property_ref('Join_Control'); # Wasn't in release 1
+ if (defined $JC) {
+ $Word += $JC->table('Y');
+ }
+ else {
+ $Word += 0x200C + 0x200D;
+ }
# This is a Perl extension, so the name doesn't begin with Posix.
my $PerlWord = $perl->add_match_table('PerlWord',
@@ -11536,24 +13209,25 @@
# No Posix equivalent for vertical space
my $Space = $perl->add_match_table('Space',
- Description => '\s including beyond ASCII plus vertical tab',
+ Description => '\s including beyond ASCII and vertical tab',
Initialize => $Blank + $VertSpace,
);
$Space->add_alias('XPosixSpace');
- $perl->add_match_table("PosixSpace",
+ my $posix_space = $perl->add_match_table("PosixSpace",
Description => "\\t, \\n, \\cK, \\f, \\r, and ' '. (\\cK is vertical tab)",
Initialize => $Space & $ASCII,
);
- # Perl's traditional space doesn't include Vertical Tab
+ # Perl's traditional space doesn't include Vertical Tab prior to v5.18
my $XPerlSpace = $perl->add_match_table('XPerlSpace',
Description => '\s, including beyond ASCII',
- Initialize => $Space - 0x000B,
+ #Initialize => $Space - 0x000B,
+ Initialize => $Space,
);
$XPerlSpace->add_alias('SpacePerl'); # A pre-existing synonym
my $PerlSpace = $perl->add_match_table('PerlSpace',
- Description => '\s, restricted to ASCII',
- Initialize => $XPerlSpace & $ASCII,
+ Description => '\s, restricted to ASCII = [ \f\n\r\t] plus vertical tab',
+ Initialize => $XPerlSpace & $ASCII,
);
@@ -11603,8 +13277,9 @@
Description => '\p{Punct} + ASCII-range \p{Symbol}',
Initialize => $gc->table('Punctuation')
+ ($ASCII & $gc->table('Symbol')),
+ Perl_Extension => 1
);
- $perl->add_match_table('PosixPunct',
+ $perl->add_match_table('PosixPunct', Perl_Extension => 1,
Description => '[-!"#$%&\'()*+,./:;<>?@[\\\]^_`{|}~]',
Initialize => $ASCII & $XPosixPunct,
);
@@ -11632,11 +13307,20 @@
0xFF10..0xFF19, 0xFF21..0xFF26, 0xFF41..0xFF46]);
$Xdigit->add_description('[0-9A-Fa-f] and corresponding fullwidth versions, like U+FF10: FULLWIDTH DIGIT ZERO');
}
- $perl->add_match_table('PosixXDigit',
- Initialize => $ASCII & $Xdigit,
- Description => '[0-9A-Fa-f]',
- );
+ # AHex was not present in early releases
+ my $PosixXDigit = $perl->add_match_table('PosixXDigit');
+ my $AHex = property_ref('ASCII_Hex_Digit');
+ if (defined $AHex && ! $AHex->is_empty) {
+ $PosixXDigit->set_equivalent_to($AHex->table('Y'), Related => 1);
+ }
+ else {
+ $PosixXDigit->initialize($Xdigit & $ASCII);
+ $PosixXDigit->add_alias('AHex');
+ $PosixXDigit->add_alias('Ascii_Hex_Digit');
+ }
+ $PosixXDigit->add_description('[0-9A-Fa-f]');
+
my $dt = property_ref('Decomposition_Type');
$dt->add_match_table('Non_Canon', Full_Name => 'Non_Canonical',
Initialize => ~ ($dt->table('None') + $dt->table('Canonical')),
@@ -11646,8 +13330,11 @@
# _CanonDCIJ is equivalent to Soft_Dotted, but if on a release earlier
# than SD appeared, construct it ourselves, based on the first release SD
- # was in.
- my $CanonDCIJ = $perl->add_match_table('_CanonDCIJ');
+ # was in. A pod entry is grandfathered in for it
+ my $CanonDCIJ = $perl->add_match_table('_CanonDCIJ', Re_Pod_Entry => 1,
+ Perl_Extension => 1,
+ Fate => $INTERNAL_ONLY,
+ Status => $DISCOURAGED);
my $soft_dotted = property_ref('Soft_Dotted');
if (defined $soft_dotted && ! $soft_dotted->is_empty) {
$CanonDCIJ->set_equivalent_to($soft_dotted->table('Y'), Related => 1);
@@ -11654,7 +13341,8 @@
}
else {
- # This list came from 3.2 Soft_Dotted.
+ # This list came from 3.2 Soft_Dotted; all of these code points are in
+ # all releases
$CanonDCIJ->initialize([ 0x0069,
0x006A,
0x012F,
@@ -11667,84 +13355,251 @@
$CanonDCIJ = $CanonDCIJ & $Assigned;
}
- # These are used in Unicode's definition of \X
- my $begin = $perl->add_match_table('_X_Begin', Perl_Extension => 1);
- my $extend = $perl->add_match_table('_X_Extend', Perl_Extension => 1);
+ # For backward compatibility, Perl has its own definition for IDStart.
+ # It is regular XID_Start plus the underscore, but all characters must be
+ # Word characters as well
+ my $XID_Start = property_ref('XID_Start');
+ my $perl_xids = $perl->add_match_table('_Perl_IDStart',
+ Perl_Extension => 1,
+ Fate => $INTERNAL_ONLY,
+ Initialize => ord('_')
+ );
+ if (defined $XID_Start
+ || defined ($XID_Start = property_ref('ID_Start')))
+ {
+ $perl_xids += $XID_Start->table('Y');
+ }
+ else {
+ # For Unicode versions that don't have the property, construct our own
+ # from first principles. The actual definition is:
+ # Letters
+ # + letter numbers (Nl)
+ # - Pattern_Syntax
+ # - Pattern_White_Space
+ # + stability extensions
+ # - NKFC modifications
+ #
+ # What we do in the code below is to include the identical code points
+ # that are in the first release that had Unicode's version of this
+ # property, essentially extrapolating backwards. There were no
+ # stability extensions until v4.1, so none are included; likewise in
+ # no Unicode version so far do subtracting PatSyn and PatWS make any
+ # difference, so those also are ignored.
+ $perl_xids += $gc->table('Letter') + pre_3_dot_1_Nl();
- my $gcb = property_ref('Grapheme_Cluster_Break');
+ # We do subtract the NFKC modifications that are in the first version
+ # that had this property. We don't bother to test if they are in the
+ # version in question, because if they aren't, the operation is a
+ # no-op. The NKFC modifications are discussed in
+ # http://www.unicode.org/reports/tr31/#NFKC_Modifications
+ foreach my $range ( 0x037A,
+ 0x0E33,
+ 0x0EB3,
+ [ 0xFC5E, 0xFC63 ],
+ [ 0xFDFA, 0xFE70 ],
+ [ 0xFE72, 0xFE76 ],
+ 0xFE78,
+ 0xFE7A,
+ 0xFE7C,
+ 0xFE7E,
+ [ 0xFF9E, 0xFF9F ],
+ ) {
+ if (ref $range) {
+ $perl_xids->delete_range($range->[0], $range->[1]);
+ }
+ else {
+ $perl_xids->delete_range($range, $range);
+ }
+ }
+ }
- # The 'extended' grapheme cluster came in 5.1. The non-extended
- # definition differs too much from the traditional Perl one to use.
- if (defined $gcb && defined $gcb->table('SpacingMark')) {
+ $perl_xids &= $Word;
- # Note that assumes HST is defined; it came in an earlier release than
- # GCB. In the line below, two negatives means: yes hangul
- $begin += ~ property_ref('Hangul_Syllable_Type')
- ->table('Not_Applicable')
- + ~ ($gcb->table('Control')
- + $gcb->table('CR')
- + $gcb->table('LF'));
- $begin->add_comment('For use in \X; matches: Hangul_Syllable | ! Control');
-
- $extend += $gcb->table('Extend') + $gcb->table('SpacingMark');
- $extend->add_comment('For use in \X; matches: Extend | SpacingMark');
+ my $perl_xidc = $perl->add_match_table('_Perl_IDCont',
+ Perl_Extension => 1,
+ Fate => $INTERNAL_ONLY);
+ my $XIDC = property_ref('XID_Continue');
+ if (defined $XIDC
+ || defined ($XIDC = property_ref('ID_Continue')))
+ {
+ $perl_xidc += $XIDC->table('Y');
}
- else { # Old definition, used on early releases.
- $extend += $gc->table('Mark')
- + 0x200C # ZWNJ
- + 0x200D; # ZWJ
- $begin += ~ $extend;
-
- # Here we may have a release that has the regular grapheme cluster
- # defined, or a release that doesn't have anything defined.
- # We set things up so the Perl core degrades gracefully, possibly with
- # placeholders that match nothing.
-
- if (! defined $gcb) {
- $gcb = Property->new('GCB', Status => $PLACEHOLDER);
+ else {
+ # Similarly, we construct our own XIDC if necessary for early Unicode
+ # versions. The definition is:
+ # everything in XIDS
+ # + Gc=Mn
+ # + Gc=Mc
+ # + Gc=Nd
+ # + Gc=Pc
+ # - Pattern_Syntax
+ # - Pattern_White_Space
+ # + stability extensions
+ # - NFKC modifications
+ #
+ # The same thing applies to this as with XIDS for the PatSyn, PatWS,
+ # and stability extensions. There is a somewhat different set of NFKC
+ # mods to remove (and add in this case). The ones below make this
+ # have identical code points as in the first release that defined it.
+ $perl_xidc += $perl_xids
+ + $gc->table('L')
+ + $gc->table('Mn')
+ + $gc->table('Mc')
+ + $gc->table('Nd')
+ + 0x00B7
+ ;
+ if (defined (my $pc = $gc->table('Pc'))) {
+ $perl_xidc += $pc;
}
- my $hst = property_ref('HST');
- if (!defined $hst) {
- $hst = Property->new('HST', Status => $PLACEHOLDER);
- $hst->add_match_table('Not_Applicable',
- Initialize => $Any,
- Matches_All => 1);
+ else { # 1.1.5 didn't have Pc, but these should have been in it
+ $perl_xidc += 0xFF3F;
+ $perl_xidc->add_range(0x203F, 0x2040);
+ $perl_xidc->add_range(0xFE33, 0xFE34);
+ $perl_xidc->add_range(0xFE4D, 0xFE4F);
}
- # On some releases, here we may not have the needed tables for the
- # perl core, in some releases we may.
- foreach my $name (qw{ L LV LVT T V prepend }) {
- my $table = $gcb->table($name);
- if (! defined $table) {
- $table = $gcb->add_match_table($name);
- push @tables_that_may_be_empty, $table->complete_name;
+ # Subtract the NFKC mods
+ foreach my $range ( 0x037A,
+ [ 0xFC5E, 0xFC63 ],
+ [ 0xFDFA, 0xFE1F ],
+ 0xFE70,
+ [ 0xFE72, 0xFE76 ],
+ 0xFE78,
+ 0xFE7A,
+ 0xFE7C,
+ 0xFE7E,
+ ) {
+ if (ref $range) {
+ $perl_xidc->delete_range($range->[0], $range->[1]);
}
-
- # The HST property predates the GCB one, and has identical tables
- # for some of them, so use it if we can.
- if ($table->is_empty
- && defined $hst
- && defined $hst->table($name))
- {
- $table += $hst->table($name);
+ else {
+ $perl_xidc->delete_range($range, $range);
}
}
}
- # More GCB. If we found some hangul syllables, populate a combined
- # table.
- my $lv_lvt_v = $perl->add_match_table('_X_LV_LVT_V');
- my $LV = $gcb->table('LV');
- if ($LV->is_empty) {
- push @tables_that_may_be_empty, $lv_lvt_v->complete_name;
- } else {
- $lv_lvt_v += $LV + $gcb->table('LVT') + $gcb->table('V');
- $lv_lvt_v->add_comment('For use in \X; matches: HST=LV | HST=LVT | HST=V');
+ $perl_xidc &= $Word;
+
+ my $charname_begin = $perl->add_match_table('_Perl_Charname_Begin',
+ Perl_Extension => 1,
+ Fate => $INTERNAL_ONLY,
+ Initialize => $gc->table('Letter') & $Alpha & $perl_xids,
+ );
+
+ my $charname_continue = $perl->add_match_table('_Perl_Charname_Continue',
+ Perl_Extension => 1,
+ Fate => $INTERNAL_ONLY,
+ Initialize => $perl_xidc
+ + 0x0020 # SPACE
+ + 0x0028 # (
+ + 0x0029 # )
+ + 0x002D # -
+ + 0x00A0 # NBSP
+ );
+
+ # These two tables are for matching \X, which is based on the 'extended'
+ # grapheme cluster, which came in 5.1; create empty ones if not already
+ # present. The straight 'grapheme cluster' (non-extended) is used prior
+ # to 5.1, and differs from the extended (see
+ # http://www.unicode.org/reports/tr29/) only by these two tables, so we
+ # get the older definition automatically when they are empty.
+ my $gcb = property_ref('Grapheme_Cluster_Break');
+ my $perl_prepend = $perl->add_match_table('_X_GCB_Prepend',
+ Perl_Extension => 1,
+ Fate => $INTERNAL_ONLY);
+ if (defined (my $gcb_prepend = $gcb->table('Prepend'))) {
+ $perl_prepend->set_equivalent_to($gcb_prepend, Related => 1);
}
+ else {
+ push @tables_that_may_be_empty, $perl_prepend->complete_name;
+ }
- # Was previously constructed to contain both Name and Unicode_1_Name
- my @composition = ('Name', 'Unicode_1_Name');
+ # All the tables with _X_ in their names are used in defining \X handling,
+ # and are based on the Unicode GCB property. Basically, \X matches:
+ # CR LF
+ # | Prepend* Begin Extend*
+ # | .
+ # Begin is: ( Special_Begin | ! Control )
+ # Begin is also: ( Regular_Begin | Special_Begin )
+ # where Regular_Begin is defined as ( ! Control - Special_Begin )
+ # Special_Begin is: ( Regional-Indicator+ | Hangul-syllable )
+ # Extend is: ( Grapheme_Extend | Spacing_Mark )
+ # Control is: [ GCB_Control | CR | LF ]
+ # Hangul-syllable is: ( T+ | ( L* ( L | ( LVT | ( V | LV ) V* ) T* ) ))
+ foreach my $gcb_name (qw{ L V T LV LVT }) {
+
+ # The perl internal extension's name is the gcb table name prepended
+ # with an '_X_'
+ my $perl_table = $perl->add_match_table('_X_GCB_' . $gcb_name,
+ Perl_Extension => 1,
+ Fate => $INTERNAL_ONLY,
+ Initialize => $gcb->table($gcb_name),
+ );
+ # Version 1 had mostly different Hangul syllables that were removed
+ # from later versions, so some of the tables may not apply.
+ if ($v_version lt v2.0) {
+ push @tables_that_may_be_empty, $perl_table->complete_name;
+ }
+ }
+
+ # More GCB. Populate a combined hangul syllables table
+ my $lv_lvt_v = $perl->add_match_table('_X_LV_LVT_V',
+ Perl_Extension => 1,
+ Fate => $INTERNAL_ONLY);
+ $lv_lvt_v += $gcb->table('LV') + $gcb->table('LVT') + $gcb->table('V');
+ $lv_lvt_v->add_comment('For use in \X; matches: gcb=LV | gcb=LVT | gcb=V');
+
+ my $ri = $perl->add_match_table('_X_RI', Perl_Extension => 1,
+ Fate => $INTERNAL_ONLY);
+ if ($v_version ge v6.2) {
+ $ri += $gcb->table('RI');
+ }
+ else {
+ push @tables_that_may_be_empty, $ri->full_name;
+ }
+
+ my $specials_begin = $perl->add_match_table('_X_Special_Begin_Start',
+ Perl_Extension => 1,
+ Fate => $INTERNAL_ONLY,
+ Initialize => $lv_lvt_v
+ + $gcb->table('L')
+ + $gcb->table('T')
+ + $ri
+ );
+ $specials_begin->add_comment(join_lines( <<END
+For use in \\X; matches first (perhaps only) character of potential
+multi-character sequences that can begin an extended grapheme cluster. They
+need special handling because of their complicated nature.
+END
+ ));
+ my $regular_begin = $perl->add_match_table('_X_Regular_Begin',
+ Perl_Extension => 1,
+ Fate => $INTERNAL_ONLY,
+ Initialize => ~ $gcb->table('Control')
+ - $specials_begin
+ - $gcb->table('CR')
+ - $gcb->table('LF')
+ );
+ $regular_begin->add_comment(join_lines( <<END
+For use in \\X; matches first character of anything that can begin an extended
+grapheme cluster, except those that require special handling.
+END
+ ));
+
+ my $extend = $perl->add_match_table('_X_Extend', Perl_Extension => 1,
+ Fate => $INTERNAL_ONLY,
+ Initialize => $gcb->table('Extend')
+ );
+ if (defined (my $sm = $gcb->table('SpacingMark'))) {
+ $extend += $sm;
+ }
+ $extend->add_comment('For use in \X; matches: Extend | SpacingMark');
+
+ # End of GCB \X processing
+
+ my @composition = ('Name', 'Unicode_1_Name', 'Name_Alias');
+
if (@named_sequences) {
push @composition, 'Named_Sequence';
foreach my $sequence (@named_sequences) {
@@ -11753,23 +13608,103 @@
}
my $alias_sentence = "";
+ my %abbreviations;
my $alias = property_ref('Name_Alias');
- if (defined $alias) {
- push @composition, 'Name_Alias';
- $alias->reset_each_range;
- while (my ($range) = $alias->each_range) {
- next if $range->value eq "";
- if ($range->start != $range->end) {
- Carp::my_carp("Expecting only one code point in the range $range. Just to keep going, using just the first code point;");
- }
- $perl_charname->add_duplicate($range->start, $range->value);
+ $perl_charname->set_proxy_for('Name_Alias');
+
+ # Add each entry in Name_Alias to Perl_Charnames. Where these go with
+ # respect to any existing entry depends on the entry type. Corrections go
+ # before said entry, as they should be returned in preference over the
+ # existing entry. (A correction to a correction should be later in the
+ # Name_Alias table, so it will correctly precede the erroneous correction
+ # in Perl_Charnames.)
+ #
+ # Abbreviations go after everything else, so they are saved temporarily in
+ # a hash for later.
+ #
+ # Everything else is added added afterwards, which preserves the input
+ # ordering
+
+ foreach my $range ($alias->ranges) {
+ next if $range->value eq "";
+ my $code_point = $range->start;
+ if ($code_point != $range->end) {
+ Carp::my_carp_bug("Bad News. Expecting only one code point in the range $range. Just to keep going, using only the first code point;");
}
- $alias_sentence = <<END;
-The Name_Alias property adds duplicate code point entries with a corrected
-name. The original (less correct, but still valid) name will be physically
-last.
+ my ($value, $type) = split ': ', $range->value;
+ my $replace_type;
+ if ($type eq 'correction') {
+ $replace_type = $MULTIPLE_BEFORE;
+ }
+ elsif ($type eq 'abbreviation') {
+
+ # Save for later
+ $abbreviations{$value} = $code_point;
+ next;
+ }
+ else {
+ $replace_type = $MULTIPLE_AFTER;
+ }
+
+ # Actually add; before or after current entry(ies) as determined
+ # above.
+
+ $perl_charname->add_duplicate($code_point, $value, Replace => $replace_type);
+ }
+ $alias_sentence = <<END;
+The Name_Alias property adds duplicate code point entries that are
+alternatives to the original name. If an addition is a corrected
+name, it will be physically first in the table. The original (less correct,
+but still valid) name will be next; then any alternatives, in no particular
+order; and finally any abbreviations, again in no particular order.
END
+
+ # Now add the Unicode_1 names for the controls. The Unicode_1 names had
+ # precedence before 6.1, so should be first in the file; the other names
+ # have precedence starting in 6.1,
+ my $before_or_after = ($v_version lt v6.1.0)
+ ? $MULTIPLE_BEFORE
+ : $MULTIPLE_AFTER;
+
+ foreach my $range (property_ref('Unicode_1_Name')->ranges) {
+ my $code_point = $range->start;
+ my $unicode_1_value = $range->value;
+ next if $unicode_1_value eq ""; # Skip if name doesn't exist.
+
+ if ($code_point != $range->end) {
+ Carp::my_carp_bug("Bad News. Expecting only one code point in the range $range. Just to keep going, using only the first code point;");
+ }
+
+ # To handle EBCDIC, we don't hard code in the code points of the
+ # controls; instead realizing that all of them are below 256.
+ last if $code_point > 255;
+
+ # We only add in the controls.
+ next if $gc->value_of($code_point) ne 'Cc';
+
+ # We reject this Unicode1 name for later Perls, as it is used for
+ # another code point
+ next if $unicode_1_value eq 'BELL' && $^V ge v5.17.0;
+
+ # This won't add an exact duplicate.
+ $perl_charname->add_duplicate($code_point, $unicode_1_value,
+ Replace => $before_or_after);
}
+
+ # But in this version only, the ALERT has precedence over BELL, the
+ # Unicode_1_Name that would otherwise have precedence.
+ if ($v_version eq v6.0.0) {
+ $perl_charname->add_duplicate(7, 'ALERT', Replace => $MULTIPLE_BEFORE);
+ }
+
+ # Now that have everything added, add in abbreviations after
+ # everything else. Sort so results don't change between runs of this
+ # program
+ foreach my $value (sort keys %abbreviations) {
+ $perl_charname->add_duplicate($abbreviations{$value}, $value,
+ Replace => $MULTIPLE_AFTER);
+ }
+
my $comment;
if (@composition <= 2) { # Always at least 2
$comment = join " and ", @composition;
@@ -11781,38 +13716,19 @@
$perl_charname->add_comment(join_lines( <<END
This file is for charnames.pm. It is the union of the $comment properties.
-Unicode_1_Name entries are used only for otherwise nameless code
-points.
+Unicode_1_Name entries are used only for nameless code points in the Name
+property.
$alias_sentence
+This file doesn't include the algorithmically determinable names. For those,
+use 'unicore/Name.pm'
END
));
-
- # The combining class property used by Perl's normalize.pm is not located
- # in the normal mapping directory; create a copy for it.
- my $ccc = property_ref('Canonical_Combining_Class');
- my $perl_ccc = Property->new('Perl_ccc',
- Default_Map => $ccc->default_map,
- Full_Name => 'Perl_Canonical_Combining_Class',
- Internal_Only_Warning => 1,
- Perl_Extension => 1,
- Pod_Entry =>0,
- Type => $ENUM,
- Initialize => $ccc,
- File => 'CombiningClass',
- Directory => File::Spec->curdir(),
- );
- $perl_ccc->set_to_output_map($EXTERNAL_MAP);
- $perl_ccc->add_comment(join_lines(<<END
-This mapping is for normalize.pm. It is currently identical to the Unicode
-Canonical_Combining_Class property.
+ property_ref('Name')->add_comment(join_lines( <<END
+This file doesn't include the algorithmically determinable names. For those,
+use 'unicore/Name.pm'
END
));
- # This one match table for it is needed for calculations on output
- my $default = $perl_ccc->add_match_table($ccc->default_map,
- Initialize => $ccc->table($ccc->default_map),
- Status => $SUPPRESSED);
-
# Construct the Present_In property from the Age property.
if (-e 'DAge.txt' && defined (my $age = property_ref('Age'))) {
my $default_map = $age->default_map;
@@ -11819,13 +13735,12 @@
my $in = Property->new('In',
Default_Map => $default_map,
Full_Name => "Present_In",
- Internal_Only_Warning => 1,
Perl_Extension => 1,
Type => $ENUM,
Initialize => $age,
);
$in->add_comment(join_lines(<<END
-This file should not be used for any purpose. The values in this file are the
+THIS FILE SHOULD NOT BE USED FOR ANY PURPOSE. The values in this file are the
same as for $age, and not for what $in really means. This is because anything
defined in a given release should have multiple values: that release and all
higher ones. But only one value per code point can be represented in a table
@@ -11891,7 +13806,32 @@
$unassigned->set_equivalent_to($age_default, Related => 1);
}
+ # See L<perlfunc/quotemeta>
+ my $quotemeta = $perl->add_match_table('_Perl_Quotemeta',
+ Perl_Extension => 1,
+ Fate => $INTERNAL_ONLY,
+ # Initialize to what's common in
+ # all Unicode releases.
+ Initialize =>
+ $Space
+ + $gc->table('Control')
+ );
+
+ # In early releases without the proper Unicode properties, just set to \W.
+ if (! defined (my $patsyn = property_ref('Pattern_Syntax'))
+ || ! defined (my $patws = property_ref('Pattern_White_Space'))
+ || ! defined (my $di = property_ref('Default_Ignorable_Code_Point')))
+ {
+ $quotemeta += ~ $Word;
+ }
+ else {
+ $quotemeta += $patsyn->table('Y')
+ + $patws->table('Y')
+ + $di->table('Y')
+ + ((~ $Word) & $ASCII);
+ }
+
# Finished creating all the perl properties. All non-internal non-string
# ones have a synonym of 'Is_' prefixed. (Internal properties begin with
# an underscore.) These do not get a separate entry in the pod file
@@ -11899,9 +13839,10 @@
foreach my $alias ($table->aliases) {
next if $alias->name =~ /^_/;
$table->add_alias('Is_' . $alias->name,
- Pod_Entry => 0,
+ Re_Pod_Entry => 0,
+ UCD => 0,
Status => $alias->status,
- Externally_Ok => 0);
+ OK_as_Filename => 0);
}
}
@@ -11915,10 +13856,12 @@
# This separates out the non-characters from the other unassigneds, so
# can give different annotations for each.
$unassigned_sans_noncharacters = Range_List->new(
- Initialize => $gc->table('Unassigned')
- & property_ref('Noncharacter_Code_Point')->table('N'));
+ Initialize => $gc->table('Unassigned'));
+ if (defined (my $nonchars = property_ref('Noncharacter_Code_Point'))) {
+ $unassigned_sans_noncharacters &= $nonchars->table('N');
+ }
- for (my $i = 0; $i <= $LAST_UNICODE_CODEPOINT; $i++ ) {
+ for (my $i = 0; $i <= $MAX_UNICODE_CODEPOINT; $i++ ) {
$i = populate_char_info($i); # Note sets $i so may cause skips
}
}
@@ -11941,13 +13884,12 @@
# Construct the list of tables to get synonyms for. Start with all the
# binary and the General_Category ones.
- my @tables = grep { $_->type == $BINARY } property_ref('*');
+ my @tables = grep { $_->type == $BINARY || $_->type == $FORCED_BINARY }
+ property_ref('*');
push @tables, $gc->tables;
# If the version of Unicode includes the Script property, add its tables
- if (defined property_ref('Script')) {
- push @tables, property_ref('Script')->tables;
- }
+ push @tables, $script->tables if defined $script;
# The Block tables are kept separate because they are treated differently.
# And the earliest versions of Unicode didn't include them, so add only if
@@ -12012,9 +13954,9 @@
# No name collision, so ok to add the perl synonym.
- my $make_pod_entry;
- my $externally_ok;
- my $status = $actual->status;
+ my $make_re_pod_entry;
+ my $ok_as_filename;
+ my $status = $alias->status;
if ($nominal_property == $block) {
# For block properties, the 'In' form is preferred for
@@ -12023,19 +13965,19 @@
# we don't want people using the name without the
# 'In', so discourage that.
if ($prefix eq "") {
- $make_pod_entry = 1;
+ $make_re_pod_entry = 1;
$status = $status || $DISCOURAGED;
- $externally_ok = 0;
+ $ok_as_filename = 0;
}
elsif ($prefix eq 'In_') {
- $make_pod_entry = 0;
+ $make_re_pod_entry = 0;
$status = $status || $NORMAL;
- $externally_ok = 1;
+ $ok_as_filename = 1;
}
else {
- $make_pod_entry = 0;
+ $make_re_pod_entry = 0;
$status = $status || $DISCOURAGED;
- $externally_ok = 0;
+ $ok_as_filename = 0;
}
}
elsif ($prefix ne "") {
@@ -12042,17 +13984,17 @@
# The 'Is' prefix is handled in the pod by a wild
# card, and we won't use it for an external name
- $make_pod_entry = 0;
+ $make_re_pod_entry = 0;
$status = $status || $NORMAL;
- $externally_ok = 0;
+ $ok_as_filename = 0;
}
else {
# Here, is an empty prefix, non block. This gets its
# own pod entry and can be used for an external name.
- $make_pod_entry = 1;
+ $make_re_pod_entry = 1;
$status = $status || $NORMAL;
- $externally_ok = 1;
+ $ok_as_filename = 1;
}
# Here, there isn't a perl pre-existing table with the
@@ -12064,9 +14006,15 @@
# Here, have found a table for $perl. Add this alias
# to it, and are done with this prefix.
$equivalent->add_alias($proposed_name,
- Pod_Entry => $make_pod_entry,
+ Re_Pod_Entry => $make_re_pod_entry,
+
+ # Currently don't output these in the
+ # ucd pod, as are strongly discouraged
+ # from being used
+ UCD => 0,
+
Status => $status,
- Externally_Ok => $externally_ok);
+ OK_as_Filename => $ok_as_filename);
trace "adding alias perl=$proposed_name to $equivalent" if main::DEBUG && $to_trace;
next PREFIX;
}
@@ -12074,9 +14022,13 @@
# Here, $perl doesn't already have a table that is a
# synonym for this property, add one.
my $added_table = $perl->add_match_table($proposed_name,
- Pod_Entry => $make_pod_entry,
+ Re_Pod_Entry => $make_re_pod_entry,
+
+ # See UCD comment just above
+ UCD => 0,
+
Status => $status,
- Externally_Ok => $externally_ok);
+ OK_as_Filename => $ok_as_filename);
# And it will be related to the actual table, since it is
# based on it.
$added_table->set_equivalent_to($actual, Related => 1);
@@ -12142,8 +14094,8 @@
&& ($actual->property != $block || $prefix eq 'In_'))
{
print simple_fold(join_lines(<<END
-There is already an alias named $proposed_name (from " . $pre_existing . "),
-so not creating this alias for " . $actual
+There is already an alias named $proposed_name (from $pre_existing),
+so not creating this alias for $actual
END
), "", 4);
}
@@ -12162,7 +14114,10 @@
# unless they are the same table. For example, N meaning Number or
# Neutral is not likely to cause confusion, so don't add caveats to things
# like them.
- foreach my $property (grep { $_->type != $BINARY } property_ref('*')) {
+ foreach my $property (grep { $_->type != $BINARY
+ && $_->type != $FORCED_BINARY }
+ property_ref('*'))
+ {
my $yes = $property->table('Yes');
if (defined $yes) {
my $y = $property->table('Y');
@@ -12192,7 +14147,7 @@
my $table = shift;
my $directory_ref = shift; # Array of the directory path for the file
- my $file = shift; # The file name in the final directory, [-1].
+ my $file = shift; # The file name in the final directory.
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
trace "table=$table, file=$file, directory=@$directory_ref" if main::DEBUG && $to_trace;
@@ -12199,8 +14154,29 @@
if ($table->isa('Property')) {
$table->set_file_path(@$directory_ref, $file);
- push @map_properties, $table
- if $directory_ref->[0] eq $map_directory;
+ push @map_properties, $table;
+
+ # No swash means don't do the rest of this.
+ return if $table->fate != $ORDINARY;
+
+ # Get the path to the file
+ my @path = $table->file_path;
+
+ # Use just the file name if no subdirectory.
+ shift @path if $path[0] eq File::Spec->curdir();
+
+ my $file = join '/', @path;
+
+ # Create a hash entry for utf8_heavy to get the file that stores this
+ # property's map table
+ foreach my $alias ($table->aliases) {
+ my $name = $alias->name;
+ $loose_property_to_file_of{standardize($name)} = $file;
+ }
+
+ # And a way for utf8_heavy to find the proper key in the SwashInfo
+ # hash for this property.
+ $file_to_swash_name{$file} = "To" . $table->swash_name;
return;
}
@@ -12208,6 +14184,21 @@
# table, so skip if isn't the leader.
return if $table->leader != $table;
+ # If this is a complement of another file, use that other file instead,
+ # with a ! prepended to it.
+ my $complement;
+ if (($complement = $table->complement) != 0) {
+ my @directories = $complement->file_path;
+
+ # This assumes that the 0th element is something like 'lib',
+ # the 1th element the property name (in its own directory), like
+ # 'AHex', and the 2th element the file like 'Y' which will have a .pl
+ # appended to it later.
+ $directories[1] =~ s/^/!/;
+ $file = pop @directories;
+ $directory_ref =\@directories;
+ }
+
# Join all the file path components together, using slashes.
my $full_filename = join('/', @$directory_ref, $file);
@@ -12223,13 +14214,39 @@
# Associate it with its file internally. Don't include the
# $matches_directory first component
$table->set_file_path(@$directory_ref, $file);
+
+ # No swash means don't do the rest of this.
+ next if $table->isa('Map_Table') && $table->fate != $ORDINARY;
+
my $sub_filename = join('/', $directory_ref->[1, -1], $file);
my $property = $table->property;
- $property = ($property == $perl)
- ? "" # 'perl' is never explicitly stated
- : standardize($property->name) . '=';
+ my $property_name = ($property == $perl)
+ ? "" # 'perl' is never explicitly stated
+ : standardize($property->name) . '=';
+ my $is_default = 0; # Is this table the default one for the property?
+
+ # To calculate $is_default, we find if this table is the same as the
+ # default one for the property. But this is complicated by the
+ # possibility that there is a master table for this one, and the
+ # information is stored there instead of here.
+ my $parent = $table->parent;
+ my $leader_prop = $parent->property;
+ my $default_map = $leader_prop->default_map;
+ if (defined $default_map) {
+ my $default_table = $leader_prop->table($default_map);
+ $is_default = 1 if defined $default_table && $parent == $default_table;
+ }
+
+ # Calculate the loose name for this table. Mostly it's just its name,
+ # standardized. But in the case of Perl tables that are single-form
+ # equivalents to Unicode properties, it is the latter's name.
+ my $loose_table_name =
+ ($property != $perl || $leader_prop == $perl)
+ ? standardize($table->name)
+ : standardize($parent->name);
+
my $deprecated = ($table->status eq $DEPRECATED)
? $table->status_info
: "";
@@ -12268,14 +14285,27 @@
if ((my $integer_name = $alias->name)
=~ s/^ ( -? \d+ ) \.0+ $ /$1/x)
{
- $stricter_to_file_of{$property . $integer_name}
- = $sub_filename;
+ $stricter_to_file_of{$property_name . $integer_name}
+ = $sub_filename;
}
}
}
+ # For Unicode::UCD, create a mapping of the prop=value to the
+ # canonical =value for that property.
+ if ($standard =~ /=/) {
+
+ # This could happen if a strict name mapped into an existing
+ # loose name. In that event, the strict names would have to
+ # be moved to a new hash.
+ if (exists($loose_to_standard_value{$standard})) {
+ Carp::my_carp_bug("'$standard' conflicts with a pre-existing use. Bad News. Continuing anyway");
+ }
+ $loose_to_standard_value{$standard} = $loose_table_name;
+ }
+
# Keep a list of the deprecated properties and their filenames
- if ($deprecated) {
+ if ($deprecated && $complement == 0) {
$utf8::why_deprecated{$sub_filename} = $deprecated;
}
@@ -12283,6 +14313,10 @@
if ($caseless_equivalent != 0) {
$caseless_equivalent_to{$standard} = $caseless_equivalent;
}
+
+ # Add to defaults list if the table this alias belongs to is the
+ # default one
+ $loose_defaults{$standard} = 1 if $is_default;
}
}
@@ -12464,7 +14498,7 @@
my @zero_match_tables; # List of tables that have no matches in this release
-sub make_table_pod_entries($) {
+sub make_re_pod_entries($) {
# This generates the entries for the pod file for a given table.
# Also done at this time are any children tables. The output looks like:
# \p{Common} \p{Script=Common} (Short: \p{Zyyy}) (5178)
@@ -12485,6 +14519,11 @@
my $status_info = $input_table->status_info;
my $caseless_equivalent = $input_table->caseless_equivalent;
+ # Don't mention a placeholder equivalent as it isn't to be listed in the
+ # pod
+ $caseless_equivalent = 0 if $caseless_equivalent != 0
+ && $caseless_equivalent->fate > $ORDINARY;
+
my $entry_for_first_table; # The entry for the first table output.
# Almost certainly, it is the parent.
@@ -12492,13 +14531,16 @@
# for each name each table goes by
foreach my $table ($input_table, $input_table->children) {
- # utf8_heavy.pl cannot deal with null string property values, so don't
- # output any.
- next if $table->name eq "";
+ # utf8_heavy.pl cannot deal with null string property values, so skip
+ # any tables that have no non-null names.
+ next if ! grep { $_->name ne "" } $table->aliases;
# First, gather all the info that applies to this table as a whole.
- push @zero_match_tables, $table if $count == 0;
+ push @zero_match_tables, $table if $count == 0
+ # Don't mention special tables
+ # as being zero length
+ && $table->fate == $ORDINARY;
my $table_property = $table->property;
@@ -12523,11 +14565,14 @@
foreach my $alias ($table->aliases) {
# Skip if not to go in pod.
- next unless $alias->make_pod_entry;
+ next unless $alias->make_re_pod_entry;
# Start gathering all the components for the entry
my $name = $alias->name;
+ # Skip if name is empty, as can't be accessed by regexes.
+ next if $name eq "";
+
my $entry; # Holds the left column, may include extras
my $entry_ref; # To refer to the left column's contents from
# another entry; has no extras
@@ -12543,13 +14588,35 @@
# Only generate one entry for all the aliases that mean true
# or false in binary properties. Append a '*' to indicate
# some are missing. (The heading comment notes this.)
- my $wild_card_mark;
+ my $rhs;
if ($type == $BINARY) {
next if $name ne 'N' && $name ne 'Y';
- $wild_card_mark = '*';
+ $rhs = "$name*";
}
+ elsif ($type != $FORCED_BINARY) {
+ $rhs = $name;
+ }
else {
- $wild_card_mark = "";
+
+ # Forced binary properties require special handling. It
+ # has two sets of tables, one set is true/false; and the
+ # other set is everything else. Entries are generated for
+ # each set. Use the Bidi_Mirrored property (which appears
+ # in all Unicode versions) to get a list of the aliases
+ # for the true/false tables. Of these, only output the N
+ # and Y ones, the same as, a regular binary property. And
+ # output all the rest, same as a non-binary property.
+ my $bm = property_ref("Bidi_Mirrored");
+ if ($name eq 'N' || $name eq 'Y') {
+ $rhs = "$name*";
+ } elsif (grep { $name eq $_->name } $bm->table("Y")->aliases,
+ $bm->table("N")->aliases)
+ {
+ next;
+ }
+ else {
+ $rhs = $name;
+ }
}
# Colon-space is used to give a little more space to be easier
@@ -12556,7 +14623,7 @@
# to read;
$entry = "\\p{"
. $table_property_full_name
- . ": $name$wild_card_mark}";
+ . ": $rhs}";
# But for the reference to this entry, which will go in the
# right column, where space is at a premium, use equals
@@ -12652,11 +14719,18 @@
# Special case the binary N tables, so that will print
# \P{single}, but use the Y table values to populate
- # 'single', as we haven't populated the N table.
+ # 'single', as we haven't likewise populated the N table.
+ # For forced binary tables, we can't just look at the N
+ # table, but must see if this table is equivalent to the N
+ # one, as there are two equivalent beasts in these
+ # properties.
my $test_table;
my $p;
- if ($type == $BINARY
- && $input_table == $property->table('No'))
+ if ( ($type == $BINARY
+ && $input_table == $property->table('No'))
+ || ($type == $FORCED_BINARY
+ && $property->table('No')->
+ is_set_equivalent_to($input_table)))
{
$test_table = $property->table('Yes');
$p = 'P';
@@ -12726,6 +14800,10 @@
push @info, "($parenthesized)" if $parenthesized;
+ if ($name =~ /_$/ && $alias->loose_match) {
+ push @info, "Note the trailing '_' matters in spite of loose matching rules.";
+ }
+
if ($table_property != $perl && $table->perl_extension) {
push @info, '(Perl extension)';
}
@@ -12750,6 +14828,179 @@
return;
}
+sub make_ucd_table_pod_entries {
+ my $table = shift;
+
+ # Generate the entries for the UCD section of the pod for $table. This
+ # also calculates if names are ambiguous, so has to be called even if the
+ # pod is not being output
+
+ my $short_name = $table->name;
+ my $standard_short_name = standardize($short_name);
+ my $full_name = $table->full_name;
+ my $standard_full_name = standardize($full_name);
+
+ my $full_info = ""; # Text of info column for full-name entries
+ my $other_info = ""; # Text of info column for short-name entries
+ my $short_info = ""; # Text of info column for other entries
+ my $meaning = ""; # Synonym of this table
+
+ my $property = ($table->isa('Property'))
+ ? $table
+ : $table->parent->property;
+
+ my $perl_extension = $table->perl_extension;
+
+ # Get the more official name for for perl extensions that aren't
+ # stand-alone properties
+ if ($perl_extension && $property != $table) {
+ if ($property == $perl ||$property->type == $BINARY) {
+ $meaning = $table->complete_name;
+ }
+ else {
+ $meaning = $property->full_name . "=$full_name";
+ }
+ }
+
+ # There are three types of info column. One for the short name, one for
+ # the full name, and one for everything else. They mostly are the same,
+ # so initialize in the same loop.
+ foreach my $info_ref (\$full_info, \$short_info, \$other_info) {
+ if ($perl_extension && $property != $table) {
+
+ # Add the synonymous name for the non-full name entries; and to
+ # the full-name entry if it adds extra information
+ if ($info_ref == \$other_info
+ || ($info_ref == \$short_info
+ && $standard_short_name ne $standard_full_name)
+ || standardize($meaning) ne $standard_full_name
+ ) {
+ $$info_ref .= "$meaning.";
+ }
+ }
+ elsif ($info_ref != \$full_info) {
+
+ # Otherwise, the non-full name columns include the full name
+ $$info_ref .= $full_name;
+ }
+
+ # And the full-name entry includes the short name, if different
+ if ($info_ref == \$full_info
+ && $standard_short_name ne $standard_full_name)
+ {
+ $full_info =~ s/\.\Z//;
+ $full_info .= " " if $full_info;
+ $full_info .= "(Short: $short_name)";
+ }
+
+ if ($table->perl_extension) {
+ $$info_ref =~ s/\.\Z//;
+ $$info_ref .= ". " if $$info_ref;
+ $$info_ref .= "(Perl extension)";
+ }
+ }
+
+ # Add any extra annotations to the full name entry
+ foreach my $more_info ($table->description,
+ $table->note,
+ $table->status_info)
+ {
+ next unless $more_info;
+ $full_info =~ s/\.\Z//;
+ $full_info .= ". " if $full_info;
+ $full_info .= $more_info;
+ }
+
+ # These keep track if have created full and short name pod entries for the
+ # property
+ my $done_full = 0;
+ my $done_short = 0;
+
+ # Every possible name is kept track of, even those that aren't going to be
+ # output. This way we can be sure to find the ambiguities.
+ foreach my $alias ($table->aliases) {
+ my $name = $alias->name;
+ my $standard = standardize($name);
+ my $info;
+ my $output_this = $alias->ucd;
+
+ # If the full and short names are the same, we want to output the full
+ # one's entry, so it has priority.
+ if ($standard eq $standard_full_name) {
+ next if $done_full;
+ $done_full = 1;
+ $info = $full_info;
+ }
+ elsif ($standard eq $standard_short_name) {
+ next if $done_short;
+ $done_short = 1;
+ next if $standard_short_name eq $standard_full_name;
+ $info = $short_info;
+ }
+ else {
+ $info = $other_info;
+ }
+
+ # Here, we have set up the two columns for this entry. But if an
+ # entry already exists for this name, we have to decide which one
+ # we're going to later output.
+ if (exists $ucd_pod{$standard}) {
+
+ # If the two entries refer to the same property, it's not going to
+ # be ambiguous. (Likely it's because the names when standardized
+ # are the same.) But that means if they are different properties,
+ # there is ambiguity.
+ if ($ucd_pod{$standard}->{'property'} != $property) {
+
+ # Here, we have an ambiguity. This code assumes that one is
+ # scheduled to be output and one not and that one is a perl
+ # extension (which is not to be output) and the other isn't.
+ # If those assumptions are wrong, things have to be rethought.
+ if ($ucd_pod{$standard}{'output_this'} == $output_this
+ || $ucd_pod{$standard}{'perl_extension'} == $perl_extension
+ || $output_this == $perl_extension)
+ {
+ Carp::my_carp("Bad news. $property and $ucd_pod{$standard}->{'property'} have unexpected output status and perl-extension combinations. Proceeding anyway.");
+ }
+
+ # We modifiy the info column of the one being output to
+ # indicate the ambiguity. Set $which to point to that one's
+ # info.
+ my $which;
+ if ($ucd_pod{$standard}{'output_this'}) {
+ $which = \$ucd_pod{$standard}->{'info'};
+ }
+ else {
+ $which = \$info;
+ $meaning = $ucd_pod{$standard}{'meaning'};
+ }
+
+ chomp $$which;
+ $$which =~ s/\.\Z//;
+ $$which .= "; NOT '$standard' meaning '$meaning'";
+
+ $ambiguous_names{$standard} = 1;
+ }
+
+ # Use the non-perl-extension variant
+ next unless $ucd_pod{$standard}{'perl_extension'};
+ }
+
+ # Store enough information about this entry that we can later look for
+ # ambiguities, and output it properly.
+ $ucd_pod{$standard} = { 'name' => $name,
+ 'info' => $info,
+ 'meaning' => $meaning,
+ 'output_this' => $output_this,
+ 'perl_extension' => $perl_extension,
+ 'property' => $property,
+ 'status' => $alias->status,
+ };
+ } # End of looping through all this table's aliases
+
+ return;
+}
+
sub pod_alphanumeric_sort {
# Sort pod entries alphanumerically.
@@ -12801,6 +15052,8 @@
# Create the .pod file. This generates the various subsections and then
# combines them in one big HERE document.
+ my $Is_flags_text = "If an entry has flag(s) at its beginning, like \"$DEPRECATED\", the \"Is_\" form has the same flag(s)";
+
return unless defined $pod_directory;
print "Making pod file\n" if $verbosity >= $PROGRESS;
@@ -12819,19 +15072,20 @@
: ""));
@block_warning = << "END";
-Matches in the Block property have shortcuts that begin with 'In_'. For
-example, \\p{Block=Latin1} can be written as \\p{In_Latin1}. For backward
-compatibility, if there is no conflict with another shortcut, these may also
-be written as \\p{Latin1} or \\p{Is_Latin1}. But, N.B., there are numerous
-such conflicting shortcuts. Use of these forms for Block is discouraged, and
-are flagged as such, not only because of the potential confusion as to what is
-meant, but also because a later release of Unicode may preempt the shortcut,
-and your program would no longer be correct. Use the 'In_' form instead to
-avoid this, or even more clearly, use the compound form, e.g.,
-\\p{blk:latin1}. See L<perlunicode/"Blocks"> for more information about this.
+Matches in the Block property have shortcuts that begin with "In_". For
+example, C<\\p{Block=Latin1}> can be written as C<\\p{In_Latin1}>. For
+backward compatibility, if there is no conflict with another shortcut, these
+may also be written as C<\\p{Latin1}> or C<\\p{Is_Latin1}>. But, N.B., there
+are numerous such conflicting shortcuts. Use of these forms for Block is
+discouraged, and are flagged as such, not only because of the potential
+confusion as to what is meant, but also because a later release of Unicode may
+preempt the shortcut, and your program would no longer be correct. Use the
+"In_" form instead to avoid this, or even more clearly, use the compound form,
+e.g., C<\\p{blk:latin1}>. See L<perlunicode/"Blocks"> for more information
+about this.
END
}
- my $text = "If an entry has flag(s) at its beginning, like '$DEPRECATED', the 'Is_' form has the same flag(s)";
+ my $text = $Is_flags_text;
$text = "$exception_message $text" if $has_Is_conflicts;
# And the 'Is_ line';
@@ -12863,22 +15117,22 @@
. $formatted_properties;
# Generate pod documentation lines for the tables that match nothing
- my $zero_matches;
+ my $zero_matches = "";
if (@zero_match_tables) {
@zero_match_tables = uniques(@zero_match_tables);
$zero_matches = join "\n\n",
map { $_ = '=item \p{' . $_->complete_name . "}" }
sort { $a->complete_name cmp $b->complete_name }
- uniques(@zero_match_tables);
+ @zero_match_tables;
$zero_matches = <<END;
-=head2 Legal \\p{} and \\P{} constructs that match no characters
+=head2 Legal C<\\p{}> and C<\\P{}> constructs that match no characters
Unicode has some property-value pairs that currently don't match anything.
-This happens generally either because they are obsolete, or for symmetry with
-other forms, but no language has yet been encoded that uses them. In this
-version of Unicode, the following match zero code points:
+This happens generally either because they are obsolete, or they exist for
+symmetry with other forms, but no language has yet been encoded that uses
+them. In this version of Unicode, the following match zero code points:
=over 4
@@ -12908,10 +15162,7 @@
foreach my $why (sort { $why_list{$a}->[0] cmp $why_list{$b}->[0] }
keys %why_list)
{
- # Add to the output, all the properties that have that reason. Start
- # with an empty line.
- push @bad_re_properties, "\n\n";
-
+ # Add to the output, all the properties that have that reason.
my $has_item = 0; # Flag if actually output anything.
foreach my $name (@{$why_list{$why}}) {
@@ -12937,6 +15188,9 @@
my $short_name = $property->name;
$short_name .= '=' . $property->table($table)->name if $table;
+ # Start with an empty line.
+ push @bad_re_properties, "\n\n" unless $has_item;
+
# And add the property as an item for the reason.
push @bad_re_properties, "\n=item I<$name> ($short_name)\n";
$has_item = 1;
@@ -12950,57 +15204,71 @@
} # End of looping through each reason.
- # Generate a list of the properties whose map table we output, from the
- # global @map_properties.
- my @map_tables_actually_output;
- my $info_indent = 20; # Left column is narrower than \p{} table.
- foreach my $property (@map_properties) {
+ if (! @bad_re_properties) {
+ push @bad_re_properties,
+ "*** This installation accepts ALL non-Unihan properties ***";
+ }
+ else {
+ # Add =over only if non-empty to avoid an empty =over/=back section,
+ # which is considered bad form.
+ unshift @bad_re_properties, "\n=over 4\n";
+ push @bad_re_properties, "\n=back\n";
+ }
- # Get the path to the file; don't output any not in the standard
- # directory.
- my @path = $property->file_path;
- next if $path[0] ne $map_directory;
+ # Similiarly, generate a list of files that we don't use, grouped by the
+ # reasons why. First, create a hash whose keys are the reasons, and whose
+ # values are anonymous arrays of all the files that share that reason.
+ my %grouped_by_reason;
+ foreach my $file (keys %ignored_files) {
+ push @{$grouped_by_reason{$ignored_files{$file}}}, $file;
+ }
+ foreach my $file (keys %skipped_files) {
+ push @{$grouped_by_reason{$skipped_files{$file}}}, $file;
+ }
- # Don't mention map tables that are for internal-use only
- next if $property->to_output_map == $INTERNAL_MAP;
+ # Then, sort each group.
+ foreach my $group (keys %grouped_by_reason) {
+ @{$grouped_by_reason{$group}} = sort { lc $a cmp lc $b }
+ @{$grouped_by_reason{$group}} ;
+ }
- shift @path; # Remove the standard name
+ # Finally, create the output text. For each reason (sorted by the
+ # alphabetically first file that has that reason)...
+ my @unused_files;
+ foreach my $reason (sort { lc $grouped_by_reason{$a}->[0]
+ cmp lc $grouped_by_reason{$b}->[0]
+ }
+ keys %grouped_by_reason)
+ {
+ # Add all the files that have that reason to the output. Start
+ # with an empty line.
+ push @unused_files, "\n\n";
+ push @unused_files, map { "\n=item F<$_> \n" }
+ @{$grouped_by_reason{$reason}};
+ # And add the reason under the list of files
+ push @unused_files, "\n$reason\n";
+ }
- my $file = join '/', @path; # In case is in sub directory
- my $info = $property->full_name;
- my $short_name = $property->name;
- if ($info ne $short_name) {
- $info .= " ($short_name)";
- }
- foreach my $more_info ($property->description,
- $property->note,
- $property->status_info)
- {
- next unless $more_info;
- $info =~ s/\.\Z//;
- $info .= ". $more_info";
- }
- push @map_tables_actually_output, format_pod_line($info_indent,
- $file,
- $info,
- $property->status);
+ # Similarly, create the output text for the UCD section of the pod
+ my @ucd_pod;
+ foreach my $key (keys %ucd_pod) {
+ next unless $ucd_pod{$key}->{'output_this'};
+ push @ucd_pod, format_pod_line($indent_info_column,
+ $ucd_pod{$key}->{'name'},
+ $ucd_pod{$key}->{'info'},
+ $ucd_pod{$key}->{'status'},
+ );
}
# Sort alphabetically, and fold for output
- @map_tables_actually_output = sort
- pod_alphanumeric_sort @map_tables_actually_output;
- @map_tables_actually_output
- = simple_fold(\@map_tables_actually_output,
- ' ',
- $info_indent,
- $automatic_pod_indent);
-
- # Generate a list of the formats that can appear in the map tables.
- my @map_table_formats;
- foreach my $format (sort keys %map_table_formats) {
- push @map_table_formats, " $format $map_table_formats{$format}\n";
- }
-
+ @ucd_pod = sort { lc substr($a, 2) cmp lc substr($b, 2) } @ucd_pod;
+ my $ucd_pod = simple_fold(\@ucd_pod,
+ ' ',
+ $indent_info_column,
+ $automatic_pod_indent);
+ $ucd_pod = format_pod_line($indent_info_column, 'NAME', ' INFO')
+ . "\n"
+ . $ucd_pod;
local $" = "";
# Everything is ready to assemble.
@@ -13015,54 +15283,69 @@
=head1 NAME
-$pod_file - Index of Unicode Version $string_version properties in Perl
+$pod_file - Index of Unicode Version $string_version character properties in Perl
=head1 DESCRIPTION
-There are many properties in Unicode, and Perl provides access to almost all of
-them, as well as some additional extensions and short-cut synonyms.
+This document provides information about the portion of the Unicode database
+that deals with character properties, that is the portion that is defined on
+single code points. (L</Other information in the Unicode data base>
+below briefly mentions other data that Unicode provides.)
-And just about all of the few that aren't accessible through the Perl
-core are accessible through the modules: Unicode::Normalize and
-Unicode::UCD, and for Unihan properties, via the CPAN module Unicode::Unihan.
+Perl can provide access to all non-provisional Unicode character properties,
+though not all are enabled by default. The omitted ones are the Unihan
+properties (accessible via the CPAN module L<Unicode::Unihan>) and certain
+deprecated or Unicode-internal properties. (An installation may choose to
+recompile Perl's tables to change this. See L<Unicode character
+properties that are NOT accepted by Perl>.)
+For most purposes, access to Unicode properties from the Perl core is through
+regular expression matches, as described in the next section.
+For some special purposes, and to access the properties that are not suitable
+for regular expression matching, all the Unicode character properties that
+Perl handles are accessible via the standard L<Unicode::UCD> module, as
+described in the section L</Properties accessible through Unicode::UCD>.
+
+Perl also provides some additional extensions and short-cut synonyms
+for Unicode properties.
+
This document merely lists all available properties and does not attempt to
explain what each property really means. There is a brief description of each
-Perl extension. There is some detail about Blocks, Scripts, General_Category,
+Perl extension; see L<perlunicode/Other Properties> for more information on
+these. There is some detail about Blocks, Scripts, General_Category,
and Bidi_Class in L<perlunicode>, but to find out about the intricacies of the
-Unicode properties, refer to the Unicode standard. A good starting place is
-L<$unicode_reference_url>. More information on the Perl extensions is in
-L<perlunicode/Other Properties>.
+official Unicode properties, refer to the Unicode standard. A good starting
+place is L<$unicode_reference_url>.
Note that you can define your own properties; see
L<perlunicode/"User-Defined Character Properties">.
-=head1 Properties accessible through \\p{} and \\P{}
+=head1 Properties accessible through C<\\p{}> and C<\\P{}>
-The Perl regular expression \\p{} and \\P{} constructs give access to most of
-the Unicode character properties. The table below shows all these constructs,
-both single and compound forms.
+The Perl regular expression C<\\p{}> and C<\\P{}> constructs give access to
+most of the Unicode character properties. The table below shows all these
+constructs, both single and compound forms.
B<Compound forms> consist of two components, separated by an equals sign or a
colon. The first component is the property name, and the second component is
the particular value of the property to match against, for example,
-'\\p{Script: Greek}' and '\\p{Script=Greek}' both mean to match characters
+C<\\p{Script: Greek}> and C<\\p{Script=Greek}> both mean to match characters
whose Script property is Greek.
-B<Single forms>, like '\\p{Greek}', are mostly Perl-defined shortcuts for
+B<Single forms>, like C<\\p{Greek}>, are mostly Perl-defined shortcuts for
their equivalent compound forms. The table shows these equivalences. (In our
-example, '\\p{Greek}' is a just a shortcut for '\\p{Script=Greek}'.)
+example, C<\\p{Greek}> is a just a shortcut for C<\\p{Script=Greek}>.)
There are also a few Perl-defined single forms that are not shortcuts for a
-compound form. One such is \\p{Word}. These are also listed in the table.
+compound form. One such is C<\\p{Word}>. These are also listed in the table.
In parsing these constructs, Perl always ignores Upper/lower case differences
-everywhere within the {braces}. Thus '\\p{Greek}' means the same thing as
-'\\p{greek}'. But note that changing the case of the 'p' or 'P' before the
-left brace completely changes the meaning of the construct, from "match" (for
-'\\p{}') to "doesn't match" (for '\\P{}'). Casing in this document is for
-improved legibility.
+everywhere within the {braces}. Thus C<\\p{Greek}> means the same thing as
+C<\\p{greek}>. But note that changing the case of the C<"p"> or C<"P"> before
+the left brace completely changes the meaning of the construct, from "match"
+(for C<\\p{}>) to "doesn't match" (for C<\\P{}>). Casing in this document is
+for improved legibility.
-Also, white space, hyphens, and underscores are also normally ignored
+Also, white space, hyphens, and underscores are normally ignored
everywhere between the {braces}, and hence can be freely added or removed
even if the C</x> modifier hasn't been specified on the regular expression.
But $a_bold_stricter at the beginning of an entry in the table below
@@ -13070,7 +15353,7 @@
=over 4
-=item Single form (\\p{name}) tighter rules:
+=item Single form (C<\\p{name}>) tighter rules:
White space, hyphens, and underscores ARE significant
except for:
@@ -13086,7 +15369,7 @@
That means, for example, that you can freely add or remove white space
adjacent to (but within) the braces without affecting the meaning.
-=item Compound form (\\p{name=value} or \\p{name:value}) tighter rules:
+=item Compound form (C<\\p{name=value}> or C<\\p{name:value}>) tighter rules:
The tighter rules given above for the single form apply to everything to the
right of the colon or equals; the looser rules still apply to everything to
@@ -13102,14 +15385,9 @@
=over 4
-=item Obsolete
-
-Properties marked with $a_bold_obsolete in the table are considered
-obsolete.
-
=item Stabilized
-Obsolete properties may be stabilized. Such a determination does not indicate
+A property may be stabilized. Such a determination does not indicate
that the property should or should not be used; instead it is a declaration
that the property will not be maintained nor extended for newly encoded
characters. Such properties are marked with $a_bold_stabilized in the
@@ -13117,7 +15395,7 @@
=item Deprecated
-An obsolete property may be deprecated, perhaps because its original intent
+A property may be deprecated, perhaps because its original intent
has been replaced by another property, or because its specification was
somehow defective. This means that its use is strongly
discouraged, so much so that a warning will be issued if used, unless the
@@ -13133,15 +15411,26 @@
A deprecated property may be made unavailable in a future Perl version, so it
is best to move away from them.
+A deprecated property may also be stabilized, but this fact is not shown.
+
+=item Obsolete
+
+Properties marked with $a_bold_obsolete in the table are considered (plain)
+obsolete. Generally this designation is given to properties that Unicode once
+used for internal purposes (but not any longer).
+
=back
Some Perl extensions are present for backwards compatibility and are
-discouraged from being used, but not obsolete. $A_bold_discouraged
-flags each such entry in the table.
+discouraged from being used, but are not obsolete. $A_bold_discouraged
+flags each such entry in the table. Future Unicode versions may force
+some of these extensions to be removed without warning, replaced by another
+property with the same name that means something different. Use the
+equivalent shown instead.
@block_warning
-The table below has two columns. The left column contains the \\p{}
+The table below has two columns. The left column contains the C<\\p{}>
constructs to look up, possibly preceded by the flags mentioned above; and
the right column contains information about them, like a description, or
synonyms. It shows both the single and compound forms for each property that
@@ -13170,7 +15459,7 @@
same code pode points as the property "other_property".
There is no description given for most non-Perl defined properties (See
-$unicode_reference_url for that).
+L<$unicode_reference_url> for that).
For compactness, 'B<*>' is used as a wildcard instead of showing all possible
combinations. For example, entries like:
@@ -13182,10 +15471,11 @@
\\p{Is_*} \\p{*}
-means that if and only if, for example, \\p{Foo} exists, then \\p{Is_Foo} and
-\\p{IsFoo} are also valid and all mean the same thing. And similarly,
-\\p{Foo=Bar} means the same as \\p{Is_Foo=Bar} and \\p{IsFoo=Bar}. '*' here
-is restricted to something not beginning with an underscore.
+means that if and only if, for example, C<\\p{Foo}> exists, then
+C<\\p{Is_Foo}> and C<\\p{IsFoo}> are also valid and all mean the same thing.
+And similarly, C<\\p{Foo=Bar}> means the same as C<\\p{Is_Foo=Bar}> and
+C<\\p{IsFoo=Bar}>. "*" here is restricted to something not beginning with an
+underscore.
Also, in binary properties, 'Yes', 'T', and 'True' are all synonyms for 'Y'.
And 'No', 'F', and 'False' are all synonyms for 'N'. The table shows 'Y*' and
@@ -13199,11 +15489,11 @@
Note that all non-essential underscores are removed in the display of the
short names below.
-B<Summary legend:>
+B<Legend summary:>
=over 4
-=item B<*> is a wild-card
+=item Z<>B<*> is a wild-card
=item B<(\\d+)> in the info column gives the number of code points matched by
this property.
@@ -13216,7 +15506,8 @@
=item B<$STRICTER> means tighter (stricter) name matching applies.
-=item B<$DISCOURAGED> means use of this form is discouraged.
+=item B<$DISCOURAGED> means use of this form is discouraged, and may not be
+stable.
=back
@@ -13224,35 +15515,80 @@
$zero_matches
-=head1 Properties not accessible through \\p{} and \\P{}
+=head1 Properties accessible through Unicode::UCD
-A few properties are accessible in Perl via various function calls only.
-These are:
+All the Unicode character properties mentioned above (except for those marked
+as for internal use by Perl) are also accessible by
+L<Unicode::UCD/prop_invlist()>.
+Due to their nature, not all Unicode character properties are suitable for
+regular expression matches, nor C<prop_invlist()>. The remaining
+non-provisional, non-internal ones are accessible via
+L<Unicode::UCD/prop_invmap()> (except for those that this Perl installation
+hasn't included; see L<below for which those are|/Unicode character properties
+that are NOT accepted by Perl>).
+
+For compatibility with other parts of Perl, all the single forms given in the
+table in the L<section above|/Properties accessible through \\p{} and \\P{}>
+are recognized. BUT, there are some ambiguities between some Perl extensions
+and the Unicode properties, all of which are silently resolved in favor of the
+official Unicode property. To avoid surprises, you should only use
+C<prop_invmap()> for forms listed in the table below, which omits the
+non-recommended ones. The affected forms are the Perl single form equivalents
+of Unicode properties, such as C<\\p{sc}> being a single-form equivalent of
+C<\\p{gc=sc}>, which is treated by C<prop_invmap()> as the C<Script> property,
+whose short name is C<sc>. The table indicates the current ambiguities in the
+INFO column, beginning with the word C<"NOT">.
+
+The standard Unicode properties listed below are documented in
+L<$unicode_reference_url>; Perl_Decimal_Digit is documented in
+L<Unicode::UCD/prop_invmap()>. The other Perl extensions are in
+L<perlunicode/Other Properties>;
+
+The first column in the table is a name for the property; the second column is
+an alternative name, if any, plus possibly some annotations. The alternative
+name is the property's full name, unless that would simply repeat the first
+column, in which case the second column indicates the property's short name
+(if different). The annotations are given only in the entry for the full
+name. If a property is obsolete, etc, the entry will be flagged with the same
+characters used in the table in the L<section above|/Properties accessible
+through \\p{} and \\P{}>, like B<$DEPRECATED> or B<$STABILIZED>.
+
+$ucd_pod
+
+=head1 Properties accessible through other means
+
+Certain properties are accessible also via core function calls. These are:
+
Lowercase_Mapping lc() and lcfirst()
Titlecase_Mapping ucfirst()
Uppercase_Mapping uc()
-Case_Folding is accessible through the /i modifier in regular expressions.
+Also, Case_Folding is accessible through the C</i> modifier in regular
+expressions, the C<\\F> transliteration escape, and the C<L<fc|perlfunc/fc>>
+operator.
-The Name property is accessible through the \\N{} interpolation in
-double-quoted strings and regular expressions, but both usages require a C<use
-charnames;> to be specified, which also contains related functions viacode(),
-vianame(), and string_vianame().
+And, the Name and Name_Aliases properties are accessible through the C<\\N{}>
+interpolation in double-quoted strings and regular expressions; and functions
+C<charnames::viacode()>, C<charnames::vianame()>, and
+C<charnames::string_vianame()> (which require a C<use charnames ();> to be
+specified.
-=head1 Unicode regular expression properties that are NOT accepted by Perl
+Finally, most properties related to decomposition are accessible via
+L<Unicode::Normalize>.
+=head1 Unicode character properties that are NOT accepted by Perl
+
Perl will generate an error for a few character properties in Unicode when
used in a regular expression. The non-Unihan ones are listed below, with the
reasons they are not accepted, perhaps with work-arounds. The short names for
the properties are listed enclosed in (parentheses).
+As described after the list, an installation can change the defaults and choose
+to accept any of these. The list is machine generated based on the
+choices made for the installation that generated this document.
-=over 4
-
@bad_re_properties
-=back
-
An installation can choose to allow any of these to be matched by downloading
the Unicode database from L<http://www.unicode.org/Public/> to
C<\$Config{privlib}>/F<unicore/> in the Perl source tree, changing the
@@ -13260,50 +15596,32 @@
C<\$Config{privlib}>/F<unicore/mktables> and then re-compiling and installing.
(C<\%Config> is available from the Config module).
-=head1 Files in the I<To> directory (for serious hackers only)
+=head1 Other information in the Unicode data base
-All Unicode properties are really mappings (in the mathematical sense) from
-code points to their respective values. As part of its build process,
-Perl constructs tables containing these mappings for all properties that it
-deals with. Some, but not all, of these are written out into files.
-Those written out are in the directory C<\$Config{privlib}>/F<unicore/To/>
-(%Config is available from the Config module).
+The Unicode data base is delivered in two different formats. The XML version
+is valid for more modern Unicode releases. The other version is a collection
+of files. The two are intended to give equivalent information. Perl uses the
+older form; this allows you to recompile Perl to use early Unicode releases.
-Perl reserves the right to change the format and even the existence of any of
-those files without notice, except the ones that were in existence prior to
-release 5.13. If those change, a deprecation cycle will be done first. These
-are:
+The only non-character property that Perl currently supports is Named
+Sequences, in which a sequence of code points
+is given a name and generally treated as a single entity. (Perl supports
+these via the C<\\N{...}> double-quotish construct,
+L<charnames/charnames::string_vianame(name)>, and L<Unicode::UCD/namedseq()>.
- at map_tables_actually_output
+Below is a list of the files in the Unicode data base that Perl doesn't
+currently use, along with very brief descriptions of their purposes.
+Some of the names of the files have been shortened from those that Unicode
+uses, in order to allow them to be distinguishable from similarly named files
+on file systems for which only the first 8 characters of a name are
+significant.
-Each of the files in this directory defines two hash entries to help reading
-programs decipher it. One of them looks like this:
+=over 4
- \$utf8::SwashInfo{'ToNAME'}{'format'} = 's';
+ at unused_files
-where 'NAME' is a name to indicate the property. For backwards compatibility,
-this is not necessarily the property's official Unicode name. (The 'To' is
-also for backwards compatibility.) The hash entry gives the format of the
-mapping fields of the table, currently one of the following:
+=back
- at map_table_formats
-
-This format applies only to the entries in the main body of the table.
-Entries defined in hashes or ones that are missing from the list can have a
-different format.
-
-The value that the missing entries have is given by the other SwashInfo hash
-entry line; it looks like this:
-
- \$utf8::SwashInfo{'ToNAME'}{'missing'} = 'NaN';
-
-This example line says that any Unicode code points not explicitly listed in
-the file have the value 'NaN' under the property indicated by NAME. If the
-value is the special string C<< <code point> >>, it means that the value for
-any missing code point is the code point itself. This happens, for example,
-in the file for Uppercase_Mapping (To/Upper.pl), in which code points like the
-character 'A', are missing because the uppercase of 'A' is itself.
-
=head1 SEE ALSO
L<$unicode_reference_url>
@@ -13323,39 +15641,68 @@
# Create and write Heavy.pl, which passes info about the tables to
# utf8_heavy.pl
+ # Stringify structures for output
+ my $loose_property_name_of
+ = simple_dumper(\%loose_property_name_of, ' ' x 4);
+ chomp $loose_property_name_of;
+
+ my $stricter_to_file_of = simple_dumper(\%stricter_to_file_of, ' ' x 4);
+ chomp $stricter_to_file_of;
+
+ my $loose_to_file_of = simple_dumper(\%loose_to_file_of, ' ' x 4);
+ chomp $loose_to_file_of;
+
+ my $nv_floating_to_rational
+ = simple_dumper(\%nv_floating_to_rational, ' ' x 4);
+ chomp $nv_floating_to_rational;
+
+ my $why_deprecated = simple_dumper(\%utf8::why_deprecated, ' ' x 4);
+ chomp $why_deprecated;
+
+ # We set the key to the file when we associated files with tables, but we
+ # couldn't do the same for the value then, as we might not have the file
+ # for the alternate table figured out at that time.
+ foreach my $cased (keys %caseless_equivalent_to) {
+ my @path = $caseless_equivalent_to{$cased}->file_path;
+ my $path = join '/', @path[1, -1];
+ $caseless_equivalent_to{$cased} = $path;
+ }
+ my $caseless_equivalent_to
+ = simple_dumper(\%caseless_equivalent_to, ' ' x 4);
+ chomp $caseless_equivalent_to;
+
+ my $loose_property_to_file_of
+ = simple_dumper(\%loose_property_to_file_of, ' ' x 4);
+ chomp $loose_property_to_file_of;
+
+ my $file_to_swash_name = simple_dumper(\%file_to_swash_name, ' ' x 4);
+ chomp $file_to_swash_name;
+
my @heavy = <<END;
$HEADER
-$INTERNAL_ONLY
+$INTERNAL_ONLY_HEADER
-# This file is for the use of utf8_heavy.pl
+# This file is for the use of utf8_heavy.pl and Unicode::UCD
-# Maps property names in loose standard form to its standard name
+# Maps Unicode (not Perl single-form extensions) property names in loose
+# standard form to their corresponding standard names
\%utf8::loose_property_name_of = (
-END
-
- push @heavy, simple_dumper (\%loose_property_name_of, ' ' x 4);
- push @heavy, <<END;
+$loose_property_name_of
);
# Maps property, table to file for those using stricter matching
\%utf8::stricter_to_file_of = (
-END
- push @heavy, simple_dumper (\%stricter_to_file_of, ' ' x 4);
- push @heavy, <<END;
+$stricter_to_file_of
);
# Maps property, table to file for those using loose matching
\%utf8::loose_to_file_of = (
-END
- push @heavy, simple_dumper (\%loose_to_file_of, ' ' x 4);
- push @heavy, <<END;
+$loose_to_file_of
);
# Maps floating point to fractional form
\%utf8::nv_floating_to_rational = (
-END
- push @heavy, simple_dumper (\%nv_floating_to_rational, ' ' x 4);
- push @heavy, <<END;
+$nv_floating_to_rational
);
# If a floating point number doesn't have enough digits in it to get this
@@ -13367,35 +15714,519 @@
# the table, so as to avoid duplication, as many property names can map to the
# file, but we only need one entry for all of them.
\%utf8::why_deprecated = (
-END
-
- push @heavy, simple_dumper (\%utf8::why_deprecated, ' ' x 4);
- push @heavy, <<END;
+$why_deprecated
);
-# A few properties have different behavior under /i matching. This maps the
+# A few properties have different behavior under /i matching. This maps
# those to substitute files to use under /i.
\%utf8::caseless_equivalent = (
+$caseless_equivalent_to
+);
+
+# Property names to mapping files
+\%utf8::loose_property_to_file_of = (
+$loose_property_to_file_of
+);
+
+# Files to the swash names within them.
+\%utf8::file_to_swash_name = (
+$file_to_swash_name
+);
+
+1;
END
+ main::write("Heavy.pl", 0, \@heavy); # The 0 means no utf8.
+ return;
+}
- # We set the key to the file when we associated files with tables, but we
- # couldn't do the same for the value then, as we might not have the file
- # for the alternate table figured out at that time.
- foreach my $cased (keys %caseless_equivalent_to) {
- my @path = $caseless_equivalent_to{$cased}->file_path;
- my $path = join '/', @path[1, -1];
- $path =~ s/\.pl//;
- $utf8::caseless_equivalent_to{$cased} = $path;
+sub make_Name_pm () {
+ # Create and write Name.pm, which contains subroutines and data to use in
+ # conjunction with Name.pl
+
+ # Maybe there's nothing to do.
+ return unless $has_hangul_syllables || @code_points_ending_in_code_point;
+
+ my @name = <<END;
+$HEADER
+$INTERNAL_ONLY_HEADER
+END
+
+ # Convert these structures to output format.
+ my $code_points_ending_in_code_point =
+ main::simple_dumper(\@code_points_ending_in_code_point,
+ ' ' x 8);
+ my $names = main::simple_dumper(\%names_ending_in_code_point,
+ ' ' x 8);
+ my $loose_names = main::simple_dumper(\%loose_names_ending_in_code_point,
+ ' ' x 8);
+
+ # Do the same with the Hangul names,
+ my $jamo;
+ my $jamo_l;
+ my $jamo_v;
+ my $jamo_t;
+ my $jamo_re;
+ if ($has_hangul_syllables) {
+
+ # Construct a regular expression of all the possible
+ # combinations of the Hangul syllables.
+ my @L_re; # Leading consonants
+ for my $i ($LBase .. $LBase + $LCount - 1) {
+ push @L_re, $Jamo{$i}
+ }
+ my @V_re; # Middle vowels
+ for my $i ($VBase .. $VBase + $VCount - 1) {
+ push @V_re, $Jamo{$i}
+ }
+ my @T_re; # Trailing consonants
+ for my $i ($TBase + 1 .. $TBase + $TCount - 1) {
+ push @T_re, $Jamo{$i}
+ }
+
+ # The whole re is made up of the L V T combination.
+ $jamo_re = '('
+ . join ('|', sort @L_re)
+ . ')('
+ . join ('|', sort @V_re)
+ . ')('
+ . join ('|', sort @T_re)
+ . ')?';
+
+ # These hashes needed by the algorithm were generated
+ # during reading of the Jamo.txt file
+ $jamo = main::simple_dumper(\%Jamo, ' ' x 8);
+ $jamo_l = main::simple_dumper(\%Jamo_L, ' ' x 8);
+ $jamo_v = main::simple_dumper(\%Jamo_V, ' ' x 8);
+ $jamo_t = main::simple_dumper(\%Jamo_T, ' ' x 8);
}
- push @heavy, simple_dumper (\%utf8::caseless_equivalent_to, ' ' x 4);
- push @heavy, <<END;
+
+ push @name, <<END;
+
+package charnames;
+
+# This module contains machine-generated tables and code for the
+# algorithmically-determinable Unicode character names. The following
+# routines can be used to translate between name and code point and vice versa
+
+{ # Closure
+
+ # Matches legal code point. 4-6 hex numbers, If there are 6, the first
+ # two must be 10; if there are 5, the first must not be a 0. Written this
+ # way to decrease backtracking. The first regex allows the code point to
+ # be at the end of a word, but to work properly, the word shouldn't end
+ # with a valid hex character. The second one won't match a code point at
+ # the end of a word, and doesn't have the run-on issue
+ my \$run_on_code_point_re = qr/$run_on_code_point_re/;
+ my \$code_point_re = qr/$code_point_re/;
+
+ # In the following hash, the keys are the bases of names which include
+ # the code point in the name, like CJK UNIFIED IDEOGRAPH-4E01. The value
+ # of each key is another hash which is used to get the low and high ends
+ # for each range of code points that apply to the name.
+ my %names_ending_in_code_point = (
+$names
+ );
+
+ # The following hash is a copy of the previous one, except is for loose
+ # matching, so each name has blanks and dashes squeezed out
+ my %loose_names_ending_in_code_point = (
+$loose_names
+ );
+
+ # And the following array gives the inverse mapping from code points to
+ # names. Lowest code points are first
+ my \@code_points_ending_in_code_point = (
+$code_points_ending_in_code_point
+ );
+END
+ # Earlier releases didn't have Jamos. No sense outputting
+ # them unless will be used.
+ if ($has_hangul_syllables) {
+ push @name, <<END;
+
+ # Convert from code point to Jamo short name for use in composing Hangul
+ # syllable names
+ my %Jamo = (
+$jamo
+ );
+
+ # Leading consonant (can be null)
+ my %Jamo_L = (
+$jamo_l
+ );
+
+ # Vowel
+ my %Jamo_V = (
+$jamo_v
+ );
+
+ # Optional trailing consonant
+ my %Jamo_T = (
+$jamo_t
+ );
+
+ # Computed re that splits up a Hangul name into LVT or LV syllables
+ my \$syllable_re = qr/$jamo_re/;
+
+ my \$HANGUL_SYLLABLE = "HANGUL SYLLABLE ";
+ my \$loose_HANGUL_SYLLABLE = "HANGULSYLLABLE";
+
+ # These constants names and values were taken from the Unicode standard,
+ # version 5.1, section 3.12. They are used in conjunction with Hangul
+ # syllables
+ my \$SBase = $SBase_string;
+ my \$LBase = $LBase_string;
+ my \$VBase = $VBase_string;
+ my \$TBase = $TBase_string;
+ my \$SCount = $SCount;
+ my \$LCount = $LCount;
+ my \$VCount = $VCount;
+ my \$TCount = $TCount;
+ my \$NCount = \$VCount * \$TCount;
+END
+ } # End of has Jamos
+
+ push @name, << 'END';
+
+ sub name_to_code_point_special {
+ my ($name, $loose) = @_;
+
+ # Returns undef if not one of the specially handled names; otherwise
+ # returns the code point equivalent to the input name
+ # $loose is non-zero if to use loose matching, 'name' in that case
+ # must be input as upper case with all blanks and dashes squeezed out.
+END
+ if ($has_hangul_syllables) {
+ push @name, << 'END';
+
+ if ((! $loose && $name =~ s/$HANGUL_SYLLABLE//)
+ || ($loose && $name =~ s/$loose_HANGUL_SYLLABLE//))
+ {
+ return if $name !~ qr/^$syllable_re$/;
+ my $L = $Jamo_L{$1};
+ my $V = $Jamo_V{$2};
+ my $T = (defined $3) ? $Jamo_T{$3} : 0;
+ return ($L * $VCount + $V) * $TCount + $T + $SBase;
+ }
+END
+ }
+ push @name, << 'END';
+
+ # Name must end in 'code_point' for this to handle.
+ return if (($loose && $name !~ /^ (.*?) ($run_on_code_point_re) $/x)
+ || (! $loose && $name !~ /^ (.*) ($code_point_re) $/x));
+
+ my $base = $1;
+ my $code_point = CORE::hex $2;
+ my $names_ref;
+
+ if ($loose) {
+ $names_ref = \%loose_names_ending_in_code_point;
+ }
+ else {
+ return if $base !~ s/-$//;
+ $names_ref = \%names_ending_in_code_point;
+ }
+
+ # Name must be one of the ones which has the code point in it.
+ return if ! $names_ref->{$base};
+
+ # Look through the list of ranges that apply to this name to see if
+ # the code point is in one of them.
+ for (my $i = 0; $i < scalar @{$names_ref->{$base}{'low'}}; $i++) {
+ return if $names_ref->{$base}{'low'}->[$i] > $code_point;
+ next if $names_ref->{$base}{'high'}->[$i] < $code_point;
+
+ # Here, the code point is in the range.
+ return $code_point;
+ }
+
+ # Here, looked like the name had a code point number in it, but
+ # did not match one of the valid ones.
+ return;
+ }
+
+ sub code_point_to_name_special {
+ my $code_point = shift;
+
+ # Returns the name of a code point if algorithmically determinable;
+ # undef if not
+END
+ if ($has_hangul_syllables) {
+ push @name, << 'END';
+
+ # If in the Hangul range, calculate the name based on Unicode's
+ # algorithm
+ if ($code_point >= $SBase && $code_point <= $SBase + $SCount -1) {
+ use integer;
+ my $SIndex = $code_point - $SBase;
+ my $L = $LBase + $SIndex / $NCount;
+ my $V = $VBase + ($SIndex % $NCount) / $TCount;
+ my $T = $TBase + $SIndex % $TCount;
+ $name = "$HANGUL_SYLLABLE$Jamo{$L}$Jamo{$V}";
+ $name .= $Jamo{$T} if $T != $TBase;
+ return $name;
+ }
+END
+ }
+ push @name, << 'END';
+
+ # Look through list of these code points for one in range.
+ foreach my $hash (@code_points_ending_in_code_point) {
+ return if $code_point < $hash->{'low'};
+ if ($code_point <= $hash->{'high'}) {
+ return sprintf("%s-%04X", $hash->{'name'}, $code_point);
+ }
+ }
+ return; # None found
+ }
+} # End closure
+
+1;
+END
+
+ main::write("Name.pm", 0, \@name); # The 0 means no utf8.
+ return;
+}
+
+sub make_UCD () {
+ # Create and write UCD.pl, which passes info about the tables to
+ # Unicode::UCD
+
+ # Create a mapping from each alias of Perl single-form extensions to all
+ # its equivalent aliases, for quick look-up.
+ my %perlprop_to_aliases;
+ foreach my $table ($perl->tables) {
+
+ # First create the list of the aliases of each extension
+ my @aliases_list; # List of legal aliases for this extension
+
+ my $table_name = $table->name;
+ my $standard_table_name = standardize($table_name);
+ my $table_full_name = $table->full_name;
+ my $standard_table_full_name = standardize($table_full_name);
+
+ # Make sure that the list has both the short and full names
+ push @aliases_list, $table_name, $table_full_name;
+
+ my $found_ucd = 0; # ? Did we actually get an alias that should be
+ # output for this table
+
+ # Go through all the aliases (including the two just added), and add
+ # any new unique ones to the list
+ foreach my $alias ($table->aliases) {
+
+ # Skip non-legal names
+ next unless $alias->ok_as_filename;
+ next unless $alias->ucd;
+
+ $found_ucd = 1; # have at least one legal name
+
+ my $name = $alias->name;
+ my $standard = standardize($name);
+
+ # Don't repeat a name that is equivalent to one already on the
+ # list
+ next if $standard eq $standard_table_name;
+ next if $standard eq $standard_table_full_name;
+
+ push @aliases_list, $name;
+ }
+
+ # If there were no legal names, don't output anything.
+ next unless $found_ucd;
+
+ # To conserve memory in the program reading these in, omit full names
+ # that are identical to the short name, when those are the only two
+ # aliases for the property.
+ if (@aliases_list == 2 && $aliases_list[0] eq $aliases_list[1]) {
+ pop @aliases_list;
+ }
+
+ # Here, @aliases_list is the list of all the aliases that this
+ # extension legally has. Now can create a map to it from each legal
+ # standardized alias
+ foreach my $alias ($table->aliases) {
+ next unless $alias->ucd;
+ next unless $alias->ok_as_filename;
+ push @{$perlprop_to_aliases{standardize($alias->name)}},
+ @aliases_list;
+ }
+ }
+
+ # Make a list of all combinations of properties/values that are suppressed.
+ my @suppressed;
+ if (! $debug_skip) { # This tends to fail in this debug mode
+ foreach my $property_name (keys %why_suppressed) {
+
+ # Just the value
+ my $value_name = $1 if $property_name =~ s/ = ( .* ) //x;
+
+ # The hash may contain properties not in this release of Unicode
+ next unless defined (my $property = property_ref($property_name));
+
+ # Find all combinations
+ foreach my $prop_alias ($property->aliases) {
+ my $prop_alias_name = standardize($prop_alias->name);
+
+ # If no =value, there's just one combination possibe for this
+ if (! $value_name) {
+
+ # The property may be suppressed, but there may be a proxy
+ # for it, so it shouldn't be listed as suppressed
+ next if $prop_alias->ucd;
+ push @suppressed, $prop_alias_name;
+ }
+ else { # Otherwise
+ foreach my $value_alias
+ ($property->table($value_name)->aliases)
+ {
+ next if $value_alias->ucd;
+
+ push @suppressed, "$prop_alias_name="
+ . standardize($value_alias->name);
+ }
+ }
+ }
+ }
+ }
+ @suppressed = sort @suppressed; # So doesn't change between runs of this
+ # program
+
+ # Convert the structure below (designed for Name.pm) to a form that UCD
+ # wants, so it doesn't have to modify it at all; i.e. so that it includes
+ # an element for the Hangul syllables in the appropriate place, and
+ # otherwise changes the name to include the "-<code point>" suffix.
+ my @algorithm_names;
+ my $done_hangul = 0;
+
+ # Copy it linearly.
+ for my $i (0 .. @code_points_ending_in_code_point - 1) {
+
+ # Insert the hanguls in the correct place.
+ if (! $done_hangul
+ && $code_points_ending_in_code_point[$i]->{'low'} > $SBase)
+ {
+ $done_hangul = 1;
+ push @algorithm_names, { low => $SBase,
+ high => $SBase + $SCount - 1,
+ name => '<hangul syllable>',
+ };
+ }
+
+ # Copy the current entry, modified.
+ push @algorithm_names, {
+ low => $code_points_ending_in_code_point[$i]->{'low'},
+ high => $code_points_ending_in_code_point[$i]->{'high'},
+ name =>
+ "$code_points_ending_in_code_point[$i]->{'name'}-<code point>",
+ };
+ }
+
+ # Serialize these structures for output.
+ my $loose_to_standard_value
+ = simple_dumper(\%loose_to_standard_value, ' ' x 4);
+ chomp $loose_to_standard_value;
+
+ my $string_property_loose_to_name
+ = simple_dumper(\%string_property_loose_to_name, ' ' x 4);
+ chomp $string_property_loose_to_name;
+
+ my $perlprop_to_aliases = simple_dumper(\%perlprop_to_aliases, ' ' x 4);
+ chomp $perlprop_to_aliases;
+
+ my $prop_aliases = simple_dumper(\%prop_aliases, ' ' x 4);
+ chomp $prop_aliases;
+
+ my $prop_value_aliases = simple_dumper(\%prop_value_aliases, ' ' x 4);
+ chomp $prop_value_aliases;
+
+ my $suppressed = (@suppressed) ? simple_dumper(\@suppressed, ' ' x 4) : "";
+ chomp $suppressed;
+
+ my $algorithm_names = simple_dumper(\@algorithm_names, ' ' x 4);
+ chomp $algorithm_names;
+
+ my $ambiguous_names = simple_dumper(\%ambiguous_names, ' ' x 4);
+ chomp $ambiguous_names;
+
+ my $loose_defaults = simple_dumper(\%loose_defaults, ' ' x 4);
+ chomp $loose_defaults;
+
+ my @ucd = <<END;
+$HEADER
+$INTERNAL_ONLY_HEADER
+
+# This file is for the use of Unicode::UCD
+
+# Highest legal Unicode code point
+\$Unicode::UCD::MAX_UNICODE_CODEPOINT = 0x$MAX_UNICODE_CODEPOINT_STRING;
+
+# Hangul syllables
+\$Unicode::UCD::HANGUL_BEGIN = $SBase_string;
+\$Unicode::UCD::HANGUL_COUNT = $SCount;
+
+# Keys are all the possible "prop=value" combinations, in loose form; values
+# are the standard loose name for the 'value' part of the key
+\%Unicode::UCD::loose_to_standard_value = (
+$loose_to_standard_value
);
+# String property loose names to standard loose name
+\%Unicode::UCD::string_property_loose_to_name = (
+$string_property_loose_to_name
+);
+
+# Keys are Perl extensions in loose form; values are each one's list of
+# aliases
+\%Unicode::UCD::loose_perlprop_to_name = (
+$perlprop_to_aliases
+);
+
+# Keys are standard property name; values are each one's aliases
+\%Unicode::UCD::prop_aliases = (
+$prop_aliases
+);
+
+# Keys of top level are standard property name; values are keys to another
+# hash, Each one is one of the property's values, in standard form. The
+# values are that prop-val's aliases. If only one specified, the short and
+# long alias are identical.
+\%Unicode::UCD::prop_value_aliases = (
+$prop_value_aliases
+);
+
+# Ordered (by code point ordinal) list of the ranges of code points whose
+# names are algorithmically determined. Each range entry is an anonymous hash
+# of the start and end points and a template for the names within it.
+\@Unicode::UCD::algorithmic_named_code_points = (
+$algorithm_names
+);
+
+# The properties that as-is have two meanings, and which must be disambiguated
+\%Unicode::UCD::ambiguous_names = (
+$ambiguous_names
+);
+
+# Keys are the prop-val combinations which are the default values for the
+# given property, expressed in standard loose form
+\%Unicode::UCD::loose_defaults = (
+$loose_defaults
+);
+
+# All combinations of names that are suppressed.
+# This is actually for UCD.t, so it knows which properties shouldn't have
+# entries. If it got any bigger, would probably want to put it in its own
+# file to use memory only when it was needed, in testing.
+\@Unicode::UCD::suppressed_properties = (
+$suppressed
+);
+
1;
END
- main::write("Heavy.pl", 0, \@heavy); # The 0 means no utf8.
+ main::write("UCD.pl", 0, \@ucd); # The 0 means no utf8.
return;
}
@@ -13412,11 +16243,20 @@
# For each property ...
# (sort so that if there is an immutable file name, it has precedence, so
- # some other property can't come in and take over its file name. If b's
- # file name is defined, will return 1, meaning to take it first; don't
- # care if both defined, as they had better be different anyway)
+ # some other property can't come in and take over its file name. (We
+ # don't care if both defined, as they had better be different anyway.)
+ # The property named 'Perl' needs to be first (it doesn't have any
+ # immutable file name) because empty properties are defined in terms of
+ # it's table named 'Any'.) We also sort by the property's name. This is
+ # just for repeatability of the outputs between runs of this program, but
+ # does not affect correctness.
PROPERTY:
- foreach my $property (sort { defined $b->file } property_ref('*')) {
+ foreach my $property ($perl,
+ sort { return -1 if defined $a->file;
+ return 1 if defined $b->file;
+ return $a->name cmp $b->name;
+ } grep { $_ != $perl } property_ref('*'))
+ {
my $type = $property->type;
# And for each table for that property, starting with the mapping
@@ -13434,6 +16274,19 @@
return 1 if ! defined $ext_a;
my $ext_b = $b->external_name;
return -1 if ! defined $ext_b;
+
+ # But return the non-complement table before
+ # the complement one, as the latter is defined
+ # in terms of the former, and needs to have
+ # the information for the former available.
+ return 1 if $a->complement != 0;
+ return -1 if $b->complement != 0;
+
+ # Similarly, return a subservient table after
+ # a leader
+ return 1 if $a->leader != $a;
+ return -1 if $b->leader != $b;
+
my $cmp = length $ext_a <=> length $ext_b;
# Return result if lengths not equal
@@ -13455,8 +16308,8 @@
# See if should suppress the table if is empty, but warn if it
# contains something.
- my $suppress_if_empty_warn_if_not = grep { $complete_name eq $_ }
- keys %why_suppress_if_empty_warn_if_not;
+ my $suppress_if_empty_warn_if_not
+ = $why_suppress_if_empty_warn_if_not{$complete_name} || 0;
# Calculate if this table should have any code points associated
# with it or not.
@@ -13489,33 +16342,14 @@
|| ($table == $property->table('N')
&& $property->table('Y')->is_empty));
-
- # Some tables should match everything
- my $expected_full =
- ($is_property)
- ? # All these types of map tables will be full because
- # they will have been populated with defaults
- ($type == $ENUM || $type == $BINARY)
-
- : # A match table should match everything if its method
- # shows it should
- ($table->matches_all
-
- # The complement of an empty binary table will match
- # everything
- || $is_complement_of_empty_binary
- )
- ;
-
if ($table->is_empty) {
-
if ($suppress_if_empty_warn_if_not) {
- $table->set_status($SUPPRESSED,
- $why_suppress_if_empty_warn_if_not{$complete_name});
+ $table->set_fate($SUPPRESSED,
+ $suppress_if_empty_warn_if_not);
}
- # Suppress expected empty tables.
+ # Suppress (by skipping them) expected empty tables.
next TABLE if $expected_empty;
# And setup to later output a warning for those that aren't
@@ -13523,22 +16357,45 @@
# this table is a child of another one to avoid duplicating
# the warning that should come from the parent one.
if (($table == $property || $table->parent == $table)
- && $table->status ne $SUPPRESSED
+ && $table->fate != $SUPPRESSED
+ && $table->fate != $MAP_PROXIED
&& ! grep { $complete_name =~ /^$_$/ }
@tables_that_may_be_empty)
{
push @unhandled_properties, "$table";
}
+
+ # An empty table is just the complement of everything.
+ $table->set_complement($Any) if $table != $property;
}
elsif ($expected_empty) {
my $because = "";
if ($suppress_if_empty_warn_if_not) {
- $because = " because $why_suppress_if_empty_warn_if_not{$complete_name}";
+ $because = " because $suppress_if_empty_warn_if_not";
}
Carp::my_carp("Not expecting property $table$because. Generating file for it anyway.");
}
+ # Some tables should match everything
+ my $expected_full =
+ ($table->fate == $SUPPRESSED)
+ ? 0
+ : ($is_property)
+ ? # All these types of map tables will be full because
+ # they will have been populated with defaults
+ ($type == $ENUM || $type == $FORCED_BINARY)
+
+ : # A match table should match everything if its method
+ # shows it should
+ ($table->matches_all
+
+ # The complement of an empty binary table will match
+ # everything
+ || $is_complement_of_empty_binary
+ )
+ ;
+
my $count = $table->count;
if ($expected_full) {
if ($count != $MAX_UNICODE_CODEPOINTS) {
@@ -13564,17 +16421,18 @@
}
}
}
- elsif ($count == $MAX_UNICODE_CODEPOINTS) {
- if ($table == $property || $table->leader == $table) {
+ elsif ($count == $MAX_UNICODE_CODEPOINTS
+ && ($table == $property || $table->leader == $table)
+ && $table->property->status ne $PLACEHOLDER)
+ {
Carp::my_carp("$table unexpectedly matches all Unicode code points. Proceeding anyway.");
- }
}
- if ($table->status eq $SUPPRESSED) {
+ if ($table->fate >= $SUPPRESSED) {
if (! $is_property) {
my @children = $table->children;
foreach my $child (@children) {
- if ($child->status ne $SUPPRESSED) {
+ if ($child->fate < $SUPPRESSED) {
Carp::my_carp_bug("'$table' is suppressed and has a child '$child' which isn't");
}
}
@@ -13582,8 +16440,11 @@
next TABLE;
}
+
if (! $is_property) {
+ make_ucd_table_pod_entries($table) if $table->property == $perl;
+
# Several things need to be done just once for each related
# group of match tables. Do them on the parent.
if ($table->parent == $table) {
@@ -13590,7 +16451,7 @@
# Add an entry in the pod file for the table; it also does
# the children.
- make_table_pod_entries($table) if defined $pod_directory;
+ make_re_pod_entries($table) if defined $pod_directory;
# See if the the table matches identical code points with
# something that has already been output. In that case,
@@ -13602,21 +16463,27 @@
# have to have the same status to share a file, so add
# this to the bucket hash. (The reason for this latter is
# that Heavy.pl associates a status with a file.)
- my $hash = $table->hash . ';' . $table->status;
+ # We don't check tables that are inverses of others, as it
+ # would lead to some coding complications, and checking
+ # all the regular ones should find everything.
+ if ($table->complement == 0) {
+ my $hash = $table->hash . ';' . $table->status;
- # Look at each table that is in the same bucket as this
- # one would be.
- foreach my $comparison (@{$match_tables_to_write{$hash}})
- {
- if ($table->matches_identically_to($comparison)) {
- $table->set_equivalent_to($comparison,
+ # Look at each table that is in the same bucket as
+ # this one would be.
+ foreach my $comparison
+ (@{$match_tables_to_write{$hash}})
+ {
+ if ($table->matches_identically_to($comparison)) {
+ $table->set_equivalent_to($comparison,
Related => 0);
- next TABLE;
+ next TABLE;
+ }
}
+
+ # Here, not equivalent, add this table to the bucket.
+ push @{$match_tables_to_write{$hash}}, $table;
}
-
- # Here, not equivalent, add this table to the bucket.
- push @{$match_tables_to_write{$hash}}, $table;
}
}
else {
@@ -13625,30 +16492,57 @@
# Don't write out or make references to the $perl property
next if $table == $perl;
- if ($type != $STRING) {
+ make_ucd_table_pod_entries($table);
- # There is a mapping stored of the various synonyms to the
- # standardized name of the property for utf8_heavy.pl.
- # Also, the pod file contains entries of the form:
- # \p{alias: *} \p{full: *}
- # rather than show every possible combination of things.
+ # There is a mapping stored of the various synonyms to the
+ # standardized name of the property for utf8_heavy.pl.
+ # Also, the pod file contains entries of the form:
+ # \p{alias: *} \p{full: *}
+ # rather than show every possible combination of things.
- my @property_aliases = $property->aliases;
+ my @property_aliases = $property->aliases;
- # The full name of this property is stored by convention
- # first in the alias array
- my $full_property_name =
- '\p{' . $property_aliases[0]->name . ': *}';
- my $standard_property_name = standardize($table->name);
+ my $full_property_name = $property->full_name;
+ my $property_name = $property->name;
+ my $standard_property_name = standardize($property_name);
+ my $standard_property_full_name
+ = standardize($full_property_name);
- # For each synonym ...
- for my $i (0 .. @property_aliases - 1) {
- my $alias = $property_aliases[$i];
- my $alias_name = $alias->name;
- my $alias_standard = standardize($alias_name);
+ # We also create for Unicode::UCD a list of aliases for
+ # the property. The list starts with the property name;
+ # then its full name.
+ my @property_list;
+ my @standard_list;
+ if ( $property->fate <= $MAP_PROXIED) {
+ @property_list = ($property_name, $full_property_name);
+ @standard_list = ($standard_property_name,
+ $standard_property_full_name);
+ }
- # Set the mapping for utf8_heavy of the alias to the
- # property
+ # For each synonym ...
+ for my $i (0 .. @property_aliases - 1) {
+ my $alias = $property_aliases[$i];
+ my $alias_name = $alias->name;
+ my $alias_standard = standardize($alias_name);
+
+
+ # Add other aliases to the list of property aliases
+ if ($property->fate <= $MAP_PROXIED
+ && ! grep { $alias_standard eq $_ } @standard_list)
+ {
+ push @property_list, $alias_name;
+ push @standard_list, $alias_standard;
+ }
+
+ # For utf8_heavy, set the mapping of the alias to the
+ # property
+ if ($type == $STRING) {
+ if ($property->fate <= $MAP_PROXIED) {
+ $string_property_loose_to_name{$alias_standard}
+ = $standard_property_name;
+ }
+ }
+ else {
if (exists ($loose_property_name_of{$alias_standard}))
{
Carp::my_carp("There already is a property with the same standard name as $alias_name: $loose_property_name_of{$alias_standard}. Old name is retained");
@@ -13658,7 +16552,7 @@
= $standard_property_name;
}
- # Now for the pod entry for this alias. Skip if not
+ # Now for the re pod entry for this alias. Skip if not
# outputting a pod; skip the first one, which is the
# full name so won't have an entry like: '\p{full: *}
# \p{full: *}', and skip if don't want an entry for
@@ -13665,9 +16559,9 @@
# this one.
next if $i == 0
|| ! defined $pod_directory
- || ! $alias->make_pod_entry;
+ || ! $alias->make_re_pod_entry;
- my $rhs = $full_property_name;
+ my $rhs = "\\p{$full_property_name: *}";
if ($property != $perl && $table->perl_extension) {
$rhs .= ' (Perl extension)';
}
@@ -13677,10 +16571,69 @@
$rhs,
$alias->status);
}
- } # End of non-string-like property code
+ }
+ # The list of all possible names is attached to each alias, so
+ # lookup is easy
+ if (@property_list) {
+ push @{$prop_aliases{$standard_list[0]}}, @property_list;
+ }
- # Don't output a mapping file if not desired.
+ if ($property->fate <= $MAP_PROXIED) {
+
+ # Similarly, we create for Unicode::UCD a list of
+ # property-value aliases.
+
+ my $property_full_name = $property->full_name;
+
+ # Look at each table in the property...
+ foreach my $table ($property->tables) {
+ my @values_list;
+ my $table_full_name = $table->full_name;
+ my $standard_table_full_name
+ = standardize($table_full_name);
+ my $table_name = $table->name;
+ my $standard_table_name = standardize($table_name);
+
+ # The list starts with the table name and its full
+ # name.
+ push @values_list, $table_name, $table_full_name;
+
+ # We add to the table each unique alias that isn't
+ # discouraged from use.
+ foreach my $alias ($table->aliases) {
+ next if $alias->status
+ && $alias->status eq $DISCOURAGED;
+ my $name = $alias->name;
+ my $standard = standardize($name);
+ next if $standard eq $standard_table_name;
+ next if $standard eq $standard_table_full_name;
+ push @values_list, $name;
+ }
+
+ # Here @values_list is a list of all the aliases for
+ # the table. That is, all the property-values given
+ # by this table. By agreement with Unicode::UCD,
+ # if the name and full name are identical, and there
+ # are no other names, drop the duplcate entry to save
+ # memory.
+ if (@values_list == 2
+ && $values_list[0] eq $values_list[1])
+ {
+ pop @values_list
+ }
+
+ # To save memory, unlike the similar list for property
+ # aliases above, only the standard forms hve the list.
+ # This forces an extra step of converting from input
+ # name to standard name, but the savings are
+ # considerable. (There is only marginal savings if we
+ # did this with the property aliases.)
+ push @{$prop_value_aliases{$standard_property_name}{$standard_table_name}}, @values_list;
+ }
+ }
+
+ # Don't write out a mapping file if not desired.
next if ! $property->to_output_map;
}
@@ -13726,7 +16679,8 @@
# Only need to write one file when shared by more than one
# property
- next if ! $is_property && $table->leader != $table;
+ next if ! $is_property
+ && ($table->leader != $table || $table->complement != 0);
# Construct a nice comment to add to the file
$table->set_final_comment;
@@ -13738,10 +16692,13 @@
# Write out the pod file
make_pod;
- # And Heavy.pl
+ # And Heavy.pl, Name.pm, UCD.pl
make_Heavy;
+ make_Name_pm;
+ make_UCD;
make_property_test_script() if $make_test_script;
+ make_normalization_test_script() if $make_norm_test_script;
return;
}
@@ -13961,7 +16918,10 @@
my @parts;
push @parts, $good_loose_seps[rand(@good_loose_seps)];
- for my $part (split /[-\s_]+/, $name) {
+
+ # Preserve trailing ones for the sake of not stripping the underscore from
+ # 'L_'
+ for my $part (split /[-\s_]+ (?= . )/, $name) {
if (@parts) {
if ($want_error and rand() < 0.3) {
push @parts, $bad_loose_seps[rand(@bad_loose_seps)];
@@ -14024,8 +16984,10 @@
# or multiple lines. main::write doesn't count the lines.
my @output;
- foreach my $property (property_ref('*')) {
- foreach my $table ($property->tables) {
+ # Sort these so get results in same order on different runs of this
+ # program
+ foreach my $property (sort { $a->name cmp $b->name } property_ref('*')) {
+ foreach my $table (sort { $a->name cmp $b->name } $property->tables) {
# Find code points that match, and don't match this table.
my $valid = $table->get_valid_code_point;
@@ -14039,6 +17001,18 @@
# in the set_final_comment() for Tables
my @table_aliases = $table->aliases;
my @property_aliases = $table->property->aliases;
+
+ # Every property can be optionally be prefixed by 'Is_', so test
+ # that those work, by creating such a new alias for each
+ # pre-existing one.
+ push @property_aliases, map { Alias->new("Is_" . $_->name,
+ $_->loose_match,
+ $_->make_re_pod_entry,
+ $_->ok_as_filename,
+ $_->status,
+ $_->ucd,
+ )
+ } @property_aliases;
my $max = max(scalar @table_aliases, scalar @property_aliases);
for my $j (0 .. $max - 1) {
@@ -14177,6 +17151,82 @@
return;
}
+sub make_normalization_test_script() {
+ print "Making normalization test script\n" if $verbosity >= $PROGRESS;
+
+ my $n_path = 'TestNorm.pl';
+
+ unshift @normalization_tests, <<'END';
+use utf8;
+use Test::More;
+
+sub ord_string { # Convert packed ords to printable string
+ use charnames ();
+ return "'" . join("", map { '\N{' . charnames::viacode($_) . '}' }
+ unpack "U*", shift) . "'";
+ #return "'" . join(" ", map { sprintf "%04X", $_ } unpack "U*", shift) . "'";
+}
+
+sub Test_N {
+ my ($source, $nfc, $nfd, $nfkc, $nfkd) = @_;
+ my $display_source = ord_string($source);
+ my $display_nfc = ord_string($nfc);
+ my $display_nfd = ord_string($nfd);
+ my $display_nfkc = ord_string($nfkc);
+ my $display_nfkd = ord_string($nfkd);
+
+ use Unicode::Normalize;
+ # NFC
+ # nfc == toNFC(source) == toNFC(nfc) == toNFC(nfd)
+ # nfkc == toNFC(nfkc) == toNFC(nfkd)
+ #
+ # NFD
+ # nfd == toNFD(source) == toNFD(nfc) == toNFD(nfd)
+ # nfkd == toNFD(nfkc) == toNFD(nfkd)
+ #
+ # NFKC
+ # nfkc == toNFKC(source) == toNFKC(nfc) == toNFKC(nfd) ==
+ # toNFKC(nfkc) == toNFKC(nfkd)
+ #
+ # NFKD
+ # nfkd == toNFKD(source) == toNFKD(nfc) == toNFKD(nfd) ==
+ # toNFKD(nfkc) == toNFKD(nfkd)
+
+ is(NFC($source), $nfc, "NFC($display_source) eq $display_nfc");
+ is(NFC($nfc), $nfc, "NFC($display_nfc) eq $display_nfc");
+ is(NFC($nfd), $nfc, "NFC($display_nfd) eq $display_nfc");
+ is(NFC($nfkc), $nfkc, "NFC($display_nfkc) eq $display_nfkc");
+ is(NFC($nfkd), $nfkc, "NFC($display_nfkd) eq $display_nfkc");
+
+ is(NFD($source), $nfd, "NFD($display_source) eq $display_nfd");
+ is(NFD($nfc), $nfd, "NFD($display_nfc) eq $display_nfd");
+ is(NFD($nfd), $nfd, "NFD($display_nfd) eq $display_nfd");
+ is(NFD($nfkc), $nfkd, "NFD($display_nfkc) eq $display_nfkd");
+ is(NFD($nfkd), $nfkd, "NFD($display_nfkd) eq $display_nfkd");
+
+ is(NFKC($source), $nfkc, "NFKC($display_source) eq $display_nfkc");
+ is(NFKC($nfc), $nfkc, "NFKC($display_nfc) eq $display_nfkc");
+ is(NFKC($nfd), $nfkc, "NFKC($display_nfd) eq $display_nfkc");
+ is(NFKC($nfkc), $nfkc, "NFKC($display_nfkc) eq $display_nfkc");
+ is(NFKC($nfkd), $nfkc, "NFKC($display_nfkd) eq $display_nfkc");
+
+ is(NFKD($source), $nfkd, "NFKD($display_source) eq $display_nfkd");
+ is(NFKD($nfc), $nfkd, "NFKD($display_nfc) eq $display_nfkd");
+ is(NFKD($nfd), $nfkd, "NFKD($display_nfd) eq $display_nfkd");
+ is(NFKD($nfkc), $nfkd, "NFKD($display_nfkc) eq $display_nfkd");
+ is(NFKD($nfkd), $nfkd, "NFKD($display_nfkd) eq $display_nfkd");
+}
+END
+
+ &write($n_path,
+ 1, # Is utf8;
+ [
+ @normalization_tests,
+ 'done_testing();'
+ ]);
+ return;
+}
+
# This is a list of the input files and how to handle them. The files are
# processed in their order in this list. Some reordering is possible if
# desired, but the v0 files should be first, and the extracted before the
@@ -14183,7 +17233,7 @@
# others except DAge.txt (as data in an extracted file can be over-ridden by
# the non-extracted. Some other files depend on data derived from an earlier
# file, like UnicodeData requires data from Jamo, and the case changing and
-# folding requires data from Unicode. Mostly, it safest to order by first
+# folding requires data from Unicode. Mostly, it is safest to order by first
# version releases in (except the Jamo). DAge.txt is read before the
# extracted ones because of the rarely used feature $compare_versions. In the
# unlikely event that there were ever an extracted file that contained the Age
@@ -14266,10 +17316,25 @@
# And for 5.14 Perls with 6.0,
# have to also make changes
- : ($v_version ge v6.0.0)
+ : ($v_version ge v6.0.0
+ && $^V lt v5.17.0)
? \&filter_v6_ucd
: undef),
+ # Early versions did not have the
+ # proper Unicode_1 names for the
+ # controls
+ (($v_version lt v3.0.0)
+ ? \&filter_early_U1_names
+ : undef),
+
+ # Early versions did not correctly
+ # use the later method for giving
+ # decimal digit values
+ (($v_version le v3.2.0)
+ ? \&filter_bad_Nd_ucd
+ : undef),
+
# And the main filter
\&filter_UnicodeData_line,
],
@@ -14300,8 +17365,11 @@
Each_Line_Handler => \&filter_unihan_line,
),
Input_file->new('SpecialCasing.txt', v2.1.8,
- Each_Line_Handler => \&filter_special_casing_line,
+ Each_Line_Handler => ($v_version eq 2.1.8)
+ ? \&filter_2_1_8_special_casing_line
+ : \&filter_special_casing_line,
Pre_Handler => \&setup_special_casing,
+ Has_Missings_Defaults => $IGNORED,
),
Input_file->new(
'LineBreak.txt', v3.0.0,
@@ -14325,9 +17393,17 @@
),
Input_file->new('BidiMirroring.txt', v3.0.1,
Property => 'Bidi_Mirroring_Glyph',
+ Has_Missings_Defaults => ($v_version lt v6.2.0)
+ ? $NO_DEFAULTS
+ # Is <none> which doesn't mean
+ # anything to us, we will use the
+ # null string
+ : $IGNORED,
+
),
- Input_file->new("NormalizationTest.txt", v3.0.1,
- Skip => 1,
+ Input_file->new("NormTest.txt", v3.0.0,
+ Handler => \&process_NormalizationsTest,
+ Skip => ($make_norm_test_script) ? 0 : 'Validation Tests',
),
Input_file->new('CaseFolding.txt', v3.0.1,
Pre_Handler => \&setup_case_folding,
@@ -14337,6 +17413,7 @@
: undef,
\&filter_case_folding_line
],
+ Has_Missings_Defaults => $IGNORED,
),
Input_file->new('DCoreProperties.txt', v3.1.0,
# 5.2 changed this file
@@ -14354,28 +17431,35 @@
? \&filter_old_style_normalization_lines
: undef),
),
- Input_file->new('HangulSyllableType.txt', v4.0.0,
+ Input_file->new('HangulSyllableType.txt', v0,
Has_Missings_Defaults => $NOT_IGNORED,
- Property => 'Hangul_Syllable_Type'),
+ Property => 'Hangul_Syllable_Type',
+ Pre_Handler => ($v_version lt v4.0.0)
+ ? \&generate_hst
+ : undef,
+ ),
Input_file->new("$AUXILIARY/WordBreakProperty.txt", v4.1.0,
Property => 'Word_Break',
Has_Missings_Defaults => $NOT_IGNORED,
),
- Input_file->new("$AUXILIARY/GraphemeBreakProperty.txt", v4.1.0,
+ Input_file->new("$AUXILIARY/GraphemeBreakProperty.txt", v0,
Property => 'Grapheme_Cluster_Break',
Has_Missings_Defaults => $NOT_IGNORED,
+ Pre_Handler => ($v_version lt v4.1.0)
+ ? \&generate_GCB
+ : undef,
),
Input_file->new("$AUXILIARY/GCBTest.txt", v4.1.0,
Handler => \&process_GCB_test,
),
Input_file->new("$AUXILIARY/LBTest.txt", v4.1.0,
- Skip => 1,
+ Skip => 'Validation Tests',
),
Input_file->new("$AUXILIARY/SBTest.txt", v4.1.0,
- Skip => 1,
+ Skip => 'Validation Tests',
),
Input_file->new("$AUXILIARY/WBTest.txt", v4.1.0,
- Skip => 1,
+ Skip => 'Validation Tests',
),
Input_file->new("$AUXILIARY/SentenceBreakProperty.txt", v4.1.0,
Property => 'Sentence_Break',
@@ -14384,11 +17468,17 @@
Input_file->new('NamedSequences.txt', v4.1.0,
Handler => \&process_NamedSequences
),
- Input_file->new('NameAliases.txt', v5.0.0,
+ Input_file->new('NameAliases.txt', v0,
Property => 'Name_Alias',
+ Pre_Handler => ($v_version le v6.0.0)
+ ? \&setup_early_name_alias
+ : undef,
+ Each_Line_Handler => ($v_version le v6.0.0)
+ ? \&filter_early_version_name_alias_line
+ : \&filter_later_version_name_alias_line,
),
Input_file->new("BidiTest.txt", v5.2.0,
- Skip => 1,
+ Skip => 'Validation Tests',
),
Input_file->new('UnihanIndicesDictionary.txt', v5.2.0,
Optional => 1,
@@ -14423,6 +17513,28 @@
Optional => 1,
Each_Line_Handler => \&filter_unihan_line,
),
+ Input_file->new('ScriptExtensions.txt', v6.0.0,
+ Property => 'Script_Extensions',
+ Pre_Handler => \&setup_script_extensions,
+ Each_Line_Handler => \&filter_script_extensions_line,
+ Has_Missings_Defaults => (($v_version le v6.0.0)
+ ? $NO_DEFAULTS
+ : $IGNORED),
+ ),
+ # The two Indic files are actually available starting in v6.0.0, but their
+ # property values are missing from PropValueAliases.txt in that release,
+ # so that further work would have to be done to get them to work properly
+ # for that release.
+ Input_file->new('IndicMatraCategory.txt', v6.1.0,
+ Property => 'Indic_Matra_Category',
+ Has_Missings_Defaults => $NOT_IGNORED,
+ Skip => "Provisional; for the analysis and processing of Indic scripts",
+ ),
+ Input_file->new('IndicSyllabicCategory.txt', v6.1.0,
+ Property => 'Indic_Syllabic_Category',
+ Has_Missings_Defaults => $NOT_IGNORED,
+ Skip => "Provisional; for the analysis and processing of Indic scripts",
+ ),
);
# End of all the preliminaries.
@@ -14498,8 +17610,8 @@
# The paths are stored with relative names, and with '/' as the
# delimiter; convert to absolute on this machine
my $full = lc(File::Spec->rel2abs(internal_file_to_platform($input)));
- $potential_files{$full} = 1
- if ! grep { lc($full) eq lc($_) } @ignored_files_full_names;
+ $potential_files{lc $full} = 1
+ if ! grep { lc($full) eq lc($_) } @ignored_files_full_names;
}
}
@@ -14519,8 +17631,8 @@
}
my @unknown_input_files;
- foreach my $file (keys %potential_files) {
- next if grep { lc($file) eq lc($_) } @known_files;
+ foreach my $file (keys %potential_files) { # The keys are stored in lc
+ next if grep { $file eq lc($_) } @known_files;
# Here, the file is unknown to us. Get relative path name
$file = File::Spec->abs2rel($file);
@@ -14572,7 +17684,7 @@
# Create the list of input files from the objects we have defined, plus
# version
-my @input_files = 'version';
+my @input_files = qw(version Makefile);
foreach my $object (@input_file_objects) {
my $file = $object->file;
next if ! defined $file; # Not all objects have files
@@ -14603,6 +17715,10 @@
}
}
+# We use 'Makefile' just to see if it has changed since the last time we
+# rebuilt. Now discard it.
+ at input_files = grep { $_ ne 'Makefile' } @input_files;
+
my $rebuild = $write_unchanged_files # Rebuild: if unconditional rebuild
|| ! scalar @mktables_list_output_files # or if no outputs known
|| $old_start_time < $most_recent; # or out-of-date
@@ -14704,7 +17820,7 @@
}
# Output these warnings unless -q explicitly specified.
-if ($verbosity >= $NORMAL_VERBOSITY) {
+if ($verbosity >= $NORMAL_VERBOSITY && ! $debug_skip) {
if (@unhandled_properties) {
print "\nProperties and tables that unexpectedly have no code points\n";
foreach my $property (sort @unhandled_properties) {
Property changes on: trunk/contrib/perl/lib/unicore/mktables
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Copied: trunk/contrib/perl/lib/unicore/mktables.lst (from rev 6437, vendor/perl/5.18.1/lib/unicore/mktables.lst)
===================================================================
--- trunk/contrib/perl/lib/unicore/mktables.lst (rev 0)
+++ trunk/contrib/perl/lib/unicore/mktables.lst 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,563 @@
+#
+# mktables.lst -- File list for mktables.
+#
+# Autogenerated on Mon Jan 26 17:57:26 2009
+#
+# - First section is input files
+# (mktables itself is automatically included)
+# - Section seperator is /^=+$/
+# - Second section is a list of output files.
+# - Lines matching /^\s*#/ are treated as comments
+# which along with blank lines are ignored.
+#
+
+# Input files:
+
+ArabicShaping.txt
+BidiMirroring.txt
+Blocks.txt
+CaseFolding.txt
+CompositionExclusions.txt
+EastAsianWidth.txt
+HangulSyllableType.txt
+Index.txt
+Jamo.txt
+LineBreak.txt
+NameAliases.txt
+NamedSequences.txt
+NamedSqProv.txt
+NamesList.txt
+NormalizationCorrections.txt
+PropList.txt
+PropValueAliases.txt
+PropertyAliases.txt
+ReadMe.txt
+Scripts.txt
+SpecialCasing.txt
+StandardizedVariants.txt
+UnicodeData.txt
+version
+
+=================================
+
+# Output files:
+
+Properties
+Canonical.pl
+CombiningClass.pl
+Decomposition.pl
+Exact.pl
+Name.pl
+PVA.pl
+To/Digit.pl
+To/Fold.pl
+To/Lower.pl
+To/Title.pl
+To/Upper.pl
+lib/bc/AL.pl
+lib/bc/AN.pl
+lib/bc/B.pl
+lib/bc/BN.pl
+lib/bc/CS.pl
+lib/bc/EN.pl
+lib/bc/ES.pl
+lib/bc/ET.pl
+lib/bc/L.pl
+lib/bc/LRE.pl
+lib/bc/LRO.pl
+lib/bc/NSM.pl
+lib/bc/ON.pl
+lib/bc/PDF.pl
+lib/bc/R.pl
+lib/bc/RLE.pl
+lib/bc/RLO.pl
+lib/bc/S.pl
+lib/bc/WS.pl
+lib/ccc/A.pl
+lib/ccc/AL.pl
+lib/ccc/AR.pl
+lib/ccc/ATAR.pl
+lib/ccc/ATB.pl
+lib/ccc/ATBL.pl
+lib/ccc/B.pl
+lib/ccc/BL.pl
+lib/ccc/BR.pl
+lib/ccc/DA.pl
+lib/ccc/DB.pl
+lib/ccc/IS.pl
+lib/ccc/KV.pl
+lib/ccc/L.pl
+lib/ccc/NK.pl
+lib/ccc/NR.pl
+lib/ccc/OV.pl
+lib/ccc/R.pl
+lib/ccc/VR.pl
+lib/dt/Can.pl
+lib/dt/Com.pl
+lib/dt/Enc.pl
+lib/dt/Fin.pl
+lib/dt/Font.pl
+lib/dt/Fra.pl
+lib/dt/Init.pl
+lib/dt/Iso.pl
+lib/dt/Med.pl
+lib/dt/Nar.pl
+lib/dt/Nb.pl
+lib/dt/Sml.pl
+lib/dt/Sqr.pl
+lib/dt/Sub.pl
+lib/dt/Sup.pl
+lib/dt/Vert.pl
+lib/dt/Wide.pl
+lib/ea/A.pl
+lib/ea/F.pl
+lib/ea/H.pl
+lib/ea/N.pl
+lib/ea/Na.pl
+lib/ea/W.pl
+lib/gc_sc/AHex.pl
+lib/gc_sc/ASCII.pl
+lib/gc_sc/Alnum.pl
+lib/gc_sc/Alpha.pl
+lib/gc_sc/Alphabet.pl
+lib/gc_sc/Any.pl
+lib/gc_sc/Arab.pl
+lib/gc_sc/Armn.pl
+lib/gc_sc/AsciiHex.pl
+lib/gc_sc/Assigned.pl
+lib/gc_sc/Bali.pl
+lib/gc_sc/Beng.pl
+lib/gc_sc/BidiC.pl
+lib/gc_sc/BidiCont.pl
+lib/gc_sc/Blank.pl
+lib/gc_sc/Bopo.pl
+lib/gc_sc/Brai.pl
+lib/gc_sc/Bugi.pl
+lib/gc_sc/Buhd.pl
+lib/gc_sc/C.pl
+lib/gc_sc/Canadian.pl
+lib/gc_sc/Cari.pl
+lib/gc_sc/Cc.pl
+lib/gc_sc/Cf.pl
+lib/gc_sc/Cham.pl
+lib/gc_sc/Cher.pl
+lib/gc_sc/Cn.pl
+lib/gc_sc/Cntrl.pl
+lib/gc_sc/Co.pl
+lib/gc_sc/Copt.pl
+lib/gc_sc/Cprt.pl
+lib/gc_sc/Cs.pl
+lib/gc_sc/Cyrl.pl
+lib/gc_sc/Dash.pl
+lib/gc_sc/Dash2.pl
+lib/gc_sc/DefaultI.pl
+lib/gc_sc/Dep.pl
+lib/gc_sc/Deprecat.pl
+lib/gc_sc/Deva.pl
+lib/gc_sc/Dia.pl
+lib/gc_sc/Diacriti.pl
+lib/gc_sc/Digit.pl
+lib/gc_sc/Dsrt.pl
+lib/gc_sc/Ethi.pl
+lib/gc_sc/Ext.pl
+lib/gc_sc/Extender.pl
+lib/gc_sc/Geor.pl
+lib/gc_sc/Glag.pl
+lib/gc_sc/Goth.pl
+lib/gc_sc/Graph.pl
+lib/gc_sc/Grek.pl
+lib/gc_sc/Gujr.pl
+lib/gc_sc/Guru.pl
+lib/gc_sc/Hang.pl
+lib/gc_sc/Hani.pl
+lib/gc_sc/Hano.pl
+lib/gc_sc/Hebr.pl
+lib/gc_sc/Hex.pl
+lib/gc_sc/HexDigit.pl
+lib/gc_sc/Hira.pl
+lib/gc_sc/HorizSpa.pl
+lib/gc_sc/Hyphen.pl
+lib/gc_sc/Hyphen2.pl
+lib/gc_sc/IDSB.pl
+lib/gc_sc/IDST.pl
+lib/gc_sc/IdContin.pl
+lib/gc_sc/IdStart.pl
+lib/gc_sc/Ideo.pl
+lib/gc_sc/Ideograp.pl
+lib/gc_sc/IdsBinar.pl
+lib/gc_sc/IdsTrina.pl
+lib/gc_sc/InAegean.pl
+lib/gc_sc/InAlphab.pl
+lib/gc_sc/InAncie2.pl
+lib/gc_sc/InAncie3.pl
+lib/gc_sc/InAncien.pl
+lib/gc_sc/InArabi2.pl
+lib/gc_sc/InArabi3.pl
+lib/gc_sc/InArabi4.pl
+lib/gc_sc/InArabic.pl
+lib/gc_sc/InArmeni.pl
+lib/gc_sc/InArrows.pl
+lib/gc_sc/InBaline.pl
+lib/gc_sc/InBasicL.pl
+lib/gc_sc/InBengal.pl
+lib/gc_sc/InBlockE.pl
+lib/gc_sc/InBopom2.pl
+lib/gc_sc/InBopomo.pl
+lib/gc_sc/InBoxDra.pl
+lib/gc_sc/InBraill.pl
+lib/gc_sc/InBugine.pl
+lib/gc_sc/InBuhid.pl
+lib/gc_sc/InByzant.pl
+lib/gc_sc/InCarian.pl
+lib/gc_sc/InCham.pl
+lib/gc_sc/InCherok.pl
+lib/gc_sc/InCjkCo2.pl
+lib/gc_sc/InCjkCo3.pl
+lib/gc_sc/InCjkCo4.pl
+lib/gc_sc/InCjkCom.pl
+lib/gc_sc/InCjkRad.pl
+lib/gc_sc/InCjkStr.pl
+lib/gc_sc/InCjkSym.pl
+lib/gc_sc/InCjkUn2.pl
+lib/gc_sc/InCjkUn3.pl
+lib/gc_sc/InCjkUni.pl
+lib/gc_sc/InCombi2.pl
+lib/gc_sc/InCombi3.pl
+lib/gc_sc/InCombi4.pl
+lib/gc_sc/InCombin.pl
+lib/gc_sc/InContro.pl
+lib/gc_sc/InCoptic.pl
+lib/gc_sc/InCounti.pl
+lib/gc_sc/InCunei2.pl
+lib/gc_sc/InCuneif.pl
+lib/gc_sc/InCurren.pl
+lib/gc_sc/InCyprio.pl
+lib/gc_sc/InCyril2.pl
+lib/gc_sc/InCyril3.pl
+lib/gc_sc/InCyril4.pl
+lib/gc_sc/InCyrill.pl
+lib/gc_sc/InDesere.pl
+lib/gc_sc/InDevana.pl
+lib/gc_sc/InDingba.pl
+lib/gc_sc/InDomino.pl
+lib/gc_sc/InEnclo2.pl
+lib/gc_sc/InEnclos.pl
+lib/gc_sc/InEthio2.pl
+lib/gc_sc/InEthio3.pl
+lib/gc_sc/InEthiop.pl
+lib/gc_sc/InGenera.pl
+lib/gc_sc/InGeomet.pl
+lib/gc_sc/InGeorg2.pl
+lib/gc_sc/InGeorgi.pl
+lib/gc_sc/InGlagol.pl
+lib/gc_sc/InGothic.pl
+lib/gc_sc/InGreekA.pl
+lib/gc_sc/InGreekE.pl
+lib/gc_sc/InGujara.pl
+lib/gc_sc/InGurmuk.pl
+lib/gc_sc/InHalfwi.pl
+lib/gc_sc/InHangu2.pl
+lib/gc_sc/InHangu3.pl
+lib/gc_sc/InHangul.pl
+lib/gc_sc/InHanuno.pl
+lib/gc_sc/InHebrew.pl
+lib/gc_sc/InHighPr.pl
+lib/gc_sc/InHighSu.pl
+lib/gc_sc/InHiraga.pl
+lib/gc_sc/InIdeogr.pl
+lib/gc_sc/InIpaExt.pl
+lib/gc_sc/InKanbun.pl
+lib/gc_sc/InKangxi.pl
+lib/gc_sc/InKannad.pl
+lib/gc_sc/InKatak2.pl
+lib/gc_sc/InKataka.pl
+lib/gc_sc/InKayahL.pl
+lib/gc_sc/InKharos.pl
+lib/gc_sc/InKhmer.pl
+lib/gc_sc/InKhmerS.pl
+lib/gc_sc/InLao.pl
+lib/gc_sc/InLatin1.pl
+lib/gc_sc/InLatin2.pl
+lib/gc_sc/InLatin3.pl
+lib/gc_sc/InLatin4.pl
+lib/gc_sc/InLatin5.pl
+lib/gc_sc/InLatinE.pl
+lib/gc_sc/InLepcha.pl
+lib/gc_sc/InLetter.pl
+lib/gc_sc/InLimbu.pl
+lib/gc_sc/InLinea2.pl
+lib/gc_sc/InLinear.pl
+lib/gc_sc/InLowSur.pl
+lib/gc_sc/InLycian.pl
+lib/gc_sc/InLydian.pl
+lib/gc_sc/InMahjon.pl
+lib/gc_sc/InMalaya.pl
+lib/gc_sc/InMathe2.pl
+lib/gc_sc/InMathem.pl
+lib/gc_sc/InMisce2.pl
+lib/gc_sc/InMisce3.pl
+lib/gc_sc/InMisce4.pl
+lib/gc_sc/InMisce5.pl
+lib/gc_sc/InMiscel.pl
+lib/gc_sc/InModifi.pl
+lib/gc_sc/InMongol.pl
+lib/gc_sc/InMusica.pl
+lib/gc_sc/InMyanma.pl
+lib/gc_sc/InNewTai.pl
+lib/gc_sc/InNko.pl
+lib/gc_sc/InNumber.pl
+lib/gc_sc/InOgham.pl
+lib/gc_sc/InOlChik.pl
+lib/gc_sc/InOldIta.pl
+lib/gc_sc/InOldPer.pl
+lib/gc_sc/InOptica.pl
+lib/gc_sc/InOriya.pl
+lib/gc_sc/InOsmany.pl
+lib/gc_sc/InPhagsP.pl
+lib/gc_sc/InPhaist.pl
+lib/gc_sc/InPhoeni.pl
+lib/gc_sc/InPhone2.pl
+lib/gc_sc/InPhonet.pl
+lib/gc_sc/InPrivat.pl
+lib/gc_sc/InRejang.pl
+lib/gc_sc/InRunic.pl
+lib/gc_sc/InSauras.pl
+lib/gc_sc/InShavia.pl
+lib/gc_sc/InSinhal.pl
+lib/gc_sc/InSmallF.pl
+lib/gc_sc/InSpacin.pl
+lib/gc_sc/InSpecia.pl
+lib/gc_sc/InSundan.pl
+lib/gc_sc/InSupers.pl
+lib/gc_sc/InSuppl2.pl
+lib/gc_sc/InSuppl3.pl
+lib/gc_sc/InSuppl4.pl
+lib/gc_sc/InSuppl5.pl
+lib/gc_sc/InSuppl6.pl
+lib/gc_sc/InSupple.pl
+lib/gc_sc/InSyloti.pl
+lib/gc_sc/InSyriac.pl
+lib/gc_sc/InTagalo.pl
+lib/gc_sc/InTagban.pl
+lib/gc_sc/InTags.pl
+lib/gc_sc/InTaiLe.pl
+lib/gc_sc/InTaiXua.pl
+lib/gc_sc/InTamil.pl
+lib/gc_sc/InTelugu.pl
+lib/gc_sc/InThaana.pl
+lib/gc_sc/InThai.pl
+lib/gc_sc/InTibeta.pl
+lib/gc_sc/InTifina.pl
+lib/gc_sc/InUgarit.pl
+lib/gc_sc/InUnifie.pl
+lib/gc_sc/InVai.pl
+lib/gc_sc/InVaria2.pl
+lib/gc_sc/InVariat.pl
+lib/gc_sc/InVertic.pl
+lib/gc_sc/InYiRadi.pl
+lib/gc_sc/InYiSyll.pl
+lib/gc_sc/InYijing.pl
+lib/gc_sc/JoinC.pl
+lib/gc_sc/JoinCont.pl
+lib/gc_sc/Kana.pl
+lib/gc_sc/KayahLi.pl
+lib/gc_sc/Khar.pl
+lib/gc_sc/Khmr.pl
+lib/gc_sc/Knda.pl
+lib/gc_sc/L.pl
+lib/gc_sc/LC.pl
+lib/gc_sc/LOE.pl
+lib/gc_sc/Laoo.pl
+lib/gc_sc/Latn.pl
+lib/gc_sc/Lepc.pl
+lib/gc_sc/Limb.pl
+lib/gc_sc/LinearB.pl
+lib/gc_sc/Ll.pl
+lib/gc_sc/Lm.pl
+lib/gc_sc/Lo.pl
+lib/gc_sc/LogicalO.pl
+lib/gc_sc/Lower.pl
+lib/gc_sc/Lowercas.pl
+lib/gc_sc/Lt.pl
+lib/gc_sc/Lu.pl
+lib/gc_sc/Lyci.pl
+lib/gc_sc/Lydi.pl
+lib/gc_sc/M.pl
+lib/gc_sc/Math.pl
+lib/gc_sc/Mc.pl
+lib/gc_sc/Me.pl
+lib/gc_sc/Mlym.pl
+lib/gc_sc/Mn.pl
+lib/gc_sc/Mong.pl
+lib/gc_sc/Mymr.pl
+lib/gc_sc/N.pl
+lib/gc_sc/NChar.pl
+lib/gc_sc/Nd.pl
+lib/gc_sc/NewTaiLu.pl
+lib/gc_sc/Nkoo.pl
+lib/gc_sc/Nl.pl
+lib/gc_sc/No.pl
+lib/gc_sc/Nonchara.pl
+lib/gc_sc/OAlpha.pl
+lib/gc_sc/ODI.pl
+lib/gc_sc/OGrExt.pl
+lib/gc_sc/OIDC.pl
+lib/gc_sc/OIDS.pl
+lib/gc_sc/OLower.pl
+lib/gc_sc/OMath.pl
+lib/gc_sc/OUpper.pl
+lib/gc_sc/Ogam.pl
+lib/gc_sc/OlChiki.pl
+lib/gc_sc/OldItali.pl
+lib/gc_sc/OldPersi.pl
+lib/gc_sc/Orya.pl
+lib/gc_sc/Osma.pl
+lib/gc_sc/OtherAlp.pl
+lib/gc_sc/OtherDef.pl
+lib/gc_sc/OtherGra.pl
+lib/gc_sc/OtherIdC.pl
+lib/gc_sc/OtherIdS.pl
+lib/gc_sc/OtherLow.pl
+lib/gc_sc/OtherMat.pl
+lib/gc_sc/OtherUpp.pl
+lib/gc_sc/P.pl
+lib/gc_sc/PatSyn.pl
+lib/gc_sc/PatWS.pl
+lib/gc_sc/PatternS.pl
+lib/gc_sc/PatternW.pl
+lib/gc_sc/Pc.pl
+lib/gc_sc/Pd.pl
+lib/gc_sc/Pe.pl
+lib/gc_sc/PerlSpac.pl
+lib/gc_sc/PerlWord.pl
+lib/gc_sc/Pf.pl
+lib/gc_sc/PhagsPa.pl
+lib/gc_sc/Phnx.pl
+lib/gc_sc/Pi.pl
+lib/gc_sc/Po.pl
+lib/gc_sc/PosixAln.pl
+lib/gc_sc/PosixAlp.pl
+lib/gc_sc/PosixBla.pl
+lib/gc_sc/PosixCnt.pl
+lib/gc_sc/PosixDig.pl
+lib/gc_sc/PosixGra.pl
+lib/gc_sc/PosixLow.pl
+lib/gc_sc/PosixPri.pl
+lib/gc_sc/PosixPun.pl
+lib/gc_sc/PosixSpa.pl
+lib/gc_sc/PosixUpp.pl
+lib/gc_sc/Print.pl
+lib/gc_sc/Ps.pl
+lib/gc_sc/Punct.pl
+lib/gc_sc/QMark.pl
+lib/gc_sc/Qaai.pl
+lib/gc_sc/Quotatio.pl
+lib/gc_sc/Radical.pl
+lib/gc_sc/Radical2.pl
+lib/gc_sc/Rjng.pl
+lib/gc_sc/Runr.pl
+lib/gc_sc/S.pl
+lib/gc_sc/SD.pl
+lib/gc_sc/STerm.pl
+lib/gc_sc/Saur.pl
+lib/gc_sc/Sc.pl
+lib/gc_sc/Shaw.pl
+lib/gc_sc/Sinh.pl
+lib/gc_sc/Sk.pl
+lib/gc_sc/Sm.pl
+lib/gc_sc/So.pl
+lib/gc_sc/SoftDott.pl
+lib/gc_sc/Space.pl
+lib/gc_sc/SpacePer.pl
+lib/gc_sc/Sterm2.pl
+lib/gc_sc/Sund.pl
+lib/gc_sc/SylotiNa.pl
+lib/gc_sc/Syrc.pl
+lib/gc_sc/Tagb.pl
+lib/gc_sc/TaiLe.pl
+lib/gc_sc/Taml.pl
+lib/gc_sc/Telu.pl
+lib/gc_sc/Term.pl
+lib/gc_sc/Terminal.pl
+lib/gc_sc/Tfng.pl
+lib/gc_sc/Tglg.pl
+lib/gc_sc/Thaa.pl
+lib/gc_sc/Thai.pl
+lib/gc_sc/Tibt.pl
+lib/gc_sc/Title.pl
+lib/gc_sc/UIdeo.pl
+lib/gc_sc/Ugar.pl
+lib/gc_sc/UnifiedI.pl
+lib/gc_sc/Upper.pl
+lib/gc_sc/Uppercas.pl
+lib/gc_sc/VS.pl
+lib/gc_sc/Vaii.pl
+lib/gc_sc/Variatio.pl
+lib/gc_sc/VertSpac.pl
+lib/gc_sc/WSpace.pl
+lib/gc_sc/WhiteSpa.pl
+lib/gc_sc/Word.pl
+lib/gc_sc/XDigit.pl
+lib/gc_sc/Xsux.pl
+lib/gc_sc/Yiii.pl
+lib/gc_sc/Z.pl
+lib/gc_sc/Zl.pl
+lib/gc_sc/Zp.pl
+lib/gc_sc/Zs.pl
+lib/gc_sc/Zyyy.pl
+lib/gc_sc/_CanonDC.pl
+lib/gc_sc/_CaseIgn.pl
+lib/gc_sc/_CombAbo.pl
+lib/hst/L.pl
+lib/hst/LV.pl
+lib/hst/LVT.pl
+lib/hst/T.pl
+lib/hst/V.pl
+lib/jt/C.pl
+lib/jt/D.pl
+lib/jt/R.pl
+lib/jt/U.pl
+lib/lb/AI.pl
+lib/lb/AL.pl
+lib/lb/B2.pl
+lib/lb/BA.pl
+lib/lb/BB.pl
+lib/lb/BK.pl
+lib/lb/CB.pl
+lib/lb/CL.pl
+lib/lb/CM.pl
+lib/lb/CR.pl
+lib/lb/EX.pl
+lib/lb/GL.pl
+lib/lb/H2.pl
+lib/lb/H3.pl
+lib/lb/HY.pl
+lib/lb/ID.pl
+lib/lb/IN.pl
+lib/lb/IS.pl
+lib/lb/JL.pl
+lib/lb/JT.pl
+lib/lb/JV.pl
+lib/lb/LF.pl
+lib/lb/NL.pl
+lib/lb/NS.pl
+lib/lb/NU.pl
+lib/lb/OP.pl
+lib/lb/PO.pl
+lib/lb/PR.pl
+lib/lb/QU.pl
+lib/lb/SA.pl
+lib/lb/SG.pl
+lib/lb/SP.pl
+lib/lb/SY.pl
+lib/lb/WJ.pl
+lib/lb/XX.pl
+lib/lb/ZW.pl
+lib/nt/De.pl
+lib/nt/Di.pl
+lib/nt/Nu.pl
+
+# 24 input files
+# 514 output files
+
+# End list
Modified: trunk/contrib/perl/lib/unicore/version
===================================================================
--- trunk/contrib/perl/lib/unicore/version 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/unicore/version 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1 +1 @@
-6.0.0
+6.2.0
Property changes on: trunk/contrib/perl/lib/unicore/version
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/utf8.pm
===================================================================
--- trunk/contrib/perl/lib/utf8.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/utf8.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -2,7 +2,7 @@
$utf8::hint_bits = 0x00800000;
-our $VERSION = '1.09';
+our $VERSION = '1.10';
sub import {
$^H |= $utf8::hint_bits;
@@ -170,14 +170,14 @@
=item * $flag = utf8::is_utf8(STRING)
-(Since Perl 5.8.1) Test whether STRING is in UTF-8 internally.
+(Since Perl 5.8.1) Test whether STRING is encoded internally in UTF-8.
Functionally the same as Encode::is_utf8().
=item * $flag = utf8::valid(STRING)
[INTERNAL] Test whether STRING is in a consistent state regarding
-UTF-8. Will return true is well-formed UTF-8 and has the UTF-8 flag
-on B<or> if string is held as bytes (both these states are 'consistent').
+UTF-8. Will return true if it is well-formed UTF-8 and has the UTF-8 flag
+on B<or> if STRING is held as bytes (both these states are 'consistent').
Main reason for this routine is to allow Perl's testsuite to check
that operations have left strings in a consistent state. You most
probably want to use utf8::is_utf8() instead.
Property changes on: trunk/contrib/perl/lib/utf8.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/lib/utf8.t
===================================================================
--- trunk/contrib/perl/lib/utf8.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/utf8.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -435,10 +435,32 @@
utf8::decode($k1);
utf8::decode($k2);
my $h = { $k1 => 1, $k2 => 2 };
- is join('', keys %$h), $k2, 'utf8::decode respects copy-on-write';
+ is join('', keys $h), $k2, 'utf8::decode respects copy-on-write';
}
{
+ # Make sure utf8::decode does not modify read-only scalars
+ # [perl #91850].
+
+ my $name = "\x{c3}\x{b3}";
+ Internals::SvREADONLY($name, 1);
+ eval { utf8::decode($name) };
+ like $@, qr/^Modification of a read-only/,
+ 'utf8::decode respects readonliness';
+}
+
+{
+ # utf8::decode should stringify refs [perl #91852].
+
+ package eieifg { use overload '""' => sub { "\x{c3}\x{b3}" },
+ fallback => 1 }
+
+ my $name = bless[], eieifg::;
+ utf8::decode($name);
+ is $name, "\xf3", 'utf8::decode flattens references';
+}
+
+{
my $a = "456\xb6";
utf8::upgrade($a);
@@ -501,9 +523,6 @@
for my $pos (0..5) {
- my $pos1 = ($pos >= 3) ? 2 : ($pos >= 1) ? 1 : 0;
- my $pos2 = ($pos1 == 2) ? 3 : $pos1;
-
my $p;
my $s = "A\xc8\x81\xe8\xab\x86\x{100}";
chop($s);
@@ -518,11 +537,11 @@
is($s, "A\xc8\x81\xe8\xab\x86","(pos $pos) str after utf8::downgrade");
utf8::decode($s);
is(length($s), 3, "(pos $pos) len after D; utf8::decode");
- is(pos($s), $pos1, "(pos $pos) pos after D; utf8::decode");
+ is(pos($s), undef, "(pos $pos) pos after D; utf8::decode");
is($s, "A\x{201}\x{8ac6}", "(pos $pos) str after D; utf8::decode");
utf8::encode($s);
is(length($s), 6, "(pos $pos) len after D; utf8::encode");
- is(pos($s), $pos2, "(pos $pos) pos after D; utf8::encode");
+ is(pos($s), undef, "(pos $pos) pos after D; utf8::encode");
is($s, "A\xc8\x81\xe8\xab\x86","(pos $pos) str after D; utf8::encode");
$s = "A\xc8\x81\xe8\xab\x86";
@@ -536,11 +555,11 @@
is($s, "A\xc8\x81\xe8\xab\x86","(pos $pos) str after utf8::upgrade");
utf8::decode($s);
is(length($s), 3, "(pos $pos) len after U; utf8::decode");
- is(pos($s), $pos1, "(pos $pos) pos after U; utf8::decode");
+ is(pos($s), undef, "(pos $pos) pos after U; utf8::decode");
is($s, "A\x{201}\x{8ac6}", "(pos $pos) str after U; utf8::decode");
utf8::encode($s);
is(length($s), 6, "(pos $pos) len after U; utf8::encode");
- is(pos($s), $pos2, "(pos $pos) pos after U; utf8::encode");
+ is(pos($s), undef, "(pos $pos) pos after U; utf8::encode");
is($s, "A\xc8\x81\xe8\xab\x86","(pos $pos) str after U; utf8::encode");
}
Property changes on: trunk/contrib/perl/lib/utf8.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/utf8_heavy.pl
===================================================================
--- trunk/contrib/perl/lib/utf8_heavy.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/utf8_heavy.pl 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,8 +1,11 @@
package utf8;
use strict;
use warnings;
+use re "/aa"; # So we won't even try to look at above Latin1, potentially
+ # resulting in a recursive call
sub DEBUG () { 0 }
+$|=1 if DEBUG;
sub DESTROY {}
@@ -10,6 +13,20 @@
sub croak { require Carp; Carp::croak(@_) }
+sub _loose_name ($) {
+ # Given a lowercase property or property-value name, return its
+ # standardized version that is expected for look-up in the 'loose' hashes
+ # in Heavy.pl (hence, this depends on what mktables does). This squeezes
+ # out blanks, underscores and dashes. The complication stems from the
+ # grandfathered-in 'L_', which retains a single trailing underscore.
+
+ my $loose = $_[0] =~ s/[-\s_]//rg;
+
+ return $loose if $loose !~ / ^ (?: is | to )? l $/x;
+ return 'l_' if $_[0] =~ / l .* _ /x; # If original had a trailing '_'
+ return $loose;
+}
+
##
## "SWASH" == "SWATCH HASH". A "swatch" is a swatch of the Unicode landscape.
## It's a data structure that encodes a set of Unicode characters.
@@ -29,6 +46,7 @@
sub SWASHNEW {
my ($class, $type, $list, $minbits, $none) = @_;
+ my $user_defined = 0;
local $^D = 0 if $^D;
$class = "" unless defined $class;
@@ -45,6 +63,8 @@
## regexec.c:regclass_swash -- for /[]/, \p, and \P
## utf8.c:is_utf8_common -- for common Unicode properties
## utf8.c:to_utf8_case -- for lc, uc, ucfirst, etc. and //i
+ ## Unicode::UCD::prop_invlist
+ ## Unicode::UCD::prop_invmap
##
## Given a $type, our goal is to fill $list with the set of codepoint
## ranges. If $type is false, $list passed is used.
@@ -63,8 +83,7 @@
## $none is undocumented, so I'm (khw) trying to do some documentation
## of it now. It appears to be if there is a mapping in an input file
## that maps to 'XXXX', then that is replaced by $none+1, expressed in
- ## hexadecimal. The only place I found it possibly used was in
- ## S_pmtrans in op.c.
+ ## hexadecimal. It is used somehow in tr///.
##
## To make the parsing of $type clear, this code takes the a rather
## unorthodox approach of last'ing out of the block once we have the
@@ -71,17 +90,27 @@
## info we need. Were this to be a subroutine, the 'last' would just
## be a 'return'.
##
+ # If a problem is found $type is returned;
+ # Upon success, a new (or cached) blessed object is returned with
+ # keys TYPE, BITS, EXTRAS, LIST, and NONE with values having the
+ # same meanings as the input parameters.
+ # SPECIALS contains a reference to any special-treatment hash in the
+ # INVERT_IT is non-zero if the result should be inverted before use
+ # USER_DEFINED is non-zero if the result came from a user-defined
+ # property.
my $file; ## file to load data from, and also part of the %Cache key.
- my $ListSorted = 0;
# Change this to get a different set of Unicode tables
my $unicore_dir = 'unicore';
+ my $invert_it = 0;
+ my $list_is_from_mktables = 0; # Is $list returned from a mktables
+ # generated file? If so, we know it's
+ # well behaved.
if ($type)
{
-
# Verify that this isn't a recursive call for this property.
- # Can't use croak, as it may try to recurse here itself.
+ # Can't use croak, as it may try to recurse to here itself.
my $class_type = $class . "::$type";
if (grep { $_ eq $class_type } @recursed) {
CORE::die "panic: Infinite recursion in SWASHNEW for '$type'\n";
@@ -93,7 +122,7 @@
# regcomp.c surrounds the property name with '__" and '_i' if this
# is to be caseless matching.
- my $caseless = $type =~ s/^__(.*)_i$/$1/;
+ my $caseless = $type =~ s/^(.*)__(.*)_i$/$1$2/;
print STDERR __LINE__, ": type=$type, caseless=$caseless\n" if DEBUG;
@@ -104,8 +133,11 @@
## package if no package given
##
- my $caller1 = $type =~ s/(.+)::// ? $1 : caller(1);
+ my $caller0 = caller(0);
+ my $caller1 = $type =~ s/(.+)::// ? $1 : $caller0 eq 'main' ?
+ 'main' : caller(1);
+
if (defined $caller1 && $type =~ /^I[ns]\w+$/) {
my $prop = "${caller1}::$type";
if (exists &{$prop}) {
@@ -122,6 +154,7 @@
if $tainted;
no strict 'refs';
$list = &{$prop}($caseless);
+ $user_defined = 1;
last GETFILE;
}
}
@@ -170,9 +203,10 @@
print STDERR __LINE__, ": $property\n" if DEBUG;
# Here it is the compound property=table form. The property
- # name is always loosely matched, which means remove any of
- # these:
- $property =~ s/[_\s-]//g;
+ # name is always loosely matched, and always can have an
+ # optional 'is' prefix (which isn't true in the single
+ # form).
+ $property = _loose_name($property) =~ s/^is//r;
# And convert to canonical form. Quit if not valid.
$property = $utf8::loose_property_name_of{$property};
@@ -212,7 +246,7 @@
# minus
# Remove underscores between digits.
- $part =~ s/( ?<= [0-9] ) _ (?= [0-9] ) //xg;
+ $part =~ s/(?<= [0-9] ) _ (?= [0-9] ) //xg;
# No leading zeros (but don't make a single '0'
# into a null string)
@@ -364,7 +398,7 @@
# out the applicable characters on the rhs and looking up
# again.
if (! defined $file) {
- $table =~ s/ [_\s-] //xg;
+ $table = _loose_name($table);
$property_and_table = "$prefix$table";
print STDERR __LINE__, ": $property_and_table\n" if DEBUG;
$file = $utf8::loose_to_file_of{$property_and_table};
@@ -372,6 +406,11 @@
# Add the constant and go fetch it in.
if (defined $file) {
+
+ # A beginning ! means to invert. The 0+ makes sure is
+ # numeric
+ $invert_it = 0 + $file =~ s/^!//;
+
if ($utf8::why_deprecated{$file}) {
warnings::warnif('deprecated', "Use of '$type' in \\p{} or \\P{} is deprecated because: $utf8::why_deprecated{$file};");
}
@@ -387,36 +426,69 @@
print STDERR __LINE__, ": didn't find $property_and_table\n" if DEBUG;
##
- ## See if it's a user-level "To".
+ ## Last attempt -- see if it's a standard "To" name
+ ## (e.g. "ToLower") ToTitle is used by ucfirst().
+ ## The user-level way to access ToDigit() and ToFold()
+ ## is to use Unicode::UCD.
##
+ # Only check if caller wants non-binary
+ my $retried = 0;
+ if ($minbits != 1 && $property_and_table =~ s/^to//) {{
+ # Look input up in list of properties for which we have
+ # mapping files.
+ if (defined ($file =
+ $utf8::loose_property_to_file_of{$property_and_table}))
+ {
+ $type = $utf8::file_to_swash_name{$file};
+ print STDERR __LINE__, ": type set to $type\n" if DEBUG;
+ $file = "$unicore_dir/$file.pl";
+ last GETFILE;
+ } # If that fails see if there is a corresponding binary
+ # property file
+ elsif (defined ($file =
+ $utf8::loose_to_file_of{$property_and_table}))
+ {
- my $caller0 = caller(0);
+ # Here, there is no map file for the property we are
+ # trying to get the map of, but this is a binary
+ # property, and there is a file for it that can easily
+ # be translated to a mapping.
- if (defined $caller0 && $type =~ /^To(?:\w+)$/) {
- my $map = $caller0 . "::" . $type;
+ # In the case of properties that are forced to binary,
+ # they are a combination. We return the actual
+ # mapping instead of the binary. If the input is
+ # something like 'Tocjkkiicore', it will be found in
+ # %loose_property_to_file_of above as => 'To/kIICore'.
+ # But the form like ToIskiicore won't be. To fix
+ # this, it was easiest to do it here. These
+ # properties are the complements of the default
+ # property, so there is an entry in %loose_to_file_of
+ # that is 'iskiicore' => '!kIICore/N', If we find such
+ # an entry, strip off things and try again, which
+ # should find the entry in %loose_property_to_file_of.
+ # Actual binary properties that are of this form, such
+ # as this entry: 'ishrkt' => '!Perl/Any' will also be
+ # retried, but won't be in %loose_property_to_file_of,
+ # and instead the next time through, it will find
+ # 'hrkt' => '!Perl/Any' and proceed.
+ redo if ! $retried
+ && $file =~ /^!/
+ && $property_and_table =~ s/^is//;
- if (exists &{$map}) {
- no strict 'refs';
-
- $list = &{$map};
- warnings::warnif('deprecated', "User-defined case-mapping '$type' is deprecated");
+ # This is a binary property. Setting this here causes
+ # it to be stored as such in the cache, so if someone
+ # comes along later looking for just a binary, they
+ # get it.
+ $minbits = 1;
+
+ # The 0+ makes sure is numeric
+ $invert_it = 0 + $file =~ s/^!//;
+ $file = "$unicore_dir/lib/$file.pl";
last GETFILE;
}
- }
+ } }
##
- ## Last attempt -- see if it's a standard "To" name
- ## (e.g. "ToLower") ToTitle is used by ucfirst().
- ## The user-level way to access ToDigit() and ToFold()
- ## is to use Unicode::UCD.
- ##
- if ($type =~ /^To(Digit|Fold|Lower|Title|Upper)$/) {
- $file = "$unicore_dir/To/$1.pl";
- ## would like to test to see if $file actually exists....
- last GETFILE;
- }
-
- ##
## If we reach this line, it's because we couldn't figure
## out what to do with $type. Ouch.
##
@@ -423,7 +495,7 @@
pop @recursed if @recursed;
return $type;
- }
+ } # end of GETFILE block
if (defined $file) {
print STDERR __LINE__, ": found it (file='$file')\n" if DEBUG;
@@ -433,11 +505,12 @@
## (exception: user-defined properties and mappings), so we
## have a filename, so now we load it if we haven't already.
## If we have, return the cached results. The cache key is the
- ## class and file to load.
+ ## class and file to load, and whether the results need to be
+ ## inverted.
##
- my $found = $Cache{$class, $file};
+ my $found = $Cache{$class, $file, $invert_it};
if ($found and ref($found) eq $class) {
- print STDERR __LINE__, ": Returning cached '$file' for \\p{$type}\n" if DEBUG;
+ print STDERR __LINE__, ": Returning cached swash for '$class,$file,$invert_it' for \\p{$type}\n" if DEBUG;
pop @recursed if @recursed;
return $found;
}
@@ -445,25 +518,59 @@
local $@;
local $!;
$list = do $file; die $@ if $@;
+ $list_is_from_mktables = 1;
}
+ } # End of $type is non-null
- $ListSorted = 1; ## we know that these lists are sorted
- }
+ # Here, either $type was null, or we found the requested property and
+ # read it into $list
- my $extras;
+ my $extras = "";
+
my $bits = $minbits;
- if ($list) {
+ # mktables lists don't have extras, like '&utf8::prop', so don't need
+ # to separate them; also lists are already sorted, so don't need to do
+ # that.
+ if ($list && ! $list_is_from_mktables) {
my $taint = substr($list,0,0); # maintain taint
- my @tmp = split(/^/m, $list);
- my %seen;
- no warnings;
- $extras = join '', $taint, grep /^[^0-9a-fA-F]/, @tmp;
- $list = join '', $taint,
- map { $_->[1] }
- sort { $a->[0] <=> $b->[0] }
- map { /^([0-9a-fA-F]+)/; [ CORE::hex($1), $_ ] }
- grep { /^([0-9a-fA-F]+)/ and not $seen{$1}++ } @tmp; # XXX doesn't do ranges right
+
+ # Separate the extras from the code point list, and make sure
+ # user-defined properties and tr/// are well-behaved for
+ # downstream code.
+ if ($user_defined || $none) {
+ my @tmp = split(/^/m, $list);
+ my %seen;
+ no warnings;
+
+ # The extras are anything that doesn't begin with a hex digit.
+ $extras = join '', $taint, grep /^[^0-9a-fA-F]/, @tmp;
+
+ # Remove the extras, and sort the remaining entries by the
+ # numeric value of their beginning hex digits, removing any
+ # duplicates.
+ $list = join '', $taint,
+ map { $_->[1] }
+ sort { $a->[0] <=> $b->[0] }
+ map { /^([0-9a-fA-F]+)/; [ CORE::hex($1), $_ ] }
+ grep { /^([0-9a-fA-F]+)/ and not $seen{$1}++ } @tmp; # XXX doesn't do ranges right
+ }
+ else {
+ # mktables has gone to some trouble to make non-user defined
+ # properties well-behaved, so we can skip the effort we do for
+ # user-defined ones. Any extras are at the very beginning of
+ # the string.
+
+ # This regex splits out the first lines of $list into $1 and
+ # strips them off from $list, until we get one that begins
+ # with a hex number, alone on the line, or followed by a tab.
+ # Either portion may be empty.
+ $list =~ s/ \A ( .*? )
+ (?: \z | (?= ^ [0-9a-fA-F]+ (?: \t | $) ) )
+ //msx;
+
+ $extras = "$taint$1";
+ }
}
if ($none) {
@@ -508,6 +615,7 @@
elsif ($c =~ /^([0-9a-fA-F]+)/) {
$subobj = utf8->SWASHNEW("", $c, $minbits, 0);
}
+ print STDERR __LINE__, ": returned from getting sub object for $name\n" if DEBUG;
if (! ref $subobj) {
pop @recursed if @recursed && $type;
return $subobj;
@@ -514,6 +622,8 @@
}
push @extras, $name => $subobj;
$bits = $subobj->{BITS} if $bits < $subobj->{BITS};
+ $user_defined = $subobj->{USER_DEFINED}
+ if $subobj->{USER_DEFINED};
}
}
}
@@ -520,7 +630,7 @@
}
if (DEBUG) {
- print STDERR __LINE__, ": CLASS = $class, TYPE => $type, BITS => $bits, NONE => $none";
+ print STDERR __LINE__, ": CLASS = $class, TYPE => $type, BITS => $bits, NONE => $none, INVERT_IT => $invert_it, USER_DEFINED => $user_defined";
print STDERR "\nLIST =>\n$list" if defined $list;
print STDERR "\nEXTRAS =>\n$extras" if defined $extras;
print STDERR "\n";
@@ -532,11 +642,22 @@
EXTRAS => $extras,
LIST => $list,
NONE => $none,
+ USER_DEFINED => $user_defined,
@extras,
} => $class;
if ($file) {
- $Cache{$class, $file} = $SWASH;
+ $Cache{$class, $file, $invert_it} = $SWASH;
+ if ($type
+ && exists $utf8::SwashInfo{$type}
+ && exists $utf8::SwashInfo{$type}{'specials_name'})
+ {
+ my $specials_name = $utf8::SwashInfo{$type}{'specials_name'};
+ no strict "refs";
+ print STDERR "\nspecials_name => $specials_name\n" if DEBUG;
+ $SWASH->{'SPECIALS'} = \%$specials_name;
+ }
+ $SWASH->{'INVERT_IT'} = $invert_it;
}
pop @recursed if @recursed && $type;
@@ -545,6 +666,6 @@
}
}
-# Now SWASHGET is recasted into a C function S_swash_get (see utf8.c).
+# Now SWASHGET is recasted into a C function S_swatch_get (see utf8.c).
1;
Property changes on: trunk/contrib/perl/lib/utf8_heavy.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/validate.pl
===================================================================
--- trunk/contrib/perl/lib/validate.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/validate.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/validate.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/lib/vars.pm
===================================================================
--- trunk/contrib/perl/lib/vars.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/vars.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -2,7 +2,7 @@
use 5.006;
-our $VERSION = '1.02';
+our $VERSION = '1.03';
use warnings::register;
use strict qw(vars subs);
@@ -48,7 +48,7 @@
=head1 NAME
-vars - Perl pragma to predeclare global variable names (obsolete)
+vars - Perl pragma to predeclare global variable names
=head1 SYNOPSIS
@@ -56,9 +56,10 @@
=head1 DESCRIPTION
-NOTE: For variables in the current package, the functionality provided
-by this pragma has been superseded by C<our> declarations, available
-in Perl v5.6.0 or later. See L<perlfunc/our>.
+NOTE: For use with variables in the current package for a single scope, the
+functionality provided by this pragma has been superseded by C<our>
+declarations, available in Perl v5.6.0 or later, and use of this pragma is
+discouraged. See L<perlfunc/our>.
This will predeclare all the variables whose names are
in the list, allowing you to use them under "use strict", and
Property changes on: trunk/contrib/perl/lib/vars.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/vars.t
===================================================================
--- trunk/contrib/perl/lib/vars.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/vars.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/vars.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/vars_carp.t
===================================================================
--- trunk/contrib/perl/lib/vars_carp.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/vars_carp.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/vars_carp.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/lib/version/Internals.pod
===================================================================
--- trunk/contrib/perl/lib/version/Internals.pod 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/version/Internals.pod 2013-12-02 21:26:09 UTC (rev 6439)
@@ -6,7 +6,7 @@
Overloaded version objects for all modern versions of Perl. This documents
the internal data representation and underlying code for version.pm. See
-L<version.pod> for daily usage. This document is only useful for users
+F<version.pod> for daily usage. This document is only useful for users
interested in the gory details.
=head1 WHAT IS A VERSION?
@@ -104,8 +104,8 @@
to specify a version, whereas Decimal Versions enforce a certain
uniformity.
-Just like L<Decimal Versions>, Dotted-Decimal Versions can be used as
-L<Alpha Versions>.
+Just like L</Decimal Versions>, Dotted-Decimal Versions can be used as
+L</Alpha Versions>.
=head2 Alpha Versions
@@ -244,8 +244,8 @@
Because of the nature of the Perl parsing and tokenizing routines,
certain initialization values B<must> be quoted in order to correctly
-parse as the intended version, especially when using the L<declare> or
-L<qv> methods. While you do not have to quote decimal numbers when
+parse as the intended version, especially when using the C<declare> or
+L</qv()> methods. While you do not have to quote decimal numbers when
creating version objects, it is always safe to quote B<all> initial values
when using version.pm methods, as this will ensure that what you type is
what is used.
@@ -338,12 +338,12 @@
=item qv
A boolean that denotes whether this is a decimal or dotted-decimal version.
-See L<is_qv>.
+See L<version/is_qv()>.
=item alpha
A boolean that denotes whether this is an alpha version. NOTE: that the
-underscore can can only appear in the last position. See L<is_alpha>.
+underscore can can only appear in the last position. See L<version/is_alpha()>.
=item version
@@ -397,7 +397,7 @@
print $module->VERSION;
-will also exclusively return the stringified form. See L<Stringification>
+will also exclusively return the stringified form. See L</Stringification>
for more details.
=head1 USAGE DETAILS
@@ -438,9 +438,9 @@
use Example 1.2.3;
and it will again work (i.e. give the error message as above), even with
-releases of Perl which do not normally support v-strings (see L<version/What about v-strings> below). This has to do with that fact that C<use> only checks
+releases of Perl which do not normally support v-strings (see L<What about v-strings?> above). This has to do with that fact that C<use> only checks
to see if the second term I<looks like a number> and passes that to the
-replacement L<UNIVERSAL::VERSION>. This is not true in Perl 5.005_04,
+replacement L<UNIVERSAL::VERSION|UNIVERSAL/VERSION>. This is not true in Perl 5.005_04,
however, so you are B<strongly encouraged> to always use a Decimal version
in your code, even for those versions of Perl which support the Dotted-Decimal
version.
@@ -462,7 +462,7 @@
In order to facilitate this feature, the following
code can be employed:
- $VERSION = version->new(qw$Revision: 1.1.1.2 $);
+ $VERSION = version->new(qw$Revision: 2.7 $);
and the version object will be created as if the following code
were used:
@@ -471,7 +471,7 @@
In other words, the version will be automatically parsed out of the
string, and it will be quoted to preserve the meaning CVS normally
-carries for versions. The CVS $Revision: 1.1.1.2 $ increments differently from
+carries for versions. The CVS $Revision$ increments differently from
Decimal versions (i.e. 1.10 follows 1.9), so it must be handled as if
it were a Dotted-Decimal Version.
@@ -541,7 +541,7 @@
For any version object which is initialized with multiple decimal
places (either quoted or if possible v-string), or initialized using
-the L<qv>() operator, the stringified representation is returned in
+the L<qv()|version/qv()> operator, the stringified representation is returned in
a normalized or reduced form (no extraneous zeros), and with a leading 'v':
print $ver->normal; # prints as v1.2.3.4
@@ -600,7 +600,7 @@
qv("v1.3.5") v1.3.5
qv("1.2") v1.2 ### exceptional case
-See also L<UNIVERSAL::VERSION>, as this also returns the stringified form
+See also L<UNIVERSAL::VERSION|UNIVERSAL/VERSION>, as this also returns the stringified form
when used as a class method.
IMPORTANT NOTE: There is one exceptional cases shown in the above table
@@ -607,20 +607,20 @@
where the "initializer" is not stringwise equivalent to the stringified
representation. If you use the C<qv>() operator on a version without a
leading 'v' B<and> with only a single decimal place, the stringified output
-will have a leading 'v', to preserve the sense. See the L<qv>() operator
+will have a leading 'v', to preserve the sense. See the L</qv()> operator
for more details.
IMPORTANT NOTE 2: Attempting to bypass the normal stringification rules by
-manually applying L<numify>() and L<normal>() will sometimes yield
+manually applying L<numify()|version/numify()> and L<normal()|version/normal()> will sometimes yield
surprising results:
print version->new(version->new("v1.0")->numify)->normal; # v1.0.0
-The reason for this is that the L<numify>() operator will turn "v1.0"
+The reason for this is that the L<numify()|version/numify()> operator will turn "v1.0"
into the equivalent string "1.000000". Forcing the outer version object
-to L<normal>() form will display the mathematically equivalent "v1.0.0".
+to L<normal()|version/normal()> form will display the mathematically equivalent "v1.0.0".
-As the example in L<new>() shows, you can always create a copy of an
+As the example in L</new()> shows, you can always create a copy of an
existing version object with the same value by the very compact:
$v2 = $v1->new($v1);
Property changes on: trunk/contrib/perl/lib/version/Internals.pod
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/lib/version.pm
===================================================================
--- trunk/contrib/perl/lib/version.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/version.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -6,7 +6,7 @@
use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv);
-$VERSION = 0.88;
+$VERSION = 0.9902;
$CLASS = 'version';
Property changes on: trunk/contrib/perl/lib/version.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/version.pod
===================================================================
--- trunk/contrib/perl/lib/version.pod 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/version.pod 2013-12-02 21:26:09 UTC (rev 6439)
@@ -11,15 +11,15 @@
# Declaring a dotted-decimal $VERSION (keep on one line!)
- use version 0.77; our $VERSION = version->declare("v1.2.3"); # formal
- use version 0.77; our $VERSION = qv("v1.2.3"); # shorthand
- use version 0.77; our $VERSION = qv("v1.2_3"); # alpha
+ use version; our $VERSION = version->declare("v1.2.3"); # formal
+ use version; our $VERSION = qv("v1.2.3"); # shorthand
+ use version; our $VERSION = qv("v1.2_3"); # alpha
# Declaring an old-style decimal $VERSION (use quotes!)
our $VERSION = "1.0203"; # recommended
- use version 0.77; our $VERSION = version->parse("1.0203"); # formal
- use version 0.77; our $VERSION = version->parse("1.02_03"); # alpha
+ use version; our $VERSION = version->parse("1.0203"); # formal
+ use version; our $VERSION = version->parse("1.02_03"); # alpha
# Comparing mixed version styles (decimals, dotted-decimals, objects)
@@ -60,9 +60,10 @@
The more modern form of version assignment, with 3 (or potentially more)
integers separated by decimal points (e.g. v1.2.3). This is the form that
-Perl itself has used since 5.6.0 was released. The leading "v" is now
+Perl itself has used since 5.6.0 was released. The leading 'v' is now
strongly recommended for clarity, and will throw a warning in a future
-release if omitted.
+release if omitted. A leading 'v' character is required to pass the
+L</is_strict()> test.
=back
@@ -95,7 +96,7 @@
=head2 How to C<declare()> a dotted-decimal version
- use version 0.77; our $VERSION = version->declare("v1.2.3");
+ use version; our $VERSION = version->declare("v1.2.3");
The C<declare()> method always creates dotted-decimal version objects. When
used in a module, you B<must> put it on the same line as "use version" to
@@ -194,7 +195,7 @@
=item C<is_strict()>
-If you want to limit youself to a much more narrow definition of what
+If you want to limit yourself to a much more narrow definition of what
a version string constitutes, C<is_strict()> is limited to version
strings like the following list:
Property changes on: trunk/contrib/perl/lib/version.pod
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/lib/version.t
===================================================================
--- trunk/contrib/perl/lib/version.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/version.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/version.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/lib/vmsish.pm
===================================================================
--- trunk/contrib/perl/lib/vmsish.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/vmsish.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,6 +1,6 @@
package vmsish;
-our $VERSION = '1.02';
+our $VERSION = '1.03';
=head1 NAME
@@ -52,7 +52,7 @@
=item C<vmsish hushed>
This suppresses printing of VMS status messages to SYS$OUTPUT and
-SYS$ERROR if Perl terminates with an error status. and allows
+SYS$ERROR if Perl terminates with an error status, and allows
programs that are expecting "unix-style" Perl to avoid having to parse
VMS error messages. It does not suppress any messages from Perl
itself, just the messages generated by DCL after Perl exits. The DCL
@@ -107,7 +107,7 @@
=back
-See L<perlmod/Pragmatic Modules>.
+See L<perlmod/Perl Modules>.
=cut
Property changes on: trunk/contrib/perl/lib/vmsish.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/vmsish.t
===================================================================
--- trunk/contrib/perl/lib/vmsish.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/vmsish.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/vmsish.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/lib/warnings/register.pm
===================================================================
--- trunk/contrib/perl/lib/warnings/register.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/warnings/register.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/warnings/register.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/lib/warnings.pm
===================================================================
--- trunk/contrib/perl/lib/warnings.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/warnings.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -5,7 +5,7 @@
package warnings;
-our $VERSION = '1.12';
+our $VERSION = '1.18';
# Verify that we're called correctly so that warnings will work.
# see also strict.pm.
@@ -47,7 +47,8 @@
The C<warnings> pragma is a replacement for the command line flag C<-w>,
but the pragma is limited to the enclosing block, while the flag is global.
-See L<perllexwarn> for more information.
+See L<perllexwarn> for more information and the list of built-in warning
+categories.
If no import list is supplied, all possible warnings are either enabled
or disabled.
@@ -224,119 +225,138 @@
'non_unicode' => 96,
'nonchar' => 98,
'surrogate' => 100,
+
+ # Warnings Categories added in Perl 5.017
+
+ 'experimental' => 102,
+ 'experimental::lexical_subs'=> 104,
+ 'experimental::lexical_topic'=> 106,
+ 'experimental::regex_sets'=> 108,
+ 'experimental::smartmatch'=> 110,
);
our %Bits = (
- 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", # [0..50]
- 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [29]
- 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [30]
- 'closed' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
- 'closure' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
- 'debugging' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [22]
- 'deprecated' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
- 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [31]
- 'exec' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
- 'exiting' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
- 'glob' => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
- 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [47]
- 'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [46]
- 'inplace' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [23]
- 'internal' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [24]
- 'io' => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
- 'layer' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
- 'malloc' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [25]
- 'misc' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
- 'newline' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
- 'non_unicode' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [48]
- 'nonchar' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [49]
- 'numeric' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
- 'once' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
- 'overflow' => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
- 'pack' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [16]
- 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00", # [32]
- 'pipe' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
- 'portable' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [17]
- 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [33]
- 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [34]
- 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [35]
- 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [36]
- 'recursion' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [18]
- 'redefine' => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [19]
- 'regexp' => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [20]
- 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [37]
- 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [38]
- 'severe' => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00\x00", # [21..25]
- 'signal' => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [26]
- 'substr' => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [27]
- 'surrogate' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [50]
- 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x40\x00", # [28..38,47]
- 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [39]
- 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [40]
- 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [41]
- 'unopened' => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
- 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [42]
- 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [43]
- 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x15", # [44,48..50]
- 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [45]
+ 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55", # [0..55]
+ 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [29]
+ 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [30]
+ 'closed' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
+ 'closure' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
+ 'debugging' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [22]
+ 'deprecated' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
+ 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [31]
+ 'exec' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
+ 'exiting' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
+ 'experimental' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x55", # [51..55]
+ 'experimental::lexical_subs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [52]
+ 'experimental::lexical_topic'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [53]
+ 'experimental::regex_sets'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [54]
+ 'experimental::smartmatch'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40", # [55]
+ 'glob' => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
+ 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [47]
+ 'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [46]
+ 'inplace' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [23]
+ 'internal' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [24]
+ 'io' => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
+ 'layer' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
+ 'malloc' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [25]
+ 'misc' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
+ 'newline' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
+ 'non_unicode' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [48]
+ 'nonchar' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [49]
+ 'numeric' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
+ 'once' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
+ 'overflow' => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
+ 'pack' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [16]
+ 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [32]
+ 'pipe' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
+ 'portable' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [17]
+ 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [33]
+ 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [34]
+ 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [35]
+ 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00", # [36]
+ 'recursion' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [18]
+ 'redefine' => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [19]
+ 'regexp' => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [20]
+ 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [37]
+ 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [38]
+ 'severe' => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00\x00\x00", # [21..25]
+ 'signal' => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [26]
+ 'substr' => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [27]
+ 'surrogate' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [50]
+ 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x40\x00\x00", # [28..38,47]
+ 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [39]
+ 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [40]
+ 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [41]
+ 'unopened' => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
+ 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [42]
+ 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [43]
+ 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x15\x00", # [44,48..50]
+ 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [45]
);
our %DeadBits = (
- 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x2a", # [0..50]
- 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [29]
- 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [30]
- 'closed' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
- 'closure' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
- 'debugging' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [22]
- 'deprecated' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
- 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [31]
- 'exec' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
- 'exiting' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
- 'glob' => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
- 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [47]
- 'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [46]
- 'inplace' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [23]
- 'internal' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [24]
- 'io' => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
- 'layer' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
- 'malloc' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [25]
- 'misc' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
- 'newline' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
- 'non_unicode' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [48]
- 'nonchar' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [49]
- 'numeric' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
- 'once' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
- 'overflow' => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
- 'pack' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [16]
- 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00", # [32]
- 'pipe' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
- 'portable' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [17]
- 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [33]
- 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [34]
- 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [35]
- 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [36]
- 'recursion' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [18]
- 'redefine' => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [19]
- 'regexp' => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [20]
- 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [37]
- 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [38]
- 'severe' => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00\x00", # [21..25]
- 'signal' => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [26]
- 'substr' => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [27]
- 'surrogate' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [50]
- 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x80\x00", # [28..38,47]
- 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [39]
- 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [40]
- 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [41]
- 'unopened' => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
- 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [42]
- 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [43]
- 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x2a", # [44,48..50]
- 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [45]
+ 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa", # [0..55]
+ 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [29]
+ 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [30]
+ 'closed' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
+ 'closure' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
+ 'debugging' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [22]
+ 'deprecated' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
+ 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [31]
+ 'exec' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
+ 'exiting' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
+ 'experimental' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xaa", # [51..55]
+ 'experimental::lexical_subs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [52]
+ 'experimental::lexical_topic'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [53]
+ 'experimental::regex_sets'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [54]
+ 'experimental::smartmatch'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80", # [55]
+ 'glob' => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
+ 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [47]
+ 'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [46]
+ 'inplace' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [23]
+ 'internal' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [24]
+ 'io' => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
+ 'layer' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
+ 'malloc' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [25]
+ 'misc' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
+ 'newline' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
+ 'non_unicode' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [48]
+ 'nonchar' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [49]
+ 'numeric' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
+ 'once' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
+ 'overflow' => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
+ 'pack' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [16]
+ 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [32]
+ 'pipe' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
+ 'portable' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [17]
+ 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [33]
+ 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [34]
+ 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [35]
+ 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00", # [36]
+ 'recursion' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [18]
+ 'redefine' => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [19]
+ 'regexp' => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [20]
+ 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [37]
+ 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [38]
+ 'severe' => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00\x00\x00", # [21..25]
+ 'signal' => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [26]
+ 'substr' => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [27]
+ 'surrogate' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [50]
+ 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x80\x00\x00", # [28..38,47]
+ 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [39]
+ 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [40]
+ 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [41]
+ 'unopened' => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
+ 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [42]
+ 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [43]
+ 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x2a\x00", # [44,48..50]
+ 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [45]
);
-$NONE = "\0\0\0\0\0\0\0\0\0\0\0\0\0";
-$LAST_BIT = 102 ;
-$BYTES = 13 ;
+$NONE = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
+$DEFAULT = "\x10\x01\x00\x00\x00\x50\x04\x00\x00\x00\x00\x00\x00\x55", # [2,52..55,4,22,23,25]
+$LAST_BIT = 112 ;
+$BYTES = 14 ;
$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
@@ -386,7 +406,7 @@
{
shift;
- my $mask = ${^WARNING_BITS} ;
+ my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
if (vec($mask, $Offsets{'all'}, 1)) {
$mask |= $Bits{'all'} ;
@@ -402,7 +422,7 @@
shift;
my $catmask ;
- my $mask = ${^WARNING_BITS} ;
+ my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
if (vec($mask, $Offsets{'all'}, 1)) {
$mask |= $Bits{'all'} ;
@@ -481,8 +501,11 @@
$i = _error_loc(); # see where Carp will allocate the error
}
- # Defaulting this to 0 reduces complexity in code paths below.
- my $callers_bitmask = (caller($i))[9] || 0 ;
+ # Default to 0 if caller returns nothing. Default to $DEFAULT if it
+ # explicitly returns undef.
+ my(@callers_bitmask) = (caller($i))[9] ;
+ my $callers_bitmask =
+ @callers_bitmask ? $callers_bitmask[0] // $DEFAULT : 0 ;
my @results;
foreach my $type (FATAL, NORMAL) {
@@ -560,7 +583,7 @@
# These are not part of any public interface, so we can delete them to save
# space.
-delete $warnings::{$_} foreach qw(NORMAL FATAL MESSAGE);
+delete @warnings::{qw(NORMAL FATAL MESSAGE)};
1;
Property changes on: trunk/contrib/perl/lib/warnings.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/lib/warnings.t
===================================================================
--- trunk/contrib/perl/lib/warnings.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/lib/warnings.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/lib/warnings.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/mad/Nomad.pm
===================================================================
--- trunk/contrib/perl/mad/Nomad.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/mad/Nomad.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/mad/Nomad.pm
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/mad/P5AST.pm
===================================================================
--- trunk/contrib/perl/mad/P5AST.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/mad/P5AST.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/mad/P5AST.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/mad/P5re.pm
===================================================================
--- trunk/contrib/perl/mad/P5re.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/mad/P5re.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/mad/P5re.pm
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/mad/PLXML.pm
===================================================================
--- trunk/contrib/perl/mad/PLXML.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/mad/PLXML.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/mad/PLXML.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/mad/p55
===================================================================
--- trunk/contrib/perl/mad/p55 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/mad/p55 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/mad/p55
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/mad/t/p55.t
===================================================================
--- trunk/contrib/perl/mad/t/p55.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/mad/t/p55.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/mad/t/p55.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/qnx/ar
===================================================================
--- trunk/contrib/perl/qnx/ar 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/qnx/ar 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/qnx/ar
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/qnx/cpp
===================================================================
--- trunk/contrib/perl/qnx/cpp 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/qnx/cpp 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/qnx/cpp
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/qnx/qnx.c
===================================================================
--- trunk/contrib/perl/qnx/qnx.c 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/qnx/qnx.c 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/qnx/qnx.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/PerlApp.cpp
===================================================================
--- trunk/contrib/perl/symbian/PerlApp.cpp 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/PerlApp.cpp 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/PerlApp.cpp
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/PerlApp.h
===================================================================
--- trunk/contrib/perl/symbian/PerlApp.h 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/PerlApp.h 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/PerlApp.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/PerlApp.hrh
===================================================================
--- trunk/contrib/perl/symbian/PerlApp.hrh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/PerlApp.hrh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/PerlApp.hrh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/PerlAppAif.rss
===================================================================
--- trunk/contrib/perl/symbian/PerlAppAif.rss 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/PerlAppAif.rss 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/PerlAppAif.rss
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/symbian/PerlBase.cpp
===================================================================
--- trunk/contrib/perl/symbian/PerlBase.cpp 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/PerlBase.cpp 2013-12-02 21:26:09 UTC (rev 6439)
@@ -364,7 +364,9 @@
#else
dTHX;
for (i = 0; i < nUtf8; i+= UTF8SKIP(pUtf8 + i)) {
- unsigned long u = utf8_to_uvchr((U8*)(pUtf8 + i), 0);
+ unsigned long u = utf8_to_uvchr_buf((U8*)(pUtf8 + i),
+ (U8*)(pUtf8 + nUtf8),
+ 0);
if (u > 0xFF) {
iConsole->Printf(_L("(keycode > 0xFF)\n"));
buf[i] = 0;
@@ -401,7 +403,7 @@
dTHX;
if (is_utf8_string((U8*)buf, n)) {
for (int i = 0; i < n; i += UTF8SKIP(buf + i)) {
- TChar u = utf8_to_uvchr((U8*)(buf + i), 0);
+ TChar u = valid_utf8_to_uvchr((U8*)(buf + i), 0);
iConsole->Printf(_L("%c"), u);
wrote++;
}
Property changes on: trunk/contrib/perl/symbian/PerlBase.cpp
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/PerlBase.h
===================================================================
--- trunk/contrib/perl/symbian/PerlBase.h 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/PerlBase.h 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/PerlBase.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/PerlBase.pod
===================================================================
--- trunk/contrib/perl/symbian/PerlBase.pod 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/PerlBase.pod 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/PerlBase.pod
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/PerlRecog.cpp
===================================================================
--- trunk/contrib/perl/symbian/PerlRecog.cpp 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/PerlRecog.cpp 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/PerlRecog.cpp
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/PerlRecog.mmp
===================================================================
--- trunk/contrib/perl/symbian/PerlRecog.mmp 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/PerlRecog.mmp 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/PerlRecog.mmp
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/PerlUi.cpp
===================================================================
--- trunk/contrib/perl/symbian/PerlUi.cpp 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/PerlUi.cpp 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/PerlUi.cpp
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/PerlUi.h
===================================================================
--- trunk/contrib/perl/symbian/PerlUi.h 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/PerlUi.h 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/PerlUi.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/PerlUi.hrh
===================================================================
--- trunk/contrib/perl/symbian/PerlUi.hrh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/PerlUi.hrh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/PerlUi.hrh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/PerlUiS60.rss
===================================================================
--- trunk/contrib/perl/symbian/PerlUiS60.rss 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/PerlUiS60.rss 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/PerlUiS60.rss
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/PerlUiS80.rss
===================================================================
--- trunk/contrib/perl/symbian/PerlUiS80.rss 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/PerlUiS80.rss 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/PerlUiS80.rss
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/PerlUiS90.rss
===================================================================
--- trunk/contrib/perl/symbian/PerlUiS90.rss 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/PerlUiS90.rss 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/PerlUiS90.rss
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/PerlUiUIQ.rss
===================================================================
--- trunk/contrib/perl/symbian/PerlUiUIQ.rss 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/PerlUiUIQ.rss 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/PerlUiUIQ.rss
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/PerlUtil.cpp
===================================================================
--- trunk/contrib/perl/symbian/PerlUtil.cpp 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/PerlUtil.cpp 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/PerlUtil.cpp
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/PerlUtil.h
===================================================================
--- trunk/contrib/perl/symbian/PerlUtil.h 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/PerlUtil.h 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/PerlUtil.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/PerlUtil.pod
===================================================================
--- trunk/contrib/perl/symbian/PerlUtil.pod 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/PerlUtil.pod 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/PerlUtil.pod
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/README
===================================================================
--- trunk/contrib/perl/symbian/README 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/README 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/README
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/TODO
===================================================================
--- trunk/contrib/perl/symbian/TODO 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/TODO 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/TODO
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/bld.inf
===================================================================
--- trunk/contrib/perl/symbian/bld.inf 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/bld.inf 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/bld.inf
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/config.pl
===================================================================
--- trunk/contrib/perl/symbian/config.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/config.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/config.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/symbian/config.sh
===================================================================
--- trunk/contrib/perl/symbian/config.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/config.sh 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,12 +1,12 @@
#!\\bin\\sh
-PERL_CONFIG_SH='true'
+Author=''
_a='.a'
_o='.o'
afs='false'
afsroot='/afs'
alignbytes='4'
+aphostname='localhost'
apiversion='5.005'
-aphostname='localhost'
ar=':'
archlib='\\system\\libs\\perl\\x.y.z\\thumb-symbian'
archlibexp='\\system\\libs\\perl\\x.y.z\\thumb-symbian'
@@ -13,8 +13,9 @@
archname='thumb-symbian'
asctime_r_proto='0'
bin='\\system\\apps\\perl'
+bincompat5005='n'
binexp='\\system\\apps\\perl'
-bincompat5005='n'
+bootstrap_charset='undef'
byteorder='1234'
castflags='0'
cc='gcc'
@@ -46,6 +47,7 @@
d_PRIu64='undef'
d_PRIx64='undef'
d_SCNfldbl='undef'
+d__fwalk='undef'
d_access='undef'
d_accessx='undef'
d_aintl='undef'
@@ -65,9 +67,9 @@
d_attribute_warn_unused_result='undef'
d_bcmp='undef'
d_bcopy='undef'
+d_bsd='undef'
d_bsdgetpgrp='undef'
d_bsdsetpgrp='undef'
-d_bsd='undef'
d_builtin_choose_expr='undef'
d_builtin_expect='undef'
d_bzero='undef'
@@ -85,11 +87,11 @@
d_const='define'
d_copysignl='undef'
d_cplusplus='undef'
+d_crypt='undef'
d_crypt_r='undef'
-d_crypt='undef'
d_csh='undef'
+d_ctermid='undef'
d_ctermid_r='undef'
-d_ctermid='undef'
d_ctime64='undef'
d_ctime_r='undef'
d_cuserid='undef'
@@ -104,12 +106,12 @@
d_dlopen='undef'
d_dlsymun='undef'
d_dosuid='undef'
+d_drand48_r='undef'
d_drand48proto='undef'
-d_drand48_r='undef'
d_dup2='undef'
d_eaccess='undef'
+d_endgrent='undef'
d_endgrent_r='undef'
-d_endgrent='undef'
d_endhent='undef'
d_endhostent_r='undef'
d_endnent='undef'
@@ -116,8 +118,8 @@
d_endnetent_r='undef'
d_endpent='undef'
d_endprotoent_r='undef'
+d_endpwent='undef'
d_endpwent_r='undef'
-d_endpwent='undef'
d_endsent='undef'
d_endservent_r='undef'
d_eofnblk='undef'
@@ -126,23 +128,23 @@
d_fchdir='undef'
d_fchmod='undef'
d_fchown='undef'
+d_fcntl='undef'
d_fcntl_can_lock='undef'
-d_fcntl='undef'
d_fd_macros='undef'
+d_fd_set='undef'
d_fds_bits='undef'
-d_fd_set='undef'
d_fgetpos='undef'
+d_finite='undef'
d_finitel='undef'
-d_finite='undef'
d_flexfnam='define'
+d_flock='undef'
d_flockproto='undef'
-d_flock='undef'
d_fork='undef'
+d_fp_class='undef'
d_fpathconf='undef'
+d_fpclass='undef'
d_fpclassify='undef'
d_fpclassl='undef'
-d_fp_class='undef'
-d_fpclass='undef'
d_fpos64_t='undef'
d_frexpl='undef'
d_fs_data_s='undef'
@@ -153,9 +155,8 @@
d_fsync='undef'
d_ftello='undef'
d_ftime='undef'
+d_futimes='undef'
d_futimesat='undef'
-d_futimes='undef'
-d__fwalk='undef'
d_gdbm_ndbm_h_uses_prototypes='undef'
d_gdbmndbm_h_uses_prototypes='undef'
d_getaddrinfo='undef'
@@ -162,8 +163,8 @@
d_getcwd='define'
d_getespwnam='undef'
d_getfsstat='undef'
+d_getgrent='undef'
d_getgrent_r='undef'
-d_getgrent='undef'
d_getgrgid_r='undef'
d_getgrnam_r='undef'
d_getgrps='undef'
@@ -176,10 +177,10 @@
d_gethostent_r='undef'
d_gethostprotos='define'
d_getitimer='undef'
+d_getlogin='undef'
d_getlogin_r='undef'
-d_getlogin='undef'
+d_getmnt='undef'
d_getmntent='undef'
-d_getmnt='undef'
d_getnameinfo='undef'
d_getnbyaddr='undef'
d_getnbyname='undef'
@@ -202,8 +203,8 @@
d_getprotoent_r='undef'
d_getprotoprotos='define'
d_getprpwnam='undef'
+d_getpwent='undef'
d_getpwent_r='undef'
-d_getpwent='undef'
d_getpwnam_r='undef'
d_getpwuid_r='undef'
d_getsbyname='define'
@@ -214,8 +215,8 @@
d_getservent_r='undef'
d_getservprotos='define'
d_getspent='undef'
+d_getspnam='undef'
d_getspnam_r='undef'
-d_getspnam='undef'
d_gettimeod='define'
d_gmtime64='undef'
d_gmtime_r='undef'
@@ -230,11 +231,16 @@
d_inetntop='undef'
d_inetpton='undef'
d_int64_t='undef'
+d_ip_mreq='undef'
+d_ip_mreq_source='undef'
+d_ipv6_mreq='undef'
+d_ipv6_mreq_source='undef'
d_isascii='undef'
+d_isblank='undef'
d_isfinite='undef'
d_isinf='undef'
+d_isnan='undef'
d_isnanl='undef'
-d_isnan='undef'
d_killpg='undef'
d_lchown='undef'
d_ldbl_dig='undef'
@@ -241,8 +247,8 @@
d_libm_lib_version='undef'
d_link='undef'
d_localtime64='undef'
+d_localtime_r='undef'
d_localtime_r_needs_tzset='undef'
-d_localtime_r='undef'
d_locconv='undef'
d_lockf='undef'
d_longdbl='undef'
@@ -263,26 +269,26 @@
d_mkdir='define'
d_mkdtemp='undef'
d_mkfifo='undef'
+d_mkstemp='undef'
d_mkstemps='undef'
-d_mkstemp='undef'
d_mktime64='undef'
d_mktime='undef'
d_mmap='undef'
+d_modfl='undef'
d_modfl_pow32_bug='undef'
d_modflproto='undef'
-d_modfl='undef'
d_mprotect='undef'
-d_msgctl='undef'
+d_msg='undef'
d_msg_ctrunc='undef'
d_msg_dontroute='undef'
-d_msgget='undef'
-d_msghdr_s='undef'
d_msg_oob='undef'
d_msg_peek='undef'
d_msg_proxy='undef'
+d_msgctl='undef'
+d_msgget='undef'
+d_msghdr_s='undef'
d_msgrcv='undef'
d_msgsnd='undef'
-d_msg='undef'
d_msync='undef'
d_munmap='undef'
d_mymalloc='undef'
@@ -393,7 +399,9 @@
d_sin6_scope_id='undef'
d_sitearch='define'
d_sitecustomize='undef'
+d_sitecustomize='undef'
d_snprintf='undef'
+d_sockaddr_in6='undef'
d_sockaddr_sa_len='undef'
d_sockatmark='undef'
d_sockatmarkproto='undef'
@@ -409,8 +417,8 @@
d_sresuproto='undef'
d_statblks='undef'
d_statfs_f_flags='undef'
+d_statfs_s='undef'
d_static_inline='undef'
-d_statfs_s='undef'
d_statvfs='undef'
d_stdio_cnt_lval='undef'
d_stdio_ptr_lval='undef'
@@ -465,7 +473,6 @@
d_union_semun='undef'
d_unordered='undef'
d_unsetenv='undef'
-d_sitecustomize='undef'
d_usleep='define'
d_usleepproto='undef'
d_ustat='undef'
@@ -597,6 +604,7 @@
i_shadow='undef'
i_socks='undef'
i_stdarg='define'
+i_stdbool='undef'
i_stddef='undef'
i_stdlib='define'
i_string='define'
@@ -653,10 +661,10 @@
ivdformat='"ld"'
ivsize='4'
ivtype='long'
-lib_ext='.a'
+ld=':'
lddlflags=''
-ld=':'
ldflags=''
+lib_ext='.a'
libc='stdlib'
libm_lib_version='0'
libperl='libperl.a'
@@ -682,11 +690,11 @@
netdb_name_type='const char *'
netdb_net_type='unsigned long'
nroff='nroff'
+nv_overflows_integers_at='256.0*256.0*256.0*256.0*256.0*256.0*2.0*2.0*2.0*2.0*2.0'
nv_preserves_uv_bits='0'
nveformat='"e"'
nvfformat='"f"'
nvgformat='"g"'
-nv_overflows_integers_at='256.0*256.0*256.0*256.0*256.0*256.0*2.0*2.0*2.0*2.0*2.0'
nvsize='8'
nvtype='double'
o_nonblock='O_NONBLOCK'
@@ -698,7 +706,7 @@
osvers='7.0s'
otherlibdirs=''
package=''
-path_sep=';';
+path_sep=';'
perl_static_inline='static'
phostname='hostname'
pidtype='int'
@@ -749,8 +757,8 @@
setprotoent_r_proto='0'
setpwent_r_proto='0'
setservent_r_proto='0'
+sh=':'
shmattype='void *'
-sh=':'
shortsize=2
sig_name_init='0'
sig_num_init='0'
@@ -771,6 +779,8 @@
srandom_r_proto='0'
src=''
ssizetype=int
+st_ino_sign='1'
+st_ino_size='4'
startperl=''
stdchar=char
stdio_base='((fp)->_IO_read_base)'
@@ -807,6 +817,7 @@
usedtrace='undef'
usefaststdio='undef'
useithreads='undef'
+usekernprocpathname='undef'
uselargefiles='undef'
uselongdouble='undef'
usemallocwrap='define'
@@ -814,6 +825,7 @@
usemultiplicity='undef'
usemymalloc='n'
usenm='false'
+usensgetexecutablepath='undef'
useopcode='true'
useperlio='define'
useposix='true'
@@ -831,16 +843,18 @@
uvsize='4'
uvtype='unsigned long'
uvuformat='"lu"'
+uvxformat='"lx"'
vaproto='undef'
+vendorarch=''
+vendorarchexp=''
+vendorlib=''
vendorlib_stem=''
-vendorlib=''
vendorlibexp=''
-vendorarch=''
-vendorarchexp=''
vendorprefix=''
vendorprefixexp=''
version='x.y.z'
-uvxformat='"lx"'
versiononly='undef'
voidflags=1
xs_apiversion='5.008'
+zip=''
+PERL_CONFIG_SH='true'
Property changes on: trunk/contrib/perl/symbian/config.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/cwd.pl
===================================================================
--- trunk/contrib/perl/symbian/cwd.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/cwd.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/cwd.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/demo_pl
===================================================================
--- trunk/contrib/perl/symbian/demo_pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/demo_pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/demo_pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/ext/Moped/Msg/Msg.mmp
===================================================================
--- trunk/contrib/perl/symbian/ext/Moped/Msg/Msg.mmp 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/ext/Moped/Msg/Msg.mmp 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/ext/Moped/Msg/Msg.mmp
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/ext/Moped/Msg/Msg.pkg
===================================================================
--- trunk/contrib/perl/symbian/ext/Moped/Msg/Msg.pkg 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/ext/Moped/Msg/Msg.pkg 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/ext/Moped/Msg/Msg.pkg
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/ext/Moped/Msg/Msg.pm
===================================================================
--- trunk/contrib/perl/symbian/ext/Moped/Msg/Msg.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/ext/Moped/Msg/Msg.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/ext/Moped/Msg/Msg.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/ext/Moped/Msg/Msg.xs
===================================================================
--- trunk/contrib/perl/symbian/ext/Moped/Msg/Msg.xs 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/ext/Moped/Msg/Msg.xs 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/ext/Moped/Msg/Msg.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/ext/Moped/Msg/README
===================================================================
--- trunk/contrib/perl/symbian/ext/Moped/Msg/README 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/ext/Moped/Msg/README 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/ext/Moped/Msg/README
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/ext/Moped/Msg/bld.inf
===================================================================
--- trunk/contrib/perl/symbian/ext/Moped/Msg/bld.inf 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/ext/Moped/Msg/bld.inf 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/ext/Moped/Msg/bld.inf
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/ext/Moped/Msg/location.pl
===================================================================
--- trunk/contrib/perl/symbian/ext/Moped/Msg/location.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/ext/Moped/Msg/location.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/ext/Moped/Msg/location.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/find_writeable_data.pl
===================================================================
--- trunk/contrib/perl/symbian/find_writeable_data.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/find_writeable_data.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/find_writeable_data.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/hexdump.pl
===================================================================
--- trunk/contrib/perl/symbian/hexdump.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/hexdump.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/hexdump.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/install.cfg
===================================================================
--- trunk/contrib/perl/symbian/install.cfg 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/install.cfg 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/install.cfg
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/makesis.pl
===================================================================
--- trunk/contrib/perl/symbian/makesis.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/makesis.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/makesis.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/port.pl
===================================================================
--- trunk/contrib/perl/symbian/port.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/port.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/port.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/sanity.pl
===================================================================
--- trunk/contrib/perl/symbian/sanity.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/sanity.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/sanity.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/sdk.pl
===================================================================
--- trunk/contrib/perl/symbian/sdk.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/sdk.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/sdk.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/sisify.pl
===================================================================
--- trunk/contrib/perl/symbian/sisify.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/sisify.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/sisify.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/symbian_dll.cpp
===================================================================
--- trunk/contrib/perl/symbian/symbian_dll.cpp 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/symbian_dll.cpp 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/symbian_dll.cpp
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/symbian_proto.h
===================================================================
--- trunk/contrib/perl/symbian/symbian_proto.h 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/symbian_proto.h 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/symbian_proto.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/symbian_stubs.c
===================================================================
--- trunk/contrib/perl/symbian/symbian_stubs.c 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/symbian_stubs.c 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/symbian_stubs.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/symbian_stubs.h
===================================================================
--- trunk/contrib/perl/symbian/symbian_stubs.h 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/symbian_stubs.h 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/symbian_stubs.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/symbian_utils.cpp
===================================================================
--- trunk/contrib/perl/symbian/symbian_utils.cpp 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/symbian_utils.cpp 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/symbian_utils.cpp
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/symbianish.h
===================================================================
--- trunk/contrib/perl/symbian/symbianish.h 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/symbianish.h 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/symbianish.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/uid.pl
===================================================================
--- trunk/contrib/perl/symbian/uid.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/uid.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/uid.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/version.pl
===================================================================
--- trunk/contrib/perl/symbian/version.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/version.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/version.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/symbian/xsbuild.pl
===================================================================
--- trunk/contrib/perl/symbian/xsbuild.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/symbian/xsbuild.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/symbian/xsbuild.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/README
===================================================================
--- trunk/contrib/perl/t/README 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/README 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/README
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/TEST
===================================================================
--- trunk/contrib/perl/t/TEST 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/TEST 2013-12-02 21:26:09 UTC (rev 6439)
@@ -2,7 +2,7 @@
# This is written in a peculiar style, since we're trying to avoid
# most of the constructs we'll be testing for. (This comment is
-# probably obsolete on the avoidance side, though still currrent
+# probably obsolete on the avoidance side, though still current
# on the peculiarity side.)
# t/TEST and t/harness need to share code. The logical way to do this would be
@@ -23,8 +23,8 @@
'../ext/File-Glob/t' => '-I.. -MTestInit', # FIXME - tests assume t/
);
-# "not absolute" is the the default, as it saves some fakery within TestInit
-# which can peturb tests, and takes CPU. Working with the upstream author of
+# "not absolute" is the default, as it saves some fakery within TestInit
+# which can perturb tests, and takes CPU. Working with the upstream author of
# any of these, to figure out how to remove them from this list, considered
# "a good thing".
my %abs = (
@@ -42,7 +42,6 @@
'../cpan/IPC-SysV' => 1,
'../cpan/Locale-Codes' => 1,
'../cpan/Log-Message' => 1,
- '../cpan/Math-Complex' => 1,
'../cpan/Module-Build' => 1,
'../cpan/Module-Load' => 1,
'../cpan/Module-Load-Conditional' => 1,
@@ -52,7 +51,6 @@
'../cpan/Pod-Simple' => 1,
'../cpan/Term-UI' => 1,
'../cpan/Test-Simple' => 1,
- '../cpan/Tie-File' => 1,
'../cpan/podlators' => 1,
'../dist/Cwd' => 1,
'../dist/ExtUtils-Command' => 1,
@@ -59,6 +57,7 @@
'../dist/ExtUtils-Install' => 1,
'../dist/ExtUtils-Manifest' => 1,
'../dist/ExtUtils-ParseXS' => 1,
+ '../dist/Tie-File' => 1,
);
my %temp_no_core =
@@ -75,7 +74,6 @@
'../cpan/podlators' => 1,
'../cpan/Test-Simple' => 1,
'../cpan/Tie-RefHash' => 1,
- '../cpan/Time-HiRes' => 1,
'../cpan/Unicode-Collate' => 1,
'../cpan/Unicode-Normalize' => 1,
);
@@ -83,7 +81,12 @@
# delete env vars that may influence the results
# but allow override via *_TEST env var if wanted
# (e.g. PERL5OPT_TEST=-d:NYTProf)
-for my $envname (qw(PERL5LIB PERLLIB PERL5OPT)) {
+my @bad_env_vars = qw(
+ PERL5LIB PERLLIB PERL5OPT
+ PERL_YAML_BACKEND PERL_JSON_BACKEND
+);
+
+for my $envname (@bad_env_vars) {
my $override = $ENV{"${envname}_TEST"};
if (defined $override) {
warn "$0: $envname=$override\n";
@@ -157,10 +160,13 @@
# check leakage for embedders
$ENV{PERL_DESTRUCT_LEVEL} = 2 unless exists $ENV{PERL_DESTRUCT_LEVEL};
+# check existence of all symbols
+$ENV{PERL_DL_NONLAZY} = 1 unless exists $ENV{PERL_DL_NONLAZY};
$ENV{EMXSHELL} = 'sh'; # For OS/2
if ($show_elapsed_time) { require Time::HiRes }
+my %timings = (); # testname => [@et] pairs if $show_elapsed_time.
my %skip = (
'.' => 1,
@@ -172,20 +178,24 @@
);
# Roll your own File::Find!
-sub _find_tests {
- my($dir) = @_;
- opendir DIR, $dir or die "Trouble opening $dir: $!";
- foreach my $f (sort { $a cmp $b } readdir DIR) {
- next if $skip{$f};
+sub _find_tests { our @found=(); push @ARGV, _find_files('\.t$', $_[0]) }
+sub _find_files {
+ my($patt, @dirs) = @_;
+ for my $dir (@dirs) {
+ opendir DIR, $dir or die "Trouble opening $dir: $!";
+ foreach my $f (sort { $a cmp $b } readdir DIR) {
+ next if $skip{$f};
- my $fullpath = "$dir/$f";
-
- if (-d $fullpath) {
- _find_tests($fullpath);
- } elsif ($f =~ /\.t$/) {
- push @ARGV, $fullpath;
+ my $fullpath = "$dir/$f";
+
+ if (-d $fullpath) {
+ _find_files($patt, $fullpath);
+ } elsif ($f =~ /$patt/) {
+ push @found, $fullpath;
+ }
}
}
+ @found;
}
@@ -292,12 +302,13 @@
if ($ENV{PERL_VALGRIND}) {
my $perl_supp = $options->{return_dir} ? "$options->{return_dir}/perl.supp" : "perl.supp";
- my $valgrind = $ENV{VALGRIND} // 'valgrind';
+ my $valgrind_exe = $ENV{VALGRIND} // 'valgrind';
my $vg_opts = $ENV{VG_OPTS}
- // "--suppressions=$perl_supp --leak-check=yes "
- . "--leak-resolution=high --show-reachable=yes "
+ // '--log-fd=3 '
+ . "--suppressions=$perl_supp --leak-check=yes "
+ . "--leak-resolution=high --show-reachable=yes "
. "--num-callers=50 --track-origins=yes";
- $perl = "$valgrind --log-fd=3 $vg_opts $perl";
+ $perl = "$valgrind_exe $vg_opts $perl";
$redir = "3>$Valgrind_Log";
if ($options->{run_dir}) {
$Valgrind_Log = "$options->{run_dir}/$Valgrind_Log";
@@ -307,7 +318,6 @@
my $args = "$options->{testswitch} $options->{switch} $options->{utf8}";
$cmd = $perl . _quote_args($args) . " $test $redir";
}
-
return $cmd;
}
@@ -420,10 +430,13 @@
# then comp, to validate that require works
# then run, to validate that -M works
# then we know we can -MTestInit for everything else, making life simpler
- foreach my $dir (qw(base comp run cmd io re op uni mro)) {
+ foreach my $dir (qw(base comp run cmd io re opbasic op uni mro)) {
_find_tests($dir);
}
- _find_tests("lib") unless $::core;
+ unless ($::core) {
+ _find_tests('porting');
+ _find_tests("lib");
+ }
# Config.pm may be broken for make minitest. And this is only a refinement
# for skipping tests on non-default builds, so it is allowed to fail.
# What we want to to is make a list of extensions which we did not build.
@@ -453,9 +466,9 @@
push @ARGV, _tests_from_manifest($extensions, $known_extensions);
unless ($::core) {
_find_tests('x2p');
- _find_tests('porting');
_find_tests('japh') if $::torture;
_find_tests('t/benchmark') if $::benchmark or $ENV{PERL_BENCHMARK};
+ _find_tests('bigmem') if $ENV{PERL_TEST_MEMORY};
}
}
@@ -511,22 +524,33 @@
}
my $maxlen = 0;
foreach (@::path_to_name{@tests}) {
- s/\.\w+\z/./;
+ s/\.\w+\z/ /; # space gives easy doubleclick to select fname
my $len = length ;
$maxlen = $len if $len > $maxlen;
}
# + 3 : we want three dots between the test name and the "ok"
my $dotdotdot = $maxlen + 3 ;
- my $valgrind = 0;
+ my $grind_ct = 0; # count of non-empty valgrind reports
my $total_files = @tests;
my $good_files = 0;
my $tested_files = 0;
my $totmax = 0;
my %failed_tests;
+ my $toolnm; # valgrind, cachegrind, perf
while (my $test = shift @tests) {
- my $test_start_time = $show_elapsed_time ? Time::HiRes::time() : 0;
-
+ my ($test_start_time, @starttimes) = 0;
+ if ($show_elapsed_time) {
+ $test_start_time = Time::HiRes::time();
+ # times() reports usage by TEST, but we want usage of each
+ # testprog it calls, so record accumulated times now,
+ # subtract them out afterwards. Ideally, we'd take times
+ # in BEGIN/END blocks (giving better visibility of self vs
+ # children of each testprog), but that would require some
+ # IPC to send results back here, or a completely different
+ # collection scheme (Storable isn't tuned for incremental use)
+ @starttimes = times;
+ }
if ($test =~ /^$/) {
next;
}
@@ -541,7 +565,7 @@
}
}
my $te = $::path_to_name{$test} . '.'
- x ($dotdotdot - length($::path_to_name{$test}));
+ x ($dotdotdot - length($::path_to_name{$test})) .' ';
if ($^O ne 'VMS') { # defer printing on VMS due to piping bug
print $te;
@@ -562,9 +586,9 @@
next if /^\s*$/; # skip blank lines
if (/^1..$/ && ($^O eq 'VMS')) {
# VMS pipe bug inserts blank lines.
- my $l2 = <RESULTS>;
+ my $l2 = <$results>;
if ($l2 =~ /^\s*$/) {
- $l2 = <RESULTS>;
+ $l2 = <$results>;
}
$_ = '1..' . $l2;
}
@@ -615,7 +639,7 @@
# SKIP is essentially the same as TODO for t/TEST
# this still conforms to TAP:
- # http://search.cpan.org/dist/TAP/TAP.pm
+ # http://testanything.org/wiki/index.php/TAP_specification
$extra and $istodo = $extra =~ /#\s*(?:TODO|SKIP)\b/;
$istodo = 1 if $todo{$num};
@@ -649,7 +673,9 @@
}
if ($ENV{PERL_VALGRIND}) {
- my @valgrind;
+ $toolnm = $ENV{VALGRIND};
+ $toolnm =~ s|.*/||; # keep basename
+ my @valgrind; # gets content of file
if (-e $Valgrind_Log) {
if (open(V, $Valgrind_Log)) {
@valgrind = <V>;
@@ -658,11 +684,17 @@
warn "$0: Failed to open '$Valgrind_Log': $!\n";
}
}
- if ($ENV{VG_OPTS} =~ /cachegrind/) {
- if (rename $Valgrind_Log, "$test.valgrind") {
- $valgrind = $valgrind + 1;
+ if ($ENV{VG_OPTS} =~ /(cachegrind)/ or $toolnm =~ /(perf)/) {
+ $toolnm = $1;
+ if ($toolnm eq 'perf') {
+ # append perfs subcommand, not just stat
+ my ($sub) = split /\s/, $ENV{VG_OPTS};
+ $toolnm .= "-$sub";
+ }
+ if (rename $Valgrind_Log, "$test.$toolnm") {
+ $grind_ct++;
} else {
- warn "$0: Failed to create '$test.valgrind': $!\n";
+ warn "$0: Failed to create '$test.$toolnm': $!\n";
}
}
elsif (@valgrind) {
@@ -683,7 +715,7 @@
}
if ($errors or $leaks) {
if (rename $Valgrind_Log, "$test.valgrind") {
- $valgrind = $valgrind + 1;
+ $grind_ct = $grind_ct + 1;
} else {
warn "$0: Failed to create '$test.valgrind': $!\n";
}
@@ -727,13 +759,18 @@
}
else {
if ($max) {
- my $elapsed;
+ my ($elapsed, $etms) = ("", 0);
if ( $show_elapsed_time ) {
- $elapsed = sprintf( " %8.0f ms", (Time::HiRes::time() - $test_start_time) * 1000 );
+ $etms = (Time::HiRes::time() - $test_start_time) * 1000;
+ $elapsed = sprintf(" %8.0f ms", $etms);
+
+ my (@endtimes) = times;
+ $endtimes[$_] -= $starttimes[$_] for 0..$#endtimes;
+ splice @endtimes, 0, 2; # drop self/harness times
+ $_ *= 1000 for @endtimes; # and scale to ms
+ $timings{$test} = [$etms, at endtimes];
+ $elapsed .= sprintf(" %5.0f ms", $_) for @endtimes;
}
- else {
- $elapsed = "";
- }
print "${te}ok$elapsed\n";
$good_files = $good_files + 1;
}
@@ -797,13 +834,68 @@
}
}
my ($user,$sys,$cuser,$csys) = times;
- print sprintf("u=%.2f s=%.2f cu=%.2f cs=%.2f scripts=%d tests=%d\n",
- $user,$sys,$cuser,$csys,$tested_files,$totmax);
+ my $tot = sprintf("u=%.2f s=%.2f cu=%.2f cs=%.2f scripts=%d tests=%d",
+ $user,$sys,$cuser,$csys,$tested_files,$totmax);
+ print "$tot\n";
+ if ($good_files) {
+ if (-d $show_elapsed_time) {
+ # HARNESS_TIMER = <a-directory>. Save timings etc to
+ # storable file there. NB: the test cds to ./t/, so
+ # relative path must account for that, ie ../../perf
+ # points to dir next to source tree.
+ require Storable;
+ my @dt = localtime;
+ $dt[5] += 1900; $dt[4] += 1; # fix year, month
+ my $fn = "$show_elapsed_time/".join('-', @dt[5,4,3,2,1]).".ttimes";
+ Storable::store({ perf => \%timings,
+ gather_conf_platform_info(),
+ total => $tot,
+ }, $fn);
+ print "wrote storable file: $fn\n";
+ }
+ }
if ($ENV{PERL_VALGRIND}) {
- my $s = $valgrind == 1 ? '' : 's';
- print "$valgrind valgrind report$s created.\n", ;
+ my $s = $grind_ct == 1 ? '' : 's';
+ print "$grind_ct valgrind report$s created.\n", ;
+ if ($toolnm eq 'cachegrind') {
+ # cachegrind leaves a lot of cachegrind.out.$pid litter
+ # around the tree, find and delete them
+ unlink _find_files('cachegrind.out.\d+$',
+ qw ( ../t ../cpan ../ext ../dist/ ));
+ }
}
}
exit ($::bad_files != 0);
+# Collect platform, config data that should allow comparing
+# performance data between different machines. With enough data,
+# and/or clever statistical analysis, it should be possible to
+# determine the effect of config choices, more memory, etc
+
+sub gather_conf_platform_info {
+ # currently rather quick & dirty, and subject to change
+ # for both content and format.
+ require Config;
+ my (%conf, @platform) = ();
+ $conf{$_} = $Config::Config{$_} for
+ grep /cc|git|config_arg\d+/, keys %Config::Config;
+ if (-f '/proc/cpuinfo') {
+ open my $fh, '/proc/cpuinfo' or warn "$!: /proc/cpuinfo\n";
+ @platform = grep /name|cpu/, <$fh>;
+ chomp $_ for @platform;
+ }
+ unshift @platform, $^O;
+
+ return (
+ conf => \%conf,
+ platform => {cpu => \@platform,
+ mem => [ grep s/\s+/ /,
+ grep chomp, `free` ],
+ load => [ grep chomp, `uptime` ],
+ },
+ host => (grep chomp, `hostname -f`),
+ version => '0.03', # bump for conf, platform, or data collection changes
+ );
+}
+
# ex: set ts=8 sts=4 sw=4 noet:
Property changes on: trunk/contrib/perl/t/TEST
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Copied: trunk/contrib/perl/t/TestInit.pm (from rev 6437, vendor/perl/5.18.1/t/TestInit.pm)
===================================================================
--- trunk/contrib/perl/t/TestInit.pm (rev 0)
+++ trunk/contrib/perl/t/TestInit.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,28 @@
+# This is a replacement for the old BEGIN preamble which heads (or
+# should head) up every core test program to prepare it for running.
+# Now instead of:
+#
+# BEGIN {
+# chdir 't' if -d 't';
+# @INC = '../lib';
+# }
+#
+# t/TEST will use -MTestInit. You may "use TestInit" in the test
+# programs but it is not required.
+#
+# P.S. This documentation is not in POD format in order to avoid
+# problems when there are fundamental bugs in perl.
+
+package TestInit;
+
+$VERSION = 1.01;
+
+chdir 't' if -d 't';
+ at INC = '../lib';
+
+# Don't interfere with the taintedness of %ENV, this could perturbate tests
+$ENV{PERL_CORE} = 1 unless ${^TAINT};
+
+$0 =~ s/\.dp$//; # for the test.deparse make target
+1;
+
Index: trunk/contrib/perl/t/base/cond.t
===================================================================
--- trunk/contrib/perl/t/base/cond.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/base/cond.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/base/cond.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/base/if.t
===================================================================
--- trunk/contrib/perl/t/base/if.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/base/if.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/base/if.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/base/lex.t
===================================================================
--- trunk/contrib/perl/t/base/lex.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/base/lex.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,6 +1,6 @@
#!./perl
-print "1..57\n";
+print "1..85\n";
$x = 'x';
@@ -152,7 +152,7 @@
# print "ok 32\n";
# These next two tests are trying to make sure that
- # $^FOO is always global; it doesn't make sense to `my' it.
+ # $^FOO is always global; it doesn't make sense to 'my' it.
#
eval 'my $^X;';
@@ -197,7 +197,7 @@
local $_ = "not ok ";
eval q{
s/^not /<<EOT/e and T '^main:\(eval \d+\):2$', $test++;
-# fuggedaboudit
+# uggedaboudit
EOT
print $_, $test++, "\n";
T('^main:\(eval \d+\):6$', $test++);
@@ -273,3 +273,130 @@
@a = (1,2,3);
print "not " unless($a[~~2] == 3);
print "ok 57\n";
+
+$_ = "";
+eval 's/(?:)/"${\q||}".<<\END/e;
+ok 58 - heredoc after "" in s/// in eval
+END
+';
+print $_ || "not ok 58\n";
+
+$_ = "";
+eval 's|(?:)|"${\<<\END}"
+ok 59 - heredoc in "" in multiline s///e in eval
+END
+|e
+';
+print $_ || "not ok 59\n";
+
+$_ = "";
+eval "s/(?:)/<<foo/e #\0
+ok 60 - null on same line as heredoc in s/// in eval
+foo
+";
+print $_ || "not ok 60\n";
+
+$_ = "";
+eval ' s/(?:)/"${\<<END}"/e;
+ok 61 - heredoc in "" in single-line s///e in eval
+END
+';
+print $_ || "not ok 61\n";
+
+$_ = "";
+s|(?:)|"${\<<END}"
+ok 62 - heredoc in "" in multiline s///e outside eval
+END
+|e;
+print $_ || "not ok 62\n";
+
+$_ = "not ok 63 - s/// in s/// pattern\n";
+s/${s|||;\""}not //;
+print;
+
+/(?{print <<END
+ok 64 - here-doc in re-eval
+END
+})/;
+
+eval '/(?{print <<END
+ok 65 - here-doc in re-eval in string eval
+END
+})/';
+
+eval 'print qq ;ok 66 - eval ending with semicolon\n;'
+ or print "not ok 66 - eval ending with semicolon\n";
+
+print "not " unless qr/(?{<<END})/ eq '(?^:(?{<<END}))';
+foo
+END
+print "ok 67 - here-doc in single-line re-eval\n";
+
+$_ = qr/(?{"${<<END}"
+foo
+END
+})/;
+print "not " unless /foo/;
+print "ok 68 - here-doc in quotes in multiline re-eval\n";
+
+eval 's//<<END/e if 0; $_ = "a
+END
+b"';
+print "not " if $_ =~ /\n\n/;
+print "ok 69 - eval 's//<<END/' does not leave extra newlines\n";
+
+$_ = a;
+eval "s/a/'b\0'#/e";
+print 'not ' unless $_ eq "b\0";
+print "ok 70 - # after null in s/// repl\n";
+
+s//"#" . <<END/e;
+foo
+END
+print "ok 71 - s//'#' . <<END/e\n";
+
+eval "s//3}->{3/e";
+print "not " unless $@;
+print "ok 72 - s//3}->{3/e\n";
+
+$_ = "not ok 73";
+$x{3} = "not ";
+eval 's/${\%x}{3}//e';
+print "$_ - s//\${\\%x}{3}/e\n";
+
+eval 's/${foo#}//e';
+print "not " unless $@;
+print "ok 74 - s/\${foo#}//e\n";
+
+eval 'warn ({$_ => 1} + 1) if 0';
+print "not " if $@;
+print "ok 75 - listop({$_ => 1} + 1)\n";
+print "# $@" if $@;
+
+$test = 76;
+for(qw< require goto last next redo dump >) {
+ eval "sub { $_ foo << 2 }";
+ print "not " if $@;
+ print "ok ", $test++, " - [perl #105924] $_ WORD << ...\n";
+ print "# $@" if $@;
+}
+
+# http://rt.perl.org/rt3/Ticket/Display.html?id=56880
+my $counter = 0;
+eval 'v23: $counter++; goto v23 unless $counter == 2';
+print "not " unless $counter == 2;
+print "ok 82 - Use v[0-9]+ as a label\n";
+$counter = 0;
+eval 'v23 : $counter++; goto v23 unless $counter == 2';
+print "not " unless $counter == 2;
+print "ok 83 - Use v[0-9]+ as a label with space before colon\n";
+
+my $output = "";
+eval "package v10::foo; sub test2 { return 'v10::foo' }
+ package v10; sub test { return v10::foo::test2(); }
+ package main; \$output = v10::test(); ";
+print "not " unless $output eq 'v10::foo';
+print "ok 84 - call a function in package v10::foo\n";
+
+print "not " unless (1?v65:"bar") eq 'A';
+print "ok 85 - colon detection after vstring does not break ? vstring :\n";
Property changes on: trunk/contrib/perl/t/base/lex.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/t/base/num.t
===================================================================
--- trunk/contrib/perl/t/base/num.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/base/num.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/base/num.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/t/base/pat.t
===================================================================
--- trunk/contrib/perl/t/base/pat.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/base/pat.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/base/pat.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/base/rs.t
===================================================================
--- trunk/contrib/perl/t/base/rs.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/base/rs.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/base/rs.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/t/base/term.t
===================================================================
--- trunk/contrib/perl/t/base/term.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/base/term.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/base/term.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/t/base/while.t
===================================================================
--- trunk/contrib/perl/t/base/while.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/base/while.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/base/while.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/benchmark/rt26188-speed-up-keys-on-empty-hash.t
===================================================================
--- trunk/contrib/perl/t/benchmark/rt26188-speed-up-keys-on-empty-hash.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/benchmark/rt26188-speed-up-keys-on-empty-hash.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -81,10 +81,3 @@
about_as_fast_ok( $res, 'lex_big', 'big', "Checking the list of hash keys in an empty hash, global vs. lexical");
__END__
-
-# code written
- /* quick bailout if the hash is empty anyway.
- I don't know if placeholders are included in the KEYS count, so a defensive check
- */
- if (! HvKEYS(hv) && !(flags & HV_ITERNEXT_WANTPLACEHOLDERS) )
- return NULL;
Property changes on: trunk/contrib/perl/t/benchmark/rt26188-speed-up-keys-on-empty-hash.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/cmd/elsif.t
===================================================================
--- trunk/contrib/perl/t/cmd/elsif.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/cmd/elsif.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/cmd/elsif.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/cmd/for.t
===================================================================
--- trunk/contrib/perl/t/cmd/for.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/cmd/for.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,6 +1,6 @@
#!./perl
-print "1..118\n";
+print "1..14\n";
for ($i = 0; $i <= 10; $i++) {
$x[$i] = $i;
@@ -95,576 +95,3 @@
print $x == 1 ? "ok" : "not ok", " 14 - double destroy, x=$x\n";
}
-# A lot of tests to check that reversed for works.
-my $test = 14;
-sub is {
- my ($got, $expected, $name) = @_;
- ++$test;
- if ($got eq $expected) {
- print "ok $test # $name\n";
- return 1;
- }
- print "not ok $test # $name\n";
- print "# got '$got', expected '$expected'\n";
- return 0;
-}
-
- at array = ('A', 'B', 'C');
-for (@array) {
- $r .= $_;
-}
-is ($r, 'ABC', 'Forwards for array');
-$r = '';
-for (1,2,3) {
- $r .= $_;
-}
-is ($r, '123', 'Forwards for list');
-$r = '';
-for (map {$_} @array) {
- $r .= $_;
-}
-is ($r, 'ABC', 'Forwards for array via map');
-$r = '';
-for (map {$_} 1,2,3) {
- $r .= $_;
-}
-is ($r, '123', 'Forwards for list via map');
-$r = '';
-for (1 .. 3) {
- $r .= $_;
-}
-is ($r, '123', 'Forwards for list via ..');
-$r = '';
-for ('A' .. 'C') {
- $r .= $_;
-}
-is ($r, 'ABC', 'Forwards for list via ..');
-
-$r = '';
-for (reverse @array) {
- $r .= $_;
-}
-is ($r, 'CBA', 'Reverse for array');
-$r = '';
-for (reverse 1,2,3) {
- $r .= $_;
-}
-is ($r, '321', 'Reverse for list');
-$r = '';
-for (reverse map {$_} @array) {
- $r .= $_;
-}
-is ($r, 'CBA', 'Reverse for array via map');
-$r = '';
-for (reverse map {$_} 1,2,3) {
- $r .= $_;
-}
-is ($r, '321', 'Reverse for list via map');
-$r = '';
-for (reverse 1 .. 3) {
- $r .= $_;
-}
-is ($r, '321', 'Reverse for list via ..');
-$r = '';
-for (reverse 'A' .. 'C') {
- $r .= $_;
-}
-is ($r, 'CBA', 'Reverse for list via ..');
-
-$r = '';
-for my $i (@array) {
- $r .= $i;
-}
-is ($r, 'ABC', 'Forwards for array with var');
-$r = '';
-for my $i (1,2,3) {
- $r .= $i;
-}
-is ($r, '123', 'Forwards for list with var');
-$r = '';
-for my $i (map {$_} @array) {
- $r .= $i;
-}
-is ($r, 'ABC', 'Forwards for array via map with var');
-$r = '';
-for my $i (map {$_} 1,2,3) {
- $r .= $i;
-}
-is ($r, '123', 'Forwards for list via map with var');
-$r = '';
-for my $i (1 .. 3) {
- $r .= $i;
-}
-is ($r, '123', 'Forwards for list via .. with var');
-$r = '';
-for my $i ('A' .. 'C') {
- $r .= $i;
-}
-is ($r, 'ABC', 'Forwards for list via .. with var');
-
-$r = '';
-for my $i (reverse @array) {
- $r .= $i;
-}
-is ($r, 'CBA', 'Reverse for array with var');
-$r = '';
-for my $i (reverse 1,2,3) {
- $r .= $i;
-}
-is ($r, '321', 'Reverse for list with var');
-$r = '';
-for my $i (reverse map {$_} @array) {
- $r .= $i;
-}
-is ($r, 'CBA', 'Reverse for array via map with var');
-$r = '';
-for my $i (reverse map {$_} 1,2,3) {
- $r .= $i;
-}
-is ($r, '321', 'Reverse for list via map with var');
-$r = '';
-for my $i (reverse 1 .. 3) {
- $r .= $i;
-}
-is ($r, '321', 'Reverse for list via .. with var');
-$r = '';
-for my $i (reverse 'A' .. 'C') {
- $r .= $i;
-}
-is ($r, 'CBA', 'Reverse for list via .. with var');
-
-# For some reason the generate optree is different when $_ is implicit.
-$r = '';
-for $_ (@array) {
- $r .= $_;
-}
-is ($r, 'ABC', 'Forwards for array with explicit $_');
-$r = '';
-for $_ (1,2,3) {
- $r .= $_;
-}
-is ($r, '123', 'Forwards for list with explicit $_');
-$r = '';
-for $_ (map {$_} @array) {
- $r .= $_;
-}
-is ($r, 'ABC', 'Forwards for array via map with explicit $_');
-$r = '';
-for $_ (map {$_} 1,2,3) {
- $r .= $_;
-}
-is ($r, '123', 'Forwards for list via map with explicit $_');
-$r = '';
-for $_ (1 .. 3) {
- $r .= $_;
-}
-is ($r, '123', 'Forwards for list via .. with var with explicit $_');
-$r = '';
-for $_ ('A' .. 'C') {
- $r .= $_;
-}
-is ($r, 'ABC', 'Forwards for list via .. with var with explicit $_');
-
-$r = '';
-for $_ (reverse @array) {
- $r .= $_;
-}
-is ($r, 'CBA', 'Reverse for array with explicit $_');
-$r = '';
-for $_ (reverse 1,2,3) {
- $r .= $_;
-}
-is ($r, '321', 'Reverse for list with explicit $_');
-$r = '';
-for $_ (reverse map {$_} @array) {
- $r .= $_;
-}
-is ($r, 'CBA', 'Reverse for array via map with explicit $_');
-$r = '';
-for $_ (reverse map {$_} 1,2,3) {
- $r .= $_;
-}
-is ($r, '321', 'Reverse for list via map with explicit $_');
-$r = '';
-for $_ (reverse 1 .. 3) {
- $r .= $_;
-}
-is ($r, '321', 'Reverse for list via .. with var with explicit $_');
-$r = '';
-for $_ (reverse 'A' .. 'C') {
- $r .= $_;
-}
-is ($r, 'CBA', 'Reverse for list via .. with var with explicit $_');
-
-# I don't think that my is that different from our in the optree. But test a
-# few:
-$r = '';
-for our $i (reverse @array) {
- $r .= $i;
-}
-is ($r, 'CBA', 'Reverse for array with our var');
-$r = '';
-for our $i (reverse 1,2,3) {
- $r .= $i;
-}
-is ($r, '321', 'Reverse for list with our var');
-$r = '';
-for our $i (reverse map {$_} @array) {
- $r .= $i;
-}
-is ($r, 'CBA', 'Reverse for array via map with our var');
-$r = '';
-for our $i (reverse map {$_} 1,2,3) {
- $r .= $i;
-}
-is ($r, '321', 'Reverse for list via map with our var');
-$r = '';
-for our $i (reverse 1 .. 3) {
- $r .= $i;
-}
-is ($r, '321', 'Reverse for list via .. with our var');
-$r = '';
-for our $i (reverse 'A' .. 'C') {
- $r .= $i;
-}
-is ($r, 'CBA', 'Reverse for list via .. with our var');
-
-
-$r = '';
-for (1, reverse @array) {
- $r .= $_;
-}
-is ($r, '1CBA', 'Reverse for array with leading value');
-$r = '';
-for ('A', reverse 1,2,3) {
- $r .= $_;
-}
-is ($r, 'A321', 'Reverse for list with leading value');
-$r = '';
-for (1, reverse map {$_} @array) {
- $r .= $_;
-}
-is ($r, '1CBA', 'Reverse for array via map with leading value');
-$r = '';
-for ('A', reverse map {$_} 1,2,3) {
- $r .= $_;
-}
-is ($r, 'A321', 'Reverse for list via map with leading value');
-$r = '';
-for ('A', reverse 1 .. 3) {
- $r .= $_;
-}
-is ($r, 'A321', 'Reverse for list via .. with leading value');
-$r = '';
-for (1, reverse 'A' .. 'C') {
- $r .= $_;
-}
-is ($r, '1CBA', 'Reverse for list via .. with leading value');
-
-$r = '';
-for (reverse (@array), 1) {
- $r .= $_;
-}
-is ($r, 'CBA1', 'Reverse for array with trailing value');
-$r = '';
-for (reverse (1,2,3), 'A') {
- $r .= $_;
-}
-is ($r, '321A', 'Reverse for list with trailing value');
-$r = '';
-for (reverse (map {$_} @array), 1) {
- $r .= $_;
-}
-is ($r, 'CBA1', 'Reverse for array via map with trailing value');
-$r = '';
-for (reverse (map {$_} 1,2,3), 'A') {
- $r .= $_;
-}
-is ($r, '321A', 'Reverse for list via map with trailing value');
-$r = '';
-for (reverse (1 .. 3), 'A') {
- $r .= $_;
-}
-is ($r, '321A', 'Reverse for list via .. with trailing value');
-$r = '';
-for (reverse ('A' .. 'C'), 1) {
- $r .= $_;
-}
-is ($r, 'CBA1', 'Reverse for list via .. with trailing value');
-
-
-$r = '';
-for $_ (1, reverse @array) {
- $r .= $_;
-}
-is ($r, '1CBA', 'Reverse for array with leading value with explicit $_');
-$r = '';
-for $_ ('A', reverse 1,2,3) {
- $r .= $_;
-}
-is ($r, 'A321', 'Reverse for list with leading value with explicit $_');
-$r = '';
-for $_ (1, reverse map {$_} @array) {
- $r .= $_;
-}
-is ($r, '1CBA',
- 'Reverse for array via map with leading value with explicit $_');
-$r = '';
-for $_ ('A', reverse map {$_} 1,2,3) {
- $r .= $_;
-}
-is ($r, 'A321', 'Reverse for list via map with leading value with explicit $_');
-$r = '';
-for $_ ('A', reverse 1 .. 3) {
- $r .= $_;
-}
-is ($r, 'A321', 'Reverse for list via .. with leading value with explicit $_');
-$r = '';
-for $_ (1, reverse 'A' .. 'C') {
- $r .= $_;
-}
-is ($r, '1CBA', 'Reverse for list via .. with leading value with explicit $_');
-
-$r = '';
-for $_ (reverse (@array), 1) {
- $r .= $_;
-}
-is ($r, 'CBA1', 'Reverse for array with trailing value with explicit $_');
-$r = '';
-for $_ (reverse (1,2,3), 'A') {
- $r .= $_;
-}
-is ($r, '321A', 'Reverse for list with trailing value with explicit $_');
-$r = '';
-for $_ (reverse (map {$_} @array), 1) {
- $r .= $_;
-}
-is ($r, 'CBA1',
- 'Reverse for array via map with trailing value with explicit $_');
-$r = '';
-for $_ (reverse (map {$_} 1,2,3), 'A') {
- $r .= $_;
-}
-is ($r, '321A',
- 'Reverse for list via map with trailing value with explicit $_');
-$r = '';
-for $_ (reverse (1 .. 3), 'A') {
- $r .= $_;
-}
-is ($r, '321A', 'Reverse for list via .. with trailing value with explicit $_');
-$r = '';
-for $_ (reverse ('A' .. 'C'), 1) {
- $r .= $_;
-}
-is ($r, 'CBA1', 'Reverse for list via .. with trailing value with explicit $_');
-
-$r = '';
-for my $i (1, reverse @array) {
- $r .= $i;
-}
-is ($r, '1CBA', 'Reverse for array with leading value and var');
-$r = '';
-for my $i ('A', reverse 1,2,3) {
- $r .= $i;
-}
-is ($r, 'A321', 'Reverse for list with leading value and var');
-$r = '';
-for my $i (1, reverse map {$_} @array) {
- $r .= $i;
-}
-is ($r, '1CBA', 'Reverse for array via map with leading value and var');
-$r = '';
-for my $i ('A', reverse map {$_} 1,2,3) {
- $r .= $i;
-}
-is ($r, 'A321', 'Reverse for list via map with leading value and var');
-$r = '';
-for my $i ('A', reverse 1 .. 3) {
- $r .= $i;
-}
-is ($r, 'A321', 'Reverse for list via .. with leading value and var');
-$r = '';
-for my $i (1, reverse 'A' .. 'C') {
- $r .= $i;
-}
-is ($r, '1CBA', 'Reverse for list via .. with leading value and var');
-
-$r = '';
-for my $i (reverse (@array), 1) {
- $r .= $i;
-}
-is ($r, 'CBA1', 'Reverse for array with trailing value and var');
-$r = '';
-for my $i (reverse (1,2,3), 'A') {
- $r .= $i;
-}
-is ($r, '321A', 'Reverse for list with trailing value and var');
-$r = '';
-for my $i (reverse (map {$_} @array), 1) {
- $r .= $i;
-}
-is ($r, 'CBA1', 'Reverse for array via map with trailing value and var');
-$r = '';
-for my $i (reverse (map {$_} 1,2,3), 'A') {
- $r .= $i;
-}
-is ($r, '321A', 'Reverse for list via map with trailing value and var');
-$r = '';
-for my $i (reverse (1 .. 3), 'A') {
- $r .= $i;
-}
-is ($r, '321A', 'Reverse for list via .. with trailing value and var');
-$r = '';
-for my $i (reverse ('A' .. 'C'), 1) {
- $r .= $i;
-}
-is ($r, 'CBA1', 'Reverse for list via .. with trailing value and var');
-
-
-$r = '';
-for (reverse 1, @array) {
- $r .= $_;
-}
-is ($r, 'CBA1', 'Reverse for value and array');
-$r = '';
-for (reverse map {$_} 1, @array) {
- $r .= $_;
-}
-is ($r, 'CBA1', 'Reverse for value and array via map');
-$r = '';
-for (reverse 1 .. 3, @array) {
- $r .= $_;
-}
-is ($r, 'CBA321', 'Reverse for .. and array');
-$r = '';
-for (reverse 'X' .. 'Z', @array) {
- $r .= $_;
-}
-is ($r, 'CBAZYX', 'Reverse for .. and array');
-$r = '';
-for (reverse map {$_} 1 .. 3, @array) {
- $r .= $_;
-}
-is ($r, 'CBA321', 'Reverse for .. and array via map');
-$r = '';
-for (reverse map {$_} 'X' .. 'Z', @array) {
- $r .= $_;
-}
-is ($r, 'CBAZYX', 'Reverse for .. and array via map');
-
-$r = '';
-for (reverse (@array, 1)) {
- $r .= $_;
-}
-is ($r, '1CBA', 'Reverse for array and value');
-$r = '';
-for (reverse (map {$_} @array, 1)) {
- $r .= $_;
-}
-is ($r, '1CBA', 'Reverse for array and value via map');
-
-$r = '';
-for $_ (reverse 1, @array) {
- $r .= $_;
-}
-is ($r, 'CBA1', 'Reverse for value and array with explicit $_');
-$r = '';
-for $_ (reverse map {$_} 1, @array) {
- $r .= $_;
-}
-is ($r, 'CBA1', 'Reverse for value and array via map with explicit $_');
-$r = '';
-for $_ (reverse 1 .. 3, @array) {
- $r .= $_;
-}
-is ($r, 'CBA321', 'Reverse for .. and array with explicit $_');
-$r = '';
-for $_ (reverse 'X' .. 'Z', @array) {
- $r .= $_;
-}
-is ($r, 'CBAZYX', 'Reverse for .. and array with explicit $_');
-$r = '';
-for $_ (reverse map {$_} 1 .. 3, @array) {
- $r .= $_;
-}
-is ($r, 'CBA321', 'Reverse for .. and array via map with explicit $_');
-$r = '';
-for $_ (reverse map {$_} 'X' .. 'Z', @array) {
- $r .= $_;
-}
-is ($r, 'CBAZYX', 'Reverse for .. and array via map with explicit $_');
-
-$r = '';
-for $_ (reverse (@array, 1)) {
- $r .= $_;
-}
-is ($r, '1CBA', 'Reverse for array and value with explicit $_');
-$r = '';
-for $_ (reverse (map {$_} @array, 1)) {
- $r .= $_;
-}
-is ($r, '1CBA', 'Reverse for array and value via map with explicit $_');
-
-
-$r = '';
-for my $i (reverse 1, @array) {
- $r .= $i;
-}
-is ($r, 'CBA1', 'Reverse for value and array with var');
-$r = '';
-for my $i (reverse map {$_} 1, @array) {
- $r .= $i;
-}
-is ($r, 'CBA1', 'Reverse for value and array via map with var');
-$r = '';
-for my $i (reverse 1 .. 3, @array) {
- $r .= $i;
-}
-is ($r, 'CBA321', 'Reverse for .. and array with var');
-$r = '';
-for my $i (reverse 'X' .. 'Z', @array) {
- $r .= $i;
-}
-is ($r, 'CBAZYX', 'Reverse for .. and array with var');
-$r = '';
-for my $i (reverse map {$_} 1 .. 3, @array) {
- $r .= $i;
-}
-is ($r, 'CBA321', 'Reverse for .. and array via map with var');
-$r = '';
-for my $i (reverse map {$_} 'X' .. 'Z', @array) {
- $r .= $i;
-}
-is ($r, 'CBAZYX', 'Reverse for .. and array via map with var');
-
-$r = '';
-for my $i (reverse (@array, 1)) {
- $r .= $i;
-}
-is ($r, '1CBA', 'Reverse for array and value with var');
-$r = '';
-for my $i (reverse (map {$_} @array, 1)) {
- $r .= $i;
-}
-is ($r, '1CBA', 'Reverse for array and value via map with var');
-
-TODO: {
- $test++;
- local $TODO = "RT #1085: what should be output of perl -we 'print do { foreach (1, 2) { 1; } }'";
- if (do {17; foreach (1, 2) { 1; } } != 17) {
- print "not ";
- }
- print "ok $test # TODO $TODO\n";
-}
-
-TODO: {
- $test++;
- no warnings 'reserved';
- local $TODO = "RT #2166: foreach spuriously autovivifies";
- my %h;
- foreach (@h{a, b}) {}
- if(keys(%h)) {
- print "not ";
- }
- print "ok $test # TODO $TODO\n";
-}
Property changes on: trunk/contrib/perl/t/cmd/for.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/t/cmd/mod.t
===================================================================
--- trunk/contrib/perl/t/cmd/mod.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/cmd/mod.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/cmd/mod.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/cmd/subval.t
===================================================================
--- trunk/contrib/perl/t/cmd/subval.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/cmd/subval.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/cmd/subval.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/cmd/switch.t
===================================================================
--- trunk/contrib/perl/t/cmd/switch.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/cmd/switch.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/cmd/switch.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/t/cmd/while.t
===================================================================
--- trunk/contrib/perl/t/cmd/while.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/cmd/while.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/cmd/while.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/comp/bproto.t
===================================================================
--- trunk/contrib/perl/t/comp/bproto.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/comp/bproto.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -8,7 +8,7 @@
@INC = '../lib';
}
-print "1..10\n";
+print "1..16\n";
my $i = 1;
@@ -21,6 +21,12 @@
printf "ok %d\n",$i++;
}
+sub test_too_few {
+ eval $_[0];
+ print "not " unless $@ =~ /^Not enough arguments/;
+ printf "ok %d\n",$i++;
+}
+
sub test_no_error {
eval $_[0];
print "not " if $@;
@@ -29,10 +35,16 @@
test_too_many($_) for split /\n/,
q[ defined(&foo, $bar);
+ pos(1,$b);
undef(&foo, $bar);
uc($bar,$bar);
];
+test_too_few($_) for split /\n/,
+q[ unpack;
+ pack;
+];
+
test_no_error($_) for split /\n/,
q[ scalar(&foo,$bar);
defined &foo, &foo, &foo;
@@ -41,4 +53,7 @@
grep(not($bar), $bar);
grep(not($bar, $bar), $bar);
grep((not $bar, $bar, $bar), $bar);
+ __FILE__();
+ __LINE__();
+ __PACKAGE__();
];
Property changes on: trunk/contrib/perl/t/comp/bproto.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/comp/cmdopt.t
===================================================================
--- trunk/contrib/perl/t/comp/cmdopt.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/comp/cmdopt.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/comp/cmdopt.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/comp/colon.t
===================================================================
--- trunk/contrib/perl/t/comp/colon.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/comp/colon.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/comp/colon.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/t/comp/cpp.aux (from rev 6437, vendor/perl/5.18.1/t/comp/cpp.aux)
===================================================================
--- trunk/contrib/perl/t/comp/cpp.aux (rev 0)
+++ trunk/contrib/perl/t/comp/cpp.aux 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,35 @@
+#!./perl -l
+
+# There's a bug in -P where the #! line is ignored. If this test
+# suddenly starts printing blank lines that bug has been fixed.
+
+print "1..3\n";
+
+#define MESS "ok 1\n"
+print MESS;
+
+#ifdef MESS
+ print "ok 2\n";
+#else
+ print "not ok 2\n";
+#endif
+
+open(TRY,">Comp_cpp.tmp") || die "Can't open temp perl file: $!";
+
+($prog = <<'END') =~ s/X//g;
+X$ok = "not ok 3\n";
+X#include "Comp_cpp.inc"
+X#ifdef OK
+X$ok = OK;
+X#endif
+Xprint $ok;
+END
+print TRY $prog;
+close TRY or die "Could not close Comp_cpp.tmp: $!";
+
+open(TRY,">Comp_cpp.inc") || (die "Can't open temp include file: $!");
+print TRY '#define OK "ok 3\n"' . "\n";
+close TRY or die "Could not close Comp_cpp.tmp: $!";
+
+print `$^X "-P" Comp_cpp.tmp`;
+unlink "Comp_cpp.tmp", "Comp_cpp.inc";
Copied: trunk/contrib/perl/t/comp/cpp.t (from rev 6437, vendor/perl/5.18.1/t/comp/cpp.t)
===================================================================
--- trunk/contrib/perl/t/comp/cpp.t (rev 0)
+++ trunk/contrib/perl/t/comp/cpp.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,17 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ $ENV{PERL5LIB} = '../lib';
+}
+
+use Config;
+if ( $^O eq 'MacOS' ||
+ ($Config{'cppstdin'} =~ /\bcppstdin\b/) &&
+ ! -x $Config{'binexp'} . "/cppstdin" ) {
+ print "1..0 # Skip: \$Config{cppstdin} unavailable\n";
+ exit; # Cannot test till after install, alas.
+}
+
+system qq{$^X -"P" "comp/cpp.aux"};
Index: trunk/contrib/perl/t/comp/decl.t
===================================================================
--- trunk/contrib/perl/t/comp/decl.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/comp/decl.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/comp/decl.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/t/comp/final_line_num.t
===================================================================
--- trunk/contrib/perl/t/comp/final_line_num.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/comp/final_line_num.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/comp/final_line_num.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/comp/fold.t
===================================================================
--- trunk/contrib/perl/t/comp/fold.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/comp/fold.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -4,7 +4,7 @@
# we've not yet verified that use works.
# use strict;
-print "1..19\n";
+print "1..26\n";
my $test = 0;
# Historically constant folding was performed by evaluating the ops, and if
@@ -118,3 +118,34 @@
ok scalar $jing =~ (0 || y/fo//),
'lone y/// is not bound via =~ after || folding';
}
+
+# [perl #78064] or print
+package other { # hide the "ok" sub
+ BEGIN { $^W = 0 }
+ print 0 ? not_ok : ok;
+ print " ", ++$test, " - print followed by const ? BEAR : BEAR\n";
+ print 1 ? ok : not_ok;
+ print " ", ++$test, " - print followed by const ? BEAR : BEAR (again)\n";
+ print 1 && ok;
+ print " ", ++$test, " - print followed by const && BEAR\n";
+ print 0 || ok;
+ print " ", ++$test, " - print followed by const || URSINE\n";
+ BEGIN { $^W = 1 }
+}
+
+# or stat
+print "not " unless stat(1 ? INSTALL : 0) eq stat("INSTALL");
+print "ok ", ++$test, " - stat(const ? word : ....)\n";
+# in case we are in t/
+print "not " unless stat(1 ? TEST : 0) eq stat("TEST");
+print "ok ", ++$test, " - stat(const ? word : ....)\n";
+
+# or truncate
+my $n = "for_fold_dot_t$$";
+open F, ">$n" or die "open: $!";
+print F "bralh blah blah \n";
+close F or die "close $!";
+eval "truncate 1 ? $n : 0, 0;";
+print "not " unless -z $n;
+print "ok ", ++$test, " - truncate(const ? word : ...)\n";
+unlink $n;
Property changes on: trunk/contrib/perl/t/comp/fold.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/comp/form_scope.t
===================================================================
--- trunk/contrib/perl/t/comp/form_scope.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/comp/form_scope.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,9 +1,8 @@
#!./perl
-#
-# Tests bug #22977. Test case from Dave Mitchell.
-print "1..2\n";
+print "1..14\n";
+# Tests bug #22977. Test case from Dave Mitchell.
sub f ($);
sub f ($) {
my $test = $_[0];
@@ -16,3 +15,146 @@
f(1);
f(2);
+
+# A bug caused by the fix for #22977/50528
+sub foo {
+ sub bar {
+ # Fill the pad with alphabet soup, to give the closed-over variable a
+ # high padoffset (more likely to trigger the bug and crash).
+ {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
+ {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
+ {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
+ {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
+ {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
+ {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
+ {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
+ {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
+ {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
+ {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
+ {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
+ {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
+ {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
+ {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
+ {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
+ {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
+ {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
+ {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
+ my $x;
+ format STDOUT2 =
+@<<<<<<
+"ok 3".$x # $x is not available, but this should not crash
+.
+ }
+}
+*STDOUT = *STDOUT2{FORMAT};
+undef *bar;
+write;
+
+# A regression introduced in 5.10; format cloning would close over the
+# variables in the currently-running sub (the main CV in this test) if the
+# outer sub were an inactive closure.
+sub baz {
+ my $a;
+ sub {
+ $a;
+ {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t)}
+ my $x;
+ format STDOUT3 =
+@<<<<<<<<<<<<<<<<<<<<<<<<<
+defined $x ? "not ok 4 - $x" : "ok 4"
+.
+ }
+}
+*STDOUT = *STDOUT3{FORMAT};
+{
+ local $^W = 1;
+ my $w;
+ local $SIG{__WARN__} = sub { $w = shift };
+ write;
+ print "not " unless $w =~ /^Variable "\$x" is not available at/;
+ print "ok 5 - closure var not available when outer sub is inactive\n";
+}
+
+# Formats inside closures should close over the topmost clone of the outer
+# sub on the call stack.
+# Tests will be out of sequence if the wrong sub is used.
+sub make_closure {
+ my $arg = shift;
+ sub {
+ shift == 0 and &$next(1), return;
+ my $x = "ok $arg";
+ format STDOUT4 =
+@<<<<<<<
+$x
+.
+ sub { write }->(); # separate sub, so as not to rely on it being the
+ } # currently-running sub
+}
+*STDOUT = *STDOUT4{FORMAT};
+$clo1 = make_closure 6;
+$clo2 = make_closure 7;
+$next = $clo1;
+&$clo2(0);
+$next = $clo2;
+&$clo1(0);
+
+# Cloning a format whose outside has been undefined
+sub x {
+ {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
+ my $z;
+ format STDOUT6 =
+@<<<<<<<<<<<<<<<<<<<<<<<<<
+defined $z ? "not ok 8 - $z" : "ok 8"
+.
+}
+undef &x;
+*STDOUT = *STDOUT6{FORMAT};
+{
+ local $^W = 1;
+ my $w;
+ local $SIG{__WARN__} = sub { $w = shift };
+ write;
+ print "not " unless $w =~ /^Variable "\$z" is not available at/;
+ print "ok 9 - closure var not available when outer sub is undefined\n";
+}
+
+format STDOUT7 =
+@<<<<<<<<<<<<<<<<<<<<<<<<<<<
+do { my $x = "ok 10 - closure inside format"; sub { $x }->() }
+.
+*STDOUT = *STDOUT7{FORMAT};
+write;
+
+$testn = 12;
+format STDOUT8 =
+@<<<< - recursive formats
+do { my $t = "ok " . $testn--; write if $t =~ 12; $t}
+.
+*STDOUT = *STDOUT8{FORMAT};
+write;
+
+sub _13 {
+ my $x;
+format STDOUT13 =
+@* - formats closing over redefined subs
+ref \$x eq 'SCALAR' ? "ok 13" : "not ok 13";
+.
+}
+undef &_13;
+eval 'sub _13 { my @x; write }';
+*STDOUT = *STDOUT13{FORMAT};
+_13();
+
+# This is a variation of bug #22977, which crashes or fails an assertion
+# up to 5.16.
+# Keep this test last if you want test numbers to be sane.
+BEGIN { \&END }
+END {
+ my $test = "ok 14";
+ *STDOUT = *STDOUT5{FORMAT};
+ write;
+ format STDOUT5 =
+@<<<<<<<
+$test
+.
+}
Property changes on: trunk/contrib/perl/t/comp/form_scope.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/comp/hints.aux
===================================================================
--- trunk/contrib/perl/t/comp/hints.aux 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/comp/hints.aux 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/comp/hints.aux
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/comp/hints.t
===================================================================
--- trunk/contrib/perl/t/comp/hints.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/comp/hints.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -4,9 +4,10 @@
BEGIN {
@INC = qw(. ../lib);
+ chdir 't';
}
-BEGIN { print "1..24\n"; }
+BEGIN { print "1..31\n"; }
BEGIN {
print "not " if exists $^H{foo};
print "ok 1 - \$^H{foo} doesn't exist initially\n";
@@ -62,10 +63,12 @@
}
# op_entereval should keep the pragmas it was compiled with
eval q*
+ BEGIN {
print "not " if $^H{foo} ne "a";
print "ok 13 - \$^H{foo} is 'a' at eval-\"\" time\n";
print "not " unless $^H & 0x00020000;
print "ok 14 - \$^H contains HINT_LOCALIZE_HH at eval\"\"-time\n";
+ }
*;
}
BEGIN {
@@ -84,7 +87,9 @@
BEGIN{$^H{x}=1};
for my $tno (15..16) {
eval q(
- print $^H{x}==1 && !$^H{y} ? "ok $tno\n" : "not ok $tno\n";
+ BEGIN {
+ print $^H{x}==1 && !$^H{y} ? "ok $tno\n" : "not ok $tno\n";
+ }
$^H{y} = 1;
);
if ($@) {
@@ -124,8 +129,146 @@
"ok 23 - \$^H{foo} correct after /unicode/i (res=$res)\n";
}
+# [perl #106282] Crash when tying %^H
+# Tying %^H should not result in a crash when the hint hash is cloned.
+# Hints should also be copied properly to inner scopes. See also
+# [rt.cpan.org #73402].
+eval q`
+ # Do something naughty enough, and you get your module mentioned in the
+ # test suite. :-)
+ package namespace::clean::_TieHintHash;
+ sub TIEHASH { bless[] }
+ sub STORE { $_[0][0]{$_[1]} = $_[2] }
+ sub FETCH { $_[0][0]{$_[1]} }
+ sub FIRSTKEY { my $a = scalar keys %{$_[0][0]}; each %{$_[0][0]} }
+ sub NEXTKEY { each %{$_[0][0]} }
+ package main;
+
+ BEGIN {
+ $^H{foo} = "bar"; # activate localisation magic
+ tie( %^H, 'namespace::clean::_TieHintHash' ); # sabotage %^H
+ $^H{foo} = "bar"; # create an element in the tied hash
+ }
+ { # clone the tied hint hash on scope entry
+ BEGIN {
+ print "not " x ($^H{foo} ne 'bar'),
+ "ok 24 - tied hint hash is copied to inner scope\n";
+ %^H = ();
+ tie( %^H, 'namespace::clean::_TieHintHash' );
+ $^H{foo} = "bar";
+ }
+ {
+ BEGIN{
+ print
+ "not " x ($^H{foo} ne 'bar'),
+ "ok 25 - tied empty hint hash is copied to inner scope\n"
+ }
+ }
+ 1;
+ }
+ 1;
+` or warn $@;
+print "ok 26 - no crash when cloning a tied hint hash\n";
+
+{
+ my $w;
+ local $SIG{__WARN__} = sub { $w = shift };
+ eval q`
+ package namespace::clean::_TieHintHasi;
+
+ sub TIEHASH { bless[] }
+ sub STORE { $_[0][0]{$_[1]} = $_[2] }
+ sub FETCH { $_[0][0]{$_[1]} }
+ sub FIRSTKEY { my $a = scalar keys %{$_[0][0]}; each %{$_[0][0]} }
+ # Intentionally commented out:
+ # sub NEXTKEY { each %{$_[0][0]} }
+
+ package main;
+
+ BEGIN {
+ $^H{foo} = "bar"; # activate localisation magic
+ tie( %^H, 'namespace::clean::_TieHintHasi' ); # sabotage %^H
+ $^H{foo} = "bar"; # create an element in the tied hash
+ }
+ { ; } # clone the tied hint hash
+ `;
+ print "not " if $w;
+ print "ok 27 - double-freeing explosive tied hints hash\n";
+ print "# got: $w" if $w;
+}
+
+# Setting ${^WARNING_HINTS} to its own value should not change things.
+{
+ my $w;
+ local $SIG{__WARN__} = sub { $w++ };
+ BEGIN {
+ # should have no effect:
+ my $x = ${^WARNING_BITS};
+ ${^WARNING_BITS} = $x;
+ }
+ {
+ local $^W = 1;
+ () = 1 + undef;
+ }
+ print "# ", $w//'no', " warnings\nnot " unless $w == 1;
+ print "ok 28 - ",
+ "setting \${^WARNING_BITS} to its own value has no effect\n";
+}
+
+# [perl #112326]
+# this code could cause a crash, due to PL_hints continuing to point to th
+# hints hash currently being freed
+
+{
+ package Foo;
+ my @h = qw(a 1 b 2);
+ BEGIN {
+ $^H{FOO} = bless {};
+ }
+ sub DESTROY {
+ @h = %^H;
+ delete $INC{strict}; require strict; # boom!
+ }
+ my $h = join ':', %h;
+ # this isn't the main point of the test; the main point is that
+ # it doesn't crash!
+ print "not " if $h ne '';
+ print "ok 29 - #112326\n";
+}
+
+
+# [perl #112444]
+# A destructor called while %^H is freed should not be able to stop %^H
+# from being magical (due to *^H{HASH} being undef).
+{
+ BEGIN {
+ # Make sure %^H is clear and not localised, to begin with
+ %^H = ();
+ $^H = 0;
+ }
+ DESTROY { %^H }
+ {
+ {
+ BEGIN {
+ $^H{foom} = bless[];
+ }
+ } # scope exit triggers destructor, which autovivifies a non-
+ # magical %^H
+ BEGIN {
+ # Here we have the %^H created by DESTROY, which is
+ # not localised
+ $^H{112444} = 'baz';
+ }
+ } # %^H leaks on scope exit
+ BEGIN { @keez = keys %^H }
+}
+print "not " if @keez;
+print "ok 30 - %^H does not leak when autovivified in destructor\n";
+print "# keys are: @keez\n" if @keez;
+
+
# Add new tests above this require, in case it fails.
require './test.pl';
@@ -135,7 +278,7 @@
stderr => 1
);
print "not " if length $result;
-print "ok 24 - double-freeing hints hash\n";
+print "ok 31 - double-freeing hints hash\n";
print "# got: $result\n" if length $result;
__END__
Property changes on: trunk/contrib/perl/t/comp/hints.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/t/comp/line_debug.t
===================================================================
--- trunk/contrib/perl/t/comp/line_debug.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/comp/line_debug.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/comp/line_debug.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/comp/line_debug_0.aux
===================================================================
--- trunk/contrib/perl/t/comp/line_debug_0.aux 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/comp/line_debug_0.aux 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/comp/line_debug_0.aux
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/comp/multiline.t
===================================================================
--- trunk/contrib/perl/t/comp/multiline.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/comp/multiline.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/comp/multiline.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/t/comp/opsubs.t
===================================================================
--- trunk/contrib/perl/t/comp/opsubs.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/comp/opsubs.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/comp/opsubs.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/t/comp/our.t
===================================================================
--- trunk/contrib/perl/t/comp/our.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/comp/our.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/comp/our.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/t/comp/package.t
===================================================================
--- trunk/contrib/perl/t/comp/package.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/comp/package.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/comp/package.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/t/comp/package_block.t
===================================================================
--- trunk/contrib/perl/t/comp/package_block.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/comp/package_block.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/comp/package_block.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/comp/parser.t
===================================================================
--- trunk/contrib/perl/t/comp/parser.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/comp/parser.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -3,7 +3,7 @@
# Checks if the parser behaves correctly in edge cases
# (including weird syntax errors)
-print "1..123\n";
+print "1..154\n";
sub failed {
my ($got, $expected, $name) = @_;
@@ -69,6 +69,13 @@
like( $@, qr/^Missing braces on \\N/,
'syntax error in string with incomplete \N' );
+eval q/"\o{"/;
+like( $@, qr/^Missing right brace on \\o/,
+ 'syntax error in string with incomplete \o' );
+eval q/"\ofoo"/;
+like( $@, qr/^Missing braces on \\o/,
+ 'syntax error in string with incomplete \o' );
+
eval "a.b.c.d.e.f;sub";
like( $@, qr/^Illegal declaration of anonymous subroutine/,
'found by Markov chain stress testing' );
@@ -125,11 +132,11 @@
is("${a}[", "A[", "interpolation, qq//");
my @b=("B");
is("@{b}{", "B{", "interpolation, qq//");
- is(qr/${a}{/, '(?^:A{)', "interpolation, qr//");
+ is(qr/${a}\{/, '(?^:A\{)', "interpolation, qr//");
my $c = "A{";
- $c =~ /${a}{/;
+ $c =~ /${a}\{/;
is($&, 'A{', "interpolation, m//");
- $c =~ s/${a}{/foo/;
+ $c =~ s/${a}\{/foo/;
is($c, 'foo', "interpolation, s/...//");
$c =~ s/foo/${a}{/;
is($c, 'A{', "interpolation, s//.../");
@@ -311,9 +318,9 @@
eval qq[ %$xFC ];
like($@, qr/Identifier too long/, "too long id in % sigil ctx");
- eval qq[ \\&$xFC ]; # take a ref since I don't want to call it
- is($@, "", "252 character & sigil ident ok");
- eval qq[ \\&$xFD ];
+ eval qq[ \\&$xFB ]; # take a ref since I don't want to call it
+ is($@, "", "251 character & sigil ident ok");
+ eval qq[ \\&$xFC ];
like($@, qr/Identifier too long/, "too long id in & sigil ctx");
eval qq[ *$xFC ];
@@ -341,6 +348,12 @@
is(defined &zlonk, '', 'but no body defined');
}
+# [perl #113016] CORE::print::foo
+sub CORE'print'foo { 43 } # apostrophes intentional; do not tempt fate
+sub CORE'foo'bar { 43 }
+is CORE::print::foo, 43, 'CORE::print::foo is not CORE::print ::foo';
+is scalar eval "CORE::foo'bar", 43, "CORE::foo'bar is not an error";
+
# bug #71748
eval q{
$_ = "";
@@ -353,8 +366,92 @@
};
is($@, "", "multiline whitespace inside substitute expression");
-# Add new tests HERE:
+eval '@A =~ s/a/b/; # compilation error
+ sub tahi {}
+ sub rua;
+ sub toru ($);
+ sub wha :lvalue;
+ sub rima ($%&*$&*\$%\*&$%*&) :method;
+ sub ono :lvalue { die }
+ sub whitu (_) { die }
+ sub waru ($;) :method { die }
+ sub iwa { die }
+ BEGIN { }';
+is $::{tahi}, undef, 'empty sub decl ignored after compilation error';
+is $::{rua}, undef, 'stub decl ignored after compilation error';
+is $::{toru}, undef, 'stub+proto decl ignored after compilation error';
+is $::{wha}, undef, 'stub+attr decl ignored after compilation error';
+is $::{rima}, undef, 'stub+proto+attr ignored after compilation error';
+is $::{ono}, undef, 'sub decl with attr ignored after compilation error';
+is $::{whitu}, undef, 'sub decl w proto ignored after compilation error';
+is $::{waru}, undef, 'sub w attr+proto ignored after compilation error';
+is $::{iwa}, undef, 'non-empty sub decl ignored after compilation error';
+is *BEGIN{CODE}, undef, 'BEGIN leaves no stub after compilation error';
+$test = $test + 1;
+"ok $test - format inside re-eval" =~ /(?{
+ format =
+@<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+$_
+.
+write
+}).*/;
+
+eval '
+"${;
+
+=pod
+
+=cut
+
+}";
+';
+is $@, "", 'pod inside string in string eval';
+"${;
+
+=pod
+
+=cut
+
+}";
+print "ok ", ++$test, " - pod inside string outside of string eval\n";
+
+like "blah blah blah\n", qr/${\ <<END
+blah blah blah
+END
+ }/, 'here docs in multiline quoted construct';
+like "blah blah blah\n", eval q|qr/${\ <<END
+blah blah blah
+END
+ }/|, 'here docs in multiline quoted construct in string eval';
+
+# Unterminated here-docs in subst in eval; used to crash
+eval 's/${<<END}//';
+eval 's//${<<END}/';
+print "ok ", ++$test, " - unterminated here-docs in s/// in string eval\n";
+
+sub 'Hello'_he_said (_);
+is prototype "Hello::_he_said", '_', 'initial tick in sub declaration';
+
+{
+ my @x = 'string';
+ is(eval q{ "$x[0]->strung" }, 'string->strung',
+ 'literal -> after an array subscript within ""');
+ @x = ['string'];
+ # this used to give "string"
+ like("$x[0]-> [0]", qr/^ARRAY\([^)]*\)-> \[0]\z/,
+ 'literal -> [0] after an array subscript within ""');
+}
+
+eval 'no if $] >= 5.17.4 warnings => "deprecated"';
+is 1,1, ' no crash for "no ... syntax error"';
+
+for my $pkg(()){}
+$pkg = 3;
+is $pkg, 3, '[perl #114942] for my $foo()){} $foo';
+
+# Add new tests HERE (above this line)
+
# bug #74022: Loop on characters in \p{OtherIDContinue}
# This test hangs if it fails.
eval chr 0x387;
@@ -437,15 +534,16 @@
check(qr/^Great hail!.*no more\.$/, 61, "Overflow both small buffer checks");
EOSTANZA
-{
- my @x = 'string';
- is(eval q{ "$x[0]->strung" }, 'string->strung',
- 'literal -> after an array subscript within ""');
- @x = ['string'];
- # this used to give "string"
- like("$x[0]-> [0]", qr/^ARRAY\([^)]*\)-> \[0]\z/,
- 'literal -> [0] after an array subscript within ""');
-}
+#line 531 parser.t
+<<EOU; check('parser\.t', 531, 'on same line as heredoc');
+EOU
+s//<<EOV/e if 0;
+EOV
+check('parser\.t', 535, 'after here-doc in quotes');
+<<EOW;
+${check('parser\.t', 537, 'first line of interp in here-doc');;
+ check('parser\.t', 538, 'second line of interp in here-doc');}
+EOW
__END__
# Don't add new tests HERE. See note above
Property changes on: trunk/contrib/perl/t/comp/parser.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/comp/proto.t
===================================================================
--- trunk/contrib/perl/t/comp/proto.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/comp/proto.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -18,7 +18,7 @@
# strict
use strict;
-print "1..172\n";
+print "1..180\n";
my $i = 1;
@@ -409,10 +409,26 @@
print "# CORE::open => ($p)\nnot " if ($p = prototype('CORE::open')) ne '*;$@';
print "ok ", $i++, "\n";
-print "# CORE:Foo => ($p), \$@ => `$@'\nnot "
+print "# CORE::Foo => ($p), \$@ => '$@'\nnot "
if defined ($p = eval { prototype('CORE::Foo') or 1 }) or $@ !~ /^Can't find an opnumber/;
print "ok ", $i++, "\n";
+eval { prototype("CORE::a\0b") };
+print "# CORE::a\\0b: \$@ => '$@'\nnot "
+ if $@ !~ /^Can't find an opnumber for "a\0b"/;
+print "ok ", $i++, "\n";
+
+eval { prototype("CORE::\x{100}") };
+print "# CORE::\\x{100}: => ($p), \$@ => '$@'\nnot "
+ if $@ !~ /^Can't find an opnumber for "\x{100}"/;
+print "ok ", $i++, "\n";
+
+"CORE::Foo" =~ /(.*)/;
+print "# \$1 containing CORE::Foo => ($p), \$@ => '$@'\nnot "
+ if defined ($p = eval { prototype($1) or 1 })
+ or $@ !~ /^Can't find an opnumber/;
+print "ok ", $i++, " - \$1 containing CORE::Foo\n";
+
# correctly note too-short parameter lists that don't end with '$',
# a possible regression.
@@ -544,6 +560,10 @@
sreftest my $sref, $i++;
sreftest($helem{$i}, $i++);
sreftest $aelem[0], $i++;
+ sreftest sub { [0] }->()[0], $i++;
+ sreftest my $a = 'quidgley', $i++;
+ print "not " if eval 'return 1; sreftest(3+4)';
+ print "ok ", $i++, ' - \$ with invalid argument', "\n";
}
# test single term
@@ -587,14 +607,6 @@
}
}
-# Not $$;$;$
-print "not " unless prototype "CORE::substr" eq '$$;$$';
-print "ok ", $i++, "\n";
-
-# recv takes a scalar reference for its second argument
-print "not " unless prototype "CORE::recv" eq '*\\$$$';
-print "ok ", $i++, "\n";
-
{
my $myvar;
my @myarray;
@@ -606,6 +618,8 @@
print "not " unless myref($myvar) =~ /^SCALAR\(/;
print "ok ", $i++, "\n";
+ print "not " unless myref($myvar=7) =~ /^SCALAR\(/;
+ print "ok ", $i++, "\n";
print "not " unless myref(@myarray) =~ /^ARRAY\(/;
print "ok ", $i++, "\n";
print "not " unless myref(%myhash) =~ /^HASH\(/;
@@ -702,6 +716,17 @@
unless eval 'sub uniproto9 (;+) {} uniproto9 $_, 1' or warn $@;
print "ok ", $i++, "\n";
+# Test that a trailing semicolon makes a sub have listop precedence
+sub unilist ($;) { $_[0]+1 }
+sub unilist2(_;) { $_[0]+1 }
+sub unilist3(;$;) { $_[0]+1 }
+print "not " unless (unilist 0 || 5) == 6;
+print "ok ", $i++, "\n";
+print "not " unless (unilist2 0 || 5) == 6;
+print "ok ", $i++, "\n";
+print "not " unless (unilist3 0 || 5) == 6;
+print "ok ", $i++, "\n";
+
{
# Lack of prototype on a subroutine definition should override any prototype
# on the declaration.
Property changes on: trunk/contrib/perl/t/comp/proto.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/t/comp/redef.t
===================================================================
--- trunk/contrib/perl/t/comp/redef.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/comp/redef.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/comp/redef.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/comp/require.t
===================================================================
--- trunk/contrib/perl/t/comp/require.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/comp/require.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -22,7 +22,7 @@
my $Is_EBCDIC = (ord('A') == 193) ? 1 : 0;
my $Is_UTF8 = (${^OPEN} || "") =~ /:utf8/;
-my $total_tests = 51;
+my $total_tests = 54;
if ($Is_EBCDIC || $Is_UTF8) { $total_tests -= 3; }
print "1..$total_tests\n";
@@ -36,61 +36,66 @@
eval {require 5.005};
print "# $@\nnot " if $@;
-print "ok ",$i++,"\n";
+print "ok ",$i++," - require 5.005 try 1\n";
eval { require 5.005 };
print "# $@\nnot " if $@;
-print "ok ",$i++,"\n";
+print "ok ",$i++," - require 5.005 try 2\n";
eval { require 5.005; };
print "# $@\nnot " if $@;
-print "ok ",$i++,"\n";
+print "ok ",$i++," - require 5.005 try 3\n";
eval {
require 5.005
};
print "# $@\nnot " if $@;
-print "ok ",$i++,"\n";
+print "ok ",$i++," - require 5.005 try 4\n";
# new style version numbers
eval { require v5.5.630; };
print "# $@\nnot " if $@;
-print "ok ",$i++,"\n";
+print "ok ",$i++," - require 5.5.630\n";
+sub v5 { die }
+eval { require v5; };
+print "# $@\nnot " if $@;
+print "ok ",$i++," - require v5 ignores sub named v5\n";
+
eval { require 10.0.2; };
print "# $@\nnot " unless $@ =~ /^Perl v10\.0\.2 required/;
-print "ok ",$i++,"\n";
+print "ok ",$i++," - require 10.0.2\n";
my $ver = 5.005_63;
eval { require $ver; };
print "# $@\nnot " if $@;
-print "ok ",$i++,"\n";
+print "ok ",$i++," - require 5.005_63\n";
# check inaccurate fp
$ver = 10.2;
eval { require $ver; };
print "# $@\nnot " unless $@ =~ /^Perl v10\.200.0 required/;
-print "ok ",$i++,"\n";
+print "ok ",$i++," - require 10.2\n";
$ver = 10.000_02;
eval { require $ver; };
print "# $@\nnot " unless $@ =~ /^Perl v10\.0\.20 required/;
-print "ok ",$i++,"\n";
+print "ok ",$i++," - require 10.000_02\n";
print "not " unless 5.5.1 gt v5.5;
-print "ok ",$i++,"\n";
+print "ok ",$i++," - 5.5.1 gt v5.5\n";
{
print "not " unless v5.5.640 eq "\x{5}\x{5}\x{280}";
- print "ok ",$i++,"\n";
+ print "ok ",$i++," - v5.5.640 eq \\x{5}\\x{5}\\x{280}\n";
print "not " unless v7.15 eq "\x{7}\x{f}";
- print "ok ",$i++,"\n";
+ print "ok ",$i++," - v7.15 eq \\x{7}\\x{f}\n";
print "not "
unless v1.20.300.4000.50000.600000 eq "\x{1}\x{14}\x{12c}\x{fa0}\x{c350}\x{927c0}";
- print "ok ",$i++,"\n";
+ print "ok ",$i++," - v1.20.300.4000.50000.600000 eq ...\n";
}
# "use 5.11.0" (and higher) loads strictures.
@@ -97,13 +102,13 @@
# check that this doesn't happen with require
eval 'require 5.11.0; ${"foo"} = "bar";';
print "# $@\nnot " if $@;
-print "ok ",$i++,"\n";
+print "ok ",$i++," - require 5.11.0\n";
eval 'BEGIN {require 5.11.0} ${"foo"} = "bar";';
print "# $@\nnot " if $@;
-print "ok ",$i++,"\n";
+print "ok ",$i++,"\ - BEGIN { require 5.11.0}\n";
# interaction with pod (see the eof)
-write_file('bleah.pm', "print 'ok $i\n'; 1;\n");
+write_file('bleah.pm', "print 'ok $i - require bleah.pm\n'; 1;\n");
require "bleah.pm";
$i++;
@@ -110,10 +115,10 @@
# run-time failure in require
do_require "0;\n";
print "# $@\nnot " unless $@ =~ /did not return a true/;
-print "ok ",$i++,"\n";
+print "ok ",$i++," - require returning 0\n";
print "not " if exists $INC{'bleah.pm'};
-print "ok ",$i++,"\n";
+print "ok ",$i++," - %INC not updated\n";
my $flag_file = 'bleah.flg';
# run-time error in require
@@ -120,14 +125,14 @@
for my $expected_compile (1,0) {
write_file($flag_file, 1);
print "not " unless -e $flag_file;
- print "ok ",$i++,"\n";
+ print "ok ",$i++," - exp $expected_compile; bleah.flg\n";
write_file('bleah.pm', "unlink '$flag_file' or die; \$a=0; \$b=1/\$a; 1;\n");
print "# $@\nnot " if eval { require 'bleah.pm' };
- print "ok ",$i++,"\n";
+ print "ok ",$i++," - exp $expected_compile; require bleah.pm with flag file\n";
print "not " unless -e $flag_file xor $expected_compile;
- print "ok ",$i++,"\n";
+ print "ok ",$i++," - exp $expected_compile; -e flag_file\n";
print "not " unless exists $INC{'bleah.pm'};
- print "ok ",$i++,"\n";
+ print "ok ",$i++," - exp $expected_compile; exists \$INC{'bleah.pm}\n";
}
# compile-time failure in require
@@ -135,31 +140,31 @@
# bison says 'parse error' instead of 'syntax error',
# various yaccs may or may not capitalize 'syntax'.
print "# $@\nnot " unless $@ =~ /(syntax|parse) error/mi;
-print "ok ",$i++,"\n";
+print "ok ",$i++," - syntax error\n";
# previous failure cached in %INC
print "not " unless exists $INC{'bleah.pm'};
-print "ok ",$i++,"\n";
+print "ok ",$i++," - cached %INC\n";
write_file($flag_file, 1);
write_file('bleah.pm', "unlink '$flag_file'; 1");
print "# $@\nnot " if eval { require 'bleah.pm' };
-print "ok ",$i++,"\n";
+print "ok ",$i++," - eval { require 'bleah.pm' }\n";
print "# $@\nnot " unless $@ =~ /Compilation failed/i;
-print "ok ",$i++,"\n";
+print "ok ",$i++," - Compilation failed\n";
print "not " unless -e $flag_file;
-print "ok ",$i++,"\n";
+print "ok ",$i++," - -e flag_file\n";
print "not " unless exists $INC{'bleah.pm'};
-print "ok ",$i++,"\n";
+print "ok ",$i++," - \$INC{'bleah.pm'}\n";
# successful require
do_require "1";
print "# $@\nnot " if $@;
-print "ok ",$i++,"\n";
+print "ok ",$i++," - do_require '1';\n";
# do FILE shouldn't see any outside lexicals
-my $x = "ok $i\n";
+my $x = "ok $i - bleah.do\n";
write_file("bleah.do", <<EOT);
-\$x = "not ok $i\\n";
+\$x = "not ok $i - bleah.do\\n";
EOT
do "bleah.do" or die $@;
dofile();
@@ -189,9 +194,9 @@
eval { require $r };
$i++;
if($@ =~ /Can't locate threads in \@INC/) {
- print "ok $i\n";
+ print "ok $i - RT #24404\n";
} else {
- print "not ok $i\n";
+ print "not ok - RT #24404$i\n";
}
@@ -199,15 +204,15 @@
delete $INC{"bleah.pm"}; ++$::i;
eval { CORE::require bleah; };
if ($@ =~ /^This is an expected error/) {
- print "ok $i\n";
+ print "ok $i - expected error\n";
} else {
- print "not ok $i\n";
+ print "not ok $i - expected error\n";
}
sub write_file_not_thing {
my ($file, $thing, $test) = @_;
write_file($file, <<"EOT");
- print "not ok $test\n";
+ print "not ok $test - write_file_not_thing $file\n";
die "The $thing file should not be loaded";
EOT
}
@@ -226,18 +231,18 @@
if ($ccflags =~ /(?:^|\s)-DPERL_DISABLE_PMC\b/) {
print "# .pmc files are ignored, so test that\n";
write_file_not_thing('krunch.pmc', '.pmc', $pmc_older);
- write_file('urkkk.pm', qq(print "ok $simple\n"));
+ write_file('urkkk.pm', qq(print "ok $simple - urkkk.pm branch A\n"));
write_file('whap.pmc', qq(die "This is not an expected error"));
print "# Sleeping for 2 seconds before creating some more files\n";
sleep 2;
- write_file('krunch.pm', qq(print "ok $pmc_older\n"));
+ write_file('krunch.pm', qq(print "ok $pmc_older - krunch.pm branch A\n"));
write_file_not_thing('urkkk.pmc', '.pmc', $simple);
write_file('whap.pm', qq(die "This is an expected error"));
} else {
print "# .pmc files should be loaded, so test that\n";
- write_file('krunch.pmc', qq(print "ok $pmc_older\n";));
+ write_file('krunch.pmc', qq(print "ok $pmc_older - krunch.pm branch B\n";));
write_file_not_thing('urkkk.pm', '.pm', $simple);
write_file('whap.pmc', qq(die "This is an expected error"));
@@ -245,7 +250,7 @@
sleep 2;
write_file_not_thing('krunch.pm', '.pm', $pmc_older);
- write_file('urkkk.pmc', qq(print "ok $simple\n";));
+ write_file('urkkk.pmc', qq(print "ok $simple - urkkk.pm branch B\n";));
write_file_not_thing('whap.pm', '.pm', $pmc_dies);
}
require urkkk;
@@ -253,26 +258,48 @@
eval {CORE::require whap; 1} and die;
if ($@ =~ /^This is an expected error/) {
- print "ok $pmc_dies\n";
+ print "ok $pmc_dies - pmc_dies\n";
} else {
- print "not ok $pmc_dies\n";
+ print "not ok $pmc_dies - pmc_dies\n";
}
}
# Test "require func()" with abs path when there is no .pmc file.
++$::i;
-require Cwd;
-require File::Spec::Functions;
-eval {
- CORE::require(File::Spec::Functions::catfile(Cwd::getcwd(),"bleah.pm"));
-};
-if ($@ =~ /^This is an expected error/) {
- print "ok $i\n";
+if (defined &DynaLoader::boot_DynaLoader) {
+ require Cwd;
+ require File::Spec::Functions;
+ eval {
+ CORE::require(File::Spec::Functions::catfile(Cwd::getcwd(),"bleah.pm"));
+ };
+ if ($@ =~ /^This is an expected error/) {
+ print "ok $i - require(func())\n";
+ } else {
+ print "not ok $i - require(func())\n";
+ }
} else {
- print "not ok $i\n";
+ print "ok $i # SKIP Cwd may not be available in miniperl\n";
}
+{
+ BEGIN { ${^OPEN} = ":utf8\0"; }
+ %INC = ();
+ write_file('bleah.pm',"package F; \$x = '\xD1\x9E';\n");
+ eval { require "bleah.pm" };
+ $i++;
+ my $not = $F::x eq "\xD1\x9E" ? "" : "not ";
+ print "${not}ok $i - require ignores I/O layers\n";
+}
+{
+ BEGIN { ${^OPEN} = ":utf8\0"; }
+ %INC = ();
+ write_file('bleah.pm',"require re; re->import('/x'); 1;\n");
+ my $not = eval 'use bleah; "ab" =~ /a b/' ? "" : "not ";
+ $i++;
+ print "${not}ok $i - require does not localise %^H at run time\n";
+}
+
##########################################
# What follows are UTF-8 specific tests. #
# Add generic tests before this point. #
Property changes on: trunk/contrib/perl/t/comp/require.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/comp/retainedlines.t
===================================================================
--- trunk/contrib/perl/t/comp/retainedlines.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/comp/retainedlines.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -6,7 +6,7 @@
# we've not yet verified that use works.
# use strict;
-print "1..73\n";
+print "1..74\n";
my $test = 0;
sub failed {
@@ -24,7 +24,7 @@
return;
}
-sub is {
+sub is($$$) {
my ($got, $expect, $name) = @_;
$test = $test + 1;
if (defined $expect) {
@@ -157,4 +157,7 @@
eval qq{#line 42 "hash-line-eval"\n labadalabada()\n};
is $::{"_<hash-line-eval"}[42], " labadalabada()\n",
'#line 42 "foo" in a string eval updates @{"_<foo"}';
+ eval qq{#line 42 "figgle"\n#line 85 "doggo"\n labadalabada()\n};
+ is $::{"_<doggo"}[85], " labadalabada()\n",
+ 'subsequent #line 42 "foo" in a string eval updates @{"_<foo"}';
}
Property changes on: trunk/contrib/perl/t/comp/retainedlines.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/t/comp/script.t (from rev 6437, vendor/perl/5.18.1/t/comp/script.t)
===================================================================
--- trunk/contrib/perl/t/comp/script.t (rev 0)
+++ trunk/contrib/perl/t/comp/script.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,29 @@
+#!./perl
+
+BEGIN {
+ chdir 't';
+ @INC = '../lib';
+ require './test.pl'; # for which_perl() etc
+}
+
+my $Perl = which_perl();
+
+my $filename = tempfile();
+
+print "1..3\n";
+
+$x = `$Perl -le "print 'ok';"`;
+
+if ($x eq "ok\n") {print "ok 1\n";} else {print "not ok 1\n";}
+
+open(try,">$filename") || (die "Can't open temp file.");
+print try 'print "ok\n";'; print try "\n";
+close try or die "Could not close: $!";
+
+$x = `$Perl $filename`;
+
+if ($x eq "ok\n") {print "ok 2\n";} else {print "not ok 2\n";}
+
+$x = `$Perl <$filename`;
+
+if ($x eq "ok\n") {print "ok 3\n";} else {print "not ok 3\n";}
Index: trunk/contrib/perl/t/comp/term.t
===================================================================
--- trunk/contrib/perl/t/comp/term.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/comp/term.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/comp/term.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/comp/uproto.t
===================================================================
--- trunk/contrib/perl/t/comp/uproto.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/comp/uproto.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,6 +1,6 @@
#!perl
-print "1..39\n";
+print "1..43\n";
my $test = 0;
sub failed {
@@ -19,10 +19,10 @@
}
sub like {
- my ($got, $pattern) = @_;
+ my ($got, $pattern, $name) = @_;
$test = $test + 1;
if (defined $got && $got =~ $pattern) {
- print "ok $test\n";
+ print "ok $test - $name\n";
# Principle of least surprise - maintain the expected interface, even
# though we aren't using it here (yet).
return 1;
@@ -31,17 +31,17 @@
}
sub is {
- my ($got, $expect) = @_;
+ my ($got, $expect, $name) = @_;
$test = $test + 1;
if (defined $expect) {
if (defined $got && $got eq $expect) {
- print "ok $test\n";
+ print "ok $test - $name\n";
return 1;
}
failed($got, "'$expect'", $name);
} else {
if (!defined $got) {
- print "ok $test\n";
+ print "ok $test - $name\n";
return 1;
}
failed($got, 'undef', $name);
@@ -72,7 +72,11 @@
like( $@, qr/Too many arguments for main::f at/ );
{
+ # We have not tested require/use/no yet, so we must avoid this:
+ # no warnings 'deprecated';
+ BEGIN { $SIG{__WARN__} = sub {} }
my $_ = "quarante-deux";
+ BEGIN { $SIG{__WARN__} = undef }
$foo = "FOO";
$bar = "BAR";
f("FOO quarante-deux", $foo);
@@ -97,7 +101,9 @@
g();
g;
undef $expected; &g; # $_ not passed
+BEGIN { $SIG{__WARN__} = sub {} }
{ $expected = my $_ = "bar"; g() }
+BEGIN { $SIG{__WARN__} = undef }
eval q{ sub wrong1 (_$); wrong1(1,2) };
like( $@, qr/Malformed prototype for main::wrong1/, 'wrong1' );
@@ -120,6 +126,21 @@
mymkdir($expected = "foo");
$expected = "foo 493"; mymkdir foo => 0755;
+sub mylist (_@) { is("@_", $expected, "mylist") }
+$expected = "foo";
+$_ = "foo";
+mylist();
+$expected = "10 11 12 13";
+mylist(10, 11 .. 13);
+
+sub mylist2 (_%) { is("@_", $expected, "mylist2") }
+$expected = "foo";
+$_ = "foo";
+mylist2();
+$expected = "10 a 1";
+my %hash = (a => 1);
+mylist2(10, %hash);
+
# $_ says modifiable, it's not passed by copy
sub double(_) { $_[0] *= 2 }
@@ -127,7 +148,9 @@
double();
is( $_, 42, '$_ is modifiable' );
{
+ BEGIN { $SIG{__WARN__} = sub {} }
my $_ = 22;
+ BEGIN { $SIG{__WARN__} = undef }
double();
is( $_, 44, 'my $_ is modifiable' );
}
Property changes on: trunk/contrib/perl/t/comp/uproto.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/comp/use.t
===================================================================
--- trunk/contrib/perl/t/comp/use.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/comp/use.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -6,7 +6,7 @@
$INC{"feature.pm"} = 1; # so we don't attempt to load feature.pm
}
-print "1..73\n";
+print "1..84\n";
# Can't require test.pl, as we're testing the use/require mechanism here.
@@ -22,6 +22,8 @@
$result = $got ne $expected;
} elsif ($type eq 'like') {
$result = $got =~ $expected;
+ } elsif ($type eq 'ok') {
+ $result = not not $got;
} else {
die "Unexpected type '$type'$name";
}
@@ -46,6 +48,8 @@
print "# Expected not '$expected'\n";
} elsif ($type eq 'like') {
print "# Expected $expected\n";
+ } elsif ($type eq 'ok') {
+ print "# Expected a true value\n";
}
}
$test = $test + 1;
@@ -61,6 +65,9 @@
sub isnt ($$;$) {
_ok ('isnt', @_);
}
+sub ok($;$) {
+ _ok ('ok', shift, undef, @_);
+}
eval "use 5"; # implicit semicolon
is ($@, '');
@@ -134,9 +141,35 @@
# and they are properly scoped
eval '{use 5.11.0;} ${"foo"} = "bar";';
is ($@, "");
+eval 'no strict; use 5.012; ${"foo"} = "bar"';
+is $@, "", 'explicit "no strict" overrides later ver decl';
+eval 'use strict; use 5.01; ${"foo"} = "bar"';
+like $@, qr/^Can't use string/,
+ 'explicit use strict overrides later use 5.01';
+eval 'use strict "subs"; use 5.012; ${"foo"} = "bar"';
+like $@, qr/^Can't use string/,
+ 'explicit use strict "subs" does not stop ver decl from enabling refs';
+eval 'use 5.012; use 5.01; ${"foo"} = "bar"';
+is $@, "", 'use 5.01 overrides implicit strict from prev ver decl';
+eval 'no strict "subs"; use 5.012; ${"foo"} = "bar"';
+ok $@, 'no strict subs allows ver decl to enable refs';
+eval 'no strict "subs"; use 5.012; $nonexistent_pack_var';
+ok $@, 'no strict subs allows ver decl to enable vars';
+eval 'no strict "refs"; use 5.012; fancy_bareword';
+ok $@, 'no strict refs allows ver decl to enable subs';
+eval 'no strict "refs"; use 5.012; $nonexistent_pack_var';
+ok $@, 'no strict refs allows ver decl to enable subs';
+eval 'no strict "vars"; use 5.012; ${"foo"} = "bar"';
+ok $@, 'no strict vars allows ver decl to enable refs';
+eval 'no strict "vars"; use 5.012; ursine_word';
+ok $@, 'no strict vars allows ver decl to enable subs';
+
{ use test_use } # check that subparse saves pending tokens
+use test_use { () };
+is ref $test_use::got[0], 'HASH', 'use parses arguments in term lexing cx';
+
local $test_use::VERSION = 1.0;
eval "use test_use 0.9";
Property changes on: trunk/contrib/perl/t/comp/use.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/t/comp/utf.t
===================================================================
--- trunk/contrib/perl/t/comp/utf.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/comp/utf.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/comp/utf.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/harness
===================================================================
--- trunk/contrib/perl/t/harness 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/harness 2013-12-02 21:26:09 UTC (rev 6439)
@@ -125,16 +125,16 @@
# ]
# };
- # but for now, run all directories in sequence. In particular, it would be
- # nice to get the tests in t/op/*.t able to run in parallel.
+ # but for now, run all directories in sequence.
unless (@tests) {
my @seq = <base/*.t>;
- my @next = qw(comp run cmd io re op uni mro lib porting);
+ my @next = qw(comp run cmd io re opbasic op uni mro lib porting);
push @next, 'japh' if $torture;
push @next, 'win32' if $^O eq 'MSWin32';
push @next, 'benchmark' if $ENV{PERL_BENCHMARK};
+ push @next, 'bigmem' if $ENV{PERL_TEST_MEMORY};
# Hopefully TAP::Parser::Scheduler will support this syntax soon.
# my $next = { par => '{' . join (',', @next) . '}/*.t' };
my $next = { par => [
Property changes on: trunk/contrib/perl/t/harness
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/t/io/argv.t
===================================================================
--- trunk/contrib/perl/t/io/argv.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/io/argv.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/io/argv.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/t/io/binmode.t
===================================================================
--- trunk/contrib/perl/t/io/binmode.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/io/binmode.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/io/binmode.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/t/io/bom.t
===================================================================
--- trunk/contrib/perl/t/io/bom.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/io/bom.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/io/bom.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/io/crlf.t
===================================================================
--- trunk/contrib/perl/t/io/crlf.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/io/crlf.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -12,8 +12,10 @@
my $file = tempfile();
+my $ungetc_count = 8200; # Somewhat over the likely buffer size
+
{
- plan(tests => 16);
+ plan(tests => 16 + 2 * $ungetc_count);
ok(open(FOO,">:crlf",$file));
ok(print FOO 'a'.((('a' x 14).qq{\n}) x 2000) || close(FOO));
ok(open(FOO,"<:crlf",$file));
@@ -42,6 +44,16 @@
$/ = "\n";
$s = <$fh>.<$fh>;
is($s, "\nxxy\n");
+
+ for my $i (0 .. $ungetc_count - 1) {
+ my $j = $i % 256;
+ is($fh->ungetc($j), $j, "ungetc of $j returns itself");
+ }
+
+ for (my $i = $ungetc_count - 1; $i >= 0; $i--) {
+ my $j = $i % 256;
+ is(ord($fh->getc()), $j, "getc gets back $j");
+ }
}
ok(close(FOO));
Property changes on: trunk/contrib/perl/t/io/crlf.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/t/io/crlf_through.t
===================================================================
--- trunk/contrib/perl/t/io/crlf_through.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/io/crlf_through.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/io/crlf_through.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/io/data.t
===================================================================
--- trunk/contrib/perl/t/io/data.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/io/data.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/io/data.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/io/defout.t
===================================================================
--- trunk/contrib/perl/t/io/defout.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/io/defout.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/io/defout.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/io/dup.t
===================================================================
--- trunk/contrib/perl/t/io/dup.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/io/dup.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/io/dup.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/io/eintr.t
===================================================================
--- trunk/contrib/perl/t/io/eintr.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/io/eintr.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -49,9 +49,11 @@
# Also skip on release builds, to avoid other possibly problematic
# platforms
-if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'cygwin' || $^O eq 'freebsd' ||
- ($^O eq 'solaris' && $Config{osvers} eq '2.8')
- || ((int($]*1000) & 1) == 0)
+my ($osmajmin) = $Config{osvers} =~ /^(\d+\.\d+)/;
+if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'cygwin' || $^O =~ /freebsd/ || $^O eq 'midnightbsd' ||
+ ($^O eq 'solaris' && $Config{osvers} eq '2.8') || $^O eq 'nto' ||
+ ($^O eq 'darwin' && $osmajmin < 9) ||
+ ((int($]*1000) & 1) == 0)
) {
skip_all('various portability issues');
exit 0;
Property changes on: trunk/contrib/perl/t/io/eintr.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/io/errno.t
===================================================================
--- trunk/contrib/perl/t/io/errno.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/io/errno.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -34,8 +34,6 @@
for my $rs_code ('', '$/=undef', '$/=\2', '$/=\1024') {
TODO:
{
- local $::TODO = "We get RMS\$_IOP at EOF on VMS when \$/ is undef"
- if $^O eq 'VMS' && $rs_code eq '$/=undef';
is( runperl( prog => "$rs_code; $test_prog",
stdin => $test_in, stderr => 1),
$test_in,
Property changes on: trunk/contrib/perl/t/io/errno.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/io/errnosig.t
===================================================================
--- trunk/contrib/perl/t/io/errnosig.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/io/errnosig.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/io/errnosig.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/io/fflush.t
===================================================================
--- trunk/contrib/perl/t/io/fflush.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/io/fflush.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/io/fflush.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/io/fs.t
===================================================================
--- trunk/contrib/perl/t/io/fs.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/io/fs.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -46,7 +46,7 @@
my $skip_mode_checks =
$^O eq 'cygwin' && $ENV{CYGWIN} !~ /ntsec/;
-plan tests => 51;
+plan tests => 52;
my $tmpdir = tempfile();
my $tmpdir1 = tempfile();
@@ -72,7 +72,7 @@
umask(022);
SKIP: {
- skip "bogus umask", 1 if ($^O eq 'MSWin32') || ($^O eq 'NetWare') || ($^O eq 'epoc');
+ skip "bogus umask", 1 if ($^O eq 'MSWin32') || ($^O eq 'NetWare');
is((umask(0)&0777), 022, 'umask'),
}
@@ -275,7 +275,7 @@
is( $atime, 500000001, 'atime' );
is( $mtime, 500000000 + $delta, 'mtime' );
}
- elsif ($^O eq 'beos' || $^O eq 'haiku') {
+ elsif ($^O eq 'haiku') {
SKIP: {
skip "atime not updated", 1;
}
@@ -372,7 +372,7 @@
SKIP: {
if ($^O eq 'vos') {
- skip ("# TODO - hit VOS bug posix-973 - cannot resize an open file below the current file pos.", 5);
+ skip ("# TODO - hit VOS bug posix-973 - cannot resize an open file below the current file pos.", 6);
}
is(-s $tmpfile, 200, "fh resize to 200 working (filename check)");
@@ -407,6 +407,14 @@
is(-s $tmpfile, 100, "fh resize by IO slot working");
close FH;
+
+ my $n = "for_fs_dot_t$$";
+ open FH, ">$n" or die "open $n: $!";
+ print FH "bloh blah bla\n";
+ close FH or die "close $n: $!";
+ eval "truncate $n, 0; 1" or die;
+ ok !-z $n, 'truncate(word) does not fall back to file name';
+ unlink $n;
}
}
Property changes on: trunk/contrib/perl/t/io/fs.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/io/inplace.t
===================================================================
--- trunk/contrib/perl/t/io/inplace.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/io/inplace.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -35,9 +35,9 @@
SKIP:
{
- # based on code, dosish and epoc systems can't do no-backup inplace
+ # based on code, dosish systems can't do no-backup inplace
# edits
- $^O =~ /^(MSWin32|cygwin|uwin|dos|epoc|os2)$/
+ $^O =~ /^(MSWin32|cygwin|uwin|dos|os2)$/
and skip("Can't inplace edit without backups on $^O", 4);
our @ifiles = ( tempfile(), tempfile(), tempfile() );
Property changes on: trunk/contrib/perl/t/io/inplace.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/t/io/iofile.t
===================================================================
--- trunk/contrib/perl/t/io/iofile.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/io/iofile.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/io/iofile.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/io/iprefix.t
===================================================================
--- trunk/contrib/perl/t/io/iprefix.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/io/iprefix.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/io/iprefix.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/io/layers.t
===================================================================
--- trunk/contrib/perl/t/io/layers.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/io/layers.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -35,7 +35,7 @@
} else {
$UTF8_STDIN = 0;
}
-my $NTEST = 55 - (($DOSISH || !$FASTSTDIO) ? 7 : 0) - ($DOSISH ? 7 : 0)
+my $NTEST = 60 - (($DOSISH || !$FASTSTDIO) ? 7 : 0) - ($DOSISH ? 7 : 0)
+ $UTF8_STDIN;
sub PerlIO::F_UTF8 () { 0x00008000 } # from perliol.h
@@ -227,4 +227,27 @@
open(UTF, "<:raw:encoding(utf8)", '$afile') or die \$!;
print ref *PerlIO::Layer::NoWarnings{CODE};
EOT
+
+ # [perl #97956] Not calling FETCH all the time on tied variables
+ my $f;
+ sub TIESCALAR { bless [] }
+ sub FETCH { ++$f; $_[0][0] = $_[1] }
+ sub STORE { $_[0][0] }
+ tie my $t, "";
+ $t = *f;
+ $f = 0; PerlIO::get_layers $t;
+ is $f, 1, '1 fetch on tied glob';
+ $t = \*f;
+ $f = 0; PerlIO::get_layers $t;
+ is $f, 1, '1 fetch on tied globref';
+ $t = *f;
+ $f = 0; PerlIO::get_layers \$t;
+ is $f, 1, '1 fetch on referenced tied glob';
+ $t = '';
+ $f = 0; PerlIO::get_layers $t;
+ is $f, 1, '1 fetch on tied string';
+
+ # No distinction between nums and strings
+ open "12", "<:crlf", "test.pl" or die "$0 cannot open test.pl: $!";
+ ok PerlIO::get_layers(12), 'str/num arguments are treated identically';
}
Property changes on: trunk/contrib/perl/t/io/layers.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/t/io/nargv.t
===================================================================
--- trunk/contrib/perl/t/io/nargv.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/io/nargv.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/io/nargv.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/io/open.t
===================================================================
--- trunk/contrib/perl/t/io/open.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/io/open.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -10,7 +10,7 @@
use warnings;
use Config;
-plan tests => 114;
+plan tests => 121;
my $Perl = which_perl();
@@ -105,7 +105,16 @@
ok( !eval { open my $f, '<&', $afile; 1; }, '<& on a non-filehandle' );
like( $@, qr/Bad filehandle:\s+$afile/, ' right error' );
+ok( !eval { *some_glob = 1; open my $f, '<&', *some_glob; 1; }, '<& on a non-filehandle glob' );
+like( $@, qr/Bad filehandle:\s+some_glob/, ' right error' );
+{
+ use utf8;
+ use open qw( :utf8 :std );
+ ok( !eval { use utf8; *ǡfilḛ = 1; open my $f, '<&', *ǡfilḛ; 1; }, '<& on a non-filehandle glob' );
+ like( $@, qr/Bad filehandle:\s+ǡfilḛ/u, ' right error' );
+}
+
# local $file tests
{
unlink($afile) if -f $afile;
@@ -224,6 +233,10 @@
# used to try to open a file [perl #17830]
ok( open(my $stdin, "<&", fileno STDIN), 'dup fileno(STDIN) into lexical fh') or _diag $!;
+
+ fileno(STDIN) =~ /(.)/;
+ ok open($stdin, "<&", $1), 'open ... "<&", $magical_fileno',
+ || _diag $!;
}
SKIP: {
@@ -258,7 +271,7 @@
open($fh1{k}, "TEST");
gimme($fh1{k});
- like($@, qr/<\$fh1{...}> line 1\./, "autoviv fh package helem");
+ like($@, qr/<\$fh1\{...}> line 1\./, "autoviv fh package helem");
my @fh2;
open($fh2[0], "TEST");
@@ -268,7 +281,12 @@
my %fh3;
open($fh3{k}, "TEST");
gimme($fh3{k});
- like($@, qr/<\$fh3{...}> line 1\./, "autoviv fh lexical helem");
+ like($@, qr/<\$fh3\{...}> line 1\./, "autoviv fh lexical helem");
+
+ local $/ = *F; # used to cause an assertion failure
+ gimme($fh3{k});
+ like($@, qr/<\$fh3\{...}> chunk 2\./,
+ '<...> line 1 when $/ is set to a glob');
}
SKIP: {
@@ -309,6 +327,15 @@
eval { open $99, "foo" };
like($@, qr/Modification of a read-only value attempted/, "readonly fh");
+# But we do not want that exception applying to close(), since it does not
+# modify the fh.
+eval {
+ no warnings "uninitialized";
+ # make sure $+ is undefined
+ "a" =~ /(b)?/;
+ close $+
+};
+is($@, '', 'no "Modification of a read-only value" when closing');
# [perl#73626] mg_get wasn't run on the pipe arg
Property changes on: trunk/contrib/perl/t/io/open.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/t/io/openpid.t
===================================================================
--- trunk/contrib/perl/t/io/openpid.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/io/openpid.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/io/openpid.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/io/perlio.t
===================================================================
--- trunk/contrib/perl/t/io/perlio.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/io/perlio.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -6,7 +6,7 @@
skip_all_without_perlio();
}
-plan tests => 42;
+plan tests => 45;
use_ok('PerlIO');
@@ -132,7 +132,7 @@
SKIP: {
eval { require PerlIO::scalar };
unless (find PerlIO::Layer 'scalar') {
- skip("PerlIO::scalar not found", 9);
+ skip("PerlIO::scalar not found", 11);
}
my $var;
ok( open(my $x,"+<",\$var), 'magic in-memory file via 3 arg open with \\$var');
@@ -168,10 +168,10 @@
}
-{ local $TODO = 'fails well back into 5.8.x';
+ { local $TODO = 'fails well back into 5.8.x';
-sub read_fh_and_return_final_rv {
+ sub read_fh_and_return_final_rv {
my ($fh) = @_;
my $buf = '';
my $rv;
@@ -180,20 +180,42 @@
next if $rv;
}
return $rv
-}
+ }
-open(my $no_perlio, '<', \'ab') or die;
-open(my $perlio, '<:crlf', \'ab') or die;
+ open(my $no_perlio, '<', \'ab') or die;
+ open(my $perlio, '<:crlf', \'ab') or die;
-is(read_fh_and_return_final_rv($perlio), read_fh_and_return_final_rv($no_perlio), "RT#69332 - perlio should return the same value as nonperlio after EOF");
+ is(read_fh_and_return_final_rv($perlio),
+ read_fh_and_return_final_rv($no_perlio),
+ "RT#69332 - perlio should return the same value as nonperlio after EOF");
-close ($perlio);
-close ($no_perlio);
+ close ($perlio);
+ close ($no_perlio);
+ }
+
+ { # [perl #92258]
+ open my $fh, "<", \(my $f = *f);
+ is join("", <$fh>), '*main::f', 'reading from a glob copy';
+ is ref \$f, 'GLOB', 'the glob copy is unaffected';
+ }
+
}
+{
+ # see RT #75722, RT #96008
+ fresh_perl_like(<<'EOP',
+unshift @INC, sub {
+ return undef unless caller eq "main";
+ open my $fh, "<", \1;
+ $fh;
+};
+require Symbol; # doesn't matter whether it exists or not
+EOP
+ qr/\ARecursive call to Perl_load_module in PerlIO_find_layer at/s,
+ {stderr => 1},
+ 'Mutal recursion between Perl_load_module and PerlIO_find_layer croaks');
}
-
END {
unlink_all $txt;
unlink_all $bin;
Property changes on: trunk/contrib/perl/t/io/perlio.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/t/io/perlio_fail.t
===================================================================
--- trunk/contrib/perl/t/io/perlio_fail.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/io/perlio_fail.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/io/perlio_fail.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/t/io/perlio_leaks.t
===================================================================
--- trunk/contrib/perl/t/io/perlio_leaks.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/io/perlio_leaks.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/io/perlio_leaks.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/t/io/perlio_open.t
===================================================================
--- trunk/contrib/perl/t/io/perlio_open.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/io/perlio_open.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/io/perlio_open.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/io/pipe.t
===================================================================
--- trunk/contrib/perl/t/io/pipe.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/io/pipe.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -27,11 +27,7 @@
next_test();
close PIPE;
-SKIP: {
- # Technically this should be TODO. Someone try it if you happen to
- # have a vmesa machine.
- skip "Doesn't work here yet", 6 if $^O eq 'vmesa';
-
+{
if (open(PIPE, "-|")) {
while(<PIPE>) {
s/^not //;
@@ -153,11 +149,9 @@
SKIP: {
# Sfio doesn't report failure when closing a broken pipe
# that has pending output. Go figure.
- # BeOS will not write to broken pipes, either.
# Nor does POSIX-BC.
skip "Won't report failure on broken pipe", 1
- if $Config{d_sfio} || $^O eq 'beos' ||
- $^O eq 'posix-bc';
+ if $Config{d_sfio} || $^O eq 'posix-bc';
local $SIG{PIPE} = 'IGNORE';
open NIL, qq{|$Perl -e "exit 0"} or die "open failed: $!";
@@ -171,9 +165,7 @@
}
}
- SKIP: {
- skip "Don't work yet", 9 if $^O eq 'vmesa';
-
+ {
# check that errno gets forced to 0 if the piped program exited
# non-zero
open NIL, qq{|$Perl -e "exit 23";} or die "fork failed: $!";
@@ -182,9 +174,8 @@
is($!, '', ' errno');
isnt($?, 0, ' status');
- SKIP: {
- skip "Don't work yet", 6 if $^O eq 'mpeix';
-
+ # Former skip block:
+ {
# check that status for the correct process is collected
my $zombie;
unless( $zombie = fork ) {
Property changes on: trunk/contrib/perl/t/io/pipe.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/io/print.t
===================================================================
--- trunk/contrib/perl/t/io/print.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/io/print.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -10,7 +10,7 @@
use strict 'vars';
-print "1..21\n";
+print "1..24\n";
my $foo = 'STDOUT';
print $foo "ok 1\n";
@@ -66,3 +66,13 @@
map print(+()), ('')x68;
print "ok 21\n";
}
+
+# printf with %n
+my $n = "abc";
+printf "ok 22%n - not really a test; just printing\n", substr $n,1,1;
+print "not " x ($n ne "a5c") . "ok 23 - printf with %n (got $n)\n";
+
+# [perl #77094] printf with empty list
+() = ("not ");
+printf +();
+print "ok 24 - printf +() does not steal stack items\n";
Property changes on: trunk/contrib/perl/t/io/print.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/t/io/pvbm.t
===================================================================
--- trunk/contrib/perl/t/io/pvbm.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/io/pvbm.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/io/pvbm.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/io/read.t
===================================================================
--- trunk/contrib/perl/t/io/read.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/io/read.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/io/read.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/io/say.t
===================================================================
--- trunk/contrib/perl/t/io/say.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/io/say.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -16,7 +16,7 @@
use strict 'vars';
use feature "say";
-say "1..12";
+say "1..13";
my $foo = 'STDOUT';
say $foo "ok 1";
@@ -53,3 +53,8 @@
local $, = "\nnot ok 13"; # how to fool Test::Harness
say "ok 12";
}
+
+{
+ no feature 'say';
+ CORE::say "ok 13 - CORE::say without feature.pm";
+}
Property changes on: trunk/contrib/perl/t/io/say.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/t/io/shm.t (from rev 6437, vendor/perl/5.18.1/t/io/shm.t)
===================================================================
--- trunk/contrib/perl/t/io/shm.t (rev 0)
+++ trunk/contrib/perl/t/io/shm.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,92 @@
+################################################################################
+#
+# $Revision: 6 $
+# $Author: mhx $
+# $Date: 2010/03/07 16:01:42 +0100 $
+#
+################################################################################
+#
+# Version 2.x, Copyright (C) 2007-2010, Marcus Holland-Moritz <mhx at cpan.org>.
+# Version 1.x, Copyright (C) 1999, Graham Barr <gbarr at pobox.com>.
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+#
+################################################################################
+
+BEGIN {
+ if ($ENV{'PERL_CORE'}) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib' && -d '../ext';
+ }
+
+ require "./test.pl";
+ require Config; import Config;
+
+ if ($ENV{'PERL_CORE'} && $Config{'extensions'} !~ m[\bIPC/SysV\b]) {
+ skip_all('-- IPC::SysV was not built');
+ }
+ skip_all_if_miniperl();
+ if ($Config{'d_shm'} ne 'define') {
+ skip_all('-- $Config{d_shm} undefined');
+ }
+}
+
+
+use sigtrap qw/die normal-signals error-signals/;
+use IPC::SysV qw/ IPC_PRIVATE S_IRWXU IPC_RMID /;
+
+my $key;
+END { shmctl $key, IPC_RMID, 0 if defined $key }
+
+{
+ local $SIG{SYS} = sub { plan(skip_all => "SIGSYS caught") } if exists $SIG{SYS};
+ $key = shmget IPC_PRIVATE, 8, S_IRWXU;
+}
+
+if (not defined $key) {
+ my $info = "IPC::SharedMem->new failed: $!";
+ if ($! == &IPC::SysV::ENOSPC || $! == &IPC::SysV::ENOSYS ||
+ $! == &IPC::SysV::ENOMEM || $! == &IPC::SysV::EACCES) {
+ plan(skip_all => $info);
+ }
+ else {
+ die $info;
+ }
+}
+else {
+ plan(tests => 15);
+ pass('acquired shared mem');
+}
+
+ok(shmwrite($key, pack("N", 4711), 0, 4), 'write(offs=0)');
+ok(shmwrite($key, pack("N", 210577), 4, 4), 'write(offs=4)');
+
+my $var;
+ok(shmread($key, $var, 0, 4), 'read(offs=0) returned ok');
+is($var, pack("N", 4711), 'read(offs=0) correct');
+ok(shmread($key, $var, 4, 4), 'read(offs=4) returned ok');
+is($var, pack("N", 210577), 'read(offs=4) correct');
+
+ok(shmwrite($key, "Shared", 1, 6), 'write(offs=1)');
+
+ok(shmread($key, $var, 1, 6), 'read(offs=1) returned ok');
+is($var, 'Shared', 'read(offs=1) correct');
+ok(shmwrite($key,"Memory", 0, 6), 'write(offs=0)');
+
+my $number = 1;
+my $int = 2;
+shmwrite $key, $int, 0, 1;
+shmread $key, $number, 0, 1;
+is("$number", $int, qq{"\$id" eq "$int"});
+cmp_ok($number + 0, '==', $int, "\$id + 0 == $int");
+
+my ($fetch, $store) = (0, 0);
+{ package Counted;
+ sub TIESCALAR { bless [undef] }
+ sub FETCH { ++$fetch; $_[0][0] }
+ sub STORE { ++$store; $_[0][0] = $_[1] } }
+tie $ct, 'Counted';
+shmread $key, $ct, 0, 1;
+is($fetch, 1, "shmread FETCH once");
+is($store, 1, "shmread STORE once");
Modified: trunk/contrib/perl/t/io/tell.t
===================================================================
--- trunk/contrib/perl/t/io/tell.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/io/tell.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -6,7 +6,7 @@
require './test.pl';
}
-print "1..28\n";
+print "1..35\n";
$TST = 'TST';
@@ -160,3 +160,24 @@
{ print "ok 28$todo\n"; } else { print "not ok 28$todo\n"; }
close $tst;
+open FH, "test.pl";
+$fh = *FH; # coercible glob
+$not = "not " x! (tell $fh == 0);
+print "${not}ok 29 - tell on coercible glob\n";
+$not = "not " x! (tell == 0);
+print "${not}ok 30 - argless tell after tell \$coercible\n";
+tell *$fh;
+$not = "not " x! (tell == 0);
+print "${not}ok 31 - argless tell after tell *\$coercible\n";
+eof $fh;
+$not = "not " x! (tell == 0);
+print "${not}ok 32 - argless tell after eof \$coercible\n";
+eof *$fh;
+$not = "not " x! (tell == 0);
+print "${not}ok 33 - argless tell after eof *\$coercible\n";
+seek $fh,0,0;
+$not = "not " x! (tell == 0);
+print "${not}ok 34 - argless tell after seek \$coercible...\n";
+seek *$fh,0,0;
+$not = "not " x! (tell == 0);
+print "${not}ok 35 - argless tell after seek *\$coercible...\n";
Property changes on: trunk/contrib/perl/t/io/tell.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/t/io/through.t
===================================================================
--- trunk/contrib/perl/t/io/through.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/io/through.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/io/through.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/io/utf8.t
===================================================================
--- trunk/contrib/perl/t/io/utf8.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/io/utf8.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -10,7 +10,7 @@
no utf8; # needed for use utf8 not griping about the raw octets
-plan(tests => 55);
+plan(tests => 61);
$| = 1;
@@ -348,3 +348,41 @@
"<:utf8 rcatline must warn about bad utf8");
close F;
}
+
+{
+ # fixed record reads
+ open F, ">:utf8", $a_file;
+ print F "foo\xE4";
+ print F "bar\xFE";
+ print F "\xC0\xC8\xCC\xD2";
+ print F "a\xE4ab";
+ print F "a\xE4a";
+ close F;
+ open F, "<:utf8", $a_file;
+ local $/ = \4;
+ my $line = <F>;
+ is($line, "foo\xE4", "readline with \$/ = \\4");
+ $line .= <F>;
+ is($line, "foo\xE4bar\xFE", "rcatline with \$/ = \\4");
+ $line = <F>;
+ is($line, "\xC0\xC8\xCC\xD2", "readline with several encoded characters");
+ $line = <F>;
+ is($line, "a\xE4ab", "readline with another boundary condition");
+ $line = <F>;
+ is($line, "a\xE4a", "readline with boundary condition");
+ close F;
+
+ # badly encoded at EOF
+ open F, ">:raw", $a_file;
+ print F "foo\xEF\xAC"; # truncated \x{FB04} small ligature ffl
+ close F;
+
+ use warnings 'utf8';
+ open F, "<:utf8", $a_file;
+ undef $@;
+ local $SIG{__WARN__} = sub { $@ = shift };
+ $line = <F>;
+
+ like( $@, qr/utf8 "\\xEF" does not map to Unicode .+ <F> chunk 1/,
+ "<:utf8 readline (fixed) must warn about bad utf8");
+}
Property changes on: trunk/contrib/perl/t/io/utf8.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/t/japh/abigail.t
===================================================================
--- trunk/contrib/perl/t/japh/abigail.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/japh/abigail.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/japh/abigail.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/lib/1_compile.t
===================================================================
--- trunk/contrib/perl/t/lib/1_compile.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/1_compile.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -7,9 +7,9 @@
BEGIN {
chdir 't';
@INC = '../lib';
+ require './test.pl';
}
-use strict;
use warnings;
use File::Spec::Functions;
@@ -27,28 +27,22 @@
@Core_Modules = sort @Core_Modules;
-print "1..".(1+ at Core_Modules)."\n";
+plan tests => 1+ at Core_Modules;
-my $message
- = "ok 1 - All modules should have tests # TODO Make Schwern Poorer\n";
-if (@Core_Modules) {
- print "not $message";
-} else {
- print $message;
-}
-print <<'EOREWARD';
-# http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2001-04/msg01223.html
-# 20010421230349.P2946 at blackrider.blackstar.co.uk
-EOREWARD
+cmp_ok(@Core_Modules, '>', 0, "All modules should have tests");
+note("http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2001-04/msg01223.html");
+note("20010421230349.P2946\@blackrider.blackstar.co.uk");
-my $test_num = 2;
-
foreach my $module (@Core_Modules) {
- my $todo = '';
- $todo = "# TODO $module needs porting on $^O" if $module eq 'ByteLoader' && $^O eq 'VMS';
- print "# $module compile failed\nnot " unless compile_module($module);
- print "ok $test_num $todo\n";
- $test_num++;
+ if ($module eq 'ByteLoader' && $^O eq 'VMS') {
+ TODO: {
+ local $TODO = "$module needs porting on $^O";
+ ok(compile_module($module), "compile $module");
+ }
+ }
+ else {
+ ok(compile_module($module), "compile $module");
+ }
}
# We do this as a separate process else we'll blow the hell
@@ -60,7 +54,6 @@
my $lib = '-I' . catdir(updir(), 'lib');
my $out = scalar `$^X $lib $compmod $module`;
- print "# $out";
return $out =~ /^ok/;
}
Property changes on: trunk/contrib/perl/t/lib/1_compile.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/t/lib/Cname.pm
===================================================================
--- trunk/contrib/perl/t/lib/Cname.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/Cname.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/lib/Cname.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/t/lib/Count.pm (from rev 6437, vendor/perl/5.18.1/t/lib/Count.pm)
===================================================================
--- trunk/contrib/perl/t/lib/Count.pm (rev 0)
+++ trunk/contrib/perl/t/lib/Count.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,8 @@
+# zero! ha ha ha
+package Count;
+"ha!";
+__DATA__
+one! ha ha ha
+two! ha ha ha
+three! ha ha ha
+four! ha ha ha
Copied: trunk/contrib/perl/t/lib/Devel/nodb.pm (from rev 6437, vendor/perl/5.18.1/t/lib/Devel/nodb.pm)
===================================================================
--- trunk/contrib/perl/t/lib/Devel/nodb.pm (rev 0)
+++ trunk/contrib/perl/t/lib/Devel/nodb.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,3 @@
+package Devel::nodb;
+*DB::DB = sub { } if 0;
+1;
Index: trunk/contrib/perl/t/lib/Devel/switchd.pm
===================================================================
--- trunk/contrib/perl/t/lib/Devel/switchd.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/Devel/switchd.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/lib/Devel/switchd.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/t/lib/Devel/switchd_empty.pm
===================================================================
--- trunk/contrib/perl/t/lib/Devel/switchd_empty.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/Devel/switchd_empty.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/lib/Devel/switchd_empty.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/lib/Dummy.pm (from rev 6437, vendor/perl/5.18.1/t/lib/Dummy.pm)
===================================================================
--- trunk/contrib/perl/t/lib/Dummy.pm (rev 0)
+++ trunk/contrib/perl/t/lib/Dummy.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,4 @@
+package Dummy;
+
+# Attempt to emulate a bug with finding the version in Exporter.
+$VERSION = '5.562';
Copied: trunk/contrib/perl/t/lib/HasSigDie.pm (from rev 6437, vendor/perl/5.18.1/t/lib/HasSigDie.pm)
===================================================================
--- trunk/contrib/perl/t/lib/HasSigDie.pm (rev 0)
+++ trunk/contrib/perl/t/lib/HasSigDie.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,6 @@
+package HasSigDie;
+
+$SIG{__DIE__} = sub { "Die, Bart, Die!" };
+
+1;
+
Copied: trunk/contrib/perl/t/lib/NoExporter.pm (from rev 6437, vendor/perl/5.18.1/t/lib/NoExporter.pm)
===================================================================
--- trunk/contrib/perl/t/lib/NoExporter.pm (rev 0)
+++ trunk/contrib/perl/t/lib/NoExporter.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,10 @@
+package NoExporter;
+
+$VERSION = 1.02;
+sub import {
+ shift;
+ die "NoExporter exports nothing. You asked for: @_" if @_;
+}
+
+1;
+
Index: trunk/contrib/perl/t/lib/Sans_mypragma.pm
===================================================================
--- trunk/contrib/perl/t/lib/Sans_mypragma.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/Sans_mypragma.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/lib/Sans_mypragma.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/lib/TieIn.pm (from rev 6437, vendor/perl/5.18.1/t/lib/TieIn.pm)
===================================================================
--- trunk/contrib/perl/t/lib/TieIn.pm (rev 0)
+++ trunk/contrib/perl/t/lib/TieIn.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,23 @@
+package TieIn;
+
+sub TIEHANDLE {
+ bless( \(my $scalar), $_[0]);
+}
+
+sub write {
+ my $self = shift;
+ $$self .= join '', @_;
+}
+
+sub READLINE {
+ my $self = shift;
+ $$self =~ s/^(.*\n?)//;
+ return $1;
+}
+
+sub EOF {
+ my $self = shift;
+ return !length $$self;
+}
+
+1;
Copied: trunk/contrib/perl/t/lib/TieOut.pm (from rev 6437, vendor/perl/5.18.1/t/lib/TieOut.pm)
===================================================================
--- trunk/contrib/perl/t/lib/TieOut.pm (rev 0)
+++ trunk/contrib/perl/t/lib/TieOut.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,28 @@
+package TieOut;
+
+sub TIEHANDLE {
+ my $scalar = '';
+ bless( \$scalar, $_[0]);
+}
+
+sub PRINT {
+ my $self = shift;
+ $$self .= join('', @_);
+}
+
+sub PRINTF {
+ my $self = shift;
+ my $fmt = shift;
+ $$self .= sprintf $fmt, @_;
+}
+
+sub FILENO {}
+
+sub read {
+ my $self = shift;
+ my $data = $$self;
+ $$self = '';
+ return $data;
+}
+
+1;
Modified: trunk/contrib/perl/t/lib/charnames/alias
===================================================================
--- trunk/contrib/perl/t/lib/charnames/alias 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/charnames/alias 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,7 +1,6 @@
-Tests for use charnames with aliases.
-(With the exception of the first test, which otherwise would need its own file)
+Tests for use charnames with compilation errors and aliases.
__END__
-# unsupported pragma
+# NAME illegal :pragma
use warnings;
use charnames ":scoobydoo";
"Here: \N{e_ACUTE}!\n";
@@ -9,15 +8,39 @@
OPTIONS regex
unsupported special ':scoobydoo' in charnames at
########
-# wrong type of alias (missing colon)
+# NAME autoload doesn't get vianame
+print "Here: \N{DIGIT ONE}\n";
+charnames::vianame("DIGIT TWO");
+EXPECT
+OPTIONS regex
+Undefined subroutine &charnames::vianame called at - line \d+.
+Here: 1
+########
+# NAME autoload doesn't get viacode
+print "Here: \N{DIGIT THREE}\n";
+charnames::viacode(0x34);
+EXPECT
+OPTIONS regex
+Undefined subroutine &charnames::viacode called at - line \d+.
+Here: 3
+########
+# NAME autoload doesn't get string_vianame
+print "Here: \N{DIGIT FOUR}\n";
+charnames::string_vianame("DIGIT FIVE");
+EXPECT
+OPTIONS regex
+Undefined subroutine &charnames::string_vianame called at - line \d+.
+Here: 4
+########
+# NAME wrong type of alias (missing colon)
no warnings;
use charnames "alias";
"Here: \N{e_ACUTE}!\n";
EXPECT
-OPTIONS regex
-Unknown charname 'e_ACUTE' at
+OPTIONS regex fatal
+Unknown charname 'e_ACUTE' at - line \d+, within string
########
-# alias without an argument
+# NAME alias without an argument
use warnings;
use charnames ":alias";
"Here: \N{e_ACUTE}!\n";
@@ -25,7 +48,7 @@
OPTIONS regex
:alias needs an argument in charnames at
########
-# reversed sequence
+# NAME reversed sequence
use warnings;
use charnames ":alias" => ":full";
"Here: \N{e_ACUTE}!\n";
@@ -33,42 +56,52 @@
OPTIONS regex
:alias cannot use existing pragma :full \(reversed order\?\) at
########
-# alias with hashref but no :full
+# NAME alias with hashref but with :short
use warnings;
-use charnames ":alias" => { e_ACUTE => "LATIN SMALL LETTER E WITH ACUTE" };
+no warnings 'void';
+use charnames ":short", ":alias" => { e_ACUTE => "LATIN SMALL LETTER E WITH ACUTE" };
"Here: \N{e_ACUTE}!\n";
EXPECT
-OPTIONS regex
-Unknown charname 'LATIN SMALL LETTER E WITH ACUTE' at
+OPTIONS regex fatal
+Unknown charname 'e_ACUTE' at - line \d+, within string
########
-# alias with hashref but with :short
+# NAME alias with hashref to :full OK
use warnings;
no warnings 'void';
-use charnames ":short", ":alias" => { e_ACUTE => "LATIN SMALL LETTER E WITH ACUTE" };
+use charnames ":full", ":alias" => { e_ACUTE => "LATIN SMALL LETTER E WITH ACUTE" };
"Here: \N{e_ACUTE}!\n";
EXPECT
OPTIONS regex
-Unknown charname 'LATIN SMALL LETTER E WITH ACUTE' at
+$
########
-# alias with hashref to :full OK
+# NAME alias with hashref to :loose OK
use warnings;
no warnings 'void';
-use charnames ":full", ":alias" => { e_ACUTE => "LATIN SMALL LETTER E WITH ACUTE" };
+use charnames ":loose", ":alias" => { e_ACUTE => "LATIN SMALL LETTER E WITH ACUTE" };
"Here: \N{e_ACUTE}!\n";
EXPECT
OPTIONS regex
$
########
-# alias with hashref to :short but using :full
+# NAME alias with :loose requires :full type name
use warnings;
no warnings 'void';
+use charnames ":loose", ":alias" => { e_ACUTE => "latin SMALL LETTER E WITH ACUTE" };
+"Here: \N{e_ACUTE}!\n";
+EXPECT
+OPTIONS regex fatal
+Unknown charname 'e_ACUTE' at - line \d+, within string
+########
+# NAME alias with hashref to :short but using :full
+use warnings;
+no warnings 'void';
use charnames ":full", ":alias" => { e_ACUTE => "LATIN:e WITH ACUTE" };
"Here: \N{e_ACUTE}!\n";
EXPECT
-OPTIONS regex
-Unknown charname 'LATIN:e WITH ACUTE' at
+OPTIONS regex fatal
+Unknown charname 'e_ACUTE' at - line \d+, within string
########
-# alias with hashref to :short OK
+# NAME alias with hashref to :short OK
use warnings;
no warnings 'void';
use charnames ":short", ":alias" => { e_ACUTE => "LATIN:e WITH ACUTE" };
@@ -77,7 +110,7 @@
OPTIONS regex
$
########
-# alias with bad hashref
+# NAME alias with bad hashref
use warnings;
no warnings 'void';
use charnames ":short", ":alias" => "e_ACUTE";
@@ -86,7 +119,7 @@
OPTIONS regex
unicore/e_ACUTE_alias.pl cannot be used as alias file for charnames at
########
-# alias with arrayref
+# NAME alias with arrayref
use warnings;
no warnings 'void';
use charnames ":short", ":alias" => [ e_ACUTE => "LATIN:e WITH ACUTE" ];
@@ -95,7 +128,7 @@
OPTIONS regex
Only HASH reference supported as argument to :alias at
########
-# alias with bad hashref
+# NAME alias with bad hashref
no warnings;
use charnames ":short", ":alias" => { e_ACUTE => "LATIN:e WITH ACUTE", "a_ACUTE" };
"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
@@ -103,7 +136,7 @@
OPTIONS regex
Unknown charname 'a_ACUTE' at
########
-# alias with hashref two aliases
+# NAME alias with hashref two aliases
use warnings;
no warnings 'void';
use charnames ":short", ":alias" => {
@@ -112,10 +145,10 @@
};
"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
EXPECT
-OPTIONS regex
-Unknown charname '' at
+OPTIONS regex fatal
+Unknown charname 'a_ACUTE' at - line \d+, within string
########
-# alias with hashref two aliases
+# NAME alias with hashref two aliases
use warnings;
no warnings 'void';
use charnames ":short", ":alias" => {
@@ -127,7 +160,7 @@
OPTIONS regex
$
########
-# alias with hashref using mixed aliases
+# NAME alias with hashref using mixed aliases
use warnings;
use charnames ":short", ":alias" => {
e_ACUTE => "LATIN:e WITH ACUTE",
@@ -135,10 +168,10 @@
};
"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
EXPECT
-OPTIONS regex
-Unknown charname 'LATIN SMALL LETTER A WITH ACUT' at
+OPTIONS regex fatal
+Unknown charname 'a_ACUTE' at - line \d+, within string
########
-# alias with hashref using mixed aliases
+# NAME alias with hashref using mixed aliases
use warnings;
use charnames ":short", ":alias" => {
e_ACUTE => "LATIN:e WITH ACUTE",
@@ -146,10 +179,10 @@
};
"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
EXPECT
-OPTIONS regex
-Unknown charname 'LATIN SMALL LETTER A WITH ACUTE' at
+OPTIONS regex fatal
+Unknown charname 'a_ACUTE' at - line \d+, within string
########
-# alias with hashref using mixed aliases
+# NAME alias with hashref using mixed aliases
use warnings;
no warnings 'void';
use charnames ":full", ":alias" => {
@@ -158,19 +191,19 @@
};
"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
EXPECT
-OPTIONS regex
-Unknown charname 'LATIN:e WITH ACUTE' at
+OPTIONS regex fatal
+Unknown charname 'e_ACUTE' at - line \d+, within string
########
-# alias with nonexisting file
+# NAME alias with nonexisting file
use warnings;
no warnings 'void';
-use charnames ":full", ":alias" => "xyzzy";
+use charnames ":full", ":alias" => "non_existing_xyzzy";
"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
EXPECT
OPTIONS regex
-unicore/xyzzy_alias.pl cannot be used as alias file for charnames at
+unicore/non_existing_xyzzy_alias.pl cannot be used as alias file for charnames at
########
-# alias with bad file name
+# NAME alias with bad file name
use warnings;
no warnings 'void';
use charnames ":full", ":alias" => "xy 7-";
@@ -177,9 +210,9 @@
"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
EXPECT
OPTIONS regex
-Charnames alias files can only have identifier characters at
+Charnames alias file names can only have identifier characters at
########
-# alias with non_absolute (existing) file name (which it should /not/ use)
+# NAME alias with non_absolute (existing) file name (which it should /not/ use)
use warnings;
no warnings 'void';
use charnames ":full", ":alias" => "perl";
@@ -188,7 +221,7 @@
OPTIONS regex
unicore/perl_alias.pl cannot be used as alias file for charnames at
########
-# alias with bad file
+# NAME alias with bad file
--FILE-- ../../lib/unicore/xyzzy_alias.pl
#!perl
0;
@@ -201,7 +234,7 @@
OPTIONS regex
unicore/xyzzy_alias.pl did not return a \(valid\) list of alias pairs at
########
-# alias with file with empty list
+# NAME alias with file with empty list
--FILE-- ../../lib/unicore/xyzzy_alias.pl
#!perl
();
@@ -211,10 +244,10 @@
use charnames ":full", ":alias" => "xyzzy";
"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
EXPECT
-OPTIONS regex
-Unknown charname 'e_ACUTE' at
+OPTIONS regex fatal
+Unknown charname 'e_ACUTE' at - line \d+, within string
########
-# alias with file OK but file has :short aliases
+# NAME alias with file OK but file has :short aliases
--FILE-- ../../lib/unicore/xyzzy_alias.pl
#!perl
( e_ACUTE => "LATIN:e WITH ACUTE",
@@ -226,10 +259,10 @@
use charnames ":full", ":alias" => "xyzzy";
"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
EXPECT
-OPTIONS regex
-Unknown charname 'LATIN:e WITH ACUTE' at
+OPTIONS regex fatal
+Unknown charname 'e_ACUTE' at - line \d+, within string
########
-# alias with :short and file OK
+# NAME alias with :short and file OK
--FILE-- ../../lib/unicore/xyzzy_alias.pl
#!perl
( e_ACUTE => "LATIN:e WITH ACUTE",
@@ -244,7 +277,7 @@
OPTIONS regex
$
########
-# alias with :short and file OK has :long aliases
+# NAME alias with :short and file OK has :long aliases
--FILE-- ../../lib/unicore/xyzzy_alias.pl
#!perl
( e_ACUTE => "LATIN SMALL LETTER E WITH ACUTE",
@@ -256,10 +289,10 @@
use charnames ":short", ":alias" => "xyzzy";
"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
EXPECT
-OPTIONS regex
-Unknown charname 'LATIN SMALL LETTER E WITH ACUTE' at
+OPTIONS regex fatal
+Unknown charname 'e_ACUTE' at - line \d+, within string
########
-# alias with file implicit :full but file has :short aliases
+# NAME alias with file implicit :full but file has :short aliases
--FILE-- ../../lib/unicore/xyzzy_alias.pl
#!perl
( e_ACUTE => "LATIN:e WITH ACUTE",
@@ -271,10 +304,10 @@
use charnames ":alias" => ":xyzzy";
"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
EXPECT
-OPTIONS regex
-Unknown charname 'LATIN:e WITH ACUTE' at
+OPTIONS regex fatal
+Unknown charname 'e_ACUTE' at - line \d+, within string
########
-# alias with file implicit :full and file has :long aliases
+# NAME alias with file implicit :full and file has :long aliases
--FILE-- ../../lib/unicore/xyzzy_alias.pl
#!perl
( e_ACUTE => "LATIN SMALL LETTER E WITH ACUTE",
@@ -289,7 +322,7 @@
OPTIONS regex
$
########
-# charnames with no import still works for runtime functions
+# NAME charnames with no import still works for runtime functions
use warnings;
no warnings 'void';
use charnames ();
@@ -298,3 +331,76 @@
EXPECT
OPTIONS regex
$
+########
+# NAME no extraneous warning [perl #11560]
+use warnings;
+use charnames ();
+print charnames::viacode(0x80), "\n";
+EXPECT
+OPTIONS regex
+PADDING CHARACTER
+########
+# NAME various wrong characters in :alias are errors
+# Below, one of the EXPECT regexes matches both the UTF-8 and non-UTF-8 form.
+# This is because under some circumstances the message gets output as UTF-8.
+use charnames ":full", ":alias" => {
+ "4e_ACUTE" => "LATIN SMALL LETTER E WITH ACUTE",
+ "e_A,CUTE" => "LATIN SMALL LETTER E WITH ACUTE",
+ "e_ACUT\x{d7}E" => "LATIN SMALL LETTER E WITH ACUTE",
+ };
+EXPECT
+OPTIONS regex
+Invalid character in charnames alias definition; marked by <-- HERE in '4<-- HERE e_ACUTE'
+Invalid character in charnames alias definition; marked by <-- HERE in 'e_A,<-- HERE CUTE'
+Invalid character in charnames alias definition; marked by <-- HERE in 'e_ACUT(?:\x{d7}|\x{C3}\x{97})<-- HERE E'
+########
+# RT#73022
+# NAME \N{...} interprets ... as octets rather than UTF-8
+use utf8;
+use open qw( :utf8 :std );
+use charnames ":full", ":alias" => { "自転車に乗る人" => "BICYCLIST" };
+print "ok\n" if "\N{自転車に乗る人}" eq "\x{1F6B4}";
+EXPECT
+ok
+########
+# NAME Misspelled \N{} UTF-8 names are errors
+use utf8;
+use open qw( :utf8 :std );
+use charnames ":full", ":alias" => { "自転車に乗る人" => "BICYCLIST" };
+print "ok\n" if "\N{転車に乗る人}" eq "\x{1F6B4}";
+EXPECT
+OPTIONS regex
+Unknown charname '転車に乗る人' at - line \d+, within string
+########
+# NAME various wrong UTF-8 characters in :alias are errors
+# First has a punctuation, KATAKANA MIDDLE DOT, in it; second begins with a
+# digit: ARABIC-INDIC DIGIT FOUR
+use utf8;
+use open qw( :utf8 :std );
+use charnames ":full", ":alias" => { "自転車・に乗る人" => "BICYCLIST",
+ "٤転車に乗る人" => "BICYCLIST",
+ };
+print "ok\n" if "\N{自転車・に乗る人}" eq "\x{1F6B4}";
+print "ok\n" if "\N{٤転車に乗る人}" eq "\x{1F6B4}";
+EXPECT
+OPTIONS regex
+Invalid character in charnames alias definition; marked by <-- HERE in '٤<-- HERE 転車に乗る人'
+Invalid character in charnames alias definition; marked by <-- HERE in '自転車・<-- HERE に乗る人' at - line \d+
+########
+# NAME trailing and sequences of multiple spaces in :alias names are deprectated
+use charnames ":alias" => { "TOO MANY SPACES" => "NO ENTRY SIGN",
+ "TRAILING SPACE " => "FACE WITH NO GOOD GESTURE"
+ };
+print "ok\n" if "\N{TOO MANY SPACES}" eq "\x{1F6AB}";
+print "ok\n" if "\N{TRAILING SPACE }" eq "\x{1F645}";
+no warnings 'deprecated';
+print "ok\n" if "\N{TOO MANY SPACES}" eq "\x{1F6AB}";
+print "ok\n" if "\N{TRAILING SPACE }" eq "\x{1F645}";
+EXPECT
+OPTIONS regex
+A sequence of multiple spaces in a charnames alias definition is deprecated; marked by <-- HERE in 'TOO <-- HERE MANY SPACES' at - line \d+.
+Trailing white-space in a charnames alias definition is deprecated; marked by <-- HERE in 'TRAILING SPACE <-- HERE ' at - line \d+.
+ok
+ok
+ok
+ok
Property changes on: trunk/contrib/perl/t/lib/charnames/alias
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/lib/common.pl
===================================================================
--- trunk/contrib/perl/t/lib/common.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/common.pl 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,5 +1,5 @@
-# This code is used by lib/charnames.t, lib/feature.t, lib/subs.t,
-# lib/strict.t and lib/warnings.t
+# This code is used by lib/charnames.t, lib/croak.t, lib/feature.t,
+# lib/subs.t, lib/strict.t and lib/warnings.t
#
# On input, $::local_tests is the number of tests in the caller; or
# 'no_plan' if unknown, in which case it is the caller's responsibility
@@ -54,11 +54,11 @@
}
$^X = rel2abs($^X);
+ at INC = map { rel2abs($_) } @INC;
my $tempdir = tempfile;
mkdir $tempdir, 0700 or die "Can't mkdir '$tempdir': $!";
chdir $tempdir or die die "Can't chdir '$tempdir': $!";
-unshift @INC, '../../lib';
my $cleanup = 1;
END {
Property changes on: trunk/contrib/perl/t/lib/common.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/lib/commonsense.t
===================================================================
--- trunk/contrib/perl/t/lib/commonsense.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/commonsense.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,21 +1,26 @@
#!./perl
-chdir 't' if -d 't';
- at INC = '../lib';
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require './test.pl';
+}
+
+plan( tests => 1);
+
require Config; import Config;
+
if (($Config{'extensions'} !~ /\bFcntl\b/) ){
- print "Bail out! Perl configured without Fcntl module\n";
- exit 0;
+ BAIL_OUT("Perl configured without Fcntl module");
}
-if (($Config{'extensions'} !~ /\bIO\b/) ){
- print "Bail out! Perl configured without IO module\n";
- exit 0;
+##Finds IO submodules when using \b
+if (($Config{'extensions'} !~ /\bIO\s/) ){
+ BAIL_OUT("Perl configured without IO module");
}
# hey, DOS users do not need this kind of common sense ;-)
if ($^O ne 'dos' && ($Config{'extensions'} !~ /\bFile\/Glob\b/) ){
- print "Bail out! Perl configured without File::Glob module\n";
- exit 0;
+ BAIL_OUT("Perl configured without File::Glob module");
}
-print "1..1\nok 1\n";
+pass('common sense');
Property changes on: trunk/contrib/perl/t/lib/commonsense.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/lib/compmod.pl
===================================================================
--- trunk/contrib/perl/t/lib/compmod.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/compmod.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/lib/compmod.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/lib/contains_bad_pod.xr (from rev 6437, vendor/perl/5.18.1/t/lib/contains_bad_pod.xr)
===================================================================
--- trunk/contrib/perl/t/lib/contains_bad_pod.xr (rev 0)
+++ trunk/contrib/perl/t/lib/contains_bad_pod.xr 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,5 @@
+=head foo
+
+bar baz.
+
+=cut
Copied: trunk/contrib/perl/t/lib/contains_pod.xr (from rev 6437, vendor/perl/5.18.1/t/lib/contains_pod.xr)
===================================================================
--- trunk/contrib/perl/t/lib/contains_pod.xr (rev 0)
+++ trunk/contrib/perl/t/lib/contains_pod.xr 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,5 @@
+=head1 foo
+
+bar baz.
+
+=cut
Modified: trunk/contrib/perl/t/lib/croak.t
===================================================================
--- trunk/contrib/perl/t/lib/croak.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/croak.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,20 +1,7 @@
#!./perl
-# So far, it seems, there is no place to test all the Perl_croak() calls in the
-# C code. So this is a start. It's likely that it needs refactoring to be data
-# driven. Data driven code exists in various other tests - best plan would be to
-# investigate whether any common code library already exists, and if not,
-# refactor the "donor" test code into a common code library.
-BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
- require './test.pl';
- plan( tests => 1 );
-}
+chdir 't' if -d 't';
+ at INC = '../lib';
-use strict;
-
-fresh_perl_is(<<'EOF', 'No such hook: _HUNGRY at - line 1.', {}, 'Perl_magic_setsig');
-$SIG{_HUNGRY} = \&mmm_pie;
-warn "Mmm, pie";
-EOF
+$FATAL = 1; # we expect all the tests to croak
+require "../t/lib/common.pl";
Property changes on: trunk/contrib/perl/t/lib/croak.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/lib/cygwin.t
===================================================================
--- trunk/contrib/perl/t/lib/cygwin.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/cygwin.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/lib/cygwin.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/lib/dbmt_common.pl
===================================================================
--- trunk/contrib/perl/t/lib/dbmt_common.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/dbmt_common.pl 2013-12-02 21:26:09 UTC (rev 6439)
@@ -43,7 +43,7 @@
}
SKIP: {
skip "different file permission semantics on $^O", 1
- if $^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'dos' || $^O eq 'cygwin';
+ if $^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'dos' || $^O eq 'cygwin' || $^O eq 'vos';
my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
$blksize,$blocks) = stat($Dfile);
is($mode & 0777, 0640);
Property changes on: trunk/contrib/perl/t/lib/dbmt_common.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/lib/deprecate/Deprecated.pm
===================================================================
--- trunk/contrib/perl/t/lib/deprecate/Deprecated.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/deprecate/Deprecated.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/lib/deprecate/Deprecated.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/lib/deprecate/Optionally.pm
===================================================================
--- trunk/contrib/perl/t/lib/deprecate/Optionally.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/deprecate/Optionally.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/lib/deprecate/Optionally.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/lib/deprecate.t
===================================================================
--- trunk/contrib/perl/t/lib/deprecate.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/deprecate.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/lib/deprecate.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/lib/feature/bundle
===================================================================
--- trunk/contrib/perl/t/lib/feature/bundle 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/feature/bundle 2013-12-02 21:26:09 UTC (rev 6439)
@@ -67,3 +67,53 @@
EXPECT
OPTIONS regex
^Feature bundle "5.8.8" is not supported by Perl \d+\.\d+\.\d+ at - line \d+
+########
+# :default
+BEGIN { *say = *state = *given = sub { print "custom sub\n" }; }
+use feature ":default";
+say "yes";
+state my $foo;
+given a => chance;
+EXPECT
+custom sub
+custom sub
+custom sub
+########
+# :default and $[
+# SKIP ? not defined DynaLoader::boot_DynaLoader
+no feature;
+use feature ":default";
+$[ = 1;
+print qw[a b c][2], "\n";
+use feature ":5.16"; # should not disable anything; no feature ':all' does that
+print qw[a b c][2], "\n";
+no feature ':all';
+print qw[a b c][2], "\n";
+use feature ":5.16";
+print qw[a b c][2], "\n";
+EXPECT
+Use of assignment to $[ is deprecated at - line 4.
+b
+b
+c
+c
+########
+# "no feature"
+use feature ':5.16'; # turns array_base off
+no feature; # resets to :default, thus turns array_base on
+$[ = 1;
+print qw[a b c][2], "\n";
+EXPECT
+Use of assignment to $[ is deprecated at - line 4.
+b
+########
+# "no feature 'all"
+$[ = 1;
+print qw[a b c][2], "\n";
+no feature ':all'; # turns array_base (and everything else) off
+$[ = 1;
+print qw[a b c][2], "\n";
+EXPECT
+Use of assignment to $[ is deprecated at - line 2.
+Assigning non-zero to $[ is no longer possible at - line 5.
+b
Property changes on: trunk/contrib/perl/t/lib/feature/bundle
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/lib/feature/implicit
===================================================================
--- trunk/contrib/perl/t/lib/feature/implicit 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/feature/implicit 2013-12-02 21:26:09 UTC (rev 6439)
@@ -21,16 +21,10 @@
########
# VERSION requirement, decimal notation
use 5.009005;
-say defined $INC{"feature.pm"} ? "Helloworld" : "Good bye";
+say "Helloworld";
EXPECT
Helloworld
########
-# VERSION requirement, doesn't load anything for < 5.9.5
-use 5.8.8;
-print "<".$INC{"feature.pm"}.">\n";
-EXPECT
-<>
-########
# VERSION requirement, doesn't load anything with require
require 5.9.5;
print "<".$INC{"feature.pm"}.">\n";
@@ -64,3 +58,67 @@
# no implicit features with 'no'
eval "no " . ($]+1); print $@;
EXPECT
+########
+# lower version after higher version
+sub evalbytes { print "evalbytes sub\n" }
+sub say { print "say sub\n" }
+use 5.015;
+evalbytes "say 'yes'";
+use 5.014;
+evalbytes;
+use 5;
+say "no"
+EXPECT
+yes
+evalbytes sub
+say sub
+########
+# No $[ under 5.15
+# SKIP ? not defined DynaLoader::boot_DynaLoader
+use v5.14;
+no warnings 'deprecated';
+$[ = 1;
+print qw[a b c][2], "\n";
+use v5.15;
+print qw[a b c][2], "\n";
+EXPECT
+b
+c
+########
+# $[ under < 5.10
+# SKIP ? not defined DynaLoader::boot_DynaLoader
+use feature 'say'; # make sure it is loaded and modifies %^H; we are test-
+use v5.8.8; # ing to make sure it does not disable $[
+no warnings 'deprecated';
+$[ = 1;
+print qw[a b c][2], "\n";
+EXPECT
+b
+########
+# $[ under < 5.10 after use v5.15
+# SKIP ? not defined DynaLoader::boot_DynaLoader
+use v5.15;
+use v5.8.8;
+no warnings 'deprecated';
+$[ = 1;
+print qw[a b c][2], "\n";
+EXPECT
+b
+########
+# Implicit unicode_string feature
+use v5.14;
+print 'ss' =~ /\xdf/i ? "ok\n" : "nok\n";
+use v5.8.8;
+print 'ss' =~ /\xdf/i ? "ok\n" : "nok\n";
+EXPECT
+ok
+nok
+########
+# Implicit unicode_eval feature
+use v5.15;
+print eval "use utf8; q|\xc5\xbf|" eq "\xc5\xbf" ? "ok\n" : "nok\n";
+use v5.8.8;
+print eval "use utf8; q|\xc5\xbf|" eq "\x{17f}" ? "ok\n" : "nok\n";
+EXPECT
+ok
+ok
Property changes on: trunk/contrib/perl/t/lib/feature/implicit
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/t/lib/feature/nonesuch
===================================================================
--- trunk/contrib/perl/t/lib/feature/nonesuch 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/feature/nonesuch 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/lib/feature/nonesuch
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/lib/feature/say
===================================================================
--- trunk/contrib/perl/t/lib/feature/say 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/feature/say 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/lib/feature/say
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/lib/feature/switch
===================================================================
--- trunk/contrib/perl/t/lib/feature/switch 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/feature/switch 2013-12-02 21:26:09 UTC (rev 6439)
@@ -3,7 +3,7 @@
__END__
# No switch; given should be a bareword.
-use warnings;
+use warnings; no warnings 'experimental::smartmatch';
print STDOUT given;
EXPECT
Unquoted string "given" may clash with future reserved word at - line 3.
@@ -10,7 +10,7 @@
given
########
# No switch; when should be a bareword.
-use warnings;
+use warnings; no warnings 'experimental::smartmatch';
print STDOUT when;
EXPECT
Unquoted string "when" may clash with future reserved word at - line 3.
@@ -17,7 +17,7 @@
when
########
# No switch; default should be a bareword.
-use warnings;
+use warnings; no warnings 'experimental::smartmatch';
print STDOUT default;
EXPECT
Unquoted string "default" may clash with future reserved word at - line 3.
@@ -24,7 +24,7 @@
default
########
# No switch; break should be a bareword.
-use warnings;
+use warnings; no warnings 'experimental::smartmatch';
print STDOUT break;
EXPECT
Unquoted string "break" may clash with future reserved word at - line 3.
@@ -33,23 +33,22 @@
# No switch; but continue is still a keyword
print STDOUT continue;
EXPECT
-syntax error at - line 2, near "STDOUT continue"
-Execution of - aborted due to compilation errors.
+Can't "continue" outside a when block at - line 2.
########
# Use switch; so given is a keyword
-use feature 'switch';
+use feature 'switch'; no warnings 'experimental::smartmatch';
given("okay\n") { print }
EXPECT
okay
########
# Use switch; so when is a keyword
-use feature 'switch';
+use feature 'switch'; no warnings 'experimental::smartmatch';
given(1) { when(1) { print "okay" } }
EXPECT
okay
########
# Use switch; so default is a keyword
-use feature 'switch';
+use feature 'switch'; no warnings 'experimental::smartmatch';
given(1) { default { print "okay" } }
EXPECT
okay
@@ -60,14 +59,8 @@
EXPECT
Can't "break" outside a given block at - line 3.
########
-# Use switch; so continue is a keyword
-use feature 'switch';
-continue;
-EXPECT
-Can't "continue" outside a when block at - line 3.
-########
# switch out of scope; given should be a bareword.
-use warnings;
+use warnings; no warnings 'experimental::smartmatch';
{ use feature 'switch';
given (1) {print "Okay here\n";}
}
@@ -78,7 +71,7 @@
given
########
# switch out of scope; when should be a bareword.
-use warnings;
+use warnings; no warnings 'experimental::smartmatch';
{ use feature 'switch';
given (1) { when(1) {print "Okay here\n";} }
}
@@ -89,7 +82,7 @@
when
########
# switch out of scope; default should be a bareword.
-use warnings;
+use warnings; no warnings 'experimental::smartmatch';
{ use feature 'switch';
given (1) { default {print "Okay here\n";} }
}
@@ -100,7 +93,7 @@
default
########
# switch out of scope; break should be a bareword.
-use warnings;
+use warnings; no warnings 'experimental::smartmatch';
{ use feature 'switch';
given (1) { break }
}
@@ -109,17 +102,8 @@
Unquoted string "break" may clash with future reserved word at - line 6.
break
########
-# switch out of scope; continue should not work
-{ use feature 'switch';
- given (1) { default {continue} }
-}
-print STDOUT continue;
-EXPECT
-syntax error at - line 5, near "STDOUT continue"
-Execution of - aborted due to compilation errors.
-########
# C<no feature 'switch'> should work
-use warnings;
+use warnings; no warnings 'experimental::smartmatch';
use feature 'switch';
given (1) { when(1) {print "Okay here\n";} }
no feature 'switch';
@@ -130,7 +114,7 @@
when
########
# C<no feature> should work too
-use warnings;
+use warnings; no warnings 'experimental::smartmatch';
use feature 'switch';
given (1) { when(1) {print "Okay here\n";} }
no feature;
@@ -141,7 +125,7 @@
when
########
# Without the feature, no 'Unambiguous use of' warning:
-use warnings;
+use warnings; no warnings 'experimental::smartmatch';
@break = ($break = "break");
print ${break}, ${break[0]};
EXPECT
@@ -148,7 +132,7 @@
breakbreak
########
# With the feature, we get an 'Unambiguous use of' warning:
-use warnings;
+use warnings; no warnings 'experimental::smartmatch';
use feature 'switch';
@break = ($break = "break");
print ${break}, ${break[0]};
Property changes on: trunk/contrib/perl/t/lib/feature/switch
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/lib/filter-util.pl (from rev 6437, vendor/perl/5.18.1/t/lib/filter-util.pl)
===================================================================
--- trunk/contrib/perl/t/lib/filter-util.pl (rev 0)
+++ trunk/contrib/perl/t/lib/filter-util.pl 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,56 @@
+
+use strict ;
+use warnings;
+
+use vars qw( $Perl $Inc);
+
+sub readFile
+{
+ my ($filename) = @_ ;
+ my ($string) = '' ;
+
+ open (F, "<$filename")
+ or die "Cannot open $filename: $!\n" ;
+ while (<F>)
+ { $string .= $_ }
+ close F ;
+ $string ;
+}
+
+sub writeFile
+{
+ my($filename, @strings) = @_ ;
+ open (F, ">$filename")
+ or die "Cannot open $filename: $!\n" ;
+ binmode(F) if $filename =~ /bin$/i;
+ foreach (@strings)
+ { print F }
+ close F or die "Could not close: $!" ;
+}
+
+sub ok
+{
+ my($number, $result, $note) = @_ ;
+
+ $note = "" if ! defined $note ;
+ if ($note) {
+ $note = "# $note" if $note !~ /^\s*#/ ;
+ $note =~ s/^\s*/ / ;
+ }
+
+ print "not " if !$result ;
+ print "ok ${number}${note}\n";
+}
+
+$Inc = '' ;
+foreach (@INC)
+ { $Inc .= "\"-I$_\" " }
+$Inc = "-I::lib" if $^O eq 'MacOS';
+
+$Perl = '' ;
+$Perl = ($ENV{'FULLPERL'} or $^X or 'perl') ;
+
+$Perl = "$Perl -MMac::err=unix" if $^O eq 'MacOS';
+$Perl = "$Perl -w" ;
+
+1;
Modified: trunk/contrib/perl/t/lib/h2ph.h
===================================================================
--- trunk/contrib/perl/t/lib/h2ph.h 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/h2ph.h 2013-12-02 21:26:09 UTC (rev 6439)
@@ -36,8 +36,8 @@
#endif /* __SOME_UNIMPORTANT_PROPERTY */
/*
- * Test #if, #elif, #else, #endif, #warn and #error, and `!'
- * Also test whitespace between the `#' and the command
+ * Test #if, #elif, #else, #endif, #warn and #error, and '!'
+ * Also test whitespace between the '#' and the command
*/
#if !(defined __SOMETHING_MORE_IMPORTANT)
# warn Be careful...
@@ -68,8 +68,8 @@
/*
* Test #include, #import and #include_next
* #include_next is difficult to test, it really depends on the actual
- * circumstances - for example, `#include_next <limits.h>' on a Linux system
- * with `use lib qw(/opt/perl5/lib/site_perl/i586-linux/linux);' or whatever
+ * circumstances - for example, '#include_next <limits.h>' on a Linux system
+ * with 'use lib qw(/opt/perl5/lib/site_perl/i586-linux/linux);' or whatever
* your equivalent is...
*/
#if 0
Property changes on: trunk/contrib/perl/t/lib/h2ph.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/t/lib/h2ph.pht
===================================================================
--- trunk/contrib/perl/t/lib/h2ph.pht 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/h2ph.pht 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/lib/h2ph.pht
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/t/lib/locale/latin1
===================================================================
--- trunk/contrib/perl/t/lib/locale/latin1 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/locale/latin1 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/lib/locale/latin1
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/lib/locale/utf8
===================================================================
--- trunk/contrib/perl/t/lib/locale/utf8 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/locale/utf8 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/lib/locale/utf8
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/lib/manifest.t (from rev 6437, vendor/perl/5.18.1/t/lib/manifest.t)
===================================================================
--- trunk/contrib/perl/t/lib/manifest.t (rev 0)
+++ trunk/contrib/perl/t/lib/manifest.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,52 @@
+#!./perl -w
+
+# Test the well-formed-ness of the MANIFEST file.
+
+BEGIN {
+ chdir 't';
+ @INC = '../lib';
+}
+
+use strict;
+use File::Spec;
+require './test.pl';
+
+plan('no_plan');
+
+my $manifest = File::Spec->catfile(File::Spec->updir(), 'MANIFEST');
+
+open my $m, '<', $manifest or die "Can't open '$manifest': $!";
+
+# Test that MANIFEST uses tabs - not spaces - after the name of the file.
+while (<$m>) {
+ chomp;
+ next unless /\s/; # Ignore lines without whitespace (i.e., filename only)
+ my ($file, $separator) = /^(\S+)(\s+)/;
+ isnt($file, undef, "Line $. doesn't start with a blank") or next;
+ if ($separator !~ tr/\t//c) {
+ # It's all tabs
+ next;
+ } elsif ($separator !~ tr/ //c) {
+ # It's all spaces
+ fail("Spaces in entry for $file");
+ } elsif ($separator =~ tr/\t//) {
+ fail("Mixed tabs and spaces in entry for $file");
+ } else {
+ fail("Odd whitespace in entry for $file");
+ }
+}
+
+close $m or die $!;
+
+# Test that MANIFEST is properly sorted
+SKIP: {
+ skip("'Porting/manisort' not found", 1) if (! -f '../Porting/manisort');
+
+ my $result = runperl('progfile' => '../Porting/manisort',
+ 'args' => [ '-c', '../MANIFEST' ],
+ 'stderr' => 1);
+
+ like($result, qr/is sorted properly/, 'MANIFEST sorted properly');
+}
+
+# EOF
Index: trunk/contrib/perl/t/lib/mypragma.pm
===================================================================
--- trunk/contrib/perl/t/lib/mypragma.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/mypragma.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/lib/mypragma.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/lib/mypragma.t
===================================================================
--- trunk/contrib/perl/t/lib/mypragma.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/mypragma.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/lib/mypragma.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/t/lib/no_load.t
===================================================================
--- trunk/contrib/perl/t/lib/no_load.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/no_load.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/lib/no_load.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/t/lib/overload_fallback.t
===================================================================
--- trunk/contrib/perl/t/lib/overload_fallback.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/overload_fallback.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/lib/overload_fallback.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/lib/overload_nomethod.t (from rev 6437, vendor/perl/5.18.1/t/lib/overload_nomethod.t)
===================================================================
--- trunk/contrib/perl/t/lib/overload_nomethod.t (rev 0)
+++ trunk/contrib/perl/t/lib/overload_nomethod.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,22 @@
+use warnings;
+use strict;
+use Test::Simple tests => 3;
+
+package Foo;
+use overload
+ nomethod => sub { die "unimplemented\n" };
+sub new { bless {}, shift };
+
+package main;
+
+my $foo = Foo->new;
+
+eval {my $val = $foo + 1};
+ok( $@ =~ /unimplemented/ );
+
+eval {$foo += 1};
+ok( $@ =~ /unimplemented/ );
+
+eval {my $val = 0; $val += $foo};
+ok( $@ =~ /unimplemented/ );
+
Modified: trunk/contrib/perl/t/lib/proxy_constant_subs.t
===================================================================
--- trunk/contrib/perl/t/lib/proxy_constant_subs.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/proxy_constant_subs.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -23,10 +23,10 @@
$ps = svref_2object(\*{"Fcntl::$symbol"});
$ms = svref_2object(\*{"::$symbol"});
}
- isa_ok($ps, 'B::GV');
+ object_ok($ps, 'B::GV');
is($ps->GvFLAGS() & GVf_IMPORTED_CV, 0,
"GVf_IMPORTED_CV not set on original");
- isa_ok($ms, 'B::GV');
+ object_ok($ms, 'B::GV');
is($ms->GvFLAGS() & GVf_IMPORTED_CV, GVf_IMPORTED_CV,
"GVf_IMPORTED_CV set on imported GV");
}
Property changes on: trunk/contrib/perl/t/lib/proxy_constant_subs.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/lib/strict/refs
===================================================================
--- trunk/contrib/perl/t/lib/strict/refs 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/strict/refs 2013-12-02 21:26:09 UTC (rev 6439)
@@ -27,6 +27,29 @@
# strict refs - error
use strict ;
+"A::Really::Big::Package::Name::To::Use" =~ /(.*)/;
+${$1};
+EXPECT
+Can't use string ("A::Really::Big::Package::Name::T"...) as a SCALAR ref while "strict refs" in use at - line 5.
+########
+
+# strict refs - error
+use strict ;
+*{"A::Really::Big::Package::Name::To::Use"; }
+EXPECT
+Can't use string ("A::Really::Big::Package::Name::T"...) as a symbol ref while "strict refs" in use at - line 4.
+########
+
+# strict refs - error
+use strict ;
+"A::Really::Big::Package::Name::To::Use" =~ /(.*)/;
+*{$1}
+EXPECT
+Can't use string ("A::Really::Big::Package::Name::T"...) as a symbol ref while "strict refs" in use at - line 5.
+########
+
+# strict refs - error
+use strict ;
my $fred ;
my $a = ${"fred"} ;
EXPECT
@@ -308,7 +331,7 @@
use strict 'refs';
/(?{${"foo"}++})/;
EXPECT
-Can't use string ("foo") as a SCALAR ref while "strict refs" in use at (re_eval 1) line 1.
+Can't use string ("foo") as a SCALAR ref while "strict refs" in use at - line 3.
########
# [perl #37886] strict 'refs' doesn't apply inside defined
use strict 'refs';
@@ -322,6 +345,8 @@
my $x = "foo";
defined @$x;
EXPECT
+defined(@array) is deprecated at - line 4.
+ (Maybe you should just omit the defined()?)
Can't use string ("foo") as an ARRAY ref while "strict refs" in use at - line 4.
########
# [perl #37886] strict 'refs' doesn't apply inside defined
@@ -338,3 +363,11 @@
my $o = 1 ; $o->{1} ;
EXPECT
Can't use string ("1") as a HASH ref while "strict refs" in use at - line 3.
+########
+# pp_hot.c [pp_entersub]
+use strict 'refs';
+use utf8;
+use open qw( :utf8 :std );
+&{"Ｆ"};
+EXPECT
+Can't use string ("Ｆ") as a subroutine ref while "strict refs" in use at - line 5.
Property changes on: trunk/contrib/perl/t/lib/strict/refs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/lib/strict/subs
===================================================================
--- trunk/contrib/perl/t/lib/strict/subs 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/strict/subs 2013-12-02 21:26:09 UTC (rev 6439)
@@ -45,8 +45,8 @@
use strict 'subs' ;
my @a = (A..Z);
EXPECT
+Bareword "A" not allowed while "strict subs" in use at - line 4.
Bareword "Z" not allowed while "strict subs" in use at - line 4.
-Bareword "A" not allowed while "strict subs" in use at - line 4.
Execution of - aborted due to compilation errors.
########
@@ -54,8 +54,8 @@
use strict 'subs' ;
my $a = (B..Y);
EXPECT
+Bareword "B" not allowed while "strict subs" in use at - line 4.
Bareword "Y" not allowed while "strict subs" in use at - line 4.
-Bareword "B" not allowed while "strict subs" in use at - line 4.
Execution of - aborted due to compilation errors.
########
@@ -378,9 +378,18 @@
use strict 'subs';
qr/(?{my $x=foo})/;
EXPECT
-Bareword "foo" not allowed while "strict subs" in use at (re_eval 1) line 1.
-Compilation failed in regexp at - line 3.
+Bareword "foo" not allowed while "strict subs" in use at - line 3.
+Execution of - aborted due to compilation errors.
########
+# Regexp compilation errors weren't UTF-8 clean
+use strict 'subs';
+use utf8;
+use open qw( :utf8 :std );
+qr/(?{my $x=fòò})/;
+EXPECT
+Bareword "fòò" not allowed while "strict subs" in use at - line 5.
+Execution of - aborted due to compilation errors.
+########
# [perl #27628] strict 'subs' didn't warn on bareword array index
use strict 'subs';
my $x=$a[FOO];
@@ -432,3 +441,20 @@
foo:
ret
bar
+########
+# infinite loop breaks some strict checking
+use strict 'subs';
+sub foo {
+ 1 while 1;
+ kill FOO, 1;
+}
+EXPECT
+Bareword "FOO" not allowed while "strict subs" in use at - line 5.
+Execution of - aborted due to compilation errors.
+########
+# make sure checks are done within (?{})
+use strict 'subs';
+/(?{FOO})/
+EXPECT
+Bareword "FOO" not allowed while "strict subs" in use at - line 3.
+Execution of - aborted due to compilation errors.
Property changes on: trunk/contrib/perl/t/lib/strict/subs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/lib/strict/vars
===================================================================
--- trunk/contrib/perl/t/lib/strict/vars 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/strict/vars 2013-12-02 21:26:09 UTC (rev 6439)
@@ -83,6 +83,21 @@
########
# Check compile time scope of strict vars pragma
+use strict 'vars' ;
+use utf8;
+use open qw( :utf8 :std );
+{
+ no strict ;
+ $jòè = 1 ;
+}
+$jòè = 1 ;
+EXPECT
+Variable "$jòè" is not imported at - line 10.
+Global symbol "$jòè" requires explicit package name at - line 10.
+Execution of - aborted due to compilation errors.
+########
+
+# Check compile time scope of strict vars pragma
no strict;
{
use strict 'vars' ;
@@ -127,6 +142,23 @@
Compilation failed in require at - line 2.
########
+--FILE-- abc
+use strict 'vars' ;
+use utf8;
+use open qw( :utf8 :std );
+$jòè = 1 ;
+1;
+--FILE--
+use utf8;
+use open qw( :utf8 :std );
+$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.
+Compilation failed in require at - line 4.
+########
+
--FILE-- abc.pm
use strict 'vars' ;
$joe = 1 ;
@@ -142,6 +174,24 @@
########
--FILE-- abc.pm
+use strict 'vars' ;
+use utf8;
+use open qw( :utf8 :std );
+$jòè = 1 ;
+1;
+--FILE--
+use utf8;
+use open qw( :utf8 :std );
+$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.
+Compilation failed in require at - line 4.
+BEGIN failed--compilation aborted at - line 4.
+########
+
+--FILE-- abc.pm
package Burp;
use strict;
$a = 1;$f = 1;$k = 1; # just to get beyond the limit...
@@ -225,6 +275,22 @@
########
# Check scope of pragma with eval
+use strict 'vars' ;
+use utf8;
+use open qw( :utf8 :std );
+eval {
+ no strict ;
+ $jòè = 1 ;
+};
+print STDERR $@;
+$jòè = 1 ;
+EXPECT
+Variable "$jòè" is not imported at - line 11.
+Global symbol "$jòè" requires explicit package name at - line 11.
+Execution of - aborted due to compilation errors.
+########
+
+# Check scope of pragma with eval
no strict ;
eval '
$joe = 1 ;
@@ -337,6 +403,21 @@
Execution of - aborted due to compilation errors.
########
+# strict vars with elapsed our - error
+use strict 'vars' ;
+use utf8;
+use open qw( :utf8 :std );
+sub fòò {
+ our $frèd;
+ $frèd;
+}
+$frèd ;
+EXPECT
+Variable "$frèd" is not imported at - line 10.
+Global symbol "$frèd" requires explicit package name at - line 10.
+Execution of - aborted due to compilation errors.
+########
+
# nested our with local - no error
$fred = 1;
use strict 'vars';
@@ -415,7 +496,7 @@
########
# Make sure the strict vars failure still occurs
-# now that the `@i should be written as \@i' failure does not occur
+# now that the '@i should be written as \@i' failure does not occur
# 20000522 mjd at plover.com (MJD)
use strict 'vars';
no warnings;
@@ -437,9 +518,18 @@
use strict 'vars';
qr/(?{$foo++})/;
EXPECT
-Global symbol "$foo" requires explicit package name at (re_eval 1) line 1.
-Compilation failed in regexp at - line 3.
+Global symbol "$foo" requires explicit package name at - line 3.
+Execution of - aborted due to compilation errors.
########
+# Regex compilation errors weren't UTF-8 clean.
+use strict 'vars';
+use utf8;
+use open qw( :utf8 :std );
+qr/(?{$fòò++})/;
+EXPECT
+Global symbol "$fòò" requires explicit package name at - line 5.
+Execution of - aborted due to compilation errors.
+########
# [perl #73712] 'Variable is not imported' should be suppressible
$dweck;
use strict 'vars';
@@ -446,3 +536,40 @@
no warnings;
eval q/$dweck/;
EXPECT
+########
+# [perl #112316] strict vars getting confused by nulls
+# Assigning to a package whose name contains a null
+BEGIN { *Foo:: = *{"foo\0bar::"} }
+package foo;
+*Foo::bar = [];
+use strict;
+eval 'package Foo; @bar = 1' or die;
+EXPECT
+########
+# [perl #112316] strict vars getting confused by nulls
+# Assigning from within a package whose name contains a null
+BEGIN { *Foo:: = *{"foo\0bar::"} }
+package Foo;
+*foo::bar = [];
+use strict;
+eval 'package foo; @bar = 1' or die;
+EXPECT
+########
+# [perl #112316] strict vars getting confused by nulls
+# Assigning from one null package to another, with a common prefix
+BEGIN { *Foo:: = *{"foo\0foo::"};
+ *Bar:: = *{"foo\0bar::"} }
+package Foo;
+*Bar::bar = [];
+use strict;
+eval 'package Bar; @bar = 1' or die;
+EXPECT
+########
+# UTF8 and Latin1 package names equivalent at the byte level
+use utf8;
+# ĵ in UTF-8 is the same as ĵ in Latin-1
+package ĵ;
+*ĵ::bar = [];
+use strict;
+eval 'package ĵ; @bar = 1' or die;
+EXPECT
Property changes on: trunk/contrib/perl/t/lib/strict/vars
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/lib/subs/subs
===================================================================
--- trunk/contrib/perl/t/lib/subs/subs 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/subs/subs 2013-12-02 21:26:09 UTC (rev 6439)
@@ -80,3 +80,28 @@
sub Fred { print $_[0] + $_[1], "\n" }
EXPECT
3
+########
+
+# Error - not predeclaring a sub
+use utf8;
+use open qw( :utf8 :std );
+Frèd 1,2 ;
+sub Frèd {}
+EXPECT
+Number found where operator expected at - line 5, near "Frèd 1"
+ (Do you need to predeclare Frèd?)
+syntax error at - line 5, near "Frèd 1"
+Execution of - aborted due to compilation errors.
+########
+
+# Error - not predeclaring a sub in time
+use utf8;
+use open qw( :utf8 :std );
+ふれど 1,2 ;
+use subs qw( ふれど ) ;
+sub ふれど {}
+EXPECT
+Number found where operator expected at - line 5, near "ふれど 1"
+ (Do you need to predeclare ふれど?)
+syntax error at - line 5, near "ふれど 1"
+BEGIN not safe after errors--compilation aborted at - line 6.
Property changes on: trunk/contrib/perl/t/lib/subs/subs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/lib/test_require.pm (from rev 6437, vendor/perl/5.18.1/t/lib/test_require.pm)
===================================================================
--- trunk/contrib/perl/t/lib/test_require.pm (rev 0)
+++ trunk/contrib/perl/t/lib/test_require.pm 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,6 @@
+#!perl -w
+# Don't use strict because this is for testing require
+
+package test_require;
+
+++$test_require::loaded;
Index: trunk/contrib/perl/t/lib/test_use.pm
===================================================================
--- trunk/contrib/perl/t/lib/test_use.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/test_use.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/lib/test_use.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/lib/test_use_14937.pm
===================================================================
--- trunk/contrib/perl/t/lib/test_use_14937.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/test_use_14937.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/lib/test_use_14937.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/lib/universal.t
===================================================================
--- trunk/contrib/perl/t/lib/universal.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/universal.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -6,7 +6,7 @@
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
- plan( tests => 5 );
+ plan( tests => 13 );
}
for my $arg ('', 'q[]', qw( 1 undef )) {
@@ -15,12 +15,10 @@
tryit "&Internals::SvREADONLY($arg)";
tryit "&Internals::SvREFCNT($arg)";
tryit "&Internals::hv_clear_placeholders($arg)";
-tryit "&Internals::HvREHASH($arg)";
----
Usage: Internals::SvREADONLY(SCALAR[, ON]) at (eval 1) line 1.
Usage: Internals::SvREFCNT(SCALAR[, REFCOUNT]) at (eval 2) line 1.
Usage: Internals::hv_clear_placeholders(hv) at (eval 3) line 1.
-Internals::HvREHASH $hashref at (eval 4) line 1.
====
}
@@ -28,6 +26,37 @@
$x = *foo;
Internals::SvREADONLY $x, 1;
+ok Internals::SvREADONLY($x),
+ 'read-only glob copies are read-only acc. to Internals::';
eval { $x = [] };
like $@, qr/Modification of a read-only value attempted at/,
'read-only glob copies';
+Internals::SvREADONLY($x,0);
+$x = 42;
+is $x, 42, 'Internals::SvREADONLY can turn off readonliness on globs';
+
+# Same thing with regexps
+$x = ${qr//};
+Internals::SvREADONLY $x, 1;
+ok Internals::SvREADONLY($x),
+ 'read-only regexps are read-only acc. to Internals::';
+eval { $x = [] };
+like $@, qr/Modification of a read-only value attempted at/,
+ 'read-only regexps';
+Internals::SvREADONLY($x,0);
+$x = 42;
+is $x, 42, 'Internals::SvREADONLY can turn off readonliness on regexps';
+
+$h{a} = __PACKAGE__;
+Internals::SvREADONLY $h{a}, 1;
+eval { $h{a} = 3 };
+like $@, qr/Modification of a read-only value attempted at/,
+ 'making a COW scalar into a read-only one';
+
+$h{b} = __PACKAGE__;
+ok !Internals::SvREADONLY($h{b}),
+ 'cows are not read-only acc. to Internals::';
+Internals::SvREADONLY($h{b},0);
+$h{b} =~ y/ia/ao/;
+is __PACKAGE__, 'main',
+ 'turning off a cow’s readonliness did not affect sharers of the same PV';
Property changes on: trunk/contrib/perl/t/lib/universal.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/lib/warnings/1global
===================================================================
--- trunk/contrib/perl/t/lib/warnings/1global 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/warnings/1global 2013-12-02 21:26:09 UTC (rev 6439)
@@ -30,7 +30,36 @@
Reversed += operator at - line 4.
Name "main::a" used only once: possible typo at - line 4.
########
+-w
+# warnable code, warnings enabled via command line switch
+use utf8;
+use open qw( :utf8 :std );
+$Ằ =+ 3 ;
+EXPECT
+Reversed += operator at - line 5.
+Name "main::Ằ" used only once: possible typo at - line 5.
+########
+#! perl -w
+# warnable code, warnings enabled via #! line
+use utf8;
+use open qw( :utf8 :std );
+$Ằ =+ 3 ;
+EXPECT
+Reversed += operator at - line 5.
+Name "main::Ằ" used only once: possible typo at - line 5.
+########
+# warnable code, warnings enabled via compile time $^W
+BEGIN { $^W = 1 }
+use utf8;
+use open qw( :utf8 :std );
+$Ằ =+ 3 ;
+EXPECT
+Reversed += operator at - line 6.
+Name "main::Ằ" used only once: possible typo at - line 6.
+
+########
+
# compile-time warnable code, warnings enabled via runtime $^W
# so no warning printed.
$^W = 1 ;
Property changes on: trunk/contrib/perl/t/lib/warnings/1global
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/lib/warnings/2use
===================================================================
--- trunk/contrib/perl/t/lib/warnings/2use 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/warnings/2use 2013-12-02 21:26:09 UTC (rev 6439)
@@ -8,7 +8,7 @@
# check illegal category is caught
use warnings 'this-should-never-be-a-warning-category' ;
EXPECT
-Unknown warnings category 'this-should-never-be-a-warning-category' at - line 3
+Unknown warnings category 'this-should-never-be-a-warning-category' at - line 3.
BEGIN failed--compilation aborted at - line 3.
########
@@ -358,3 +358,22 @@
EXPECT
Reversed += operator at - line 6.
Use of uninitialized value $c in scalar chop at - line 9.
+########
+
+# Check that deprecation warnings are not implicitly disabled by use
+$*;
+use warnings "void";
+$#;
+EXPECT
+$* is no longer supported at - line 3.
+$# is no longer supported at - line 5.
+Useless use of a variable in void context at - line 5.
+########
+
+# Check that deprecation warnings are not implicitly disabled by no
+$*;
+no warnings "void";
+$#;
+EXPECT
+$* is no longer supported at - line 3.
+$# is no longer supported at - line 5.
Property changes on: trunk/contrib/perl/t/lib/warnings/2use
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/lib/warnings/3both
===================================================================
--- trunk/contrib/perl/t/lib/warnings/3both 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/warnings/3both 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/lib/warnings/3both
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/lib/warnings/4lint
===================================================================
--- trunk/contrib/perl/t/lib/warnings/4lint 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/warnings/4lint 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/lib/warnings/4lint
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/lib/warnings/5nolint
===================================================================
--- trunk/contrib/perl/t/lib/warnings/5nolint 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/warnings/5nolint 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/lib/warnings/5nolint
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/lib/warnings/6default
===================================================================
--- trunk/contrib/perl/t/lib/warnings/6default 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/warnings/6default 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/lib/warnings/6default
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/lib/warnings/7fatal
===================================================================
--- trunk/contrib/perl/t/lib/warnings/7fatal 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/warnings/7fatal 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/lib/warnings/7fatal
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/t/lib/warnings/8signal
===================================================================
--- trunk/contrib/perl/t/lib/warnings/8signal 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/warnings/8signal 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/lib/warnings/8signal
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/lib/warnings/9enabled
===================================================================
--- trunk/contrib/perl/t/lib/warnings/9enabled 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/warnings/9enabled 2013-12-02 21:26:09 UTC (rev 6439)
@@ -344,8 +344,8 @@
} ;
print $@ ;
EXPECT
-Usage: warnings::warn([category,] 'message') at - line 5
-Unknown warnings category 'fred' at - line 9
+Usage: warnings::warn([category,] 'message') at - line 5.
+Unknown warnings category 'fred' at - line 9.
########
# check warnings::warnif
@@ -359,8 +359,8 @@
} ;
print $@ ;
EXPECT
-Usage: warnings::warnif([category,] 'message') at - line 5
-Unknown warnings category 'fred' at - line 9
+Usage: warnings::warnif([category,] 'message') at - line 5.
+Unknown warnings category 'fred' at - line 9.
########
--FILE-- abc18.pm
@@ -373,7 +373,7 @@
use abc18;
abc18::check() ;
EXPECT
-hello at - line 3
+hello at - line 3.
########
--FILE-- abc19.pm
@@ -386,7 +386,7 @@
use abc19;
abc19::check() ;
EXPECT
-hello at - line 3
+hello at - line 3.
########
--FILE-- abc20.pm
@@ -402,7 +402,7 @@
} ;
print "[[$@]]\n";
EXPECT
-hello at - line 4
+hello at - line 4.
[[]]
########
@@ -419,7 +419,7 @@
} ;
print "[[$@]]\n";
EXPECT
-[[hello at - line 4
+[[hello at - line 4.
]]
########
-W
@@ -463,7 +463,7 @@
use abc24 ;
abc24::check() ;
EXPECT
-package 'abc24' not registered for warnings at abc24.pm line 4
+package 'abc24' not registered for warnings at abc24.pm line 4.
########
--FILE-- abc25.pm
@@ -478,7 +478,7 @@
use abc25 ;
abc25::check() ;
EXPECT
-package 'abc25' not registered for warnings at abc25.pm line 4
+package 'abc25' not registered for warnings at abc25.pm line 4.
########
--FILE-- abc26.pm
@@ -493,7 +493,7 @@
use abc26 ;
abc26::check() ;
EXPECT
-package 'abc26' not registered for warnings at abc26.pm line 4
+package 'abc26' not registered for warnings at abc26.pm line 4.
########
--FILE-- abc27.pm
@@ -652,7 +652,7 @@
use warnings "abc34" ;
abc34::check() ;
EXPECT
-hello at - line 3
+hello at - line 3.
########
--FILE-- abc35.pm
@@ -664,7 +664,7 @@
use abc35;
abc35::check() ;
EXPECT
-hello at - line 2
+hello at - line 2.
########
--FILE-- abc36.pm
@@ -680,7 +680,7 @@
} ;
print "[[$@]]\n";
EXPECT
-hello at - line 4
+hello at - line 4.
[[]]
########
@@ -697,7 +697,7 @@
} ;
print "[[$@]]\n";
EXPECT
-[[hello at - line 4
+[[hello at - line 4.
]]
########
-W
@@ -1005,9 +1005,9 @@
ok2
ok3
ok4
-my message 1 at - line 3
-my message 2 at - line 3
-my message 3 at - line 3
+my message 1 at - line 3.
+my message 2 at - line 3.
+my message 3 at - line 3.
########
--FILE-- def.pm
@@ -1044,9 +1044,9 @@
ok2
ok3
ok4
-my message 1 at abc49.pm line 5
-my message 2 at abc49.pm line 5
-my message 3 at abc49.pm line 5
+my message 1 at abc49.pm line 5.
+my message 2 at abc49.pm line 5.
+my message 3 at abc49.pm line 5.
########
--FILE-- def.pm
@@ -1089,8 +1089,8 @@
ok3
ok4
ok5
-my message 1 at - line 4
-my message 3 at - line 4
+my message 1 at - line 4.
+my message 3 at - line 4.
########
--FILE-- def.pm
@@ -1166,10 +1166,10 @@
ok4
ok5
ok6
-my message 1 at - line 5
-my message 2 at - line 5
-my message 4 at - line 5
-my message 8 at - line 5
+my message 1 at - line 5.
+my message 2 at - line 5.
+my message 4 at - line 5.
+my message 8 at - line 5.
**
ok1
ok2
@@ -1176,9 +1176,9 @@
ok3
ok4
ok5
-my message 1 at - line 8
-my message 2 at - line 8
-my message 4 at - line 8
+my message 1 at - line 8.
+my message 2 at - line 8.
+my message 4 at - line 8.
########
--FILE-- abc52.pm
@@ -1195,8 +1195,8 @@
use warnings("abc52", "abc52::bar");
abc52::check() ;
EXPECT
-hello at - line 3
-hello bar at - line 3
+hello at - line 3.
+hello bar at - line 3.
########
--FILE--
Property changes on: trunk/contrib/perl/t/lib/warnings/9enabled
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/lib/warnings/9uninit
===================================================================
--- trunk/contrib/perl/t/lib/warnings/9uninit 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/warnings/9uninit 2013-12-02 21:26:09 UTC (rev 6439)
@@ -33,6 +33,19 @@
Use of uninitialized value $m1 in addition (+) at - line 6.
########
use warnings 'uninitialized';
+use utf8;
+use open qw( :utf8 :std );
+
+$v = $à1 + 10;
+$v = 22 + $ａ2;
+$v = $à1 + $ａ2;
+EXPECT
+Use of uninitialized value $à1 in addition (+) at - line 5.
+Use of uninitialized value $ａ2 in addition (+) at - line 6.
+Use of uninitialized value $ａ2 in addition (+) at - line 7.
+Use of uninitialized value $à1 in addition (+) at - line 7.
+########
+use warnings 'uninitialized';
my ($m1, $v);
our ($g1, $g2);
@@ -296,9 +309,11 @@
close $m1; # exercises rv2gv
close $g1; # exercises rv2gv
+close undef; # exercises rv2gv
EXPECT
Use of uninitialized value $m1 in ref-to-glob cast at - line 5.
Use of uninitialized value $g1 in ref-to-glob cast at - line 6.
+Use of uninitialized value in ref-to-glob cast at - line 7.
########
use warnings 'uninitialized';
my ($m1, $m2, $v);
@@ -515,12 +530,12 @@
EXPECT
Use of uninitialized value $m1 in range (or flop) at - line 7.
Use of uninitialized value $m2 in range (or flop) at - line 8.
-Use of uninitialized value in range (or flop) at - line 9.
-Use of uninitialized value in range (or flop) at - line 9.
+Use of uninitialized value $m1 in range (or flop) at - line 9.
+Use of uninitialized value $m2 in range (or flop) at - line 9.
Use of uninitialized value $m1 in range (or flop) at - line 12.
Use of uninitialized value $m2 in range (or flop) at - line 13.
-Use of uninitialized value in range (or flop) at - line 14.
-Use of uninitialized value in range (or flop) at - line 14.
+Use of uninitialized value $m1 in range (or flop) at - line 14.
+Use of uninitialized value $m2 in range (or flop) at - line 14.
########
use warnings 'uninitialized';
my ($m1, $v);
@@ -617,6 +632,19 @@
@sort = sort {$a <=> $b} $m1, $g1;
sub sortf {$a-1 <=> $b-1};
@sort = sort &sortf, $m1, $g1;
+ at sort = sort { undef } 1, 2;
+sub frobnicate($$) { undef }
+ at sort = sort frobnicate 1, 2;
+ at sort = sort pyfg 1, 2;
+ at sort = sort pyfgc 1, 2;
+no warnings;
+sub pyfg { undef }
+sub pyfgc($$) { undef }
+use warnings;
+sub dog {}
+sub dogwood($$) {}
+ at sort = sort dog 1,2;
+ at sort = sort dogwood 1,2;
EXPECT
Use of uninitialized value $m1 in sort at - line 6.
Use of uninitialized value $g1 in sort at - line 6.
@@ -634,8 +662,30 @@
Use of uninitialized value $m1 in sort at - line 9.
Use of uninitialized value $g1 in sort at - line 9.
Use of uninitialized value $g1 in sort at - line 9.
+Use of uninitialized value in sort at - line 10.
+Use of uninitialized value in sort at - line 12.
+Use of uninitialized value in sort at - line 13.
+Use of uninitialized value in sort at - line 14.
+Use of uninitialized value in sort at - line 21.
+Use of uninitialized value in sort at - line 22.
########
+my $nan = sin 9**9**9;
+if ($nan == $nan) {
+ print <<EOM ;
+SKIPPED
+# No nan support
+EOM
+ exit ;
+}
use warnings 'uninitialized';
+# The optimised {$a<=>$b} case should behave the same way as unoptimised.
+ at sort = sort { ($a)[0] <=> $b } 1, $nan;
+ at sort = sort { $a <=> $b } 1, $nan;
+EXPECT
+Use of uninitialized value in sort at - line 11.
+Use of uninitialized value in sort at - line 12.
+########
+use warnings 'uninitialized';
my ($m1, $m2, $v);
our ($g1);
@@ -735,6 +785,7 @@
s//$g1/; undef $_;
s/$m1/$g1/; undef $_;
tr/x/y/; undef $_;
+tr/x/y/r; undef $_;
my $_;
/y/;
@@ -745,6 +796,7 @@
s//$g1/; undef $_;
s/$m1/$g1/; undef $_;
tr/x/y/; undef $_;
+tr/x/y/r; undef $_;
$g2 =~ /y/;
$g2 =~ /$m1/;
@@ -754,6 +806,7 @@
$g2 =~ s//$g1/; undef $g2;
$g2 =~ s/$m1/$g1/; undef $g2;
$g2 =~ tr/x/y/; undef $g2; # XXX can't extract var name yet
+$g2 =~ tr/x/y/r; undef $g2; # XXX can't extract var name yet
my $foo = "abc";
$foo =~ /$m1/;
@@ -767,6 +820,7 @@
$m1 = '$g1';
$foo =~ s//$m1/ee;
EXPECT
+Use of my $_ is experimental at - line 16.
Use of uninitialized value $_ in pattern match (m//) at - line 5.
Use of uninitialized value $m1 in regexp compilation at - line 6.
Use of uninitialized value $_ in pattern match (m//) at - line 6.
@@ -777,58 +831,58 @@
Use of uninitialized value $_ in substitution (s///) at - line 10.
Use of uninitialized value $_ in substitution (s///) at - line 10.
Use of uninitialized value $_ in substitution (s///) at - line 11.
-Use of uninitialized value $g1 in substitution (s///) at - line 11.
Use of uninitialized value $_ in substitution (s///) at - line 11.
-Use of uninitialized value $g1 in substitution (s///) at - line 11.
+Use of uninitialized value $g1 in substitution iterator at - line 11.
Use of uninitialized value $m1 in regexp compilation at - line 12.
Use of uninitialized value $_ in substitution (s///) at - line 12.
Use of uninitialized value $_ in substitution (s///) at - line 12.
Use of uninitialized value $g1 in substitution iterator at - line 12.
Use of uninitialized value $_ in transliteration (tr///) at - line 13.
-Use of uninitialized value $_ in pattern match (m//) at - line 16.
-Use of uninitialized value $m1 in regexp compilation at - line 17.
+Use of uninitialized value $_ in transliteration (tr///) at - line 14.
Use of uninitialized value $_ in pattern match (m//) at - line 17.
-Use of uninitialized value $g1 in regexp compilation at - line 18.
+Use of uninitialized value $m1 in regexp compilation at - line 18.
Use of uninitialized value $_ in pattern match (m//) at - line 18.
-Use of uninitialized value $_ in substitution (s///) at - line 19.
-Use of uninitialized value $m1 in regexp compilation at - line 20.
+Use of uninitialized value $g1 in regexp compilation at - line 19.
+Use of uninitialized value $_ in pattern match (m//) at - line 19.
Use of uninitialized value $_ in substitution (s///) at - line 20.
-Use of uninitialized value $_ in substitution (s///) at - line 20.
+Use of uninitialized value $m1 in regexp compilation at - line 21.
Use of uninitialized value $_ in substitution (s///) at - line 21.
-Use of uninitialized value $g1 in substitution (s///) at - line 21.
Use of uninitialized value $_ in substitution (s///) at - line 21.
-Use of uninitialized value $g1 in substitution (s///) at - line 21.
-Use of uninitialized value $m1 in regexp compilation at - line 22.
Use of uninitialized value $_ in substitution (s///) at - line 22.
Use of uninitialized value $_ in substitution (s///) at - line 22.
Use of uninitialized value $g1 in substitution iterator at - line 22.
-Use of uninitialized value $_ in transliteration (tr///) at - line 23.
-Use of uninitialized value $g2 in pattern match (m//) at - line 25.
-Use of uninitialized value $m1 in regexp compilation at - line 26.
-Use of uninitialized value $g2 in pattern match (m//) at - line 26.
-Use of uninitialized value $g1 in regexp compilation at - line 27.
+Use of uninitialized value $m1 in regexp compilation at - line 23.
+Use of uninitialized value $_ in substitution (s///) at - line 23.
+Use of uninitialized value $_ in substitution (s///) at - line 23.
+Use of uninitialized value $g1 in substitution iterator at - line 23.
+Use of uninitialized value $_ in transliteration (tr///) at - line 24.
+Use of uninitialized value $_ in transliteration (tr///) at - line 25.
Use of uninitialized value $g2 in pattern match (m//) at - line 27.
-Use of uninitialized value $g2 in substitution (s///) at - line 28.
-Use of uninitialized value $m1 in regexp compilation at - line 29.
-Use of uninitialized value $g2 in substitution (s///) at - line 29.
-Use of uninitialized value $g2 in substitution (s///) at - line 29.
+Use of uninitialized value $m1 in regexp compilation at - line 28.
+Use of uninitialized value $g2 in pattern match (m//) at - line 28.
+Use of uninitialized value $g1 in regexp compilation at - line 29.
+Use of uninitialized value $g2 in pattern match (m//) at - line 29.
Use of uninitialized value $g2 in substitution (s///) at - line 30.
-Use of uninitialized value $g1 in substitution (s///) at - line 30.
-Use of uninitialized value $g2 in substitution (s///) at - line 30.
-Use of uninitialized value $g1 in substitution (s///) at - line 30.
Use of uninitialized value $m1 in regexp compilation at - line 31.
Use of uninitialized value $g2 in substitution (s///) at - line 31.
Use of uninitialized value $g2 in substitution (s///) at - line 31.
-Use of uninitialized value $g1 in substitution iterator at - line 31.
-Use of uninitialized value in transliteration (tr///) at - line 32.
-Use of uninitialized value $m1 in regexp compilation at - line 35.
-Use of uninitialized value $g1 in regexp compilation at - line 36.
+Use of uninitialized value $g2 in substitution (s///) at - line 32.
+Use of uninitialized value $g2 in substitution (s///) at - line 32.
+Use of uninitialized value $g1 in substitution iterator at - line 32.
+Use of uninitialized value $m1 in regexp compilation at - line 33.
+Use of uninitialized value $g2 in substitution (s///) at - line 33.
+Use of uninitialized value $g2 in substitution (s///) at - line 33.
+Use of uninitialized value $g1 in substitution iterator at - line 33.
+Use of uninitialized value in transliteration (tr///) at - line 34.
+Use of uninitialized value in transliteration (tr///) at - line 35.
Use of uninitialized value $m1 in regexp compilation at - line 38.
-Use of uninitialized value $g1 in substitution (s///) at - line 39.
-Use of uninitialized value $m1 in regexp compilation at - line 40.
-Use of uninitialized value $g1 in substitution iterator at - line 40.
-Use of uninitialized value $m1 in substitution iterator at - line 41.
-Use of uninitialized value in substitution iterator at - line 44.
+Use of uninitialized value $g1 in regexp compilation at - line 39.
+Use of uninitialized value $m1 in regexp compilation at - line 41.
+Use of uninitialized value $g1 in substitution iterator at - line 42.
+Use of uninitialized value $m1 in regexp compilation at - line 43.
+Use of uninitialized value $g1 in substitution iterator at - line 43.
+Use of uninitialized value $m1 in substitution (s///) at - line 44.
+Use of uninitialized value in substitution iterator at - line 47.
########
use warnings 'uninitialized';
my ($m1);
@@ -963,23 +1017,22 @@
Use of uninitialized value $m2 in substr at - line 6.
Use of uninitialized value $g1 in substr at - line 6.
Use of uninitialized value $m1 in substr at - line 6.
-Use of uninitialized value $g2 in substr at - line 7.
Use of uninitialized value $m2 in substr at - line 7.
Use of uninitialized value $g1 in substr at - line 7.
+Use of uninitialized value $g2 in substr at - line 7.
Use of uninitialized value $m1 in substr at - line 7.
Use of uninitialized value $g1 in substr at - line 8.
+Use of uninitialized value $g2 in substr at - line 8.
Use of uninitialized value $m1 in substr at - line 8.
-Use of uninitialized value in scalar assignment at - line 8.
Use of uninitialized value $m2 in substr at - line 9.
Use of uninitialized value $g1 in substr at - line 9.
+Use of uninitialized value $g2 in substr at - line 9.
Use of uninitialized value $m1 in substr at - line 9.
-Use of uninitialized value in scalar assignment at - line 9.
Use of uninitialized value $m2 in vec at - line 11.
Use of uninitialized value $g1 in vec at - line 11.
Use of uninitialized value $m1 in vec at - line 11.
Use of uninitialized value $m2 in vec at - line 12.
Use of uninitialized value $g1 in vec at - line 12.
-Use of uninitialized value $m1 in vec at - line 12.
Use of uninitialized value $m1 in index at - line 14.
Use of uninitialized value $m2 in index at - line 14.
Use of uninitialized value $g1 in index at - line 15.
@@ -1088,8 +1141,8 @@
my @foo4=(1,undef); chop @foo4;
our @foo5=(1,undef); $v = sprintf "%s%s", at foo5;
my @foo6=(1,undef); $v = sprintf "%s%s", at foo6;
-our %foo7=('foo'=>'bar','baz'=>undef); $v = sprintf "%s%s",%foo7;
-my %foo8=('foo'=>'bar','baz'=>undef); $v = sprintf "%s%s",%foo8;
+our %foo7=('foo'=>'bar','baz'=>undef); $v = sprintf "%s%s%s%s",%foo7;
+my %foo8=('foo'=>'bar','baz'=>undef); $v = sprintf "%s%s%s%s",%foo8;
our @foo9 =(1,undef); $v = sprintf "%s%s%s%s",$m1, at foo9, $ma[2];
my @foo10=(1,undef); $v = sprintf "%s%s%s%s",$m2, at foo10,$ma[2];
our %foo11=('foo'=>'bar','baz'=>undef); $v = join '', %foo11;
@@ -1133,10 +1186,10 @@
my ($v);
# check hash key is sanitised
-my %h = ("\0011\002\r\n\t\f\"\\abcdefghijklmnopqrstuvwxyz", undef);
+my %h = ("\0011\002\r\n\t\f\"\\\x{1234}abcdefghijklmnopqrstuvwxyz", undef);
$v = join '', %h;
EXPECT
-Use of uninitialized value $h{"\0011\2\r\n\t\f\"\\abcdefghijklm"...} in join or string at - line 6.
+Use of uninitialized value $h{"\0011\2\r\n\t\f\"\\\x{1234}abcde"...} in join or string at - line 6.
########
use warnings 'uninitialized';
my ($m1, $v);
@@ -1170,8 +1223,6 @@
Use of uninitialized value $g1 in splice at - line 10.
Use of uninitialized value in addition (+) at - line 10.
Use of uninitialized value $m1 in method lookup at - line 13.
-Use of uninitialized value in subroutine entry at - line 15.
-Use of uninitialized value in subroutine entry at - line 16.
Use of uninitialized value $m1 in warn at - line 18.
Use of uninitialized value $g1 in warn at - line 18.
foo at - line 18.
@@ -1906,7 +1957,7 @@
EXPECT
Use of uninitialized value in addition (+) at - line 4.
########
-use warnings 'uninitialized';
+use warnings 'uninitialized'; no warnings 'experimental::smartmatch';
my $v;
my $fn = sub {};
$v = 1 + (1 ~~ $fn);
@@ -1962,3 +2013,77 @@
__END__
EXPECT
Use of uninitialized value in addition (+) at - line 3.
+########
+use warnings 'uninitialized';
+use constant {u=>undef, v=>undef};
+sub foo () {u}
+sub foo () {v}
+EXPECT
+########
+# [perl #72090]
+use warnings 'uninitialized';
+$a = @$a > 0;
+EXPECT
+Use of uninitialized value $a in array dereference at - line 3.
+Use of uninitialized value in numeric gt (>) at - line 3.
+########
+# [perl #103766]
+use warnings 'uninitialized';
+"@{[ $x ]}";
+EXPECT
+Use of uninitialized value in join or string at - line 3.
+########
+# inside formats
+use warnings 'uninitialized';
+my $x;
+format =
+@
+"$x";
+.
+write;
+EXPECT
+Use of uninitialized value $x in string at - line 6.
+########
+# NAME off-by-one error in hash bucket walk in key detection logic
+use warnings 'uninitialized';
+
+for ( 0 .. 20 ) { # we assume that this means we test keys for every bucket
+ my %h= ( $_ => undef );
+ my $s= sprintf "%s", $h{$_};
+}
+EXPECT
+Use of uninitialized value $h{"0"} in sprintf at - line 5.
+Use of uninitialized value $h{"1"} in sprintf at - line 5.
+Use of uninitialized value $h{"2"} in sprintf at - line 5.
+Use of uninitialized value $h{"3"} in sprintf at - line 5.
+Use of uninitialized value $h{"4"} in sprintf at - line 5.
+Use of uninitialized value $h{"5"} in sprintf at - line 5.
+Use of uninitialized value $h{"6"} in sprintf at - line 5.
+Use of uninitialized value $h{"7"} in sprintf at - line 5.
+Use of uninitialized value $h{"8"} in sprintf at - line 5.
+Use of uninitialized value $h{"9"} in sprintf at - line 5.
+Use of uninitialized value $h{"10"} in sprintf at - line 5.
+Use of uninitialized value $h{"11"} in sprintf at - line 5.
+Use of uninitialized value $h{"12"} in sprintf at - line 5.
+Use of uninitialized value $h{"13"} in sprintf at - line 5.
+Use of uninitialized value $h{"14"} in sprintf at - line 5.
+Use of uninitialized value $h{"15"} in sprintf at - line 5.
+Use of uninitialized value $h{"16"} in sprintf at - line 5.
+Use of uninitialized value $h{"17"} in sprintf at - line 5.
+Use of uninitialized value $h{"18"} in sprintf at - line 5.
+Use of uninitialized value $h{"19"} in sprintf at - line 5.
+Use of uninitialized value $h{"20"} in sprintf at - line 5.
+########
+# NAME SvPOK && SvLEN==0 should not produce uninit warning
+use warnings 'uninitialized';
+
+$v = int(${qr||}); # sv_2iv on a regexp
+$v = 1.1 * ${qr||}; # sv_2nv on a regexp
+$v = ${qr||} << 2; # sv_2uv on a regexp
+
+sub TIESCALAR{bless[]}
+sub FETCH {${qr||}}
+tie $t, "";
+$v = 1.1 * $t; # sv_2nv on a tied regexp
+
+EXPECT
Property changes on: trunk/contrib/perl/t/lib/warnings/9uninit
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/t/lib/warnings/av
===================================================================
--- trunk/contrib/perl/t/lib/warnings/av 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/warnings/av 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/lib/warnings/av
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/lib/warnings/doio
===================================================================
--- trunk/contrib/perl/t/lib/warnings/doio 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/warnings/doio 2013-12-02 21:26:09 UTC (rev 6439)
@@ -170,6 +170,16 @@
Use of -l on filehandle STDIN at - line 3.
Use of -l on filehandle $fh at - line 6.
########
+# doio.c [Perl_my_stat]
+use utf8;
+use open qw( :utf8 :std );
+use warnings 'io';
+-l ᶠᚻ;
+no warnings 'io';
+-l ᶠᚻ;
+EXPECT
+Use of -l on filehandle ᶠᚻ at - line 5.
+########
# doio.c [Perl_do_aexec5]
use warnings 'io' ;
exec "lskdjfalksdjfdjfkls","" ;
@@ -270,6 +280,8 @@
########
# doio.c [Perl_do_openn]
use Config;
+use utf8;
+use open qw( :utf8 :std );
BEGIN {
if (!$Config{useperlio}) {
print <<EOM;
@@ -280,6 +292,25 @@
}
}
use warnings 'io' ;
+close STDOUT;
+open ᶠᚻ1, "../harness"; close ᶠᚻ1;
+no warnings 'io' ;
+open ᶠᚻ2, "../harness"; close ᶠᚻ2;
+EXPECT
+Filehandle STDOUT reopened as ᶠᚻ1 only for input at - line 16.
+########
+# doio.c [Perl_do_openn]
+use Config;
+BEGIN {
+ if (!$Config{useperlio}) {
+ print <<EOM;
+SKIPPED
+# warns only with perlio
+EOM
+ exit;
+ }
+}
+use warnings 'io' ;
close STDIN;
open my $fh1, ">doiowarn.tmp"; close $fh1;
no warnings 'io' ;
@@ -287,3 +318,47 @@
unlink "doiowarn.tmp";
EXPECT
Filehandle STDIN reopened as $fh1 only for output at - line 14.
+########
+# doio.c [Perl_do_openn]
+use Config;
+use utf8;
+use open qw( :utf8 :std );
+BEGIN {
+ if (!$Config{useperlio}) {
+ print <<EOM;
+SKIPPED
+# warns only with perlio
+EOM
+ exit;
+ }
+}
+use warnings 'io' ;
+close STDIN;
+open my $ᶠᚻ1, ">doiowarn.tmp"; close $ᶠᚻ1;
+no warnings 'io' ;
+open my $ᶠᚻ2, ">doiowarn.tmp"; close $ᶠᚻ2;
+unlink "doiowarn.tmp";
+EXPECT
+Filehandle STDIN reopened as $ᶠᚻ1 only for output at - line 16.
+########
+# doio.c [Perl_do_openn]
+use Config;
+use utf8;
+use open qw( :utf8 :std );
+BEGIN {
+ if (!$Config{useperlio}) {
+ print <<EOM;
+SKIPPED
+# warns only with perlio
+EOM
+ exit;
+ }
+}
+use warnings 'io' ;
+close STDIN;
+open ᶠᚻ1, ">doiowarn.tmp"; close ᶠᚻ1;
+no warnings 'io' ;
+open ᶠᚻ2, ">doiowarn.tmp"; close ᶠᚻ2;
+unlink "doiowarn.tmp";
+EXPECT
+Filehandle STDIN reopened as ᶠᚻ1 only for output at - line 16.
Property changes on: trunk/contrib/perl/t/lib/warnings/doio
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/t/lib/warnings/doop
===================================================================
--- trunk/contrib/perl/t/lib/warnings/doop 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/warnings/doop 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/lib/warnings/doop
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/lib/warnings/gv
===================================================================
--- trunk/contrib/perl/t/lib/warnings/gv 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/warnings/gv 2013-12-02 21:26:09 UTC (rev 6439)
@@ -17,7 +17,7 @@
Mandatory Warnings ALL TODO
------------------
- Had to create %s unexpectedly [gv_fetchpv]
+ Had to create %SVf unexpectedly [gv_fetchpv]
Attempt to free unreferenced glob pointers [gp_free]
__END__
@@ -43,6 +43,16 @@
Use of inherited AUTOLOAD for non-method main::fred() is deprecated at - line 5.
########
# gv.c
+use utf8;
+use open qw( :utf8 :std );
+sub Oᕞʀ::AUTOLOAD { 1 } sub Oᕞʀ::fᕃƌ {}
+ at ISA = qw(Oᕞʀ) ;
+use warnings 'deprecated' ;
+fᕃƌ() ;
+EXPECT
+Use of inherited AUTOLOAD for non-method main::fᕃƌ() is deprecated at - line 7.
+########
+# gv.c
$a = ${"#"};
$a = ${"*"};
no warnings 'deprecated' ;
@@ -51,3 +61,63 @@
EXPECT
$# is no longer supported at - line 2.
$* is no longer supported at - line 3.
+########
+# gv.c
+$a = ${#};
+$a = ${*};
+no warnings 'deprecated' ;
+$a = ${#};
+$a = ${*};
+EXPECT
+$# is no longer supported at - line 2.
+$* is no longer supported at - line 3.
+########
+# gv.c
+$a = $#;
+$a = $*;
+$# = $a;
+$* = $a;
+$a = \$#;
+$a = \$*;
+no warnings 'deprecated' ;
+$a = $#;
+$a = $*;
+$# = $a;
+$* = $a;
+$a = \$#;
+$a = \$*;
+EXPECT
+$# is no longer supported at - line 2.
+$* is no longer supported at - line 3.
+$# is no longer supported at - line 4.
+$* is no longer supported at - line 5.
+$# is no longer supported at - line 6.
+$* is no longer supported at - line 7.
+########
+# gv.c
+ at a = @#;
+ at a = @*;
+$a = $#;
+$a = $*;
+EXPECT
+$# is no longer supported at - line 4.
+$* is no longer supported at - line 5.
+########
+# gv.c
+$a = $#;
+$a = $*;
+ at a = @#;
+ at a = @*;
+EXPECT
+$# is no longer supported at - line 2.
+$* is no longer supported at - line 3.
+########
+# gv.c
+use warnings 'syntax' ;
+use utf8;
+use open qw( :utf8 :std );
+package Ｙ;
+ at ISA = qw(Fred); joe()
+EXPECT
+Can't locate package Fred for @Ｙ::ISA at - line 6.
+Undefined subroutine &Ｙ::joe called at - line 6.
Property changes on: trunk/contrib/perl/t/lib/warnings/gv
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/lib/warnings/hv
===================================================================
--- trunk/contrib/perl/t/lib/warnings/hv 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/warnings/hv 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/lib/warnings/hv
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/lib/warnings/malloc
===================================================================
--- trunk/contrib/perl/t/lib/warnings/malloc 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/warnings/malloc 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/lib/warnings/malloc
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/lib/warnings/mg
===================================================================
--- trunk/contrib/perl/t/lib/warnings/mg 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/warnings/mg 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/lib/warnings/mg
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/lib/warnings/op
===================================================================
--- trunk/contrib/perl/t/lib/warnings/op 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/warnings/op 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,5 +1,8 @@
op.c AOK
+ Use of my $_ is experimental
+ my $_ ;
+
Found = in conditional, should be ==
1 if $a = 1 ;
@@ -72,7 +75,14 @@
defined(%hash) is deprecated
(Maybe you should just omit the defined()?)
my %h ; defined %h ;
-
+
+ "my %s" used in sort comparison
+
+ $[ used in comparison (did you mean $] ?)
+
+ length() used on @array (did you mean "scalar(@array)"?)
+ length() used on %hash (did you mean "scalar(keys %hash)"?)
+
/---/ should probably be written as "---"
join(/---/, @foo);
@@ -80,7 +90,7 @@
fred() ; sub fred ($$) {}
- Package `%s' not found (did you use the incorrect case?)
+ Package '%s' not found (did you use the incorrect case?)
Use of /g modifier is meaningless in split
@@ -92,18 +102,33 @@
sub fred() ;
sub fred($) {}
- Runaway prototype [newSUB] TODO
oops: oopsAV [oopsAV] TODO
oops: oopsHV [oopsHV] TODO
__END__
# op.c
+use warnings 'experimental::lexical_topic' ;
+my $_;
+CORE::state $_;
+no warnings 'experimental::lexical_topic' ;
+my $_;
+CORE::state $_;
+EXPECT
+Use of my $_ is experimental at - line 3.
+Use of state $_ is experimental at - line 4.
+########
+# op.c
use warnings 'syntax' ;
1 if $a = 1 ;
+1 if $a
+ = 1 ;
no warnings 'syntax' ;
1 if $a = 1 ;
+1 if $a
+ = 1 ;
EXPECT
Found = in conditional, should be == at - line 3.
+Found = in conditional, should be == at - line 4.
########
# op.c
use warnings 'syntax' ;
@@ -143,8 +168,10 @@
Using an array as a reference is deprecated at - line 10.
########
# op.c
-use warnings 'void' ; close STDIN ;
-1 x 3 ; # OP_REPEAT
+use warnings 'void' ; no warnings 'experimental::smartmatch'; close STDIN ;
+#line 2
+1 x 3 ; # OP_REPEAT (folded)
+(1) x 3 ; # OP_REPEAT
# OP_GVSV
wantarray ; # OP_WANTARRAY
# OP_GV
@@ -198,7 +225,10 @@
prototype "foo"; # OP_PROTOTYPE
$a ~~ $b; # OP_SMARTMATCH
$a <=> $b; # OP_NCMP
+use 5.015;
+__SUB__ # OP_RUNCV
EXPECT
+Useless use of a constant ("111") in void context at - line 2.
Useless use of repeat (x) in void context at - line 3.
Useless use of wantarray in void context at - line 5.
Useless use of reference-type operator in void context at - line 12.
@@ -239,6 +269,7 @@
Useless use of subroutine prototype in void context at - line 54.
Useless use of smart match in void context at - line 55.
Useless use of numeric comparison (<=>) in void context at - line 56.
+Useless use of __SUB__ in void context at - line 58.
########
# op.c
use warnings 'void' ; close STDIN ;
@@ -518,9 +549,9 @@
2 + 2; # optimized to OP_CONST
use constant U => undef;
U;
+qq/" \n/;
5 || print "bad\n"; # test OPpCONST_SHORTCIRCUIT
print "boo\n" if U; # test OPpCONST_SHORTCIRCUIT
-$[ = 2; # should not warn
no warnings 'void' ;
"abc"; # OP_CONST
7 ; # OP_CONST
@@ -527,30 +558,51 @@
"x" . "y"; # optimized to OP_CONST
2 + 2; # optimized to OP_CONST
EXPECT
-Useless use of a constant (abc) in void context at - line 3.
+Useless use of a constant ("abc") in void context at - line 3.
Useless use of a constant (7) in void context at - line 4.
-Useless use of a constant (xy) in void context at - line 5.
+Useless use of a constant ("xy") in void context at - line 5.
Useless use of a constant (4) in void context at - line 6.
Useless use of a constant (undef) in void context at - line 8.
+Useless use of a constant ("\"\t\n") in void context at - line 9.
########
# op.c
+use utf8;
+use open qw( :utf8 :std );
+use warnings 'void' ;
+"àḆc"; # OP_CONST
+"Ẋ" . "ƴ"; # optimized to OP_CONST
+ＦＯＯ; # Bareword optimized to OP_CONST
+use constant ů => undef;
+ů;
+5 || print "bad\n"; # test OPpCONST_SHORTCIRCUIT
+print "boo\n" if ů; # test OPpCONST_SHORTCIRCUIT
+no warnings 'void' ;
+"àḆc"; # OP_CONST
+"Ẋ" . "ƴ"; # optimized to OP_CONST
+EXPECT
+Useless use of a constant ("\340\x{1e06}c") in void context at - line 5.
+Useless use of a constant ("\x{1e8a}\x{1b4}") in void context at - line 6.
+Useless use of a constant ("\x{ff26}\x{ff2f}\x{ff2f}") in void context at - line 7.
+Useless use of a constant (undef) in void context at - line 9.
+########
+# op.c
#
use warnings 'misc' ;
my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ;my $d = 'test';
@a =~ /abc/ ;
- at a =~ s/a/b/ ;
- at a =~ tr/a/b/ ;
+ at a2 =~ s/a/b/ ;
+ at a3 =~ tr/a/b/ ;
@$b =~ /abc/ ;
@$b =~ s/a/b/ ;
@$b =~ tr/a/b/ ;
%a =~ /abc/ ;
-%a =~ s/a/b/ ;
-%a =~ tr/a/b/ ;
+%a2 =~ s/a/b/ ;
+%a3 =~ tr/a/b/ ;
%$c =~ /abc/ ;
%$c =~ s/a/b/ ;
%$c =~ tr/a/b/ ;
$d =~ tr/a/b/d ;
-$d =~ tr/a/bc/;
+$d2 =~ tr/a/bc/;
{
no warnings 'misc' ;
my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ; my $d = 'test';
@@ -570,21 +622,21 @@
$d =~ tr/a/bc/ ;
}
EXPECT
-Applying pattern match (m//) to @array will act on scalar(@array) at - line 5.
-Applying substitution (s///) to @array will act on scalar(@array) at - line 6.
-Applying transliteration (tr///) to @array will act on scalar(@array) at - line 7.
+Applying pattern match (m//) to @a will act on scalar(@a) at - line 5.
+Applying substitution (s///) to @a2 will act on scalar(@a2) at - line 6.
+Applying transliteration (tr///) to @a3 will act on scalar(@a3) at - line 7.
Applying pattern match (m//) to @array will act on scalar(@array) at - line 8.
Applying substitution (s///) to @array will act on scalar(@array) at - line 9.
Applying transliteration (tr///) to @array will act on scalar(@array) at - line 10.
-Applying pattern match (m//) to %hash will act on scalar(%hash) at - line 11.
-Applying substitution (s///) to %hash will act on scalar(%hash) at - line 12.
-Applying transliteration (tr///) to %hash will act on scalar(%hash) at - line 13.
+Applying pattern match (m//) to %a will act on scalar(%a) at - line 11.
+Applying substitution (s///) to %a2 will act on scalar(%a2) at - line 12.
+Applying transliteration (tr///) to %a3 will act on scalar(%a3) at - line 13.
Applying pattern match (m//) to %hash will act on scalar(%hash) at - line 14.
Applying substitution (s///) to %hash will act on scalar(%hash) at - line 15.
Applying transliteration (tr///) to %hash will act on scalar(%hash) at - line 16.
Useless use of /d modifier in transliteration operator at - line 17.
Replacement list is longer than search list at - line 18.
-Can't modify private array in substitution (s///) at - line 6, near "s/a/b/ ;"
+Can't modify array dereference in substitution (s///) at - line 6, near "s/a/b/ ;"
BEGIN not safe after errors--compilation aborted at - line 20.
########
# op.c
@@ -631,28 +683,43 @@
use warnings 'misc' ;
open FH, "<abc" ;
$x = 1 if $x = <FH> ;
+$x = 1 if $x
+ = <FH> ;
no warnings 'misc' ;
$x = 1 if $x = <FH> ;
+$x = 1 if $x
+ = <FH> ;
EXPECT
Value of <HANDLE> construct can be "0"; test with defined() at - line 4.
+Value of <HANDLE> construct can be "0"; test with defined() at - line 5.
########
# op.c
use warnings 'misc' ;
opendir FH, "." ;
$x = 1 if $x = readdir FH ;
+$x = 1 if $x
+ = readdir FH ;
no warnings 'misc' ;
$x = 1 if $x = readdir FH ;
+$x = 1 if $x
+ = readdir FH ;
closedir FH ;
EXPECT
Value of readdir() operator can be "0"; test with defined() at - line 4.
+Value of readdir() operator can be "0"; test with defined() at - line 5.
########
# op.c
use warnings 'misc' ;
$x = 1 if $x = <*> ;
+$x = 1 if $x
+ = <*> ;
no warnings 'misc' ;
$x = 1 if $x = <*> ;
+$x = 1 if $x
+ = <*> ;
EXPECT
Value of glob construct can be "0"; test with defined() at - line 3.
+Value of glob construct can be "0"; test with defined() at - line 4.
########
# op.c
use warnings 'misc' ;
@@ -693,10 +760,15 @@
use warnings 'redefine' ;
sub fred {}
sub fred {}
+sub fred { # warning should be for this line
+}
no warnings 'redefine' ;
sub fred {}
+sub fred {
+}
EXPECT
Subroutine fred redefined at - line 4.
+Subroutine fred redefined at - line 5.
########
# op.c
use warnings 'redefine' ;
@@ -708,18 +780,50 @@
Constant subroutine fred redefined at - line 4.
########
# op.c
-no warnings 'redefine' ;
sub fred () { 1 }
sub fred () { 2 }
EXPECT
+Constant subroutine fred redefined at - line 3.
+########
+# op.c
+sub fred () { 1 }
+*fred = sub () { 2 };
+EXPECT
+Constant subroutine main::fred redefined at - line 3.
+########
+# op.c
+use feature "lexical_subs", "state";
+my sub fred () { 1 }
+sub fred { 2 };
+my sub george { 1 }
+sub george () { 2 } # should *not* produce redef warnings by default
+state sub phred () { 1 }
+sub phred { 2 };
+state sub jorge { 1 }
+sub jorge () { 2 } # should *not* produce redef warnings by default
+EXPECT
+The lexical_subs feature is experimental at - line 3.
+Prototype mismatch: sub fred () vs none at - line 4.
Constant subroutine fred redefined at - line 4.
+The lexical_subs feature is experimental at - line 5.
+Prototype mismatch: sub george: none vs () at - line 6.
+The lexical_subs feature is experimental at - line 7.
+Prototype mismatch: sub phred () vs none at - line 8.
+Constant subroutine phred redefined at - line 8.
+The lexical_subs feature is experimental at - line 9.
+Prototype mismatch: sub jorge: none vs () at - line 10.
########
# op.c
no warnings 'redefine' ;
sub fred () { 1 }
+sub fred () { 2 }
+EXPECT
+########
+# op.c
+no warnings 'redefine' ;
+sub fred () { 1 }
*fred = sub () { 2 };
EXPECT
-Constant subroutine main::fred redefined at - line 4.
########
# op.c
use warnings 'redefine' ;
@@ -755,7 +859,19 @@
Statement unlikely to be reached at - line 4.
(Maybe you meant system() when you said exec()?)
########
+# op.c, no warning if exec isn't a statement.
+use warnings 'syntax' ;
+$a || exec "$^X -e 1" ;
+my $a
+EXPECT
+########
# op.c
+defined(@a);
+EXPECT
+defined(@array) is deprecated at - line 2.
+ (Maybe you should just omit the defined()?)
+########
+# op.c
my @a; defined(@a);
EXPECT
defined(@array) is deprecated at - line 2.
@@ -768,6 +884,12 @@
(Maybe you should just omit the defined()?)
########
# op.c
+defined(%h);
+EXPECT
+defined(%hash) is deprecated at - line 2.
+ (Maybe you should just omit the defined()?)
+########
+# op.c
my %h; defined(%h);
EXPECT
defined(%hash) is deprecated at - line 2.
@@ -783,10 +905,79 @@
# op.c
sub fred();
sub fred($) {}
+use constant foo=>bar; sub foo(@);
+use constant bav=>bar; sub bav(); # no warning
+sub btu; sub btu();
EXPECT
Prototype mismatch: sub main::fred () vs ($) at - line 3.
+Prototype mismatch: sub foo () vs (@) at - line 4.
+Prototype mismatch: sub btu: none vs () at - line 6.
########
# op.c
+use utf8;
+use open qw( :utf8 :std );
+sub frèd();
+sub frèd($) {}
+EXPECT
+Prototype mismatch: sub main::frèd () vs ($) at - line 5.
+########
+# op.c
+use utf8;
+use open qw( :utf8 :std );
+use warnings;
+eval "sub fòò (\$\0) {}";
+EXPECT
+Illegal character in prototype for main::fòò : $\0 at (eval 1) line 1.
+########
+# op.c
+use utf8;
+use open qw( :utf8 :std );
+use warnings;
+eval "sub foo (\0) {}";
+EXPECT
+Illegal character in prototype for main::foo : \0 at (eval 1) line 1.
+########
+# op.c
+use utf8;
+use open qw( :utf8 :std );
+use warnings;
+BEGIN { $::{"foo"} = "\$\0L\351on" }
+BEGIN { eval "sub foo (\$\0L\x{c3}\x{a9}on) {}"; }
+EXPECT
+Illegal character in prototype for main::foo : $\x{0}L... at (eval 1) line 1.
+########
+# op.c
+use utf8;
+use open qw( :utf8 :std );
+use warnings;
+BEGIN { eval "sub foo (\0) {}"; }
+EXPECT
+Illegal character in prototype for main::foo : \0 at (eval 1) line 1.
+########
+# op.c
+use warnings;
+eval "sub foo (\xAB) {}";
+EXPECT
+Illegal character in prototype for main::foo : \x{ab} at (eval 1) line 1.
+########
+# op.c
+use utf8;
+use open qw( :utf8 :std );
+use warnings;
+BEGIN { eval "sub foo (\x{30cb}) {}"; }
+EXPECT
+Illegal character in prototype for main::foo : \x{30cb} at (eval 1) line 1.
+########
+# op.c
+use utf8;
+use open qw( :utf8 :std );
+use warnings;
+BEGIN { $::{"foo"} = "\x{30cb}" }
+BEGIN { eval "sub foo {}"; }
+EXPECT
+Prototype mismatch: sub main::foo (ニ) vs none at (eval 1) line 1.
+########
+# op.c
$^W = 0 ;
sub fred() ;
sub fred($) {}
@@ -805,6 +996,189 @@
Prototype mismatch: sub main::freD () vs ($) at - line 11.
Prototype mismatch: sub main::FRED () vs ($) at - line 14.
########
+# op.c [S_simplify_sort]
+# [perl #86136]
+my @tests = split /^/, '
+ sort {$a <=> $b} @a;
+ sort {$a cmp $b} @a;
+ { use integer; sort {$a <=> $b} @a}
+ sort {$b <=> $a} @a;
+ sort {$b cmp $a} @a;
+ { use integer; sort {$b <=> $a} @a}
+';
+for my $pragma ('use warnings "syntax";', '') {
+ for my $vars ('', 'my $a;', 'my $b;', 'my ($a,$b);') {
+ for my $inner_stmt ('', 'print;', 'func();') {
+ eval "#line " . ++$line . "01 -\n$pragma\n$vars"
+ . join "", map s/sort \{\K/$inner_stmt/r, @tests;
+ $@ and die;
+ }
+ }
+}
+sub func{}
+use warnings 'syntax';
+my $a;
+# These used to be errors!
+sort { ; } $a <=> $b;
+sort { ; } $a, "<=>";
+sort { ; } $a, $cmp;
+sort $a, $b if $cmpany_name;
+sort if $a + $cmp;
+sort @t; $a + $cmp;
+EXPECT
+"my $a" used in sort comparison at - line 403.
+"my $a" used in sort comparison at - line 404.
+"my $a" used in sort comparison at - line 405.
+"my $a" used in sort comparison at - line 406.
+"my $a" used in sort comparison at - line 407.
+"my $a" used in sort comparison at - line 408.
+"my $a" used in sort comparison at - line 503.
+"my $a" used in sort comparison at - line 504.
+"my $a" used in sort comparison at - line 505.
+"my $a" used in sort comparison at - line 506.
+"my $a" used in sort comparison at - line 507.
+"my $a" used in sort comparison at - line 508.
+"my $a" used in sort comparison at - line 603.
+"my $a" used in sort comparison at - line 604.
+"my $a" used in sort comparison at - line 605.
+"my $a" used in sort comparison at - line 606.
+"my $a" used in sort comparison at - line 607.
+"my $a" used in sort comparison at - line 608.
+"my $b" used in sort comparison at - line 703.
+"my $b" used in sort comparison at - line 704.
+"my $b" used in sort comparison at - line 705.
+"my $b" used in sort comparison at - line 706.
+"my $b" used in sort comparison at - line 707.
+"my $b" used in sort comparison at - line 708.
+"my $b" used in sort comparison at - line 803.
+"my $b" used in sort comparison at - line 804.
+"my $b" used in sort comparison at - line 805.
+"my $b" used in sort comparison at - line 806.
+"my $b" used in sort comparison at - line 807.
+"my $b" used in sort comparison at - line 808.
+"my $b" used in sort comparison at - line 903.
+"my $b" used in sort comparison at - line 904.
+"my $b" used in sort comparison at - line 905.
+"my $b" used in sort comparison at - line 906.
+"my $b" used in sort comparison at - line 907.
+"my $b" used in sort comparison at - line 908.
+"my $a" used in sort comparison at - line 1003.
+"my $b" used in sort comparison at - line 1003.
+"my $a" used in sort comparison at - line 1004.
+"my $b" used in sort comparison at - line 1004.
+"my $a" used in sort comparison at - line 1005.
+"my $b" used in sort comparison at - line 1005.
+"my $b" used in sort comparison at - line 1006.
+"my $a" used in sort comparison at - line 1006.
+"my $b" used in sort comparison at - line 1007.
+"my $a" used in sort comparison at - line 1007.
+"my $b" used in sort comparison at - line 1008.
+"my $a" used in sort comparison at - line 1008.
+"my $a" used in sort comparison at - line 1103.
+"my $b" used in sort comparison at - line 1103.
+"my $a" used in sort comparison at - line 1104.
+"my $b" used in sort comparison at - line 1104.
+"my $a" used in sort comparison at - line 1105.
+"my $b" used in sort comparison at - line 1105.
+"my $b" used in sort comparison at - line 1106.
+"my $a" used in sort comparison at - line 1106.
+"my $b" used in sort comparison at - line 1107.
+"my $a" used in sort comparison at - line 1107.
+"my $b" used in sort comparison at - line 1108.
+"my $a" used in sort comparison at - line 1108.
+"my $a" used in sort comparison at - line 1203.
+"my $b" used in sort comparison at - line 1203.
+"my $a" used in sort comparison at - line 1204.
+"my $b" used in sort comparison at - line 1204.
+"my $a" used in sort comparison at - line 1205.
+"my $b" used in sort comparison at - line 1205.
+"my $b" used in sort comparison at - line 1206.
+"my $a" used in sort comparison at - line 1206.
+"my $b" used in sort comparison at - line 1207.
+"my $a" used in sort comparison at - line 1207.
+"my $b" used in sort comparison at - line 1208.
+"my $a" used in sort comparison at - line 1208.
+########
+# op.c [S_simplify_sort]
+use warnings 'syntax'; use 5.01;
+state $a;
+sort { $a <=> $b } ();
+EXPECT
+"state $a" used in sort comparison at - line 4.
+########
+# op.c [Perl_ck_cmp]
+use warnings 'syntax' ;
+no warnings 'deprecated';
+ at a = $[ < 5;
+ at a = $[ > 5;
+ at a = $[ <= 5;
+ at a = $[ >= 5;
+ at a = 42 < $[;
+ at a = 42 > $[;
+ at a = 42 <= $[;
+ at a = 42 >= $[;
+use integer;
+ at a = $[ < 5;
+ at a = $[ > 5;
+ at a = $[ <= 5;
+ at a = $[ >= 5;
+ at a = 42 < $[;
+ at a = 42 > $[;
+ at a = 42 <= $[;
+ at a = 42 >= $[;
+no integer;
+ at a = $[ < $5;
+ at a = $[ > $5;
+ at a = $[ <= $5;
+ at a = $[ >= $5;
+ at a = $42 < $[;
+ at a = $42 > $[;
+ at a = $42 <= $[;
+ at a = $42 >= $[;
+use integer;
+ at a = $[ < $5;
+ at a = $[ > $5;
+ at a = $[ <= $5;
+ at a = $[ >= $5;
+ at a = $42 < $[;
+ at a = $42 > $[;
+ at a = $42 <= $[;
+ at a = $42 >= $[;
+EXPECT
+$[ used in numeric lt (<) (did you mean $] ?) at - line 4.
+$[ used in numeric gt (>) (did you mean $] ?) at - line 5.
+$[ used in numeric le (<=) (did you mean $] ?) at - line 6.
+$[ used in numeric ge (>=) (did you mean $] ?) at - line 7.
+$[ used in numeric lt (<) (did you mean $] ?) at - line 8.
+$[ used in numeric gt (>) (did you mean $] ?) at - line 9.
+$[ used in numeric le (<=) (did you mean $] ?) at - line 10.
+$[ used in numeric ge (>=) (did you mean $] ?) at - line 11.
+$[ used in numeric lt (<) (did you mean $] ?) at - line 13.
+$[ used in numeric gt (>) (did you mean $] ?) at - line 14.
+$[ used in numeric le (<=) (did you mean $] ?) at - line 15.
+$[ used in numeric ge (>=) (did you mean $] ?) at - line 16.
+$[ used in numeric lt (<) (did you mean $] ?) at - line 17.
+$[ used in numeric gt (>) (did you mean $] ?) at - line 18.
+$[ used in numeric le (<=) (did you mean $] ?) at - line 19.
+$[ used in numeric ge (>=) (did you mean $] ?) at - line 20.
+########
+# op.c [Perl_ck_length]
+use warnings 'syntax' ;
+length(@a);
+length(%b);
+length(@$c);
+length(%$d);
+length($a);
+length(my %h);
+length(my @g);
+EXPECT
+length() used on @a (did you mean "scalar(@a)"?) at - line 3.
+length() used on %b (did you mean "scalar(keys %b)"?) at - line 4.
+length() used on @array (did you mean "scalar(@array)"?) at - line 5.
+length() used on %hash (did you mean "scalar(keys %hash)"?) at - line 6.
+length() used on %h (did you mean "scalar(keys %h)"?) at - line 8.
+length() used on @g (did you mean "scalar(@g)"?) at - line 9.
+########
# op.c
use warnings 'syntax' ;
join /---/, 'x', 'y', 'z';
@@ -811,6 +1185,14 @@
EXPECT
/---/ should probably be written as "---" at - line 3.
########
+# op.c
+use utf8;
+use open qw( :utf8 :std );
+use warnings 'syntax' ;
+join /～～～/, 'x', 'y', 'z';
+EXPECT
+/～～～/ should probably be written as "～～～" at - line 5.
+########
# op.c [Perl_peep]
use warnings 'prototype' ;
fred() ;
@@ -999,7 +1381,6 @@
local(vec($x,0,1)); # OP_VEC
local($a[$b]); # OP_AELEM ok
local($a{$b}); # OP_HELEM ok
-local($[); # OP_CONST
no warnings 'syntax';
EXPECT
@@ -1082,3 +1463,101 @@
split /y/, "z";
EXPECT
Useless use of split in void context at - line 5.
+########
+# op.c
+use warnings 'redefine' ;
+use utf8;
+use open qw( :utf8 :std );
+sub frèd {}
+sub frèd {}
+no warnings 'redefine' ;
+sub frèd {}
+EXPECT
+Subroutine frèd redefined at - line 6.
+########
+# op.c
+use warnings 'redefine' ;
+use utf8;
+use open qw( :utf8 :std );
+sub frèd () { 1 }
+sub frèd () { 1 }
+no warnings 'redefine' ;
+sub frèd () { 1 }
+EXPECT
+Constant subroutine frèd redefined at - line 6.
+########
+# op.c
+use utf8;
+use open qw( :utf8 :std );
+sub frèd () { 1 }
+sub frèd () { 2 }
+EXPECT
+Constant subroutine frèd redefined at - line 5.
+########
+# op.c
+use utf8;
+use open qw( :utf8 :std );
+sub frèd () { 1 }
+*frèd = sub () { 2 };
+EXPECT
+Constant subroutine main::frèd redefined at - line 5.
+########
+# op.c
+use warnings 'redefine' ;
+use utf8;
+use open qw( :utf8 :std );
+sub ᚠርƊ {}
+sub ᚠርƊ {}
+no warnings 'redefine' ;
+sub ᚠርƊ {}
+EXPECT
+Subroutine ᚠርƊ redefined at - line 6.
+########
+# op.c
+use warnings 'redefine' ;
+use utf8;
+use open qw( :utf8 :std );
+sub ᚠርƊ () { 1 }
+sub ᚠርƊ () { 1 }
+no warnings 'redefine' ;
+sub ᚠርƊ () { 1 }
+EXPECT
+Constant subroutine ᚠርƊ redefined at - line 6.
+########
+# op.c
+use utf8;
+use open qw( :utf8 :std );
+sub ᚠርƊ () { 1 }
+sub ᚠርƊ () { 2 }
+EXPECT
+Constant subroutine ᚠርƊ redefined at - line 5.
+########
+# op.c
+use utf8;
+use open qw( :utf8 :std );
+sub ᚠርƊ () { 1 }
+*ᚠርƊ = sub () { 2 };
+EXPECT
+Constant subroutine main::ᚠርƊ redefined at - line 5.
+########
+# OPTION regex
+sub DynaLoader::dl_error {};
+use warnings;
+# We're testing that the warnings report the same line number:
+eval <<'EOC' or die $@;
+{
+ DynaLoader::boot_DynaLoader("DynaLoader");
+}
+EOC
+eval <<'EOC' or die $@;
+BEGIN {
+ DynaLoader::boot_DynaLoader("DynaLoader");
+}
+1
+EOC
+EXPECT
+OPTION regex
+\ASubroutine DynaLoader::dl_error redefined at \(eval 1\) line 2\.
+?(?s).*
+Subroutine DynaLoader::dl_error redefined at \(eval 2\) line 2\.
+########
Property changes on: trunk/contrib/perl/t/lib/warnings/op
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/lib/warnings/pad
===================================================================
--- trunk/contrib/perl/t/lib/warnings/pad 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/warnings/pad 2013-12-02 21:26:09 UTC (rev 6439)
@@ -173,7 +173,7 @@
}->();
f();
EXPECT
-Variable "$x" is not available at (eval 1) line 2.
+Variable "$x" is not available at (eval 1) line 1.
########
# pad.c
use warnings 'closure' ;
@@ -195,7 +195,7 @@
}
f()->();
EXPECT
-Variable "$x" is not available at (eval 1) line 2.
+Variable "$x" is not available at (eval 1) line 1.
########
use warnings 'closure' ;
{
@@ -205,7 +205,7 @@
}
f2();
EXPECT
-Variable "$x" is not available at (eval 1) line 2.
+Variable "$x" is not available at (eval 1) line 1.
########
use warnings 'closure' ;
for my $x (1,2,3) {
@@ -214,7 +214,7 @@
}
f();
EXPECT
-Variable "$x" is not available at (eval 4) line 2.
+Variable "$x" is not available at (eval 4) line 1.
########
# pad.c
no warnings 'closure' ;
@@ -327,3 +327,248 @@
our $_;
EXPECT
"our" variable $_ redeclared at - line 6.
+########
+use warnings 'misc';
+BEGIN { binmode STDERR, 'utf8'; }
+{
+ use utf8;
+ my $ニコニコ;
+ my $ニコニコ;
+}
+EXPECT
+"my" variable $ニコニコ masks earlier declaration in same scope at - line 6.
+########
+use warnings 'misc';
+BEGIN { binmode STDERR, 'utf8'; }
+{
+ use utf8;
+ my $thìs;
+ my $thìs;
+}
+EXPECT
+"my" variable $thìs masks earlier declaration in same scope at - line 6.
+########
+# pad.c
+use warnings 'closure' ;
+BEGIN { binmode STDERR, 'utf8'; }
+sub {
+ use utf8;
+ my $è;
+ sub f { $è }
+}->();
+EXPECT
+Variable "$è" is not available at - line 7.
+########
+# pad.c
+use warnings 'closure' ;
+BEGIN { binmode STDERR, 'utf8'; }
+sub {
+ use utf8;
+ my $ニ;
+ sub f { $ニ }
+}->();
+EXPECT
+Variable "$ニ" is not available at - line 7.
+########
+# pad.c
+use warnings 'closure' ;
+BEGIN { binmode STDERR, 'utf8'; }
+sub x {
+ use utf8;
+ my $に;
+ sub y {
+ $に
+ }
+ }
+EXPECT
+Variable "$に" will not stay shared at - line 9.
+########
+# pad.c
+use warnings 'closure' ;
+BEGIN { binmode STDERR, 'utf8'; }
+sub x {
+ use utf8;
+ my $に;
+ sub y {
+ sub { $に }
+ }
+ }
+EXPECT
+Variable "$に" will not stay shared at - line 8.
+########
+# pad.c
+use warnings 'closure' ;
+BEGIN { binmode STDERR, 'utf8'; }
+sub x {
+ use utf8;
+ my $に;
+ sub {
+ $に;
+ sub y {
+ $に
+ }
+ }->();
+}
+EXPECT
+Variable "$に" will not stay shared at - line 11.
+########
+# pad.c
+use warnings 'closure' ;
+BEGIN { binmode STDERR, 'utf8'; }
+sub {
+ use utf8;
+ my $に;
+ sub f { $に }
+}->();
+EXPECT
+Variable "$に" is not available at - line 7.
+########
+# pad.c
+use warnings 'closure' ;
+BEGIN { binmode STDERR, 'utf8'; }
+sub {
+ use utf8;
+ my $に;
+ sub f { eval '$に' }
+}->();
+f();
+EXPECT
+Variable "$に" is not available at (eval 1) line 1.
+########
+# pad.c
+# see bugid 1754
+use warnings 'closure' ;
+BEGIN { binmode STDERR, 'utf8'; }
+sub f {
+ use utf8;
+ my $に;
+ sub { eval '$に' };
+}
+f()->();
+EXPECT
+Variable "$に" is not available at (eval 1) line 1.
+########
+use warnings 'closure' ;
+BEGIN { binmode STDERR, 'utf8'; }
+{
+ use utf8;
+ my $に = 1;
+ $y = \$に; # force abandonment rather than clear-in-place at scope exit
+ sub f2 { eval '$に' }
+}
+f2();
+EXPECT
+Variable "$に" is not available at (eval 1) line 1.
+########
+use warnings 'closure' ;
+BEGIN { binmode STDERR, 'utf8'; }
+use utf8;
+for my $に (1,2,3) {
+ sub f { eval '$に' }
+ f();
+}
+f();
+EXPECT
+Variable "$に" is not available at (eval 4) line 1.
+########
+# pad.c
+use warnings 'closure' ;
+BEGIN { binmode STDERR, 'utf8'; }
+sub x {
+ use utf8;
+ my $è;
+ sub y {
+ $è
+ }
+ }
+EXPECT
+Variable "$è" will not stay shared at - line 9.
+########
+# pad.c
+use warnings 'closure' ;
+BEGIN { binmode STDERR, 'utf8'; }
+sub x {
+ use utf8;
+ my $è;
+ sub y {
+ sub { $è }
+ }
+ }
+EXPECT
+Variable "$è" will not stay shared at - line 8.
+########
+# pad.c
+use warnings 'closure' ;
+BEGIN { binmode STDERR, 'utf8'; }
+sub x {
+ use utf8;
+ my $è;
+ sub {
+ $è;
+ sub y {
+ $è
+ }
+ }->();
+}
+EXPECT
+Variable "$è" will not stay shared at - line 11.
+########
+# pad.c
+use warnings 'closure' ;
+BEGIN { binmode STDERR, 'utf8'; }
+sub {
+ use utf8;
+ my $è;
+ sub f { $è }
+}->();
+EXPECT
+Variable "$è" is not available at - line 7.
+########
+# pad.c
+use warnings 'closure' ;
+BEGIN { binmode STDERR, 'utf8'; }
+sub {
+ use utf8;
+ my $è;
+ sub f { eval '$è' }
+}->();
+f();
+EXPECT
+Variable "$è" is not available at (eval 1) line 1.
+########
+# pad.c
+# see bugid 1754
+use warnings 'closure' ;
+BEGIN { binmode STDERR, 'utf8'; }
+sub f {
+ use utf8;
+ my $è;
+ sub { eval '$è' };
+}
+f()->();
+EXPECT
+Variable "$è" is not available at (eval 1) line 1.
+########
+use warnings 'closure' ;
+BEGIN { binmode STDERR, 'utf8'; }
+{
+ use utf8;
+ my $è = 1;
+ $y = \$è; # force abandonment rather than clear-in-place at scope exit
+ sub f2 { eval '$è' }
+}
+f2();
+EXPECT
+Variable "$è" is not available at (eval 1) line 1.
+########
+use warnings 'closure' ;
+BEGIN { binmode STDERR, 'utf8'; }
+use utf8;
+for my $è (1,2,3) {
+ sub f { eval '$è' }
+ f();
+}
+f();
+EXPECT
+Variable "$è" is not available at (eval 4) line 1.
+########
Property changes on: trunk/contrib/perl/t/lib/warnings/pad
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/lib/warnings/perl
===================================================================
--- trunk/contrib/perl/t/lib/warnings/perl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/warnings/perl 2013-12-02 21:26:09 UTC (rev 6439)
@@ -71,3 +71,161 @@
$y = 3 ;
EXPECT
Name "main::y" used only once: possible typo at - line 6.
+########
+
+# perl.c
+use utf8;
+use open qw( :utf8 :std );
+no warnings 'once' ;
+$ᛪ = 3 ;
+use warnings 'once' ;
+$ȥ = 3 ;
+EXPECT
+Name "main::ȥ" used only once: possible typo at - line 8.
+########
+-w
+# perl.c
+use utf8;
+use open qw( :utf8 :std );
+$ᛪ = 3 ;
+no warnings 'once' ;
+$ȥ = 3;
+EXPECT
+Name "main::ᛪ" used only once: possible typo at - line 5.
+########
+# perl.c
+use utf8;
+use open qw( :utf8 :std );
+BEGIN { $^W =1 ; }
+$ᛪ = 3 ;
+no warnings 'once' ;
+$ȥ = 3
+EXPECT
+Name "main::ᛪ" used only once: possible typo at - line 5.
+########
+-W
+# perl.c
+use utf8;
+use open qw( :utf8 :std );
+no warnings 'once' ;
+$ᛪ = 3 ;
+use warnings 'once' ;
+$ȥ = 3 ;
+EXPECT
+OPTION random
+Name "main::ȥ" used only once: possible typo at - line 8.
+Name "main::ᛪ" used only once: possible typo at - line 6.
+########
+-X
+# perl.c
+use utf8;
+use open qw( :utf8 :std );
+use warnings 'once' ;
+$ᛪ = 3 ;
+EXPECT
+########
+
+# perl.c
+use utf8;
+use open qw( :utf8 :std );
+{ use warnings 'once' ; $ᛪ = 3 ; }
+$ŷ = 3 ;
+EXPECT
+Name "main::ᛪ" used only once: possible typo at - line 5.
+########
+
+# perl.c
+use utf8;
+use open qw( :utf8 :std );
+$ȥ = 3 ;
+BEGIN { $^W = 1 }
+{ no warnings 'once' ; $ᛪ = 3 ; }
+$ŷ = 3 ;
+EXPECT
+Name "main::ŷ" used only once: possible typo at - line 8.
+########
+
+
+# perl.c
+use utf8;
+use open qw( :utf8 :std );
+package ɕლȃṢȿ;
+no warnings 'once' ;
+$ᛪ = 3 ;
+use warnings 'once' ;
+$ȥ = 3 ;
+EXPECT
+Name "ɕლȃṢȿ::ȥ" used only once: possible typo at - line 10.
+########
+-w
+# perl.c
+use utf8;
+use open qw( :utf8 :std );
+package ɕლȃṢȿ;
+$ᛪ = 3 ;
+no warnings 'once' ;
+$ȥ = 3
+EXPECT
+Name "ɕლȃṢȿ::ᛪ" used only once: possible typo at - line 6.
+########
+# perl.c
+use utf8;
+use open qw( :utf8 :std );
+package ɕლȃṢȿ;
+BEGIN { $^W =1 ; }
+$ᛪ = 3 ;
+no warnings 'once' ;
+$ȥ = 3
+EXPECT
+Name "ɕლȃṢȿ::ᛪ" used only once: possible typo at - line 6.
+########
+-W
+# perl.c
+use utf8;
+use open qw( :utf8 :std );
+package ɕლȃṢȿ;
+no warnings 'once' ;
+$ᛪ = 3 ;
+use warnings 'once' ;
+$ȥ = 3 ;
+EXPECT
+OPTION random
+Name "ɕლȃṢȿ::ᛪ" used only once: possible typo at - line 7.
+Name "ɕლȃṢȿ::ȥ" used only once: possible typo at - line 9.
+########
+-X
+# perl.c
+use utf8;
+use open qw( :utf8 :std );
+use warnings 'once' ;
+package ɕლȃṢȿ;
+$ᛪ = 3 ;
+EXPECT
+########
+
+# perl.c
+use utf8;
+use open qw( :utf8 :std );
+package ɕლȃṢȿ;
+{ use warnings 'once' ; $ᛪ = 3 ; }
+$ŷ = 3 ;
+EXPECT
+Name "ɕლȃṢȿ::ᛪ" used only once: possible typo at - line 6.
+########
+
+# perl.c
+use utf8;
+use open qw( :utf8 :std );
+package ɕლȃṢȿ;
+$ȥ = 3 ;
+BEGIN { $^W = 1 }
+{ no warnings 'once' ; $ᛪ = 3 ; }
+$ŷ = 3 ;
+EXPECT
+Name "ɕლȃṢȿ::ŷ" used only once: possible typo at - line 9.
+########
+
+use warnings 'once';
+$foo++; BEGIN { eval q|@a =~ s///; sub foo;| }
+EXPECT
+Name "main::foo" used only once: possible typo at - line 3.
Property changes on: trunk/contrib/perl/t/lib/warnings/perl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/lib/warnings/perlio
===================================================================
--- trunk/contrib/perl/t/lib/warnings/perlio 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/warnings/perlio 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/lib/warnings/perlio
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/lib/warnings/perly
===================================================================
--- trunk/contrib/perl/t/lib/warnings/perly 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/warnings/perly 2013-12-02 21:26:09 UTC (rev 6439)
@@ -8,23 +8,6 @@
sub fred {} $a = "fred" ; do $a()
sub fred {} $a = "fred" ; do $a(1)
- Use of qw(...) as parentheses is deprecated
-
- if qw(a) {}
- unless qw(a) {}
- if (0) {} elsif qw(a) {}
- given qw(a) {}
- when qw(a) {}
- while qw(a) {}
- until qw(a) {}
- foreach $x qw(a b c) {}
- foreach my $x qw(a b c) {}
- $obj->meth qw(a b c)
- do foo qw(a b c)
- do $subref qw(a b c)
- &foo qw(a b c)
- $a[0] qw(a b c)
-
__END__
# perly.y
use warnings 'deprecated' ;
@@ -45,222 +28,3 @@
Use of "do" to call subroutines is deprecated at - line 5.
Use of "do" to call subroutines is deprecated at - line 7.
Use of "do" to call subroutines is deprecated at - line 8.
-########
-use warnings qw(deprecated void);
-if qw(a) { print "x0\n"; } else { }
-if qw(0) { print "x1\n"; } else { }
-if qw(z a) { print "x2\n"; } else { }
-if qw(z 0) { print "x3\n"; } else { }
-EXPECT
-Use of qw(...) as parentheses is deprecated at - line 2.
-Use of qw(...) as parentheses is deprecated at - line 3.
-Use of qw(...) as parentheses is deprecated at - line 4.
-Useless use of a constant (z) in void context at - line 4.
-Use of qw(...) as parentheses is deprecated at - line 5.
-Useless use of a constant (z) in void context at - line 5.
-x0
-x2
-########
-if qw() { print "x0\n"; } else { }
-EXPECT
-Use of qw(...) as parentheses is deprecated at - line 1.
-syntax error at - line 1, near "if qw()"
-Execution of - aborted due to compilation errors.
-########
-use warnings qw(deprecated void);
-unless qw(a) { print "x0\n"; } else { }
-unless qw(0) { print "x1\n"; } else { }
-unless qw(z a) { print "x2\n"; } else { }
-unless qw(z 0) { print "x3\n"; } else { }
-EXPECT
-Use of qw(...) as parentheses is deprecated at - line 2.
-Use of qw(...) as parentheses is deprecated at - line 3.
-Use of qw(...) as parentheses is deprecated at - line 4.
-Useless use of a constant (z) in void context at - line 4.
-Use of qw(...) as parentheses is deprecated at - line 5.
-Useless use of a constant (z) in void context at - line 5.
-x1
-x3
-########
-unless qw() { print "x0\n"; } else { }
-EXPECT
-Use of qw(...) as parentheses is deprecated at - line 1.
-syntax error at - line 1, near "unless qw()"
-Execution of - aborted due to compilation errors.
-########
-use warnings qw(deprecated void);
-if(0) { print "eek\n"; } elsif qw(a) { print "x0\n"; } else { }
-if(0) { print "eek\n"; } elsif qw(0) { print "x1\n"; } else { }
-if(0) { print "eek\n"; } elsif qw(z a) { print "x2\n"; } else { }
-if(0) { print "eek\n"; } elsif qw(z 0) { print "x3\n"; } else { }
-EXPECT
-Use of qw(...) as parentheses is deprecated at - line 2.
-Use of qw(...) as parentheses is deprecated at - line 3.
-Use of qw(...) as parentheses is deprecated at - line 4.
-Useless use of a constant (z) in void context at - line 4.
-Use of qw(...) as parentheses is deprecated at - line 5.
-Useless use of a constant (z) in void context at - line 5.
-x0
-x2
-########
-if(0) { print "eek\n"; } elsif qw() { print "x0\n"; } else { }
-EXPECT
-Use of qw(...) as parentheses is deprecated at - line 1.
-syntax error at - line 1, near "elsif qw()"
-Execution of - aborted due to compilation errors.
-########
-use warnings qw(deprecated void); use feature "switch";
-given qw(a) { print "x0 $_\n"; }
-given qw(z a) { print "x1 $_\n"; }
-EXPECT
-Use of qw(...) as parentheses is deprecated at - line 2.
-Use of qw(...) as parentheses is deprecated at - line 3.
-Useless use of a constant (z) in void context at - line 3.
-x0 a
-x1 a
-########
-use feature "switch";
-given qw() { print "x0\n"; }
-EXPECT
-Use of qw(...) as parentheses is deprecated at - line 2.
-syntax error at - line 2, near "given qw()"
-Execution of - aborted due to compilation errors.
-########
-use warnings qw(deprecated void); use feature "switch";
-given("a") { when qw(a) { print "x0\n"; } }
-given("a") { when qw(b) { print "x1\n"; } }
-given("a") { when qw(z a) { print "x2\n"; } }
-given("a") { when qw(z b) { print "x3\n"; } }
-EXPECT
-Use of qw(...) as parentheses is deprecated at - line 2.
-Use of qw(...) as parentheses is deprecated at - line 3.
-Use of qw(...) as parentheses is deprecated at - line 4.
-Useless use of a constant (z) in void context at - line 4.
-Use of qw(...) as parentheses is deprecated at - line 5.
-Useless use of a constant (z) in void context at - line 5.
-x0
-x2
-########
-use feature "switch";
-given("a") { when qw() { print "x0\n"; } }
-EXPECT
-Use of qw(...) as parentheses is deprecated at - line 2.
-syntax error at - line 2, near "when qw()"
-syntax error at - line 2, near "} }"
-Execution of - aborted due to compilation errors.
-########
-use warnings qw(deprecated void);
-while qw(a) { print "x0\n"; last; } {;}
-while qw(0) { print "x1\n"; last; } {;}
-while qw(z a) { print "x2\n"; last; } {;}
-while qw(z 0) { print "x3\n"; last; } {;}
-EXPECT
-Use of qw(...) as parentheses is deprecated at - line 2.
-Use of qw(...) as parentheses is deprecated at - line 3.
-Use of qw(...) as parentheses is deprecated at - line 4.
-Useless use of a constant (z) in void context at - line 4.
-Use of qw(...) as parentheses is deprecated at - line 5.
-Useless use of a constant (z) in void context at - line 5.
-x0
-x2
-########
-while qw() { print "x0\n"; last; }
-EXPECT
-Use of qw(...) as parentheses is deprecated at - line 1.
-x0
-########
-use warnings qw(deprecated void);
-until qw(a) { print "x0\n"; last; } {;}
-until qw(0) { print "x1\n"; last; } {;}
-until qw(z a) { print "x2\n"; last; } {;}
-until qw(z 0) { print "x3\n"; last; } {;}
-EXPECT
-Use of qw(...) as parentheses is deprecated at - line 2.
-Use of qw(...) as parentheses is deprecated at - line 3.
-Use of qw(...) as parentheses is deprecated at - line 4.
-Useless use of a constant (z) in void context at - line 4.
-Use of qw(...) as parentheses is deprecated at - line 5.
-Useless use of a constant (z) in void context at - line 5.
-x1
-x3
-########
-until qw() { print "x0\n"; } else { }
-EXPECT
-Use of qw(...) as parentheses is deprecated at - line 1.
-syntax error at - line 1, near "until qw()"
-Execution of - aborted due to compilation errors.
-########
-foreach $x qw(a b c) { print $x, "\n"; }
-EXPECT
-Use of qw(...) as parentheses is deprecated at - line 1.
-a
-b
-c
-########
-foreach $x qw() { print $x, "\n"; }
-EXPECT
-Use of qw(...) as parentheses is deprecated at - line 1.
-syntax error at - line 1, near "$x qw()"
-Execution of - aborted due to compilation errors.
-########
-foreach my $x qw(a b c) { print $x, "\n"; }
-EXPECT
-Use of qw(...) as parentheses is deprecated at - line 1.
-a
-b
-c
-########
-foreach my $x qw() { print $x, "\n"; }
-EXPECT
-Use of qw(...) as parentheses is deprecated at - line 1.
-syntax error at - line 1, near "$x qw()"
-Execution of - aborted due to compilation errors.
-########
-sub a5c85eef3bf30129e20989e96b099d13::foo { print "+", join(":", @_), "\n"; }
-"a5c85eef3bf30129e20989e96b099d13"->foo qw(); {;}
-"a5c85eef3bf30129e20989e96b099d13"->foo qw(a b c); {;}
-EXPECT
-Use of qw(...) as parentheses is deprecated at - line 2.
-Use of qw(...) as parentheses is deprecated at - line 3.
-+a5c85eef3bf30129e20989e96b099d13
-+a5c85eef3bf30129e20989e96b099d13:a:b:c
-########
-sub fd4de2af1449cec72693c36842d41862 { print "+", join(":", @_), "\n"; }
-do fd4de2af1449cec72693c36842d41862 qw(); {;}
-do fd4de2af1449cec72693c36842d41862 qw(a b c); {;}
-EXPECT
-Use of qw(...) as parentheses is deprecated at - line 2.
-Use of "do" to call subroutines is deprecated at - line 2.
-Use of qw(...) as parentheses is deprecated at - line 3.
-Use of "do" to call subroutines is deprecated at - line 3.
-+
-+a:b:c
-########
-$subref = sub { print "+", join(":", @_), "\n"; };
-do $subref qw();
-do $subref qw(a b c);
-EXPECT
-Use of qw(...) as parentheses is deprecated at - line 2.
-Use of "do" to call subroutines is deprecated at - line 2.
-Use of qw(...) as parentheses is deprecated at - line 3.
-Use of "do" to call subroutines is deprecated at - line 3.
-+
-+a:b:c
-########
-sub e293a8f7cb38880a48867fcb336448e5 { print "+", join(":", @_), "\n"; }
-&e293a8f7cb38880a48867fcb336448e5 qw();
-&e293a8f7cb38880a48867fcb336448e5 qw(a b c);
-EXPECT
-Use of qw(...) as parentheses is deprecated at - line 2.
-Use of qw(...) as parentheses is deprecated at - line 3.
-+
-+a:b:c
-########
-my @a = (sub { print "+", join(":", @_), "\n"; });
-$a[0] qw();
-$a[0] qw(a b c);
-EXPECT
-Use of qw(...) as parentheses is deprecated at - line 2.
-Use of qw(...) as parentheses is deprecated at - line 3.
-+
-+a:b:c
Property changes on: trunk/contrib/perl/t/lib/warnings/perly
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/lib/warnings/pp
===================================================================
--- trunk/contrib/perl/t/lib/warnings/pp 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/warnings/pp 2013-12-02 21:26:09 UTC (rev 6439)
@@ -6,9 +6,6 @@
Attempt to use reference as lvalue in substr
$a = "ab" ; $b = \$a ; substr($b, 1,1) = $b
- Use of uninitialized value in ref-to-glob cast [pp_rv2gv()]
- *b = *{ undef()}
-
Use of uninitialized value in scalar dereference [pp_rv2sv()]
my $a = undef ; my $b = $$a
@@ -40,18 +37,35 @@
$a = "ab" ;
$b = \$a ;
substr($b, 1,1) = "ab" ;
+$b = \$a;
+substr($b, 1,1) = "\x{100}" ;
no warnings 'substr' ;
+$b = \$a;
substr($b, 1,1) = "ab" ;
+$b = \$a;
+substr($b, 1,1) = "\x{100}" ;
EXPECT
Attempt to use reference as lvalue in substr at - line 5.
+Attempt to use reference as lvalue in substr at - line 7.
########
# pp.c
-use warnings 'uninitialized' ;
-*x = *{ undef() };
-no warnings 'uninitialized' ;
-*y = *{ undef() };
+use warnings 'misc' ;
+ at a = qw( a b c );
+splice(@a, 4, 0, 'e') ;
+ at a = qw( a b c );
+splice(@a, 4, 1) ;
+ at a = qw( a b c );
+splice(@a, 4) ;
+no warnings 'misc' ;
+ at a = qw( a b c );
+splice(@a, 4, 0, 'e') ;
+ at a = qw( a b c );
+splice(@a, 4, 1) ;
+ at a = qw( a b c );
+splice(@a, 4) ;
EXPECT
-Use of uninitialized value in ref-to-glob cast at - line 3.
+splice() offset past end of array at - line 4.
+splice() offset past end of array at - line 6.
########
# pp.c
use warnings 'uninitialized';
@@ -88,7 +102,19 @@
Constant subroutine foo undefined at - line 4.
########
# pp.c
+use utf8;
+use open qw( :utf8 :std );
use warnings 'misc';
+sub ฝᶱ () { 1 }
+undef &ฝᶱ;
+no warnings 'misc';
+sub ƚ () { 2 }
+undef &ƚ;
+EXPECT
+Constant subroutine ฝᶱ undefined at - line 6.
+########
+# pp.c
+use warnings 'misc';
$foo = sub () { 3 };
undef &$foo;
no warnings 'misc';
Property changes on: trunk/contrib/perl/t/lib/warnings/pp
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/lib/warnings/pp_ctl
===================================================================
--- trunk/contrib/perl/t/lib/warnings/pp_ctl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/warnings/pp_ctl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/lib/warnings/pp_ctl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/lib/warnings/pp_hot
===================================================================
--- trunk/contrib/perl/t/lib/warnings/pp_hot 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/warnings/pp_hot 2013-12-02 21:26:09 UTC (rev 6439)
@@ -61,6 +61,15 @@
print() on unopened filehandle abc at - line 4.
########
# pp_hot.c [pp_print]
+use warnings 'unopened' ;
+$SIG{__WARN__} = sub { warn $_[0] =~ s/\0/\\0/rug; };
+print {"a\0b"} "anc";
+print {"\0b"} "anc";
+EXPECT
+print() on unopened filehandle a\0b at - line 4.
+print() on unopened filehandle \0b at - line 5.
+########
+# pp_hot.c [pp_print]
use warnings 'io' ;
# There is no guarantee that STDOUT is output only, or STDIN input only.
# Certainly on some BSDs (at least FreeBSD, Darwin, BSDi) file descriptors
@@ -90,6 +99,24 @@
Filehandle FOO opened only for input at - line 20.
########
# pp_hot.c [pp_print]
+$SIG{__WARN__} = sub { warn $_[0] =~ s/\0/\\0/rug; };
+use warnings 'io' ;
+my $file = "./xcv" ; unlink $file ;
+open (FH, ">$file") or die $! ;
+close FH or die $! ;
+die "There is no file $file" unless -f $file ;
+open ("a\0b", "<$file") or die $! ;
+print {"a\0b"} "anc" ;
+open ("\0b", "<$file") or die $! ;
+print {"\0b"} "anc" ;
+close "a\0b" or die $! ;
+close "\0b" or die $! ;
+unlink $file ;
+EXPECT
+Filehandle a\0b opened only for input at - line 9.
+Filehandle \0b opened only for input at - line 11.
+########
+# pp_hot.c [pp_print]
use warnings 'closed' ;
close STDIN ;
print STDIN "anc";
@@ -116,7 +143,7 @@
close STDOUT or die "Can't close STDOUT";
print $fh "Shouldn't print anything, but shouldn't SEGV either\n";
EXPECT
-print() on closed filehandle at - line 7.
+print() on closed filehandle __ANONIO__ at - line 7.
########
# pp_hot.c [pp_print]
package foo;
Property changes on: trunk/contrib/perl/t/lib/warnings/pp_hot
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/lib/warnings/pp_pack
===================================================================
--- trunk/contrib/perl/t/lib/warnings/pp_pack 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/warnings/pp_pack 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/lib/warnings/pp_pack
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/lib/warnings/pp_sys
===================================================================
--- trunk/contrib/perl/t/lib/warnings/pp_sys 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/warnings/pp_sys 2013-12-02 21:26:09 UTC (rev 6439)
@@ -585,16 +585,21 @@
stat(STDIN) ;
-T HOCUS;
stat(POCUS);
+stat "../test.pl";
+stat *foo;
no warnings qw(unopened closed) ;
-T STDIN ;
stat(STDIN);
-T HOCUS;
stat(POCUS);
+stat "../test.pl";
+stat *foo;
EXPECT
-T on closed filehandle STDIN at - line 4.
stat() on closed filehandle STDIN at - line 5.
-T on unopened filehandle HOCUS at - line 6.
stat() on unopened filehandle POCUS at - line 7.
+stat() on unopened filehandle foo at - line 9.
########
# pp_sys.c [pp_fttext]
use warnings 'newline' ;
@@ -644,8 +649,11 @@
use warnings 'io';
open FH, "../harness" or die "# $!";
lstat FH;
+lstat *FH;
+lstat \*FH;
open my $fh, $0 or die "# $!";
lstat $fh;
+lstat *FH{IO};
no warnings 'io';
lstat FH;
lstat $fh;
@@ -653,8 +661,29 @@
close $fh;
EXPECT
lstat() on filehandle FH at - line 4.
-lstat() on filehandle $fh at - line 6.
+lstat() on filehandle FH at - line 5.
+lstat() on filehandle FH at - line 6.
+lstat() on filehandle $fh at - line 8.
+lstat() on filehandle at - line 9.
########
+
+# pp_sys.c [pp_lstat]
+use warnings 'io';
+use utf8;
+use open qw( :utf8 :std );
+open ᶠḨ, "../harness" or die "# $!";
+lstat ᶠḨ;
+open my $ｆᚺ, $0 or die "# $!";
+lstat $ｆᚺ;
+no warnings 'io';
+lstat ᶠḨ;
+lstat $ｆᚺ;
+close ᶠḨ;
+close $ｆᚺ;
+EXPECT
+lstat() on filehandle ᶠḨ at - line 7.
+lstat() on filehandle $ｆᚺ at - line 9.
+########
# pp_sys.c [pp_getc]
use warnings qw(unopened closed) ;
getc FOO;
@@ -681,6 +710,9 @@
use warnings 'misc';
$x = 1;
select $x, undef, undef, 1;
+sub TIESCALAR{bless[]} sub FETCH {"hello"} sub STORE{}
+tie $y, "";
+select $y, undef, undef, 1;
no warnings 'misc';
select $x, undef, undef, 1;
EXPECT
@@ -728,6 +760,22 @@
Opening dirhandle FOO also as a file at - line 5.
Opening dirhandle $foo also as a file at - line 6.
########
+
+# pp_sys.c [pp_open]
+use utf8;
+use open qw( :utf8 :std );
+use warnings;
+opendir ＦＯＯ, ".";
+opendir $ｆｏｏ, ".";
+open ＦＯＯ, "../harness";
+open $ｆｏｏ, "../harness";
+no warnings qw(io deprecated);
+open ＦＯＯ, "../harness";
+open $ｆｏｏ, "../harness";
+EXPECT
+Opening dirhandle ＦＯＯ also as a file at - line 8.
+Opening dirhandle $ｆｏｏ also as a file at - line 9.
+########
# pp_sys.c [pp_open_dir]
use warnings;
open FOO, "../harness";
@@ -740,3 +788,87 @@
EXPECT
Opening filehandle FOO also as a directory at - line 5.
Opening filehandle $foo also as a directory at - line 6.
+########
+
+# pp_sys.c [pp_open_dir]
+use utf8;
+use open qw( :utf8 :std );
+use warnings;
+use warnings;
+open ＦＯＯ, "../harness";
+open $ｆｏｏ, "../harness";
+opendir ＦＯＯ, ".";
+opendir $ｆｏｏ, ".";
+no warnings qw(io deprecated);
+opendir ＦＯＯ, ".";
+opendir $ｆｏｏ, ".";
+EXPECT
+Opening filehandle ＦＯＯ also as a directory at - line 9.
+Opening filehandle $ｆｏｏ also as a directory at - line 10.
+########
+# pp_sys.c [pp_*dir]
+use warnings 'io';
+opendir FOO, ".";
+opendir $foo, ".";
+closedir FOO;
+closedir $foo;
+
+readdir(FOO);
+telldir(FOO);
+seekdir(FOO, 0);
+rewinddir(FOO);
+closedir(FOO);
+
+readdir($foo);
+telldir($foo);
+seekdir($foo, 0);
+rewinddir($foo);
+closedir($foo);
+
+EXPECT
+readdir() attempted on invalid dirhandle FOO at - line 8.
+telldir() attempted on invalid dirhandle FOO at - line 9.
+seekdir() attempted on invalid dirhandle FOO at - line 10.
+rewinddir() attempted on invalid dirhandle FOO at - line 11.
+closedir() attempted on invalid dirhandle FOO at - line 12.
+readdir() attempted on invalid dirhandle $foo at - line 14.
+telldir() attempted on invalid dirhandle $foo at - line 15.
+seekdir() attempted on invalid dirhandle $foo at - line 16.
+rewinddir() attempted on invalid dirhandle $foo at - line 17.
+closedir() attempted on invalid dirhandle $foo at - line 18.
+########
+
+# pp_sys.c [pp_*dir]
+use utf8;
+use open qw( :utf8 :std );
+use warnings 'io';
+opendir ＦＯＯ, ".";
+opendir $ｆｏｏ, ".";
+opendir ＦＯＯ, ".";
+opendir $ｆｏｏ, ".";
+closedir ＦＯＯ;
+closedir $ｆｏｏ;
+
+readdir(ＦＯＯ);
+telldir(ＦＯＯ);
+seekdir(ＦＯＯ, 0);
+rewinddir(ＦＯＯ);
+closedir(ＦＯＯ);
+
+readdir($ｆｏｏ);
+telldir($ｆｏｏ);
+seekdir($ｆｏｏ, 0);
+rewinddir($ｆｏｏ);
+closedir($ｆｏｏ);
+
+EXPECT
+readdir() attempted on invalid dirhandle ＦＯＯ at - line 13.
+telldir() attempted on invalid dirhandle ＦＯＯ at - line 14.
+seekdir() attempted on invalid dirhandle ＦＯＯ at - line 15.
+rewinddir() attempted on invalid dirhandle ＦＯＯ at - line 16.
+closedir() attempted on invalid dirhandle ＦＯＯ at - line 17.
+readdir() attempted on invalid dirhandle $ｆｏｏ at - line 19.
+telldir() attempted on invalid dirhandle $ｆｏｏ at - line 20.
+seekdir() attempted on invalid dirhandle $ｆｏｏ at - line 21.
+rewinddir() attempted on invalid dirhandle $ｆｏｏ at - line 22.
+closedir() attempted on invalid dirhandle $ｆｏｏ at - line 23.
Property changes on: trunk/contrib/perl/t/lib/warnings/pp_sys
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/lib/warnings/regcomp
===================================================================
--- trunk/contrib/perl/t/lib/warnings/regcomp 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/warnings/regcomp 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,266 +1,3 @@
- regcomp.c AOK
+ regcomp.c These tests have been moved to t/re/reg_mesg.t
- Quantifier unexpected on zero-length expression [S_study_chunk]
-
- Useless (%s%c) - %suse /%c modifier [S_reg]
- Useless (%sc) - %suse /gc modifier [S_reg]
-
-
-
- Strange *+?{} on zero-length expression [S_study_chunk]
- /(?=a)?/
-
- %.*s matches null string many times [S_regpiece]
- $a = "ABC123" ; $a =~ /(?=a)*/'
-
- /%.127s/: Unrecognized escape \\%c passed through [S_regatom]
- $x = '\m' ; /$x/
-
- POSIX syntax [%c %c] belongs inside character classes [S_checkposixcc]
-
-
- Character class [:%.*s:] unknown [S_regpposixcc]
-
- Character class syntax [%c %c] belongs inside character classes [S_checkposixcc]
-
- /%.127s/: false [] range \"%*.*s\" in regexp [S_regclass]
-
- /%.127s/: false [] range \"%*.*s\" in regexp [S_regclassutf8]
-
- /%.127s/: Unrecognized escape \\%c in character class passed through" [S_regclass]
-
- /%.127s/: Unrecognized escape \\%c in character class passed through" [S_regclassutf8]
-
- False [] range \"%*.*s\" [S_regclass]
-
__END__
-# regcomp.c [S_regpiece]
-use warnings 'regexp' ;
-my $a = "ABC123" ;
-$a =~ /(?=a)*/ ;
-no warnings 'regexp' ;
-$a =~ /(?=a)*/ ;
-EXPECT
-(?=a)* matches null string many times in regex; marked by <-- HERE in m/(?=a)* <-- HERE / at - line 4.
-########
-# regcomp.c [S_regatom]
-$x = '\m' ;
-use warnings 'regexp' ;
-$a =~ /a$x/ ;
-no warnings 'regexp' ;
-$a =~ /a$x/ ;
-EXPECT
-Unrecognized escape \m passed through in regex; marked by <-- HERE in m/a\m <-- HERE / at - line 4.
-########
-# regcomp.c [S_regatom]
-# The \q should warn, the \_ should NOT warn.
-use warnings 'regexp';
-"foo" =~ /\q/;
-"foo" =~ /\q{/;
-"foo" =~ /a\b{cde/;
-"foo" =~ /a\B{cde/;
-"bar" =~ /\_/;
-no warnings 'regexp';
-"foo" =~ /\q/;
-"foo" =~ /\q{/;
-"foo" =~ /a\b{cde/;
-"foo" =~ /a\B{cde/;
-"bar" =~ /\_/;
-EXPECT
-Unrecognized escape \q passed through in regex; marked by <-- HERE in m/\q <-- HERE / at - line 4.
-Unrecognized escape \q{ passed through in regex; marked by <-- HERE in m/\q{ <-- HERE / at - line 5.
-"\b{" is deprecated; use "\b\{" instead in regex; marked by <-- HERE in m/a\ <-- HERE b{cde/ at - line 6.
-"\B{" is deprecated; use "\B\{" instead in regex; marked by <-- HERE in m/a\ <-- HERE B{cde/ at - line 7.
-########
-# regcomp.c [S_regpposixcc S_checkposixcc]
-#
-use warnings 'regexp' ;
-$_ = "" ;
-/[:alpha:]/;
-/[:zog:]/;
-no warnings 'regexp' ;
-/[:alpha:]/;
-/[:zog:]/;
-EXPECT
-POSIX syntax [: :] belongs inside character classes in regex; marked by <-- HERE in m/[:alpha:] <-- HERE / at - line 5.
-POSIX syntax [: :] belongs inside character classes in regex; marked by <-- HERE in m/[:zog:] <-- HERE / at - line 6.
-########
-# regcomp.c [S_checkposixcc]
-#
-use warnings 'regexp' ;
-$_ = "" ;
-/[.zog.]/;
-no warnings 'regexp' ;
-/[.zog.]/;
-EXPECT
-POSIX syntax [. .] belongs inside character classes in regex; marked by <-- HERE in m/[.zog.] <-- HERE / at - line 5.
-POSIX syntax [. .] is reserved for future extensions in regex; marked by <-- HERE in m/[.zog.] <-- HERE / at - line 5.
-########
-# regcomp.c [S_regclass]
-$_ = "";
-use warnings 'regexp' ;
-/[a-b]/;
-/[a-\d]/;
-/[\d-b]/;
-/[\s-\d]/;
-/[\d-\s]/;
-/[a-[:digit:]]/;
-/[[:digit:]-b]/;
-/[[:alpha:]-[:digit:]]/;
-/[[:digit:]-[:alpha:]]/;
-no warnings 'regexp' ;
-/[a-b]/;
-/[a-\d]/;
-/[\d-b]/;
-/[\s-\d]/;
-/[\d-\s]/;
-/[a-[:digit:]]/;
-/[[:digit:]-b]/;
-/[[:alpha:]-[:digit:]]/;
-/[[:digit:]-[:alpha:]]/;
-EXPECT
-False [] range "a-\d" in regex; marked by <-- HERE in m/[a-\d <-- HERE ]/ at - line 5.
-False [] range "\d-" in regex; marked by <-- HERE in m/[\d- <-- HERE b]/ at - line 6.
-False [] range "\s-" in regex; marked by <-- HERE in m/[\s- <-- HERE \d]/ at - line 7.
-False [] range "\d-" in regex; marked by <-- HERE in m/[\d- <-- HERE \s]/ at - line 8.
-False [] range "a-[:digit:]" in regex; marked by <-- HERE in m/[a-[:digit:] <-- HERE ]/ at - line 9.
-False [] range "[:digit:]-" in regex; marked by <-- HERE in m/[[:digit:]- <-- HERE b]/ at - line 10.
-False [] range "[:alpha:]-" in regex; marked by <-- HERE in m/[[:alpha:]- <-- HERE [:digit:]]/ at - line 11.
-False [] range "[:digit:]-" in regex; marked by <-- HERE in m/[[:digit:]- <-- HERE [:alpha:]]/ at - line 12.
-########
-# regcomp.c [S_regclassutf8]
-BEGIN {
- if (ord("\t") == 5) {
- print "SKIPPED\n# ebcdic regular expression ranges differ.";
- exit 0;
- }
-}
-use utf8;
-$_ = "";
-use warnings 'regexp' ;
-/[a-b]/;
-/[a-\d]/;
-/[\d-b]/;
-/[\s-\d]/;
-/[\d-\s]/;
-/[a-[:digit:]]/;
-/[[:digit:]-b]/;
-/[[:alpha:]-[:digit:]]/;
-/[[:digit:]-[:alpha:]]/;
-no warnings 'regexp' ;
-/[a-b]/;
-/[a-\d]/;
-/[\d-b]/;
-/[\s-\d]/;
-/[\d-\s]/;
-/[a-[:digit:]]/;
-/[[:digit:]-b]/;
-/[[:alpha:]-[:digit:]]/;
-/[[:digit:]-[:alpha:]]/;
-EXPECT
-False [] range "a-\d" in regex; marked by <-- HERE in m/[a-\d <-- HERE ]/ at - line 12.
-False [] range "\d-" in regex; marked by <-- HERE in m/[\d- <-- HERE b]/ at - line 13.
-False [] range "\s-" in regex; marked by <-- HERE in m/[\s- <-- HERE \d]/ at - line 14.
-False [] range "\d-" in regex; marked by <-- HERE in m/[\d- <-- HERE \s]/ at - line 15.
-False [] range "a-[:digit:]" in regex; marked by <-- HERE in m/[a-[:digit:] <-- HERE ]/ at - line 16.
-False [] range "[:digit:]-" in regex; marked by <-- HERE in m/[[:digit:]- <-- HERE b]/ at - line 17.
-False [] range "[:alpha:]-" in regex; marked by <-- HERE in m/[[:alpha:]- <-- HERE [:digit:]]/ at - line 18.
-False [] range "[:digit:]-" in regex; marked by <-- HERE in m/[[:digit:]- <-- HERE [:alpha:]]/ at - line 19.
-########
-# regcomp.c [S_regclass S_regclassutf8]
-use warnings 'regexp' ;
-$a =~ /[a\zb]/ ;
-no warnings 'regexp' ;
-$a =~ /[a\zb]/ ;
-EXPECT
-Unrecognized escape \z in character class passed through in regex; marked by <-- HERE in m/[a\z <-- HERE b]/ at - line 3.
-
-########
-# regcomp.c [S_reg]
-use warnings 'regexp' ;
-$a = qr/(?c)/;
-$a = qr/(?-c)/;
-$a = qr/(?g)/;
-$a = qr/(?-g)/;
-$a = qr/(?o)/;
-$a = qr/(?-o)/;
-$a = qr/(?g-o)/;
-$a = qr/(?g-c)/;
-$a = qr/(?o-cg)/; # (?c) means (?g) error won't be thrown
-$a = qr/(?ogc)/;
-no warnings 'regexp' ;
-$a = qr/(?c)/;
-$a = qr/(?-c)/;
-$a = qr/(?g)/;
-$a = qr/(?-g)/;
-$a = qr/(?o)/;
-$a = qr/(?-o)/;
-$a = qr/(?g-o)/;
-$a = qr/(?g-c)/;
-$a = qr/(?o-cg)/; # (?c) means (?g) error won't be thrown
-$a = qr/(?ogc)/;
-#EXPECT
-EXPECT
-Useless (?c) - use /gc modifier in regex; marked by <-- HERE in m/(?c <-- HERE )/ at - line 3.
-Useless (?-c) - don't use /gc modifier in regex; marked by <-- HERE in m/(?-c <-- HERE )/ at - line 4.
-Useless (?g) - use /g modifier in regex; marked by <-- HERE in m/(?g <-- HERE )/ at - line 5.
-Useless (?-g) - don't use /g modifier in regex; marked by <-- HERE in m/(?-g <-- HERE )/ at - line 6.
-Useless (?o) - use /o modifier in regex; marked by <-- HERE in m/(?o <-- HERE )/ at - line 7.
-Useless (?-o) - don't use /o modifier in regex; marked by <-- HERE in m/(?-o <-- HERE )/ at - line 8.
-Useless (?g) - use /g modifier in regex; marked by <-- HERE in m/(?g <-- HERE -o)/ at - line 9.
-Useless (?-o) - don't use /o modifier in regex; marked by <-- HERE in m/(?g-o <-- HERE )/ at - line 9.
-Useless (?g) - use /g modifier in regex; marked by <-- HERE in m/(?g <-- HERE -c)/ at - line 10.
-Useless (?-c) - don't use /gc modifier in regex; marked by <-- HERE in m/(?g-c <-- HERE )/ at - line 10.
-Useless (?o) - use /o modifier in regex; marked by <-- HERE in m/(?o <-- HERE -cg)/ at - line 11.
-Useless (?-c) - don't use /gc modifier in regex; marked by <-- HERE in m/(?o-c <-- HERE g)/ at - line 11.
-Useless (?o) - use /o modifier in regex; marked by <-- HERE in m/(?o <-- HERE gc)/ at - line 12.
-Useless (?g) - use /g modifier in regex; marked by <-- HERE in m/(?og <-- HERE c)/ at - line 12.
-Useless (?c) - use /gc modifier in regex; marked by <-- HERE in m/(?ogc <-- HERE )/ at - line 12.
-########
-# regcomp.c [S_regatom]
-$a = qr/\o{/;
-EXPECT
-Missing right brace on \o{ in regex; marked by <-- HERE in m/\o{ <-- HERE / at - line 2.
-########
-# regcomp.c [S_regatom]
-$a = qr/\o/;
-EXPECT
-Missing braces on \o{} in regex; marked by <-- HERE in m/\o <-- HERE / at - line 2.
-########
-# regcomp.c [S_regatom]
-$a = qr/\o{}/;
-EXPECT
-Number with no digits in regex; marked by <-- HERE in m/\o{} <-- HERE / at - line 2.
-########
-# regcomp.c [S_regclass]
-$a = qr/[\o{]/;
-EXPECT
-Missing right brace on \o{ in regex; marked by <-- HERE in m/[\o{ <-- HERE ]/ at - line 2.
-########
-# regcomp.c [S_regclass]
-$a = qr/[\o]/;
-EXPECT
-Missing braces on \o{} in regex; marked by <-- HERE in m/[\o <-- HERE ]/ at - line 2.
-########
-# regcomp.c [S_regclass]
-$a = qr/[\o{}]/;
-EXPECT
-Number with no digits in regex; marked by <-- HERE in m/[\o{} <-- HERE ]/ at - line 2.
-########
-# regcomp.c [S_regclass]
-use warnings 'regexp' ;
-$a = qr/[\8\9]/;
-$a = qr/[\_\0]/; # Should have no warnings on this and the remainder of this test
-$a = qr/[\07]/;
-$a = qr/[\006]/;
-$a = qr/[\0005]/;
-no warnings 'regexp' ;
-$a = qr/[\8\9]/;
-EXPECT
-Unrecognized escape \8 in character class passed through in regex; marked by <-- HERE in m/[\8 <-- HERE \9]/ at - line 3.
-Unrecognized escape \9 in character class passed through in regex; marked by <-- HERE in m/[\8\9 <-- HERE ]/ at - line 3.
-########
-# regcomp.c [Perl_re_compile]
-$a = qr/(?^-i:foo)/;
-EXPECT
-Sequence (?^-...) not recognized in regex; marked by <-- HERE in m/(?^- <-- HERE i:foo)/ at - line 2.
Property changes on: trunk/contrib/perl/t/lib/warnings/regcomp
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/t/lib/warnings/regexec
===================================================================
--- trunk/contrib/perl/t/lib/warnings/regexec 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/warnings/regexec 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/lib/warnings/regexec
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/lib/warnings/run
===================================================================
--- trunk/contrib/perl/t/lib/warnings/run 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/warnings/run 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/lib/warnings/run
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/lib/warnings/sv
===================================================================
--- trunk/contrib/perl/t/lib/warnings/sv 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/warnings/sv 2013-12-02 21:26:09 UTC (rev 6439)
@@ -34,6 +34,8 @@
Reference is already weak [Perl_sv_rvweaken] <<TODO
+ vector argument not supported with alpha versions
+
Mandatory Warnings
------------------
Malformed UTF-8 character [sv_pos_b2u] (not tested: difficult to produce
@@ -209,13 +211,6 @@
Use of uninitialized value $a in concatenation (.) or string at - line 5.
Use of uninitialized value $a in concatenation (.) or string at - line 6.
########
-# [perl #72090]
-use warnings 'uninitialized';
-$a = @$a > 0;
-EXPECT
-Use of uninitialized value $a in array dereference at - line 3.
-Use of uninitialized value in numeric gt (>) at - line 3.
-########
# sv.c
use warnings 'numeric' ;
sub TIESCALAR{bless[]} ;
@@ -366,3 +361,39 @@
$a = "\x{100}\x{200}"; $a = -$a;
EXPECT
Argument "\x{100}\x{200}" isn't numeric in negation (-) at - line 3.
+########
+# sv.c
+use warnings 'redefine' ;
+use utf8;
+use open qw( :utf8 :std );
+sub frèd {}
+sub jòè {}
+*frèd = \&jòè;
+no warnings 'redefine' ;
+sub jìm {}
+*jìm = \&jòè ;
+EXPECT
+Subroutine main::frèd redefined at - line 7.
+########
+# sv.c
+use warnings 'redefine' ;
+use utf8;
+use open qw( :utf8 :std );
+sub ｆ렏 {}
+sub 조Ȩ {}
+*ｆ렏 = \&조Ȩ ;
+no warnings 'redefine' ;
+sub 짐 {}
+*짐 = \&조Ȩ ;
+EXPECT
+Subroutine main::ｆ렏 redefined at - line 7.
+########
+# sv.c
+sprintf "%vd", new version v1.1_0;
+use warnings 'printf' ;
+sprintf "%vd", new version v1.1_0;
+no warnings 'printf' ;
+sprintf "%vd", new version v1.1_0;
+EXPECT
+vector argument not supported with alpha versions at - line 2.
+vector argument not supported with alpha versions at - line 4.
Property changes on: trunk/contrib/perl/t/lib/warnings/sv
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/t/lib/warnings/taint
===================================================================
--- trunk/contrib/perl/t/lib/warnings/taint 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/warnings/taint 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/lib/warnings/taint
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/lib/warnings/toke
===================================================================
--- trunk/contrib/perl/t/lib/warnings/toke 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/warnings/toke 2013-12-02 21:26:09 UTC (rev 6439)
@@ -80,6 +80,9 @@
Unrecognized escape \\%c passed through
$a = "\m" ;
+ Useless use of \\E.
+ $a = "abcd\E" ;
+
%s number > %s non-portable
my $a = 0b011111111111111111111111111111110 ;
$a = 0b011111111111111111111111111111111 ;
@@ -140,21 +143,41 @@
Use of comma-less variable list is deprecated at - line 4.
########
# toke.c
-$a =~ m/$foo/sand $bar;
-$a =~ s/$foo/fool/sand $bar;
$a = <<;
no warnings 'deprecated' ;
-$a =~ m/$foo/sand $bar;
-$a =~ s/$foo/fool/sand $bar;
$a = <<;
EXPECT
-Having no space between pattern and following word is deprecated at - line 2.
-Having no space between pattern and following word is deprecated at - line 3.
-Use of bare << to mean <<"" is deprecated at - line 4.
+Use of bare << to mean <<"" is deprecated at - line 2.
########
# toke.c
+$a =~ m/$foo/eq;
+$a =~ s/$foo/fool/seq;
+
+EXPECT
+OPTION fatal
+Unknown regexp modifier "/e" at - line 2, near "=~ "
+Unknown regexp modifier "/q" at - line 2, near "=~ "
+Unknown regexp modifier "/q" at - line 3, near "=~ "
+Execution of - aborted due to compilation errors.
+########
+# toke.c
+use utf8;
+use open qw( :utf8 :std );
+$a =~ m/$foo/eネq;
+$a =~ s/$foo/fool/seネq;
+
+EXPECT
+OPTION fatal
+Unknown regexp modifier "/e" at - line 4, near "=~ "
+Unknown regexp modifier "/ネ" at - line 4, near "=~ "
+Unknown regexp modifier "/q" at - line 4, near "=~ "
+Unknown regexp modifier "/ネ" at - line 5, near "=~ "
+Unknown regexp modifier "/q" at - line 5, near "=~ "
+Execution of - aborted due to compilation errors.
+########
+# toke.c
use warnings 'syntax' ;
s/(abc)/\1/;
no warnings 'syntax' ;
@@ -234,7 +257,27 @@
You need to quote "fred" at - line 3.
########
# toke.c
+use utf8;
+use open qw( :utf8 :std );
use warnings 'syntax' ;
+sub frèd {} ; $SIG{TERM} = frèd;
+no warnings 'syntax' ;
+$SIG{TERM} = frèd;
+EXPECT
+You need to quote "frèd" at - line 5.
+########
+# toke.c
+use utf8;
+use open qw( :utf8 :std );
+use warnings 'syntax' ;
+sub ふれど {} ; $SIG{TERM} = ふれど;
+no warnings 'syntax' ;
+$SIG{TERM} = ふれど;
+EXPECT
+You need to quote "ふれど" at - line 5.
+########
+# toke.c
+use warnings 'syntax' ;
@a[3] = 2;
@a{3} = 2;
no warnings 'syntax' ;
@@ -245,7 +288,33 @@
Scalar value @a{3} better written as $a{3} at - line 4.
########
# toke.c
+use utf8;
+use open qw( :utf8 :std );
use warnings 'syntax' ;
+@à[3] = 2;
+@à{3} = 2;
+no warnings 'syntax' ;
+@à[3] = 2;
+@à{3} = 2;
+EXPECT
+Scalar value @à[3] better written as $à[3] at - line 5.
+Scalar value @à{3} better written as $à{3} at - line 6.
+########
+# toke.c
+use utf8;
+use open qw( :utf8 :std );
+use warnings 'syntax' ;
+@ぁ[3] = 2;
+@ぁ{3} = 2;
+no warnings 'syntax' ;
+@ぁ[3] = 2;
+@ぁ{3} = 2;
+EXPECT
+Scalar value @ぁ[3] better written as $ぁ[3] at - line 5.
+Scalar value @ぁ{3} better written as $ぁ{3} at - line 6.
+########
+# toke.c
+use warnings 'syntax' ;
$_ = "ab" ;
s/(ab)/\1/e;
no warnings 'syntax' ;
@@ -275,13 +344,22 @@
########
# toke.c
use warnings 'qw' ;
- at a = qw(a b #) ;
+ at a = qw(a b c # #) ;
no warnings 'qw' ;
- at a = qw(a b #) ;
+ at a = qw(a b c # #) ;
EXPECT
Possible attempt to put comments in qw() list at - line 3.
########
# toke.c
+use warnings 'qw' ;
+ at a = qw(a, b, c # #) ;
+no warnings 'qw' ;
+ at a = qw(a, b, c # #) ;
+EXPECT
+Possible attempt to separate words with commas at - line 3.
+Possible attempt to put comments in qw() list at - line 3.
+########
+# toke.c
use warnings 'syntax' ;
print ("");
print ("") and $x = 1;
@@ -558,6 +636,30 @@
Bareword "FRED::" refers to nonexistent package at bar line 25.
########
# toke.c
+use utf8;
+use open qw( :utf8 :std );
+use warnings 'bareword' ;
+#line 25 "bar"
+$a = FRÈD:: ;
+no warnings 'bareword' ;
+#line 25 "bar"
+$a = FRÈD:: ;
+EXPECT
+Bareword "FRÈD::" refers to nonexistent package at bar line 25.
+########
+# toke.c
+use utf8;
+use open qw( :utf8 :std );
+use warnings 'bareword' ;
+#line 25 "bar"
+$a = ϞϞϞ:: ;
+no warnings 'bareword' ;
+#line 25 "bar"
+$a = ϞϞϞ:: ;
+EXPECT
+Bareword "ϞϞϞ::" refers to nonexistent package at bar line 25.
+########
+# toke.c
use warnings 'ambiguous' ;
sub time {}
my $a = time() ;
@@ -580,6 +682,8 @@
########
# toke.c
my $a = rand + 4 ;
+$a = rand *^H ;
+$a = rand $^H ;
EXPECT
Warning: Use of "rand" without parentheses is ambiguous at - line 2.
########
@@ -598,6 +702,14 @@
Warning: Use of "rand" without parentheses is ambiguous at - line 8.
Warning: Use of "rand" without parentheses is ambiguous at - line 10.
########
+# [perl #97110]
+sub myrand(;$) { }
+sub whatever($) { }
+my $a = myrand + 4 ;
+my $b = whatever + 4 ;
+EXPECT
+Warning: Use of "myrand" without parentheses is ambiguous at - line 4.
+########
# toke.c
use warnings "ambiguous";
print for keys %+; # should not warn
@@ -606,6 +718,8 @@
# toke.c
sub fred {};
-fred ;
+sub hank : lvalue {$_}
+--hank; # This should *not* warn [perl #77240]
EXPECT
Ambiguous use of -fred resolved as -&fred() at - line 3.
########
@@ -626,10 +740,77 @@
Ambiguous use of -fred resolved as -&fred() at - line 11.
########
# toke.c
+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
+$^W = 0 ;
+use utf8;
+use open qw( :utf8 :std );
+sub frèd {} ;
+-frèd ;
+{
+ no warnings 'ambiguous' ;
+ -frèd ;
+ use warnings 'ambiguous' ;
+ -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
+use utf8;
+use open qw( :utf8 :std );
+sub ᒍᒘᒊ {};
+-ᒍᒘᒊ ;
+EXPECT
+Ambiguous use of -ᒍᒘᒊ resolved as -&ᒍᒘᒊ() at - line 5.
+########
+# toke.c
+$^W = 0 ;
+use utf8;
+use open qw( :utf8 :std );
+sub ᒍᒘᒊ {} ;
+-ᒍᒘᒊ ;
+{
+ no warnings 'ambiguous' ;
+ -ᒍᒘᒊ ;
+ use warnings 'ambiguous' ;
+ -ᒍᒘᒊ ;
+}
+-ᒍᒘᒊ ;
+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;
+open local *FOO; # should be ok
EXPECT
Precedence problem: open FOO should be open(FOO) at - line 2.
########
+# toke.c
+use utf8;
+use open qw( :utf8 :std );
+open FÒÒ || time;
+EXPECT
+Precedence problem: open FÒÒ should be open(FÒÒ) at - line 4.
+########
+# toke.c
+use utf8;
+use open qw( :utf8 :std );
+open ᒍOO || time;
+EXPECT
+Precedence problem: open ᒍOO should be open(ᒍOO) at - line 4.
+########
# toke.c (and [perl #16184])
open FOO => "<&0"; close FOO;
EXPECT
@@ -644,6 +825,7 @@
open FOO || time;
}
open FOO || time;
+open Foo::BAR; # this should not warn
EXPECT
Precedence problem: open FOO should be open(FOO) at - line 3.
Precedence problem: open FOO should be open(FOO) at - line 8.
@@ -651,6 +833,40 @@
########
# toke.c
$^W = 0 ;
+use utf8;
+use open qw( :utf8 :std );
+open FÒÒ || time;
+{
+ no warnings 'precedence' ;
+ open FÒÒ || time;
+ use warnings 'precedence' ;
+ open FÒÒ || time;
+}
+open FÒÒ || time;
+EXPECT
+Precedence problem: open FÒÒ should be open(FÒÒ) at - line 5.
+Precedence problem: open FÒÒ should be open(FÒÒ) at - line 10.
+Precedence problem: open FÒÒ should be open(FÒÒ) at - line 12.
+########
+# toke.c
+use utf8;
+use open qw( :utf8 :std );
+$^W = 0 ;
+open ᒍÒÒ || time;
+{
+ no warnings 'precedence' ;
+ open ᒍÒÒ || time;
+ use warnings 'precedence' ;
+ open ᒍÒÒ || time;
+}
+open ᒍÒÒ || time;
+EXPECT
+Precedence problem: open ᒍÒÒ should be open(ᒍÒÒ) at - line 5.
+Precedence problem: open ᒍÒÒ should be open(ᒍÒÒ) at - line 10.
+Precedence problem: open ᒍÒÒ should be open(ᒍÒÒ) at - line 12.
+########
+# toke.c
+$^W = 0 ;
*foo *foo ;
{
no warnings 'ambiguous' ;
@@ -668,6 +884,26 @@
Ambiguous use of * resolved as operator * at - line 10.
########
# toke.c
+use utf8;
+use open qw( :utf8 :std );
+$^W = 0 ;
+*ｆｏｏ *ｆｏｏ ;
+{
+ no warnings 'ambiguous' ;
+ *ｆｏｏ *ｆｏｏ ;
+ use warnings 'ambiguous' ;
+ *ｆｏｏ *ｆｏｏ ;
+}
+*ｆｏｏ *ｆｏｏ ;
+EXPECT
+Operator or semicolon missing before *ｆｏｏ at - line 5.
+Ambiguous use of * resolved as operator * at - line 5.
+Operator or semicolon missing before *ｆｏｏ at - line 10.
+Ambiguous use of * resolved as operator * at - line 10.
+Operator or semicolon missing before *ｆｏｏ at - line 12.
+Ambiguous use of * resolved as operator * at - line 12.
+########
+# toke.c
use warnings 'misc' ;
my $a = "\m" ;
no warnings 'misc' ;
@@ -676,6 +912,14 @@
Unrecognized escape \m passed through at - line 3.
########
# toke.c
+use warnings 'misc' ;
+my $a = "abcd\E" ;
+no warnings 'misc' ;
+$a = "abcd\E" ;
+EXPECT
+Useless use of \E at - line 3.
+########
+# toke.c
use warnings 'portable' ;
my $a = 0b011111111111111111111111111111110 ;
$a = 0b011111111111111111111111111111111 ;
@@ -748,11 +992,31 @@
use warnings 'ambiguous';
"@mjd_previously_unused_array";
no warnings 'ambiguous';
-"@mjd_previously_unused_array";
+"@mjd_previously_unused_array2";
EXPECT
Possible unintended interpolation of @mjd_previously_unused_array in string at - line 3.
########
# toke.c
+use utf8;
+use open qw( :utf8 :std );
+use warnings 'ambiguous';
+"@mjd_previously_unused_àrray";
+no warnings 'ambiguous';
+"@mjd_previously_unused_àrray2";
+EXPECT
+Possible unintended interpolation of @mjd_previously_unused_àrray in string at - line 5.
+########
+# toke.c
+use utf8;
+use open qw( :utf8 :std );
+use warnings 'ambiguous';
+"@mjd_previously_unused_ぁrrぁy";
+no warnings 'ambiguous';
+"@mjd_previously_unused_ぁrrぁy2";
+EXPECT
+Possible unintended interpolation of @mjd_previously_unused_ぁrrぁy in string at - line 5.
+########
+# toke.c
# 20020328 mjd-perl-patch+ at plover.com at behest of jfriedl at yahoo.com
use warnings 'regexp';
"foo" =~ /foo/c;
@@ -823,7 +1087,7 @@
(Missing operator before 6?)
########
# toke.c
-use warnings "syntax";
+use warnings "syntax"; no warnings "deprecated";
$_ = $a = 1;
$a !=~ /1/;
$a !=~ m#1#;
@@ -871,7 +1135,7 @@
Use of :locked is deprecated at - line 6.
########
# toke.c
-use warnings "syntax";
+use warnings "syntax"; use feature 'lexical_subs';
sub proto_after_array(@$);
sub proto_after_arref(\@$);
sub proto_after_arref2(\[@$]);
@@ -883,6 +1147,14 @@
sub underscore2($_;$);
sub underscore_fail($_$);
sub underscore_after_at(@_);
+our sub hour (@$);
+my sub migh (@$);
+use feature 'state';
+state sub estate (@$);
+package other;
+sub hour (@$);
+sub migh (@$);
+sub estate (@$);
no warnings "syntax";
sub proto_after_array(@$);
sub proto_after_hash(%$);
@@ -892,6 +1164,15 @@
Prototype after '%' for main::proto_after_hash : %$ at - line 7.
Illegal character after '_' in prototype for main::underscore_fail : $_$ at - line 12.
Prototype after '@' for main::underscore_after_at : @_ at - line 13.
+The lexical_subs feature is experimental at - line 14.
+Prototype after '@' for hour : @$ at - line 14.
+The lexical_subs feature is experimental at - line 15.
+Prototype after '@' for migh : @$ at - line 15.
+The lexical_subs feature is experimental at - line 17.
+Prototype after '@' for estate : @$ at - line 17.
+Prototype after '@' for hour : @$ at - line 19.
+Prototype after '@' for migh : @$ at - line 20.
+Prototype after '@' for estate : @$ at - line 21.
########
# toke.c
use warnings "ambiguous";
@@ -972,3 +1253,83 @@
Regexp modifier "/l" may not appear twice at - line 5, near "= "
Regexp modifier "/a" may appear a maximum of twice at - line 7, near "= "
BEGIN not safe after errors--compilation aborted at - line 8.
+########
+# toke.c
+# [perl #4362]
+eval "print q\xabfoo";
+print "ok\n" if
+ $@ =~ /Can't find string terminator "\xab" anywhere before EOF/;
+EXPECT
+ok
+########
+# toke.c
+use utf8;
+use open qw( :utf8 :std );
+use warnings 'ambiguous' ;
+sub frèd {}
+$a = ${frèd} ;
+no warnings 'ambiguous' ;
+$a = ${frèd} ;
+EXPECT
+Ambiguous use of ${frèd} resolved to $frèd at - line 6.
+########
+# toke.c
+use utf8;
+use open qw( :utf8 :std );
+use warnings 'ambiguous' ;
+sub f렏 {}
+$a = ${f렏} ;
+no warnings 'ambiguous' ;
+$a = ${f렏} ;
+EXPECT
+Ambiguous use of ${f렏} resolved to $f렏 at - line 6.
+########
+# toke.c
+use utf8;
+use open qw( :utf8 :std );
+use warnings;
+CORE::렏;
+EXPECT
+CORE::렏 is not a keyword at - line 5.
+########
+# toke.c
+# [perl #16249]
+print '';
+eval this_method_is_fake ();
+EXPECT
+Undefined subroutine &main::this_method_is_fake called at - line 4.
+########
+# toke.c
+# [perl #107002] Erroneous ambiguity warnings
+sub { # do not actually call require
+ require a::b . 1; # These used to produce erroneous
+ require a::b + 1; # ambiguity warnings.
+}
+EXPECT
+########
+# toke.c
+# [perl #113094]
+print "aa" =~ m{^a\{1,2\}$}, "\n";
+print "aa" =~ m{^a\x\{61\}$}, "\n";
+print "aa" =~ m{^a{1,2}$}, "\n";
+print "aq" =~ m[^a\[a-z\]$], "\n";
+print "aq" =~ m(^a\(q\)$), "\n";
+no warnings 'deprecated';
+print "aa" =~ m{^a\{1,2\}$}, "\n";
+print "aa" =~ m{^a\x\{61\}$}, "\n";
+print "aq" =~ m[^a\[a-z\]$], "\n";
+print "aq" =~ m(^a\(q\)$), "\n";
+EXPECT
+Useless use of '\'; doesn't escape metacharacter '{' at - line 3.
+Useless use of '\'; doesn't escape metacharacter '{' at - line 4.
+Useless use of '\'; doesn't escape metacharacter '[' at - line 6.
+Useless use of '\'; doesn't escape metacharacter '(' at - line 7.
+1
+1
+1
+1
+q
+1
+1
+1
+q
Property changes on: trunk/contrib/perl/t/lib/warnings/toke
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/lib/warnings/universal
===================================================================
--- trunk/contrib/perl/t/lib/warnings/universal 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/warnings/universal 2013-12-02 21:26:09 UTC (rev 6439)
@@ -13,3 +13,15 @@
UNIVERSAL::isa $a, Jim ;
EXPECT
Can't locate package Joe for @main::ISA at - line 5.
+########
+# universal.c [S_isa_lookup]
+print("SKIPPED\n# todo fix: overloading triggers spurious warnings\n"),exit;
+use warnings 'misc' ;
+use utf8;
+use open qw( :utf8 :std );
+package Ｙ;
+ at ISA = qw(Joe) ;
+my $a = bless [] ;
+UNIVERSAL::isa $a, Jim ;
+EXPECT
+Can't locate package Joe for @Ｙ::ISA at - line 8.
Property changes on: trunk/contrib/perl/t/lib/warnings/universal
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/lib/warnings/utf8
===================================================================
--- trunk/contrib/perl/t/lib/warnings/utf8 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/warnings/utf8 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,7 +1,7 @@
utf8.c AOK
- [utf8_to_uv]
+ [utf8_to_uvchr_buf]
Malformed UTF-8 character
my $a = ord "\x80" ;
@@ -14,7 +14,7 @@
<<<<<< Add a test when something actually calls utf16_to_utf8
__END__
-# utf8.c [utf8_to_uv] -W
+# utf8.c [utf8_to_uvchr_buf] -W
BEGIN {
if (ord('A') == 193) {
print "SKIPPED\n# ebcdic platforms do not generate Malformed UTF-8 warnings.";
@@ -170,7 +170,283 @@
chr(0x100000) =~ /\p{Any}/;
chr(0x10FFFE) =~ /\p{Any}/;
chr(0x10FFFF) =~ /\p{Any}/;
-chr(0x110000) =~ /\p{Any}/;
+chr(0x110000) =~ /[\w\p{Any}]/;
+chr(0x110010) =~ /[\w\p{PosixWord}]/;
+chr(0x110011) =~ /[\w\P{PosixWord}]/;
+chr(0x110012) =~ /[\w\p{XPosixWord}]/;
+chr(0x110013) =~ /[\w\P{XPosixWord}]/;
+chr(0x110014) =~ /[\w\p{PosixAlnum}]/;
+chr(0x110015) =~ /[\w\P{PosixAlnum}]/;
+chr(0x110016) =~ /[\w\p{XPosixAlnum}]/;
+chr(0x110017) =~ /[\w\P{XPosixAlnum}]/;
+chr(0x110018) =~ /[\w\p{PosixSpace}]/;
+chr(0x110019) =~ /[\w\P{PosixSpace}]/;
+chr(0x11001A) =~ /[\w\p{XPosixSpace}]/;
+chr(0x11001B) =~ /[\w\P{XPosixSpace}]/;
+chr(0x11001C) =~ /[\w\p{PosixDigit}]/;
+chr(0x11001D) =~ /[\w\P{PosixDigit}]/;
+chr(0x11001E) =~ /[\w\p{XPosixDigit}]/;
+chr(0x11001F) =~ /[\w\P{XPosixDigit}]/;
+chr(0x110020) =~ /[\w\p{PosixAlpha}]/;
+chr(0x110021) =~ /[\w\P{PosixAlpha}]/;
+chr(0x110022) =~ /[\w\p{XPosixAlpha}]/;
+chr(0x110023) =~ /[\w\P{XPosixAlpha}]/;
+chr(0x110024) =~ /[\w\p{Ascii}]/;
+chr(0x110025) =~ /[\w\P{Ascii}]/;
+chr(0x110026) =~ /[\w\p{PosixCntrl}]/;
+chr(0x110027) =~ /[\w\P{PosixCntrl}]/;
+chr(0x110028) =~ /[\w\p{XPosixCntrl}]/;
+chr(0x110029) =~ /[\w\P{XPosixCntrl}]/;
+chr(0x11002A) =~ /[\w\p{PosixGraph}]/;
+chr(0x11002B) =~ /[\w\P{PosixGraph}]/;
+chr(0x11002C) =~ /[\w\p{XPosixGraph}]/;
+chr(0x11002D) =~ /[\w\P{XPosixGraph}]/;
+chr(0x11002E) =~ /[\w\p{PosixLower}]/;
+chr(0x11002F) =~ /[\w\P{PosixLower}]/;
+chr(0x110030) =~ /[\w\p{XPosixLower}]/;
+chr(0x110031) =~ /[\w\P{XPosixLower}]/;
+chr(0x110032) =~ /[\w\p{PosixPrint}]/;
+chr(0x110033) =~ /[\w\P{PosixPrint}]/;
+chr(0x110034) =~ /[\w\p{XPosixPrint}]/;
+chr(0x110035) =~ /[\w\P{XPosixPrint}]/;
+chr(0x110036) =~ /[\w\p{PosixPunct}]/;
+chr(0x110037) =~ /[\w\P{PosixPunct}]/;
+chr(0x110038) =~ /[\w\p{XPosixPunct}]/;
+chr(0x110039) =~ /[\w\P{XPosixPunct}]/;
+chr(0x11003A) =~ /[\w\p{PosixUpper}]/;
+chr(0x11003B) =~ /[\w\P{PosixUpper}]/;
+chr(0x11003C) =~ /[\w\p{XPosixUpper}]/;
+chr(0x11003D) =~ /[\w\P{XPosixUpper}]/;
+chr(0x11003E) =~ /[\w\p{PosixXdigit}]/;
+chr(0x11003F) =~ /[\w\P{PosixXdigit}]/;
+chr(0x110040) =~ /[\w\p{XPosixXdigit}]/;
+chr(0x110041) =~ /[\w\P{XPosixXdigit}]/;
+chr(0x110042) =~ /[\w\p{PerlSpace}]/;
+chr(0x110043) =~ /[\w\P{PerlSpace}]/;
+chr(0x110044) =~ /[\w\p{XPerlSpace}]/;
+chr(0x110045) =~ /[\w\P{XPerlSpace}]/;
+chr(0x110046) =~ /[\w\p{PosixBlank}]/;
+chr(0x110047) =~ /[\w\P{PosixBlank}]/;
+chr(0x110048) =~ /[\w\p{XPosixBlank}]/;
+chr(0x110049) =~ /[\w\P{XPosixBlank}]/;
+# Currently some warnings from the above are output twice
+# Only Unicode properties give non-Unicode warnings, and not when something
+# else in the class matches above Unicode. Below we test three ways where
+# something outside the property may match non-Unicode: a code point above it,
+# a class \S that we know at compile time doesn't, and a class \W whose values
+# aren't (at the time of this writing) specified at compile time, but which
+# wouldn't match
+chr(0x110050) =~ /\w/;
+chr(0x110051) =~ /\W/;
+chr(0x110052) =~ /\d/;
+chr(0x110053) =~ /\D/;
+chr(0x110054) =~ /\s/;
+chr(0x110055) =~ /\S/;
+chr(0x110056) =~ /[[:word:]]/;
+chr(0x110057) =~ /[[:^word:]]/;
+chr(0x110058) =~ /[[:alnum:]]/;
+chr(0x110059) =~ /[[:^alnum:]]/;
+chr(0x11005A) =~ /[[:space:]]/;
+chr(0x11005B) =~ /[[:^space:]]/;
+chr(0x11005C) =~ /[[:digit:]]/;
+chr(0x11005D) =~ /[[:^digit:]]/;
+chr(0x11005E) =~ /[[:alpha:]]/;
+chr(0x11005F) =~ /[[:^alpha:]]/;
+chr(0x110060) =~ /[[:ascii:]]/;
+chr(0x110061) =~ /[[:^ascii:]]/;
+chr(0x110062) =~ /[[:cntrl:]]/;
+chr(0x110063) =~ /[[:^cntrl:]]/;
+chr(0x110064) =~ /[[:graph:]]/;
+chr(0x110065) =~ /[[:^graph:]]/;
+chr(0x110066) =~ /[[:lower:]]/;
+chr(0x110067) =~ /[[:^lower:]]/;
+chr(0x110068) =~ /[[:print:]]/;
+chr(0x110069) =~ /[[:^print:]]/;
+chr(0x11006A) =~ /[[:punct:]]/;
+chr(0x11006B) =~ /[[:^punct:]]/;
+chr(0x11006C) =~ /[[:upper:]]/;
+chr(0x11006D) =~ /[[:^upper:]]/;
+chr(0x11006E) =~ /[[:xdigit:]]/;
+chr(0x11006F) =~ /[[:^xdigit:]]/;
+chr(0x110070) =~ /[[:blank:]]/;
+chr(0x110071) =~ /[[:^blank:]]/;
+chr(0x111000) =~ /[\W\p{Any}]/;
+chr(0x111010) =~ /[\W\p{PosixWord}]/;
+chr(0x111011) =~ /[\W\P{PosixWord}]/;
+chr(0x111012) =~ /[\W\p{XPosixWord}]/;
+chr(0x111013) =~ /[\W\P{XPosixWord}]/;
+chr(0x111014) =~ /[\W\p{PosixAlnum}]/;
+chr(0x111015) =~ /[\W\P{PosixAlnum}]/;
+chr(0x111016) =~ /[\W\p{XPosixAlnum}]/;
+chr(0x111017) =~ /[\W\P{XPosixAlnum}]/;
+chr(0x111018) =~ /[\W\p{PosixSpace}]/;
+chr(0x111019) =~ /[\W\P{PosixSpace}]/;
+chr(0x11101A) =~ /[\W\p{XPosixSpace}]/;
+chr(0x11101B) =~ /[\W\P{XPosixSpace}]/;
+chr(0x11101C) =~ /[\W\p{PosixDigit}]/;
+chr(0x11101D) =~ /[\W\P{PosixDigit}]/;
+chr(0x11101E) =~ /[\W\p{XPosixDigit}]/;
+chr(0x11101F) =~ /[\W\P{XPosixDigit}]/;
+chr(0x111020) =~ /[\W\p{PosixAlpha}]/;
+chr(0x111021) =~ /[\W\P{PosixAlpha}]/;
+chr(0x111022) =~ /[\W\p{XPosixAlpha}]/;
+chr(0x111023) =~ /[\W\P{XPosixAlpha}]/;
+chr(0x111024) =~ /[\W\p{Ascii}]/;
+chr(0x111025) =~ /[\W\P{Ascii}]/;
+chr(0x111026) =~ /[\W\p{PosixCntrl}]/;
+chr(0x111027) =~ /[\W\P{PosixCntrl}]/;
+chr(0x111028) =~ /[\W\p{XPosixCntrl}]/;
+chr(0x111029) =~ /[\W\P{XPosixCntrl}]/;
+chr(0x11102A) =~ /[\W\p{PosixGraph}]/;
+chr(0x11102B) =~ /[\W\P{PosixGraph}]/;
+chr(0x11102C) =~ /[\W\p{XPosixGraph}]/;
+chr(0x11102D) =~ /[\W\P{XPosixGraph}]/;
+chr(0x11102E) =~ /[\W\p{PosixLower}]/;
+chr(0x11102F) =~ /[\W\P{PosixLower}]/;
+chr(0x111030) =~ /[\W\p{XPosixLower}]/;
+chr(0x111031) =~ /[\W\P{XPosixLower}]/;
+chr(0x111032) =~ /[\W\p{PosixPrint}]/;
+chr(0x111033) =~ /[\W\P{PosixPrint}]/;
+chr(0x111034) =~ /[\W\p{XPosixPrint}]/;
+chr(0x111035) =~ /[\W\P{XPosixPrint}]/;
+chr(0x111036) =~ /[\W\p{PosixPunct}]/;
+chr(0x111037) =~ /[\W\P{PosixPunct}]/;
+chr(0x111038) =~ /[\W\p{XPosixPunct}]/;
+chr(0x111039) =~ /[\W\P{XPosixPunct}]/;
+chr(0x11103A) =~ /[\W\p{PosixUpper}]/;
+chr(0x11103B) =~ /[\W\P{PosixUpper}]/;
+chr(0x11103C) =~ /[\W\p{XPosixUpper}]/;
+chr(0x11103D) =~ /[\W\P{XPosixUpper}]/;
+chr(0x11103E) =~ /[\W\p{PosixXdigit}]/;
+chr(0x11103F) =~ /[\W\P{PosixXdigit}]/;
+chr(0x111040) =~ /[\W\p{XPosixXdigit}]/;
+chr(0x111041) =~ /[\W\P{XPosixXdigit}]/;
+chr(0x111042) =~ /[\W\p{PerlSpace}]/;
+chr(0x111043) =~ /[\W\P{PerlSpace}]/;
+chr(0x111044) =~ /[\W\p{XPerlSpace}]/;
+chr(0x111045) =~ /[\W\P{XPerlSpace}]/;
+chr(0x111046) =~ /[\W\p{PosixBlank}]/;
+chr(0x111047) =~ /[\W\P{PosixBlank}]/;
+chr(0x111048) =~ /[\W\p{XPosixBlank}]/;
+chr(0x111049) =~ /[\W\P{XPosixBlank}]/;
+chr(0x112000) =~ /[\S\p{Any}]/;
+chr(0x112010) =~ /[\S\p{PosixWord}]/;
+chr(0x112011) =~ /[\S\P{PosixWord}]/;
+chr(0x112012) =~ /[\S\p{XPosixWord}]/;
+chr(0x112013) =~ /[\S\P{XPosixWord}]/;
+chr(0x112014) =~ /[\S\p{PosixAlnum}]/;
+chr(0x112015) =~ /[\S\P{PosixAlnum}]/;
+chr(0x112016) =~ /[\S\p{XPosixAlnum}]/;
+chr(0x112017) =~ /[\S\P{XPosixAlnum}]/;
+chr(0x112018) =~ /[\S\p{PosixSpace}]/;
+chr(0x112019) =~ /[\S\P{PosixSpace}]/;
+chr(0x11201A) =~ /[\S\p{XPosixSpace}]/;
+chr(0x11201B) =~ /[\S\P{XPosixSpace}]/;
+chr(0x11201C) =~ /[\S\p{PosixDigit}]/;
+chr(0x11201D) =~ /[\S\P{PosixDigit}]/;
+chr(0x11201E) =~ /[\S\p{XPosixDigit}]/;
+chr(0x11201F) =~ /[\S\P{XPosixDigit}]/;
+chr(0x112020) =~ /[\S\p{PosixAlpha}]/;
+chr(0x112021) =~ /[\S\P{PosixAlpha}]/;
+chr(0x112022) =~ /[\S\p{XPosixAlpha}]/;
+chr(0x112023) =~ /[\S\P{XPosixAlpha}]/;
+chr(0x112024) =~ /[\S\p{Ascii}]/;
+chr(0x112025) =~ /[\S\P{Ascii}]/;
+chr(0x112026) =~ /[\S\p{PosixCntrl}]/;
+chr(0x112027) =~ /[\S\P{PosixCntrl}]/;
+chr(0x112028) =~ /[\S\p{XPosixCntrl}]/;
+chr(0x112029) =~ /[\S\P{XPosixCntrl}]/;
+chr(0x11202A) =~ /[\S\p{PosixGraph}]/;
+chr(0x11202B) =~ /[\S\P{PosixGraph}]/;
+chr(0x11202C) =~ /[\S\p{XPosixGraph}]/;
+chr(0x11202D) =~ /[\S\P{XPosixGraph}]/;
+chr(0x11202E) =~ /[\S\p{PosixLower}]/;
+chr(0x11202F) =~ /[\S\P{PosixLower}]/;
+chr(0x112030) =~ /[\S\p{XPosixLower}]/;
+chr(0x112031) =~ /[\S\P{XPosixLower}]/;
+chr(0x112032) =~ /[\S\p{PosixPrint}]/;
+chr(0x112033) =~ /[\S\P{PosixPrint}]/;
+chr(0x112034) =~ /[\S\p{XPosixPrint}]/;
+chr(0x112035) =~ /[\S\P{XPosixPrint}]/;
+chr(0x112036) =~ /[\S\p{PosixPunct}]/;
+chr(0x112037) =~ /[\S\P{PosixPunct}]/;
+chr(0x112038) =~ /[\S\p{XPosixPunct}]/;
+chr(0x112039) =~ /[\S\P{XPosixPunct}]/;
+chr(0x11203A) =~ /[\S\p{PosixUpper}]/;
+chr(0x11203B) =~ /[\S\P{PosixUpper}]/;
+chr(0x11203C) =~ /[\S\p{XPosixUpper}]/;
+chr(0x11203D) =~ /[\S\P{XPosixUpper}]/;
+chr(0x11203E) =~ /[\S\p{PosixXdigit}]/;
+chr(0x11203F) =~ /[\S\P{PosixXdigit}]/;
+chr(0x112040) =~ /[\S\p{XPosixXdigit}]/;
+chr(0x112041) =~ /[\S\P{XPosixXdigit}]/;
+chr(0x112042) =~ /[\S\p{PerlSpace}]/;
+chr(0x112043) =~ /[\S\P{PerlSpace}]/;
+chr(0x112044) =~ /[\S\p{XPerlSpace}]/;
+chr(0x112045) =~ /[\S\P{XPerlSpace}]/;
+chr(0x112046) =~ /[\S\p{PosixBlank}]/;
+chr(0x112047) =~ /[\S\P{PosixBlank}]/;
+chr(0x112048) =~ /[\S\p{XPosixBlank}]/;
+chr(0x112049) =~ /[\S\P{XPosixBlank}]/;
+chr(0x113000) =~ /[\x{110000}\p{Any}]/;
+chr(0x113010) =~ /[\x{110000}\p{PosixWord}]/;
+chr(0x113011) =~ /[\x{110000}\P{PosixWord}]/;
+chr(0x113012) =~ /[\x{110000}\p{XPosixWord}]/;
+chr(0x113013) =~ /[\x{110000}\P{XPosixWord}]/;
+chr(0x113014) =~ /[\x{110000}\p{PosixAlnum}]/;
+chr(0x113015) =~ /[\x{110000}\P{PosixAlnum}]/;
+chr(0x113016) =~ /[\x{110000}\p{XPosixAlnum}]/;
+chr(0x113017) =~ /[\x{110000}\P{XPosixAlnum}]/;
+chr(0x113018) =~ /[\x{110000}\p{PosixSpace}]/;
+chr(0x113019) =~ /[\x{110000}\P{PosixSpace}]/;
+chr(0x11301A) =~ /[\x{110000}\p{XPosixSpace}]/;
+chr(0x11301B) =~ /[\x{110000}\P{XPosixSpace}]/;
+chr(0x11301C) =~ /[\x{110000}\p{PosixDigit}]/;
+chr(0x11301D) =~ /[\x{110000}\P{PosixDigit}]/;
+chr(0x11301E) =~ /[\x{110000}\p{XPosixDigit}]/;
+chr(0x11301F) =~ /[\x{110000}\P{XPosixDigit}]/;
+chr(0x113020) =~ /[\x{110000}\p{PosixAlpha}]/;
+chr(0x113021) =~ /[\x{110000}\P{PosixAlpha}]/;
+chr(0x113022) =~ /[\x{110000}\p{XPosixAlpha}]/;
+chr(0x113023) =~ /[\x{110000}\P{XPosixAlpha}]/;
+chr(0x113024) =~ /[\x{110000}\p{Ascii}]/;
+chr(0x113025) =~ /[\x{110000}\P{Ascii}]/;
+chr(0x113026) =~ /[\x{110000}\p{PosixCntrl}]/;
+chr(0x113027) =~ /[\x{110000}\P{PosixCntrl}]/;
+chr(0x113028) =~ /[\x{110000}\p{XPosixCntrl}]/;
+chr(0x113029) =~ /[\x{110000}\P{XPosixCntrl}]/;
+chr(0x11302A) =~ /[\x{110000}\p{PosixGraph}]/;
+chr(0x11302B) =~ /[\x{110000}\P{PosixGraph}]/;
+chr(0x11302C) =~ /[\x{110000}\p{XPosixGraph}]/;
+chr(0x11302D) =~ /[\x{110000}\P{XPosixGraph}]/;
+chr(0x11302E) =~ /[\x{110000}\p{PosixLower}]/;
+chr(0x11302F) =~ /[\x{110000}\P{PosixLower}]/;
+chr(0x113030) =~ /[\x{110000}\p{XPosixLower}]/;
+chr(0x113031) =~ /[\x{110000}\P{XPosixLower}]/;
+chr(0x113032) =~ /[\x{110000}\p{PosixPrint}]/;
+chr(0x113033) =~ /[\x{110000}\P{PosixPrint}]/;
+chr(0x113034) =~ /[\x{110000}\p{XPosixPrint}]/;
+chr(0x113035) =~ /[\x{110000}\P{XPosixPrint}]/;
+chr(0x113036) =~ /[\x{110000}\p{PosixPunct}]/;
+chr(0x113037) =~ /[\x{110000}\P{PosixPunct}]/;
+chr(0x113038) =~ /[\x{110000}\p{XPosixPunct}]/;
+chr(0x113039) =~ /[\x{110000}\P{XPosixPunct}]/;
+chr(0x11303A) =~ /[\x{110000}\p{PosixUpper}]/;
+chr(0x11303B) =~ /[\x{110000}\P{PosixUpper}]/;
+chr(0x11303C) =~ /[\x{110000}\p{XPosixUpper}]/;
+chr(0x11303D) =~ /[\x{110000}\P{XPosixUpper}]/;
+chr(0x11303E) =~ /[\x{110000}\p{PosixXdigit}]/;
+chr(0x11303F) =~ /[\x{110000}\P{PosixXdigit}]/;
+chr(0x113040) =~ /[\x{110000}\p{XPosixXdigit}]/;
+chr(0x113041) =~ /[\x{110000}\P{XPosixXdigit}]/;
+chr(0x113042) =~ /[\x{110000}\p{PerlSpace}]/;
+chr(0x113043) =~ /[\x{110000}\P{PerlSpace}]/;
+chr(0x113044) =~ /[\x{110000}\p{XPerlSpace}]/;
+chr(0x113045) =~ /[\x{110000}\P{XPerlSpace}]/;
+chr(0x113046) =~ /[\x{110000}\p{PosixBlank}]/;
+chr(0x113047) =~ /[\x{110000}\P{PosixBlank}]/;
+chr(0x113048) =~ /[\x{110000}\p{XPosixBlank}]/;
+chr(0x113049) =~ /[\x{110000}\P{XPosixBlank}]/;
no warnings 'utf8';
chr(0xD7FF) =~ /\p{Any}/;
chr(0xD800) =~ /\p{Any}/;
@@ -185,8 +461,187 @@
chr(0x10FFFE) =~ /\p{Any}/;
chr(0x10FFFF) =~ /\p{Any}/;
chr(0x110000) =~ /\p{Any}/;
+chr(0x110010) =~ /\p{PosixWord}/;
+chr(0x110011) =~ /\P{PosixWord}/;
+chr(0x110012) =~ /\p{XPosixWord}/;
+chr(0x110013) =~ /\P{XPosixWord}/;
+chr(0x110014) =~ /\p{PosixAlnum}/;
+chr(0x110015) =~ /\P{PosixAlnum}/;
+chr(0x110016) =~ /\p{XPosixAlnum}/;
+chr(0x110017) =~ /\P{XPosixAlnum}/;
+chr(0x110018) =~ /\p{PosixSpace}/;
+chr(0x110019) =~ /\P{PosixSpace}/;
+chr(0x11001A) =~ /\p{XPosixSpace}/;
+chr(0x11001B) =~ /\P{XPosixSpace}/;
+chr(0x11001C) =~ /\p{PosixDigit}/;
+chr(0x11001D) =~ /\P{PosixDigit}/;
+chr(0x11001E) =~ /\p{XPosixDigit}/;
+chr(0x11001F) =~ /\P{XPosixDigit}/;
+chr(0x110020) =~ /\p{PosixAlpha}/;
+chr(0x110021) =~ /\P{PosixAlpha}/;
+chr(0x110022) =~ /\p{XPosixAlpha}/;
+chr(0x110023) =~ /\P{XPosixAlpha}/;
+chr(0x110024) =~ /\p{Ascii}/;
+chr(0x110025) =~ /\P{Ascii}/;
+chr(0x110026) =~ /\p{PosixCntrl}/;
+chr(0x110027) =~ /\P{PosixCntrl}/;
+chr(0x110028) =~ /\p{XPosixCntrl}/;
+chr(0x110029) =~ /\P{XPosixCntrl}/;
+chr(0x11002A) =~ /\p{PosixGraph}/;
+chr(0x11002B) =~ /\P{PosixGraph}/;
+chr(0x11002C) =~ /\p{XPosixGraph}/;
+chr(0x11002D) =~ /\P{XPosixGraph}/;
+chr(0x11002E) =~ /\p{PosixLower}/;
+chr(0x11002F) =~ /\P{PosixLower}/;
+chr(0x110030) =~ /\p{XPosixLower}/;
+chr(0x110031) =~ /\P{XPosixLower}/;
+chr(0x110032) =~ /\p{PosixPrint}/;
+chr(0x110033) =~ /\P{PosixPrint}/;
+chr(0x110034) =~ /\p{XPosixPrint}/;
+chr(0x110035) =~ /\P{XPosixPrint}/;
+chr(0x110036) =~ /\p{PosixPunct}/;
+chr(0x110037) =~ /\P{PosixPunct}/;
+chr(0x110038) =~ /\p{XPosixPunct}/;
+chr(0x110039) =~ /\P{XPosixPunct}/;
+chr(0x11003A) =~ /\p{PosixUpper}/;
+chr(0x11003B) =~ /\P{PosixUpper}/;
+chr(0x11003C) =~ /\p{XPosixUpper}/;
+chr(0x11003D) =~ /\P{XPosixUpper}/;
+chr(0x11003E) =~ /\p{PosixXdigit}/;
+chr(0x11003F) =~ /\P{PosixXdigit}/;
+chr(0x110040) =~ /\p{XPosixXdigit}/;
+chr(0x110041) =~ /\P{XPosixXdigit}/;
+chr(0x110042) =~ /\p{PerlSpace}/;
+chr(0x110043) =~ /\P{PerlSpace}/;
+chr(0x110044) =~ /\p{XPerlSpace}/;
+chr(0x110045) =~ /\P{XPerlSpace}/;
+chr(0x110046) =~ /\p{PosixBlank}/;
+chr(0x110047) =~ /\P{PosixBlank}/;
+chr(0x110048) =~ /\p{XPosixBlank}/;
+chr(0x110049) =~ /\P{XPosixBlank}/;
+chr(0x110050) =~ /\w/;
+chr(0x110051) =~ /\W/;
+chr(0x110052) =~ /\d/;
+chr(0x110053) =~ /\D/;
+chr(0x110054) =~ /\s/;
+chr(0x110055) =~ /\S/;
+chr(0x110056) =~ /[[:word:]]/;
+chr(0x110057) =~ /[[:^word:]]/;
+chr(0x110058) =~ /[[:alnum:]]/;
+chr(0x110059) =~ /[[:^alnum:]]/;
+chr(0x11005A) =~ /[[:space:]]/;
+chr(0x11005B) =~ /[[:^space:]]/;
+chr(0x11005C) =~ /[[:digit:]]/;
+chr(0x11005D) =~ /[[:^digit:]]/;
+chr(0x11005E) =~ /[[:alpha:]]/;
+chr(0x11005F) =~ /[[:^alpha:]]/;
+chr(0x110060) =~ /[[:ascii:]]/;
+chr(0x110061) =~ /[[:^ascii:]]/;
+chr(0x110062) =~ /[[:cntrl:]]/;
+chr(0x110063) =~ /[[:^cntrl:]]/;
+chr(0x110064) =~ /[[:graph:]]/;
+chr(0x110065) =~ /[[:^graph:]]/;
+chr(0x110066) =~ /[[:lower:]]/;
+chr(0x110067) =~ /[[:^lower:]]/;
+chr(0x110068) =~ /[[:print:]]/;
+chr(0x110069) =~ /[[:^print:]]/;
+chr(0x11006A) =~ /[[:punct:]]/;
+chr(0x11006B) =~ /[[:^punct:]]/;
+chr(0x11006C) =~ /[[:upper:]]/;
+chr(0x11006D) =~ /[[:^upper:]]/;
+chr(0x11006E) =~ /[[:xdigit:]]/;
+chr(0x11006F) =~ /[[:^xdigit:]]/;
+chr(0x110070) =~ /[[:blank:]]/;
+chr(0x110071) =~ /[[:^blank:]]/;
EXPECT
-Code point 0x110000 is not Unicode, no properties match it; all inverse properties do at - line 14.
+Code point 0x110000 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 14.
+Code point 0x110010 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 15.
+Code point 0x110011 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 16.
+Code point 0x110011 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 16.
+Code point 0x110012 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 17.
+Code point 0x110013 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 18.
+Code point 0x110013 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 18.
+Code point 0x110014 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 19.
+Code point 0x110015 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 20.
+Code point 0x110015 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 20.
+Code point 0x110016 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 21.
+Code point 0x110017 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 22.
+Code point 0x110017 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 22.
+Code point 0x110018 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 23.
+Code point 0x110019 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 24.
+Code point 0x110019 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 24.
+Code point 0x11001A is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 25.
+Code point 0x11001B is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 26.
+Code point 0x11001B is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 26.
+Code point 0x11001C is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 27.
+Code point 0x11001D is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 28.
+Code point 0x11001D is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 28.
+Code point 0x11001E is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 29.
+Code point 0x11001F is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 30.
+Code point 0x11001F is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 30.
+Code point 0x110020 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 31.
+Code point 0x110021 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 32.
+Code point 0x110021 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 32.
+Code point 0x110022 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 33.
+Code point 0x110023 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 34.
+Code point 0x110023 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 34.
+Code point 0x110024 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 35.
+Code point 0x110025 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 36.
+Code point 0x110025 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 36.
+Code point 0x110026 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 37.
+Code point 0x110027 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 38.
+Code point 0x110027 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 38.
+Code point 0x110028 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 39.
+Code point 0x110029 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 40.
+Code point 0x110029 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 40.
+Code point 0x11002A is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 41.
+Code point 0x11002B is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 42.
+Code point 0x11002B is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 42.
+Code point 0x11002C is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 43.
+Code point 0x11002D is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 44.
+Code point 0x11002D is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 44.
+Code point 0x11002E is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 45.
+Code point 0x11002F is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 46.
+Code point 0x11002F is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 46.
+Code point 0x110030 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 47.
+Code point 0x110031 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 48.
+Code point 0x110031 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 48.
+Code point 0x110032 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 49.
+Code point 0x110033 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 50.
+Code point 0x110033 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 50.
+Code point 0x110034 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 51.
+Code point 0x110035 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 52.
+Code point 0x110035 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 52.
+Code point 0x110036 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 53.
+Code point 0x110037 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 54.
+Code point 0x110037 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 54.
+Code point 0x110038 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 55.
+Code point 0x110039 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 56.
+Code point 0x110039 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 56.
+Code point 0x11003A is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 57.
+Code point 0x11003B is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 58.
+Code point 0x11003B is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 58.
+Code point 0x11003C is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 59.
+Code point 0x11003D is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 60.
+Code point 0x11003D is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 60.
+Code point 0x11003E is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 61.
+Code point 0x11003F is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 62.
+Code point 0x11003F is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 62.
+Code point 0x110040 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 63.
+Code point 0x110041 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 64.
+Code point 0x110041 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 64.
+Code point 0x110042 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 65.
+Code point 0x110043 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 66.
+Code point 0x110043 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 66.
+Code point 0x110044 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 67.
+Code point 0x110045 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 68.
+Code point 0x110045 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 68.
+Code point 0x110046 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 69.
+Code point 0x110047 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 70.
+Code point 0x110047 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 70.
+Code point 0x110048 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 71.
+Code point 0x110049 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 72.
+Code point 0x110049 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 72.
########
use warnings 'utf8';
chr(0x110000) =~ /\p{Any}/;
@@ -193,10 +648,27 @@
no warnings 'non_unicode';
chr(0x110000) =~ /\p{Any}/;
EXPECT
-Code point 0x110000 is not Unicode, no properties match it; all inverse properties do at - line 2.
+Code point 0x110000 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 2.
########
+# TODO optimized regnode should still give warnings
+use warnings 'utf8';
+chr(0x110000) =~ /lb=cr/;
+no warnings 'non_unicode';
+chr(0x110000) =~ /lb=cr/;
+EXPECT
+Code point 0x110000 is not Unicode, all \p{} matches fail; all \P{} matches succeed at - line 2.
+########
require "../test.pl";
use warnings 'utf8';
+sub Is_Super { return '!utf8::Any' }
+# The extra char is to avoid an optimization that avoids the problem when the
+# property is the only non-latin1 char in a class
+print "\x{1100000}" =~ /^[\p{Is_Super}\x{100}]$/, "\n";
+EXPECT
+1
+########
+require "../test.pl";
+use warnings 'utf8';
my $file = tempfile();
open(my $fh, "+>:utf8", $file);
print $fh "\x{D7FF}", "\n";
@@ -340,7 +812,37 @@
Unicode surrogate U+D800 is illegal in UTF-8 at - line 6.
Unicode non-character U+FFFF is illegal for open interchange at - line 7.
########
+# NAME C<use warnings "nonchar"> works in isolation
require "../test.pl";
+use warnings 'nonchar';
+my $file = tempfile();
+open(my $fh, "+>:utf8", $file);
+print $fh "\x{FFFF}", "\n";
+close $fh;
+EXPECT
+Unicode non-character U+FFFF is illegal for open interchange at - line 5.
+########
+# NAME C<use warnings "surrogate"> works in isolation
+require "../test.pl";
+use warnings 'surrogate';
+my $file = tempfile();
+open(my $fh, "+>:utf8", $file);
+print $fh "\x{D800}", "\n";
+close $fh;
+EXPECT
+Unicode surrogate U+D800 is illegal in UTF-8 at - line 5.
+########
+# NAME C<use warnings "non_unicode"> works in isolation
+require "../test.pl";
+use warnings 'non_unicode';
+my $file = tempfile();
+open(my $fh, "+>:utf8", $file);
+print $fh "\x{110000}", "\n";
+close $fh;
+EXPECT
+Code point 0x110000 is not Unicode, may not be portable at - line 5.
+########
+require "../test.pl";
no warnings 'utf8';
my $file = tempfile();
open(my $fh, "+>:utf8", $file);
Property changes on: trunk/contrib/perl/t/lib/warnings/utf8
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/lib/warnings/util
===================================================================
--- trunk/contrib/perl/t/lib/warnings/util 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/lib/warnings/util 2013-12-02 21:26:09 UTC (rev 6439)
@@ -156,3 +156,123 @@
EXPECT
Name "main::y" used only once: possible typo at - line 8.
Use of uninitialized value $y in print at - line 8.
+########
+# util.c
+use utf8;
+use open qw( :utf8 :std );
+use warnings;
+$ㄒ = 1;
+if ($ㄒ) {
+ print $ʎ;
+}
+EXPECT
+Name "main::ʎ" used only once: possible typo at - line 7.
+Use of uninitialized value $ʎ in print at - line 7.
+########
+# util.c
+use utf8;
+use open qw( :utf8 :std );
+use warnings;
+$ㄒ = 1;
+if ($ㄒ) {
+ $ㄒ++;
+ print $ʎ;
+}
+EXPECT
+Name "main::ʎ" used only once: possible typo at - line 8.
+Use of uninitialized value $ʎ in print at - line 8.
+########
+# util.c
+use utf8;
+use open qw( :utf8 :std );
+use warnings;
+$ㄒ = 0;
+if ($ㄒ) {
+ print "1\n";
+} elsif (!$ㄒ) {
+ print $ʎ;
+} else {
+ print "0\n";
+}
+EXPECT
+Name "main::ʎ" used only once: possible typo at - line 9.
+Use of uninitialized value $ʎ in print at - line 9.
+########
+# util.c
+use utf8;
+use open qw( :utf8 :std );
+use warnings;
+$ㄒ = 0;
+if ($ㄒ) {
+ print "1\n";
+} elsif (!$ㄒ) {
+ $ㄒ++;
+ print $ʎ;
+} else {
+ print "0\n";
+}
+EXPECT
+Name "main::ʎ" used only once: possible typo at - line 10.
+Use of uninitialized value $ʎ in print at - line 10.
+########
+# util.c
+use utf8;
+use open qw( :utf8 :std );
+use warnings;
+package 팣칵ぇ;
+$ㄒ = 1;
+if ($ㄒ) {
+ print $ʎ;
+}
+EXPECT
+Name "팣칵ぇ::ʎ" used only once: possible typo at - line 8.
+Use of uninitialized value $팣칵ぇ::ʎ in print at - line 8.
+########
+# util.c
+use utf8;
+use open qw( :utf8 :std );
+use warnings;
+package 팣칵ぇ;
+$ㄒ = 1;
+if ($ㄒ) {
+ $ㄒ++;
+ print $ʎ;
+}
+EXPECT
+Name "팣칵ぇ::ʎ" used only once: possible typo at - line 9.
+Use of uninitialized value $팣칵ぇ::ʎ in print at - line 9.
+########
+# util.c
+use utf8;
+use open qw( :utf8 :std );
+use warnings;
+package 팣칵ぇ;
+$ㄒ = 0;
+if ($ㄒ) {
+ print "1\n";
+} elsif (!$ㄒ) {
+ print $ʎ;
+} else {
+ print "0\n";
+}
+EXPECT
+Name "팣칵ぇ::ʎ" used only once: possible typo at - line 10.
+Use of uninitialized value $팣칵ぇ::ʎ in print at - line 10.
+########
+# util.c
+use utf8;
+use open qw( :utf8 :std );
+use warnings;
+package 팣칵ぇ;
+$ㄒ = 0;
+if ($ㄒ) {
+ print "1\n";
+} elsif (!$ㄒ) {
+ $ㄒ++;
+ print $ʎ;
+} else {
+ print "0\n";
+}
+EXPECT
+Name "팣칵ぇ::ʎ" used only once: possible typo at - line 11.
+Use of uninitialized value $팣칵ぇ::ʎ in print at - line 11.
Property changes on: trunk/contrib/perl/t/lib/warnings/util
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/mro/basic.t
===================================================================
--- trunk/contrib/perl/t/mro/basic.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/mro/basic.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -3,7 +3,7 @@
use strict;
use warnings;
-BEGIN { require q(./test.pl); } plan(tests => 52);
+BEGIN { require q(./test.pl); } plan(tests => 59);
require mro;
@@ -328,3 +328,45 @@
undef %Thwit::;
ok !Thrext->isa('Sile'), 'undef %package:: updates subclasses';
}
+
+{
+ # Obliterating @ISA via glob assignment
+ # Broken in 5.14.0; fixed in 5.17.2
+ @Gwythaint::ISA = "Fantastic::Creature";
+ undef *This_glob_haD_better_not_exist; # paranoia; must have no array
+ *Gwythaint::ISA = *This_glob_haD_better_not_exist;
+ ok !Gwythaint->isa("Fantastic::Creature"),
+ 'obliterating @ISA via glob assignment';
+}
+
+{
+ # Autovivifying @ISA via @{*ISA}
+ no warnings;
+ undef *fednu::ISA;
+ @{*fednu::ISA} = "pyfg";
+ ok +fednu->isa("pyfg"), 'autovivifying @ISA via *{@ISA}';
+}
+
+{
+ sub Detached::method;
+ my $h = delete $::{"Detached::"};
+ eval { local *Detached::method };
+ is $@, "", 'localising gv-with-cv belonging to detached package';
+}
+
+{
+ # *ISA localisation
+ @il::ISA = "ilsuper";
+ sub ilsuper::can { "puree" }
+ sub il::tomatoes;
+ {
+ local *il::ISA;
+ is +il->can("tomatoes"), \&il::tomatoes, 'local *ISA';
+ }
+ is "il"->can("tomatoes"), "puree", 'local *ISA unwinding';
+ {
+ local *il::ISA = [];
+ is +il->can("tomatoes"), \&il::tomatoes, 'local *ISA = []';
+ }
+ is "il"->can("tomatoes"), "puree", 'local *ISA=[] unwinding';
+}
Property changes on: trunk/contrib/perl/t/mro/basic.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/t/mro/basic_01_c3.t
===================================================================
--- trunk/contrib/perl/t/mro/basic_01_c3.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/mro/basic_01_c3.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/mro/basic_01_c3.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/t/mro/basic_01_c3_utf8.t (from rev 6437, vendor/perl/5.18.1/t/mro/basic_01_c3_utf8.t)
===================================================================
--- trunk/contrib/perl/t/mro/basic_01_c3_utf8.t (rev 0)
+++ trunk/contrib/perl/t/mro/basic_01_c3_utf8.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,49 @@
+#!./perl
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+
+require q(./test.pl); plan(tests => 4);
+
+=pod
+
+This tests the classic diamond inheritance pattern.
+
+ <A>
+ / \
+<B> <C>
+ \ /
+ <D>
+
+=cut
+
+{
+ package Ｄiᚪၚd_A;
+ sub hèllò { 'Ｄiᚪၚd_A::hèllò' }
+}
+{
+ package Ｄiᚪၚd_B;
+ use base 'Ｄiᚪၚd_A';
+}
+{
+ package Ｄiᚪၚd_C;
+ use base 'Ｄiᚪၚd_A';
+
+ sub hèllò { 'Ｄiᚪၚd_C::hèllò' }
+}
+{
+ package Ｄiᚪၚd_D;
+ use base ('Ｄiᚪၚd_B', 'Ｄiᚪၚd_C');
+ use mro 'c3';
+}
+
+ok(eq_array(
+ mro::get_linear_isa('Ｄiᚪၚd_D'),
+ [ qw(Ｄiᚪၚd_D Ｄiᚪၚd_B Ｄiᚪၚd_C Ｄiᚪၚd_A) ]
+), '... got the right MRO for Ｄiᚪၚd_D');
+
+is(Ｄiᚪၚd_D->hèllò, 'Ｄiᚪၚd_C::hèllò', '... method resolved itself as expected');
+is(Ｄiᚪၚd_D->can('hèllò')->(), 'Ｄiᚪၚd_C::hèllò', '... can(method) resolved itself as expected');
+is(UNIVERSAL::can("Ｄiᚪၚd_D", 'hèllò')->(), 'Ｄiᚪၚd_C::hèllò', '... can(method) resolved itself as expected');
Index: trunk/contrib/perl/t/mro/basic_01_dfs.t
===================================================================
--- trunk/contrib/perl/t/mro/basic_01_dfs.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/mro/basic_01_dfs.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/mro/basic_01_dfs.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/t/mro/basic_01_dfs_utf8.t (from rev 6437, vendor/perl/5.18.1/t/mro/basic_01_dfs_utf8.t)
===================================================================
--- trunk/contrib/perl/t/mro/basic_01_dfs_utf8.t (rev 0)
+++ trunk/contrib/perl/t/mro/basic_01_dfs_utf8.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,49 @@
+#!./perl
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+
+require q(./test.pl); plan(tests => 4);
+
+=pod
+
+This tests the classic diamond inheritance pattern.
+
+ <A>
+ / \
+<B> <C>
+ \ /
+ <D>
+
+=cut
+
+{
+ package Ｄiᚪၚd_A;
+ sub hèllò { 'Ｄiᚪၚd_A::hèllò' }
+}
+{
+ package Ｄiᚪၚd_B;
+ use base 'Ｄiᚪၚd_A';
+}
+{
+ package Ｄiᚪၚd_C;
+ use base 'Ｄiᚪၚd_A';
+
+ sub hèllò { 'Ｄiᚪၚd_C::hèllò' }
+}
+{
+ package Ｄiᚪၚd_D;
+ use base ('Ｄiᚪၚd_B', 'Ｄiᚪၚd_C');
+ use mro 'dfs';
+}
+
+ok(eq_array(
+ mro::get_linear_isa('Ｄiᚪၚd_D'),
+ [ qw(Ｄiᚪၚd_D Ｄiᚪၚd_B Ｄiᚪၚd_A Ｄiᚪၚd_C) ]
+), '... got the right MRO for Ｄiᚪၚd_D');
+
+is(Ｄiᚪၚd_D->hèllò, 'Ｄiᚪၚd_A::hèllò', '... method resolved itself as expected');
+is(Ｄiᚪၚd_D->can('hèllò')->(), 'Ｄiᚪၚd_A::hèllò', '... can(method) resolved itself as expected');
+is(UNIVERSAL::can("Ｄiᚪၚd_D", 'hèllò')->(), 'Ｄiᚪၚd_A::hèllò', '... can(method) resolved itself as expected');
Index: trunk/contrib/perl/t/mro/basic_02_c3.t
===================================================================
--- trunk/contrib/perl/t/mro/basic_02_c3.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/mro/basic_02_c3.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/mro/basic_02_c3.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/mro/basic_02_c3_utf8.t (from rev 6437, vendor/perl/5.18.1/t/mro/basic_02_c3_utf8.t)
===================================================================
--- trunk/contrib/perl/t/mro/basic_02_c3_utf8.t (rev 0)
+++ trunk/contrib/perl/t/mro/basic_02_c3_utf8.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,117 @@
+#!./perl
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+
+require q(./test.pl); plan(tests => 10);
+
+=pod
+
+This example is take from: http://www.python.org/2.3/mro.html
+
+"My first example"
+class O: pass
+class F(O): pass
+class E(O): pass
+class D(O): pass
+class C(D,F): pass
+class B(D,E): pass
+class A(B,C): pass
+
+
+ 6
+ ---
+Level 3 | O | (more general)
+ / --- \
+ / | \ |
+ / | \ |
+ / | \ |
+ --- --- --- |
+Level 2 3 | D | 4| E | | F | 5 |
+ --- --- --- |
+ \ \ _ / | |
+ \ / \ _ | |
+ \ / \ | |
+ --- --- |
+Level 1 1 | B | | C | 2 |
+ --- --- |
+ \ / |
+ \ / \ /
+ ---
+Level 0 0 | A | (more specialized)
+ ---
+
+=cut
+
+{
+ package 텟ţ::ᴼ;
+ use mro 'c3';
+
+ package 텟ţ::Ḟ;
+ use mro 'c3';
+ use base '텟ţ::ᴼ';
+
+ package 텟ţ::ऍ;
+ use base '텟ţ::ᴼ';
+ use mro 'c3';
+
+ sub ƈ_or_ऍ { '텟ţ::ऍ' }
+
+ package 텟ţ::Ḋ;
+ use mro 'c3';
+ use base '텟ţ::ᴼ';
+
+ sub ƈ_or_Ḋ { '텟ţ::Ḋ' }
+
+ package 텟ţ::ƈ;
+ use base ('텟ţ::Ḋ', '텟ţ::Ḟ');
+ use mro 'c3';
+
+ sub ƈ_or_Ḋ { '텟ţ::ƈ' }
+ sub ƈ_or_ऍ { '텟ţ::ƈ' }
+
+ package 텟ţ::ᛒ;
+ use mro 'c3';
+ use base ('텟ţ::Ḋ', '텟ţ::ऍ');
+
+ package 텟ţ::ଅ;
+ use base ('텟ţ::ᛒ', '텟ţ::ƈ');
+ use mro 'c3';
+}
+
+ok(eq_array(
+ mro::get_linear_isa('텟ţ::Ḟ'),
+ [ qw(텟ţ::Ḟ 텟ţ::ᴼ) ]
+), '... got the right MRO for 텟ţ::Ḟ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟ţ::ऍ'),
+ [ qw(텟ţ::ऍ 텟ţ::ᴼ) ]
+), '... got the right MRO for 텟ţ::ऍ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟ţ::Ḋ'),
+ [ qw(텟ţ::Ḋ 텟ţ::ᴼ) ]
+), '... got the right MRO for 텟ţ::Ḋ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟ţ::ƈ'),
+ [ qw(텟ţ::ƈ 텟ţ::Ḋ 텟ţ::Ḟ 텟ţ::ᴼ) ]
+), '... got the right MRO for 텟ţ::ƈ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟ţ::ᛒ'),
+ [ qw(텟ţ::ᛒ 텟ţ::Ḋ 텟ţ::ऍ 텟ţ::ᴼ) ]
+), '... got the right MRO for 텟ţ::ᛒ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟ţ::ଅ'),
+ [ qw(텟ţ::ଅ 텟ţ::ᛒ 텟ţ::ƈ 텟ţ::Ḋ 텟ţ::ऍ 텟ţ::Ḟ 텟ţ::ᴼ) ]
+), '... got the right MRO for 텟ţ::ଅ');
+
+is(텟ţ::ଅ->ƈ_or_Ḋ, '텟ţ::ƈ', '... got the expected method output');
+is(텟ţ::ଅ->can('ƈ_or_Ḋ')->(), '텟ţ::ƈ', '... can got the expected method output');
+is(텟ţ::ଅ->ƈ_or_ऍ, '텟ţ::ƈ', '... got the expected method output');
+is(텟ţ::ଅ->can('ƈ_or_ऍ')->(), '텟ţ::ƈ', '... can got the expected method output');
Index: trunk/contrib/perl/t/mro/basic_02_dfs.t
===================================================================
--- trunk/contrib/perl/t/mro/basic_02_dfs.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/mro/basic_02_dfs.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/mro/basic_02_dfs.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/mro/basic_02_dfs_utf8.t (from rev 6437, vendor/perl/5.18.1/t/mro/basic_02_dfs_utf8.t)
===================================================================
--- trunk/contrib/perl/t/mro/basic_02_dfs_utf8.t (rev 0)
+++ trunk/contrib/perl/t/mro/basic_02_dfs_utf8.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,117 @@
+#!./perl
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+
+require q(./test.pl); plan(tests => 10);
+
+=pod
+
+This example is take from: http://www.python.org/2.3/mro.html
+
+"My first example"
+class O: pass
+class F(O): pass
+class E(O): pass
+class D(O): pass
+class C(D,F): pass
+class B(D,E): pass
+class A(B,C): pass
+
+
+ 6
+ ---
+Level 3 | O | (more general)
+ / --- \
+ / | \ |
+ / | \ |
+ / | \ |
+ --- --- --- |
+Level 2 3 | D | 4| E | | F | 5 |
+ --- --- --- |
+ \ \ _ / | |
+ \ / \ _ | |
+ \ / \ | |
+ --- --- |
+Level 1 1 | B | | C | 2 |
+ --- --- |
+ \ / |
+ \ / \ /
+ ---
+Level 0 0 | A | (more specialized)
+ ---
+
+=cut
+
+{
+ package 텟ţ::ᴼ;
+ use mro 'dfs';
+
+ package 텟ţ::Ḟ;
+ use mro 'dfs';
+ use base '텟ţ::ᴼ';
+
+ package 텟ţ::ऍ;
+ use base '텟ţ::ᴼ';
+ use mro 'dfs';
+
+ sub ƈ_or_ऍ { '텟ţ::ऍ' }
+
+ package 텟ţ::Ḋ;
+ use mro 'dfs';
+ use base '텟ţ::ᴼ';
+
+ sub ƈ_or_Ḋ { '텟ţ::Ḋ' }
+
+ package 텟ţ::ƈ;
+ use base ('텟ţ::Ḋ', '텟ţ::Ḟ');
+ use mro 'dfs';
+
+ sub ƈ_or_Ḋ { '텟ţ::ƈ' }
+ sub ƈ_or_ऍ { '텟ţ::ƈ' }
+
+ package 텟ţ::ᛒ;
+ use mro 'dfs';
+ use base ('텟ţ::Ḋ', '텟ţ::ऍ');
+
+ package 텟ţ::ଅ;
+ use base ('텟ţ::ᛒ', '텟ţ::ƈ');
+ use mro 'dfs';
+}
+
+ok(eq_array(
+ mro::get_linear_isa('텟ţ::Ḟ'),
+ [ qw(텟ţ::Ḟ 텟ţ::ᴼ) ]
+), '... got the right MRO for 텟ţ::Ḟ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟ţ::ऍ'),
+ [ qw(텟ţ::ऍ 텟ţ::ᴼ) ]
+), '... got the right MRO for 텟ţ::ऍ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟ţ::Ḋ'),
+ [ qw(텟ţ::Ḋ 텟ţ::ᴼ) ]
+), '... got the right MRO for 텟ţ::Ḋ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟ţ::ƈ'),
+ [ qw(텟ţ::ƈ 텟ţ::Ḋ 텟ţ::ᴼ 텟ţ::Ḟ) ]
+), '... got the right MRO for 텟ţ::ƈ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟ţ::ᛒ'),
+ [ qw(텟ţ::ᛒ 텟ţ::Ḋ 텟ţ::ᴼ 텟ţ::ऍ) ]
+), '... got the right MRO for 텟ţ::ᛒ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟ţ::ଅ'),
+ [ qw(텟ţ::ଅ 텟ţ::ᛒ 텟ţ::Ḋ 텟ţ::ᴼ 텟ţ::ऍ 텟ţ::ƈ 텟ţ::Ḟ) ]
+), '... got the right MRO for 텟ţ::ଅ');
+
+is(텟ţ::ଅ->ƈ_or_Ḋ, '텟ţ::Ḋ', '... got the expected method output');
+is(텟ţ::ଅ->can('ƈ_or_Ḋ')->(), '텟ţ::Ḋ', '... can got the expected method output');
+is(텟ţ::ଅ->ƈ_or_ऍ, '텟ţ::ऍ', '... got the expected method output');
+is(텟ţ::ଅ->can('ƈ_or_ऍ')->(), '텟ţ::ऍ', '... can got the expected method output');
Index: trunk/contrib/perl/t/mro/basic_03_c3.t
===================================================================
--- trunk/contrib/perl/t/mro/basic_03_c3.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/mro/basic_03_c3.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/mro/basic_03_c3.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/mro/basic_03_c3_utf8.t (from rev 6437, vendor/perl/5.18.1/t/mro/basic_03_c3_utf8.t)
===================================================================
--- trunk/contrib/perl/t/mro/basic_03_c3_utf8.t (rev 0)
+++ trunk/contrib/perl/t/mro/basic_03_c3_utf8.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,103 @@
+#!./perl
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+
+require q(./test.pl); plan(tests => 4);
+
+=pod
+
+This example is take from: http://www.python.org/2.3/mro.html
+
+"My second example"
+class O: pass
+class F(O): pass
+class E(O): pass
+class D(O): pass
+class C(D,F): pass
+class B(E,D): pass
+class A(B,C): pass
+
+ 6
+ ---
+Level 3 | O |
+ / --- \
+ / | \
+ / | \
+ / | \
+ --- --- ---
+Level 2 2 | E | 4 | D | | F | 5
+ --- --- ---
+ \ / \ /
+ \ / \ /
+ \ / \ /
+ --- ---
+Level 1 1 | B | | C | 3
+ --- ---
+ \ /
+ \ /
+ ---
+Level 0 0 | A |
+ ---
+
+>>> A.mro()
+(<class '__main__.A'>, <class '__main__.B'>, <class '__main__.E'>,
+<class '__main__.C'>, <class '__main__.D'>, <class '__main__.F'>,
+<type 'object'>)
+
+=cut
+
+{
+ package 텟ţ::ᴼ;
+ use mro 'c3';
+
+ sub ᴼ_or_Ḋ { '텟ţ::ᴼ' }
+ sub ᴼ_or_Ḟ { '텟ţ::ᴼ' }
+
+ package 텟ţ::Ḟ;
+ use base '텟ţ::ᴼ';
+ use mro 'c3';
+
+ sub ᴼ_or_Ḟ { '텟ţ::Ḟ' }
+
+ package 텟ţ::ऍ;
+ use base '텟ţ::ᴼ';
+ use mro 'c3';
+
+ package 텟ţ::Ḋ;
+ use base '텟ţ::ᴼ';
+ use mro 'c3';
+
+ sub ᴼ_or_Ḋ { '텟ţ::Ḋ' }
+ sub ƈ_or_Ḋ { '텟ţ::Ḋ' }
+
+ package 텟ţ::ƈ;
+ use base ('텟ţ::Ḋ', '텟ţ::Ḟ');
+ use mro 'c3';
+
+ sub ƈ_or_Ḋ { '텟ţ::ƈ' }
+
+ package 텟ţ::ᛒ;
+ use base ('텟ţ::ऍ', '텟ţ::Ḋ');
+ use mro 'c3';
+
+ package 텟ţ::ଅ;
+ use base ('텟ţ::ᛒ', '텟ţ::ƈ');
+ use mro 'c3';
+}
+
+ok(eq_array(
+ mro::get_linear_isa('텟ţ::ଅ'),
+ [ qw(텟ţ::ଅ 텟ţ::ᛒ 텟ţ::ऍ 텟ţ::ƈ 텟ţ::Ḋ 텟ţ::Ḟ 텟ţ::ᴼ) ]
+), '... got the right MRO for 텟ţ::ଅ');
+
+is(텟ţ::ଅ->ᴼ_or_Ḋ, '텟ţ::Ḋ', '... got the right method dispatch');
+is(텟ţ::ଅ->ᴼ_or_Ḟ, '텟ţ::Ḟ', '... got the right method dispatch');
+
+# NOTE:
+# this test is particularly interesting because the p5 dispatch
+# would actually call 텟ţ::Ḋ before 텟ţ::ƈ and 텟ţ::Ḋ is a
+# subclass of 텟ţ::ƈ
+is(텟ţ::ଅ->ƈ_or_Ḋ, '텟ţ::ƈ', '... got the right method dispatch');
Index: trunk/contrib/perl/t/mro/basic_03_dfs.t
===================================================================
--- trunk/contrib/perl/t/mro/basic_03_dfs.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/mro/basic_03_dfs.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/mro/basic_03_dfs.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/mro/basic_03_dfs_utf8.t (from rev 6437, vendor/perl/5.18.1/t/mro/basic_03_dfs_utf8.t)
===================================================================
--- trunk/contrib/perl/t/mro/basic_03_dfs_utf8.t (rev 0)
+++ trunk/contrib/perl/t/mro/basic_03_dfs_utf8.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,103 @@
+#!./perl
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+
+require q(./test.pl); plan(tests => 4);
+
+=pod
+
+This example is take from: http://www.python.org/2.3/mro.html
+
+"My second example"
+class O: pass
+class F(O): pass
+class E(O): pass
+class D(O): pass
+class C(D,F): pass
+class B(E,D): pass
+class A(B,C): pass
+
+ 6
+ ---
+Level 3 | O |
+ / --- \
+ / | \
+ / | \
+ / | \
+ --- --- ---
+Level 2 2 | E | 4 | D | | F | 5
+ --- --- ---
+ \ / \ /
+ \ / \ /
+ \ / \ /
+ --- ---
+Level 1 1 | B | | C | 3
+ --- ---
+ \ /
+ \ /
+ ---
+Level 0 0 | A |
+ ---
+
+>>> A.mro()
+(<class '__main__.A'>, <class '__main__.B'>, <class '__main__.E'>,
+<class '__main__.C'>, <class '__main__.D'>, <class '__main__.F'>,
+<type 'object'>)
+
+=cut
+
+{
+ package 텟ţ::ᴼ;
+ use mro 'dfs';
+
+ sub ᴼ_or_Ḋ { '텟ţ::ᴼ' }
+ sub ᴼ_or_Ḟ { '텟ţ::ᴼ' }
+
+ package 텟ţ::Ḟ;
+ use base '텟ţ::ᴼ';
+ use mro 'dfs';
+
+ sub ᴼ_or_Ḟ { '텟ţ::Ḟ' }
+
+ package 텟ţ::ऍ;
+ use base '텟ţ::ᴼ';
+ use mro 'dfs';
+
+ package 텟ţ::Ḋ;
+ use base '텟ţ::ᴼ';
+ use mro 'dfs';
+
+ sub ᴼ_or_Ḋ { '텟ţ::Ḋ' }
+ sub ƈ_or_Ḋ { '텟ţ::Ḋ' }
+
+ package 텟ţ::ƈ;
+ use base ('텟ţ::Ḋ', '텟ţ::Ḟ');
+ use mro 'dfs';
+
+ sub ƈ_or_Ḋ { '텟ţ::ƈ' }
+
+ package 텟ţ::ᛒ;
+ use base ('텟ţ::ऍ', '텟ţ::Ḋ');
+ use mro 'dfs';
+
+ package 텟ţ::ଅ;
+ use base ('텟ţ::ᛒ', '텟ţ::ƈ');
+ use mro 'dfs';
+}
+
+ok(eq_array(
+ mro::get_linear_isa('텟ţ::ଅ'),
+ [ qw(텟ţ::ଅ 텟ţ::ᛒ 텟ţ::ऍ 텟ţ::ᴼ 텟ţ::Ḋ 텟ţ::ƈ 텟ţ::Ḟ) ]
+), '... got the right MRO for 텟ţ::ଅ');
+
+is(텟ţ::ଅ->ᴼ_or_Ḋ, '텟ţ::ᴼ', '... got the right method dispatch');
+is(텟ţ::ଅ->ᴼ_or_Ḟ, '텟ţ::ᴼ', '... got the right method dispatch');
+
+# NOTE:
+# this test is particularly interesting because the p5 dispatch
+# would actually call 텟ţ::Ḋ before 텟ţ::ƈ and 텟ţ::Ḋ is a
+# subclass of 텟ţ::ƈ
+is(텟ţ::ଅ->ƈ_or_Ḋ, '텟ţ::Ḋ', '... got the right method dispatch');
Index: trunk/contrib/perl/t/mro/basic_04_c3.t
===================================================================
--- trunk/contrib/perl/t/mro/basic_04_c3.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/mro/basic_04_c3.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/mro/basic_04_c3.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/mro/basic_04_c3_utf8.t (from rev 6437, vendor/perl/5.18.1/t/mro/basic_04_c3_utf8.t)
===================================================================
--- trunk/contrib/perl/t/mro/basic_04_c3_utf8.t (rev 0)
+++ trunk/contrib/perl/t/mro/basic_04_c3_utf8.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,36 @@
+#!./perl
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+
+require q(./test.pl); plan(tests => 1);
+
+=pod
+
+From the parrot test t/pmc/object-meths.t
+
+ A B A E
+ \ / \ /
+ C D
+ \ /
+ \ /
+ F
+
+=cut
+
+{
+ package Ƭ::ŁiƁ::ଅ; use mro 'c3';
+ package Ƭ::ŁiƁ::ᛒ; use mro 'c3';
+ package Ƭ::ŁiƁ::ऍ; use mro 'c3';
+ package Ƭ::ŁiƁ::ƈ; use mro 'c3'; use base ('Ƭ::ŁiƁ::ଅ', 'Ƭ::ŁiƁ::ᛒ');
+ package Ƭ::ŁiƁ::Ḋ; use mro 'c3'; use base ('Ƭ::ŁiƁ::ଅ', 'Ƭ::ŁiƁ::ऍ');
+ package Ƭ::ŁiƁ::Ḟ; use mro 'c3'; use base ('Ƭ::ŁiƁ::ƈ', 'Ƭ::ŁiƁ::Ḋ');
+}
+
+ok(eq_array(
+ mro::get_linear_isa('Ƭ::ŁiƁ::Ḟ'),
+ [ qw(Ƭ::ŁiƁ::Ḟ Ƭ::ŁiƁ::ƈ Ƭ::ŁiƁ::Ḋ Ƭ::ŁiƁ::ଅ Ƭ::ŁiƁ::ᛒ Ƭ::ŁiƁ::ऍ) ]
+), '... got the right MRO for Ƭ::ŁiƁ::Ḟ');
+
Index: trunk/contrib/perl/t/mro/basic_04_dfs.t
===================================================================
--- trunk/contrib/perl/t/mro/basic_04_dfs.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/mro/basic_04_dfs.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/mro/basic_04_dfs.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/mro/basic_04_dfs_utf8.t (from rev 6437, vendor/perl/5.18.1/t/mro/basic_04_dfs_utf8.t)
===================================================================
--- trunk/contrib/perl/t/mro/basic_04_dfs_utf8.t (rev 0)
+++ trunk/contrib/perl/t/mro/basic_04_dfs_utf8.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,36 @@
+#!./perl
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+
+require q(./test.pl); plan(tests => 1);
+
+=pod
+
+From the parrot test t/pmc/object-meths.t
+
+ ଅ ᛒ ଅ ऍ
+ \ / \ /
+ ƈ Ḋ
+ \ /
+ \ /
+ Ḟ
+
+=cut
+
+{
+ package Ƭ::ŁiƁ::ଅ; use mro 'dfs';
+ package Ƭ::ŁiƁ::ᛒ; use mro 'dfs';
+ package Ƭ::ŁiƁ::ऍ; use mro 'dfs';
+ package Ƭ::ŁiƁ::ƈ; use mro 'dfs'; use base ('Ƭ::ŁiƁ::ଅ', 'Ƭ::ŁiƁ::ᛒ');
+ package Ƭ::ŁiƁ::Ḋ; use mro 'dfs'; use base ('Ƭ::ŁiƁ::ଅ', 'Ƭ::ŁiƁ::ऍ');
+ package Ƭ::ŁiƁ::Ḟ; use mro 'dfs'; use base ('Ƭ::ŁiƁ::ƈ', 'Ƭ::ŁiƁ::Ḋ');
+}
+
+ok(eq_array(
+ mro::get_linear_isa('Ƭ::ŁiƁ::Ḟ'),
+ [ qw(Ƭ::ŁiƁ::Ḟ Ƭ::ŁiƁ::ƈ Ƭ::ŁiƁ::ଅ Ƭ::ŁiƁ::ᛒ Ƭ::ŁiƁ::Ḋ Ƭ::ŁiƁ::ऍ) ]
+), '... got the right MRO for Ƭ::ŁiƁ::Ḟ');
+
Index: trunk/contrib/perl/t/mro/basic_05_c3.t
===================================================================
--- trunk/contrib/perl/t/mro/basic_05_c3.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/mro/basic_05_c3.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/mro/basic_05_c3.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/mro/basic_05_c3_utf8.t (from rev 6437, vendor/perl/5.18.1/t/mro/basic_05_c3_utf8.t)
===================================================================
--- trunk/contrib/perl/t/mro/basic_05_c3_utf8.t (rev 0)
+++ trunk/contrib/perl/t/mro/basic_05_c3_utf8.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,57 @@
+#!./perl
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+
+require q(./test.pl); plan(tests => 2);
+
+=pod
+
+This tests a strange bug found by Matt S. Trout
+while building DBIx::Class. Thanks Matt!!!!
+
+ <A>
+ / \
+<C> <B>
+ \ /
+ <D>
+
+=cut
+
+{
+ package Ｄiᚪၚd_A;
+ use mro 'c3';
+
+ sub ᕘ { 'Ｄiᚪၚd_A::ᕘ' }
+}
+{
+ package Ｄiᚪၚd_B;
+ use base 'Ｄiᚪၚd_A';
+ use mro 'c3';
+
+ sub ᕘ { 'Ｄiᚪၚd_B::ᕘ => ' . (shift)->SUPER::ᕘ }
+}
+{
+ package Ｄiᚪၚd_C;
+ use mro 'c3';
+ use base 'Ｄiᚪၚd_A';
+
+}
+{
+ package Ｄiᚪၚd_D;
+ use base ('Ｄiᚪၚd_C', 'Ｄiᚪၚd_B');
+ use mro 'c3';
+
+ sub ᕘ { 'Ｄiᚪၚd_D::ᕘ => ' . (shift)->SUPER::ᕘ }
+}
+
+ok(eq_array(
+ mro::get_linear_isa('Ｄiᚪၚd_D'),
+ [ qw(Ｄiᚪၚd_D Ｄiᚪၚd_C Ｄiᚪၚd_B Ｄiᚪၚd_A) ]
+), '... got the right MRO for Ｄiᚪၚd_D');
+
+is(Ｄiᚪၚd_D->ᕘ,
+ 'Ｄiᚪၚd_D::ᕘ => Ｄiᚪၚd_B::ᕘ => Ｄiᚪၚd_A::ᕘ',
+ '... got the right next::method dispatch path');
Index: trunk/contrib/perl/t/mro/basic_05_dfs.t
===================================================================
--- trunk/contrib/perl/t/mro/basic_05_dfs.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/mro/basic_05_dfs.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/mro/basic_05_dfs.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/mro/basic_05_dfs_utf8.t (from rev 6437, vendor/perl/5.18.1/t/mro/basic_05_dfs_utf8.t)
===================================================================
--- trunk/contrib/perl/t/mro/basic_05_dfs_utf8.t (rev 0)
+++ trunk/contrib/perl/t/mro/basic_05_dfs_utf8.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,58 @@
+#!./perl
+
+use strict;
+use warnings;
+
+use utf8;
+use open qw( :utf8 :std );
+
+require q(./test.pl); plan(tests => 2);
+
+=pod
+
+This tests a strange bug found by Matt S. Trout
+while building DBIx::Class. Thanks Matt!!!!
+
+ <A>
+ / \
+<C> <B>
+ \ /
+ <D>
+
+=cut
+
+{
+ package Ｄiᚪၚd_A;
+ use mro 'dfs';
+
+ sub ᕘ { 'Ｄiᚪၚd_A::ᕘ' }
+}
+{
+ package Ｄiᚪၚd_B;
+ use base 'Ｄiᚪၚd_A';
+ use mro 'dfs';
+
+ sub ᕘ { 'Ｄiᚪၚd_B::ᕘ => ' . (shift)->SUPER::ᕘ }
+}
+{
+ package Ｄiᚪၚd_C;
+ use mro 'dfs';
+ use base 'Ｄiᚪၚd_A';
+
+}
+{
+ package Ｄiᚪၚd_D;
+ use base ('Ｄiᚪၚd_C', 'Ｄiᚪၚd_B');
+ use mro 'dfs';
+
+ sub ᕘ { 'Ｄiᚪၚd_D::ᕘ => ' . (shift)->SUPER::ᕘ }
+}
+
+ok(eq_array(
+ mro::get_linear_isa('Ｄiᚪၚd_D'),
+ [ qw(Ｄiᚪၚd_D Ｄiᚪၚd_C Ｄiᚪၚd_A Ｄiᚪၚd_B) ]
+), '... got the right MRO for Ｄiᚪၚd_D');
+
+is(Ｄiᚪၚd_D->ᕘ,
+ 'Ｄiᚪၚd_D::ᕘ => Ｄiᚪၚd_A::ᕘ',
+ '... got the right next::method dispatch path');
Copied: trunk/contrib/perl/t/mro/basic_utf8.t (from rev 6437, vendor/perl/5.18.1/t/mro/basic_utf8.t)
===================================================================
--- trunk/contrib/perl/t/mro/basic_utf8.t (rev 0)
+++ trunk/contrib/perl/t/mro/basic_utf8.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,328 @@
+#!./perl
+
+use utf8;
+use open qw( :utf8 :std );
+use strict;
+use warnings;
+
+BEGIN { require q(./test.pl); } plan(tests => 53);
+
+require mro;
+
+{
+ package MRO_அ;
+ our @ISA = qw//;
+ package MRO_ɓ;
+ our @ISA = qw//;
+ package MRO_ᶝ;
+ our @ISA = qw//;
+ package MRO_ｄ;
+ our @ISA = qw/MRO_அ MRO_ɓ MRO_ᶝ/;
+ package MRO_ɛ;
+ our @ISA = qw/MRO_அ MRO_ɓ MRO_ᶝ/;
+ package MRO_ᚠ;
+ our @ISA = qw/MRO_ｄ MRO_ɛ/;
+}
+
+my @MFO_ᚠ_DFS = qw/MRO_ᚠ MRO_ｄ MRO_அ MRO_ɓ MRO_ᶝ MRO_ɛ/;
+my @MFO_ᚠ_C3 = qw/MRO_ᚠ MRO_ｄ MRO_ɛ MRO_அ MRO_ɓ MRO_ᶝ/;
+is(mro::get_mro('MRO_ᚠ'), 'dfs');
+ok(eq_array(
+ mro::get_linear_isa('MRO_ᚠ'), \@MFO_ᚠ_DFS
+));
+
+ok(eq_array(mro::get_linear_isa('MRO_ᚠ', 'dfs'), \@MFO_ᚠ_DFS));
+ok(eq_array(mro::get_linear_isa('MRO_ᚠ', 'c3'), \@MFO_ᚠ_C3));
+eval{mro::get_linear_isa('MRO_ᚠ', 'C3')};
+like($@, qr/^Invalid mro name: 'C3'/);
+
+mro::set_mro('MRO_ᚠ', 'c3');
+is(mro::get_mro('MRO_ᚠ'), 'c3');
+ok(eq_array(
+ mro::get_linear_isa('MRO_ᚠ'), \@MFO_ᚠ_C3
+));
+
+ok(eq_array(mro::get_linear_isa('MRO_ᚠ', 'dfs'), \@MFO_ᚠ_DFS));
+ok(eq_array(mro::get_linear_isa('MRO_ᚠ', 'c3'), \@MFO_ᚠ_C3));
+eval{mro::get_linear_isa('MRO_ᚠ', 'C3')};
+like($@, qr/^Invalid mro name: 'C3'/);
+
+ok(!mro::is_universal('MRO_ɓ'));
+
+ at UNIVERSAL::ISA = qw/MRO_ᚠ/;
+ok(mro::is_universal('MRO_ɓ'));
+
+ at UNIVERSAL::ISA = ();
+ok(!mro::is_universal('MRO_ᚠ'));
+ok(!mro::is_universal('MRO_ɓ'));
+
+# is_universal, get_mro, and get_linear_isa should
+# handle non-existent packages sanely
+ok(!mro::is_universal('Does_Not_Exist'));
+is(mro::get_mro('Also_Does_Not_Exist'), 'dfs');
+ok(eq_array(
+ mro::get_linear_isa('Does_Not_Exist_Three'),
+ [qw/Does_Not_Exist_Three/]
+));
+
+# Assigning @ISA via globref
+{
+ package MRO_ҭṣṱबꗻ;
+ sub 텟tf운ꜿ { return 123 }
+ package MRO_Test옽ḦРꤷsӭ;
+ sub 텟ₜꖢᶯcƧ { return 321 }
+ package MRO_Ɯ; our @ISA = qw/MRO_ҭṣṱबꗻ/;
+}
+*MRO_ᕡ::ISA = *MRO_Ɯ::ISA;
+is(eval { MRO_ᕡ->텟tf운ꜿ() }, 123);
+
+# XXX TODO (when there's a way to backtrack through a glob's aliases)
+# push(@MRO_M::ISA, 'MRO_TestOtherBase');
+# is(eval { MRO_N->testfunctwo() }, 321);
+
+# Simple DESTROY Baseline
+{
+ my $x = 0;
+ my $obj;
+
+ {
+ package DESTROY_MRO_Bӓeᓕne;
+ sub new { bless {} => shift }
+ sub DESTROY { $x++ }
+
+ package DESTROY_MRO_Bӓeᓕne_χḻɖ;
+ our @ISA = qw/DESTROY_MRO_Bӓeᓕne/;
+ }
+
+ $obj = DESTROY_MRO_Bӓeᓕne->new();
+ undef $obj;
+ is($x, 1);
+
+ $obj = DESTROY_MRO_Bӓeᓕne_χḻɖ->new();
+ undef $obj;
+ is($x, 2);
+}
+
+# Dynamic DESTROY
+{
+ my $x = 0;
+ my $obj;
+
+ {
+ package DESTROY_MRO_Ｄჷ및;
+ sub new { bless {} => shift }
+
+ package DESTROY_MRO_Ｄჷ및_χḻɖ;
+ our @ISA = qw/DESTROY_MRO_Ｄჷ및/;
+ }
+
+ $obj = DESTROY_MRO_Ｄჷ및->new();
+ undef $obj;
+ is($x, 0);
+
+ $obj = DESTROY_MRO_Ｄჷ및_χḻɖ->new();
+ undef $obj;
+ is($x, 0);
+
+ no warnings 'once';
+ *DESTROY_MRO_Ｄჷ및::DESTROY = sub { $x++ };
+
+ $obj = DESTROY_MRO_Ｄჷ및->new();
+ undef $obj;
+ is($x, 1);
+
+ $obj = DESTROY_MRO_Ｄჷ및_χḻɖ->new();
+ undef $obj;
+ is($x, 2);
+}
+
+# clearing @ISA in different ways
+# some are destructive to the package, hence the new
+# package name each time
+{
+ no warnings 'uninitialized';
+ {
+ package ᛁ앛ଌᛠ;
+ our @ISA = qw/ｘｘ ƳƳ ƶƶ/;
+ }
+ # baseline
+ ok(eq_array(mro::get_linear_isa('ᛁ앛ଌᛠ'),[qw/ᛁ앛ଌᛠ ｘｘ ƳƳ ƶƶ/]));
+
+ # this looks dumb, but it preserves existing behavior for compatibility
+ # (undefined @ISA elements treated as "main")
+ $ᛁ앛ଌᛠ::ISA[1] = undef;
+ ok(eq_array(mro::get_linear_isa('ᛁ앛ଌᛠ'),[qw/ᛁ앛ଌᛠ ｘｘ main ƶƶ/]));
+
+ # undef the array itself
+ undef @ᛁ앛ଌᛠ::ISA;
+ ok(eq_array(mro::get_linear_isa('ᛁ앛ଌᛠ'),[qw/ᛁ앛ଌᛠ/]));
+
+ # Now, clear more than one package's @ISA at once
+ {
+ package ᛁ앛ଌᛠ1;
+ our @ISA = qw/ＷẆ ｘｘ/;
+
+ package ᛁ앛ଌᛠ2;
+ our @ISA = qw/ƳƳ ƶƶ/;
+ }
+ # baseline
+ ok(eq_array(mro::get_linear_isa('ᛁ앛ଌᛠ1'),[qw/ᛁ앛ଌᛠ1 ＷẆ ｘｘ/]));
+ ok(eq_array(mro::get_linear_isa('ᛁ앛ଌᛠ2'),[qw/ᛁ앛ଌᛠ2 ƳƳ ƶƶ/]));
+ (@ᛁ앛ଌᛠ1::ISA, @ᛁ앛ଌᛠ2::ISA) = ();
+
+ ok(eq_array(mro::get_linear_isa('ᛁ앛ଌᛠ1'),[qw/ᛁ앛ଌᛠ1/]));
+ ok(eq_array(mro::get_linear_isa('ᛁ앛ଌᛠ2'),[qw/ᛁ앛ଌᛠ2/]));
+
+ # [perl #49564] This is a pretty obscure way of clearing @ISA but
+ # it tests a regression that affects XS code calling av_clear too.
+ {
+ package ᛁ앛ଌᛠ3;
+ our @ISA = qw/ＷẆ ｘｘ/;
+ }
+ ok(eq_array(mro::get_linear_isa('ᛁ앛ଌᛠ3'),[qw/ᛁ앛ଌᛠ3 ＷẆ ｘｘ/]));
+ {
+ package ᛁ앛ଌᛠ3;
+ reset 'I';
+ }
+ ok(eq_array(mro::get_linear_isa('ᛁ앛ଌᛠ3'),[qw/ᛁ앛ଌᛠ3/]));
+}
+
+# Check that recursion bails out "cleanly" in a variety of cases
+# (as opposed to say, bombing the interpreter or something)
+{
+ my @recurse_codes = (
+ '@MRO_ഋ1::ISA = "MRO_ഋ2"; @MRO_ഋ2::ISA = "MRO_ഋ1";',
+ '@MRO_ഋ3::ISA = "MRO_ഋ4"; push(@MRO_ഋ4::ISA, "MRO_ഋ3");',
+ '@MRO_ഋ5::ISA = "MRO_ഋ6"; @MRO_ഋ6::ISA = qw/ｘｘ MRO_ഋ5 ƳƳ/;',
+ '@MRO_ഋ7::ISA = "MRO_ഋ8"; push(@MRO_ഋ8::ISA, qw/ｘｘ MRO_ഋ7 ƳƳ/)',
+ );
+ foreach my $code (@recurse_codes) {
+ eval $code;
+ ok($@ =~ /Recursive inheritance detected/);
+ }
+}
+
+# Check that SUPER caches get invalidated correctly
+{
+ {
+ package ｽṔઍR텟ʇ;
+ sub new { bless {} => shift }
+ sub ຟઓ { $_[1]+1 }
+
+ package ｽṔઍR텟ʇ::MᶤƉ;
+ our @ISA = 'ｽṔઍR텟ʇ';
+
+ package ｽṔઍR텟ʇ::킫;
+ our @ISA = 'ｽṔઍR텟ʇ::MᶤƉ';
+ sub ຟઓ { my $s = shift; $s->SUPER::ຟઓ(@_) }
+
+ package ｽṔઍR텟ʇ::렙ﷰए;
+ sub ຟઓ { $_[1]+3 }
+ }
+
+ my $stk_obj = ｽṔઍR텟ʇ::킫->new();
+ is($stk_obj->ຟઓ(1), 2);
+ { no warnings 'redefine';
+ *ｽṔઍR텟ʇ::ຟઓ = sub { $_[1]+2 };
+ }
+ is($stk_obj->ຟઓ(2), 4);
+ @ｽṔઍR텟ʇ::MᶤƉ::ISA = 'ｽṔઍR텟ʇ::렙ﷰए';
+ is($stk_obj->ຟઓ(3), 6);
+}
+
+{
+ {
+ # assigning @ISA via arrayref to globref RT 60220
+ package ᛔ1;
+ sub new { bless {}, shift }
+
+ package ᛔ2;
+ }
+ *{ᛔ2::ISA} = [ 'ᛔ1' ];
+ my $foo = ᛔ2->new;
+ ok(!eval { $foo->ɓᛅƘ }, "no ɓᛅƘ method");
+ no warnings 'once'; # otherwise it'll bark about ᛔ1::ɓᛅƘ used only once
+ *{ᛔ1::ɓᛅƘ} = sub { "[ɓᛅƘ]" };
+ is(scalar eval { $foo->ɓᛅƘ }, "[ɓᛅƘ]", "can ɓᛅƘ now");
+ is $@, '';
+}
+
+{
+ # assigning @ISA via arrayref then modifying it RT 72866
+ {
+ package ㄑ1;
+ sub Ｆஓ { }
+
+ package ㄑ2;
+ sub ƚ { }
+
+ package ㄑ3;
+ }
+ push @ㄑ3::ISA, "ㄑ1";
+ can_ok("ㄑ3", "Ｆஓ");
+ *ㄑ3::ISA = [];
+ push @ㄑ3::ISA, "ㄑ1";
+ can_ok("ㄑ3", "Ｆஓ");
+ *ㄑ3::ISA = [];
+ push @ㄑ3::ISA, "ㄑ2";
+ can_ok("ㄑ3", "ƚ");
+ ok(!ㄑ3->can("Ｆஓ"), "can't call Ｆஓ method any longer");
+}
+
+{
+ # test mro::method_changed_in
+ my $count = mro::get_pkg_gen("MRO_அ");
+ mro::method_changed_in("MRO_அ");
+ my $count_new = mro::get_pkg_gen("MRO_அ");
+
+ is($count_new, $count + 1);
+}
+
+{
+ # test if we can call mro::invalidate_all_method_caches;
+ eval {
+ mro::invalidate_all_method_caches();
+ };
+ is($@, "");
+}
+
+{
+ # @main::ISA
+ no warnings 'once';
+ @main::ISA = 'პᛅeȵᛏ';
+ my $output = '';
+ *პᛅeȵᛏ::ど = sub { $output .= 'პᛅeȵᛏ' };
+ *პᛅeȵᛏ2::ど = sub { $output .= 'პᛅeȵᛏ2' };
+ main->ど;
+ @main::ISA = 'პᛅeȵᛏ2';
+ main->ど;
+ is $output, 'პᛅeȵᛏპᛅeȵᛏ2', '@main::ISA is magical';
+}
+
+{
+ # Undefining *ISA, then modifying @ISA
+ # This broke Class::Trait. See [perl #79024].
+ {package Class::Trait::Base}
+ no strict 'refs';
+ undef *{"एxṰர::ʦፖㄡsȨ::ISA"};
+ 'एxṰர::ʦፖㄡsȨ'->isa('Class::Trait::Base'); # cache the mro
+ unshift @{"एxṰர::ʦፖㄡsȨ::ISA"}, 'Class::Trait::Base';
+ ok 'एxṰர::ʦፖㄡsȨ'->isa('Class::Trait::Base'),
+ 'a isa b after undef *a::ISA and @a::ISA modification';
+}
+
+{
+ # Deleting $package::{ISA}
+ # Broken in 5.10.0; fixed in 5.13.7
+ @BḼᵑtｈ::ISA = 'Bલdḏ';
+ delete $BḼᵑtｈ::{ISA};
+ ok !BḼᵑtｈ->isa("Bલdḏ"), 'delete $package::{ISA}';
+}
+
+{
+ # Undefining stashes
+ @ᖫᕃㄒṭ::ISA = "ᖮw잍";
+ @ᖮw잍::ISA = "ሲঌએ";
+ undef %ᖮw잍::;
+ ok !ᖫᕃㄒṭ->isa('ሲঌએ'), 'undef %package:: updates subclasses';
+}
Modified: trunk/contrib/perl/t/mro/c3_with_overload.t
===================================================================
--- trunk/contrib/perl/t/mro/c3_with_overload.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/mro/c3_with_overload.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -29,10 +29,10 @@
}
my $x = InheritingFromOverloadedTest->new();
-isa_ok($x, 'InheritingFromOverloadedTest');
+object_ok($x, 'InheritingFromOverloadedTest');
my $y = OverloadingTest->new();
-isa_ok($y, 'OverloadingTest');
+object_ok($y, 'OverloadingTest');
is("$x", 'InheritingFromOverloadedTest stringified', '... got the right value when stringifing');
is("$y", 'OverloadingTest stringified', '... got the right value when stringifing');
Property changes on: trunk/contrib/perl/t/mro/c3_with_overload.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/mro/c3_with_overload_utf8.t (from rev 6437, vendor/perl/5.18.1/t/mro/c3_with_overload_utf8.t)
===================================================================
--- trunk/contrib/perl/t/mro/c3_with_overload_utf8.t (rev 0)
+++ trunk/contrib/perl/t/mro/c3_with_overload_utf8.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,47 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+require q(./test.pl); plan(tests => 7);
+
+{
+ package BaseTest;
+ use strict;
+ use warnings;
+ use mro 'c3';
+
+ package OverloadingTest;
+ use strict;
+ use warnings;
+ use mro 'c3';
+ use base 'BaseTest';
+ use overload '""' => sub { ref(shift) . " stringified" },
+ fallback => 1;
+
+ sub new { bless {} => shift }
+
+ package InheritingFromOverloadedTest;
+ use strict;
+ use warnings;
+ use base 'OverloadingTest';
+ use mro 'c3';
+}
+
+my $x = InheritingFromOverloadedTest->new();
+object_ok($x, 'InheritingFromOverloadedTest');
+
+my $y = OverloadingTest->new();
+object_ok($y, 'OverloadingTest');
+
+is("$x", 'InheritingFromOverloadedTest stringified', '... got the right value when stringifing');
+is("$y", 'OverloadingTest stringified', '... got the right value when stringifing');
+
+ok(($y eq 'OverloadingTest stringified'), '... eq was handled correctly');
+
+my $result;
+eval {
+ $result = $x eq 'InheritingFromOverloadedTest stringified'
+};
+ok(!$@, '... this should not throw an exception');
+ok($result, '... and we should get the true value');
Index: trunk/contrib/perl/t/mro/complex_c3.t
===================================================================
--- trunk/contrib/perl/t/mro/complex_c3.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/mro/complex_c3.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/mro/complex_c3.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/mro/complex_c3_utf8.t (from rev 6437, vendor/perl/5.18.1/t/mro/complex_c3_utf8.t)
===================================================================
--- trunk/contrib/perl/t/mro/complex_c3_utf8.t (rev 0)
+++ trunk/contrib/perl/t/mro/complex_c3_utf8.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,144 @@
+#!./perl
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+
+require q(./test.pl); plan(tests => 12);
+
+=pod
+
+This example is taken from: http://rt.cpan.org/Public/Bug/Display.html?id=20879
+
+ --- --- ---
+Level 5 8 | A | 9 | B | A | C | (More General)
+ --- --- --- V
+ \ | / |
+ \ | / |
+ \ | / |
+ \ | / |
+ --- |
+Level 4 7 | D | |
+ --- |
+ / \ |
+ / \ |
+ --- --- |
+Level 3 4 | G | 6 | E | |
+ --- --- |
+ | | |
+ | | |
+ --- --- |
+Level 2 3 | H | 5 | F | |
+ --- --- |
+ \ / | |
+ \ / | |
+ \ | |
+ / \ | |
+ / \ | |
+ --- --- |
+Level 1 1 | J | 2 | I | |
+ --- --- |
+ \ / |
+ \ / |
+ --- v
+Level 0 0 | K | (More Specialized)
+ ---
+
+
+0123456789A
+KJIHGFEDABC
+
+=cut
+
+{
+ package 텟Ṱ::ᐊ; use mro 'c3';
+
+ package 텟Ṱ::ḅ; use mro 'c3';
+
+ package 텟Ṱ::ȼ; use mro 'c3';
+
+ package 텟Ṱ::Ḏ; use mro 'c3';
+ use base qw/텟Ṱ::ᐊ 텟Ṱ::ḅ 텟Ṱ::ȼ/;
+
+ package 텟Ṱ::Ӭ; use mro 'c3';
+ use base qw/텟Ṱ::Ḏ/;
+
+ package 텟Ṱ::Ḟ; use mro 'c3';
+ use base qw/텟Ṱ::Ӭ/;
+ sub testmèth { "wrong" }
+
+ package 텟Ṱ::ḡ; use mro 'c3';
+ use base qw/텟Ṱ::Ḏ/;
+
+ package 텟Ṱ::Ḣ; use mro 'c3';
+ use base qw/텟Ṱ::ḡ/;
+
+ package 텟Ṱ::ᶦ; use mro 'c3';
+ use base qw/텟Ṱ::Ḣ 텟Ṱ::Ḟ/;
+ sub testmèth { "right" }
+
+ package 텟Ṱ::Ｊ; use mro 'c3';
+ use base qw/텟Ṱ::Ḟ/;
+
+ package 텟Ṱ::Ḵ; use mro 'c3';
+ use base qw/텟Ṱ::Ｊ 텟Ṱ::ᶦ/;
+ sub testmèth { shift->next::method }
+}
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::ᐊ'),
+ [ qw(텟Ṱ::ᐊ) ]
+), '... got the right C3 merge order for 텟Ṱ::ᐊ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::ḅ'),
+ [ qw(텟Ṱ::ḅ) ]
+), '... got the right C3 merge order for 텟Ṱ::ḅ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::ȼ'),
+ [ qw(텟Ṱ::ȼ) ]
+), '... got the right C3 merge order for 텟Ṱ::ȼ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::Ḏ'),
+ [ qw(텟Ṱ::Ḏ 텟Ṱ::ᐊ 텟Ṱ::ḅ 텟Ṱ::ȼ) ]
+), '... got the right C3 merge order for 텟Ṱ::Ḏ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::Ӭ'),
+ [ qw(텟Ṱ::Ӭ 텟Ṱ::Ḏ 텟Ṱ::ᐊ 텟Ṱ::ḅ 텟Ṱ::ȼ) ]
+), '... got the right C3 merge order for 텟Ṱ::Ӭ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::Ḟ'),
+ [ qw(텟Ṱ::Ḟ 텟Ṱ::Ӭ 텟Ṱ::Ḏ 텟Ṱ::ᐊ 텟Ṱ::ḅ 텟Ṱ::ȼ) ]
+), '... got the right C3 merge order for 텟Ṱ::Ḟ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::ḡ'),
+ [ qw(텟Ṱ::ḡ 텟Ṱ::Ḏ 텟Ṱ::ᐊ 텟Ṱ::ḅ 텟Ṱ::ȼ) ]
+), '... got the right C3 merge order for 텟Ṱ::ḡ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::Ḣ'),
+ [ qw(텟Ṱ::Ḣ 텟Ṱ::ḡ 텟Ṱ::Ḏ 텟Ṱ::ᐊ 텟Ṱ::ḅ 텟Ṱ::ȼ) ]
+), '... got the right C3 merge order for 텟Ṱ::Ḣ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::ᶦ'),
+ [ qw(텟Ṱ::ᶦ 텟Ṱ::Ḣ 텟Ṱ::ḡ 텟Ṱ::Ḟ 텟Ṱ::Ӭ 텟Ṱ::Ḏ 텟Ṱ::ᐊ 텟Ṱ::ḅ 텟Ṱ::ȼ) ]
+), '... got the right C3 merge order for 텟Ṱ::ᶦ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::Ｊ'),
+ [ qw(텟Ṱ::Ｊ 텟Ṱ::Ḟ 텟Ṱ::Ӭ 텟Ṱ::Ḏ 텟Ṱ::ᐊ 텟Ṱ::ḅ 텟Ṱ::ȼ) ]
+), '... got the right C3 merge order for 텟Ṱ::Ｊ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::Ḵ'),
+ [ qw(텟Ṱ::Ḵ 텟Ṱ::Ｊ 텟Ṱ::ᶦ 텟Ṱ::Ḣ 텟Ṱ::ḡ 텟Ṱ::Ḟ 텟Ṱ::Ӭ 텟Ṱ::Ḏ 텟Ṱ::ᐊ 텟Ṱ::ḅ 텟Ṱ::ȼ) ]
+), '... got the right C3 merge order for 텟Ṱ::Ḵ');
+
+is(텟Ṱ::Ḵ->testmèth(), "right", 'next::method working ok');
Index: trunk/contrib/perl/t/mro/complex_dfs.t
===================================================================
--- trunk/contrib/perl/t/mro/complex_dfs.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/mro/complex_dfs.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/mro/complex_dfs.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/mro/complex_dfs_utf8.t (from rev 6437, vendor/perl/5.18.1/t/mro/complex_dfs_utf8.t)
===================================================================
--- trunk/contrib/perl/t/mro/complex_dfs_utf8.t (rev 0)
+++ trunk/contrib/perl/t/mro/complex_dfs_utf8.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,139 @@
+#!./perl
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+
+require q(./test.pl); plan(tests => 11);
+
+=pod
+
+This example is taken from: http://rt.cpan.org/Public/Bug/Display.html?id=20879
+
+ --- --- ---
+Level 5 8 | A | 9 | B | A | C | (More General)
+ --- --- --- V
+ \ | / |
+ \ | / |
+ \ | / |
+ \ | / |
+ --- |
+Level 4 7 | D | |
+ --- |
+ / \ |
+ / \ |
+ --- --- |
+Level 3 4 | G | 6 | E | |
+ --- --- |
+ | | |
+ | | |
+ --- --- |
+Level 2 3 | H | 5 | F | |
+ --- --- |
+ \ / | |
+ \ / | |
+ \ | |
+ / \ | |
+ / \ | |
+ --- --- |
+Level 1 1 | J | 2 | I | |
+ --- --- |
+ \ / |
+ \ / |
+ --- v
+Level 0 0 | K | (More Specialized)
+ ---
+
+
+0123456789A
+KJIHGFEDABC
+
+=cut
+
+{
+ package 텟Ṱ::ᐊ; use mro 'dfs';
+
+ package 텟Ṱ::ḅ; use mro 'dfs';
+
+ package 텟Ṱ::ȼ; use mro 'dfs';
+
+ package 텟Ṱ::Ḏ; use mro 'dfs';
+ use base qw/텟Ṱ::ᐊ 텟Ṱ::ḅ 텟Ṱ::ȼ/;
+
+ package 텟Ṱ::Ӭ; use mro 'dfs';
+ use base qw/텟Ṱ::Ḏ/;
+
+ package 텟Ṱ::Ḟ; use mro 'dfs';
+ use base qw/텟Ṱ::Ӭ/;
+
+ package 텟Ṱ::ḡ; use mro 'dfs';
+ use base qw/텟Ṱ::Ḏ/;
+
+ package 텟Ṱ::Ḣ; use mro 'dfs';
+ use base qw/텟Ṱ::ḡ/;
+
+ package 텟Ṱ::ᶦ; use mro 'dfs';
+ use base qw/텟Ṱ::Ḣ 텟Ṱ::Ḟ/;
+
+ package 텟Ṱ::Ｊ; use mro 'dfs';
+ use base qw/텟Ṱ::Ḟ/;
+
+ package 텟Ṱ::Ḵ; use mro 'dfs';
+ use base qw/텟Ṱ::Ｊ 텟Ṱ::ᶦ/;
+}
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::ᐊ'),
+ [ qw(텟Ṱ::ᐊ) ]
+), '... got the right DFS merge order for 텟Ṱ::ᐊ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::ḅ'),
+ [ qw(텟Ṱ::ḅ) ]
+), '... got the right DFS merge order for 텟Ṱ::ḅ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::ȼ'),
+ [ qw(텟Ṱ::ȼ) ]
+), '... got the right DFS merge order for 텟Ṱ::ȼ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::Ḏ'),
+ [ qw(텟Ṱ::Ḏ 텟Ṱ::ᐊ 텟Ṱ::ḅ 텟Ṱ::ȼ) ]
+), '... got the right DFS merge order for 텟Ṱ::Ḏ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::Ӭ'),
+ [ qw(텟Ṱ::Ӭ 텟Ṱ::Ḏ 텟Ṱ::ᐊ 텟Ṱ::ḅ 텟Ṱ::ȼ) ]
+), '... got the right DFS merge order for 텟Ṱ::Ӭ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::Ḟ'),
+ [ qw(텟Ṱ::Ḟ 텟Ṱ::Ӭ 텟Ṱ::Ḏ 텟Ṱ::ᐊ 텟Ṱ::ḅ 텟Ṱ::ȼ) ]
+), '... got the right DFS merge order for 텟Ṱ::Ḟ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::ḡ'),
+ [ qw(텟Ṱ::ḡ 텟Ṱ::Ḏ 텟Ṱ::ᐊ 텟Ṱ::ḅ 텟Ṱ::ȼ) ]
+), '... got the right DFS merge order for 텟Ṱ::ḡ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::Ḣ'),
+ [ qw(텟Ṱ::Ḣ 텟Ṱ::ḡ 텟Ṱ::Ḏ 텟Ṱ::ᐊ 텟Ṱ::ḅ 텟Ṱ::ȼ) ]
+), '... got the right DFS merge order for 텟Ṱ::Ḣ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::ᶦ'),
+ [ qw(텟Ṱ::ᶦ 텟Ṱ::Ḣ 텟Ṱ::ḡ 텟Ṱ::Ḏ 텟Ṱ::ᐊ 텟Ṱ::ḅ 텟Ṱ::ȼ 텟Ṱ::Ḟ 텟Ṱ::Ӭ) ]
+), '... got the right DFS merge order for 텟Ṱ::ᶦ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::Ｊ'),
+ [ qw(텟Ṱ::Ｊ 텟Ṱ::Ḟ 텟Ṱ::Ӭ 텟Ṱ::Ḏ 텟Ṱ::ᐊ 텟Ṱ::ḅ 텟Ṱ::ȼ) ]
+), '... got the right DFS merge order for 텟Ṱ::Ｊ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::Ḵ'),
+ [ qw(텟Ṱ::Ḵ 텟Ṱ::Ｊ 텟Ṱ::Ḟ 텟Ṱ::Ӭ 텟Ṱ::Ḏ 텟Ṱ::ᐊ 텟Ṱ::ḅ 텟Ṱ::ȼ 텟Ṱ::ᶦ 텟Ṱ::Ḣ 텟Ṱ::ḡ) ]
+), '... got the right DFS merge order for 텟Ṱ::Ḵ');
Index: trunk/contrib/perl/t/mro/dbic_c3.t
===================================================================
--- trunk/contrib/perl/t/mro/dbic_c3.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/mro/dbic_c3.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/mro/dbic_c3.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/mro/dbic_c3_utf8.t (from rev 6437, vendor/perl/5.18.1/t/mro/dbic_c3_utf8.t)
===================================================================
(Binary files differ)
Index: trunk/contrib/perl/t/mro/dbic_dfs.t
===================================================================
--- trunk/contrib/perl/t/mro/dbic_dfs.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/mro/dbic_dfs.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/mro/dbic_dfs.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/mro/dbic_dfs_utf8.t (from rev 6437, vendor/perl/5.18.1/t/mro/dbic_dfs_utf8.t)
===================================================================
(Binary files differ)
Modified: trunk/contrib/perl/t/mro/inconsistent_c3.t
===================================================================
--- trunk/contrib/perl/t/mro/inconsistent_c3.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/mro/inconsistent_c3.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -46,4 +46,5 @@
}
eval { mro::get_linear_isa('Z', 'c3') };
-like($@, qr/^Inconsistent /, '... got the right error with an inconsistent hierarchy');
+like($@, qr/^Inconsistent hierarchy during C3 merge of class 'Z'/,
+ '... got the right error with an inconsistent hierarchy');
Property changes on: trunk/contrib/perl/t/mro/inconsistent_c3.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/t/mro/inconsistent_c3_utf8.t (from rev 6437, vendor/perl/5.18.1/t/mro/inconsistent_c3_utf8.t)
===================================================================
--- trunk/contrib/perl/t/mro/inconsistent_c3_utf8.t (rev 0)
+++ trunk/contrib/perl/t/mro/inconsistent_c3_utf8.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,52 @@
+#!./perl
+
+use strict;
+use warnings;
+BEGIN {
+ unless (-d 'blib') {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+}
+
+use utf8;
+use open qw( :utf8 :std );
+
+require q(./test.pl); plan(tests => 1);
+
+require mro;
+
+=pod
+
+This example is take from: http://www.python.org/2.3/mro.html
+
+"Serious order disagreement" # From Guido
+class O: pass
+class X(O): pass
+class Y(O): pass
+class A(X,Y): pass
+class B(Y,X): pass
+try:
+ class Z(A,B): pass #creates Z(A,B) in Python 2.2
+except TypeError:
+ pass # Z(A,B) cannot be created in Python 2.3
+
+=cut
+
+{
+ package ẋ;
+
+ package Ƴ;
+
+ package ẋƳ;
+ our @ISA = ('ẋ', 'Ƴ');
+
+ package Ƴẋ;
+ our @ISA = ('Ƴ', 'ẋ');
+
+ package Ȥ;
+ our @ISA = ('ẋƳ', 'Ƴẋ');
+}
+
+eval { mro::get_linear_isa('Ȥ', 'c3') };
+like($@, qr/^Inconsistent /, '... got the right error with an inconsistent hierarchy');
Modified: trunk/contrib/perl/t/mro/isa_aliases.t
===================================================================
--- trunk/contrib/perl/t/mro/isa_aliases.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/mro/isa_aliases.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -2,7 +2,7 @@
BEGIN { chdir 't'; @INC = '../lib'; require './test.pl' }
-plan 12;
+plan 13;
@Foogh::ISA = "Bar";
*Phoogh::ISA = *Foogh::ISA;
@@ -41,3 +41,11 @@
'!isa when another stash has claimed the @ISA via ref-to-glob assignment';
ok !Phoo->isa("Bar"),
'!isa on the stash that claimed the @ISA via ref-to-glob assignment';
+
+*Fooo::ISA = *Baro::ISA;
+ at Fooo::ISA = "Bazo";
+sub Bazo::ook { "Baz" }
+sub L::ook { "See" }
+Baro->ook;
+local *Fooo::ISA = ["L"];
+is 'Baro'->ook, 'See', 'localised *ISA=$ref assignment';
Property changes on: trunk/contrib/perl/t/mro/isa_aliases.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/mro/isa_aliases_utf8.t (from rev 6437, vendor/perl/5.18.1/t/mro/isa_aliases_utf8.t)
===================================================================
--- trunk/contrib/perl/t/mro/isa_aliases_utf8.t (rev 0)
+++ trunk/contrib/perl/t/mro/isa_aliases_utf8.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,46 @@
+#!./perl
+
+BEGIN { chdir 't'; @INC = '../lib'; require './test.pl' }
+
+use utf8;
+use open qw( :utf8 :std );
+
+plan 12;
+
+@ฟ옥ʮ::ISA = "ᶶ";
+*ຜ옥ㄏ::ISA = *ฟ옥ʮ::ISA;
+@ฟ옥ʮ::ISA = "Ｂᐊㄗ";
+
+ok 'ฟ옥ʮ'->isa("Ｂᐊㄗ"),
+ 'isa after another stash has claimed the @ISA via glob assignment';
+ok 'ຜ옥ㄏ'->isa("Ｂᐊㄗ"),
+ 'isa on the stash that claimed the @ISA via glob assignment';
+ok !ฟ옥ʮ->isa("ᶶ"),
+ '!isa when another stash has claimed the @ISA via glob assignment';
+ok !ຜ옥ㄏ->isa("ᶶ"),
+ '!isa on the stash that claimed the @ISA via glob assignment';
+
+@ฟ옥ʮ::ISA = "ᶶ";
+*ฟ옥ʮ::ISA = ["Ｂᐊㄗ"];
+
+ok 'ฟ옥ʮ'->isa("Ｂᐊㄗ"),
+ 'isa after glob-to-ref assignment when *ISA is shared';
+ok 'ຜ옥ㄏ'->isa("Ｂᐊㄗ"),
+ 'isa after glob-to-ref assignment on another stash when *ISA is shared';
+ok !ฟ옥ʮ->isa("ᶶ"),
+ '!isa after glob-to-ref assignment when *ISA is shared';
+ok !ຜ옥ㄏ->isa("ᶶ"),
+ '!isa after glob-to-ref assignment on another stash when *ISA is shared';
+
+@ᕘ::ISA = "ᶶ";
+*ጶ::ISA = \@ᕘ::ISA;
+@ᕘ::ISA = "Ｂᐊㄗ";
+
+ok 'ᕘ'->isa("Ｂᐊㄗ"),
+ 'isa after another stash has claimed the @ISA via ref-to-glob assignment';
+ok 'ጶ'->isa("Ｂᐊㄗ"),
+ 'isa on the stash that claimed the @ISA via ref-to-glob assignment';
+ok !ᕘ->isa("ᶶ"),
+ '!isa when another stash has claimed the @ISA via ref-to-glob assignment';
+ok !ጶ->isa("ᶶ"),
+ '!isa on the stash that claimed the @ISA via ref-to-glob assignment';
Modified: trunk/contrib/perl/t/mro/isa_c3.t
===================================================================
--- trunk/contrib/perl/t/mro/isa_c3.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/mro/isa_c3.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -64,6 +64,6 @@
is("@{mro::get_linear_isa($package)}", "@$isa", "\@ISA for $package");
foreach my $class ($package, @$isa, 'UNIVERSAL') {
- isa_ok($ref, $class, $package);
+ object_ok($ref, $class, $package);
}
}
Property changes on: trunk/contrib/perl/t/mro/isa_c3.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/mro/isa_c3_utf8.t (from rev 6437, vendor/perl/5.18.1/t/mro/isa_c3_utf8.t)
===================================================================
--- trunk/contrib/perl/t/mro/isa_c3_utf8.t (rev 0)
+++ trunk/contrib/perl/t/mro/isa_c3_utf8.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,71 @@
+#!perl -w
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require "./test.pl";
+}
+
+use strict;
+use utf8;
+use open qw( :utf8 :std );
+
+plan 'no_plan';
+
+# package klonk doesn't have a stash.
+
+package 캎oẃ;
+use mro 'c3';
+
+# No parents
+
+package urḲḵｋ;
+use mro 'c3';
+
+# 1 parent
+ at urḲḵｋ::ISA = 'kഌoんḰ';
+
+package к;
+use mro 'c3';
+
+# 2 parents
+ at urḲḵｋ::ISA = ('kഌoんḰ', '캎oẃ');
+
+package ṭ화ckэ;
+use mro 'c3';
+
+# No parents, has @ISA
+@ṭ화ckэ::ISA = ();
+
+package Źzzzዟᑉ;
+use mro 'c3';
+
+@Źzzzዟᑉ::ISA = ('ṭ화ckэ', '캎oẃ');
+
+package Ẁ함Ｍ;
+use mro 'c3';
+
+@Ẁ함Ｍ::ISA = ('캎oẃ', 'ṭ화ckэ');
+
+package main;
+
+my %expect =
+ (
+ kഌoんḰ => [qw(kഌoんḰ)],
+ urḲḵｋ => [qw(urḲḵｋ kഌoんḰ 캎oẃ)],
+ 캎oẃ => [qw(캎oẃ)],
+ к => [qw(к)],
+ ṭ화ckэ => [qw(ṭ화ckэ)],
+ Źzzzዟᑉ => [qw(Źzzzዟᑉ ṭ화ckэ 캎oẃ)],
+ Ẁ함Ｍ => [qw(Ẁ함Ｍ 캎oẃ ṭ화ckэ)],
+ );
+
+foreach my $package (qw(kഌoんḰ urḲḵｋ 캎oẃ к ṭ화ckэ Źzzzዟᑉ Ẁ함Ｍ)) {
+ my $ref = bless [], $package;
+ my $isa = $expect{$package};
+ is("@{mro::get_linear_isa($package)}", "@$isa", "\@ISA for $package");
+
+ foreach my $class ($package, @$isa, 'UNIVERSAL') {
+ object_ok($ref, $class, $package);
+ }
+}
Modified: trunk/contrib/perl/t/mro/isa_dfs.t
===================================================================
--- trunk/contrib/perl/t/mro/isa_dfs.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/mro/isa_dfs.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -60,6 +60,6 @@
is("@{mro::get_linear_isa($package)}", "@$isa", "\@ISA for $package");
foreach my $class ($package, @$isa, 'UNIVERSAL') {
- isa_ok($ref, $class, $package);
+ object_ok($ref, $class, $package);
}
}
Property changes on: trunk/contrib/perl/t/mro/isa_dfs.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/mro/isa_dfs_utf8.t (from rev 6437, vendor/perl/5.18.1/t/mro/isa_dfs_utf8.t)
===================================================================
--- trunk/contrib/perl/t/mro/isa_dfs_utf8.t (rev 0)
+++ trunk/contrib/perl/t/mro/isa_dfs_utf8.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,67 @@
+#!perl -w
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require "./test.pl";
+}
+
+use strict;
+use utf8;
+use open qw( :utf8 :std );
+
+plan 'no_plan';
+
+# package klonk doesn't have a stash.
+
+package 캎oẃ;
+
+# No parents
+
+package urḲḵｋ;
+
+# 1 parent
+ at urḲḵｋ::ISA = 'kഌoんḰ';
+
+package к;
+
+# 2 parents
+ at urḲḵｋ::ISA = ('kഌoんḰ', '캎oẃ');
+
+package ṭ화ckэ;
+
+# No parents, has @ISA
+@ṭ화ckэ::ISA = ();
+
+package Źzzzዟᑉ;
+
+@Źzzzዟᑉ::ISA = ('ṭ화ckэ', '캎oẃ');
+
+package Ẁ함Ｍ;
+
+@Ẁ함Ｍ::ISA = ('캎oẃ', 'ṭ화ckэ');
+
+package main;
+
+require mro;
+
+my %expect =
+ (
+ kഌoんḰ => [qw(kഌoんḰ)],
+ urḲḵｋ => [qw(urḲḵｋ kഌoんḰ 캎oẃ)],
+ 캎oẃ => [qw(캎oẃ)],
+ к => [qw(к)],
+ ṭ화ckэ => [qw(ṭ화ckэ)],
+ Źzzzዟᑉ => [qw(Źzzzዟᑉ ṭ화ckэ 캎oẃ)],
+ Ẁ함Ｍ => [qw(Ẁ함Ｍ 캎oẃ ṭ화ckэ)],
+ );
+
+foreach my $package (qw(kഌoんḰ urḲḵｋ 캎oẃ к ṭ화ckэ Źzzzዟᑉ Ẁ함Ｍ)) {
+ my $ref = bless [], $package;
+ my $isa = $expect{$package};
+ is("@{mro::get_linear_isa($package)}", "@$isa", "\@ISA for $package");
+
+ foreach my $class ($package, @$isa, 'UNIVERSAL') {
+ object_ok($ref, $class, $package);
+ }
+}
Index: trunk/contrib/perl/t/mro/isarev.t
===================================================================
--- trunk/contrib/perl/t/mro/isarev.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/mro/isarev.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/mro/isarev.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/mro/isarev_utf8.t (from rev 6437, vendor/perl/5.18.1/t/mro/isarev_utf8.t)
===================================================================
(Binary files differ)
Modified: trunk/contrib/perl/t/mro/method_caching.t
===================================================================
--- trunk/contrib/perl/t/mro/method_caching.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/mro/method_caching.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,6 +1,7 @@
#!./perl
use strict;
+no strict 'refs'; # we do a lot of this
use warnings;
no warnings 'redefine'; # we do a lot of this
no warnings 'prototype'; # we do a lot of this
@@ -10,10 +11,9 @@
chdir 't' if -d 't';
@INC = '../lib';
}
+ require './test.pl';
}
-require './test.pl';
-
{
package MCTest::Base;
sub foo { return $_[1]+1 };
@@ -35,6 +35,15 @@
sub { is(MCTest::Derived->foo(0), 5); },
sub { sub FFF { $_[1]+7 }; local *MCTest::Base::foo = *FFF; is(MCTest::Derived->foo(0), 7); },
sub { is(MCTest::Derived->foo(0), 5); },
+ sub { { local *MCTest::Base::can = sub { "tomatoes" };
+ MCTest::Derived->can(0); }
+ is(MCTest::Derived->can("isa"), \&UNIVERSAL::isa,
+ 'removing method when unwinding local *method=sub{}'); },
+ sub { sub peas { "peas" }
+ { local *MCTest::Base::can = *peas;
+ MCTest::Derived->can(0); }
+ is(MCTest::Derived->can("isa"), \&UNIVERSAL::isa,
+ 'removing method when unwinding local *method=*other'); },
sub { sub DDD { $_[1]+8 }; *MCTest::Base::foo = *DDD; is(MCTest::Derived->foo(0), 8); },
sub { *ASDF::asdf = sub { $_[1]+9 }; *MCTest::Base::foo = \&ASDF::asdf; is(MCTest::Derived->foo(0), 9); },
sub { undef *MCTest::Base::foo; eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); },
@@ -57,6 +66,39 @@
sub { *{MCTest::Base::} = *{Foo::}; eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); },
sub { *MCTest::Derived::foo = \&MCTest::Base::foo; eval { MCTest::Derived::foo(0,0) }; ok(!$@); undef *MCTest::Derived::foo },
sub { eval 'package MCTest::Base; sub foo { $_[1]+18 }'; is(MCTest::Derived->foo(0), 18); },
+
+ # Redefining through a glob alias
+ sub { *A = *{'MCTest::Base::foo'}; eval 'sub A { $_[1]+19 }';
+ is(MCTest::Derived->foo(0), 19,
+ 'redefining sub through glob alias via decl'); },
+ sub { SKIP: {
+ skip_if_miniperl("no XS");
+ eval { require XS::APItest; }
+ or skip "XS::APItest not available", 1;
+ *A = *{'MCTest::Base::foo'};
+ XS::APItest::newCONSTSUB(\%main::, "A", 0, 20);
+ is (MCTest::Derived->foo(0), 20,
+ 'redefining sub through glob alias via newXS');
+ } },
+ sub { undef *{'MCTest::Base::foo'}; *A = *{'MCTest::Base::foo'};
+ eval { no warnings 'once'; local *UNIVERSAL::foo = sub {96};
+ MCTest::Derived->foo };
+ ()=\&A;
+ eval { MCTest::Derived->foo };
+ like($@, qr/Undefined subroutine/,
+ 'redefining sub through glob alias via stub vivification'); },
+ sub { *A = *{'MCTest::Base::foo'};
+ local *A = sub { 21 };
+ is(MCTest::Derived->foo, 21,
+ 'redef sub through glob alias via local cv-to-glob assign'); },
+ sub { *A = *{'MCTest::Base::foo'};
+ eval 'sub MCTest::Base::foo { 22 }';
+ { local *A = sub { 23 }; MCTest::Derived->foo }
+ is(MCTest::Derived->foo, 22,
+ 'redef sub through glob alias via localisation unwinding'); },
+ sub { *A = *{'MCTest::Base::foo'}; *A = sub { 24 };
+ is(MCTest::Derived->foo(0), 24,
+ 'redefining sub through glob alias via cv-to-glob assign'); },
);
plan(tests => scalar(@testsubs));
Property changes on: trunk/contrib/perl/t/mro/method_caching.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/mro/method_caching_utf8.t (from rev 6437, vendor/perl/5.18.1/t/mro/method_caching_utf8.t)
===================================================================
(Binary files differ)
Index: trunk/contrib/perl/t/mro/next_NEXT.t
===================================================================
--- trunk/contrib/perl/t/mro/next_NEXT.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/mro/next_NEXT.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/mro/next_NEXT.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/mro/next_NEXT_utf8.t (from rev 6437, vendor/perl/5.18.1/t/mro/next_NEXT_utf8.t)
===================================================================
--- trunk/contrib/perl/t/mro/next_NEXT_utf8.t (rev 0)
+++ trunk/contrib/perl/t/mro/next_NEXT_utf8.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,50 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use NEXT;
+use utf8;
+use open qw( :utf8 :std );
+
+require './test.pl';
+plan(tests => 4);
+
+{
+ package ᕘ;
+ use strict;
+ use warnings;
+ use mro 'c3';
+
+ sub fಓ { 'ᕘ::fಓ' }
+
+ package Fᶽ;
+ use strict;
+ use warnings;
+ use mro 'c3';
+ use base 'ᕘ';
+
+ sub fಓ { 'Fᶽ::fಓ => ' . (shift)->next::method }
+
+ package Bᛆ;
+ use strict;
+ use warnings;
+ use mro 'c3';
+ use base 'ᕘ';
+
+ sub fಓ { 'Bᛆ::fಓ => ' . (shift)->next::method }
+
+ package Baᕃ;
+ use strict;
+ use warnings;
+
+ use base 'Bᛆ', 'Fᶽ';
+
+ sub fಓ { 'Baᕃ::fಓ => ' . (shift)->NEXT::fಓ }
+}
+
+is(ᕘ->fಓ, 'ᕘ::fಓ', '... got the right value from ᕘ->fಓ');
+is(Fᶽ->fಓ, 'Fᶽ::fಓ => ᕘ::fಓ', '... got the right value from Fᶽ->fಓ');
+is(Bᛆ->fಓ, 'Bᛆ::fಓ => ᕘ::fಓ', '... got the right value from Bᛆ->fಓ');
+
+is(Baᕃ->fಓ, 'Baᕃ::fಓ => Bᛆ::fಓ => Fᶽ::fಓ => ᕘ::fಓ', '... got the right value using NEXT in a subclass of a C3 class');
+
Modified: trunk/contrib/perl/t/mro/next_edgecases.t
===================================================================
--- trunk/contrib/perl/t/mro/next_edgecases.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/mro/next_edgecases.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -21,7 +21,7 @@
# call the submethod in the direct instance
my $foo = Foo->new();
- isa_ok($foo, 'Foo');
+ object_ok($foo, 'Foo');
can_ok($foo, 'bar');
is($foo->bar(), 'Foo::bar', '... got the right return value');
@@ -37,8 +37,8 @@
}
my $bar = Bar->new();
- isa_ok($bar, 'Bar');
- isa_ok($bar, 'Foo');
+ object_ok($bar, 'Bar');
+ object_ok($bar, 'Foo');
# test it working with with Sub::Name
SKIP: {
@@ -68,8 +68,8 @@
}
my $baz = Baz->new();
- isa_ok($baz, 'Baz');
- isa_ok($baz, 'Foo');
+ object_ok($baz, 'Baz');
+ object_ok($baz, 'Foo');
{
my $m = sub { (shift)->next::method() };
Property changes on: trunk/contrib/perl/t/mro/next_edgecases.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Copied: trunk/contrib/perl/t/mro/next_edgecases_utf8.t (from rev 6437, vendor/perl/5.18.1/t/mro/next_edgecases_utf8.t)
===================================================================
--- trunk/contrib/perl/t/mro/next_edgecases_utf8.t (rev 0)
+++ trunk/contrib/perl/t/mro/next_edgecases_utf8.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,98 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+BEGIN { chdir 't'; require q(./test.pl); @INC = qw "../lib lib" }
+
+use utf8;
+use open qw( :utf8 :std );
+
+plan(tests => 12);
+
+{
+
+ {
+ package ᕘ;
+ use strict;
+ use warnings;
+ use mro 'c3';
+ sub new { bless {}, $_[0] }
+ sub ƚ { 'ᕘ::ƚ' }
+ }
+
+ # call the submethod in the direct instance
+
+ my $foo = ᕘ->new();
+ object_ok($foo, 'ᕘ');
+
+ can_ok($foo, 'ƚ');
+ is($foo->ƚ(), 'ᕘ::ƚ', '... got the right return value');
+
+ # fail calling it from a subclass
+
+ {
+ package Baɾ;
+ use strict;
+ use warnings;
+ use mro 'c3';
+ our @ISA = ('ᕘ');
+ }
+
+ my $bar = Baɾ->new();
+ object_ok($bar, 'Baɾ');
+ object_ok($bar, 'ᕘ');
+
+ # test it working with with Sub::Name
+ SKIP: {
+ eval 'use Sub::Name';
+ skip("Sub::Name is required for this test", 3) if $@;
+
+ my $m = sub { (shift)->next::method() };
+ Sub::Name::subname('Baɾ::ƚ', $m);
+ {
+ no strict 'refs';
+ *{'Baɾ::ƚ'} = $m;
+ }
+
+ can_ok($bar, 'ƚ');
+ my $value = eval { $bar->ƚ() };
+ ok(!$@, '... calling ƚ() succeeded') || diag $@;
+ is($value, 'ᕘ::ƚ', '... got the right return value too');
+ }
+
+ # test it failing without Sub::Name
+ {
+ package બʑ;
+ use strict;
+ use warnings;
+ use mro 'c3';
+ our @ISA = ('ᕘ');
+ }
+
+ my $baz = બʑ->new();
+ object_ok($baz, 'બʑ');
+ object_ok($baz, 'ᕘ');
+
+ {
+ my $m = sub { (shift)->next::method() };
+ {
+ no strict 'refs';
+ *{'બʑ::ƚ'} = $m;
+ }
+
+ eval { $baz->ƚ() };
+ ok($@, '... calling ƚ() with next::method failed') || diag $@;
+ }
+
+ # Test with non-existing class (used to segfault)
+ {
+ package Qűx;
+ use mro;
+ sub fਓ { No::Such::Class->next::can }
+ }
+
+ eval { Qűx->fਓ() };
+ is($@, '', "->next::can on non-existing package name");
+
+}
Index: trunk/contrib/perl/t/mro/next_goto.t
===================================================================
--- trunk/contrib/perl/t/mro/next_goto.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/mro/next_goto.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/mro/next_goto.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/mro/next_goto_utf8.t (from rev 6437, vendor/perl/5.18.1/t/mro/next_goto_utf8.t)
===================================================================
--- trunk/contrib/perl/t/mro/next_goto_utf8.t (rev 0)
+++ trunk/contrib/perl/t/mro/next_goto_utf8.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,36 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+require q(./test.pl); plan(tests => 4);
+
+use mro;
+
+{
+ package PṞoxᚤ;
+ our @ISA = qw//;
+ sub next_prxᔬ { goto &next::method }
+ sub maybe_prxᔬ { goto &maybe::next::method }
+ sub can_prxᔬ { goto &next::can }
+
+ package Ⱦ밧ᶟ;
+ our @ISA = qw//;
+ sub ᕗ { 42 }
+ sub Ƚ { 24 }
+ # বẔ doesn't exist intentionally
+ sub ʠঊₓ { 242 }
+
+ package ᵗ톺;
+ our @ISA = qw/Ⱦ밧ᶟ/;
+ sub ᕗ { shift->PṞoxᚤ::next_prxᔬ() }
+ sub Ƚ { shift->PṞoxᚤ::maybe_prxᔬ() }
+ sub বẔ { shift->PṞoxᚤ::maybe_prxᔬ() }
+ sub ʠঊₓ { shift->PṞoxᚤ::can_prxᔬ()->() }
+}
+
+is(ᵗ톺->ᕗ, 42, 'proxy next::method via goto');
+is(ᵗ톺->Ƚ, 24, 'proxy maybe::next::method via goto');
+ok(!ᵗ톺->বẔ, 'proxy maybe::next::method via goto with no method');
+is(ᵗ톺->ʠঊₓ, 242, 'proxy next::can via goto');
Index: trunk/contrib/perl/t/mro/next_inanon.t
===================================================================
--- trunk/contrib/perl/t/mro/next_inanon.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/mro/next_inanon.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/mro/next_inanon.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/mro/next_inanon_utf8.t (from rev 6437, vendor/perl/5.18.1/t/mro/next_inanon_utf8.t)
===================================================================
--- trunk/contrib/perl/t/mro/next_inanon_utf8.t (rev 0)
+++ trunk/contrib/perl/t/mro/next_inanon_utf8.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,58 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+require q(./test.pl); plan(tests => 2);
+
+=pod
+
+This tests the successful handling of a next::method call from within an
+anonymous subroutine.
+
+=cut
+
+{
+ package ㅏ;
+ use mro 'c3';
+
+ sub ᕘ {
+ return 'ㅏ::ᕘ';
+ }
+
+ sub Ḃᛆ {
+ return 'ㅏ::Ḃᛆ';
+ }
+}
+
+{
+ package Ḃ;
+ use base 'ㅏ';
+ use mro 'c3';
+
+ sub ᕘ {
+ my $code = sub {
+ return 'Ḃ::ᕘ => ' . (shift)->next::method();
+ };
+ return (shift)->$code;
+ }
+
+ sub Ḃᛆ {
+ my $code1 = sub {
+ my $code2 = sub {
+ return 'Ḃ::Ḃᛆ => ' . (shift)->next::method();
+ };
+ return (shift)->$code2;
+ };
+ return (shift)->$code1;
+ }
+}
+
+is(Ḃ->ᕘ, "Ḃ::ᕘ => ㅏ::ᕘ",
+ 'method resolved inside anonymous sub');
+
+is(Ḃ->Ḃᛆ, "Ḃ::Ḃᛆ => ㅏ::Ḃᛆ",
+ 'method resolved inside nested anonymous subs');
+
+
Index: trunk/contrib/perl/t/mro/next_ineval.t
===================================================================
--- trunk/contrib/perl/t/mro/next_ineval.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/mro/next_ineval.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/mro/next_ineval.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/mro/next_ineval_utf8.t (from rev 6437, vendor/perl/5.18.1/t/mro/next_ineval_utf8.t)
===================================================================
--- trunk/contrib/perl/t/mro/next_ineval_utf8.t (rev 0)
+++ trunk/contrib/perl/t/mro/next_ineval_utf8.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,46 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+
+require q(./test.pl); plan(tests => 1);
+
+=pod
+
+This tests the use of an eval{} block to wrap a next::method call.
+
+=cut
+
+{
+ package అ;
+ use mro 'c3';
+
+ sub ຟǫ {
+ die 'అ::ຟǫ died';
+ return 'అ::ຟǫ succeeded';
+ }
+}
+
+{
+ package ｂ;
+ use base 'అ';
+ use mro 'c3';
+
+ sub ຟǫ {
+ eval {
+ return 'ｂ::ຟǫ => ' . (shift)->next::method();
+ };
+
+ if ($@) {
+ return $@;
+ }
+ }
+}
+
+like(ｂ->ຟǫ,
+ qr/^అ::ຟǫ died/u,
+ 'method resolved inside eval{}');
+
+
Index: trunk/contrib/perl/t/mro/next_method.t
===================================================================
--- trunk/contrib/perl/t/mro/next_method.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/mro/next_method.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/mro/next_method.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/t/mro/next_method_utf8.t (from rev 6437, vendor/perl/5.18.1/t/mro/next_method_utf8.t)
===================================================================
--- trunk/contrib/perl/t/mro/next_method_utf8.t (rev 0)
+++ trunk/contrib/perl/t/mro/next_method_utf8.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,67 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+
+require q(./test.pl); plan(tests => 5);
+
+=pod
+
+This tests the classic diamond inheritance pattern.
+
+ <A>
+ / \
+<B> <C>
+ \ /
+ <D>
+
+=cut
+
+{
+ package Diӑmond_A;
+ use mro 'c3';
+ sub 헬ฬ { 'Diӑmond_A::헬ฬ' }
+ sub fಓ { 'Diӑmond_A::fಓ' }
+}
+{
+ package Diӑmond_B;
+ use base 'Diӑmond_A';
+ use mro 'c3';
+ sub fಓ { 'Diӑmond_B::fಓ => ' . (shift)->next::method() }
+}
+{
+ package Diӑmond_C;
+ use mro 'c3';
+ use base 'Diӑmond_A';
+
+ sub 헬ฬ { 'Diӑmond_C::헬ฬ => ' . (shift)->next::method() }
+ sub fಓ { 'Diӑmond_C::fಓ => ' . (shift)->next::method() }
+}
+{
+ package Diӑmond_D;
+ use base ('Diӑmond_B', 'Diӑmond_C');
+ use mro 'c3';
+
+ sub fಓ { 'Diӑmond_D::fಓ => ' . (shift)->next::method() }
+}
+
+ok(eq_array(
+ mro::get_linear_isa('Diӑmond_D'),
+ [ qw(Diӑmond_D Diӑmond_B Diӑmond_C Diӑmond_A) ]
+), '... got the right MRO for Diӑmond_D');
+
+is(Diӑmond_D->헬ฬ, 'Diӑmond_C::헬ฬ => Diӑmond_A::헬ฬ', '... method resolved itself as expected');
+
+is(Diӑmond_D->can('헬ฬ')->('Diӑmond_D'),
+ 'Diӑmond_C::헬ฬ => Diӑmond_A::헬ฬ',
+ '... can(method) resolved itself as expected');
+
+is(UNIVERSAL::can("Diӑmond_D", '헬ฬ')->('Diӑmond_D'),
+ 'Diӑmond_C::헬ฬ => Diӑmond_A::헬ฬ',
+ '... can(method) resolved itself as expected');
+
+is(Diӑmond_D->fಓ,
+ 'Diӑmond_D::fಓ => Diӑmond_B::fಓ => Diӑmond_C::fಓ => Diӑmond_A::fಓ',
+ '... method fಓ resolved itself as expected');
Index: trunk/contrib/perl/t/mro/next_skip.t
===================================================================
--- trunk/contrib/perl/t/mro/next_skip.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/mro/next_skip.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/mro/next_skip.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/t/mro/next_skip_utf8.t (from rev 6437, vendor/perl/5.18.1/t/mro/next_skip_utf8.t)
===================================================================
--- trunk/contrib/perl/t/mro/next_skip_utf8.t (rev 0)
+++ trunk/contrib/perl/t/mro/next_skip_utf8.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,77 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+require q(./test.pl); plan(tests => 10);
+
+use utf8;
+use open qw( :utf8 :std );
+
+=pod
+
+This tests the classic diamond inheritance pattern.
+
+ <A>
+ / \
+<B> <C>
+ \ /
+ <D>
+
+=cut
+
+{
+ package Ｄiᚪၚd_A;
+ use mro 'c3';
+ sub ᴮaȐ { 'Ｄiᚪၚd_A::ᴮaȐ' }
+ sub 바ź { 'Ｄiᚪၚd_A::바ź' }
+}
+{
+ package Ｄiᚪၚd_B;
+ use base 'Ｄiᚪၚd_A';
+ use mro 'c3';
+ sub 바ź { 'Ｄiᚪၚd_B::바ź => ' . (shift)->next::method() }
+}
+{
+ package Ｄiᚪၚd_C;
+ use mro 'c3';
+ use base 'Ｄiᚪၚd_A';
+ sub ᕘ { 'Ｄiᚪၚd_C::ᕘ' }
+ sub buƵ { 'Ｄiᚪၚd_C::buƵ' }
+
+ sub woｚ { 'Ｄiᚪၚd_C::woｚ' }
+ sub maᐇbʚ { 'Ｄiᚪၚd_C::maᐇbʚ' }
+}
+{
+ package Ｄiᚪၚd_D;
+ use base ('Ｄiᚪၚd_B', 'Ｄiᚪၚd_C');
+ use mro 'c3';
+ sub ᕘ { 'Ｄiᚪၚd_D::ᕘ => ' . (shift)->next::method() }
+ sub ᴮaȐ { 'Ｄiᚪၚd_D::ᴮaȐ => ' . (shift)->next::method() }
+ sub buƵ { 'Ｄiᚪၚd_D::buƵ => ' . (shift)->바ź() }
+ sub fuz { 'Ｄiᚪၚd_D::fuz => ' . (shift)->next::method() }
+
+ sub woｚ { 'Ｄiᚪၚd_D::woｚ can => ' . ((shift)->next::can() ? 1 : 0) }
+ sub noz { 'Ｄiᚪၚd_D::noz can => ' . ((shift)->next::can() ? 1 : 0) }
+
+ sub maᐇbʚ { 'Ｄiᚪၚd_D::maᐇbʚ => ' . ((shift)->maybe::next::method() || 0) }
+ sub ᒧyベ { 'Ｄiᚪၚd_D::ᒧyベ => ' . ((shift)->maybe::next::method() || 0) }
+
+}
+
+ok(eq_array(
+ mro::get_linear_isa('Ｄiᚪၚd_D'),
+ [ qw(Ｄiᚪၚd_D Ｄiᚪၚd_B Ｄiᚪၚd_C Ｄiᚪၚd_A) ]
+), '... got the right MRO for Ｄiᚪၚd_D');
+
+is(Ｄiᚪၚd_D->ᕘ, 'Ｄiᚪၚd_D::ᕘ => Ｄiᚪၚd_C::ᕘ', '... skipped B and went to C correctly');
+is(Ｄiᚪၚd_D->ᴮaȐ, 'Ｄiᚪၚd_D::ᴮaȐ => Ｄiᚪၚd_A::ᴮaȐ', '... skipped B & C and went to A correctly');
+is(Ｄiᚪၚd_D->바ź, 'Ｄiᚪၚd_B::바ź => Ｄiᚪၚd_A::바ź', '... called B method, skipped C and went to A correctly');
+is(Ｄiᚪၚd_D->buƵ, 'Ｄiᚪၚd_D::buƵ => Ｄiᚪၚd_B::바ź => Ｄiᚪၚd_A::바ź', '... called D method dispatched to , different method correctly');
+eval { Ｄiᚪၚd_D->fuz };
+like($@, qr/^No next::method 'fuz' found for Ｄiᚪၚd_D/u, '... cannot re-dispatch to a method which is not there');
+is(Ｄiᚪၚd_D->woｚ, 'Ｄiᚪၚd_D::woｚ can => 1', '... can re-dispatch figured out correctly');
+is(Ｄiᚪၚd_D->noz, 'Ｄiᚪၚd_D::noz can => 0', '... cannot re-dispatch figured out correctly');
+
+is(Ｄiᚪၚd_D->maᐇbʚ, 'Ｄiᚪၚd_D::maᐇbʚ => Ｄiᚪၚd_C::maᐇbʚ', '... redispatched D to C when it exists');
+is(Ｄiᚪၚd_D->ᒧyベ, 'Ｄiᚪၚd_D::ᒧyベ => 0', '... quietly failed redispatch from D');
Modified: trunk/contrib/perl/t/mro/overload_c3.t
===================================================================
--- trunk/contrib/perl/t/mro/overload_c3.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/mro/overload_c3.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -35,10 +35,10 @@
}
my $x = InheritingFromOverloadedTest->new();
-isa_ok($x, 'InheritingFromOverloadedTest');
+object_ok($x, 'InheritingFromOverloadedTest');
my $y = OverloadingTest->new();
-isa_ok($y, 'OverloadingTest');
+object_ok($y, 'OverloadingTest');
is("$x", 'InheritingFromOverloadedTest stringified', '... got the right value when stringifing');
is("$y", 'OverloadingTest stringified', '... got the right value when stringifing');
Property changes on: trunk/contrib/perl/t/mro/overload_c3.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/mro/overload_c3_utf8.t (from rev 6437, vendor/perl/5.18.1/t/mro/overload_c3_utf8.t)
===================================================================
--- trunk/contrib/perl/t/mro/overload_c3_utf8.t (rev 0)
+++ trunk/contrib/perl/t/mro/overload_c3_utf8.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,57 @@
+#!./perl
+
+use strict;
+use warnings;
+BEGIN {
+ unless (-d 'blib') {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+}
+
+use utf8;
+use open qw( :utf8 :std );
+
+require q(./test.pl); plan(tests => 7);
+
+{
+ package 밧e텟ʇ;
+ use strict;
+ use warnings;
+ use mro 'c3';
+
+ package Ov에rꪩࡃᛝＴeŝṱ;
+ use strict;
+ use warnings;
+ use mro 'c3';
+ use base '밧e텟ʇ';
+ use overload '""' => sub { ref(shift) . " stringified" },
+ fallback => 1;
+
+ sub ネᚹ { bless {} => shift }
+
+ package 읺ҎꀀḮṆᵷꜰ롬ᵕveŔŁoad엗텟ᵵ;
+ use strict;
+ use warnings;
+ use base 'Ov에rꪩࡃᛝＴeŝṱ';
+ use mro 'c3';
+}
+
+my $x = 읺ҎꀀḮṆᵷꜰ롬ᵕveŔŁoad엗텟ᵵ->ネᚹ();
+object_ok($x, '읺ҎꀀḮṆᵷꜰ롬ᵕveŔŁoad엗텟ᵵ');
+
+my $y = Ov에rꪩࡃᛝＴeŝṱ->ネᚹ();
+object_ok($y, 'Ov에rꪩࡃᛝＴeŝṱ');
+
+is("$x", '읺ҎꀀḮṆᵷꜰ롬ᵕveŔŁoad엗텟ᵵ stringified', '... got the right value when stringifing');
+is("$y", 'Ov에rꪩࡃᛝＴeŝṱ stringified', '... got the right value when stringifing');
+
+ok(($y eq 'Ov에rꪩࡃᛝＴeŝṱ stringified'), '... eq was handled correctly');
+
+my $result;
+eval {
+ $result = $x eq '읺ҎꀀḮṆᵷꜰ롬ᵕveŔŁoad엗텟ᵵ stringified'
+};
+ok(!$@, '... this should not throw an exception');
+ok($result, '... and we should get the true value');
+
Modified: trunk/contrib/perl/t/mro/overload_dfs.t
===================================================================
--- trunk/contrib/perl/t/mro/overload_dfs.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/mro/overload_dfs.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -35,10 +35,10 @@
}
my $x = InheritingFromOverloadedTest->new();
-isa_ok($x, 'InheritingFromOverloadedTest');
+object_ok($x, 'InheritingFromOverloadedTest');
my $y = OverloadingTest->new();
-isa_ok($y, 'OverloadingTest');
+object_ok($y, 'OverloadingTest');
is("$x", 'InheritingFromOverloadedTest stringified', '... got the right value when stringifing');
is("$y", 'OverloadingTest stringified', '... got the right value when stringifing');
Property changes on: trunk/contrib/perl/t/mro/overload_dfs.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/mro/package_aliases.t
===================================================================
--- trunk/contrib/perl/t/mro/package_aliases.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/mro/package_aliases.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -10,7 +10,7 @@
use strict;
use warnings;
-plan(tests => 52);
+plan(tests => 53);
{
package New;
@@ -30,8 +30,8 @@
ok (Old->isa (New::), 'Old inherits from New');
ok (New->isa (Old::), 'New inherits from Old');
-isa_ok (bless ({}, Old::), New::, 'Old object');
-isa_ok (bless ({}, New::), Old::, 'New object');
+object_ok (bless ({}, Old::), New::, 'Old object');
+object_ok (bless ({}, New::), Old::, 'New object');
# Test that replacing a package by assigning to an existing glob
@@ -399,4 +399,12 @@
'isa(foo) when inheriting from "class:" after string-to-glob assignment';
}
-
+ at Bazo::ISA = "Fooo::bar";
+sub Fooo::bar::ber { 'baz' }
+sub UNIVERSAL::ber { "black sheep" }
+Bazo->ber;
+local *Fooo:: = \%Baro::;
+{
+ no warnings;
+ is 'Bazo'->ber, 'black sheep', 'localised *glob=$stashref assignment';
+}
Property changes on: trunk/contrib/perl/t/mro/package_aliases.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/t/mro/package_aliases_utf8.t (from rev 6437, vendor/perl/5.18.1/t/mro/package_aliases_utf8.t)
===================================================================
--- trunk/contrib/perl/t/mro/package_aliases_utf8.t (rev 0)
+++ trunk/contrib/perl/t/mro/package_aliases_utf8.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,469 @@
+#!./perl
+
+BEGIN {
+ $ENV{PERL_UNICODE} = 0;
+ unless (-d 'blib') {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ require q(./test.pl);
+}
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+
+plan(tests => 52);
+
+{
+ package Ｎeẁ;
+ use strict;
+ use warnings;
+
+ package ऑlㄉ;
+ use strict;
+ use warnings;
+
+ {
+ no strict 'refs';
+ *{'ऑlㄉ::'} = *{'Ｎeẁ::'};
+ }
+}
+
+ok (ऑlㄉ->isa(Ｎeẁ::), 'ऑlㄉ inherits from Ｎeẁ');
+ok (Ｎeẁ->isa(ऑlㄉ::), 'Ｎeẁ inherits from ऑlㄉ');
+
+object_ok (bless ({}, ऑlㄉ::), Ｎeẁ::, 'ऑlㄉ object');
+object_ok (bless ({}, Ｎeẁ::), ऑlㄉ::, 'Ｎeẁ object');
+
+
+# Test that replacing a package by assigning to an existing glob
+# invalidates the isa caches
+for(
+ {
+ name => 'assigning a glob to a glob',
+ code => '$life_raft = $::{"ｌㅔf::"}; *ｌㅔf:: = $::{"릭Ⱶᵀ::"}',
+ },
+ {
+ name => 'assigning a string to a glob',
+ code => '$life_raft = $::{"ｌㅔf::"}; *ｌㅔf:: = "릭Ⱶᵀ::"',
+ },
+ {
+ name => 'assigning a stashref to a glob',
+ code => '$life_raft = \%ｌㅔf::; *ｌㅔf:: = \%릭Ⱶᵀ::',
+ },
+) {
+my $prog = q~
+ BEGIN {
+ unless (-d 'blib') {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ }
+ use utf8;
+ use open qw( :utf8 :std );
+
+ @숩cਲꩋ::ISA = "ｌㅔf";
+ @ｌㅔf::ISA = "톺ĺФț";
+
+ sub 톺ĺФț::Ｓᑊeಅḱ { "Woof!" }
+ sub ᴖ릭ᚽʇ::Ｓᑊeಅḱ { "Bow-wow!" }
+
+ my $thing = bless [], "숩cਲꩋ";
+
+ # mro_package_moved needs to know to skip non-globs
+ $릭Ⱶᵀ::{"ᚷꝆエcƙ::"} = 3;
+
+ @릭Ⱶᵀ::ISA = 'ᴖ릭ᚽʇ';
+ my $life_raft;
+ __code__;
+
+ print $thing->Ｓᑊeಅḱ, "\n";
+
+ undef $life_raft;
+ print $thing->Ｓᑊeಅḱ, "\n";
+ ~ =~ s\__code__\$$_{code}\r; #\
+utf8::encode($prog);
+ fresh_perl_is
+ $prog,
+ "Bow-wow!\nBow-wow!\n",
+ {},
+ "replacing packages by $$_{name} updates isa caches";
+}
+
+# Similar test, but with nested packages
+#
+# 톺ĺФț (Woof) ᴖ릭ᚽʇ (Bow-wow)
+# | |
+# ｌㅔf::Side <- 릭Ⱶᵀ::Side
+# |
+# 숩cਲꩋ
+#
+# This test assigns 릭Ⱶᵀ:: to ｌㅔf::, indirectly making ｌㅔf::Side an
+# alias to 릭Ⱶᵀ::Side (following the arrow in the diagram).
+for(
+ {
+ name => 'assigning a glob to a glob',
+ code => '$life_raft = $::{"ｌㅔf::"}; *ｌㅔf:: = $::{"릭Ⱶᵀ::"}',
+ },
+ {
+ name => 'assigning a string to a glob',
+ code => '$life_raft = $::{"ｌㅔf::"}; *ｌㅔf:: = "릭Ⱶᵀ::"',
+ },
+ {
+ name => 'assigning a stashref to a glob',
+ code => '$life_raft = \%ｌㅔf::; *ｌㅔf:: = \%릭Ⱶᵀ::',
+ },
+) {
+ my $prog = q~
+ BEGIN {
+ unless (-d 'blib') {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ }
+ use utf8;
+ use open qw( :utf8 :std );
+ @숩cਲꩋ::ISA = "ｌㅔf::Side";
+ @ｌㅔf::Side::ISA = "톺ĺФț";
+
+ sub 톺ĺФț::Ｓᑊeಅḱ { "Woof!" }
+ sub ᴖ릭ᚽʇ::Ｓᑊeಅḱ { "Bow-wow!" }
+
+ my $thing = bless [], "숩cਲꩋ";
+
+ @릭Ⱶᵀ::Side::ISA = 'ᴖ릭ᚽʇ';
+ my $life_raft;
+ __code__;
+
+ print $thing->Ｓᑊeಅḱ, "\n";
+
+ undef $life_raft;
+ print $thing->Ｓᑊeಅḱ, "\n";
+ ~ =~ s\__code__\$$_{code}\r;
+ utf8::encode($prog);
+
+ fresh_perl_is
+ $prog,
+ "Bow-wow!\nBow-wow!\n",
+ {},
+ "replacing nested packages by $$_{name} updates isa caches";
+}
+
+# Another nested package test, in which the isa cache needs to be reset on
+# the subclass of a package that does not exist.
+#
+# Parenthesized packages do not exist.
+#
+# ɵűʇㄦ::인ንʵ ( cฬnए::인ንʵ )
+# | |
+# Ｌфť R익hȚ
+#
+# ɵűʇㄦ -> cฬnए
+#
+# This test assigns ɵűʇㄦ:: to cฬnए::, making cฬnए::인ንʵ an alias to
+# ɵűʇㄦ::인ንʵ.
+#
+# Then we also run the test again, but without ɵűʇㄦ::인ንʵ
+for(
+ {
+ name => 'assigning a glob to a glob',
+ code => '*cฬnए:: = *ɵűʇㄦ::',
+ },
+ {
+ name => 'assigning a string to a glob',
+ code => '*cฬnए:: = "ɵűʇㄦ::"',
+ },
+ {
+ name => 'assigning a stashref to a glob',
+ code => '*cฬnए:: = \%ɵűʇㄦ::',
+ },
+) {
+ for my $tail ('인ንʵ', '인ንʵ::', '인ንʵ:::', '인ንʵ::::') {
+ my $prog = q~
+ BEGIN {
+ unless (-d 'blib') {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ }
+ use utf8;
+ use open qw( :utf8 :std );
+ use Encode ();
+
+ if (grep /\P{ASCII}/, @ARGV) {
+ @ARGV = map { Encode::decode("UTF-8", $_) } @ARGV;
+ }
+
+ my $tail = shift;
+ @Ｌфť::ISA = "ɵűʇㄦ::$tail";
+ @R익hȚ::ISA = "cฬnए::$tail";
+ bless [], "ɵűʇㄦ::$tail"; # autovivify the stash
+
+ __code__;
+
+ print "ok 1", "\n" if Ｌфť->isa("cฬnए::$tail");
+ print "ok 2", "\n" if R익hȚ->isa("ɵűʇㄦ::$tail");
+ print "ok 3", "\n" if R익hȚ->isa("cฬnए::$tail");
+ print "ok 4", "\n" if Ｌфť->isa("ɵűʇㄦ::$tail");
+ ~ =~ s\__code__\$$_{code}\r;
+ utf8::encode($prog);
+ fresh_perl_is
+ $prog,
+ "ok 1\nok 2\nok 3\nok 4\n",
+ { args => [$tail] },
+ "replacing nonexistent nested packages by $$_{name} updates isa caches"
+ ." ($tail)";
+
+ # Same test but with the subpackage autovivified after the assignment
+ $prog = q~
+ BEGIN {
+ unless (-d 'blib') {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ }
+ use utf8;
+ use open qw( :utf8 :std );
+ use Encode ();
+
+ if (grep /\P{ASCII}/, @ARGV) {
+ @ARGV = map { Encode::decode("UTF-8", $_) } @ARGV;
+ }
+
+ my $tail = shift;
+ @Ｌфť::ISA = "ɵűʇㄦ::$tail";
+ @R익hȚ::ISA = "cฬnए::$tail";
+
+ __code__;
+
+ bless [], "ɵűʇㄦ::$tail";
+
+ print "ok 1", "\n" if Ｌфť->isa("cฬnए::$tail");
+ print "ok 2", "\n" if R익hȚ->isa("ɵűʇㄦ::$tail");
+ print "ok 3", "\n" if R익hȚ->isa("cฬnए::$tail");
+ print "ok 4", "\n" if Ｌфť->isa("ɵűʇㄦ::$tail");
+ ~ =~ s\__code__\$$_{code}\r;
+ utf8::encode($prog);
+ fresh_perl_is
+ $prog,
+ "ok 1\nok 2\nok 3\nok 4\n",
+ { args => [$tail] },
+ "Giving nonexistent packages multiple effective names by $$_{name}"
+ . " ($tail)";
+ }
+}
+
+no warnings; # temporary; there seems to be a scoping bug, as this does not
+ # work when placed in the blocks below
+
+# Test that deleting stash elements containing
+# subpackages also invalidates the isa cache.
+# Maybe this does not belong in package_aliases.t, but it is closely
+# related to the tests immediately preceding.
+{
+ @ቹऋ::ISA = ("Cuȓ", "ฮﾝᛞ");
+ @Cuȓ::ISA = "Hyḹ앛Ҭテ";
+
+ sub Hyḹ앛Ҭテ::Ｓᑊeಅḱ { "Arff!" }
+ sub ฮﾝᛞ::Ｓᑊeಅḱ { "Woof!" }
+
+ my $pet = bless [], "ቹऋ";
+
+ my $life_raft = delete $::{'Cuȓ::'};
+
+ is $pet->Ｓᑊeಅḱ, 'Woof!',
+ 'deleting a stash from its parent stash invalidates the isa caches';
+
+ undef $life_raft;
+ is $pet->Ｓᑊeಅḱ, 'Woof!',
+ 'the deleted stash is gone completely when freed';
+}
+# Same thing, but with nested packages
+{
+ @펱ᑦ::ISA = ("Cuȓȓ::Cuȓȓ::Cuȓȓ", "ɥwn");
+ @Cuȓȓ::Cuȓȓ::Cuȓȓ::ISA = "lȺt랕ᚖ";
+
+ sub lȺt랕ᚖ::Ｓᑊeಅḱ { "Arff!" }
+ sub ɥwn::Ｓᑊeಅḱ { "Woof!" }
+
+ my $pet = bless [], "펱ᑦ";
+
+ my $life_raft = delete $::{'Cuȓȓ::'};
+
+ is $pet->Ｓᑊeಅḱ, 'Woof!',
+ 'deleting a stash from its parent stash resets caches of substashes';
+
+ undef $life_raft;
+ is $pet->Ｓᑊeಅḱ, 'Woof!',
+ 'the deleted substash is gone completely when freed';
+}
+
+# [perl #77358]
+my $prog = q~#!perl -w
+ BEGIN {
+ unless (-d 'blib') {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ }
+ use utf8;
+ use open qw( :utf8 :std );
+ @펱ᑦ::ISA = "T잌ዕ";
+ @T잌ዕ::ISA = "Bᛆヶṝ";
+
+ sub Bᛆヶṝ::Ｓᑊeಅḱ { print "Woof!\n" }
+ sub lȺt랕ᚖ::Ｓᑊeಅḱ { print "Bow-wow!\n" }
+
+ my $pet = bless [], "펱ᑦ";
+
+ $pet->Ｓᑊeಅḱ;
+
+ sub ດƓ::Ｓᑊeಅḱ { print "Hello.\n" } # strange ດƓ!
+ @ດƓ::ISA = 'lȺt랕ᚖ';
+ *T잌ዕ:: = delete $::{'ດƓ::'};
+
+ $pet->Ｓᑊeಅḱ;
+ ~;
+utf8::encode($prog);
+fresh_perl_is
+ $prog,
+ "Woof!\nHello.\n",
+ { stderr => 1 },
+ "Assigning a nameless package over one w/subclasses updates isa caches";
+
+# mro_package_moved needs to make a distinction between replaced and
+# assigned stashes when keeping track of what it has seen so far.
+no warnings; {
+ no strict 'refs';
+
+ sub ʉ::bᓗnǩ::bᓗnǩ::ພo { "bbb" }
+ sub ᵛeↄl움::ພo { "lasrevinu" }
+ @ݏ엗Ƚeᵬૐᵖ::ISA = qw 'ພo::bᓗnǩ::bᓗnǩ ᵛeↄl움';
+ *ພo::ବㄗ:: = *ʉ::bᓗnǩ::; # now ʉ::bᓗnǩ:: is on both sides
+ *ພo:: = *ʉ::; # here ʉ::bᓗnǩ:: is both deleted and added
+ *ʉ:: = *ቦᵕ::; # now it is only known as ພo::bᓗnǩ::
+
+ # At this point, before the bug was fixed, %ພo::bᓗnǩ::bᓗnǩ:: ended
+ # up with no effective name, allowing it to be deleted without updating
+ # its subclasses’ caches.
+
+ my $accum = '';
+
+ $accum .= 'ݏ엗Ƚeᵬૐᵖ'->ພo; # bbb
+ delete ${"ພo::bᓗnǩ::"}{"bᓗnǩ::"};
+ $accum .= 'ݏ엗Ƚeᵬૐᵖ'->ພo; # bbb (Oops!)
+ @ݏ엗Ƚeᵬૐᵖ::ISA = @ݏ엗Ƚeᵬૐᵖ::ISA;
+ $accum .= 'ݏ엗Ƚeᵬૐᵖ'->ພo; # lasrevinu
+
+ is $accum, 'bbblasrevinulasrevinu',
+ 'nested classes deleted & added simultaneously';
+}
+use warnings;
+
+# mro_package_moved needs to check for self-referential packages.
+# This broke Text::Template [perl #78362].
+watchdog 3;
+*ᕘ:: = \%::;
+*Aᶜme::Mῌ::Aᶜme:: = \*Aᶜme::; # indirect self-reference
+pass("mro_package_moved and self-referential packages");
+
+# Deleting a glob whose name does not indicate its location in the symbol
+# table but which nonetheless *is* in the symbol table.
+{
+ no strict refs=>;
+ no warnings;
+ @ოƐ::mഒrェ::ISA = "foᚒ";
+ sub foᚒ::ວmᑊ { "aoeaa" }
+ *ťວ:: = *ოƐ::;
+ delete $::{"ოƐ::"};
+ @C힐dᒡl았::ISA = 'ťວ::mഒrェ';
+ my $accum = 'C힐dᒡl았'->ວmᑊ . '-';
+ my $life_raft = delete ${"ťວ::"}{"mഒrェ::"};
+ $accum .= eval { 'C힐dᒡl았'->ວmᑊ } // '<undef>';
+ is $accum, 'aoeaa-<undef>',
+ 'Deleting globs whose loc in the symtab differs from gv_fullname'
+}
+
+# Pathological test for undeffing a stash that has an alias.
+*ᵍh엞:: = *ኔƞ::;
+@숩cਲꩋ::ISA = 'ᵍh엞';
+undef %ᵍh엞::;
+sub F렐ᛔ::ວmᑊ { "clumpren" }
+eval '
+ $ኔƞ::whatever++;
+ @ኔƞ::ISA = "F렐ᛔ";
+';
+is eval { '숩cਲꩋ'->ວmᑊ }, 'clumpren',
+ 'Changes to @ISA after undef via original name';
+undef %ᵍh엞::;
+eval '
+ $ᵍh엞::whatever++;
+ @ᵍh엞::ISA = "F렐ᛔ";
+';
+is eval { '숩cਲꩋ'->ວmᑊ }, 'clumpren',
+ 'Changes to @ISA after undef via alias';
+
+
+# Packages whose containing stashes have aliases must lose all names cor-
+# responding to that container when detached.
+{
+ {package śmᛅḙ::በɀ} # autovivify
+ *pḢ린ᚷ:: = *śmᛅḙ::; # śmᛅḙ::በɀ now also named pḢ린ᚷ::በɀ
+ *본:: = delete $śmᛅḙ::{"በɀ::"};
+ # In 5.13.7, it has now lost its śmᛅḙ::በɀ name (reverting to pḢ린ᚷ::በɀ
+ # as the effective name), and gained 본 as an alias.
+ # In 5.13.8, both śmᛅḙ::በɀ *and* pḢ린ᚷ::በɀ names are deleted.
+
+ # Make some methods
+ no strict 'refs';
+ *{"pḢ린ᚷ::በɀ::fฤmᛈ"} = sub { "hello" };
+ sub Ｆルmፕṟ::fฤmᛈ { "good bye" };
+
+ @ᵇるᣘ킨::ISA = qw "본 Ｆルmፕṟ"; # now wrongly inherits from pḢ린ᚷ::በɀ
+
+ is fฤmᛈ ᵇるᣘ킨, "good bye",
+ 'detached stashes lose all names corresponding to the containing stash';
+}
+
+# Crazy edge cases involving packages ending with a single :
+@촐oン::ISA = 'ᚖგ:'; # pun intended!
+bless [], "ᚖგ:"; # autovivify the stash
+ok "촐oン"->isa("ᚖგ:"), 'class isa "class:"';
+{ no strict 'refs'; *{"ᚖგ:::"} = *ᚖგ:: }
+ok "촐oン"->isa("ᚖგ"),
+ 'isa(ᕘ) when inheriting from "class:" which is an alias for ᕘ';
+{
+ no warnings;
+ # The next line of code is *not* normative. If the structure changes,
+ # this line needs to change, too.
+ my $ᕘ = delete $ᚖგ::{":"};
+ ok !촐oン->isa("ᚖგ"),
+ 'class that isa "class:" no longer isa ᕘ if "class:" has been deleted';
+}
+@촐oン::ISA = ':';
+bless [], ":";
+ok "촐oン"->isa(":"), 'class isa ":"';
+{ no strict 'refs'; *{":::"} = *ፑňṪu앝ȋ온:: }
+ok "촐oン"->isa("ፑňṪu앝ȋ온"),
+ 'isa(ᕘ) when inheriting from ":" which is an alias for ᕘ';
+@촐oン::ISA = 'ᚖგ:';
+bless [], "ᚖგ:";
+{
+ no strict 'refs';
+ my $life_raft = \%{"ᚖგ:::"};
+ *{"ᚖგ:::"} = \%ᚖგ::;
+ ok "촐oン"->isa("ᚖგ"),
+ 'isa(ᕘ) when inheriting from "class:" after hash-to-glob assignment';
+}
+@촐oン::ISA = 'ŏ:';
+bless [], "ŏ:";
+{
+ no strict 'refs';
+ my $life_raft = \%{"ŏ:::"};
+ *{"ŏ:::"} = "ᚖგ::";
+ ok "촐oン"->isa("ᚖგ"),
+ 'isa(ᕘ) when inheriting from "class:" after string-to-glob assignment';
+}
+=cut
Index: trunk/contrib/perl/t/mro/pkg_gen.t
===================================================================
--- trunk/contrib/perl/t/mro/pkg_gen.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/mro/pkg_gen.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/mro/pkg_gen.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Copied: trunk/contrib/perl/t/mro/pkg_gen_utf8.t (from rev 6437, vendor/perl/5.18.1/t/mro/pkg_gen_utf8.t)
===================================================================
--- trunk/contrib/perl/t/mro/pkg_gen_utf8.t (rev 0)
+++ trunk/contrib/perl/t/mro/pkg_gen_utf8.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,44 @@
+#!./perl
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+
+chdir 't' if -d 't';
+require q(./test.pl); plan(tests => 7);
+
+require mro;
+
+{
+ package ᕘ;
+ our @ISA = qw//;
+}
+
+ok(!mro::get_pkg_gen('레알ឭ되s놑Eξsᴛ'),
+ "pkg_gen 0 for non-existent pkg");
+
+my $f_gen = mro::get_pkg_gen('ᕘ');
+ok($f_gen > 0, 'ᕘ pkg_gen > 0');
+
+{
+ no warnings 'once';
+ *ᕘ::ᕘ_Ƒ운ℭ = sub { 123 };
+}
+my $new_f_gen = mro::get_pkg_gen('ᕘ');
+ok($new_f_gen > $f_gen, 'ᕘ pkg_gen incs for methods');
+$f_gen = $new_f_gen;
+
+@ᕘ::ISA = qw/Bar/;
+$new_f_gen = mro::get_pkg_gen('ᕘ');
+ok($new_f_gen > $f_gen, 'ᕘ pkg_gen incs for @ISA');
+
+undef %ᕘ::;
+is(mro::get_pkg_gen('ᕘ'), 1, "pkg_gen 1 for undef %Pkg::");
+
+delete $::{"ᕘ::"};
+is(mro::get_pkg_gen('ᕘ'), 0, 'pkg_gen 0 for delete $::{Pkg::}');
+
+delete $::{"ㄑଊｘ::"};
+push @ㄑଊｘ::ISA, "Woot"; # should not segfault
+ok(1, "No segfault on modification of ISA in a deleted stash");
Index: trunk/contrib/perl/t/mro/recursion_c3.t
===================================================================
--- trunk/contrib/perl/t/mro/recursion_c3.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/mro/recursion_c3.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/mro/recursion_c3.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Copied: trunk/contrib/perl/t/mro/recursion_c3_utf8.t (from rev 6437, vendor/perl/5.18.1/t/mro/recursion_c3_utf8.t)
===================================================================
--- trunk/contrib/perl/t/mro/recursion_c3_utf8.t (rev 0)
+++ trunk/contrib/perl/t/mro/recursion_c3_utf8.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,102 @@
+#!./perl
+
+use strict;
+use warnings;
+BEGIN {
+ unless (-d 'blib') {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+}
+use utf8;
+use open qw( :utf8 :std );
+
+require './test.pl';
+
+plan(skip_all => "Your system has no SIGALRM") if !exists $SIG{ALRM};
+plan(tests => 8);
+
+require mro;
+
+=pod
+
+These are like the 010_complex_merge_classless test,
+but an infinite loop has been made in the heirarchy,
+to test that we can fail cleanly instead of going
+into an infinite loop
+
+=cut
+
+# initial setup, everything sane
+{
+ package ƙ;
+ use mro 'c3';
+ our @ISA = qw/ᶨ ィ/;
+ package ᶨ;
+ use mro 'c3';
+ our @ISA = qw/ｆ/;
+ package ィ;
+ use mro 'c3';
+ our @ISA = qw/ʰ ｆ/;
+ package ʰ;
+ use mro 'c3';
+ our @ISA = qw/ᶢ/;
+ package ᶢ;
+ use mro 'c3';
+ our @ISA = qw/ᛞ/;
+ package ｆ;
+ use mro 'c3';
+ our @ISA = qw/ǝ/;
+ package ǝ;
+ use mro 'c3';
+ our @ISA = qw/ᛞ/;
+ package ᛞ;
+ use mro 'c3';
+ our @ISA = qw/Ạ Ｂ ʗ/;
+ package ʗ;
+ use mro 'c3';
+ our @ISA = qw//;
+ package Ｂ;
+ use mro 'c3';
+ our @ISA = qw//;
+ package Ạ;
+ use mro 'c3';
+ our @ISA = qw//;
+}
+
+# A series of 8 aberations that would cause infinite loops,
+# each one undoing the work of the previous
+my @loopies = (
+ sub { @ǝ::ISA = qw/ｆ/ },
+ sub { @ǝ::ISA = qw/ᛞ/; @ʗ::ISA = qw/ｆ/ },
+ sub { @ʗ::ISA = qw//; @Ạ::ISA = qw/ƙ/ },
+ sub { @Ạ::ISA = qw//; @ᶨ::ISA = qw/ｆ ƙ/ },
+ sub { @ᶨ::ISA = qw/ｆ/; @ʰ::ISA = qw/ƙ ᶢ/ },
+ sub { @ʰ::ISA = qw/ᶢ/; @Ｂ::ISA = qw/Ｂ/ },
+ sub { @Ｂ::ISA = qw//; @ƙ::ISA = qw/ƙ ᶨ ィ/ },
+ sub { @ƙ::ISA = qw/ᶨ ィ/; @ᛞ::ISA = qw/Ạ ʰ Ｂ ʗ/ },
+);
+
+foreach my $loopy (@loopies) {
+ eval {
+ local $SIG{ALRM} = sub { die "ALRMTimeout" };
+ alarm(3);
+ $loopy->();
+ mro::get_linear_isa('ƙ', 'c3');
+ };
+
+ if(my $err = $@) {
+ if($err =~ /ALRMTimeout/) {
+ ok(0, "Loop terminated by SIGALRM");
+ }
+ elsif($err =~ /Recursive inheritance detected/) {
+ ok(1, "Graceful exception thrown");
+ }
+ else {
+ ok(0, "Unrecognized exception: $err");
+ }
+ }
+ else {
+ ok(0, "Infinite loop apparently succeeded???");
+ }
+}
Index: trunk/contrib/perl/t/mro/recursion_dfs.t
===================================================================
--- trunk/contrib/perl/t/mro/recursion_dfs.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/mro/recursion_dfs.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/mro/recursion_dfs.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/t/mro/recursion_dfs_utf8.t (from rev 6437, vendor/perl/5.18.1/t/mro/recursion_dfs_utf8.t)
===================================================================
--- trunk/contrib/perl/t/mro/recursion_dfs_utf8.t (rev 0)
+++ trunk/contrib/perl/t/mro/recursion_dfs_utf8.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,89 @@
+#!./perl
+
+use strict;
+use warnings;
+BEGIN {
+ unless (-d 'blib') {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+}
+use utf8;
+use open qw( :utf8 :std );
+
+require './test.pl';
+
+plan(skip_all => "Your system has no SIGALRM") if !exists $SIG{ALRM};
+plan(tests => 8);
+
+=pod
+
+These are like the 010_complex_merge_classless test,
+but an infinite loop has been made in the heirarchy,
+to test that we can fail cleanly instead of going
+into an infinite loop
+
+=cut
+
+# initial setup, everything sane
+{
+ package ƙ;
+ our @ISA = qw/ᶨ ィ/;
+ package ᶨ;
+ our @ISA = qw/ｆ/;
+ package ィ;
+ our @ISA = qw/ʰ ｆ/;
+ package ʰ;
+ our @ISA = qw/ᶢ/;
+ package ᶢ;
+ our @ISA = qw/ᛞ/;
+ package ｆ;
+ our @ISA = qw/ǝ/;
+ package ǝ;
+ our @ISA = qw/ᛞ/;
+ package ᛞ;
+ our @ISA = qw/Ạ Ｂ ʗ/;
+ package ʗ;
+ our @ISA = qw//;
+ package Ｂ;
+ our @ISA = qw//;
+ package Ạ;
+ our @ISA = qw//;
+}
+
+# A series of 8 aberations that would cause infinite loops,
+# each one undoing the work of the previous
+my @loopies = (
+ sub { @ǝ::ISA = qw/ｆ/ },
+ sub { @ǝ::ISA = qw/ᛞ/; @ʗ::ISA = qw/ｆ/ },
+ sub { @ʗ::ISA = qw//; @Ạ::ISA = qw/ƙ/ },
+ sub { @Ạ::ISA = qw//; @ᶨ::ISA = qw/ｆ ƙ/ },
+ sub { @ᶨ::ISA = qw/ｆ/; @ʰ::ISA = qw/ƙ ᶢ/ },
+ sub { @ʰ::ISA = qw/ᶢ/; @Ｂ::ISA = qw/Ｂ/ },
+ sub { @Ｂ::ISA = qw//; @ƙ::ISA = qw/ƙ ᶨ ィ/ },
+ sub { @ƙ::ISA = qw/ᶨ ィ/; @ᛞ::ISA = qw/Ạ ʰ Ｂ ʗ/ },
+);
+
+foreach my $loopy (@loopies) {
+ eval {
+ local $SIG{ALRM} = sub { die "ALRMTimeout" };
+ alarm(3);
+ $loopy->();
+ mro::get_linear_isa('ƙ', 'dfs');
+ };
+
+ if(my $err = $@) {
+ if($err =~ /ALRMTimeout/) {
+ ok(0, "Loop terminated by SIGALRM");
+ }
+ elsif($err =~ /Recursive inheritance detected/) {
+ ok(1, "Graceful exception thrown");
+ }
+ else {
+ ok(0, "Unrecognized exception: $err");
+ }
+ }
+ else {
+ ok(0, "Infinite loop apparently succeeded???");
+ }
+}
Index: trunk/contrib/perl/t/mro/vulcan_c3.t
===================================================================
--- trunk/contrib/perl/t/mro/vulcan_c3.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/mro/vulcan_c3.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/mro/vulcan_c3.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/t/mro/vulcan_c3_utf8.t (from rev 6437, vendor/perl/5.18.1/t/mro/vulcan_c3_utf8.t)
===================================================================
--- trunk/contrib/perl/t/mro/vulcan_c3_utf8.t (rev 0)
+++ trunk/contrib/perl/t/mro/vulcan_c3_utf8.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,67 @@
+#!./perl
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+require q(./test.pl); plan(tests => 1);
+
+=pod
+
+example taken from: L<http://www.opendylan.org/books/drm/Method_Dispatch>
+
+ 옵젳Ṯ
+ ^
+ |
+ ᓕᵮꡠＦᚖᶭ
+ ^ ^
+ / \
+ SㄣチenŦ 빞엗ᱞ
+ ^ ^
+ | |
+ ᕟ텔li겐ț Hʉ만ӫ읻
+ ^ ^
+ \ /
+ ቩᓪ찬
+
+ define class <SㄣチenŦ> (<ᓕᵮꡠＦᚖᶭ>) end class;
+ define class <빞엗ᱞ> (<ᓕᵮꡠＦᚖᶭ>) end class;
+ define class <ᕟ텔li겐ț> (<SㄣチenŦ>) end class;
+ define class <Hʉ만ӫ읻> (<빞엗ᱞ>) end class;
+ define class <ቩᓪ찬> (<ᕟ텔li겐ț>, <Hʉ만ӫ읻>) end class;
+
+=cut
+
+{
+ package 옵젳Ṯ;
+ use mro 'c3';
+
+ package ᓕᵮꡠＦᚖᶭ;
+ use mro 'c3';
+ use base '옵젳Ṯ';
+
+ package SㄣチenŦ;
+ use mro 'c3';
+ use base 'ᓕᵮꡠＦᚖᶭ';
+
+ package 빞엗ᱞ;
+ use mro 'c3';
+ use base 'ᓕᵮꡠＦᚖᶭ';
+
+ package ᕟ텔li겐ț;
+ use mro 'c3';
+ use base 'SㄣチenŦ';
+
+ package Hʉ만ӫ읻;
+ use mro 'c3';
+ use base '빞엗ᱞ';
+
+ package ቩᓪ찬;
+ use mro 'c3';
+ use base ('ᕟ텔li겐ț', 'Hʉ만ӫ읻');
+}
+
+ok(eq_array(
+ mro::get_linear_isa('ቩᓪ찬'),
+ [ qw(ቩᓪ찬 ᕟ텔li겐ț SㄣチenŦ Hʉ만ӫ읻 빞엗ᱞ ᓕᵮꡠＦᚖᶭ 옵젳Ṯ) ]
+), '... got the right MRO for the ቩᓪ찬 Dylan Example');
Index: trunk/contrib/perl/t/mro/vulcan_dfs.t
===================================================================
--- trunk/contrib/perl/t/mro/vulcan_dfs.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/mro/vulcan_dfs.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/mro/vulcan_dfs.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/t/mro/vulcan_dfs_utf8.t (from rev 6437, vendor/perl/5.18.1/t/mro/vulcan_dfs_utf8.t)
===================================================================
--- trunk/contrib/perl/t/mro/vulcan_dfs_utf8.t (rev 0)
+++ trunk/contrib/perl/t/mro/vulcan_dfs_utf8.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,68 @@
+#!./perl
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+require q(./test.pl); plan(tests => 1);
+
+
+=pod
+
+example taken from: L<http://www.opendylan.org/books/drm/Method_Dispatch>
+
+ 옵젳Ṯ
+ ^
+ |
+ ᓕᵮꡠＦᚖᶭ
+ ^ ^
+ / \
+ SㄣチenŦ 빞엗ᱞ
+ ^ ^
+ | |
+ ᕟ텔li겐ț Hʉ만ӫ읻
+ ^ ^
+ \ /
+ ቩᓪ찬
+
+ define class <SㄣチenŦ> (<life-form>) end class;
+ define class <빞엗ᱞ> (<life-form>) end class;
+ define class <ᕟ텔li겐ț> (<SㄣチenŦ>) end class;
+ define class <Hʉ만ӫ읻> (<빞엗ᱞ>) end class;
+ define class <ቩᓪ찬> (<ᕟ텔li겐ț>, <Hʉ만ӫ읻>) end class;
+
+=cut
+
+{
+ package 옵젳Ṯ;
+ use mro 'dfs';
+
+ package ᓕᵮꡠＦᚖᶭ;
+ use mro 'dfs';
+ use base '옵젳Ṯ';
+
+ package SㄣチenŦ;
+ use mro 'dfs';
+ use base 'ᓕᵮꡠＦᚖᶭ';
+
+ package 빞엗ᱞ;
+ use mro 'dfs';
+ use base 'ᓕᵮꡠＦᚖᶭ';
+
+ package ᕟ텔li겐ț;
+ use mro 'dfs';
+ use base 'SㄣチenŦ';
+
+ package Hʉ만ӫ읻;
+ use mro 'dfs';
+ use base '빞엗ᱞ';
+
+ package ቩᓪ찬;
+ use mro 'dfs';
+ use base ('ᕟ텔li겐ț', 'Hʉ만ӫ읻');
+}
+
+ok(eq_array(
+ mro::get_linear_isa('ቩᓪ찬'),
+ [ qw(ቩᓪ찬 ᕟ텔li겐ț SㄣチenŦ ᓕᵮꡠＦᚖᶭ 옵젳Ṯ Hʉ만ӫ읻 빞엗ᱞ) ]
+), '... got the right MRO for the ቩᓪ찬 Dylan Example');
Index: trunk/contrib/perl/t/op/64bitint.t
===================================================================
--- trunk/contrib/perl/t/op/64bitint.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/64bitint.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/64bitint.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/alarm.t
===================================================================
--- trunk/contrib/perl/t/op/alarm.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/alarm.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -16,30 +16,35 @@
plan tests => 5;
my $Perl = which_perl();
-my $start_time = time;
+my ($start_time, $end_time);
+
eval {
- local $SIG{ALRM} = sub { die "ALARM!\n" };
+ local $SIG{ALRM} = sub { $end_time = time; die "ALARM!\n" };
+ $start_time = time;
alarm 3;
# perlfunc recommends against using sleep in combination with alarm.
- 1 while (time - $start_time < 6);
+ 1 while (($end_time = time) - $start_time < 6);
+ alarm 0;
};
alarm 0;
-my $diff = time - $start_time;
+my $diff = $end_time - $start_time;
# alarm time might be one second less than you said.
is( $@, "ALARM!\n", 'alarm w/$SIG{ALRM} vs inf loop' );
-ok( abs($diff - 3) <= 1, " right time" );
+ok( abs($diff - 3) <= 1, " right time (waited $diff secs for 3-sec alarm)" );
-my $start_time = time;
eval {
- local $SIG{ALRM} = sub { die "ALARM!\n" };
+ local $SIG{ALRM} = sub { $end_time = time; die "ALARM!\n" };
+ $start_time = time;
alarm 3;
system(qq{$Perl -e "sleep 6"});
+ $end_time = time;
+ alarm 0;
};
alarm 0;
-$diff = time - $start_time;
+$diff = $end_time - $start_time;
# alarm time might be one second less than you said.
is( $@, "ALARM!\n", 'alarm w/$SIG{ALRM} vs system()' );
@@ -53,7 +58,7 @@
{
local $SIG{"ALRM"} = sub { die };
- eval { alarm(1); my $x = qx($Perl -e "sleep 3") };
+ eval { alarm(1); my $x = qx($Perl -e "sleep 3"); alarm(0); };
chomp (my $foo = "foo\n");
ok($foo eq "foo", '[perl #33928] chomp() fails after alarm(), `sleep`');
}
Property changes on: trunk/contrib/perl/t/op/alarm.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/anonsub.t
===================================================================
--- trunk/contrib/perl/t/op/anonsub.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/anonsub.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -84,3 +84,10 @@
print sub { return "ok 1\n" } -> ();
EXPECT
ok 1
+########
+# [perl #71154] undef &$code makes $code->() die with: Not a CODE reference
+sub __ANON__ { print "42\n" }
+undef &{$x=sub{}};
+$x->();
+EXPECT
+Undefined subroutine called at - line 4.
Property changes on: trunk/contrib/perl/t/op/anonsub.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/append.t
===================================================================
--- trunk/contrib/perl/t/op/append.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/append.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,22 +1,26 @@
#!./perl
-print "1..13\n";
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require './test.pl';
+}
+##Literal test count since evals below can fail
+plan tests => 13;
+
$a = 'ab' . 'c'; # compile time
$b = 'def';
$c = $a . $b;
-print "#1\t:$c: eq :abcdef:\n";
-if ($c eq 'abcdef') {print "ok 1\n";} else {print "not ok 1\n";}
+is( $c, 'abcdef', 'compile time concatenation' );
$c .= 'xyz';
-print "#2\t:$c: eq :abcdefxyz:\n";
-if ($c eq 'abcdefxyz') {print "ok 2\n";} else {print "not ok 2\n";}
+is( $c, 'abcdefxyz', 'concat to self');
$_ = $a;
$_ .= $b;
-print "#3\t:$_: eq :abcdef:\n";
-if ($_ eq 'abcdef') {print "ok 3\n";} else {print "not ok 3\n";}
+is( $_, 'abcdef', 'concat using $_');
# test that when right argument of concat is UTF8, and is the same
# variable as the target, and the left argument is not UTF8, it no
@@ -28,7 +32,8 @@
$string = "abcdefghijkl$string";
}
- r2() and print "ok $_\n" for qw/ 4 5 /;
+ isnt(r2(), '', 'UTF8 concat does not free the wrong string');
+ isnt(r2(), '', 'second check');
}
# test that nul bytes get copied
@@ -38,35 +43,30 @@
my $ub = pack("U0a*", 'b');
+ #aa\0b
my $t1 = $a; $t1 .= $ab;
+ like( $t1, qr/b/, 'null bytes do not stop string copy, aa\0b');
- print $t1 =~ /b/ ? "ok 6\n" : "not ok 6\t# $t1\n";
-
+ #a\0a\0b
my $t2 = $a; $t2 .= $uab;
-
- print eval '$t2 =~ /$ub/' ? "ok 7\n" : "not ok 7\t# $t2\n";
-
+ ok( eval '$t2 =~ /$ub/', '... a\0a\0b' );
+
+ #\0aa\0b
my $t3 = $ua; $t3 .= $ab;
-
- print $t3 =~ /$ub/ ? "ok 8\n" : "not ok 8\t# $t3\n";
-
+ ok( eval '$t3 =~ /$ub/', '... \0aa\0b' );
+
my $t4 = $ua; $t4 .= $uab;
-
- print eval '$t4 =~ /$ub/' ? "ok 9\n" : "not ok 9\t# $t4\n";
-
+ ok( eval '$t4 =~ /$ub/', '... \0a\0a\0b' );
+
my $t5 = $a; $t5 = $ab . $t5;
-
- print $t5 =~ /$ub/ ? "ok 10\n" : "not ok 10\t# $t5\n";
-
+ like( $t5, qr/$ub/, '... a\0ba' );
+
my $t6 = $a; $t6 = $uab . $t6;
-
- print eval '$t6 =~ /$ub/' ? "ok 11\n" : "not ok 11\t# $t6\n";
-
+ ok( eval '$t6 =~ /$ub/', '... \0a\0ba' );
+
my $t7 = $ua; $t7 = $ab . $t7;
-
- print $t7 =~ /$ub/ ? "ok 12\n" : "not ok 12\t# $t7\n";
-
+ like( $t7, qr/$ub/, '... a\0b\0a' );
+
my $t8 = $ua; $t8 = $uab . $t8;
-
- print eval '$t8 =~ /$ub/' ? "ok 13\n" : "not ok 13\t# $t8\n";
+ ok( eval '$t8 =~ /$ub/', '... \0a\0b\0a' );
}
Property changes on: trunk/contrib/perl/t/op/append.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/args.t
===================================================================
--- trunk/contrib/perl/t/op/args.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/args.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -14,8 +14,8 @@
{
my $x = new1("x");
my $y = new1("y");
- is("@$y","y");
- is("@$x","x");
+ is("@$y","y", 'bless');
+ is("@$x","x", 'bless');
}
sub new2 { splice @_, 0, 0, "a", "b", "c"; return \@_ }
@@ -22,8 +22,8 @@
{
my $x = new2("x");
my $y = new2("y");
- is("@$x","a b c x");
- is("@$y","a b c y");
+ is("@$x","a b c x", 'splice');
+ is("@$y","a b c y", 'splice');
}
sub new3 { goto &new1 }
@@ -30,8 +30,8 @@
{
my $x = new3("x");
my $y = new3("y");
- is("@$y","y");
- is("@$x","x");
+ is("@$y","y", 'goto: single element');
+ is("@$x","x", 'goto: single element');
}
sub new4 { goto &new2 }
@@ -38,8 +38,8 @@
{
my $x = new4("x");
my $y = new4("y");
- is("@$x","a b c x");
- is("@$y","a b c y");
+ is("@$x","a b c x", 'goto: multiple elements');
+ is("@$y","a b c y", 'goto: multiple elements');
}
# see if POPSUB gets to see the right pad across a dounwind() with
@@ -54,24 +54,27 @@
&methimpl;
}
+my $failcount = 0;
sub try {
eval { method('foo', 'bar'); };
print "# $@" if $@;
+ $failcount++;
}
for (1..5) { try() }
-pass();
+is($failcount, 5,
+ 'POPSUB sees right pad across a dounwind() with reified @_');
# bug #21542 local $_[0] causes reify problems and coredumps
sub local1 { local $_[0] }
my $foo = 'foo'; local1($foo); local1($foo);
-print "got [$foo], expected [foo]\nnot " if $foo ne 'foo';
-pass();
+is($foo, 'foo',
+ "got 'foo' as expected rather than '\$foo': RT \#21542");
sub local2 { local $_[0]; last L }
L: { local2 }
-pass();
+pass("last to label");
# the following test for local(@_) used to be in t/op/nothr5005.t (because it
# failed with 5005threads)
@@ -82,9 +85,9 @@
sub bar { unshift @_, 'D'; @_ }
sub baz { push @_, 'E'; return @_ }
for (1..3) {
- is(join('',foo('a', 'b', 'c')),'pqr');
- is(join('',bar('d')),'Dd');
- is(join('',baz('e')),'eE');
+ is(join('',foo('a', 'b', 'c')),'pqr', 'local @_');
+ is(join('',bar('d')),'Dd', 'unshift @_');
+ is(join('',baz('e')),'eE', 'push @_');
}
# [perl #28032] delete $_[0] was freeing things too early
Property changes on: trunk/contrib/perl/t/op/args.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/op/arith.t
===================================================================
--- trunk/contrib/perl/t/op/arith.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/arith.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/arith.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/array.t
===================================================================
--- trunk/contrib/perl/t/op/array.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/array.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -3,12 +3,11 @@
BEGIN {
chdir 't' if -d 't';
@INC = ('.', '../lib');
+ require 'test.pl';
}
-require 'test.pl';
+plan (127);
-plan (130);
-
#
# @foo, @bar, and @ary are also used from tie-stdarray after tie-ing them
#
@@ -24,23 +23,6 @@
{
no warnings 'deprecated';
-$[ = 1;
- at ary = (1,2,3,4,5);
-is(join('', at ary), '12345');
-
-$tmp = $ary[$#ary]; --$#ary;
-is($tmp, 5);
-# Must do == here beacuse $[ isn't 0
-ok($#ary == 4);
-is(join('', at ary), '1234');
-
-is($ary[5], undef);
-
-$#ary += 1; # see if element 5 gone for good
-ok($#ary == 5);
-ok(!defined $ary[5]);
-
-$[ = 0;
@foo = ();
$r = join(',', $#foo, @foo);
is($r, "-1");
@@ -254,22 +236,6 @@
@foo=(foo())[0,0];
is ($foo[1], "a");
-# $[ should have the same effect regardless of whether the aelem
-# op is optimized to aelemfast.
-
-
-
-sub tary {
- no warnings 'deprecated';
- local $[ = 10;
- my $five = 5;
- is ($tary[5], $tary[$five]);
-}
-
- at tary = (0..50);
-tary();
-
-
# bugid #15439 - clearing an array calls destructors which may try
# to modify the array - caused 'Attempt to free unreferenced scalar'
@@ -427,6 +393,13 @@
(our $y, our $z) = ($x,$y);
is("$x $y $z", "1 1 2");
}
+{
+ # AASSIGN_COMMON detection with logical operators
+ my $true = 1;
+ our($x,$y,$z) = (1..3);
+ (our $y, our $z) = $true && ($x,$y);
+ is("$x $y $z", "1 1 2");
+}
# [perl #70171]
{
@@ -467,4 +440,36 @@
*trit = *scile; $trit[0];
ok(1, 'aelem_fast on a nonexistent array does not crash');
+# [perl #107440]
+sub A::DESTROY { $::ra = 0 }
+$::ra = [ bless [], 'A' ];
+undef @$::ra;
+pass 'no crash when freeing array that is being undeffed';
+$::ra = [ bless [], 'A' ];
+@$::ra = ('a'..'z');
+pass 'no crash when freeing array that is being cleared';
+
+# [perl #85670] Copying magic to elements
+SKIP: {
+ skip "no Scalar::Util::weaken on miniperl", 1, if is_miniperl;
+ require Scalar::Util;
+ package glelp {
+ Scalar::Util::weaken ($a = \@ISA);
+ @ISA = qw(Foo);
+ Scalar::Util::weaken ($a = \$ISA[0]);
+ ::is @ISA, 1, 'backref magic is not copied to elements';
+ }
+}
+package peen {
+ $#ISA = -1;
+ @ISA = qw(Foo);
+ $ISA[0] = qw(Sphare);
+
+ sub Sphare::pling { 'pling' }
+
+ ::is eval { pling peen }, 'pling',
+ 'arylen_p magic does not stop isa magic from being copied';
+}
+
+
"We're included by lib/Tie/Array/std.t so we need to return something true";
Property changes on: trunk/contrib/perl/t/op/array.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/t/op/array_base.aux
===================================================================
--- trunk/contrib/perl/t/op/array_base.aux 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/array_base.aux 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/array_base.aux
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/array_base.t
===================================================================
--- trunk/contrib/perl/t/op/array_base.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/array_base.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,82 +1,40 @@
#!perl -w
use strict;
-require './test.pl';
+BEGIN {
+ require './test.pl';
-plan (tests => 24);
-no warnings 'deprecated';
+ plan (tests => my $tests = 11);
-# Bug #27024
-{
- # this used to segfault (because $[=1 is optimized away to a null block)
- my $x;
- $[ = 1 while $x;
- pass('#27204');
- $[ = 0; # restore the original value for less side-effects
-}
+ # Run these at BEGIN time, before arybase loads
+ use v5.15;
+ is(eval('$[ = 1; 123'), undef);
+ like($@, qr/\AAssigning non-zero to \$\[ is no longer possible/);
-# [perl #36313] perl -e "1for$[=0" crash
-{
- my $x;
- $x = 1 for ($[) = 0;
- pass('optimized assignment to $[ used to segfault in list context');
- if ($[ = 0) { $x = 1 }
- pass('optimized assignment to $[ used to segfault in scalar context');
- $x = ($[=2.4);
- is($x, 2, 'scalar assignment to $[ behaves like other variables');
- $x = (($[) = 0);
- is($x, 1, 'list assignment to $[ behaves like other variables');
- $x = eval q{ ($[, $x) = (0) };
- like($@, qr/That use of \$\[ is unsupported/,
- 'cannot assign to $[ in a list');
- eval q{ ($[) = (0, 1) };
- like($@, qr/That use of \$\[ is unsupported/,
- 'cannot assign list of >1 elements to $[');
- eval q{ ($[) = () };
- like($@, qr/That use of \$\[ is unsupported/,
- 'cannot assign list of <1 elements to $[');
+ if (is_miniperl()) {
+ # skip the rest
+ SKIP: { skip ("no arybase.xs on miniperl", $tests-2) }
+ exit;
+ }
}
+no warnings 'deprecated';
-{
- $[ = 11;
- cmp_ok($[ + 0, '==', 11, 'setting $[ affects $[');
- our $t11; BEGIN { $t11 = $^H{'$['} }
- cmp_ok($t11, '==', 11, 'setting $[ affects $^H{\'$[\'}');
+is(eval('$['), 0);
+is(eval('$[ = 0; 123'), 123);
+is(eval('$[ = 1; 123'), 123);
+$[ = 1;
+ok $INC{'arybase.pm'};
- BEGIN { $^H{'$['} = 22 }
- cmp_ok($[ + 0, '==', 22, 'setting $^H{\'$\'} affects $[');
- our $t22; BEGIN { $t22 = $^H{'$['} }
- cmp_ok($t22, '==', 22, 'setting $^H{\'$[\'} affects $^H{\'$[\'}');
+use v5.15;
+is(eval('$[ = 1; 123'), undef);
+like($@, qr/\AAssigning non-zero to \$\[ is no longer possible/);
+is $[, 0, '$[ is 0 under 5.16';
+$_ = "hello";
+/l/g;
+my $pos = \pos;
+is $$pos, 3;
+$$pos = 1;
+is $$pos, 1;
- BEGIN { %^H = () }
- my $val = do {
- no warnings 'uninitialized';
- $[;
- };
- cmp_ok($val, '==', 0, 'clearing %^H affects $[');
- our $t0; BEGIN { $t0 = $^H{'$['} }
- cmp_ok($t0, '==', 0, 'clearing %^H affects $^H{\'$[\'}');
-}
-
-{
- $[ = 13;
- BEGIN { $^H |= 0x04000000; $^H{foo} = "z"; }
-
- our($ri0, $rf0); BEGIN { $ri0 = $^H; $rf0 = $^H{foo}; }
- cmp_ok($[ + 0, '==', 13, '$[ correct before require');
- ok($ri0 & 0x04000000, '$^H correct before require');
- is($rf0, "z", '$^H{foo} correct before require');
-
- our($ra1, $ri1, $rf1, $rfe1);
- BEGIN { require "op/array_base.aux"; }
- cmp_ok($ra1, '==', 0, '$[ cleared for require');
- ok(!($ri1 & 0x04000000), '$^H cleared for require');
- is($rf1, undef, '$^H{foo} cleared for require');
- ok(!$rfe1, '$^H{foo} cleared for require');
-
- our($ri2, $rf2); BEGIN { $ri2 = $^H; $rf2 = $^H{foo}; }
- cmp_ok($[ + 0, '==', 13, '$[ correct after require');
- ok($ri2 & 0x04000000, '$^H correct after require');
- is($rf2, "z", '$^H{foo} correct after require');
-}
+1;
Property changes on: trunk/contrib/perl/t/op/array_base.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/assignwarn.t
===================================================================
--- trunk/contrib/perl/t/op/assignwarn.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/assignwarn.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -19,18 +19,15 @@
++$should_warn{$_} foreach qw(* / x & ** << >>);
++$should_not{$_} foreach qw(+ - . | ^ && ||);
-my %todo_as_tie = reverse (add => '+', subtract => '-',
- bit_or => '|', bit_xor => '^');
+my %integer;
+$integer{$_} = 0 foreach qw(* / % + -);
-my %integer = reverse (i_add => '+', i_subtract => '-');
-$integer{$_} = 0 foreach qw(* / %);
-
sub TIESCALAR { my $x; bless \$x }
sub FETCH { ${$_[0]} }
sub STORE { ${$_[0]} = $_[1] }
sub test_op {
- my ($tie, $int, $op_seq, $warn, $todo) = @_;
+ my ($tie, $int, $op_seq, $warn) = @_;
my $code = "sub {\n";
$code .= "use integer;" if $int;
$code .= "my \$x;\n";
@@ -39,8 +36,6 @@
my $sub = eval $code;
is($@, '', "Can eval code for $op_seq");
- local $::TODO;
- $::TODO = "[perl #17809] pp_$todo" if $todo;
if ($warn) {
warning_like($sub, qr/^Use of uninitialized value/,
"$op_seq$tie$int warns");
@@ -56,13 +51,13 @@
}
foreach (keys %should_warn, keys %should_not) {
- test_op($tie, '', "\$x $_= 1", $should_warn{$_}, $tie && $todo_as_tie{$_});
+ test_op($tie, '', "\$x $_= 1", $should_warn{$_});
next unless exists $integer{$_};
- test_op($tie, ', int', "\$x $_= 1", $should_warn{$_}, $tie && $integer{$_});
+ test_op($tie, ', int', "\$x $_= 1", $should_warn{$_});
}
foreach (qw(| ^ &)) {
- test_op($tie, '', "\$x $_= 'x'", $should_warn{$_}, $tie && $todo_as_tie{$_});
+ test_op($tie, '', "\$x $_= 'x'", $should_warn{$_});
}
}
Property changes on: trunk/contrib/perl/t/op/assignwarn.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/t/op/attrhand.t
===================================================================
--- trunk/contrib/perl/t/op/attrhand.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/attrhand.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/attrhand.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/attrs.t
===================================================================
--- trunk/contrib/perl/t/op/attrs.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/attrs.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -18,6 +18,9 @@
is( $@, '', @_);
}
+fresh_perl_is 'use attributes; print "ok"', 'ok',
+ 'attributes.pm can load without warnings.pm already loaded';
+
our $anon1; eval_ok '$anon1 = sub : method { $_[0]++ }';
eval 'sub e1 ($) : plugh ;';
@@ -194,7 +197,7 @@
sub PVBM () { 'foo' }
{ my $dummy = index 'foo', PVBM }
-ok !defined(attributes::get(\PVBM)),
+ok !defined(eval 'attributes::get(\PVBM)'),
'PVBMs don\'t segfault attributes::get';
{
@@ -310,6 +313,16 @@
'Calling closure proto with no @_ that returns a lexical';
}
+# Referencing closure prototypes
+{
+ package buckbuck;
+ my @proto;
+ sub MODIFY_CODE_ATTRIBUTES { push @proto, $_[1], \&{$_[1]}; _: }
+ my $id;
+ () = sub :buck {$id};
+ &::is(@proto, 'referencing closure prototype');
+}
+
# [perl #68658] Attributes on stately variables
{
package thwext;
@@ -322,4 +335,52 @@
is $x_values, '00', 'state with attributes';
}
+{
+ package ningnangnong;
+ sub MODIFY_SCALAR_ATTRIBUTES{}
+ sub MODIFY_ARRAY_ATTRIBUTES{ }
+ sub MODIFY_HASH_ATTRIBUTES{ }
+ my ($cows, @go, %bong) : teapots = qw[ jibber jabber joo ];
+ ::is $cows, 'jibber', 'list assignment to scalar with attrs';
+ ::is "@go", 'jabber joo', 'list assignment to array with attrs';
+}
+
+{
+ my $w;
+ local $SIG{__WARN__} = sub { $w = shift };
+ sub ent {}
+ sub lent :lvalue {}
+ my $posmsg =
+ 'lvalue attribute applied to already-defined subroutine at '
+ .'\(eval';
+ my $negmsg =
+ 'lvalue attribute removed from already-defined subroutine at '
+ .'\(eval';
+ eval 'use attributes __PACKAGE__, \&ent, "lvalue"';
+ like $w, qr/^$posmsg/, 'lvalue attr warning on def sub';
+ is join("",&attributes::get(\&ent)), "lvalue",':lvalue applied anyway';
+ $w = '';
+ eval 'use attributes __PACKAGE__, \&lent, "lvalue"; 1' or die;
+ is $w, "", 'no lvalue warning on def lvalue sub';
+ eval 'use attributes __PACKAGE__, \&lent, "-lvalue"';
+ like $w, qr/^$negmsg/, '-lvalue attr warning on def sub';
+ is join("",&attributes::get(\&lent)), "",
+ 'lvalue attribute removed anyway';
+ $w = '';
+ eval 'use attributes __PACKAGE__, \&lent, "-lvalue"; 1' or die;
+ is $w, "", 'no -lvalue warning on def non-lvalue sub';
+ no warnings 'misc';
+ eval 'use attributes __PACKAGE__, \&lent, "lvalue"';
+ is $w, "", 'no lvalue warnings under no warnings misc';
+ eval 'use attributes __PACKAGE__, \&ent, "-lvalue"';
+ is $w, "", 'no -lvalue warnings under no warnings misc';
+}
+
+unlike runperl(
+ prog => 'BEGIN {$^H{a}=b} sub foo:bar{1}',
+ stderr => 1,
+ ),
+ qr/Unbalanced/,
+ 'attribute errors do not cause op trees to leak';
+
done_testing();
Property changes on: trunk/contrib/perl/t/op/attrs.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/auto.t
===================================================================
--- trunk/contrib/perl/t/op/auto.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/auto.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -3,10 +3,10 @@
BEGIN {
chdir 't' if -d 't';
@INC = qw(. ../lib);
+ require "test.pl";
}
-require "test.pl";
-plan( tests => 39 );
+plan( tests => 47 );
$x = 10000;
cmp_ok(0 + ++$x - 1,'==',10000,'scalar ++x - 1');
@@ -55,3 +55,11 @@
cmp_ok(++($foo = 'A99'),'eq','B00','A99 incr B00');
cmp_ok(++($foo = 'zi'), 'eq','zj','zi incr zj (EBCDIC i,j non-contiguous check)');
cmp_ok(++($foo = 'zr'), 'eq','zs','zr incr zs (EBCDIC r,s non-contiguous check)');
+
+# test with glob copies
+
+for(qw '$x++ ++$x $x-- --$x') {
+ my $x = *foo;
+ ok eval "$_; 1", "$_ does not die on a glob copy";
+ is $x, /-/ ? -1 : 1, "result of $_ on a glob copy";
+}
Property changes on: trunk/contrib/perl/t/op/auto.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/t/op/avhv.t
===================================================================
--- trunk/contrib/perl/t/op/avhv.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/avhv.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/avhv.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/op/bless.t
===================================================================
--- trunk/contrib/perl/t/op/bless.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/bless.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/bless.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/blocks.t
===================================================================
--- trunk/contrib/perl/t/op/blocks.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/blocks.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -6,7 +6,7 @@
require './test.pl';
}
-plan tests => 5;
+plan tests => 6;
my @expect = qw(
b1
@@ -13,13 +13,13 @@
b2
b3
b4
-b6
-u5
+b6-c
b7
u6
+u5-c
u1
c3
-c2
+c2-c
c1
i1
i2
@@ -27,6 +27,8 @@
u2
u3
u4
+b6-r
+u5-r
e2
e1
);
@@ -45,9 +47,18 @@
eval 'BEGIN {print ":b5"}';
eval 'UNITCHECK {print ":u2"}';
eval 'UNITCHECK {print ":u3"; UNITCHECK {print ":u4"}}';
-"a" =~ /(?{UNITCHECK {print ":u5"};
- CHECK {print ":c2"};
- BEGIN {print ":b6"}})/x;
+"a" =~ /(?{UNITCHECK {print ":u5-c"};
+ CHECK {print ":c2-c"};
+ BEGIN {print ":b6-c"}})/x;
+{
+ use re 'eval';
+ my $runtime = q{
+ (?{UNITCHECK {print ":u5-r"};
+ CHECK {print ":c2-r"};
+ BEGIN {print ":b6-r"}})/
+ };
+ "a" =~ /$runtime/x;
+}
eval {BEGIN {print ":b7"}};
eval {UNITCHECK {print ":u6"}};
eval {INIT {print ":i2"}};
@@ -113,3 +124,21 @@
# [perl #78634] Make sure block names can be used as constants.
use constant INIT => 5;
::is INIT, 5, 'constant named after a special block';
+
+# [perl #108794] context
+fresh_perl_is(<<'SCRIPT3', <<expEct,{stderr => 1 },'context');
+sub context {
+ print qw[void scalar list][wantarray + defined wantarray], "\n"
+}
+BEGIN {context}
+UNITCHECK {context}
+CHECK {context}
+INIT {context}
+END {context}
+SCRIPT3
+void
+void
+void
+void
+void
+expEct
Property changes on: trunk/contrib/perl/t/op/blocks.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/bop.t
===================================================================
--- trunk/contrib/perl/t/op/bop.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/bop.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -15,7 +15,7 @@
# If you find tests are failing, please try adding names to tests to track
# down where the failure is, and supply your new names as a patch.
# (Just-in-time test naming)
-plan tests => 171 + (10*13*2) + 4;
+plan tests => 174 + (10*13*2) + 5;
# numerics
ok ((0xdead & 0xbeef) == 0x9ead);
@@ -77,6 +77,18 @@
is _xor 0, '0', 'num var ^ const str';
is _xor "yit", 'RYt', 'str var ^ const str again';
+# But don’t mistake a COW for a constant when assigning to it
+%h=(150=>1);
+$i=(keys %h)[0];
+$i |= 105;
+is $i, 255, '[perl #108480] $cow |= number';
+$i=(keys %h)[0];
+$i &= 105;
+is $i, 0, '[perl #108480] $cow &= number';
+$i=(keys %h)[0];
+$i ^= 105;
+is $i, 255, '[perl #108480] $cow ^= number';
+
#
is ("ok \xFF\xFF\n" & "ok 19\n", "ok 19\n");
is ("ok 20\n" | "ok \0\0\n", "ok 20\n");
@@ -554,3 +566,7 @@
eval { $obj |= "Q" };
$strval = "z";
is("$obj", "z", "|= doesn't break string overload");
+
+# [perl #29070]
+$^A .= new version ~$_ for "\xce", v205, "\xcc";
+is $^A, "123", '~v0 clears vstring magic on retval';
Property changes on: trunk/contrib/perl/t/op/bop.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/t/op/caller.pl
===================================================================
--- trunk/contrib/perl/t/op/caller.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/caller.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/caller.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/caller.t
===================================================================
--- trunk/contrib/perl/t/op/caller.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/caller.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -5,7 +5,7 @@
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
- plan( tests => 82 );
+ plan( tests => 91 );
}
my @c;
@@ -19,7 +19,7 @@
is( $c[3], "(eval)", "subroutine name in an eval {}" );
ok( !$c[4], "hasargs false in an eval {}" );
-eval q{ @c = (Caller(0))[3] };
+eval q{ @c = caller(0) };
is( $c[3], "(eval)", "subroutine name in an eval ''" );
ok( !$c[4], "hasargs false in an eval ''" );
@@ -111,8 +111,8 @@
# The repetition number must be set to the value of $BYTES in
# lib/warnings.pm
- BEGIN { check_bits( ${^WARNING_BITS}, "\0" x 13, 'all bits off via "no warnings"' ) }
- testwarn("\0" x 13, 'no bits');
+ BEGIN { check_bits( ${^WARNING_BITS}, "\0" x 14, 'all bits off via "no warnings"' ) }
+ testwarn("\0" x 14, 'no bits');
use warnings;
BEGIN { check_bits( ${^WARNING_BITS}, $default,
@@ -225,6 +225,78 @@
::is $gone, 1, 'caller does not leak @DB::args elems when AvREAL';
}
+# And this crashed [perl #93320]:
+sub {
+ package DB;
+ ()=caller(0);
+ undef *DB::args;
+ ()=caller(0);
+}->();
+pass 'No crash when @DB::args is freed between caller calls';
+
+# This also crashed:
+package glelp;
+sub TIEARRAY { bless [] }
+sub EXTEND { }
+sub CLEAR { }
+sub FETCH { $_[0][$_[1]] }
+sub STORE { $_[0][$_[1]] = $_[2] }
+package DB;
+tie @args, 'glelp';
+eval { sub { () = caller 0; } ->(1..3) };
+::like $@, qr "^Cannot set tied \@DB::args at ",
+ 'caller dies with tie @DB::args';
+::ok tied @args, '@DB::args is still tied';
+untie @args;
+package main;
+
+# [perl #113486]
+fresh_perl_is <<'END', "ok\n", {},
+ { package foo; sub bar { main::bar() } }
+ sub bar {
+ delete $::{"foo::"};
+ my $x = \($1+2);
+ my $y = \($1+2); # this is the one that reuses the mem addr, but
+ my $z = \($1+2); # try the others just in case
+ s/2// for $$x, $$y, $$z; # now SvOOK
+ $x = caller;
+ print "ok\n";
+};
+foo::bar
+END
+ "No crash when freed stash is reused for PV with offset hack";
+
+is eval "(caller 0)[6]", "(caller 0)[6]",
+ 'eval text returned by caller does not include \n;';
+
+# PL_linestr should not be modifiable
+eval '"${;BEGIN{ ${\(caller 2)[6]} = *foo }}"';
+pass "no assertion failure after modifying eval text via caller";
+
+is eval "<<END;\nfoo\nEND\n(caller 0)[6]",
+ "<<END;\nfoo\nEND\n(caller 0)[6]",
+ 'here-docs do not gut eval text';
+is eval "s//<<END/e;\nfoo\nEND\n(caller 0)[6]",
+ "s//<<END/e;\nfoo\nEND\n(caller 0)[6]",
+ 'here-docs in quote-like ops do not gut eval text';
+
+# The bitmask should be assignable to ${^WARNING_BITS} without resulting in
+# different warnings settings.
+{
+ my $ bits = sub { (caller 0)[9] }->();
+ my $w;
+ local $SIG{__WARN__} = sub { $w++ };
+ eval '
+ use warnings;
+ BEGIN { ${^WARNING_BITS} = $bits }
+ local $^W = 1;
+ () = 1 + undef;
+ $^W = 0;
+ () = 1 + undef;
+ ';
+ is $w, 1, 'value from (caller 0)[9] (bitmask) works in ${^WARNING_BITS}';
+}
+
$::testing_caller = 1;
do './op/caller.pl' or die $@;
Property changes on: trunk/contrib/perl/t/op/caller.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.4
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/chars.t
===================================================================
--- trunk/contrib/perl/t/op/chars.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/chars.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,74 +1,82 @@
#!./perl
-print "1..33\n";
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require './test.pl';
+}
+plan tests => 34;
+
# because of ebcdic.c these should be the same on asciiish
# and ebcdic machines.
# Peter Prymmer <pvhp at best.com>.
my $c = "\c@";
-print +((ord($c) == 0) ? "" : "not "),"ok 1\n";
+is (ord($c), 0, '\c@');
$c = "\cA";
-print +((ord($c) == 1) ? "" : "not "),"ok 2\n";
+is (ord($c), 1, '\cA');
$c = "\cB";
-print +((ord($c) == 2) ? "" : "not "),"ok 3\n";
+is (ord($c), 2, '\cB');
$c = "\cC";
-print +((ord($c) == 3) ? "" : "not "),"ok 4\n";
+is (ord($c), 3, '\cC');
$c = "\cD";
-print +((ord($c) == 4) ? "" : "not "),"ok 5\n";
+is (ord($c), 4, '\cD');
$c = "\cE";
-print +((ord($c) == 5) ? "" : "not "),"ok 6\n";
+is (ord($c), 5, '\cE');
$c = "\cF";
-print +((ord($c) == 6) ? "" : "not "),"ok 7\n";
+is (ord($c), 6, '\cF');
$c = "\cG";
-print +((ord($c) == 7) ? "" : "not "),"ok 8\n";
+is (ord($c), 7, '\cG');
$c = "\cH";
-print +((ord($c) == 8) ? "" : "not "),"ok 9\n";
+is (ord($c), 8, '\cH');
$c = "\cI";
-print +((ord($c) == 9) ? "" : "not "),"ok 10\n";
+is (ord($c), 9, '\cI');
$c = "\cJ";
-print +((ord($c) == 10) ? "" : "not "),"ok 11\n";
+is (ord($c), 10, '\cJ');
$c = "\cK";
-print +((ord($c) == 11) ? "" : "not "),"ok 12\n";
+is (ord($c), 11, '\cK');
$c = "\cL";
-print +((ord($c) == 12) ? "" : "not "),"ok 13\n";
+is (ord($c), 12, '\cL');
$c = "\cM";
-print +((ord($c) == 13) ? "" : "not "),"ok 14\n";
+is (ord($c), 13, '\cM');
$c = "\cN";
-print +((ord($c) == 14) ? "" : "not "),"ok 15\n";
+is (ord($c), 14, '\cN');
$c = "\cO";
-print +((ord($c) == 15) ? "" : "not "),"ok 16\n";
+is (ord($c), 15, '\cO');
$c = "\cP";
-print +((ord($c) == 16) ? "" : "not "),"ok 17\n";
+is (ord($c), 16, '\cP');
$c = "\cQ";
-print +((ord($c) == 17) ? "" : "not "),"ok 18\n";
+is (ord($c), 17, '\cQ');
$c = "\cR";
-print +((ord($c) == 18) ? "" : "not "),"ok 19\n";
+is (ord($c), 18, '\cR');
$c = "\cS";
-print +((ord($c) == 19) ? "" : "not "),"ok 20\n";
+is (ord($c), 19, '\cS');
$c = "\cT";
-print +((ord($c) == 20) ? "" : "not "),"ok 21\n";
+is (ord($c), 20, '\cT');
$c = "\cU";
-print +((ord($c) == 21) ? "" : "not "),"ok 22\n";
+is (ord($c), 21, '\cU');
$c = "\cV";
-print +((ord($c) == 22) ? "" : "not "),"ok 23\n";
+is (ord($c), 22, '\cV');
$c = "\cW";
-print +((ord($c) == 23) ? "" : "not "),"ok 24\n";
+is (ord($c), 23, '\cW');
$c = "\cX";
-print +((ord($c) == 24) ? "" : "not "),"ok 25\n";
+is (ord($c), 24, '\cX');
$c = "\cY";
-print +((ord($c) == 25) ? "" : "not "),"ok 26\n";
+is (ord($c), 25, '\cY');
$c = "\cZ";
-print +((ord($c) == 26) ? "" : "not "),"ok 27\n";
+is (ord($c), 26, '\cZ');
$c = "\c[";
-print +((ord($c) == 27) ? "" : "not "),"ok 28\n";
+is (ord($c), 27, '\c[');
$c = "\c\\";
-print +((ord($c) == 28) ? "" : "not "),"ok 29\n";
+is (ord($c), 28, '\c\\');
$c = "\c]";
-print +((ord($c) == 29) ? "" : "not "),"ok 30\n";
+is (ord($c), 29, '\c]');
$c = "\c^";
-print +((ord($c) == 30) ? "" : "not "),"ok 31\n";
+is (ord($c), 30, '\c^');
$c = "\c_";
-print +((ord($c) == 31) ? "" : "not "),"ok 32\n";
+is (ord($c), 31, '\c_');
$c = "\c?";
-print +((ord($c) == 127) ? "" : "not "),"ok 33\n";
+is (ord($c), 127, '\c?');
+$c = '';
+is (ord($c), 0, 'ord("") is 0');
Property changes on: trunk/contrib/perl/t/op/chars.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/op/chdir.t
===================================================================
--- trunk/contrib/perl/t/op/chdir.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/chdir.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/chdir.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/chop.t
===================================================================
--- trunk/contrib/perl/t/op/chop.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/chop.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -23,93 +23,93 @@
@foo = ("hi \n","there\n","!\n");
@bar = @foo;
chop(@bar);
-is (join('', at bar), 'hi there!');
+is (join('', at bar), 'hi there!', 'chop list of strings');
$foo = "\n";
chop($foo, at foo);
-is (join('',$foo, at foo), 'hi there!');
+is (join('',$foo, at foo), 'hi there!', 'chop on list reduces one-character element to an empty string');
$_ = "foo\n\n";
$got = chomp();
-ok ($got == 1) or print "# got $got\n";
-is ($_, "foo\n");
+is($got, 1, 'check return value when chomp string ending with two newlines; $/ is set to default of one newline');
+is ($_, "foo\n", 'chomp string ending with two newlines while $/ is set to one newline' );
$_ = "foo\n";
$got = chomp();
-ok ($got == 1) or print "# got $got\n";
-is ($_, "foo");
+is($got, 1, 'check return value chomp string ending with one newline while $/ is set to a newline');
+is ($_, "foo", 'test typical use of chomp; chomp a string ending in a single newline while $/ is set to default of one newline');
$_ = "foo";
$got = chomp();
-ok ($got == 0) or print "# got $got\n";
-is ($_, "foo");
+is($got, 0, 'check return value when chomp a string that does not end with current value of $/, 0 should be returned');
+is ($_, "foo", 'chomp a string that does not end with the current value of $/');
$_ = "foo";
$/ = "oo";
$got = chomp();
-ok ($got == 2) or print "# got $got\n";
-is ($_, "f");
+is ($got, "2", 'check return value when chomp string with $/ consisting of more than one character, and with the ending of the string matching $/');
+is ($_, "f", 'chomp a string when $/ consists of two characters that are at the end of the string, check that chomped string contains remnant of original string');
$_ = "bar";
$/ = "oo";
$got = chomp();
-ok ($got == 0) or print "# got $got\n";
-is ($_, "bar");
+is($got, "0", 'check return value when call chomp with $/ consisting of more than one character, and with the ending of the string NOT matching $/');
+is ($_, "bar", 'chomp a string when $/ consists of two characters that are NOT at the end of the string');
$_ = "f\n\n\n\n\n";
$/ = "";
$got = chomp();
-ok ($got == 5) or print "# got $got\n";
-is ($_, "f");
+is ($got, 5, 'check return value when chomp in paragraph mode on string ending with 5 newlines');
+is ($_, "f", 'chomp in paragraph mode on string ending with 5 newlines');
$_ = "f\n\n";
$/ = "";
$got = chomp();
-ok ($got == 2) or print "# got $got\n";
-is ($_, "f");
+is ($got, 2, 'check return value when chomp in paragraph mode on string ending with 2 newlines');
+is ($_, "f", 'chomp in paragraph mode on string ending with 2 newlines');
$_ = "f\n";
$/ = "";
$got = chomp();
-ok ($got == 1) or print "# got $got\n";
-is ($_, "f");
+is ($got, 1, 'check return value when chomp in paragraph mode on string ending with 1 newline');
+is ($_, "f", 'chomp in paragraph mode on string ending with 1 newlines');
$_ = "f";
$/ = "";
$got = chomp();
-ok ($got == 0) or print "# got $got\n";
-is ($_, "f");
+is ($got, 0, 'check return value when chomp in paragraph mode on string ending with no newlines');
+is ($_, "f", 'chomp in paragraph mode on string lacking trailing newlines');
$_ = "xx";
$/ = "xx";
$got = chomp();
-ok ($got == 2) or print "# got $got\n";
-is ($_, "");
+is ($got, 2, 'check return value when chomp string that consists solely of current value of $/');
+is ($_, "", 'chomp on string that consists solely of current value of $/; check that empty string remains');
$_ = "axx";
$/ = "xx";
$got = chomp();
-ok ($got == 2) or print "# got $got\n";
-is ($_, "a");
+is ($got, 2, 'check return value when chomp string that ends with current value of $/. $/ contains two characters');
+is ($_, "a", 'check that when chomp string that ends with currnt value of $/, the part of original string that wasn\'t in $/ remains');
$_ = "axx";
$/ = "yy";
$got = chomp();
-ok ($got == 0) or print "# got $got\n";
-is ($_, "axx");
+is ($got, 0, 'check return value when chomp string that does not end with $/');
+is ($_, "axx", 'chomp a string that does not end with $/, the entire string should remain intact');
# This case once mistakenly behaved like paragraph mode.
$_ = "ab\n";
$/ = \3;
$got = chomp();
-ok ($got == 0) or print "# got $got\n";
-is ($_, "ab\n");
+is ($got, 0, 'check return value when call chomp with $_ = "ab\\n", $/ = \3' );
+is ($_, "ab\n", 'chomp with $_ = "ab\\n", $/ = \3' );
# Go Unicode.
$_ = "abc\x{1234}";
chop;
-is ($_, "abc", "Go Unicode");
+is ($_, "abc", 'Go Unicode');
$_ = "abc\x{1234}d";
chop;
Property changes on: trunk/contrib/perl/t/op/chop.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/chr.t
===================================================================
--- trunk/contrib/perl/t/op/chr.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/chr.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -6,7 +6,7 @@
require "test.pl";
}
-plan tests => 34;
+plan tests => 42;
# Note that t/op/ord.t already tests for chr() <-> ord() rountripping.
@@ -31,6 +31,22 @@
is(chr(-3.0), "\xFD");
}
+# Make sure -1 is treated the same way when coming from a tied variable
+sub TIESCALAR {bless[]}
+sub STORE { $_[0][0] = $_[1] }
+sub FETCH { $_[0][0] }
+tie $t, "";
+$t = -1; is chr $t, chr -1, 'chr $tied when $tied is -1';
+$t = -2; is chr $t, chr -2, 'chr $tied when $tied is -2';
+$t = -1.1; is chr $t, chr -1.1, 'chr $tied when $tied is -1.1';
+$t = -2.2; is chr $t, chr -2.2, 'chr $tied when $tied is -2.2';
+
+# And that stringy scalars are treated likewise
+is chr "-1", chr -1, 'chr "-1" eq chr -1';
+is chr "-2", chr -2, 'chr "-2" eq chr -2';
+is chr "-1.1", chr -1.1, 'chr "-1.1" eq chr -1.1';
+is chr "-2.2", chr -2.2, 'chr "-2.2" eq chr -2.2';
+
# Check UTF-8 (not UTF-EBCDIC).
SKIP: {
skip "no UTF-8 on EBCDIC", 21 if chr(193) eq 'A';
@@ -63,3 +79,4 @@
is(hexes(0x1FFFFF), "f7 bf bf bf"); # last four byte encoding
is(hexes(0x200000), "f8 88 80 80 80");
}
+
Property changes on: trunk/contrib/perl/t/op/chr.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/closure.t
===================================================================
--- trunk/contrib/perl/t/op/closure.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/closure.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -9,10 +9,10 @@
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
+ require './test.pl';
}
use Config;
-require './test.pl';
my $i = 1;
sub foo { $i = shift if @_; $i }
@@ -654,19 +654,21 @@
}
sub f {
- my $x if $_[0];
- sub { \$x }
+ my $x;
+ format ff =
+@
+$r = \$x
+.
}
{
- f(1);
- my $c1= f(0);
- my $c2= f(0);
-
- my $r1 = $c1->();
- my $r2 = $c2->();
+ fileno ff;
+ write ff;
+ my $r1 = $r;
+ write ff;
+ my $r2 = $r;
isnt($r1, $r2,
- "don't copy a stale lexical; crate a fresh undef one instead");
+ "don't copy a stale lexical; create a fresh undef one instead");
}
# [perl #63540] Don’t treat sub { if(){.....}; "constant" } as a constant
@@ -683,4 +685,134 @@
is($blonk_was_called, 1, 'RT #63540');
}
+# test PL_cv_has_eval. Any anon sub that could conceivably contain an
+# eval, should be marked as cloneable
+
+{
+
+ my @s;
+ push @s, sub { eval '1' } for 1,2;
+ isnt($s[0], $s[1], "cloneable with eval");
+ @s = ();
+ push @s, sub { use re 'eval'; my $x; s/$x/1/; } for 1,2;
+ isnt($s[0], $s[1], "cloneable with use re eval");
+ @s = ();
+ push @s, sub { s/1/1/ee; } for 1,2;
+ isnt($s[0], $s[1], "cloneable with //ee");
+}
+
+# [perl #89544]
+{
+ sub trace::DESTROY {
+ push @trace::trace, "destroyed";
+ }
+
+ my $outer2 = sub {
+ my $a = bless \my $dummy, trace::;
+
+ my $outer = sub {
+ my $b;
+ my $inner = sub {
+ undef $b;
+ };
+
+ $a;
+
+ $inner
+ };
+
+ $outer->()
+ };
+
+ my $inner = $outer2->();
+ is "@trace::trace", "destroyed",
+ 'closures only close over named variables, not entire subs';
+}
+
+# [perl #113812] Closure prototypes with no CvOUTSIDE (crash caused by the
+# fix for #89544)
+do "./op/closure_test.pl" or die $@||$!;
+is $closure_test::s2->()(), '10 cubes',
+ 'cloning closure proto with no CvOUTSIDE';
+
+# Also brought up in #113812: Even when being cloned, a closure prototype
+# might have its CvOUTSIDE pointing to the wrong thing.
+{
+ package main::113812;
+ $s1 = sub {
+ my $x = 3;
+ $s2 = sub {
+ $x;
+ $s3 = sub { $x };
+ };
+ };
+ $s1->();
+ undef &$s1; # frees $s2’s prototype, causing the $s3 proto to have its
+ # CvOUTSIDE point to $s1
+ ::is $s2->()(), 3, 'cloning closure proto whose CvOUTSIDE has changed';
+}
+
+# This should never emit two different values:
+# print $x, "\n";
+# print sub { $x }->(), "\n";
+# This test case started to do just that in commit 33894c1aa3e
+# (5.10.1/5.12.0):
+sub mosquito {
+ my $x if @_;
+ return if @_;
+
+ $x = 17;
+ is sub { $x }->(), $x, 'closing over stale var in 2nd sub call';
+}
+mosquito(1);
+mosquito;
+# And this case in commit adf8f095c588 (5.14):
+sub anything {
+ my $x;
+ sub gnat {
+ $x = 3;
+ is sub { $x }->(), $x,
+ 'closing over stale var before 1st sub call';
+ }
+}
+gnat();
+
+# [perl #114018] Similar to the above, but with string eval
+sub staleval {
+ my $x if @_;
+ return if @_;
+
+ $x = 3;
+ is eval '$x', $x, 'eval closing over stale var in active sub';
+ return #
+}
+staleval 1;
+staleval;
+
+# [perl #114888]
+# Test that closure creation localises PL_comppad_name properly. Usually
+# at compile time a BEGIN block will localise PL_comppad_name for use, so
+# pp_anoncode can mess with it without any visible effects.
+# But inside a source filter, it affects the directly enclosing compila-
+# tion scope.
+SKIP: {
+ skip_if_miniperl("no XS on miniperl (for source filters)");
+ fresh_perl_is <<' [perl #114888]', "ok\n", {stderr=>1},
+ use strict;
+ BEGIN {
+ package Foo;
+ use Filter::Util::Call;
+ sub import { filter_add( sub {
+ my $status = filter_read();
+ sub { $status };
+ $status;
+ })}
+ Foo->import
+ }
+ my $x = "ok\n"; # stores $x in the wrong padnamelist
+ print $x; # cannot find it - strict violation
+ [perl #114888]
+ 'closures in source filters do not interfere with pad names';
+}
+
done_testing();
Property changes on: trunk/contrib/perl/t/op/closure.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Copied: trunk/contrib/perl/t/op/closure_test.pl (from rev 6437, vendor/perl/5.18.1/t/op/closure_test.pl)
===================================================================
--- trunk/contrib/perl/t/op/closure_test.pl (rev 0)
+++ trunk/contrib/perl/t/op/closure_test.pl 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,10 @@
+# This file exists to test closure prototypes with no CvOUTSIDE. Only
+# by putting this in a separate file can we get a sub (this file’s
+# main CV) with no CvOUTSIDE. When the outer sub is freed, the inner
+# subs also get CvOUTSIDE set to null.
+
+ my $x;
+ $closure_test::s2 = sub {
+ $x;
+ sub { $x; '10 cubes' };
+ };
Index: trunk/contrib/perl/t/op/cmp.t
===================================================================
--- trunk/contrib/perl/t/op/cmp.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/cmp.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/cmp.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/t/op/concat.t
===================================================================
--- trunk/contrib/perl/t/op/concat.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/concat.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/concat.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/concat2.t
===================================================================
--- trunk/contrib/perl/t/op/concat2.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/concat2.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -9,11 +9,13 @@
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
- skip_all_if_miniperl("no dynamic loading on miniperl, no Encode");
}
-plan 1;
+plan 3;
+SKIP: {
+skip_if_miniperl("no dynamic loading on miniperl, no Encode", 1);
+skip('encoding pragma is deprecated', 1) if $] >= 5.017009;
fresh_perl_is <<'end', "ok\n", {},
use encoding 'utf8';
map { "a" . $a } ((1)x5000);
@@ -20,3 +22,35 @@
print "ok\n";
end
"concat does not lose its stack pointer after utf8 upgrade [perl #78674]";
+}
+
+# This test is in the file because overload.pm uses concatenation.
+{ package o; use overload '""' => sub { $_[0][0] } }
+$x = bless[chr 256],o::;
+"$x";
+$x->[0] = "\xff";
+$x.= chr 257;
+$x.= chr 257;
+is $x, "\xff\x{101}\x{101}", '.= is not confused by changing utf8ness';
+
+# Ops should not share the same TARG between recursion levels. This may
+# affect other ops, too, but concat seems more susceptible to this than
+# others, since it can call itself recursively. (Where else would I put
+# this test, anyway?)
+fresh_perl_is <<'end', "tmp\ntmp\n", {},
+ sub canonpath {
+ my ($path) = @_;
+ my $node = '';
+ $path =~ s|/\z||;
+ return "$node$path";
+ }
+
+ {
+ package Path::Class::Dir;
+ use overload q[""] => sub { ::canonpath("tmp") };
+ }
+
+ print canonpath("tmp"), "\n";
+ print canonpath(bless {},"Path::Class::Dir"), "\n";
+end
+ "recursive concat does not share TARGs";
Property changes on: trunk/contrib/perl/t/op/concat2.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/cond.t
===================================================================
--- trunk/contrib/perl/t/op/cond.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/cond.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,10 +1,16 @@
#!./perl
-print "1..4\n";
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require './test.pl';
+}
-print 1 ? "ok 1\n" : "not ok 1\n"; # compile time
-print 0 ? "not ok 2\n" : "ok 2\n";
+is( 1 ? 1 : 0, 1, 'compile time, true' );
+is( 0 ? 0 : 1, 1, 'compile time, false' );
$x = 1;
-print $x ? "ok 3\n" : "not ok 3\n"; # run time
-print !$x ? "not ok 4\n" : "ok 4\n";
+is( $x ? 1 : 0, 1, 'run time, true');
+is( !$x ? 0 : 1, 1, 'run time, false');
+
+done_testing();
Property changes on: trunk/contrib/perl/t/op/cond.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/op/context.t
===================================================================
--- trunk/contrib/perl/t/op/context.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/context.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/context.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/op/coreamp.t (from rev 6437, vendor/perl/5.18.1/t/op/coreamp.t)
===================================================================
--- trunk/contrib/perl/t/op/coreamp.t (rev 0)
+++ trunk/contrib/perl/t/op/coreamp.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,1052 @@
+#!./perl
+
+# This file tests the results of calling subroutines in the CORE::
+# namespace with ampersand syntax. In other words, it tests the bodies of
+# the subroutines themselves, not the ops that they might inline themselves
+# as when called as barewords.
+
+# Other tests for CORE subs are in coresubs.t
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = qw(. ../lib);
+ require "test.pl";
+ $^P |= 0x100;
+}
+
+no warnings 'experimental::smartmatch';
+
+sub lis($$;$) {
+ &is(map(@$_ ? "[@{[map $_//'~~u~~', @$_]}]" : 'nought', @_[0,1]), $_[2]);
+}
+
+package hov {
+ use overload '%{}' => sub { +{} }
+}
+package sov {
+ use overload '${}' => sub { \my $x }
+}
+
+my %op_desc = (
+ evalbytes=> 'eval "string"',
+ join => 'join or string',
+ pos => 'match position',
+ prototype=> 'subroutine prototype',
+ readline => '<HANDLE>',
+ readpipe => 'quoted execution (``, qx)',
+ reset => 'symbol reset',
+ ref => 'reference-type operator',
+ undef => 'undef operator',
+);
+sub op_desc($) {
+ return $op_desc{$_[0]} || $_[0];
+}
+
+
+# This tests that the &{} syntax respects the number of arguments implied
+# by the prototype, plus some extra tests for the (_) prototype.
+sub test_proto {
+ my($o) = shift;
+
+ # Create an alias, for the caller’s convenience.
+ *{"my$o"} = \&{"CORE::$o"};
+
+ my $p = prototype "CORE::$o";
+ $p = '$;$' if $p eq '$_';
+
+ if ($p eq '') {
+ $tests ++;
+
+ eval " &CORE::$o(1) ";
+ like $@, qr/^Too many arguments for $o at /, "&$o with too many args";
+
+ }
+ elsif ($p =~ /^_;?\z/) {
+ $tests ++;
+
+ eval " &CORE::$o(1,2) ";
+ my $desc = quotemeta op_desc($o);
+ like $@, qr/^Too many arguments for $desc at /,
+ "&$o with too many args";
+
+ if (!@_) { return }
+
+ $tests += 6;
+
+ my($in,$out) = @_; # for testing implied $_
+
+ # Since we have $in and $out values, we might as well test basic amper-
+ # sand calls, too.
+
+ is &{"CORE::$o"}($in), $out, "&$o";
+ lis [&{"CORE::$o"}($in)], [$out], "&$o in list context";
+
+ $_ = $in;
+ is &{"CORE::$o"}(), $out, "&$o with no args";
+
+ # Since there is special code to deal with lexical $_, make sure it
+ # works in all cases.
+ undef $_;
+ {
+ no warnings 'experimental::lexical_topic';
+ my $_ = $in;
+ is &{"CORE::$o"}(), $out, "&$o with no args uses lexical \$_";
+ }
+ # Make sure we get the right pad under recursion
+ my $r;
+ $r = sub {
+ if($_[0]) {
+ no warnings 'experimental::lexical_topic';
+ my $_ = $in;
+ is &{"CORE::$o"}(), $out,
+ "&$o with no args uses the right lexical \$_ under recursion";
+ }
+ else {
+ &$r(1)
+ }
+ };
+ &$r(0);
+ no warnings 'experimental::lexical_topic';
+ my $_ = $in;
+ eval {
+ is "CORE::$o"->(), $out, "&$o with the right lexical \$_ in an eval"
+ };
+ }
+ elsif ($p =~ '^;([$*]+)\z') { # ;$ ;* ;$$ etc.
+ my $maxargs = length $1;
+ $tests += 1;
+ eval " &CORE::$o((1)x($maxargs+1)) ";
+ my $desc = quotemeta op_desc($o);
+ like $@, qr/^Too many arguments for $desc at /,
+ "&$o with too many args";
+ }
+ elsif ($p =~ '^([$*]+);?\z') { # Fixed-length $$$ or ***
+ my $args = length $1;
+ $tests += 2;
+ my $desc = quotemeta op_desc($o);
+ eval " &CORE::$o((1)x($args-1)) ";
+ like $@, qr/^Not enough arguments for $desc at /, "&$o w/too few args";
+ eval " &CORE::$o((1)x($args+1)) ";
+ like $@, qr/^Too many arguments for $desc at /, "&$o w/too many args";
+ }
+ elsif ($p =~ '^([$*]+);([$*]+)\z') { # Variable-length $$$ or ***
+ my $minargs = length $1;
+ my $maxargs = $minargs + length $2;
+ $tests += 2;
+ eval " &CORE::$o((1)x($minargs-1)) ";
+ like $@, qr/^Not enough arguments for $o at /, "&$o with too few args";
+ eval " &CORE::$o((1)x($maxargs+1)) ";
+ like $@, qr/^Too many arguments for $o at /, "&$o with too many args";
+ }
+ elsif ($p eq '_;$') {
+ $tests += 1;
+
+ eval " &CORE::$o(1,2,3) ";
+ like $@, qr/^Too many arguments for $o at /, "&$o with too many args";
+ }
+ elsif ($p eq '@') {
+ # Do nothing, as we cannot test for too few or too many arguments.
+ }
+ elsif ($p =~ '^[$*;]+@\z') {
+ $tests ++;
+ $p =~ ';@';
+ my $minargs = $-[0];
+ eval " &CORE::$o((1)x($minargs-1)) ";
+ my $desc = quotemeta op_desc($o);
+ like $@, qr/^Not enough arguments for $desc at /,
+ "&$o with too few args";
+ }
+ elsif ($p =~ /^\*\\\$\$(;?)\$\z/) { # *\$$$ and *\$$;$
+ $tests += 5;
+
+ eval "&CORE::$o(1,1,1,1,1)";
+ like $@, qr/^Too many arguments for $o at /,
+ "&$o with too many args";
+ eval " &CORE::$o((1)x(\$1?2:3)) ";
+ like $@, qr/^Not enough arguments for $o at /,
+ "&$o with too few args";
+ eval " &CORE::$o(1,[],1,1) ";
+ like $@, qr/^Type of arg 2 to &CORE::$o must be scalar reference at /,
+ "&$o with array ref arg";
+ eval " &CORE::$o(1,1,1,1) ";
+ like $@, qr/^Type of arg 2 to &CORE::$o must be scalar reference at /,
+ "&$o with scalar arg";
+ eval " &CORE::$o(1,bless([], 'sov'),1,1) ";
+ like $@, qr/^Type of arg 2 to &CORE::$o must be scalar reference at /,
+ "&$o with non-scalar arg w/scalar overload (which does not count)";
+ }
+ elsif ($p =~ /^\\%\$*\z/) { # \% and \%$$
+ $tests += 5;
+
+ eval "&CORE::$o(" . join(",", (1) x length $p) . ")";
+ like $@, qr/^Too many arguments for $o at /,
+ "&$o with too many args";
+ eval " &CORE::$o(" . join(",", (1) x (length($p)-2)) . ") ";
+ like $@, qr/^Not enough arguments for $o at /,
+ "&$o with too few args";
+ my $moreargs = ",1" x (length($p) - 2);
+ eval " &CORE::$o([]$moreargs) ";
+ like $@, qr/^Type of arg 1 to &CORE::$o must be hash reference at /,
+ "&$o with array ref arg";
+ eval " &CORE::$o(*foo$moreargs) ";
+ like $@, qr/^Type of arg 1 to &CORE::$o must be hash reference at /,
+ "&$o with typeglob arg";
+ eval " &CORE::$o(bless([], 'hov')$moreargs) ";
+ like $@, qr/^Type of arg 1 to &CORE::$o must be hash reference at /,
+ "&$o with non-hash arg with hash overload (which does not count)";
+ }
+ elsif ($p =~ /^(;)?\\\[(\$\@%&?\*)](\$\@)?\z/) {
+ $tests += 3;
+
+ unless ($3) {
+ $tests ++;
+ eval " &CORE::$o(1,2) ";
+ like $@, qr/^Too many arguments for ${\op_desc($o)} at /,
+ "&$o with too many args";
+ }
+ unless ($1) {
+ $tests ++;
+ eval { &{"CORE::$o"}($3 ? 1 : ()) };
+ like $@, qr/^Not enough arguments for $o at /,
+ "&$o with too few args";
+ }
+ my $more_args = $3 ? ',1' : '';
+ eval " &CORE::$o(2$more_args) ";
+ like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one of(?x:
+ ) \[\Q$2\E] at /,
+ "&$o with non-ref arg";
+ eval " &CORE::$o(*STDOUT{IO}$more_args) ";
+ like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one of(?x:
+ ) \[\Q$2\E] at /,
+ "&$o with ioref arg";
+ my $class = ref *DATA{IO};
+ eval " &CORE::$o(bless(*DATA{IO}, 'hov')$more_args) ";
+ like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one of(?x:
+ ) \[\Q$2\E] at /,
+ "&$o with ioref arg with hash overload (which does not count)";
+ bless *DATA{IO}, $class;
+ if (do {$2 !~ /&/}) {
+ $tests++;
+ eval " &CORE::$o(\\&scriggle$more_args) ";
+ like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one (?x:
+ )of \[\Q$2\E] at /,
+ "&$o with coderef arg";
+ }
+ }
+ elsif ($p eq ';\[$*]') {
+ $tests += 4;
+
+ my $desc = quotemeta op_desc($o);
+ eval " &CORE::$o(1,2) ";
+ like $@, qr/^Too many arguments for $desc at /,
+ "&$o with too many args";
+ eval " &CORE::$o([]) ";
+ like $@, qr/^Type of arg 1 to &CORE::$o must be scalar reference at /,
+ "&$o with array ref arg";
+ eval " &CORE::$o(1) ";
+ like $@, qr/^Type of arg 1 to &CORE::$o must be scalar reference at /,
+ "&$o with scalar arg";
+ eval " &CORE::$o(bless([], 'sov')) ";
+ like $@, qr/^Type of arg 1 to &CORE::$o must be scalar reference at /,
+ "&$o with non-scalar arg w/scalar overload (which does not count)";
+ }
+
+ else {
+ die "Please add tests for the $p prototype";
+ }
+}
+
+# Test that &CORE::foo calls without parentheses (no new @_) can handle the
+# total absence of any @_ without crashing.
+undef *_;
+&CORE::wantarray;
+$tests++;
+pass('no crash with &CORE::foo when *_{ARRAY} is undef');
+
+test_proto '__FILE__';
+test_proto '__LINE__';
+test_proto '__PACKAGE__';
+test_proto '__SUB__';
+
+is file(), 'frob' , '__FILE__ does check its caller' ; ++ $tests;
+is line(), 5 , '__LINE__ does check its caller' ; ++ $tests;
+is pakg(), 'stribble', '__PACKAGE__ does check its caller'; ++ $tests;
+sub __SUB__test { &my__SUB__ }
+is __SUB__test, \&__SUB__test, '&__SUB__'; ++ $tests;
+
+test_proto 'abs', -5, 5;
+
+test_proto 'accept';
+$tests += 6; eval q{
+ is &CORE::accept(qw{foo bar}), undef, "&accept";
+ lis [&{"CORE::accept"}(qw{foo bar})], [undef], "&accept in list context";
+
+ &myaccept(my $foo, my $bar);
+ is ref $foo, 'GLOB', 'CORE::accept autovivifies its first argument';
+ is $bar, undef, 'CORE::accept does not autovivify its second argument';
+ use strict;
+ undef $foo;
+ eval { 'myaccept'->($foo, $bar) };
+ like $@, qr/^Can't use an undefined value as a symbol reference at/,
+ 'CORE::accept will not accept undef 2nd arg under strict';
+ is ref $foo, 'GLOB', 'CORE::accept autovivs its first arg under strict';
+};
+
+test_proto 'alarm';
+test_proto 'atan2';
+
+test_proto 'bind';
+$tests += 3;
+is &CORE::bind('foo', 'bear'), undef, "&bind";
+lis [&CORE::bind('foo', 'bear')], [undef], "&bind in list context";
+eval { &mybind(my $foo, "bear") };
+like $@, qr/^Bad symbol for filehandle at/,
+ 'CORE::bind dies with undef first arg';
+
+test_proto 'binmode';
+$tests += 3;
+is &CORE::binmode(qw[foo bar]), undef, "&binmode";
+lis [&CORE::binmode(qw[foo bar])], [undef], "&binmode in list context";
+is &mybinmode(foo), undef, '&binmode with one arg';
+
+test_proto 'bless';
+$tests += 3;
+like &CORE::bless([],'parcel'), qr/^parcel=ARRAY/, "&bless";
+like join(" ", &CORE::bless([],'parcel')),
+ qr/^parcel=ARRAY(?!.* )/, "&bless in list context";
+like &mybless([]), qr/^main=ARRAY/, '&bless with one arg';
+
+test_proto 'break';
+{ $tests ++;
+ my $tmp;
+ CORE::given(1) {
+ CORE::when(1) {
+ &mybreak;
+ $tmp = 'bad';
+ }
+ }
+ is $tmp, undef, '&break';
+}
+
+test_proto 'caller';
+$tests += 4;
+sub caller_test {
+ is scalar &CORE::caller, 'hadhad', '&caller';
+ is scalar &CORE::caller(1), 'main', '&caller(1)';
+ lis [&CORE::caller], [caller], '&caller in list context';
+ # The last element of caller in list context is a hint hash, which
+ # may be a different hash for caller vs &CORE::caller, so an eq com-
+ # parison (which lis() uses for convenience) won’t work. So just
+ # pop the last element, since the rest are sufficient to prove that
+ # &CORE::caller works.
+ my @ampcaller = &CORE::caller(1);
+ my @caller = caller(1);
+ pop @ampcaller; pop @caller;
+ lis \@ampcaller, \@caller, '&caller(1) in list context';
+}
+sub {
+ package hadhad;
+ ::caller_test();
+}->();
+
+test_proto 'chmod';
+$tests += 3;
+is &CORE::chmod(), 0, '&chmod with no args';
+is &CORE::chmod(0666), 0, '&chmod';
+lis [&CORE::chmod(0666)], [0], '&chmod in list context';
+
+test_proto 'chown';
+$tests += 4;
+is &CORE::chown(), 0, '&chown with no args';
+is &CORE::chown(1), 0, '&chown with 1 arg';
+is &CORE::chown(1,2), 0, '&chown';
+lis [&CORE::chown(1,2)], [0], '&chown in list context';
+
+test_proto 'chr', 5, "\5";
+test_proto 'chroot';
+
+test_proto 'close';
+{
+ last if is_miniperl;
+ $tests += 3;
+
+ open my $fh, ">", \my $buffalo;
+ print $fh 'an address in the outskirts of Jersey';
+ ok &CORE::close($fh), '&CORE::close retval';
+ print $fh 'lalala';
+ is $buffalo, 'an address in the outskirts of Jersey',
+ 'effect of &CORE::close';
+ # This has to be a separate variable from $fh, as re-using the same
+ # variable can cause the tests to pass by accident. That actually hap-
+ # pened during developement, because the second close() was reading
+ # beyond the end of the stack and finding a $fh left over from before.
+ open my $fh2, ">", \($buffalo = '');
+ select+(select($fh2), do {
+ print "Nasusiro Tokasoni";
+ &CORE::close();
+ print "jfd";
+ is $buffalo, "Nasusiro Tokasoni", '&CORE::close with no args';
+ })[0];
+}
+lis [&CORE::close('tototootot')], [''], '&close in list context'; ++$tests;
+
+test_proto 'closedir';
+$tests += 2;
+is &CORE::closedir(foo), undef, '&CORE::closedir';
+lis [&CORE::closedir(foo)], [undef], '&CORE::closedir in list context';
+
+test_proto 'connect';
+$tests += 2;
+is &CORE::connect('foo','bar'), undef, '&connect';
+lis [&myconnect('foo','bar')], [undef], '&connect in list context';
+
+test_proto 'continue';
+$tests ++;
+CORE::given(1) {
+ CORE::when(1) {
+ &mycontinue();
+ }
+ pass "&continue";
+}
+
+test_proto 'cos';
+test_proto 'crypt';
+
+test_proto 'dbmclose';
+test_proto 'dbmopen';
+{
+ last unless eval { require AnyDBM_File };
+ $tests ++;
+ my $filename = tempfile();
+ &mydbmopen(\my %db, $filename, 0666);
+ $db{1} = 2; $db{3} = 4;
+ &mydbmclose(\%db);
+ is scalar keys %db, 0, '&dbmopen and &dbmclose';
+}
+
+test_proto 'die';
+eval { dier('quinquangle') };
+is $@, "quinquangle at frob line 6.\n", '&CORE::die'; $tests ++;
+
+test_proto $_ for qw(
+ endgrent endhostent endnetent endprotoent endpwent endservent
+);
+
+test_proto 'evalbytes';
+$tests += 4;
+{
+ chop(my $upgraded = "use utf8; '\xc4\x80'" . chr 256);
+ is &myevalbytes($upgraded), chr 256, '&evalbytes';
+ # Test hints
+ require strict;
+ strict->import;
+ &myevalbytes('
+ is someone, "someone", "run-time hint bits do not leak into &evalbytes"
+ ');
+ use strict;
+ BEGIN { $^H{coreamp} = 42 }
+ $^H{coreamp} = 75;
+ &myevalbytes('
+ BEGIN {
+ is $^H{coreamp}, 42, "compile-time hh propagates into &evalbytes";
+ }
+ ${"frobnicate"}
+ ');
+ like $@, qr/strict/, 'compile-time hint bits propagate into &evalbytes';
+}
+
+test_proto 'exit';
+$tests ++;
+is runperl(prog => '&CORE::exit; END { print qq-ok\n- }'), "ok\n",
+ '&exit with no args';
+
+test_proto 'fork';
+
+test_proto 'formline';
+$tests += 3;
+is &myformline(' @<<< @>>>', 1, 2), 1, '&myformline retval';
+is $^A, ' 1 2', 'effect of &myformline';
+lis [&myformline('@')], [1], '&myformline in list context';
+
+test_proto 'exp';
+
+test_proto 'fc';
+$tests += 2;
+{
+ my $sharp_s = "\xdf";
+ is &myfc($sharp_s), $sharp_s, '&fc, no unicode_strings';
+ use feature 'unicode_strings';
+ is &myfc($sharp_s), "ss", '&fc, unicode_strings';
+}
+
+test_proto 'fcntl';
+
+test_proto 'fileno';
+$tests += 2;
+is &CORE::fileno(\*STDIN), fileno STDIN, '&CORE::fileno';
+lis [&CORE::fileno(\*STDIN)], [fileno STDIN], '&CORE::fileno in list cx';
+
+test_proto 'flock';
+test_proto 'fork';
+
+test_proto 'getc';
+{
+ last if is_miniperl;
+ $tests += 3;
+ local *STDIN;
+ open my $fh, "<", \(my $buf='falo');
+ open STDIN, "<", \(my $buf2 = 'bison');
+ is &mygetc($fh), 'f', '&mygetc';
+ is &mygetc(), 'b', '&mygetc with no args';
+ lis [&mygetc($fh)], ['a'], '&mygetc in list context';
+}
+
+test_proto "get$_" for qw '
+ grent grgid grnam hostbyaddr hostbyname hostent login netbyaddr netbyname
+ netent peername
+';
+
+test_proto 'getpgrp';
+eval {&mygetpgrp()};
+pass '&getpgrp with no args does not crash'; $tests++;
+
+test_proto "get$_" for qw '
+ ppid priority protobyname protobynumber protoent
+ pwent pwnam pwuid servbyname servbyport servent sockname sockopt
+';
+
+# Make sure the following tests test what we think they are testing.
+ok ! $CORE::{glob}, '*CORE::glob not autovivified yet'; $tests ++;
+{
+ # Make sure ck_glob does not respect the override when &CORE::glob is
+ # autovivified (by test_proto).
+ local *CORE::GLOBAL::glob = sub {};
+ test_proto 'glob';
+}
+$_ = "t/*.t";
+ at _ = &myglob($_);
+is join($", &myglob()), "@_", '&glob without arguments';
+is join($", &myglob("t/*.t")), "@_", '&glob with an arg';
+$tests += 2;
+
+test_proto 'gmtime';
+&CORE::gmtime;
+pass '&gmtime without args does not crash'; ++$tests;
+
+test_proto 'hex', ff=>255;
+
+test_proto 'index';
+$tests += 3;
+is &myindex("foffooo","o",2),4,'&index';
+lis [&myindex("foffooo","o",2)],[4],'&index in list context';
+is &myindex("foffooo","o"),1,'&index with 2 args';
+
+test_proto 'int', 1.5=>1;
+test_proto 'ioctl';
+
+test_proto 'join';
+$tests += 2;
+is &myjoin('a','b','c'), 'bac', '&join';
+lis [&myjoin('a','b','c')], ['bac'], '&join in list context';
+
+test_proto 'kill'; # set up mykill alias
+if ($^O ne 'riscos') {
+ $tests ++;
+ ok( &mykill(0, $$), '&kill' );
+}
+
+test_proto 'lc', 'A', 'a';
+test_proto 'lcfirst', 'AA', 'aA';
+test_proto 'length', 'aaa', 3;
+test_proto 'link';
+test_proto 'listen';
+
+test_proto 'localtime';
+&CORE::localtime;
+pass '&localtime without args does not crash'; ++$tests;
+
+test_proto 'lock';
+$tests += 6;
+is \&mylock(\$foo), \$foo, '&lock retval when passed a scalar ref';
+lis [\&mylock(\$foo)], [\$foo], '&lock in list context';
+is &mylock(\@foo), \@foo, '&lock retval when passed an array ref';
+is &mylock(\%foo), \%foo, '&lock retval when passed a ash ref';
+is &mylock(\&foo), \&foo, '&lock retval when passed a code ref';
+is \&mylock(\*foo), \*foo, '&lock retval when passed a glob ref';
+
+test_proto 'log';
+
+test_proto 'mkdir';
+# mkdir is tested with implicit $_ at the end, to make the test easier
+
+test_proto "msg$_" for qw( ctl get rcv snd );
+
+test_proto 'not';
+$tests += 2;
+is &mynot(1), !1, '¬';
+lis [&mynot(0)], [!0], '¬ in list context';
+
+test_proto 'oct', '666', 438;
+
+test_proto 'open';
+$tests += 5;
+$file = 'test.pl';
+ok &myopen('file'), '&open with 1 arg' or warn "1-arg open: $!";
+like <file>, qr|^#|, 'result of &open with 1 arg';
+close file;
+{
+ ok &myopen(my $fh, "test.pl"), 'two-arg &open';
+ ok $fh, '&open autovivifies';
+ like <$fh>, qr '^#', 'result of &open with 2 args';
+ last if is_miniperl;
+ $tests +=2;
+ ok &myopen(my $fh2, "<", \"sharummbles"), 'retval of 3-arg &open';
+ is <$fh2>, 'sharummbles', 'result of three-arg &open';
+}
+
+test_proto 'opendir';
+test_proto 'ord', chr(64), 64;
+
+test_proto 'pack';
+$tests += 2;
+is &mypack("H*", '5065726c'), 'Perl', '&pack';
+lis [&mypack("H*", '5065726c')], ['Perl'], '&pack in list context';
+
+test_proto 'pipe';
+
+test_proto 'pos';
+$tests += 4;
+$_ = "hello";
+pos = 3;
+is &mypos, 3, 'reading &pos without args';
+&mypos = 4;
+is pos, 4, 'writing to &pos without args';
+{
+ my $x = "gubai";
+ pos $x = 3;
+ is &mypos(\$x), 3, 'reading &pos without args';
+ &mypos(\$x) = 4;
+ is pos $x, 4, 'writing to &pos without args';
+}
+
+test_proto 'prototype';
+$tests++;
+is &myprototype(\&myprototype), prototype("CORE::prototype"), '&prototype';
+
+test_proto 'quotemeta', '$', '\$';
+
+test_proto 'rand';
+$tests += 3;
+like &CORE::rand, qr/^0[.\d+-e]*\z/, '&rand';
+unlike join(" ", &CORE::rand), qr/ /, '&rand in list context';
+&cmp_ok(&CORE::rand(78), qw '< 78', '&rand with 1 arg');
+
+test_proto 'read';
+{
+ last if is_miniperl;
+ $tests += 5;
+ open my $fh, "<", \(my $buff = 'morays have their mores');
+ ok &myread($fh, \my $input, 6), '&read with 3 args';
+ is $input, 'morays', 'value read by 3-arg &read';
+ ok &myread($fh, \$input, 6, 6), '&read with 4 args';
+ is $input, 'morays have ', 'value read by 4-arg &read';
+ is +()=&myread($fh, \$input, 6), 1, '&read in list context';
+}
+
+test_proto 'readdir';
+
+test_proto 'readline';
+{
+ local *ARGV = *DATA;
+ $tests ++;
+ is scalar &myreadline,
+ "I wandered lonely as a cloud\n", '&readline w/no args';
+}
+{
+ last if is_miniperl;
+ $tests += 2;
+ open my $fh, "<", \(my $buff = <<END);
+The Recursive Problem
+---------------------
+I have a problem I cannot solve.
+The problem is that I cannot solve it.
+END
+ is &myreadline($fh), "The Recursive Problem\n",
+ '&readline with 1 arg';
+ lis [&myreadline($fh)], [
+ "---------------------\n",
+ "I have a problem I cannot solve.\n",
+ "The problem is that I cannot solve it.\n",
+ ], '&readline in list context';
+}
+
+test_proto 'readlink';
+test_proto 'readpipe';
+test_proto 'recv';
+
+use if !is_miniperl, File::Spec::Functions, qw "catfile";
+use if !is_miniperl, File::Temp, 'tempdir';
+
+test_proto 'rename';
+{
+ last if is_miniperl;
+ $tests ++;
+ my $dir = tempdir(uc cleanup => 1);
+ my $tmpfilenam = catfile $dir, 'aaa';
+ open my $fh, ">", $tmpfilenam or die "cannot open $tmpfilenam: $!";
+ close $fh or die "cannot close $tmpfilenam: $!";
+ &myrename("$tmpfilenam", $tmpfilenam = catfile $dir,'bbb');
+ ok open(my $fh, '>', $tmpfilenam), '&rename';
+}
+
+test_proto 'ref', [], 'ARRAY';
+
+test_proto 'reset';
+$tests += 2;
+my $oncer = sub { "a" =~ m?a? };
+&$oncer;
+&myreset;
+ok &$oncer, '&reset with no args';
+package resettest {
+ $b = "c";
+ $banana = "cream";
+ &::myreset('b');
+ ::lis [$b,$banana],[(undef)x2], '1-arg &reset';
+}
+
+test_proto 'reverse';
+$tests += 2;
+is &myreverse('reward'), 'drawer', '&reverse';
+lis [&myreverse(qw 'dog bites man')], [qw 'man bites dog'],
+ '&reverse in list context';
+
+test_proto 'rewinddir';
+
+test_proto 'rindex';
+$tests += 3;
+is &myrindex("foffooo","o",2),1,'&rindex';
+lis [&myrindex("foffooo","o",2)],[1],'&rindex in list context';
+is &myrindex("foffooo","o"),6,'&rindex with 2 args';
+
+test_proto 'rmdir';
+
+test_proto 'scalar';
+$tests += 2;
+is &myscalar(3), 3, '&scalar';
+lis [&myscalar(3)], [3], '&scalar in list cx';
+
+test_proto 'seek';
+{
+ last if is_miniperl;
+ $tests += 1;
+ open my $fh, "<", \"misled" or die $!;
+ &myseek($fh, 2, 0);
+ is <$fh>, 'sled', '&seek in action';
+}
+
+test_proto 'seekdir';
+
+# Can’t test_proto, as it has none
+$tests += 8;
+*myselect = \&CORE::select;
+is defined prototype &myselect, defined prototype "CORE::select",
+ 'prototype of &select (or lack thereof)';
+is &myselect, select, '&select with no args';
+{
+ my $prev = select;
+ is &myselect(my $fh), $prev, '&select($arg) retval';
+ is lc ref $fh, 'glob', '&select autovivifies';
+ is select=~s/\*//rug, (*$fh."")=~s/\*//rug, '&select selects';
+ select $prev;
+}
+eval { &myselect(1,2) };
+like $@, qr/^Not enough arguments for select system call at /,
+ ,'&myselect($two,$args)';
+eval { &myselect(1,2,3) };
+like $@, qr/^Not enough arguments for select system call at /,
+ ,'&myselect($with,$three,$args)';
+eval { &myselect(1,2,3,4,5) };
+like $@, qr/^Too many arguments for select system call at /,
+ ,'&myselect($a,$total,$of,$five,$args)';
+&myselect((undef)x3,.25);
+# Just have to assume that worked. :-) If we get here, at least it didn’t
+# crash or anything.
+
+test_proto "sem$_" for qw "ctl get op";
+
+test_proto 'send';
+
+test_proto "set$_" for qw '
+ grent hostent netent
+';
+
+test_proto 'setpgrp';
+$tests +=2;
+eval { &mysetpgrp( 0) };
+pass "&setpgrp with one argument";
+eval { &mysetpgrp };
+pass "&setpgrp with no arguments";
+
+test_proto "set$_" for qw '
+ priority protoent pwent servent sockopt
+';
+
+test_proto "shm$_" for qw "ctl get read write";
+test_proto 'shutdown';
+test_proto 'sin';
+test_proto 'sleep';
+test_proto "socket$_" for "", "pair";
+
+test_proto 'sprintf';
+$tests += 2;
+is &mysprintf("%x", 65), '41', '&sprintf';
+lis [&mysprintf("%x", '65')], ['41'], '&sprintf in list context';
+
+test_proto 'sqrt', 4, 2;
+
+test_proto 'srand';
+$tests ++;
+&CORE::srand;
+() = &CORE::srand;
+pass '&srand with no args does not crash';
+
+test_proto 'study';
+
+test_proto 'substr';
+$tests += 5;
+$_ = "abc";
+is &mysubstr($_, 1, 1, "d"), 'b', '4-arg &substr';
+is $_, 'adc', 'what 4-arg &substr does';
+is &mysubstr("abc", 1, 1), 'b', '3-arg &substr';
+is &mysubstr("abc", 1), 'bc', '2-arg &substr';
+&mysubstr($_, 1) = 'long';
+is $_, 'along', 'lvalue &substr';
+
+test_proto 'symlink';
+test_proto 'syscall';
+
+test_proto 'sysopen';
+$tests +=2;
+{
+ &mysysopen(my $fh, 'test.pl', 0);
+ pass '&sysopen does not crash with 3 args';
+ ok $fh, 'sysopen autovivifies';
+}
+
+test_proto 'sysread';
+test_proto 'sysseek';
+test_proto 'syswrite';
+
+test_proto 'tell';
+{
+ $tests += 2;
+ open my $fh, "test.pl" or die "Cannot open test.pl";
+ <$fh>;
+ is &mytell(), tell($fh), '&tell with no args';
+ is &mytell($fh), tell($fh), '&tell with an arg';
+}
+
+test_proto 'telldir';
+
+test_proto 'tie';
+test_proto 'tied';
+$tests += 3;
+{
+ my $fetches;
+ package tier {
+ sub TIESCALAR { bless[] }
+ sub FETCH { ++$fetches }
+ }
+ my $tied;
+ my $obj = &mytie(\$tied, 'tier');
+ is &mytied(\$tied), $obj, '&tie and &tied retvals';
+ () = "$tied";
+ is $fetches, 1, '&tie actually ties';
+ &CORE::untie(\$tied);
+ () = "$tied";
+ is $fetches, 1, '&untie unties';
+}
+
+test_proto 'time';
+$tests += 2;
+like &mytime, '^\d+\z', '&time in scalar context';
+like join('-', &mytime), '^\d+\z', '&time in list context';
+
+test_proto 'times';
+$tests += 2;
+like &mytimes, '^[\d.]+\z', '× in scalar context';
+like join('-',&mytimes), '^[\d.]+-[\d.]+-[\d.]+-[\d.]+\z',
+ '× in list context';
+
+test_proto 'uc', 'aa', 'AA';
+test_proto 'ucfirst', 'aa', "Aa";
+
+test_proto 'umask';
+$tests ++;
+is &myumask, umask, '&umask with no args';
+
+test_proto 'undef';
+$tests += 12;
+is &myundef(), undef, '&undef returns undef';
+lis [&myundef()], [undef], '&undef returns undef in list cx';
+lis [&myundef(\$_)], [undef], '&undef(...) returns undef in list cx';
+is \&myundef(), \undef, '&undef returns the right undef';
+$_ = 'anserine questions';
+&myundef(\$_);
+is $_, undef, '&undef(\$_) undefines $_';
+ at _ = 1..3;
+&myundef(\@_);
+is @_, 0, '&undef(\@_) undefines @_';
+%_ = 1..4;
+&myundef(\%_);
+ok !%_, '&undef(\%_) undefines %_';
+&myundef(\&utf8::valid); # nobody should be using this :-)
+ok !defined &utf8::valid, '&undef(\&foo) undefines &foo';
+ at _ = \*_;
+&myundef;
+is *_{ARRAY}, undef, '@_=\*_, &undef undefines *_';
+ at _ = \*_;
+&myundef(\*_);
+is *_{ARRAY}, undef, '&undef(\*_) undefines *_';
+(&myundef(), @_) = 1..10;
+lis \@_, [2..10], 'list assignment to &undef()';
+ok !defined undef, 'list assignment to &undef() does not affect undef';
+undef @_;
+
+test_proto 'unpack';
+$tests += 2;
+$_ = 'abcd';
+is &myunpack("H*"), '61626364', '&unpack with one arg';
+is &myunpack("H*", "bcde"), '62636465', '&unpack with two arg';
+
+
+test_proto 'untie'; # behaviour already tested along with tie(d)
+
+test_proto 'utime';
+$tests += 2;
+is &myutime(undef,undef), 0, '&utime';
+lis [&myutime(undef,undef)], [0], '&utime in list context';
+
+test_proto 'vec';
+$tests += 3;
+is &myvec("foo", 0, 4), 6, '&vec';
+lis [&myvec("foo", 0, 4)], [6], '&vec in list context';
+$tmp = "foo";
+++&myvec($tmp,0,4);
+is $tmp, "goo", 'lvalue &vec';
+
+test_proto 'wait';
+test_proto 'waitpid';
+
+test_proto 'wantarray';
+$tests += 4;
+my $context;
+my $cx_sub = sub {
+ $context = qw[void scalar list][&mywantarray + defined mywantarray()]
+};
+() = &$cx_sub;
+is $context, 'list', '&wantarray with caller in list context';
+scalar &$cx_sub;
+is($context, 'scalar', '&wantarray with caller in scalar context');
+&$cx_sub;
+is($context, 'void', '&wantarray with caller in void context');
+lis [&mywantarray],[wantarray], '&wantarray itself in list context';
+
+test_proto 'warn';
+{ $tests += 3;
+ my $w;
+ local $SIG{__WARN__} = sub { $w = shift };
+ is &mywarn('a'), 1, '&warn retval';
+ is $w, "a at " . __FILE__ . " line " . (__LINE__-1) . ".\n", 'warning';
+ lis [&mywarn()], [1], '&warn retval in list context';
+}
+
+test_proto 'write';
+$tests ++;
+eval {&mywrite};
+like $@, qr'^Undefined format "STDOUT" called',
+ "&write without arguments can handle the null";
+
+# This is just a check to make sure we have tested everything. If we
+# haven’t, then either the sub needs to be tested or the list in
+# gv.c is wrong.
+{
+ last if is_miniperl;
+ require File::Spec::Functions;
+ my $keywords_file =
+ File::Spec::Functions::catfile(
+ File::Spec::Functions::updir,'regen','keywords.pl'
+ );
+ open my $kh, $keywords_file
+ or die "$0 cannot open $keywords_file: $!";
+ while(<$kh>) {
+ if (m?__END__?..${\0} and /^[-+](.*)/) {
+ my $word = $1;
+ next if
+ $word =~ /^(?:s(?:tate|ort|ay|ub)?|d(?:ef
+ ault|ump|o)|p(?:rintf?|ackag
+ e)|e(?:ls(?:if|e)|val|q)|g(?:[et]|iven|oto
+ |rep)|u(?:n(?:less|til)|se)|l(?:(?:as)?t|ocal|e)|re
+ (?:quire|turn|do)|__(?:DATA|END)__|for(?:each|mat)?|(?:
+ AUTOLOA|EN)D|n(?:e(?:xt)?|o)|C(?:HECK|ORE)|wh(?:ile|en)
+ |(?:ou?|t)r|m(?:ap|y)?|UNITCHECK|q[qrwx]?|x(?:or)?|DEST
+ ROY|BEGIN|INIT|and|cmp|if|y)\z/x;
+ $tests ++;
+ ok exists &{"my$word"}
+ || (eval{&{"CORE::$word"}}, $@ =~ /cannot be called directly/),
+ "$word either has been tested or is not ampable";
+ }
+ }
+}
+
+# Add new tests above this line.
+
+# This test must come last (before the test count test):
+
+{
+ last if is_miniperl;
+ require Cwd;
+ import Cwd;
+ $tests += 3;
+ require File::Temp ;
+ my $dir = File::Temp::tempdir(uc cleanup => 1);
+ my $cwd = cwd();
+ chdir($dir);
+
+ # Make sure that implicit $_ is not applied to mkdir’s second argument.
+ local $^W = 1;
+ my $warnings;
+ local $SIG{__WARN__} = sub { ++$warnings };
+
+ no warnings 'experimental::lexical_topic';
+ my $_ = 'Phoo';
+ ok &mymkdir(), '&mkdir';
+ like <*>, qr/^phoo(.DIR)?\z/i, 'mkdir works with implicit $_';
+
+ is $warnings, undef, 'no implicit $_ for second argument to mkdir';
+
+ chdir($cwd); # so auto-cleanup can remove $dir
+}
+
+# ------------ END TESTING ----------- #
+
+done_testing $tests;
+
+#line 3 frob
+
+sub file { &CORE::__FILE__ }
+sub line { &CORE::__LINE__ } # 5
+sub dier { &CORE::die(@_) } # 6
+package stribble;
+sub main::pakg { &CORE::__PACKAGE__ }
+
+# Please do not add new tests here.
+package main;
+CORE::__DATA__
+I wandered lonely as a cloud
+That floats on high o’er vales and hills,
+And all at once I saw a crowd,
+A host of golden daffodils!
+Beside the lake, beneath the trees,
+Fluttering, dancing, in the breeze.
+-- Wordsworth
Copied: trunk/contrib/perl/t/op/coresubs.t (from rev 6437, vendor/perl/5.18.1/t/op/coresubs.t)
===================================================================
--- trunk/contrib/perl/t/op/coresubs.t (rev 0)
+++ trunk/contrib/perl/t/op/coresubs.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,155 @@
+#!./perl
+
+# This script tests the inlining and prototype of CORE:: subs. Any generic
+# tests that are not specific to &foo-style calls should go in this
+# file, too.
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = qw(. ../lib);
+ require "test.pl";
+ skip_all_without_dynamic_extension('B');
+ $^P |= 0x100;
+}
+
+use B::Deparse;
+my $bd = new B::Deparse '-p';
+
+my %unsupported = map +($_=>1), qw (
+ __DATA__ __END__ AUTOLOAD BEGIN UNITCHECK CORE DESTROY END INIT CHECK and
+ cmp default do dump else elsif eq eval for foreach
+ format ge given goto grep gt if last le local lt m map my ne next
+ no or our package print printf q qq qr qw qx redo require
+ return s say sort state sub tr unless until use
+ when while x xor y
+);
+my %args_for = (
+ dbmopen => '%1,$2,$3',
+ dbmclose => '%1',
+ delete => '$1[2]',
+ exists => '$1[2]',
+);
+my %desc = (
+ pos => 'match position',
+);
+
+use File::Spec::Functions;
+my $keywords_file = catfile(updir,'regen','keywords.pl');
+open my $kh, $keywords_file
+ or die "$0 cannot open $keywords_file: $!";
+while(<$kh>) {
+ if (m?__END__?..${\0} and /^[+-]/) {
+ chomp(my $word = $');
+ if($unsupported{$word}) {
+ $tests ++;
+ ok !defined &{"CORE::$word"}, "no CORE::$word";
+ }
+ else {
+ $tests += 4;
+
+ ok defined &{"CORE::$word"}, "defined &{'CORE::$word'}";
+
+ my $proto = prototype "CORE::$word";
+ *{"my$word"} = \&{"CORE::$word"};
+ is prototype \&{"my$word"}, $proto, "prototype of &CORE::$word";
+
+ CORE::state $protochar = qr/([^\\]|\\(?:[^[]|\[[^]]+\]))/;
+ my $numargs =
+ $word eq 'delete' || $word eq 'exists' ? 1 :
+ (() = $proto =~ s/;.*//r =~ /\G$protochar/g);
+ my $code =
+ "#line 1 This-line-makes-__FILE__-easier-to-test.
+ sub { () = (my$word("
+ . ($args_for{$word} || join ",", map "\$$_", 1..$numargs)
+ . "))}";
+ my $core = $bd->coderef2text(eval $code =~ s/my/CORE::/r or die);
+ my $my = $bd->coderef2text(eval $code or die);
+ is $my, $core, "inlinability of CORE::$word with parens";
+
+ $code =
+ "#line 1 This-line-makes-__FILE__-easier-to-test.
+ sub { () = (my$word "
+ . ($args_for{$word} || join ",", map "\$$_", 1..$numargs)
+ . ")}";
+ $core = $bd->coderef2text(eval $code =~ s/my/CORE::/r or die);
+ $my = $bd->coderef2text(eval $code or die);
+ is $my, $core, "inlinability of CORE::$word without parens";
+
+ # High-precedence tests
+ my $hpcode;
+ if (!$proto && defined $proto) { # nullary
+ $hpcode = "sub { () = my$word + 1 }";
+ }
+ elsif ($proto =~ /^;?$protochar\z/) { # unary
+ $hpcode = "sub { () = my$word "
+ . ($args_for{$word}||'$a') . ' > $b'
+ .'}';
+ }
+ if ($hpcode) {
+ $tests ++;
+ $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";
+ }
+
+ next if ($proto =~ /\@/);
+ # These ops currently accept any number of args, despite their
+ # prototypes, if they have any:
+ next if $word =~ /^(?:chom?p|exec|keys|each|not
+ |(?:prototyp|read(?:lin|pip))e
+ |reset|system|values|l?stat)|evalbytes/x;
+
+ $tests ++;
+ $code =
+ "sub { () = (my$word("
+ . (
+ $args_for{$word}
+ ? $args_for{$word}.',$7'
+ : join ",", map "\$$_", 1..$numargs+5+(
+ $proto =~ /;/
+ ? () = $' =~ /\G$protochar/g
+ : 0
+ )
+ )
+ . "))}";
+ eval $code;
+ my $desc = $desc{$word} || $word;
+ like $@, qr/^Too many arguments for $desc/,
+ "inlined CORE::$word with too many args"
+ or warn $code;
+
+ }
+ }
+}
+
+$tests++;
+# This subroutine is outside the warnings scope:
+sub foo { goto &CORE::abs }
+use warnings;
+$SIG{__WARN__} = sub { like shift, qr\^Use of uninitialized\ };
+foo(undef);
+
+$tests+=2;
+is runperl(prog => 'print CORE->lc, qq-\n-'), "core\n",
+ 'methods calls autovivify coresubs';
+is runperl(prog => '@ISA=CORE; print main->uc, qq-\n-'), "MAIN\n",
+ 'inherted method calls autovivify coresubs';
+
+{ # RT #117607
+ $tests++;
+ like runperl(prog => '$foo/; \&CORE::lc', stderr => 1),
+ qr/^syntax error/, "RT #117607: \\&CORE::foo doesn't crash in error context";
+}
+
+$tests++;
+ok eval { *CORE::exit = \42 },
+ '[rt.cpan.org #74289] *CORE::foo is not accidentally made read-only';
+
+ at UNIVERSAL::ISA = CORE;
+is "just another "->ucfirst . "perl hacker,\n"->ucfirst,
+ "Just another Perl hacker,\n", 'coresubs do not return TARG';
+++$tests;
+
+done_testing $tests;
+
+CORE::__END__
Modified: trunk/contrib/perl/t/op/cproto.t
===================================================================
--- trunk/contrib/perl/t/op/cproto.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/cproto.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -7,7 +7,7 @@
}
BEGIN { require './test.pl'; }
-plan tests => 237;
+plan tests => 254;
while (<DATA>) {
chomp;
@@ -20,7 +20,10 @@
like( $@, qr/Can't find an opnumber for/, $keyword );
}
else {
- is( "(".prototype("CORE::".$keyword).")", $proto, $keyword );
+ is(
+ "(".(prototype("CORE::".$keyword) // 'undef').")", $proto,
+ $keyword
+ );
}
}
@@ -27,14 +30,28 @@
# the keyword list :
__DATA__
+__FILE__ ()
+__LINE__ ()
+__PACKAGE__ ()
+__DATA__ undef
+__END__ undef
+__SUB__ ()
+AUTOLOAD undef
+BEGIN undef
+CORE unknown
+DESTROY undef
+END undef
+INIT undef
+CHECK undef
abs (_)
accept (**)
alarm (_)
-and ()
+and undef
atan2 ($$)
bind (*$)
binmode (*;$)
bless ($;$)
+break ()
caller (;$)
chdir (;$)
chmod (@)
@@ -45,7 +62,7 @@
chroot (_)
close (;*)
closedir (*)
-cmp unknown
+cmp undef
connect (*$)
continue ()
cos (_)
@@ -52,6 +69,7 @@
crypt ($$)
dbmclose (\%)
dbmopen (\%$$)
+default undef
defined undef
delete undef
die (@)
@@ -67,12 +85,14 @@
endpwent ()
endservent ()
eof (;*)
-eq ($$)
+eq undef
eval undef
+evalbytes (_)
exec undef
exists undef
exit (;$)
exp (_)
+fc (_)
fcntl (*$$)
fileno (*)
flock (*$)
@@ -81,7 +101,7 @@
fork ()
format undef
formline ($@)
-ge ($$)
+ge undef
getc (;*)
getgrent ()
getgrgid ($)
@@ -98,7 +118,7 @@
getppid ()
getpriority ($$)
getprotobyname ($)
-getprotobynumber ($)
+getprotobynumber ($;)
getprotoent ()
getpwent ()
getpwnam ($)
@@ -109,11 +129,11 @@
getsockname (*)
getsockopt (*$$)
given undef
-glob undef
+glob (_;)
gmtime (;$)
goto undef
grep undef
-gt ($$)
+gt undef
hex (_)
if undef
index ($$;$)
@@ -125,16 +145,16 @@
last undef
lc (_)
lcfirst (_)
-le ($$)
+le undef
length (_)
link ($$)
listen (*$)
local undef
localtime (;$)
-lock (\$)
+lock (\[$@%&*])
log (_)
-lstat (*)
-lt ($$)
+lstat (;*)
+lt undef
m undef
map undef
mkdir (_;$)
@@ -143,14 +163,14 @@
msgrcv ($$$$$)
msgsnd ($$$)
my undef
-ne ($$)
+ne undef
next undef
no undef
-not ($)
+not ($;)
oct (_)
open (*;$@)
opendir (*$)
-or ()
+or undef
ord (_)
our undef
pack ($@)
@@ -157,10 +177,10 @@
package undef
pipe (**)
pop (;+)
-pos undef
+pos (;\[$*])
print undef
printf undef
-prototype undef
+prototype ($)
push (+@)
q undef
qq undef
@@ -187,10 +207,10 @@
rmdir (_)
s undef
say undef
-scalar undef
+scalar ($)
seek (*$$)
seekdir (*$)
-select (;*)
+select undef
semctl ($$$$)
semget ($$$)
semop ($$)
@@ -220,9 +240,9 @@
sprintf ($@)
sqrt (_)
srand (;$)
-stat (*)
+stat (;*)
state undef
-study undef
+study (_)
sub undef
substr ($$;$$)
symlink ($$)
@@ -243,10 +263,10 @@
uc (_)
ucfirst (_)
umask (;$)
-undef undef
+undef (;\[$@%&*])
unless undef
unlink (@)
-unpack ($;$)
+unpack ($_)
unshift (+@)
untie (\[$@%*])
until undef
@@ -261,6 +281,6 @@
when undef
while undef
write (;*)
-x unknown
-xor ($$)
+x undef
+xor undef
y undef
Property changes on: trunk/contrib/perl/t/op/cproto.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/t/op/crypt.t
===================================================================
--- trunk/contrib/perl/t/op/crypt.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/crypt.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/crypt.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/op/current_sub.t (from rev 6437, vendor/perl/5.18.1/t/op/current_sub.t)
===================================================================
--- trunk/contrib/perl/t/op/current_sub.t (rev 0)
+++ trunk/contrib/perl/t/op/current_sub.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,77 @@
+#!./perl
+
+BEGIN {
+ chdir 't';
+ @INC = qw(../lib);
+ require './test.pl';
+ plan (tests => 17);
+}
+
+is __SUB__, "__SUB__", '__SUB__ is a bareword outside of use feature';
+
+{
+ use v5.15;
+ is __SUB__, undef, '__SUB__ under use v5.16';
+}
+
+use feature 'current_sub';
+
+is __SUB__, undef, '__SUB__ returns undef outside of a subroutine';
+is +()=__SUB__, 1, '__SUB__ returns undef in list context';
+
+sub foo { __SUB__ }
+is foo, \&foo, '__SUB__ inside a named subroutine';
+is foo->(), \&foo, '__SUB__ is callable';
+is ref foo, 'CODE', '__SUB__ is a code reference';
+
+my $subsub = sub { __SUB__ };
+is &$subsub, $subsub, '__SUB__ inside anonymous non-closure';
+
+my @subsubs;
+for my $x(1..3) {
+ push @subsubs, sub { return $x if @_; __SUB__ };
+}
+# Don’t loop here; we need to avoid interactions between the iterator
+# and the closure.
+is $subsubs[0]()(0), 1, '__SUB__ inside closure (1)';
+is $subsubs[1]()(0), 2, '__SUB__ inside closure (2)';
+is $subsubs[2]()(0), 3, '__SUB__ inside closure (3)';
+
+BEGIN {
+ return "begin 1" if @_;
+ is CORE::__SUB__->(0), "begin 1", 'in BEGIN block'
+}
+BEGIN {
+ return "begin 2" if @_;
+ is &CORE::__SUB__->(0), "begin 2", 'in BEGIN block via & (unoptimised)'
+}
+
+sub bar;
+sub bar {
+ () = sort {
+ is CORE::__SUB__, \&bar, 'in sort block in sub with forw decl'
+ } 1,2;
+}
+bar();
+sub bur;
+sub bur {
+ () = sort {
+ is &CORE::__SUB__, \&bur, '& in sort block in sub with forw decl'
+ } 1,2;
+}
+bur();
+
+sub squog;
+sub squog {
+ grep { is CORE::__SUB__, \&squog,
+ 'in grep block in sub with forw decl'
+ } 1;
+}
+squog();
+sub squag;
+sub squag {
+ grep { is &CORE::__SUB__, \&squag,
+ '& in grep block in sub with forw decl'
+ } 1;
+}
+squag();
Modified: trunk/contrib/perl/t/op/dbm.t
===================================================================
--- trunk/contrib/perl/t/op/dbm.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/dbm.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -9,7 +9,7 @@
skip_all("No dbm functions") if $@;
}
-plan tests => 4;
+plan tests => 5;
# This is [20020104.007] "coredump on dbmclose"
@@ -58,3 +58,10 @@
fresh_perl_like('delete $::{"AnyDBM_File::"}; ' . $prog,
qr/No dbm on this machine/, {},
'implicit require and no stash fails');
+
+{ # undef 3rd arg
+ local $^W = 1;
+ local $SIG{__WARN__} = sub { ++$w };
+ dbmopen(%truffe, 'pleaseletthisfilenotexist', undef);
+ is $w, 1, '1 warning from dbmopen with undef third arg';
+}
Property changes on: trunk/contrib/perl/t/op/dbm.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/t/op/defined.t (from rev 6437, vendor/perl/5.18.1/t/op/defined.t)
===================================================================
--- trunk/contrib/perl/t/op/defined.t (rev 0)
+++ trunk/contrib/perl/t/op/defined.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,20 @@
+#!perl
+BEGIN {
+ chdir 't';
+ require './test.pl';
+}
+
+plan 5;
+
+sub notdef { undef }
+
+# [perl #97466]
+# These should actually call the sub, instead of testing the sub itself
+ok !defined do { ¬def }, 'defined do { &sub }';
+ok !defined(scalar(42,¬def)), 'defined(scalar(42,&sub))';
+ok !defined do{();¬def}, '!defined do{();&sub}';
+
+# Likewise, these should evaluate @array in scalar context
+no warnings "deprecated";
+ok defined($false ? $scalar : @array), 'defined( ... ? ... : @array)';
+ok defined(scalar @array), 'defined(scalar @array)';
Modified: trunk/contrib/perl/t/op/defins.t
===================================================================
--- trunk/contrib/perl/t/op/defins.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/defins.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -10,7 +10,7 @@
$SIG{__WARN__} = sub { $warns++; warn $_[0] };
}
require 'test.pl';
-plan( tests => 19 );
+plan( tests => 27 );
my $unix_mode = 1;
@@ -33,15 +33,23 @@
$unix_mode = 1 if $drop_dot && unix_rpt;
}
+# $wanted_filename should be 0 for readdir() and glob() tests.
+# This is because it is the only valid filename that is false in a boolean test.
+
+# $filename = '0';
+# print "hi\n" if $filename; # doesn't print
+
+# In the case of VMS, '0' isn't always the filename that you get.
+# Which makes those particular tests pointless.
+
$wanted_filename = $unix_mode ? '0' : '0.';
$saved_filename = './0';
cmp_ok($warns,'==',0,'no warns at start');
-open(FILE,">$saved_filename");
-ok(defined(FILE),'created work file');
+ok(open(FILE,">$saved_filename"),'created work file');
+print FILE "0\n";
print FILE "1\n";
-print FILE "0";
close(FILE);
open(FILE,"<$saved_filename");
@@ -50,6 +58,7 @@
my $dummy;
while (my $name = <FILE>)
{
+ chomp($name);
$seen++ if $name eq '0';
}
cmp_ok($seen,'==',1,'seen in while()');
@@ -59,6 +68,7 @@
my $line = '';
do
{
+ chomp($line);
$seen++ if $line eq '0';
} while ($line = <FILE>);
cmp_ok($seen,'==',1,'seen in do/while');
@@ -67,9 +77,10 @@
$seen = 0;
while (($seen ? $dummy : $name) = <FILE> )
{
+ chomp($name);
$seen++ if $name eq '0';
}
-cmp_ok($seen,'==',1,'seen in while() ternary');
+cmp_ok($seen,'==',2,'seen in while() ternary');
seek(FILE,0,0);
$seen = 0;
@@ -76,6 +87,7 @@
my %where;
while ($where{$seen} = <FILE>)
{
+ chomp($where{$seen});
$seen++ if $where{$seen} eq '0';
}
cmp_ok($seen,'==',1,'seen in hash while()');
@@ -107,7 +119,32 @@
}
cmp_ok($seen,'==',1,'saw file in hash while()');
+rewinddir(DIR);
$seen = 0;
+$_ = 'not 0';
+while (readdir(DIR))
+ {
+ $seen++ if $_ eq $wanted_filename;
+ }
+cmp_ok($seen,'==',1,'saw file in bare while(readdir){...}');
+
+rewinddir(DIR);
+$seen = 0;
+$_ = 'not 0';
+
+$_ eq $wanted_filename && $seen++ while readdir(DIR);
+cmp_ok($seen,'==',1,'saw file in bare "... while readdir"');
+
+rewinddir(DIR);
+$seen = 0;
+$_ = ""; # suppress uninit warning
+do
+ {
+ $seen++ if $_ eq $wanted_filename;
+ } while (readdir(DIR));
+cmp_ok($seen,'==',1,'saw file in bare do{...}while(readdir)');
+
+$seen = 0;
while (my $name = glob('*'))
{
$seen++ if $name eq $wanted_filename;
@@ -133,12 +170,17 @@
ok(!(-f $saved_filename),'work file unlinked');
my %hash = (0 => 1, 1 => 2);
+my @array = 1;
+my $neg_sum= 0;
$seen = 0;
+
while (my $name = each %hash)
{
+ $neg_sum = $name - $neg_sum;
$seen++ if $name eq '0';
}
+cmp_ok(abs($neg_sum),'==',1,'abs(neg_sum) should equal 1');
cmp_ok($seen,'==',1,'seen in each');
$seen = 0;
@@ -147,7 +189,7 @@
{
$seen++ if $name eq '0';
}
-cmp_ok($seen,'==',1,'seen in each ternary');
+cmp_ok($seen,'==',$neg_sum < 0 ? 1 : 2,'seen in each ternary');
$seen = 0;
while ($where{$seen} = each %hash)
@@ -156,4 +198,30 @@
}
cmp_ok($seen,'==',1,'seen in each hash');
+$seen = 0;
+undef $_;
+while (each %hash)
+ {
+ $seen++ if $_ eq '0';
+ }
+cmp_ok($seen,'==',1,'0 seen in $_ in while(each %hash)');
+
+$seen = 0;
+undef $_;
+while (each @array)
+ {
+ $seen++ if $_ eq '0';
+ }
+cmp_ok($seen,'==',1,'0 seen in $_ in while(each @array)');
+
+$seen = 0;
+undef $_;
+$_ eq '0' and $seen++ while each %hash;
+cmp_ok($seen,'==',1,'0 seen in $_ in while(each %hash) as stm mod');
+
+$seen = 0;
+undef $_;
+$_ eq '0' and $seen++ while each @array;
+cmp_ok($seen,'==',1,'0 seen in $_ in while(each @array) as stm mod');
+
cmp_ok($warns,'==',0,'no warns at finish');
Property changes on: trunk/contrib/perl/t/op/defins.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/t/op/delete.t
===================================================================
--- trunk/contrib/perl/t/op/delete.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/delete.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/delete.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/die.t
===================================================================
--- trunk/contrib/perl/t/op/die.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/die.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,74 +1,97 @@
#!./perl
-print "1..15\n";
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require './test.pl';
+}
-$SIG{__DIE__} = sub { print ref($_[0]) ? ("ok ",$_[0]->[0]++,"\n") : @_ } ;
+plan tests => 19;
-$err = "#[\000]\nok 1\n";
eval {
- die $err;
+ eval {
+ die "Horribly\n";
+ };
+ die if $@;
};
-print "not " unless $@ eq $err;
-print "ok 2\n";
+like($@, '^Horribly', 'die with no args propagates $@');
+like($@, 'propagated', '... and appends a phrase');
-$x = [3];
-eval { die $x; };
+{
+ local $SIG{__DIE__} = sub { is( $_[0], "[\000]\n", 'Embedded null passed to signal handler' )};
-print "not " unless $x->[0] == 4;
-print "ok 4\n";
+ $err = "[\000]\n";
+ eval {
+ die $err;
+ };
+ is( $@, $err, 'Embedded null passed back into $@' );
+}
-eval {
+{
+ local $SIG{__DIE__} = sub {
+ isa_ok( $_[0], 'ARRAY', 'pass an array ref as an argument' );
+ $_[0]->[0]++;
+ };
+ $x = [3];
+ eval { die $x; };
+
+ is( $x->[0], 4, 'actual array, not a copy, passed to signal handler' );
+
eval {
- die [ 5 ];
+ eval {
+ die [ 5 ];
+ };
+ die if $@;
};
- die if $@;
-};
-eval {
+ is($@->[0], 7, 'die with no arguments propagates $@, but leaves references alone');
+
eval {
- die bless [ 7 ], "Error";
+ eval {
+ die bless [ 7 ], "Error";
+ };
+ isa_ok( $@, 'Error', '$@ is an Error object' );
+ die if $@;
};
- die if $@;
-};
-print "not " unless ref($@) eq "Out";
-print "ok 10\n";
+ isa_ok( $@, 'Out', 'returning a different object than what was passed in, via PROPAGATE' );
+ is($@->[0], 9, 'reference returned correctly');
+}
{
package Error;
sub PROPAGATE {
- print "ok ",$_[0]->[0]++,"\n";
bless [$_[0]->[0]], "Out";
}
}
+
{
# die/warn and utf8
use utf8;
local $SIG{__DIE__};
my $msg = "ce ºtii tu, bã ?\n";
- eval { die $msg }; print "not " unless $@ eq $msg;
- print "ok 11\n";
+ eval { die $msg };
+ is( $@, $msg, "Literal passed to die" );
our $err;
local $SIG{__WARN__} = $SIG{__DIE__} = sub { $err = shift };
- eval { die $msg }; print "not " unless $err eq $msg;
- print "ok 12\n";
- eval { warn $msg }; print "not " unless $err eq $msg;
- print "ok 13\n";
+ eval { die $msg };
+ is( $err, $msg, 'die handler with utf8' );
+ eval { warn $msg };
+ is( $err, $msg, 'warn handler with utf8' );
eval qq/ use strict; \$\x{3b1} /;
- print "not " unless $@ =~ /Global symbol "\$\x{3b1}"/;
- print "ok 14\n";
+ like( $@, qr/Global symbol "\$\x{3b1}"/, 'utf8 symbol names show up in $@' );
}
# [perl #36470] got uninit warning if $@ was undef
{
+ use warnings "uninitialized";
my $ok = 1;
local $SIG{__DIE__};
local $SIG{__WARN__} = sub { $ok = 0 };
eval { undef $@; die };
- print "not " unless $ok;
- print "ok 15\n";
+ is( $ok, 1, 'no warnings if $@ is undef' );
}
Property changes on: trunk/contrib/perl/t/op/die.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/die_except.t
===================================================================
--- trunk/contrib/perl/t/op/die_except.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/die_except.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -19,8 +19,8 @@
$@ = "t1\n";
1;
}; $err = $@;
-is($val, 1);
-is($err, "");
+is($val, 1, "true return value from successful eval block");
+is($err, "", "no exception after successful eval block");
$@ = "t0\n";
$val = eval {
@@ -30,8 +30,8 @@
};
1;
}; $err = $@;
-is($val, undef);
-is($err, "t3\n");
+is($val, undef, "undefined return value from eval block with 'die'");
+is($err, "t3\n", "exception after eval block with 'die'");
$@ = "t0\n";
$val = eval {
@@ -39,8 +39,8 @@
local $@ = "t2\n";
1;
}; $err = $@;
-is($val, 1);
-is($err, "");
+is($val, 1, "true return value from successful eval block with localized \$@");
+is($err, "", "no exception after successful eval block with localized \$@");
$@ = "t0\n";
$val = eval {
@@ -51,8 +51,10 @@
};
1;
}; $err = $@;
-is($val, undef);
-is($err, "t3\n");
+is($val, undef,
+ "undefined return value from eval block with 'die' and localized \$@");
+is($err, "t3\n",
+ "exception after eval block with 'die' and localized \$@");
$@ = "t0\n";
$val = eval {
@@ -60,8 +62,8 @@
my $c = end { $@ = "t2\n"; };
1;
}; $err = $@;
-is($val, 1);
-is($err, "");
+is($val, 1, "true return value from eval block with 'end'");
+is($err, "", "no exception after eval block with 'end'");
$@ = "t0\n";
$val = eval {
@@ -72,7 +74,7 @@
};
1;
}; $err = $@;
-is($val, undef);
-is($err, "t3\n");
+is($val, undef, "undefined return value from eval block with 'end' and 'die'");
+is($err, "t3\n", "exception after eval block with 'end' and 'die'");
done_testing();
Property changes on: trunk/contrib/perl/t/op/die_except.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/die_exit.t
===================================================================
--- trunk/contrib/perl/t/op/die_exit.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/die_exit.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -13,8 +13,6 @@
use strict;
-skip_all('broken on MPE/iX') if $^O eq 'mpeix';
-
$| = 1;
my @tests = (
Property changes on: trunk/contrib/perl/t/op/die_exit.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/die_keeperr.t
===================================================================
--- trunk/contrib/perl/t/op/die_keeperr.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/die_keeperr.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -3,7 +3,7 @@
BEGIN {
chdir 't' if -d 't';
require 'test.pl';
- plan(20);
+ plan(24);
}
sub End::DESTROY { $_[0]->() }
@@ -31,15 +31,46 @@
no warnings "misc";
my $warn = "";
local $SIG{__WARN__} = sub { $warn .= $_[0] };
- { my $e = end { die "aa\n"; }; }
+ { my $e = end { no warnings "misc"; die "aa\n"; }; }
is $warn, "";
}
{
+ no warnings "misc";
my $warn = "";
local $SIG{__WARN__} = sub { $warn .= $_[0] };
+ { my $e = end { use warnings "misc"; die "aa\n"; }; }
+ is $warn, "\t(in cleanup) aa\n";
+}
+
+{
+ my $warn = "";
+ local $SIG{__WARN__} = sub { $warn .= $_[0] };
{ my $e = end { no warnings "misc"; die "aa\n"; }; }
+ is $warn, "";
+}
+
+{
+ my $warn = "";
+ local $SIG{__WARN__} = sub { $warn .= $_[0] };
+ { my $e = end { use warnings "misc"; die "aa\n"; }; }
is $warn, "\t(in cleanup) aa\n";
}
+{
+ use warnings "misc";
+ my $warn = "";
+ local $SIG{__WARN__} = sub { $warn .= $_[0] };
+ { my $e = end { no warnings "misc"; die "aa\n"; }; }
+ is $warn, "";
+}
+
+{
+ use warnings "misc";
+ my $warn = "";
+ local $SIG{__WARN__} = sub { $warn .= $_[0] };
+ { my $e = end { use warnings "misc"; die "aa\n"; }; }
+ is $warn, "\t(in cleanup) aa\n";
+}
+
1;
Property changes on: trunk/contrib/perl/t/op/die_keeperr.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/die_unwind.t
===================================================================
--- trunk/contrib/perl/t/op/die_unwind.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/die_unwind.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -5,7 +5,7 @@
#
# This test checks for $@ being set early during an exceptional
-# unwinding, and that this early setting doesn't affect the late
+# unwinding, and that this early setting does not affect the late
# setting used to emit the exception from eval{}. The early setting is
# a backward-compatibility hack to satisfy modules that were relying on
# the historical early setting in order to detect exceptional unwinding.
@@ -29,9 +29,9 @@
my $c = end { $uerr = $@; $@ = "t2\n"; };
1;
}; $err = $@;
-is($uerr, "");
-is($val, 1);
-is($err, "");
+is($uerr, "", "\$@ false at start of 'end' block inside 'eval' block");
+is($val, 1, "successful return from 'eval' block");
+is($err, "", "\$@ still false after 'end' block inside 'eval' block");
$@ = "t0\n";
$val = eval {
@@ -39,9 +39,9 @@
my $c = end { $uerr = $@; $@ = "t2\n"; };
1;
}; $err = $@;
-is($uerr, "t1\n");
-is($val, 1);
-is($err, "");
+is($uerr, "t1\n", "true value assigned to \$@ before 'end' block inside 'eval' block");
+is($val, 1, "successful return from 'eval' block");
+is($err, "", "\$@ still false after 'end' block inside 'eval' block");
$@ = "";
$val = eval {
@@ -52,7 +52,7 @@
1;
}; $err = $@;
is($uerr, "t3\n");
-is($val, undef);
+is($val, undef, "undefined return value from 'eval' block with 'die'");
is($err, "t3\n");
$@ = "t0\n";
@@ -65,7 +65,7 @@
1;
}; $err = $@;
is($uerr, "t3\n");
-is($val, undef);
+is($val, undef, "undefined return value from 'eval' block with 'die'");
is($err, "t3\n");
done_testing();
Property changes on: trunk/contrib/perl/t/op/die_unwind.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/do.t
===================================================================
--- trunk/contrib/perl/t/op/do.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/do.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,6 +1,10 @@
#!./perl -w
-require './test.pl';
+BEGIN {
+ chdir 't';
+ @INC = '../lib';
+ require './test.pl';
+}
use strict;
no warnings 'void';
@@ -159,6 +163,73 @@
@x = sub { do { return do { 1; do { 2; @a } } }; 5 }->();
is("@x", "7 8 9 10", 'return do { do { ; } } receives caller list context');
+# More tests about context propagation below return()
+ at a = (11, 12);
+ at b = (21, 22, 23);
+
+my $test_code = sub {
+ my ($x, $y) = @_;
+ if ($x) {
+ return $y ? do { my $z; @a } : do { my $z; @b };
+ } else {
+ return (
+ do { my $z; @a },
+ (do { my$z; @b }) x $y
+ );
+ }
+ 'xxx';
+};
+
+$x = $test_code->(1, 1);
+is($x, 2, 'return $y ? do { } : do { } - scalar context 1');
+$x = $test_code->(1, 0);
+is($x, 3, 'return $y ? do { } : do { } - scalar context 2');
+ at x = $test_code->(1, 1);
+is("@x", '11 12', 'return $y ? do { } : do { } - list context 1');
+ at x = $test_code->(1, 0);
+is("@x", '21 22 23', 'return $y ? do { } : do { } - list context 2');
+
+$x = $test_code->(0, 0);
+is($x, "", 'return (do { }, (do { }) x ...) - scalar context 1');
+$x = $test_code->(0, 1);
+is($x, 3, 'return (do { }, (do { }) x ...) - scalar context 2');
+ at x = $test_code->(0, 0);
+is("@x", '11 12', 'return (do { }, (do { }) x ...) - list context 1');
+ at x = $test_code->(0, 1);
+is("@x", '11 12 21 22 23', 'return (do { }, (do { }) x ...) - list context 2');
+
+$test_code = sub {
+ my ($x, $y) = @_;
+ if ($x) {
+ return do {
+ if ($y == 0) {
+ my $z;
+ @a;
+ } elsif ($y == 1) {
+ my $z;
+ @b;
+ } else {
+ my $z;
+ (wantarray ? reverse(@a) : '99');
+ }
+ };
+ }
+ 'xxx';
+};
+
+$x = $test_code->(1, 0);
+is($x, 2, 'return do { if () { } elsif () { } else { } } - scalar 1');
+$x = $test_code->(1, 1);
+is($x, 3, 'return do { if () { } elsif () { } else { } } - scalar 2');
+$x = $test_code->(1, 2);
+is($x, 99, 'return do { if () { } elsif () { } else { } } - scalar 3');
+ at x = $test_code->(1, 0);
+is("@x", '11 12', 'return do { if () { } elsif () { } else { } } - list 1');
+ at x = $test_code->(1, 1);
+is("@x", '21 22 23', 'return do { if () { } elsif () { } else { } } - list 2');
+ at x = $test_code->(1, 2);
+is("@x", '12 11', 'return do { if () { } elsif () { } else { } } - list 3');
+
# Do blocks created by constant folding
# [perl #68108]
$x = sub { if (1) { 20 } }->();
@@ -197,4 +268,48 @@
@x = sub { if (0){} else { 0; @a } }->();
is("@x", "24 25 26 27", 'if (0){} else { ...; @a } receives caller list context');
+# [rt.cpan.org #72767] do "string" should not propagate warning hints
+SKIP: {
+ skip_if_miniperl("no in-memory files under miniperl", 1);
+
+ my $code = '42; 1';
+ # Based on Eval::WithLexicals::_eval_do
+ local @INC = (sub {
+ if ($_[1] eq '/eval_do') {
+ open my $fh, '<', \$code;
+ $fh;
+ } else {
+ ();
+ }
+ }, @INC);
+ local $^W;
+ use warnings;
+ my $w;
+ local $SIG{__WARN__} = sub { warn shift; ++$w };
+ do '/eval_do' or die $@;
+ is($w, undef, 'do STRING does not propagate warning hints');
+}
+
+# RT#113730 - $@ should be cleared on IO error.
+{
+ $@ = "should not see";
+ $! = 0;
+ my $rv = do("some nonexistent file");
+ my $saved_error = $@;
+ my $saved_errno = $!;
+ ok(!$rv, "do returns false on io errror");
+ ok(!$saved_error, "\$\@ not set on io error");
+ ok($saved_errno, "\$! set on io error");
+}
+
+# do subname should not be do "subname"
+{
+ my $called;
+ sub fungi { $called .= "fungible" }
+ $@ = "scrimptious scrobblings";
+ do fungi;
+ is $called, "fungible", "do-file does not force bareword";
+ isnt $@, "scrimptious scrobblings", "It was interpreted as do-file";
+}
+
done_testing();
Property changes on: trunk/contrib/perl/t/op/do.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/dor.t
===================================================================
--- trunk/contrib/perl/t/op/dor.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/dor.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -23,7 +23,7 @@
$x='';
is($x // 0, '', ' // : left-hand operand defined but empty');
-like([] // 0, qr/^ARRAY/, ' // : left-hand operand a referece');
+like([] // 0, qr/^ARRAY/, ' // : left-hand operand a reference');
$x=undef;
$x //= 1;
@@ -56,15 +56,18 @@
# Test for some ambiguous syntaxes
eval q# sub f ($) { } f $x / 2; #;
-is( $@, '' );
+is( $@, '', "'/' correctly parsed as arithmetic operator" );
eval q# sub f ($):lvalue { $y } f $x /= 2; #;
-is( $@, '' );
+is( $@, '', "'/=' correctly parsed as assigment operator" );
eval q# sub f ($) { } f $x /2; #;
-like( $@, qr/^Search pattern not terminated/ );
+like( $@, qr/^Search pattern not terminated/,
+ "Caught unterminated search pattern error message: empty subroutine" );
eval q# sub { print $fh / 2 } #;
-is( $@, '' );
+is( $@, '',
+ "'/' correctly parsed as arithmetic operator in sub with built-in function" );
eval q# sub { print $fh /2 } #;
-like( $@, qr/^Search pattern not terminated/ );
+like( $@, qr/^Search pattern not terminated/,
+ "Caught unterminated search pattern error message: sub with built-in function" );
# [perl #28123] Perl optimizes // away incorrectly
Property changes on: trunk/contrib/perl/t/op/dor.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/each.t
===================================================================
--- trunk/contrib/perl/t/op/each.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/each.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -6,7 +6,7 @@
require './test.pl';
}
-plan tests => 54;
+plan tests => 59;
$h{'abc'} = 'ABC';
$h{'def'} = 'DEF';
@@ -238,3 +238,53 @@
my @arr=%foo&&%foo;
is(@arr,10,"Got expected number of elements in list context");
}
+{
+ # make sure a deleted active iterator gets freed timely, even if the
+ # hash is otherwise empty
+
+ package Single;
+
+ my $c = 0;
+ sub DESTROY { $c++ };
+
+ {
+ my %h = ("a" => bless []);
+ my ($k,$v) = each %h;
+ delete $h{$k};
+ ::is($c, 0, "single key not yet freed");
+ }
+ ::is($c, 1, "single key now freed");
+}
+
+{
+ # Make sure each() does not leave the iterator in an inconsistent state
+ # (RITER set to >= 0, with EITER null) if the active iterator is
+ # deleted, leaving the hash apparently empty.
+ my %h;
+ $h{1} = 2;
+ each %h;
+ delete $h{1};
+ each %h;
+ $h{1}=2;
+ is join ("-", each %h), '1-2',
+ 'each on apparently empty hash does not leave RITER set';
+}
+{
+ my $warned= 0;
+ local $SIG{__WARN__}= sub {
+ /\QUse of each() on hash after insertion without resetting hash iterator results in undefined behavior\E/
+ and $warned++ for @_;
+ };
+ my %h= map { $_ => $_ } "A".."F";
+ while (my ($k, $v)= each %h) {
+ $h{"$k$k"}= $v;
+ }
+ ok($warned,"each() after insert produces warnings");
+ no warnings 'internal';
+ $warned= 0;
+ %h= map { $_ => $_ } "A".."F";
+ while (my ($k, $v)= each %h) {
+ $h{"$k$k"}= $v;
+ }
+ ok(!$warned, "no warnings 'internal' silences each() after insert warnings");
+}
Property changes on: trunk/contrib/perl/t/op/each.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/each_array.t
===================================================================
--- trunk/contrib/perl/t/op/each_array.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/each_array.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -7,128 +7,183 @@
}
use strict;
use warnings;
-no warnings 'deprecated';
-use vars qw(@array @r $k $v);
+use vars qw(@array @r $k $v $c);
-plan tests => 48;
+plan tests => 63;
@array = qw(crunch zam bloop);
(@r) = each @array;
-is (scalar @r, 2);
-is ($r[0], 0);
-is ($r[1], 'crunch');
+is (scalar @r, 2, "'each' on array returns index and value of next element");
+is ($r[0], 0, "got expected index");
+is ($r[1], 'crunch', "got expected value");
($k, $v) = each @array;
-is ($k, 1);
-is ($v, 'zam');
+is ($k, 1, "got expected index of next element");
+is ($v, 'zam', "got expected value of next element");
($k, $v) = each @array;
-is ($k, 2);
-is ($v, 'bloop');
+is ($k, 2, "got expected index of remaining element");
+is ($v, 'bloop', "got expected value of remaining element");
(@r) = each @array;
-is (scalar @r, 0);
+is (scalar @r, 0,
+ "no elements remaining to be iterated over in original array");
(@r) = each @array;
-is (scalar @r, 2);
-is ($r[0], 0);
-is ($r[1], 'crunch');
+is (scalar @r, 2, "start second iteration over original array");
+is ($r[0], 0, "got expected index");
+is ($r[1], 'crunch', "got expected value");
($k) = each @array;
-is ($k, 1);
-{
- $[ = 2;
- my ($k, $v) = each @array;
- is ($k, 4);
- is ($v, 'bloop');
- (@r) = each @array;
- is (scalar @r, 0);
-}
+is ($k, 1, "got index when only index was assigned to variable");
-my @lex_array = qw(PLOP SKLIZZORCH RATTLE PBLRBLPSFT);
+my @lex_array = qw(PLOP SKLIZZORCH RATTLE);
(@r) = each @lex_array;
-is (scalar @r, 2);
-is ($r[0], 0);
-is ($r[1], 'PLOP');
+is (scalar @r, 2, "'each' on array returns index and value of next element");
+is ($r[0], 0, "got expected index");
+is ($r[1], 'PLOP', "got expected value");
($k, $v) = each @lex_array;
-is ($k, 1);
-is ($v, 'SKLIZZORCH');
+is ($k, 1, "got expected index of next element");
+is ($v, 'SKLIZZORCH', "got expected value of next element");
($k) = each @lex_array;
-is ($k, 2);
-{
- $[ = -42;
- my ($k, $v) = each @lex_array;
- is ($k, -39);
- is ($v, 'PBLRBLPSFT');
-}
+is ($k, 2, "got expected index of remaining element");
(@r) = each @lex_array;
-is (scalar @r, 0);
+is (scalar @r, 0,
+ "no elements remaining to be iterated over in original array");
my $ar = ['bacon'];
(@r) = each @$ar;
-is (scalar @r, 2);
-is ($r[0], 0);
-is ($r[1], 'bacon');
+is (scalar @r, 2,
+ "'each' on array inside reference returns index and value of next element");
+is ($r[0], 0, "got expected index");
+is ($r[1], 'bacon', "got expected value of array element inside reference");
(@r) = each @$ar;
-is (scalar @r, 0);
+is (scalar @r, 0,
+ "no elements remaining to be iterated over in array inside reference");
-is (each @$ar, 0);
-is (scalar each @$ar, undef);
+is (each @$ar, 0, "scalar context 'each' on array returns expected index");
+is (scalar each @$ar, undef,
+ "no elements remaining to be iterated over; array reference case");
my @keys;
@keys = keys @array;
-is ("@keys", "0 1 2");
+is ("@keys", "0 1 2",
+ "'keys' on array in list context returns list of indices");
@keys = keys @lex_array;
-is ("@keys", "0 1 2 3");
+is ("@keys", "0 1 2",
+ "'keys' on another array in list context returns list of indices");
-{
- $[ = 1;
-
- @keys = keys @array;
- is ("@keys", "1 2 3");
-
- @keys = keys @lex_array;
- is ("@keys", "1 2 3 4");
-}
-
($k, $v) = each @array;
-is ($k, 0);
-is ($v, 'crunch');
+is ($k, 0, "got expected index");
+is ($v, 'crunch', "got expected value");
@keys = keys @array;
-is ("@keys", "0 1 2");
+is ("@keys", "0 1 2",
+ "'keys' on array in list context returns list of indices");
($k, $v) = each @array;
-is ($k, 0);
-is ($v, 'crunch');
+is ($k, 0, "following 'keys', got expected index");
+is ($v, 'crunch', "following 'keys', got expected value");
my @values;
@values = values @array;
-is ("@values", "@array");
+is ("@values", "@array",
+ "'values' on array returns list of values");
@values = values @lex_array;
-is ("@values", "@lex_array");
+is ("@values", "@lex_array",
+ "'values' on another array returns list of values");
-{
- $[ = 1;
+($k, $v) = each @array;
+is ($k, 0, "following 'values', got expected index");
+is ($v, 'crunch', "following 'values', got expected index");
- @values = values @array;
- is ("@values", "@array");
+ at values = values @array;
+is ("@values", "@array",
+ "following 'values' and 'each', 'values' continues to return expected list of values");
- @values = values @lex_array;
- is ("@values", "@lex_array");
+($k, $v) = each @array;
+is ($k, 0,
+ "following 'values', 'each' and 'values', 'each' continues to return expected index");
+is ($v, 'crunch',
+ "following 'values', 'each' and 'values', 'each' continues to return expected value");
+
+# reset
+while (each @array) { }
+
+# each(ARRAY) in the conditional loop
+$c = 0;
+while (($k, $v) = each @array) {
+ is ($k, $c, "'each' on array in loop returns expected index '$c'");
+ is ($v, $array[$k],
+ "'each' on array in loop returns expected value '$array[$k]'");
+ $c++;
}
-($k, $v) = each @array;
-is ($k, 0);
-is ($v, 'crunch');
+# each(ARRAY) on scalar context in conditional loop
+# should guarantee to be wrapped into defined() function.
+# first return value will be 0 --> [#90888]
+$c = 0;
+$k = 0;
+$v = 0;
+while ($k = each @array) {
+ is ($k, $v,
+ "'each' on array in scalar context in loop returns expected index '$v'");
+ $v++;
+}
- at values = values @array;
-is ("@values", "@array");
+# each(ARRAY) in the conditional loop
+$c = 0;
+for (; ($k, $v) = each @array ;) {
+ is ($k, $c,
+ "'each' on array in list context in loop returns expected index '$c'");
+ is ($v, $array[$k],
+ "'each' on array in list context in loop returns expected value '$array[$k]'");
+ $c++;
+}
-($k, $v) = each @array;
-is ($k, 0);
-is ($v, 'crunch');
+# each(ARRAY) on scalar context in conditional loop
+# --> [#90888]
+$c = 0;
+$k = 0;
+$v = 0;
+for (; $k = each(@array) ;) {
+ is ($k, $v,
+ "'each' on array in scalar context in loop returns expected index '$v'");
+ $v++;
+}
+
+# Reset the iterator when the array is cleared [RT #75596]
+{
+ my @a = 'a' .. 'c';
+ my ($i, $v) = each @a;
+ is ("$i-$v", '0-a', "got expected index and value");
+ @a = 'A' .. 'C';
+ ($i, $v) = each @a;
+ is ("$i-$v", '0-A',
+ "got expected new index and value after array gets new content");
+}
+
+# Check that the iterator is reset when localization ends
+{
+ @array = 'a' .. 'c';
+ my ($i, $v) = each @array;
+ is ("$i-$v", '0-a', "got expected index and value");
+ {
+ local @array = 'A' .. 'C';
+ my ($i, $v) = each @array;
+ is ("$i-$v", '0-A',
+ "got expected new index and value after array is localized and gets new content");
+ ($i, $v) = each @array;
+ is ("$i-$v", '1-B',
+ "got expected next index and value after array is localized and gets new content");
+ }
+ ($i, $v) = each @array;
+ is ("$i-$v", '1-b',
+ "got expected next index and value upon return to pre-localized array");
+ # Explicit reset
+ while (each @array) { }
+}
Property changes on: trunk/contrib/perl/t/op/each_array.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/eval.t
===================================================================
--- trunk/contrib/perl/t/op/eval.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/eval.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -6,7 +6,7 @@
require './test.pl';
}
-plan(tests => 118);
+plan(tests => 128);
eval 'pass();';
@@ -25,6 +25,11 @@
print eval '$foo = /'; # this tests for a call through fatal()
like($@, qr/Search/);
+is scalar(eval '++'), undef, 'eval syntax error in scalar context';
+is scalar(eval 'die'), undef, 'eval run-time error in scalar context';
+is +()=eval '++', 0, 'eval syntax error in list context';
+is +()=eval 'die', 0, 'eval run-time error in list context';
+
is(eval '"ok 7\n";', "ok 7\n");
$foo = 5;
@@ -432,13 +437,13 @@
{
no warnings;
- eval "/ /b;";
+ eval "&& $b;";
like($@, qr/^syntax error/, 'eval syntax error, no warnings');
}
-# a syntax error in an eval called magically 9eg vie tie or overload)
+# a syntax error in an eval called magically (eg via tie or overload)
# resulted in an assertion failure in S_docatch, since doeval had already
-# poppedthe EVAL context due to the failure, but S_docatch expected the
+# popped the EVAL context due to the failure, but S_docatch expected the
# context to still be there.
{
@@ -491,7 +496,7 @@
is($tombstone, "Done\n", 'Program completed successfully');
- $first =~ s/,pNOK//;
+ $first =~ s/p?[NI]OK,//g;
s/ PV = 0x[0-9a-f]+/ PV = 0x/ foreach $first, $second;
s/ LEN = [0-9]+/ LEN = / foreach $first, $second;
# Dump may double newlines through pipes, though not files
@@ -516,7 +521,7 @@
# test that the CV compiled for the eval is freed by checking that no additional
# reference to outside lexicals are made.
my $x;
- is(Internals::SvREFCNT($x), 1, "originally only 1 referece");
+ is(Internals::SvREFCNT($x), 1, "originally only 1 reference");
eval '$x';
is(Internals::SvREFCNT($x), 1, "execution eval doesn't create new references");
}
@@ -567,3 +572,49 @@
is "a" =~ /a/, "1",
"string eval leaves readonly lexicals readonly [perl #19135]";
}
+
+# [perl #68750]
+fresh_perl_is(<<'EOP', "ok\nok\nok\n", undef, 'eval clears %^H');
+ BEGIN {
+ require re; re->import('/x'); # should only affect surrounding scope
+ eval '
+ print "a b" =~ /a b/ ? "ok\n" : "nokay\n";
+ use re "/m";
+ print "a b" =~ /a b/ ? "ok\n" : "nokay\n";
+ ';
+ }
+ print "ab" =~ /a b/ ? "ok\n" : "nokay\n";
+EOP
+
+# [perl #70151]
+{
+ BEGIN { eval 'require re; import re "/x"' }
+ ok "ab" =~ /a b/, 'eval does not localise %^H at run time';
+}
+
+# The fix for perl #70151 caused an assertion failure that broke
+# SNMP::Trapinfo, when toke.c finds no syntax errors but perly.y fails.
+eval(q|""!=!~//|);
+pass("phew! dodged the assertion after a parsing (not lexing) error");
+
+# [perl #111462]
+{
+ local $ENV{PERL_DESTRUCT_LEVEL} = 1;
+ unlike
+ runperl(
+ prog => 'BEGIN { $^H{foo} = bar }'
+ .'our %FIELDS; my main $x; eval q[$x->{foo}]',
+ stderr => 1,
+ ),
+ qr/Unbalanced string table/,
+ 'Errors in finalize_optree do not leak string eval op tree';
+}
+
+# [perl #114658] Line numbers at end of string eval
+for("{;", "{") {
+ eval $_; is $@ =~ s/eval \d+/eval 1/rag, <<'EOE',
+Missing right curly or square bracket at (eval 1) line 1, at end of line
+syntax error at (eval 1) line 1, at EOF
+EOE
+ qq'Right line number for eval "$_"';
+}
Property changes on: trunk/contrib/perl/t/op/eval.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Copied: trunk/contrib/perl/t/op/evalbytes.t (from rev 6437, vendor/perl/5.18.1/t/op/evalbytes.t)
===================================================================
--- trunk/contrib/perl/t/op/evalbytes.t (rev 0)
+++ trunk/contrib/perl/t/op/evalbytes.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,34 @@
+#!./perl
+
+BEGIN {
+ chdir 't';
+ @INC = '../lib';
+ require './test.pl';
+}
+
+plan(tests => 8);
+
+{
+ local $SIG{__WARN__} = sub {};
+ eval "evalbytes 'foo'";
+ like $@, qr/syntax error/, 'evalbytes outside feature scope';
+}
+
+# We enable unicode_eval just to test that it does not interfere.
+use feature 'evalbytes', 'unicode_eval';
+
+is evalbytes("1+7"), 8, 'evalbytes basic sanity check';
+
+my $code = qq('\xff\xfe');
+is evalbytes($code), "\xff\xfe", 'evalbytes on extra-ASCII bytes';
+chop((my $upcode = $code) .= chr 256);
+is evalbytes($upcode), "\xff\xfe", 'evalbytes on upgraded extra-ASCII';
+{
+ use utf8;
+ is evalbytes($code), "\xff\xfe", 'evalbytes ignores outer utf8 pragma';
+}
+is evalbytes "use utf8; '\xc4\x80'", chr 256, 'use utf8 within evalbytes';
+chop($upcode = "use utf8; '\xc4\x80'" . chr 256);
+is evalbytes $upcode, chr 256, 'use utf8 within evalbytes on utf8 string';
+eval { evalbytes chr 256 };
+like $@, qr/Wide character/, 'evalbytes croaks on non-bytes';
Modified: trunk/contrib/perl/t/op/exec.t
===================================================================
--- trunk/contrib/perl/t/op/exec.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/exec.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -124,6 +124,7 @@
END
{
+ no warnings 'experimental::lexical_topic';
my $_ = qq($Perl -le "print 'ok'");
is( readpipe, "ok\n", 'readpipe default argument' );
}
Property changes on: trunk/contrib/perl/t/op/exec.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/exists_sub.t
===================================================================
--- trunk/contrib/perl/t/op/exists_sub.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/exists_sub.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -3,10 +3,9 @@
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
+ require './test.pl';
}
-print "1..9\n";
-
sub t1;
sub t2 : lvalue;
sub t3 ();
@@ -19,28 +18,66 @@
@ISA = 'P1';
}
-print "not " unless exists &t1 && not defined &t1;
-print "ok 1\n";
-print "not " unless exists &t2 && not defined &t2;
-print "ok 2\n";
-print "not " unless exists &t3 && not defined &t3;
-print "ok 3\n";
-print "not " unless exists &t4 && not defined &t4;
-print "ok 4\n";
-print "not " unless exists &t5 && defined &t5;
-print "ok 5\n";
-P2::->tmc;
-print "not " unless not exists &P2::tmc && not defined &P2::tmc;
-print "ok 6\n";
+my $has_t1 = ok( exists &t1, 't1 sub declared' );
+SKIP: {
+ skip 't1 sub was not declared', 1 if ! $has_t1;
+ ok( ! defined &t1, 't1 not defined' );
+}
+
+my $has_t2 = ok( exists &t2, 't2 sub declared' );
+SKIP: {
+ skip 't2 sub was not declared', 1 if ! $has_t2;
+ ok( ! defined &t2, 't2 not defined' );
+}
+
+my $has_t3 = ok( exists &t3, 't3 sub declared' );
+SKIP: {
+ skip 't3 sub was not declared', 1 if ! $has_t3;
+ ok( ! defined &t3, 't3 not defined' );
+}
+
+my $has_t4 = ok( exists &t4, 't4 sub declared' );
+SKIP: {
+ skip 't4 sub was not declared', 1 if ! $has_t4;
+ ok( ! defined &t4, 't4 not defined' );
+}
+
+my $has_t5 = ok( exists &t5, 't5 sub declared' );
+SKIP: {
+ skip 't5 sub was not declared', 1 if ! $has_t5;
+ ok( defined &t5, , 't5 defined' );
+}
+
+my $has_p2_tmc = ok(! exists &P2::tmc, 'P2::tmc not declared, it was inherited');
+SKIP: {
+ skip 'P2::tmc sub was not declared', 1 if ! $has_t5;
+ ok( ! defined &P2::tmc, 'P2::tmc not defined' );
+}
+
my $ref;
$ref->{A}[0] = \&t4;
-print "not " unless exists &{$ref->{A}[0]} && not defined &{$ref->{A}[0]};
-print "ok 7\n";
+my $ref_exists = ok( exists &{$ref->{A}[0]}, 'references to subroutines exist');
+SKIP: {
+ skip 1, 'Reference sub is not considered declared', 1 if ! $ref_exists;
+ ok( ! defined &{$ref->{A}[0]}, 'Reference to a sub is not defined' );
+}
+
+my $p1_tmc_exists = ok( exists &P1::tmc, 'test setup check');
+SKIP: {
+ skip 'Setup P1::tmc sub is not considered declared', 1 if ! $p1_tmc_exists;
+ ok( defined P1::tmc, 'Setup sub is defined' );
+}
+
undef &P1::tmc;
-print "not " unless exists &P1::tmc && not defined &P1::tmc;
-print "ok 8\n";
+$p1_tmc_exists = ok( exists &P1::tmc, 'P1::tmc was once defined, and continues to be after being undeffed');
+SKIP: {
+ skip( 'Sub P1::tmc still exists after having undef called on it', 1) if ! $p1_tmc_exists;
+ ok( ! defined &P1::tmc, 'P1::tmc is not longer defined after undef was called on it' );
+}
+
eval 'exists &t5()';
-print "not " unless $@;
-print "ok 9\n";
+like( $@, qr/not a subroutine name/, 'exists takes subroutine names with no argument list');
+done_testing();
+
exit 0;
Property changes on: trunk/contrib/perl/t/op/exists_sub.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/exp.t
===================================================================
--- trunk/contrib/perl/t/op/exp.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/exp.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -11,12 +11,12 @@
# compile time evaluation
$s = sqrt(2);
-is(substr($s,0,5), '1.414');
+is(substr($s,0,5), '1.414', 'compile time sqrt(2) == 1.414');
$s = exp(1);
-is(substr($s,0,7), '2.71828');
+is(substr($s,0,7), '2.71828', 'compile time exp(1) == e');
-cmp_ok(exp(log(1)), '==', 1);
+cmp_ok(exp(log(1)), '==', 1, 'compile time exp(log(1)) == 1');
# run time evaluation
@@ -23,12 +23,12 @@
$x1 = 1;
$x2 = 2;
$s = sqrt($x2);
-is(substr($s,0,5), '1.414');
+is(substr($s,0,5), '1.414', 'run time sqrt(2) == 1.414');
$s = exp($x1);
-is(substr($s,0,7), '2.71828');
+is(substr($s,0,7), '2.71828', 'run time exp(1) = e');
-cmp_ok(exp(log($x1)), '==', 1);
+cmp_ok(exp(log($x1)), '==', 1, 'run time exp(log(1)) == 1');
# tests for transcendental functions
@@ -41,18 +41,18 @@
}
# sin() tests
-cmp_ok(sin(0), '==', 0.0);
-cmp_ok(round(sin($pi)), '==', 0.0);
-cmp_ok(round(sin(-1 * $pi)), '==', 0.0);
-cmp_ok(round(sin($pi_2)), '==', 1.0);
-cmp_ok(round(sin(-1 * $pi_2)), '==', -1.0);
+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');
# cos() tests
-cmp_ok(cos(0), '==', 1.0);
-cmp_ok(round(cos($pi)), '==', -1.0);
-cmp_ok(round(cos(-1 * $pi)), '==', -1.0);
-cmp_ok(round(cos($pi_2)), '==', 0.0);
-cmp_ok(round(cos(-1 * $pi_2)), '==', 0.0);
+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
Property changes on: trunk/contrib/perl/t/op/exp.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/fh.t
===================================================================
--- trunk/contrib/perl/t/op/fh.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/fh.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -12,18 +12,18 @@
$|=1;
my $a = "SYM000";
-ok(!defined(fileno($a)));
-ok(!defined *{$a});
+ok(!defined(fileno($a)), 'initial file handle is undefined');
+ok(!defined *{$a}, 'initial typeglob of file handle is undefined');
select select $a;
-ok(defined *{$a});
+ok(defined *{$a}, 'typeglob of file handle defined after select');
$a++;
-ok(!close $a);
-ok(!defined *{$a});
+ok(!close $a, 'close does not succeed with incremented file handle');
+ok(!defined *{$a}, 'typeglob of file handle not defined after increment');
-ok(open($a, ">&STDOUT"));
-ok(defined *{$a});
+ok(open($a, ">&STDOUT"), 'file handle used with open of standard output');
+ok(defined *{$a}, 'typeglob of file handle defined after opening standard output');
-ok(close $a);
+ok(close $a, 'close standard output via file handle;');
Property changes on: trunk/contrib/perl/t/op/fh.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/filehandle.t
===================================================================
--- trunk/contrib/perl/t/op/filehandle.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/filehandle.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,8 +1,5 @@
#!./perl
-# There are few filetest operators that are portable enough to test.
-# See pod/perlport.pod for details.
-
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
@@ -15,12 +12,12 @@
my $str = "foo";
open my $fh, "<", \$str;
-is <$fh>, "foo";
+is <$fh>, "foo", "open fh to reference to string: got expected content";
eval {
$fh->seek(0, 0);
- is $fh->tell, 0;
- is <$fh>, "foo";
+ is $fh->tell, 0, "after 'seek' and 'tell', got expected current fh position in bytes";
+ is <$fh>, "foo", "after 'seek' and 'tell', still got expected content";
};
-is $@, '';
+is $@, '', "no errors after 'seek' or 'tell'";
Property changes on: trunk/contrib/perl/t/op/filehandle.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/filetest.t
===================================================================
--- trunk/contrib/perl/t/op/filetest.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/filetest.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -9,92 +9,121 @@
require './test.pl';
}
-use Config;
-plan(tests => 28 + 27*14);
+plan(tests => 50 + 27*14);
-ok( -d 'op' );
-ok( -f 'TEST' );
-ok( !-f 'op' );
-ok( !-d 'TEST' );
-ok( -r 'TEST' );
+# Tests presume we are in t/op directory and that file 'TEST' is found
+# therein.
+is(-d 'op', 1, "-d: directory correctly identified");
+is(-f 'TEST', 1, "-f: plain file correctly identified");
+isnt(-f 'op', 1, "-f: directory is not a plain file");
+isnt(-d 'TEST', 1, "-d: plain file is not a directory");
+is(-r 'TEST', 1, "-r: file readable by effective uid/gid not found");
-# Make a read only file
-my $ro_file = tempfile();
+# Make a read only file. This happens to be empty, so we also use it later.
+my $ro_empty_file = tempfile();
{
- open my $fh, '>', $ro_file or die "open $fh: $!";
+ open my $fh, '>', $ro_empty_file or die "open $fh: $!";
close $fh or die "close $fh: $!";
}
-chmod 0555, $ro_file or die "chmod 0555, '$ro_file' failed: $!";
+chmod 0555, $ro_empty_file or die "chmod 0555, '$ro_empty_file' failed: $!";
-$oldeuid = $>; # root can read and write anything
-eval '$> = 1'; # so switch uid (may not be implemented)
+SKIP: {
+ my $restore_root;
+ if ($> == 0) {
+ # root can read and write anything, so switch uid (may not be
+ # implemented)
+ eval '$> = 1';
-print "# oldeuid = $oldeuid, euid = $>\n";
-
-SKIP: {
- if (!$Config{d_seteuid}) {
- skip('no seteuid');
- }
- else {
- ok( !-w $ro_file );
+ skip("Can't drop root privs to test read-only files") if $> == 0;
+ note("Dropped root privs to test read-only files. \$> == $>");
+ ++$restore_root;
}
-}
-# Scripts are not -x everywhere so cannot test that.
+ isnt(-w $ro_empty_file, 1, "-w: file writable by effective uid/gid");
-eval '$> = $oldeuid'; # switch uid back (may not be implemented)
-
-# this would fail for the euid 1
-# (unless we have unpacked the source code as uid 1...)
-ok( -r 'op' );
-
-# this would fail for the euid 1
-# (unless we have unpacked the source code as uid 1...)
-SKIP: {
- if ($Config{d_seteuid}) {
- ok( -w 'op' );
- } else {
- skip('no seteuid');
+ if ($restore_root) {
+ # If the previous assignment to $> worked, so should this:
+ $> = 0;
+ note("Restored root privs after testing read-only files. \$> == $>");
}
}
-ok( -x 'op' ); # Hohum. Are directories -x everywhere?
+# these would fail for the euid 1
+# (unless we have unpacked the source code as uid 1...)
+is(-r 'op', 1, "-r: directory readable by effective uid/gid");
+is(-w 'op', 1, "-w: directory writable by effective uid/gid");
+is(-x 'op', 1, "-x: executable by effective uid/gid"); # Hohum. Are directories -x everywhere?
-is( "@{[grep -r, qw(foo io noo op zoo)]}", "io op" );
+is( "@{[grep -r, qw(foo io noo op zoo)]}", "io op",
+ "-r: found directories readable by effective uid/gid" );
# Test stackability of filetest operators
-ok( defined( -f -d 'TEST' ) && ! -f -d _ );
-ok( !defined( -e 'zoo' ) );
-ok( !defined( -e -d 'zoo' ) );
-ok( !defined( -f -e 'zoo' ) );
-ok( -f -e 'TEST' );
-ok( -e -f 'TEST' );
-ok( defined(-d -e 'TEST') );
-ok( defined(-e -d 'TEST') );
-ok( ! -f -d 'op' );
-ok( -x -d -x 'op' );
-ok( (-s -f 'TEST' > 1), "-s returns real size" );
-ok( -f -s 'TEST' == 1 );
+is(defined( -f -d 'TEST' ), 1, "-f and -d stackable: plain file found");
+isnt(-f -d _, 1, "-f and -d stackable: no plain file found");
+isnt(defined( -e 'zoo' ), 1, "-e: file does not exist");
+isnt(defined( -e -d 'zoo' ), 1, "-e and -d: neither file nor directory exists");
+isnt(defined( -f -e 'zoo' ), 1, "-f and -e: not a plain file and does not exist");
+is(-f -e 'TEST', 1, "-f and -e: plain file and exists");
+is(-e -f 'TEST', 1, "-e and -f: exists and is plain file");
+is(defined(-d -e 'TEST'), 1, "-d and -e: file at least exists");
+is(defined(-e -d 'TEST'), 1, "-e and -d: file at least exists");
+isnt( -f -d 'op', 1, "-f and -d: directory found but is not a plain file");
+is(-x -d -x 'op', 1, "-x, -d and -x again: directory exists and is executable");
+my ($size) = (stat 'TEST')[7];
+cmp_ok($size, '>', 1, 'TEST is longer than 1 byte');
+is( (-s -f 'TEST'), $size, "-s returns real size" );
+is(-f -s 'TEST', 1, "-f and -s: plain file with non-zero size");
# now with an empty file
-my $tempfile = tempfile();
-open my $fh, ">", $tempfile;
-close $fh;
-ok( -f $tempfile );
-is( -s $tempfile, 0 );
-is( -f -s $tempfile, 0 );
-is( -s -f $tempfile, 0 );
-unlink_all $tempfile;
+is(-f $ro_empty_file, 1, "-f: plain file found");
+is(-s $ro_empty_file, 0, "-s: file has 0 bytes");
+is(-f -s $ro_empty_file, 0, "-f and -s: plain file with 0 bytes");
+is(-s -f $ro_empty_file, 0, "-s and -f: file with 0 bytes is plain file");
+# stacked -l
+eval { -l -e "TEST" };
+like $@, qr/^The stat preceding -l _ wasn't an lstat at /,
+ 'stacked -l non-lstat error with warnings off';
+{
+ local $^W = 1;
+ eval { -l -e "TEST" };
+ like $@, qr/^The stat preceding -l _ wasn't an lstat at /,
+ 'stacked -l non-lstat error with warnings on';
+}
+# Make sure -l is using the previous stat buffer, and not using the previ-
+# ous op’s return value as a file name.
+# t/TEST can be a symlink under -Dmksymlinks, so use our temporary file.
+SKIP: {
+ use Perl::OSType 'os_type';
+ if (os_type ne 'Unix') { skip "Not Unix", 3 }
+ chomp(my $ln = `which ln`);
+ if ( ! -e $ln ) { skip "No ln" , 3 }
+ lstat $ro_empty_file;
+ `ln -s $ro_empty_file 1`;
+ isnt(-l -e _, 1, 'stacked -l uses previous stat, not previous retval');
+ unlink 1;
+
+ # Since we already have our skip block set up, we might as well put this
+ # test here, too:
+ # -l always treats a non-bareword argument as a file name
+ system 'ln', '-s', $ro_empty_file, \*foo;
+ local $^W = 1;
+ my @warnings;
+ local $SIG{__WARN__} = sub { push @warnings, @_ };
+ is(-l \*foo, 1, '-l \*foo is a file name');
+ ok($warnings[0] =~ /-l on filehandle foo/, 'warning for -l $handle');
+ unlink \*foo;
+}
+
# test that _ is a bareword after filetest operators
-f 'TEST';
-ok( -f _ );
+is(-f _, 1, "_ is bareword after filetest operator");
sub _ { "this is not a file name" }
-ok( -f _ );
+is(-f _, 1, "_ is bareword after filetest operator");
my $over;
{
@@ -149,7 +178,8 @@
for my $op (split //, "rwxoRWXOezsfdlpSbctugkTMBAC") {
$over = [];
- ok( my $rv = eval "-$op \$ft", "overloaded -$op succeeds" )
+ my $rv = eval "-$op \$ft";
+ isnt( $rv, undef, "overloaded -$op succeeds" )
or diag( $@ );
is( $over->[0], $ftstr, "correct object for overloaded -$op" );
is( $over->[1], $op, "correct op for overloaded -$op" );
@@ -168,8 +198,7 @@
$over = 0;
$rv = eval "-$op \$str";
- ok( !$@, "-$op succeeds with string overloading" )
- or diag( $@ );
+ is($@, "", "-$op succeeds with string overloading");
is( $rv, eval "-$op 'TEST'", "correct -$op on string overload" );
is( $over, $exp, "string overload $is called for -$op" );
@@ -191,10 +220,133 @@
is( $rv, "-$op", "correct -$op on string/-X overload" );
$rv = eval "-$op \$neither";
- ok( !$@, "-$op succeeds with random overloading" )
- or diag( $@ );
+ is($@, "", "-$op succeeds with random overloading");
is( $rv, eval "-$op \$nstr", "correct -$op with random overloading" );
is( eval "-r -$op \$ft", "-r", "stacked overloaded -$op" );
is( eval "-$op -r \$ft", "-$op", "overloaded stacked -$op" );
}
+
+# -l stack corruption: this bug occurred from 5.8 to 5.14
+{
+ push my @foo, "bar", -l baz;
+ is $foo[0], "bar", '-l bareword does not corrupt the stack';
+}
+
+# -l and fatal warnings
+stat "test.pl";
+eval { use warnings FATAL => io; -l cradd };
+isnt(stat _, 1,
+ 'fatal warnings do not prevent -l HANDLE from setting stat status');
+
+# File test ops should not call get-magic on the topmost SV on the stack if
+# it belongs to another op.
+{
+ my $w;
+ sub oon::TIESCALAR{bless[],'oon'}
+ sub oon::FETCH{$w++}
+ tie my $t, 'oon';
+ push my @a, $t, -t;
+ is $w, 1, 'file test does not call FETCH on stack item not its own';
+}
+
+# -T and -B
+
+my $Perl = which_perl();
+
+SKIP: {
+ skip "no -T on filehandles", 8 unless eval { -T STDERR; 1 };
+
+ # Test that -T HANDLE sets the last stat type
+ -l "perl.c"; # last stat type is now lstat
+ -T STDERR; # should set it to stat, since -T does a stat
+ eval { -l _ }; # should die, because the last stat type is not lstat
+ like $@, qr/^The stat preceding -l _ wasn't an lstat at /,
+ '-T HANDLE sets the stat type';
+
+ # statgv should be cleared when freed
+ fresh_perl_is
+ 'open my $fh, "test.pl"; -r $fh; undef $fh; open my $fh2, '
+ . "q\0$Perl\0; print -B _",
+ '',
+ { switches => ['-l'] },
+ 'PL_statgv should not point to freed-and-reused SV';
+
+ # or coerced into a non-glob
+ fresh_perl_is
+ 'open Fh, "test.pl"; -r($h{i} = *Fh); $h{i} = 3; undef %h;'
+ . 'open my $fh2, ' . "q\0" . which_perl() . "\0; print -B _",
+ '',
+ { switches => ['-l'] },
+ 'PL_statgv should not point to coerced-freed-and-reused GV';
+
+ # -T _ should work after stat $ioref
+ open my $fh, 'test.pl';
+ stat $Perl; # a binary file
+ stat *$fh{IO};
+ is(-T _, 1, '-T _ works after stat $ioref');
+
+ # and after -r $ioref
+ -r *$fh{IO};
+ is(-T _, 1, '-T _ works after -r $ioref');
+
+ # -T _ on closed filehandle should still reset stat info
+ stat $fh;
+ close $fh;
+ -T _;
+ isnt(stat _, 1, '-T _ on closed filehandle resets stat info');
+
+ lstat "test.pl";
+ -T $fh; # closed
+ eval { lstat _ };
+ like $@, qr/^The stat preceding lstat\(\) wasn't an lstat at /,
+ '-T on closed handle resets last stat type';
+
+ # Fatal warnings should not affect the setting of errno.
+ $! = 7;
+ -T cradd;
+ my $errno = $!;
+ $! = 7;
+ eval { use warnings FATAL => unopened; -T cradd };
+ my $errno2 = $!;
+ is $errno2, $errno,
+ 'fatal warnings do not affect errno after -T BADHADNLE';
+}
+
+is runperl(prog => '-T _', switches => ['-w'], stderr => 1), "",
+ 'no uninit warnings from -T with no preceding stat';
+
+SKIP: {
+ my $rand_file_name = 'filetest-' . rand =~ y/.//dr;
+ if (-e $rand_file_name) { skip "File $rand_file_name exists", 1 }
+ stat 'test.pl';
+ -T $rand_file_name;
+ isnt(stat _, 1, '-T "nonexistent" resets stat success status');
+}
+
+# Unsuccessful filetests on filehandles should leave stat buffers in the
+# same state whether fatal warnings are on or off.
+{
+ stat "test.pl";
+ # This GV has no IO
+ -r *phlon;
+ my $failed_stat1 = stat _;
+
+ stat "test.pl";
+ eval { use warnings FATAL => unopened; -r *phlon };
+ my $failed_stat2 = stat _;
+
+ is $failed_stat2, $failed_stat1,
+ 'failed -r($gv_without_io) with and w/out fatal warnings';
+
+ stat "test.pl";
+ -r cength; # at compile time autovivifies IO, but with no fp
+ $failed_stat1 = stat _;
+
+ stat "test.pl";
+ eval { use warnings FATAL => unopened; -r cength };
+ $failed_stat2 = stat _;
+
+ is $failed_stat2, $failed_stat1,
+ 'failed -r($gv_with_io_but_no_fp) with and w/out fatal warnings';
+}
Property changes on: trunk/contrib/perl/t/op/filetest.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/filetest_stack_ok.t
===================================================================
--- trunk/contrib/perl/t/op/filetest_stack_ok.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/filetest_stack_ok.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -12,10 +12,14 @@
my @ops = split //, 'rwxoRWXOezsfdlpSbctugkTMBAC';
-plan( tests => @ops * 3 );
+plan( tests => @ops * 5 );
+package o { use overload '-X' => sub { 1 } }
+my $o = bless [], 'o';
+
for my $op (@ops) {
ok( 1 == @{ [ eval "-$op 'TEST'" ] }, "-$op returns single value" );
+ ok( 1 == @{ [ eval "-$op *TEST" ] }, "-$op *gv returns single value" );
my $count = 0;
my $t;
@@ -35,12 +39,11 @@
$t = eval "-$op -e \$^X" ? 0 : "bar";
}
elsif ($count == 1) {
- local $TODO;
- if ($op eq 'T' or $op eq 't' or $op eq 'B') {
- $TODO = "[perl #77388] stacked file test does not work with -$op";
- }
is($m, "d", "-$op -e \$^X did not remove too many values from the stack");
}
$count++;
}
+
+ my @foo = eval "-$op \$o";
+ is @foo, 1, "-$op \$overld did not leave \$overld on the stack";
}
Property changes on: trunk/contrib/perl/t/op/filetest_stack_ok.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/filetest_t.t
===================================================================
--- trunk/contrib/perl/t/op/filetest_t.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/filetest_t.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -8,7 +8,7 @@
use strict;
-plan 2;
+plan 7;
my($dev_tty, $dev_null) = qw(/dev/tty /dev/null);
($dev_tty, $dev_null) = qw(con nul ) if $^O =~ /^(MSWin32|os2)$/;
@@ -16,16 +16,23 @@
SKIP: {
open(my $tty, "<", $dev_tty)
- or skip("Can't open terminal '$dev_tty': $!");
+ or skip("Can't open terminal '$dev_tty': $!", 4);
if ($^O eq 'VMS') {
# TT might be a mailbox or other non-terminal device
my $tt_dev = VMS::Filespec::vmspath('TT');
- skip("'$tt_dev' is probably not a terminal") if $tt_dev !~ m/^_(tt|ft|rt)/i;
+ skip("'$tt_dev' is probably not a terminal", 4) if $tt_dev !~ m/^_(tt|ft|rt)/i;
}
ok(-t $tty, "'$dev_tty' is a TTY");
+ ok(-t -e $tty, "'$dev_tty' is a TTY (with -t -e)");
+ -e 'mehyparchonarcheion'; # clear last stat buffer
+ ok(-e -t $tty, "'$dev_tty' is a TTY (with -e -t)");
+ -e 'mehyparchonarcheion';
+ ok(-e -t -t $tty, "'$dev_tty' is a TTY (with -e -t -t)");
}
SKIP: {
open(my $null, "<", $dev_null)
- or skip("Can't open null device '$dev_null': $!");
+ or skip("Can't open null device '$dev_null': $!", 3);
ok(!-t $null, "'$dev_null' is not a TTY");
+ ok(!-t -e $null, "'$dev_null' is not a TTY (with -t -e)");
+ ok(!-e -t $null, "'$dev_null' is not a TTY (with -e -t)");
}
Property changes on: trunk/contrib/perl/t/op/filetest_t.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/op/flip.t
===================================================================
--- trunk/contrib/perl/t/op/flip.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/flip.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/flip.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/t/op/for.t (from rev 6437, vendor/perl/5.18.1/t/op/for.t)
===================================================================
--- trunk/contrib/perl/t/op/for.t (rev 0)
+++ trunk/contrib/perl/t/op/for.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,564 @@
+#!./perl
+
+BEGIN {
+ require "test.pl";
+}
+
+plan(104);
+
+# A lot of tests to check that reversed for works.
+
+ at array = ('A', 'B', 'C');
+for (@array) {
+ $r .= $_;
+}
+is ($r, 'ABC', 'Forwards for array');
+$r = '';
+for (1,2,3) {
+ $r .= $_;
+}
+is ($r, '123', 'Forwards for list');
+$r = '';
+for (map {$_} @array) {
+ $r .= $_;
+}
+is ($r, 'ABC', 'Forwards for array via map');
+$r = '';
+for (map {$_} 1,2,3) {
+ $r .= $_;
+}
+is ($r, '123', 'Forwards for list via map');
+$r = '';
+for (1 .. 3) {
+ $r .= $_;
+}
+is ($r, '123', 'Forwards for list via ..');
+$r = '';
+for ('A' .. 'C') {
+ $r .= $_;
+}
+is ($r, 'ABC', 'Forwards for list via ..');
+
+$r = '';
+for (reverse @array) {
+ $r .= $_;
+}
+is ($r, 'CBA', 'Reverse for array');
+$r = '';
+for (reverse 1,2,3) {
+ $r .= $_;
+}
+is ($r, '321', 'Reverse for list');
+$r = '';
+for (reverse map {$_} @array) {
+ $r .= $_;
+}
+is ($r, 'CBA', 'Reverse for array via map');
+$r = '';
+for (reverse map {$_} 1,2,3) {
+ $r .= $_;
+}
+is ($r, '321', 'Reverse for list via map');
+$r = '';
+for (reverse 1 .. 3) {
+ $r .= $_;
+}
+is ($r, '321', 'Reverse for list via ..');
+$r = '';
+for (reverse 'A' .. 'C') {
+ $r .= $_;
+}
+is ($r, 'CBA', 'Reverse for list via ..');
+
+$r = '';
+for my $i (@array) {
+ $r .= $i;
+}
+is ($r, 'ABC', 'Forwards for array with var');
+$r = '';
+for my $i (1,2,3) {
+ $r .= $i;
+}
+is ($r, '123', 'Forwards for list with var');
+$r = '';
+for my $i (map {$_} @array) {
+ $r .= $i;
+}
+is ($r, 'ABC', 'Forwards for array via map with var');
+$r = '';
+for my $i (map {$_} 1,2,3) {
+ $r .= $i;
+}
+is ($r, '123', 'Forwards for list via map with var');
+$r = '';
+for my $i (1 .. 3) {
+ $r .= $i;
+}
+is ($r, '123', 'Forwards for list via .. with var');
+$r = '';
+for my $i ('A' .. 'C') {
+ $r .= $i;
+}
+is ($r, 'ABC', 'Forwards for list via .. with var');
+
+$r = '';
+for my $i (reverse @array) {
+ $r .= $i;
+}
+is ($r, 'CBA', 'Reverse for array with var');
+$r = '';
+for my $i (reverse 1,2,3) {
+ $r .= $i;
+}
+is ($r, '321', 'Reverse for list with var');
+$r = '';
+for my $i (reverse map {$_} @array) {
+ $r .= $i;
+}
+is ($r, 'CBA', 'Reverse for array via map with var');
+$r = '';
+for my $i (reverse map {$_} 1,2,3) {
+ $r .= $i;
+}
+is ($r, '321', 'Reverse for list via map with var');
+$r = '';
+for my $i (reverse 1 .. 3) {
+ $r .= $i;
+}
+is ($r, '321', 'Reverse for list via .. with var');
+$r = '';
+for my $i (reverse 'A' .. 'C') {
+ $r .= $i;
+}
+is ($r, 'CBA', 'Reverse for list via .. with var');
+
+# For some reason the generate optree is different when $_ is implicit.
+$r = '';
+for $_ (@array) {
+ $r .= $_;
+}
+is ($r, 'ABC', 'Forwards for array with explicit $_');
+$r = '';
+for $_ (1,2,3) {
+ $r .= $_;
+}
+is ($r, '123', 'Forwards for list with explicit $_');
+$r = '';
+for $_ (map {$_} @array) {
+ $r .= $_;
+}
+is ($r, 'ABC', 'Forwards for array via map with explicit $_');
+$r = '';
+for $_ (map {$_} 1,2,3) {
+ $r .= $_;
+}
+is ($r, '123', 'Forwards for list via map with explicit $_');
+$r = '';
+for $_ (1 .. 3) {
+ $r .= $_;
+}
+is ($r, '123', 'Forwards for list via .. with var with explicit $_');
+$r = '';
+for $_ ('A' .. 'C') {
+ $r .= $_;
+}
+is ($r, 'ABC', 'Forwards for list via .. with var with explicit $_');
+
+$r = '';
+for $_ (reverse @array) {
+ $r .= $_;
+}
+is ($r, 'CBA', 'Reverse for array with explicit $_');
+$r = '';
+for $_ (reverse 1,2,3) {
+ $r .= $_;
+}
+is ($r, '321', 'Reverse for list with explicit $_');
+$r = '';
+for $_ (reverse map {$_} @array) {
+ $r .= $_;
+}
+is ($r, 'CBA', 'Reverse for array via map with explicit $_');
+$r = '';
+for $_ (reverse map {$_} 1,2,3) {
+ $r .= $_;
+}
+is ($r, '321', 'Reverse for list via map with explicit $_');
+$r = '';
+for $_ (reverse 1 .. 3) {
+ $r .= $_;
+}
+is ($r, '321', 'Reverse for list via .. with var with explicit $_');
+$r = '';
+for $_ (reverse 'A' .. 'C') {
+ $r .= $_;
+}
+is ($r, 'CBA', 'Reverse for list via .. with var with explicit $_');
+
+# I don't think that my is that different from our in the optree. But test a
+# few:
+$r = '';
+for our $i (reverse @array) {
+ $r .= $i;
+}
+is ($r, 'CBA', 'Reverse for array with our var');
+$r = '';
+for our $i (reverse 1,2,3) {
+ $r .= $i;
+}
+is ($r, '321', 'Reverse for list with our var');
+$r = '';
+for our $i (reverse map {$_} @array) {
+ $r .= $i;
+}
+is ($r, 'CBA', 'Reverse for array via map with our var');
+$r = '';
+for our $i (reverse map {$_} 1,2,3) {
+ $r .= $i;
+}
+is ($r, '321', 'Reverse for list via map with our var');
+$r = '';
+for our $i (reverse 1 .. 3) {
+ $r .= $i;
+}
+is ($r, '321', 'Reverse for list via .. with our var');
+$r = '';
+for our $i (reverse 'A' .. 'C') {
+ $r .= $i;
+}
+is ($r, 'CBA', 'Reverse for list via .. with our var');
+
+
+$r = '';
+for (1, reverse @array) {
+ $r .= $_;
+}
+is ($r, '1CBA', 'Reverse for array with leading value');
+$r = '';
+for ('A', reverse 1,2,3) {
+ $r .= $_;
+}
+is ($r, 'A321', 'Reverse for list with leading value');
+$r = '';
+for (1, reverse map {$_} @array) {
+ $r .= $_;
+}
+is ($r, '1CBA', 'Reverse for array via map with leading value');
+$r = '';
+for ('A', reverse map {$_} 1,2,3) {
+ $r .= $_;
+}
+is ($r, 'A321', 'Reverse for list via map with leading value');
+$r = '';
+for ('A', reverse 1 .. 3) {
+ $r .= $_;
+}
+is ($r, 'A321', 'Reverse for list via .. with leading value');
+$r = '';
+for (1, reverse 'A' .. 'C') {
+ $r .= $_;
+}
+is ($r, '1CBA', 'Reverse for list via .. with leading value');
+
+$r = '';
+for (reverse (@array), 1) {
+ $r .= $_;
+}
+is ($r, 'CBA1', 'Reverse for array with trailing value');
+$r = '';
+for (reverse (1,2,3), 'A') {
+ $r .= $_;
+}
+is ($r, '321A', 'Reverse for list with trailing value');
+$r = '';
+for (reverse (map {$_} @array), 1) {
+ $r .= $_;
+}
+is ($r, 'CBA1', 'Reverse for array via map with trailing value');
+$r = '';
+for (reverse (map {$_} 1,2,3), 'A') {
+ $r .= $_;
+}
+is ($r, '321A', 'Reverse for list via map with trailing value');
+$r = '';
+for (reverse (1 .. 3), 'A') {
+ $r .= $_;
+}
+is ($r, '321A', 'Reverse for list via .. with trailing value');
+$r = '';
+for (reverse ('A' .. 'C'), 1) {
+ $r .= $_;
+}
+is ($r, 'CBA1', 'Reverse for list via .. with trailing value');
+
+
+$r = '';
+for $_ (1, reverse @array) {
+ $r .= $_;
+}
+is ($r, '1CBA', 'Reverse for array with leading value with explicit $_');
+$r = '';
+for $_ ('A', reverse 1,2,3) {
+ $r .= $_;
+}
+is ($r, 'A321', 'Reverse for list with leading value with explicit $_');
+$r = '';
+for $_ (1, reverse map {$_} @array) {
+ $r .= $_;
+}
+is ($r, '1CBA',
+ 'Reverse for array via map with leading value with explicit $_');
+$r = '';
+for $_ ('A', reverse map {$_} 1,2,3) {
+ $r .= $_;
+}
+is ($r, 'A321', 'Reverse for list via map with leading value with explicit $_');
+$r = '';
+for $_ ('A', reverse 1 .. 3) {
+ $r .= $_;
+}
+is ($r, 'A321', 'Reverse for list via .. with leading value with explicit $_');
+$r = '';
+for $_ (1, reverse 'A' .. 'C') {
+ $r .= $_;
+}
+is ($r, '1CBA', 'Reverse for list via .. with leading value with explicit $_');
+
+$r = '';
+for $_ (reverse (@array), 1) {
+ $r .= $_;
+}
+is ($r, 'CBA1', 'Reverse for array with trailing value with explicit $_');
+$r = '';
+for $_ (reverse (1,2,3), 'A') {
+ $r .= $_;
+}
+is ($r, '321A', 'Reverse for list with trailing value with explicit $_');
+$r = '';
+for $_ (reverse (map {$_} @array), 1) {
+ $r .= $_;
+}
+is ($r, 'CBA1',
+ 'Reverse for array via map with trailing value with explicit $_');
+$r = '';
+for $_ (reverse (map {$_} 1,2,3), 'A') {
+ $r .= $_;
+}
+is ($r, '321A',
+ 'Reverse for list via map with trailing value with explicit $_');
+$r = '';
+for $_ (reverse (1 .. 3), 'A') {
+ $r .= $_;
+}
+is ($r, '321A', 'Reverse for list via .. with trailing value with explicit $_');
+$r = '';
+for $_ (reverse ('A' .. 'C'), 1) {
+ $r .= $_;
+}
+is ($r, 'CBA1', 'Reverse for list via .. with trailing value with explicit $_');
+
+$r = '';
+for my $i (1, reverse @array) {
+ $r .= $i;
+}
+is ($r, '1CBA', 'Reverse for array with leading value and var');
+$r = '';
+for my $i ('A', reverse 1,2,3) {
+ $r .= $i;
+}
+is ($r, 'A321', 'Reverse for list with leading value and var');
+$r = '';
+for my $i (1, reverse map {$_} @array) {
+ $r .= $i;
+}
+is ($r, '1CBA', 'Reverse for array via map with leading value and var');
+$r = '';
+for my $i ('A', reverse map {$_} 1,2,3) {
+ $r .= $i;
+}
+is ($r, 'A321', 'Reverse for list via map with leading value and var');
+$r = '';
+for my $i ('A', reverse 1 .. 3) {
+ $r .= $i;
+}
+is ($r, 'A321', 'Reverse for list via .. with leading value and var');
+$r = '';
+for my $i (1, reverse 'A' .. 'C') {
+ $r .= $i;
+}
+is ($r, '1CBA', 'Reverse for list via .. with leading value and var');
+
+$r = '';
+for my $i (reverse (@array), 1) {
+ $r .= $i;
+}
+is ($r, 'CBA1', 'Reverse for array with trailing value and var');
+$r = '';
+for my $i (reverse (1,2,3), 'A') {
+ $r .= $i;
+}
+is ($r, '321A', 'Reverse for list with trailing value and var');
+$r = '';
+for my $i (reverse (map {$_} @array), 1) {
+ $r .= $i;
+}
+is ($r, 'CBA1', 'Reverse for array via map with trailing value and var');
+$r = '';
+for my $i (reverse (map {$_} 1,2,3), 'A') {
+ $r .= $i;
+}
+is ($r, '321A', 'Reverse for list via map with trailing value and var');
+$r = '';
+for my $i (reverse (1 .. 3), 'A') {
+ $r .= $i;
+}
+is ($r, '321A', 'Reverse for list via .. with trailing value and var');
+$r = '';
+for my $i (reverse ('A' .. 'C'), 1) {
+ $r .= $i;
+}
+is ($r, 'CBA1', 'Reverse for list via .. with trailing value and var');
+
+
+$r = '';
+for (reverse 1, @array) {
+ $r .= $_;
+}
+is ($r, 'CBA1', 'Reverse for value and array');
+$r = '';
+for (reverse map {$_} 1, @array) {
+ $r .= $_;
+}
+is ($r, 'CBA1', 'Reverse for value and array via map');
+$r = '';
+for (reverse 1 .. 3, @array) {
+ $r .= $_;
+}
+is ($r, 'CBA321', 'Reverse for .. and array');
+$r = '';
+for (reverse 'X' .. 'Z', @array) {
+ $r .= $_;
+}
+is ($r, 'CBAZYX', 'Reverse for .. and array');
+$r = '';
+for (reverse map {$_} 1 .. 3, @array) {
+ $r .= $_;
+}
+is ($r, 'CBA321', 'Reverse for .. and array via map');
+$r = '';
+for (reverse map {$_} 'X' .. 'Z', @array) {
+ $r .= $_;
+}
+is ($r, 'CBAZYX', 'Reverse for .. and array via map');
+
+$r = '';
+for (reverse (@array, 1)) {
+ $r .= $_;
+}
+is ($r, '1CBA', 'Reverse for array and value');
+$r = '';
+for (reverse (map {$_} @array, 1)) {
+ $r .= $_;
+}
+is ($r, '1CBA', 'Reverse for array and value via map');
+
+$r = '';
+for $_ (reverse 1, @array) {
+ $r .= $_;
+}
+is ($r, 'CBA1', 'Reverse for value and array with explicit $_');
+$r = '';
+for $_ (reverse map {$_} 1, @array) {
+ $r .= $_;
+}
+is ($r, 'CBA1', 'Reverse for value and array via map with explicit $_');
+$r = '';
+for $_ (reverse 1 .. 3, @array) {
+ $r .= $_;
+}
+is ($r, 'CBA321', 'Reverse for .. and array with explicit $_');
+$r = '';
+for $_ (reverse 'X' .. 'Z', @array) {
+ $r .= $_;
+}
+is ($r, 'CBAZYX', 'Reverse for .. and array with explicit $_');
+$r = '';
+for $_ (reverse map {$_} 1 .. 3, @array) {
+ $r .= $_;
+}
+is ($r, 'CBA321', 'Reverse for .. and array via map with explicit $_');
+$r = '';
+for $_ (reverse map {$_} 'X' .. 'Z', @array) {
+ $r .= $_;
+}
+is ($r, 'CBAZYX', 'Reverse for .. and array via map with explicit $_');
+
+$r = '';
+for $_ (reverse (@array, 1)) {
+ $r .= $_;
+}
+is ($r, '1CBA', 'Reverse for array and value with explicit $_');
+$r = '';
+for $_ (reverse (map {$_} @array, 1)) {
+ $r .= $_;
+}
+is ($r, '1CBA', 'Reverse for array and value via map with explicit $_');
+
+
+$r = '';
+for my $i (reverse 1, @array) {
+ $r .= $i;
+}
+is ($r, 'CBA1', 'Reverse for value and array with var');
+$r = '';
+for my $i (reverse map {$_} 1, @array) {
+ $r .= $i;
+}
+is ($r, 'CBA1', 'Reverse for value and array via map with var');
+$r = '';
+for my $i (reverse 1 .. 3, @array) {
+ $r .= $i;
+}
+is ($r, 'CBA321', 'Reverse for .. and array with var');
+$r = '';
+for my $i (reverse 'X' .. 'Z', @array) {
+ $r .= $i;
+}
+is ($r, 'CBAZYX', 'Reverse for .. and array with var');
+$r = '';
+for my $i (reverse map {$_} 1 .. 3, @array) {
+ $r .= $i;
+}
+is ($r, 'CBA321', 'Reverse for .. and array via map with var');
+$r = '';
+for my $i (reverse map {$_} 'X' .. 'Z', @array) {
+ $r .= $i;
+}
+is ($r, 'CBAZYX', 'Reverse for .. and array via map with var');
+
+$r = '';
+for my $i (reverse (@array, 1)) {
+ $r .= $i;
+}
+is ($r, '1CBA', 'Reverse for array and value with var');
+$r = '';
+for my $i (reverse (map {$_} @array, 1)) {
+ $r .= $i;
+}
+is ($r, '1CBA', 'Reverse for array and value via map with var');
+
+TODO: {
+ if (do {17; foreach (1, 2) { 1; } } != 17) {
+ #print "not ";
+ todo_skip("RT #1085: what should be output of perl -we 'print do { foreach (1, 2) { 1; } }'");
+ }
+}
+
+TODO: {
+ local $TODO = "RT #2166: foreach spuriously autovivifies";
+ my %h;
+ foreach (@h{a, b}) {}
+ if(keys(%h)) {
+ todo_skip("RT #2166: foreach spuriously autovivifies");
+ }
+}
Modified: trunk/contrib/perl/t/op/fork.t
===================================================================
--- trunk/contrib/perl/t/op/fork.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/fork.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -11,13 +11,32 @@
unless ($Config::Config{d_fork} or $Config::Config{d_pseudofork});
}
-skip_all('fork/status problems on MPE/iX')
- if $^O eq 'mpeix';
-
$|=1;
run_multiple_progs('', \*DATA);
+my $shell = $ENV{SHELL} || '';
+SKIP: {
+ skip "This test can only be run under bash or zsh"
+ unless $shell =~ m{/(?:ba|z)sh$};
+ my $probe = qx{
+ $shell -c 'ulimit -u 1 2>&1 && echo good'
+ };
+ chomp $probe;
+ skip "Can't set ulimit -u on this system: $probe"
+ unless $probe eq 'good';
+
+ my $out = qx{
+ $shell -c 'ulimit -u 1; exec $^X -e "
+ print((() = fork) == 1 ? q[ok] : q[not ok])
+ "'
+ };
+ # perl #117141
+ skip "fork() didn't fail, maybe you're running as root", 1
+ if $out eq "okok";
+ is($out, "ok", "bash/zsh-only test for 'fork' returning undef on failure");
+}
+
done_testing();
__END__
Property changes on: trunk/contrib/perl/t/op/fork.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Copied: trunk/contrib/perl/t/op/fresh_perl_utf8.t (from rev 6437, vendor/perl/5.18.1/t/op/fresh_perl_utf8.t)
===================================================================
--- trunk/contrib/perl/t/op/fresh_perl_utf8.t (rev 0)
+++ trunk/contrib/perl/t/op/fresh_perl_utf8.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,21 @@
+#!./perl
+
+#This file is intentionally written in UTF-8
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require './test.pl';
+}
+
+plan 1;
+
+use utf8;
+use strict;
+use open qw( :utf8 :std );
+
+{
+ local $@;
+ eval 'sub testme { my $ᨕ = "test"; { local $ᨕ = "new test"; print $ᨕ } }';
+ like( $@, qr/Can't localize lexical variable \$ᨕ at /u, q!"Can't localize lexical" error is in UTF-8! );
+}
Modified: trunk/contrib/perl/t/op/getpid.t
===================================================================
--- trunk/contrib/perl/t/op/getpid.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/getpid.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -30,5 +30,21 @@
new threads( sub { ($pid2, $ppid2) = ($$, getppid()); } ) -> join();
-is($pid, $pid2, 'pids');
-is($ppid, $ppid2, 'ppids');
+# If this breaks you're either running under LinuxThreads (and we
+# haven't detected it) or your system doesn't have POSIX thread
+# semantics.
+# Newer linuxthreads from gnukfreebsd (0.11) does have POSIX thread
+# semantics, so include a version check
+# <http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=675606>
+my $thread_version = qx[getconf GNU_LIBPTHREAD_VERSION 2>&1];
+chomp $thread_version;
+if ($^O =~ /^(?:gnukfreebsd|linux)$/ and
+ $thread_version =~ /linuxthreads/ and
+ !($thread_version =~ /linuxthreads-(.*)/ && $1 >= 0.11)) {
+ diag "We're running under $^O with linuxthreads <$thread_version>";
+ isnt($pid, $pid2, "getpid() in a thread is different from the parent on this non-POSIX system");
+ isnt($ppid, $ppid2, "getppid() in a thread is different from the parent on this non-POSIX system");
+} else {
+ is($pid, $pid2, 'getpid() in a thread is the same as in the parent');
+ is($ppid, $ppid2, 'getppid() in a thread is the same as in the parent');
+}
Property changes on: trunk/contrib/perl/t/op/getpid.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/getppid.t
===================================================================
--- trunk/contrib/perl/t/op/getppid.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/getppid.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -20,6 +20,9 @@
plan (8);
}
+# No, we don't want any zombies. kill 0, $ppid spots zombies :-(
+$SIG{CHLD} = 'IGNORE';
+
sub fork_and_retrieve {
my $which = shift;
pipe my ($r, $w) or die "pipe: $!\n";
@@ -27,13 +30,16 @@
if ($pid) {
# parent
- close $w;
+ close $w or die "close: $!\n";
$_ = <$r>;
chomp;
die "Garbled output '$_'"
- unless my ($first, $second) = /^(\d+),(\d+)\z/;
+ unless my ($how, $first, $second) = /^([a-z]+),(\d+),(\d+)\z/;
cmp_ok ($first, '>=', 1, "Parent of $which grandchild");
- cmp_ok ($second, '>=', 1, "New parent of orphaned $which grandchild");
+ my $message = "grandchild waited until '$how'";
+ cmp_ok ($second, '>=', 1, "New parent of orphaned $which grandchild")
+ ? note ($message) : diag ($message);
+
SKIP: {
skip("Orphan processes are not reparented on QNX", 1)
if $^O eq 'nto';
@@ -46,20 +52,55 @@
# child
# Prevent test.pl from thinking that we failed to run any tests.
$::NO_ENDING = 1;
- close $r;
+ close $r or die "close: $!\n";
+ pipe my ($r2, $w2) or die "pipe: $!\n";
+ pipe my ($r3, $w3) or die "pipe: $!\n";
my $pid2 = fork; defined $pid2 or die "fork: $!\n";
if ($pid2) {
- close $w;
- sleep 1;
+ close $w or die "close: $!\n";
+ close $w2 or die "close: $!\n";
+ close $r3 or die "close: $!\n";
+ # Wait for our child to signal that it's read our PID:
+ <$r2>;
+ # Implicit close of $w3:
+ exit 0;
}
else {
# grandchild
+ close $r2 or die "close: $!\n";
+ close $w3 or die "close: $!\n";
my $ppid1 = getppid();
- # Wait for immediate parent to exit
- sleep 2;
+ # kill 0 isn't portable:
+ my $can_kill0 = eval {
+ kill 0, $ppid1;
+ };
+ my $how = $can_kill0 ? 'undead' : 'sleep';
+
+ # Tell immediate parent to exit:
+ close $w2 or die "close: $!\n";
+ # Wait for it to (start to) exit:
+ <$r3>;
+ # Which sadly isn't enough to be sure that it has exited - often we
+ # get switched in during its shutdown, after $w3 closes but before
+ # it exits and we get reparented.
+ if ($can_kill0) {
+ # use kill 0 where possible. Try 10 times, then give up:
+ for (0..9) {
+ my $got = kill 0, $ppid1;
+ die "kill: $!" unless defined $got;
+ if (!$got) {
+ $how = 'kill';
+ last;
+ }
+ sleep 1;
+ }
+ } else {
+ # Fudge it by waiting a bit more:
+ sleep 2;
+ }
my $ppid2 = getppid();
- print $w "$ppid1,$ppid2\n";
+ print $w "$how,$ppid1,$ppid2\n";
}
exit 0;
}
Property changes on: trunk/contrib/perl/t/op/getppid.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/glob.t
===================================================================
--- trunk/contrib/perl/t/op/glob.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/glob.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -3,10 +3,10 @@
BEGIN {
chdir 't' if -d 't';
@INC = qw(. ../lib);
+ require 'test.pl';
}
-require 'test.pl';
-plan( tests => 13 );
+plan( tests => 17 );
@oops = @ops = <op/*>;
@@ -20,7 +20,7 @@
}
else {
map { $files{$_}++ } <op/*>;
- map { delete $files{$_} } split /[\s\n]/, `echo op/*`;
+ map { delete $files{$_} } split /\n/, `ls op/* | cat`;
}
ok( !(keys(%files)),'leftover op/* files' ) or diag(join(' ',sort keys %files));
@@ -48,7 +48,7 @@
for (1..2) {
eval "<.>";
ok(!length($@),"eval'ed a glob $_");
- undef %File::Glob::;
+ local %File::Glob::;
++$i;
}
cmp_ok($i,'==',2,'remove File::Glob stash');
@@ -55,11 +55,24 @@
# a more sinister version of the same test (crashes from 5.8 to 5.13.1)
{
- undef %File::Glob::;
+ local %File::Glob::;
local %CORE::GLOBAL::;
eval "<.>";
ok(!length($@),"remove File::Glob stash *and* CORE::GLOBAL::glob");
}
+# Also try undeffing the typeglob itself, instead of hiding it
+{
+ local *CORE::GLOBAL::glob;
+ ok eval { glob("0"); 1 },
+ 'undefined *CORE::GLOBAL::glob{CODE} at run time';
+}
+# And hide the typeglob without hiding File::Glob (crashes from 5.8
+# to 5.15.4)
+{
+ local %CORE::GLOBAL::;
+ ok eval q{ glob("0"); 1 },
+ 'undefined *CORE::GLOBAL::glob{CODE} at compile time';
+}
# ... while ($var = glob(...)) should test definedness not truth
@@ -81,3 +94,19 @@
}
cmp_ok(scalar(@oops),'>',0,'glob globbed something');
+
+SKIP: {
+ skip "~ globbing returns nothing on VMS", 1 if $^O eq 'VMS';
+ # This test exists mainly for miniperl, to test that external calls to
+ # csh, which clear %ENV first, leave $ENV{HOME}.
+ # On Windows, external glob uses File::DosGlob which returns "~", so
+ # this should pass anyway.
+ ok <~>, '~ works';
+}
+
+{
+ my $called;
+ local *CORE::GLOBAL::glob = sub { ++$called };
+ eval 'CORE::glob("0")';
+ ok !$called, 'CORE::glob bypasses overrides';
+}
Property changes on: trunk/contrib/perl/t/op/glob.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/gmagic.t
===================================================================
--- trunk/contrib/perl/t/op/gmagic.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/gmagic.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -11,11 +11,11 @@
tie my $c => 'Tie::Monitor';
sub expected_tie_calls {
- my ($obj, $rexp, $wexp) = @_;
+ my ($obj, $rexp, $wexp, $tn) = @_;
local $::Level = $::Level + 1;
my ($rgot, $wgot) = $obj->init();
- is ($rgot, $rexp);
- is ($wgot, $wexp);
+ is ($rgot, $rexp, $tn ? "number of fetches when $tn" : ());
+ is ($wgot, $wexp, $tn ? "number of stores when $tn" : ());
}
# Use ok() instead of is(), cmp_ok() etc, to strictly control number of accesses
@@ -50,14 +50,82 @@
ok($s eq '0', 'multiple magic in core functions');
expected_tie_calls(tied $c, 1, 1);
-# was a glob
-my $tied_to = tied $c;
$c = *strat;
$s = $c;
ok($s eq *strat,
'Assignment should not ignore magic when the last thing assigned was a glob');
-expected_tie_calls($tied_to, 1, 1);
+expected_tie_calls(tied $c, 1, 1);
+package o { use overload '""' => sub { "foo\n" } }
+$c = bless [], o::;
+chomp $c;
+expected_tie_calls(tied $c, 1, 2, 'chomping a ref');
+
+{
+ my $outfile = tempfile();
+ open my $h, ">$outfile" or die "$0 cannot close $outfile: $!";
+ print $h "bar\n";
+ close $h or die "$0 cannot close $outfile: $!";
+
+ $c = *foo; # 1 write
+ open $h, $outfile;
+ sysread $h, $c, 3, 7; # 1 read; 1 write
+ is $c, "*main::bar", 'what sysread wrote'; # 1 read
+ expected_tie_calls(tied $c, 2, 2, 'calling sysread with tied buf');
+ close $h or die "$0 cannot close $outfile: $!";
+
+ # Do this again, with a utf8 handle
+ $c = *foo; # 1 write
+ open $h, "<:utf8", $outfile;
+ sysread $h, $c, 3, 7; # 1 read; 1 write
+ is $c, "*main::bar", 'what sysread wrote'; # 1 read
+ expected_tie_calls(tied $c, 2, 2, 'calling sysread with tied buf');
+ close $h or die "$0 cannot close $outfile: $!";
+
+ unlink_all $outfile;
+}
+
+# autovivication of aelem, helem, of rv2sv combined with get-magic
+{
+ my $true = 1;
+ my $s;
+ tie $$s, "Tie::Monitor";
+ $$s = undef;
+ $$s->[0] = 73;
+ is($$s->[0], 73);
+ expected_tie_calls(tied $$s, 3, 2);
+
+ my @a;
+ tie $a[0], "Tie::Monitor";
+ $a[0] = undef;
+ $a[0][0] = 73;
+ is($a[0][0], 73);
+ expected_tie_calls(tied $a[0], 3, 2);
+
+ my %h;
+ tie $h{foo}, "Tie::Monitor";
+ $h{foo} = undef;
+ $h{foo}{bar} = 73;
+ is($h{foo}{bar}, 73);
+ expected_tie_calls(tied $h{foo}, 3, 2);
+
+ # Similar tests, but with obscured autovivication by using dummy list or "?:" operator
+ $$s = undef;
+ ${ (), $$s }[0] = 73;
+ is( $$s->[0], 73);
+ expected_tie_calls(tied $$s, 3, 2);
+
+ $$s = undef;
+ ( ! $true ? undef : $$s )->[0] = 73;
+ is( $$s->[0], 73);
+ expected_tie_calls(tied $$s, 3, 2);
+
+ $$s = undef;
+ ( $true ? $$s : undef )->[0] = 73;
+ is( $$s->[0], 73);
+ expected_tie_calls(tied $$s, 3, 2);
+}
+
# A plain *foo should not call get-magic on *foo.
# This method of scalar-tying an immutable glob relies on details of the
# current implementation that are subject to change. This test may need to
@@ -69,6 +137,51 @@
ok($rgot == 0, 'a plain *foo causes no get-magic');
ok($wgot == 0, 'a plain *foo causes no set-magic');
+# get-magic when exiting a non-lvalue sub in potentially autovivify-
+# ing context
+{
+ no strict;
+
+ my $tied_to = tie $_{elem}, "Tie::Monitor";
+ () = sub { delete $_{elem} }->()->[3];
+ expected_tie_calls $tied_to, 1, 0,
+ 'mortal magic var is implicitly returned in autoviv context';
+
+ $tied_to = tie $_{elem}, "Tie::Monitor";
+ () = sub { return delete $_{elem} }->()->[3];
+ expected_tie_calls $tied_to, 1, 0,
+ 'mortal magic var is explicitly returned in autoviv context';
+
+ $tied_to = tie $_{elem}, "Tie::Monitor";
+ my $rsub;
+ $rsub = sub { if ($_[0]) { delete $_{elem} } else { &$rsub(1)->[3] } };
+ &$rsub;
+ expected_tie_calls $tied_to, 1, 0,
+ 'mortal magic var is implicitly returned in recursive autoviv context';
+
+ $tied_to = tie $_{elem}, "Tie::Monitor";
+ $rsub = sub {
+ if ($_[0]) { return delete $_{elem} } else { &$rsub(1)->[3] }
+ };
+ &$rsub;
+ expected_tie_calls $tied_to, 1, 0,
+ 'mortal magic var is explicitly returned in recursive autoviv context';
+
+ $tied_to = tie $_{elem}, "Tie::Monitor";
+ my $x = \sub { delete $_{elem} }->();
+ expected_tie_calls $tied_to, 1, 0,
+ 'mortal magic var is implicitly returned to refgen';
+ is tied $$x, undef,
+ 'mortal magic var is copied when implicitly returned';
+
+ $tied_to = tie $_{elem}, "Tie::Monitor";
+ $x = \sub { return delete $_{elem} }->();
+ expected_tie_calls $tied_to, 1, 0,
+ 'mortal magic var is explicitly returned to refgen';
+ is tied $$x, undef,
+ 'mortal magic var is copied when explicitly returned';
+}
+
done_testing();
# adapted from Tie::Counter by Abigail
Property changes on: trunk/contrib/perl/t/op/gmagic.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/goto.t
===================================================================
--- trunk/contrib/perl/t/op/goto.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/goto.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -10,7 +10,7 @@
use warnings;
use strict;
-plan tests => 77;
+plan tests => 89;
our $TODO;
my $deprecated = 0;
@@ -20,7 +20,7 @@
while ($?) {
$foo = 1;
label1:
- is($deprecated, 1);
+ is($deprecated, 1, "following label1");
$deprecated = 0;
$foo = 2;
goto label2;
@@ -28,12 +28,12 @@
$foo = 0;
goto label4;
label3:
- is($deprecated, 1);
+ is($deprecated, 1, "following label3");
$deprecated = 0;
$foo = 4;
goto label4;
}
-is($deprecated, 0);
+is($deprecated, 0, "after 'while' loop");
goto label1;
$foo = 3;
@@ -40,7 +40,7 @@
label2:
is($foo, 2, 'escape while loop');
-is($deprecated, 0);
+is($deprecated, 0, "following label2");
goto label3;
label4:
@@ -183,10 +183,10 @@
A: { if ($false) { redo A; B: $ok = 1; redo A; } }
goto B unless $count++;
}
- is($deprecated, 0);
+ is($deprecated, 0, "before calling sub a()");
a();
ok($ok, '#19061 loop label wiped away by goto');
- is($deprecated, 1);
+ is($deprecated, 1, "after calling sub a()");
$deprecated = 0;
$ok = 0;
@@ -193,7 +193,7 @@
my $p;
for ($p=1;$p && goto A;$p=0) { A: $ok = 1 }
ok($ok, 'weird case of goto and for(;;) loop');
- is($deprecated, 1);
+ is($deprecated, 1, "following goto and for(;;) loop");
$deprecated = 0;
}
@@ -205,6 +205,17 @@
}
f1();
+# bug #99850, which is similar - freeing the subroutine we are about to
+# go(in)to during a FREETMPS call should not crash perl.
+
+package _99850 {
+ sub reftype{}
+ DESTROY { undef &reftype }
+ eval { sub { my $guard = bless []; goto &reftype }->() };
+}
+like $@, qr/^Goto undefined subroutine &_99850::reftype at /,
+ 'goto &foo undefining &foo on sub cleanup';
+
# bug #22181 - this used to coredump or make $x undefined, due to
# erroneous popping of the inner BLOCK context
@@ -415,7 +426,11 @@
my $x = shift;
$_[0] ? +1 + recurse1($_[0] - 1) : 0
}
+my $w = 0;
+$SIG{__WARN__} = sub { ++$w };
is(recurse1(500), 500, 'recursive goto &foo');
+is $w, 0, 'no recursion warnings for "no warnings; goto &sub"';
+delete $SIG{__WARN__};
# [perl #32039] Chained goto &sub drops data too early.
@@ -445,13 +460,28 @@
# goto &foo not allowed in evals
-
sub null { 1 };
eval 'goto &null';
like($@, qr/Can't goto subroutine from an eval-string/, 'eval string');
eval { goto &null };
like($@, qr/Can't goto subroutine from an eval-block/, 'eval block');
+
+# goto &foo leaves @_ alone when called from a sub
+sub returnarg { $_[0] };
+is sub {
+ local *_ = ["ick and queasy"];
+ goto &returnarg;
+}->("quick and easy"), "ick and queasy",
+ 'goto &foo with *_{ARRAY} replaced';
+my @__ = "\xc4\x80";
+sub { local *_ = \@__; goto &utf8::decode }->("no thinking aloud");
+is "@__", chr 256, 'goto &xsub with replaced *_{ARRAY}';
+# And goto &foo should leave reified @_ alone
+sub { *__ = \@_; goto &null } -> ("rough and tubbery");
+is ${*__}[0], 'rough and tubbery', 'goto &foo leaves reified @_ alone';
+
+
# [perl #36521] goto &foo in warn handler could defeat recursion avoider
{
@@ -473,7 +503,7 @@
}
}
-is($deprecated, 0);
+is($deprecated, 0, "following TODOed test for #43403");
#74290
{
@@ -596,3 +626,46 @@
$foo .= ",1.";
$foo .= ",2.";
is($foo, ",0.,1.,2.", "third of three stacked labels");
+
+# [perl #112316] Wrong behavior regarding labels with same prefix
+sub same_prefix_labels {
+ my $pass;
+ my $first_time = 1;
+ CATCH: {
+ if ( $first_time ) {
+ CATCHLOOP: {
+ if ( !$first_time ) {
+ return 0;
+ }
+ $first_time--;
+ goto CATCH;
+ }
+ }
+ else {
+ return 1;
+ }
+ }
+}
+
+ok(
+ same_prefix_labels(),
+ "perl 112316: goto and labels with the same prefix doesn't get mixed up"
+);
+
+eval { my $x = ""; goto $x };
+like $@, qr/^goto must have label at /, 'goto $x where $x is empty string';
+eval { goto "" };
+like $@, qr/^goto must have label at /, 'goto ""';
+eval { goto };
+like $@, qr/^goto must have label at /, 'argless goto';
+
+eval { my $x = "\0"; goto $x };
+like $@, qr/^Can't find label \0 at /, 'goto $x where $x begins with \0';
+eval { goto "\0" };
+like $@, qr/^Can't find label \0 at /, 'goto "\0"';
+
+sub TIESCALAR { bless [pop] }
+sub FETCH { $_[0][0] }
+tie my $t, "", sub { "cluck up porridge" };
+is eval { sub { goto $t }->() }//$@, 'cluck up porridge',
+ 'tied arg returning sub ref';
Property changes on: trunk/contrib/perl/t/op/goto.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/t/op/goto_xs.t
===================================================================
--- trunk/contrib/perl/t/op/goto_xs.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/goto_xs.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/goto_xs.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/grent.t
===================================================================
--- trunk/contrib/perl/t/op/grent.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/grent.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -28,11 +28,11 @@
{
print "# `ypcat group` worked\n";
- # Check to make sure we're really using NIS.
+ # Check to make sure we are really using NIS.
if( open(NSSW, "/etc/nsswitch.conf" ) ) {
my($group) = grep /^\s*group:/, <NSSW>;
- # If there's no group line, assume it default to compat.
+ # If there is no group line, assume it default to compat.
if( !$group || $group !~ /(nis|compat)/ ) {
print "# Doesn't look like you're using NIS in ".
"/etc/nsswitch.conf\n";
@@ -91,7 +91,7 @@
while (<GR>) {
chomp;
- # LIMIT -1 so that groups with no users don't fall off
+ # LIMIT -1 so that groups with no users do not fall off
my @s = split /:/, $_, -1;
my ($name_s,$passwd_s,$gid_s,$members_s) = @s;
if (@s) {
@@ -158,7 +158,7 @@
fail();
print "#\t (not necessarily serious: run t/op/grent.t by itself)\n";
} else {
- pass();
+ pass("getgrgid and getgrnam performed as expected");
}
# Test both the scalar and list contexts.
@@ -183,6 +183,6 @@
}
endgrent();
-is("@gr1", "@gr2");
+is("@gr1", "@gr2", "getgrent gave same results in scalar and list contexts");
close(GR);
Property changes on: trunk/contrib/perl/t/op/grent.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/grep.t
===================================================================
--- trunk/contrib/perl/t/op/grep.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/grep.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -7,10 +7,10 @@
BEGIN {
chdir 't' if -d 't';
@INC = qw(. ../lib);
+ require "test.pl";
}
-require "test.pl";
-plan( tests => 61 );
+plan( tests => 62 );
{
my @lol = ([qw(a b c)], [], [qw(1 2 3)]);
@@ -214,3 +214,11 @@
like($@, qr/Missing comma after first argument to grep function/,
"proper error on variable as block. [perl #37314]");
}
+
+# [perl #92254] freeing $_ in gremap block
+{
+ my $y;
+ grep { undef *_ } $y;
+ map { undef *_ } $y;
+}
+pass 'no double frees with grep/map { undef *_ }';
Property changes on: trunk/contrib/perl/t/op/grep.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/groups.t
===================================================================
--- trunk/contrib/perl/t/op/groups.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/groups.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -406,4 +406,4 @@
# indent-tabs-mode: nil
# End:
#
-# ex: set ts=8 sts=4 sw=4 noet:
+# ex: set ts=8 sts=4 sw=4 et:
Property changes on: trunk/contrib/perl/t/op/groups.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/gv.t
===================================================================
--- trunk/contrib/perl/t/op/gv.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/gv.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -12,9 +12,9 @@
use warnings;
-plan( tests => 234 );
+plan( tests => 245 );
-# type coersion on assignment
+# type coercion on assignment
$foo = 'foo';
$bar = *main::foo;
$bar = $foo;
@@ -21,7 +21,7 @@
is(ref(\$bar), 'SCALAR');
$foo = *main::bar;
-# type coersion (not) on misc ops
+# type coercion (not) on misc ops
ok($foo);
is(ref(\$foo), 'GLOB');
@@ -35,7 +35,7 @@
{
no warnings;
${\*$foo} = undef;
- is(ref(\$foo), 'GLOB', 'no type coersion when assigning to *{} retval');
+ is(ref(\$foo), 'GLOB', 'no type coercion when assigning to *{} retval');
$::{phake} = *bar;
is(
\$::{phake}, \*{"phake"},
@@ -44,7 +44,7 @@
${\*{"phake"}} = undef;
is(
ref(\$::{phake}), 'GLOB',
- 'no type coersion when assigning to retval of symbolic *{}'
+ 'no type coercion when assigning to retval of symbolic *{}'
);
$::{phaque} = *bar;
eval '
@@ -56,11 +56,11 @@
';
is(
ref(\$::{phaque}), 'GLOB',
- 'no type coersion when assigning to retval of compile-time *{}'
+ 'no type coercion when assigning to retval of compile-time *{}'
);
}
-# type coersion on substitutions that match
+# type coercion on substitutions that match
$a = *main::foo;
$b = $a;
$a =~ s/^X//;
@@ -166,6 +166,8 @@
curr_test($test);
is (ref *x{FORMAT}, "FORMAT");
+is ("@{sub { *_{ARRAY} }->(1..3)}", "1 2 3",
+ 'returning *_{ARRAY} from sub');
*x = *STDOUT;
is (*{*x{GLOB}}, "*main::STDOUT");
@@ -185,6 +187,12 @@
curr_test(++$test);
}
+is *x{NAME}, 'x', '*foo{NAME}';
+is *x{PACKAGE}, 'main', '*foo{PACKAGE}';
+{ no warnings 'once'; *x = *Foo::y; }
+is *x, '*Foo::y', 'glob stringifies as assignee after glob-to-glob assign';
+is *x{NAME}, 'x', 'but *foo{NAME} still returns the original name';
+is *x{PACKAGE}, 'main', 'and *foo{PACKAGE} the original package';
{
# test if defined() doesn't create any new symbols
@@ -192,7 +200,10 @@
my $a = "SYM000";
ok(!defined *{$a});
- ok(!defined @{$a});
+ {
+ no warnings 'deprecated';
+ ok(!defined @{$a});
+ }
ok(!defined *{$a});
{
@@ -219,8 +230,8 @@
# although it *should* if you're talking about magicals
my $a = "]";
+ ok(defined *{$a});
ok(defined ${$a});
- ok(defined *{$a});
$a = "1";
"o" =~ /(o)/;
@@ -595,25 +606,27 @@
"with the correct error message");
}
-# RT #60954 anonymous glob should be defined, and not coredump when
+# RT #65582 anonymous glob should be defined, and not coredump when
# stringified. The behaviours are:
#
-# defined($glob) "$glob"
-# 5.8.8 false "" with uninit warning
-# 5.10.0 true (coredump)
-# 5.12.0 true ""
+# defined($glob) "$glob" $glob .= ...
+# 5.8.8 false "" with uninit warning "" with uninit warning
+# 5.10.0 true (coredump) (coredump)
+# 5.1[24] true "" "" with uninit warning
+# 5.16 true "*__ANON__::..." "*__ANON__::..."
{
my $io_ref = *STDOUT{IO};
my $glob = *$io_ref;
- ok(defined $glob, "RT #60954 anon glob should be defined");
+ ok(defined $glob, "RT #65582 anon glob should be defined");
my $warn = '';
local $SIG{__WARN__} = sub { $warn = $_[0] };
use warnings;
my $str = "$glob";
- is($warn, '', "RT #60954 anon glob stringification shouldn't warn");
- is($str, '', "RT #60954 anon glob stringification should be empty");
+ is($warn, '', "RT #65582 anon glob stringification shouldn't warn");
+ is($str, '*__ANON__::__ANONIO__',
+ "RT #65582/#96326 anon glob stringification");
}
# [perl #71254] - Assigning a glob to a variable that has a current
@@ -830,7 +843,6 @@
tie my $a, "thrext";
() = "$a"; # do a fetch; now $a holds a glob
eval { *$a = sub{} };
- eval { $a = undef }; # workaround for untie($handle) bug
untie $a;
eval { $a = "bar" };
::is $a, "bar",
@@ -855,13 +867,13 @@
my $glob = do { no warnings "once"; \*phing::foo};
delete $::{"phing::"};
*$glob = *greck;
-}, "Assigning a glob-with-sub to a glob that has lost its stash warks";
+}, "Assigning a glob-with-sub to a glob that has lost its stash works";
ok eval {
sub pon::foo;
my $glob = \*pon::foo;
delete $::{"pon::"};
*$glob = *foo;
-}, "Assigning a glob to a glob-with-sub that has lost its stash warks";
+}, "Assigning a glob to a glob-with-sub that has lost its stash works";
{
package Tie::Alias;
@@ -899,6 +911,46 @@
'no error when gp_free calls a destructor that assigns to the gv';
}
+# *{undef}
+eval { *{my $undef} = 3 };
+like $@, qr/^Can't use an undefined value as a symbol reference at /,
+ '*{ $undef } assignment';
+eval { *{;undef} = 3 };
+like $@, qr/^Can't use an undefined value as a symbol reference at /,
+ '*{ ;undef } assignment';
+
+# [perl #99142] defined &{"foo"} when there is a constant stub
+# If I break your module, you get to have it mentioned in Perl's tests. :-)
+package HTTP::MobileAttribute::Plugin::Locator {
+ use constant LOCATOR_GPS => 1;
+ ::ok defined &{__PACKAGE__."::LOCATOR_GPS"},
+ 'defined &{"name of constant"}';
+ ::ok Internals::SvREFCNT(${__PACKAGE__."::"}{LOCATOR_GPS}),
+ "stash elem for slot is not freed prematurely";
+}
+
+# Check that constants promoted to CVs point to the right GVs when the name
+# contains a null.
+package lrcg {
+ use constant x => 3;
+ # These two lines abuse the optimisation that copies the scalar ref from
+ # one stash element to another, to get a constant with a null in its name
+ *{"yz\0a"} = \&{"x"};
+ my $ref = \&{"yz\0a"};
+ ::ok !exists $lrcg::{yz},
+ 'constants w/nulls in their names point 2 the right GVs when promoted';
+}
+
+# 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
+# unallocated memory as a result. There is no ok() or is() because the
+# panic that used to occur only occurred during global destruction, and
+# only with PERL_DESTRUCT_LEVEL=2. (The panic itself was sufficient for
+# the harness to consider this test script to have failed.)
+$::{aoeuaoeuaoeaoeu} = __PACKAGE__; # cow
+() = *{"aoeuaoeuaoeaoeu"};
+
__END__
Perl
Rules
Property changes on: trunk/contrib/perl/t/op/gv.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Copied: trunk/contrib/perl/t/op/hash-rt85026.t (from rev 6437, vendor/perl/5.18.1/t/op/hash-rt85026.t)
===================================================================
--- trunk/contrib/perl/t/op/hash-rt85026.t (rev 0)
+++ trunk/contrib/perl/t/op/hash-rt85026.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,69 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ chdir 't';
+ @INC = '../lib';
+ require './test.pl';
+ skip_all_without_dynamic_extension("Devel::Peek");
+}
+
+use strict;
+use Devel::Peek;
+use File::Temp qw(tempdir);
+use File::Spec;
+
+my %hash = map +($_ => 1), ("a".."z");
+
+my $tmp_dir = tempdir(CLEANUP => 1);
+my $tmp_file = File::Spec->catfile($tmp_dir, 'dump');
+
+sub riter {
+ local *OLDERR;
+ open(OLDERR, ">&STDERR") || die "Can't dup STDERR: $!";
+ open(STDERR, ">", $tmp_file) ||
+ die "Could not open '$tmp_file' for write: $^E";
+ Dump(\%hash);
+ open(STDERR, ">&OLDERR") || die "Can't dup OLDERR: $!";
+ open(my $fh, "<", $tmp_file) ||
+ die "Could not open '$tmp_file' for read: $^E";
+ local $/;
+ my $dump = <$fh>;
+ my ($riter) = $dump =~ /^\s*RITER\s*=\s*(\d+)/m or
+ die "No plain RITER in dump '$dump'";
+ return $riter;
+}
+
+my @riters;
+while (my $key = each %hash) {
+ push @{$riters[riter()]}, $key;
+}
+
+my ($first_key, $second_key);
+my $riter = 0;
+for my $chain (@riters) {
+ if ($chain && @$chain >= 2) {
+ $first_key = $chain->[0];
+ $second_key = $chain->[1];
+ last;
+ }
+ $riter++;
+}
+$first_key ||
+ skip_all "No 2 element chains; need a different initial HASH";
+$| = 1;
+
+plan(1);
+
+# Ok all preparation is done
+note <<"EOF"
+Found keys '$first_key' and '$second_key' on chain $riter
+Will now iterato to key '$first_key' then delete '$first_key' and '$second_key'.
+EOF
+;
+1 until $first_key eq each %hash;
+delete $hash{$first_key};
+delete $hash{$second_key};
+
+note "Now iterating into freed memory\n";
+1 for each %hash;
+ok(1, "Survived!");
Modified: trunk/contrib/perl/t/op/hash.t
===================================================================
--- trunk/contrib/perl/t/op/hash.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/hash.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -8,108 +8,8 @@
use strict;
-plan tests => 8;
+plan tests => 10;
-my %h;
-
-ok (!Internals::HvREHASH(%h), "hash doesn't start with rehash flag on");
-
-foreach (1..10) {
- $h{"\0"x$_}++;
-}
-
-ok (!Internals::HvREHASH(%h), "10 entries doesn't trigger rehash");
-
-foreach (11..20) {
- $h{"\0"x$_}++;
-}
-
-ok (Internals::HvREHASH(%h), "20 entries triggers rehash");
-
-
-
-
-# second part using an emulation of the PERL_HASH in perl, mounting an
-# attack on a pre-populated hash. This is also useful if you need normal
-# keys which don't contain \0 -- suitable for stashes
-
-use constant MASK_U32 => 2**32;
-use constant HASH_SEED => 0;
-use constant THRESHOLD => 14;
-use constant START => "a";
-
-# some initial hash data
-my %h2 = map {$_ => 1} 'a'..'cc';
-
-ok (!Internals::HvREHASH(%h2),
- "starting with pre-populated non-pathological hash (rehash flag if off)");
-
-my @keys = get_keys(\%h2);
-$h2{$_}++ for @keys;
-ok (Internals::HvREHASH(%h2),
- scalar(@keys) . " colliding into the same bucket keys are triggering rehash");
-
-sub get_keys {
- my $hr = shift;
-
- # the minimum of bits required to mount the attack on a hash
- my $min_bits = log(THRESHOLD)/log(2);
-
- # if the hash has already been populated with a significant amount
- # of entries the number of mask bits can be higher
- my $keys = scalar keys %$hr;
- my $bits = $keys ? log($keys)/log(2) : 0;
- $bits = $min_bits if $min_bits > $bits;
-
- $bits = int($bits) < $bits ? int($bits) + 1 : int($bits);
- # need to add 2 bits to cover the internal split cases
- $bits += 2;
- my $mask = 2**$bits-1;
- print "# using mask: $mask ($bits)\n";
-
- my @keys;
- my $s = START;
- my $c = 0;
- # get 2 keys on top of the THRESHOLD
- my $hash;
- while (@keys < THRESHOLD+2) {
- # next if exists $hash->{$s};
- $hash = hash($s);
- next unless ($hash & $mask) == 0;
- $c++;
- printf "# %2d: %5s, %10s\n", $c, $s, $hash;
- push @keys, $s;
- } continue {
- $s++;
- }
-
- return @keys;
-}
-
-
-# trying to provide the fastest equivalent of C macro's PERL_HASH in
-# Perl - the main complication is that it uses U32 integer, which we
-# can't do it perl, without doing some tricks
-sub hash {
- my $s = shift;
- my @c = split //, $s;
- my $u = HASH_SEED;
- for (@c) {
- # (A % M) + (B % M) == (A + B) % M
- # This works because '+' produces a NV, which is big enough to hold
- # the intermediate result. We only need the % before any "^" and "&"
- # to get the result in the range for an I32.
- # and << doesn't work on NV, so using 1 << 10
- $u += ord;
- $u += $u * (1 << 10); $u %= MASK_U32;
- $u ^= $u >> 6;
- }
- $u += $u << 3; $u %= MASK_U32;
- $u ^= $u >> 11; $u %= MASK_U32;
- $u += $u << 15; $u %= MASK_U32;
- $u;
-}
-
# This will crash perl if it fails
use constant PVBM => 'foo';
@@ -146,3 +46,74 @@
is ref $key, SCALAR =>
'hash keys are not stringified during compilation';
}
+
+# Part of RT #85026: Deleting the current iterator in void context does not
+# free it.
+{
+ my $gone;
+ no warnings 'once';
+ local *::DESTROY = sub { ++$gone };
+ my %a=(a=>bless[]);
+ each %a; # make the entry with the obj the current iterator
+ delete $a{a};
+ ok $gone, 'deleting the current iterator in void context frees the val'
+}
+
+# [perl #99660] Deleted hash element visible to destructor
+{
+ my %h;
+ $h{k} = bless [];
+ my $normal_exit;
+ local *::DESTROY = sub { my $x = $h{k}; ++$normal_exit };
+ delete $h{k}; # must be in void context to trigger the bug
+ ok $normal_exit, 'freed hash elems are not visible to DESTROY';
+}
+
+# [perl #100340] Similar bug: freeing a hash elem during a delete
+sub guard::DESTROY {
+ ${$_[0]}->();
+};
+*guard = sub (&) {
+ my $callback = shift;
+ return bless \$callback, "guard"
+};
+{
+ my $ok;
+ my %t; %t = (
+ stash => {
+ guard => guard(sub{
+ $ok++;
+ delete $t{stash};
+ }),
+ foo => "bar",
+ bar => "baz",
+ },
+ );
+ ok eval { delete $t{stash}{guard}; # must be in void context
+ 1 },
+ 'freeing a hash elem from destructor called by delete does not die';
+ diag $@ if $@; # panic: free from wrong pool
+ is $ok, 1, 'the destructor was called';
+}
+
+# Weak references to pad hashes
+SKIP: {
+ skip_if_miniperl("No Scalar::Util::weaken under miniperl", 1);
+ my $ref;
+ require Scalar::Util;
+ {
+ my %hash;
+ Scalar::Util::weaken($ref = \%hash);
+ 1; # the previous statement must not be the last
+ }
+ is $ref, undef, 'weak refs to pad hashes go stale on scope exit';
+}
+
+# [perl #107440]
+sub A::DESTROY { $::ra = 0 }
+$::ra = {a=>bless [], 'A'};
+undef %$::ra;
+pass 'no crash when freeing hash that is being undeffed';
+$::ra = {a=>bless [], 'A'};
+%$::ra = ('a'..'z');
+pass 'no crash when freeing hash that is being exonerated, ahem, cleared';
Property changes on: trunk/contrib/perl/t/op/hash.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/hashassign.t
===================================================================
--- trunk/contrib/perl/t/op/hashassign.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/hashassign.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -8,7 +8,7 @@
# use strict;
-plan tests => 218;
+plan tests => 309;
my @comma = ("key", "value");
@@ -280,9 +280,9 @@
'hash assignment in list context removes duplicates' );
is( (join ':', %h = qw(a 1 a 2 b 3 c 4 d 5 d 6)), 'a:2:b:3:c:4:d:6',
'hash assignment in list context removes duplicates 2' );
- is( scalar( %h = (1,2,1,3,1,4,1,5) ), 2,
+ is( scalar( %h = (1,2,1,3,1,4,1,5) ), 8,
'hash assignment in scalar context' );
- is( scalar( ($x,%h) = (0,1,2,1,3,1,4,1,5) ), 3,
+ is( scalar( ($x,%h) = (0,1,2,1,3,1,4,1,5) ), 9,
'scalar + hash assignment in scalar context' );
$ar = [ %h = (1,2,1,3,1,4,1,5) ];
is( $#$ar, 1, 'hash assignment in list context' );
@@ -320,3 +320,217 @@
undef %tb;
is $p, \%tb, "hash undef should not zap weak refs";
}
+
+# test odd hash assignment warnings
+{
+ my ($s, %h);
+ warning_like(sub {%h = (1..3)}, qr/^Odd number of elements in hash assignment/);
+ warning_like(sub {%h = ({})}, qr/^Reference found where even-sized list expected/);
+
+ warning_like(sub { ($s, %h) = (1..4)}, qr/^Odd number of elements in hash assignment/);
+ warning_like(sub { ($s, %h) = (1, {})}, qr/^Reference found where even-sized list expected/);
+}
+
+# hash assignment in scalar and list context with odd number of elements
+{
+ no warnings 'misc', 'uninitialized';
+ my %h; my $x;
+ is( join( ':', %h = (1..3)), '1:2:3:',
+ 'odd hash assignment in list context' );
+ ok( eq_hash( \%h, {1 => 2, 3 => undef} ), "correct value stored" );
+ is( scalar( %h = (1..3) ), 3,
+ 'odd hash assignment in scalar context' );
+ ok( eq_hash( \%h, {1 => 2, 3 => undef} ), "correct value stored" );
+ is( join(':', ($x,%h) = (0,1,2,3) ), '0:1:2:3:',
+ 'scalar + odd hash assignment in list context' );
+ ok( eq_hash( \%h, {1 => 2, 3 => undef} ), "correct value stored" );
+ is( scalar( ($x,%h) = (0,1,2,3) ), 4,
+ 'scalar + odd hash assignment in scalar context' );
+ ok( eq_hash( \%h, {1 => 2, 3 => undef} ), "correct value stored" );
+}
+
+# hash assignment in scalar and list context with odd number of elements
+# and duplicates
+{
+ no warnings 'misc', 'uninitialized';
+ my %h; my $x;
+ is( (join ':', %h = (1,1,1)), '1:',
+ 'odd hash assignment in list context with duplicates' );
+ ok( eq_hash( \%h, {1 => undef} ), "correct value stored" );
+ is( scalar(%h = (1,1,1)), 3,
+ 'odd hash assignment in scalar context with duplicates' );
+ ok( eq_hash( \%h, {1 => undef} ), "correct value stored" );
+ is( join(':', ($x,%h) = (0,1,1,1) ), '0:1:',
+ 'scalar + odd hash assignment in list context with duplicates' );
+ ok( eq_hash( \%h, {1 => undef} ), "correct value stored" );
+ is( scalar( ($x,%h) = (0,1,1,1) ), 4,
+ 'scalar + odd hash assignment in scalar context with duplicates' );
+ ok( eq_hash( \%h, {1 => undef} ), "correct value stored" );
+}
+
+# hash followed by more elements on LHS of list assignment
+# (%h, ...) = ...;
+{
+ my (%h, %x, @x, $x);
+ is( scalar( (%h,$x) = (1,2,3,4)), 4,
+ 'hash+scalar assignment in scalar context' );
+ ok( eq_hash( \%h, {1 => 2, 3 => 4} ), "correct hash" );
+ is( $x, undef, "correct scalar" );
+ # this arguable, but this is how it works
+ is( join(':', (%h,$x) = (1,2,3,4)), '1:2:3:4',
+ 'hash+scalar assignment in list context' );
+ ok( eq_hash( \%h, {1 => 2, 3 => 4} ), "correct hash" );
+ is( $x, undef, "correct scalar" );
+
+ is( scalar( (%h,%x) = (1,2,3,4)), 4,
+ 'hash+hash assignment in scalar context' );
+ ok( eq_hash( \%h, {1 => 2, 3 => 4} ), "correct hash" );
+ ok( eq_hash( \%x, {} ), "correct hash" );
+ is( join(':', (%h,%x) = (1,2,3,4)), '1:2:3:4',
+ 'hash+hash assignment in list context' );
+ ok( eq_hash( \%h, {1 => 2, 3 => 4} ), "correct hash" );
+ ok( eq_hash( \%x, {} ), "correct hash" );
+
+ is( scalar( (%h, at x) = (1,2,3,4)), 4,
+ 'hash+array assignment in scalar context' );
+ ok( eq_hash( \%h, {1 => 2, 3 => 4} ), "correct hash" );
+ ok( eq_array( \@x, [] ), "correct array" );
+ is( join(':', (%h, at x) = (1,2,3,4)), '1:2:3:4',
+ 'hash+hash assignment in list context' );
+ ok( eq_hash( \%h, {1 => 2, 3 => 4} ), "correct hash" );
+ ok( eq_array( \@x, [] ), "correct array" );
+}
+
+# hash followed by more elements on LHS of list assignment
+# and duplicates on RHS
+# (%h, ...) = (1)x10;
+{
+ my (%h, %x, @x, $x);
+ is( scalar( (%h,$x) = (1,2,1,4)), 4,
+ 'hash+scalar assignment in scalar context' );
+ ok( eq_hash( \%h, {1 => 4} ), "correct hash" );
+ is( $x, undef, "correct scalar" );
+ # this arguable, but this is how it works
+ is( join(':', (%h,$x) = (1,2,1,4)), '1:4',
+ 'hash+scalar assignment in list context' );
+ ok( eq_hash( \%h, {1 => 4} ), "correct hash" );
+ is( $x, undef, "correct scalar" );
+
+ is( scalar( (%h,%x) = (1,2,1,4)), 4,
+ 'hash+hash assignment in scalar context' );
+ ok( eq_hash( \%h, {1 => 4} ), "correct hash" );
+ ok( eq_hash( \%x, {} ), "correct hash" );
+ is( join(':', (%h,%x) = (1,2,1,4)), '1:4',
+ 'hash+hash assignment in list context' );
+ ok( eq_hash( \%h, {1 => 4} ), "correct hash" );
+ ok( eq_hash( \%x, {} ), "correct hash" );
+
+ is( scalar( (%h, at x) = (1,2,1,4)), 4,
+ 'hash+array assignment in scalar context' );
+ ok( eq_hash( \%h, {1 => 4} ), "correct hash" );
+ ok( eq_array( \@x, [] ), "correct array" );
+ is( join(':', (%h, at x) = (1,2,1,4)), '1:4',
+ 'hash+hash assignment in list context' );
+ ok( eq_hash( \%h, {1 => 4} ), "correct hash" );
+ ok( eq_array( \@x, [] ), "correct array" );
+}
+
+# hash followed by more elements on LHS of list assignment
+# and duplicates with odd number of elements on RHS
+# (%h, ...) = (1,2,3,4,1);
+{
+ no warnings 'misc'; # suppress oddball warnings
+ my (%h, %x, @x, $x);
+ is( scalar( (%h,$x) = (1,2,3,4,1)), 5,
+ 'hash+scalar assignment in scalar context' );
+ ok( eq_hash( \%h, {1 => undef, 3 => 4} ), "correct hash" );
+ is( $x, undef, "correct scalar" );
+ # this arguable, but this is how it works
+ is( join(':', map $_//'undef', (%h,$x) = (1,2,3,4,1)), '1:undef:3:4',
+ 'hash+scalar assignment in list context' );
+ ok( eq_hash( \%h, {1 => undef, 3 => 4} ), "correct hash" );
+ is( $x, undef, "correct scalar" );
+
+ is( scalar( (%h,%x) = (1,2,3,4,1)), 5,
+ 'hash+hash assignment in scalar context' );
+ ok( eq_hash( \%h, {1 => undef, 3 => 4} ), "correct hash" );
+ ok( eq_hash( \%x, {} ), "correct hash" );
+ is( join(':', map $_//'undef', (%h,%x) = (1,2,3,4,1)), '1:undef:3:4',
+ 'hash+hash assignment in list context' );
+ ok( eq_hash( \%h, {1 => undef, 3 => 4} ), "correct hash" );
+ ok( eq_hash( \%x, {} ), "correct hash" );
+
+ is( scalar( (%h, at x) = (1,2,3,4,1)), 5,
+ 'hash+array assignment in scalar context' );
+ ok( eq_hash( \%h, {1 => undef, 3 => 4} ), "correct hash" );
+ ok( eq_array( \@x, [] ), "correct array" );
+ is( join(':', map $_//'undef', (%h, at x) = (1,2,3,4,1)), '1:undef:3:4',
+ 'hash+hash assignment in list context' );
+ ok( eq_hash( \%h, {1 => undef, 3 => 4} ), "correct hash" );
+ ok( eq_array( \@x, [] ), "correct array" );
+}
+
+
+# not enough elements on rhs
+# ($x,$y,$z,...) = (1);
+{
+ my ($x,$y,$z, at a,%h);
+ is( join(':', ($x, $y, %h) = (1)), '1',
+ 'only assigned elements are returned in list context');
+ is( join(':', ($x, $y, %h) = (1,1)), '1:1',
+ 'only assigned elements are returned in list context');
+ no warnings 'misc'; # suppress oddball warnings
+ is( join(':', map $_//'undef', ($x, $y, %h) = (1,1,1)), '1:1:1:undef',
+ 'only assigned elements are returned in list context');
+ is( join(':', ($x, $y, %h) = (1,1,1,1)), '1:1:1:1',
+ 'only assigned elements are returned in list context');
+ is( join(':', map $_//'undef', ($x, %h, $y) = (1,2,3,4)),
+ '1:2:3:4:undef',
+ 'only assigned elements are returned in list context');
+ is( join(':', ($x, $y, @h) = (1)), '1',
+ 'only assigned elements are returned in list context');
+ is( join(':', ($x, @h, $y) = (1,2,3,4)), '1:2:3:4',
+ 'only assigned elements are returned in list context');
+}
+
+# lvaluedness of list context
+{
+ my %h; my ($x, $y, $z);
+ $_++ foreach %h = (1,2,3,4);
+ ok( eq_hash( \%h, {1 => 3, 3 => 5} ), "aassign in list context returns lvalues" );
+
+ $_++ foreach %h = (1,2,1,4);
+ ok( eq_hash( \%h, {1 => 5} ), "the same for assignment with duplicates" );
+
+ $_++ foreach ($x, %h) = (0,1,2,3,4);
+ is( $x, 1, "... and leading scalar" );
+ ok( eq_hash( \%h, {1 => 3, 3 => 5} ), "... scalar followed by hash" );
+
+ {
+ no warnings 'misc';
+ $_++ foreach %h = (1,2,3);
+ ok( eq_hash( \%h, {1 => 3, 3 => 1} ), "odd elements also lvalued" );
+ }
+
+ $x = 0;
+ $_++ foreach %h = ($x,$x);
+ is($x, 0, "returned values are not aliased to RHS of the assignment operation");
+
+ %h = ();
+ $x = 0;
+ $_++ foreach sub :lvalue { %h = ($x,$x) }->();
+ is($x, 0,
+ "returned values are not aliased to RHS of assignment in lvalue sub");
+
+ $_++ foreach ($x,$y,%h,$z) = (0);
+ ok( eq_array([$x,$y,%h,$z], [1,undef,undef]), "only assigned values are returned" );
+
+ $_++ foreach ($x,$y,%h,$z) = (0,1);
+ ok( eq_array([$x,$y,%h,$z], [1,2,undef]), "only assigned values are returned" );
+
+ no warnings 'misc'; # suppress oddball warnings
+ $_++ foreach ($x,$y,%h,$z) = (0,1,2);
+ ok( eq_array([$x,$y,%h,$z], [1,2,2,1,undef]), "only assigned values are returned" );
+}
+
+
Property changes on: trunk/contrib/perl/t/op/hashassign.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/t/op/hashwarn.t
===================================================================
--- trunk/contrib/perl/t/op/hashwarn.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/hashwarn.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/hashwarn.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/op/heredoc.t (from rev 6437, vendor/perl/5.18.1/t/op/heredoc.t)
===================================================================
--- trunk/contrib/perl/t/op/heredoc.t (rev 0)
+++ trunk/contrib/perl/t/op/heredoc.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,85 @@
+# tests for heredocs besides what is tested in base/lex.t
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require './test.pl';
+}
+
+use strict;
+plan(tests => 9);
+
+
+# heredoc without newline (#65838)
+{
+ my $string = <<'HEREDOC';
+testing for 65838
+HEREDOC
+
+ my $code = "<<'HEREDOC';\n${string}HEREDOC"; # HD w/o newline, in eval-string
+ my $hd = eval $code or warn "$@ ---";
+ is($hd, $string, "no terminating newline in string-eval");
+}
+
+
+# here-doc edge cases
+{
+ my $string = "testing for 65838";
+
+ fresh_perl_is(
+ "print <<'HEREDOC';\n${string}\nHEREDOC",
+ $string,
+ {},
+ "heredoc at EOF without trailing newline"
+ );
+
+ fresh_perl_is(
+ "print <<;\n$string\n",
+ $string,
+ { switches => ['-X'] },
+ "blank-terminated heredoc at EOF"
+ );
+ fresh_perl_is(
+ "print <<\n$string\n",
+ $string,
+ { switches => ['-X'] },
+ "blank-terminated heredoc at EOF and no semicolon"
+ );
+ fresh_perl_is(
+ "print <<foo\r\nick and queasy\r\nfoo\r\n",
+ 'ick and queasy',
+ { switches => ['-X'] },
+ "crlf-terminated heredoc"
+ );
+ fresh_perl_is(
+ "print qq|\${\\<<foo}|\nick and queasy\nfoo\n",
+ 'ick and queasy',
+ { switches => ['-w'], stderr => 1 },
+ 'no warning for qq|${\<<foo}| in file'
+ );
+}
+
+
+# here-doc parse failures
+{
+ fresh_perl_like(
+ "print <<HEREDOC;\nwibble\n HEREDOC",
+ qr/find string terminator/,
+ {},
+ "string terminator must start at newline"
+ );
+
+ fresh_perl_like(
+ "print <<;\nno more newlines",
+ qr/find string terminator/,
+ { switches => ['-X'] },
+ "empty string terminator still needs a newline"
+ );
+
+ fresh_perl_like(
+ "print <<ThisTerminatorIsLongerThanTheData;\nno more newlines",
+ qr/find string terminator/,
+ {},
+ "long terminator fails correctly"
+ );
+}
Modified: trunk/contrib/perl/t/op/inc.t
===================================================================
--- trunk/contrib/perl/t/op/inc.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/inc.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -3,6 +3,8 @@
require './test.pl';
use strict;
+# Tests of post/pre - increment/decrement operators.
+
# Verify that addition/subtraction properly upgrade to doubles.
# These tests are only significant on machines with 32 bit longs,
# and two's complement negation, but shouldn't fail anywhere.
@@ -9,57 +11,61 @@
my $a = 2147483647;
my $c=$a++;
-cmp_ok($a, '==', 2147483648);
+cmp_ok($a, '==', 2147483648, "postincrement properly upgrades to double");
$a = 2147483647;
$c=++$a;
-cmp_ok($a, '==', 2147483648);
+cmp_ok($a, '==', 2147483648, "preincrement properly upgrades to double");
$a = 2147483647;
$a=$a+1;
-cmp_ok($a, '==', 2147483648);
+cmp_ok($a, '==', 2147483648, "addition properly upgrades to double");
$a = -2147483648;
$c=$a--;
-cmp_ok($a, '==', -2147483649);
+cmp_ok($a, '==', -2147483649, "postdecrement properly upgrades to double");
$a = -2147483648;
$c=--$a;
-cmp_ok($a, '==', -2147483649);
+cmp_ok($a, '==', -2147483649, "predecrement properly upgrades to double");
$a = -2147483648;
$a=$a-1;
-cmp_ok($a, '==', -2147483649);
+cmp_ok($a, '==', -2147483649, "subtraction properly upgrades to double");
$a = 2147483648;
$a = -$a;
$c=$a--;
-cmp_ok($a, '==', -2147483649);
+cmp_ok($a, '==', -2147483649,
+ "negation and postdecrement properly upgrade to double");
$a = 2147483648;
$a = -$a;
$c=--$a;
-cmp_ok($a, '==', -2147483649);
+cmp_ok($a, '==', -2147483649,
+ "negation and predecrement properly upgrade to double");
$a = 2147483648;
$a = -$a;
$a=$a-1;
-cmp_ok($a, '==', -2147483649);
+cmp_ok($a, '==', -2147483649,
+ "negation and subtraction properly upgrade to double");
$a = 2147483648;
$b = -$a;
$c=$b--;
-cmp_ok($b, '==', -$a-1);
+cmp_ok($b, '==', -$a-1, "negation, postdecrement and additional negation");
$a = 2147483648;
$b = -$a;
$c=--$b;
-cmp_ok($b, '==', -$a-1);
+cmp_ok($b, '==', -$a-1, "negation, predecrement and additional negation");
$a = 2147483648;
$b = -$a;
$b=$b-1;
-cmp_ok($b, '==', -(++$a));
+cmp_ok($b, '==', -(++$a),
+ "negation, subtraction, preincrement and additional negation");
$a = undef;
is($a++, '0', "postinc undef returns '0'");
@@ -88,7 +94,7 @@
print "# key '$_' was '$orig->{$_}' now missing\n";
$fail = 1;
}
- ok (!$fail);
+ ok (!$fail, "original hashes unchanged");
}
my (%orig) = my (%inc) = my (%dec) = my (%postinc) = my (%postdec)
@@ -100,8 +106,8 @@
my $ans = $up{$_};
my $up;
eval {$up = ++$_};
- is($up, $ans);
- is($@, '');
+ is($up, $ans, "key '$_' incremented correctly");
+ is($@, '', "no error condition");
}
check_same (\%orig, \%inc);
@@ -110,8 +116,8 @@
my $ans = $down{$_};
my $down;
eval {$down = --$_};
- is($down, $ans);
- is($@, '');
+ is($down, $ans, "key '$_' decremented correctly");
+ is($@, '', "no error condition");
}
check_same (\%orig, \%dec);
@@ -120,8 +126,8 @@
my $ans = $postinc{$_};
my $up;
eval {$up = $_++};
- is($up, $ans);
- is($@, '');
+ is($up, $ans, "assignment preceded postincrement");
+ is($@, '', "no error condition");
}
check_same (\%orig, \%postinc);
@@ -130,8 +136,8 @@
my $ans = $postdec{$_};
my $down;
eval {$down = $_--};
- is($down, $ans);
- is($@, '');
+ is($down, $ans, "assignment preceded postdecrement");
+ is($@, '', "no error condition");
}
check_same (\%orig, \%postdec);
@@ -143,8 +149,8 @@
$y ="$x\n";
++$x;
};
- cmp_ok($x, '==', 1);
- is($@, '');
+ cmp_ok($x, '==', 1, "preincrement of previously uninitialized variable");
+ is($@, '', "no error condition");
my ($p, $q);
eval {
@@ -151,18 +157,18 @@
$q ="$p\n";
--$p;
};
- cmp_ok($p, '==', -1);
- is($@, '');
+ cmp_ok($p, '==', -1, "predecrement of previously uninitialized variable");
+ is($@, '', "no error condition");
}
$a = 2147483648;
$c=--$a;
-cmp_ok($a, '==', 2147483647);
+cmp_ok($a, '==', 2147483647, "predecrement properly downgrades from double");
$a = 2147483648;
$c=$a--;
-cmp_ok($a, '==', 2147483647);
+cmp_ok($a, '==', 2147483647, "postdecrement properly downgrades from double");
{
use integer;
@@ -243,10 +249,10 @@
sub PVBM () { 'foo' }
{ my $dummy = index 'foo', PVBM }
-isnt(scalar eval { my $pvbm = PVBM; $pvbm++ }, undef);
-isnt(scalar eval { my $pvbm = PVBM; $pvbm-- }, undef);
-isnt(scalar eval { my $pvbm = PVBM; ++$pvbm }, undef);
-isnt(scalar eval { my $pvbm = PVBM; --$pvbm }, undef);
+isnt(scalar eval { my $pvbm = PVBM; $pvbm++ }, undef, "postincrement defined");
+isnt(scalar eval { my $pvbm = PVBM; $pvbm-- }, undef, "postdecrement defined");
+isnt(scalar eval { my $pvbm = PVBM; ++$pvbm }, undef, "preincrement defined");
+isnt(scalar eval { my $pvbm = PVBM; --$pvbm }, undef, "predecrement defined");
# #9466
Property changes on: trunk/contrib/perl/t/op/inc.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/t/op/inccode-tie.t
===================================================================
--- trunk/contrib/perl/t/op/inccode-tie.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/inccode-tie.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/inccode-tie.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/inccode.t
===================================================================
--- trunk/contrib/perl/t/op/inccode.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/inccode.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -21,7 +21,7 @@
use strict;
-plan(tests => 49 + !is_miniperl() * (3 + 14 * $can_fork));
+plan(tests => 60 + !is_miniperl() * (3 + 14 * $can_fork));
sub get_temp_fh {
my $f = tempfile();
@@ -194,12 +194,27 @@
is( $ret, 'abc', 'do "abc.pl" sees return value' );
{
- my $filename = './Foo.pm';
+ my $got;
#local @INC; # local fails on tied @INC
my @old_INC = @INC; # because local doesn't work on tied arrays
- @INC = sub { $filename = 'seen'; return undef; };
- eval { require $filename; };
- is( $filename, 'seen', 'the coderef sees fully-qualified pathnames' );
+ @INC = ('lib', 'lib/Devel', sub { $got = $_[1]; return undef; });
+ foreach my $filename ('/test_require.pm', './test_require.pm',
+ '../test_require.pm') {
+ local %INC;
+ undef $got;
+ undef $test_require::loaded;
+ eval { require $filename; };
+ is($got, $filename, "the coderef sees the pathname $filename");
+ is($test_require::loaded, undef, 'no module is loaded' );
+ }
+
+ local %INC;
+ undef $got;
+ undef $test_require::loaded;
+
+ eval { require 'test_require.pm'; };
+ is($got, undef, 'the directory is scanned for test_require.pm');
+ is($test_require::loaded, 1, 'the module is loaded');
@INC = @old_INC;
}
@@ -226,6 +241,26 @@
ok( 1, 'returning PVBM ref doesn\'t segfault use' );
shift @INC;
+# [perl #92252]
+{
+ my $die = sub { die };
+ my $data = [];
+ unshift @INC, sub { $die, $data };
+
+ my $initial_sub_refcnt = &Internals::SvREFCNT($die);
+ my $initial_data_refcnt = &Internals::SvREFCNT($data);
+
+ do "foo";
+ is(&Internals::SvREFCNT($die), $initial_sub_refcnt, "no leaks");
+ is(&Internals::SvREFCNT($data), $initial_data_refcnt, "no leaks");
+
+ do "bar";
+ is(&Internals::SvREFCNT($die), $initial_sub_refcnt, "no leaks");
+ is(&Internals::SvREFCNT($data), $initial_data_refcnt, "no leaks");
+
+ shift @INC;
+}
+
exit if is_miniperl();
SKIP: {
Property changes on: trunk/contrib/perl/t/op/inccode.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/incfilter.t
===================================================================
--- trunk/contrib/perl/t/op/incfilter.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/incfilter.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -216,6 +216,11 @@
"pass('And return multiple lines');\n",
]] or die;
+ at origlines = keys %{{ "1\n+\n2\n" => 1 }};
+ at lines = @origlines;
+do \&generator or die;
+is $origlines[0], "1\n+\n2\n", 'ink filters do not mangle cow buffers';
+
# d8723a6a74b2c12e wasn't perfect, as the char * returned by SvPV*() can be
# a temporary, freed at the next FREETMPS. And there is a FREETMPS in
# pp_require
@@ -228,22 +233,10 @@
do $fh or die;
}
-# [perl #91880] $_ marked TEMP or having the wrong refcount inside a
+# [perl #91880] $_ having the wrong refcount inside a
{ # filter sub
local @INC; local $|;
unshift @INC, sub { sub { undef *_; --$| }};
do "dah";
pass '$_ has the right refcount inside a filter sub';
-
- my $temps = 0;
- @INC = sub { sub {
- my $temp = \sub{$_}->();
- $temps++ if $temp == \$_;
- $_ = "a" unless $|;
- return --$|
- }};
- local $^W;
- do "dah";
-
- is $temps, 0, '$_ is not marked TEMP';
}
Property changes on: trunk/contrib/perl/t/op/incfilter.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/index.t
===================================================================
--- trunk/contrib/perl/t/op/index.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/index.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -7,7 +7,7 @@
}
use strict;
-plan( tests => 120 );
+plan( tests => 114 );
run_tests() unless caller;
@@ -128,19 +128,6 @@
is (rindex($text, $search_octets), -1);
}
-foreach my $utf8 ('', ', utf-8') {
- foreach my $arraybase (0, 1, -1, -2) {
- my $expect_pos = 2 + $arraybase;
-
- my $prog = "no warnings 'deprecated';\n";
- $prog .= "\$[ = $arraybase; \$big = \"N\\xabN\\xab\"; ";
- $prog .= '$big .= chr 256; chop $big; ' if $utf8;
- $prog .= 'print rindex $big, "N", 2 + $[';
-
- fresh_perl_is($prog, $expect_pos, {}, "\$[ = $arraybase$utf8");
- }
-}
-
SKIP: {
skip "UTF-EBCDIC is limited to 0x7fffffff", 3 if ord("A") == 193;
@@ -224,4 +211,10 @@
is($^A, 'bang', "formline isn't confused by index compilation");
is(index('bang', PVBM2), 0, "index isn't confused by format compilation");
+{
+ use constant perl => "rules";
+ is(index("perl rules", perl), 5, 'first index of a constant works');
+ is(index("rules 1 & 2", perl), 0, 'second index of the same constant works');
}
+
+}
Property changes on: trunk/contrib/perl/t/op/index.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.4
\ No newline at end of property
Index: trunk/contrib/perl/t/op/index_thr.t
===================================================================
--- trunk/contrib/perl/t/op/index_thr.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/index_thr.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/index_thr.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/int.t
===================================================================
--- trunk/contrib/perl/t/op/int.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/int.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -10,18 +10,20 @@
# compile time evaluation
-if (int(1.234) == 1) {pass()} else {fail()}
+my $test1_descr = 'compile time evaluation 1.234';
+if (int(1.234) == 1) {pass($test1_descr)} else {fail($test1_descr)}
-if (int(-1.234) == -1) {pass()} else {fail()}
+my $test2_descr = 'compile time evaluation -1.234';
+if (int(-1.234) == -1) {pass($test2_descr)} else {fail($test2_descr)}
# run time evaluation
$x = 1.234;
-cmp_ok(int($x), '==', 1);
-cmp_ok(int(-$x), '==', -1);
+cmp_ok(int($x), '==', 1, 'run time evaluation 1');
+cmp_ok(int(-$x), '==', -1, 'run time evaluation -1');
$x = length("abc") % -10;
-cmp_ok($x, '==', -7);
+cmp_ok($x, '==', -7, 'subtract from string length');
{
my $fail;
@@ -28,8 +30,8 @@
use integer;
$x = length("abc") % -10;
$y = (3/-10)*-10;
- ok($x+$y == 3) or ++$fail;
- ok(abs($x) < 10) or ++$fail;
+ ok($x+$y == 3, 'x+y equals 3') or ++$fail;
+ ok(abs($x) < 10, 'abs(x) < 10') or ++$fail;
if ($fail) {
diag("\$x == $x", "\$y == $y");
}
@@ -38,6 +40,8 @@
@x = ( 6, 8, 10);
cmp_ok($x["1foo"], '==', 8, 'check bad strings still get converted');
+# 4,294,967,295 is largest unsigned 32 bit integer
+
$x = 4294967303.15;
$y = int ($x);
is($y, "4294967303", 'check values > 32 bits work');
@@ -44,26 +48,26 @@
$y = int (-$x);
-is($y, "-4294967303");
+is($y, "-4294967303", 'negative value more than maximum unsigned 32 bit value');
$x = 4294967294.2;
$y = int ($x);
-is($y, "4294967294");
+is($y, "4294967294", 'floating point value slightly less than the largest unsigned 32 bit');
$x = 4294967295.7;
$y = int ($x);
-is($y, "4294967295");
+is($y, "4294967295", 'floating point value slightly more than largest unsigned 32 bit');
$x = 4294967296.11312;
$y = int ($x);
-is($y, "4294967296");
+is($y, "4294967296", 'floating point value more than largest unsigned 32 bit');
$y = int(279964589018079/59);
-cmp_ok($y, '==', 4745162525730);
+cmp_ok($y, '==', 4745162525730, 'compile time division, result of about 42 bits');
$y = 279964589018079;
$y = int($y/59);
-cmp_ok($y, '==', 4745162525730);
+cmp_ok($y, '==', 4745162525730, 'run time divison, result of about 42 bits');
Property changes on: trunk/contrib/perl/t/op/int.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/join.t
===================================================================
--- trunk/contrib/perl/t/op/join.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/join.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,25 +1,31 @@
#!./perl
-print "1..22\n";
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require './test.pl';
+}
+plan tests => 22;
+
@x = (1, 2, 3);
-if (join(':', at x) eq '1:2:3') {print "ok 1\n";} else {print "not ok 1\n";}
+is( join(':', at x), '1:2:3', 'join an array with character');
-if (join('',1,2,3) eq '123') {print "ok 2\n";} else {print "not ok 2\n";}
+is( join('',1,2,3), '123', 'join list with no separator');
-if (join(':',split(/ /,"1 2 3")) eq '1:2:3') {print "ok 3\n";} else {print "not ok 3\n";}
+is( join(':',split(/ /,"1 2 3")), '1:2:3', 'join implicit array with character');
my $f = 'a';
$f = join ',', 'b', $f, 'e';
-if ($f eq 'b,a,e') {print "ok 4\n";} else {print "# '$f'\nnot ok 4\n";}
+is( $f, 'b,a,e', 'join list back to self, middle of list');
$f = 'a';
$f = join ',', $f, 'b', 'e';
-if ($f eq 'a,b,e') {print "ok 5\n";} else {print "not ok 5\n";}
+is( $f, 'a,b,e', 'join list back to self, beginning of list');
$f = 'a';
$f = join $f, 'b', 'e', 'k';
-if ($f eq 'baeak') {print "ok 6\n";} else {print "# '$f'\nnot ok 6\n";}
+is( $f, 'baeak', 'join back to self, self is join character');
# 7,8 check for multiple read of tied objects
{ package X;
@@ -27,11 +33,9 @@
sub FETCH { my $y = shift; $$y += 5 };
tie my $t, 'X';
my $r = join ':', $t, 99, $t, 99;
- print "# expected '12:99:17:99' got '$r'\nnot " if $r ne '12:99:17:99';
- print "ok 7\n";
+ main::is($r, '12:99:17:99', 'check for multiple read of tied objects, with separator');
$r = join '', $t, 99, $t, 99;
- print "# expected '22992799' got '$r'\nnot " if $r ne '22992799';
- print "ok 8\n";
+ main::is($r, '22992799', 'check for multiple read of tied objects, w/o separator, and magic');
};
# 9,10 and for multiple read of undef
@@ -38,31 +42,25 @@
{ my $s = 5;
local ($^W, $SIG{__WARN__}) = ( 1, sub { $s+=4 } );
my $r = join ':', 'a', undef, $s, 'b', undef, $s, 'c';
- print "# expected 'a::9:b::13:c' got '$r'\nnot " if $r ne 'a::9:b::13:c';
- print "ok 9\n";
+ is( $r, 'a::9:b::13:c', 'multiple read of undef, with separator');
my $r = join '', 'a', undef, $s, 'b', undef, $s, 'c';
- print "# expected 'a17b21c' got '$r'\nnot " if $r ne 'a17b21c';
- print "ok 10\n";
+ is( $r, 'a17b21c', '... and without separator');
};
{ my $s = join("", chr(0x1234), chr(0xff));
- print "not " unless length($s) == 2 && $s eq "\x{1234}\x{ff}";
- print "ok 11\n";
+ is( $s, "\x{1234}\x{ff}", 'join two characters with multiple bytes, get two characters');
}
{ my $s = join(chr(0xff), chr(0x1234), "");
- print "not " unless length($s) == 2 && $s eq "\x{1234}\x{ff}";
- print "ok 12\n";
+ is( $s, "\x{1234}\x{ff}", 'high byte character as separator, 1 multi-byte character in front');
}
{ my $s = join(chr(0x1234), chr(0xff), chr(0x2345));
- print "not " unless length($s) == 3 && $s eq "\x{ff}\x{1234}\x{2345}";
- print "ok 13\n";
+ is( $s, "\x{ff}\x{1234}\x{2345}", 'multibyte character as separator');
}
{ my $s = join(chr(0xff), chr(0x1234), chr(0xfe));
- print "not " unless length($s) == 3 && $s eq "\x{1234}\x{ff}\x{fe}";
- print "ok 14\n";
+ is( $s, "\x{1234}\x{ff}\x{fe}", 'high byte as separator, multi-byte and high byte list');
}
{ # [perl #24846] $jb2 should be in bytes, not in utf8.
@@ -74,40 +72,28 @@
return $r;
}
+ sub byte_is {
+ use bytes;
+ return $_[0] eq $_[1] ? pass($_[2]) : fail($_[2]);
+ }
+
my $jb1 = join_into_my_variable("", $b);
my $ju1 = join_into_my_variable("", $u);
my $jb2 = join_into_my_variable("", $b);
my $ju2 = join_into_my_variable("", $u);
- {
- use bytes;
- print "not " unless $jb1 eq $b;
- print "ok 15\n";
- }
- print "not " unless $jb1 eq $b;
- print "ok 16\n";
+ note( 'utf8 and byte checks, perl #24846' );
- {
- use bytes;
- print "not " unless $ju1 eq $u;
- print "ok 17\n";
- }
- print "not " unless $ju1 eq $u;
- print "ok 18\n";
+ byte_is($jb1, $b);
+ is( $jb1, $b );
- {
- use bytes;
- print "not " unless $jb2 eq $b;
- print "ok 19\n";
- }
- print "not " unless $jb2 eq $b;
- print "ok 20\n";
+ byte_is($ju1, $u);
+ is( $ju1, $u );
- {
- use bytes;
- print "not " unless $ju2 eq $u;
- print "ok 21\n";
- }
- print "not " unless $ju2 eq $u;
- print "ok 22\n";
+ byte_is($jb2, $b);
+ is( $jb2, $b );
+
+ byte_is($ju2, $u);
+ is( $ju2, $u );
}
+
Property changes on: trunk/contrib/perl/t/op/join.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/op/kill0.t
===================================================================
--- trunk/contrib/perl/t/op/kill0.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/kill0.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/kill0.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/lc.t
===================================================================
--- trunk/contrib/perl/t/op/lc.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/lc.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,5 +1,7 @@
#!./perl
+# This file is intentionally encoded in latin-1.
+
BEGIN {
chdir 't';
@INC = '../lib';
@@ -6,13 +8,32 @@
require './test.pl';
}
-plan tests => 93;
+use feature qw( fc );
+plan tests => 128;
+
is(lc(undef), "", "lc(undef) is ''");
is(lcfirst(undef), "", "lcfirst(undef) is ''");
is(uc(undef), "", "uc(undef) is ''");
is(ucfirst(undef), "", "ucfirst(undef) is ''");
+{
+ no feature 'fc';
+ is(CORE::fc(undef), "", "fc(undef) is ''");
+ is(CORE::fc(''), "", "fc('') is ''");
+
+ local $@;
+ eval { fc("eeyup") };
+ like($@, qr/Undefined subroutine &main::fc/, "fc() throws an exception,");
+
+ {
+ use feature 'fc';
+ local $@;
+ eval { fc("eeyup") };
+ ok(!$@, "...but works after requesting the feature");
+ }
+}
+
$a = "HELLO.* world";
$b = "hello.* WORLD";
@@ -21,6 +42,7 @@
is("\l$a" , "hELLO\.\* world", '\l');
is("\U$a" , "HELLO\.\* WORLD", '\U');
is("\L$a" , "hello\.\* world", '\L');
+is("\F$a" , "hello\.\* world", '\F');
is(quotemeta($a) , "HELLO\\.\\*\\ world", 'quotemeta');
is(ucfirst($a) , "HELLO\.\* world", 'ucfirst');
@@ -27,6 +49,7 @@
is(lcfirst($a) , "hELLO\.\* world", 'lcfirst');
is(uc($a) , "HELLO\.\* WORLD", 'uc');
is(lc($a) , "hello\.\* world", 'lc');
+is(fc($a) , "hello\.\* world", 'fc');
is("\Q$b\E." , "hello\\.\\*\\ WORLD.", '\Q\E hello.* WORLD');
is("\u$b" , "Hello\.\* WORLD", '\u');
@@ -33,6 +56,7 @@
is("\l$b" , "hello\.\* WORLD", '\l');
is("\U$b" , "HELLO\.\* WORLD", '\U');
is("\L$b" , "hello\.\* world", '\L');
+is("\F$b" , "hello\.\* world", '\F');
is(quotemeta($b) , "hello\\.\\*\\ WORLD", 'quotemeta');
is(ucfirst($b) , "Hello\.\* WORLD", 'ucfirst');
@@ -39,9 +63,11 @@
is(lcfirst($b) , "hello\.\* WORLD", 'lcfirst');
is(uc($b) , "HELLO\.\* WORLD", 'uc');
is(lc($b) , "hello\.\* world", 'lc');
+is(fc($b) , "hello\.\* world", 'fc');
# \x{100} is LATIN CAPITAL LETTER A WITH MACRON; its bijective lowercase is
# \x{101}, LATIN SMALL LETTER A WITH MACRON.
+# Which is also its foldcase.
$a = "\x{100}\x{101}Aa";
$b = "\x{101}\x{100}aA";
@@ -51,6 +77,7 @@
is("\l$a" , "\x{101}\x{101}Aa", '\l');
is("\U$a" , "\x{100}\x{100}AA", '\U');
is("\L$a" , "\x{101}\x{101}aa", '\L');
+is("\F$a" , "\x{101}\x{101}aa", '\F');
is(quotemeta($a) , "\x{100}\x{101}Aa", 'quotemeta');
is(ucfirst($a) , "\x{100}\x{101}Aa", 'ucfirst');
@@ -57,6 +84,7 @@
is(lcfirst($a) , "\x{101}\x{101}Aa", 'lcfirst');
is(uc($a) , "\x{100}\x{100}AA", 'uc');
is(lc($a) , "\x{101}\x{101}aa", 'lc');
+is(fc($a) , "\x{101}\x{101}aa", 'fc');
is("\Q$b\E." , "\x{101}\x{100}aA.", '\Q\E \x{101}\x{100}aA');
is("\u$b" , "\x{100}\x{100}aA", '\u');
@@ -63,6 +91,7 @@
is("\l$b" , "\x{101}\x{100}aA", '\l');
is("\U$b" , "\x{100}\x{100}AA", '\U');
is("\L$b" , "\x{101}\x{101}aa", '\L');
+is("\F$b" , "\x{101}\x{101}aa", '\F');
is(quotemeta($b) , "\x{101}\x{100}aA", 'quotemeta');
is(ucfirst($b) , "\x{100}\x{100}aA", 'ucfirst');
@@ -69,6 +98,7 @@
is(lcfirst($b) , "\x{101}\x{100}aA", 'lcfirst');
is(uc($b) , "\x{100}\x{100}AA", 'uc');
is(lc($b) , "\x{101}\x{101}aa", 'lc');
+is(fc($b) , "\x{101}\x{101}aa", 'fc');
# \x{DF} is LATIN SMALL LETTER SHARP S, its uppercase is SS or \x{53}\x{53};
# \x{149} is LATIN SMALL LETTER N PRECEDED BY APOSTROPHE, its uppercase is
@@ -83,6 +113,15 @@
is(latin1_to_native("\L\x{DF}aB\x{149}cD"), latin1_to_native("\x{DF}ab\x{149}cd"),
"multicharacter lowercase");
+# \x{DF} is LATIN SMALL LETTER SHARP S, its foldcase is ss or \x{73}\x{73};
+# \x{149} is LATIN SMALL LETTER N PRECEDED BY APOSTROPHE, its foldcase is
+# \x{2BC}\x{6E} or MODIFIER LETTER APOSTROPHE and n.
+# Note that is this further tested in t/uni/fold.t
+
+is(latin1_to_native("\F\x{DF}aB\x{149}cD"), latin1_to_native("ssab\x{2BC}ncd"),
+ "multicharacter foldcase");
+
+
# titlecase is used for \u / ucfirst.
# \x{587} is ARMENIAN SMALL LIGATURE ECH YIWN and its titlecase is
@@ -91,6 +130,7 @@
# \x{587} itself
# and its uppercase is
# \x{535}\x{552} ARMENIAN CAPITAL LETTER ECH + ARMENIAN CAPITAL LETTER YIWN
+# The foldcase is \x{565}\x{582} ARMENIAN SMALL LETTER ECH + ARMENIAN SMALL LETTER YIWN
$a = "\x{587}";
@@ -97,10 +137,11 @@
is("\L\x{587}" , "\x{587}", "ligature lowercase");
is("\u\x{587}" , "\x{535}\x{582}", "ligature titlecase");
is("\U\x{587}" , "\x{535}\x{552}", "ligature uppercase");
+is("\F\x{587}" , "\x{565}\x{582}", "ligature foldcase");
# mktables had problems where many-to-one case mappings didn't work right.
# The lib/uni/fold.t should give the fourth folding, "casefolding", a good
-# workout (one cannot directly get that from Perl).
+# workout.
# \x{01C4} is LATIN CAPITAL LETTER DZ WITH CARON
# \x{01C5} is LATIN CAPITAL LETTER D WITH SMALL LETTER Z WITH CARON
# \x{01C6} is LATIN SMALL LETTER DZ WITH CARON
@@ -127,6 +168,9 @@
($c = $a) =~ s/(\p{IsWord}+)/uc($1)/ge;
is($c , $b, "Using s///e to change case.");
+($c = $a) =~ s/(\p{IsWord}+)/fc($1)/ge;
+is($c , $a, "Using s///e to foldcase.");
+
($c = $b) =~ s/(\p{IsWord}+)/lcfirst($1)/ge;
is($c , "\x{3c3}FOO.bAR", "Using s///e to change case.");
@@ -165,6 +209,11 @@
is(substr(ucfirst($_), 0), ucfirst($_), "[perl #38619] ucfirst");
}
+#fc() didn't exist back then, but coverage is coverage.
+for ("a\x{100}", "\xDFyz\x{100}", "xyz\x{100}", "XYZ\x{100}") { # \xDF to Ss (different length)
+ is(substr(fc($_), 0), fc($_), "[perl #38619] fc");
+}
+
# Related to [perl #38619]
# the original report concerns PERL_MAGIC_utf8.
# these cases concern PERL_MAGIC_regex_global.
@@ -187,11 +236,23 @@
is($result, $expect, "[perl #38619]");
}
+for (map { $_ } "A\x{100}", "ABC\x{100}", "\x{100}") {
+ chop; # get ("A", "ABC", "") in utf8
+ my $return = fc($_) =~ /\G(.?)/g;
+ my $result = $return ? $1 : "not";
+ my $expect = (fc($_) =~ /(.?)/g)[0];
+ is($return, 1, "[perl #38619]");
+ is($result, $expect, "[perl #38619]");
+}
+
for (1, 4, 9, 16, 25) {
is(uc "\x{03B0}" x $_, "\x{3a5}\x{308}\x{301}" x $_,
'uc U+03B0 grows threefold');
is(lc "\x{0130}" x $_, "i\x{307}" x $_, 'lc U+0130 grows');
+
+ is(fc "\x{03B0}" x $_, "\x{3C5}\x{308}\x{301}" x $_,
+ 'fc U+03B0 grows threefold');
}
# bug #43207
@@ -201,5 +262,21 @@
is($_, "Hello");
}
+# bug #43207
+my $temp = "Hello";
+for ("$temp") {
+ fc $_;
+ is($_, "Hello");
+}
+
# new in Unicode 5.1.0
is(lc("\x{1E9E}"), "\x{df}", "lc(LATIN CAPITAL LETTER SHARP S)");
+
+{
+ use feature 'unicode_strings';
+ use bytes;
+ is(lc("\xc0"), "\xc0", "lc of above-ASCII Latin1 is itself under use bytes");
+ is(lcfirst("\xc0"), "\xc0", "lcfirst of above-ASCII Latin1 is itself under use bytes");
+ is(uc("\xe0"), "\xe0", "uc of above-ASCII Latin1 is itself under use bytes");
+ is(ucfirst("\xe0"), "\xe0", "ucfirst of above-ASCII Latin1 is itself under use bytes");
+}
Property changes on: trunk/contrib/perl/t/op/lc.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/t/op/lc_user.t
===================================================================
--- trunk/contrib/perl/t/op/lc_user.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/lc_user.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/lc_user.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/leaky-magic.t
===================================================================
--- trunk/contrib/perl/t/op/leaky-magic.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/leaky-magic.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -104,11 +104,6 @@
ok eval { ${"foo::$name"} = 'twor'}, "\$foo::^$_";
}
-use tests 1; # $[
-# To avoid tests that are *too* weird, we’ll just check for definition.
-${"foo::["}; # touch
-ok !defined ${"foo::["}, '$foo::[';
-
use tests 4; # user/group vars
# These are rw, but setting them is obviously going to make the test much
# more complex than necessary. So, again, we check for definition.
Property changes on: trunk/contrib/perl/t/op/leaky-magic.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/length.t
===================================================================
--- trunk/contrib/perl/t/op/length.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/length.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -6,7 +6,7 @@
@INC = '../lib';
}
-plan (tests => 37);
+plan (tests => 41);
print "not " unless length("") == 0;
print "ok 1\n";
@@ -191,7 +191,12 @@
my $uo = bless [], 'U';
-is(length($uo), undef, "Length of overloaded reference");
+{
+ my $w;
+ local $SIG{__WARN__} = sub { $w = shift };
+ is(length($uo), 0, "Length of overloaded reference");
+ like $w, qr/uninitialized/, 'uninit warning for stringifying as undef';
+}
my $ul = 3;
is(($ul = length(undef)), undef,
@@ -204,12 +209,15 @@
is($ul, undef, "Assigned length of tied undef with result in TARG");
$ul = 3;
-is(($ul = length($uo)), undef,
+{
+ my $w;
+ local $SIG{__WARN__} = sub { $w = shift };
+ is(($ul = length($uo)), 0,
"Returned length of overloaded undef with result in TARG");
-is($ul, undef, "Assigned length of overloaded undef with result in TARG");
+ like $w, qr/uninitialized/, 'uninit warning for stringifying as undef';
+}
+is($ul, 0, "Assigned length of overloaded undef with result in TARG");
-# ok(!defined $uo); Turns you can't test this. FIXME for pp_defined?
-
{
my $y = "\x{100}BC";
is(index($y, "B"), 1, 'adds an intermediate position to the offset cache');
@@ -224,4 +232,17 @@
print length undef;
}
+{
+ local $SIG{__WARN__} = sub {
+ pass '[perl #106726] no crash with length @lexical warning'
+ };
+ eval ' sub { length my @forecasts } ';
+}
+
+# length could be fooled by UTF8ness of non-magical variables changing with
+# stringification.
+my $ref = [];
+bless $ref, "\x{100}";
+is length $ref, length "$ref", 'length on reference blessed to utf8 class';
+
is($warnings, 0, "There were no other warnings");
Property changes on: trunk/contrib/perl/t/op/length.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/lex.t
===================================================================
--- trunk/contrib/perl/t/op/lex.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/lex.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -4,7 +4,7 @@
require './test.pl';
-plan(tests => 4);
+plan(tests => 7);
{
no warnings 'deprecated';
@@ -45,3 +45,31 @@
}
+{
+ delete local $ENV{PERL_UNICODE};
+ fresh_perl_is(
+ 'BEGIN{ ++$_ for @INC{"charnames.pm","_charnames.pm"} } "\N{a}"',
+ 'Constant(\N{a}) unknown at - line 1, within string' . "\n"
+ ."Execution of - aborted due to compilation errors.\n",
+ { stderr => 1 },
+ 'correct output (and no crash) when charnames cannot load for \N{...}'
+ );
+}
+fresh_perl_is(
+ 'BEGIN{ ++$_ for @INC{"charnames.pm","_charnames.pm"};
+ $^H{charnames} = "foo" } "\N{a}"',
+ "Undefined subroutine &main::foo called at - line 2.\n"
+ ."Propagated at - line 2, within string\n"
+ ."Execution of - aborted due to compilation errors.\n",
+ { stderr => 1 },
+ 'no crash when charnames cannot load and %^H holds string'
+);
+fresh_perl_is(
+ 'BEGIN{ ++$_ for @INC{"charnames.pm","_charnames.pm"};
+ $^H{charnames} = \"foo" } "\N{a}"',
+ "Not a CODE reference at - line 2.\n"
+ ."Propagated at - line 2, within string\n"
+ ."Execution of - aborted due to compilation errors.\n",
+ { stderr => 1 },
+ 'no crash when charnames cannot load and %^H holds string reference'
+);
Property changes on: trunk/contrib/perl/t/op/lex.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/lex_assign.t
===================================================================
--- trunk/contrib/perl/t/op/lex_assign.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/lex_assign.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -3,6 +3,7 @@
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
+ require './test.pl';
}
$| = 1;
@@ -24,17 +25,13 @@
@INPUT = <DATA>;
@simple_input = grep /^\s*\w+\s*\$\w+\s*[#\n]/, @INPUT;
-print "1..", (11 + @INPUT + @simple_input), "\n";
-$ord = 0;
sub wrn {"@_"}
# Check correct optimization of ucfirst etc
-$ord++;
my $a = "AB";
my $b = "\u\L$a";
-print "not " unless $b eq 'Ab';
-print "ok $ord\n";
+is( $b, 'Ab', 'Check correct optimization of ucfirst, etc');
# Check correct destruction of objects:
my $dc = 0;
@@ -43,23 +40,18 @@
my $b;
{ my $c = 6; $b = bless \$c, "A"}
-$ord++;
-print "not " unless $dc == 0;
-print "ok $ord\n";
+is($dc, 0, 'No destruction yet');
$b = $a+5;
-$ord++;
-print "not " unless $dc == 1;
-print "ok $ord\n";
+is($dc, 1, 'object descruction via reassignment to variable');
-$ord++;
my $xxx = 'b';
$xxx = 'c' . ($xxx || 'e');
-print "not " unless $xxx eq 'cb';
-print "ok $ord\n";
+is( $xxx, 'cb', 'variables can be read before being overwritten');
{ # Check calling STORE
+ note('Tied variables, calling STORE');
my $sc = 0;
sub B::TIESCALAR {bless [11], 'B'}
sub B::FETCH { -(shift->[0]) }
@@ -69,31 +61,19 @@
tie $m, 'B';
$m = 100;
- $ord++;
- print "not " unless $sc == 1;
- print "ok $ord\n";
+ is( $sc, 1, 'STORE called when assigning scalar to tied variable' );
my $t = 11;
$m = $t + 89;
- $ord++;
- print "not " unless $sc == 2;
- print "ok $ord\n";
+ is( $sc, 2, 'and again' );
+ is( $m, -117, 'checking the tied variable result' );
- $ord++;
- print "# $m\nnot " unless $m == -117;
- print "ok $ord\n";
-
$m += $t;
- $ord++;
- print "not " unless $sc == 3;
- print "ok $ord\n";
+ is( $sc, 3, 'called on self-increment' );
+ is( $m, 89, 'checking the tied variable result' );
- $ord++;
- print "# $m\nnot " unless $m == 89;
- print "ok $ord\n";
-
}
# Chains of assignments
@@ -102,14 +82,14 @@
my $zzzz = 12;
$zzz1 = $l1 = $l2 = $zzz2 = $l3 = $l4 = 1 + $zzzz;
-$ord++;
-print "# $zzz1 = $l1 = $l2 = $zzz2 = $l3 = $l4 = 13\nnot "
- unless $zzz1 == 13 and $zzz2 == 13 and $l1 == 13
- and $l2 == 13 and $l3 == 13 and $l4 == 13;
-print "ok $ord\n";
+is($zzz1, 13, 'chain assignment, part1');
+is($zzz2, 13, 'chain assignment, part2');
+is($l1, 13, 'chain assignment, part3');
+is($l2, 13, 'chain assignment, part4');
+is($l3, 13, 'chain assignment, part5');
+is($l4, 13, 'chain assignment, part6');
for (@INPUT) {
- $ord++;
($op, undef, $comment) = /^([^\#]+)(\#\s+(.*))?/;
$comment = $op unless defined $comment;
chomp;
@@ -119,7 +99,13 @@
$skip = ($op =~ /^'\?\?\?'/ or $comment =~ /skip\(.*\Q$^O\E.*\)/i)
? "skip" : "# '$_'\nnot";
$integer = ($comment =~ /^i_/) ? "use integer" : '' ;
- (print "#skipping $comment:\nok $ord\n"), next if $skip eq 'skip';
+ if ($skip eq 'skip') {
+ SKIP: {
+ skip $comment, 1;
+ pass();
+ }
+ next;
+ }
eval <<EOE;
local \$SIG{__WARN__} = \\&wrn;
@@ -128,23 +114,28 @@
\$a = $op;
\$b = $expectop;
if (\$a ne \$b) {
- print "# \$comment: got `\$a', expected `\$b'\n";
- print "\$skip " if \$a ne \$b or \$skip eq 'skip';
+ SKIP: {
+ skip "\$comment: got '\$a', expected '\$b'", 1;
+ pass("")
+ }
}
- print "ok \$ord\\n";
+ pass();
EOE
if ($@) {
+ $warning = $@;
+ chomp $warning;
if ($@ =~ /is unimplemented/) {
- print "# skipping $comment: unimplemented:\nok $ord\n";
+ SKIP: {
+ skip $warning, 1;
+ pass($comment);
+ }
} else {
- warn $@;
- print "# '$_'\nnot ok $ord\n";
+ fail($_ . ' ' . $warning);
}
}
}
for (@simple_input) {
- $ord++;
($op, undef, $comment) = /^([^\#]+)(\#\s+(.*))?/;
$comment = $op unless defined $comment;
chomp;
@@ -155,23 +146,28 @@
\$$variable = $operator \$$variable;
\$toself = \$$variable;
\$direct = $operator "Ac# Ca\\nxxx";
- print "# \\\$$variable = $operator \\\$$variable\\nnot "
- unless \$toself eq \$direct;
- print "ok \$ord\\n";
+ is(\$toself, \$direct);
EOE
if ($@) {
+ $warning = $@;
+ chomp $warning;
if ($@ =~ /is unimplemented/) {
- print "# skipping $comment: unimplemented:\nok $ord\n";
+ SKIP: {
+ skip $warning, 1;
+ pass($comment);
+ }
} elsif ($@ =~ /Can't (modify|take log of 0)/) {
- print "# skipping $comment: syntax not good for selfassign:\nok $ord\n";
+ SKIP: {
+ skip $warning . ' ' . $comment . ' syntax not good for selfassign', 1;
+ pass();
+ }
} else {
- warn $@;
- print "# '$_'\nnot ok $ord\n";
+ ##Something bad happened
+ fail($_ . ' ' . $warning);
}
}
}
-$ord++;
eval {
sub PVBM () { 'foo' }
index 'foo', PVBM;
@@ -183,12 +179,10 @@
1;
};
-if ($@) {
- warn "# $@";
- print 'not ';
-}
-print "ok $ord\n";
+is($@, '', 'ex-PVBM assert'.$@);
+done_testing();
+
__END__
ref $xref # ref
ref $cstr # ref nonref
Property changes on: trunk/contrib/perl/t/op/lex_assign.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/op/lexsub.t (from rev 6437, vendor/perl/5.18.1/t/op/lexsub.t)
===================================================================
--- trunk/contrib/perl/t/op/lexsub.t (rev 0)
+++ trunk/contrib/perl/t/op/lexsub.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,713 @@
+#!perl
+
+BEGIN {
+ chdir 't';
+ @INC = '../lib';
+ require './test.pl';
+ *bar::is = *is;
+ *bar::like = *like;
+}
+no warnings 'deprecated';
+plan 136;
+
+# -------------------- Errors with feature disabled -------------------- #
+
+eval "#line 8 foo\nmy sub foo";
+is $@, qq 'Experimental "my" subs not enabled at foo line 8.\n',
+ 'my sub unexperimental error';
+eval "#line 8 foo\nCORE::state sub foo";
+is $@, qq 'Experimental "state" subs not enabled at foo line 8.\n',
+ 'state sub unexperimental error';
+eval "#line 8 foo\nour sub foo";
+is $@, qq 'Experimental "our" subs not enabled at foo line 8.\n',
+ 'our sub unexperimental error';
+
+# -------------------- our -------------------- #
+
+no warnings "experimental::lexical_subs";
+use feature 'lexical_subs';
+{
+ our sub foo { 42 }
+ is foo, 42, 'calling our sub from same package';
+ is &foo, 42, 'calling our sub from same package (amper)';
+ is do foo(), 42, 'calling our sub from same package (do)';
+ package bar;
+ sub bar::foo { 43 }
+ is foo, 42, 'calling our sub from another package';
+ is &foo, 42, 'calling our sub from another package (amper)';
+ is do foo(), 42, 'calling our sub from another package (do)';
+}
+package bar;
+is foo, 43, 'our sub falling out of scope';
+is &foo, 43, 'our sub falling out of scope (called via amper)';
+is do foo(), 43, 'our sub falling out of scope (called via amper)';
+package main;
+{
+ sub bar::a { 43 }
+ our sub a {
+ if (shift) {
+ package bar;
+ is a, 43, 'our sub invisible inside itself';
+ is &a, 43, 'our sub invisible inside itself (called via amper)';
+ is do a(), 43, 'our sub invisible inside itself (called via do)';
+ }
+ 42
+ }
+ a(1);
+ sub bar::b { 43 }
+ our sub b;
+ our sub b {
+ if (shift) {
+ package bar;
+ is b, 42, 'our sub visible inside itself after decl';
+ is &b, 42, 'our sub visible inside itself after decl (amper)';
+ is do b(), 42, 'our sub visible inside itself after decl (do)';
+ }
+ 42
+ }
+ b(1)
+}
+sub c { 42 }
+sub bar::c { 43 }
+{
+ our sub c;
+ package bar;
+ is c, 42, 'our sub foo; makes lex alias for existing sub';
+ is &c, 42, 'our sub foo; makes lex alias for existing sub (amper)';
+ is do c(), 42, 'our sub foo; makes lex alias for existing sub (do)';
+}
+{
+ our sub d;
+ sub bar::d { 'd43' }
+ package bar;
+ sub d { 'd42' }
+ is eval ::d, 'd42', 'our sub foo; applies to subsequent sub foo {}';
+}
+{
+ our sub e ($);
+ is prototype "::e", '$', 'our sub with proto';
+}
+{
+ our sub if() { 42 }
+ my $x = if if if;
+ is $x, 42, 'lexical subs (even our) override all keywords';
+ package bar;
+ my $y = if if if;
+ is $y, 42, 'our subs from other packages override all keywords';
+}
+
+# -------------------- state -------------------- #
+
+use feature 'state'; # state
+{
+ state sub foo { 44 }
+ isnt \&::foo, \&foo, 'state sub is not stored in the package';
+ is eval foo, 44, 'calling state sub from same package';
+ is eval &foo, 44, 'calling state sub from same package (amper)';
+ is eval do foo(), 44, 'calling state sub from same package (do)';
+ package bar;
+ is eval foo, 44, 'calling state sub from another package';
+ is eval &foo, 44, 'calling state sub from another package (amper)';
+ is eval do foo(), 44, 'calling state sub from another package (do)';
+}
+package bar;
+is foo, 43, 'state sub falling out of scope';
+is &foo, 43, 'state sub falling out of scope (called via amper)';
+is do foo(), 43, 'state sub falling out of scope (called via amper)';
+{
+ sub sa { 43 }
+ state sub sa {
+ if (shift) {
+ is sa, 43, 'state sub invisible inside itself';
+ is &sa, 43, 'state sub invisible inside itself (called via amper)';
+ is do sa(), 43, 'state sub invisible inside itself (called via do)';
+ }
+ 44
+ }
+ sa(1);
+ sub sb { 43 }
+ state sub sb;
+ state sub sb {
+ if (shift) {
+ # ‘state sub foo{}’ creates a new pad entry, not reusing the forward
+ # declaration. Being invisible inside itself, it sees the stub.
+ eval{sb};
+ like $@, qr/^Undefined subroutine &sb called at /,
+ 'state sub foo {} after forward declaration';
+ eval{&sb};
+ like $@, qr/^Undefined subroutine &sb called at /,
+ 'state sub foo {} after forward declaration (amper)';
+ eval{do sb()};
+ like $@, qr/^Undefined subroutine &sb called at /,
+ 'state sub foo {} after forward declaration (do)';
+ }
+ 44
+ }
+ sb(1);
+ sub sb2 { 43 }
+ state sub sb2;
+ sub sb2 {
+ if (shift) {
+ package bar;
+ is sb2, 44, 'state sub visible inside itself after decl';
+ is &sb2, 44, 'state sub visible inside itself after decl (amper)';
+ is do sb2(), 44, 'state sub visible inside itself after decl (do)';
+ }
+ 44
+ }
+ sb2(1);
+ state sub sb3;
+ {
+ state sub sb3 { # new pad entry
+ # The sub containing this comment is invisible inside itself.
+ # So this one here will assign to the outer pad entry:
+ sub sb3 { 47 }
+ }
+ }
+ is eval{sb3}, 47,
+ 'sub foo{} applying to "state sub foo;" even inside state sub foo{}';
+ # Same test again, but inside an anonymous sub
+ sub {
+ state sub sb4;
+ {
+ state sub sb4 {
+ sub sb4 { 47 }
+ }
+ }
+ is sb4, 47,
+ 'sub foo{} applying to "state sub foo;" even inside state sub foo{}';
+ }->();
+}
+sub sc { 43 }
+{
+ state sub sc;
+ eval{sc};
+ like $@, qr/^Undefined subroutine &sc called at /,
+ 'state sub foo; makes no lex alias for existing sub';
+ eval{&sc};
+ like $@, qr/^Undefined subroutine &sc called at /,
+ 'state sub foo; makes no lex alias for existing sub (amper)';
+ eval{do sc()};
+ like $@, qr/^Undefined subroutine &sc called at /,
+ 'state sub foo; makes no lex alias for existing sub (do)';
+}
+package main;
+{
+ state sub se ($);
+ is prototype eval{\&se}, '$', 'state sub with proto';
+ is prototype "se", undef, 'prototype "..." ignores state subs';
+}
+{
+ state sub if() { 44 }
+ my $x = if if if;
+ is $x, 44, 'state subs override all keywords';
+ package bar;
+ my $y = if if if;
+ is $y, 44, 'state subs from other packages override all keywords';
+}
+{
+ use warnings; no warnings "experimental::lexical_subs";
+ state $w ;
+ local $SIG{__WARN__} = sub { $w .= shift };
+ eval '#line 87 squidges
+ state sub foo;
+ state sub foo {};
+ ';
+ is $w,
+ '"state" subroutine &foo masks earlier declaration in same scope at '
+ . "squidges line 88.\n",
+ 'warning for state sub masking earlier declaration';
+}
+# Since state vars inside anonymous subs are cloned at the same time as the
+# anonymous subs containing them, the same should happen for state subs.
+sub make_closure {
+ my $x = shift;
+ sub {
+ state sub foo { $x }
+ foo
+ }
+}
+$sub1 = make_closure 48;
+$sub2 = make_closure 49;
+is &$sub1, 48, 'state sub in closure (1)';
+is &$sub2, 49, 'state sub in closure (2)';
+# But we need to test that state subs actually do persist from one invoca-
+# tion of a named sub to another (i.e., that they are not my subs).
+{
+ use warnings; no warnings "experimental::lexical_subs";
+ state $w;
+ local $SIG{__WARN__} = sub { $w .= shift };
+ eval '#line 65 teetet
+ sub foom {
+ my $x = shift;
+ state sub poom { $x }
+ eval{\&poom}
+ }
+ ';
+ is $w, "Variable \"\$x\" will not stay shared at teetet line 67.\n",
+ 'state subs get "Variable will not stay shared" messages';
+ my $poom = foom(27);
+ my $poom2 = foom(678);
+ is eval{$poom->()}, eval {$poom2->()},
+ 'state subs close over the first outer my var, like pkg subs';
+ my $x = 43;
+ for $x (765) {
+ state sub etetetet { $x }
+ is eval{etetetet}, 43, 'state sub ignores for() localisation';
+ }
+}
+# And we also need to test that multiple state subs can close over each
+# other’s entries in the parent subs pad, and that cv_clone is not con-
+# fused by that.
+sub make_anon_with_state_sub{
+ sub {
+ state sub s1;
+ state sub s2 { \&s1 }
+ sub s1 { \&s2 }
+ if (@_) { return \&s1 }
+ is s1,\&s2, 'state sub in anon closure closing over sibling state sub';
+ is s2,\&s1, 'state sub in anon closure closing over sibling state sub';
+ }
+}
+{
+ my $s = make_anon_with_state_sub;
+ &$s;
+
+ # And make sure the state subs were actually cloned.
+ isnt make_anon_with_state_sub->(0), &$s(0),
+ 'state subs in anon subs are cloned';
+ is &$s(0), &$s(0), 'but only when the anon sub is cloned';
+}
+{
+ state sub BEGIN { exit };
+ pass 'state subs are never special blocks';
+ state sub END { shift }
+ is eval{END('jkqeudth')}, jkqeudth,
+ 'state sub END {shift} implies @_, not @ARGV';
+}
+{
+ state sub redef {}
+ use warnings; no warnings "experimental::lexical_subs";
+ state $w;
+ local $SIG{__WARN__} = sub { $w .= shift };
+ eval "#line 56 pygpyf\nsub redef {}";
+ is $w, "Subroutine redef redefined at pygpyf line 56.\n",
+ "sub redefinition warnings from state subs";
+}
+{
+ state sub p (\@) {
+ is ref $_[0], 'ARRAY', 'state sub with proto';
+ }
+ p(my @a);
+ p my @b;
+ state sub q () { 45 }
+ is q(), 45, 'state constant called with parens';
+}
+{
+ state sub x;
+ eval 'sub x {3}';
+ is x, 3, 'state sub defined inside eval';
+
+ sub r {
+ state sub foo { 3 };
+ if (@_) { # outer call
+ r();
+ is foo(), 42,
+ 'state sub run-time redefinition applies to all recursion levels';
+ }
+ else { # inner call
+ eval 'sub foo { 42 }';
+ }
+ }
+ r(1);
+}
+like runperl(
+ switches => [ '-Mfeature=:all' ],
+ prog => 'state sub a { foo ref } a()',
+ stderr => 1
+ ),
+ qr/syntax error/,
+ 'referencing a state sub after a syntax error does not crash';
+
+# -------------------- my -------------------- #
+
+{
+ my sub foo { 44 }
+ isnt \&::foo, \&foo, 'my sub is not stored in the package';
+ is foo, 44, 'calling my sub from same package';
+ is &foo, 44, 'calling my sub from same package (amper)';
+ is do foo(), 44, 'calling my sub from same package (do)';
+ package bar;
+ is foo, 44, 'calling my sub from another package';
+ is &foo, 44, 'calling my sub from another package (amper)';
+ is do foo(), 44, 'calling my sub from another package (do)';
+}
+package bar;
+is foo, 43, 'my sub falling out of scope';
+is &foo, 43, 'my sub falling out of scope (called via amper)';
+is do foo(), 43, 'my sub falling out of scope (called via amper)';
+{
+ sub ma { 43 }
+ my sub ma {
+ if (shift) {
+ is ma, 43, 'my sub invisible inside itself';
+ is &ma, 43, 'my sub invisible inside itself (called via amper)';
+ is do ma(), 43, 'my sub invisible inside itself (called via do)';
+ }
+ 44
+ }
+ ma(1);
+ sub mb { 43 }
+ my sub mb;
+ my sub mb {
+ if (shift) {
+ # ‘my sub foo{}’ creates a new pad entry, not reusing the forward
+ # declaration. Being invisible inside itself, it sees the stub.
+ eval{mb};
+ like $@, qr/^Undefined subroutine &mb called at /,
+ 'my sub foo {} after forward declaration';
+ eval{&mb};
+ like $@, qr/^Undefined subroutine &mb called at /,
+ 'my sub foo {} after forward declaration (amper)';
+ eval{do mb()};
+ like $@, qr/^Undefined subroutine &mb called at /,
+ 'my sub foo {} after forward declaration (do)';
+ }
+ 44
+ }
+ mb(1);
+ sub mb2 { 43 }
+ my sub sb2;
+ sub mb2 {
+ if (shift) {
+ package bar;
+ is mb2, 44, 'my sub visible inside itself after decl';
+ is &mb2, 44, 'my sub visible inside itself after decl (amper)';
+ is do mb2(), 44, 'my sub visible inside itself after decl (do)';
+ }
+ 44
+ }
+ mb2(1);
+ my sub mb3;
+ {
+ my sub mb3 { # new pad entry
+ # The sub containing this comment is invisible inside itself.
+ # So this one here will assign to the outer pad entry:
+ sub mb3 { 47 }
+ }
+ }
+ is eval{mb3}, 47,
+ 'sub foo{} applying to "my sub foo;" even inside my sub foo{}';
+ # Same test again, but inside an anonymous sub
+ sub {
+ my sub mb4;
+ {
+ my sub mb4 {
+ sub mb4 { 47 }
+ }
+ }
+ is mb4, 47,
+ 'sub foo{} applying to "my sub foo;" even inside my sub foo{}';
+ }->();
+}
+sub mc { 43 }
+{
+ my sub mc;
+ eval{mc};
+ like $@, qr/^Undefined subroutine &mc called at /,
+ 'my sub foo; makes no lex alias for existing sub';
+ eval{&mc};
+ like $@, qr/^Undefined subroutine &mc called at /,
+ 'my sub foo; makes no lex alias for existing sub (amper)';
+ eval{do mc()};
+ like $@, qr/^Undefined subroutine &mc called at /,
+ 'my sub foo; makes no lex alias for existing sub (do)';
+}
+package main;
+{
+ my sub me ($);
+ is prototype eval{\&me}, '$', 'my sub with proto';
+ is prototype "me", undef, 'prototype "..." ignores my subs';
+}
+{
+ my sub if() { 44 }
+ my $x = if if if;
+ is $x, 44, 'my subs override all keywords';
+ package bar;
+ my $y = if if if;
+ is $y, 44, 'my subs from other packages override all keywords';
+}
+{
+ use warnings; no warnings "experimental::lexical_subs";
+ my $w ;
+ local $SIG{__WARN__} = sub { $w .= shift };
+ eval '#line 87 squidges
+ my sub foo;
+ my sub foo {};
+ ';
+ is $w,
+ '"my" subroutine &foo masks earlier declaration in same scope at '
+ . "squidges line 88.\n",
+ 'warning for my sub masking earlier declaration';
+}
+# Test that my subs are cloned inside anonymous subs.
+sub mmake_closure {
+ my $x = shift;
+ sub {
+ my sub foo { $x }
+ foo
+ }
+}
+$sub1 = mmake_closure 48;
+$sub2 = mmake_closure 49;
+is &$sub1, 48, 'my sub in closure (1)';
+is &$sub2, 49, 'my sub in closure (2)';
+# Test that they are cloned in named subs.
+{
+ use warnings; no warnings "experimental::lexical_subs";
+ my $w;
+ local $SIG{__WARN__} = sub { $w .= shift };
+ eval '#line 65 teetet
+ sub mfoom {
+ my $x = shift;
+ my sub poom { $x }
+ \&poom
+ }
+ ';
+ is $w, undef, 'my subs get no "Variable will not stay shared" messages';
+ my $poom = mfoom(27);
+ my $poom2 = mfoom(678);
+ is $poom->(), 27, 'my subs closing over outer my var (1)';
+ is $poom2->(), 678, 'my subs closing over outer my var (2)';
+ my $x = 43;
+ my sub aoeu;
+ for $x (765) {
+ my sub etetetet { $x }
+ sub aoeu { $x }
+ is etetetet, 765, 'my sub respects for() localisation';
+ is aoeu, 43, 'unless it is declared outside the for loop';
+ }
+}
+# And we also need to test that multiple my subs can close over each
+# other’s entries in the parent subs pad, and that cv_clone is not con-
+# fused by that.
+sub make_anon_with_my_sub{
+ sub {
+ my sub s1;
+ my sub s2 { \&s1 }
+ sub s1 { \&s2 }
+ if (@_) { return eval { \&s1 } }
+ is eval{s1},eval{\&s2}, 'my sub in anon closure closing over sibling my sub';
+ is eval{s2},eval{\&s1}, 'my sub in anon closure closing over sibling my sub';
+ }
+}
+
+# Test my subs inside predeclared my subs
+{
+ my sub s2;
+ sub s2 {
+ my $x = 3;
+ my sub s3 { eval '$x' }
+ s3;
+ }
+ is s2, 3, 'my sub inside predeclared my sub';
+}
+
+{
+ my $s = make_anon_with_my_sub;
+ &$s;
+
+ # And make sure the my subs were actually cloned.
+ isnt make_anon_with_my_sub->(0), &$s(0),
+ 'my subs in anon subs are cloned';
+ isnt &$s(0), &$s(0), 'at each invocation of the enclosing sub';
+}
+{
+ my sub BEGIN { exit };
+ pass 'my subs are never special blocks';
+ my sub END { shift }
+ is END('jkqeudth'), jkqeudth,
+ 'my sub END {shift} implies @_, not @ARGV';
+}
+{
+ my sub redef {}
+ use warnings; no warnings "experimental::lexical_subs";
+ my $w;
+ local $SIG{__WARN__} = sub { $w .= shift };
+ eval "#line 56 pygpyf\nsub redef {}";
+ is $w, "Subroutine redef redefined at pygpyf line 56.\n",
+ "sub redefinition warnings from my subs";
+
+ undef $w;
+ sub {
+ my sub x {};
+ sub { eval "#line 87 khaki\n\\&x" }
+ }->()();
+ is $w, "Subroutine \"&x\" is not available at khaki line 87.\n",
+ "unavailability warning during compilation of eval in closure";
+
+ undef $w;
+ no warnings 'void';
+ eval <<'->()();';
+#line 87 khaki
+ sub {
+ my sub x{}
+ sub not_lexical8 {
+ \&x
+ }
+ }
+->()();
+ is $w, "Subroutine \"&x\" is not available at khaki line 90.\n",
+ "unavailability warning during compilation of named sub in anon";
+
+ undef $w;
+ sub not_lexical9 {
+ my sub x {};
+ format =
+@
+&x
+.
+ }
+ eval { write };
+ my($f,$l) = (__FILE__,__LINE__ - 1);
+ is $w, "Subroutine \"&x\" is not available at $f line $l.\n",
+ 'unavailability warning during cloning';
+ $l -= 3;
+ is $@, "Undefined subroutine &x called at $f line $l.\n",
+ 'Vivified sub is correctly named';
+}
+sub not_lexical10 {
+ my sub foo;
+ foo();
+ sub not_lexical11 {
+ my sub bar {
+ my $x = 'khaki car keys for the khaki car';
+ not_lexical10();
+ sub foo {
+ is $x, 'khaki car keys for the khaki car',
+ 'mysubs in inner clonables use the running clone of their CvOUTSIDE'
+ }
+ }
+ bar()
+ }
+}
+not_lexical11();
+{
+ my sub p (\@) {
+ is ref $_[0], 'ARRAY', 'my sub with proto';
+ }
+ p(my @a);
+ p @a;
+ my sub q () { 46 }
+ is q(), 46, 'my constant called with parens';
+}
+{
+ my sub x;
+ my $count;
+ sub x { x() if $count++ < 10 }
+ x();
+ is $count, 11, 'my recursive subs';
+}
+{
+ my sub x;
+ eval 'sub x {3}';
+ is x, 3, 'my sub defined inside eval';
+}
+
+{
+ state $w;
+ local $SIG{__WARN__} = sub { $w .= shift };
+ eval q{ my sub george () { 2 } };
+ is $w, undef, 'no double free from constant my subs';
+}
+like runperl(
+ switches => [ '-Mfeature=:all' ],
+ prog => 'my sub a { foo ref } a()',
+ stderr => 1
+ ),
+ qr/syntax error/,
+ 'referencing a my sub after a syntax error does not crash';
+
+# -------------------- Interactions (and misc tests) -------------------- #
+
+is sub {
+ my sub s1;
+ my sub s2 { 3 };
+ sub s1 { state sub foo { \&s2 } foo }
+ s1
+ }->()(), 3, 'state sub inside my sub closing over my sub uncle';
+
+{
+ my sub s2 { 3 };
+ sub not_lexical { state sub foo { \&s2 } foo }
+ is not_lexical->(), 3, 'state subs that reference my sub from outside';
+}
+
+# Test my subs inside predeclared package subs
+# This test also checks that CvOUTSIDE pointers are not mangled when the
+# inner sub’s CvOUTSIDE points to another sub.
+sub not_lexical2;
+sub not_lexical2 {
+ my $x = 23;
+ my sub bar;
+ sub not_lexical3 {
+ not_lexical2();
+ sub bar { $x }
+ };
+ bar
+}
+is not_lexical3, 23, 'my subs inside predeclared package subs';
+
+# Test my subs inside predeclared package sub, where the lexical sub is
+# declared outside the package sub.
+# This checks that CvOUTSIDE pointers are fixed up even when the sub is
+# not declared inside the sub that its CvOUTSIDE points to.
+sub not_lexical5 {
+ my sub foo;
+ sub not_lexical4;
+ sub not_lexical4 {
+ my $x = 234;
+ not_lexical5();
+ sub foo { $x }
+ }
+ foo
+}
+is not_lexical4, 234,
+ 'my sub defined in predeclared pkg sub but declared outside';
+
+undef *not_lexical6;
+{
+ my sub foo;
+ sub not_lexical6 { sub foo { } }
+ pass 'no crash when cloning a mysub declared inside an undef pack sub';
+}
+
+undef ¬_lexical7;
+eval 'sub not_lexical7 { my @x }';
+{
+ my sub foo;
+ foo();
+ sub not_lexical7 {
+ state $x;
+ sub foo {
+ is ref \$x, 'SCALAR',
+ "redeffing a mysub's outside does not make it use the wrong pad"
+ }
+ }
+}
+
+like runperl(
+ switches => [ '-Mfeature=:all', '-Mwarnings=FATAL,all', '-M-warnings=experimental::lexical_subs' ],
+ prog => 'my sub foo; sub foo { foo } foo',
+ stderr => 1
+ ),
+ qr/Deep recursion on subroutine "foo"/,
+ 'deep recursion warnings for lexical subs do not crash';
+
+like runperl(
+ switches => [ '-Mfeature=:all', '-Mwarnings=FATAL,all', '-M-warnings=experimental::lexical_subs' ],
+ prog => 'my sub foo() { 42 } undef &foo',
+ stderr => 1
+ ),
+ qr/Constant subroutine foo undefined at /,
+ 'constant undefinition warnings for lexical subs do not crash';
Index: trunk/contrib/perl/t/op/lfs.t
===================================================================
--- trunk/contrib/perl/t/op/lfs.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/lfs.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/lfs.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/list.t
===================================================================
--- trunk/contrib/perl/t/op/list.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/list.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -6,7 +6,7 @@
}
require "test.pl";
-plan( tests => 63 );
+plan( tests => 64 );
@foo = (1, 2, 3, 4);
cmp_ok($foo[0], '==', 1, 'first elem');
@@ -175,3 +175,10 @@
my @b = qw();
is($#b, -1);
}
+
+{
+ # comma operator with lvalue only propagates the lvalue context to
+ # the last operand.
+ ("const", my $x) ||= 1;
+ is( $x, 1 );
+}
Property changes on: trunk/contrib/perl/t/op/list.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/local.t
===================================================================
--- trunk/contrib/perl/t/op/local.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/local.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -5,11 +5,11 @@
@INC = qw(. ../lib);
require './test.pl';
}
-plan tests => 306;
+plan tests => 310;
my $list_assignment_supported = 1;
-#mg.c says list assignment not supported on VMS, EPOC, and SYMBIAN.
+#mg.c says list assignment not supported on VMS and SYMBIAN.
$list_assignment_supported = 0 if ($^O eq 'VMS');
@@ -618,8 +618,6 @@
"Chop" => sub { chop }, 0,
"Filetest" => sub { -x }, 0,
"Assignment" => sub { $_ = "Bad" }, 0,
- # XXX whether next one should fail is debatable
- "Local \$_" => sub { local $_ = 'ok?'; print }, 0,
"for local" => sub { for("#ok?\n"){ print } }, 1,
);
while ( ($name, $code, $ok) = splice(@tests, 0, 3) ) {
@@ -649,10 +647,10 @@
is($@, "");
{
- my $STORE = 0;
+ my $STORE = my $FETCH = 0;
package TieHash;
sub TIEHASH { bless $_[1], $_[0] }
- sub FETCH { 42 }
+ sub FETCH { ++$FETCH; 42 }
sub STORE { ++$STORE }
package main;
@@ -660,6 +658,7 @@
eval { for ($hash{key}) {local $_ = 2} };
is($STORE, 0);
+ is($FETCH, 0);
}
# The s/// adds 'g' magic to $_, but it should remain non-readonly
@@ -666,16 +665,6 @@
eval { for("a") { for $x (1,2) { local $_="b"; s/(.*)/+$1/ } } };
is($@, "");
-# RT #4342 Special local() behavior for $[
-{
- no warnings 'deprecated';
- local $[ = 1;
- ok(1 == $[, 'lexcical scope of local $[');
- f();
-}
-
-sub f { ok(0 == $[); }
-
# sub localisation
{
package Other;
@@ -792,11 +781,47 @@
'index(q(a), foo);' .
'local *g=${::}{foo};print q(ok);'), "ok", "[perl #52740]");
-# Keep this test last, as it can SEGV
+# related to perl #112966
+# Magic should not cause elements not to be deleted after scope unwinding
+# when they did not exist before local()
+() = \$#squinch; # $#foo in lvalue context makes array magical
{
+ local $squinch[0];
+ local @squinch[1..2];
+ package Flibbert;
+ m??; # makes stash magical
+ local $Flibbert::{foo};
+ local @Flibbert::{<bar baz>};
+}
+ok !exists $Flibbert::{foo},
+ 'local helem on magic hash does not leave elems on scope exit';
+ok !exists $Flibbert::{bar},
+ 'local hslice on magic hash does not leave elems on scope exit';
+ok !exists $squinch[0],
+ 'local aelem on magic hash does not leave elems on scope exit';
+ok !exists $squinch[1],
+ 'local aslice on magic hash does not leave elems on scope exit';
+
+# Keep these tests last, as they can SEGV
+{
local *@;
pass("Localised *@");
eval {1};
pass("Can eval with *@ localised");
+
+ local @{"nugguton"};
+ local %{"netgonch"};
+ delete $::{$_} for 'nugguton','netgonch';
}
+pass ('localised arrays and hashes do not crash if glob is deleted');
+# [perl #112966] Rmagic can cause delete local to crash
+package Grompits {
+local $SIG{__WARN__};
+ delete local $ISA[0];
+ delete local @ISA[1..10];
+ m??; # makes stash magical
+ delete local $Grompits::{foo};
+ delete local @Grompits::{<foo bar>};
+}
+pass 'rmagic does not cause delete local to crash on nonexistent elems';
Property changes on: trunk/contrib/perl/t/op/local.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/t/op/localref.t
===================================================================
--- trunk/contrib/perl/t/op/localref.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/localref.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/localref.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/op/lock.t (from rev 6437, vendor/perl/5.18.1/t/op/lock.t)
===================================================================
--- trunk/contrib/perl/t/op/lock.t (rev 0)
+++ trunk/contrib/perl/t/op/lock.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,16 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = qw(. ../lib);
+ require './test.pl';
+}
+plan tests => 5;
+
+is \lock $foo, \$foo, 'lock returns a scalar argument';
+is lock @foo, \@foo, 'lock returns a ref to its array argument';
+is lock %foo, \%foo, 'lock returns a ref to its hash argument';
+is lock &foo, \&foo, 'lock returns a ref to its code argument';
+
+sub eulavl : lvalue { $x }
+is lock &eulavl, \&eulavl, 'lock returns a ref to its lvalue sub arg';
Modified: trunk/contrib/perl/t/op/loopctl.t
===================================================================
--- trunk/contrib/perl/t/op/loopctl.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/loopctl.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -36,7 +36,7 @@
}
require "test.pl";
-plan( tests => 54 );
+plan( tests => 64 );
my $ok;
@@ -994,3 +994,113 @@
}
is($x_21469, 'X', "bug 21469: X okay at end of loop");
}
+
+# [perl #112316] Wrong behavior regarding labels with same prefix
+{
+ my $fail;
+ CATCH: {
+ CATCHLOOP: {
+ last CATCH;
+ }
+ $fail = 1;
+ }
+ ok(!$fail, "perl 112316: Labels with the same prefix don't get mixed up.");
+}
+
+# [perl #73618]
+{
+ sub foo_73618_0 {
+ while (0) { }
+ }
+ sub bar_73618_0 {
+ my $i = 0;
+ while ($i) { }
+ }
+ sub foo_73618_undef {
+ while (undef) { }
+ }
+ sub bar_73618_undef {
+ my $i = undef;
+ while ($i) { }
+ }
+ sub foo_73618_emptystring {
+ while ("") { }
+ }
+ sub bar_73618_emptystring {
+ my $i = "";
+ while ($i) { }
+ }
+ sub foo_73618_0float {
+ while (0.0) { }
+ }
+ sub bar_73618_0float {
+ my $i = 0.0;
+ while ($i) { }
+ }
+ sub foo_73618_0string {
+ while ("0") { }
+ }
+ sub bar_73618_0string {
+ my $i = "0";
+ while ($i) { }
+ }
+ sub foo_73618_until {
+ until (1) { }
+ }
+ sub bar_73618_until {
+ my $i = 1;
+ until ($i) { }
+ }
+
+ is(scalar(foo_73618_0()), scalar(bar_73618_0()),
+ "constant optimization doesn't change return value");
+ is(scalar(foo_73618_undef()), scalar(bar_73618_undef()),
+ "constant optimization doesn't change return value");
+ is(scalar(foo_73618_emptystring()), scalar(bar_73618_emptystring()),
+ "constant optimization doesn't change return value");
+ is(scalar(foo_73618_0float()), scalar(bar_73618_0float()),
+ "constant optimization doesn't change return value");
+ is(scalar(foo_73618_0string()), scalar(bar_73618_0string()),
+ "constant optimization doesn't change return value");
+ { local $TODO = "until is still wrongly optimized";
+ is(scalar(foo_73618_until()), scalar(bar_73618_until()),
+ "constant optimization doesn't change return value");
+ }
+}
+
+# [perl #113684]
+last_113684:
+{
+ label1:
+ {
+ my $label = "label1";
+ eval { last $label };
+ fail("last with non-constant label");
+ last last_113684;
+ }
+ pass("last with non-constant label");
+}
+next_113684:
+{
+ label2:
+ {
+ my $label = "label2";
+ eval { next $label };
+ fail("next with non-constant label");
+ next next_113684;
+ }
+ pass("next with non-constant label");
+}
+redo_113684:
+{
+ my $count;
+ label3:
+ {
+ if ($count++) {
+ pass("redo with non-constant label"); last redo_113684
+ }
+ my $label = "label3";
+ eval { redo $label };
+ fail("redo with non-constant label");
+ }
+}
Property changes on: trunk/contrib/perl/t/op/loopctl.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/lop.t
===================================================================
--- trunk/contrib/perl/t/op/lop.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/lop.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -7,11 +7,11 @@
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
+ require './test.pl';
}
-print "1..11\n";
+plan tests => 17;
-my $test = 0;
for my $i (undef, 0 .. 2, "", "0 but true") {
my $true = 1;
my $false = 0;
@@ -29,37 +29,30 @@
and (($i || !$j) != (!$i && $j))
);
}
- if (not $true) {
- print "not ";
- } elsif ($false) {
- print "not ";
- }
- print "ok ", ++$test, "\n";
+ my $m = ! defined $i ? 'undef'
+ : $i eq '' ? 'empty string'
+ : $i;
+ ok( $true, "true: $m");
+ ok( ! $false, "false: $m");
}
-# $test == 6
my $i = 0;
(($i ||= 1) &&= 3) += 4;
-print "not " unless $i == 7;
-print "ok ", ++$test, "\n";
+is( $i, 7, '||=, &&=');
my ($x, $y) = (1, 8);
$i = !$x || $y;
-print "not " unless $i == 8;
-print "ok ", ++$test, "\n";
+is( $i, 8, 'negation precedence with ||' );
++$y;
$i = !$x || !$x || !$x || $y;
-print "not " unless $i == 9;
-print "ok ", ++$test, "\n";
+is( $i, 9, 'negation precedence with ||, multiple operands' );
$x = 0;
++$y;
$i = !$x && $y;
-print "not " unless $i == 10;
-print "ok ", ++$test, "\n";
+is( $i, 10, 'negation precedence with &&' );
++$y;
$i = !$x && !$x && !$x && $y;
-print "not " unless $i == 11;
-print "ok ", ++$test, "\n";
+is( $i, 11, 'negation precedence with &&, multiple operands' );
Property changes on: trunk/contrib/perl/t/op/lop.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/t/op/magic-27839.t
===================================================================
--- trunk/contrib/perl/t/op/magic-27839.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/magic-27839.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/magic-27839.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/magic.t
===================================================================
--- trunk/contrib/perl/t/op/magic.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/magic.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -4,15 +4,50 @@
$| = 1;
chdir 't' if -d 't';
@INC = '../lib';
+ require './test.pl';
+ plan (tests => 179);
+}
+
+# Test that defined() returns true for magic variables created on the fly,
+# even before they have been created.
+# This must come first, even before turning on warnings or setting up
+# $SIG{__WARN__}, to avoid invalidating the tests. warnings.pm currently
+# does not mention any special variables, but that could easily change.
+BEGIN {
+ # not available in miniperl
+ my %non_mini = map { $_ => 1 } qw(+ - [);
+ for (qw(
+ SIG ^OPEN ^TAINT ^UNICODE ^UTF8LOCALE ^WARNING_BITS 1 2 3 4 5 6 7 8
+ 9 42 & ` ' : ? ! _ - [ ^ ~ = % . ( ) < > \ / $ | + ; ] ^A ^C ^D
+ ^E ^F ^H ^I ^L ^N ^O ^P ^S ^T ^V ^W ^UTF8CACHE ::12345 main::98732
+ ^LAST_FH
+ )) {
+ my $v = $_;
+ # avoid using any global vars here:
+ if ($v =~ s/^\^(?=.)//) {
+ for(substr $v, 0, 1) {
+ $_ = chr ord() - 64;
+ }
+ }
+ SKIP:
+ {
+ skip_if_miniperl("the module for *$_ may not be available in "
+ . "miniperl", 1) if $non_mini{$_};
+ ok defined *$v, "*$_ appears to be defined at the outset";
+ }
+ }
+}
+
+# This must be in a separate BEGIN block, as the mere mention of ${^TAINT}
+# will invalidate the test for it.
+BEGIN {
$ENV{PATH} = '/bin' if ${^TAINT};
$SIG{__WARN__} = sub { die "Dying on warning: ", @_ };
- require './test.pl';
}
use warnings;
use Config;
-plan (tests => 87);
$Is_MSWin32 = $^O eq 'MSWin32';
$Is_NetWare = $^O eq 'NetWare';
@@ -20,8 +55,6 @@
$Is_Dos = $^O eq 'dos';
$Is_os2 = $^O eq 'os2';
$Is_Cygwin = $^O eq 'cygwin';
-$Is_MPE = $^O eq 'mpeix';
-$Is_BeOS = $^O eq 'beos';
$PERL = $ENV{PERL}
|| ($Is_NetWare ? 'perl' :
@@ -29,9 +62,37 @@
$Is_MSWin32 ? '.\perl' :
'./perl');
+sub env_is {
+ my ($key, $val, $desc) = @_;
+
+ use open IN => ":raw";
+ if ($Is_MSWin32) {
+ # cmd.exe will echo 'variable=value' but 4nt will echo just the value
+ # -- Nikola Knezevic
+ require Win32;
+ my $cp = Win32::GetConsoleOutputCP();
+ Win32::SetConsoleOutputCP(Win32::GetACP());
+ (my $set = `set $key 2>nul`) =~ s/\r\n$/\n/;
+ Win32::SetConsoleOutputCP($cp);
+ like $set, qr/^(?:\Q$key\E=)?\Q$val\E$/, $desc;
+ } elsif ($Is_VMS) {
+ my $eqv = `write sys\$output f\$trnlnm("\Q$key\E")`;
+ # A single null byte in the equivalence string means
+ # an undef value for Perl, so mimic that here.
+ $eqv = "\n" if length($eqv) == 2 and $eqv eq "\000\n";
+ is $eqv, "$val\n", $desc;
+ } else {
+ is `echo \$\Q$key\E`, "$val\n", $desc;
+ }
+}
+
END {
# On VMS, environment variable changes are peristent after perl exits
- delete $ENV{'FOO'} if $Is_VMS;
+ if ($Is_VMS) {
+ delete $ENV{'FOO'};
+ delete $ENV{'__NoNeSuCh'};
+ delete $ENV{'__NoNeSuCh2'};
+ }
}
eval '$ENV{"FOO"} = "hi there";'; # check that ENV is inited inside eval
@@ -49,28 +110,34 @@
SKIP: {
skip('SIGINT not safe on this platform', 5)
- if $Is_MSWin32 || $Is_NetWare || $Is_Dos || $Is_MPE;
+ if $Is_MSWin32 || $Is_NetWare || $Is_Dos;
# the next tests are done in a subprocess because sh spits out a
# newline onto stderr when a child process kills itself with SIGINT.
# We use a pipe rather than system() because the VMS command buffer
# would overflow with a command that long.
+ # For easy interpolation of test numbers:
+ $next_test = curr_test() - 1;
+ sub TIEARRAY {bless[]}
+ sub FETCH { $next_test + pop }
+ tie my @tn, __PACKAGE__;
+
open( CMDPIPE, "| $PERL");
- print CMDPIPE <<'END';
+ print CMDPIPE "\$t1 = $tn[1]; \$t2 = $tn[2];\n", <<'END';
$| = 1; # command buffering
- $SIG{"INT"} = "ok3"; kill "INT",$$; sleep 1;
- $SIG{"INT"} = "IGNORE"; kill "INT",$$; sleep 1; print "ok 4\n";
- $SIG{"INT"} = "DEFAULT"; kill "INT",$$; sleep 1; print "not ok 4\n";
+ $SIG{"INT"} = "ok1"; kill "INT",$$; sleep 1;
+ $SIG{"INT"} = "IGNORE"; kill "INT",$$; sleep 1; print "ok $t2\n";
+ $SIG{"INT"} = "DEFAULT"; kill "INT",$$; sleep 1; print" not ok $t2\n";
- sub ok3 {
+ sub ok1 {
if (($x = pop(@_)) eq "INT") {
- print "ok 3\n";
+ print "ok $t1\n";
}
else {
- print "not ok 3 ($x @_)\n";
+ print "not ok $t1 ($x @_)\n";
}
}
@@ -79,7 +146,7 @@
close CMDPIPE;
open( CMDPIPE, "| $PERL");
- print CMDPIPE <<'END';
+ print CMDPIPE "\$t3 = $tn[3];\n", <<'END';
{ package X;
sub DESTROY {
@@ -91,7 +158,7 @@
return sub { $x };
}
$| = 1; # command buffering
- $SIG{"INT"} = "ok5";
+ $SIG{"INT"} = "ok3";
{
local $SIG{"INT"}=x();
print ""; # Needed to expose failure in 5.8.0 (why?)
@@ -99,14 +166,14 @@
sleep 1;
delete $SIG{"INT"};
kill "INT",$$; sleep 1;
- sub ok5 {
- print "ok 5\n";
+ sub ok3 {
+ print "ok $t3\n";
}
END
close CMDPIPE;
$? >>= 8 if $^O eq 'VMS'; # POSIX status hiding in 2nd byte
my $todo = ($^O eq 'os2' ? ' # TODO: EMX v0.9d_fix4 bug: wrong nibble? ' : '');
- print $? & 0xFF ? "ok 6$todo\n" : "not ok 6$todo\n";
+ print $? & 0xFF ? "ok $tn[4]$todo\n" : "not ok $tn[4]$todo\n";
open(CMDPIPE, "| $PERL");
print CMDPIPE <<'END';
@@ -122,7 +189,7 @@
END
close CMDPIPE;
$? >>= 8 if $^O eq 'VMS';
- print $? ? "not ok 7\n" : "ok 7\n";
+ print $? ? "not ok $tn[5]\n" : "ok $tn[5]\n";
curr_test(curr_test() + 5);
}
@@ -140,6 +207,14 @@
is $', 'baz';
is $+, 'a';
+# [perl #24237]
+for (qw < ` & ' >) {
+ fresh_perl_is
+ qq < \@$_; q "fff" =~ /(?!^)./; print "[\$$_]\\n" >,
+ "[f]\n", {},
+ "referencing \@$_ before \$$_ etc. still saws off ampersands";
+}
+
# $"
@a = qw(foo bar baz);
is "@a", "foo bar baz";
@@ -169,15 +244,33 @@
is $@, "foo\n";
cmp_ok($$, '>', 0);
-eval { $$++ };
-like ($@, qr/^Modification of a read-only value attempted/);
+my $pid = $$;
+eval { $$ = 42 };
+is $$, 42, '$$ can be modified';
+SKIP: {
+ skip "no fork", 1 unless $Config{d_fork};
+ (my $kidpid = open my $fh, "-|") // skip "cannot fork: $!", 1;
+ if($kidpid) { # parent
+ my $kiddollars = <$fh>;
+ close $fh or die "cannot close pipe from kid proc: $!";
+ is $kiddollars, $kidpid, '$$ is reset on fork';
+ }
+ else { # child
+ print $$;
+ $::NO_ENDING = 1; # silence "Looks like you only ran..."
+ exit;
+ }
+}
+$$ = $pid; # Tests below use $$
# $^X and $0
{
+ my $is_abs = $Config{d_procselfexe} || $Config{usekernprocpathname}
+ || $Config{usensgetexecutablepath};
if ($^O eq 'qnx') {
chomp($wd = `/usr/bin/fullpath -t`);
}
- elsif($Is_Cygwin || $Config{'d_procselfexe'}) {
+ elsif($Is_Cygwin || $is_abs) {
# Cygwin turns the symlink into the real file
chomp($wd = `pwd`);
$wd =~ s#/t$##;
@@ -192,7 +285,7 @@
else {
$wd = '.';
}
- my $perl = $Is_VMS || $Config{d_procselfexe} ? $^X : "$wd/perl";
+ my $perl = $Is_VMS || $is_abs ? $^X : "$wd/perl";
my $headmaybe = '';
my $middlemaybe = '';
my $tailmaybe = '';
@@ -227,7 +320,7 @@
$0 = Cygwin::win_to_posix_path(Cygwin::posix_to_win_path($0, 1));
EOX
}
- if ($^O eq 'os390' or $^O eq 'posix-bc' or $^O eq 'vmesa') { # no shebang
+ if ($^O eq 'os390' or $^O eq 'posix-bc') { # no shebang
$headmaybe = <<EOH ;
eval 'exec ./perl -S \$0 \${1+"\$\@"}'
if 0;
@@ -244,7 +337,6 @@
ok chmod(0755, $script) or diag $!;
$_ = $Is_VMS ? `$perl $script` : `$script`;
s/\.exe//i if $Is_Dos or $Is_Cygwin or $Is_os2;
- s{./$script}{$script} if $Is_BeOS; # revert BeOS execvp() side-effect
s{is perl}{is $perl}; # for systems where $^X is only a basename
s{\\}{/}g;
if ($Is_MSWin32 || $Is_os2) {
@@ -254,7 +346,6 @@
}
$_ = `$perl $script`;
s/\.exe//i if $Is_Dos or $Is_os2 or $Is_Cygwin;
- s{./$perl}{$perl} if $Is_BeOS; # revert BeOS execvp() side-effect
s{\\}{/}g;
if ($Is_MSWin32 || $Is_os2) {
is uc $_, uc $s1;
@@ -309,7 +400,7 @@
no warnings;
my $res = `$cmd`;
- skip "Couldn't shell out to `$cmd', returned code $?", 2 if $?;
+ skip "Couldn't shell out to '$cmd', returned code $?", 2 if $?;
return $res;
};
@@ -350,7 +441,7 @@
}
SKIP: {
- skip_if_miniperl("miniperl can't rely on loading %Errno", 1);
+ skip_if_miniperl("miniperl can't rely on loading %Errno", 2);
# Make sure that Errno loading doesn't clobber $!
undef %Errno::;
@@ -359,6 +450,14 @@
open(FOO, "nonesuch"); # Generate ENOENT
my %errs = %{"!"}; # Cause Errno.pm to be loaded at run-time
ok ${"!"}{ENOENT};
+
+ # Make sure defined(*{"!"}) before %! does not stop %! from working
+ is
+ runperl(
+ prog => 'BEGIN { defined *{q-!-} } print qq-ok\n- if tied %!',
+ ),
+ "ok\n",
+ 'defined *{"!"} does not stop %! from working';
}
# Check that we don't auto-load packages
@@ -419,7 +518,7 @@
}
# Test for bug [perl #36434]
-# Can not do this test on VMS, EPOC, and SYMBIAN according to comments
+# Can not do this test on VMS, and SYMBIAN according to comments
# in mg.c/Perl_magic_clear_all_env()
SKIP: {
skip('Can\'t make assignment to \%ENV on this system', 3) if $Is_VMS;
@@ -471,15 +570,73 @@
}
+# %+ %-
+SKIP: {
+ skip_if_miniperl("No XS in miniperl", 2);
+ # Make sure defined(*{"+"}) before %+ does not stop %+ from working
+ is
+ runperl(
+ prog => 'BEGIN { defined *{q-+-} } print qq-ok\n- if tied %+',
+ ),
+ "ok\n",
+ 'defined *{"+"} does not stop %+ from working';
+ is
+ runperl(
+ prog => 'BEGIN { defined *{q=-=} } print qq-ok\n- if tied %-',
+ ),
+ "ok\n",
+ 'defined *{"-"} does not stop %- from working';
+}
+
+SKIP: {
+ skip_if_miniperl("No XS in miniperl", 3);
+
+ for ( [qw( %- Tie::Hash::NamedCapture )], [qw( $[ arybase )],
+ [qw( %! Errno )] ) {
+ my ($var, $mod) = @$_;
+ my $modfile = $mod =~ s|::|/|gr . ".pm";
+ fresh_perl_is
+ qq 'sub UNIVERSAL::AUTOLOAD{}
+ $mod\::foo() if 0;
+ $var;
+ print "ok\\n" if \$INC{"$modfile"}',
+ "ok\n",
+ { switches => [ '-X' ] },
+ "$var still loads $mod when stash and UNIVERSAL::AUTOLOAD exist";
+ }
+}
+
+# ${^LAST_FH}
+() = tell STDOUT;
+is ${^LAST_FH}, \*STDOUT, '${^LAST_FH} after tell';
+() = tell STDIN;
+is ${^LAST_FH}, \*STDIN, '${^LAST_FH} after another tell';
+{
+ my $fh = *STDOUT;
+ () = tell $fh;
+ is ${^LAST_FH}, \$fh, '${^LAST_FH} referencing lexical coercible glob';
+}
+# This also tests that ${^LAST_FH} is a weak reference:
+is ${^LAST_FH}, undef, '${^LAST_FH} is undef when PL_last_in_gv is NULL';
+
+
+# $|
+fresh_perl_is 'print $| = ~$|', "1\n", {switches => ['-l']},
+ '[perl #4760] print $| = ~$|';
+fresh_perl_is
+ 'select f; undef *f; ${q/|/}; print STDOUT qq|ok\n|', "ok\n", {},
+ '[perl #115206] no crash when vivifying $| while *{+select}{IO} is undef';
+
+
# ^^^^^^^^^ New tests go here ^^^^^^^^^
SKIP: {
- skip("%ENV manipulations fail or aren't safe on $^O", 4)
- if $Is_VMS || $Is_Dos;
+ skip("%ENV manipulations fail or aren't safe on $^O", 19)
+ if $Is_Dos;
SKIP: {
- skip("clearing \%ENV is not safe when running under valgrind")
- if $ENV{PERL_VALGRIND};
+ skip("clearing \%ENV is not safe when running under valgrind or on VMS")
+ if $ENV{PERL_VALGRIND} || $Is_VMS;
$PATH = $ENV{PATH};
$PDL = $ENV{PERL_DESTRUCT_LEVEL} || 0;
@@ -494,15 +651,61 @@
}
}
- $ENV{__NoNeSuCh} = "foo";
- $0 = "bar";
-# cmd.exe will echo 'variable=value' but 4nt will echo just the value
-# -- Nikola Knezevic
- if ($Is_MSWin32) {
- like `set __NoNeSuCh`, qr/^(?:__NoNeSuCh=)?foo$/;
- } else {
- is `echo \$__NoNeSuCh`, "foo\n";
+ $ENV{__NoNeSuCh} = 'foo';
+ $0 = 'bar';
+ env_is(__NoNeSuCh => 'foo', 'setting $0 does not break %ENV');
+
+ $ENV{__NoNeSuCh2} = 'foo';
+ $ENV{__NoNeSuCh2} = undef;
+ env_is(__NoNeSuCh2 => '', 'setting a key as undef does not delete it');
+
+ # stringify a glob
+ $ENV{foo} = *TODO;
+ env_is(foo => '*main::TODO', 'ENV store of stringified glob');
+
+ # stringify a ref
+ my $ref = [];
+ $ENV{foo} = $ref;
+ env_is(foo => "$ref", 'ENV store of stringified ref');
+
+ # downgrade utf8 when possible
+ $bytes = "eh zero \x{A0}";
+ utf8::upgrade($chars = $bytes);
+ $forced = $ENV{foo} = $chars;
+ ok(!utf8::is_utf8($forced) && $forced eq $bytes, 'ENV store downgrades utf8 in SV');
+ env_is(foo => $bytes, 'ENV store downgrades utf8 in setenv');
+
+ # warn when downgrading utf8 is not possible
+ $chars = "X-Day \x{1998}";
+ utf8::encode($bytes = $chars);
+ {
+ my $warned = 0;
+ local $SIG{__WARN__} = sub { ++$warned if $_[0] =~ /^Wide character in setenv/; print "# @_" };
+ $forced = $ENV{foo} = $chars;
+ ok($warned == 1, 'ENV store warns about wide characters');
}
+ ok(!utf8::is_utf8($forced) && $forced eq $bytes, 'ENV store encodes high utf8 in SV');
+ env_is(foo => $bytes, 'ENV store encodes high utf8 in SV');
+
+ # test local $ENV{foo} on existing foo
+ {
+ local $ENV{__NoNeSuCh};
+ { local $TODO = 'exists on %ENV should reflect real env';
+ ok(!exists $ENV{__NoNeSuCh}, 'not exists $ENV{existing} during local $ENV{existing}'); }
+ env_is(__NoNeLoCaL => '');
+ }
+ ok(exists $ENV{__NoNeSuCh}, 'exists $ENV{existing} after local $ENV{existing}');
+ env_is(__NoNeSuCh => 'foo');
+
+ # test local $ENV{foo} on new foo
+ {
+ local $ENV{__NoNeLoCaL} = 'foo';
+ ok(exists $ENV{__NoNeLoCaL}, 'exists $ENV{new} during local $ENV{new}');
+ env_is(__NoNeLoCaL => 'foo');
+ }
+ ok(!exists $ENV{__NoNeLoCaL}, 'not exists $ENV{new} after local $ENV{new}');
+ env_is(__NoNeLoCaL => '');
+
SKIP: {
skip("\$0 check only on Linux and FreeBSD", 2)
unless $^O =~ /^(linux|freebsd)$/
Property changes on: trunk/contrib/perl/t/op/magic.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/t/op/magic_phase.t
===================================================================
--- trunk/contrib/perl/t/op/magic_phase.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/magic_phase.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/magic_phase.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/method.t
===================================================================
--- trunk/contrib/perl/t/op/method.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/method.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -6,7 +6,7 @@
BEGIN {
chdir 't' if -d 't';
- @INC = qw(. ../lib);
+ @INC = qw(. ../lib lib);
require "test.pl";
}
@@ -13,7 +13,7 @@
use strict;
no warnings 'once';
-plan(tests => 79);
+plan(tests => 141);
@A::ISA = 'B';
@B::ISA = 'C';
@@ -80,11 +80,16 @@
is(A->d, "B::d2"); # Update hash table;
# What follows is hardly guarantied to work, since the names in scripts
-# are already linked to "pruned" globs. Say, `undef &B::d' if it were
-# after `delete $B::{d}; sub B::d {}' would reach an old subroutine.
+# are already linked to "pruned" globs. Say, 'undef &B::d' if it were
+# after 'delete $B::{d}; sub B::d {}' would reach an old subroutine.
undef &B::d;
delete $B::{d};
+is(A->d, "C::d");
+
+eval 'sub B::d {"B::d2.5"}';
+A->d; # Update hash table;
+my $glob = \delete $B::{d}; # non-void context; hang on to the glob
is(A->d, "C::d"); # Update hash table;
eval 'sub B::d {"B::d3"}'; # Import now.
@@ -167,7 +172,10 @@
{
no strict 'refs';
+ no warnings 'deprecated';
# this test added due to bug discovery (in 5.004_04, fb73857aa0bfa8ed)
+ # Possibly kill this test now that defined @::array is finally properly
+ # deprecated?
is(defined(@{"unknown_package::ISA"}) ? "defined" : "undefined", "undefined");
}
@@ -215,7 +223,50 @@
eval '$e = bless {}, "UNIVERSAL"; $e->E::F::foo()';
like ($@, qr/^\QCan't locate object method "foo" via package "E::F" at/);
-# TODO: we need some tests for the SUPER:: pseudoclass
+# SUPER:: pseudoclass
+ at Saab::ISA = "Souper";
+sub Souper::method { @_ }
+ at OtherSaab::ISA = "OtherSouper";
+sub OtherSouper::method { "Isidore Ropen, Draft Manager" }
+{
+ my $o = bless [], "Saab";
+ package Saab;
+ my @ret = $o->SUPER::method('whatever');
+ ::is $ret[0], $o, 'object passed to SUPER::method';
+ ::is $ret[1], 'whatever', 'argument passed to SUPER::method';
+ @ret = $o->SUPER'method('whatever');
+ ::is $ret[0], $o, "object passed to SUPER'method";
+ ::is $ret[1], 'whatever', "argument passed to SUPER'method";
+ @ret = Saab->SUPER::method;
+ ::is $ret[0], 'Saab', "package name passed to SUPER::method";
+ @ret = OtherSaab->SUPER::method;
+ ::is $ret[0], 'OtherSaab',
+ "->SUPER::method uses current package, not invocant";
+}
+() = *SUPER::;
+{
+ local our @ISA = "Souper";
+ is eval { (main->SUPER::method)[0] }, 'main',
+ 'Mentioning *SUPER:: does not stop ->SUPER from working in main';
+}
+{
+ BEGIN {
+ *Mover:: = *Mover2::;
+ *Mover2:: = *foo;
+ }
+ package Mover;
+ no strict;
+ # Not our(@ISA), because the bug we are testing for interacts with an
+ # our() bug that cancels this bug out.
+ @ISA = 'door';
+ sub door::dohtem { 'dohtem' }
+ ::is eval { Mover->SUPER::dohtem; }, 'dohtem',
+ 'SUPER inside moved package';
+ undef *door::dohtem;
+ *door::dohtem = sub { 'method' };
+ ::is eval { Mover->SUPER::dohtem; }, 'method',
+ 'SUPER inside moved package respects method changes';
+}
# failed method call or UNIVERSAL::can() should not autovivify packages
is( $::{"Foo::"} || "none", "none"); # sanity check 1
@@ -319,3 +370,254 @@
);
}
+# Test for calling a method on a packag name return by a magic variable
+sub TIESCALAR{bless[]}
+sub FETCH{"main"}
+my $kalled;
+sub bolgy { ++$kalled; }
+tie my $a, "";
+$a->bolgy;
+is $kalled, 1, 'calling a class method via a magic variable';
+
+{
+ package NulTest;
+ sub method { 1 }
+
+ package main;
+ eval {
+ NulTest->${ \"method\0Whoops" };
+ };
+ like $@, qr/Can't locate object method "method\0Whoops" via package "NulTest" at/,
+ "method lookup is nul-clean";
+
+ *NulTest::AUTOLOAD = sub { our $AUTOLOAD; return $AUTOLOAD };
+
+ like(NulTest->${ \"nul\0test" }, "nul\0test", "AUTOLOAD is nul-clean");
+}
+
+
+{
+ fresh_perl_is(
+ q! sub T::DESTROY { $x = $_[0]; } bless [], "T";!,
+ "DESTROY created new reference to dead object 'T' during global destruction.",
+ {},
+ "DESTROY creating a new reference to the object generates a warning."
+ );
+}
+
+# [perl #43663]
+{
+ $::{"Just"} = \1;
+ sub Just::a_japh { return "$_[0] another Perl hacker," }
+ is eval { "Just"->a_japh }, "Just another Perl hacker,",
+ 'constants do not interfere with class methods';
+}
+
+# [perl #109264]
+{
+ no strict 'vars';
+ sub bliggles { 1 }
+ sub lbiggles :lvalue { index "foo", "f" }
+ ok eval { main->bliggles(my($foo,$bar)) },
+ 'foo->bar(my($foo,$bar)) is not called in lvalue context';
+ ok eval { main->bliggles(our($foo,$bar)) },
+ 'foo->bar(our($foo,$bar)) is not called in lvalue context';
+ ok eval { main->bliggles(local($foo,$bar)) },
+ 'foo->bar(local($foo,$bar)) is not called in lvalue context';
+ ok eval { () = main->lbiggles(my($foo,$bar)); 1 },
+ 'foo->lv(my($foo,$bar)) is not called in lvalue context';
+ ok eval { () = main->lbiggles(our($foo,$bar)); 1 },
+ 'foo->lv(our($foo,$bar)) is not called in lvalue context';
+ ok eval { () = main->lbiggles(local($foo,$bar)); 1 },
+ 'foo->lv(local($foo,$bar)) is not called in lvalue context';
+}
+
+{
+ # AUTOLOAD and DESTROY can be declared without a leading sub,
+ # like BEGIN and friends.
+ package NoSub;
+
+ eval 'AUTOLOAD { our $AUTOLOAD; return $AUTOLOAD }';
+ ::ok( !$@, "AUTOLOAD without a leading sub is legal" );
+
+ eval "DESTROY { ::pass( q!DESTROY without a leading sub is legal and gets called! ) }";
+ {
+ ::ok( NoSub->can("AUTOLOAD"), "...and sets up an AUTOLOAD normally" );
+ ::is( eval { NoSub->bluh }, "NoSub::bluh", "...which works as expected" );
+ }
+ { bless {}, "NoSub"; }
+}
+
+eval { () = 3; new {} };
+like $@,
+ qr/^Can't call method "new" without a package or object reference/,
+ 'Err msg from new{} when stack contains a number';
+eval { () = "foo"; new {} };
+like $@,
+ qr/^Can't call method "new" without a package or object reference/,
+ 'Err msg from new{} when stack contains a word';
+eval { () = undef; new {} };
+like $@,
+ qr/^Can't call method "new" without a package or object reference/,
+ 'Err msg from new{} when stack contains undef';
+
+package egakacp {
+ our @ISA = 'ASI';
+ sub ASI::m { shift; "@_" };
+ my @a = (bless([]), 'arg');
+ my $r = SUPER::m{@a};
+ ::is $r, 'arg', 'method{@array}';
+ $r = SUPER::m{}@a;
+ ::is $r, 'arg', 'method{}@array';
+ $r = SUPER::m{@a}"b";
+ ::is $r, 'arg b', 'method{@array}$more_args';
+}
+
+# [perl #114924] SUPER->method
+ at SUPER::ISA = "SUPPER";
+sub SUPPER::foo { "supper" }
+is "SUPER"->foo, 'supper', 'SUPER->method';
+
+sub flomp { "flimp" }
+sub main::::flomp { "flump" }
+is "::"->flomp, 'flump', 'method call on ::';
+is "::main"->flomp, 'flimp', 'method call on ::main';
+eval { ""->flomp };
+like $@,
+ qr/^Can't call method "flomp" without a package or object reference/,
+ 'method call on empty string';
+is "3foo"->CORE::uc, '3FOO', '"3foo"->CORE::uc';
+{ no strict; @{"3foo::ISA"} = "CORE"; }
+is "3foo"->uc, '3FOO', '"3foo"->uc (autobox style!)';
+
+# Test that PL_stashcache doesn't change the resolution behaviour for file
+# handles and package names.
+SKIP: {
+ skip_if_miniperl('file handles as methods requires loading IO::File', 25);
+ require Fcntl;
+
+ foreach (qw (Count::DATA Count Colour::H1 Color::H1 C3::H1)) {
+ eval qq{
+ package $_;
+
+ sub getline {
+ return "method in $_";
+ }
+
+ 1;
+ } or die $@;
+ }
+
+ BEGIN {
+ *The::Count:: = \*Count::;
+ }
+
+ is(Count::DATA->getline(), 'method in Count::DATA',
+ 'initial resolution is a method');
+ is(The::Count::DATA->getline(), 'method in Count::DATA',
+ 'initial resolution is a method in aliased classes');
+
+ require Count;
+
+ is(Count::DATA->getline(), "one! ha ha ha\n", 'file handles take priority');
+ is(The::Count::DATA->getline(), "two! ha ha ha\n",
+ 'file handles take priority in aliased classes');
+
+ eval q{close Count::DATA} or die $!;
+
+ {
+ no warnings 'io';
+ is(Count::DATA->getline(), undef,
+ "closing a file handle doesn't change object resolution");
+ is(The::Count::DATA->getline(), undef,
+ "closing a file handle doesn't change object resolution in aliased classes");
+}
+
+ undef *Count::DATA;
+ is(Count::DATA->getline(), 'method in Count::DATA',
+ 'undefining the typeglob does change object resolution');
+ is(The::Count::DATA->getline(), 'method in Count::DATA',
+ 'undefining the typeglob does change object resolution in aliased classes');
+
+ is(Count->getline(), 'method in Count',
+ 'initial resolution is a method');
+ is(The::Count->getline(), 'method in Count',
+ 'initial resolution is a method in aliased classes');
+
+ eval q{
+ open Count, '<', $INC{'Count.pm'}
+ or die "Can't open $INC{'Count.pm'}: $!";
+1;
+ } or die $@;
+
+ is(Count->getline(), "# zero! ha ha ha\n", 'file handles take priority');
+ is(The::Count->getline(), 'method in Count', 'but not in an aliased class');
+
+ eval q{close Count} or die $!;
+
+ {
+ no warnings 'io';
+ is(Count->getline(), undef,
+ "closing a file handle doesn't change object resolution");
+ }
+
+ undef *Count;
+ is(Count->getline(), 'method in Count',
+ 'undefining the typeglob does change object resolution');
+
+ open Colour::H1, 'op/method.t' or die $!;
+ while (<Colour::H1>) {
+ last if /^__END__/;
+ }
+ open CLOSED, 'TEST' or die $!;
+ close CLOSED or die $!;
+
+ my $fh_start = tell Colour::H1;
+ my $data_start = tell DATA;
+ is(Colour::H1->getline(), <DATA>, 'read from a file');
+ is(Color::H1->getline(), 'method in Color::H1',
+ 'initial resolution is a method');
+
+ *Color::H1 = *Colour::H1{IO};
+
+ is(Colour::H1->getline(), <DATA>, 'read from a file');
+ is(Color::H1->getline(), <DATA>,
+ 'file handles take priority after typeglob assignment');
+
+ *Color::H1 = *CLOSED{IO};
+ {
+ no warnings 'io';
+ is(Color::H1->getline(), undef,
+ "assigning a closed a file handle doesn't change object resolution");
+ }
+
+ undef *Color::H1;
+ is(Color::H1->getline(), 'method in Color::H1',
+ 'undefining the typeglob does change object resolution');
+
+ seek Colour::H1, $fh_start, Fcntl::SEEK_SET() or die $!;
+ seek DATA, $data_start, Fcntl::SEEK_SET() or die $!;
+
+ is(Colour::H1->getline(), <DATA>, 'read from a file');
+ is(C3::H1->getline(), 'method in C3::H1', 'intial resolution is a method');
+
+ *Copy:: = \*C3::;
+ *C3:: = \*Colour::;
+
+ is(Colour::H1->getline(), <DATA>, 'read from a file');
+ is(C3::H1->getline(), <DATA>,
+ 'file handles take priority after stash aliasing');
+
+ *C3:: = \*Copy::;
+
+ is(C3::H1->getline(), 'method in C3::H1',
+ 'restoring the stash returns to a method');
+}
+
+__END__
+#FF9900
+#F78C08
+#FFA500
+#FF4D00
+#FC5100
+#FF5D00
Property changes on: trunk/contrib/perl/t/op/method.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/mkdir.t
===================================================================
--- trunk/contrib/perl/t/op/mkdir.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/mkdir.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -48,6 +48,7 @@
$_ = 'lfrulb';
{
+ no warnings 'experimental::lexical_topic';
my $_ = 'blurfl';
ok(mkdir);
ok(-d);
Property changes on: trunk/contrib/perl/t/op/mkdir.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/my.t
===================================================================
--- trunk/contrib/perl/t/op/my.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/my.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,7 +1,10 @@
#!./perl
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require './test.pl';
+}
-print "1..36\n";
-
sub foo {
my($a, $b) = @_;
my $c;
@@ -10,8 +13,10 @@
$d = "ok 4\n";
{ my($a, undef, $c) = ("ok 9\n", "not ok 10\n", "ok 10\n");
($x, $y) = ($a, $c); }
- print $a, $b;
- $c . $d;
+ is($a, "ok 1\n", 'value of sub argument maintained outside of block');
+ is($b, "ok 2\n", 'sub argument maintained');
+ is($c, "ok 3\n", 'variable value maintained outside of block');
+ is($d, "ok 4\n", 'variable value maintained');
}
$a = "ok 5\n";
@@ -19,9 +24,14 @@
$c = "ok 7\n";
$d = "ok 8\n";
-print &foo("ok 1\n","ok 2\n");
+&foo("ok 1\n","ok 2\n");
-print $a,$b,$c,$d,$x,$y;
+is($a, "ok 5\n", 'global was not affected by duplicate names inside subroutine');
+is($b, "ok 6\n", '...');
+is($c, "ok 7\n", '...');
+is($d, "ok 8\n", '...');
+is($x, "ok 9\n", 'globals modified inside of block keeps its value outside of block');
+is($y, "ok 10\n", '...');
# same thing, only with arrays and associative arrays
@@ -30,9 +40,13 @@
my(@c, %d);
@c = "ok 13\n";
$d{''} = "ok 14\n";
- { my($a, at c) = ("ok 19\n", "ok 20\n"); ($x, $y) = ($a, @c); }
- print $a, @b;
- $c[0] . $d{''};
+ { my($a, at c) = ("ok 19\n", "ok 20\n", "ok 21\n"); ($x, $y) = ($a, @c); }
+ is($a, "ok 11\n", 'value of sub argument maintained outside of block');
+ is(scalar @b, 1, 'did not add any elements to @b');
+ is($b[0], "ok 12\n", 'did not alter @b');
+ is(scalar @c, 1, 'did not add arguments to @c');
+ is($c[0], "ok 13\n", 'did not alter @c');
+ is($d{''}, "ok 14\n", 'did not touch %d');
}
$a = "ok 15\n";
@@ -40,62 +54,67 @@
@c = "ok 17\n";
$d{''} = "ok 18\n";
-print &foo2("ok 11\n","ok 12\n");
+&foo2("ok 11\n", "ok 12\n");
-print $a, at b, at c,%d,$x,$y;
+is($a, "ok 15\n", 'Global was not modifed out of scope');
+is(scalar @b, 1, 'correct number of elements in array');
+is($b[0], "ok 16\n", 'array value was not modified out of scope');
+is(scalar @c, 1, 'correct number of elements in array');
+is($c[0], "ok 17\n", 'array value was not modified out of scope');
+is($d{''}, "ok 18\n", 'hash key/value pair is correct');
+is($x, "ok 19\n", 'global was modified');
+is($y, "ok 20\n", 'this one too');
my $i = "outer";
if (my $i = "inner") {
- print "not " if $i ne "inner";
+ is( $i, 'inner', 'my variable inside conditional propagates inside block');
}
-print "ok 21\n";
if ((my $i = 1) == 0) {
- print "not ";
+ fail("nested parens do not propagate variable outside");
}
else {
- print "not" if $i != 1;
+ is($i, 1, 'lexical variable lives available inside else block');
}
-print "ok 22\n";
my $j = 5;
while (my $i = --$j) {
- print("not "), last unless $i > 0;
+ last unless is( $i, $j, 'lexical inside while block');
}
continue {
- print("not "), last unless $i > 0;
+ last unless is( $i, $j, 'lexical inside continue block');
}
-print "ok 23\n";
+is( $j, 0, 'went through the previous while/continue loop all 4 times' );
$j = 5;
for (my $i = 0; (my $k = $i) < $j; ++$i) {
- print("not "), last unless $i >= 0 && $i < $j && $i == $k;
+ fail(""), last unless $i >= 0 && $i < $j && $i == $k;
}
-print "ok 24\n";
-print "not " if defined $k;
-print "ok 25\n";
+ok( ! defined $k, '$k is only defined in the scope of the previous for loop' );
-foreach my $i (26, 27) {
- print "ok $i\n";
+curr_test(37);
+$jj = 0;
+foreach my $i (30, 31) {
+ is( $i, $jj+30, 'assignment inside the foreach loop variable definition');
+ $jj++;
}
+is( $jj, 2, 'foreach loop executed twice');
-print "not " if $i ne "outer";
-print "ok 28\n";
+is( $i, 'outer', '$i not modified by while/for/foreach using same variable name');
# Ensure that C<my @y> (without parens) doesn't force scalar context.
my @x;
{ @x = my @y }
-print +(@x ? "not " : ""), "ok 29\n";
+is(scalar @x, 0, 'my @y without parens does not force scalar context');
{ @x = my %y }
-print +(@x ? "not " : ""), "ok 30\n";
+is(scalar @x, 0, 'my %y without parens does not force scalar context');
# Found in HTML::FormatPS
-my %fonts = qw(nok 31);
+my %fonts = qw(nok 35);
for my $full (keys %fonts) {
$full =~ s/^n//;
- # Supposed to be copy-on-write via force_normal after a THINKFIRST check.
- print "$full $fonts{nok}\n";
+ is( $fonts{nok}, 35, 'Supposed to be copy-on-write via force_normal after a THINKFIRST check.' );
}
# [perl #29340] optimising away the = () left the padav returning the
@@ -104,21 +123,17 @@
sub opta { my @a=() }
sub opth { my %h=() }
eval { my $x = opta };
-print "not " if $@;
-print "ok 32\n";
+is($@, '', ' perl #29340, No bizarre copy of array error');
eval { my $x = opth };
-print "not " if $@;
-print "ok 33\n";
+is($@, '', ' perl #29340, No bizarre copy of array error via hash');
-
sub foo3 {
++my $x->{foo};
- print "not " if defined $x->{bar};
+ ok(! defined $x->{bar}, '$x->{bar} is not defined');
++$x->{bar};
}
eval { foo3(); foo3(); };
-print "not " if $@;
-print "ok 34\n";
+is( $@, '', 'no errors while checking autovivification and persistence of hash refs inside subs' );
# my $foo = undef should always assign [perl #37776]
{
@@ -125,8 +140,14 @@
my $count = 35;
loop:
my $test = undef;
- print "not " if defined $test;
- print "ok $count\n";
+ is($test, undef, 'var is undef, repeated test');
$test = 42;
goto loop if ++$count < 37;
}
+
+# [perl #113554]
+eval "my ()";
+is( $@, '', "eval of my() passes");
+
+#Variable number of tests due to the way the while/for loops are tested now
+done_testing();
Property changes on: trunk/contrib/perl/t/op/my.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/op/my_stash.t
===================================================================
--- trunk/contrib/perl/t/op/my_stash.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/my_stash.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/my_stash.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/mydef.t
===================================================================
--- trunk/contrib/perl/t/op/mydef.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/mydef.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -7,7 +7,7 @@
}
use strict;
-no warnings 'misc';
+no warnings 'misc', 'experimental::lexical_topic';
$_ = 'global';
is($_, 'global', '$_ initial value');
Property changes on: trunk/contrib/perl/t/op/mydef.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/negate.t
===================================================================
--- trunk/contrib/perl/t/op/negate.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/negate.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -6,7 +6,7 @@
require './test.pl';
}
-plan tests => 16;
+plan tests => 45;
# Some of these will cause warnings if left on. Here we're checking the
# functionality, not the warnings.
@@ -19,7 +19,11 @@
is(-"10.0", -10, "Negation of a positive decimal sting to negative");
is(-"10foo", -10, "Negation of a numeric-lead string returns negation of numeric");
is(-"-10", 10, 'Negation of string starting with "-" returns a positive number - integer');
+"-10" =~ /(.*)/;
+is(-$1, 10, 'Negation of magical string starting with "-" - integer');
is(-"-10.0", 10.0, 'Negation of string starting with "-" returns a positive number - decimal');
+"-10.0" =~ /(.*)/;
+is(-$1, 10.0, 'Negation of magical string starting with "-" - decimal');
is(-"-10foo", "+10foo", 'Negation of string starting with "-" returns a string starting with "+" - non-numeric');
is(-"xyz", "-xyz", 'Negation of a negative string adds "-" to the front');
is(-"-xyz", "+xyz", "Negation of a negative string to positive");
@@ -28,4 +32,73 @@
is(- -bareword, "+bareword", "Negation of -bareword returns string +bareword");
is(-" -10", 10, "Negation of a whitespace-lead numeric string");
is(-" -10.0", 10, "Negation of a whitespace-lead decimal string");
-is(-" -10foo", 10, "Negation of a whitespace-lead sting starting with a numeric")
+is(-" -10foo", 10,
+ "Negation of a whitespace-lead sting starting with a numeric");
+
+$x = "dogs";
+()=0+$x;
+is -$x, '-dogs', 'cached numeric value does not sabotage string negation';
+
+is(-"97656250000000000", -97656250000000000, '-bigint vs -"bigint"');
+"9765625000000000" =~ /(\d+)/;
+is -$1, -"$1", '-$1 vs -"$1" with big int';
+
+$a = "%apples";
+chop($au = "%apples\x{100}");
+is(-$au, -$a, 'utf8 flag makes no difference for string negation');
+is -"\x{100}", 0, '-(non-ASCII) is equivalent to -(punct)';
+
+sub TIESCALAR { bless[] }
+sub STORE { $_[0][0] = $_[1] }
+sub FETCH { $_[0][0] }
+
+tie $t, "";
+$a = "97656250000000000";
+() = 0+$a;
+$t = $a;
+is -$t, -97656250000000000, 'magic str+int dualvar';
+
+{ # Repeat most of the tests under use integer
+ use integer;
+ is(- 10, -10, "Simple numeric negation to negative");
+ is(- -10, 10, "Simple numeric negation to positive");
+ is(-"10", -10, "Negation of a positive string to negative");
+ is(-"10.0", -10, "Negation of a positive decimal sting to negative");
+ is(-"10foo", -10,
+ "Negation of a numeric-lead string returns negation of numeric");
+ is(-"-10", 10,
+ 'Negation of string starting with "-" returns a positive number -'
+ .' integer');
+ "-10" =~ /(.*)/;
+ is(-$1, 10, 'Negation of magical string starting with "-" - integer');
+ is(-"-10.0", 10,
+ 'Negation of string starting with "-" returns a positive number - '
+ .'decimal');
+ "-10.0" =~ /(.*)/;
+ is(-$1, 10, 'Negation of magical string starting with "-" - decimal');
+ is(-"-10foo", "+10foo",
+ 'Negation of string starting with "-" returns a string starting '
+ .'with "+" - non-numeric');
+ is(-"xyz", "-xyz",
+ 'Negation of a negative string adds "-" to the front');
+ is(-"-xyz", "+xyz", "Negation of a negative string to positive");
+ is(-"+xyz", "-xyz", "Negation of a positive string to negative");
+ is(-bareword, "-bareword",
+ "Negation of bareword treated like a string");
+ is(- -bareword, "+bareword",
+ "Negation of -bareword returns string +bareword");
+ is(-" -10", 10, "Negation of a whitespace-lead numeric string");
+ is(-" -10.0", 10, "Negation of a whitespace-lead decimal string");
+ is(-" -10foo", 10,
+ "Negation of a whitespace-lead sting starting with a numeric");
+
+ $x = "dogs";
+ ()=0+$x;
+ is -$x, '-dogs',
+ 'cached numeric value does not sabotage string negation';
+
+ $a = "%apples";
+ chop($au = "%apples\x{100}");
+ is(-$au, -$a, 'utf8 flag makes no difference for string negation');
+ is -"\x{100}", 0, '-(non-ASCII) is equivalent to -(punct)';
+}
Property changes on: trunk/contrib/perl/t/op/negate.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/not.t
===================================================================
--- trunk/contrib/perl/t/op/not.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/not.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -6,17 +6,22 @@
require './test.pl';
}
-plan tests => 16;
+plan tests => 19;
# not() tests
-pass() if not();
-is(not(), 1);
-is(not(), not(0));
+pass("logical negation of empty list") if not();
+is(not(), 1, "logical negation of empty list in numeric comparison");
+is(not(), not(0),
+ "logical negation of empty list compared with logical negation of false value");
# test not(..) and !
-is(! 1, not 1);
-is(! 0, not 0);
-is(! (0, 0), not(0, 0));
+note("parens needed around second argument in next two tests\nto preserve list context inside function call");
+is(! 1, (not 1),
+ "high- and low-precedence logical negation of true value");
+is(! 0, (not 0),
+ "high- and low-precedence logical negation of false value");
+is(! (0, 0), not(0, 0),
+ "high- and low-precedence logical negation of lists");
# test the return of !
{
@@ -24,13 +29,18 @@
my $not1 = ! 1;
no warnings;
- ok($not1 == undef);
- ok($not1 == ());
+ ok($not1 == undef,
+ "logical negation (high-precedence) of true value is numerically equal to undefined value");
+ ok($not1 == (),
+ "logical negation (high-precedence) of true value is numerically equal to empty list");
use warnings;
- ok($not1 eq '');
- ok($not1 == 0);
- ok($not0 == 1);
+ ok($not1 eq '',
+ "logical negation (high-precedence) of true value in string context is equal to empty string");
+ ok($not1 == 0,
+ "logical negation (high-precedence) of true value is false in numeric context");
+ ok($not0 == 1,
+ "logical negation (high-precedence) of false value is true in numeric context");
}
# test the return of not
@@ -39,11 +49,30 @@
my $not1 = not 1;
no warnings;
- ok($not1 == undef);
- ok($not1 == ());
+ ok($not1 == undef,
+ "logical negation (low-precedence) of true value is numerically equal to undefined value");
+ ok($not1 == (),
+ "logical negation (low-precedence) of true value is numerically equal to empty list");
use warnings;
- ok($not1 eq '');
- ok($not1 == 0);
- ok($not0 == 1);
+ ok($not1 eq '',
+ "logical negation (low-precedence) of true value in string context is equal to empty string");
+ ok($not1 == 0,
+ "logical negation (low-precedence) of true value is false in numeric context");
+ ok($not0 == 1,
+ "logical negation (low-precedence) of false value is true in numeric context");
}
+
+# test truth of dualvars
+SKIP:
+{
+ my $got_dualvar;
+ eval 'use Scalar::Util "dualvar"; $got_dualvar++';
+ skip "No Scalar::Util::dualvar", 3 unless $got_dualvar;
+ my $a = Scalar::Util::dualvar(3, "");
+ is not($a), 1, 'not(dualvar) ignores int when string is false';
+ my $b = Scalar::Util::dualvar(3.3,"");
+ is not($b), 1, 'not(dualvar) ignores float when string is false';
+ my $c = Scalar::Util::dualvar(0,"1");
+ is not($c), "", 'not(dualvar) ignores false int when string is true';
+}
Property changes on: trunk/contrib/perl/t/op/not.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/op/numconvert.t
===================================================================
--- trunk/contrib/perl/t/op/numconvert.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/numconvert.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/numconvert.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/oct.t
===================================================================
--- trunk/contrib/perl/t/op/oct.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/oct.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,6 +1,6 @@
#!./perl
-# tests 51 onwards aren't all warnings clean. (intentionally)
+# Tests 51 onwards are intentionally not all-warnings-clean
require './test.pl';
use strict;
@@ -105,33 +105,37 @@
$_ = "\0_7_7";
-is(length, 5);
-is($_, "\0"."_"."7"."_"."7");
+is(length, 5,
+ "length() correctly calculated string with nul character in octal");
+is($_, "\0"."_"."7"."_"."7", "string concatenation with nul character");
chop, chop, chop, chop;
-is($_, "\0");
+is($_, "\0", "repeated chop() eliminated all but nul character");
if (ord("\t") != 9) {
- # question mark is 111 in 1047, 037, && POSIX-BC
- is("\157_", "?_");
+ is("\157_", "?_",
+ "question mark is 111 in 1047, 037, && POSIX-BC");
}
else {
- is("\077_", "?_");
+ is("\077_", "?_",
+ "question mark is 077 in other than 1047, 037, && POSIX-BC");
}
$_ = "\x_7_7";
-is(length, 5);
-is($_, "\0"."_"."7"."_"."7");
+is(length, 5,
+ "length() correctly calculated string with nul character in hex");
+is($_, "\0"."_"."7"."_"."7", "string concatenation with nul character");
chop, chop, chop, chop;
-is($_, "\0");
+is($_, "\0", "repeated chop() eliminated all but nul character");
if (ord("\t") != 9) {
- # / is 97 in 1047, 037, && POSIX-BC
- is("\x61_", "/_");
+ is("\x61_", "/_",
+ "/ is 97 in 1047, 037, && POSIX-BC");
}
else {
- is("\x2F_", "/_");
+ is("\x2F_", "/_",
+ "/ is 79 in other than 1047, 037, && POSIX-BC");
}
eval '$a = oct "10\x{100}"';
-like($@, qr/Wide character/);
+like($@, qr/Wide character/, "wide character - oct");
eval '$a = hex "ab\x{100}"';
-like($@, qr/Wide character/);
+like($@, qr/Wide character/, "wide character - hex");
Property changes on: trunk/contrib/perl/t/op/oct.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/or.t
===================================================================
--- trunk/contrib/perl/t/op/or.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/or.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -37,20 +37,20 @@
$c = $a || $b;
-is($c, $a_str);
-is($c+0, $a_num); # force numeric context.
+is($c, $a_str, "comparison of string equality");
+is($c+0, $a_num, "comparison of numeric equality"); # force numeric context.
$a =~ /./g or die "Match failed for some reason"; # Make $a magic
$c = $a || $b;
-is($c, $a_str);
-is($c+0, $a_num); # force numeric context.
+is($c, $a_str, "comparison of string equality");
+is($c+0, $a_num, "comparison of numeric equality"); # force numeric context.
my $val = 3;
$c = $val || $b;
-is($c, 3);
+is($c, 3, "|| short-circuited as expected");
tie $a, 'Countdown', $val;
Property changes on: trunk/contrib/perl/t/op/or.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/op/ord.t
===================================================================
--- trunk/contrib/perl/t/op/ord.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/ord.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/ord.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/overload_integer.t
===================================================================
--- trunk/contrib/perl/t/op/overload_integer.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/overload_integer.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,9 +1,15 @@
#!./perl
+BEGIN {
+ chdir 't' if -d 't';
+ push @INC, '../lib';
+ require './test.pl';
+}
+
use strict;
use warnings;
-print "1..2\n";
+plan tests => 2;
package Foo;
@@ -11,7 +17,7 @@
sub import
{
- overload::constant 'integer' => sub { return shift; };
+ overload::constant 'integer' => sub { return shift };
}
package main;
@@ -21,35 +27,9 @@
use Foo;
my $result = eval "5+6";
-
my $error = $@;
+$result //= '';
-my $label = "No exception was thrown with an overload::constant 'integer' inside an eval.";
-# TEST
-if ($error eq "")
-{
- print "ok 1 - $label\n"
-}
-else
-{
- print "not ok 1 - $label\n";
- print "# Error is $error\n";
-}
+is ($error, '', "No exception was thrown with an overload::constant 'integer' inside an eval.");
+is ($result, 11, "Correct solution");
-$label = "Correct solution";
-
-if (!defined($result))
-{
- $result = "";
-}
-# TEST
-if ($result eq 11)
-{
- print "ok 2 - $label\n";
-}
-else
-{
- print "not ok 2 - $label\n";
- print "# Result is $result\n";
-}
-
Property changes on: trunk/contrib/perl/t/op/overload_integer.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/override.t
===================================================================
--- trunk/contrib/perl/t/op/override.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/override.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -6,7 +6,7 @@
require './test.pl';
}
-plan tests => 26;
+plan tests => 28;
#
# This file tries to test builtin override using CORE::GLOBAL
@@ -49,9 +49,30 @@
eval "use Foo::Bar";
is( $r, join($dirsep, "Foo", "Bar.pm") );
-eval "use 5.006";
-is( $r, "5.006" );
+{
+ my @r;
+ local *CORE::GLOBAL::require = sub { push @r, shift; 1; };
+ eval "use 5.006";
+ like( " @r ", qr " 5\.006 " );
+}
+{
+ local $_ = 'foo.pm';
+ require;
+ is( $r, 'foo.pm' );
+}
+
+{
+ BEGIN {
+ # Can’t do ‘no warnings’ with CORE::GLOBAL::require overridden. :-)
+ CORE::require warnings;
+ unimport warnings 'experimental::lexical_topic';
+ }
+ my $_ = 'bar.pm';
+ require;
+ is( $r, 'bar.pm' );
+}
+
# localizing *CORE::GLOBAL::foo should revert to finding CORE::foo
{
local(*CORE::GLOBAL::require);
Property changes on: trunk/contrib/perl/t/op/override.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/pack.t
===================================================================
--- trunk/contrib/perl/t/op/pack.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/pack.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -12,7 +12,7 @@
my $no_signedness = $] > 5.009 ? '' :
"Signed/unsigned pack modifiers not available on this perl";
-plan tests => 14700;
+plan tests => 14704;
use strict;
use warnings qw(FATAL all);
@@ -300,8 +300,6 @@
skip("-- $^O has serious fp indigestion on w-packed infinities", 1)
if (
- ($^O eq 'mpeix')
- ||
($^O eq 'ultrix')
||
($^O =~ /^svr4/ && -f "/etc/issue" && -f "/etc/.relid") # NCR MP-RAS
@@ -816,7 +814,7 @@
{
# /
- my ($x, $y, $z);
+ my ($x, $y, $z, @a);
eval { ($x) = unpack '/a*','hello' };
like($@, qr!'/' must follow a numeric type!);
undef $x;
@@ -823,6 +821,14 @@
eval { $x = unpack '/a*','hello' };
like($@, qr!'/' must follow a numeric type!);
+ # [perl #60204] Unhelpful error message from unpack
+ eval { @a = unpack 'v/a*','h' };
+ is($@, '');
+ is(scalar @a, 0);
+ eval { $x = unpack 'v/a*','h' };
+ is($@, '');
+ is($x, undef);
+
undef $x;
eval { ($z,$x,$y) = unpack 'a3/A C/a* C/Z', "003ok \003yes\004z\000abc" };
is($@, '');
Property changes on: trunk/contrib/perl/t/op/pack.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.4
\ No newline at end of property
Index: trunk/contrib/perl/t/op/packagev.t
===================================================================
--- trunk/contrib/perl/t/op/packagev.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/packagev.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/packagev.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/op/pat.t (from rev 6437, vendor/perl/5.18.1/t/op/pat.t)
===================================================================
--- trunk/contrib/perl/t/op/pat.t (rev 0)
+++ trunk/contrib/perl/t/op/pat.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,4373 @@
+#!./perl
+#
+# This is a home for regular expression tests that don't fit into
+# the format supported by op/regexp.t. If you want to add a test
+# that does fit that format, add it to op/re_tests, not here.
+
+use strict;
+use warnings;
+use 5.010;
+
+
+sub run_tests;
+
+$| = 1;
+
+my $EXPECTED_TESTS = 4065; # Update this when adding/deleting tests.
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+our $TODO;
+our $Message = "Noname test";
+our $Error;
+our $DiePattern;
+our $WarnPattern;
+our $BugId;
+our $PatchId;
+our $running_as_thread;
+
+my $ordA = ord ('A'); # This defines ASCII/UTF-8 vs EBCDIC/UTF-EBCDIC
+# This defined the platform.
+my $IS_ASCII = $ordA == 65;
+my $IS_EBCDIC = $ordA == 193;
+
+use vars '%Config';
+eval 'use Config'; # Defaults assumed if this fails
+
+my $test = 0;
+
+print "1..$EXPECTED_TESTS\n";
+
+run_tests unless caller ();
+
+END {
+}
+
+sub pretty {
+ my ($mess) = @_;
+ $mess =~ s/\n/\\n/g;
+ $mess =~ s/\r/\\r/g;
+ $mess =~ s/\t/\\t/g;
+ $mess =~ s/([\00-\37\177])/sprintf '\%03o', ord $1/eg;
+ $mess =~ s/#/\\#/g;
+ $mess;
+}
+
+sub safe_globals {
+ defined($_) and s/#/\\#/g for $BugId, $PatchId, $TODO;
+}
+
+sub _ok {
+ my ($ok, $mess, $error) = @_;
+ safe_globals();
+ $mess = pretty ($mess // $Message);
+ $mess .= "; Bug $BugId" if defined $BugId;
+ $mess .= "; Patch $PatchId" if defined $PatchId;
+ $mess .= " # TODO $TODO" if defined $TODO;
+
+ my $line_nr = (caller(1)) [2];
+
+ printf "%sok %d - %s\n",
+ ($ok ? "" : "not "),
+ ++ $test,
+ "$mess\tLine $line_nr";
+
+ unless ($ok) {
+ print "# Failed test at line $line_nr\n" unless defined $TODO;
+ if ($error //= $Error) {
+ no warnings 'utf8';
+ chomp $error;
+ $error = join "\n#", map {pretty $_} split /\n\h*#/ => $error;
+ $error = "# $error" unless $error =~ /^\h*#/;
+ print $error, "\n";
+ }
+ }
+
+ return $ok;
+}
+
+# Force scalar context on the pattern match
+sub ok ($;$$) {_ok $_ [0], $_ [1], $_ [2]}
+sub nok ($;$$) {_ok !$_ [0], "Failed: " . ($_ [1] // $Message), $_ [2]}
+
+
+sub skip {
+ my $why = shift;
+ safe_globals();
+ $why =~ s/\n.*//s;
+ $why .= "; Bug $BugId" if defined $BugId;
+ # seems like the new harness code doesnt like todo and skip to be mixed.
+ # which seems like a bug in the harness to me. -- dmq
+ #$why .= " # TODO $TODO" if defined $TODO;
+
+ my $n = shift // 1;
+ my $line_nr = (caller(0)) [2];
+ for (1 .. $n) {
+ ++ $test;
+ #print "not " if defined $TODO;
+ print "ok $test # skip $why\tLine $line_nr\n";
+ }
+ no warnings "exiting";
+ last SKIP;
+}
+
+sub iseq ($$;$) {
+ my ($got, $expect, $name) = @_;
+
+ $_ = defined ($_) ? "'$_'" : "undef" for $got, $expect;
+
+ my $ok = $got eq $expect;
+ my $error = "# expected: $expect\n" .
+ "# result: $got";
+
+ _ok $ok, $name, $error;
+}
+
+sub isneq ($$;$) {
+ my ($got, $expect, $name) = @_;
+ my $todo = $TODO ? " # TODO $TODO" : '';
+
+ $_ = defined ($_) ? "'$_'" : "undef" for $got, $expect;
+
+ my $ok = $got ne $expect;
+ my $error = "# results are equal ($got)";
+
+ _ok $ok, $name, $error;
+}
+
+
+sub eval_ok ($;$) {
+ my ($code, $name) = @_;
+ local $@;
+ if (ref $code) {
+ _ok eval {&$code} && !$@, $name;
+ }
+ else {
+ _ok eval ($code) && !$@, $name;
+ }
+}
+
+sub must_die {
+ my ($code, $pattern, $name) = @_;
+ $pattern //= $DiePattern;
+ undef $@;
+ ref $code ? &$code : eval $code;
+ my $r = $@ && $@ =~ /$pattern/;
+ _ok $r, $name // $Message // "\$\@ =~ /$pattern/";
+}
+
+sub must_warn {
+ my ($code, $pattern, $name) = @_;
+ $pattern //= $WarnPattern;
+ my $w;
+ local $SIG {__WARN__} = sub {$w .= join "" => @_};
+ use warnings 'all';
+ ref $code ? &$code : eval $code;
+ my $r = $w && $w =~ /$pattern/;
+ $w //= "UNDEF";
+ _ok $r, $name // $Message // "Got warning /$pattern/",
+ "# expected: /$pattern/\n" .
+ "# result: $w";
+}
+
+sub may_not_warn {
+ my ($code, $name) = @_;
+ my $w;
+ local $SIG {__WARN__} = sub {$w .= join "" => @_};
+ use warnings 'all';
+ ref $code ? &$code : eval $code;
+ _ok !$w, $name // ($Message ? "$Message (did not warn)"
+ : "Did not warn"),
+ "Got warning '$w'";
+}
+
+
+#
+# Tests start here.
+#
+sub run_tests {
+
+ {
+
+ my $x = "abc\ndef\n";
+
+ ok $x =~ /^abc/, qq ["$x" =~ /^abc/];
+ ok $x !~ /^def/, qq ["$x" !~ /^def/];
+
+ # used to be a test for $*
+ ok $x =~ /^def/m, qq ["$x" =~ /^def/m];
+
+ nok $x =~ /^xxx/, qq ["$x" =~ /^xxx/];
+ nok $x !~ /^abc/, qq ["$x" !~ /^abc/];
+
+ ok $x =~ /def/, qq ["$x" =~ /def/];
+ nok $x !~ /def/, qq ["$x" !~ /def/];
+
+ ok $x !~ /.def/, qq ["$x" !~ /.def/];
+ nok $x =~ /.def/, qq ["$x" =~ /.def/];
+
+ ok $x =~ /\ndef/, qq ["$x" =~ /\ndef/];
+ nok $x !~ /\ndef/, qq ["$x" !~ /\ndef/];
+ }
+
+ {
+ $_ = '123';
+ ok /^([0-9][0-9]*)/, qq [\$_ = '$_'; /^([0-9][0-9]*)/];
+ }
+
+ {
+ $_ = 'aaabbbccc';
+ ok /(a*b*)(c*)/ && $1 eq 'aaabbb' && $2 eq 'ccc',
+ qq [\$_ = '$_'; /(a*b*)(c*)/];
+ ok /(a+b+c+)/ && $1 eq 'aaabbbccc', qq [\$_ = '$_'; /(a+b+c+)/];
+ nok /a+b?c+/, qq [\$_ = '$_'; /a+b?c+/];
+
+ $_ = 'aaabccc';
+ ok /a+b?c+/, qq [\$_ = '$_'; /a+b?c+/];
+ ok /a*b?c*/, qq [\$_ = '$_'; /a*b?c*/];
+
+ $_ = 'aaaccc';
+ ok /a*b?c*/, qq [\$_ = '$_'; /a*b?c*/];
+ nok /a*b+c*/, qq [\$_ = '$_'; /a*b+c*/];
+
+ $_ = 'abcdef';
+ ok /bcd|xyz/, qq [\$_ = '$_'; /bcd|xyz/];
+ ok /xyz|bcd/, qq [\$_ = '$_'; /xyz|bcd/];
+ ok m|bc/*d|, qq [\$_ = '$_'; m|bc/*d|];
+ ok /^$_$/, qq [\$_ = '$_'; /^\$_\$/];
+ }
+
+ {
+ # used to be a test for $*
+ ok "ab\ncd\n" =~ /^cd/m, qq ["ab\ncd\n" =~ /^cd/m];
+ }
+
+ {
+ our %XXX = map {($_ => $_)} 123, 234, 345;
+
+ our @XXX = ('ok 1','not ok 1', 'ok 2','not ok 2','not ok 3');
+ while ($_ = shift(@XXX)) {
+ my $f = index ($_, 'not') >= 0 ? \&nok : \&ok;
+ my $r = ?(.*)?;
+ &$f ($r, "?(.*)?");
+ /not/ && reset;
+ if (/not ok 2/) {
+ if ($^O eq 'VMS') {
+ $_ = shift(@XXX);
+ }
+ else {
+ reset 'X';
+ }
+ }
+ }
+
+ SKIP: {
+ if ($^O eq 'VMS') {
+ skip "Reset 'X'", 1;
+ }
+ ok !keys %XXX, "%XXX is empty";
+ }
+
+ }
+
+ {
+ local $Message = "Test empty pattern";
+ my $xyz = 'xyz';
+ my $cde = 'cde';
+
+ $cde =~ /[^ab]*/;
+ $xyz =~ //;
+ iseq $&, $xyz;
+
+ my $foo = '[^ab]*';
+ $cde =~ /$foo/;
+ $xyz =~ //;
+ iseq $&, $xyz;
+
+ $cde =~ /$foo/;
+ my $null;
+ no warnings 'uninitialized';
+ $xyz =~ /$null/;
+ iseq $&, $xyz;
+
+ $null = "";
+ $xyz =~ /$null/;
+ iseq $&, $xyz;
+ }
+
+ {
+ local $Message = q !Check $`, $&, $'!;
+ $_ = 'abcdefghi';
+ /def/; # optimized up to cmd
+ iseq "$`:$&:$'", 'abc:def:ghi';
+
+ no warnings 'void';
+ /cde/ + 0; # optimized only to spat
+ iseq "$`:$&:$'", 'ab:cde:fghi';
+
+ /[d][e][f]/; # not optimized
+ iseq "$`:$&:$'", 'abc:def:ghi';
+ }
+
+ {
+ $_ = 'now is the {time for all} good men to come to.';
+ / {([^}]*)}/;
+ iseq $1, 'time for all', "Match braces";
+ }
+
+ {
+ local $Message = "{N,M} quantifier";
+ $_ = 'xxx {3,4} yyy zzz';
+ ok /( {3,4})/;
+ iseq $1, ' ';
+ ok !/( {4,})/;
+ ok /( {2,3}.)/;
+ iseq $1, ' y';
+ ok /(y{2,3}.)/;
+ iseq $1, 'yyy ';
+ ok !/x {3,4}/;
+ ok !/^xxx {3,4}/;
+ }
+
+ {
+ local $Message = "Test /g";
+ local $" = ":";
+ $_ = "now is the time for all good men to come to.";
+ my @words = /(\w+)/g;
+ my $exp = "now:is:the:time:for:all:good:men:to:come:to";
+
+ iseq "@words", $exp;
+
+ @words = ();
+ while (/\w+/g) {
+ push (@words, $&);
+ }
+ iseq "@words", $exp;
+
+ @words = ();
+ pos = 0;
+ while (/to/g) {
+ push(@words, $&);
+ }
+ iseq "@words", "to:to";
+
+ pos $_ = 0;
+ @words = /to/g;
+ iseq "@words", "to:to";
+ }
+
+ {
+ $_ = "abcdefghi";
+
+ my $pat1 = 'def';
+ my $pat2 = '^def';
+ my $pat3 = '.def.';
+ my $pat4 = 'abc';
+ my $pat5 = '^abc';
+ my $pat6 = 'abc$';
+ my $pat7 = 'ghi';
+ my $pat8 = '\w*ghi';
+ my $pat9 = 'ghi$';
+
+ my $t1 = my $t2 = my $t3 = my $t4 = my $t5 =
+ my $t6 = my $t7 = my $t8 = my $t9 = 0;
+
+ for my $iter (1 .. 5) {
+ $t1++ if /$pat1/o;
+ $t2++ if /$pat2/o;
+ $t3++ if /$pat3/o;
+ $t4++ if /$pat4/o;
+ $t5++ if /$pat5/o;
+ $t6++ if /$pat6/o;
+ $t7++ if /$pat7/o;
+ $t8++ if /$pat8/o;
+ $t9++ if /$pat9/o;
+ }
+ my $x = "$t1$t2$t3$t4$t5$t6$t7$t8$t9";
+ iseq $x, '505550555', "Test /o";
+ }
+
+
+ SKIP: {
+ my $xyz = 'xyz';
+ ok "abc" =~ /^abc$|$xyz/, "| after \$";
+
+ # perl 4.009 says "unmatched ()"
+ local $Message = '$ inside ()';
+
+ my $result;
+ eval '"abc" =~ /a(bc$)|$xyz/; $result = "$&:$1"';
+ iseq $@, "" or skip "eval failed", 1;
+ iseq $result, "abc:bc";
+ }
+
+
+ {
+ local $Message = "Scalar /g";
+ $_ = "abcfooabcbar";
+
+ ok /abc/g && $` eq "";
+ ok /abc/g && $` eq "abcfoo";
+ ok !/abc/g;
+
+ local $Message = "Scalar /gi";
+ pos = 0;
+ ok /ABC/gi && $` eq "";
+ ok /ABC/gi && $` eq "abcfoo";
+ ok !/ABC/gi;
+
+ local $Message = "Scalar /g";
+ pos = 0;
+ ok /abc/g && $' eq "fooabcbar";
+ ok /abc/g && $' eq "bar";
+
+ $_ .= '';
+ my @x = /abc/g;
+ iseq @x, 2, "/g reset after assignment";
+ }
+
+ {
+ local $Message = '/g, \G and pos';
+ $_ = "abdc";
+ pos $_ = 2;
+ /\Gc/gc;
+ iseq pos $_, 2;
+ /\Gc/g;
+ ok !defined pos $_;
+ }
+
+ {
+ local $Message = '(?{ })';
+ our $out = 1;
+ 'abc' =~ m'a(?{ $out = 2 })b';
+ iseq $out, 2;
+
+ $out = 1;
+ 'abc' =~ m'a(?{ $out = 3 })c';
+ iseq $out, 1;
+ }
+
+
+ {
+ $_ = 'foobar1 bar2 foobar3 barfoobar5 foobar6';
+ my @out = /(?<!foo)bar./g;
+ iseq "@out", 'bar2 barf', "Negative lookbehind";
+ }
+
+ {
+ local $Message = "REG_INFTY tests";
+ # Tests which depend on REG_INFTY
+ $::reg_infty = $Config {reg_infty} // 32767;
+ $::reg_infty_m = $::reg_infty - 1;
+ $::reg_infty_p = $::reg_infty + 1;
+ $::reg_infty_m = $::reg_infty_m; # Surpress warning.
+
+ # As well as failing if the pattern matches do unexpected things, the
+ # next three tests will fail if you should have picked up a lower-than-
+ # default value for $reg_infty from Config.pm, but have not.
+
+ eval_ok q (('aaa' =~ /(a{1,$::reg_infty_m})/)[0] eq 'aaa');
+ eval_ok q (('a' x $::reg_infty_m) =~ /a{$::reg_infty_m}/);
+ eval_ok q (('a' x ($::reg_infty_m - 1)) !~ /a{$::reg_infty_m}/);
+ eval "'aaa' =~ /a{1,$::reg_infty}/";
+ ok $@ =~ /^\QQuantifier in {,} bigger than/;
+ eval "'aaa' =~ /a{1,$::reg_infty_p}/";
+ ok $@ =~ /^\QQuantifier in {,} bigger than/;
+ }
+
+ {
+ # Poke a couple more parse failures
+ my $context = 'x' x 256;
+ eval qq("${context}y" =~ /(?<=$context)y/);
+ ok $@ =~ /^\QLookbehind longer than 255 not/, "Lookbehind limit";
+ }
+
+ {
+ # Long Monsters
+ local $Message = "Long monster";
+ for my $l (125, 140, 250, 270, 300000, 30) { # Ordered to free memory
+ my $a = 'a' x $l;
+ local $Error = "length = $l";
+ ok "ba$a=" =~ /a$a=/;
+ nok "b$a=" =~ /a$a=/;
+ ok "b$a=" =~ /ba+=/;
+
+ ok "ba$a=" =~ /b(?:a|b)+=/;
+ }
+ }
+
+
+ {
+ # 20000 nodes, each taking 3 words per string, and 1 per branch
+ my $long_constant_len = join '|', 12120 .. 32645;
+ my $long_var_len = join '|', 8120 .. 28645;
+ my %ans = ( 'ax13876y25677lbc' => 1,
+ 'ax13876y25677mcb' => 0, # not b.
+ 'ax13876y35677nbc' => 0, # Num too big
+ 'ax13876y25677y21378obc' => 1,
+ 'ax13876y25677y21378zbc' => 0, # Not followed by [k-o]
+ 'ax13876y25677y21378y21378kbc' => 1,
+ 'ax13876y25677y21378y21378kcb' => 0, # Not b.
+ 'ax13876y25677y21378y21378y21378kbc' => 0, # 5 runs
+ );
+
+ local $Message = "20000 nodes";
+ for (keys %ans) {
+ local $Error = "const-len '$_'";
+ ok !($ans{$_} xor /a(?=([yx]($long_constant_len)){2,4}[k-o]).*b./o);
+
+ local $Error = "var-len '$_'";
+ ok !($ans{$_} xor /a(?=([yx]($long_var_len)){2,4}[k-o]).*b./o);
+ }
+ }
+
+ {
+ local $Message = "Complicated backtracking";
+ $_ = " a (bla()) and x(y b((l)u((e))) and b(l(e)e)e";
+ my $expect = "(bla()) ((l)u((e))) (l(e)e)";
+
+ use vars '$c';
+ sub matchit {
+ m/
+ (
+ \(
+ (?{ $c = 1 }) # Initialize
+ (?:
+ (?(?{ $c == 0 }) # PREVIOUS iteration was OK, stop the loop
+ (?!
+ ) # Fail: will unwind one iteration back
+ )
+ (?:
+ [^()]+ # Match a big chunk
+ (?=
+ [()]
+ ) # Do not try to match subchunks
+ |
+ \(
+ (?{ ++$c })
+ |
+ \)
+ (?{ --$c })
+ )
+ )+ # This may not match with different subblocks
+ )
+ (?(?{ $c != 0 })
+ (?!
+ ) # Fail
+ ) # Otherwise the chunk 1 may succeed with $c>0
+ /xg;
+ }
+
+ my @ans = ();
+ my $res;
+ push @ans, $res while $res = matchit;
+ iseq "@ans", "1 1 1";
+
+ @ans = matchit;
+ iseq "@ans", $expect;
+
+ local $Message = "Recursion with (??{ })";
+ our $matched;
+ $matched = qr/\((?:(?>[^()]+)|(??{$matched}))*\)/;
+
+ @ans = my @ans1 = ();
+ push (@ans, $res), push (@ans1, $&) while $res = m/$matched/g;
+
+ iseq "@ans", "1 1 1";
+ iseq "@ans1", $expect;
+
+ @ans = m/$matched/g;
+ iseq "@ans", $expect;
+
+ }
+
+ {
+ ok "abc" =~ /^(??{"a"})b/, '"abc" =~ /^(??{"a"})b/';
+ }
+
+ {
+ my @ans = ('a/b' =~ m%(.*/)?(.*)%); # Stack may be bad
+ iseq "@ans", 'a/ b', "Stack may be bad";
+ }
+
+ {
+ local $Message = "Eval-group not allowed at runtime";
+ my $code = '{$blah = 45}';
+ our $blah = 12;
+ eval { /(?$code)/ };
+ ok $@ && $@ =~ /not allowed at runtime/ && $blah == 12;
+
+ for $code ('{$blah = 45}','=xx') {
+ $blah = 12;
+ my $res = eval { "xx" =~ /(?$code)/o };
+ no warnings 'uninitialized';
+ local $Error = "'$@', '$res', '$blah'";
+ if ($code eq '=xx') {
+ ok !$@ && $res;
+ }
+ else {
+ ok $@ && $@ =~ /not allowed at runtime/ && $blah == 12;
+ }
+ }
+
+ $code = '{$blah = 45}';
+ $blah = 12;
+ eval "/(?$code)/";
+ iseq $blah, 45;
+
+ $blah = 12;
+ /(?{$blah = 45})/;
+ iseq $blah, 45;
+ }
+
+ {
+ local $Message = "Pos checks";
+ my $x = 'banana';
+ $x =~ /.a/g;
+ iseq pos ($x), 2;
+
+ $x =~ /.z/gc;
+ iseq pos ($x), 2;
+
+ sub f {
+ my $p = $_[0];
+ return $p;
+ }
+
+ $x =~ /.a/g;
+ iseq f (pos ($x)), 4;
+ }
+
+ {
+ local $Message = 'Checking $^R';
+ our $x = $^R = 67;
+ 'foot' =~ /foo(?{$x = 12; 75})[t]/;
+ iseq $^R, 75;
+
+ $x = $^R = 67;
+ 'foot' =~ /foo(?{$x = 12; 75})[xy]/;
+ ok $^R eq '67' && $x eq '12';
+
+ $x = $^R = 67;
+ 'foot' =~ /foo(?{ $^R + 12 })((?{ $x = 12; $^R + 17 })[xy])?/;
+ ok $^R eq '79' && $x eq '12';
+ }
+
+ {
+ iseq qr/\b\v$/i, '(?i-xsm:\b\v$)', 'qr/\b\v$/i';
+ iseq qr/\b\v$/s, '(?s-xim:\b\v$)', 'qr/\b\v$/s';
+ iseq qr/\b\v$/m, '(?m-xis:\b\v$)', 'qr/\b\v$/m';
+ iseq qr/\b\v$/x, '(?x-ism:\b\v$)', 'qr/\b\v$/x';
+ iseq qr/\b\v$/xism, '(?msix:\b\v$)', 'qr/\b\v$/xism';
+ iseq qr/\b\v$/, '(?-xism:\b\v$)', 'qr/\b\v$/';
+ }
+
+
+ {
+ local $Message = "Look around";
+ $_ = 'xabcx';
+ SKIP:
+ foreach my $ans ('', 'c') {
+ ok /(?<=(?=a)..)((?=c)|.)/g or skip "Match failed", 1;
+ iseq $1, $ans;
+ }
+ }
+
+ {
+ local $Message = "Empty clause";
+ $_ = 'a';
+ foreach my $ans ('', 'a', '') {
+ ok /^|a|$/g or skip "Match failed", 1;
+ iseq $&, $ans;
+ }
+ }
+
+ {
+ local $Message = "Prefixify";
+ sub prefixify {
+ SKIP: {
+ my ($v, $a, $b, $res) = @_;
+ ok $v =~ s/\Q$a\E/$b/ or skip "Match failed", 1;
+ iseq $v, $res;
+ }
+ }
+
+ prefixify ('/a/b/lib/arch', "/a/b/lib", 'X/lib', 'X/lib/arch');
+ prefixify ('/a/b/man/arch', "/a/b/man", 'X/man', 'X/man/arch');
+ }
+
+ {
+ $_ = 'var="foo"';
+ /(\")/;
+ ok $1 && /$1/, "Capture a quote";
+ }
+
+ {
+ local $Message = "Call code from qr //";
+ $a = qr/(?{++$b})/;
+ $b = 7;
+ ok /$a$a/ && $b eq '9';
+
+ $c="$a";
+ ok /$a$a/ && $b eq '11';
+
+ undef $@;
+ eval {/$c/};
+ ok $@ && $@ =~ /not allowed at runtime/;
+
+ use re "eval";
+ /$a$c$a/;
+ iseq $b, '14';
+
+ our $lex_a = 43;
+ our $lex_b = 17;
+ our $lex_c = 27;
+ my $lex_res = ($lex_b =~ qr/$lex_b(?{ $lex_c = $lex_a++ })/);
+
+ iseq $lex_res, 1;
+ iseq $lex_a, 44;
+ iseq $lex_c, 43;
+
+ no re "eval";
+ undef $@;
+ my $match = eval { /$a$c$a/ };
+ ok $@ && $@ =~ /Eval-group not allowed/ && !$match;
+ iseq $b, '14';
+
+ $lex_a = 2;
+ $lex_a = 43;
+ $lex_b = 17;
+ $lex_c = 27;
+ $lex_res = ($lex_b =~ qr/17(?{ $lex_c = $lex_a++ })/);
+
+ iseq $lex_res, 1;
+ iseq $lex_a, 44;
+ iseq $lex_c, 43;
+
+ }
+
+
+ {
+ no warnings 'closure';
+ local $Message = '(?{ $var } refers to package vars';
+ package aa;
+ our $c = 2;
+ $::c = 3;
+ '' =~ /(?{ $c = 4 })/;
+ main::iseq $c, 4;
+ main::iseq $::c, 3;
+ }
+
+
+ {
+ must_die 'q(a:[b]:) =~ /[x[:foo:]]/',
+ 'POSIX class \[:[^:]+:\] unknown in regex',
+ 'POSIX class [: :] must have valid name';
+
+ for my $d (qw [= .]) {
+ must_die "/[[${d}foo${d}]]/",
+ "\QPOSIX syntax [$d $d] is reserved for future extensions",
+ "POSIX syntax [[$d $d]] is an error";
+ }
+ }
+
+
+ {
+ # test if failure of patterns returns empty list
+ local $Message = "Failed pattern returns empty list";
+ $_ = 'aaa';
+ @_ = /bbb/;
+ iseq "@_", "";
+
+ @_ = /bbb/g;
+ iseq "@_", "";
+
+ @_ = /(bbb)/;
+ iseq "@_", "";
+
+ @_ = /(bbb)/g;
+ iseq "@_", "";
+ }
+
+
+ {
+ local $Message = '@- and @+ tests';
+
+ /a(?=.$)/;
+ iseq $#+, 0;
+ iseq $#-, 0;
+ iseq $+ [0], 2;
+ iseq $- [0], 1;
+ ok !defined $+ [1] && !defined $- [1] &&
+ !defined $+ [2] && !defined $- [2];
+
+ /a(a)(a)/;
+ iseq $#+, 2;
+ iseq $#-, 2;
+ iseq $+ [0], 3;
+ iseq $- [0], 0;
+ iseq $+ [1], 2;
+ iseq $- [1], 1;
+ iseq $+ [2], 3;
+ iseq $- [2], 2;
+ ok !defined $+ [3] && !defined $- [3] &&
+ !defined $+ [4] && !defined $- [4];
+
+
+ /.(a)(b)?(a)/;
+ iseq $#+, 3;
+ iseq $#-, 3;
+ iseq $+ [1], 2;
+ iseq $- [1], 1;
+ iseq $+ [3], 3;
+ iseq $- [3], 2;
+ ok !defined $+ [2] && !defined $- [2] &&
+ !defined $+ [4] && !defined $- [4];
+
+
+ /.(a)/;
+ iseq $#+, 1;
+ iseq $#-, 1;
+ iseq $+ [0], 2;
+ iseq $- [0], 0;
+ iseq $+ [1], 2;
+ iseq $- [1], 1;
+ ok !defined $+ [2] && !defined $- [2] &&
+ !defined $+ [3] && !defined $- [3];
+
+ /.(a)(ba*)?/;
+ iseq $#+, 2;
+ iseq $#-, 1;
+ }
+
+
+ {
+ local $DiePattern = '^Modification of a read-only value attempted';
+ local $Message = 'Elements of @- and @+ are read-only';
+ must_die '$+[0] = 13';
+ must_die '$-[0] = 13';
+ must_die '@+ = (7, 6, 5)';
+ must_die '@- = qw (foo bar)';
+ }
+
+
+ {
+ local $Message = '\G testing';
+ $_ = 'aaa';
+ pos = 1;
+ my @a = /\Ga/g;
+ iseq "@a", "a a";
+
+ my $str = 'abcde';
+ pos $str = 2;
+ ok $str !~ /^\G/;
+ ok $str !~ /^.\G/;
+ ok $str =~ /^..\G/;
+ ok $str !~ /^...\G/;
+ ok $str =~ /\G../ && $& eq 'cd';
+
+ local $TODO = $running_as_thread;
+ ok $str =~ /.\G./ && $& eq 'bc';
+ }
+
+
+ {
+ local $Message = 'pos inside (?{ })';
+ my $str = 'abcde';
+ our ($foo, $bar);
+ ok $str =~ /b(?{$foo = $_; $bar = pos})c/;
+ iseq $foo, $str;
+ iseq $bar, 2;
+ ok !defined pos ($str);
+
+ undef $foo;
+ undef $bar;
+ pos $str = undef;
+ ok $str =~ /b(?{$foo = $_; $bar = pos})c/g;
+ iseq $foo, $str;
+ iseq $bar, 2;
+ iseq pos ($str), 3;
+
+ $_ = $str;
+ undef $foo;
+ undef $bar;
+ ok /b(?{$foo = $_; $bar = pos})c/;
+ iseq $foo, $str;
+ iseq $bar, 2;
+
+ undef $foo;
+ undef $bar;
+ ok /b(?{$foo = $_; $bar = pos})c/g;
+ iseq $foo, $str;
+ iseq $bar, 2;
+ iseq pos, 3;
+
+ undef $foo;
+ undef $bar;
+ pos = undef;
+ 1 while /b(?{$foo = $_; $bar = pos})c/g;
+ iseq $foo, $str;
+ iseq $bar, 2;
+ ok !defined pos;
+
+ undef $foo;
+ undef $bar;
+ $_ = 'abcde|abcde';
+ ok s/b(?{$foo = $_; $bar = pos})c/x/g;
+ iseq $foo, 'abcde|abcde';
+ iseq $bar, 8;
+ iseq $_, 'axde|axde';
+
+ # List context:
+ $_ = 'abcde|abcde';
+ our @res;
+ () = /([ace]).(?{push @res, $1,$2})([ce])(?{push @res, $1,$2})/g;
+ @res = map {defined $_ ? "'$_'" : 'undef'} @res;
+ iseq "@res", "'a' undef 'a' 'c' 'e' undef 'a' undef 'a' 'c'";
+
+ @res = ();
+ () = /([ace]).(?{push @res, $`,$&,$'})([ce])(?{push @res, $`,$&,$'})/g;
+ @res = map {defined $_ ? "'$_'" : 'undef'} @res;
+ iseq "@res", "'' 'ab' 'cde|abcde' " .
+ "'' 'abc' 'de|abcde' " .
+ "'abcd' 'e|' 'abcde' " .
+ "'abcde|' 'ab' 'cde' " .
+ "'abcde|' 'abc' 'de'" ;
+ }
+
+
+ {
+ local $Message = '\G anchor checks';
+ my $foo = 'aabbccddeeffgg';
+ pos ($foo) = 1;
+ {
+ local $TODO = $running_as_thread;
+ no warnings 'uninitialized';
+ ok $foo =~ /.\G(..)/g;
+ iseq $1, 'ab';
+
+ pos ($foo) += 1;
+ ok $foo =~ /.\G(..)/g;
+ iseq $1, 'cc';
+
+ pos ($foo) += 1;
+ ok $foo =~ /.\G(..)/g;
+ iseq $1, 'de';
+
+ ok $foo =~ /\Gef/g;
+ }
+
+ undef pos $foo;
+ ok $foo =~ /\G(..)/g;
+ iseq $1, 'aa';
+
+ ok $foo =~ /\G(..)/g;
+ iseq $1, 'bb';
+
+ pos ($foo) = 5;
+ ok $foo =~ /\G(..)/g;
+ iseq $1, 'cd';
+ }
+
+
+ {
+ $_ = '123x123';
+ my @res = /(\d*|x)/g;
+ local $" = '|';
+ iseq "@res", "123||x|123|", "0 match in alternation";
+ }
+
+
+ {
+ local $Message = "Match against temporaries (created via pp_helem())" .
+ " is safe";
+ ok {foo => "bar\n" . $^X} -> {foo} =~ /^(.*)\n/g;
+ iseq $1, "bar";
+ }
+
+
+ {
+ local $Message = 'package $i inside (?{ }), ' .
+ 'saved substrings and changing $_';
+ our @a = qw [foo bar];
+ our @b = ();
+ s/(\w)(?{push @b, $1})/,$1,/g for @a;
+ iseq "@b", "f o o b a r";
+ iseq "@a", ",f,,o,,o, ,b,,a,,r,";
+
+ local $Message = 'lexical $i inside (?{ }), ' .
+ 'saved substrings and changing $_';
+ no warnings 'closure';
+ my @c = qw [foo bar];
+ my @d = ();
+ s/(\w)(?{push @d, $1})/,$1,/g for @c;
+ iseq "@d", "f o o b a r";
+ iseq "@c", ",f,,o,,o, ,b,,a,,r,";
+ }
+
+
+ {
+ local $Message = 'Brackets';
+ our $brackets;
+ $brackets = qr {
+ { (?> [^{}]+ | (??{ $brackets }) )* }
+ }x;
+
+ ok "{{}" =~ $brackets;
+ iseq $&, "{}";
+ ok "something { long { and } hairy" =~ $brackets;
+ iseq $&, "{ and }";
+ ok "something { long { and } hairy" =~ m/((??{ $brackets }))/;
+ iseq $&, "{ and }";
+ }
+
+
+ {
+ $_ = "a-a\nxbb";
+ pos = 1;
+ nok m/^-.*bb/mg, '$_ = "a-a\nxbb"; m/^-.*bb/mg';
+ }
+
+
+ {
+ local $Message = '\G anchor checks';
+ my $text = "aaXbXcc";
+ pos ($text) = 0;
+ ok $text !~ /\GXb*X/g;
+ }
+
+
+ {
+ $_ = "xA\n" x 500;
+ nok /^\s*A/m, '$_ = "xA\n" x 500; /^\s*A/m"';
+
+ my $text = "abc dbf";
+ my @res = ($text =~ /.*?(b).*?\b/g);
+ iseq "@res", "b b", '\b is not special';
+ }
+
+
+ {
+ local $Message = '\S, [\S], \s, [\s]';
+ my @a = map chr, 0 .. 255;
+ my @b = grep /\S/, @a;
+ my @c = grep /[^\s]/, @a;
+ iseq "@b", "@c";
+
+ @b = grep /\S/, @a;
+ @c = grep /[\S]/, @a;
+ iseq "@b", "@c";
+
+ @b = grep /\s/, @a;
+ @c = grep /[^\S]/, @a;
+ iseq "@b", "@c";
+
+ @b = grep /\s/, @a;
+ @c = grep /[\s]/, @a;
+ iseq "@b", "@c";
+ }
+ {
+ local $Message = '\D, [\D], \d, [\d]';
+ my @a = map chr, 0 .. 255;
+ my @b = grep /\D/, @a;
+ my @c = grep /[^\d]/, @a;
+ iseq "@b", "@c";
+
+ @b = grep /\D/, @a;
+ @c = grep /[\D]/, @a;
+ iseq "@b", "@c";
+
+ @b = grep /\d/, @a;
+ @c = grep /[^\D]/, @a;
+ iseq "@b", "@c";
+
+ @b = grep /\d/, @a;
+ @c = grep /[\d]/, @a;
+ iseq "@b", "@c";
+ }
+ {
+ local $Message = '\W, [\W], \w, [\w]';
+ my @a = map chr, 0 .. 255;
+ my @b = grep /\W/, @a;
+ my @c = grep /[^\w]/, @a;
+ iseq "@b", "@c";
+
+ @b = grep /\W/, @a;
+ @c = grep /[\W]/, @a;
+ iseq "@b", "@c";
+
+ @b = grep /\w/, @a;
+ @c = grep /[^\W]/, @a;
+ iseq "@b", "@c";
+
+ @b = grep /\w/, @a;
+ @c = grep /[\w]/, @a;
+ iseq "@b", "@c";
+ }
+
+
+ {
+ # see if backtracking optimization works correctly
+ local $Message = 'Backtrack optimization';
+ ok "\n\n" =~ /\n $ \n/x;
+ ok "\n\n" =~ /\n* $ \n/x;
+ ok "\n\n" =~ /\n+ $ \n/x;
+ ok "\n\n" =~ /\n? $ \n/x;
+ ok "\n\n" =~ /\n*? $ \n/x;
+ ok "\n\n" =~ /\n+? $ \n/x;
+ ok "\n\n" =~ /\n?? $ \n/x;
+ ok "\n\n" !~ /\n*+ $ \n/x;
+ ok "\n\n" !~ /\n++ $ \n/x;
+ ok "\n\n" =~ /\n?+ $ \n/x;
+ }
+
+
+ {
+ package S;
+ use overload '""' => sub {'Object S'};
+ sub new {bless []}
+
+ local $Message = "Ref stringification";
+ ::ok do { \my $v} =~ /^SCALAR/, "Scalar ref stringification";
+ ::ok do {\\my $v} =~ /^REF/, "Ref ref stringification";
+ ::ok [] =~ /^ARRAY/, "Array ref stringification";
+ ::ok {} =~ /^HASH/, "Hash ref stringification";
+ ::ok 'S' -> new =~ /^Object S/, "Object stringification";
+ }
+
+
+ {
+ local $Message = "Test result of match used as match";
+ ok 'a1b' =~ ('xyz' =~ /y/);
+ iseq $`, 'a';
+ ok 'a1b' =~ ('xyz' =~ /t/);
+ iseq $`, 'a';
+ }
+
+
+ {
+ local $Message = '"1" is not \s';
+ may_not_warn sub {ok ("1\n" x 102) !~ /^\s*\n/m};
+ }
+
+
+ {
+ local $Message = '\s, [[:space:]] and [[:blank:]]';
+ my %space = (spc => " ",
+ tab => "\t",
+ cr => "\r",
+ lf => "\n",
+ ff => "\f",
+ # There's no \v but the vertical tabulator seems miraculously
+ # be 11 both in ASCII and EBCDIC.
+ vt => chr(11),
+ false => "space");
+
+ my @space0 = sort grep {$space {$_} =~ /\s/ } keys %space;
+ my @space1 = sort grep {$space {$_} =~ /[[:space:]]/} keys %space;
+ my @space2 = sort grep {$space {$_} =~ /[[:blank:]]/} keys %space;
+
+ iseq "@space0", "cr ff lf spc tab";
+ iseq "@space1", "cr ff lf spc tab vt";
+ iseq "@space2", "spc tab";
+ }
+
+
+ {
+ local $BugId = '20000731.001';
+ ok "A \x{263a} B z C" =~ /A . B (??{ "z" }) C/,
+ "Match UTF-8 char in presense of (??{ })";
+ }
+
+
+ {
+ local $BugId = '20001021.005';
+ no warnings 'uninitialized';
+ ok undef =~ /^([^\/]*)(.*)$/, "Used to cause a SEGV";
+ }
+
+
+ SKIP:
+ {
+ local $Message = '\C matches octet';
+ $_ = "a\x{100}b";
+ ok /(.)(\C)(\C)(.)/ or skip q [\C doesn't match], 4;
+ iseq $1, "a";
+ if ($IS_ASCII) { # ASCII (or equivalent), should be UTF-8
+ iseq $2, "\xC4";
+ iseq $3, "\x80";
+ }
+ elsif ($IS_EBCDIC) { # EBCDIC (or equivalent), should be UTF-EBCDIC
+ iseq $2, "\x8C";
+ iseq $3, "\x41";
+ }
+ else {
+ SKIP: {
+ ok 0, "Unexpected platform", "ord ('A') = $ordA";
+ skip "Unexpected platform";
+ }
+ }
+ iseq $4, "b";
+ }
+
+
+ SKIP:
+ {
+ local $Message = '\C matches octet';
+ $_ = "\x{100}";
+ ok /(\C)/g or skip q [\C doesn't match], 2;
+ if ($IS_ASCII) {
+ iseq $1, "\xC4";
+ }
+ elsif ($IS_EBCDIC) {
+ iseq $1, "\x8C";
+ }
+ else {
+ ok 0, "Unexpected platform", "ord ('A') = $ordA";
+ }
+ ok /(\C)/g or skip q [\C doesn't match];
+ if ($IS_ASCII) {
+ iseq $1, "\x80";
+ }
+ elsif ($IS_EBCDIC) {
+ iseq $1, "\x41";
+ }
+ else {
+ ok 0, "Unexpected platform", "ord ('A') = $ordA";
+ }
+ }
+
+
+ {
+ # Japhy -- added 03/03/2001
+ () = (my $str = "abc") =~ /(...)/;
+ $str = "def";
+ iseq $1, "abc", 'Changing subject does not modify $1';
+ }
+
+
+ SKIP:
+ {
+ # The trick is that in EBCDIC the explicit numeric range should
+ # match (as also in non-EBCDIC) but the explicit alphabetic range
+ # should not match.
+ ok "\x8e" =~ /[\x89-\x91]/, '"\x8e" =~ /[\x89-\x91]/';
+ ok "\xce" =~ /[\xc9-\xd1]/, '"\xce" =~ /[\xc9-\xd1]/';
+
+ skip "Not an EBCDIC platform", 2 unless ord ('i') == 0x89 &&
+ ord ('J') == 0xd1;
+
+ # In most places these tests would succeed since \x8e does not
+ # in most character sets match 'i' or 'j' nor would \xce match
+ # 'I' or 'J', but strictly speaking these tests are here for
+ # the good of EBCDIC, so let's test these only there.
+ nok "\x8e" !~ /[i-j]/, '"\x8e" !~ /[i-j]/';
+ nok "\xce" !~ /[I-J]/, '"\xce" !~ /[I-J]/';
+ }
+
+
+ {
+ ok "\x{ab}" =~ /\x{ab}/, '"\x{ab}" =~ /\x{ab}/ ';
+ ok "\x{abcd}" =~ /\x{abcd}/, '"\x{abcd}" =~ /\x{abcd}/';
+ }
+
+
+ {
+ local $Message = 'bug id 20001008.001';
+
+ my @x = ("stra\337e 138", "stra\337e 138");
+ for (@x) {
+ ok s/(\d+)\s*([\w\-]+)/$1 . uc $2/e;
+ ok my ($latin) = /^(.+)(?:\s+\d)/;
+ iseq $latin, "stra\337e";
+ ok $latin =~ s/stra\337e/straße/;
+ #
+ # Previous code follows, but outcommented - there were no tests.
+ #
+ # $latin =~ s/stra\337e/straße/; # \303\237 after the 2nd a
+ # use utf8; # needed for the raw UTF-8
+ # $latin =~ s!(s)tr(?:aß|s+e)!$1tr.!; # \303\237 after the a
+ }
+ }
+
+
+ {
+ local $Message = 'Test \x escapes';
+ ok "ba\xd4c" =~ /([a\xd4]+)/ && $1 eq "a\xd4";
+ ok "ba\xd4c" =~ /([a\xd4]+)/ && $1 eq "a\x{d4}";
+ ok "ba\x{d4}c" =~ /([a\xd4]+)/ && $1 eq "a\x{d4}";
+ ok "ba\x{d4}c" =~ /([a\xd4]+)/ && $1 eq "a\xd4";
+ ok "ba\xd4c" =~ /([a\x{d4}]+)/ && $1 eq "a\xd4";
+ ok "ba\xd4c" =~ /([a\x{d4}]+)/ && $1 eq "a\x{d4}";
+ ok "ba\x{d4}c" =~ /([a\x{d4}]+)/ && $1 eq "a\x{d4}";
+ ok "ba\x{d4}c" =~ /([a\x{d4}]+)/ && $1 eq "a\xd4";
+ }
+
+
+ {
+ local $BugId = '20001028.003';
+
+ # Fist half of the bug.
+ local $Message = 'HEBREW ACCENT QADMA matched by .*';
+ my $X = chr (1448);
+ ok my ($Y) = $X =~ /(.*)/;
+ iseq $Y, v1448;
+ iseq length ($Y), 1;
+
+ # Second half of the bug.
+ $Message = 'HEBREW ACCENT QADMA in replacement';
+ $X = '';
+ $X =~ s/^/chr(1488)/e;
+ iseq length $X, 1;
+ iseq ord ($X), 1488;
+ }
+
+
+ {
+ local $BugId = '20001108.001';
+ local $Message = 'Repeated s///';
+ my $X = "Szab\x{f3},Bal\x{e1}zs";
+ my $Y = $X;
+ $Y =~ s/(B)/$1/ for 0 .. 3;
+ iseq $Y, $X;
+ iseq $X, "Szab\x{f3},Bal\x{e1}zs";
+ }
+
+
+ {
+ local $BugId = '20000517.001';
+ local $Message = 's/// on UTF-8 string';
+ my $x = "\x{100}A";
+ $x =~ s/A/B/;
+ iseq $x, "\x{100}B";
+ iseq length $x, 2;
+ }
+
+
+ {
+ local $BugId = '20001230.002';
+ local $Message = '\C and É';
+ ok "École" =~ /^\C\C(.)/ && $1 eq 'c';
+ ok "École" =~ /^\C\C(c)/;
+ }
+
+
+ SKIP:
+ {
+ local $Message = 'Match code points > 255';
+ $_ = "abc\x{100}\x{200}\x{300}\x{380}\x{400}defg";
+ ok /(.\x{300})./ or skip "No match", 4;
+ ok $` eq "abc\x{100}" && length ($`) == 4;
+ ok $& eq "\x{200}\x{300}\x{380}" && length ($&) == 3;
+ ok $' eq "\x{400}defg" && length ($') == 5;
+ ok $1 eq "\x{200}\x{300}" && length ($1) == 2;
+ }
+
+
+ {
+ # The original bug report had 'no utf8' here but that was irrelevant.
+ local $BugId = '20010306.008';
+ local $Message = "Don't dump core";
+ my $a = "a\x{1234}";
+ ok $a =~ m/\w/; # used to core dump.
+ }
+
+
+ {
+ local $BugId = '20010410.006';
+ local $Message = '/g in scalar context';
+ for my $rx ('/(.*?)\{(.*?)\}/csg',
+ '/(.*?)\{(.*?)\}/cg',
+ '/(.*?)\{(.*?)\}/sg',
+ '/(.*?)\{(.*?)\}/g',
+ '/(.+?)\{(.+?)\}/csg',) {
+ my $i = 0;
+ my $input = "a{b}c{d}";
+ eval <<" --";
+ while (eval \$input =~ $rx) {
+ \$i ++;
+ }
+ --
+ iseq $i, 2;
+ }
+ }
+
+
+ {
+ my $x = "\x{10FFFD}";
+ $x =~ s/(.)/$1/g;
+ ok ord($x) == 0x10FFFD && length($x) == 1, "From Robin Houston";
+ }
+
+
+ {
+ my %d = (
+ "7f" => [0, 0, 0],
+ "80" => [1, 1, 0],
+ "ff" => [1, 1, 0],
+ "100" => [0, 1, 1],
+ );
+ SKIP:
+ while (my ($code, $match) = each %d) {
+ local $Message = "Properties of \\x$code";
+ my $char = eval qq ["\\x{$code}"];
+ my $i = 0;
+ ok (($char =~ /[\x80-\xff]/) xor !$$match [$i ++]);
+ ok (($char =~ /[\x80-\x{100}]/) xor !$$match [$i ++]);
+ ok (($char =~ /[\x{100}]/) xor !$$match [$i ++]);
+ }
+ }
+
+
+ {
+ # From Japhy
+ local $Message;
+ must_warn 'qr/(?c)/', '^Useless \(\?c\)';
+ must_warn 'qr/(?-c)/', '^Useless \(\?-c\)';
+ must_warn 'qr/(?g)/', '^Useless \(\?g\)';
+ must_warn 'qr/(?-g)/', '^Useless \(\?-g\)';
+ must_warn 'qr/(?o)/', '^Useless \(\?o\)';
+ must_warn 'qr/(?-o)/', '^Useless \(\?-o\)';
+
+ # Now test multi-error regexes
+ must_warn 'qr/(?g-o)/', '^Useless \(\?g\).*\nUseless \(\?-o\)';
+ must_warn 'qr/(?g-c)/', '^Useless \(\?g\).*\nUseless \(\?-c\)';
+ # (?c) means (?g) error won't be thrown
+ must_warn 'qr/(?o-cg)/', '^Useless \(\?o\).*\nUseless \(\?-c\)';
+ must_warn 'qr/(?ogc)/', '^Useless \(\?o\).*\nUseless \(\?g\).*\n' .
+ 'Useless \(\?c\)';
+ }
+
+
+ {
+ local $Message = "/x tests";
+ $_ = "foo";
+ eval_ok <<" --";
+ /f
+ o\r
+ o
+ \$
+ /x
+ --
+ eval_ok <<" --";
+ /f
+ o
+ o
+ \$\r
+ /x
+ --
+ }
+
+
+ {
+ local $Message = "/o feature";
+ sub test_o {$_ [0] =~ /$_[1]/o; return $1}
+ iseq test_o ('abc', '(.)..'), 'a';
+ iseq test_o ('abc', '..(.)'), 'a';
+ }
+
+
+ {
+ local $BugId = "20010619.003";
+ # Amazingly vertical tabulator is the same in ASCII and EBCDIC.
+ for ("\n", "\t", "\014", "\r") {
+ ok !/[[:print:]]/, "'$_' not in [[:print:]]";
+ }
+ for (" ") {
+ ok /[[:print:]]/, "'$_' in [[:print:]]";
+ }
+ }
+
+
+ {
+ # Test basic $^N usage outside of a regex
+ local $Message = '$^N usage outside of a regex';
+ my $x = "abcdef";
+ ok ($x =~ /cde/ and !defined $^N);
+ ok ($x =~ /(cde)/ and $^N eq "cde");
+ ok ($x =~ /(c)(d)(e)/ and $^N eq "e");
+ ok ($x =~ /(c(d)e)/ and $^N eq "cde");
+ ok ($x =~ /(foo)|(c(d)e)/ and $^N eq "cde");
+ ok ($x =~ /(c(d)e)|(foo)/ and $^N eq "cde");
+ ok ($x =~ /(c(d)e)|(abc)/ and $^N eq "abc");
+ ok ($x =~ /(c(d)e)|(abc)x/ and $^N eq "cde");
+ ok ($x =~ /(c(d)e)(abc)?/ and $^N eq "cde");
+ ok ($x =~ /(?:c(d)e)/ and $^N eq "d");
+ ok ($x =~ /(?:c(d)e)(?:f)/ and $^N eq "d");
+ ok ($x =~ /(?:([abc])|([def]))*/ and $^N eq "f");
+ ok ($x =~ /(?:([ace])|([bdf]))*/ and $^N eq "f");
+ ok ($x =~ /(([ace])|([bd]))*/ and $^N eq "e");
+ {ok ($x =~ /(([ace])|([bdf]))*/ and $^N eq "f");}
+ ## Test to see if $^N is automatically localized -- it should now
+ ## have the value set in the previous test.
+ iseq $^N, "e", '$^N is automatically localized';
+
+ # Now test inside (?{ ... })
+ local $Message = '$^N usage inside (?{ ... })';
+ our ($y, $z);
+ ok ($x =~ /a([abc])(?{$y=$^N})c/ and $y eq "b");
+ ok ($x =~ /a([abc]+)(?{$y=$^N})d/ and $y eq "bc");
+ ok ($x =~ /a([abcdefg]+)(?{$y=$^N})d/ and $y eq "bc");
+ ok ($x =~ /(a([abcdefg]+)(?{$y=$^N})d)(?{$z=$^N})e/ and $y eq "bc"
+ and $z eq "abcd");
+ ok ($x =~ /(a([abcdefg]+)(?{$y=$^N})de)(?{$z=$^N})/ and $y eq "bc"
+ and $z eq "abcde");
+
+ }
+
+
+ SKIP:
+ {
+ ## Should probably put in tests for all the POSIX stuff,
+ ## but not sure how to guarantee a specific locale......
+
+ skip "Not an ASCII platform", 2 unless $IS_ASCII;
+ local $Message = 'Test [[:cntrl:]]';
+ my $AllBytes = join "" => map {chr} 0 .. 255;
+ (my $x = $AllBytes) =~ s/[[:cntrl:]]//g;
+ iseq $x, join "", map {chr} 0x20 .. 0x7E, 0x80 .. 0xFF;
+
+ ($x = $AllBytes) =~ s/[^[:cntrl:]]//g;
+ iseq $x, join "", map {chr} 0x00 .. 0x1F, 0x7F;
+ }
+
+
+ {
+ # With /s modifier UTF8 chars were interpreted as bytes
+ local $Message = "UTF-8 chars aren't bytes";
+ my $a = "Hello \x{263A} World";
+ my @a = ($a =~ /./gs);
+ iseq $#a, 12;
+ }
+
+
+ {
+ local $Message = '. matches \n with /s';
+ my $str1 = "foo\nbar";
+ my $str2 = "foo\n\x{100}bar";
+ my ($a, $b) = map {chr} $IS_ASCII ? (0xc4, 0x80) : (0x8c, 0x41);
+ my @a;
+ @a = $str1 =~ /./g; iseq @a, 6; iseq "@a", "f o o b a r";
+ @a = $str1 =~ /./gs; iseq @a, 7; iseq "@a", "f o o \n b a r";
+ @a = $str1 =~ /\C/g; iseq @a, 7; iseq "@a", "f o o \n b a r";
+ @a = $str1 =~ /\C/gs; iseq @a, 7; iseq "@a", "f o o \n b a r";
+ @a = $str2 =~ /./g; iseq @a, 7; iseq "@a", "f o o \x{100} b a r";
+ @a = $str2 =~ /./gs; iseq @a, 8; iseq "@a", "f o o \n \x{100} b a r";
+ @a = $str2 =~ /\C/g; iseq @a, 9; iseq "@a", "f o o \n $a $b b a r";
+ @a = $str2 =~ /\C/gs; iseq @a, 9; iseq "@a", "f o o \n $a $b b a r";
+ }
+
+
+ {
+ # [ID 20010814.004] pos() doesn't work when using =~m// in list context
+ local $BugId = '20010814.004';
+ $_ = "ababacadaea";
+ my $a = join ":", /b./gc;
+ my $b = join ":", /a./gc;
+ my $c = pos;
+ iseq "$a $b $c", 'ba:ba ad:ae 10', "pos() works with () = m//";
+ }
+
+
+ {
+ # [ID 20010407.006] matching utf8 return values from
+ # functions does not work
+ local $BugId = '20010407.006';
+ local $Message = 'UTF-8 return values from functions';
+ package ID_20010407_006;
+ sub x {"a\x{1234}"}
+ my $x = x;
+ my $y;
+ ::ok $x =~ /(..)/;
+ $y = $1;
+ ::ok length ($y) == 2 && $y eq $x;
+ ::ok x =~ /(..)/;
+ $y = $1;
+ ::ok length ($y) == 2 && $y eq $x;
+ }
+
+
+ {
+ no warnings 'digit';
+ # Check that \x## works. 5.6.1 and 5.005_03 fail some of these.
+ my $x;
+ $x = "\x4e" . "E";
+ ok ($x =~ /^\x4EE$/, "Check only 2 bytes of hex are matched.");
+
+ $x = "\x4e" . "i";
+ ok ($x =~ /^\x4Ei$/, "Check that invalid hex digit stops it (2)");
+
+ $x = "\x4" . "j";
+ ok ($x =~ /^\x4j$/, "Check that invalid hex digit stops it (1)");
+
+ $x = "\x0" . "k";
+ ok ($x =~ /^\xk$/, "Check that invalid hex digit stops it (0)");
+
+ $x = "\x0" . "x";
+ ok ($x =~ /^\xx$/, "\\xx isn't to be treated as \\0");
+
+ $x = "\x0" . "xa";
+ ok ($x =~ /^\xxa$/, "\\xxa isn't to be treated as \\xa");
+
+ $x = "\x9" . "_b";
+ ok ($x =~ /^\x9_b$/, "\\x9_b isn't to be treated as \\x9b");
+
+ # and now again in [] ranges
+
+ $x = "\x4e" . "E";
+ ok ($x =~ /^[\x4EE]{2}$/, "Check only 2 bytes of hex are matched.");
+
+ $x = "\x4e" . "i";
+ ok ($x =~ /^[\x4Ei]{2}$/, "Check that invalid hex digit stops it (2)");
+
+ $x = "\x4" . "j";
+ ok ($x =~ /^[\x4j]{2}$/, "Check that invalid hex digit stops it (1)");
+
+ $x = "\x0" . "k";
+ ok ($x =~ /^[\xk]{2}$/, "Check that invalid hex digit stops it (0)");
+
+ $x = "\x0" . "x";
+ ok ($x =~ /^[\xx]{2}$/, "\\xx isn't to be treated as \\0");
+
+ $x = "\x0" . "xa";
+ ok ($x =~ /^[\xxa]{3}$/, "\\xxa isn't to be treated as \\xa");
+
+ $x = "\x9" . "_b";
+ ok ($x =~ /^[\x9_b]{3}$/, "\\x9_b isn't to be treated as \\x9b");
+
+ # Check that \x{##} works. 5.6.1 fails quite a few of these.
+
+ $x = "\x9b";
+ ok ($x =~ /^\x{9_b}$/, "\\x{9_b} is to be treated as \\x9b");
+
+ $x = "\x9b" . "y";
+ ok ($x =~ /^\x{9_b}y$/, "\\x{9_b} is to be treated as \\x9b (again)");
+
+ $x = "\x9b" . "y";
+ ok ($x =~ /^\x{9b_}y$/, "\\x{9b_} is to be treated as \\x9b");
+
+ $x = "\x9b" . "y";
+ ok ($x =~ /^\x{9_bq}y$/, "\\x{9_bc} is to be treated as \\x9b");
+
+ $x = "\x0" . "y";
+ ok ($x =~ /^\x{x9b}y$/, "\\x{x9b} is to be treated as \\x0");
+
+ $x = "\x0" . "y";
+ ok ($x =~ /^\x{0x9b}y$/, "\\x{0x9b} is to be treated as \\x0");
+
+ $x = "\x9b" . "y";
+ ok ($x =~ /^\x{09b}y$/, "\\x{09b} is to be treated as \\x9b");
+
+ $x = "\x9b";
+ ok ($x =~ /^[\x{9_b}]$/, "\\x{9_b} is to be treated as \\x9b");
+
+ $x = "\x9b" . "y";
+ ok ($x =~ /^[\x{9_b}y]{2}$/,
+ "\\x{9_b} is to be treated as \\x9b (again)");
+
+ $x = "\x9b" . "y";
+ ok ($x =~ /^[\x{9b_}y]{2}$/, "\\x{9b_} is to be treated as \\x9b");
+
+ $x = "\x9b" . "y";
+ ok ($x =~ /^[\x{9_bq}y]{2}$/, "\\x{9_bc} is to be treated as \\x9b");
+
+ $x = "\x0" . "y";
+ ok ($x =~ /^[\x{x9b}y]{2}$/, "\\x{x9b} is to be treated as \\x0");
+
+ $x = "\x0" . "y";
+ ok ($x =~ /^[\x{0x9b}y]{2}$/, "\\x{0x9b} is to be treated as \\x0");
+
+ $x = "\x9b" . "y";
+ ok ($x =~ /^[\x{09b}y]{2}$/, "\\x{09b} is to be treated as \\x9b");
+
+ }
+
+
+ {
+ # High bit bug -- japhy
+ my $x = "ab\200d";
+ ok $x =~ /.*?\200/, "High bit fine";
+ }
+
+
+ {
+ # The basic character classes and Unicode
+ ok "\x{0100}" =~ /\w/, 'LATIN CAPITAL LETTER A WITH MACRON in /\w/';
+ ok "\x{0660}" =~ /\d/, 'ARABIC-INDIC DIGIT ZERO in /\d/';
+ ok "\x{1680}" =~ /\s/, 'OGHAM SPACE MARK in /\s/';
+ }
+
+
+ {
+ local $Message = "Folding matches and Unicode";
+ ok "a\x{100}" =~ /A/i;
+ ok "A\x{100}" =~ /a/i;
+ ok "a\x{100}" =~ /a/i;
+ ok "A\x{100}" =~ /A/i;
+ ok "\x{101}a" =~ /\x{100}/i;
+ ok "\x{100}a" =~ /\x{100}/i;
+ ok "\x{101}a" =~ /\x{101}/i;
+ ok "\x{100}a" =~ /\x{101}/i;
+ ok "a\x{100}" =~ /A\x{100}/i;
+ ok "A\x{100}" =~ /a\x{100}/i;
+ ok "a\x{100}" =~ /a\x{100}/i;
+ ok "A\x{100}" =~ /A\x{100}/i;
+ ok "a\x{100}" =~ /[A]/i;
+ ok "A\x{100}" =~ /[a]/i;
+ ok "a\x{100}" =~ /[a]/i;
+ ok "A\x{100}" =~ /[A]/i;
+ ok "\x{101}a" =~ /[\x{100}]/i;
+ ok "\x{100}a" =~ /[\x{100}]/i;
+ ok "\x{101}a" =~ /[\x{101}]/i;
+ ok "\x{100}a" =~ /[\x{101}]/i;
+ }
+
+
+ {
+ use charnames ':full';
+ local $Message = "Folding 'LATIN LETTER A WITH GRAVE'";
+
+ my $lower = "\N{LATIN SMALL LETTER A WITH GRAVE}";
+ my $UPPER = "\N{LATIN CAPITAL LETTER A WITH GRAVE}";
+
+ ok $lower =~ m/$UPPER/i;
+ ok $UPPER =~ m/$lower/i;
+ ok $lower =~ m/[$UPPER]/i;
+ ok $UPPER =~ m/[$lower]/i;
+
+ local $Message = "Folding 'GREEK LETTER ALPHA WITH VRACHY'";
+
+ $lower = "\N{GREEK CAPITAL LETTER ALPHA WITH VRACHY}";
+ $UPPER = "\N{GREEK SMALL LETTER ALPHA WITH VRACHY}";
+
+ ok $lower =~ m/$UPPER/i;
+ ok $UPPER =~ m/$lower/i;
+ ok $lower =~ m/[$UPPER]/i;
+ ok $UPPER =~ m/[$lower]/i;
+
+ local $Message = "Folding 'LATIN LETTER Y WITH DIAERESIS'";
+
+ $lower = "\N{LATIN SMALL LETTER Y WITH DIAERESIS}";
+ $UPPER = "\N{LATIN CAPITAL LETTER Y WITH DIAERESIS}";
+
+ ok $lower =~ m/$UPPER/i;
+ ok $UPPER =~ m/$lower/i;
+ ok $lower =~ m/[$UPPER]/i;
+ ok $UPPER =~ m/[$lower]/i;
+ }
+
+
+ {
+ use charnames ':full';
+ local $PatchId = "13843";
+ local $Message = "GREEK CAPITAL LETTER SIGMA vs " .
+ "COMBINING GREEK PERISPOMENI";
+
+ my $SIGMA = "\N{GREEK CAPITAL LETTER SIGMA}";
+ my $char = "\N{COMBINING GREEK PERISPOMENI}";
+
+ may_not_warn sub {ok "_:$char:_" !~ m/_:$SIGMA:_/i};
+ }
+
+
+ {
+ local $Message = '\X';
+ use charnames ':full';
+
+ ok "a!" =~ /^(\X)!/ && $1 eq "a";
+ ok "\xDF!" =~ /^(\X)!/ && $1 eq "\xDF";
+ ok "\x{100}!" =~ /^(\X)!/ && $1 eq "\x{100}";
+ ok "\x{100}\x{300}!" =~ /^(\X)!/ && $1 eq "\x{100}\x{300}";
+ ok "\N{LATIN CAPITAL LETTER E}!" =~ /^(\X)!/ &&
+ $1 eq "\N{LATIN CAPITAL LETTER E}";
+ ok "\N{LATIN CAPITAL LETTER E}\N{COMBINING GRAVE ACCENT}!"
+ =~ /^(\X)!/ &&
+ $1 eq "\N{LATIN CAPITAL LETTER E}\N{COMBINING GRAVE ACCENT}";
+
+ local $Message = '\C and \X';
+ ok "!abc!" =~ /a\Cc/;
+ ok "!abc!" =~ /a\Xc/;
+ }
+
+
+ {
+ local $Message = "Final Sigma";
+
+ my $SIGMA = "\x{03A3}"; # CAPITAL
+ my $Sigma = "\x{03C2}"; # SMALL FINAL
+ my $sigma = "\x{03C3}"; # SMALL
+
+ ok $SIGMA =~ /$SIGMA/i;
+ ok $SIGMA =~ /$Sigma/i;
+ ok $SIGMA =~ /$sigma/i;
+
+ ok $Sigma =~ /$SIGMA/i;
+ ok $Sigma =~ /$Sigma/i;
+ ok $Sigma =~ /$sigma/i;
+
+ ok $sigma =~ /$SIGMA/i;
+ ok $sigma =~ /$Sigma/i;
+ ok $sigma =~ /$sigma/i;
+
+ ok $SIGMA =~ /[$SIGMA]/i;
+ ok $SIGMA =~ /[$Sigma]/i;
+ ok $SIGMA =~ /[$sigma]/i;
+
+ ok $Sigma =~ /[$SIGMA]/i;
+ ok $Sigma =~ /[$Sigma]/i;
+ ok $Sigma =~ /[$sigma]/i;
+
+ ok $sigma =~ /[$SIGMA]/i;
+ ok $sigma =~ /[$Sigma]/i;
+ ok $sigma =~ /[$sigma]/i;
+
+ local $Message = "More final Sigma";
+
+ my $S3 = "$SIGMA$Sigma$sigma";
+
+ ok ":$S3:" =~ /:(($SIGMA)+):/i && $1 eq $S3 && $2 eq $sigma;
+ ok ":$S3:" =~ /:(($Sigma)+):/i && $1 eq $S3 && $2 eq $sigma;
+ ok ":$S3:" =~ /:(($sigma)+):/i && $1 eq $S3 && $2 eq $sigma;
+
+ ok ":$S3:" =~ /:(([$SIGMA])+):/i && $1 eq $S3 && $2 eq $sigma;
+ ok ":$S3:" =~ /:(([$Sigma])+):/i && $1 eq $S3 && $2 eq $sigma;
+ ok ":$S3:" =~ /:(([$sigma])+):/i && $1 eq $S3 && $2 eq $sigma;
+ }
+
+
+ {
+ use charnames ':full';
+ local $Message = "Parlez-Vous " .
+ "Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais?";
+
+ ok "Fran\N{LATIN SMALL LETTER C}ais" =~ /Fran.ais/ &&
+ $& eq "Francais";
+ ok "Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais" =~ /Fran.ais/ &&
+ $& eq "Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais";
+ ok "Fran\N{LATIN SMALL LETTER C}ais" =~ /Fran\Cais/ &&
+ $& eq "Francais";
+ # COMBINING CEDILLA is two bytes when encoded
+ ok "Franc\N{COMBINING CEDILLA}ais" =~ /Franc\C\Cais/;
+ ok "Fran\N{LATIN SMALL LETTER C}ais" =~ /Fran\Xais/ &&
+ $& eq "Francais";
+ ok "Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais" =~ /Fran\Xais/ &&
+ $& eq "Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais";
+ ok "Franc\N{COMBINING CEDILLA}ais" =~ /Fran\Xais/ &&
+ $& eq "Franc\N{COMBINING CEDILLA}ais";
+ ok "Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais" =~
+ /Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais/ &&
+ $& eq "Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais";
+ ok "Franc\N{COMBINING CEDILLA}ais" =~ /Franc\N{COMBINING CEDILLA}ais/ &&
+ $& eq "Franc\N{COMBINING CEDILLA}ais";
+
+ my @f = (
+ ["Fran\N{LATIN SMALL LETTER C}ais", "Francais"],
+ ["Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais",
+ "Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais"],
+ ["Franc\N{COMBINING CEDILLA}ais", "Franc\N{COMBINING CEDILLA}ais"],
+ );
+ foreach my $entry (@f) {
+ my ($subject, $match) = @$entry;
+ ok $subject =~ /Fran(?:c\N{COMBINING CEDILLA}?|
+ \N{LATIN SMALL LETTER C WITH CEDILLA})ais/x &&
+ $& eq $match;
+ }
+ }
+
+
+ {
+ local $Message = "Lingering (and useless) UTF8 flag doesn't mess up /i";
+ my $pat = "ABcde";
+ my $str = "abcDE\x{100}";
+ chop $str;
+ ok $str =~ /$pat/i;
+
+ $pat = "ABcde\x{100}";
+ $str = "abcDE";
+ chop $pat;
+ ok $str =~ /$pat/i;
+
+ $pat = "ABcde\x{100}";
+ $str = "abcDE\x{100}";
+ chop $pat;
+ chop $str;
+ ok $str =~ /$pat/i;
+ }
+
+
+ {
+ use charnames ':full';
+ local $Message = "LATIN SMALL LETTER SHARP S " .
+ "(\N{LATIN SMALL LETTER SHARP S})";
+
+ ok "\N{LATIN SMALL LETTER SHARP S}" =~
+ /\N{LATIN SMALL LETTER SHARP S}/;
+ ok "\N{LATIN SMALL LETTER SHARP S}" =~
+ /\N{LATIN SMALL LETTER SHARP S}/i;
+ ok "\N{LATIN SMALL LETTER SHARP S}" =~
+ /[\N{LATIN SMALL LETTER SHARP S}]/;
+ ok "\N{LATIN SMALL LETTER SHARP S}" =~
+ /[\N{LATIN SMALL LETTER SHARP S}]/i;
+
+ ok "ss" =~ /\N{LATIN SMALL LETTER SHARP S}/i;
+ ok "SS" =~ /\N{LATIN SMALL LETTER SHARP S}/i;
+ ok "ss" =~ /[\N{LATIN SMALL LETTER SHARP S}]/i;
+ ok "SS" =~ /[\N{LATIN SMALL LETTER SHARP S}]/i;
+
+ ok "\N{LATIN SMALL LETTER SHARP S}" =~ /ss/i;
+ ok "\N{LATIN SMALL LETTER SHARP S}" =~ /SS/i;
+
+ local $Message = "Unoptimized named sequence in class";
+ ok "ss" =~ /[\N{LATIN SMALL LETTER SHARP S}x]/i;
+ ok "SS" =~ /[\N{LATIN SMALL LETTER SHARP S}x]/i;
+ ok "\N{LATIN SMALL LETTER SHARP S}" =~
+ /[\N{LATIN SMALL LETTER SHARP S}x]/;
+ ok "\N{LATIN SMALL LETTER SHARP S}" =~
+ /[\N{LATIN SMALL LETTER SHARP S}x]/i;
+ }
+
+
+ {
+ # More whitespace: U+0085, U+2028, U+2029\n";
+
+ # U+0085, U+00A0 need to be forced to be Unicode, the \x{100} does that.
+ SKIP: {
+ skip "EBCDIC platform", 4 if $IS_EBCDIC;
+ # Do \x{0015} and \x{0041} match \s in EBCDIC?
+ ok "<\x{100}\x{0085}>" =~ /<\x{100}\s>/, '\x{0085} in \s';
+ ok "<\x{0085}>" =~ /<\v>/, '\x{0085} in \v';
+ ok "<\x{100}\x{00A0}>" =~ /<\x{100}\s>/, '\x{00A0} in \s';
+ ok "<\x{00A0}>" =~ /<\h>/, '\x{00A0} in \h';
+ }
+ my @h = map {sprintf "%05x" => $_} 0x01680, 0x0180E, 0x02000 .. 0x0200A,
+ 0x0202F, 0x0205F, 0x03000;
+ my @v = map {sprintf "%05x" => $_} 0x02028, 0x02029;
+
+ my @H = map {sprintf "%05x" => $_} 0x01361, 0x0200B, 0x02408, 0x02420,
+ 0x0303F, 0xE0020;
+ my @V = map {sprintf "%05x" => $_} 0x0008A .. 0x0008D, 0x00348, 0x10100,
+ 0xE005F, 0xE007C;
+
+ for my $hex (@h) {
+ my $str = eval qq ["<\\x{$hex}>"];
+ ok $str =~ /<\s>/, "\\x{$hex} in \\s";
+ ok $str =~ /<\h>/, "\\x{$hex} in \\h";
+ ok $str !~ /<\v>/, "\\x{$hex} not in \\v";
+ }
+
+ for my $hex (@v) {
+ my $str = eval qq ["<\\x{$hex}>"];
+ ok $str =~ /<\s>/, "\\x{$hex} in \\s";
+ ok $str =~ /<\v>/, "\\x{$hex} in \\v";
+ ok $str !~ /<\h>/, "\\x{$hex} not in \\h";
+ }
+
+ for my $hex (@H) {
+ my $str = eval qq ["<\\x{$hex}>"];
+ ok $str =~ /<\S>/, "\\x{$hex} in \\S";
+ ok $str =~ /<\H>/, "\\x{$hex} in \\H";
+ }
+
+ for my $hex (@V) {
+ my $str = eval qq ["<\\x{$hex}>"];
+ ok $str =~ /<\S>/, "\\x{$hex} in \\S";
+ ok $str =~ /<\V>/, "\\x{$hex} in \\V";
+ }
+ }
+
+
+ {
+ # . with /s should work on characters, as opposed to bytes
+ local $Message = ". with /s works on characters, not bytes";
+
+ my $s = "\x{e4}\x{100}";
+ # This is not expected to match: the point is that
+ # neither should we get "Malformed UTF-8" warnings.
+ may_not_warn sub {$s =~ /\G(.+?)\n/gcs}, "No 'Malformed UTF-8' warning";
+
+ my @c;
+ push @c => $1 while $s =~ /\G(.)/gs;
+
+ local $" = "";
+ iseq "@c", $s;
+
+ # Test only chars < 256
+ my $t1 = "Q003\n\n\x{e4}\x{f6}\n\nQ004\n\n\x{e7}";
+ my $r1 = "";
+ while ($t1 =~ / \G ( .+? ) \n\s+ ( .+? ) ( $ | \n\s+ ) /xgcs) {
+ $r1 .= $1 . $2;
+ }
+
+ my $t2 = $t1 . "\x{100}"; # Repeat with a larger char
+ my $r2 = "";
+ while ($t2 =~ / \G ( .+? ) \n\s+ ( .+? ) ( $ | \n\s+ ) /xgcs) {
+ $r2 .= $1 . $2;
+ }
+ $r2 =~ s/\x{100}//;
+
+ iseq $r1, $r2;
+ }
+
+
+ {
+ local $Message = "Unicode lookbehind";
+ ok "A\x{100}B" =~ /(?<=A.)B/;
+ ok "A\x{200}\x{300}B" =~ /(?<=A..)B/;
+ ok "\x{400}AB" =~ /(?<=\x{400}.)B/;
+ ok "\x{500}\x{600}B" =~ /(?<=\x{500}.)B/;
+
+ # Original code also contained:
+ # ok "\x{500\x{600}}B" =~ /(?<=\x{500}.)B/;
+ # but that looks like a typo.
+ }
+
+
+ {
+ local $Message = 'UTF-8 hash keys and /$/';
+ # http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters
+ # /2002-01/msg01327.html
+
+ my $u = "a\x{100}";
+ my $v = substr ($u, 0, 1);
+ my $w = substr ($u, 1, 1);
+ my %u = ($u => $u, $v => $v, $w => $w);
+ for (keys %u) {
+ my $m1 = /^\w*$/ ? 1 : 0;
+ my $m2 = $u {$_} =~ /^\w*$/ ? 1 : 0;
+ iseq $m1, $m2;
+ }
+ }
+
+
+ {
+ local $BugId = "20020124.005";
+ local $PatchId = "14795";
+ local $Message = "s///eg";
+
+ for my $char ("a", "\x{df}", "\x{100}") {
+ my $x = "$char b $char";
+ $x =~ s{($char)}{
+ "c" =~ /c/;
+ "x";
+ }ge;
+ iseq substr ($x, 0, 1), substr ($x, -1, 1);
+ }
+ }
+
+
+ {
+ local $Message = "No SEGV in s/// and UTF-8";
+ my $s = "s#\x{100}" x 4;
+ ok $s =~ s/[^\w]/ /g;
+ if ($ENV {REAL_POSIX_CC}) {
+ iseq $s, "s " x 4;
+ }
+ else {
+ iseq $s, "s \x{100}" x 4;
+ }
+ }
+
+
+ {
+ local $Message = "UTF-8 bug (maybe already known?)";
+ my $u = "foo";
+ $u =~ s/./\x{100}/g;
+ iseq $u, "\x{100}\x{100}\x{100}";
+
+ $u = "foobar";
+ $u =~ s/[ao]/\x{100}/g;
+ iseq $u, "f\x{100}\x{100}b\x{100}r";
+
+ $u =~ s/\x{100}/e/g;
+ iseq $u, "feeber";
+ }
+
+
+ {
+ local $Message = "UTF-8 bug with s///";
+ # check utf8/non-utf8 mixtures
+ # try to force all float/anchored check combinations
+
+ my $c = "\x{100}";
+ my $subst;
+ for my $re ("xx.*$c", "x.*$c$c", "$c.*xx", "$c$c.*x",
+ "xx.*(?=$c)", "(?=$c).*xx",) {
+ ok "xxx" !~ /$re/;
+ ok +($subst = "xxx") !~ s/$re//;
+ }
+ for my $re ("xx.*$c*", "$c*.*xx") {
+ ok "xxx" =~ /$re/;
+ ok +($subst = "xxx") =~ s/$re//;
+ iseq $subst, "";
+ }
+ for my $re ("xxy*", "y*xx") {
+ ok "xx$c" =~ /$re/;
+ ok +($subst = "xx$c") =~ s/$re//;
+ iseq $subst, $c;
+ ok "xy$c" !~ /$re/;
+ ok +($subst = "xy$c") !~ s/$re//;
+ }
+ for my $re ("xy$c*z", "x$c*yz") {
+ ok "xyz" =~ /$re/;
+ ok +($subst = "xyz") =~ s/$re//;
+ iseq $subst, "";
+ }
+ }
+
+
+ {
+ local $Message = "qr /.../x";
+ my $R = qr / A B C # D E/x;
+ ok "ABCDE" =~ $R && $& eq "ABC";
+ ok "ABCDE" =~ /$R/ && $& eq "ABC";
+ ok "ABCDE" =~ m/$R/ && $& eq "ABC";
+ ok "ABCDE" =~ /($R)/ && $1 eq "ABC";
+ ok "ABCDE" =~ m/($R)/ && $1 eq "ABC";
+ }
+
+
+ {
+ local $BugId = "20020412.005";
+ local $Message = "Correct pmop flags checked when empty pattern";
+
+ # Requires reuse of last successful pattern.
+ my $num = 123;
+ $num =~ /\d/;
+ for (0 .. 1) {
+ my $match = ?? + 0;
+ ok $match != $_, $Message,
+ sprintf "'match one' %s on %s iteration" =>
+ $match ? 'succeeded' : 'failed',
+ $_ ? 'second' : 'first';
+ }
+ $num =~ /(\d)/;
+ my $result = join "" => $num =~ //g;
+ iseq $result, $num;
+ }
+
+
+ {
+ local $BugId = '20020630.002';
+ local $Message = 'UTF-8 regex matches above 32k';
+ for (['byte', "\x{ff}"], ['utf8', "\x{1ff}"]) {
+ my ($type, $char) = @$_;
+ for my $len (32000, 32768, 33000) {
+ my $s = $char . "f" x $len;
+ my $r = $s =~ /$char([f]*)/gc;
+ ok $r, $Message, "<$type x $len>";
+ ok !$r || pos ($s) == $len + 1, $Message,
+ "<$type x $len>; pos = @{[pos $s]}";
+ }
+ }
+ }
+
+
+ {
+ our $a = bless qr /foo/ => 'Foo';
+ ok 'goodfood' =~ $a, "Reblessed qr // matches";
+ iseq $a, '(?-xism:foo)', "Reblessed qr // stringifies";
+ my $x = "\x{3fe}";
+ my $z = my $y = "\317\276"; # Byte representation of $x
+ $a = qr /$x/;
+ ok $x =~ $a, "UTF-8 interpolation in qr //";
+ ok "a$a" =~ $x, "Stringified qr // preserves UTF-8";
+ ok "a$x" =~ /^a$a\z/, "Interpolated qr // preserves UTF-8";
+ ok "a$x" =~ /^a(??{$a})\z/,
+ "Postponed interpolation of qr // preserves UTF-8";
+ {
+ local $BugId = '17776';
+ iseq length qr /##/x, 12, "## in qr // doesn't corrupt memory";
+ }
+ {
+ use re 'eval';
+ ok "$x$x" =~ /^$x(??{$x})\z/,
+ "Postponed UTF-8 string in UTF-8 re matches UTF-8";
+ ok "$y$x" =~ /^$y(??{$x})\z/,
+ "Postponed UTF-8 string in non-UTF-8 re matches UTF-8";
+ ok "$y$x" !~ /^$y(??{$y})\z/,
+ "Postponed non-UTF-8 string in non-UTF-8 re doesn't match UTF-8";
+ ok "$x$x" !~ /^$x(??{$y})\z/,
+ "Postponed non-UTF-8 string in UTF-8 re doesn't match UTF-8";
+ ok "$y$y" =~ /^$y(??{$y})\z/,
+ "Postponed non-UTF-8 string in non-UTF-8 re matches non-UTF8";
+ ok "$x$y" =~ /^$x(??{$y})\z/,
+ "Postponed non-UTF-8 string in UTF-8 re matches non-UTF8";
+
+ $y = $z; # Reset $y after upgrade.
+ ok "$x$y" !~ /^$x(??{$x})\z/,
+ "Postponed UTF-8 string in UTF-8 re doesn't match non-UTF-8";
+ ok "$y$y" !~ /^$y(??{$x})\z/,
+ "Postponed UTF-8 string in non-UTF-8 re doesn't match non-UTF-8";
+ }
+ }
+
+
+ {
+ local $PatchId = '18179';
+ my $s = "\x{100}" x 5;
+ my $ok = $s =~ /(\x{100}{4})/;
+ my ($ord, $len) = (ord $1, length $1);
+ ok $ok && $ord == 0x100 && $len == 4, "No panic: end_shift";
+ }
+
+
+ {
+ local $BugId = '15763';
+ our $a = "x\x{100}";
+ chop $a; # Leaves the UTF-8 flag
+ $a .= "y"; # 1 byte before 'y'.
+
+ ok $a =~ /^\C/, 'match one \C on 1-byte UTF-8';
+ ok $a =~ /^\C{1}/, 'match \C{1}';
+
+ ok $a =~ /^\Cy/, 'match \Cy';
+ ok $a =~ /^\C{1}y/, 'match \C{1}y';
+
+ ok $a !~ /^\C\Cy/, q {don't match two \Cy};
+ ok $a !~ /^\C{2}y/, q {don't match \C{2}y};
+
+ $a = "\x{100}y"; # 2 bytes before "y"
+
+ ok $a =~ /^\C/, 'match one \C on 2-byte UTF-8';
+ ok $a =~ /^\C{1}/, 'match \C{1}';
+ ok $a =~ /^\C\C/, 'match two \C';
+ ok $a =~ /^\C{2}/, 'match \C{2}';
+
+ ok $a =~ /^\C\C\C/, 'match three \C on 2-byte UTF-8 and a byte';
+ ok $a =~ /^\C{3}/, 'match \C{3}';
+
+ ok $a =~ /^\C\Cy/, 'match two \C';
+ ok $a =~ /^\C{2}y/, 'match \C{2}';
+
+ ok $a !~ /^\C\C\Cy/, q {don't match three \Cy};
+ ok $a !~ /^\C{2}\Cy/, q {don't match \C{2}\Cy};
+ ok $a !~ /^\C{3}y/, q {don't match \C{3}y};
+
+ $a = "\x{1000}y"; # 3 bytes before "y"
+
+ ok $a =~ /^\C/, 'match one \C on three-byte UTF-8';
+ ok $a =~ /^\C{1}/, 'match \C{1}';
+ ok $a =~ /^\C\C/, 'match two \C';
+ ok $a =~ /^\C{2}/, 'match \C{2}';
+ ok $a =~ /^\C\C\C/, 'match three \C';
+ ok $a =~ /^\C{3}/, 'match \C{3}';
+
+ ok $a =~ /^\C\C\C\C/, 'match four \C on three-byte UTF-8 and a byte';
+ ok $a =~ /^\C{4}/, 'match \C{4}';
+
+ ok $a =~ /^\C\C\Cy/, 'match three \Cy';
+ ok $a =~ /^\C{3}y/, 'match \C{3}y';
+
+ ok $a !~ /^\C\C\C\Cy/, q {don't match four \Cy};
+ ok $a !~ /^\C{4}y/, q {don't match \C{4}y};
+ }
+
+
+ {
+ local $\;
+ $_ = 'aaaaaaaaaa';
+ utf8::upgrade($_); chop $_; $\="\n";
+ ok /[^\s]+/, 'm/[^\s]/ utf8';
+ ok /[^\d]+/, 'm/[^\d]/ utf8';
+ ok +($a = $_, $_ =~ s/[^\s]+/./g), 's/[^\s]/ utf8';
+ ok +($a = $_, $a =~ s/[^\d]+/./g), 's/[^\s]/ utf8';
+ }
+
+
+ {
+ local $BugId = '15397';
+ local $Message = 'UTF-8 matching';
+ ok "\x{100}" =~ /\x{100}/;
+ ok "\x{100}" =~ /(\x{100})/;
+ ok "\x{100}" =~ /(\x{100}){1}/;
+ ok "\x{100}\x{100}" =~ /(\x{100}){2}/;
+ ok "\x{100}\x{100}" =~ /(\x{100})(\x{100})/;
+ }
+
+
+ {
+ local $BugId = '7471';
+ local $Message = 'Neither ()* nor ()*? sets $1 when matched 0 times';
+ local $_ = 'CD';
+ ok /(AB)*?CD/ && !defined $1;
+ ok /(AB)*CD/ && !defined $1;
+ }
+
+
+ {
+ local $BugId = '3547';
+ local $Message = "Caching shouldn't prevent match";
+ my $pattern = "^(b+?|a){1,2}c";
+ ok "bac" =~ /$pattern/ && $1 eq 'a';
+ ok "bbac" =~ /$pattern/ && $1 eq 'a';
+ ok "bbbac" =~ /$pattern/ && $1 eq 'a';
+ ok "bbbbac" =~ /$pattern/ && $1 eq 'a';
+ }
+
+
+
+ {
+ local $BugId = '18232';
+ local $Message = '$1 should keep UTF-8 ness';
+ ok "\x{100}" =~ /(.)/;
+ iseq $1, "\x{100}", '$1 is UTF-8';
+ { 'a' =~ /./; }
+ iseq $1, "\x{100}", '$1 is still UTF-8';
+ isneq $1, "\xC4\x80", '$1 is not non-UTF-8';
+ }
+
+
+ {
+ local $BugId = '19767';
+ local $Message = "Optimizer doesn't prematurely reject match";
+ use utf8;
+
+ my $attr = 'Name-1';
+ my $NormalChar = qr /[\p{IsDigit}\p{IsLower}\p{IsUpper}]/;
+ my $NormalWord = qr /${NormalChar}+?/;
+ my $PredNameHyphen = qr /^${NormalWord}(\-${NormalWord})*?$/;
+
+ $attr =~ /^$/;
+ ok $attr =~ $PredNameHyphen; # Original test.
+
+ "a" =~ m/[b]/;
+ ok "0" =~ /\p{N}+\z/; # Variant.
+ }
+
+
+ {
+ local $BugId = '20683';
+ local $Message = "(??{ }) doesn't return stale values";
+ our $p = 1;
+ foreach (1, 2, 3, 4) {
+ $p ++ if /(??{ $p })/
+ }
+ iseq $p, 5;
+
+ {
+ package P;
+ $a = 1;
+ sub TIESCALAR {bless []}
+ sub FETCH {$a ++}
+ }
+ tie $p, "P";
+ foreach (1, 2, 3, 4) {
+ /(??{ $p })/
+ }
+ iseq $p, 5;
+ }
+
+
+ {
+ # Subject: Odd regexp behavior
+ # From: Markus Kuhn <Markus.Kuhn at cl.cam.ac.uk>
+ # Date: Wed, 26 Feb 2003 16:53:12 +0000
+ # Message-Id: <E18o4nw-0008Ly-00 at wisbech.cl.cam.ac.uk>
+ # To: perl-unicode at perl.org
+
+ local $Message = 'Markus Kuhn 2003-02-26';
+
+ my $x = "\x{2019}\nk";
+ ok $x =~ s/(\S)\n(\S)/$1 $2/sg;
+ ok $x eq "\x{2019} k";
+
+ $x = "b\nk";
+ ok $x =~ s/(\S)\n(\S)/$1 $2/sg;
+ ok $x eq "b k";
+
+ ok "\x{2019}" =~ /\S/;
+ }
+
+
+ {
+ local $BugId = '21411';
+ local $Message = "(??{ .. }) in split doesn't corrupt its stack";
+ our $i;
+ ok '-1-3-5-' eq join '', split /((??{$i++}))/, '-1-3-5-';
+ no warnings 'deprecated', 'syntax';
+ split /(?{'WOW'})/, 'abc';
+ local $" = "|";
+ iseq "@_", "a|b|c";
+ }
+
+
+ {
+ # XXX DAPM 13-Apr-06. Recursive split is still broken. It's only luck it
+ # hasn't been crashing. Disable this test until it is fixed properly.
+ # XXX also check what it returns rather than just doing ok(1,...)
+ # split /(?{ split "" })/, "abc";
+ local $TODO = "Recursive split is still broken";
+ ok 0, 'cache_re & "(?{": it dumps core in 5.6.1 & 5.8.0';
+ }
+
+
+ {
+ ok "\x{100}\n" =~ /\x{100}\n$/, "UTF-8 length cache and fbm_compile";
+ }
+
+
+ {
+ package Str;
+ use overload q /""/ => sub {${$_ [0]};};
+ sub new {my ($c, $v) = @_; bless \$v, $c;}
+
+ package main;
+ $_ = Str -> new ("a\x{100}/\x{100}b");
+ ok join (":", /\b(.)\x{100}/g) eq "a:/", "re_intuit_start and PL_bostr";
+ }
+
+
+ {
+ local $BugId = '17757';
+ $_ = "code: 'x' { '...' }\n"; study;
+ my @x; push @x, $& while m/'[^\']*'/gx;
+ local $" = ":";
+ iseq "@x", "'x':'...'", "Parse::RecDescent triggered infinite loop";
+ }
+
+
+ {
+ my $re = qq /^([^X]*)X/;
+ utf8::upgrade ($re);
+ ok "\x{100}X" =~ /$re/, "S_cl_and ANYOF_UNICODE & ANYOF_INVERTED";
+ }
+
+
+ {
+ local $BugId = '22354';
+ sub func ($) {
+ ok "a\nb" !~ /^b/, "Propagated modifier; $_[0]";
+ ok "a\nb" =~ /^b/m, "Propagated modifier; $_[0] - with /m";
+ }
+ func "standalone";
+ $_ = "x"; s/x/func "in subst"/e;
+ $_ = "x"; s/x/func "in multiline subst"/em;
+
+ #
+ # Next two give 'panic: malloc'.
+ # Outcommented, using two TODOs.
+ #
+ local $TODO = 'panic: malloc';
+ local $Message = 'Postponed regexp and propaged modifier';
+ # ok 0 for 1 .. 2;
+ SKIP: {
+ skip "panic: malloc", 2;
+ $_ = "x"; /x(?{func "in regexp"})/;
+ $_ = "x"; /x(?{func "in multiline regexp"})/m;
+ }
+ }
+
+
+ {
+ local $BugId = '19049';
+ $_ = "abcdef\n";
+ my @x = m/./g;
+ iseq "abcde", $`, 'Global match sets $`';
+ }
+
+
+ {
+ ok "123\x{100}" =~ /^.*1.*23\x{100}$/,
+ 'UTF-8 + multiple floating substr';
+ }
+
+
+ {
+ local $Message = '<20030808193656.5109.1 at llama.ni-s.u-net.com>';
+
+ # LATIN SMALL/CAPITAL LETTER A WITH MACRON
+ ok " \x{101}" =~ qr/\x{100}/i;
+
+ # LATIN SMALL/CAPITAL LETTER A WITH RING BELOW
+ ok " \x{1E01}" =~ qr/\x{1E00}/i;
+
+ # DESERET SMALL/CAPITAL LETTER LONG I
+ ok " \x{10428}" =~ qr/\x{10400}/i;
+
+ # LATIN SMALL/CAPITAL LETTER A WITH RING BELOW + 'X'
+ ok " \x{1E01}x" =~ qr/\x{1E00}X/i;
+ }
+
+
+ {
+ # [perl #23769] Unicode regex broken on simple example
+ # regrepeat() didn't handle UTF-8 EXACT case right.
+ local $BugId = '23769';
+ my $Mess = 'regrepeat() handles UTF-8 EXACT case right';
+ local $Message = $Mess;
+
+ my $s = "\x{a0}\x{a0}\x{a0}\x{100}"; chop $s;
+
+ ok $s =~ /\x{a0}/;
+ ok $s =~ /\x{a0}+/;
+ ok $s =~ /\x{a0}\x{a0}/;
+
+ $Message = "$Mess (easy variant)";
+ ok "aaa\x{100}" =~ /(a+)/;
+ iseq $1, "aaa";
+
+ $Message = "$Mess (easy invariant)";
+ ok "aaa\x{100} " =~ /(a+?)/;
+ iseq $1, "a";
+
+ $Message = "$Mess (regrepeat variant)";
+ ok "\xa0\xa0\xa0\x{100} " =~ /(\xa0+?)/;
+ iseq $1, "\xa0";
+
+ $Message = "$Mess (regrepeat invariant)";
+ ok "\xa0\xa0\xa0\x{100}" =~ /(\xa0+)/;
+ iseq $1, "\xa0\xa0\xa0";
+
+ $Message = "$Mess (hard variant)";
+ ok "\xa0\xa1\xa0\xa1\xa0\xa1\x{100}" =~ /((?:\xa0\xa1)+?)/;
+ iseq $1, "\xa0\xa1";
+
+ $Message = "$Mess (hard invariant)";
+ ok "ababab\x{100} " =~ /((?:ab)+)/;
+ iseq $1, 'ababab';
+
+ ok "\xa0\xa1\xa0\xa1\xa0\xa1\x{100}" =~ /((?:\xa0\xa1)+)/;
+ iseq $1, "\xa0\xa1\xa0\xa1\xa0\xa1";
+
+ ok "ababab\x{100} " =~ /((?:ab)+?)/;
+ iseq $1, "ab";
+
+ $Message = "Don't match first byte of UTF-8 representation";
+ ok "\xc4\xc4\xc4" !~ /(\x{100}+)/;
+ ok "\xc4\xc4\xc4" !~ /(\x{100}+?)/;
+ ok "\xc4\xc4\xc4" !~ /(\x{100}++)/;
+ }
+
+
+ {
+ for (120 .. 130) {
+ my $head = 'x' x $_;
+ local $Message = q [Don't misparse \x{...} in regexp ] .
+ q [near 127 char EXACT limit];
+ for my $tail ('\x{0061}', '\x{1234}', '\x61') {
+ eval_ok qq ["$head$tail" =~ /$head$tail/];
+ }
+ local $Message = q [Don't misparse \N{...} in regexp ] .
+ q [near 127 char EXACT limit];
+ for my $tail ('\N{SNOWFLAKE}') {
+ eval_ok qq [use charnames ':full';
+ "$head$tail" =~ /$head$tail/];
+ }
+ }
+ }
+
+
+ {
+ # perl panic: pp_match start/end pointers
+ local $BugId = '25269';
+ iseq "a-bc", eval {my ($x, $y) = "bca" =~ /^(?=.*(a)).*(bc)/; "$x-$y"},
+ 'Captures can move backwards in string';
+ }
+
+
+ {
+ local $BugId = '27940'; # \cA not recognized in character classes
+ ok "a\cAb" =~ /\cA/, '\cA in pattern';
+ ok "a\cAb" =~ /[\cA]/, '\cA in character class';
+ ok "a\cAb" =~ /[\cA-\cB]/, '\cA in character class range';
+ ok "abc" =~ /[^\cA-\cB]/, '\cA in negated character class range';
+ ok "a\cBb" =~ /[\cA-\cC]/, '\cB in character class range';
+ ok "a\cCbc" =~ /[^\cA-\cB]/, '\cC in negated character class range';
+ ok "a\cAb" =~ /(??{"\cA"})/, '\cA in ??{} pattern';
+ ok "ab" !~ /a\cIb/x, '\cI in pattern';
+ }
+
+
+ {
+ # perl #28532: optional zero-width match at end of string is ignored
+ local $BugId = '28532';
+ ok "abc" =~ /^abc(\z)?/ && defined($1),
+ 'Optional zero-width match at end of string';
+ ok "abc" =~ /^abc(\z)??/ && !defined($1),
+ 'Optional zero-width match at end of string';
+ }
+
+
+
+ { # TRIE related
+ our @got = ();
+ "words" =~ /(word|word|word)(?{push @got, $1})s$/;
+ iseq @got, 1, "TRIE optimation";
+
+ @got = ();
+ "words" =~ /(word|word|word)(?{push @got,$1})s$/i;
+ iseq @got, 1,"TRIEF optimisation";
+
+ my @nums = map {int rand 1000} 1 .. 100;
+ my $re = "(" . (join "|", @nums) . ")";
+ $re = qr/\b$re\b/;
+
+ foreach (@nums) {
+ ok $_ =~ /$re/, "Trie nums";
+ }
+
+ $_ = join " ", @nums;
+ @got = ();
+ push @got, $1 while /$re/g;
+
+ my %count;
+ $count {$_} ++ for @got;
+ my $ok = 1;
+ for (@nums) {
+ $ok = 0 if --$count {$_} < 0;
+ }
+ ok $ok, "Trie min count matches";
+ }
+
+
+ {
+ # TRIE related
+ # LATIN SMALL/CAPITAL LETTER A WITH MACRON
+ ok "foba \x{101}foo" =~ qr/(foo|\x{100}foo|bar)/i &&
+ $1 eq "\x{101}foo",
+ "TRIEF + LATIN SMALL/CAPITAL LETTER A WITH MACRON";
+
+ # LATIN SMALL/CAPITAL LETTER A WITH RING BELOW
+ ok "foba \x{1E01}foo" =~ qr/(foo|\x{1E00}foo|bar)/i &&
+ $1 eq "\x{1E01}foo",
+ "TRIEF + LATIN SMALL/CAPITAL LETTER A WITH RING BELOW";
+
+ # DESERET SMALL/CAPITAL LETTER LONG I
+ ok "foba \x{10428}foo" =~ qr/(foo|\x{10400}foo|bar)/i &&
+ $1 eq "\x{10428}foo",
+ "TRIEF + DESERET SMALL/CAPITAL LETTER LONG I";
+
+ # LATIN SMALL/CAPITAL LETTER A WITH RING BELOW + 'X'
+ ok "foba \x{1E01}xfoo" =~ qr/(foo|\x{1E00}Xfoo|bar)/i &&
+ $1 eq "\x{1E01}xfoo",
+ "TRIEF + LATIN SMALL/CAPITAL LETTER A WITH RING BELOW + 'X'";
+
+ use charnames ':full';
+
+ my $s = "\N{LATIN SMALL LETTER SHARP S}";
+ ok "foba ba$s" =~ qr/(foo|Ba$s|bar)/i && $1 eq "ba$s",
+ "TRIEF + LATIN SMALL LETTER SHARP S =~ ss";
+ ok "foba ba$s" =~ qr/(Ba$s|foo|bar)/i && $1 eq "ba$s",
+ "TRIEF + LATIN SMALL LETTER SHARP S =~ ss";
+ ok "foba ba$s" =~ qr/(foo|bar|Ba$s)/i && $1 eq "ba$s",
+ "TRIEF + LATIN SMALL LETTER SHARP S =~ ss";
+
+ ok "foba ba$s" =~ qr/(foo|Bass|bar)/i && $1 eq "ba$s",
+ "TRIEF + LATIN SMALL LETTER SHARP S =~ ss";
+
+ ok "foba ba$s" =~ qr/(foo|BaSS|bar)/i && $1 eq "ba$s",
+ "TRIEF + LATIN SMALL LETTER SHARP S =~ SS";
+
+ ok "foba ba${s}pxySS$s$s" =~ qr/(b(?:a${s}t|a${s}f|a${s}p)[xy]+$s*)/i
+ && $1 eq "ba${s}pxySS$s$s",
+ "COMMON PREFIX TRIEF + LATIN SMALL LETTER SHARP S";
+ }
+
+
+ SKIP:
+ {
+ print "# Set PERL_SKIP_PSYCHO_TEST to skip this test\n";
+ my @normal = qw [the are some normal words];
+
+ skip "Skipped Psycho", 2 * @normal if $ENV {PERL_SKIP_PSYCHO_TEST};
+
+ local $" = "|";
+
+ my @psycho = (@normal, map chr $_, 255 .. 20000);
+ my $psycho1 = "@psycho";
+ for (my $i = @psycho; -- $i;) {
+ my $j = int rand (1 + $i);
+ @psycho [$i, $j] = @psycho [$j, $i];
+ }
+ my $psycho2 = "@psycho";
+
+ foreach my $word (@normal) {
+ ok $word =~ /($psycho1)/ && $1 eq $word, 'Psycho';
+ ok $word =~ /($psycho2)/ && $1 eq $word, 'Psycho';
+ }
+ }
+
+
+ {
+ local $BugId = '36207';
+ my $utf8 = "\xe9\x{100}"; chop $utf8;
+ my $latin1 = "\xe9";
+
+ ok $utf8 =~ /\xe9/i, "utf8/latin";
+ ok $utf8 =~ /$latin1/i, "utf8/latin runtime";
+ ok $utf8 =~ /(abc|\xe9)/i, "utf8/latin trie";
+ ok $utf8 =~ /(abc|$latin1)/i, "utf8/latin trie runtime";
+
+ ok "\xe9" =~ /$utf8/i, "latin/utf8";
+ ok "\xe9" =~ /(abc|$utf8)/i, "latin/utf8 trie";
+ ok $latin1 =~ /$utf8/i, "latin/utf8 runtime";
+ ok $latin1 =~ /(abc|$utf8)/i, "latin/utf8 trie runtime";
+ }
+
+
+ {
+ local $BugId = '37038';
+ my $s = "abcd";
+ $s =~ /(..)(..)/g;
+ $s = $1;
+ $s = $2;
+ iseq $2, 'cd',
+ "Assigning to original string does not corrupt match vars";
+ }
+
+
+ {
+ {
+ package wooosh;
+ sub gloople {"!"}
+ }
+ my $aeek = bless {} => 'wooosh';
+ eval_ok sub {$aeek -> gloople () =~ /(.)/g},
+ "//g match against return value of sub";
+
+ sub gloople {"!"}
+ eval_ok sub {gloople () =~ /(.)/g},
+ "26410 didn't affect sub calls for some reason";
+ }
+
+
+ {
+ local $TODO = "See changes 26925-26928, which reverted change 26410";
+ {
+ package lv;
+ our $var = "abc";
+ sub variable : lvalue {$var}
+ }
+ my $o = bless [] => 'lv';
+ my $f = "";
+ my $r = eval {
+ for (1 .. 2) {
+ $f .= $1 if $o -> variable =~ /(.)/g;
+ }
+ 1;
+ };
+ if ($r) {
+ iseq $f, "ab", "pos() retained between calls";
+ }
+ else {
+ local $TODO;
+ ok 0, "Code failed: $@";
+ }
+
+ our $var = "abc";
+ sub variable : lvalue {$var}
+ my $g = "";
+ my $s = eval {
+ for (1 .. 2) {
+ $g .= $1 if variable =~ /(.)/g;
+ }
+ 1;
+ };
+ if ($s) {
+ iseq $g, "ab", "pos() retained between calls";
+ }
+ else {
+ local $TODO;
+ ok 0, "Code failed: $@";
+ }
+ }
+
+
+ SKIP:
+ {
+ local $BugId = '37836';
+ skip "In EBCDIC" if $IS_EBCDIC;
+ no warnings 'utf8';
+ $_ = pack 'U0C2', 0xa2, 0xf8; # Ill-formed UTF-8
+ my $ret = 0;
+ eval_ok sub {!($ret = s/[\0]+//g)},
+ "Ill-formed UTF-8 doesn't match NUL in class";
+ }
+
+
+ {
+ # chr(65535) should be allowed in regexes
+ local $BugId = '38293';
+ no warnings 'utf8'; # To allow non-characters
+ my ($c, $r, $s);
+
+ $c = chr 0xffff;
+ $c =~ s/$c//g;
+ ok $c eq "", "U+FFFF, parsed as atom";
+
+ $c = chr 0xffff;
+ $r = "\\$c";
+ $c =~ s/$r//g;
+ ok $c eq "", "U+FFFF backslashed, parsed as atom";
+
+ $c = chr 0xffff;
+ $c =~ s/[$c]//g;
+ ok $c eq "", "U+FFFF, parsed in class";
+
+ $c = chr 0xffff;
+ $r = "[\\$c]";
+ $c =~ s/$r//g;
+ ok $c eq "", "U+FFFF backslashed, parsed in class";
+
+ $s = "A\x{ffff}B";
+ $s =~ s/\x{ffff}//i;
+ ok $s eq "AB", "U+FFFF, EXACTF";
+
+ $s = "\x{ffff}A";
+ $s =~ s/\bA//;
+ ok $s eq "\x{ffff}", "U+FFFF, BOUND";
+
+ $s = "\x{ffff}!";
+ $s =~ s/\B!//;
+ ok $s eq "\x{ffff}", "U+FFFF, NBOUND";
+ }
+
+
+ {
+ local $BugId = '39583';
+
+ # The printing characters
+ my @chars = ("A" .. "Z");
+ my $delim = ",";
+ my $size = 32771 - 4;
+ my $str = '';
+
+ # Create some random junk. Inefficient, but it works.
+ for (my $i = 0; $i < $size; $ i++) {
+ $str .= $chars [rand @chars];
+ }
+
+ $str .= ($delim x 4);
+ my $res;
+ my $matched;
+ ok $str =~ s/^(.*?)${delim}{4}//s, "Pattern matches";
+ iseq $str, "", "Empty string";
+ ok defined $1 && length ($1) == $size, '$1 is correct size';
+ }
+
+
+ {
+ local $BugId = '27940';
+ ok "\0-A" =~ /\c at -A/, '@- should not be interpolated in a pattern';
+ ok "\0\0A" =~ /\c at +A/, '@+ should not be interpolated in a pattern';
+ ok "X\@-A" =~ /X at -A/, '@- should not be interpolated in a pattern';
+ ok "X\@\@A" =~ /X at +A/, '@+ should not be interpolated in a pattern';
+
+ ok "X\0A" =~ /X\c@?A/, '\c@?';
+ ok "X\0A" =~ /X\c@*A/, '\c@*';
+ ok "X\0A" =~ /X\c@(A)/, '\c@(';
+ ok "X\0A" =~ /X(\c@)A/, '\c@)';
+ ok "X\0A" =~ /X\c@|ZA/, '\c@|';
+
+ ok "X\@A" =~ /X@?A/, '@?';
+ ok "X\@A" =~ /X@*A/, '@*';
+ ok "X\@A" =~ /X@(A)/, '@(';
+ ok "X\@A" =~ /X(@)A/, '@)';
+ ok "X\@A" =~ /X@|ZA/, '@|';
+
+ local $" = ','; # non-whitespace and non-RE-specific
+ ok 'abc' =~ /(.)(.)(.)/, 'The last successful match is bogus';
+ ok "A at +B" =~ /A@{+}B/, 'Interpolation of @+ in /@{+}/';
+ ok "A at -B" =~ /A@{-}B/, 'Interpolation of @- in /@{-}/';
+ ok "A at +B" =~ /A@{+}B/x, 'Interpolation of @+ in /@{+}/x';
+ ok "A at -B" =~ /A@{-}B/x, 'Interpolation of @- in /@{-}/x';
+ }
+
+
+ {
+ use lib 'lib';
+ use Cname;
+
+ ok 'fooB' =~ /\N{foo}[\N{B}\N{b}]/, "Passthrough charname";
+ my $test = 1233;
+ #
+ # Why doesn't must_warn work here?
+ #
+ my $w;
+ local $SIG {__WARN__} = sub {$w .= "@_"};
+ eval 'q(xxWxx) =~ /[\N{WARN}]/';
+ ok $w && $w =~ /^Ignoring excess chars from/,
+ "Ignoring excess chars warning";
+
+ undef $w;
+ eval q [ok "\0" !~ /[\N{EMPTY-STR}XY]/,
+ "Zerolength charname in charclass doesn't match \\0"];
+ ok $w && $w =~ /^Ignoring zero length/,
+ 'Ignoring zero length \N{%} in character class warning';
+
+ ok 'AB' =~ /(\N{EVIL})/ && $1 eq 'A', 'Charname caching $1';
+ ok 'ABC' =~ /(\N{EVIL})/, 'Charname caching $1';
+ ok 'xy' =~ /x\N{EMPTY-STR}y/,
+ 'Empty string charname produces NOTHING node';
+ ok '' =~ /\N{EMPTY-STR}/,
+ 'Empty string charname produces NOTHING node';
+
+ }
+
+
+ {
+ use charnames ':full';
+
+ ok 'aabc' !~ /a\N{PLUS SIGN}b/, '/a\N{PLUS SIGN}b/ against aabc';
+ ok 'a+bc' =~ /a\N{PLUS SIGN}b/, '/a\N{PLUS SIGN}b/ against a+bc';
+
+ ok ' A B' =~ /\N{SPACE}\N{U+0041}\N{SPACE}\N{U+0042}/,
+ 'Intermixed named and unicode escapes';
+ ok "\N{SPACE}\N{U+0041}\N{SPACE}\N{U+0042}" =~
+ /\N{SPACE}\N{U+0041}\N{SPACE}\N{U+0042}/,
+ 'Intermixed named and unicode escapes';
+ ok "\N{SPACE}\N{U+0041}\N{SPACE}\N{U+0042}" =~
+ /[\N{SPACE}\N{U+0041}][\N{SPACE}\N{U+0042}]/,
+ 'Intermixed named and unicode escapes';
+ }
+
+
+ {
+ our $brackets;
+ $brackets = qr{
+ { (?> [^{}]+ | (??{ $brackets }) )* }
+ }x;
+
+ ok "{b{c}d" !~ m/^((??{ $brackets }))/, "Bracket mismatch";
+
+ SKIP: {
+ our @stack = ();
+ my @expect = qw(
+ stuff1
+ stuff2
+ <stuff1>and<stuff2>
+ right
+ <right>
+ <<right>>
+ <<<right>>>
+ <<stuff1>and<stuff2>><<<<right>>>>
+ );
+
+ local $_ = '<<<stuff1>and<stuff2>><<<<right>>>>>';
+ ok /^(<((?:(?>[^<>]+)|(?1))*)>(?{push @stack, $2 }))$/,
+ "Recursion matches";
+ iseq @stack, @expect, "Right amount of matches"
+ or skip "Won't test individual results as count isn't equal",
+ 0 + @expect;
+ my $idx = 0;
+ foreach my $expect (@expect) {
+ iseq $stack [$idx], $expect,
+ "Expecting '$expect' at stack pos #$idx";
+ $idx ++;
+ }
+ }
+ }
+
+
+ {
+ my $s = '123453456';
+ $s =~ s/(?<digits>\d+)\k<digits>/$+{digits}/;
+ ok $s eq '123456', 'Named capture (angle brackets) s///';
+ $s = '123453456';
+ $s =~ s/(?'digits'\d+)\k'digits'/$+{digits}/;
+ ok $s eq '123456', 'Named capture (single quotes) s///';
+ }
+
+
+ {
+ my @ary = (
+ pack('U', 0x00F1), # n-tilde
+ '_'.pack('U', 0x00F1), # _ + n-tilde
+ 'c'.pack('U', 0x0327), # c + cedilla
+ pack('U*', 0x00F1, 0x0327), # n-tilde + cedilla
+ 'a'.pack('U', 0x00B2), # a + superscript two
+ pack('U', 0x0391), # ALPHA
+ pack('U', 0x0391).'2', # ALPHA + 2
+ pack('U', 0x0391).'_', # ALPHA + _
+ );
+
+ for my $uni (@ary) {
+ my ($r1, $c1, $r2, $c2) = eval qq {
+ use utf8;
+ scalar ("..foo foo.." =~ /(?'${uni}'foo) \\k'${uni}'/),
+ \$+{${uni}},
+ scalar ("..bar bar.." =~ /(?<${uni}>bar) \\k<${uni}>/),
+ \$+{${uni}};
+ };
+ ok $r1, "Named capture UTF (?'')";
+ ok defined $c1 && $c1 eq 'foo', "Named capture UTF \%+";
+ ok $r2, "Named capture UTF (?<>)";
+ ok defined $c2 && $c2 eq 'bar', "Named capture UTF \%+";
+ }
+ }
+
+
+ {
+ my $s = 'foo bar baz';
+ my (@k, @v, @fetch, $res);
+ my $count = 0;
+ my @names = qw ($+{A} $+{B} $+{C});
+ if ($s =~ /(?<A>foo)\s+(?<B>bar)?\s+(?<C>baz)/) {
+ while (my ($k, $v) = each (%+)) {
+ $count++;
+ }
+ @k = sort keys (%+);
+ @v = sort values (%+);
+ $res = 1;
+ push @fetch,
+ ["$+{A}", "$1"],
+ ["$+{B}", "$2"],
+ ["$+{C}", "$3"],
+ ;
+ }
+ foreach (0 .. 2) {
+ if ($fetch [$_]) {
+ iseq $fetch [$_] [0], $fetch [$_] [1], $names [$_];
+ } else {
+ ok 0, $names[$_];
+ }
+ }
+ iseq $res, 1, "'$s' =~ /(?<A>foo)\\s+(?<B>bar)?\\s+(?<C>baz)/";
+ iseq $count, 3, "Got 3 keys in %+ via each";
+ iseq 0 + @k, 3, 'Got 3 keys in %+ via keys';
+ iseq "@k", "A B C", "Got expected keys";
+ iseq "@v", "bar baz foo", "Got expected values";
+ eval '
+ no warnings "uninitialized";
+ print for $+ {this_key_doesnt_exist};
+ ';
+ ok !$@, 'lvalue $+ {...} should not throw an exception';
+ }
+
+
+ {
+ #
+ # Almost the same as the block above, except that the capture is nested.
+ #
+ local $BugId = '50496';
+ my $s = 'foo bar baz';
+ my (@k, @v, @fetch, $res);
+ my $count = 0;
+ my @names = qw ($+{A} $+{B} $+{C} $+{D});
+ if ($s =~ /(?<D>(?<A>foo)\s+(?<B>bar)?\s+(?<C>baz))/) {
+ while (my ($k,$v) = each(%+)) {
+ $count++;
+ }
+ @k = sort keys (%+);
+ @v = sort values (%+);
+ $res = 1;
+ push @fetch,
+ ["$+{A}", "$2"],
+ ["$+{B}", "$3"],
+ ["$+{C}", "$4"],
+ ["$+{D}", "$1"],
+ ;
+ }
+ foreach (0 .. 3) {
+ if ($fetch [$_]) {
+ iseq $fetch [$_] [0], $fetch [$_] [1], $names [$_];
+ } else {
+ ok 0, $names [$_];
+ }
+ }
+ iseq $res, 1, "'$s' =~ /(?<D>(?<A>foo)\\s+(?<B>bar)?\\s+(?<C>baz))/";
+ iseq $count, 4, "Got 4 keys in %+ via each";
+ iseq @k, 4, 'Got 4 keys in %+ via keys';
+ iseq "@k", "A B C D", "Got expected keys";
+ iseq "@v", "bar baz foo foo bar baz", "Got expected values";
+ eval '
+ no warnings "uninitialized";
+ print for $+ {this_key_doesnt_exist};
+ ';
+ ok !$@,'lvalue $+ {...} should not throw an exception';
+ }
+
+
+ {
+ my $s = 'foo bar baz';
+ my @res;
+ if ('1234' =~ /(?<A>1)(?<B>2)(?<A>3)(?<B>4)/) {
+ foreach my $name (sort keys(%-)) {
+ my $ary = $- {$name};
+ foreach my $idx (0 .. $#$ary) {
+ push @res, "$name:$idx:$ary->[$idx]";
+ }
+ }
+ }
+ my @expect = qw (A:0:1 A:1:3 B:0:2 B:1:4);
+ iseq "@res", "@expect", "Check %-";
+ eval'
+ no warnings "uninitialized";
+ print for $- {this_key_doesnt_exist};
+ ';
+ ok !$@,'lvalue $- {...} should not throw an exception';
+ }
+
+
+ SKIP:
+ {
+ # stress test CURLYX/WHILEM.
+ #
+ # This test includes varying levels of nesting, and according to
+ # profiling done against build 28905, exercises every code line in the
+ # CURLYX and WHILEM blocks, except those related to LONGJMP, the
+ # super-linear cache and warnings. It executes about 0.5M regexes
+
+ skip "No psycho tests" if $ENV {PERL_SKIP_PSYCHO_TEST};
+ print "# Set PERL_SKIP_PSYCHO_TEST to skip this test\n";
+ my $r = qr/^
+ (?:
+ ( (?:a|z+)+ )
+ (?:
+ ( (?:b|z+){3,}? )
+ (
+ (?:
+ (?:
+ (?:c|z+){1,1}?z
+ )?
+ (?:c|z+){1,1}
+ )*
+ )
+ (?:z*){2,}
+ ( (?:z+|d)+ )
+ (?:
+ ( (?:e|z+)+ )
+ )*
+ ( (?:f|z+)+ )
+ )*
+ ( (?:z+|g)+ )
+ (?:
+ ( (?:h|z+)+ )
+ )*
+ ( (?:i|z+)+ )
+ )+
+ ( (?:j|z+)+ )
+ (?:
+ ( (?:k|z+)+ )
+ )*
+ ( (?:l|z+)+ )
+ $/x;
+
+ my $ok = 1;
+ my $msg = "CURLYX stress test";
+ OUTER:
+ for my $a ("x","a","aa") {
+ for my $b ("x","bbb","bbbb") {
+ my $bs = $a.$b;
+ for my $c ("x","c","cc") {
+ my $cs = $bs.$c;
+ for my $d ("x","d","dd") {
+ my $ds = $cs.$d;
+ for my $e ("x","e","ee") {
+ my $es = $ds.$e;
+ for my $f ("x","f","ff") {
+ my $fs = $es.$f;
+ for my $g ("x","g","gg") {
+ my $gs = $fs.$g;
+ for my $h ("x","h","hh") {
+ my $hs = $gs.$h;
+ for my $i ("x","i","ii") {
+ my $is = $hs.$i;
+ for my $j ("x","j","jj") {
+ my $js = $is.$j;
+ for my $k ("x","k","kk") {
+ my $ks = $js.$k;
+ for my $l ("x","l","ll") {
+ my $ls = $ks.$l;
+ if ($ls =~ $r) {
+ if ($ls =~ /x/) {
+ $msg .= ": unexpected match for [$ls]";
+ $ok = 0;
+ last OUTER;
+ }
+ my $cap = "$1$2$3$4$5$6$7$8$9$10$11$12";
+ unless ($ls eq $cap) {
+ $msg .= ": capture: [$ls], got [$cap]";
+ $ok = 0;
+ last OUTER;
+ }
+ }
+ else {
+ unless ($ls =~ /x/) {
+ $msg = ": failed for [$ls]";
+ $ok = 0;
+ last OUTER;
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ ok($ok, $msg);
+ }
+
+
+ {
+ # \, breaks {3,4}
+ ok "xaaay" !~ /xa{3\,4}y/, '\, in a pattern';
+ ok "xa{3,4}y" =~ /xa{3\,4}y/, '\, in a pattern';
+
+ # \c\ followed by _
+ ok "x\c_y" !~ /x\c\_y/, '\_ in a pattern';
+ ok "x\c\_y" =~ /x\c\_y/, '\_ in a pattern';
+
+ # \c\ followed by other characters
+ for my $c ("z", "\0", "!", chr(254), chr(256)) {
+ my $targ = "a\034$c";
+ my $reg = "a\\c\\$c";
+ ok eval ("qq/$targ/ =~ /$reg/"), "\\c\\ in pattern";
+ }
+ }
+
+
+ {
+ local $BugId = '36046';
+ my $str = 'abc';
+ my $count = 0;
+ my $mval = 0;
+ my $pval = 0;
+ while ($str =~ /b/g) {$mval = $#-; $pval = $#+; $count ++}
+ iseq $mval, 0, '@- should be empty';
+ iseq $pval, 0, '@+ should be empty';
+ iseq $count, 1, 'Should have matched once only';
+ }
+
+
+ { # Test the (*PRUNE) pattern
+ our $count = 0;
+ 'aaab' =~ /a+b?(?{$count++})(*FAIL)/;
+ iseq $count, 9, "Expect 9 for no (*PRUNE)";
+ $count = 0;
+ 'aaab' =~ /a+b?(*PRUNE)(?{$count++})(*FAIL)/;
+ iseq $count, 3, "Expect 3 with (*PRUNE)";
+ local $_ = 'aaab';
+ $count = 0;
+ 1 while /.(*PRUNE)(?{$count++})(*FAIL)/g;
+ iseq $count, 4, "/.(*PRUNE)/";
+ $count = 0;
+ 'aaab' =~ /a+b?(??{'(*PRUNE)'})(?{$count++})(*FAIL)/;
+ iseq $count, 3, "Expect 3 with (*PRUNE)";
+ local $_ = 'aaab';
+ $count = 0;
+ 1 while /.(??{'(*PRUNE)'})(?{$count++})(*FAIL)/g;
+ iseq $count, 4, "/.(*PRUNE)/";
+ }
+
+
+ { # Test the (*SKIP) pattern
+ our $count = 0;
+ 'aaab' =~ /a+b?(*SKIP)(?{$count++})(*FAIL)/;
+ iseq $count, 1, "Expect 1 with (*SKIP)";
+ local $_ = 'aaab';
+ $count = 0;
+ 1 while /.(*SKIP)(?{$count++})(*FAIL)/g;
+ iseq $count, 4, "/.(*SKIP)/";
+ $_ = 'aaabaaab';
+ $count = 0;
+ our @res = ();
+ 1 while /(a+b?)(*SKIP)(?{$count++; push @res,$1})(*FAIL)/g;
+ iseq $count, 2, "Expect 2 with (*SKIP)";
+ iseq "@res", "aaab aaab", "Adjacent (*SKIP) works as expected";
+ }
+
+
+ { # Test the (*SKIP) pattern
+ our $count = 0;
+ 'aaab' =~ /a+b?(*MARK:foo)(*SKIP)(?{$count++})(*FAIL)/;
+ iseq $count, 1, "Expect 1 with (*SKIP)";
+ local $_ = 'aaab';
+ $count = 0;
+ 1 while /.(*MARK:foo)(*SKIP)(?{$count++})(*FAIL)/g;
+ iseq $count, 4, "/.(*SKIP)/";
+ $_ = 'aaabaaab';
+ $count = 0;
+ our @res = ();
+ 1 while /(a+b?)(*MARK:foo)(*SKIP)(?{$count++; push @res,$1})(*FAIL)/g;
+ iseq $count, 2, "Expect 2 with (*SKIP)";
+ iseq "@res", "aaab aaab", "Adjacent (*SKIP) works as expected";
+ }
+
+
+ { # Test the (*SKIP) pattern
+ our $count = 0;
+ 'aaab' =~ /a*(*MARK:a)b?(*MARK:b)(*SKIP:a)(?{$count++})(*FAIL)/;
+ iseq $count, 3, "Expect 3 with *MARK:a)b?(*MARK:b)(*SKIP:a)";
+ local $_ = 'aaabaaab';
+ $count = 0;
+ our @res = ();
+ 1 while
+ /(a*(*MARK:a)b?)(*MARK:x)(*SKIP:a)(?{$count++; push @res,$1})(*FAIL)/g;
+ iseq $count, 5, "Expect 5 with (*MARK:a)b?)(*MARK:x)(*SKIP:a)";
+ iseq "@res", "aaab b aaab b ",
+ "Adjacent (*MARK:a)b?)(*MARK:x)(*SKIP:a) works as expected";
+ }
+
+
+ { # Test the (*COMMIT) pattern
+ our $count = 0;
+ 'aaabaaab' =~ /a+b?(*COMMIT)(?{$count++})(*FAIL)/;
+ iseq $count, 1, "Expect 1 with (*COMMIT)";
+ local $_ = 'aaab';
+ $count = 0;
+ 1 while /.(*COMMIT)(?{$count++})(*FAIL)/g;
+ iseq $count, 1, "/.(*COMMIT)/";
+ $_ = 'aaabaaab';
+ $count = 0;
+ our @res = ();
+ 1 while /(a+b?)(*COMMIT)(?{$count++; push @res,$1})(*FAIL)/g;
+ iseq $count, 1, "Expect 1 with (*COMMIT)";
+ iseq "@res", "aaab", "Adjacent (*COMMIT) works as expected";
+ }
+
+
+ {
+ # Test named commits and the $REGERROR var
+ our $REGERROR;
+ for my $name ('', ':foo') {
+ for my $pat ("(*PRUNE$name)",
+ ($name ? "(*MARK$name)" : "") . "(*SKIP$name)",
+ "(*COMMIT$name)") {
+ for my $suffix ('(*FAIL)', '') {
+ 'aaaab' =~ /a+b$pat$suffix/;
+ iseq $REGERROR,
+ ($suffix ? ($name ? 'foo' : "1") : ""),
+ "Test $pat and \$REGERROR $suffix";
+ }
+ }
+ }
+ }
+
+
+ {
+ # Test named commits and the $REGERROR var
+ package Fnorble;
+ our $REGERROR;
+ for my $name ('', ':foo') {
+ for my $pat ("(*PRUNE$name)",
+ ($name ? "(*MARK$name)" : "") . "(*SKIP$name)",
+ "(*COMMIT$name)") {
+ for my $suffix ('(*FAIL)','') {
+ 'aaaab' =~ /a+b$pat$suffix/;
+ ::iseq $REGERROR,
+ ($suffix ? ($name ? 'foo' : "1") : ""),
+ "Test $pat and \$REGERROR $suffix";
+ }
+ }
+ }
+ }
+
+
+ {
+ # Test named commits and the $REGERROR var
+ local $Message = '$REGERROR';
+ our $REGERROR;
+ for my $word (qw (bar baz bop)) {
+ $REGERROR = "";
+ "aaaaa$word" =~
+ /a+(?:bar(*COMMIT:bar)|baz(*COMMIT:baz)|bop(*COMMIT:bop))(*FAIL)/;
+ iseq $REGERROR, $word;
+ }
+ }
+
+
+ {
+ local $BugId = '40684';
+ local $Message = '/m in precompiled regexp';
+ my $s = "abc\ndef";
+ my $rex = qr'^abc$'m;
+ ok $s =~ m/$rex/;
+ ok $s =~ m/^abc$/m;
+ }
+
+
+ {
+ #Mindnumbingly simple test of (*THEN)
+ for ("ABC","BAX") {
+ ok /A (*THEN) X | B (*THEN) C/x, "Simple (*THEN) test";
+ }
+ }
+
+
+ {
+ local $Message = "Relative Recursion";
+ my $parens = qr/(\((?:[^()]++|(?-1))*+\))/;
+ local $_ = 'foo((2*3)+4-3) + bar(2*(3+4)-1*(2-3))';
+ my ($all, $one, $two) = ('', '', '');
+ ok /foo $parens \s* \+ \s* bar $parens/x;
+ iseq $1, '((2*3)+4-3)';
+ iseq $2, '(2*(3+4)-1*(2-3))';
+ iseq $&, 'foo((2*3)+4-3) + bar(2*(3+4)-1*(2-3))';
+ iseq $&, $_;
+ }
+
+ {
+ my $spaces=" ";
+ local $_ = join 'bar', $spaces, $spaces;
+ our $count = 0;
+ s/(?>\s+bar)(?{$count++})//g;
+ iseq $_, $spaces, "SUSPEND final string";
+ iseq $count, 1, "Optimiser should have prevented more than one match";
+ }
+
+ {
+ local $BugId = '36909';
+ local $Message = '(?: ... )? should not lose $^R';
+ $^R = 'Nothing';
+ {
+ local $^R = "Bad";
+ ok 'x foofoo y' =~ m {
+ (foo) # $^R correctly set
+ (?{ "last regexp code result" })
+ }x;
+ iseq $^R, 'last regexp code result';
+ }
+ iseq $^R, 'Nothing';
+
+ {
+ local $^R = "Bad";
+
+ ok 'x foofoo y' =~ m {
+ (?:foo|bar)+ # $^R correctly set
+ (?{ "last regexp code result" })
+ }x;
+ iseq $^R, 'last regexp code result';
+ }
+ iseq $^R, 'Nothing';
+
+ {
+ local $^R = "Bad";
+ ok 'x foofoo y' =~ m {
+ (foo|bar)\1+ # $^R undefined
+ (?{ "last regexp code result" })
+ }x;
+ iseq $^R, 'last regexp code result';
+ }
+ iseq $^R, 'Nothing';
+
+ {
+ local $^R = "Bad";
+ ok 'x foofoo y' =~ m {
+ (foo|bar)\1 # This time without the +
+ (?{"last regexp code result"})
+ }x;
+ iseq $^R, 'last regexp code result';
+ }
+ iseq $^R, 'Nothing';
+ }
+
+
+ {
+ local $BugId = '22395';
+ local $Message = 'Match is linear, not quadratic';
+ our $count;
+ for my $l (10, 100, 1000) {
+ $count = 0;
+ ('a' x $l) =~ /(.*)(?{$count++})[bc]/;
+ local $TODO = "Should be L+1 not L*(L+3)/2 (L=$l)";
+ iseq $count, $l + 1;
+ }
+ }
+
+
+ {
+ local $BugId = '22614';
+ local $Message = '@-/@+ should not have undefined values';
+ local $_ = 'ab';
+ our @len = ();
+ /(.){1,}(?{push @len,0+ at -})(.){1,}(?{})^/;
+ iseq "@len", "2 2 2";
+ }
+
+
+ {
+ local $BugId = '18209';
+ local $Message = '$& set on s///';
+ my $text = ' word1 word2 word3 word4 word5 word6 ';
+
+ my @words = ('word1', 'word3', 'word5');
+ my $count;
+ foreach my $word (@words) {
+ $text =~ s/$word\s//gi; # Leave a space to seperate words
+ # in the resultant str.
+ # The following block is not working.
+ if ($&) {
+ $count ++;
+ }
+ # End bad block
+ }
+ iseq $count, 3;
+ iseq $text, ' word2 word4 word6 ';
+ }
+
+
+ {
+ # RT#6893
+ local $BugId = '6893';
+ local $_ = qq (A\nB\nC\n);
+ my @res;
+ while (m#(\G|\n)([^\n]*)\n#gsx) {
+ push @res, "$2";
+ last if @res > 3;
+ }
+ iseq "@res", "A B C", "/g pattern shouldn't infinite loop";
+ }
+
+
+ {
+ # From Message-ID: <877ixs6oa6.fsf at k75.linux.bogus>
+ my $dow_name = "nada";
+ my $parser = "(\$dow_name) = \$time_string =~ /(D\x{e9}\\ " .
+ "C\x{e9}adaoin|D\x{e9}\\ Sathairn|\\w+|\x{100})/";
+ my $time_string = "D\x{e9} C\x{e9}adaoin";
+ eval $parser;
+ ok !$@, "Test Eval worked";
+ iseq $dow_name, $time_string, "UTF-8 trie common prefix extraction";
+ }
+
+
+ {
+ my $v;
+ ($v = 'bar') =~ /(\w+)/g;
+ $v = 'foo';
+ iseq "$1", 'bar', '$1 is safe after /g - may fail due ' .
+ 'to specialized config in pp_hot.c'
+ }
+
+
+ {
+ local $Message = "http://nntp.perl.org/group/perl.perl5.porters/118663";
+ my $qr_barR1 = qr/(bar)\g-1/;
+ ok "foobarbarxyz" =~ $qr_barR1;
+ ok "foobarbarxyz" =~ qr/foo${qr_barR1}xyz/;
+ ok "foobarbarxyz" =~ qr/(foo)${qr_barR1}xyz/;
+ ok "foobarbarxyz" =~ qr/(foo)(bar)\g{-1}xyz/;
+ ok "foobarbarxyz" =~ qr/(foo${qr_barR1})xyz/;
+ ok "foobarbarxyz" =~ qr/(foo(bar)\g{-1})xyz/;
+ }
+
+
+ {
+ local $BugId = '41010';
+ local $Message = 'No optimizer bug';
+ my @tails = ('', '(?(1))', '(|)', '()?');
+ my @quants = ('*','+');
+ my $doit = sub {
+ my $pats = shift;
+ for (@_) {
+ for my $pat (@$pats) {
+ for my $quant (@quants) {
+ for my $tail (@tails) {
+ my $re = "($pat$quant\$)$tail";
+ ok /$re/ && $1 eq $_, "'$_' =~ /$re/";
+ ok /$re/m && $1 eq $_, "'$_' =~ /$re/m";
+ }
+ }
+ }
+ }
+ };
+
+ my @dpats = ('\d',
+ '[1234567890]',
+ '(1|[23]|4|[56]|[78]|[90])',
+ '(?:1|[23]|4|[56]|[78]|[90])',
+ '(1|2|3|4|5|6|7|8|9|0)',
+ '(?:1|2|3|4|5|6|7|8|9|0)');
+ my @spats = ('[ ]', ' ', '( |\t)', '(?: |\t)', '[ \t]', '\s');
+ my @sstrs = (' ');
+ my @dstrs = ('12345');
+ $doit -> (\@spats, @sstrs);
+ $doit -> (\@dpats, @dstrs);
+ }
+
+
+ {
+ local $Message = '$REGMARK';
+ our @r = ();
+ our ($REGMARK, $REGERROR);
+ ok 'foofoo' =~ /foo (*MARK:foo) (?{push @r,$REGMARK}) /x;
+ iseq "@r","foo";
+ iseq $REGMARK, "foo";
+ ok 'foofoo' !~ /foo (*MARK:foo) (*FAIL) /x;
+ ok !$REGMARK;
+ iseq $REGERROR, 'foo';
+ }
+
+
+ {
+ local $Message = '\K test';
+ my $x;
+ $x = "abc.def.ghi.jkl";
+ $x =~ s/.*\K\..*//;
+ iseq $x, "abc.def.ghi";
+
+ $x = "one two three four";
+ $x =~ s/o+ \Kthree//g;
+ iseq $x, "one two four";
+
+ $x = "abcde";
+ $x =~ s/(.)\K/$1/g;
+ iseq $x, "aabbccddee";
+ }
+
+
+ {
+ sub kt {
+ return '4' if $_[0] eq '09028623';
+ }
+ # Nested EVAL using PL_curpm (via $1 or friends)
+ my $re;
+ our $grabit = qr/ ([0-6][0-9]{7}) (??{ kt $1 }) [890] /x;
+ $re = qr/^ ( (??{ $grabit }) ) $ /x;
+ my @res = '0902862349' =~ $re;
+ iseq join ("-", @res), "0902862349",
+ 'PL_curpm is set properly on nested eval';
+
+ our $qr = qr/ (o) (??{ $1 }) /x;
+ ok 'boob'=~/( b (??{ $qr }) b )/x && 1, "PL_curpm, nested eval";
+ }
+
+
+ {
+ use charnames ":full";
+ ok "\N{ROMAN NUMERAL ONE}" =~ /\p{Alphabetic}/, "I =~ Alphabetic";
+ ok "\N{ROMAN NUMERAL ONE}" =~ /\p{Uppercase}/, "I =~ Uppercase";
+ ok "\N{ROMAN NUMERAL ONE}" !~ /\p{Lowercase}/, "I !~ Lowercase";
+ ok "\N{ROMAN NUMERAL ONE}" =~ /\p{IDStart}/, "I =~ ID_Start";
+ ok "\N{ROMAN NUMERAL ONE}" =~ /\p{IDContinue}/, "I =~ ID_Continue";
+ ok "\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{Alphabetic}/, "i =~ Alphabetic";
+ ok "\N{SMALL ROMAN NUMERAL ONE}" !~ /\p{Uppercase}/, "i !~ Uppercase";
+ ok "\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{Lowercase}/, "i =~ Lowercase";
+ ok "\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{IDStart}/, "i =~ ID_Start";
+ ok "\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{IDContinue}/, "i =~ ID_Continue"
+ }
+
+
+ {
+ # requirement of Unicode Technical Standard #18, 1.7 Code Points
+ # cf. http://www.unicode.org/reports/tr18/#Supplementary_Characters
+ for my $u (0x7FF, 0x800, 0xFFFF, 0x10000) {
+ no warnings 'utf8'; # oops
+ my $c = chr $u;
+ my $x = sprintf '%04X', $u;
+ ok "A${c}B" =~ /A[\0-\x{10000}]B/, "Unicode range - $x";
+ }
+ }
+
+
+ {
+ my $res="";
+
+ if ('1' =~ /(?|(?<digit>1)|(?<digit>2))/) {
+ $res = "@{$- {digit}}";
+ }
+ iseq $res, "1",
+ "Check that (?|...) doesnt cause dupe entries in the names array";
+
+ $res = "";
+ if ('11' =~ /(?|(?<digit>1)|(?<digit>2))(?&digit)/) {
+ $res = "@{$- {digit}}";
+ }
+ iseq $res, "1", "Check that (?&..) to a buffer inside " .
+ "a (?|...) goes to the leftmost";
+ }
+
+
+ {
+ use warnings;
+ local $Message = "ASCII pattern that really is UTF-8";
+ my @w;
+ local $SIG {__WARN__} = sub {push @w, "@_"};
+ my $c = qq (\x{DF});
+ ok $c =~ /${c}|\x{100}/;
+ ok @w == 0;
+ }
+
+
+ {
+ local $Message = "Corruption of match results of qr// across scopes";
+ my $qr = qr/(fo+)(ba+r)/;
+ 'foobar' =~ /$qr/;
+ iseq "$1$2", "foobar";
+ {
+ 'foooooobaaaaar' =~ /$qr/;
+ iseq "$1$2", 'foooooobaaaaar';
+ }
+ iseq "$1$2", "foobar";
+ }
+
+
+ {
+ local $Message = "HORIZWS";
+ local $_ = "\t \r\n \n \t".chr(11)."\n";
+ s/\H/H/g;
+ s/\h/h/g;
+ iseq $_, "hhHHhHhhHH";
+ $_ = "\t \r\n \n \t" . chr (11) . "\n";
+ utf8::upgrade ($_);
+ s/\H/H/g;
+ s/\h/h/g;
+ iseq $_, "hhHHhHhhHH";
+ }
+
+
+ {
+ local $Message = "Various whitespace special patterns";
+ my @h = map {chr $_} 0x09, 0x20, 0xa0, 0x1680, 0x180e, 0x2000,
+ 0x2001, 0x2002, 0x2003, 0x2004, 0x2005, 0x2006,
+ 0x2007, 0x2008, 0x2009, 0x200a, 0x202f, 0x205f,
+ 0x3000;
+ my @v = map {chr $_} 0x0a, 0x0b, 0x0c, 0x0d, 0x85, 0x2028,
+ 0x2029;
+ my @lb = ("\x0D\x0A", map {chr $_} 0x0A .. 0x0D, 0x85, 0x2028, 0x2029);
+ foreach my $t ([\@h, qr/\h/, qr/\h+/],
+ [\@v, qr/\v/, qr/\v+/],
+ [\@lb, qr/\R/, qr/\R+/],) {
+ my $ary = shift @$t;
+ foreach my $pat (@$t) {
+ foreach my $str (@$ary) {
+ ok $str =~ /($pat)/, $pat;
+ iseq $1, $str, $pat;
+ utf8::upgrade ($str);
+ ok $str =~ /($pat)/, "Upgraded string - $pat";
+ iseq $1, $str, "Upgraded string - $pat";
+ }
+ }
+ }
+ }
+
+
+ {
+ local $Message = "Check that \\xDF match properly in its various forms";
+ # Test that \xDF matches properly. this is pretty hacky stuff,
+ # but its actually needed. The malarky with '-' is to prevent
+ # compilation caching from playing any role in the test.
+ my @df = (chr (0xDF), '-', chr (0xDF));
+ utf8::upgrade ($df [2]);
+ my @strs = ('ss', 'sS', 'Ss', 'SS', chr (0xDF));
+ my @ss = map {("$_", "$_")} @strs;
+ utf8::upgrade ($ss [$_ * 2 + 1]) for 0 .. $#strs;
+
+ for my $ssi (0 .. $#ss) {
+ for my $dfi (0 .. $#df) {
+ my $pat = $df [$dfi];
+ my $str = $ss [$ssi];
+ my $utf_df = ($dfi > 1) ? 'utf8' : '';
+ my $utf_ss = ($ssi % 2) ? 'utf8' : '';
+ (my $sstr = $str) =~ s/\xDF/\\xDF/;
+
+ if ($utf_df || $utf_ss || length ($ss [$ssi]) == 1) {
+ my $ret = $str =~ /$pat/i;
+ next if $pat eq '-';
+ ok $ret, "\"$sstr\" =~ /\\xDF/i " .
+ "(str is @{[$utf_ss||'latin']}, pat is " .
+ "@{[$utf_df||'latin']})";
+ }
+ else {
+ my $ret = $str !~ /$pat/i;
+ next if $pat eq '-';
+ ok $ret, "\"$sstr\" !~ /\\xDF/i " .
+ "(str is @{[$utf_ss||'latin']}, pat is " .
+ "@{[$utf_df||'latin']})";
+ }
+ }
+ }
+ }
+
+
+ {
+ local $Message = "BBC(Bleadperl Breaks CPAN) Today: String::Multibyte";
+ my $re = qr/(?:[\x00-\xFF]{4})/;
+ my $hyp = "\0\0\0-";
+ my $esc = "\0\0\0\\";
+
+ my $str = "$esc$hyp$hyp$esc$esc";
+ my @a = ($str =~ /\G(?:\Q$esc$esc\E|\Q$esc$hyp\E|$re)/g);
+
+ iseq @a,3;
+ local $" = "=";
+ iseq "@a","$esc$hyp=$hyp=$esc$esc";
+ }
+
+
+ {
+ # Test for keys in %+ and %-
+ local $Message = 'Test keys in %+ and %-';
+ no warnings 'uninitialized';
+ my $_ = "abcdef";
+ /(?<foo>a)|(?<foo>b)/;
+ iseq ((join ",", sort keys %+), "foo");
+ iseq ((join ",", sort keys %-), "foo");
+ iseq ((join ",", sort values %+), "a");
+ iseq ((join ",", sort map "@$_", values %-), "a ");
+ /(?<bar>a)(?<bar>b)(?<quux>.)/;
+ iseq ((join ",", sort keys %+), "bar,quux");
+ iseq ((join ",", sort keys %-), "bar,quux");
+ iseq ((join ",", sort values %+), "a,c"); # leftmost
+ iseq ((join ",", sort map "@$_", values %-), "a b,c");
+ /(?<un>a)(?<deux>c)?/; # second buffer won't capture
+ iseq ((join ",", sort keys %+), "un");
+ iseq ((join ",", sort keys %-), "deux,un");
+ iseq ((join ",", sort values %+), "a");
+ iseq ((join ",", sort map "@$_", values %-), ",a");
+ }
+
+
+ {
+ # length() on captures, the numbered ones end up in Perl_magic_len
+ my $_ = "aoeu \xe6var ook";
+ /^ \w+ \s (?<eek>\S+)/x;
+
+ iseq length ($`), 0, q[length $`];
+ iseq length ($'), 4, q[length $'];
+ iseq length ($&), 9, q[length $&];
+ iseq length ($1), 4, q[length $1];
+ iseq length ($+{eek}), 4, q[length $+{eek} == length $1];
+ }
+
+
+ {
+ my $ok = -1;
+
+ $ok = exists ($-{x}) ? 1 : 0 if 'bar' =~ /(?<x>foo)|bar/;
+ iseq $ok, 1, '$-{x} exists after "bar"=~/(?<x>foo)|bar/';
+ iseq scalar (%+), 0, 'scalar %+ == 0 after "bar"=~/(?<x>foo)|bar/';
+ iseq scalar (%-), 1, 'scalar %- == 1 after "bar"=~/(?<x>foo)|bar/';
+
+ $ok = -1;
+ $ok = exists ($+{x}) ? 1 : 0 if 'bar' =~ /(?<x>foo)|bar/;
+ iseq $ok, 0, '$+{x} not exists after "bar"=~/(?<x>foo)|bar/';
+ iseq scalar (%+), 0, 'scalar %+ == 0 after "bar"=~/(?<x>foo)|bar/';
+ iseq scalar (%-), 1, 'scalar %- == 1 after "bar"=~/(?<x>foo)|bar/';
+
+ $ok = -1;
+ $ok = exists ($-{x}) ? 1 : 0 if 'foo' =~ /(?<x>foo)|bar/;
+ iseq $ok, 1, '$-{x} exists after "foo"=~/(?<x>foo)|bar/';
+ iseq scalar (%+), 1, 'scalar %+ == 1 after "foo"=~/(?<x>foo)|bar/';
+ iseq scalar (%-), 1, 'scalar %- == 1 after "foo"=~/(?<x>foo)|bar/';
+
+ $ok = -1;
+ $ok = exists ($+{x}) ? 1 : 0 if 'foo'=~/(?<x>foo)|bar/;
+ iseq $ok, 1, '$+{x} exists after "foo"=~/(?<x>foo)|bar/';
+ }
+
+
+ {
+ local $_;
+ ($_ = 'abc') =~ /(abc)/g;
+ $_ = '123';
+ iseq "$1", 'abc', "/g leads to unsafe match vars: $1";
+ }
+
+
+ {
+ local $Message = 'Message-ID: <20070818091501.7eff4831 at r2d2>';
+ my $str = "";
+ for (0 .. 5) {
+ my @x;
+ $str .= "@x"; # this should ALWAYS be the empty string
+ 'a' =~ /(a|)/;
+ push @x, 1;
+ }
+ iseq length ($str), 0, "Trie scope error, string should be empty";
+ $str = "";
+ my @foo = ('a') x 5;
+ for (@foo) {
+ my @bar;
+ $str .= "@bar";
+ s/a|/push @bar, 1/e;
+ }
+ iseq length ($str), 0, "Trie scope error, string should be empty";
+ }
+
+
+ {
+ local $BugId = '45605';
+ # [perl #45605] Regexp failure with utf8-flagged and byte-flagged string
+
+ my $utf_8 = "\xd6schel";
+ utf8::upgrade ($utf_8);
+ $utf_8 =~ m {(\xd6|Ö)schel};
+ iseq $1, "\xd6", "Upgrade error";
+ }
+
+ {
+# more TRIE/AHOCORASICK problems with mixed utf8 / latin-1 and case folding
+ for my $chr (160 .. 255) {
+ my $chr_byte = chr($chr);
+ my $chr_utf8 = chr($chr); utf8::upgrade($chr_utf8);
+ my $rx = qr{$chr_byte|X}i;
+ ok($chr_utf8 =~ $rx, "utf8/latin, codepoint $chr");
+ }
+ }
+
+ {
+ # Regardless of utf8ness any character matches itself when
+ # doing a case insensitive match. See also [perl #36207]
+ local $BugId = '36207';
+ for my $o (0 .. 255) {
+ my @ch = (chr ($o), chr ($o));
+ utf8::upgrade ($ch [1]);
+ for my $u_str (0, 1) {
+ for my $u_pat (0, 1) {
+ ok $ch [$u_str] =~ /\Q$ch[$u_pat]\E/i,
+ "\$c =~ /\$c/i : chr ($o) : u_str = $u_str u_pat = $u_pat";
+ ok $ch [$u_str] =~ /\Q$ch[$u_pat]\E|xyz/i,
+ "\$c=~/\$c|xyz/i : chr($o) : u_str = $u_str u_pat = $u_pat";
+ }
+ }
+ }
+ }
+
+
+ {
+ our $a = 3; "" =~ /(??{ $a })/;
+ our $b = $a;
+ iseq $b, $a, "Copy of scalar used for postponed subexpression";
+ }
+
+
+ {
+ local $BugId = '49190';
+ local $Message = '$REGMARK in replacement';
+ our $REGMARK;
+ my $_ = "A";
+ ok s/(*:B)A/$REGMARK/;
+ iseq $_, "B";
+ $_ = "CCCCBAA";
+ ok s/(*:X)A+|(*:Y)B+|(*:Z)C+/$REGMARK/g;
+ iseq $_, "ZYX";
+ }
+
+
+ {
+ our @ctl_n = ();
+ our @plus = ();
+ our $nested_tags;
+ $nested_tags = qr{
+ <
+ (\w+)
+ (?{
+ push @ctl_n,$^N;
+ push @plus,$+;
+ })
+ >
+ (??{$nested_tags})*
+ </\s* \w+ \s*>
+ }x;
+
+ my $match = '<bla><blubb></blubb></bla>' =~ m/^$nested_tags$/;
+ ok $match, 'nested construct matches';
+ iseq "@ctl_n", "bla blubb", '$^N inside of (?{}) works as expected';
+ iseq "@plus", "bla blubb", '$+ inside of (?{}) works as expected';
+ }
+
+
+ {
+ local $BugId = '52658';
+ local $Message = 'Substitution evaluation in list context';
+ my $reg = '../xxx/';
+ my @te = ($reg =~ m{^(/?(?:\.\./)*)},
+ $reg =~ s/(x)/'b'/eg > 1 ? '##' : '++');
+ iseq $reg, '../bbb/';
+ iseq $te [0], '../';
+ }
+
+ # This currently has to come before any "use encoding" in this file.
+ {
+ local $Message;
+ local $BugId = '59342';
+ # for 5.10.x, add a dummy test indead
+ #must_warn 'qr/\400/', '^Use of octal value above 377';
+ $Message=""; ok 1;
+ }
+
+
+ SKIP: {
+ # XXX: This set of tests is essentially broken, POSIX character classes
+ # should not have differing definitions under Unicode.
+ # There are property names for that.
+ skip "Tests assume ASCII", 4 unless $IS_ASCII;
+
+ my @notIsPunct = grep {/[[:punct:]]/ and not /\p{IsPunct}/}
+ map {chr} 0x20 .. 0x7f;
+ iseq join ('', @notIsPunct), '$+<=>^`|~',
+ '[:punct:] disagress with IsPunct on Symbols';
+
+ my @isPrint = grep {not /[[:print:]]/ and /\p{IsPrint}/}
+ map {chr} 0 .. 0x1f, 0x7f .. 0x9f;
+ iseq join ('', @isPrint), "\x09\x0a\x0b\x0c\x0d\x85",
+ 'IsPrint disagrees with [:print:] on control characters';
+
+ my @isPunct = grep {/[[:punct:]]/ != /\p{IsPunct}/}
+ map {chr} 0x80 .. 0xff;
+ iseq join ('', @isPunct), "\xa1\xab\xb7\xbb\xbf", # ¡ « · » ¿
+ 'IsPunct disagrees with [:punct:] outside ASCII';
+
+ my @isPunctLatin1 = eval q {
+ use encoding 'latin1';
+ grep {/[[:punct:]]/ != /\p{IsPunct}/} map {chr} 0x80 .. 0xff;
+ };
+ skip "Eval failed ($@)", 1 if $@;
+ skip "PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS set to 0", 1
+ if $ENV {REAL_POSIX_CC};
+ iseq join ('', @isPunctLatin1), '',
+ 'IsPunct agrees with [:punct:] with explicit Latin1';
+ }
+
+
+ {
+ local $BugId = '60034';
+ my $a = "xyzt" x 8192;
+ ok $a =~ /\A(?>[a-z])*\z/,
+ '(?>) does not cause wrongness on long string';
+ my $b = $a . chr 256;
+ chop $b;
+ {
+ iseq $a, $b;
+ }
+ ok $b =~ /\A(?>[a-z])*\z/,
+ '(?>) does not cause wrongness on long string with UTF-8';
+ }
+
+
+ #
+ # Keep the following tests last -- they may crash perl
+ #
+ print "# Tests that follow may crash perl\n";
+ {
+ local $BugId = '19049/38869';
+ local $Message = 'Pattern in a loop, failure should not ' .
+ 'affect previous success';
+ my @list = (
+ 'ab cdef', # Matches regex
+ ('e' x 40000 ) .'ab c' # Matches not, but 'ab c' matches part of it
+ );
+ my $y;
+ my $x;
+ foreach (@list) {
+ m/ab(.+)cd/i; # The ignore-case seems to be important
+ $y = $1; # Use $1, which might not be from the last match!
+ $x = substr ($list [0], $- [0], $+ [0] - $- [0]);
+ }
+ iseq $y, ' ';
+ iseq $x, 'ab cd';
+ }
+
+
+ {
+ local $BugId = '24274';
+
+ ok (("a" x (2 ** 15 - 10)) =~ /^()(a|bb)*$/, "Recursive stack cracker");
+ ok ((q(a)x 100) =~ /^(??{'(.)'x 100})/,
+ "Regexp /^(??{'(.)'x 100})/ crashes older perls");
+ }
+
+
+ {
+ eval '/\k/';
+ ok $@ =~ /\QSequence \k... not terminated in regex;\E/,
+ 'Lone \k not allowed';
+ }
+
+
+ {
+ local $Message = "Substitution with lookahead (possible segv)";
+ $_ = "ns1ns1ns1";
+ s/ns(?=\d)/ns_/g;
+ iseq $_, "ns_1ns_1ns_1";
+ $_ = "ns1";
+ s/ns(?=\d)/ns_/;
+ iseq $_, "ns_1";
+ $_ = "123";
+ s/(?=\d+)|(?<=\d)/!Bang!/g;
+ iseq $_, "!Bang!1!Bang!2!Bang!3!Bang!";
+ }
+
+
+ {
+ # [perl #45337] utf8 + "[a]a{2}" + /$.../ = panic: sv_len_utf8 cache
+ local $BugId = '45337';
+ local ${^UTF8CACHE} = -1;
+ local $Message = "Shouldn't panic";
+ my $s = "[a]a{2}";
+ utf8::upgrade $s;
+ ok "aaa" =~ /$s/;
+ }
+ {
+ local $BugId = '57042';
+ local $Message = "Check if tree logic breaks \$^R";
+ my $cond_re = qr/\s*
+ \s* (?:
+ \( \s* A (?{1})
+ | \( \s* B (?{2})
+ )
+ /x;
+ my @res;
+ for my $line ("(A)","(B)") {
+ if ($line =~ m/$cond_re/) {
+ push @res, $^R ? "#$^R" : "UNDEF";
+ }
+ }
+ iseq "@res","#1 #2";
+ }
+ {
+ no warnings 'closure';
+ my $re = qr/A(??{"1"})/;
+ ok "A1B" =~ m/^((??{ $re }))((??{"B"}))$/;
+ ok $1 eq "A1";
+ ok $2 eq "B";
+ }
+
+
+ {
+ use re 'eval';
+ local $Message = 'Test if $^N and $+ work in (?{{})';
+ our @ctl_n = ();
+ our @plus = ();
+ our $nested_tags;
+ $nested_tags = qr{
+ <
+ ((\w)+)
+ (?{
+ push @ctl_n, (defined $^N ? $^N : "undef");
+ push @plus, (defined $+ ? $+ : "undef");
+ })
+ >
+ (??{$nested_tags})*
+ </\s* \w+ \s*>
+ }x;
+
+
+ my $c = 0;
+ for my $test (
+ # Test structure:
+ # [ Expected result, Regex, Expected value(s) of $^N, Expected value(s) of $+ ]
+ [ 1, qr#^$nested_tags$#, "bla blubb bla", "a b a" ],
+ [ 1, qr#^($nested_tags)$#, "bla blubb <bla><blubb></blubb></bla>", "a b a" ],
+ [ 1, qr#^(|)$nested_tags$#, "bla blubb bla", "a b a" ],
+ [ 1, qr#^(?:|)$nested_tags$#, "bla blubb bla", "a b a" ],
+ [ 1, qr#^<(bl|bla)>$nested_tags<(/\1)>$#, "blubb /bla", "b /bla" ],
+ [ 1, qr#(??{"(|)"})$nested_tags$#, "bla blubb bla", "a b a" ],
+ [ 1, qr#^(??{"(bla|)"})$nested_tags$#, "bla blubb bla", "a b a" ],
+ [ 1, qr#^(??{"(|)"})(??{$nested_tags})$#, "bla blubb undef", "a b undef" ],
+ [ 1, qr#^(??{"(?:|)"})$nested_tags$#, "bla blubb bla", "a b a" ],
+ [ 1, qr#^((??{"(?:bla|)"}))((??{$nested_tags}))$#, "bla blubb <bla><blubb></blubb></bla>", "a b <bla><blubb></blubb></bla>" ],
+ [ 1, qr#^((??{"(?!)?"}))((??{$nested_tags}))$#, "bla blubb <bla><blubb></blubb></bla>", "a b <bla><blubb></blubb></bla>" ],
+ [ 1, qr#^((??{"(?:|<(/?bla)>)"}))((??{$nested_tags}))\1$#, "bla blubb <bla><blubb></blubb></bla>", "a b <bla><blubb></blubb></bla>" ],
+ [ 0, qr#^((??{"(?!)"}))?((??{$nested_tags}))(?!)$#, "bla blubb undef", "a b undef" ],
+
+ ) { #"#silence vim highlighting
+ $c++;
+ @ctl_n = ();
+ @plus = ();
+ my $match = (("<bla><blubb></blubb></bla>" =~ $test->[1]) ? 1 : 0);
+ push @ctl_n, (defined $^N ? $^N : "undef");
+ push @plus, (defined $+ ? $+ : "undef");
+ ok($test->[0] == $match, "match $c");
+ if ($test->[0] != $match) {
+ # unset @ctl_n and @plus
+ @ctl_n = @plus = ();
+ }
+ iseq("@ctl_n", $test->[2], "ctl_n $c");
+ iseq("@plus", $test->[3], "plus $c");
+ }
+ }
+
+ {
+ use re 'eval';
+ local $BugId = '56194';
+
+ our $f;
+ local $f;
+ $f = sub {
+ defined $_[0] ? $_[0] : "undef";
+ };
+
+ ok("123" =~ m/^(\d)(((??{1 + $^N})))+$/);
+
+ our @ctl_n;
+ our @plus;
+
+ my $re = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))*(?{$^N})#;
+ my $re2 = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))*(?{$^N})(|a(b)c|def)(??{"$^R"})#;
+ my $re3 = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})){2}(?{$^N})(|a(b)c|def)(??{"$^R"})#;
+ our $re5;
+ local $re5 = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})){2}(?{$^N})#;
+ my $re6 = qr#(??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})#;
+ my $re7 = qr#(??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})#;
+ my $re8 = qr/(\d+)/;
+ my $c = 0;
+ for my $test (
+ # Test structure:
+ # [
+ # String to match
+ # Regex too match
+ # Expected values of $^N
+ # Expected values of $+
+ # Expected values of $1, $2, $3, $4 and $5
+ # ]
+ [
+ "1233",
+ qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(??{$^N})$#,
+ "1 2 3 3",
+ "1 2 3 3",
+ "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef",
+ ],
+ [
+ "1233",
+ qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(abc|def|)?(??{$+})$#,
+ "1 2 3 3",
+ "1 2 3 3",
+ "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef",
+ ],
+ [
+ "1233",
+ qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(|abc|def)?(??{$+})$#,
+ "1 2 3 3",
+ "1 2 3 3",
+ "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef",
+ ],
+ [
+ "1233",
+ qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(abc|def|)?(??{$^N})$#,
+ "1 2 3 3",
+ "1 2 3 3",
+ "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef",
+ ],
+ [
+ "1233",
+ qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(|abc|def)?(??{$^N})$#,
+ "1 2 3 3",
+ "1 2 3 3",
+ "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef",
+ ],
+ [
+ "123abc3",
+ qr#^($re)(|a(b)c|def)(??{$^R})$#,
+ "1 2 3 abc",
+ "1 2 3 b",
+ "\$1 = 123, \$2 = 1, \$3 = 3, \$4 = abc, \$5 = b",
+ ],
+ [
+ "123abc3",
+ qr#^($re2)$#,
+ "1 2 3 123abc3",
+ "1 2 3 b",
+ "\$1 = 123abc3, \$2 = 1, \$3 = 3, \$4 = abc, \$5 = b",
+ ],
+ [
+ "123abc3",
+ qr#^($re3)$#,
+ "1 2 123abc3",
+ "1 2 b",
+ "\$1 = 123abc3, \$2 = 1, \$3 = 3, \$4 = abc, \$5 = b",
+ ],
+ [
+ "123abc3",
+ qr#^(??{$re5})(|abc|def)(??{"$^R"})$#,
+ "1 2 abc",
+ "1 2 abc",
+ "\$1 = abc, \$2 = undef, \$3 = undef, \$4 = undef, \$5 = undef",
+ ],
+ [
+ "123abc3",
+ qr#^(??{$re5})(|a(b)c|def)(??{"$^R"})$#,
+ "1 2 abc",
+ "1 2 b",
+ "\$1 = abc, \$2 = b, \$3 = undef, \$4 = undef, \$5 = undef",
+ ],
+ [
+ "1234",
+ qr#^((\d+)((??{push @ctl_n, $f->($^N); push @plus, $f->($+);$^N + 1}))((??{push @ctl_n, $f->($^N); push @plus, $f->($+);$^N + 1}))((??{push @ctl_n, $f->($^N); push @plus, $f->($+);$^N + 1})))$#,
+ "1234 123 12 1 2 3 1234",
+ "1234 123 12 1 2 3 4",
+ "\$1 = 1234, \$2 = 1, \$3 = 2, \$4 = 3, \$5 = 4",
+ ],
+ [
+ "1234556",
+ qr#^(\d+)($re6)($re6)($re6)$re6(($re6)$re6)$#,
+ "1234556 123455 12345 1234 123 12 1 2 3 4 4 5 56",
+ "1234556 123455 12345 1234 123 12 1 2 3 4 4 5 5",
+ "\$1 = 1, \$2 = 2, \$3 = 3, \$4 = 4, \$5 = 56",
+ ],
+ [
+ "12345562",
+ qr#^((??{$re8}))($re7)($re7)($re7)$re7($re7)($re7(\2))$#,
+ "12345562 1234556 123455 12345 1234 123 12 1 2 3 4 4 5 62",
+ "12345562 1234556 123455 12345 1234 123 12 1 2 3 4 4 5 2",
+ "\$1 = 1, \$2 = 2, \$3 = 3, \$4 = 4, \$5 = 5",
+ ],
+ ) {
+ $c++;
+ @ctl_n = ();
+ @plus = ();
+ undef $^R;
+ my $match = $test->[0] =~ $test->[1];
+ my $str = join(", ", '$1 = '.$f->($1), '$2 = '.$f->($2), '$3 = '.$f->($3), '$4 = '.$f->($4),'$5 = '.$f->($5));
+ push @ctl_n, $f->($^N);
+ push @plus, $f->($+);
+ ok($match, "match $c");
+ if (not $match) {
+ # unset $str, @ctl_n and @plus
+ $str = "";
+ @ctl_n = @plus = ();
+ }
+ iseq("@ctl_n", $test->[2], "ctl_n $c");
+ iseq("@plus", $test->[3], "plus $c");
+ iseq($str, $test->[4], "str $c");
+ }
+ SKIP: {
+ if ($] le '5.010') {
+ skip "test segfaults on perl < 5.10", 4;
+ }
+
+ @ctl_n = ();
+ @plus = ();
+
+ our $re4;
+ local $re4 = qr#(1)((??{push @ctl_n, $f->($^N); push @plus, $f->($+);$^N + 1})){2}(?{$^N})(|abc|def)(??{"$^R"})#;
+ undef $^R;
+ my $match = "123abc3" =~ m/^(??{$re4})$/;
+ my $str = join(", ", '$1 = '.$f->($1), '$2 = '.$f->($2), '$3 = '.$f->($3), '$4 = '.$f->($4),'$5 = '.$f->($5),'$^R = '.$f->($^R));
+ push @ctl_n, $f->($^N);
+ push @plus, $f->($+);
+ ok($match);
+ if (not $match) {
+ # unset $str
+ @ctl_n = ();
+ @plus = ();
+ $str = "";
+ }
+ iseq("@ctl_n", "1 2 undef");
+ iseq("@plus", "1 2 undef");
+ iseq($str, "\$1 = undef, \$2 = undef, \$3 = undef, \$4 = undef, \$5 = undef, \$^R = undef");
+ }
+ }
+
+ {
+ local $BugId = 65372; # minimal CURLYM limited to 32767 matches
+ my @pat = (
+ qr{a(x|y)*b}, # CURLYM
+ qr{a(x|y)*?b}, # .. with minmod
+ qr{a([wx]|[yz])*b}, # .. and without tries
+ qr{a([wx]|[yz])*?b},
+ );
+ my $len = 32768;
+ my $s = join '', 'a', 'x' x $len, 'b';
+ for my $pat (@pat) {
+ ok($s =~ $pat, $pat);
+ }
+ }
+ #
+ # This should be the last test.
+ #
+ iseq $test + 1, $EXPECTED_TESTS, "Got the right number of tests!";
+
+} # End of sub run_tests
+
+1;
Copied: trunk/contrib/perl/t/op/pat_thr.t (from rev 6437, vendor/perl/5.18.1/t/op/pat_thr.t)
===================================================================
--- trunk/contrib/perl/t/op/pat_thr.t (rev 0)
+++ trunk/contrib/perl/t/op/pat_thr.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,7 @@
+#!./perl
+
+chdir 't' if -d 't';
+ at INC = ('../lib', '.');
+
+require 'thread_it.pl';
+thread_it(qw(op pat.t));
Modified: trunk/contrib/perl/t/op/pos.t
===================================================================
--- trunk/contrib/perl/t/op/pos.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/pos.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -6,28 +6,28 @@
require './test.pl';
}
-plan tests => 8;
+plan tests => 12;
$x='banana';
$x=~/.a/g;
-is(pos($x), 2);
+is(pos($x), 2, "matching, pos() leaves off at offset 2");
$x=~/.z/gc;
-is(pos($x), 2);
+is(pos($x), 2, "not matching, pos() remains at offset 2");
sub f { my $p=$_[0]; return $p }
$x=~/.a/g;
-is(f(pos($x)), 4);
+is(f(pos($x)), 4, "matching again, pos() next leaves off at offset 4");
# Is pos() set inside //g? (bug id 19990615.008)
$x = "test string?"; $x =~ s/\w/pos($x)/eg;
-is($x, "0123 5678910?");
+is($x, "0123 5678910?", "pos() set inside //g");
$x = "123 56"; $x =~ / /g;
-is(pos($x), 4);
+is(pos($x), 4, "matching, pos() leaves off at offset 4");
{ local $x }
-is(pos($x), 4);
+is(pos($x), 4, "value of pos() unaffected by intermediate localization");
# Explicit test that triggers the utf8_mg_len_cache_update() code path in
# Perl_sv_pos_b2u().
@@ -34,7 +34,7 @@
$x = "\x{100}BC";
$x =~ m/.*/g;
-is(pos $x, 3);
+is(pos $x, 3, "utf8_mg_len_cache_update() test");
my $destroyed;
@@ -47,3 +47,19 @@
$x = bless({}, 'Class');
}
is($destroyed, 1, 'Timely scalar destruction with lvalue pos');
+
+eval 'pos @a = 1';
+like $@, qr/^Can't modify array dereference in match position at /,
+ 'pos refuses @arrays';
+eval 'pos %a = 1';
+like $@, qr/^Can't modify hash dereference in match position at /,
+ 'pos refuses %hashes';
+eval 'pos *a = 1';
+is eval 'pos *a', 1, 'pos *glob works';
+
+# Test that UTF8-ness of $1 changing does not confuse pos
+"f" =~ /(f)/; "$1"; # first make sure UTF8-ness is off
+"\x{100}a" =~ /(..)/; # give PL_curpm a UTF8 string; $1 does not know yet
+pos($1) = 2; # set pos; was ignoring UTF8-ness
+"$1"; # turn on UTF8 flag
+is pos($1), 2, 'pos is not confused about changing UTF8-ness';
Property changes on: trunk/contrib/perl/t/op/pos.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/pow.t
===================================================================
--- trunk/contrib/perl/t/op/pow.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/pow.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -37,11 +37,11 @@
is(3**2, 9, "positive ** 2 = positive");
is(3**3, 27, "(positive int) ** (odd power) is positive");
-# And test order of operations while we're at it
-is(-3**0, -1);
-is(-3**1, -3);
-is(-3**2, -9);
-is(-3**3, -27);
+# And test order of operations while we are at it
+is(-3**0, -1, "positive ** 0, then negated, = -1");
+is(-3**1, -3, "positive ** 1, then negated, = negative of self");
+is(-3**2, -9, "positive ** 2, then negated, = negative of square");
+is(-3**3, -27, "(positive int) ** (odd power), then negated, is negative");
# Ought to be 32, 64, 36 or something like that.
Property changes on: trunk/contrib/perl/t/op/pow.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/print.t
===================================================================
--- trunk/contrib/perl/t/op/print.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/print.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -4,9 +4,25 @@
require "test.pl";
}
-plan(2);
+plan(3);
fresh_perl_is('$_ = qq{OK\n}; print;', "OK\n",
'print without arguments outputs $_');
fresh_perl_is('$_ = qq{OK\n}; print STDOUT;', "OK\n",
'print with only a filehandle outputs $_');
+SKIP: {
+ skip_if_miniperl('no dynamic loading of PerlIO::scalar in miniperl');
+fresh_perl_is(<<'EOF', "\xC1\xAF\xC1\xAF\xC1\xB0\xC1\xB3", "", "print doesn't launder utf8 overlongs");
+use strict;
+use warnings;
+
+no warnings 'utf8';
+
+# These form overlong "oops"
+open my $fh, "<:utf8", \"\xC1\xAF\xC1\xAF\xC1\xB0\xC1\xB3"
+ or die "Could not open\n";
+read($fh, my $s, 10) or die "Could not read\n";
+print $s;
+EOF
+
+}
Property changes on: trunk/contrib/perl/t/op/print.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/op/protowarn.t
===================================================================
--- trunk/contrib/perl/t/op/protowarn.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/protowarn.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/protowarn.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/push.t
===================================================================
--- trunk/contrib/perl/t/op/push.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/push.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,5 +1,11 @@
#!./perl
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require './test.pl';
+}
+
@tests = split(/\n/, <<EOF);
0 3, 0 1 2, 3 4 5 6 7
0 0 a b c, , a b c 0 1 2 3 4 5 6 7
@@ -14,14 +20,14 @@
-4, 4 5 6 7, 0 1 2 3
EOF
-print "1..", 14 + 2*@tests, "\n";
+plan tests => 16 + @tests*4;
die "blech" unless @tests;
@x = (1,2,3);
push(@x, at x);
-if (join(':', at x) eq '1:2:3:1:2:3') {print "ok 1\n";} else {print "not ok 1\n";}
+is( join(':', at x), '1:2:3:1:2:3', 'push array onto array');
push(@x,4);
-if (join(':', at x) eq '1:2:3:1:2:3:4') {print "ok 2\n";} else {print "not ok 2\n";}
+is( join(':', at x), '1:2:3:1:2:3:4', 'push integer onto array');
# test for push/pop intuiting @ on array
{
@@ -28,42 +34,42 @@
no warnings 'deprecated';
push(x,3);
}
-if (join(':', at x) eq '1:2:3:1:2:3:4:3') {print "ok 3\n";} else {print "not ok 3\n";}
+is( join(':', at x), '1:2:3:1:2:3:4:3', 'push intuiting @ on array');
{
no warnings 'deprecated';
pop(x);
}
-if (join(':', at x) eq '1:2:3:1:2:3:4') {print "ok 4\n";} else {print "not ok 4\n";}
+is( join(':', at x), '1:2:3:1:2:3:4', 'pop intuiting @ on array');
# test for push/pop on arrayref
push(\@x,5);
-if (join(':', at x) eq '1:2:3:1:2:3:4:5') {print "ok 5\n";} else {print "not ok 5\n";}
+is( join(':', at x), '1:2:3:1:2:3:4:5', 'push arrayref');
pop(\@x);
-if (join(':', at x) eq '1:2:3:1:2:3:4') {print "ok 6\n";} else {print "not ok 6\n";}
+is( join(':', at x), '1:2:3:1:2:3:4', 'pop arrayref');
# test autovivification
push @$undef1, 1, 2, 3;
-if (join(':',@$undef1) eq '1:2:3') {print "ok 7\n";} else {print "not ok 7\n";}
+is( join(':',@$undef1), '1:2:3', 'autovivify array');
# test push on undef (error)
eval { push $undef2, 1, 2, 3 };
-if ($@ =~ /Not an ARRAY/) {print "ok 8\n";} else {print "not ok 8\n";}
+like( $@, qr/Not an ARRAY/, 'push on undef generates an error');
# test constant
use constant CONST_ARRAYREF => [qw/a b c/];
push CONST_ARRAYREF(), qw/d e f/;
-if (join(':',@{CONST_ARRAYREF()}) eq 'a:b:c:d:e:f') {print "ok 9\n";} else {print "not ok 9\n";}
+is( join(':',@{CONST_ARRAYREF()}), 'a:b:c:d:e:f', 'test constant');
# test implicit dereference errors
eval "push 42, 0, 1, 2, 3";
-if ( $@ && $@ =~ /must be array/ ) {print "ok 10\n"} else {print "not ok 10 # \$\@ = $@\n"}
+like ( $@, qr/must be array/, 'push onto a literal integer');
$hashref = { };
eval { push $hashref, 0, 1, 2, 3 };
-if ( $@ && $@ =~ /Not an ARRAY reference/ ) {print "ok 11\n"} else {print "not ok 11 # \$\@ = $@\n"}
+like( $@, qr/Not an ARRAY reference/, 'push onto a hashref');
eval { push bless([]), 0, 1, 2, 3 };
-if ( $@ && $@ =~ /Not an unblessed ARRAY reference/ ) {print "ok 12\n"} else {print "not ok 12 # \$\@ = $@\n"}
+like( $@, qr/Not an unblessed ARRAY reference/, 'push onto a blessed array ref');
$test = 13;
@@ -72,22 +78,12 @@
my($first, $second) = ([1], [2]);
sub two_things { return +($first, $second) }
push two_things(), 3;
- if (join(':',@$first) eq '1' &&
- join(':',@$second) eq '2:3') {
- print "ok ",$test++,"\n";
- }
- else {
- print "not ok ",$test++," got: \$first = [ @$first ]; \$second = [ @$second ];\n";
- }
+ is( join(':',@$first), '1', "\$first = [ @$first ];");
+ is( join(':',@$second), '2:3', "\$second = [ @$second ]");
push @{ two_things() }, 4;
- if (join(':',@$first) eq '1' &&
- join(':',@$second) eq '2:3:4') {
- print "ok ",$test++,"\n";
- }
- else {
- print "not ok ",$test++," got: \$first = [ @$first ]; \$second = [ @$second ];\n";
- }
+ is( join(':',@$first), '1', "\$first = [ @$first ];");
+ is( join(':',@$second), '2:3:4', "\$second = [ @$second ]");
}
foreach $line (@tests) {
@@ -105,20 +101,10 @@
@got = splice(@x, $pos);
@got2 = splice($y, $pos);
}
- if (join(':', at got) eq join(':', at get) &&
- join(':', at x) eq join(':', at leave)) {
- print "ok ",$test++,"\n";
- }
- else {
- print "not ok ",$test++," got: @got == @get left: @x == @leave\n";
- }
- if (join(':', at got2) eq join(':', at get) &&
- join(':',@$y) eq join(':', at leave)) {
- print "ok ",$test++,"\n";
- }
- else {
- print "not ok ",$test++," got (arrayref): @got2 == @get left: @$y == @leave\n";
- }
+ is(join(':', at got), join(':', at get), "got: @got == @get");
+ is(join(':', at x), join(':', at leave), "left: @x == @leave");
+ is(join(':', at got2), join(':', at get), "ref got: @got2 == @get");
+ is(join(':',@$y), join(':', at leave), "ref left: @$y == @leave");
}
1; # this file is require'd by lib/tie-stdpush.t
Property changes on: trunk/contrib/perl/t/op/push.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/pwent.t
===================================================================
--- trunk/contrib/perl/t/op/pwent.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/pwent.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -74,6 +74,10 @@
chomp;
if ($_ eq '-') {
if (@rec) {
+ # Some records do not have all items. In particular,
+ # the macports user has no real name. Here it's an undef,
+ # in the password file it becomes an empty string.
+ no warnings 'uninitialized';
push @lines, join (':', @rec) . "\n";
@rec = ();
}
@@ -92,6 +96,8 @@
}
}
if (@rec) {
+ # see above
+ no warnings 'uninitialized';
push @lines, join (':', @rec) . "\n";
}
my $data = join '', @lines;
@@ -211,7 +217,7 @@
EOEX
}
- cmp_ok(keys %perfect, '>', 0)
+ cmp_ok(keys %perfect, '>', 0, "pwent test satisfactory")
or note("(not necessarily serious: run t/op/pwent.t by itself)");
}
@@ -237,6 +243,7 @@
}
endpwent();
-is("@pw1", "@pw2");
+is("@pw1", "@pw2",
+ "getpwent() produced identical results in list and scalar contexts");
close(PW);
Property changes on: trunk/contrib/perl/t/op/pwent.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/t/op/qq.t
===================================================================
--- trunk/contrib/perl/t/op/qq.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/qq.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/qq.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/qr.t
===================================================================
--- trunk/contrib/perl/t/op/qr.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/qr.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -2,9 +2,12 @@
use strict;
-require './test.pl';
+BEGIN {
+ chdir 't';
+ require './test.pl';
+}
-plan(tests => 18);
+plan(tests => 32);
sub r {
return qr/Good/;
@@ -11,9 +14,9 @@
}
my $a = r();
-isa_ok($a, 'Regexp');
+object_ok($a, 'Regexp');
my $b = r();
-isa_ok($b, 'Regexp');
+object_ok($b, 'Regexp');
my $b1 = $b;
@@ -21,9 +24,9 @@
bless $b, 'Pie';
-isa_ok($b, 'Pie');
-isa_ok($a, 'Regexp');
-isa_ok($b1, 'Pie');
+object_ok($b, 'Pie');
+object_ok($a, 'Regexp');
+object_ok($b1, 'Pie');
my $c = r();
like("$c", qr/Good/);
@@ -43,7 +46,7 @@
# Assignment to an implicitly blessed Regexp object retains the class
# (No different from direct value assignment to any other blessed SV
-isa_ok($d, 'Regexp');
+object_ok($d, 'Regexp');
like("$d", qr/\ARegexp=SCALAR\(0x[0-9a-f]+\)\z/);
# As does an explicitly blessed Regexp object.
@@ -50,9 +53,60 @@
my $e = bless qr/Faux Pie/, 'Stew';
-isa_ok($e, 'Stew');
+object_ok($e, 'Stew');
$$e = 'Fake!';
is($$e, 'Fake!');
-isa_ok($e, 'Stew');
+object_ok($e, 'Stew');
like("$e", qr/\Stew=SCALAR\(0x[0-9a-f]+\)\z/);
+
+# [perl #96230] qr// should not have the reuse-last-pattern magic
+"foo" =~ /foo/;
+like "bar",qr//,'[perl #96230] =~ qr// does not reuse last successful pat';
+"foo" =~ /foo/;
+$_ = "bar";
+$_ =~ s/${qr||}/baz/;
+is $_, "bazbar", '[perl #96230] s/$qr// does not reuse last pat';
+
+{
+ my $x = 1.1; $x = ${qr//};
+ pass 'no assertion failure when upgrading NV to regexp';
+}
+
+sub TIESCALAR{bless[]}
+sub STORE { is ref\pop, "REGEXP", "stored regexp" }
+tie my $t, "";
+$t = ${qr||};
+ok tied $t, 'tied var is still tied after regexp assignment';
+
+bless \my $t2;
+$t2 = ${qr||};
+is ref \$t2, 'main', 'regexp assignment is not maledictory';
+
+{
+ my $w;
+ local $SIG{__WARN__}=sub{$w=$_[0]};
+ $_ = 1.1;
+ $_ = ${qr//};
+ is 0+$_, 0, 'double upgraded to regexp';
+ like $w, 'numeric', 'produces non-numeric warning';
+ undef $w;
+ $_ = 1;
+ $_ = ${qr//};
+ is 0+$_, 0, 'int upgraded to regexp';
+ like $w, 'numeric', 'likewise produces non-numeric warning';
+}
+
+sub {
+ $_[0] = ${qr=crumpets=};
+ is ref\$_[0], 'REGEXP', 'PVLVs';
+ # Don’t use like() here, as we would no longer be testing a PVLV.
+ ok " crumpets " =~ $_[0], 'using a regexpvlv as regexp';
+ my $x = $_[0];
+ is ref\$x, 'REGEXP', 'copying a regexpvlv';
+ $_[0] = ${qr//};
+ my $str = "".qr//;
+ $_[0] .= " ";
+ is $_[0], "$str ", 'stringifying regexpvlv in place';
+}
+ ->((\my%hash)->{key});
Property changes on: trunk/contrib/perl/t/op/qr.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/t/op/qr_gc.t (from rev 6437, vendor/perl/5.18.1/t/op/qr_gc.t)
===================================================================
--- trunk/contrib/perl/t/op/qr_gc.t (rev 0)
+++ trunk/contrib/perl/t/op/qr_gc.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,35 @@
+#!./perl -w
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require './test.pl';
+ undef &Regexp::DESTROY;
+}
+
+plan tests => 2;
+
+if ($] >= 5.011) { # doesn't leak on 5.10.x
+ $TODO = "leaking since 32751";
+}
+
+my $destroyed;
+{
+ sub Regexp::DESTROY { $destroyed++ }
+}
+
+{
+ my $rx = qr//;
+}
+
+is( $destroyed, 1, "destroyed regexp" );
+
+undef $destroyed;
+
+{
+ my $var = bless {}, "Foo";
+ my $rx = qr/(?{ $var })/;
+}
+
+is( $destroyed, 1, "destroyed regexp with closure capture" );
+
Copied: trunk/contrib/perl/t/op/qrstack.t (from rev 6437, vendor/perl/5.18.1/t/op/qrstack.t)
===================================================================
--- trunk/contrib/perl/t/op/qrstack.t (rev 0)
+++ trunk/contrib/perl/t/op/qrstack.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,11 @@
+#!./perl -w
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require './test.pl';
+}
+
+plan tests => 1;
+
+ok(defined [(1)x127,qr//,1]->[127], "qr// should extend the stack properly");
Modified: trunk/contrib/perl/t/op/quotemeta.t
===================================================================
--- trunk/contrib/perl/t/op/quotemeta.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/quotemeta.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -7,7 +7,7 @@
require "test.pl";
}
-plan tests => 22;
+plan tests => 60;
if ($Config{ebcdic} eq 'define') {
$_ = join "", map chr($_), 129..233;
@@ -44,9 +44,102 @@
is("\U\lPerl\E\E\E\E", "pERL", '\U\lPerl\E\E\E\E');
is("\l\UPerl\E\E\E\E", "pERL", '\l\UPerl\E\E\E\E');
-is(quotemeta("\x{263a}"), "\x{263a}", "quotemeta Unicode");
-is(length(quotemeta("\x{263a}")), 1, "quotemeta Unicode length");
+is(quotemeta("\x{263a}"), "\\\x{263a}", "quotemeta Unicode quoted");
+is(length(quotemeta("\x{263a}")), 2, "quotemeta Unicode quoted length");
+is(quotemeta("\x{100}"), "\x{100}", "quotemeta Unicode nonquoted");
+is(length(quotemeta("\x{100}")), 1, "quotemeta Unicode nonquoted length");
+my $char = ":";
+utf8::upgrade($char);
+is(quotemeta($char), "\\$char", "quotemeta '$char' in UTF-8");
+is(length(quotemeta($char)), 2, "quotemeta '$char' in UTF-8 length");
+
+$char = "M";
+utf8::upgrade($char);
+is(quotemeta($char), "$char", "quotemeta '$char' in UTF-8");
+is(length(quotemeta($char)), 1, "quotemeta '$char' in UTF-8 length");
+
+my $char = "\N{U+D7}";
+utf8::upgrade($char);
+is(quotemeta($char), "\\$char", "quotemeta '\\N{U+D7}' in UTF-8");
+is(length(quotemeta($char)), 2, "quotemeta '\\N{U+D7}' in UTF-8 length");
+
+$char = "\N{U+D8}";
+utf8::upgrade($char);
+is(quotemeta($char), "$char", "quotemeta '\\N{U+D8}' in UTF-8");
+is(length(quotemeta($char)), 1, "quotemeta '\\N{U+D8}' in UTF-8 length");
+
+{
+ no feature 'unicode_strings';
+ is(quotemeta("\x{d7}"), "\\\x{d7}", "quotemeta Latin1 no unicode_strings quoted");
+ is(length(quotemeta("\x{d7}")), 2, "quotemeta Latin1 no unicode_strings quoted length");
+ is(quotemeta("\x{d8}"), "\\\x{d8}", "quotemeta Latin1 no unicode_strings quoted");
+ is(length(quotemeta("\x{d8}")), 2, "quotemeta Latin1 no unicode_strings quoted length");
+
+ SKIP: {
+ skip 'No locale testing without d_setlocale', 8 if(!$Config{d_setlocale});
+ require locale; import locale;
+
+ my $char = ":";
+ is(quotemeta($char), "\\$char", "quotemeta '$char' locale");
+ is(length(quotemeta($char)), 2, "quotemeta '$char' locale");
+
+ $char = "M";
+ utf8::upgrade($char);
+ is(quotemeta($char), "$char", "quotemeta '$char' locale");
+ is(length(quotemeta($char)), 1, "quotemeta '$char' locale");
+
+ my $char = "\x{D7}";
+ is(quotemeta($char), "\\$char", "quotemeta '\\x{D7}' locale");
+ is(length(quotemeta($char)), 2, "quotemeta '\\x{D7}' locale length");
+
+ $char = "\x{D8}"; # Every non-ASCII Latin1 is quoted in locale.
+ is(quotemeta($char), "\\$char", "quotemeta '\\x{D8}' locale");
+ is(length(quotemeta($char)), 2, "quotemeta '\\x{D8}' locale length");
+ }
+}
+{
+ use feature 'unicode_strings';
+ is(quotemeta("\x{d7}"), "\\\x{d7}", "quotemeta Latin1 unicode_strings quoted");
+ is(length(quotemeta("\x{d7}")), 2, "quotemeta Latin1 unicode_strings quoted length");
+ is(quotemeta("\x{d8}"), "\x{d8}", "quotemeta Latin1 unicode_strings nonquoted");
+ is(length(quotemeta("\x{d8}")), 1, "quotemeta Latin1 unicode_strings nonquoted length");
+
+ SKIP: {
+ skip 'No locale testing without d_setlocale', 12 if(!$Config{d_setlocale});
+ BEGIN {
+ if($Config{d_setlocale}) {
+ require locale; import locale;
+ }
+ }
+
+ my $char = ":";
+ utf8::upgrade($char);
+ is(quotemeta($char), "\\$char", "quotemeta '$char' locale in UTF-8");
+ is(length(quotemeta($char)), 2, "quotemeta '$char' locale in UTF-8 length");
+
+ $char = "M";
+ utf8::upgrade($char);
+ is(quotemeta($char), "$char", "quotemeta '$char' locale in UTF-8");
+ is(length(quotemeta($char)), 1, "quotemeta '$char' locale in UTF-8 length");
+
+ my $char = "\N{U+D7}";
+ utf8::upgrade($char);
+ is(quotemeta($char), "\\$char", "quotemeta '\\N{U+D7}' locale in UTF-8");
+ is(length(quotemeta($char)), 2, "quotemeta '\\N{U+D7}' locale in UTF-8 length");
+
+ $char = "\N{U+D8}"; # Every non-ASCII Latin1 is quoted in locale.
+ utf8::upgrade($char);
+ is(quotemeta($char), "\\$char", "quotemeta '\\N{U+D8}' locale in UTF-8");
+ is(length(quotemeta($char)), 2, "quotemeta '\\N{U+D8}' locale in UTF-8 length");
+
+ is(quotemeta("\x{263a}"), "\\\x{263a}", "quotemeta locale Unicode quoted");
+ is(length(quotemeta("\x{263a}")), 2, "quotemeta locale Unicode quoted length");
+ is(quotemeta("\x{100}"), "\x{100}", "quotemeta locale Unicode nonquoted");
+ is(length(quotemeta("\x{100}")), 1, "quotemeta locale Unicode nonquoted length");
+ }
+}
+
$a = "foo|bar";
is("a\Q\Ec$a", "acfoo|bar", '\Q\E');
is("a\L\Ec$a", "acfoo|bar", '\L\E');
Property changes on: trunk/contrib/perl/t/op/quotemeta.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/op/rand.t
===================================================================
--- trunk/contrib/perl/t/op/rand.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/rand.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/rand.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/range.t
===================================================================
--- trunk/contrib/perl/t/op/range.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/range.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -355,28 +355,19 @@
@foo = 4 .. $x;
is(scalar @foo, 3);
is("@foo", "4 5 6");
-{
- local $TODO = "test for double magic with range operator";
- is(fetches($x), 1);
-}
+is(fetches($x), 1);
is(stores($x), 0);
@foo = $x .. 8;
is(scalar @foo, 3);
is("@foo", "6 7 8");
-{
- local $TODO = "test for double magic with range operator";
- is(fetches($x), 1);
-}
+is(fetches($x), 1);
is(stores($x), 0);
@foo = $x .. $x + 1;
is(scalar @foo, 2);
is("@foo", "6 7");
-{
- local $TODO = "test for double magic with range operator";
- is(fetches($x), 2);
-}
+is(fetches($x), 2);
is(stores($x), 0);
@foo = ();
@@ -385,10 +376,7 @@
}
is(scalar @foo, 3);
is("@foo", "4 5 6");
-{
- local $TODO = "test for double magic with range operator";
- is(fetches($x), 1);
-}
+is(fetches($x), 1);
is(stores($x), 0);
@foo = ();
@@ -397,10 +385,7 @@
}
is(scalar @foo, 3);
is("@foo", "6 5 4");
-{
- local $TODO = "test for double magic with range operator";
- is(fetches($x), 1);
-}
+is(fetches($x), 1);
is(stores($x), 0);
is( ( join ' ', map { join '', map ++$_, ($x=1)..4 } 1..2 ), '2345 2345',
Property changes on: trunk/contrib/perl/t/op/range.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Copied: trunk/contrib/perl/t/op/re.t (from rev 6437, vendor/perl/5.18.1/t/op/re.t)
===================================================================
--- trunk/contrib/perl/t/op/re.t (rev 0)
+++ trunk/contrib/perl/t/op/re.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,46 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use strict;
+use warnings;
+
+use Test::More; # test count at bottom of file
+use re qw(is_regexp regexp_pattern
+ regname regnames regnames_count);
+{
+ my $qr=qr/foo/pi;
+ ok(is_regexp($qr),'is_regexp($qr)');
+ ok(!is_regexp(''),'is_regexp("")');
+ is((regexp_pattern($qr))[0],'foo','regexp_pattern[0]');
+ is((regexp_pattern($qr))[1],'ip','regexp_pattern[1]');
+ is(regexp_pattern($qr),'(?pi-xsm:foo)','scalar regexp_pattern');
+ ok(!regexp_pattern(''),'!regexp_pattern("")');
+}
+
+if ('1234'=~/(?:(?<A>\d)|(?<C>!))(?<B>\d)(?<A>\d)(?<B>\d)/){
+ my @names = sort +regnames();
+ is("@names","A B","regnames");
+ @names = sort +regnames(0);
+ is("@names","A B","regnames");
+ my $names = regnames();
+ is($names, "B", "regnames in scalar context");
+ @names = sort +regnames(1);
+ is("@names","A B C","regnames");
+ is(join("", @{regname("A",1)}),"13");
+ is(join("", @{regname("B",1)}),"24");
+ {
+ if ('foobar'=~/(?<foo>foo)(?<bar>bar)/) {
+ is(regnames_count(),2);
+ } else {
+ ok(0); ok(0);
+ }
+ }
+ is(regnames_count(),3);
+}
+# New tests above this line, don't forget to update the test count below!
+use Test::More tests => 14;
+# No tests here!
Copied: trunk/contrib/perl/t/op/re_tests (from rev 6437, vendor/perl/5.18.1/t/op/re_tests)
===================================================================
--- trunk/contrib/perl/t/op/re_tests (rev 0)
+++ trunk/contrib/perl/t/op/re_tests 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,1375 @@
+# This stops me getting screenfulls of syntax errors every time I accidentally
+# run this file via a shell glob
+__END__
+abc abc y $& abc
+abc abc y $-[0] 0
+abc abc y $+[0] 3
+abc xbc n - -
+abc axc n - -
+abc abx n - -
+abc xabcy y $& abc
+abc xabcy y $-[0] 1
+abc xabcy y $+[0] 4
+abc ababc y $& abc
+abc ababc y $-[0] 2
+abc ababc y $+[0] 5
+ab*c abc y $& abc
+ab*c abc y $-[0] 0
+ab*c abc y $+[0] 3
+ab*bc abc y $& abc
+ab*bc abc y $-[0] 0
+ab*bc abc y $+[0] 3
+ab*bc abbc y $& abbc
+ab*bc abbc y $-[0] 0
+ab*bc abbc y $+[0] 4
+ab*bc abbbbc y $& abbbbc
+ab*bc abbbbc y $-[0] 0
+ab*bc abbbbc y $+[0] 6
+.{1} abbbbc y $& a
+.{1} abbbbc y $-[0] 0
+.{1} abbbbc y $+[0] 1
+.{3,4} abbbbc y $& abbb
+.{3,4} abbbbc y $-[0] 0
+.{3,4} abbbbc y $+[0] 4
+ab{0,}bc abbbbc y $& abbbbc
+ab{0,}bc abbbbc y $-[0] 0
+ab{0,}bc abbbbc y $+[0] 6
+ab+bc abbc y $& abbc
+ab+bc abbc y $-[0] 0
+ab+bc abbc y $+[0] 4
+ab+bc abc n - -
+ab+bc abq n - -
+ab{1,}bc abq n - -
+ab+bc abbbbc y $& abbbbc
+ab+bc abbbbc y $-[0] 0
+ab+bc abbbbc y $+[0] 6
+ab{1,}bc abbbbc y $& abbbbc
+ab{1,}bc abbbbc y $-[0] 0
+ab{1,}bc abbbbc y $+[0] 6
+ab{1,3}bc abbbbc y $& abbbbc
+ab{1,3}bc abbbbc y $-[0] 0
+ab{1,3}bc abbbbc y $+[0] 6
+ab{3,4}bc abbbbc y $& abbbbc
+ab{3,4}bc abbbbc y $-[0] 0
+ab{3,4}bc abbbbc y $+[0] 6
+ab{4,5}bc abbbbc n - -
+ab?bc abbc y $& abbc
+ab?bc abc y $& abc
+ab{0,1}bc abc y $& abc
+ab?bc abbbbc n - -
+ab?c abc y $& abc
+ab{0,1}c abc y $& abc
+^abc$ abc y $& abc
+^abc$ abcc n - -
+^abc abcc y $& abc
+^abc$ aabc n - -
+abc$ aabc y $& abc
+abc$ aabcd n - -
+^ abc y $&
+$ abc y $&
+a.c abc y $& abc
+a.c axc y $& axc
+a.*c axyzc y $& axyzc
+a.*c axyzd n - -
+a[bc]d abc n - -
+a[bc]d abd y $& abd
+a[b]d abd y $& abd
+[a][b][d] abd y $& abd
+.[b]. abd y $& abd
+.[b]. aBd n - -
+(?i:.[b].) abd y $& abd
+a[b-d]e abd n - -
+a[b-d]e ace y $& ace
+a[b-d] aac y $& ac
+a[-b] a- y $& a-
+a[b-] a- y $& a-
+a[b-a] - c - Invalid [] range \"b-a\"
+a[]b - c - Unmatched [
+a[ - c - Unmatched [
+a] a] y $& a]
+a[]]b a]b y $& a]b
+a[^bc]d aed y $& aed
+a[^bc]d abd n - -
+a[^-b]c adc y $& adc
+a[^-b]c a-c n - -
+a[^]b]c a]c n - -
+a[^]b]c adc y $& adc
+\ba\b a- y - -
+\ba\b -a y - -
+\ba\b -a- y - -
+\by\b xy n - -
+\by\b yz n - -
+\by\b xyz n - -
+\Ba\B a- n - -
+\Ba\B -a n - -
+\Ba\B -a- n - -
+\By\b xy y - -
+\By\b xy y $-[0] 1
+\By\b xy y $+[0] 2
+\By\b xy y - -
+\by\B yz y - -
+\By\B xyz y - -
+\w a y - -
+\w - n - -
+\W a n - -
+\W - y - -
+a\sb a b y - -
+a\sb a-b n - -
+a\Sb a b n - -
+a\Sb a-b y - -
+\d 1 y - -
+\d - n - -
+\D 1 n - -
+\D - y - -
+[\w] a y - -
+[\w] - n - -
+[\W] a n - -
+[\W] - y - -
+a[\s]b a b y - -
+a[\s]b a-b n - -
+a[\S]b a b n - -
+a[\S]b a-b y - -
+[\d] 1 y - -
+[\d] - n - -
+[\D] 1 n - -
+[\D] - y - -
+ab|cd abc y $& ab
+ab|cd abcd y $& ab
+()ef def y $&-$1 ef-
+()ef def y $-[0] 1
+()ef def y $+[0] 3
+()ef def y $-[1] 1
+()ef def y $+[1] 1
+*a - c - Quantifier follows nothing
+(|*)b - c - Quantifier follows nothing
+(*)b - c - Unknown verb
+$b b n - -
+a\ - c - Search pattern not terminated
+a\(b a(b y $&-$1 a(b-
+a\(*b ab y $& ab
+a\(*b a((b y $& a((b
+a\\b a\\b y $& a\\b
+abc) - c - Unmatched )
+(abc - c - Unmatched (
+((a)) abc y $&-$1-$2 a-a-a
+((a)) abc y $-[0]-$-[1]-$-[2] 0-0-0
+((a)) abc y $+[0]-$+[1]-$+[2] 1-1-1
+((a)) abc b @- 0 0 0
+((a)) abc b @+ 1 1 1
+(a)b(c) abc y $&-$1-$2 abc-a-c
+(a)b(c) abc y $-[0]-$-[1]-$-[2] 0-0-2
+(a)b(c) abc y $+[0]-$+[1]-$+[2] 3-1-3
+a+b+c aabbabc y $& abc
+a{1,}b{1,}c aabbabc y $& abc
+a** - c - Nested quantifiers
+a.+?c abcabc y $& abc
+(a+|b)* ab y $&-$1 ab-b
+(a+|b)* ab y $-[0] 0
+(a+|b)* ab y $+[0] 2
+(a+|b)* ab y $-[1] 1
+(a+|b)* ab y $+[1] 2
+(a+|b){0,} ab y $&-$1 ab-b
+(a+|b)+ ab y $&-$1 ab-b
+(a+|b){1,} ab y $&-$1 ab-b
+(a+|b)? ab y $&-$1 a-a
+(a+|b){0,1} ab y $&-$1 a-a
+)( - c - Unmatched )
+[^ab]* cde y $& cde
+abc n - -
+a* y $&
+([abc])*d abbbcd y $&-$1 abbbcd-c
+([abc])*bcd abcd y $&-$1 abcd-a
+a|b|c|d|e e y $& e
+(a|b|c|d|e)f ef y $&-$1 ef-e
+(a|b|c|d|e)f ef y $-[0] 0
+(a|b|c|d|e)f ef y $+[0] 2
+(a|b|c|d|e)f ef y $-[1] 0
+(a|b|c|d|e)f ef y $+[1] 1
+abcd*efg abcdefg y $& abcdefg
+ab* xabyabbbz y $& ab
+ab* xayabbbz y $& a
+(ab|cd)e abcde y $&-$1 cde-cd
+[abhgefdc]ij hij y $& hij
+^(ab|cd)e abcde n x$1y xy
+(abc|)ef abcdef y $&-$1 ef-
+(a|b)c*d abcd y $&-$1 bcd-b
+(ab|ab*)bc abc y $&-$1 abc-a
+a([bc]*)c* abc y $&-$1 abc-bc
+a([bc]*)(c*d) abcd y $&-$1-$2 abcd-bc-d
+a([bc]*)(c*d) abcd y $-[0] 0
+a([bc]*)(c*d) abcd y $+[0] 4
+a([bc]*)(c*d) abcd y $-[1] 1
+a([bc]*)(c*d) abcd y $+[1] 3
+a([bc]*)(c*d) abcd y $-[2] 3
+a([bc]*)(c*d) abcd y $+[2] 4
+a([bc]+)(c*d) abcd y $&-$1-$2 abcd-bc-d
+a([bc]*)(c+d) abcd y $&-$1-$2 abcd-b-cd
+a([bc]*)(c+d) abcd y $-[0] 0
+a([bc]*)(c+d) abcd y $+[0] 4
+a([bc]*)(c+d) abcd y $-[1] 1
+a([bc]*)(c+d) abcd y $+[1] 2
+a([bc]*)(c+d) abcd y $-[2] 2
+a([bc]*)(c+d) abcd y $+[2] 4
+a[bcd]*dcdcde adcdcde y $& adcdcde
+a[bcd]+dcdcde adcdcde n - -
+(ab|a)b*c abc y $&-$1 abc-ab
+(ab|a)b*c abc y $-[0] 0
+(ab|a)b*c abc y $+[0] 3
+(ab|a)b*c abc y $-[1] 0
+(ab|a)b*c abc y $+[1] 2
+((a)(b)c)(d) abcd y $1-$2-$3-$4 abc-a-b-d
+((a)(b)c)(d) abcd y $-[0] 0
+((a)(b)c)(d) abcd y $+[0] 4
+((a)(b)c)(d) abcd y $-[1] 0
+((a)(b)c)(d) abcd y $+[1] 3
+((a)(b)c)(d) abcd y $-[2] 0
+((a)(b)c)(d) abcd y $+[2] 1
+((a)(b)c)(d) abcd y $-[3] 1
+((a)(b)c)(d) abcd y $+[3] 2
+((a)(b)c)(d) abcd y $-[4] 3
+((a)(b)c)(d) abcd y $+[4] 4
+[a-zA-Z_][a-zA-Z0-9_]* alpha y $& alpha
+^a(bc+|b[eh])g|.h$ abh y $&-$1 bh-
+(bc+d$|ef*g.|h?i(j|k)) effgz y $&-$1-$2 effgz-effgz-
+(bc+d$|ef*g.|h?i(j|k)) ij y $&-$1-$2 ij-ij-j
+(bc+d$|ef*g.|h?i(j|k)) effg n - -
+(bc+d$|ef*g.|h?i(j|k)) bcdd n - -
+(bc+d$|ef*g.|h?i(j|k)) reffgz y $&-$1-$2 effgz-effgz-
+((((((((((a)))))))))) a y $10 a
+((((((((((a)))))))))) a y $-[0] 0
+((((((((((a)))))))))) a y $+[0] 1
+((((((((((a)))))))))) a y $-[10] 0
+((((((((((a)))))))))) a y $+[10] 1
+((((((((((a))))))))))\10 aa y $& aa
+((((((((((a))))))))))${bang} aa n - -
+((((((((((a))))))))))${bang} a! y $& a!
+(((((((((a))))))))) a y $& a
+multiple words of text uh-uh n - -
+multiple words multiple words, yeah y $& multiple words
+(.*)c(.*) abcde y $&-$1-$2 abcde-ab-de
+\((.*), (.*)\) (a, b) y ($2, $1) (b, a)
+[k] ab n - -
+abcd abcd y $&-\$&-\\$& abcd-\$&-\\abcd
+a(bc)d abcd y $1-\$1-\\$1 bc-\$1-\\bc
+a[-]?c ac y $& ac
+(abc)\1 abcabc y $1 abc
+([a-c]*)\1 abcabc y $1 abc
+\1 - c - Reference to nonexistent group
+\2 - c - Reference to nonexistent group
+\g1 - c - Reference to nonexistent group
+\g-1 - c - Reference to nonexistent or unclosed group
+\g{1} - c - Reference to nonexistent group
+\g{-1} - c - Reference to nonexistent or unclosed group
+\g0 - c - Reference to invalid group 0
+\g-0 - c - Reference to invalid group 0
+\g{0} - c - Reference to invalid group 0
+\g{-0} - c - Reference to invalid group 0
+(a)|\1 a y - -
+(a)|\1 x n - -
+(a)|\2 - c - Reference to nonexistent group
+(([a-c])b*?\2)* ababbbcbc y $&-$1-$2 ababb-bb-b
+(([a-c])b*?\2){3} ababbbcbc y $&-$1-$2 ababbbcbc-cbc-c
+((\3|b)\2(a)x)+ aaxabxbaxbbx n - -
+((\3|b)\2(a)x)+ aaaxabaxbaaxbbax y $&-$1-$2-$3 bbax-bbax-b-a
+((\3|b)\2(a)){2,} bbaababbabaaaaabbaaaabba y $&-$1-$2-$3 bbaaaabba-bba-b-a
+#Bug #3589 - up to perl-5.6.0 matches incorrectly, from 5.6.1 not anymore
+^((.)?a\2)+$ babadad n - -
+(a)|(b) b y $-[0] 0
+(a)|(b) b y $+[0] 1
+(a)|(b) b y x$-[1] x
+(a)|(b) b y x$+[1] x
+(a)|(b) b y $-[2] 0
+(a)|(b) b y $+[2] 1
+'abc'i ABC y $& ABC
+'abc'i XBC n - -
+'abc'i AXC n - -
+'abc'i ABX n - -
+'abc'i XABCY y $& ABC
+'abc'i ABABC y $& ABC
+'ab*c'i ABC y $& ABC
+'ab*bc'i ABC y $& ABC
+'ab*bc'i ABBC y $& ABBC
+'ab*?bc'i ABBBBC y $& ABBBBC
+'ab{0,}?bc'i ABBBBC y $& ABBBBC
+'ab+?bc'i ABBC y $& ABBC
+'ab+bc'i ABC n - -
+'ab+bc'i ABQ n - -
+'ab{1,}bc'i ABQ n - -
+'ab+bc'i ABBBBC y $& ABBBBC
+'ab{1,}?bc'i ABBBBC y $& ABBBBC
+'ab{1,3}?bc'i ABBBBC y $& ABBBBC
+'ab{3,4}?bc'i ABBBBC y $& ABBBBC
+'ab{4,5}?bc'i ABBBBC n - -
+'ab??bc'i ABBC y $& ABBC
+'ab??bc'i ABC y $& ABC
+'ab{0,1}?bc'i ABC y $& ABC
+'ab??bc'i ABBBBC n - -
+'ab??c'i ABC y $& ABC
+'ab{0,1}?c'i ABC y $& ABC
+'^abc$'i ABC y $& ABC
+'^abc$'i ABCC n - -
+'^abc'i ABCC y $& ABC
+'^abc$'i AABC n - -
+'abc$'i AABC y $& ABC
+'^'i ABC y $&
+'$'i ABC y $&
+'a.c'i ABC y $& ABC
+'a.c'i AXC y $& AXC
+'a.*?c'i AXYZC y $& AXYZC
+'a.*c'i AXYZD n - -
+'a[bc]d'i ABC n - -
+'a[bc]d'i ABD y $& ABD
+'a[b-d]e'i ABD n - -
+'a[b-d]e'i ACE y $& ACE
+'a[b-d]'i AAC y $& AC
+'a[-b]'i A- y $& A-
+'a[b-]'i A- y $& A-
+'a[b-a]'i - c - Invalid [] range \"b-a\"
+'a[]b'i - c - Unmatched [
+'a['i - c - Unmatched [
+'a]'i A] y $& A]
+'a[]]b'i A]B y $& A]B
+'a[^bc]d'i AED y $& AED
+'a[^bc]d'i ABD n - -
+'a[^-b]c'i ADC y $& ADC
+'a[^-b]c'i A-C n - -
+'a[^]b]c'i A]C n - -
+'a[^]b]c'i ADC y $& ADC
+'ab|cd'i ABC y $& AB
+'ab|cd'i ABCD y $& AB
+'()ef'i DEF y $&-$1 EF-
+'*a'i - c - Quantifier follows nothing
+'(|*)b'i - c - Quantifier follows nothing
+'(*)b'i - c - Unknown verb
+'$b'i B n - -
+'a\'i - c - Search pattern not terminated
+'a\(b'i A(B y $&-$1 A(B-
+'a\(*b'i AB y $& AB
+'a\(*b'i A((B y $& A((B
+'a\\b'i A\\B y $& A\\B
+'abc)'i - c - Unmatched )
+'(abc'i - c - Unmatched (
+'((a))'i ABC y $&-$1-$2 A-A-A
+'(a)b(c)'i ABC y $&-$1-$2 ABC-A-C
+'a+b+c'i AABBABC y $& ABC
+'a{1,}b{1,}c'i AABBABC y $& ABC
+'a**'i - c - Nested quantifiers
+'a.+?c'i ABCABC y $& ABC
+'a.*?c'i ABCABC y $& ABC
+'a.{0,5}?c'i ABCABC y $& ABC
+'(a+|b)*'i AB y $&-$1 AB-B
+'(a+|b){0,}'i AB y $&-$1 AB-B
+'(a+|b)+'i AB y $&-$1 AB-B
+'(a+|b){1,}'i AB y $&-$1 AB-B
+'(a+|b)?'i AB y $&-$1 A-A
+'(a+|b){0,1}'i AB y $&-$1 A-A
+'(a+|b){0,1}?'i AB y $&-$1 -
+')('i - c - Unmatched )
+'[^ab]*'i CDE y $& CDE
+'abc'i n - -
+'a*'i y $&
+'([abc])*d'i ABBBCD y $&-$1 ABBBCD-C
+'([abc])*bcd'i ABCD y $&-$1 ABCD-A
+'a|b|c|d|e'i E y $& E
+'(a|b|c|d|e)f'i EF y $&-$1 EF-E
+'abcd*efg'i ABCDEFG y $& ABCDEFG
+'ab*'i XABYABBBZ y $& AB
+'ab*'i XAYABBBZ y $& A
+'(ab|cd)e'i ABCDE y $&-$1 CDE-CD
+'[abhgefdc]ij'i HIJ y $& HIJ
+'^(ab|cd)e'i ABCDE n x$1y XY
+'(abc|)ef'i ABCDEF y $&-$1 EF-
+'(a|b)c*d'i ABCD y $&-$1 BCD-B
+'(ab|ab*)bc'i ABC y $&-$1 ABC-A
+'a([bc]*)c*'i ABC y $&-$1 ABC-BC
+'a([bc]*)(c*d)'i ABCD y $&-$1-$2 ABCD-BC-D
+'a([bc]+)(c*d)'i ABCD y $&-$1-$2 ABCD-BC-D
+'a([bc]*)(c+d)'i ABCD y $&-$1-$2 ABCD-B-CD
+'a[bcd]*dcdcde'i ADCDCDE y $& ADCDCDE
+'a[bcd]+dcdcde'i ADCDCDE n - -
+'(ab|a)b*c'i ABC y $&-$1 ABC-AB
+'((a)(b)c)(d)'i ABCD y $1-$2-$3-$4 ABC-A-B-D
+'[a-zA-Z_][a-zA-Z0-9_]*'i ALPHA y $& ALPHA
+'^a(bc+|b[eh])g|.h$'i ABH y $&-$1 BH-
+'(bc+d$|ef*g.|h?i(j|k))'i EFFGZ y $&-$1-$2 EFFGZ-EFFGZ-
+'(bc+d$|ef*g.|h?i(j|k))'i IJ y $&-$1-$2 IJ-IJ-J
+'(bc+d$|ef*g.|h?i(j|k))'i EFFG n - -
+'(bc+d$|ef*g.|h?i(j|k))'i BCDD n - -
+'(bc+d$|ef*g.|h?i(j|k))'i REFFGZ y $&-$1-$2 EFFGZ-EFFGZ-
+'((((((((((a))))))))))'i A y $10 A
+'((((((((((a))))))))))\10'i AA y $& AA
+'((((((((((a))))))))))${bang}'i AA n - -
+'((((((((((a))))))))))${bang}'i A! y $& A!
+'(((((((((a)))))))))'i A y $& A
+'(?:(?:(?:(?:(?:(?:(?:(?:(?:(a))))))))))'i A y $1 A
+'(?:(?:(?:(?:(?:(?:(?:(?:(?:(a|b|c))))))))))'i C y $1 C
+'multiple words of text'i UH-UH n - -
+'multiple words'i MULTIPLE WORDS, YEAH y $& MULTIPLE WORDS
+'(.*)c(.*)'i ABCDE y $&-$1-$2 ABCDE-AB-DE
+'\((.*), (.*)\)'i (A, B) y ($2, $1) (B, A)
+'[k]'i AB n - -
+'abcd'i ABCD y $&-\$&-\\$& ABCD-\$&-\\ABCD
+'a(bc)d'i ABCD y $1-\$1-\\$1 BC-\$1-\\BC
+'a[-]?c'i AC y $& AC
+'(abc)\1'i ABCABC y $1 ABC
+'([a-c]*)\1'i ABCABC y $1 ABC
+a(?!b). abad y $& ad
+(?=)a a y $& a
+a(?=d). abad y $& ad
+a(?=c|d). abad y $& ad
+a(?:b|c|d)(.) ace y $1 e
+a(?:b|c|d)*(.) ace y $1 e
+a(?:b|c|d)+?(.) ace y $1 e
+a(?:b|c|d)+?(.) acdbcdbe y $1 d
+a(?:b|c|d)+(.) acdbcdbe y $1 e
+a(?:b|c|d){2}(.) acdbcdbe y $1 b
+a(?:b|c|d){4,5}(.) acdbcdbe y $1 b
+a(?:b|c|d){4,5}?(.) acdbcdbe y $1 d
+((foo)|(bar))* foobar y $1-$2-$3 bar-foo-bar
+:(?: - c - Sequence (? incomplete
+a(?:b|c|d){6,7}(.) acdbcdbe y $1 e
+a(?:b|c|d){6,7}?(.) acdbcdbe y $1 e
+a(?:b|c|d){5,6}(.) acdbcdbe y $1 e
+a(?:b|c|d){5,6}?(.) acdbcdbe y $1 b
+a(?:b|c|d){5,7}(.) acdbcdbe y $1 e
+a(?:b|c|d){5,7}?(.) acdbcdbe y $1 b
+a(?:b|(c|e){1,2}?|d)+?(.) ace y $1$2 ce
+^(.+)?B AB y $1 A
+^([^a-z])|(\^)$ . y $1 .
+^[<>]& <&OUT y $& <&
+^(a\1?){4}$ aaaaaaaaaa y $1 aaaa
+^(a\1?){4}$ aaaaaaaaa n - -
+^(a\1?){4}$ aaaaaaaaaaa n - -
+^(a(?(1)\1)){4}$ aaaaaaaaaa y $1 aaaa
+^(a(?(1)\1)){4}$ aaaaaaaaa n - -
+^(a(?(1)\1)){4}$ aaaaaaaaaaa n - -
+((a{4})+) aaaaaaaaa y $1 aaaaaaaa
+(((aa){2})+) aaaaaaaaaa y $1 aaaaaaaa
+(((a{2}){2})+) aaaaaaaaaa y $1 aaaaaaaa
+(?:(f)(o)(o)|(b)(a)(r))* foobar y $1:$2:$3:$4:$5:$6 f:o:o:b:a:r
+(?<=a)b ab y $& b
+(?<=a)b cb n - -
+(?<=a)b b n - -
+(?<!c)b ab y $& b
+(?<!c)b cb n - -
+(?<!c)b b y - -
+(?<!c)b b y $& b
+(?<%)b - c - Sequence (?<%...) not recognized
+(?:..)*a aba y $& aba
+(?:..)*?a aba y $& a
+^(?:b|a(?=(.)))*\1 abc y $& ab
+^(){3,5} abc y a$1 a
+^(a+)*ax aax y $1 a
+^((a|b)+)*ax aax y $1 a
+^((a|bc)+)*ax aax y $1 a
+(a|x)*ab cab y y$1 y
+(a)*ab cab y y$1 y
+(?:(?i)a)b ab y $& ab
+((?i)a)b ab y $&:$1 ab:a
+(?:(?i)a)b Ab y $& Ab
+((?i)a)b Ab y $&:$1 Ab:A
+(?:(?i)a)b aB n - -
+((?i)a)b aB n - -
+(?i:a)b ab y $& ab
+((?i:a))b ab y $&:$1 ab:a
+(?i:a)b Ab y $& Ab
+((?i:a))b Ab y $&:$1 Ab:A
+(?i:a)b aB n - -
+((?i:a))b aB n - -
+'(?:(?-i)a)b'i ab y $& ab
+'((?-i)a)b'i ab y $&:$1 ab:a
+'(?:(?-i)a)b'i aB y $& aB
+'((?-i)a)b'i aB y $&:$1 aB:a
+'(?:(?-i)a)b'i Ab n - -
+'((?-i)a)b'i Ab n - -
+'(?:(?-i)a)b'i aB y $& aB
+'((?-i)a)b'i aB y $1 a
+'(?:(?-i)a)b'i AB n - -
+'((?-i)a)b'i AB n - -
+'(?-i:a)b'i ab y $& ab
+'((?-i:a))b'i ab y $&:$1 ab:a
+'(?-i:a)b'i aB y $& aB
+'((?-i:a))b'i aB y $&:$1 aB:a
+'(?-i:a)b'i Ab n - -
+'((?-i:a))b'i Ab n - -
+'(?-i:a)b'i aB y $& aB
+'((?-i:a))b'i aB y $1 a
+'(?-i:a)b'i AB n - -
+'((?-i:a))b'i AB n - -
+'((?-i:a.))b'i a\nB n - -
+'((?s-i:a.))b'i a\nB y $1 a\n
+'((?s-i:a.))b'i B\nB n - -
+(?:c|d)(?:)(?:a(?:)(?:b)(?:b(?:))(?:b(?:)(?:b))) cabbbb y $& cabbbb
+(?:c|d)(?:)(?:aaaaaaaa(?:)(?:bbbbbbbb)(?:bbbbbbbb(?:))(?:bbbbbbbb(?:)(?:bbbbbbbb))) caaaaaaaabbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb y $& caaaaaaaabbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb
+'(ab)\d\1'i Ab4ab y $1 Ab
+'(ab)\d\1'i ab4Ab y $1 ab
+foo\w*\d{4}baz foobar1234baz y $& foobar1234baz
+a(?{})b cabd y $& ab
+a(?{)b - c - Sequence (?{...}) not terminated or not {}-balanced
+a(?{{})b - c - Sequence (?{...}) not terminated or not {}-balanced
+a(?{}})b - c -
+a(?{"{"})b - c - Sequence (?{...}) not terminated or not {}-balanced
+a(?{"\{"})b cabd y $& ab
+a(?{"{"}})b - c - Unmatched right curly bracket
+a(?{$::bl="\{"}).b caxbd y $::bl {
+x(~~)*(?:(?:F)?)? x~~ y - -
+^a(?#xxx){3}c aaac y $& aaac
+'^a (?#xxx) (?#yyy) {3}c'x aaac y $& aaac
+(?<![cd])b dbcb n - -
+(?<![cd])[ab] dbaacb y $& a
+(?<!(c|d))b dbcb n - -
+(?<!(c|d))[ab] dbaacb y $& a
+(?<!cd)[ab] cdaccb y $& b
+^(?:a?b?)*$ a-- n - -
+((?s)^a(.))((?m)^b$) a\nb\nc\n y $1;$2;$3 a\n;\n;b
+((?m)^b$) a\nb\nc\n y $1 b
+(?m)^b a\nb\n y $& b
+(?m)^(b) a\nb\n y $1 b
+((?m)^b) a\nb\n y $1 b
+\n((?m)^b) a\nb\n y $1 b
+((?s).)c(?!.) a\nb\nc\n y $1 \n
+((?s).)c(?!.) a\nb\nc\n y $1:$& \n:\nc
+((?s)b.)c(?!.) a\nb\nc\n y $1 b\n
+((?s)b.)c(?!.) a\nb\nc\n y $1:$& b\n:b\nc
+^b a\nb\nc\n n - -
+()^b a\nb\nc\n n - -
+((?m)^b) a\nb\nc\n y $1 b
+(?(1)a|b) a n - -
+(?(1)b|a) a y $& a
+(x)?(?(1)a|b) a n - -
+(x)?(?(1)b|a) a y $& a
+()?(?(1)b|a) a y $& a
+()(?(1)b|a) a n - -
+()?(?(1)a|b) a y $& a
+^(\()?blah(?(1)(\)))$ (blah) y $2 )
+^(\()?blah(?(1)(\)))$ blah y ($2) ()
+^(\()?blah(?(1)(\)))$ blah) n - -
+^(\()?blah(?(1)(\)))$ (blah n - -
+^(\(+)?blah(?(1)(\)))$ (blah) y $2 )
+^(\(+)?blah(?(1)(\)))$ blah y ($2) ()
+^(\(+)?blah(?(1)(\)))$ blah) n - -
+^(\(+)?blah(?(1)(\)))$ (blah n - -
+(?(1?)a|b) a c - Switch condition not recognized
+(?(1)a|b|c) a c - Switch (?(condition)... contains too many branches
+(?(?{0})a|b) a n - -
+(?(?{0})b|a) a y $& a
+(?(?{1})b|a) a n - -
+(?(?{1})a|b) a y $& a
+(?(?!a)a|b) a n - -
+(?(?!a)b|a) a y $& a
+(?(?=a)b|a) a n - -
+(?(?=a)a|b) a y $& a
+(?=(a+?))(\1ab) aaab y $2 aab
+^(?=(a+?))\1ab aaab n - -
+(\w+:)+ one: y $1 one:
+$(?<=^(a)) a y $1 a
+(?=(a+?))(\1ab) aaab y $2 aab
+^(?=(a+?))\1ab aaab n - -
+([\w:]+::)?(\w+)$ abcd: n - -
+([\w:]+::)?(\w+)$ abcd y $1-$2 -abcd
+([\w:]+::)?(\w+)$ xy:z:::abcd y $1-$2 xy:z:::-abcd
+^[^bcd]*(c+) aexycd y $1 c
+(a*)b+ caab y $1 aa
+([\w:]+::)?(\w+)$ abcd: n - -
+([\w:]+::)?(\w+)$ abcd y $1-$2 -abcd
+([\w:]+::)?(\w+)$ xy:z:::abcd y $1-$2 xy:z:::-abcd
+^[^bcd]*(c+) aexycd y $1 c
+(?{$a=2})a*aa(?{local$a=$a+1})k*c(?{$b=$a}) yaaxxaaaacd y $b 3
+(?{$a=2})(a(?{local$a=$a+1}))*aak*c(?{$b=$a}) yaaxxaaaacd y $b 4
+(>a+)ab aaab n - -
+(?>a+)b aaab y - -
+([[:]+) a:[b]: y $1 :[
+([[=]+) a=[b]= y $1 =[
+([[.]+) a.[b]. y $1 .[
+[a[:xyz: - c - Unmatched [
+[a[:xyz:] - c - POSIX class [:xyz:] unknown
+[a[:]b[:c] abc y $& abc
+([a[:xyz:]b]+) pbaq c - POSIX class [:xyz:] unknown
+[a[:]b[:c] abc y $& abc
+([[:alpha:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd
+([[:alnum:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy
+([[:ascii:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy__-- ${nulnul}
+([[:cntrl:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ${nulnul}
+([[:digit:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 01
+([[:graph:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy__--
+([[:lower:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 cd
+([[:print:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy__--
+([[:punct:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 __--
+([[:space:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1
+([[:word:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy__
+([[:upper:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 AB
+([[:xdigit:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01
+([[:^alpha:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 01
+([[:^alnum:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 __-- ${nulnul}${ffff}
+([[:^ascii:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ${ffff}
+([[:^cntrl:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy__--
+([[:^digit:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd
+([[:^lower:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 AB
+([[:^print:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ${nulnul}${ffff}
+([[:^punct:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy
+([[:^space:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy__--
+([[:^word:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 -- ${nulnul}${ffff}
+([[:^upper:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 cd01
+([[:^xdigit:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 Xy__-- ${nulnul}${ffff}
+[[:foo:]] - c - POSIX class [:foo:] unknown
+[[:^foo:]] - c - POSIX class [:^foo:] unknown
+((?>a+)b) aaab y $1 aaab
+(?>(a+))b aaab y $1 aaa
+((?>[^()]+)|\([^()]*\))+ ((abc(ade)ufh()()x y $& abc(ade)ufh()()x
+(?<=x+)y - c - Variable length lookbehind not implemented
+a{37,17} - c - Can't do {n,m} with n > m
+a{37,0} - c - Can't do {n,m} with n > m
+\Z a\nb\n y $-[0] 3
+\z a\nb\n y $-[0] 4
+$ a\nb\n y $-[0] 3
+\Z b\na\n y $-[0] 3
+\z b\na\n y $-[0] 4
+$ b\na\n y $-[0] 3
+\Z b\na y $-[0] 3
+\z b\na y $-[0] 3
+$ b\na y $-[0] 3
+'\Z'm a\nb\n y $-[0] 3
+'\z'm a\nb\n y $-[0] 4
+'$'m a\nb\n y $-[0] 1
+'\Z'm b\na\n y $-[0] 3
+'\z'm b\na\n y $-[0] 4
+'$'m b\na\n y $-[0] 1
+'\Z'm b\na y $-[0] 3
+'\z'm b\na y $-[0] 3
+'$'m b\na y $-[0] 1
+a\Z a\nb\n n - -
+a\z a\nb\n n - -
+a$ a\nb\n n - -
+a\Z b\na\n y $-[0] 2
+a\z b\na\n n - -
+a$ b\na\n y $-[0] 2
+a\Z b\na y $-[0] 2
+a\z b\na y $-[0] 2
+a$ b\na y $-[0] 2
+'a\Z'm a\nb\n n - -
+'a\z'm a\nb\n n - -
+'a$'m a\nb\n y $-[0] 0
+'a\Z'm b\na\n y $-[0] 2
+'a\z'm b\na\n n - -
+'a$'m b\na\n y $-[0] 2
+'a\Z'm b\na y $-[0] 2
+'a\z'm b\na y $-[0] 2
+'a$'m b\na y $-[0] 2
+aa\Z aa\nb\n n - -
+aa\z aa\nb\n n - -
+aa$ aa\nb\n n - -
+aa\Z b\naa\n y $-[0] 2
+aa\z b\naa\n n - -
+aa$ b\naa\n y $-[0] 2
+aa\Z b\naa y $-[0] 2
+aa\z b\naa y $-[0] 2
+aa$ b\naa y $-[0] 2
+'aa\Z'm aa\nb\n n - -
+'aa\z'm aa\nb\n n - -
+'aa$'m aa\nb\n y $-[0] 0
+'aa\Z'm b\naa\n y $-[0] 2
+'aa\z'm b\naa\n n - -
+'aa$'m b\naa\n y $-[0] 2
+'aa\Z'm b\naa y $-[0] 2
+'aa\z'm b\naa y $-[0] 2
+'aa$'m b\naa y $-[0] 2
+aa\Z ac\nb\n n - -
+aa\z ac\nb\n n - -
+aa$ ac\nb\n n - -
+aa\Z b\nac\n n - -
+aa\z b\nac\n n - -
+aa$ b\nac\n n - -
+aa\Z b\nac n - -
+aa\z b\nac n - -
+aa$ b\nac n - -
+'aa\Z'm ac\nb\n n - -
+'aa\z'm ac\nb\n n - -
+'aa$'m ac\nb\n n - -
+'aa\Z'm b\nac\n n - -
+'aa\z'm b\nac\n n - -
+'aa$'m b\nac\n n - -
+'aa\Z'm b\nac n - -
+'aa\z'm b\nac n - -
+'aa$'m b\nac n - -
+aa\Z ca\nb\n n - -
+aa\z ca\nb\n n - -
+aa$ ca\nb\n n - -
+aa\Z b\nca\n n - -
+aa\z b\nca\n n - -
+aa$ b\nca\n n - -
+aa\Z b\nca n - -
+aa\z b\nca n - -
+aa$ b\nca n - -
+'aa\Z'm ca\nb\n n - -
+'aa\z'm ca\nb\n n - -
+'aa$'m ca\nb\n n - -
+'aa\Z'm b\nca\n n - -
+'aa\z'm b\nca\n n - -
+'aa$'m b\nca\n n - -
+'aa\Z'm b\nca n - -
+'aa\z'm b\nca n - -
+'aa$'m b\nca n - -
+ab\Z ab\nb\n n - -
+ab\z ab\nb\n n - -
+ab$ ab\nb\n n - -
+ab\Z b\nab\n y $-[0] 2
+ab\z b\nab\n n - -
+ab$ b\nab\n y $-[0] 2
+ab\Z b\nab y $-[0] 2
+ab\z b\nab y $-[0] 2
+ab$ b\nab y $-[0] 2
+'ab\Z'm ab\nb\n n - -
+'ab\z'm ab\nb\n n - -
+'ab$'m ab\nb\n y $-[0] 0
+'ab\Z'm b\nab\n y $-[0] 2
+'ab\z'm b\nab\n n - -
+'ab$'m b\nab\n y $-[0] 2
+'ab\Z'm b\nab y $-[0] 2
+'ab\z'm b\nab y $-[0] 2
+'ab$'m b\nab y $-[0] 2
+ab\Z ac\nb\n n - -
+ab\z ac\nb\n n - -
+ab$ ac\nb\n n - -
+ab\Z b\nac\n n - -
+ab\z b\nac\n n - -
+ab$ b\nac\n n - -
+ab\Z b\nac n - -
+ab\z b\nac n - -
+ab$ b\nac n - -
+'ab\Z'm ac\nb\n n - -
+'ab\z'm ac\nb\n n - -
+'ab$'m ac\nb\n n - -
+'ab\Z'm b\nac\n n - -
+'ab\z'm b\nac\n n - -
+'ab$'m b\nac\n n - -
+'ab\Z'm b\nac n - -
+'ab\z'm b\nac n - -
+'ab$'m b\nac n - -
+ab\Z ca\nb\n n - -
+ab\z ca\nb\n n - -
+ab$ ca\nb\n n - -
+ab\Z b\nca\n n - -
+ab\z b\nca\n n - -
+ab$ b\nca\n n - -
+ab\Z b\nca n - -
+ab\z b\nca n - -
+ab$ b\nca n - -
+'ab\Z'm ca\nb\n n - -
+'ab\z'm ca\nb\n n - -
+'ab$'m ca\nb\n n - -
+'ab\Z'm b\nca\n n - -
+'ab\z'm b\nca\n n - -
+'ab$'m b\nca\n n - -
+'ab\Z'm b\nca n - -
+'ab\z'm b\nca n - -
+'ab$'m b\nca n - -
+abb\Z abb\nb\n n - -
+abb\z abb\nb\n n - -
+abb$ abb\nb\n n - -
+abb\Z b\nabb\n y $-[0] 2
+abb\z b\nabb\n n - -
+abb$ b\nabb\n y $-[0] 2
+abb\Z b\nabb y $-[0] 2
+abb\z b\nabb y $-[0] 2
+abb$ b\nabb y $-[0] 2
+'abb\Z'm abb\nb\n n - -
+'abb\z'm abb\nb\n n - -
+'abb$'m abb\nb\n y $-[0] 0
+'abb\Z'm b\nabb\n y $-[0] 2
+'abb\z'm b\nabb\n n - -
+'abb$'m b\nabb\n y $-[0] 2
+'abb\Z'm b\nabb y $-[0] 2
+'abb\z'm b\nabb y $-[0] 2
+'abb$'m b\nabb y $-[0] 2
+abb\Z ac\nb\n n - -
+abb\z ac\nb\n n - -
+abb$ ac\nb\n n - -
+abb\Z b\nac\n n - -
+abb\z b\nac\n n - -
+abb$ b\nac\n n - -
+abb\Z b\nac n - -
+abb\z b\nac n - -
+abb$ b\nac n - -
+'abb\Z'm ac\nb\n n - -
+'abb\z'm ac\nb\n n - -
+'abb$'m ac\nb\n n - -
+'abb\Z'm b\nac\n n - -
+'abb\z'm b\nac\n n - -
+'abb$'m b\nac\n n - -
+'abb\Z'm b\nac n - -
+'abb\z'm b\nac n - -
+'abb$'m b\nac n - -
+abb\Z ca\nb\n n - -
+abb\z ca\nb\n n - -
+abb$ ca\nb\n n - -
+abb\Z b\nca\n n - -
+abb\z b\nca\n n - -
+abb$ b\nca\n n - -
+abb\Z b\nca n - -
+abb\z b\nca n - -
+abb$ b\nca n - -
+'abb\Z'm ca\nb\n n - -
+'abb\z'm ca\nb\n n - -
+'abb$'m ca\nb\n n - -
+'abb\Z'm b\nca\n n - -
+'abb\z'm b\nca\n n - -
+'abb$'m b\nca\n n - -
+'abb\Z'm b\nca n - -
+'abb\z'm b\nca n - -
+'abb$'m b\nca n - -
+(^|x)(c) ca y $2 c
+a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz x n - -
+a(?{$a=2;$b=3;($b)=$a})b yabz y $b 2
+round\(((?>[^()]+))\) _I(round(xs * sz),1) y $1 xs * sz
+'((?x:.) )' x y $1- x -
+'((?-x:.) )'x x y $1- x-
+foo.bart foo.bart y - -
+'^d[x][x][x]'m abcd\ndxxx y - -
+.X(.+)+X bbbbXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - -
+.X(.+)+XX bbbbXcXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - -
+.XX(.+)+X bbbbXXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - -
+.X(.+)+X bbbbXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - -
+.X(.+)+XX bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - -
+.XX(.+)+X bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - -
+.X(.+)+[X] bbbbXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - -
+.X(.+)+[X][X] bbbbXcXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - -
+.XX(.+)+[X] bbbbXXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - -
+.X(.+)+[X] bbbbXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - -
+.X(.+)+[X][X] bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - -
+.XX(.+)+[X] bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - -
+.[X](.+)+[X] bbbbXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - -
+.[X](.+)+[X][X] bbbbXcXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - -
+.[X][X](.+)+[X] bbbbXXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - -
+.[X](.+)+[X] bbbbXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - -
+.[X](.+)+[X][X] bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - -
+.[X][X](.+)+[X] bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - -
+tt+$ xxxtt y - -
+([a-\d]+) za-9z y $1 a-9
+([\d-z]+) a0-za y $1 0-z
+([\d-\s]+) a0- z y $1 0-
+([a-[:digit:]]+) za-9z y $1 a-9
+([[:digit:]-z]+) =0-z= y $1 0-z
+([[:digit:]-[:alpha:]]+) =0-z= y $1 0-z
+\GX.*X aaaXbX n - -
+(\d+\.\d+) 3.1415926 y $1 3.1415926
+(\ba.{0,10}br) have a web browser y $1 a web br
+'\.c(pp|xx|c)?$'i Changes n - -
+'\.c(pp|xx|c)?$'i IO.c y - -
+'(\.c(pp|xx|c)?$)'i IO.c y $1 .c
+^([a-z]:) C:/ n - -
+'^\S\s+aa$'m \nx aa y - -
+(^|a)b ab y - -
+^([ab]*?)(b)?(c)$ abac y -$2- --
+(\w)?(abc)\1b abcab n - -
+^(?:.,){2}c a,b,c y - -
+^(.,){2}c a,b,c y $1 b,
+^(?:[^,]*,){2}c a,b,c y - -
+^([^,]*,){2}c a,b,c y $1 b,
+^([^,]*,){3}d aaa,b,c,d y $1 c,
+^([^,]*,){3,}d aaa,b,c,d y $1 c,
+^([^,]*,){0,3}d aaa,b,c,d y $1 c,
+^([^,]{1,3},){3}d aaa,b,c,d y $1 c,
+^([^,]{1,3},){3,}d aaa,b,c,d y $1 c,
+^([^,]{1,3},){0,3}d aaa,b,c,d y $1 c,
+^([^,]{1,},){3}d aaa,b,c,d y $1 c,
+^([^,]{1,},){3,}d aaa,b,c,d y $1 c,
+^([^,]{1,},){0,3}d aaa,b,c,d y $1 c,
+^([^,]{0,3},){3}d aaa,b,c,d y $1 c,
+^([^,]{0,3},){3,}d aaa,b,c,d y $1 c,
+^([^,]{0,3},){0,3}d aaa,b,c,d y $1 c,
+(?i) y - -
+'(?!\A)x'm a\nxb\n y - -
+^(a(b)?)+$ aba y -$1-$2- -a--
+^(aa(bb)?)+$ aabbaa y -$1-$2- -aa--
+'^.{9}abc.*\n'm 123\nabcabcabcabc\n y - -
+^(a)?a$ a y -$1- --
+^(a)?(?(1)a|b)+$ a n - -
+^(a\1?)(a\1?)(a\2?)(a\3?)$ aaaaaa y $1,$2,$3,$4 a,aa,a,aa
+^(a\1?){4}$ aaaaaa y $1 aa
+^(0+)?(?:x(1))? x1 y - -
+^([0-9a-fA-F]+)(?:x([0-9a-fA-F]+)?)(?:x([0-9a-fA-F]+))? 012cxx0190 y - -
+^(b+?|a){1,2}c bbbac y $1 a
+^(b+?|a){1,2}c bbbbac y $1 a
+\((\w\. \w+)\) cd. (A. Tw) y -$1- -A. Tw-
+((?:aaaa|bbbb)cccc)? aaaacccc y - -
+((?:aaaa|bbbb)cccc)? bbbbcccc y - -
+(a)?(a)+ a y $1:$2 :a -
+(ab)?(ab)+ ab y $1:$2 :ab -
+(abc)?(abc)+ abc y $1:$2 :abc -
+'b\s^'m a\nb\n n - -
+\ba a y - -
+^(a(??{"(?!)"})|(a)(?{1}))b ab y $2 a # [ID 20010811.006]
+ab(?i)cd AbCd n - - # [ID 20010809.023]
+ab(?i)cd abCd y - -
+(A|B)*(?(1)(CD)|(CD)) CD y $2-$3 -CD
+(A|B)*(?(1)(CD)|(CD)) ABCD y $2-$3 CD-
+(A|B)*?(?(1)(CD)|(CD)) CD y $2-$3 -CD # [ID 20010803.016]
+(A|B)*?(?(1)(CD)|(CD)) ABCD y $2-$3 CD-
+'^(o)(?!.*\1)'i Oo n - -
+(.*)\d+\1 abc12bc y $1 bc
+(?m:(foo\s*$)) foo\n bar y $1 foo
+(.*)c abcd y $1 ab
+(.*)(?=c) abcd y $1 ab
+(.*)(?=c)c abcd yB $1 ab
+(.*)(?=b|c) abcd y $1 ab
+(.*)(?=b|c)c abcd y $1 ab
+(.*)(?=c|b) abcd y $1 ab
+(.*)(?=c|b)c abcd y $1 ab
+(.*)(?=[bc]) abcd y $1 ab
+(.*)(?=[bc])c abcd yB $1 ab
+(.*)(?<=b) abcd y $1 ab
+(.*)(?<=b)c abcd y $1 ab
+(.*)(?<=b|c) abcd y $1 abc
+(.*)(?<=b|c)c abcd y $1 ab
+(.*)(?<=c|b) abcd y $1 abc
+(.*)(?<=c|b)c abcd y $1 ab
+(.*)(?<=[bc]) abcd y $1 abc
+(.*)(?<=[bc])c abcd y $1 ab
+(.*?)c abcd y $1 ab
+(.*?)(?=c) abcd y $1 ab
+(.*?)(?=c)c abcd yB $1 ab
+(.*?)(?=b|c) abcd y $1 a
+(.*?)(?=b|c)c abcd y $1 ab
+(.*?)(?=c|b) abcd y $1 a
+(.*?)(?=c|b)c abcd y $1 ab
+(.*?)(?=[bc]) abcd y $1 a
+(.*?)(?=[bc])c abcd yB $1 ab
+(.*?)(?<=b) abcd y $1 ab
+(.*?)(?<=b)c abcd y $1 ab
+(.*?)(?<=b|c) abcd y $1 ab
+(.*?)(?<=b|c)c abcd y $1 ab
+(.*?)(?<=c|b) abcd y $1 ab
+(.*?)(?<=c|b)c abcd y $1 ab
+(.*?)(?<=[bc]) abcd y $1 ab
+(.*?)(?<=[bc])c abcd y $1 ab
+2(]*)?$\1 2 y $& 2
+(??{}) x y - -
+a(b)?? abc y <$1> <> # undef [perl #16773]
+(\d{1,3}\.){3,} 128.134.142.8 y <$1> <142.> # [perl #18019]
+^.{3,4}(.+)\1\z foobarbar y $1 bar # 16 tests for [perl #23171]
+^(?:f|o|b){3,4}(.+)\1\z foobarbar y $1 bar
+^.{3,4}((?:b|a|r)+)\1\z foobarbar y $1 bar
+^(?:f|o|b){3,4}((?:b|a|r)+)\1\z foobarbar y $1 bar
+^.{3,4}(.+?)\1\z foobarbar y $1 bar
+^(?:f|o|b){3,4}(.+?)\1\z foobarbar y $1 bar
+^.{3,4}((?:b|a|r)+?)\1\z foobarbar y $1 bar
+^(?:f|o|b){3,4}((?:b|a|r)+?)\1\z foobarbar y $1 bar
+^.{2,3}?(.+)\1\z foobarbar y $1 bar
+^(?:f|o|b){2,3}?(.+)\1\z foobarbar y $1 bar
+^.{2,3}?((?:b|a|r)+)\1\z foobarbar y $1 bar
+^(?:f|o|b){2,3}?((?:b|a|r)+)\1\z foobarbar y $1 bar
+^.{2,3}?(.+?)\1\z foobarbar y $1 bar
+^(?:f|o|b){2,3}?(.+?)\1\z foobarbar y $1 bar
+^.{2,3}?((?:b|a|r)+?)\1\z foobarbar y $1 bar
+^(?:f|o|b){2,3}?((?:b|a|r)+?)\1\z foobarbar y $1 bar
+.*a(?!(b|cd)*e).*f ......abef n - - # [perl #23030]
+x(?# x c - Sequence (?#... not terminated
+:x(?#: x c - Sequence (?#... not terminated
+(WORDS|WORD)S WORDS y $1 WORD
+(X.|WORDS|X.|WORD)S WORDS y $1 WORD
+(WORDS|WORLD|WORD)S WORDS y $1 WORD
+(X.|WORDS|WORD|Y.)S WORDS y $1 WORD
+(foo|fool|x.|money|parted)$ fool y $1 fool
+(x.|foo|fool|x.|money|parted|y.)$ fool y $1 fool
+(foo|fool|money|parted)$ fool y $1 fool
+(foo|fool|x.|money|parted)$ fools n - -
+(x.|foo|fool|x.|money|parted|y.)$ fools n - -
+(foo|fool|money|parted)$ fools n - -
+(a|aa|aaa||aaaa|aaaaa|aaaaaa)(b|c) aaaaaaaaaaaaaaab y $1$2 aaaaaab
+(a|aa|aaa||aaaa|aaaaa|aaaaaa)(??{$1&&""})(b|c) aaaaaaaaaaaaaaab y $1$2 aaaaaab
+(a|aa|aaa|aaaa|aaaaa|aaaaaa)(??{$1&&"foo"})(b|c) aaaaaaaaaaaaaaab n - -
+^(a*?)(?!(aa|aaaa)*$) aaaaaaaaaaaaaaaaaaaa y $1 a # [perl #34195]
+^(a*?)(?!(aa|aaaa)*$)(?=a\z) aaaaaaaa y $1 aaaaaaa
+^(.)\s+.$(?(1)) A B y $1 A # [perl #37688]
+(?:r?)*?r|(.{2,4}) abcde y $1 abcd
+(?!)+?|(.{2,4}) abcde y $1 abcd
+^(a*?)(?!(a{6}|a{5})*$) aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y $+[1] 12 # super-linear cache bug may return 18
+^((?>(?:aa)?b)?) aab y $1 aab
+^((?:aa)*)(?:X+((?:\d+|-)(?:X+(.+))?))?$ aaaaX5 y $1 aaaa
+X(A|B||C|D)Y XXXYYY y $& XY # Trie w/ NOTHING
+(?i:X([A]|[B]|y[Y]y|[D]|)Y) XXXYYYB y $& XY # Trie w/ NOTHING
+^([a]{1})*$ aa y $1 a
+a(?!b(?!c))(..) abababc y $1 bc # test nested negatives
+a(?!b(?=a))(..) abababc y $1 bc # test nested lookaheads
+a(?!b(?!c(?!d(?!e))))...(.) abxabcdxabcde y $1 e
+X(?!b+(?!(c+)*(?!(c+)*d))).*X aXbbbbbbbcccccccccccccaaaX y - -
+^(XXXXXXXXXX|YYYYYYYYYY|Z.Q*X|Z[TE]Q*P): ZEQQQQQQQQQQQQQQQQQQP: y $1 ZEQQQQQQQQQQQQQQQQQQP
+^(XXXXXXXXXX|YYYYYYYYYY|Z.Q*X|Z[TE]Q*P): ZEQQQX: y $1 ZEQQQX
+^([TUV]+|XXXXXXXXXX|YYYYYYYYYY|Z.Q*X|Z[TE]Q*P): ZEQQQQQQQQQQQQQQQQQQP: y $1 ZEQQQQQQQQQQQQQQQQQQP
+^([TUV]+|XXXXXXXXXX|YYYYYYYYYY|Z.Q*X|Z[TE]Q*P): ZEQQQX: y $1 ZEQQQX
+^([TUV]+|XXXXXXXXXX|YYYYYYYYYY|Z.Q*X|Z[TE]Q*P|[MKJ]): ZEQQQQQQQQQQQQQQQQQQP: y $1 ZEQQQQQQQQQQQQQQQQQQP
+^([TUV]+|XXXXXXXXXX|YYYYYYYYYY|Z.Q*X|Z[TE]Q*P|[MKJ]): ZEQQQX: y $1 ZEQQQX
+^(XXX|YYY|Z.Q*X|Z[TE]Q*P): ZEQQQQQQQQQQQQQQQQQQP: y $1 ZEQQQQQQQQQQQQQQQQQQP
+^(XXX|YYY|Z.Q*X|Z[TE]Q*P): ZEQQQX: y $1 ZEQQQX
+^([TUV]+|XXX|YYY|Z.Q*X|Z[TE]Q*P): ZEQQQQQQQQQQQQQQQQQQP: y $1 ZEQQQQQQQQQQQQQQQQQQP
+^([TUV]+|XXX|YYY|Z.Q*X|Z[TE]Q*P): ZEQQQX: y $1 ZEQQQX
+^([TUV]+|XXX|YYY|Z.Q*X|Z[TE]Q*P|[MKJ]): ZEQQQQQQQQQQQQQQQQQQP: y $1 ZEQQQQQQQQQQQQQQQQQQP
+^([TUV]+|XXX|YYY|Z.Q*X|Z[TE]Q*P|[MKJ]): ZEQQQX: y $1 ZEQQQX
+X(?:ABCF[cC]x*|ABCD|ABCF):(?:DIT|DID|DIM) XABCFCxxxxxxxxxx:DIM y $& XABCFCxxxxxxxxxx:DIM
+(((ABCD|ABCE|ABCF)))(A|B|C[xy]*): ABCFCxxxxxxxxxx:DIM y $& ABCFCxxxxxxxxxx:
+(?=foo) foo y pos 0
+(?=foo) XfooY y pos 1
+.*(?=foo) XfooY y pos 1
+(?<=foo) foo y pos 3
+(?<=foo) XfooY y pos 4
+.*(?<=foo) foo y pos 3
+.*(?<=foo) XfooY y pos 4
+(?<=foo)Y XfooY y pos 5
+o(?<=foo)Y ..XfooY.. y pos 7
+X(?=foo)f ..XfooY.. y pos 4
+X(?=foo) ..XfooY.. y pos 3
+X(?<=foo.)[YZ] ..XfooXY.. y pos 8
+(?=XY*foo) Xfoo y pos 0
+^(?=XY*foo) Xfoo y pos 0
+^(??{"a+"})a aa y $& aa
+^(?:(??{"a+"})|b)a aa y $& aa
+^(??{chr 0x100}).$ \x{100}\x{100} y $& \x{100}\x{100}
+^(??{q(\x{100})}). \x{100}\x{100} y $& \x{100}\x{100}
+^(??{q(.+)})\x{100} \x{100}\x{100} y $& \x{100}\x{100}
+^(??{q(.)})\x{100} \x{100}\x{100} y $& \x{100}\x{100}
+^(??{chr 0x100})\xbb \x{100}\x{bb} y $& \x{100}\x{bb}
+^(.)(??{"(.)(.)"})(.)$ abcd y $1-$2 a-d
+^(.)(??{"(bz+|.)(.)"})(.)$ abcd y $1-$2 a-d
+^(.)((??{"(.)(cz+)"})|.) abcd y $1-$2 a-b
+^a(?>(??{q(b)}))(??{q(c)})d abcd y - -
+^x(??{""})+$ x y $& x
+^(<(?:[^<>]+|(?3)|(?1))*>)()(!>!>!>)$ <<!>!>!>><>>!>!>!> y $1 <<!>!>!>><>>
+^(<(?:[^<>]+|(?1))*>)$ <<><<<><>>>> y $1 <<><<<><>>>>
+((?2)*)([fF]o+) fooFoFoo y $1-$2 fooFo-Foo
+(<(?:[^<>]+|(?R))*>) <<><<<><>>>> y $1 <<><<<><>>>>
+(?<n>foo|bar|baz) snofooewa y $1 foo
+(?<n>foo|bar|baz) snofooewa y $+{n} foo
+(?<n>foo|bar|baz)(?<m>[ew]+) snofooewa y $+{n} foo
+(?<n>foo|bar|baz)(?<m>[ew]+) snofooewa y $+{m} ew
+(?<n>foo)|(?<n>bar)|(?<n>baz) snofooewa y $+{n} foo
+(?<n>foo)(??{ $+{n} }) snofooefoofoowaa y $+{n} foo
+(?P<n>foo|bar|baz) snofooewa y $1 foo
+(?P<n>foo|bar|baz) snofooewa y $+{n} foo
+(?P<n>foo|bar|baz)(?P<m>[ew]+) snofooewa y $+{n} foo
+(?P<n>foo|bar|baz)(?P<m>[ew]+) snofooewa y $+{m} ew
+(?P<n>foo)|(?P<n>bar)|(?P<n>baz) snofooewa y $+{n} foo
+(?P<n>foo)(??{ $+{n} }) snofooefoofoowaa y $+{n} foo
+(?P<=n>foo|bar|baz) snofooewa c - Sequence (?P<=...) not recognized
+(?P<!n>foo|bar|baz) snofooewa c - Sequence (?P<!...) not recognized
+(?PX<n>foo|bar|baz) snofooewa c - Sequence (?PX<...) not recognized
+/(?'n'foo|bar|baz)/ snofooewa y $1 foo
+/(?'n'foo|bar|baz)/ snofooewa y $+{n} foo
+/(?'n'foo|bar|baz)(?'m'[ew]+)/ snofooewa y $+{n} foo
+/(?'n'foo|bar|baz)(?'m'[ew]+)/ snofooewa y $+{m} ew
+/(?'n'foo)|(?'n'bar)|(?<n>baz)/ snobazewa y $+{n} baz
+/(?'n'foo)(??{ $+{n} })/ snofooefoofoowaa y $+{n} foo
+/(?'n'foo)\k<n>/ ..foofoo.. y $1 foo
+/(?'n'foo)\k<n>/ ..foofoo.. y $+{n} foo
+/(?<n>foo)\k'n'/ ..foofoo.. y $1 foo
+/(?<n>foo)\k'n'/ ..foofoo.. y $+{n} foo
+/(?:(?<n>foo)|(?<n>bar))\k<n>/ ..barbar.. y $+{n} bar
+/^(?'main'<(?:[^<>]+|(?&crap)|(?&main))*>)(?'empty')(?'crap'!>!>!>)$/ <<!>!>!>><>>!>!>!> y $+{main} <<!>!>!>><>>
+/^(?'main'<(?:[^<>]+|(?&main))*>)$/ <<><<<><>>>> y $1 <<><<<><>>>>
+/(?'first'(?&second)*)(?'second'[fF]o+)/ fooFoFoo y $+{first}-$+{second} fooFo-Foo
+(?<A>foo)?(?(<A>)bar|nada) foobar y $+{A} foo
+(?<A>foo)?(?(<A>)bar|nada) foo-barnada y $& nada
+(?<A>foo)?(?(1)bar|nada) foo-barnada y $& nada
+(?<A>foo(?(R)bar))?(?1) foofoobar y $1 foo
+(?<A>foo(?(R)bar))?(?1) foofoobar y $& foofoobar
+(x)(?<A>foo(?(R&A)bar))?(?&A) xfoofoobar y $2 foo
+(x)(?<A>foo(?(R&A)bar))?(?&A) xfoofoobar y $& xfoofoobar
+(x)(?<A>foo(?(R2)bar))?(?&A) xfoofoobar y $2 foo
+(x)(?<A>foo(?(R2)bar))?(?&A) xfoofoobar y $& xfoofoobar
+(?1)(?(DEFINE)(blah)) blah y $& blah
+/^(?<PAL>(?<CHAR>.)((?&PAL)|.?)\k<CHAR>)$/ madamimadam y $& madamimadam
+/^(?<PAL>(?<CHAR>.)((?&PAL)|.?)\k<CHAR>)$/ madamiamadam n - -
+/(a)?((?1))(fox)/ aafox y $1-$2-$3 a-a-fox
+/(a)*((?1))(fox)/ aafox y $1-$2-$3 a-a-fox
+/(a)+((?1))(fox)/ aafox y $1-$2-$3 a-a-fox
+/(a){1,100}((?1))(fox)/ aafox y $1-$2-$3 a-a-fox
+/(a){0,100}((?1))(fox)/ aafox y $1-$2-$3 a-a-fox
+/(ab)?((?1))(fox)/ ababfox y $1-$2-$3 ab-ab-fox
+/(ab)*((?1))(fox)/ ababfox y $1-$2-$3 ab-ab-fox
+/(ab)+((?1))(fox)/ ababfox y $1-$2-$3 ab-ab-fox
+/(ab){1,100}((?1))(fox)/ ababfox y $1-$2-$3 ab-ab-fox
+/(ab){0,100}((?1))(fox)/ ababfox y $1-$2-$3 ab-ab-fox
+# possessive captures
+a++a aaaaa n - -
+a*+a aaaaa n - -
+a{1,5}+a aaaaa n - -
+a?+a ab n - -
+a++b aaaaab y $& aaaaab
+a*+b aaaaab y $& aaaaab
+a{1,5}+b aaaaab y $& aaaaab
+a?+b ab y $& ab
+fooa++a fooaaaaa n - -
+fooa*+a fooaaaaa n - -
+fooa{1,5}+a fooaaaaa n - -
+fooa?+a fooab n - -
+fooa++b fooaaaaab y $& fooaaaaab
+fooa*+b fooaaaaab y $& fooaaaaab
+fooa{1,5}+b fooaaaaab y $& fooaaaaab
+fooa?+b fooab y $& fooab
+(?:aA)++(?:aA) aAaAaAaAaA n - aAaAaAaAaA
+(aA)++(aA) aAaAaAaAaA n - aAaAaAaAaA
+(aA|bB)++(aA|bB) aAaAbBaAbB n - aAaAbBaAbB
+(?:aA|bB)++(?:aA|bB) aAbBbBbBaA n - aAbBbBbBaA
+(?:aA)*+(?:aA) aAaAaAaAaA n - aAaAaAaAaA
+(aA)*+(aA) aAaAaAaAaA n - aAaAaAaAaA
+(aA|bB)*+(aA|bB) aAaAbBaAaA n - aAaAbBaAaA
+(?:aA|bB)*+(?:aA|bB) aAaAaAbBaA n - aAaAaAbBaA
+(?:aA){1,5}+(?:aA) aAaAaAaAaA n - aAaAaAaAaA
+(aA){1,5}+(aA) aAaAaAaAaA n - aAaAaAaAaA
+(aA|bB){1,5}+(aA|bB) aAaAbBaAaA n - aAaAbBaAaA
+(?:aA|bB){1,5}+(?:aA|bB) bBbBbBbBbB n - bBbBbBbBbB
+(?:aA)?+(?:aA) aAb n - aAb
+(aA)?+(aA) aAb n - aAb
+(aA|bB)?+(aA|bB) bBb n - bBb
+(?:aA|bB)?+(?:aA|bB) aAb n - aAb
+(?:aA)++b aAaAaAaAaAb y $& aAaAaAaAaAb
+(aA)++b aAaAaAaAaAb y $& aAaAaAaAaAb
+(aA|bB)++b aAbBaAaAbBb y $& aAbBaAaAbBb
+(?:aA|bB)++b aAbBbBaAaAb y $& aAbBbBaAaAb
+(?:aA)*+b aAaAaAaAaAb y $& aAaAaAaAaAb
+(aA)*+b aAaAaAaAaAb y $& aAaAaAaAaAb
+(aA|bB)*+b bBbBbBbBbBb y $& bBbBbBbBbBb
+(?:aA|bB)*+b bBaAbBbBaAb y $& bBaAbBbBaAb
+(?:aA){1,5}+b aAaAaAaAaAb y $& aAaAaAaAaAb
+(aA){1,5}+b aAaAaAaAaAb y $& aAaAaAaAaAb
+(aA|bB){1,5}+b bBaAbBaAbBb y $& bBaAbBaAbBb
+(?:aA|bB){1,5}+b aAbBaAbBbBb y $& aAbBaAbBbBb
+(?:aA)?+b aAb y $& aAb
+(aA)?+b aAb y $& aAb
+(aA|bB)?+b bBb y $& bBb
+(?:aA|bB)?+b bBb y $& bBb
+foo(?:aA)++(?:aA) fooaAaAaAaAaA n - fooaAaAaAaAaA
+foo(aA)++(aA) fooaAaAaAaAaA n - fooaAaAaAaAaA
+foo(aA|bB)++(aA|bB) foobBbBbBaAaA n - foobBbBbBaAaA
+foo(?:aA|bB)++(?:aA|bB) fooaAaAaAaAaA n - fooaAaAaAaAaA
+foo(?:aA)*+(?:aA) fooaAaAaAaAaA n - fooaAaAaAaAaA
+foo(aA)*+(aA) fooaAaAaAaAaA n - fooaAaAaAaAaA
+foo(aA|bB)*+(aA|bB) foobBaAbBaAaA n - foobBaAbBaAaA
+foo(?:aA|bB)*+(?:aA|bB) fooaAaAbBbBaA n - fooaAaAbBbBaA
+foo(?:aA){1,5}+(?:aA) fooaAaAaAaAaA n - fooaAaAaAaAaA
+foo(aA){1,5}+(aA) fooaAaAaAaAaA n - fooaAaAaAaAaA
+foo(aA|bB){1,5}+(aA|bB) fooaAbBbBaAaA n - fooaAbBbBaAaA
+foo(?:aA|bB){1,5}+(?:aA|bB) fooaAbBbBaAbB n - fooaAbBbBaAbB
+foo(?:aA)?+(?:aA) fooaAb n - fooaAb
+foo(aA)?+(aA) fooaAb n - fooaAb
+foo(aA|bB)?+(aA|bB) foobBb n - foobBb
+foo(?:aA|bB)?+(?:aA|bB) fooaAb n - fooaAb
+foo(?:aA)++b fooaAaAaAaAaAb y $& fooaAaAaAaAaAb
+foo(aA)++b fooaAaAaAaAaAb y $& fooaAaAaAaAaAb
+foo(aA|bB)++b foobBaAbBaAbBb y $& foobBaAbBaAbBb
+foo(?:aA|bB)++b fooaAaAbBaAaAb y $& fooaAaAbBaAaAb
+foo(?:aA)*+b fooaAaAaAaAaAb y $& fooaAaAaAaAaAb
+foo(aA)*+b fooaAaAaAaAaAb y $& fooaAaAaAaAaAb
+foo(aA|bB)*+b foobBbBaAaAaAb y $& foobBbBaAaAaAb
+foo(?:aA|bB)*+b foobBaAaAbBaAb y $& foobBaAaAbBaAb
+foo(?:aA){1,5}+b fooaAaAaAaAaAb y $& fooaAaAaAaAaAb
+foo(aA){1,5}+b fooaAaAaAaAaAb y $& fooaAaAaAaAaAb
+foo(aA|bB){1,5}+b foobBaAaAaAaAb y $& foobBaAaAaAaAb
+foo(?:aA|bB){1,5}+b fooaAbBaAbBbBb y $& fooaAbBaAbBbBb
+foo(?:aA)?+b fooaAb y $& fooaAb
+foo(aA)?+b fooaAb y $& fooaAb
+foo(aA|bB)?+b foobBb y $& foobBb
+foo(?:aA|bB)?+b foobBb y $& foobBb
+
+([^()]++|\([^()]*\))+ ((abc(ade)ufh()()x y $& abc(ade)ufh()()x
+round\(([^()]++)\) _I(round(xs * sz),1) y $1 xs * sz
+
+(foo[1x]|bar[2x]|baz[3x])+y foo1bar2baz3y y $1 baz3
+(foo[1x]|bar[2x]|baz[3x])+y foo1bar2baz3y y $& foo1bar2baz3y
+(foo[1x]|bar[2x]|baz[3x])*y foo1bar2baz3y y $1 baz3
+(foo[1x]|bar[2x]|baz[3x])*y foo1bar2baz3y y $& foo1bar2baz3y
+
+([yX].|WORDS|[yX].|WORD)S WORDS y $1 WORD
+(WORDS|WORLD|WORD)S WORDS y $1 WORD
+([yX].|WORDS|WORD|[xY].)S WORDS y $1 WORD
+(foo|fool|[zx].|money|parted)$ fool y $1 fool
+([zx].|foo|fool|[zq].|money|parted|[yx].)$ fool y $1 fool
+(foo|fool|[zx].|money|parted)$ fools n - -
+([zx].|foo|fool|[qx].|money|parted|[py].)$ fools n - -
+
+([yX].|WORDS|[yX].|WORD)+S WORDS y $1 WORD
+(WORDS|WORLD|WORD)+S WORDS y $1 WORD
+([yX].|WORDS|WORD|[xY].)+S WORDS y $1 WORD
+(foo|fool|[zx].|money|parted)+$ fool y $1 fool
+([zx].|foo|fool|[zq].|money|parted|[yx].)+$ fool y $1 fool
+(foo|fool|[zx].|money|parted)+$ fools n - -
+([zx].|foo|fool|[qx].|money|parted|[py].)+$ fools n - -
+
+(x|y|z[QW])+(longish|loquatious|excessive|overblown[QW])+ xyzQzWlongishoverblownW y $1-$2 zW-overblownW
+(x|y|z[QW])*(longish|loquatious|excessive|overblown[QW])* xyzQzWlongishoverblownW y $1-$2 zW-overblownW
+(x|y|z[QW]){1,5}(longish|loquatious|excessive|overblown[QW]){1,5} xyzQzWlongishoverblownW y $1-$2 zW-overblownW
+
+(x|y|z[QW])++(longish|loquatious|excessive|overblown[QW])++ xyzQzWlongishoverblownW y $1-$2 zW-overblownW
+(x|y|z[QW])*+(longish|loquatious|excessive|overblown[QW])*+ xyzQzWlongishoverblownW y $1-$2 zW-overblownW
+(x|y|z[QW]){1,5}+(longish|loquatious|excessive|overblown[QW]){1,5}+ xyzQzWlongishoverblownW y $1-$2 zW-overblownW
+
+a*(?!) aaaab n - -
+a*(*FAIL) aaaab n - -
+a*(*F) aaaab n - -
+
+(A(A|B(*ACCEPT)|C)D)(E) AB y $1 AB
+(A(A|B(*ACCEPT)|C)D)(E) ACDE y $1$2$3 ACDCE
+
+(a)(?:(?-1)|(?+1))(b) aab y $&-$1-$2 aab-a-b
+(a)(?:(?-1)|(?+1))(b) abb y $1-$2 a-b
+(a)(?:(?-1)|(?+1))(b) acb n - -
+
+(foo)(\g-2) foofoo y $1-$2 foo-foo
+(foo)(\g-2)(foo)(\g-2) foofoofoofoo y $1-$2-$3-$4 foo-foo-foo-foo
+(([abc]+) \g-1)(([abc]+) \g{-1}) abc abccba cba y $2-$4 abc-cba
+(a)(b)(c)\g1\g2\g3 abcabc y $1$2$3 abc
+
+# \k<n> preceded by a literal
+/(?'n'foo) \k<n>/ ..foo foo.. y $1 foo
+/(?'n'foo) \k<n>/ ..foo foo.. y $+{n} foo
+/(?<n>foo) \k'n'/ ..foo foo.. y $1 foo
+/(?<n>foo) \k'n'/ ..foo foo.. y $+{n} foo
+/(?'a1'foo) \k'a1'/ ..foo foo.. y $+{a1} foo
+/(?<a1>foo) \k<a1>/ ..foo foo.. y $+{a1} foo
+/(?'_'foo) \k'_'/ ..foo foo.. y $+{_} foo
+/(?<_>foo) \k<_>/ ..foo foo.. y $+{_} foo
+/(?'_0_'foo) \k'_0_'/ ..foo foo.. y $+{_0_} foo
+/(?<_0_>foo) \k<_0_>/ ..foo foo.. y $+{_0_} foo
+/(?'0'foo) bar/ ..foo bar.. c - Sequence (?'
+/(?<0>foo) bar/ ..foo bar.. c - Sequence (?<
+/(?'12'foo) bar/ ..foo bar.. c - Sequence (?'
+/(?<12>foo) bar/ ..foo bar.. c - Sequence (?<
+/(?'1a'foo) bar/ ..foo bar.. c - Sequence (?'
+/(?<1a>foo) bar/ ..foo bar.. c - Sequence (?<
+/(?''foo) bar/ ..foo bar.. c - Sequence (?''
+/(?<>foo) bar/ ..foo bar.. c - Sequence (?<>
+/foo \k'n'/ foo foo c - Reference to nonexistent named group
+/foo \k<n>/ foo foo c - Reference to nonexistent named group
+/foo \k'a1'/ foo foo c - Reference to nonexistent named group
+/foo \k<a1>/ foo foo c - Reference to nonexistent named group
+/foo \k'_'/ foo foo c - Reference to nonexistent named group
+/foo \k<_>/ foo foo c - Reference to nonexistent named group
+/foo \k'_0_'/ foo foo c - Reference to nonexistent named group
+/foo \k<_0_>/ foo foo c - Reference to nonexistent named group
+/foo \k'0'/ foo foo c - Sequence \\k'
+/foo \k<0>/ foo foo c - Sequence \\k<
+/foo \k'12'/ foo foo c - Sequence \\k'
+/foo \k<12>/ foo foo c - Sequence \\k<
+/foo \k'1a'/ foo foo c - Sequence \\k'
+/foo \k<1a>/ foo foo c - Sequence \\k<
+/foo \k''/ foo foo c - Sequence \\k'
+/foo \k<>/ foo foo c - Sequence \\k<
+/(?<as>as) (\w+) \k<as> (\w+)/ as easy as pie y $1-$2-$3 as-easy-pie
+
+# \g{...} with a name as the argument
+/(?'n'foo) \g{n}/ ..foo foo.. y $1 foo
+/(?'n'foo) \g{n}/ ..foo foo.. y $+{n} foo
+/(?<n>foo) \g{n}/ ..foo foo.. y $1 foo
+/(?<n>foo) \g{n}/ ..foo foo.. y $+{n} foo
+/(?<as>as) (\w+) \g{as} (\w+)/ as easy as pie y $1-$2-$3 as-easy-pie
+
+# Python style named capture buffer stuff
+/(?P<n>foo)(?P=n)/ ..foofoo.. y $1 foo
+/(?P<n>foo)(?P=n)/ ..foofoo.. y $+{n} foo
+/(?:(?P<n>foo)|(?P<n>bar))(?P=n)/ ..barbar.. y $+{n} bar
+/^(?P<PAL>(?P<CHAR>.)((?P>PAL)|.?)(?P=CHAR))$/ madamimadam y $& madamimadam
+/^(?P<PAL>(?P<CHAR>.)((?P>PAL)|.?)(?P=CHAR))$/ madamiamadam n - -
+/(?P<n>foo) (?P=n)/ ..foo foo.. y $1 foo
+/(?P<n>foo) (?P=n)/ ..foo foo.. y $+{n} foo
+/(?P<as>as) (\w+) (?P=as) (\w+)/ as easy as pie y $1-$2-$3 as-easy-pie
+
+#check that non identifiers as names are treated as the appropriate lookaround
+(?<=bar>)foo bar>foo y $& foo
+(?<!bar>)foo bar>foo n - -
+(?<=bar>ABC)foo bar>ABCfoo y $& foo
+(?<!bar>ABC)foo bar>ABCfoo n - -
+(?<bar>)foo bar>ABCfoo y $& foo
+(?<bar>ABC)foo bar>ABCfoo y $& ABCfoo
+
+(?<=abcd(?<=(aaaabcd))) ..aaaabcd.. y $1 aaaabcd
+(?=xy(?<=(aaxy))) ..aaxy.. y $1 aaxy
+
+X(\w+)(?=\s)|X(\w+) Xab y [$1-$2] [-ab]
+
+#check that branch reset works ok.
+(?|(a)) a y $1-$+-$^N a-a-a
+(?|a(.)b|d(.(o).)d|i(.)(.)j)(.) d!o!da y $1-$2-$3 !o!-o-a
+(?|a(.)b|d(.(o).)d|i(.)(.)j)(.) aabc y $1-$2-$3 a--c
+(?|a(.)b|d(.(o).)d|i(.)(.)j)(.) ixyjp y $1-$2-$3 x-y-p
+(?|(?|(a)|(b))|(?|(c)|(d))) a y $1 a
+(?|(?|(a)|(b))|(?|(c)|(d))) b y $1 b
+(?|(?|(a)|(b))|(?|(c)|(d))) c y $1 c
+(?|(?|(a)|(b))|(?|(c)|(d))) d y $1 d
+(.)(?|(.)(.)x|(.)d)(.) abcde y $1-$2-$3-$4-$5- b-c--e--
+(?|(?<foo>x)) x y $+{foo} x
+(?|(?<foo>x)|(?<bar>y)) x y $+{foo} x
+(?|(?<bar>y)|(?<foo>x)) x y $+{foo} x
+(?<bar>)(?|(?<foo>x)) x y $+{foo} x
+
+#Bug #41492
+(?(DEFINE)(?<A>(?&B)+)(?<B>a))(?&A) a y $& a
+(?(DEFINE)(?<A>(?&B)+)(?<B>a))(?&A) aa y $& aa
+\x{100}?(??{""})xxx xxx y $& xxx
+
+foo(\R)bar foo\r\nbar y $1 \r\n
+foo(\R)bar foo\nbar y $1 \n
+foo(\R)bar foo\rbar y $1 \r
+
+foo(\R+)bar foo\r\n\x{85}\r\n\nbar y $1 \r\n\x{85}\r\n\n
+(\V+)(\R) foo\r\n\x{85}\r\n\nbar y $1-$2 foo-\r\n
+(\R+)(\V) foo\r\n\x{85}\r\n\nbar y $1-$2 \r\n\x{85}\r\n\n-b
+foo(\R)bar foo\x{85}bar y $1 \x{85}
+(\V)(\R) foo\x{85}bar y $1-$2 o-\x{85}
+(\R)(\V) foo\x{85}bar y $1-$2 \x{85}-b
+foo(\R)bar foo\r\nbar y $1 \r\n
+(\V)(\R) foo\r\nbar y $1-$2 o-\r\n
+(\R)(\V) foo\r\nbar y $1-$2 \r\n-b
+foo(\R)bar foo\r\nbar y $1 \r\n
+(\V)(\R) foo\r\nbar y $1-$2 o-\r\n
+(\R)(\V) foo\r\nbar y $1-$2 \r\n-b
+foo(\R)bar foo\rbar y $1 \r
+(\V)(\R) foo\rbar y $1-$2 o-\r
+(\R)(\V) foo\rbar y $1-$2 \r-b
+
+foo(\v+)bar foo\r\n\x{85}\r\n\nbar y $1 \r\n\x{85}\r\n\n
+(\V+)(\v) foo\r\n\x{85}\r\n\nbar y $1-$2 foo-\r
+(\v+)(\V) foo\r\n\x{85}\r\n\nbar y $1-$2 \r\n\x{85}\r\n\n-b
+foo(\v)bar foo\x{85}bar y $1 \x{85}
+(\V)(\v) foo\x{85}bar y $1-$2 o-\x{85}
+(\v)(\V) foo\x{85}bar y $1-$2 \x{85}-b
+foo(\v)bar foo\rbar y $1 \r
+(\V)(\v) foo\rbar y $1-$2 o-\r
+(\v)(\V) foo\rbar y $1-$2 \r-b
+
+
+foo(\h+)bar foo\t\x{A0}bar y $1 \t\x{A0}
+(\H+)(\h) foo\t\x{A0}bar y $1-$2 foo-\t
+(\h+)(\H) foo\t\x{A0}bar y $1-$2 \t\x{A0}-b
+foo(\h)bar foo\x{A0}bar y $1 \x{A0}
+(\H)(\h) foo\x{A0}bar y $1-$2 o-\x{A0}
+(\h)(\H) foo\x{A0}bar y $1-$2 \x{A0}-b
+foo(\h)bar foo\tbar y $1 \t
+(\H)(\h) foo\tbar y $1-$2 o-\t
+(\h)(\H) foo\tbar y $1-$2 \t-b
+
+.*\z foo\n y - -
+^(?:(\d)x)?\d$ 1 y ${\(defined($1)?1:0)} 0
+.*?(?:(\w)|(\w))x abx y $1-$2 b-
+
+0{50} 000000000000000000000000000000000000000000000000000 y - -
+^a?(?=b)b ab y $& ab # Bug #56690
+^a*(?=b)b ab y $& ab # Bug #56690
+/>\d+$ \n/ix >10\n y $& >10
+/>\d+$ \n/ix >1\n y $& >1
+/\d+$ \n/ix >10\n y $& 10
+/>\d\d$ \n/ix >10\n y $& >10
+/>\d+$ \n/x >10\n y $& >10
+
+# Two regressions in 5.8.x (only) introduced by change 30638
+# Simplification of the test failure in XML::LibXML::Simple:
+/^\s*i.*?o\s*$/s io\n io y - -
+# As reported in #59168 by Father Chrysostomos:
+/(.*?)a(?!(a+)b\2c)/ baaabaac y $&-$1 baa-ba
+# [perl #60344] Regex lookbehind failure after an (if)then|else in perl 5.10
+/\A(?(?=db2)db2|\D+)(?<!processed)\.csv\z/xms sql_processed.csv n - -
+/\N{U+0100}/ \x{100} y $& \x{100} # Bug #59328
+[\s][\S] \x{a0}\x{a0} nT - - # TODO Unicode complements should not match same character
+
+# was generating malformed utf8
+'[\x{100}\xff]'i \x{ff} y $& \x{ff}
+
+((??{ "(?:|)" }))\s C\x20 y - -
Index: trunk/contrib/perl/t/op/read.t
===================================================================
--- trunk/contrib/perl/t/op/read.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/read.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/read.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/readdir.t
===================================================================
--- trunk/contrib/perl/t/op/readdir.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/readdir.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -59,9 +59,12 @@
# See that perl does not segfault upon readdir($x=".");
# http://rt.perl.org/rt3/Ticket/Display.html?id=68182
-fresh_perl_like(<<'EOP', qr/^Bad symbol for dirhandle at -/, {}, 'RT #68182');
+fresh_perl_like(<<'EOP', qr/^no crash/, {}, 'RT #68182');
+ eval {
my $x = ".";
my @files = readdir($x);
+ };
+ print "no crash";
EOP
done_testing();
Property changes on: trunk/contrib/perl/t/op/readdir.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/readline.t
===================================================================
--- trunk/contrib/perl/t/op/readline.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/readline.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -6,7 +6,7 @@
require './test.pl';
}
-plan tests => 25;
+plan tests => 30;
# [perl #19566]: sv_gets writes directly to its argument via
# TARG. Test that we respect SvREADONLY.
@@ -245,6 +245,30 @@
is( $one, "A: One\n", "rcatline works with tied scalars" );
is( $two, "B: Two\n", "rcatline works with tied scalars" );
+# mentioned in bug #97482
+# <$foo> versus readline($foo) should not affect vivification.
+my $yunk = "brumbo";
+if (exists $::{$yunk}) {
+ die "Name $yunk already used. Please adjust this test."
+}
+<$yunk>;
+ok !defined *$yunk, '<> does not autovivify';
+readline($yunk);
+ok !defined *$yunk, "readline does not autovivify";
+
+# [perl #97988] PL_last_in_gv could end up pointing to junk.
+# Now glob copies set PL_last_in_gv to null when unglobbed.
+open *foom,'test.pl';
+my %f;
+$f{g} = *foom;
+readline $f{g};
+$f{g} = 3; # PL_last_in_gv should be cleared now
+is tell, -1, 'tell returns -1 after last gv is unglobbed';
+$f{g} = *foom; # since PL_last_in_gv is null, this should have no effect
+is tell, -1, 'unglobbery of last gv nullifies PL_last_in_gv';
+readline *{$f{g}};
+is tell, tell *foom, 'readline *$glob_copy sets PL_last_in_gv';
+
__DATA__
moo
moo
Property changes on: trunk/contrib/perl/t/op/readline.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/t/op/recurse.t
===================================================================
--- trunk/contrib/perl/t/op/recurse.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/recurse.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/recurse.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/ref.t
===================================================================
--- trunk/contrib/perl/t/op/ref.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/ref.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -8,7 +8,7 @@
use strict qw(refs subs);
-plan(217);
+plan(230);
# Test glob operations.
@@ -119,6 +119,7 @@
&$subref;
is ($called, 1);
}
+is ref eval {\&{""}}, "CODE", 'reference to &{""} [perl #94476]';
# Test references to return values of operators (TARGs/PADTMPs)
{
@@ -174,7 +175,6 @@
# tied lvalue => SCALAR, as we haven't tested tie yet
# BIND, 'cos we can't create them yet
# REGEXP, 'cos that requires overload or Scalar::Util
-# LVALUE ref, 'cos I can't work out how to create one :)
for (
[ 'undef', SCALAR => \undef ],
@@ -186,9 +186,13 @@
[ 'PVNV', SCALAR => \$pvnv ],
[ 'PVMG', SCALAR => \$0 ],
[ 'PVBM', SCALAR => \PVBM ],
+ [ 'scalar @array', SCALAR => \scalar @array ],
+ [ 'scalar %hash', SCALAR => \scalar %hash ],
[ 'vstring', VSTRING => \v1 ],
[ 'ref', REF => \\1 ],
- [ 'lvalue', LVALUE => \substr($x, 0, 0) ],
+ [ 'substr lvalue', LVALUE => \substr($x, 0, 0) ],
+ [ 'pos lvalue', LVALUE => \pos ],
+ [ 'vec lvalue', LVALUE => \vec($x,0,1) ],
[ 'named array', ARRAY => \@ary ],
[ 'anon array', ARRAY => [ 1 ] ],
[ 'named hash', HASH => \%whatever ],
@@ -207,6 +211,15 @@
like (*STDOUT{IO}, qr/^IO::File=IO\(0x[0-9a-f]+\)$/,
'stringify for IO refs');
+{ # Test re-use of ref's TARG [perl #101738]
+ my $obj = bless [], '____';
+ my $uniobj = bless [], chr 256;
+ my $get_ref = sub { ref shift };
+ my $dummy = &$get_ref($uniobj);
+ $dummy = &$get_ref($obj);
+ ok exists { ____ => undef }->{$dummy}, 'ref sets UTF8 flag correctly';
+}
+
# Test anonymous hash syntax.
$anonhash = {};
@@ -380,7 +393,6 @@
# test that DESTROY is called on all objects during global destruction,
# even those without hard references [perl #36347]
-$TODO = 'bug #36347';
is(
runperl(
stderr => 1, prog => 'sub DESTROY { print qq-aaa\n- } bless \$a[0]'
@@ -395,8 +407,15 @@
"aaa\n",
'DESTROY called on closure variable'
);
-$TODO = undef;
+# But cursing objects must not result in double frees
+# This caused "Attempt to free unreferenced scalar" in 5.16.
+fresh_perl_is(
+ 'bless \%foo::, bar::; bless \%bar::, foo::; print "ok\n"', "ok\n",
+ { stderr => 1 },
+ 'no double free when stashes are blessed into each other');
+
+
# test if refgen behaves with autoviv magic
{
my @a;
@@ -478,7 +497,7 @@
), qr/^(ok)+$/, 'STDOUT destructor');
}
-TODO: {
+{
no strict 'refs';
$name8 = chr 163;
$name_utf8 = $name8 . chr 256;
@@ -488,11 +507,10 @@
is ($$name_utf8, undef, 'Nothing before we start');
$$name8 = "Pound";
is ($$name8, "Pound", 'Accessing via 8 bit symref works');
- local $TODO = "UTF8 mangled in symrefs";
is ($$name_utf8, "Pound", 'Accessing via UTF8 symref works');
}
-TODO: {
+{
no strict 'refs';
$name_utf8 = $name = chr 9787;
utf8::encode $name_utf8;
@@ -504,7 +522,6 @@
is ($$name_utf8, undef, 'Nothing before we start');
$$name = "Face";
is ($$name, "Face", 'Accessing via Unicode symref works');
- local $TODO = "UTF8 mangled in symrefs";
is ($$name_utf8, undef,
'Accessing via the UTF8 byte sequence gives nothing');
}
@@ -747,6 +764,29 @@
}
+SKIP:{
+ skip_if_miniperl "no Scalar::Util on miniperl", 1;
+ my $error;
+ *hassgropper::DESTROY = sub {
+ require Scalar::Util;
+ eval { Scalar::Util::weaken($_[0]) };
+ $error = $@;
+ # This line caused a crash before weaken refused to weaken a
+ # read-only reference:
+ $do::not::overwrite::this = $_[0];
+ };
+ my $xs = bless [], "hassgropper";
+ undef $xs;
+ like $error, qr/^Modification of a read-only/,
+ 'weaken refuses to weaken a read-only ref';
+ # Now that the test has passed, avoid sabotaging global destruction:
+ undef *hassgropper::DESTROY;
+ undef $do::not::overwrite::this;
+}
+
+
+is ref( bless {}, "nul\0clean" ), "nul\0clean", "ref() is nul-clean";
+
# Bit of a hack to make test.pl happy. There are 3 more tests after it leaves.
$test = curr_test();
curr_test($test + 3);
Property changes on: trunk/contrib/perl/t/op/ref.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Copied: trunk/contrib/perl/t/op/reg_email.t (from rev 6437, vendor/perl/5.18.1/t/op/reg_email.t)
===================================================================
--- trunk/contrib/perl/t/op/reg_email.t (rev 0)
+++ trunk/contrib/perl/t/op/reg_email.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,103 @@
+#!./perl
+#
+# Tests to make sure the regexp engine doesn't run into limits too soon.
+#
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+print "1..13\n";
+
+my $email = qr {
+ (?(DEFINE)
+ (?<address> (?&mailbox) | (?&group))
+ (?<mailbox> (?&name_addr) | (?&addr_spec))
+ (?<name_addr> (?&display_name)? (?&angle_addr))
+ (?<angle_addr> (?&CFWS)? < (?&addr_spec) > (?&CFWS)?)
+ (?<group> (?&display_name) : (?:(?&mailbox_list) | (?&CFWS))? ;
+ (?&CFWS)?)
+ (?<display_name> (?&phrase))
+ (?<mailbox_list> (?&mailbox) (?: , (?&mailbox))*)
+
+ (?<addr_spec> (?&local_part) \@ (?&domain))
+ (?<local_part> (?&dot_atom) | (?"ed_string))
+ (?<domain> (?&dot_atom) | (?&domain_literal))
+ (?<domain_literal> (?&CFWS)? \[ (?: (?&FWS)? (?&dcontent))* (?&FWS)?
+ \] (?&CFWS)?)
+ (?<dcontent> (?&dtext) | (?"ed_pair))
+ (?<dtext> (?&NO_WS_CTL) | [\x21-\x5a\x5e-\x7e])
+
+ (?<atext> (?&ALPHA) | (?&DIGIT) | [!#\$%&'*+-/=?^_`{|}~])
+ (?<atom> (?&CFWS)? (?&atext)+ (?&CFWS)?)
+ (?<dot_atom> (?&CFWS)? (?&dot_atom_text) (?&CFWS)?)
+ (?<dot_atom_text> (?&atext)+ (?: \. (?&atext)+)*)
+
+ (?<text> [\x01-\x09\x0b\x0c\x0e-\x7f])
+ (?<quoted_pair> \\ (?&text))
+
+ (?<qtext> (?&NO_WS_CTL) | [\x21\x23-\x5b\x5d-\x7e])
+ (?<qcontent> (?&qtext) | (?"ed_pair))
+ (?<quoted_string> (?&CFWS)? (?&DQUOTE) (?:(?&FWS)? (?&qcontent))*
+ (?&FWS)? (?&DQUOTE) (?&CFWS)?)
+
+ (?<word> (?&atom) | (?"ed_string))
+ (?<phrase> (?&word)+)
+
+ # Folding white space
+ (?<FWS> (?: (?&WSP)* (?&CRLF))? (?&WSP)+)
+ (?<ctext> (?&NO_WS_CTL) | [\x21-\x27\x2a-\x5b\x5d-\x7e])
+ (?<ccontent> (?&ctext) | (?"ed_pair) | (?&comment))
+ (?<comment> \( (?: (?&FWS)? (?&ccontent))* (?&FWS)? \) )
+ (?<CFWS> (?: (?&FWS)? (?&comment))*
+ (?: (?:(?&FWS)? (?&comment)) | (?&FWS)))
+
+ # No whitespace control
+ (?<NO_WS_CTL> [\x01-\x08\x0b\x0c\x0e-\x1f\x7f])
+
+ (?<ALPHA> [A-Za-z])
+ (?<DIGIT> [0-9])
+ (?<CRLF> \x0d \x0a)
+ (?<DQUOTE> ")
+ (?<WSP> [\x20\x09])
+ )
+
+ (?&address)
+}x;
+
+
+run_tests() unless caller;
+
+sub run_tests {
+ my $count = 0;
+
+ $| = 1;
+ # rewinding DATA is necessary with PERLIO=stdio when this
+ # test is run from another thread
+ seek *DATA, 0, 0;
+ while (<DATA>) { last if /^__DATA__/ }
+ while (<DATA>) {
+ chomp;
+ next if /^#/;
+ print /^$email$/ ? "ok " : "not ok ", ++ $count, "\n";
+ }
+}
+
+#
+# Acme::MetaSyntactic ++
+#
+__DATA__
+Jeff_Tracy at thunderbirds.org
+"Lady Penelope"@thunderbirds.org
+"The\ Hood"@thunderbirds.org
+fred @ flintstones.net
+barney (rubble) @ flintstones.org
+bammbamm (bam! bam! (bam! bam! (bam!)) bam!) @ flintstones.org
+Michelangelo@[127.0.0.1]
+Donatello @ [127.0.0.1]
+Raphael (He as well) @ [127.0.0.1]
+"Leonardo" @ [127.0.0.1]
+Barbapapa <barbapapa @ barbapapa.net>
+"Barba Mama" <barbamama @ [127.0.0.1]>
+Barbalala (lalalalalalalala) <barbalala (Yes, her!) @ (barba) barbapapa.net>
Copied: trunk/contrib/perl/t/op/reg_email_thr.t (from rev 6437, vendor/perl/5.18.1/t/op/reg_email_thr.t)
===================================================================
--- trunk/contrib/perl/t/op/reg_email_thr.t (rev 0)
+++ trunk/contrib/perl/t/op/reg_email_thr.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,7 @@
+#!./perl
+
+chdir 't' if -d 't';
+ at INC = ('../lib', '.');
+
+require 'thread_it.pl';
+thread_it(qw(op reg_email.t));
Copied: trunk/contrib/perl/t/op/reg_fold.t (from rev 6437, vendor/perl/5.18.1/t/op/reg_fold.t)
===================================================================
--- trunk/contrib/perl/t/op/reg_fold.t (rev 0)
+++ trunk/contrib/perl/t/op/reg_fold.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,42 @@
+#!perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use strict;
+use warnings;
+use Test::More;
+my $count=1;
+my @tests;
+
+my $file="../lib/unicore/CaseFolding.txt";
+open my $fh,"<",$file or die "Failed to read '$file': $!";
+while (<$fh>) {
+ chomp;
+ my ($line,$comment)= split/\s+#\s+/, $_;
+ my ($cp,$type, at fc)=split/[\s;]+/,$line||'';
+ next unless $type and ($type eq 'F' or $type eq 'C');
+ $_="\\x{$_}" for @fc;
+ my $cpv=hex("0x$cp");
+ my $chr="chr(0x$cp)";
+ my @str;
+ push @str,$chr if $cpv<128 or $cpv>256;
+ if ($cpv<256) {
+ push @str,"do{my \$c=$chr; utf8::upgrade(\$c); \$c}"
+ }
+
+ foreach my $str ( @str ) {
+ my $expr="$str=~/@fc/ix";
+ my $t=($cpv > 256 || $str=~/^do/) ? "unicode" : "latin";
+ push @tests,
+ qq[ok($expr,'$chr=~/@fc/ix - $comment ($t string)')];
+ $tests[-1]="TODO: { local \$TODO='[13:41] <BinGOs> cue *It is all Greek to me* joke.';\n$tests[-1] }"
+ if $cp eq '0390' or $cp eq '03B0';
+ $count++;
+ }
+}
+eval join ";\n","plan tests=>".($count-1), at tests,"1"
+ or die $@;
+__DATA__
Copied: trunk/contrib/perl/t/op/reg_mesg.t (from rev 6437, vendor/perl/5.18.1/t/op/reg_mesg.t)
===================================================================
--- trunk/contrib/perl/t/op/reg_mesg.t (rev 0)
+++ trunk/contrib/perl/t/op/reg_mesg.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,194 @@
+#!./perl -w
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+my $debug = 1;
+
+##
+## If the markers used are changed (search for "MARKER1" in regcomp.c),
+## update only these two variables, and leave the {#} in the @death/@warning
+## arrays below. The {#} is a meta-marker -- it marks where the marker should
+## go.
+
+my $marker1 = "<-- HERE";
+my $marker2 = " <-- HERE ";
+
+##
+## Key-value pairs of code/error of code that should have fatal errors.
+##
+
+eval 'use Config'; # assume defaults if fail
+our %Config;
+my $inf_m1 = ($Config{reg_infty} || 32767) - 1;
+my $inf_p1 = $inf_m1 + 2;
+my @death =
+(
+ '/[[=foo=]]/' => 'POSIX syntax [= =] is reserved for future extensions in regex; marked by {#} in m/[[=foo=]{#}]/',
+
+ '/(?<= .*)/' => 'Variable length lookbehind not implemented in regex m/(?<= .*)/',
+
+ '/(?<= x{1000})/' => 'Lookbehind longer than 255 not implemented in regex m/(?<= x{1000})/',
+
+ '/(?@)/' => 'Sequence (?@...) not implemented in regex; marked by {#} in m/(?@{#})/',
+
+ '/(?{ 1/' => 'Sequence (?{...}) not terminated or not {}-balanced in regex; marked by {#} in m/(?{{#} 1/',
+
+ '/(?(1x))/' => 'Switch condition not recognized in regex; marked by {#} in m/(?(1x{#}))/',
+
+ '/(?(1)x|y|z)/' => 'Switch (?(condition)... contains too many branches in regex; marked by {#} in m/(?(1)x|y|{#}z)/',
+
+ '/(?(x)y|x)/' => 'Unknown switch condition (?(x) in regex; marked by {#} in m/(?({#}x)y|x)/',
+
+ '/(?/' => 'Sequence (? incomplete in regex; marked by {#} in m/(?{#}/',
+
+ '/(?;x/' => 'Sequence (?;...) not recognized in regex; marked by {#} in m/(?;{#}x/',
+ '/(?<;x/' => 'Sequence (?<;...) not recognized in regex; marked by {#} in m/(?<;{#}x/',
+
+ '/(?\ix/' => 'Sequence (?\...) not recognized in regex; marked by {#} in m/(?\{#}ix/',
+ '/(?\mx/' => 'Sequence (?\...) not recognized in regex; marked by {#} in m/(?\{#}mx/',
+ '/(?\:x/' => 'Sequence (?\...) not recognized in regex; marked by {#} in m/(?\{#}:x/',
+ '/(?\=x/' => 'Sequence (?\...) not recognized in regex; marked by {#} in m/(?\{#}=x/',
+ '/(?\!x/' => 'Sequence (?\...) not recognized in regex; marked by {#} in m/(?\{#}!x/',
+ '/(?\<=x/' => 'Sequence (?\...) not recognized in regex; marked by {#} in m/(?\{#}<=x/',
+ '/(?\<!x/' => 'Sequence (?\...) not recognized in regex; marked by {#} in m/(?\{#}<!x/',
+ '/(?\>x/' => 'Sequence (?\...) not recognized in regex; marked by {#} in m/(?\{#}>x/',
+
+ '/((x)/' => 'Unmatched ( in regex; marked by {#} in m/({#}(x)/',
+
+ "/x{$inf_p1}/" => "Quantifier in {,} bigger than $inf_m1 in regex; marked by {#} in m/x{{#}$inf_p1}/",
+
+ '/x{3,1}/' => 'Can\'t do {n,m} with n > m in regex; marked by {#} in m/x{3,1}{#}/',
+
+ '/x**/' => 'Nested quantifiers in regex; marked by {#} in m/x**{#}/',
+
+ '/x[/' => 'Unmatched [ in regex; marked by {#} in m/x[{#}/',
+
+ '/*/', => 'Quantifier follows nothing in regex; marked by {#} in m/*{#}/',
+
+ '/\p{x/' => 'Missing right brace on \p{} in regex; marked by {#} in m/\p{{#}x/',
+
+ '/[\p{x]/' => 'Missing right brace on \p{} in regex; marked by {#} in m/[\p{{#}x]/',
+
+ '/(x)\2/' => 'Reference to nonexistent group in regex; marked by {#} in m/(x)\2{#}/',
+
+ 'my $m = "\\\"; $m =~ $m', => 'Trailing \ in regex m/\/',
+
+ '/\x{1/' => 'Missing right brace on \x{} in regex; marked by {#} in m/\x{{#}1/',
+
+ '/[\x{X]/' => 'Missing right brace on \x{} in regex; marked by {#} in m/[\x{{#}X]/',
+
+ '/[[:barf:]]/' => 'POSIX class [:barf:] unknown in regex; marked by {#} in m/[[:barf:]{#}]/',
+
+ '/[[=barf=]]/' => 'POSIX syntax [= =] is reserved for future extensions in regex; marked by {#} in m/[[=barf=]{#}]/',
+
+ '/[[.barf.]]/' => 'POSIX syntax [. .] is reserved for future extensions in regex; marked by {#} in m/[[.barf.]{#}]/',
+
+ '/[z-a]/' => 'Invalid [] range "z-a" in regex; marked by {#} in m/[z-a{#}]/',
+
+ '/\p/' => 'Empty \p{} in regex; marked by {#} in m/\p{#}/',
+
+ '/\P{}/' => 'Empty \P{} in regex; marked by {#} in m/\P{{#}}/',
+);
+
+##
+## Key-value pairs of code/error of code that should have non-fatal warnings.
+##
+ at warning = (
+ 'm/\b*/' => '\b* matches null string many times in regex; marked by {#} in m/\b*{#}/',
+
+ 'm/[:blank:]/' => 'POSIX syntax [: :] belongs inside character classes in regex; marked by {#} in m/[:blank:]{#}/',
+
+ "m'[\\y]'" => 'Unrecognized escape \y in character class passed through in regex; marked by {#} in m/[\y{#}]/',
+
+ 'm/[a-\d]/' => 'False [] range "a-\d" in regex; marked by {#} in m/[a-\d{#}]/',
+ 'm/[\w-x]/' => 'False [] range "\w-" in regex; marked by {#} in m/[\w-{#}x]/',
+ 'm/[a-\pM]/' => 'False [] range "a-\pM" in regex; marked by {#} in m/[a-\pM{#}]/',
+ 'm/[\pM-x]/' => 'False [] range "\pM-" in regex; marked by {#} in m/[\pM-{#}x]/',
+ "m'\\y'" => 'Unrecognized escape \y passed through in regex; marked by {#} in m/\y{#}/',
+);
+
+my $total = (@death + @warning)/2;
+
+# utf8 is a noop on EBCDIC platforms, it is not fatal
+my $Is_EBCDIC = (ord('A') == 193);
+if ($Is_EBCDIC) {
+ my @utf8_death = grep(/utf8/, @death);
+ $total = $total - @utf8_death;
+}
+
+print "1..$total\n";
+
+my $count = 0;
+
+while (@death)
+{
+ my $regex = shift @death;
+ my $result = shift @death;
+ # skip the utf8 test on EBCDIC since they do not die
+ next if ($Is_EBCDIC && $regex =~ /utf8/);
+ $count++;
+
+ $_ = "x";
+ eval $regex;
+ if (not $@) {
+ print "# oops, $regex didn't die\nnot ok $count\n";
+ next;
+ }
+ chomp $@;
+ $result =~ s/{\#}/$marker1/;
+ $result =~ s/{\#}/$marker2/;
+ $result .= " at ";
+ if ($@ !~ /^\Q$result/) {
+ print "# For $regex, expected:\n# $result\n# Got:\n# $@\n#\nnot ";
+ }
+ print "ok $count - $regex\n";
+}
+
+
+our $warning;
+$SIG{__WARN__} = sub { $warning = shift };
+
+while (@warning)
+{
+ $count++;
+ my $regex = shift @warning;
+ my $result = shift @warning;
+
+ undef $warning;
+ $_ = "x";
+ eval $regex;
+
+ if ($@)
+ {
+ print "# oops, $regex died with:\n#\t$@#\nnot ok $count\n";
+ next;
+ }
+
+ if (not $warning)
+ {
+ print "# oops, $regex didn't generate a warning\nnot ok $count\n";
+ next;
+ }
+ $result =~ s/{\#}/$marker1/;
+ $result =~ s/{\#}/$marker2/;
+ $result .= " at ";
+ if ($warning !~ /^\Q$result/)
+ {
+ print <<"EOM";
+# For $regex, expected:
+# $result
+# Got:
+# $warning
+#
+not ok $count
+EOM
+ next;
+ }
+ print "ok $count - $regex\n";
+}
+
+
+
Copied: trunk/contrib/perl/t/op/reg_namedcapture.t (from rev 6437, vendor/perl/5.18.1/t/op/reg_namedcapture.t)
===================================================================
--- trunk/contrib/perl/t/op/reg_namedcapture.t (rev 0)
+++ trunk/contrib/perl/t/op/reg_namedcapture.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,26 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ unless ( -r "$INC[0]/Errno.pm") {
+ print "1..0 # Skip: Errno.pm not yet available\n";
+ exit 0;
+ }
+}
+
+# WARNING: Do not directly use any modules as part of this test code.
+# We could get action at a distance that would invalidate the tests.
+
+print "1..2\n";
+
+# This tests whether glob assignment fails to load the tie.
+*X = *-;
+'X'=~/(?<X>X)/;
+print eval '*X{HASH}{X} || 1' ? "" :"not ","ok ",++$test,"\n";
+
+# And since it's a similar case we check %! as well. Note that
+# this can't be done until ../lib/Errno.pm is in place, as the
+# glob hits $!, which needs that module.
+*Y = *!;
+print 0<keys(%Y) ? "" :"not ","ok ",++$test,"\n";
Copied: trunk/contrib/perl/t/op/reg_nc_tie.t (from rev 6437, vendor/perl/5.18.1/t/op/reg_nc_tie.t)
===================================================================
--- trunk/contrib/perl/t/op/reg_nc_tie.t (rev 0)
+++ trunk/contrib/perl/t/op/reg_nc_tie.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,53 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require './test.pl';
+}
+
+# Do a basic test on all the tied methods of Tie::Hash::NamedCapture
+
+print "1..13\n";
+
+# PL_curpm->paren_names can be a null pointer. See that this succeeds anyway.
+'x' =~ /(.)/;
+() = %+;
+pass( 'still alive' );
+
+"hlagh" =~ /
+ (?<a>.)
+ (?<b>.)
+ (?<a>.)
+ .*
+ (?<e>$)
+/x;
+
+# FETCH
+is($+{a}, "h", "FETCH");
+is($+{b}, "l", "FETCH");
+is($-{a}[0], "h", "FETCH");
+is($-{a}[1], "a", "FETCH");
+
+# STORE
+eval { $+{a} = "yon" };
+ok(index($@, "read-only") != -1, "STORE");
+
+# DELETE
+eval { delete $+{a} };
+ok(index($@, "read-only") != -1, "DELETE");
+
+# CLEAR
+eval { %+ = () };
+ok(index($@, "read-only") != -1, "CLEAR");
+
+# EXISTS
+ok(exists $+{e}, "EXISTS");
+ok(!exists $+{d}, "EXISTS");
+
+# FIRSTKEY/NEXTKEY
+is(join('|', sort keys %+), "a|b|e", "FIRSTKEY/NEXTKEY");
+
+# SCALAR
+is(scalar(%+), 3, "SCALAR");
+is(scalar(%-), 3, "SCALAR");
Copied: trunk/contrib/perl/t/op/reg_pmod.t (from rev 6437, vendor/perl/5.18.1/t/op/reg_pmod.t)
===================================================================
--- trunk/contrib/perl/t/op/reg_pmod.t (rev 0)
+++ trunk/contrib/perl/t/op/reg_pmod.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,49 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require './test.pl';
+}
+
+use strict;
+use warnings;
+
+our @tests = (
+ # /p Pattern PRE MATCH POST
+ [ '/p', "456", "123-", "456", "-789"],
+ [ '(?p)', "456", "123-", "456", "-789"],
+ [ '', "(456)", "123-", "456", "-789"],
+ [ '', "456", undef, undef, undef ],
+);
+
+plan tests => 4 * @tests + 2;
+my $W = "";
+
+$SIG{__WARN__} = sub { $W.=join("", at _); };
+sub _u($$) { "$_[0] is ".(defined $_[1] ? "'$_[1]'" : "undef") }
+
+$_ = '123-456-789';
+foreach my $test (@tests) {
+ my ($p, $pat,$l,$m,$r) = @$test;
+ my $test_name = $p eq '/p' ? "/$pat/p"
+ : $p eq '(?p)' ? "/(?p)$pat/"
+ : "/$pat/";
+
+ #
+ # Cannot use if/else due to the scope invalidating ${^MATCH} and friends.
+ #
+ my $ok = ok $p eq '/p' ? /$pat/p
+ : $p eq '(?p)' ? /(?p)$pat/
+ : /$pat/
+ => $test_name;
+ SKIP: {
+ skip "/$pat/$p failed to match", 3
+ unless $ok;
+ is(${^PREMATCH}, $l,_u "$test_name: ^PREMATCH",$l);
+ is(${^MATCH}, $m,_u "$test_name: ^MATCH",$m );
+ is(${^POSTMATCH}, $r,_u "$test_name: ^POSTMATCH",$r );
+ }
+}
+is($W,"","No warnings should be produced");
+ok(!defined ${^MATCH}, "No /p in scope so ^MATCH is undef");
Copied: trunk/contrib/perl/t/op/reg_posixcc.t (from rev 6437, vendor/perl/5.18.1/t/op/reg_posixcc.t)
===================================================================
--- trunk/contrib/perl/t/op/reg_posixcc.t (rev 0)
+++ trunk/contrib/perl/t/op/reg_posixcc.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,158 @@
+#!perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use strict;
+use warnings;
+use Test::More 'no_plan'; # otherwise it would 38401 tests, which is, uh, a lot. :-)
+my @pats=(
+ "\\w",
+ "\\W",
+ "\\s",
+ "\\S",
+ "\\d",
+ "\\D",
+ "[:alnum:]",
+ "[:^alnum:]",
+ "[:alpha:]",
+ "[:^alpha:]",
+ "[:ascii:]",
+ "[:^ascii:]",
+ "[:cntrl:]",
+ "[:^cntrl:]",
+ "[:graph:]",
+ "[:^graph:]",
+ "[:lower:]",
+ "[:^lower:]",
+ "[:print:]",
+ "[:^print:]",
+ "[:punct:]",
+ "[:^punct:]",
+ "[:upper:]",
+ "[:^upper:]",
+ "[:xdigit:]",
+ "[:^xdigit:]",
+ "[:space:]",
+ "[:^space:]",
+ "[:blank:]",
+ "[:^blank:]" );
+if (not $ENV{REAL_POSIX_CC}) {
+ $TODO = "Only works under PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS = 0";
+}
+
+sub rangify {
+ my $ary= shift;
+ my $fmt= shift || '%d';
+ my $sep= shift || ' ';
+ my $rng= shift || '..';
+
+
+ my $first= $ary->[0];
+ my $last= $ary->[0];
+ my $ret= sprintf $fmt, $first;
+ for my $idx (1..$#$ary) {
+ if ( $ary->[$idx] != $last + 1) {
+ if ($last!=$first) {
+ $ret.=sprintf "%s$fmt",$rng, $last;
+ }
+ $first= $last= $ary->[$idx];
+ $ret.=sprintf "%s$fmt",$sep,$first;
+ } else {
+ $last= $ary->[$idx];
+ }
+ }
+ if ( $last != $first) {
+ $ret.=sprintf "%s$fmt",$rng, $last;
+ }
+ return $ret;
+}
+
+my $description = "";
+while (@pats) {
+ my ($yes,$no)= splice @pats,0,2;
+
+ my %err_by_type;
+ my %singles;
+ my %complements;
+ foreach my $b (0..255) {
+ my %got;
+ for my $type ('unicode','not-unicode') {
+ my $str=chr($b).chr($b);
+ if ($type eq 'unicode') {
+ $str.=chr(256);
+ chop $str;
+ }
+ if ($str=~/[$yes][$no]/){
+ TODO: {
+ unlike($str,qr/[$yes][$no]/,
+ "chr($b)=~/[$yes][$no]/ should not match under $type");
+ }
+ push @{$err_by_type{$type}},$b;
+ }
+ $got{"[$yes]"}{$type} = $str=~/[$yes]/ ? 1 : 0;
+ $got{"[$no]"}{$type} = $str=~/[$no]/ ? 1 : 0;
+ $got{"[^$yes]"}{$type} = $str=~/[^$yes]/ ? 1 : 0;
+ $got{"[^$no]"}{$type} = $str=~/[^$no]/ ? 1 : 0;
+ }
+ foreach my $which ("[$yes]","[$no]","[^$yes]","[^$no]") {
+ if ($got{$which}{'unicode'} != $got{$which}{'not-unicode'}){
+ TODO: {
+ is($got{$which}{'unicode'},$got{$which}{'not-unicode'},
+ "chr($b)=~/$which/ should have the same results regardless of internal string encoding");
+ }
+ push @{$singles{$which}},$b;
+ }
+ }
+ foreach my $which ($yes,$no) {
+ foreach my $strtype ('unicode','not-unicode') {
+ if ($got{"[$which]"}{$strtype} == $got{"[^$which]"}{$strtype}) {
+ TODO: {
+ isnt($got{"[$which]"}{$strtype},$got{"[^$which]"}{$strtype},
+ "chr($b)=~/[$which]/ should not have the same result as chr($b)=~/[^$which]/");
+ }
+ push @{$complements{$which}{$strtype}},$b;
+ }
+ }
+ }
+ }
+
+
+ if (%err_by_type || %singles || %complements) {
+ $description||=" Error:\n";
+ $description .= "/[$yes][$no]/\n";
+ if (%err_by_type) {
+ foreach my $type (sort keys %err_by_type) {
+ $description .= "\tmatches $type codepoints:\t";
+ $description .= rangify($err_by_type{$type});
+ $description .= "\n";
+ }
+ $description .= "\n";
+ }
+ if (%singles) {
+ $description .= "Unicode/Nonunicode mismatches:\n";
+ foreach my $type (sort keys %singles) {
+ $description .= "\t$type:\t";
+ $description .= rangify($singles{$type});
+ $description .= "\n";
+ }
+ $description .= "\n";
+ }
+ if (%complements) {
+ foreach my $class (sort keys %complements) {
+ foreach my $strtype (sort keys %{$complements{$class}}) {
+ $description .= "\t$class has complement failures under $strtype for:\t";
+ $description .= rangify($complements{$class}{$strtype});
+ $description .= "\n";
+ }
+ }
+ }
+ }
+}
+TODO: {
+ is( $description, "", "POSIX and perl charclasses should not depend on string type");
+}
+
+__DATA__
Copied: trunk/contrib/perl/t/op/reg_unsafe.t (from rev 6437, vendor/perl/5.18.1/t/op/reg_unsafe.t)
===================================================================
--- trunk/contrib/perl/t/op/reg_unsafe.t (rev 0)
+++ trunk/contrib/perl/t/op/reg_unsafe.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,19 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+
+}
+print "1..1\n";
+
+# there is an equivelent test in t/op/pat.t which does NOT fail
+# its not clear why it doesnt fail, so this todo gets its own test
+# file until we can work it out.
+
+my $x;
+($x='abc')=~/(abc)/g;
+$x='123';
+
+print "not " if $1 ne 'abc';
+print "ok 1 # TODO safe match vars make /g slow\n";
Copied: trunk/contrib/perl/t/op/regexp.t (from rev 6437, vendor/perl/5.18.1/t/op/regexp.t)
===================================================================
--- trunk/contrib/perl/t/op/regexp.t (rev 0)
+++ trunk/contrib/perl/t/op/regexp.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,207 @@
+#!./perl
+
+# The tests are in a separate file 't/op/re_tests'.
+# Each line in that file is a separate test.
+# There are five columns, separated by tabs.
+#
+# Column 1 contains the pattern, optionally enclosed in C<''>.
+# Modifiers can be put after the closing C<'>.
+#
+# Column 2 contains the string to be matched.
+#
+# Column 3 contains the expected result:
+# y expect a match
+# n expect no match
+# c expect an error
+# T the test is a TODO (can be combined with y/n/c)
+# B test exposes a known bug in Perl, should be skipped
+# b test exposes a known bug in Perl, should be skipped if noamp
+# t test exposes a bug with threading, TODO if qr_embed_thr
+#
+# Columns 4 and 5 are used only if column 3 contains C<y> or C<c>.
+#
+# Column 4 contains a string, usually C<$&>.
+#
+# Column 5 contains the expected result of double-quote
+# interpolating that string after the match, or start of error message.
+#
+# Column 6, if present, contains a reason why the test is skipped.
+# This is printed with "skipped", for harness to pick up.
+#
+# \n in the tests are interpolated, as are variables of the form ${\w+}.
+#
+# Blanks lines are treated as PASSING tests to keep the line numbers
+# linked to the test number.
+#
+# If you want to add a regular expression test that can't be expressed
+# in this format, don't add it here: put it in op/pat.t instead.
+#
+# Note that columns 2,3 and 5 are all enclosed in double quotes and then
+# evalled; so something like a\"\x{100}$1 has length 3+length($1).
+
+my $file;
+BEGIN {
+ $iters = shift || 1; # Poor man performance suite, 10000 is OK.
+
+ # Do this open before any chdir
+ $file = shift;
+ if (defined $file) {
+ open TESTS, $file or die "Can't open $file";
+ }
+
+ chdir 't' if -d 't';
+ @INC = '../lib';
+
+ if ($qr_embed_thr) {
+ require Config;
+ if (!$Config::Config{useithreads}) {
+ print "1..0 # Skip: no ithreads\n";
+ exit 0;
+ }
+ if ($ENV{PERL_CORE_MINITEST}) {
+ print "1..0 # Skip: no dynamic loading on miniperl, no threads\n";
+ exit 0;
+ }
+ require threads;
+ }
+}
+
+use strict;
+use warnings FATAL=>"all";
+use vars qw($iters $numtests $bang $ffff $nulnul $OP);
+use vars qw($qr $skip_amp $qr_embed $qr_embed_thr); # set by our callers
+
+
+if (!defined $file) {
+ open(TESTS,'op/re_tests') || open(TESTS,'t/op/re_tests')
+ || open(TESTS,':op:re_tests') || die "Can't open re_tests";
+}
+
+my @tests = <TESTS>;
+
+close TESTS;
+
+$bang = sprintf "\\%03o", ord "!"; # \41 would not be portable.
+$ffff = chr(0xff) x 2;
+$nulnul = "\0" x 2;
+$OP = $qr ? 'qr' : 'm';
+
+$| = 1;
+printf "1..%d\n# $iters iterations\n", scalar @tests;
+
+my $test;
+TEST:
+foreach (@tests) {
+ $test++;
+ if (!/\S/ || /^\s*#/ || /^__END__$/) {
+ print "ok $test # (Blank line or comment)\n";
+ if (/#/) { print $_ };
+ next;
+ }
+ chomp;
+ s/\\n/\n/g;
+ my ($pat, $subject, $result, $repl, $expect, $reason) = split(/\t/,$_,6);
+ $reason = '' unless defined $reason;
+ my $input = join(':',$pat,$subject,$result,$repl,$expect);
+ # the double '' below keeps simple syntax highlighters from going crazy
+ $pat = "'$pat'" unless $pat =~ /^[:''\/]/;
+ $pat =~ s/(\$\{\w+\})/$1/eeg;
+ $pat =~ s/\\n/\n/g;
+ $subject = eval qq("$subject"); die $@ if $@;
+ $expect = eval qq("$expect"); die $@ if $@;
+ $expect = $repl = '-' if $skip_amp and $input =~ /\$[&\`\']/;
+ my $todo_qr = $qr_embed_thr && ($result =~ s/t//);
+ my $skip = ($skip_amp ? ($result =~ s/B//i) : ($result =~ s/B//));
+ $reason = 'skipping $&' if $reason eq '' && $skip_amp;
+ $result =~ s/B//i unless $skip;
+ my $todo= $result =~ s/T// ? " # TODO" : "";
+
+
+ for my $study ('', 'study $subject', 'utf8::upgrade($subject)',
+ 'utf8::upgrade($subject); study $subject') {
+ # Need to make a copy, else the utf8::upgrade of an alreay studied
+ # scalar confuses things.
+ my $subject = $subject;
+ my $c = $iters;
+ my ($code, $match, $got);
+ if ($repl eq 'pos') {
+ $code= <<EOFCODE;
+ $study;
+ pos(\$subject)=0;
+ \$match = ( \$subject =~ m${pat}g );
+ \$got = pos(\$subject);
+EOFCODE
+ }
+ elsif ($qr_embed) {
+ $code= <<EOFCODE;
+ my \$RE = qr$pat;
+ $study;
+ \$match = (\$subject =~ /(?:)\$RE(?:)/) while \$c--;
+ \$got = "$repl";
+EOFCODE
+ }
+ elsif ($qr_embed_thr) {
+ $code= <<EOFCODE;
+ # Can't run the match in a subthread, but can do this and
+ # clone the pattern the other way.
+ my \$RE = threads->new(sub {qr$pat})->join();
+ $study;
+ \$match = (\$subject =~ /(?:)\$RE(?:)/) while \$c--;
+ \$got = "$repl";
+EOFCODE
+ }
+ else {
+ $code= <<EOFCODE;
+ $study;
+ \$match = (\$subject =~ $OP$pat) while \$c--;
+ \$got = "$repl";
+EOFCODE
+ }
+ #$code.=qq[\n\$expect="$expect";\n];
+ #use Devel::Peek;
+ #die Dump($code) if $pat=~/\\h/ and $subject=~/\x{A0}/;
+ {
+ # Probably we should annotate specific tests with which warnings
+ # categories they're known to trigger, and hence should be
+ # disabled just for that test
+ no warnings qw(uninitialized regexp);
+ eval $code;
+ }
+ chomp( my $err = $@ );
+ if ($result eq 'c') {
+ if ($err !~ m!^\Q$expect!) { print "not ok $test$todo (compile) $input => `$err'\n"; next TEST }
+ last; # no need to study a syntax error
+ }
+ elsif ( $skip ) {
+ print "ok $test # skipped", length($reason) ? " $reason" : '', "\n";
+ next TEST;
+ }
+ elsif ( $todo_qr ) {
+ print "not ok $test # TODO", length($reason) ? " - $reason" : '', "\n";
+ next TEST;
+ }
+ elsif ($@) {
+ print "not ok $test$todo $input => error `$err'\n$code\n$@\n"; next TEST;
+ }
+ elsif ($result =~ /^n/) {
+ if ($match) { print "not ok $test$todo ($study) $input => false positive\n"; next TEST }
+ }
+ else {
+ if (!$match || $got ne $expect) {
+ eval { require Data::Dumper };
+ if ($@) {
+ print "not ok $test$todo ($study) $input => `$got', match=$match\n$code\n";
+ }
+ else { # better diagnostics
+ my $s = Data::Dumper->new([$subject],['subject'])->Useqq(1)->Dump;
+ my $g = Data::Dumper->new([$got],['got'])->Useqq(1)->Dump;
+ print "not ok $test$todo ($study) $input => `$got', match=$match\n$s\n$g\n$code\n";
+ }
+ next TEST;
+ }
+ }
+ }
+ print "ok $test$todo\n";
+}
+
+1;
Copied: trunk/contrib/perl/t/op/regexp_noamp.t (from rev 6437, vendor/perl/5.18.1/t/op/regexp_noamp.t)
===================================================================
--- trunk/contrib/perl/t/op/regexp_noamp.t (rev 0)
+++ trunk/contrib/perl/t/op/regexp_noamp.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,10 @@
+#!./perl
+
+$skip_amp = 1;
+for $file ('./op/regexp.t', './t/op/regexp.t', ':op:regexp.t') {
+ if (-r $file) {
+ do $file or die $@;
+ exit;
+ }
+}
+die "Cannot find ./op/regexp.t or ./t/op/regexp.t\n";
Copied: trunk/contrib/perl/t/op/regexp_notrie.t (from rev 6437, vendor/perl/5.18.1/t/op/regexp_notrie.t)
===================================================================
--- trunk/contrib/perl/t/op/regexp_notrie.t (rev 0)
+++ trunk/contrib/perl/t/op/regexp_notrie.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,15 @@
+#!./perl
+#use re 'debug';
+BEGIN {
+ ${^RE_TRIE_MAXBUF}=-1;
+ #${^RE_DEBUG_FLAGS}=0;
+}
+
+$qr = 1;
+for $file ('./op/regexp.t', './t/op/regexp.t', ':op:regexp.t') {
+ if (-r $file) {
+ do $file or die $@;
+ exit;
+ }
+}
+die "Cannot find ./op/regexp.t or ./t/op/regexp.t\n";
Copied: trunk/contrib/perl/t/op/regexp_qr.t (from rev 6437, vendor/perl/5.18.1/t/op/regexp_qr.t)
===================================================================
--- trunk/contrib/perl/t/op/regexp_qr.t (rev 0)
+++ trunk/contrib/perl/t/op/regexp_qr.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,10 @@
+#!./perl
+
+$qr = 1;
+for $file ('./op/regexp.t', './t/op/regexp.t', ':op:regexp.t') {
+ if (-r $file) {
+ do $file or die $@;
+ exit;
+ }
+}
+die "Cannot find ./op/regexp.t or ./t/op/regexp.t\n";
Copied: trunk/contrib/perl/t/op/regexp_qr_embed.t (from rev 6437, vendor/perl/5.18.1/t/op/regexp_qr_embed.t)
===================================================================
--- trunk/contrib/perl/t/op/regexp_qr_embed.t (rev 0)
+++ trunk/contrib/perl/t/op/regexp_qr_embed.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,11 @@
+#!./perl
+
+$qr = 1;
+$qr_embed = 1;
+for $file ('./op/regexp.t', './t/op/regexp.t', ':op:regexp.t') {
+ if (-r $file) {
+ do $file or die $@;
+ exit;
+ }
+}
+die "Cannot find ./op/regexp.t or ./t/op/regexp.t\n";
Copied: trunk/contrib/perl/t/op/regexp_qr_embed_thr.t (from rev 6437, vendor/perl/5.18.1/t/op/regexp_qr_embed_thr.t)
===================================================================
--- trunk/contrib/perl/t/op/regexp_qr_embed_thr.t (rev 0)
+++ trunk/contrib/perl/t/op/regexp_qr_embed_thr.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,11 @@
+#!./perl
+
+$qr = 1;
+$qr_embed_thr = 1;
+for $file ('./op/regexp.t', './t/op/regexp.t', ':op:regexp.t') {
+ if (-r $file) {
+ do $file or die $@;
+ exit;
+ }
+}
+die "Cannot find ./op/regexp.t or ./t/op/regexp.t\n";
Copied: trunk/contrib/perl/t/op/regexp_trielist.t (from rev 6437, vendor/perl/5.18.1/t/op/regexp_trielist.t)
===================================================================
--- trunk/contrib/perl/t/op/regexp_trielist.t (rev 0)
+++ trunk/contrib/perl/t/op/regexp_trielist.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,15 @@
+#!./perl
+#use re 'debug';
+BEGIN {
+ ${^RE_TRIE_MAXBUFF}=0;
+ #${^RE_DEBUG_FLAGS}=0;
+ }
+
+$qr = 1;
+for $file ('./op/regexp.t', './t/op/regexp.t', ':op:regexp.t') {
+ if (-r $file) {
+ do $file or die $@;
+ exit;
+ }
+}
+die "Cannot find ./op/regexp.t or ./t/op/regexp.t\n";
Copied: trunk/contrib/perl/t/op/regexp_unicode_prop.t (from rev 6437, vendor/perl/5.18.1/t/op/regexp_unicode_prop.t)
===================================================================
--- trunk/contrib/perl/t/op/regexp_unicode_prop.t (rev 0)
+++ trunk/contrib/perl/t/op/regexp_unicode_prop.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,303 @@
+#!./perl
+#
+# Tests that have to do with checking whether characters have (or not have)
+# certain Unicode properties; belong (or not belong) to blocks, scripts, etc.
+#
+
+use strict;
+use warnings;
+use 5.010;
+
+my $IS_EBCDIC = ord ('A') == 193;
+
+sub run_tests;
+
+#
+# This is the data to test.
+#
+# This is a hash; keys are the property to test.
+# Values are arrays containing characters to test. The characters can
+# have the following formats:
+# '\N{CHARACTER NAME}' - Use character with that name
+# '\x{1234}' - Use character with that hex escape
+# '0x1234' - Use chr() to get that character
+# "a" - Character to use
+#
+# If a character entry starts with ! the character does not belong to the class
+#
+# If the class is just single letter, we use both \pL and \p{L}
+#
+
+use charnames ':full';
+
+my @CLASSES = (
+ L => ["a", "A"],
+ Ll => ["b", "!B"],
+ Lu => ["!c", "C"],
+ IsLl => ["d", "!D"],
+ IsLu => ["!e", "E"],
+ LC => ["f", "!1"],
+ 'L&' => ["g", "!2"],
+ 'Lowercase Letter' => ["h", "!H"],
+
+ Common => ["!i", "3"],
+ Inherited => ["!j", '\x{300}'],
+
+ InBasicLatin => ['\N{LATIN CAPITAL LETTER A}'],
+ InLatin1Supplement => ['\N{LATIN CAPITAL LETTER A WITH GRAVE}'],
+ InLatinExtendedA => ['\N{LATIN CAPITAL LETTER A WITH MACRON}'],
+ InLatinExtendedB => ['\N{LATIN SMALL LETTER B WITH STROKE}'],
+ InKatakana => ['\N{KATAKANA LETTER SMALL A}'],
+ IsLatin => ["0x100", "0x212b"],
+ IsHebrew => ["0x5d0", "0xfb4f"],
+ IsGreek => ["0x37a", "0x386", "!0x387", "0x388",
+ "0x38a", "!0x38b", "0x38c"],
+ HangulSyllables => ['\x{AC00}'],
+ 'Script=Latin' => ['\x{0100}'],
+ 'Block=LatinExtendedA' => ['\x{0100}'],
+ 'Category=UppercaseLetter' => ['\x{0100}'],
+
+ #
+ # It's ok to repeat class names.
+ #
+ InLatin1Supplement =>
+ $IS_EBCDIC ? ['!\x{7f}', '\x{80}', '!\x{100}']
+ : ['!\x{7f}', '\x{80}', '\x{ff}', '!\x{100}'],
+ InLatinExtendedA =>
+ ['!\x{7f}', '!\x{80}', '!\x{ff}', '\x{100}'],
+
+ #
+ # Properties are case-insensitive, and may have whitespace,
+ # dashes and underscores.
+ #
+ 'in-latin1_SUPPLEMENT' => ['\x{80}',
+ '\N{LATIN SMALL LETTER Y WITH DIAERESIS}'],
+ ' ^ In Latin 1 Supplement '
+ => ['!\x{80}', '\N{COFFIN}'],
+ 'latin-1 supplement' => ['\x{80}', "0xDF"],
+
+);
+
+my @USER_DEFINED_PROPERTIES = (
+ #
+ # User defined properties
+ #
+ InKana1 => ['\x{3040}', '!\x{303F}'],
+ InKana2 => ['\x{3040}', '!\x{303F}'],
+ InKana3 => ['\x{3041}', '!\x{3040}'],
+ InNotKana => ['\x{3040}', '!\x{3041}'],
+ InConsonant => ['d', '!e'],
+ IsSyriac1 => ['\x{0712}', '!\x{072F}'],
+ Syriac1 => ['\x{0712}', '!\x{072F}'],
+ '# User-defined character properties my lack \n at the end',
+ InGreekSmall => ['\N{GREEK SMALL LETTER PI}',
+ '\N{GREEK SMALL LETTER FINAL SIGMA}'],
+ InGreekCapital => ['\N{GREEK CAPITAL LETTER PI}', '!\x{03A2}'],
+ Dash => ['-'],
+ ASCII_Hex_Digit => ['!-', 'A'],
+ AsciiHexAndDash => ['-', 'A'],
+);
+
+
+#
+# From the short properties we populate POSIX-like classes.
+#
+my %SHORT_PROPERTIES = (
+ 'Ll' => ['m', '\N{CYRILLIC SMALL LETTER A}'],
+ 'Lu' => ['M', '\N{GREEK CAPITAL LETTER ALPHA}'],
+ 'Lo' => ['\N{HIRAGANA LETTER SMALL A}'],
+ 'Mn' => ['\N{COMBINING GRAVE ACCENT}'],
+ 'Nd' => ["0", '\N{ARABIC-INDIC DIGIT ZERO}'],
+ 'Pc' => ["_"],
+ 'Po' => ["!"],
+ 'Zs' => [" "],
+ 'Cc' => ['\x{00}'],
+);
+
+#
+# Illegal properties
+#
+my @ILLEGAL_PROPERTIES = qw [q qrst];
+
+my %d;
+
+while (my ($class, $chars) = each %SHORT_PROPERTIES) {
+ push @{$d {IsAlpha}} => map {$class =~ /^[LM]/ ? $_ : "!$_"} @$chars;
+ push @{$d {IsAlnum}} => map {$class =~ /^[LMN]./ ? $_ : "!$_"} @$chars;
+ push @{$d {IsASCII}} => map {length ($_) == 1 || $_ eq '\x{00}'
+ ? $_ : "!$_"} @$chars;
+ push @{$d {IsCntrl}} => map {$class =~ /^C/ ? $_ : "!$_"} @$chars;
+ push @{$d {IsBlank}} => map {$class =~ /^Z[lps]/ ? $_ : "!$_"} @$chars;
+ push @{$d {IsDigit}} => map {$class =~ /^Nd$/ ? $_ : "!$_"} @$chars;
+ push @{$d {IsGraph}} => map {$class =~ /^([LMNPS]|Co)/
+ ? $_ : "!$_"} @$chars;
+ push @{$d {IsPrint}} => map {$class =~ /^([LMNPS]|Co|Zs)/
+ ? $_ : "!$_"} @$chars;
+ push @{$d {IsLower}} => map {$class =~ /^Ll$/ ? $_ : "!$_"} @$chars;
+ push @{$d {IsUpper}} => map {$class =~ /^L[ut]/ ? $_ : "!$_"} @$chars;
+ push @{$d {IsPunct}} => map {$class =~ /^P/ ? $_ : "!$_"} @$chars;
+ push @{$d {IsWord}} => map {$class =~ /^[LMN]/ || $_ eq "_"
+ ? $_ : "!$_"} @$chars;
+ push @{$d {IsSpace}} => map {$class =~ /^Z/ ||
+ length ($_) == 1 && ord ($_) >= 0x09
+ && ord ($_) <= 0x0D
+ ? $_ : "!$_"} @$chars;
+}
+
+delete $d {IsASCII} if $IS_EBCDIC;
+
+push @CLASSES => "# Short properties" => %SHORT_PROPERTIES,
+ "# POSIX like properties" => %d,
+ "# User defined properties" => @USER_DEFINED_PROPERTIES;
+
+
+#
+# Calculate the number of tests.
+#
+my $count = 0;
+for (my $i = 0; $i < @CLASSES; $i += 2) {
+ $i ++, redo if $CLASSES [$i] =~ /^\h*#\h*(.*)/;
+ $count += (length $CLASSES [$i] == 1 ? 4 : 2) * @{$CLASSES [$i + 1]};
+}
+$count += 2 * @ILLEGAL_PROPERTIES;
+$count += 2 * grep {length $_ == 1} @ILLEGAL_PROPERTIES;
+
+my $tests = 0;
+
+say "1..$count";
+
+run_tests unless caller ();
+
+sub match {
+ my ($char, $match, $nomatch) = @_;
+
+ my ($str, $name);
+
+ given ($char) {
+ when (/^\\/) {
+ $str = eval qq ["$char"];
+ $name = qq ["$char"];
+ }
+ when (/^0x([0-9A-Fa-f]+)$/) {
+ $str = chr hex $1;
+ $name = "chr ($char)";
+ }
+ default {
+ $str = $char;
+ $name = qq ["$char"];
+ }
+ }
+
+ print "not " unless $str =~ /$match/;
+ print "ok ", ++ $tests, " - $name =~ /$match/\n";
+ print "not " unless $str !~ /$nomatch/;
+ print "ok ", ++ $tests, " - $name !~ /$nomatch/\n";
+}
+
+sub run_tests {
+
+ while (@CLASSES) {
+ my $class = shift @CLASSES;
+ if ($class =~ /^\h*#\h*(.*)/) {
+ print "# $1\n";
+ next;
+ }
+ last unless @CLASSES;
+ my $chars = shift @CLASSES;
+ my @in = grep {!/^!./} @$chars;
+ my @out = map {s/^!(?=.)//; $_} grep { /^!./} @$chars;
+ my $in_pat = eval qq ['\\p{$class}'];
+ my $out_pat = eval qq ['\\P{$class}'];
+
+ match $_, $in_pat, $out_pat for @in;
+ match $_, $out_pat, $in_pat for @out;
+
+ if (1 == length $class) {
+ my $in_pat = eval qq ['\\p$class'];
+ my $out_pat = eval qq ['\\P$class'];
+
+ match $_, $in_pat, $out_pat for @in;
+ match $_, $out_pat, $in_pat for @out;
+ }
+ }
+
+
+ my $pat = qr /^Can't find Unicode property definition/;
+ print "# Illegal properties\n";
+ foreach my $p (@ILLEGAL_PROPERTIES) {
+ undef $@;
+ my $r = eval "'a' =~ /\\p{$p}/; 1";
+ print "not " unless !$r && $@ && $@ =~ $pat;
+ print "ok ", ++ $tests, " - Unknown Unicode property \\p{$p}\n";
+ undef $@;
+ my $s = eval "'a' =~ /\\P{$p}/; 1";
+ print "not " unless !$s && $@ && $@ =~ $pat;
+ print "ok ", ++ $tests, " - Unknown Unicode property \\P{$p}\n";
+ if (length $p == 1) {
+ undef $@;
+ my $r = eval "'a' =~ /\\p$p/; 1";
+ print "not " unless !$r && $@ && $@ =~ $pat;
+ print "ok ", ++ $tests, " - Unknown Unicode property \\p$p\n";
+ undef $@;
+ my $s = eval "'a' =~ /\\P$p/; 1";
+ print "not " unless !$s && $@ && $@ =~ $pat;
+ print "ok ", ++ $tests, " - Unknown Unicode property \\P$p\n";
+ }
+ }
+}
+
+
+#
+# User defined properties
+#
+
+sub InKana1 {<<'--'}
+3040 309F
+30A0 30FF
+--
+
+sub InKana2 {<<'--'}
++utf8::InHiragana
++utf8::InKatakana
+--
+
+sub InKana3 {<<'--'}
++utf8::InHiragana
++utf8::InKatakana
+-utf8::IsCn
+--
+
+sub InNotKana {<<'--'}
+!utf8::InHiragana
+-utf8::InKatakana
++utf8::IsCn
+--
+
+sub InConsonant {<<'--'} # Not EBCDIC-aware.
+0061 007f
+-0061
+-0065
+-0069
+-006f
+-0075
+--
+
+sub IsSyriac1 {<<'--'}
+0712 072C
+0730 074A
+--
+
+sub Syriac1 {<<'--'}
+0712 072C
+0730 074A
+--
+
+sub InGreekSmall {return "03B1\t03C9"}
+sub InGreekCapital {return "0391\t03A9\n-03A2"}
+
+sub AsciiHexAndDash {<<'--'}
++utf8::ASCII_Hex_Digit
++utf8::Dash
+--
+
+__END__
Copied: trunk/contrib/perl/t/op/regexp_unicode_prop_thr.t (from rev 6437, vendor/perl/5.18.1/t/op/regexp_unicode_prop_thr.t)
===================================================================
--- trunk/contrib/perl/t/op/regexp_unicode_prop_thr.t (rev 0)
+++ trunk/contrib/perl/t/op/regexp_unicode_prop_thr.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,7 @@
+#!./perl
+
+chdir 't' if -d 't';
+ at INC = ('../lib', '.');
+
+require 'thread_it.pl';
+thread_it(qw(op regexp_unicode_prop.t));
Index: trunk/contrib/perl/t/op/repeat.t
===================================================================
--- trunk/contrib/perl/t/op/repeat.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/repeat.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/repeat.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/op/require_37033.t (from rev 6437, vendor/perl/5.18.1/t/op/require_37033.t)
===================================================================
--- trunk/contrib/perl/t/op/require_37033.t (rev 0)
+++ trunk/contrib/perl/t/op/require_37033.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,42 @@
+#!perl -w
+use strict;
+
+# Check that require doesn't leave the handle it uses open, if it happens that
+# the handle it opens gets file descriptor 0. RT #37033.
+
+require './test.pl';
+ at INC = 'lib';
+
+sub test_require {
+ my ($state, $want) = @_;
+ delete $INC{'test_use_14937.pm'};
+ open my $fh, '<', 'README' or die "Can't open README: $!";
+ my $fileno = fileno $fh;
+ if (defined $want) {
+ is($fileno, $want,
+ "file handle has correct numeric file descriptor $state");
+ } else {
+ like($fileno, qr/\A\d+\z/,
+ "file handle has a numeric file descriptor $state");
+ }
+ close $fh or die;
+
+ is($INC{'test_use_14937.pm'}, undef, "test_use_14937 isn't loaded $state");
+ require test_use_14937;
+ isnt($INC{'test_use_14937.pm'}, undef, "test_use_14937 is loaded $state");
+
+ open $fh, '<', 'README' or die "Can't open README: $!";
+ is(fileno $fh, $fileno,
+ "file handle has the same numeric file descriptor $state");
+ close $fh or die;
+}
+
+is(fileno STDIN, 0, 'STDIN is open on file descriptor 0');
+test_require('(STDIN open)');
+
+close STDIN or die "Can't close STDIN: $!";
+
+is(fileno STDIN, undef, 'STDIN is closed');
+test_require('(STDIN closed)', 0);
+
+done_testing();
Modified: trunk/contrib/perl/t/op/require_errors.t
===================================================================
--- trunk/contrib/perl/t/op/require_errors.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/require_errors.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -3,21 +3,33 @@
use warnings;
BEGIN {
+ chdir 't';
require './test.pl';
}
-plan(tests => 3);
+plan(tests => 11);
my $nonfile = tempfile();
@INC = qw(Perl Rules);
-eval {
- require $nonfile;
-};
+# The tests for ' ' and '.h' never did fail, but previously the error reporting
+# code would read memory before the start of the SV's buffer
-like $@, qr/^Can't locate $nonfile in \@INC \(\@INC contains: @INC\) at/;
+for my $file ($nonfile, ' ') {
+ eval {
+ require $file;
+ };
+ like $@, qr/^Can't locate $file in \@INC \(\@INC contains: @INC\) at/,
+ "correct error message for require '$file'";
+}
+
+eval "require $nonfile";
+
+like $@, qr/^Can't locate $nonfile\.pm in \@INC \(you may need to install the $nonfile module\) \(\@INC contains: @INC\) at/,
+ "correct error message for require $nonfile";
+
eval {
require "$nonfile.ph";
};
@@ -24,12 +36,78 @@
like $@, qr/^Can't locate $nonfile\.ph in \@INC \(did you run h2ph\?\) \(\@INC contains: @INC\) at/;
-eval {
- require "$nonfile.h";
-};
+for my $file ("$nonfile.h", ".h") {
+ eval {
+ require $file
+ };
-like $@, qr/^Can't locate $nonfile\.h in \@INC \(change \.h to \.ph maybe\?\) \(did you run h2ph\?\) \(\@INC contains: @INC\) at/;
+ like $@, qr/^Can't locate \Q$file\E in \@INC \(change \.h to \.ph maybe\?\) \(did you run h2ph\?\) \(\@INC contains: @INC\) at/,
+ "correct error message for require '$file'";
+}
+for my $file ("$nonfile.ph", ".ph") {
+ eval {
+ require $file
+ };
+
+ like $@, qr/^Can't locate \Q$file\E in \@INC \(did you run h2ph\?\) \(\@INC contains: @INC\) at/,
+ "correct error message for require '$file'";
+}
+
+eval 'require <foom>';
+like $@, qr/^<> should be quotes at /, 'require <> error';
+
+my $module = tempfile();
+my $mod_file = "$module.pm";
+
+open my $module_fh, ">", $mod_file or die $!;
+print { $module_fh } "print 1; 1;\n";
+close $module_fh;
+
+chmod 0333, $mod_file;
+
+SKIP: {
+ skip_if_miniperl("these modules may not be available to miniperl", 2);
+
+ push @INC, '../lib';
+ require Cwd;
+ require File::Spec::Functions;
+ if ($^O eq 'cygwin') {
+ require Win32;
+ }
+
+ # Going to try to switch away from root. Might not work.
+ # (stolen from t/op/stat.t)
+ my $olduid = $>;
+ eval { $> = 1; };
+ skip "Can't test permissions meaningfully if you're superuser", 2
+ if ($^O eq 'cygwin' ? Win32::IsAdminUser() : $> == 0);
+
+ local @INC = ".";
+ eval "use $module";
+ like $@,
+ qr<^\QCan't locate $mod_file:>,
+ "special error message if the file exists but can't be opened";
+
+ SKIP: {
+ skip "Can't make the path absolute", 1
+ if !defined(Cwd::getcwd());
+
+ my $file = File::Spec::Functions::catfile(Cwd::getcwd(), $mod_file);
+ eval {
+ require($file);
+ };
+ like $@,
+ qr<^\QCan't locate $file:>,
+ "...even if we use a full path";
+ }
+
+ # switch uid back (may not be implemented)
+ eval { $> = $olduid; };
+}
+
+1 while unlink $mod_file;
+
# I can't see how to test the EMFILE case
# I can't see how to test the case of not displaying @INC in the message.
# (and does that only happen on VMS?)
Property changes on: trunk/contrib/perl/t/op/require_errors.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/reset.t
===================================================================
--- trunk/contrib/perl/t/op/reset.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/reset.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -7,8 +7,7 @@
}
use strict;
-# Currently only testing the reset of patterns.
-plan tests => 24;
+plan tests => 30;
package aiieee;
@@ -62,7 +61,66 @@
is(CLINK::ZZIP("ZZIP"), 1, "match matches after reset");
is(CLINK::ZZIP(""), 0, "mismatch doesn't match");
+sub match_foo{
+ "foo" =~ m?foo?;
+}
+match_foo();
+reset "";
+ok !match_foo(), 'reset "" leaves patterns alone [perl #97958]';
+$scratch::a = "foo";
+$scratch::a2 = "bar";
+$scratch::b = "baz";
+package scratch { reset "a" }
+is join("-", $scratch::a//'u', $scratch::a2//'u', $scratch::b//'u'),
+ "u-u-baz",
+ 'reset "char"';
+
+$scratch::a = "foo";
+$scratch::a2 = "bar";
+$scratch::b = "baz";
+$scratch::c = "sea";
+package scratch { reset "bc" }
+is join("-", $scratch::a//'u', $scratch::a2//'u', $scratch::b//'u',
+ $scratch::c//'u'),
+ "foo-bar-u-u",
+ 'reset "chars"';
+
+$scratch::a = "foo";
+$scratch::a2 = "bar";
+$scratch::b = "baz";
+$scratch::c = "sea";
+package scratch { reset "a-b" }
+is join("-", $scratch::a//'u', $scratch::a2//'u', $scratch::b//'u',
+ $scratch::c//'u'),
+ "u-u-u-sea",
+ 'reset "range"';
+
+{ no strict; ${"scratch::\0foo"} = "bar" }
+$scratch::a = "foo";
+package scratch { reset "\0a" }
+is join("-", $scratch::a//'u', do { no strict; ${"scratch::\0foo"} }//'u'),
+ "u-u",
+ 'reset "\0char"';
+
+# This used to crash under threaded builds, because pmops were remembering
+# their stashes by name, rather than by pointer.
+fresh_perl_is( # it crashes more reliably with a smaller script
+ 'package bar;
+ sub foo {
+ m??;
+ BEGIN { *baz:: = *bar::; *bar:: = *foo:: }
+ # The name "bar" no langer refers to the same package
+ }
+ undef &foo; # so freeing the op does not remove it from the stash’s list
+ $_ = "";
+ push @_, ($_) x 10000; # and its memory is scribbled over
+ reset; # so reset on the original package tries to reset an invalid op
+ print "ok\n";',
+ "ok\n", {},
+ "no crash if package is effectively renamed before op is freed");
+
+
undef $/;
my $prog = <DATA>;
@@ -98,7 +156,7 @@
use threads::shared;
sub wipe {
- eval 'no warnings; sub b {}';
+ eval 'no warnings; sub b {}; 1' or die $@;
}
sub lock_then_wipe {
Property changes on: trunk/contrib/perl/t/op/reset.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/reverse.t
===================================================================
--- trunk/contrib/perl/t/op/reverse.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/reverse.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -8,46 +8,46 @@
plan tests => 26;
-is(reverse("abc"), "cba");
+is(reverse("abc"), "cba", 'simple reverse');
$_ = "foobar";
-is(reverse(), "raboof");
+is(reverse(), "raboof", 'reverse of the default variable');
{
my @a = ("foo", "bar");
my @b = reverse @a;
- is($b[0], $a[1]);
- is($b[1], $a[0]);
+ is($b[0], $a[1], 'array reversal moved second element to first');
+ is($b[1], $a[0], 'array reversal moved first element to second');
}
{
my @a = (1, 2, 3, 4);
@a = reverse @a;
- is("@a", "4 3 2 1");
+ is("@a", "4 3 2 1", 'four element array reversed');
delete $a[1];
@a = reverse @a;
- ok(!exists $a[2]);
- is($a[0] . $a[1] . $a[3], '124');
+ ok(!exists $a[2], 'array reversed with deleted second element');
+ is($a[0] . $a[1] . $a[3], '124', 'remaining elements ok after delete and reverse');
@a = (5, 6, 7, 8, 9);
@a = reverse @a;
- is("@a", "9 8 7 6 5");
+ is("@a", "9 8 7 6 5", 'five element array reversed');
delete $a[3];
@a = reverse @a;
- ok(!exists $a[1]);
- is($a[0] . $a[2] . $a[3] . $a[4], '5789');
+ ok(!exists $a[1], 'five element array reversed with deleted fourth element');
+ is($a[0] . $a[2] . $a[3] . $a[4], '5789', 'remaining elements ok after delete and reverse');
delete $a[2];
@a = reverse @a;
- ok(!exists $a[2] && !exists $a[3]);
- is($a[0] . $a[1] . $a[4], '985');
+ ok(!exists $a[2] && !exists $a[3], 'test position of two deleted elements after reversal');
+ is($a[0] . $a[1] . $a[4], '985', 'check value of remaining elements');
my @empty;
@empty = reverse @empty;
- is("@empty", "");
+ is("@empty", "", 'reversed empty array is still empty');
}
use Tie::Array;
@@ -57,30 +57,30 @@
@a = (1, 2, 3, 4);
@a = reverse @a;
- is("@a", "4 3 2 1");
+ is("@a", "4 3 2 1", 'tie array reversal');
delete $a[1];
@a = reverse @a;
- ok(!exists $a[2]);
- is($a[0] . $a[1] . $a[3], '124');
+ ok(!exists $a[2], 'deleted element position ok after reversal of tie array');
+ is($a[0] . $a[1] . $a[3], '124', 'remaining elements ok after delete and reversal for tie array');
@a = (5, 6, 7, 8, 9);
@a = reverse @a;
- is("@a", "9 8 7 6 5");
+ is("@a", "9 8 7 6 5", 'five element tie array reversal');
delete $a[3];
@a = reverse @a;
- ok(!exists $a[1]);
- is($a[0] . $a[2] . $a[3] . $a[4], '5789');
+ ok(!exists $a[1], 'deleted element position ok after tie array reversal');
+ is($a[0] . $a[2] . $a[3] . $a[4], '5789', 'remaining elements ok after tie array delete and reversal');
delete $a[2];
@a = reverse @a;
- ok(!exists $a[2] && !exists $a[3]);
- is($a[0] . $a[1] . $a[4], '985');
+ ok(!exists $a[2] && !exists $a[3], 'two deleted element positions ok after tie array reversal');
+ is($a[0] . $a[1] . $a[4], '985', 'remaining elements ok after two deletes and reversals');
tie my @empty, "Tie::StdArray";
@empty = reverse @empty;
- is(scalar(@empty), 0);
+ is(scalar(@empty), 0, 'reversed tie array still empty after reversal');
}
{
@@ -89,17 +89,18 @@
my $a = "\x{263A}\x{263A}x\x{263A}y\x{263A}";
my $b = scalar reverse($a);
my $c = scalar reverse($b);
- is($a, $c);
+ is($a, $c, 'Unicode string double reversal matches original');
}
{
# Lexical $_.
+ no warnings 'experimental::lexical_topic';
sub blurp { my $_ = shift; reverse }
- is(blurp("foo"), "oof");
- is(sub { my $_ = shift; reverse }->("bar"), "rab");
+ is(blurp("foo"), "oof", 'reversal of default variable in function');
+ is(sub { my $_ = shift; reverse }->("bar"), "rab", 'reversal of default variable in anonymous function');
{
local $_ = "XXX";
- is(blurp("paz"), "zap");
+ is(blurp("paz"), "zap", 'reversal of default variable with local value set' );
}
}
Property changes on: trunk/contrib/perl/t/op/reverse.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/t/op/runlevel.t
===================================================================
--- trunk/contrib/perl/t/op/runlevel.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/runlevel.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/runlevel.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Copied: trunk/contrib/perl/t/op/rxcode.t (from rev 6437, vendor/perl/5.18.1/t/op/rxcode.t)
===================================================================
--- trunk/contrib/perl/t/op/rxcode.t (rev 0)
+++ trunk/contrib/perl/t/op/rxcode.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,86 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require './test.pl';
+}
+
+plan tests => 38;
+
+$^R = undef;
+like( 'a', qr/^a(?{1})(?:b(?{2}))?/, 'a =~ ab?' );
+cmp_ok( $^R, '==', 1, '..$^R after a =~ ab?' );
+
+$^R = undef;
+unlike( 'abc', qr/^a(?{3})(?:b(?{4}))$/, 'abc !~ a(?:b)$' );
+ok( !defined $^R, '..$^R after abc !~ a(?:b)$' );
+
+$^R = undef;
+like( 'ab', qr/^a(?{5})b(?{6})/, 'ab =~ ab' );
+cmp_ok( $^R, '==', 6, '..$^R after ab =~ ab' );
+
+$^R = undef;
+like( 'ab', qr/^a(?{7})(?:b(?{8}))?/, 'ab =~ ab?' );
+
+cmp_ok( $^R, '==', 8, '..$^R after ab =~ ab?' );
+
+$^R = undef;
+like( 'ab', qr/^a(?{9})b?(?{10})/, 'ab =~ ab? (2)' );
+cmp_ok( $^R, '==', 10, '..$^R after ab =~ ab? (2)' );
+
+$^R = undef;
+like( 'ab', qr/^(a(?{11})(?:b(?{12})))?/, 'ab =~ (ab)? (3)' );
+cmp_ok( $^R, '==', 12, '..$^R after ab =~ ab? (3)' );
+
+$^R = undef;
+unlike( 'ac', qr/^a(?{13})b(?{14})/, 'ac !~ ab' );
+ok( !defined $^R, '..$^R after ac !~ ab' );
+
+$^R = undef;
+like( 'ac', qr/^a(?{15})(?:b(?{16}))?/, 'ac =~ ab?' );
+cmp_ok( $^R, '==', 15, '..$^R after ac =~ ab?' );
+
+my @ar;
+like( 'ab', qr/^a(?{push @ar,101})(?:b(?{push @ar,102}))?/, 'ab =~ ab? with code push' );
+cmp_ok( scalar(@ar), '==', 2, '.. at ar pushed' );
+cmp_ok( $ar[0], '==', 101, '..first element pushed' );
+cmp_ok( $ar[1], '==', 102, '..second element pushed' );
+
+$^R = undef;
+unlike( 'a', qr/^a(?{103})b(?{104})/, 'a !~ ab with code push' );
+ok( !defined $^R, '..$^R after a !~ ab with code push' );
+
+ at ar = ();
+unlike( 'a', qr/^a(?{push @ar,105})b(?{push @ar,106})/, 'a !~ ab (push)' );
+cmp_ok( scalar(@ar), '==', 0, '..nothing pushed' );
+
+ at ar = ();
+unlike( 'abc', qr/^a(?{push @ar,107})b(?{push @ar,108})$/, 'abc !~ ab$ (push)' );
+cmp_ok( scalar(@ar), '==', 0, '..still nothing pushed' );
+
+use vars '@var';
+
+like( 'ab', qr/^a(?{push @var,109})(?:b(?{push @var,110}))?/, 'ab =~ ab? push to package var' );
+cmp_ok( scalar(@var), '==', 2, '.. at var pushed' );
+cmp_ok( $var[0], '==', 109, '..first element pushed (package)' );
+cmp_ok( $var[1], '==', 110, '..second element pushed (package)' );
+
+ at var = ();
+unlike( 'a', qr/^a(?{push @var,111})b(?{push @var,112})/, 'a !~ ab (push package var)' );
+cmp_ok( scalar(@var), '==', 0, '..nothing pushed (package)' );
+
+ at var = ();
+unlike( 'abc', qr/^a(?{push @var,113})b(?{push @var,114})$/, 'abc !~ ab$ (push package var)' );
+cmp_ok( scalar(@var), '==', 0, '..still nothing pushed (package)' );
+
+{
+ local $^R = undef;
+ ok( 'ac' =~ /^a(?{30})(?:b(?{31})|c(?{32}))?/, 'ac =~ a(?:b|c)?' );
+ ok( $^R == 32, '$^R == 32' );
+}
+{
+ local $^R = undef;
+ ok( 'abbb' =~ /^a(?{36})(?:b(?{37})|c(?{38}))+/, 'abbbb =~ a(?:b|c)+' );
+ ok( $^R == 37, '$^R == 37' ) or print "# \$^R=$^R\n";
+}
Copied: trunk/contrib/perl/t/op/select.t (from rev 6437, vendor/perl/5.18.1/t/op/select.t)
===================================================================
--- trunk/contrib/perl/t/op/select.t (rev 0)
+++ trunk/contrib/perl/t/op/select.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,34 @@
+#!./perl
+
+BEGIN {
+ chdir 't';
+ require './test.pl';
+}
+
+plan reverse 9;
+
+
+open my $fh, "test.pl" or die "$0 unfortunately cannot open test.pl: $!";
+
+is select, 'main::STDOUT', 'select retval';
+is select($fh), 'main::STDOUT', 'select retval when called with argument';
+ok ref select, 'select returns ref for glob generated by open';
+is select, $fh, 'the ref returned references the right referent';
+is select(STDOUT), $fh, 'select previous ref when setting to bareword';
+is select, 'main::STDOUT', 'switching back to STDOUT';
+is ref\select, 'SCALAR', 'and STDOUT is a plain string';
+
+open foo::bar, "test.pl" or die "$0 sadly cannot open test.pl: $!";
+select foo::bar;
+$handle = \*foo::bar;
+$stash = \%foo::;
+*foo:: = *bar::;
+is select, $handle,
+ 'select returns ref for glob whose stash has been detached';
+
+open thwat::snin, "test.pl" or die "$0 is unable to open test.pl: $!";
+select thwat::snin;
+$handle = \*thwat::snin;
+*thwat:: = *snin::; # gv is now *__ANON__::snin
+is select, $handle,
+ 'select returns ref for glob with no stash pointer';
Modified: trunk/contrib/perl/t/op/setpgrpstack.t
===================================================================
--- trunk/contrib/perl/t/op/setpgrpstack.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/setpgrpstack.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -4,13 +4,12 @@
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
+ skip_all_without_config('d_setpgrp');
}
-use Config;
-plan tests => 2;
+plan tests => 3;
-SKIP: {
- skip "setpgrp() is not available", 2 unless $Config{d_setpgrp};
- ok(!eval { package A;sub foo { die("got here") }; package main; A->foo(setpgrp())});
- ok($@ =~ /got here/, "setpgrp() should extend the stack before modifying it");
-}
+ok(!eval { package A;sub foo { die("got here") }; package main; A->foo(setpgrp())});
+ok($@ =~ /got here/, "setpgrp() should extend the stack before modifying it");
+
+is join("_", setpgrp(0)), 1, 'setpgrp with one argument';
Property changes on: trunk/contrib/perl/t/op/setpgrpstack.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/sigdispatch.t
===================================================================
--- trunk/contrib/perl/t/op/sigdispatch.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/sigdispatch.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -9,7 +9,8 @@
use strict;
use Config;
-plan tests => 17;
+plan tests => 29;
+$| = 1;
watchdog(15);
@@ -39,26 +40,35 @@
is($@, "Alarm!\n", 'after the second loop');
SKIP: {
- skip('We can\'t test blocking without sigprocmask', 11)
+ skip('We can\'t test blocking without sigprocmask', 17)
if is_miniperl() || !$Config{d_sigprocmask};
- skip('This doesn\'t work on OpenBSD threaded builds RT#88814', 11)
- if $^O eq 'openbsd' && $Config{useithreads};
+ skip('This doesn\'t work on $^O threaded builds RT#88814', 17)
+ if $^O =~ /openbsd|cygwin/ && $Config{useithreads};
require POSIX;
+ my $pending = POSIX::SigSet->new();
+ is POSIX::sigpending($pending), '0 but true', 'sigpending';
+ is $pending->ismember(&POSIX::SIGUSR1), 0, 'SIGUSR1 is not pending';
my $new = POSIX::SigSet->new(&POSIX::SIGUSR1);
POSIX::sigprocmask(&POSIX::SIG_BLOCK, $new);
my $gotit = 0;
$SIG{USR1} = sub { $gotit++ };
- kill SIGUSR1, $$;
+ kill 'SIGUSR1', $$;
is $gotit, 0, 'Haven\'t received third signal yet';
+
+ diag "2nd sigpending crashes on cygwin" if $^O eq 'cygwin';
+ is POSIX::sigpending($pending), '0 but true', 'sigpending';
+ is $pending->ismember(&POSIX::SIGUSR1), 1, 'SIGUSR1 is pending';
my $old = POSIX::SigSet->new();
POSIX::sigsuspend($old);
is $gotit, 1, 'Received third signal';
+ is POSIX::sigpending($pending), '0 but true', 'sigpending';
+ is $pending->ismember(&POSIX::SIGUSR1), 0, 'SIGUSR1 is no longer pending';
{
- kill SIGUSR1, $$;
+ kill 'SIGUSR1', $$;
local $SIG{USR1} = sub { die "FAIL\n" };
POSIX::sigprocmask(&POSIX::SIG_BLOCK, undef, $old);
ok $old->ismember(&POSIX::SIGUSR1), 'SIGUSR1 is blocked';
@@ -72,32 +82,37 @@
}
}
-TODO:
- {
- local $::TODO = "Needs investigation" if $^O eq 'VMS';
- kill SIGUSR1, $$;
- is $gotit, 1, 'Haven\'t received fifth signal yet';
- POSIX::sigprocmask(&POSIX::SIG_UNBLOCK, $new, $old);
- ok $old->ismember(&POSIX::SIGUSR1), 'SIGUSR1 was still blocked';
- }
+ POSIX::sigprocmask(&POSIX::SIG_BLOCK, $new);
+ kill 'SIGUSR1', $$;
+ is $gotit, 1, 'Haven\'t received fifth signal yet';
+ POSIX::sigprocmask(&POSIX::SIG_UNBLOCK, $new, $old);
+ ok $old->ismember(&POSIX::SIGUSR1), 'SIGUSR1 was still blocked';
is $gotit, 2, 'Received fifth signal';
# test unsafe signal handlers in combination with exceptions
- my $action = POSIX::SigAction->new(sub { $gotit--, die }, POSIX::SigSet->new, 0);
- POSIX::sigaction(&POSIX::SIGALRM, $action);
- eval {
- alarm 1;
- my $set = POSIX::SigSet->new;
- POSIX::sigprocmask(&POSIX::SIG_BLOCK, undef, $set);
- is $set->ismember(&POSIX::SIGALRM), 0, "SIGALRM is not blocked on attempt $_";
- POSIX::sigsuspend($set);
- } for 1..2;
- is $gotit, 0, 'Received both signals';
+
+ SKIP: {
+ # #89718: on old linux kernels, this test hangs. No-ones thought
+ # of a reliable way to probe for this, so for now, just skip the
+ # tests on production releases
+ skip("some OSes hang here", 3) if (int($]*1000) & 1) == 0;
+
+ my $action = POSIX::SigAction->new(sub { $gotit--, die }, POSIX::SigSet->new, 0);
+ POSIX::sigaction(&POSIX::SIGALRM, $action);
+ eval {
+ alarm 1;
+ my $set = POSIX::SigSet->new;
+ POSIX::sigprocmask(&POSIX::SIG_BLOCK, undef, $set);
+ is $set->ismember(&POSIX::SIGALRM), 0, "SIGALRM is not blocked on attempt $_";
+ POSIX::sigsuspend($set);
+ } for 1..2;
+ is $gotit, 0, 'Received both signals';
+ }
}
SKIP: {
skip("alarm cannot interrupt blocking system calls on $^O", 2)
- if ($^O eq 'MSWin32' || $^O eq 'VMS');
+ if $^O =~ /MSWin32|cygwin|VMS/;
# RT #88774
# make sure the signal handler's called in an eval block *before*
# the eval is popped
@@ -118,3 +133,31 @@
alarm(0);
is($@, "HANDLER CALLED\n", 'string eval');
}
+
+eval { $SIG{"__WARN__\0"} = sub { 1 } };
+like $@, qr/No such hook: __WARN__\\0 at/, q!Fetching %SIG hooks with an extra trailing nul is nul-clean!;
+
+eval { $SIG{"__DIE__\0whoops"} = sub { 1 } };
+like $@, qr/No such hook: __DIE__\\0whoops at/;
+
+{
+ use warnings;
+ my $w;
+ local $SIG{__WARN__} = sub { $w = shift };
+
+ $SIG{"KILL\0"} = sub { 1 };
+ like $w, qr/No such signal: SIGKILL\\0 at/, 'Arbitrary signal lookup through %SIG is clean';
+}
+
+# [perl #45173]
+{
+ my $int_called;
+ local $SIG{INT} = sub { $int_called = 1; };
+ $@ = "died";
+ is($@, "died");
+ kill 'INT', $$;
+ # this is needed to ensure signal delivery on MSWin32
+ sleep(1);
+ is($int_called, 1);
+ is($@, "died");
+}
Property changes on: trunk/contrib/perl/t/op/sigdispatch.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/op/sigsystem.t (from rev 6437, vendor/perl/5.18.1/t/op/sigsystem.t)
===================================================================
--- trunk/contrib/perl/t/op/sigsystem.t (rev 0)
+++ trunk/contrib/perl/t/op/sigsystem.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,64 @@
+#!perl -w
+
+BEGIN {
+ require './test.pl';
+ skip_all_if_miniperl();
+ skip_all_without_config(qw(d_fork));
+}
+
+use strict;
+use constant TRUE => ($^X, '-e', 'exit 0');
+use Data::Dumper;
+
+plan tests => 4;
+
+SKIP: {
+ skip 'Platform doesn\'t support SIGCHLD', 4 if not exists $SIG{CHLD};
+ require POSIX;
+ require Time::HiRes;
+
+ my @pids;
+ $SIG{CHLD} = sub {
+ while ((my $child = waitpid(-1, POSIX::WNOHANG())) > 0) {
+ note "Reaped: $child";
+ push @pids, $child;
+ }
+ };
+ my $pid = fork // die "Can't fork: $!";
+ unless ($pid) {
+ note("Child PID: $$");
+ Time::HiRes::sleep(0.250);
+ POSIX::_exit(0);
+ }
+
+ test_system('without reaper');
+
+ test_system('with reaper');
+
+ note("Waiting briefly for SIGCHLD...");
+ Time::HiRes::sleep(0.500);
+
+ ok(@pids == 1, 'Reaped only one process');
+ ok($pids[0] == $pid, "Reaped the right process.") or diag(Dumper(\@pids));
+}
+
+sub test_system {
+ my $subtest = shift;
+
+ my $expected_zeroes = 10;
+ my $got_zeroes = 0;
+
+ # This test is looking for a race between system()'s waitpid() and a
+ # signal handler. Looping a few times increases the chances of
+ # catching the error.
+
+ for (1..$expected_zeroes) {
+ $got_zeroes++ unless system(TRUE);
+ }
+
+ is(
+ $got_zeroes, $expected_zeroes,
+ "system() $subtest succeeded $got_zeroes times out of $expected_zeroes"
+ );
+}
+
Index: trunk/contrib/perl/t/op/sleep.t
===================================================================
--- trunk/contrib/perl/t/op/sleep.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/sleep.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/sleep.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/smartkve.t
===================================================================
--- trunk/contrib/perl/t/op/smartkve.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/smartkve.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -14,12 +14,31 @@
sub j { join(":", at _) }
+# NOTE
+#
+# Hash insertion is currently unstable, in that
+# %hash= %otherhash will not necessarily result in
+# the same internal ordering of the data in the hash.
+# For instance when keys collide the copy may not
+# match the inserted order. So we declare one hash
+# and then make all our copies from that, which should
+# mean all the copies have the same internal structure.
+#
+# And these days, even if all that weren't true, we now
+# per-hash randomize keys/values. So, we cant expect two
+# hashes with the same internal structure to return the
+# same thing at all. All we *can* expect is that keys()
+# and values() use the same ordering.
+our %base_hash;
+
BEGIN { # in BEGIN for "use constant ..." later
+ # values match keys here so we can easily check that keys(%hash) == values(%hash)
+ %base_hash= ( pi => 'pi', e => 'e', i => 'i' );
$array = [ qw(pi e i) ];
- $values = [ 3.14, 2.72, -1 ];
- $hash = { pi => 3.14, e => 2.72, i => -1 } ;
+ $values = [ qw(pi e i) ];
+ $hash = { %base_hash } ;
$data = {
- hash => { %$hash },
+ hash => { %base_hash },
array => [ @$array ],
};
}
@@ -27,7 +46,7 @@
package Foo;
sub new {
my $self = {
- hash => {%{$main::hash} },
+ hash => { %base_hash },
array => [@{$main::array}]
};
bless $self, shift;
@@ -58,10 +77,10 @@
package main;
-use constant CONST_HASH => { %$hash };
+use constant CONST_HASH => { %base_hash };
use constant CONST_ARRAY => [ @$array ];
-my %a_hash = %$hash;
+my %a_hash = %base_hash;
my @an_array = @$array;
sub hash_sub { return \%a_hash; }
sub array_sub { return \@an_array; }
@@ -106,16 +125,25 @@
# Keys -- list
-$h_expect = j(keys %$hash);
+$h_expect = j(sort keys %base_hash);
$a_expect = j(keys @$array);
-is(j(keys $hash) ,$h_expect, 'List: keys $hash');
-is(j(keys $data->{hash}) ,$h_expect, 'List: keys $data->{hash}');
-is(j(keys CONST_HASH) ,$h_expect, 'List: keys CONST_HASH');
-is(j(keys CONST_HASH()) ,$h_expect, 'List: keys CONST_HASH()');
-is(j(keys hash_sub) ,$h_expect, 'List: keys hash_sub');
-is(j(keys hash_sub()) ,$h_expect, 'List: keys hash_sub()');
-is(j(keys $obj->hash) ,$h_expect, 'List: keys $obj->hash');
+is(j(sort keys $hash) ,$h_expect, 'List: sort keys $hash');
+is(j(sort keys $data->{hash}) ,$h_expect, 'List: sort keys $data->{hash}');
+is(j(sort keys CONST_HASH) ,$h_expect, 'List: sort keys CONST_HASH');
+is(j(sort keys CONST_HASH()) ,$h_expect, 'List: sort keys CONST_HASH()');
+is(j(sort keys hash_sub) ,$h_expect, 'List: sort keys hash_sub');
+is(j(sort keys hash_sub()) ,$h_expect, 'List: sort keys hash_sub()');
+is(j(sort keys $obj->hash) ,$h_expect, 'List: sort keys $obj->hash');
+
+is(j(keys $hash) ,j(values $hash), 'List: keys $hash == values $hash');
+is(j(keys $data->{hash}) ,j(values $data->{hash}), 'List: keys $data->{hash} == values $data->{hash}');
+is(j(keys CONST_HASH) ,j(values CONST_HASH), 'List: keys CONST_HASH == values CONST_HASH');
+is(j(keys CONST_HASH()) ,j(values CONST_HASH()), 'List: keys CONST_HASH() == values CONST_HASH()');
+is(j(keys hash_sub) ,j(values hash_sub), 'List: keys hash_sub == values hash_sub');
+is(j(keys hash_sub()) ,j(values hash_sub()), 'List: keys hash_sub() == values hash_sub()');
+is(j(keys $obj->hash) ,j(values $obj->hash), 'List: keys $obj->hash == values obj->hash');
+
is(j(keys $array) ,$a_expect, 'List: keys $array');
is(j(keys $data->{array}) ,$a_expect, 'List: keys $data->{array}');
is(j(keys CONST_ARRAY) ,$a_expect, 'List: keys CONST_ARRAY');
@@ -168,7 +196,7 @@
'Errors: keys qr/foo/ throws error'
);
-eval "keys $hash qw/fo bar/";
+eval q"keys $hash qw/fo bar/";
ok($@ =~ qr/syntax error/,
'Errors: keys $hash, @stuff throws error'
) or print "# Got: $@";
@@ -209,16 +237,25 @@
# Values -- list
-$h_expect = j(values %$hash);
+$h_expect = j(sort values %base_hash);
$a_expect = j(values @$array);
-is(j(values $hash) ,$h_expect, 'List: values $hash');
-is(j(values $data->{hash}) ,$h_expect, 'List: values $data->{hash}');
-is(j(values CONST_HASH) ,$h_expect, 'List: values CONST_HASH');
-is(j(values CONST_HASH()) ,$h_expect, 'List: values CONST_HASH()');
-is(j(values hash_sub) ,$h_expect, 'List: values hash_sub');
-is(j(values hash_sub()) ,$h_expect, 'List: values hash_sub()');
-is(j(values $obj->hash) ,$h_expect, 'List: values $obj->hash');
+is(j(sort values $hash) ,$h_expect, 'List: sort values $hash');
+is(j(sort values $data->{hash}) ,$h_expect, 'List: sort values $data->{hash}');
+is(j(sort values CONST_HASH) ,$h_expect, 'List: sort values CONST_HASH');
+is(j(sort values CONST_HASH()) ,$h_expect, 'List: sort values CONST_HASH()');
+is(j(sort values hash_sub) ,$h_expect, 'List: sort values hash_sub');
+is(j(sort values hash_sub()) ,$h_expect, 'List: sort values hash_sub()');
+is(j(sort values $obj->hash) ,$h_expect, 'List: sort values $obj->hash');
+
+is(j(values $hash) ,j(keys $hash), 'List: values $hash == keys $hash');
+is(j(values $data->{hash}) ,j(keys $data->{hash}), 'List: values $data->{hash} == keys $data->{hash}');
+is(j(values CONST_HASH) ,j(keys CONST_HASH), 'List: values CONST_HASH == keys CONST_HASH');
+is(j(values CONST_HASH()) ,j(keys CONST_HASH()), 'List: values CONST_HASH() == keys CONST_HASH()');
+is(j(values hash_sub) ,j(keys hash_sub), 'List: values hash_sub == keys hash_sub');
+is(j(values hash_sub()) ,j(keys hash_sub()), 'List: values hash_sub() == keys hash_sub()');
+is(j(values $obj->hash) ,j(keys $obj->hash), 'List: values $obj->hash == keys $obj->hash');
+
is(j(values $array) ,$a_expect, 'List: values $array');
is(j(values $data->{array}) ,$a_expect, 'List: values $data->{array}');
is(j(values CONST_ARRAY) ,$a_expect, 'List: values CONST_ARRAY');
@@ -263,7 +300,7 @@
'Errors: values qr/foo/ throws error'
);
-eval "values $hash qw/fo bar/";
+eval q"values $hash qw/fo bar/";
ok($@ =~ qr/syntax error/,
'Errors: values $hash, @stuff throws error'
) or print "# Got: $@";
@@ -372,7 +409,7 @@
'Errors: each qr/foo/ throws error'
);
-eval "each $hash qw/foo bar/";
+eval q"each $hash qw/foo bar/";
ok($@ =~ qr/syntax error/,
'Errors: each $hash, @stuff throws error'
) or print "# Got: $@";
Property changes on: trunk/contrib/perl/t/op/smartkve.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/smartmatch.t
===================================================================
--- trunk/contrib/perl/t/op/smartmatch.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/smartmatch.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -8,6 +8,7 @@
use strict;
use warnings;
no warnings 'uninitialized';
+no warnings 'experimental::smartmatch';
use Tie::Array;
use Tie::Hash;
@@ -73,7 +74,7 @@
my %fooormore = map { $_ => 0 } @fooormore;
# Load and run the tests
-plan tests => 351;
+plan tests => 349;
while (<DATA>) {
SKIP: {
@@ -223,8 +224,6 @@
@ "object" $str_obj
@ FALSE $str_obj
# Those will treat the $str_obj as a string because of fallback:
-! $ov_obj $str_obj
- $ov_obj_2 $str_obj
# object (overloaded or not) ~~ Any
$obj qr/NoOverload/
Property changes on: trunk/contrib/perl/t/op/smartmatch.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/sort.t
===================================================================
--- trunk/contrib/perl/t/op/sort.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/sort.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -6,7 +6,7 @@
require 'test.pl';
}
use warnings;
-plan( tests => 162 );
+plan( tests => 176 );
# these shouldn't hang
{
@@ -770,7 +770,8 @@
{
local $TODO = "sort should make sure elements are not freed in the sort block";
- eval { @nomodify_x=(1..8); our @copy = sort { @nomodify_x = (0) } (@nomodify_x, 3); };
+ eval { @nomodify_x=(1..8);
+ our @copy = sort { undef @nomodify_x; 1 } (@nomodify_x, 3); };
is($@, "");
}
@@ -938,3 +939,59 @@
like $output, qr/^(?:Win)+\z/,
'Match vars do not leak from one $$ sort sub to the next';
}
+
+# [perl #30661] autoloading
+AUTOLOAD { $b <=> $a }
+sub stubbedsub;
+is join("", sort stubbedsub split//, '04381091'), '98431100',
+ 'stubborn AUTOLOAD';
+is join("", sort hopefullynonexistent split//, '04381091'), '98431100',
+ 'AUTOLOAD without stub';
+my $stubref = \&givemeastub;
+is join("", sort $stubref split//, '04381091'), '98431100',
+ 'AUTOLOAD with stubref';
+
+# [perl #90030] sort without arguments
+eval '@x = (sort); 1';
+is $@, '', '(sort) does not die';
+is @x, 0, '(sort) returns empty list';
+eval '@x = sort; 1';
+is $@, '', 'sort; does not die';
+is @x, 0, 'sort; returns empty list';
+eval '{@x = sort} 1';
+is $@, '', '{sort} does not die';
+is @x, 0, '{sort} returns empty list';
+
+# this happened while the padrange op was being added. Sort blocks
+# are executed in void context, and the padrange op was skipping pushing
+# the item in void cx. The net result was that the return value was
+# whatever was on the stack last.
+
+{
+ my @a = sort {
+ my $r = $a <=> $b;
+ if ($r) {
+ undef; # this got returned by mistake
+ return $r
+ }
+ return 0;
+ } 5,1,3,6,0;
+ is "@a", "0 1 3 5 6", "padrange and void context";
+}
+
+# Fatal warnings an sort sub returning a non-number
+# We need two evals, because the panic used to happen on scope exit.
+eval { eval { use warnings FATAL => 'all'; () = sort { undef } 1,2 } };
+is $@, "",
+ 'no panic/crash with fatal warnings when sort sub returns undef';
+eval { eval { use warnings FATAL => 'all'; () = sort { "no thin" } 1,2 } };
+is $@, "",
+ 'no panic/crash with fatal warnings when sort sub returns string';
+sub notdef($$) { undef }
+eval { eval { use warnings FATAL => 'all'; () = sort notdef 1,2 } };
+is $@, "",
+ 'no panic/crash with fatal warnings when sort sub($$) returns undef';
+sub yarn($$) { "no thinking aloud" }
+eval { eval { use warnings FATAL => 'all'; () = sort yarn 1,2 } };
+is $@, "",
+ 'no panic/crash with fatal warnings when sort sub($$) returns string';
Property changes on: trunk/contrib/perl/t/op/sort.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/splice.t
===================================================================
--- trunk/contrib/perl/t/op/splice.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/splice.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,41 +1,47 @@
#!./perl
-print "1..21\n";
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require './test.pl';
+}
+$| = 1;
+
@a = (1..10);
sub j { join(":", at _) }
-print "not " unless j(splice(@a, at a,0,11,12)) eq "" && j(@a) eq j(1..12);
-print "ok 1\n";
+is( j(splice(@a, at a,0,11,12)), '', 'return value of splice when nothing is removed, only added');
+is( j(@a), j(1..12), '... added two elements');
-print "not " unless j(splice(@a,-1)) eq "12" && j(@a) eq j(1..11);
-print "ok 2\n";
+is( j(splice(@a,-1)), "12", 'remove last element, return value');
+is( j(@a), j(1..11), '... removed last element');
-print "not " unless j(splice(@a,0,1)) eq "1" && j(@a) eq j(2..11);
-print "ok 3\n";
+is( j(splice(@a,0,1)), "1", 'remove first element, return value');
+is( j(@a), j(2..11), '... first element removed');
-print "not " unless j(splice(@a,0,0,0,1)) eq "" && j(@a) eq j(0..11);
-print "ok 4\n";
+is( j(splice(@a,0,0,0,1)), "", 'emulate shift, return value is empty');
+is( j(@a), j(0..11), '... added two elements to beginning of the list');
-print "not " unless j(splice(@a,5,1,5)) eq "5" && j(@a) eq j(0..11);
-print "ok 5\n";
+is( j(splice(@a,5,1,5)), "5", 'remove and replace an element to the end of the list, return value is the element');
+is( j(@a), j(0..11), '... list remains the same');
-print "not " unless j(splice(@a, @a, 0, 12, 13)) eq "" && j(@a) eq j(0..13);
-print "ok 6\n";
+is( j(splice(@a, @a, 0, 12, 13)), "", 'push two elements onto the end of the list, return value is empty');
+is( j(@a), j(0..13), '... added two elements to the end of the list');
-print "not " unless j(splice(@a, - at a, @a, 1, 2, 3)) eq j(0..13) && j(@a) eq j(1..3);
-print "ok 7\n";
+is( j(splice(@a, - at a, @a, 1, 2, 3)), j(0..13), 'splice the whole list out, add 3 elements, return value is @a');
+is( j(@a), j(1..3), '... array only contains new elements');
-print "not " unless j(splice(@a, 1, -1, 7, 7)) eq "2" && j(@a) eq j(1,7,7,3);
-print "ok 8\n";
+is( j(splice(@a, 1, -1, 7, 7)), "2", 'replace middle element with two elements, negative offset, return value is the element' );
+is( j(@a), j(1,7,7,3), '... array 1,7,7,3');
-print "not " unless j(splice(@a,-3,-2,2)) eq j(7) && j(@a) eq j(1,2,7,3);
-print "ok 9\n";
+is( j(splice(@a,-3,-2,2)), j(7), 'replace first 7 with a 2, negative offset, negative length, return value is 7');
+is( j(@a), j(1,2,7,3), '... array has 1,2,7,3');
# Bug 20000223.001 - no test for splice(@array). Destructive test!
-print "not " unless j(splice(@a)) eq j(1,2,7,3) && j(@a) eq '';
-print "ok 10\n";
+is( j(splice(@a)), j(1,2,7,3), 'bare splice empties the array, return value is the array');
+is( j(@a), '', 'array is empty');
# Tests 11 and 12:
# [ID 20010711.005] in Tie::Array, SPLICE ignores context, breaking SHIFT
@@ -44,56 +50,46 @@
@a = ('red', 'green', 'blue');
$foo = splice @a, 1, 2;
-print "not " unless $foo eq 'blue';
-print "ok 11\n";
+is( $foo, 'blue', 'remove a single element in scalar context');
@a = ('red', 'green', 'blue');
$foo = shift @a;
-print "not " unless $foo eq 'red';
-print "ok 12\n";
+is( $foo, 'red', 'do the same with shift');
# Bug [perl #30568] - insertions of deleted elements
@a = (1, 2, 3);
splice( @a, 0, 3, $a[1], $a[0] );
-print "not " unless j(@a) eq j(2,1);
-print "ok 13\n";
+is( j(@a), j(2,1), 'splice and replace with indexes 1, 0');
@a = (1, 2, 3);
splice( @a, 0, 3 ,$a[0], $a[1] );
-print "not " unless j(@a) eq j(1,2);
-print "ok 14\n";
+is( j(@a), j(1,2), 'splice and replace with indexes 0, 1');
@a = (1, 2, 3);
splice( @a, 0, 3 ,$a[2], $a[1], $a[0] );
-print "not " unless j(@a) eq j(3,2,1);
-print "ok 15\n";
+is( j(@a), j(3,2,1), 'splice and replace with indexes 2, 1, 0');
@a = (1, 2, 3);
splice( @a, 0, 3, $a[0], $a[1], $a[2], $a[0], $a[1], $a[2] );
-print "not " unless j(@a) eq j(1,2,3,1,2,3);
-print "ok 16\n";
+is( j(@a), j(1,2,3,1,2,3), 'splice and replace with a whole bunch');
@a = (1, 2, 3);
splice( @a, 1, 2, $a[2], $a[1] );
-print "not " unless j(@a) eq j(1,3,2);
-print "ok 17\n";
+is( j(@a), j(1,3,2), 'swap last two elements');
@a = (1, 2, 3);
splice( @a, 1, 2, $a[1], $a[1] );
-print "not " unless j(@a) eq j(1,2,2);
-print "ok 18\n";
+is( j(@a), j(1,2,2), 'duplicate middle element on the end');
# splice should invoke get magic
-print "not " if Foo->isa('Bar');
-print "ok 19\n";
+ok( ! Foo->isa('Bar'), 'Foo is not a Bar');
splice @Foo::ISA, 0, 0, 'Bar';
+ok( !oo->isa('Bar'), 'splice @ISA and make Foo a Bar');
-print "not " if !Foo->isa('Bar');
-print "ok 20\n";
-
# Test undef first arg
eval { splice( $new_arrayref, 0, 0, 1, 2, 3 ) };
-print "not " unless $@ && $@ =~ /Not an ARRAY/;
-print "ok 21\n";
+like($@, qr/Not an ARRAY/, 'undefined first argument to splice');
+
+done_testing;
Property changes on: trunk/contrib/perl/t/op/splice.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/split.t
===================================================================
--- trunk/contrib/perl/t/op/split.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/split.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -6,7 +6,7 @@
require './test.pl';
}
-plan tests => 102;
+plan tests => 118;
$FS = ':';
@@ -14,7 +14,7 @@
($a,$b,$c) = split($FS,$_);
-is(join(';',$a,$b,$c), 'a;b;c');
+is(join(';',$a,$b,$c), 'a;b;c', 'Split a simple string into scalars.');
@ary = split(/:b:/);
$cnt = split(/:b:/);
@@ -53,18 +53,18 @@
# Can we say how many fields to split to?
$_ = join(':', split(' ','1 2 3 4 5 6', 3));
-is($_, '1:2:3 4 5 6');
+is($_, '1:2:3 4 5 6', "Split into a specified number of fields, defined by a literal");
@ary = split(' ','1 2 3 4 5 6', 3);
$cnt = split(' ','1 2 3 4 5 6', 3);
-is($cnt, scalar(@ary));
+is($cnt, scalar(@ary), "Check element count from previous test");
# Can we do it as a variable?
$x = 4;
$_ = join(':', split(' ','1 2 3 4 5 6', $x));
-is($_, '1:2:3:4 5 6');
+is($_, '1:2:3:4 5 6', "Split into a specified number of fields, defined by a scalar variable");
@ary = split(' ','1 2 3 4 5 6', $x);
$cnt = split(' ','1 2 3 4 5 6', $x);
-is($cnt, scalar(@ary));
+is($cnt, scalar(@ary), "Check element count from previous test");
# Does the 999 suppress null field chopping?
$_ = join(':', split(/:/,'1:2:3:4:5:6:::', 999));
@@ -76,7 +76,7 @@
# Splitting without pattern
$_ = "1 2 3 4";
$_ = join(':', split);
-is($_ , '1:2:3:4');
+is($_ , '1:2:3:4', "Split and join without specifying a split pattern");
# Does assignment to a list imply split to one more field than that?
$foo = runperl( switches => ['-Dt'], stderr => 1, prog => '($a,$b)=split;' );
@@ -85,7 +85,7 @@
# Can we say how many fields to split to when assigning to a list?
($a,$b) = split(' ','1 2 3 4 5 6', 2);
$_ = join(':',$a,$b);
-is($_, '1:2 3 4 5 6');
+is($_, '1:2 3 4 5 6', "Storing split output into list of scalars");
# do subpatterns generate additional fields (without trailing nulls)?
$_ = join '|', split(/,|(-)/, "1-10,20,,,");
@@ -417,3 +417,74 @@
# 'my' doesn't trigger the bug
is "@PATH", "Font GlyphNames", "hybrid scalar-and-array context";
}
+
+{
+ my @results;
+ my $expr= "foo bar";
+ my $cond;
+
+ @results= split(0||" ", $expr);
+ is @results, 2, 'split(0||" ") is treated like split(" ")'; #'
+
+ $cond= 0;
+ @results= split $cond ? " " : qr/ /, $expr;
+ is @results, 3, 'split($cond ? " " : qr/ /, $expr) works as expected (like qr/ /)';
+ $cond= 1;
+ @results= split $cond ? " " : qr/ /, $expr;
+ is @results, 2, 'split($cond ? " " : qr/ /, $expr) works as expected (like " ")';
+
+ $expr = ' a b c ';
+ @results = split /\s/, $expr;
+ is @results, 4,
+ "split on regex of single space metacharacter: captured 4 elements";
+ is $results[0], '',
+ "split on regex of single space metacharacter: first element is empty string";
+
+ @results = split / /, $expr;
+ is @results, 4,
+ "split on regex of single whitespace: captured 4 elements";
+ is $results[0], '',
+ "split on regex of single whitespace: first element is empty string";
+
+ @results = split " ", $expr;
+ is @results, 3,
+ "split on string of single whitespace: captured 3 elements";
+ is $results[0], 'a',
+ "split on string of single whitespace: first element is non-empty";
+
+ $expr = " a \tb c ";
+ @results = split " ", $expr;
+ is @results, 3,
+ "split on string of single whitespace: captured 3 elements";
+ is $results[0], 'a',
+ "split on string of single whitespace: first element is non-empty; multiple contiguous space characters";
+
+ my @seq;
+ for my $cond (0,1,0,1,0) {
+ $expr = " foo ";
+ @results = split $cond ? qr/ / : " ", $expr;
+ push @seq, scalar(@results) . ":" . $results[-1];
+ }
+ is join(" ", @seq), "1:foo 3:foo 1:foo 3:foo 1:foo",
+ qq{split(\$cond ? qr/ / : " ", "$exp") behaves as expected over repeated similar patterns};
+}
+
+{
+ # 'RT #116086: split "\x20" does not work as documented';
+ my @results;
+ my $expr;
+ $expr = ' a b c ';
+ @results = split "\x20", $expr;
+ is @results, 3,
+ "RT #116086: split on string of single hex-20: captured 3 elements";
+ is $results[0], 'a',
+ "RT #116086: split on string of single hex-20: first element is non-empty";
+
+ $expr = " a \tb c ";
+ @results = split "\x20", $expr;
+ is @results, 3,
+ "RT #116086: split on string of single hex-20: captured 3 elements";
+ is $results[0], 'a',
+ "RT #116086: split on string of single hex-20: first element is non-empty; multiple contiguous space characters";
+}
+
Property changes on: trunk/contrib/perl/t/op/split.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/split_unicode.t
===================================================================
--- trunk/contrib/perl/t/op/split_unicode.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/split_unicode.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -3,7 +3,7 @@
BEGIN {
require './test.pl';
skip_all_if_miniperl("no dynamic loading on miniperl, no File::Spec (used by charnames)");
- plan(tests => 150);
+ plan(tests => 151);
}
{
@@ -61,4 +61,18 @@
ok(@r3 == 3 && join('-', @r3) eq "-:A:-:B", "$msg - /\\s+/ No.2");
is($c3, scalar(@r3), "$msg - /\\s+/ No.2 (count)");
}
+
+ { # RT #114808
+ warning_is(
+ sub {
+ $p=chr(0x100);
+ for (".","ab\x{101}def") {
+ @q = split /$p/
+ }
+ },
+ undef,
+ 'no warnings when part of split cant match non-utf8'
+ );
+ }
+
}
Property changes on: trunk/contrib/perl/t/op/split_unicode.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/sprintf.t
===================================================================
--- trunk/contrib/perl/t/op/sprintf.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/sprintf.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -6,6 +6,8 @@
# not-a-number ...), of the effects of locale, and of features
# specific to multi-byte characters (under the utf8 pragma and such).
+# For tests that do not fit this format, use sprintf2.t.
+
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
@@ -14,9 +16,10 @@
use version;
use Config;
use strict;
+require './test.pl';
my @tests = ();
-my ($i, $template, $data, $result, $comment, $w, $x, $evalData, $n, $p);
+my ($template, $data, $result, $comment, $w, $x, $evalData, $n, $p);
my $Is_VMS_VAX = 0;
# We use HW_MODEL since ARCH_NAME was not in VMS V5.*
@@ -41,7 +44,7 @@
if ($Is_VMS_VAX || $Is_Ultrix_VAX) {
# VAX DEC C 5.3 at least since there is no
# ccflags =~ /float=ieee/ on VAX.
- # AXP is unaffected whether or not it's using ieee.
+ # AXP is unaffected whether or not it is using ieee.
$data =~ s/([eE])96$/${1}26/; # smaller exponents
$result =~ s/([eE]\+)102$/${1}32/; # " "
$data =~ s/([eE])\-101$/${1}-24/; # larger exponents
@@ -53,7 +56,7 @@
push @tests, [$template, $evalData, $result, $comment, $data];
}
-print '1..', scalar @tests, "\n";
+plan(scalar @tests);
$SIG{__WARN__} = sub {
if ($_[0] =~ /^Invalid conversion/) {
@@ -62,13 +65,15 @@
$w .= ' UNINIT';
} elsif ($_[0] =~ /^Missing argument/) {
$w .= ' MISSING';
+ } elsif ($_[0]=~/^vector argument not supported with alpha versions/) {
+ $w .= ' ALPHA';
} else {
warn @_;
}
};
-for ($i = 1; @tests; $i++) {
- ($template, $evalData, $result, $comment, $data) = @{shift @tests};
+for (@tests) {
+ ($template, $evalData, $result, $comment, $data) = @$_;
$w = undef;
$x = sprintf($template, @$evalData);
$x = ">$x<" if defined $x;
@@ -101,7 +106,7 @@
} elsif ($os =~ /\b$^O(?::(\S+))?\b/i) {
my $vsn = defined $1 ? $1 : "0";
# Only compare on the the first pair of digits, as numeric
- # compares don't like 2.6.10-3mdksmp or 2.6.8-24.10-default
+ # compares do not like 2.6.10-3mdksmp or 2.6.8-24.10-default
s/^(\d+(\.\d+)?).*/$1/ for $osv, $vsn;
$skip = $vsn ? ($osv <= $vsn ? 1 : 0) : 1;
}
@@ -109,28 +114,27 @@
}
if ($x eq ">$result<") {
- print "ok $i\n";
+ ok(1, ">$result<");
}
elsif ($skip) {
- print "ok $i # skip $comment\n";
+ ok(1, "skip $comment");
}
elsif ($y eq ">$result<") # Some C libraries always give
{ # three-digit exponent
- print("ok $i # >$result< $x three-digit exponent accepted\n");
+ ok(1, ">$result< $x three-digit exponent accepted");
}
elsif ($result =~ /[-+]\d{3}$/ &&
# Suppress tests with modulo of exponent >= 100 on platforms
- # which can't handle such magnitudes (or where we can't tell).
+ # which cannot handle such magnitudes (or where we cannot tell).
((!eval {require POSIX}) || # Costly: only do this if we must!
(length(&POSIX::DBL_MAX) - rindex(&POSIX::DBL_MAX, '+')) == 3))
{
- print("ok $i # >$template< >$data< >$result<",
- " Suppressed: exponent out of range?\n");
+ ok(1,
+ ">$template< >$data< >$result< Suppressed: exponent out of range?\n");
}
else {
- $y = ($x eq $y ? "" : " => $y");
- print("not ok $i >$template< >$data< >$result< $x$y",
- $comment ? " # $comment\n" : "\n");
+ $y = ($x eq $y ? "" : " => $y");
+ ok(0, ">$template< >$data< >$result< $x$y $comment");
}
}
@@ -317,6 +321,7 @@
>%vd< >[version->new("1.002")]< >1.2<
>%vd< >[version->new("1048576.5")]< >1048576.5<
>%vd< >[version->new("50")]< >50<
+>[%vd]< >[version->new(v1.1_1)]< >[] ALPHA<
>%v.3d< >"\01\02\03"< >001.002.003<
>%0v3d< >"\01\02\03"< >001.002.003<
>%v.3d< >[version::qv("1.2.3")]< >001.002.003<
@@ -399,7 +404,7 @@
> %.0g< >[]< > 0 MISSING<
>%.2g< >[]< >0 MISSING<
>%.2gC< >[]< >0C MISSING<
->%.0g< >-0.0< >-0< >C99 standard mandates minus sign but C89 does not skip: MSWin32 VMS hpux:10.20 openbsd netbsd:1.5 irix darwin<
+>%.0g< >-0.0< >-0< >C99 standard mandates minus sign but C89 does not skip: MSWin32 VMS hpux:10.20 openbsd netbsd:1.5 irix darwin freebsd:4.9<
>%.0g< >12345.6789< >1e+04<
>%#.0g< >12345.6789< >1.e+04<
>%.2g< >12345.6789< >1.2e+04<
@@ -436,6 +441,8 @@
>%l< >''< >%l INVALID<
>%m< >''< >%m INVALID<
>%s< >sprintf('%%n%n %d', $n, $n)< >%n 2< >Slight sneakiness to test %n<
+>%s< >$n="abc"; sprintf(' %n%s', substr($n,1,1), $n)< > a1c< >%n w/magic<
+>%s< >no warnings; sprintf('%s%n', chr(256)x5, $n),$n< >5< >Unicode %n<
>%o< >2**32-1< >37777777777<
>%+o< >2**32-1< >37777777777<
>%#o< >2**32-1< >037777777777<
@@ -710,3 +717,4 @@
>%v.*X< >[3, '012']< >030.031.032< >perl #83194: vector flag + dynamic precision<
>%*v.3X< >[':', '012']< >030:031:032< >perl #83194: vector flag + custom separator + static precision<
>%*v.*X< >[':', 3, '012']< >030:031:032< >perl #83194: vector flag + custom separator + dynamic precision<
+>%vd< >"version"< >118.101.114.115.105.111.110< >perl #102586: vector flag + "version"<
Property changes on: trunk/contrib/perl/t/op/sprintf.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/sprintf2.t
===================================================================
--- trunk/contrib/perl/t/op/sprintf2.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/sprintf2.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,5 +1,7 @@
#!./perl -w
+# Tests for sprintf that do not fit the format of sprintf.t.
+
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
@@ -6,7 +8,7 @@
require './test.pl';
}
-plan tests => 1368;
+plan tests => 1370;
use strict;
use Config;
@@ -180,3 +182,12 @@
);
}
}
+
+# Overload count
+package o { use overload '""', sub { ++our $count; $_[0][0]; } }
+my $o = bless ["\x{100}"], o::;
+() = sprintf "%1s", $o;
+is $o::count, '1', 'sprinf %1s overload count';
+$o::count = 0;
+() = sprintf "%.1s", $o;
+is $o::count, '1', 'sprinf %.1s overload count';
Property changes on: trunk/contrib/perl/t/op/sprintf2.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/srand.t
===================================================================
--- trunk/contrib/perl/t/op/srand.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/srand.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -10,7 +10,7 @@
use strict;
require "test.pl";
-plan(tests => 9);
+plan(tests => 10);
# Generate a load of random numbers.
# int() avoids possible floating point error.
@@ -79,3 +79,12 @@
is( $b, 0, "Quacks like a zero");
is( "@warnings", "", "Does not warn");
}
+
+# [perl #40605]
+{
+ use warnings;
+ my $w = '';
+ local $SIG{__WARN__} = sub { $w .= $_[0] };
+ srand(2**100);
+ like($w, qr/^Integer overflow in srand at /, "got a warning");
+}
Property changes on: trunk/contrib/perl/t/op/srand.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/sselect.t
===================================================================
--- trunk/contrib/perl/t/op/sselect.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/sselect.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,8 +1,10 @@
#!./perl
+my $hires;
BEGIN {
chdir 't' if -d 't';
@INC = ('.', '../lib');
+ $hires = eval 'use Time::HiResx "time"; 1';
}
require 'test.pl';
@@ -11,40 +13,54 @@
my $blank = "";
eval {select undef, $blank, $blank, 0};
-is ($@, "");
+is ($@, "", 'select undef $blank $blank 0');
eval {select $blank, undef, $blank, 0};
-is ($@, "");
+is ($@, "", 'select $blank undef $blank 0');
eval {select $blank, $blank, undef, 0};
-is ($@, "");
+is ($@, "", 'select $blank $blank undef 0');
eval {select "", $blank, $blank, 0};
-is ($@, "");
+is ($@, "", 'select "" $blank $blank 0');
eval {select $blank, "", $blank, 0};
-is ($@, "");
+is ($@, "", 'select $blank "" $blank 0');
eval {select $blank, $blank, "", 0};
-is ($@, "");
+is ($@, "", 'select $blank $blank "" 0');
eval {select "a", $blank, $blank, 0};
-like ($@, qr/^Modification of a read-only value attempted/);
+like ($@, qr/^Modification of a read-only value attempted/,
+ 'select "a" $blank $blank 0');
eval {select $blank, "a", $blank, 0};
-like ($@, qr/^Modification of a read-only value attempted/);
+like ($@, qr/^Modification of a read-only value attempted/,
+ 'select $blank "a" $blank 0');
eval {select $blank, $blank, "a", 0};
-like ($@, qr/^Modification of a read-only value attempted/);
+like ($@, qr/^Modification of a read-only value attempted/,
+ 'select $blank $blank "a" 0');
-my($sleep,$fudge) = (3,0);
+my $sleep = 3;
# Actual sleep time on Windows may be rounded down to an integral
# multiple of the system clock tick interval. Clock tick interval
# is configurable, but usually about 15.625 milliseconds.
-# time() however doesn't return fractional values, so the observed
-# delay may be 1 second short.
-($sleep,$fudge) = (4,1) if $^O eq "MSWin32";
+# time() however (if we haven;t loaded Time::HiRes), doesn't return
+# fractional values, so the observed delay may be 1 second short.
+#
+# There is also a report that old linux kernels may return 0.5ms early:
+# <20110520081714.GC17549 at mars.tony.develop-help.com>.
+#
-my $t = time;
+my $under = $hires ? 0.1 : 1;
+
+my $t0 = time;
select(undef, undef, undef, $sleep);
-ok(time-$t >= $sleep-$fudge, "$sleep seconds have passed");
+my $t1 = time;
+my $diff = $t1-$t0;
+ok($diff >= $sleep-$under, "select(u,u,u,\$sleep): at least $sleep seconds have passed");
+note("diff=$diff under=$under");
my $empty = "";
vec($empty,0,1) = 0;
-$t = time;
+$t0 = time;
select($empty, undef, undef, $sleep);
-ok(time-$t >= $sleep-$fudge, "$sleep seconds have passed");
+$t1 = time;
+$diff = $t1-$t0;
+ok($diff >= $sleep-$under, "select(\$e,u,u,\$sleep): at least $sleep seconds have passed");
+note("diff=$diff under=$under");
Property changes on: trunk/contrib/perl/t/op/sselect.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/stash.t
===================================================================
--- trunk/contrib/perl/t/op/stash.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/stash.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -7,7 +7,7 @@
BEGIN { require "./test.pl"; }
-plan( tests => 54 );
+plan( tests => 58 );
# Used to segfault (bug #15479)
fresh_perl_like(
@@ -25,6 +25,17 @@
q(Insert a non-GV in a stash, under warnings 'once'),
);
+# Used to segfault, too
+SKIP: {
+ skip_if_miniperl('requires XS');
+ fresh_perl_like(
+ 'sub foo::bar{}; $mro::{get_mro}=*foo::bar; undef %foo::; require mro',
+ qr/^Subroutine mro::get_mro redefined at /,
+ { switches => [ '-w' ] },
+ q(Defining an XSUB over an existing sub with no stash under warnings),
+ );
+}
+
{
no warnings 'deprecated';
ok( defined %oedipa::maas::, q(stashes happen to be defined if not used) );
@@ -52,6 +63,13 @@
'',
'',
);
+ # Variant of the above which creates an object that persists until global
+ # destruction.
+ fresh_perl_is(
+ 'use Exporter; package A; sub a { // }; %::=""',
+ '',
+ '',
+ );
}
# now tests in eval
@@ -81,7 +99,7 @@
delete $one::{one};
my $gv = b($sub)->GV;
- isa_ok( $gv, "B::GV", "deleted stash entry leaves CV with valid GV");
+ object_ok( $gv, "B::GV", "deleted stash entry leaves CV with valid GV");
is( b($sub)->CvFLAGS & $CVf_ANON, $CVf_ANON, "...and CVf_ANON set");
is( eval { $gv->NAME }, "__ANON__", "...and an __ANON__ name");
is( eval { $gv->STASH->NAME }, "one", "...but leaves stash intact");
@@ -93,7 +111,7 @@
%two:: = ();
$gv = b($sub)->GV;
- isa_ok( $gv, "B::GV", "cleared stash leaves CV with valid GV");
+ object_ok( $gv, "B::GV", "cleared stash leaves CV with valid GV");
is( b($sub)->CvFLAGS & $CVf_ANON, $CVf_ANON, "...and CVf_ANON set");
is( eval { $gv->NAME }, "__ANON__", "...and an __ANON__ name");
is( eval { $gv->STASH->NAME }, "two", "...but leaves stash intact");
@@ -105,7 +123,7 @@
undef %three::;
$gv = b($sub)->GV;
- isa_ok( $gv, "B::GV", "undefed stash leaves CV with valid GV");
+ object_ok( $gv, "B::GV", "undefed stash leaves CV with valid GV");
is( b($sub)->CvFLAGS & $CVf_ANON, $CVf_ANON, "...and CVf_ANON set");
is( eval { $gv->NAME }, "__ANON__", "...and an __ANON__ name");
is( eval { $gv->STASH->NAME }, "__ANON__", "...and an __ANON__ stash");
@@ -269,11 +287,8 @@
'ref() returns the same thing when an object’s stash is moved';
::like "$obj", qr "^rile=ARRAY\(0x[\da-f]+\)\z",
'objects stringify the same way when their stashes are moved';
- {
- local $::TODO = $Config{useithreads} ? "fails under threads" : undef;
- ::is eval '__PACKAGE__', 'rile',
+ ::is eval '__PACKAGE__', 'rile',
'__PACKAGE__ returns the same when the current stash is moved';
- }
# Now detach it completely from the symtab, making it effect-
# ively anonymous
@@ -286,11 +301,8 @@
'ref() returns the same thing when an object’s stash is detached';
::like "$obj", qr "^rile=ARRAY\(0x[\da-f]+\)\z",
'objects stringify the same way when their stashes are detached';
- {
- local $::TODO = $Config{useithreads} ? "fails under threads" : undef;
- ::is eval '__PACKAGE__', 'rile',
+ ::is eval '__PACKAGE__', 'rile',
'__PACKAGE__ returns the same when the current stash is detached';
- }
}
# Setting the name during undef %stash:: should have no effect.
@@ -312,3 +324,15 @@
ok eval { Bear::::baz() },
'packages ending with :: are self-consistent';
}
+
+# [perl #88138] ' not equivalent to :: before a null
+${"a'\0b"} = "c";
+is ${"a::\0b"}, "c", "' is equivalent to :: before a null";
+
+# [perl #101486] Clobbering the current package
+ok eval '
+ package Do;
+ BEGIN { *Do:: = *Re:: }
+ sub foo{};
+ 1
+ ', 'no crashing or errors when clobbering the current package';
Property changes on: trunk/contrib/perl/t/op/stash.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/stat.t
===================================================================
--- trunk/contrib/perl/t/op/stat.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/stat.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -20,15 +20,17 @@
}
-plan tests => 107;
+plan tests => 113;
my $Perl = which_perl();
+$ENV{LC_ALL} = 'C'; # Forge English error messages.
+$ENV{LANGUAGE} = 'C'; # Ditto in GNU.
+
$Is_Amiga = $^O eq 'amigaos';
$Is_Cygwin = $^O eq 'cygwin';
$Is_Darwin = $^O eq 'darwin';
$Is_Dos = $^O eq 'dos';
-$Is_MPE = $^O eq 'mpeix';
$Is_MSWin32 = $^O eq 'MSWin32';
$Is_NetWare = $^O eq 'NetWare';
$Is_OS2 = $^O eq 'os2';
@@ -36,7 +38,6 @@
$Is_VMS = $^O eq 'VMS';
$Is_DGUX = $^O eq 'dgux';
$Is_MPRAS = $^O =~ /svr4/ && -f '/etc/.relid';
-$Is_Rhapsody= $^O eq 'rhapsody';
$Is_Dosish = $Is_Dos || $Is_OS2 || $Is_MSWin32 || $Is_NetWare;
@@ -249,6 +250,7 @@
skip "ls command not available to Perl in OpenVMS right now.", 6
if $Is_VMS;
+ delete $ENV{CLICOLOR_FORCE};
my $LS = $Config{d_readlink} ? "ls -lL" : "ls -l";
my $CMD = "$LS /dev 2>/dev/null";
my $DEV = qx($CMD);
@@ -341,7 +343,7 @@
SKIP: {
skip "These tests require a TTY", 4 if $ENV{PERL_SKIP_TTY_TEST};
- my $TTY = $Is_Rhapsody ? "/dev/ttyp0" : "/dev/tty";
+ my $TTY = "/dev/tty";
SKIP: {
skip "Test uses unixisms", 2 if $Is_MSWin32 || $Is_NetWare;
@@ -441,6 +443,12 @@
eval { lstat _ };
like( $@, qr/^The stat preceding lstat\(\) wasn't an lstat/,
'lstat _ croaks after stat' );
+eval { lstat *_ };
+like( $@, qr/^The stat preceding lstat\(\) wasn't an lstat/,
+ 'lstat *_ croaks after stat' );
+eval { lstat \*_ };
+like( $@, qr/^The stat preceding lstat\(\) wasn't an lstat/,
+ 'lstat \*_ croaks after stat' );
eval { -l _ };
like( $@, qr/^The stat preceding -l _ wasn't an lstat/,
'-l _ croaks after stat' );
@@ -450,6 +458,22 @@
is( "$@", "", "lstat _ ok after lstat" );
eval { -l _ };
is( "$@", "", "-l _ ok after lstat" );
+
+eval { lstat "test.pl" };
+{
+ open my $fh, "test.pl";
+ stat *$fh{IO};
+ eval { lstat _ }
+}
+like $@, qr/^The stat preceding lstat\(\) wasn't an lstat at /,
+'stat $ioref resets stat type';
+
+{
+ my @statbuf = stat STDOUT;
+ stat "test.pl";
+ my @lstatbuf = lstat *STDOUT{IO};
+ is "@lstatbuf", "@statbuf", 'lstat $ioref reverts to regular fstat';
+}
SKIP: {
skip "No lstat", 2 unless $Config{d_lstat};
@@ -456,8 +480,10 @@
# bug id 20020124.004
# If we have d_lstat, we should have symlink()
- my $linkname = 'dolzero';
- symlink $0, $linkname or die "# Can't symlink $0: $!";
+ my $linkname = 'stat-' . rand =~ y/.//dr;
+ my $target = $Perl;
+ $target =~ s/;\d+\z// if $Is_VMS; # symlinks don't like version numbers
+ symlink $target, $linkname or die "# Can't symlink $0: $!";
lstat $linkname;
-T _;
eval { lstat _ };
@@ -488,6 +514,7 @@
ok(unlink($f), 'unlink tmp file');
}
+# [perl #4253]
{
ok(open(F, ">", $tmpfile), 'can create temp file');
close F;
@@ -497,6 +524,15 @@
-T _;
my $s2 = -s _;
is($s1, $s2, q(-T _ doesn't break the statbuffer));
+ SKIP: {
+ skip "No lstat", 1 unless $Config{d_lstat};
+ skip "uid=0", 1 unless $<&&$>;
+ skip "Readable by group/other means readable by me", 1 if $^O eq 'VMS';
+ lstat($tmpfile);
+ -T _;
+ ok(eval { lstat _ },
+ q(-T _ doesn't break lstat for unreadable file));
+ }
unlink $tmpfile;
}
@@ -557,6 +593,16 @@
}
}
+# [perl #71002]
+{
+ local $^W = 1;
+ my $w;
+ local $SIG{__WARN__} = sub { warn shift; ++$w };
+ stat 'prepeinamehyparcheiarcheiometoonomaavto';
+ stat _;
+ is $w, undef, 'no unopened warning from stat _';
+}
+
END {
chmod 0666, $tmpfile;
unlink_all $tmpfile;
Property changes on: trunk/contrib/perl/t/op/stat.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/state.t
===================================================================
--- trunk/contrib/perl/t/op/state.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/state.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -8,9 +8,15 @@
}
use strict;
+
+plan tests => 132;
+
+# Before loading feature.pm, test it with CORE::
+ok eval 'CORE::state $x = 1;', 'CORE::state outside of feature.pm scope';
+
+
use feature ":5.10";
-plan tests => 130;
ok( ! defined state $uninit, q(state vars are undef by default) );
@@ -205,6 +211,7 @@
my $First = ucfirst $first;
$_ = "bambam";
foreach my $flint (@stones) {
+ no warnings 'experimental::lexical_topic';
state $_ = $flint;
is $_, $first, 'state $_';
ok /$first/, '/.../ binds to $_';
@@ -305,6 +312,7 @@
#
my @spam = qw [spam ham bacon beans];
foreach my $spam (@spam) {
+ no warnings 'experimental::smartmatch';
given (state $spam = $spam) {
when ($spam [0]) {ok 1, "given"}
default {ok 0, "given"}
@@ -398,6 +406,17 @@
}
+# [perl #117095] state var initialisation getting skipped
+# the 'if 0' code below causes a call to op_free at compile-time,
+# which used to inadvertently mark the state var as initialised.
+
+{
+ state $f = 1;
+ foo($f) if 0; # this calls op_free on padmy($f)
+ ok(defined $f, 'state init not skipped');
+}
+
+
__DATA__
state ($a) = 1;
(state $a) = 1;
Property changes on: trunk/contrib/perl/t/op/state.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/study.t
===================================================================
--- trunk/contrib/perl/t/op/study.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/study.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -7,7 +7,7 @@
}
watchdog(10);
-plan(tests => 29);
+plan(tests => 43);
use strict;
use vars '$x';
@@ -85,3 +85,77 @@
ok(!/G.F$/, 'bug 20010618.006');
ok(!/[F]F$/, 'bug 20010618.006');
}
+
+{
+ my $a = 'QaaQaabQaabbQ';
+ study $a;
+ my @a = split /aab*/, $a;
+ is("@a", 'Q Q Q Q', 'split with studied string passed to the regep engine');
+}
+
+{
+ $_ = "AABBAABB";
+ study;
+ is(s/AB+/1/ge, 2, 'studied scalar passed to pp_substconst');
+ is($_, 'A1A1');
+}
+
+{
+ $_ = "AABBAABB";
+ study;
+ is(s/(A)B+/1/ge, 2,
+ 'studied scalar passed to pp_substconst with RX_MATCH_COPIED() true');
+ is($1, 'A');
+ is($2, undef);
+ is($_, 'A1A1');
+}
+
+{
+ my @got;
+ $a = "ydydydyd";
+ $b = "xdx";
+ push @got, $_ foreach $a =~ /[^x]d(?{})[^x]d/g;
+ is("@got", 'ydyd ydyd', '#92696 control');
+
+ @got = ();
+ $a = "ydydydyd";
+ $b = "xdx";
+ study $a;
+ push @got, $_ foreach $a =~ /[^x]d(?{})[^x]d/g;
+ is("@got", 'ydyd ydyd', '#92696 study $a');
+
+ @got = ();
+ $a = "ydydydyd";
+ $b = "xdx";
+ study $b;
+ push @got, $_ foreach $a =~ /[^x]d(?{})[^x]d/g;
+ is("@got", 'ydyd ydyd', '#92696 study $b');
+
+ @got = ();
+ $a = "ydydydyd";
+ $b = "xdx";
+ push @got, $_ foreach $a =~ /[^x]d(?{study $b})[^x]d/g;
+ is("@got", 'ydyd ydyd', '#92696 study $b inside (?{}), nothing studied');
+
+ @got = ();
+ $a = "ydydydyd";
+ $b = "xdx";
+ my $c = 'zz';
+ study $c;
+ push @got, $_ foreach $a =~ /[^x]d(?{study $b})[^x]d/g;
+ is("@got", 'ydyd ydyd', '#92696 study $b inside (?{}), $c studied');
+
+ @got = ();
+ $a = "ydydydyd";
+ $b = "xdx";
+ study $a;
+ push @got, $_ foreach $a =~ /[^x]d(?{study $b})[^x]d/g;
+ is("@got", 'ydyd ydyd', '#92696 study $b inside (?{}), $a studied');
+
+ @got = ();
+ $a = "ydydydyd";
+ $b = "xdx";
+ study $a;
+ push @got, $_ foreach $a =~ /[^x]d(?{$a .= ''})[^x]d/g;
+ is("@got", 'ydyd ydyd', '#92696 $a .= \'\' inside (?{}), $a studied');
+}
Property changes on: trunk/contrib/perl/t/op/study.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/t/op/studytied.t
===================================================================
--- trunk/contrib/perl/t/op/studytied.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/studytied.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/studytied.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/sub.t
===================================================================
--- trunk/contrib/perl/t/op/sub.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/sub.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -6,7 +6,7 @@
require './test.pl';
}
-plan( tests => 8 );
+plan( tests => 16 );
sub empty_sub {}
@@ -40,3 +40,48 @@
push @a, 34, 35, &{$x == $x};
ok(eq_array(\@a, [34,35]), "yes without args");
}
+
+# [perl #81944] return should always copy
+{
+ $foo{bar} = 7;
+ for my $x ($foo{bar}) {
+ # Pity test.pl doesnt have isn't.
+ isnt \sub { delete $foo{bar} }->(), \$x,
+ 'result of delete(helem) is copied when returned';
+ }
+ $foo{bar} = 7;
+ for my $x ($foo{bar}) {
+ isnt \sub { return delete $foo{bar} }->(), \$x,
+ 'result of delete(helem) is copied when explicitly returned';
+ }
+ my $x;
+ isnt \sub { delete $_[0] }->($x), \$x,
+ 'result of delete(aelem) is copied when returned';
+ isnt \sub { return delete $_[0] }->($x), \$x,
+ 'result of delete(aelem) is copied when explicitly returned';
+ isnt \sub { ()=\@_; shift }->($x), \$x,
+ 'result of shift is copied when returned';
+ isnt \sub { ()=\@_; return shift }->($x), \$x,
+ 'result of shift is copied when explicitly returned';
+}
+
+fresh_perl_is
+ <<'end', "main::foo\n", {}, 'sub redefinition sets CvGV';
+*foo = \&baz;
+*bar = *foo;
+eval 'sub bar { print +(caller 0)[3], "\n" }';
+bar();
+end
+
+fresh_perl_is
+ <<'end', "main::foo\nok\n", {}, 'no double free redefining anon stub';
+my $sub = sub { 4 };
+*foo = $sub;
+*bar = *foo;
+undef &$sub;
+eval 'sub bar { print +(caller 0)[3], "\n" }';
+&$sub;
+undef *foo;
+undef *bar;
+print "ok\n";
+end
Property changes on: trunk/contrib/perl/t/op/sub.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/sub_lval.t
===================================================================
--- trunk/contrib/perl/t/op/sub_lval.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/sub_lval.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -3,7 +3,7 @@
@INC = '../lib';
require './test.pl';
}
-plan tests=>76;
+plan tests=>192;
sub a : lvalue { my $a = 34; ${\(bless \$a)} } # Return a temporary
sub b : lvalue { ${\shift} }
@@ -131,7 +131,7 @@
#@out = ($x, a3, $y, b2, $z, c4, $t);
#@in = (34 .. 41, (undef) x 4, 46);
-#print "# `@out' ne `@in'\nnot " unless "@out" eq "@in";
+#print "# '@out' ne '@in'\nnot " unless "@out" eq "@in";
like($_, qr/Can\'t return an uninitialized value from lvalue subroutine/);
print "ok 22\n";
@@ -210,7 +210,8 @@
like($_, qr/Can\'t modify non-lvalue subroutine call/)
or diag "'$_', '$x0', '$x1'";
-sub lv0 : lvalue { } # Converted to lv10 in scalar context
+sub lv0 : lvalue { }
+sub rlv0 : lvalue { return }
$_ = undef;
eval <<'EOE' or $_ = $@;
@@ -220,8 +221,15 @@
like($_, qr/Can't return undef from lvalue subroutine/);
-sub lv10 : lvalue {}
+$_ = undef;
+eval <<'EOE' or $_ = $@;
+ rlv0 = (2,3);
+ 1;
+EOE
+like($_, qr/Can't return undef from lvalue subroutine/,
+ 'explicit return of nothing in scalar context');
+
$_ = undef;
eval <<'EOE' or $_ = $@;
(lv0) = (2,3);
@@ -230,7 +238,22 @@
ok(!defined $_) or diag $_;
+$_ = undef;
+eval <<'EOE' or $_ = $@;
+ (rlv0) = (2,3);
+ 1;
+EOE
+
+ok(!defined $_, 'explicit return of nothing in list context') or diag $_;
+
+($a,$b)=();
+(lv0($a,$b)) = (3,4);
+is +($a//'undef') . ($b//'undef'), 'undefundef',
+ 'list assignment to empty lvalue sub';
+
+
sub lv1u :lvalue { undef }
+sub rlv1u :lvalue { undef }
$_ = undef;
eval <<'EOE' or $_ = $@;
@@ -242,15 +265,29 @@
$_ = undef;
eval <<'EOE' or $_ = $@;
+ rlv1u = (2,3);
+ 1;
+EOE
+
+like($_, qr/Can't return undef from lvalue subroutine/,
+ 'explicitly returning undef in scalar context');
+
+$_ = undef;
+eval <<'EOE' or $_ = $@;
(lv1u) = (2,3);
1;
EOE
-# Fixed by change @10777
-#print "# '$_'.\nnot "
-# unless /Can\'t return an uninitialized value from lvalue subroutine/;
-# print "ok 34 # Skip: removed test\n";
+ok(!defined, 'implicitly returning undef in list context');
+$_ = undef;
+eval <<'EOE' or $_ = $@;
+ (rlv1u) = (2,3);
+ 1;
+EOE
+
+ok(!defined, 'explicitly returning undef in list context');
+
$x = '1234567';
$_ = undef;
@@ -260,17 +297,32 @@
1;
EOE
-like($_, qr/Can\'t modify index in lvalue subroutine return/);
+like($_, qr/Can\'t return a temporary from lvalue subroutine/);
$_ = undef;
eval <<'EOE' or $_ = $@;
- sub lv2t : lvalue { shift }
- (lv2t) = (2,3);
+ sub rlv1t : lvalue { index $x, 2 }
+ rlv1t = (2,3);
1;
EOE
-like($_, qr/Can\'t modify shift in lvalue subroutine return/);
+like($_, qr/Can\'t return a temporary from lvalue subroutine/,
+ 'returning a PADTMP explicitly');
+$_ = undef;
+eval <<'EOE' or $_ = $@;
+ (rlv1t) = (2,3);
+ 1;
+EOE
+
+like($_, qr/Can\'t return a temporary from lvalue subroutine/,
+ 'returning a PADTMP explicitly (list context)');
+
+$_ = undef;
+sub lv2t : lvalue { shift }
+(lv2t($_)) = (2,3);
+is($_, 2);
+
$xxx = 'xxx';
sub xxx () { $xxx } # Not lvalue
@@ -281,7 +333,7 @@
1;
EOE
-like($_, qr/Can\'t modify non-lvalue subroutine call in lvalue subroutine return/);
+like($_, qr/Can\'t modify non-lvalue subroutine call at /);
$_ = undef;
eval <<'EOE' or $_ = $@;
@@ -289,7 +341,7 @@
1;
EOE
-like($_, qr/Can\'t return a temporary from lvalue subroutine/);
+like($_, qr/Can\'t modify non-lvalue subroutine call at /);
sub yyy () { 'yyy' } # Const, not lvalue
@@ -300,7 +352,7 @@
1;
EOE
-like($_, qr/Can\'t modify constant item in lvalue subroutine return/);
+like($_, qr/Can\'t return a readonly value from lvalue subroutine at/);
$_ = undef;
eval <<'EOE' or $_ = $@;
@@ -333,17 +385,15 @@
is("'@a' $_", "'2 3' ");
-$_ = undef;
- at a = ();
-$a[0] = undef;
-$a[1] = 12;
-eval <<'EOE' or $_ = $@;
- (lva) = (2,3);
- 1;
-EOE
+is lva->${\sub { return $_[0] }}, 2,
+ 'lvalue->$thing when lvalue returns array';
-is("'@a' $_", "'2 3' ");
+my @my = qw/ a b c /;
+sub lvmya : lvalue { @my }
+is lvmya->${\sub { return $_[0] }}, 3,
+ 'lvalue->$thing when lvalue returns lexical array';
+
sub lv1n : lvalue { $newvar }
$_ = undef;
@@ -372,6 +422,13 @@
foobar() = 12;
is($newvar, "12");
+# But autoloading should only be triggered by a call to an undefined
+# subroutine.
+&{"lv1nn"} = 14;
+is $newvar, 12, 'AUTOLOAD does not take precedence over lvalue sub';
+eval { &{"xxx"} = 14 };
+is $newvar, 12, 'AUTOLOAD does not take precedence over non-lvalue sub';
+
{
my %hash; my @array;
sub alv : lvalue { $array[1] }
@@ -452,6 +509,11 @@
}
is("@p", "1 8");
+sub keeze : lvalue { keys %__ }
+%__ = ("a","b");
+keeze = 64;
+is scalar %__, '1/64', 'keys assignment through lvalue sub';
+
# Bug 20001223.002: split thought that the list had only one element
@ary = qw(4 5 6);
sub lval1 : lvalue { $ary[0]; }
@@ -500,10 +562,35 @@
is ($Tie_Array::val[0], "value");
-TODO: {
- local $TODO = 'test explicit return of lval expr';
- # subs are corrupted copies from tests 1-~4
+# Check that tied pad vars that are returned can be assigned to
+sub TIESCALAR { bless [] }
+sub STORE {$wheel = $_[1]}
+sub FETCH {$wheel}
+sub tied_pad_var :lvalue { tie my $tyre, ''; $tyre }
+sub tied_pad_varr :lvalue { tie my $tyre, ''; return $tyre }
+tied_pad_var = 1;
+is $wheel, 1, 'tied pad var returned in scalar lvalue context';
+tied_pad_var->${\sub{ $_[0] = 2 }};
+is $wheel, 2, 'tied pad var returned in scalar ref context';
+(tied_pad_var) = 3;
+is $wheel, 3, 'tied pad var returned in list lvalue context';
+$_ = 4 for tied_pad_var;
+is $wheel, 4, 'tied pad var returned in list ref context';
+tied_pad_varr = 5;
+is $wheel, 5, 'tied pad var explicitly returned in scalar lvalue context';
+tied_pad_varr->${\sub{ $_[0] = 6 }};
+is $wheel, 6, 'tied pad var explicitly returned in scalar ref context';
+(tied_pad_varr) = 7;
+is $wheel, 7, 'tied pad var explicitly returned in list lvalue context';
+$_ = 8 for tied_pad_varr;
+is $wheel, 8, 'tied pad var explicitly returned in list ref context';
+
+
+# Test explicit return of lvalue expression
+{
+ # subs are copies from tests 1-~18 with an explicit return added.
+ # They used not to work, which is why they are ‘badly’ named.
sub bad_get_lex : lvalue { return $in };
sub bad_get_st : lvalue { return $blah }
@@ -525,6 +612,80 @@
++bad_get_st;
is($blah, 8, "yada");
+
+ ++bad_get_lex;
+ cmp_ok($in, '==', 8);
+
+ bad_id(bad_get_st) = 10;
+ cmp_ok($blah, '==', 10);
+
+ bad_id(bad_get_lex) = 10;
+ cmp_ok($in, '==', 10);
+
+ ++bad_id(bad_get_st);
+ cmp_ok($blah, '==', 11);
+
+ ++bad_id(bad_get_lex);
+ cmp_ok($in, '==', 11);
+
+ bad_id1(bad_get_st) = 20;
+ cmp_ok($blah, '==', 20);
+
+ bad_id1(bad_get_lex) = 20;
+ cmp_ok($in, '==', 20);
+
+ ++bad_id1(bad_get_st);
+ cmp_ok($blah, '==', 21);
+
+ ++bad_id1(bad_get_lex);
+ cmp_ok($in, '==', 21);
+
+ bad_inc(bad_get_st);
+ cmp_ok($blah, '==', 22);
+
+ bad_inc(bad_get_lex);
+ cmp_ok($in, '==', 22);
+
+ bad_inc(bad_id(bad_get_st));
+ cmp_ok($blah, '==', 23);
+
+ bad_inc(bad_id(bad_get_lex));
+ cmp_ok($in, '==', 23);
+
+ ++bad_inc(bad_id1(bad_id(bad_get_st)));
+ cmp_ok($blah, '==', 25);
+
+ ++bad_inc(bad_id1(bad_id(bad_get_lex)));
+ cmp_ok($in, '==', 25);
+
+ # Recursive
+ my $r;
+ my $to_modify;
+ $r = sub :lvalue {
+ my $depth = shift//0;
+ if ($depth == 2) { return $to_modify }
+ return &$r($depth+1);
+ };
+ &$r(0) = 7;
+ is $to_modify, 7, 'recursive lvalue sub';
+
+ # Recursive with substr [perl #72706]
+ my $val = '';
+ my $pie;
+ $pie = sub :lvalue {
+ my $depth = shift;
+ return &$pie($depth) if $depth--;
+ substr $val, 0;
+ };
+ for my $depth (0, 1, 2) {
+ my $value = "Good $depth";
+ eval {
+ &$pie($depth) = $value;
+ };
+ is($@, '', "recursive lvalue substr return depth $depth");
+ is($val, $value,
+ "value assigned to recursive lvalue substr (depth $depth)");
+ }
}
{ # bug #23790
@@ -544,6 +705,61 @@
sub changeme { $_[2] = "free" }
changeme(lval_array);
is("@arr", "one two free");
+
+ # test again, with explicit return
+ sub rlval_array() : lvalue {return @arr}
+ @arr = qw /one two three/;
+ $line = "zero";
+ for (rlval_array) {
+ $line .= $_;
+ }
+ is($line, "zeroonetwothree");
+ is(trythislval(rlval_array()), "3xonetwothree");
+ changeme(rlval_array);
+ is("@arr", "one two free");
+
+ # Variations on the same theme, with multiple vars returned
+ my $scalar = 'half';
+ sub lval_scalar_array () : lvalue { $scalar, @arr }
+ @arr = qw /one two three/;
+ $line = "zero";
+ for (lval_scalar_array) {
+ $line .= $_;
+ }
+ is($line, "zerohalfonetwothree");
+ is(trythislval(lval_scalar_array()), "4xhalfonetwothree");
+ changeme(lval_scalar_array);
+ is("@arr", "one free three");
+
+ sub lval_array_scalar () : lvalue { @arr, $scalar }
+ @arr = qw /one two three/;
+ $line = "zero";
+ $scalar = 'four';
+ for (lval_array_scalar) {
+ $line .= $_;
+ }
+ is($line, "zeroonetwothreefour");
+ is(trythislval(lval_array_scalar()), "4xonetwothreefour");
+ changeme(lval_array_scalar);
+ is("@arr", "one two free");
+
+ # Tests for specific ops not tested above
+ # rv2av
+ @array2 = qw 'one two free';
+ is join(',', map $_, sub:lvalue{@array2}->()), 'one,two,free',
+ 'rv2av in reference context';
+ is join(',', map $_, sub:lvalue{@{\@array2}}->()), 'one,two,free',
+ 'rv2av-with-ref in reference context';
+ # padhv
+ my %hash = qw[a b c d];
+ like join(',', map $_, sub:lvalue{%hash}->()),
+ qr/^(?:a,b,c,d|c,d,a,b)\z/, 'padhv in reference context';
+ # rv2hv
+ %hash2 = qw[a b c d];
+ like join(',', map $_, sub:lvalue{%hash2}->()),
+ qr/^(?:a,b,c,d|c,d,a,b)\z/, 'rv2hv in reference context';
+ like join(',', map $_, sub:lvalue{%{\%hash2}}->()),
+ qr/^(?:a,b,c,d|c,d,a,b)\z/, 'rv2hv-with-ref in reference context';
}
{
@@ -557,17 +773,22 @@
is ($result, 'bar', "RT #41550");
}
+SKIP: { skip 'no attributes.pm', 1 unless eval 'require attributes';
fresh_perl_is(<<'----', <<'====', "lvalue can not be set after definition. [perl #68758]");
use warnings;
our $x;
sub foo { $x }
sub foo : lvalue;
+sub MODIFY_CODE_ATTRIBUTES {}
+sub foo : lvalue : fr0g;
foo = 3;
----
lvalue attribute ignored after the subroutine has been defined at - line 4.
-Can't modify non-lvalue subroutine call in scalar assignment at - line 5, near "3;"
+lvalue attribute ignored after the subroutine has been defined at - line 6.
+Can't modify non-lvalue subroutine call in scalar assignment at - line 7, near "3;"
Execution of - aborted due to compilation errors.
====
+}
{
my $x;
@@ -577,24 +798,172 @@
is($x, 5, "subroutine declared with lvalue before definition retains lvalue. [perl #68758]");
}
+SKIP: { skip "no attributes.pm", 2 unless eval { require attributes };
+ sub utf8::valid :lvalue;
+ require attributes;
+ is "@{[ &attributes::get(\&utf8::valid) ]}", 'lvalue',
+ 'sub declaration with :lvalue applies it to XSUBs';
+
+ BEGIN { *wonky = \&marjibberous }
+ sub wonky :lvalue;
+ is "@{[ &attributes::get(\&wonky) ]}", 'lvalue',
+ 'sub declaration with :lvalue applies it to assigned stub';
+}
+
sub fleen : lvalue { $pnare }
$pnare = __PACKAGE__;
ok eval { fleen = 1 }, "lvalues can return COWs (CATTLE?) [perl #75656]";\
is $pnare, 1, 'and returning CATTLE actually works';
+$pnare = __PACKAGE__;
+ok eval { (fleen) = 1 }, "lvalues can return COWs in list context";
+is $pnare, 1, 'and returning COWs in list context actually works';
+$pnare = __PACKAGE__;
+ok eval { $_ = 1 for(fleen); 1 }, "lvalues can return COWs in ref cx";
+is $pnare, 1, 'and returning COWs in reference context actually works';
-{
- my $result_3363;
- sub a_3363 {
- my ($word, $replace) = @_;
- my $ref = \substr($word, 0, 1);
- $$ref = $replace;
- if ($replace eq "b") {
- $result_3363 = $word;
- } else {
- a_3363($word, "b");
- }
+
+# Returning an arbitrary expression, not necessarily lvalue
++sub :lvalue { return $ambaga || $ambaga }->() = 73;
+is $ambaga, 73, 'explicit return of arbitrary expression (scalar context)';
+(sub :lvalue { return $ambaga || $ambaga }->()) = 74;
+is $ambaga, 74, 'explicit return of arbitrary expression (list context)';
++sub :lvalue { $ambaga || $ambaga }->() = 73;
+is $ambaga, 73, 'implicit return of arbitrary expression (scalar context)';
+(sub :lvalue { $ambaga || $ambaga }->()) = 74;
+is $ambaga, 74, 'implicit return of arbitrary expression (list context)';
+eval { +sub :lvalue { return 3 }->() = 4 };
+like $@, qr/Can\'t return a readonly value from lvalue subroutine at/,
+ 'assignment to numeric constant explicitly returned from lv sub';
+eval { (sub :lvalue { return 3 }->()) = 4 };
+like $@, qr/Can\'t return a readonly value from lvalue subroutine at/,
+ 'assignment to num constant explicitly returned (list cx)';
+eval { +sub :lvalue { 3 }->() = 4 };
+like $@, qr/Can\'t return a readonly value from lvalue subroutine at/,
+ 'assignment to numeric constant implicitly returned from lv sub';
+eval { (sub :lvalue { 3 }->()) = 4 };
+like $@, qr/Can\'t return a readonly value from lvalue subroutine at/,
+ 'assignment to num constant implicitly returned (list cx)';
+
+# reference (potential lvalue) context
+$suffix = '';
+for my $sub (sub :lvalue {$_}, sub :lvalue {return $_}) {
+ &$sub()->${\sub { $_[0] = 37 }};
+ is $_, '37', 'lvalue->method'.$suffix;
+ ${\scalar &$sub()} = 38;
+ is $_, '38', 'scalar(lvalue)'.$suffix;
+ sub assign39_with_proto ($) { $_[0] = 39 }
+ assign39_with_proto(&$sub());
+ is $_, '39', 'func(lvalue) when func has $ proto'.$suffix;
+ $_ = 1;
+ ${\(&$sub()||undef)} = 40;
+ is $_, '40', 'lvalue||...'.$suffix;
+ ${\(${\undef}||&$sub())} = 41; # extra ${\...} to bypass const folding
+ is $_, '41', '...||lvalue'.$suffix;
+ $_ = 0;
+ ${\(&$sub()&&undef)} = 42;
+ is $_, '42', 'lvalue&&...'.$suffix;
+ ${\(${\1}&&&$sub())} = 43;
+ is $_, '43', '...&&lvalue'.$suffix;
+ ${\(&$sub())[0]} = 44;
+ is $_, '44', '(lvalue)[0]'.$suffix;
+}
+continue { $suffix = ' (explicit return)' }
+
+# autovivification
+$suffix = '';
+for my $sub (sub :lvalue {$_}, sub :lvalue {return $_}) {
+ undef $_;
+ &$sub()->[3] = 4;
+ is $_->[3], 4, 'func->[...] autovivification'.$suffix;
+ undef $_;
+ &$sub()->{3} = 4;
+ is $_->{3}, 4, 'func->{...} autovivification'.$suffix;
+ undef $_;
+ ${&$sub()} = 4;
+ is $$_, 4, '${func()} autovivification' .$suffix;
+ undef $_;
+ @{&$sub()} = 4;
+ is "@$_", 4, '@{func()} autovivification' .$suffix;
+ undef $_;
+ %{&$sub()} = (4,5);
+ is join('-',%$_), '4-5', '%{func()} autovivification'.$suffix;
+ undef $_;
+ ${ (), &$sub()} = 4;
+ is $$_, 4, '${ (), func()} autovivification' .$suffix;
+}
+continue { $suffix = ' (explicit return)' }
+
+# [perl #92406] [perl #92290] Returning a pad var in rvalue context
+$suffix = '';
+for my $sub (
+ sub :lvalue { my $x = 72; $x },
+ sub :lvalue { my $x = 72; return $x }
+) {
+ is scalar(&$sub), 72, "sub returning pad var in scalar context$suffix";
+ is +(&$sub)[0], 72, "sub returning pad var in list context$suffix";
+}
+continue { $suffix = ' (explicit return)' }
+
+# Returning read-only values in reference context
+$suffix = '';
+for (
+ sub :lvalue { $] }->(),
+ sub :lvalue { return $] }->()
+) {
+ is \$_, \$], 'read-only values are returned in reference context'
+ .$suffix # (they used to be copied)
+}
+continue { $suffix = ' (explicit return)' }
+
+# Returning unwritables from nested lvalue sub call in in rvalue context
+# First, ensure we are testing what we think we are:
+if (!Internals::SvREADONLY($])) { Internals::SvREADONLY($],1); }
+sub squibble : lvalue { return $] }
+sub squebble : lvalue { squibble }
+sub squabble : lvalue { return squibble }
+is $x = squebble, $], 'returning ro from nested lv sub call in rv cx';
+is $x = squabble, $], 'explct. returning ro from nested lv sub in rv cx';
+is \squebble, \$], 'returning ro from nested lv sub call in ref cx';
+is \squabble, \$], 'explct. returning ro from nested lv sub in ref cx';
+
+# [perl #102486] Sub calls as the last statement of an lvalue sub
+package _102486 {
+ my $called;
+ my $x = 'nonlv';
+ sub strictlv :lvalue { use strict 'refs'; &$x }
+ sub lv :lvalue { &$x }
+ sub nonlv { ++$called }
+ eval { strictlv };
+ ::like $@, qr/^Can't use string \("nonlv"\) as a subroutine ref while/,
+ 'strict mode applies to sub:lvalue{ &$string }';
+ $called = 0;
+ ::ok eval { lv },
+ 'sub:lvalue{&$x}->() does not die for non-lvalue inner sub call';
+ ::is $called, 1, 'The &$x actually called the sub';
+ eval { +sub :lvalue { &$x }->() = 3 };
+ ::like $@, qr/^Can't modify non-lvalue subroutine call at /,
+ 'sub:lvalue{&$x}->() dies in true lvalue context';
+}
+
+# TARG should be copied in rvalue context
+sub ucf :lvalue { ucfirst $_[0] }
+is ucf("just another ") . ucf("perl hacker,\n"),
+ "Just another Perl hacker,\n", 'TARG is copied in rvalue scalar cx';
+is join('',ucf("just another "), ucf "perl hacker,\n"),
+ "Just another Perl hacker,\n", 'TARG is copied in rvalue list cx';
+sub ucfr : lvalue {
+ @_ ? ucfirst $_[0] : do {
+ is ucfr("just another ") . ucfr("perl hacker,\n"),
+ "Just another Perl hacker,\n",
+ 'TARG is copied in recursive rvalue scalar cx';
+ is join('',ucfr("just another "), ucfr("perl hacker,\n")),
+ "Just another Perl hacker,\n",
+ 'TARG is copied in recursive rvalue list cx';
}
- a_3363($_, "v") for "test";
+}
+ucfr();
- is($result_3363, "best", "ref-to-substr retains lvalue-ness under recursion [perl #3363]");
-}
+# [perl #117947] XSUBs should not be treated as lvalues at run time
+eval { &{\&utf8::is_utf8}("") = 3 };
+like $@, qr/^Can't modify non-lvalue subroutine call at /,
+ 'XSUB not seen at compile time dies in lvalue context';
Property changes on: trunk/contrib/perl/t/op/sub_lval.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/t/op/subst.t (from rev 6437, vendor/perl/5.18.1/t/op/subst.t)
===================================================================
--- trunk/contrib/perl/t/op/subst.t (rev 0)
+++ trunk/contrib/perl/t/op/subst.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,593 @@
+#!./perl -w
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+}
+
+require './test.pl';
+plan( tests => 139 );
+
+$x = 'foo';
+$_ = "x";
+s/x/\$x/;
+ok( $_ eq '$x', ":$_: eq :\$x:" );
+
+$_ = "x";
+s/x/$x/;
+ok( $_ eq 'foo', ":$_: eq :foo:" );
+
+$_ = "x";
+s/x/\$x $x/;
+ok( $_ eq '$x foo', ":$_: eq :\$x foo:" );
+
+$b = 'cd';
+($a = 'abcdef') =~ s<(b${b}e)>'\n$1';
+ok( $1 eq 'bcde' && $a eq 'a\n$1f', ":$1: eq :bcde: ; :$a: eq :a\\n\$1f:" );
+
+$a = 'abacada';
+ok( ($a =~ s/a/x/g) == 4 && $a eq 'xbxcxdx' );
+
+ok( ($a =~ s/a/y/g) == 0 && $a eq 'xbxcxdx' );
+
+ok( ($a =~ s/b/y/g) == 1 && $a eq 'xyxcxdx' );
+
+$_ = 'ABACADA';
+ok( /a/i && s///gi && $_ eq 'BCD' );
+
+$_ = '\\' x 4;
+ok( length($_) == 4 );
+$snum = s/\\/\\\\/g;
+ok( $_ eq '\\' x 8 && $snum == 4 );
+
+$_ = '\/' x 4;
+ok( length($_) == 8 );
+$snum = s/\//\/\//g;
+ok( $_ eq '\\//' x 4 && $snum == 4 );
+ok( length($_) == 12 );
+
+$_ = 'aaaXXXXbbb';
+s/^a//;
+ok( $_ eq 'aaXXXXbbb' );
+
+$_ = 'aaaXXXXbbb';
+s/a//;
+ok( $_ eq 'aaXXXXbbb' );
+
+$_ = 'aaaXXXXbbb';
+s/^a/b/;
+ok( $_ eq 'baaXXXXbbb' );
+
+$_ = 'aaaXXXXbbb';
+s/a/b/;
+ok( $_ eq 'baaXXXXbbb' );
+
+$_ = 'aaaXXXXbbb';
+s/aa//;
+ok( $_ eq 'aXXXXbbb' );
+
+$_ = 'aaaXXXXbbb';
+s/aa/b/;
+ok( $_ eq 'baXXXXbbb' );
+
+$_ = 'aaaXXXXbbb';
+s/b$//;
+ok( $_ eq 'aaaXXXXbb' );
+
+$_ = 'aaaXXXXbbb';
+s/b//;
+ok( $_ eq 'aaaXXXXbb' );
+
+$_ = 'aaaXXXXbbb';
+s/bb//;
+ok( $_ eq 'aaaXXXXb' );
+
+$_ = 'aaaXXXXbbb';
+s/aX/y/;
+ok( $_ eq 'aayXXXbbb' );
+
+$_ = 'aaaXXXXbbb';
+s/Xb/z/;
+ok( $_ eq 'aaaXXXzbb' );
+
+$_ = 'aaaXXXXbbb';
+s/aaX.*Xbb//;
+ok( $_ eq 'ab' );
+
+$_ = 'aaaXXXXbbb';
+s/bb/x/;
+ok( $_ eq 'aaaXXXXxb' );
+
+# now for some unoptimized versions of the same.
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/^a//;
+ok( $_ eq 'aaXXXXbbb' );
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/a//;
+ok( $_ eq 'aaXXXXbbb' );
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/^a/b/;
+ok( $_ eq 'baaXXXXbbb' );
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/a/b/;
+ok( $_ eq 'baaXXXXbbb' );
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/aa//;
+ok( $_ eq 'aXXXXbbb' );
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/aa/b/;
+ok( $_ eq 'baXXXXbbb' );
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/b$//;
+ok( $_ eq 'aaaXXXXbb' );
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/b//;
+ok( $_ eq 'aaaXXXXbb' );
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/bb//;
+ok( $_ eq 'aaaXXXXb' );
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/aX/y/;
+ok( $_ eq 'aayXXXbbb' );
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/Xb/z/;
+ok( $_ eq 'aaaXXXzbb' );
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/aaX.*Xbb//;
+ok( $_ eq 'ab' );
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/bb/x/;
+ok( $_ eq 'aaaXXXXxb' );
+
+$_ = 'abc123xyz';
+s/(\d+)/$1*2/e; # yields 'abc246xyz'
+ok( $_ eq 'abc246xyz' );
+s/(\d+)/sprintf("%5d",$1)/e; # yields 'abc 246xyz'
+ok( $_ eq 'abc 246xyz' );
+s/(\w)/$1 x 2/eg; # yields 'aabbcc 224466xxyyzz'
+ok( $_ eq 'aabbcc 224466xxyyzz' );
+
+$_ = "aaaaa";
+ok( y/a/b/ == 5 );
+ok( y/a/b/ == 0 );
+ok( y/b// == 5 );
+ok( y/b/c/s == 5 );
+ok( y/c// == 1 );
+ok( y/c//d == 1 );
+ok( $_ eq "" );
+
+$_ = "Now is the %#*! time for all good men...";
+ok( ($x=(y/a-zA-Z //cd)) == 7 );
+ok( y/ / /s == 8 );
+
+$_ = 'abcdefghijklmnopqrstuvwxyz0123456789';
+tr/a-z/A-Z/;
+
+ok( $_ eq 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789' );
+
+# same as tr/A-Z/a-z/;
+if (defined $Config{ebcdic} && $Config{ebcdic} eq 'define') { # EBCDIC.
+ no utf8;
+ y[\301-\351][\201-\251];
+} else { # Ye Olde ASCII. Or something like it.
+ y[\101-\132][\141-\172];
+}
+
+ok( $_ eq 'abcdefghijklmnopqrstuvwxyz0123456789' );
+
+SKIP: {
+ skip("not ASCII",1) unless (ord("+") == ord(",") - 1
+ && ord(",") == ord("-") - 1
+ && ord("a") == ord("b") - 1
+ && ord("b") == ord("c") - 1);
+ $_ = '+,-';
+ tr/+--/a-c/;
+ ok( $_ eq 'abc' );
+}
+
+$_ = '+,-';
+tr/+\--/a\/c/;
+ok( $_ eq 'a,/' );
+
+$_ = '+,-';
+tr/-+,/ab\-/;
+ok( $_ eq 'b-a' );
+
+
+# test recursive substitutions
+# code based on the recursive expansion of makefile variables
+
+my %MK = (
+ AAAAA => '$(B)', B=>'$(C)', C => 'D', # long->short
+ E => '$(F)', F=>'p $(G) q', G => 'HHHHH', # short->long
+ DIR => '$(UNDEFINEDNAME)/xxx',
+);
+sub var {
+ my($var,$level) = @_;
+ return "\$($var)" unless exists $MK{$var};
+ return exp_vars($MK{$var}, $level+1); # can recurse
+}
+sub exp_vars {
+ my($str,$level) = @_;
+ $str =~ s/\$\((\w+)\)/var($1, $level+1)/ge; # can recurse
+ #warn "exp_vars $level = '$str'\n";
+ $str;
+}
+
+ok( exp_vars('$(AAAAA)',0) eq 'D' );
+ok( exp_vars('$(E)',0) eq 'p HHHHH q' );
+ok( exp_vars('$(DIR)',0) eq '$(UNDEFINEDNAME)/xxx' );
+ok( exp_vars('foo $(DIR)/yyy bar',0) eq 'foo $(UNDEFINEDNAME)/xxx/yyy bar' );
+
+$_ = "abcd";
+s/(..)/$x = $1, m#.#/eg;
+ok( $x eq "cd", 'a match nested in the RHS of a substitution' );
+
+# Subst and lookbehind
+
+$_="ccccc";
+$snum = s/(?<!x)c/x/g;
+ok( $_ eq "xxxxx" && $snum == 5 );
+
+$_="ccccc";
+$snum = s/(?<!x)(c)/x/g;
+ok( $_ eq "xxxxx" && $snum == 5 );
+
+$_="foobbarfoobbar";
+$snum = s/(?<!r)foobbar/foobar/g;
+ok( $_ eq "foobarfoobbar" && $snum == 1 );
+
+$_="foobbarfoobbar";
+$snum = s/(?<!ar)(foobbar)/foobar/g;
+ok( $_ eq "foobarfoobbar" && $snum == 1 );
+
+$_="foobbarfoobbar";
+$snum = s/(?<!ar)foobbar/foobar/g;
+ok( $_ eq "foobarfoobbar" && $snum == 1 );
+
+eval 's{foo} # this is a comment, not a delimiter
+ {bar};';
+ok( ! @?, 'parsing of split subst with comment' );
+
+$_="baacbaa";
+$snum = tr/a/b/s;
+ok( $_ eq "bbcbb" && $snum == 4,
+ 'check if squashing works at the end of string' );
+
+$_ = "ab";
+ok( s/a/b/ == 1 );
+
+$_ = <<'EOL';
+ $url = new URI::URL "http://www/"; die if $url eq "xXx";
+EOL
+$^R = 'junk';
+
+$foo = ' $@%#lowercase $@%# lowercase UPPERCASE$@%#UPPERCASE' .
+ ' $@%#lowercase$@%#lowercase$@%# lowercase lowercase $@%#lowercase' .
+ ' lowercase $@%#MiXeD$@%# ';
+
+$snum =
+s{ \d+ \b [,.;]? (?{ 'digits' })
+ |
+ [a-z]+ \b [,.;]? (?{ 'lowercase' })
+ |
+ [A-Z]+ \b [,.;]? (?{ 'UPPERCASE' })
+ |
+ [A-Z] [a-z]+ \b [,.;]? (?{ 'Capitalized' })
+ |
+ [A-Za-z]+ \b [,.;]? (?{ 'MiXeD' })
+ |
+ [A-Za-z0-9]+ \b [,.;]? (?{ 'alphanumeric' })
+ |
+ \s+ (?{ ' ' })
+ |
+ [^A-Za-z0-9\s]+ (?{ '$@%#' })
+}{$^R}xg;
+ok( $_ eq $foo );
+ok( $snum == 31 );
+
+$_ = 'a' x 6;
+$snum = s/a(?{})//g;
+ok( $_ eq '' && $snum == 6 );
+
+$_ = 'x' x 20;
+$snum = s/(\d*|x)/<$1>/g;
+$foo = '<>' . ('<x><>' x 20) ;
+ok( $_ eq $foo && $snum == 41 );
+
+$t = 'aaaaaaaaa';
+
+$_ = $t;
+pos = 6;
+$snum = s/\Ga/xx/g;
+ok( $_ eq 'aaaaaaxxxxxx' && $snum == 3 );
+
+$_ = $t;
+pos = 6;
+$snum = s/\Ga/x/g;
+ok( $_ eq 'aaaaaaxxx' && $snum == 3 );
+
+$_ = $t;
+pos = 6;
+s/\Ga/xx/;
+ok( $_ eq 'aaaaaaxxaa' );
+
+$_ = $t;
+pos = 6;
+s/\Ga/x/;
+ok( $_ eq 'aaaaaaxaa' );
+
+$_ = $t;
+$snum = s/\Ga/xx/g;
+ok( $_ eq 'xxxxxxxxxxxxxxxxxx' && $snum == 9 );
+
+$_ = $t;
+$snum = s/\Ga/x/g;
+ok( $_ eq 'xxxxxxxxx' && $snum == 9 );
+
+$_ = $t;
+s/\Ga/xx/;
+ok( $_ eq 'xxaaaaaaaa' );
+
+$_ = $t;
+s/\Ga/x/;
+ok( $_ eq 'xaaaaaaaa' );
+
+$_ = 'aaaa';
+$snum = s/\ba/./g;
+ok( $_ eq '.aaa' && $snum == 1 );
+
+eval q% s/a/"b"}/e %;
+ok( $@ =~ /Bad evalled substitution/ );
+eval q% ($_ = "x") =~ s/(.)/"$1 "/e %;
+ok( $_ eq "x " and !length $@ );
+$x = $x = 'interp';
+eval q% ($_ = "x") =~ s/x(($x)*)/"$1"/e %;
+ok( $_ eq '' and !length $@ );
+
+$_ = "C:/";
+ok( !s/^([a-z]:)/\u$1/ );
+
+$_ = "Charles Bronson";
+$snum = s/\B\w//g;
+ok( $_ eq "C B" && $snum == 12 );
+
+{
+ use utf8;
+ my $s = "H\303\266he";
+ my $l = my $r = $s;
+ $l =~ s/[^\w]//g;
+ $r =~ s/[^\w\.]//g;
+ is($l, $r, "use utf8 \\w");
+}
+
+my $pv1 = my $pv2 = "Andreas J. K\303\266nig";
+$pv1 =~ s/A/\x{100}/;
+substr($pv2,0,1) = "\x{100}";
+is($pv1, $pv2);
+
+SKIP: {
+ skip("EBCDIC", 3) if ord("A") == 193;
+
+ {
+ # Gregor Chrupala <gregor.chrupala at star-group.net>
+ use utf8;
+ $a = 'España';
+ $a =~ s/ñ/ñ/;
+ like($a, qr/ñ/, "use utf8 RHS");
+ }
+
+ {
+ use utf8;
+ $a = 'España España';
+ $a =~ s/ñ/ñ/;
+ like($a, qr/ñ/, "use utf8 LHS");
+ }
+
+ {
+ use utf8;
+ $a = 'España';
+ $a =~ s/ñ/ñ/;
+ like($a, qr/ñ/, "use utf8 LHS and RHS");
+ }
+}
+
+{
+ # SADAHIRO Tomoyuki <bqw10602 at nifty.com>
+
+ $a = "\x{100}\x{101}";
+ $a =~ s/\x{101}/\xFF/;
+ like($a, qr/\xFF/);
+ is(length($a), 2, "SADAHIRO utf8 s///");
+
+ $a = "\x{100}\x{101}";
+ $a =~ s/\x{101}/"\xFF"/e;
+ like($a, qr/\xFF/);
+ is(length($a), 2);
+
+ $a = "\x{100}\x{101}";
+ $a =~ s/\x{101}/\xFF\xFF\xFF/;
+ like($a, qr/\xFF\xFF\xFF/);
+ is(length($a), 4);
+
+ $a = "\x{100}\x{101}";
+ $a =~ s/\x{101}/"\xFF\xFF\xFF"/e;
+ like($a, qr/\xFF\xFF\xFF/);
+ is(length($a), 4);
+
+ $a = "\xFF\x{101}";
+ $a =~ s/\xFF/\x{100}/;
+ like($a, qr/\x{100}/);
+ is(length($a), 2);
+
+ $a = "\xFF\x{101}";
+ $a =~ s/\xFF/"\x{100}"/e;
+ like($a, qr/\x{100}/);
+ is(length($a), 2);
+
+ $a = "\xFF";
+ $a =~ s/\xFF/\x{100}/;
+ like($a, qr/\x{100}/);
+ is(length($a), 1);
+
+ $a = "\xFF";
+ $a =~ s/\xFF/"\x{100}"/e;
+ like($a, qr/\x{100}/);
+ is(length($a), 1);
+}
+
+{
+ # subst with mixed utf8/non-utf8 type
+ my($ua, $ub, $uc, $ud) = ("\x{101}", "\x{102}", "\x{103}", "\x{104}");
+ my($na, $nb) = ("\x{ff}", "\x{fe}");
+ my $a = "$ua--$ub";
+ my $b;
+ ($b = $a) =~ s/--/$na/;
+ is($b, "$ua$na$ub", "s///: replace non-utf8 into utf8");
+ ($b = $a) =~ s/--/--$na--/;
+ is($b, "$ua--$na--$ub", "s///: replace long non-utf8 into utf8");
+ ($b = $a) =~ s/--/$uc/;
+ is($b, "$ua$uc$ub", "s///: replace utf8 into utf8");
+ ($b = $a) =~ s/--/--$uc--/;
+ is($b, "$ua--$uc--$ub", "s///: replace long utf8 into utf8");
+ $a = "$na--$nb";
+ ($b = $a) =~ s/--/$ua/;
+ is($b, "$na$ua$nb", "s///: replace utf8 into non-utf8");
+ ($b = $a) =~ s/--/--$ua--/;
+ is($b, "$na--$ua--$nb", "s///: replace long utf8 into non-utf8");
+
+ # now with utf8 pattern
+ $a = "$ua--$ub";
+ ($b = $a) =~ s/-($ud)?-/$na/;
+ is($b, "$ua$na$ub", "s///: replace non-utf8 into utf8 (utf8 pattern)");
+ ($b = $a) =~ s/-($ud)?-/--$na--/;
+ is($b, "$ua--$na--$ub", "s///: replace long non-utf8 into utf8 (utf8 pattern)");
+ ($b = $a) =~ s/-($ud)?-/$uc/;
+ is($b, "$ua$uc$ub", "s///: replace utf8 into utf8 (utf8 pattern)");
+ ($b = $a) =~ s/-($ud)?-/--$uc--/;
+ is($b, "$ua--$uc--$ub", "s///: replace long utf8 into utf8 (utf8 pattern)");
+ $a = "$na--$nb";
+ ($b = $a) =~ s/-($ud)?-/$ua/;
+ is($b, "$na$ua$nb", "s///: replace utf8 into non-utf8 (utf8 pattern)");
+ ($b = $a) =~ s/-($ud)?-/--$ua--/;
+ is($b, "$na--$ua--$nb", "s///: replace long utf8 into non-utf8 (utf8 pattern)");
+ ($b = $a) =~ s/-($ud)?-/$na/;
+ is($b, "$na$na$nb", "s///: replace non-utf8 into non-utf8 (utf8 pattern)");
+ ($b = $a) =~ s/-($ud)?-/--$na--/;
+ is($b, "$na--$na--$nb", "s///: replace long non-utf8 into non-utf8 (utf8 pattern)");
+}
+
+$_ = 'aaaa';
+$r = 'x';
+$s = s/a(?{})/$r/g;
+is("<$_> <$s>", "<xxxx> <4>", "[perl #7806]");
+
+$_ = 'aaaa';
+$s = s/a(?{})//g;
+is("<$_> <$s>", "<> <4>", "[perl #7806]");
+
+# [perl #19048] Coredump in silly replacement
+{
+ local $^W = 0;
+ $_="abcdef\n";
+ s!.!!eg;
+ is($_, "\n", "[perl #19048]");
+}
+
+# [perl #17757] interaction between saw_ampersand and study
+{
+ my $f = eval q{ $& };
+ $f = "xx";
+ study $f;
+ $f =~ s/x/y/g;
+ is($f, "yy", "[perl #17757]");
+}
+
+# [perl #20684] returned a zero count
+$_ = "1111";
+is(s/(??{1})/2/eg, 4, '#20684 s/// with (??{..}) inside');
+
+# [perl #20682] @- not visible in replacement
+$_ = "123";
+/(2)/; # seed @- with something else
+s/(1)(2)(3)/$#- (@-)/;
+is($_, "3 (0 0 1 2)", '#20682 @- not visible in replacement');
+
+# [perl #20682] $^N not visible in replacement
+$_ = "abc";
+/(a)/; s/(b)|(c)/-$^N/g;
+is($_,'a-b-c','#20682 $^N not visible in replacement');
+
+# [perl #22351] perl bug with 'e' substitution modifier
+my $name = "chris";
+{
+ no warnings 'uninitialized';
+ $name =~ s/hr//e;
+}
+is($name, "cis", q[#22351 bug with 'e' substitution modifier]);
+
+
+# [perl #34171] $1 didn't honour 'use bytes' in s//e
+{
+ my $s="\x{100}";
+ my $x;
+ {
+ use bytes;
+ $s=~ s/(..)/$x=$1/e
+ }
+ is(length($x), 2, '[perl #34171]');
+}
+
+
+{ # [perl #27940] perlbug: [\x00-\x1f] works, [\c at -\c_] does not
+ my $c;
+
+ ($c = "\x20\c@\x30\cA\x40\cZ\x50\c_\x60") =~ s/[\c at -\c_]//g;
+ is($c, "\x20\x30\x40\x50\x60", "s/[\\c\@-\\c_]//g");
+
+ ($c = "\x20\x00\x30\x01\x40\x1A\x50\x1F\x60") =~ s/[\x00-\x1f]//g;
+ is($c, "\x20\x30\x40\x50\x60", "s/[\\x00-\\x1f]//g");
+}
+{
+ $_ = "xy";
+ no warnings 'uninitialized';
+ /(((((((((x)))))))))(z)/; # clear $10
+ s/(((((((((x)))))))))(y)/${10}/;
+ is($_,"y","RT#6006: \$_ eq '$_'");
+ $_ = "xr";
+ s/(((((((((x)))))))))(r)/fooba${10}/;
+ is($_,"foobar","RT#6006: \$_ eq '$_'");
+}
+{
+ my $want=("\n" x 11).("B\n" x 11)."B";
+ $_="B";
+ our $i;
+ for $i(1..11){
+ s/^.*$/$&/gm;
+ $_="\n$_\n$&";
+ }
+ is($want,$_,"RT#17542");
+}
+
+{
+ my @tests = ('ABC', "\xA3\xA4\xA5", "\x{410}\x{411}\x{412}");
+ foreach (@tests) {
+ my $id = ord $_;
+ s/./pos/ge;
+ is($_, "012", "RT#52104: $id");
+ }
+}
Copied: trunk/contrib/perl/t/op/substT.t (from rev 6437, vendor/perl/5.18.1/t/op/substT.t)
===================================================================
--- trunk/contrib/perl/t/op/substT.t (rev 0)
+++ trunk/contrib/perl/t/op/substT.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,9 @@
+#!perl -wT
+
+for $file ('op/subst.t', 't/op/subst.t', ':op:subst.t') {
+ if (-r $file) {
+ do ($^O eq 'MacOS' ? $file : "./$file");
+ exit;
+ }
+}
+die "Cannot find op/subst.t or t/op/subst.t\n";
Copied: trunk/contrib/perl/t/op/subst_amp.t (from rev 6437, vendor/perl/5.18.1/t/op/subst_amp.t)
===================================================================
--- trunk/contrib/perl/t/op/subst_amp.t (rev 0)
+++ trunk/contrib/perl/t/op/subst_amp.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,104 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+}
+
+print "1..13\n";
+
+$_ = 'x' x 20;
+s/\d*|x/<$&>/g;
+$foo = '<>' . ('<x><>' x 20) ;
+print ($_ eq $foo ? "ok 1\n" : "not ok 1\n#'$_'\n#'$foo'\n");
+
+$t = 'aaa';
+
+$_ = $t;
+ at res = ();
+pos = 1;
+s/\Ga(?{push @res, $_, $`})/xx/g;
+print "not " unless "$_ @res" eq 'axxxx aaa a aaa aa';
+print "ok 2\n";
+
+$_ = $t;
+ at res = ();
+pos = 1;
+s/\Ga(?{push @res, $_, $`})/x/g;
+print "not " unless "$_ @res" eq 'axx aaa a aaa aa';
+print "ok 3\n";
+
+$_ = $t;
+ at res = ();
+pos = 1;
+s/\Ga(?{push @res, $_, $`})/xx/;
+print "not " unless "$_ @res" eq 'axxa aaa a';
+print "ok 4\n";
+
+$_ = $t;
+ at res = ();
+pos = 1;
+s/\Ga(?{push @res, $_, $`})/x/;
+print "not " unless "$_ @res" eq 'axa aaa a';
+print "ok 5\n";
+
+$a = $t;
+ at res = ();
+pos ($a) = 1;
+$a =~ s/\Ga(?{push @res, $_, $`})/xx/g;
+print "#'$a' '@res'\nnot " unless "$a @res" eq 'axxxx aaa a aaa aa';
+print "ok 6\n";
+
+$a = $t;
+ at res = ();
+pos ($a) = 1;
+$a =~ s/\Ga(?{push @res, $_, $`})/x/g;
+print "#'$a' '@res'\nnot " unless "$a @res" eq 'axx aaa a aaa aa';
+print "ok 7\n";
+
+$a = $t;
+ at res = ();
+pos ($a) = 1;
+$a =~ s/\Ga(?{push @res, $_, $`})/xx/;
+print "#'$a' '@res'\nnot " unless "$a @res" eq 'axxa aaa a';
+print "ok 8\n";
+
+$a = $t;
+ at res = ();
+pos ($a) = 1;
+$a =~ s/\Ga(?{push @res, $_, $`})/x/;
+print "#'$a' '@res'\nnot " unless "$a @res" eq 'axa aaa a';
+print "ok 9\n";
+
+sub x2 {'xx'}
+sub x1 {'x'}
+
+$a = $t;
+ at res = ();
+pos ($a) = 1;
+$a =~ s/\Ga(?{push @res, $_, $`})/x2/ge;
+print "#'$a' '@res'\nnot " unless "$a @res" eq 'axxxx aaa a aaa aa';
+print "ok 10\n";
+
+$a = $t;
+ at res = ();
+pos ($a) = 1;
+$a =~ s/\Ga(?{push @res, $_, $`})/x1/ge;
+print "#'$a' '@res'\nnot " unless "$a @res" eq 'axx aaa a aaa aa';
+print "ok 11\n";
+
+$a = $t;
+ at res = ();
+pos ($a) = 1;
+$a =~ s/\Ga(?{push @res, $_, $`})/x2/e;
+print "#'$a' '@res'\nnot " unless "$a @res" eq 'axxa aaa a';
+print "ok 12\n";
+
+$a = $t;
+ at res = ();
+pos ($a) = 1;
+$a =~ s/\Ga(?{push @res, $_, $`})/x1/e;
+print "#'$a' '@res'\nnot " unless "$a @res" eq 'axa aaa a';
+print "ok 13\n";
+
Copied: trunk/contrib/perl/t/op/subst_wamp.t (from rev 6437, vendor/perl/5.18.1/t/op/subst_wamp.t)
===================================================================
--- trunk/contrib/perl/t/op/subst_wamp.t (rev 0)
+++ trunk/contrib/perl/t/op/subst_wamp.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,11 @@
+#!./perl
+
+$dummy = defined $&; # Now we have it...
+for $file ('op/subst.t', 't/op/subst.t', ':op:subst.t') {
+ if (-r $file) {
+ do ($^O eq 'MacOS' ? $file : "./$file");
+ exit;
+ }
+}
+die "Cannot find op/subst.t or t/op/subst.t\n";
+
Copied: trunk/contrib/perl/t/op/substr.t (from rev 6437, vendor/perl/5.18.1/t/op/substr.t)
===================================================================
--- trunk/contrib/perl/t/op/substr.t (rev 0)
+++ trunk/contrib/perl/t/op/substr.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,864 @@
+#!./perl
+
+#P = start of string Q = start of substr R = end of substr S = end of string
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+use warnings ;
+
+$a = 'abcdefxyz';
+$SIG{__WARN__} = sub {
+ if ($_[0] =~ /^substr outside of string/) {
+ $w++;
+ } elsif ($_[0] =~ /^Attempt to use reference as lvalue in substr/) {
+ $w += 2;
+ } elsif ($_[0] =~ /^Use of uninitialized value/) {
+ $w += 3;
+ } else {
+ warn $_[0];
+ }
+};
+
+BEGIN { require './test.pl'; }
+
+plan(387);
+
+run_tests() unless caller;
+
+my $krunch = "a";
+
+sub run_tests {
+
+$FATAL_MSG = qr/^substr outside of string/;
+
+is(substr($a,0,3), 'abc'); # P=Q R S
+is(substr($a,3,3), 'def'); # P Q R S
+is(substr($a,6,999), 'xyz'); # P Q S R
+$b = substr($a,999,999) ; # warn # P R Q S
+is ($w--, 1);
+eval{substr($a,999,999) = "" ; };# P R Q S
+like ($@, $FATAL_MSG);
+is(substr($a,0,-6), 'abc'); # P=Q R S
+is(substr($a,-3,1), 'x'); # P Q R S
+sub{$b = shift}->(substr($a,999,999));
+is ($w--, 1, 'boundless lvalue substr only warns on fetch');
+
+substr($a,3,3) = 'XYZ';
+is($a, 'abcXYZxyz' );
+substr($a,0,2) = '';
+is($a, 'cXYZxyz' );
+substr($a,0,0) = 'ab';
+is($a, 'abcXYZxyz' );
+substr($a,0,0) = '12345678';
+is($a, '12345678abcXYZxyz' );
+substr($a,-3,3) = 'def';
+is($a, '12345678abcXYZdef');
+substr($a,-3,3) = '<';
+is($a, '12345678abcXYZ<' );
+substr($a,-1,1) = '12345678';
+is($a, '12345678abcXYZ12345678' );
+
+$a = 'abcdefxyz';
+
+is(substr($a,6), 'xyz' ); # P Q R=S
+is(substr($a,-3), 'xyz' ); # P Q R=S
+$b = substr($a,999,999) ; # warning # P R=S Q
+is($w--, 1);
+eval{substr($a,999,999) = "" ; } ; # P R=S Q
+like($@, $FATAL_MSG);
+is(substr($a,0), 'abcdefxyz'); # P=Q R=S
+is(substr($a,9), ''); # P Q=R=S
+is(substr($a,-11), 'abcdefxyz'); # Q P R=S
+is(substr($a,-9), 'abcdefxyz'); # P=Q R=S
+
+$a = '54321';
+
+$b = substr($a,-7, 1) ; # warn # Q R P S
+is($w--, 1);
+eval{substr($a,-7, 1) = "" ; }; # Q R P S
+like($@, $FATAL_MSG);
+$b = substr($a,-7,-6) ; # warn # Q R P S
+is($w--, 1);
+eval{substr($a,-7,-6) = "" ; }; # Q R P S
+like($@, $FATAL_MSG);
+is(substr($a,-5,-7), ''); # R P=Q S
+is(substr($a, 2,-7), ''); # R P Q S
+is(substr($a,-3,-7), ''); # R P Q S
+is(substr($a, 2,-5), ''); # P=R Q S
+is(substr($a,-3,-5), ''); # P=R Q S
+is(substr($a, 2,-4), ''); # P R Q S
+is(substr($a,-3,-4), ''); # P R Q S
+is(substr($a, 5,-6), ''); # R P Q=S
+is(substr($a, 5,-5), ''); # P=R Q S
+is(substr($a, 5,-3), ''); # P R Q=S
+$b = substr($a, 7,-7) ; # warn # R P S Q
+is($w--, 1);
+eval{substr($a, 7,-7) = "" ; }; # R P S Q
+like($@, $FATAL_MSG);
+$b = substr($a, 7,-5) ; # warn # P=R S Q
+is($w--, 1);
+eval{substr($a, 7,-5) = "" ; }; # P=R S Q
+like($@, $FATAL_MSG);
+$b = substr($a, 7,-3) ; # warn # P Q S Q
+is($w--, 1);
+eval{substr($a, 7,-3) = "" ; }; # P Q S Q
+like($@, $FATAL_MSG);
+$b = substr($a, 7, 0) ; # warn # P S Q=R
+is($w--, 1);
+eval{substr($a, 7, 0) = "" ; }; # P S Q=R
+like($@, $FATAL_MSG);
+
+is(substr($a,-7,2), ''); # Q P=R S
+is(substr($a,-7,4), '54'); # Q P R S
+is(substr($a,-7,7), '54321');# Q P R=S
+is(substr($a,-7,9), '54321');# Q P S R
+is(substr($a,-5,0), ''); # P=Q=R S
+is(substr($a,-5,3), '543');# P=Q R S
+is(substr($a,-5,5), '54321');# P=Q R=S
+is(substr($a,-5,7), '54321');# P=Q S R
+is(substr($a,-3,0), ''); # P Q=R S
+is(substr($a,-3,3), '321');# P Q R=S
+is(substr($a,-2,3), '21'); # P Q S R
+is(substr($a,0,-5), ''); # P=Q=R S
+is(substr($a,2,-3), ''); # P Q=R S
+is(substr($a,0,0), ''); # P=Q=R S
+is(substr($a,0,5), '54321');# P=Q R=S
+is(substr($a,0,7), '54321');# P=Q S R
+is(substr($a,2,0), ''); # P Q=R S
+is(substr($a,2,3), '321'); # P Q R=S
+is(substr($a,5,0), ''); # P Q=R=S
+is(substr($a,5,2), ''); # P Q=S R
+is(substr($a,-7,-5), ''); # Q P=R S
+is(substr($a,-7,-2), '543');# Q P R S
+is(substr($a,-5,-5), ''); # P=Q=R S
+is(substr($a,-5,-2), '543');# P=Q R S
+is(substr($a,-3,-3), ''); # P Q=R S
+is(substr($a,-3,-1), '32');# P Q R S
+
+$a = '';
+
+is(substr($a,-2,2), ''); # Q P=R=S
+is(substr($a,0,0), ''); # P=Q=R=S
+is(substr($a,0,1), ''); # P=Q=S R
+is(substr($a,-2,3), ''); # Q P=S R
+is(substr($a,-2), ''); # Q P=R=S
+is(substr($a,0), ''); # P=Q=R=S
+
+
+is(substr($a,0,-1), ''); # R P=Q=S
+$b = substr($a,-2, 0) ; # warn # Q=R P=S
+is($w--, 1);
+eval{substr($a,-2, 0) = "" ; }; # Q=R P=S
+like($@, $FATAL_MSG);
+
+$b = substr($a,-2, 1) ; # warn # Q R P=S
+is($w--, 1);
+eval{substr($a,-2, 1) = "" ; }; # Q R P=S
+like($@, $FATAL_MSG);
+
+$b = substr($a,-2,-1) ; # warn # Q R P=S
+is($w--, 1);
+eval{substr($a,-2,-1) = "" ; }; # Q R P=S
+like($@, $FATAL_MSG);
+
+$b = substr($a,-2,-2) ; # warn # Q=R P=S
+is($w--, 1);
+eval{substr($a,-2,-2) = "" ; }; # Q=R P=S
+like($@, $FATAL_MSG);
+
+$b = substr($a, 1,-2) ; # warn # R P=S Q
+is($w--, 1);
+eval{substr($a, 1,-2) = "" ; }; # R P=S Q
+like($@, $FATAL_MSG);
+
+$b = substr($a, 1, 1) ; # warn # P=S Q R
+is($w--, 1);
+eval{substr($a, 1, 1) = "" ; }; # P=S Q R
+like($@, $FATAL_MSG);
+
+$b = substr($a, 1, 0) ;# warn # P=S Q=R
+is($w--, 1);
+eval{substr($a, 1, 0) = "" ; }; # P=S Q=R
+like($@, $FATAL_MSG);
+
+$b = substr($a,1) ; # warning # P=R=S Q
+is($w--, 1);
+eval{substr($a,1) = "" ; }; # P=R=S Q
+like($@, $FATAL_MSG);
+
+$b = substr($a,-7,-6) ; # warn # Q R P S
+is($w--, 1);
+eval{substr($a,-7,-6) = "" ; }; # Q R P S
+like($@, $FATAL_MSG);
+
+my $a = 'zxcvbnm';
+substr($a,2,0) = '';
+is($a, 'zxcvbnm');
+substr($a,7,0) = '';
+is($a, 'zxcvbnm');
+substr($a,5,0) = '';
+is($a, 'zxcvbnm');
+substr($a,0,2) = 'pq';
+is($a, 'pqcvbnm');
+substr($a,2,0) = 'r';
+is($a, 'pqrcvbnm');
+substr($a,8,0) = 'asd';
+is($a, 'pqrcvbnmasd');
+substr($a,0,2) = 'iop';
+is($a, 'ioprcvbnmasd');
+substr($a,0,5) = 'fgh';
+is($a, 'fghvbnmasd');
+substr($a,3,5) = 'jkl';
+is($a, 'fghjklsd');
+substr($a,3,2) = '1234';
+is($a, 'fgh1234lsd');
+
+
+# with lexicals (and in re-entered scopes)
+for (0,1) {
+ my $txt;
+ unless ($_) {
+ $txt = "Foo";
+ substr($txt, -1) = "X";
+ is($txt, "FoX");
+ }
+ else {
+ substr($txt, 0, 1) = "X";
+ is($txt, "X");
+ }
+}
+
+$w = 0 ;
+# coercion of references
+{
+ my $s = [];
+ substr($s, 0, 1) = 'Foo';
+ is (substr($s,0,7), "FooRRAY");
+ is ($w,2);
+ $w = 0;
+}
+
+# check no spurious warnings
+is($w, 0);
+
+# check new 4 arg replacement syntax
+$a = "abcxyz";
+$w = 0;
+is(substr($a, 0, 3, ""), "abc");
+is($a, "xyz");
+is(substr($a, 0, 0, "abc"), "");
+is($a, "abcxyz");
+is(substr($a, 3, -1, ""), "xy");
+is($a, "abcz");
+
+is(substr($a, 3, undef, "xy"), "");
+is($a, "abcxyz");
+is($w, 3);
+
+$w = 0;
+
+is(substr($a, 3, 9999999, ""), "xyz");
+is($a, "abc");
+eval{substr($a, -99, 0, "") };
+like($@, $FATAL_MSG);
+eval{substr($a, 99, 3, "") };
+like($@, $FATAL_MSG);
+
+substr($a, 0, length($a), "foo");
+is ($a, "foo");
+is ($w, 0);
+
+# using 4 arg substr as lvalue is a compile time error
+eval 'substr($a,0,0,"") = "abc"';
+like ($@, qr/Can't modify substr/);
+is ($a, "foo");
+
+$a = "abcdefgh";
+is(sub { shift }->(substr($a, 0, 4, "xxxx")), 'abcd');
+is($a, 'xxxxefgh');
+
+{
+ my $y = 10;
+ $y = "2" . $y;
+ is ($y, 210);
+}
+
+# utf8 sanity
+{
+ my $x = substr("a\x{263a}b",0);
+ is(length($x), 3);
+ $x = substr($x,1,1);
+ is($x, "\x{263a}");
+ $x = $x x 2;
+ is(length($x), 2);
+ substr($x,0,1) = "abcd";
+ is($x, "abcd\x{263a}");
+ is(length($x), 5);
+ $x = reverse $x;
+ is(length($x), 5);
+ is($x, "\x{263a}dcba");
+
+ my $z = 10;
+ $z = "21\x{263a}" . $z;
+ is(length($z), 5);
+ is($z, "21\x{263a}10");
+}
+
+# replacement should work on magical values
+require Tie::Scalar;
+my %data;
+tie $data{'a'}, 'Tie::StdScalar'; # makes $data{'a'} magical
+$data{a} = "firstlast";
+is(substr($data{'a'}, 0, 5, ""), "first");
+is($data{'a'}, "last");
+
+# more utf8
+
+# The following two originally from Ignasi Roca.
+
+$x = "\xF1\xF2\xF3";
+substr($x, 0, 1) = "\x{100}"; # Ignasi had \x{FF}
+is(length($x), 3);
+is($x, "\x{100}\xF2\xF3");
+is(substr($x, 0, 1), "\x{100}");
+is(substr($x, 1, 1), "\x{F2}");
+is(substr($x, 2, 1), "\x{F3}");
+
+$x = "\xF1\xF2\xF3";
+substr($x, 0, 1) = "\x{100}\x{FF}"; # Ignasi had \x{FF}
+is(length($x), 4);
+is($x, "\x{100}\x{FF}\xF2\xF3");
+is(substr($x, 0, 1), "\x{100}");
+is(substr($x, 1, 1), "\x{FF}");
+is(substr($x, 2, 1), "\x{F2}");
+is(substr($x, 3, 1), "\x{F3}");
+
+# more utf8 lval exercise
+
+$x = "\xF1\xF2\xF3";
+substr($x, 0, 2) = "\x{100}\xFF";
+is(length($x), 3);
+is($x, "\x{100}\xFF\xF3");
+is(substr($x, 0, 1), "\x{100}");
+is(substr($x, 1, 1), "\x{FF}");
+is(substr($x, 2, 1), "\x{F3}");
+
+$x = "\xF1\xF2\xF3";
+substr($x, 1, 1) = "\x{100}\xFF";
+is(length($x), 4);
+is($x, "\xF1\x{100}\xFF\xF3");
+is(substr($x, 0, 1), "\x{F1}");
+is(substr($x, 1, 1), "\x{100}");
+is(substr($x, 2, 1), "\x{FF}");
+is(substr($x, 3, 1), "\x{F3}");
+
+$x = "\xF1\xF2\xF3";
+substr($x, 2, 1) = "\x{100}\xFF";
+is(length($x), 4);
+is($x, "\xF1\xF2\x{100}\xFF");
+is(substr($x, 0, 1), "\x{F1}");
+is(substr($x, 1, 1), "\x{F2}");
+is(substr($x, 2, 1), "\x{100}");
+is(substr($x, 3, 1), "\x{FF}");
+
+$x = "\xF1\xF2\xF3";
+substr($x, 3, 1) = "\x{100}\xFF";
+is(length($x), 5);
+is($x, "\xF1\xF2\xF3\x{100}\xFF");
+is(substr($x, 0, 1), "\x{F1}");
+is(substr($x, 1, 1), "\x{F2}");
+is(substr($x, 2, 1), "\x{F3}");
+is(substr($x, 3, 1), "\x{100}");
+is(substr($x, 4, 1), "\x{FF}");
+
+$x = "\xF1\xF2\xF3";
+substr($x, -1, 1) = "\x{100}\xFF";
+is(length($x), 4);
+is($x, "\xF1\xF2\x{100}\xFF");
+is(substr($x, 0, 1), "\x{F1}");
+is(substr($x, 1, 1), "\x{F2}");
+is(substr($x, 2, 1), "\x{100}");
+is(substr($x, 3, 1), "\x{FF}");
+
+$x = "\xF1\xF2\xF3";
+substr($x, -1, 0) = "\x{100}\xFF";
+is(length($x), 5);
+is($x, "\xF1\xF2\x{100}\xFF\xF3");
+is(substr($x, 0, 1), "\x{F1}");
+is(substr($x, 1, 1), "\x{F2}");
+is(substr($x, 2, 1), "\x{100}");
+is(substr($x, 3, 1), "\x{FF}");
+is(substr($x, 4, 1), "\x{F3}");
+
+$x = "\xF1\xF2\xF3";
+substr($x, 0, -1) = "\x{100}\xFF";
+is(length($x), 3);
+is($x, "\x{100}\xFF\xF3");
+is(substr($x, 0, 1), "\x{100}");
+is(substr($x, 1, 1), "\x{FF}");
+is(substr($x, 2, 1), "\x{F3}");
+
+$x = "\xF1\xF2\xF3";
+substr($x, 0, -2) = "\x{100}\xFF";
+is(length($x), 4);
+is($x, "\x{100}\xFF\xF2\xF3");
+is(substr($x, 0, 1), "\x{100}");
+is(substr($x, 1, 1), "\x{FF}");
+is(substr($x, 2, 1), "\x{F2}");
+is(substr($x, 3, 1), "\x{F3}");
+
+$x = "\xF1\xF2\xF3";
+substr($x, 0, -3) = "\x{100}\xFF";
+is(length($x), 5);
+is($x, "\x{100}\xFF\xF1\xF2\xF3");
+is(substr($x, 0, 1), "\x{100}");
+is(substr($x, 1, 1), "\x{FF}");
+is(substr($x, 2, 1), "\x{F1}");
+is(substr($x, 3, 1), "\x{F2}");
+is(substr($x, 4, 1), "\x{F3}");
+
+$x = "\xF1\xF2\xF3";
+substr($x, 1, -1) = "\x{100}\xFF";
+is(length($x), 4);
+is($x, "\xF1\x{100}\xFF\xF3");
+is(substr($x, 0, 1), "\x{F1}");
+is(substr($x, 1, 1), "\x{100}");
+is(substr($x, 2, 1), "\x{FF}");
+is(substr($x, 3, 1), "\x{F3}");
+
+$x = "\xF1\xF2\xF3";
+substr($x, -1, -1) = "\x{100}\xFF";
+is(length($x), 5);
+is($x, "\xF1\xF2\x{100}\xFF\xF3");
+is(substr($x, 0, 1), "\x{F1}");
+is(substr($x, 1, 1), "\x{F2}");
+is(substr($x, 2, 1), "\x{100}");
+is(substr($x, 3, 1), "\x{FF}");
+is(substr($x, 4, 1), "\x{F3}");
+
+# And tests for already-UTF8 one
+
+$x = "\x{101}\x{F2}\x{F3}";
+substr($x, 0, 1) = "\x{100}";
+is(length($x), 3);
+is($x, "\x{100}\xF2\xF3");
+is(substr($x, 0, 1), "\x{100}");
+is(substr($x, 1, 1), "\x{F2}");
+is(substr($x, 2, 1), "\x{F3}");
+
+$x = "\x{101}\x{F2}\x{F3}";
+substr($x, 0, 1) = "\x{100}\x{FF}";
+is(length($x), 4);
+is($x, "\x{100}\x{FF}\xF2\xF3");
+is(substr($x, 0, 1), "\x{100}");
+is(substr($x, 1, 1), "\x{FF}");
+is(substr($x, 2, 1), "\x{F2}");
+is(substr($x, 3, 1), "\x{F3}");
+
+$x = "\x{101}\x{F2}\x{F3}";
+substr($x, 0, 2) = "\x{100}\xFF";
+is(length($x), 3);
+is($x, "\x{100}\xFF\xF3");
+is(substr($x, 0, 1), "\x{100}");
+is(substr($x, 1, 1), "\x{FF}");
+is(substr($x, 2, 1), "\x{F3}");
+
+$x = "\x{101}\x{F2}\x{F3}";
+substr($x, 1, 1) = "\x{100}\xFF";
+is(length($x), 4);
+is($x, "\x{101}\x{100}\xFF\xF3");
+is(substr($x, 0, 1), "\x{101}");
+is(substr($x, 1, 1), "\x{100}");
+is(substr($x, 2, 1), "\x{FF}");
+is(substr($x, 3, 1), "\x{F3}");
+
+$x = "\x{101}\x{F2}\x{F3}";
+substr($x, 2, 1) = "\x{100}\xFF";
+is(length($x), 4);
+is($x, "\x{101}\xF2\x{100}\xFF");
+is(substr($x, 0, 1), "\x{101}");
+is(substr($x, 1, 1), "\x{F2}");
+is(substr($x, 2, 1), "\x{100}");
+is(substr($x, 3, 1), "\x{FF}");
+
+$x = "\x{101}\x{F2}\x{F3}";
+substr($x, 3, 1) = "\x{100}\xFF";
+is(length($x), 5);
+is($x, "\x{101}\x{F2}\x{F3}\x{100}\xFF");
+is(substr($x, 0, 1), "\x{101}");
+is(substr($x, 1, 1), "\x{F2}");
+is(substr($x, 2, 1), "\x{F3}");
+is(substr($x, 3, 1), "\x{100}");
+is(substr($x, 4, 1), "\x{FF}");
+
+$x = "\x{101}\x{F2}\x{F3}";
+substr($x, -1, 1) = "\x{100}\xFF";
+is(length($x), 4);
+is($x, "\x{101}\xF2\x{100}\xFF");
+is(substr($x, 0, 1), "\x{101}");
+is(substr($x, 1, 1), "\x{F2}");
+is(substr($x, 2, 1), "\x{100}");
+is(substr($x, 3, 1), "\x{FF}");
+
+$x = "\x{101}\x{F2}\x{F3}";
+substr($x, -1, 0) = "\x{100}\xFF";
+is(length($x), 5);
+is($x, "\x{101}\xF2\x{100}\xFF\xF3");
+is(substr($x, 0, 1), "\x{101}");
+is(substr($x, 1, 1), "\x{F2}");
+is(substr($x, 2, 1), "\x{100}");
+is(substr($x, 3, 1), "\x{FF}");
+is(substr($x, 4, 1), "\x{F3}");
+
+$x = "\x{101}\x{F2}\x{F3}";
+substr($x, 0, -1) = "\x{100}\xFF";
+is(length($x), 3);
+is($x, "\x{100}\xFF\xF3");
+is(substr($x, 0, 1), "\x{100}");
+is(substr($x, 1, 1), "\x{FF}");
+is(substr($x, 2, 1), "\x{F3}");
+
+$x = "\x{101}\x{F2}\x{F3}";
+substr($x, 0, -2) = "\x{100}\xFF";
+is(length($x), 4);
+is($x, "\x{100}\xFF\xF2\xF3");
+is(substr($x, 0, 1), "\x{100}");
+is(substr($x, 1, 1), "\x{FF}");
+is(substr($x, 2, 1), "\x{F2}");
+is(substr($x, 3, 1), "\x{F3}");
+
+$x = "\x{101}\x{F2}\x{F3}";
+substr($x, 0, -3) = "\x{100}\xFF";
+is(length($x), 5);
+is($x, "\x{100}\xFF\x{101}\x{F2}\x{F3}");
+is(substr($x, 0, 1), "\x{100}");
+is(substr($x, 1, 1), "\x{FF}");
+is(substr($x, 2, 1), "\x{101}");
+is(substr($x, 3, 1), "\x{F2}");
+is(substr($x, 4, 1), "\x{F3}");
+
+$x = "\x{101}\x{F2}\x{F3}";
+substr($x, 1, -1) = "\x{100}\xFF";
+is(length($x), 4);
+is($x, "\x{101}\x{100}\xFF\xF3");
+is(substr($x, 0, 1), "\x{101}");
+is(substr($x, 1, 1), "\x{100}");
+is(substr($x, 2, 1), "\x{FF}");
+is(substr($x, 3, 1), "\x{F3}");
+
+$x = "\x{101}\x{F2}\x{F3}";
+substr($x, -1, -1) = "\x{100}\xFF";
+is(length($x), 5);
+is($x, "\x{101}\xF2\x{100}\xFF\xF3");
+is(substr($x, 0, 1), "\x{101}");
+is(substr($x, 1, 1), "\x{F2}");
+is(substr($x, 2, 1), "\x{100}");
+is(substr($x, 3, 1), "\x{FF}");
+is(substr($x, 4, 1), "\x{F3}");
+
+substr($x = "ab", 0, 0, "\x{100}\x{200}");
+is($x, "\x{100}\x{200}ab");
+
+substr($x = "\x{100}\x{200}", 0, 0, "ab");
+is($x, "ab\x{100}\x{200}");
+
+substr($x = "ab", 1, 0, "\x{100}\x{200}");
+is($x, "a\x{100}\x{200}b");
+
+substr($x = "\x{100}\x{200}", 1, 0, "ab");
+is($x, "\x{100}ab\x{200}");
+
+substr($x = "ab", 2, 0, "\x{100}\x{200}");
+is($x, "ab\x{100}\x{200}");
+
+substr($x = "\x{100}\x{200}", 2, 0, "ab");
+is($x, "\x{100}\x{200}ab");
+
+substr($x = "\xFFb", 0, 0, "\x{100}\x{200}");
+is($x, "\x{100}\x{200}\xFFb");
+
+substr($x = "\x{100}\x{200}", 0, 0, "\xFFb");
+is($x, "\xFFb\x{100}\x{200}");
+
+substr($x = "\xFFb", 1, 0, "\x{100}\x{200}");
+is($x, "\xFF\x{100}\x{200}b");
+
+substr($x = "\x{100}\x{200}", 1, 0, "\xFFb");
+is($x, "\x{100}\xFFb\x{200}");
+
+substr($x = "\xFFb", 2, 0, "\x{100}\x{200}");
+is($x, "\xFFb\x{100}\x{200}");
+
+substr($x = "\x{100}\x{200}", 2, 0, "\xFFb");
+is($x, "\x{100}\x{200}\xFFb");
+
+# [perl #20933]
+{
+ my $s = "ab";
+ my @r;
+ $r[$_] = \ substr $s, $_, 1 for (0, 1);
+ is(join("", map { $$_ } @r), "ab");
+}
+
+# [perl #23207]
+{
+ sub ss {
+ substr($_[0],0,1) ^= substr($_[0],1,1) ^=
+ substr($_[0],0,1) ^= substr($_[0],1,1);
+ }
+ my $x = my $y = 'AB'; ss $x; ss $y;
+ is($x, $y);
+}
+
+# [perl #24605]
+{
+ my $x = "0123456789\x{500}";
+ my $y = substr $x, 4;
+ is(substr($x, 7, 1), "7");
+}
+
+# multiple assignments to lvalue [perl #24346]
+{
+ my $x = "abcdef";
+ for (substr($x,1,3)) {
+ is($_, 'bcd');
+ $_ = 'XX';
+ is($_, 'XX');
+ is($x, 'aXXef');
+ $_ = "\xFF";
+ is($_, "\xFF");
+ is($x, "a\xFFef");
+ $_ = "\xF1\xF2\xF3\xF4\xF5\xF6";
+ is($_, "\xF1\xF2\xF3\xF4\xF5\xF6");
+ is($x, "a\xF1\xF2\xF3\xF4\xF5\xF6ef");
+ $_ = 'YYYY';
+ is($_, 'YYYY');
+ is($x, 'aYYYYef');
+ }
+ $x = "abcdef";
+ for (substr($x,1)) {
+ is($_, 'bcdef');
+ $_ = 'XX';
+ is($_, 'XX');
+ is($x, 'aXX');
+ $x .= "frompswiggle";
+ is $_, "XXfrompswiggle";
+ }
+ $x = "abcdef";
+ for (substr($x,1,-1)) {
+ is($_, 'bcde');
+ $_ = 'XX';
+ is($_, 'XX');
+ is($x, 'aXXf');
+ $x .= "frompswiggle";
+ is $_, "XXffrompswiggl";
+ }
+ $x = "abcdef";
+ for (substr($x,-5,3)) {
+ is($_, 'bcd');
+ $_ = 'XX'; # now $_ is substr($x, -4, 2)
+ is($_, 'XX');
+ is($x, 'aXXef');
+ $x .= "frompswiggle";
+ is $_, "gg";
+ }
+ $x = "abcdef";
+ for (substr($x,-5)) {
+ is($_, 'bcdef');
+ $_ = 'XX'; # now substr($x, -2)
+ is($_, 'XX');
+ is($x, 'aXX');
+ $x .= "frompswiggle";
+ is $_, "le";
+ }
+ $x = "abcdef";
+ for (substr($x,-5,-1)) {
+ is($_, 'bcde');
+ $_ = 'XX'; # now substr($x, -3, -1)
+ is($_, 'XX');
+ is($x, 'aXXf');
+ $x .= "frompswiggle";
+ is $_, "gl";
+ }
+}
+
+# [perl #24200] string corruption with lvalue sub
+
+{
+ sub bar: lvalue { substr $krunch, 0 }
+ bar = "XXX";
+ is(bar, 'XXX');
+ $krunch = '123456789';
+ is(bar, '123456789');
+}
+
+# [perl #29149]
+{
+ my $text = "0123456789\xED ";
+ utf8::upgrade($text);
+ my $pos = 5;
+ pos($text) = $pos;
+ my $a = substr($text, $pos, $pos);
+ is(substr($text,$pos,1), $pos);
+
+}
+
+# [perl #23765]
+{
+ my $a = pack("C", 0xbf);
+ substr($a, -1) &= chr(0xfeff);
+ is($a, "\xbf");
+}
+
+# [perl #34976] incorrect caching of utf8 substr length
+{
+ my $a = "abcd\x{100}";
+ is(substr($a,1,2), 'bc');
+ is(substr($a,1,1), 'b');
+}
+
+# [perl #62646] offsets exceeding 32 bits on 64-bit system
+SKIP: {
+ skip("32-bit system", 24) unless ~0 > 0xffffffff;
+ my $a = "abc";
+ my $s;
+ my $r;
+
+ utf8::downgrade($a);
+ for (1..2) {
+ $w = 0;
+ $r = substr($a, 0xffffffff, 1);
+ is($r, undef);
+ is($w, 1);
+
+ $w = 0;
+ $r = substr($a, 0xffffffff+1, 1);
+ is($r, undef);
+ is($w, 1);
+
+ $w = 0;
+ ok( !eval { $r = substr($s=$a, 0xffffffff, 1, "_"); 1 } );
+ is($r, undef);
+ is($s, $a);
+ is($w, 0);
+
+ $w = 0;
+ ok( !eval { $r = substr($s=$a, 0xffffffff+1, 1, "_"); 1 } );
+ is($r, undef);
+ is($s, $a);
+ is($w, 0);
+
+ utf8::upgrade($a);
+ }
+}
+
+# [perl #77692] UTF8 cache not being reset when TARG is reused
+ok eval {
+ local ${^UTF8CACHE} = -1;
+ for my $i (0..1)
+ {
+ my $dummy = length(substr("\x{100}",0,$i));
+ }
+ 1
+}, 'UTF8 cache is reset when TARG is reused [perl #77692]';
+
+{
+ use utf8;
+ use open qw( :utf8 :std );
+ no warnings 'once';
+
+ my $t = "";
+ substr $t, 0, 0, *ワルド;
+ is($t, "*main::ワルド", "substr works on UTF-8 globs");
+
+ $t = "The World!";
+ substr $t, 0, 9, *ザ::ワルド;
+ is($t, "*ザ::ワルド!", "substr works on a UTF-8 glob + stash");
+}
+
+{
+ my $x = *foo;
+ my $y = \substr *foo, 0, 0;
+ is ref \$x, 'GLOB', '\substr does not coerce its glob arg just yet';
+ $x = \"foo";
+ $y = \substr *foo, 0, 0;
+ is ref \$x, 'REF', '\substr does not coerce its ref arg just yet';
+}
+
+# Test that UTF8-ness of magic var changing does not confuse substr lvalue
+# assignment.
+# We use overloading for our magic var, but a typeglob would work, too.
+package o {
+ use overload '""' => sub { ++our $count; $_[0][0] }
+}
+my $refee = bless ["\x{100}a"], o::;
+my $substr = \substr $refee, -2; # UTF8 flag still off for $$substr.
+$$substr = "b"; # UTF8 flag turns on when setsubstr
+is $refee, "b", # magic stringifies $$substr.
+ 'substr lvalue assignment when stringification turns on UTF8ness';
+
+# Test that changing UTF8-ness does not confuse 4-arg substr.
+$refee = bless [], "\x{100}a";
+# stringify without returning on UTF8 flag on $refee:
+my $string = $refee; $string = "$string";
+substr $refee, 0, 0, "\xff";
+is $refee, "\xff$string",
+ '4-arg substr with target UTF8ness turning on when stringified';
+$refee = bless [], "\x{100}";
+() = "$refee"; # UTF8 flag now on
+bless $refee, "\xff";
+$string = $refee; $string = "$string";
+substr $refee, 0, 0, "\xff";
+is $refee, "\xff$string",
+ '4-arg substr with target UTF8ness turning off when stringified';
+
+# Overload count
+$refee = bless ["foo"], o::;
+$o::count = 0;
+substr $refee, 0, 0, "";
+is $o::count, 1, '4-arg substr calls overloading once on the target';
+$refee = bless ["\x{100}"], o::;
+() = "$refee"; # turn UTF8 flag on
+$o::count = 0;
+() = substr $refee, 0;
+is $o::count, 1, 'rvalue substr calls overloading once on utf8 target';
+$o::count = 0;
+$refee = "";
+${\substr $refee, 0} = bless ["\x{100}"], o::;
+is $o::count, 1, 'assigning utf8 overload to substr lvalue calls ovld 1ce';
+
+# [perl #7678] core dump with substr reference and localisation
+{$b="abcde"; local $k; *k=\substr($b, 2, 1);}
+
+} # sub run_tests - put tests above this line that can run in threads
+
+
+my $destroyed;
+{ package Class; DESTROY { ++$destroyed; } }
+
+$destroyed = 0;
+{
+ my $x = '';
+ substr($x,0,1) = "";
+ $x = bless({}, 'Class');
+}
+is($destroyed, 1, 'Timely scalar destruction with lvalue substr');
+
+{
+ my $result_3363;
+ sub a_3363 {
+ my ($word, $replace) = @_;
+ my $ref = \substr($word, 0, 1);
+ $$ref = $replace;
+ if ($replace eq "b") {
+ $result_3363 = $word;
+ } else {
+ a_3363($word, "b");
+ }
+ }
+ a_3363($_, "v") for "test";
+
+ is($result_3363, "best", "ref-to-substr retains lvalue-ness under recursion [perl #3363]");
+}
Copied: trunk/contrib/perl/t/op/substr_thr.t (from rev 6437, vendor/perl/5.18.1/t/op/substr_thr.t)
===================================================================
--- trunk/contrib/perl/t/op/substr_thr.t (rev 0)
+++ trunk/contrib/perl/t/op/substr_thr.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,3 @@
+#!./perl
+chdir 't' if -d 't';
+require './thread_it.pl';
Copied: trunk/contrib/perl/t/op/svleak.pl (from rev 6437, vendor/perl/5.18.1/t/op/svleak.pl)
===================================================================
--- trunk/contrib/perl/t/op/svleak.pl (rev 0)
+++ trunk/contrib/perl/t/op/svleak.pl 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1 @@
+<<END
Modified: trunk/contrib/perl/t/op/svleak.t
===================================================================
--- trunk/contrib/perl/t/op/svleak.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/svleak.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -13,8 +13,10 @@
or skip_all("XS::APItest not available");
}
-plan tests => 19;
+use Config;
+plan tests => 124;
+
# run some code N times. If the number of SVs at the end of loop N is
# greater than (N-1)*delta at the end of loop 1, we've got a leak
#
@@ -30,6 +32,15 @@
cmp_ok($sv1-$sv0, '<=', ($n-1)*$delta, @rest);
}
+# Like leak, but run a string eval instead.
+# The code is used instead of the test name
+# if the name is absent.
+sub eleak {
+ my ($n,$delta,$code, at rest) = @_;
+ leak $n, $delta, sub { eval $code },
+ @rest ? @rest : $code
+}
+
# run some expression N times. The expr is concatenated N times and then
# evaled, ensuring that that there are no scope exits between executions.
# If the number of SVs at the end of expr N is greater than (N-1)*delta at
@@ -58,6 +69,53 @@
leak(5, 0, sub {push @a,1;pop @a}, "basic check 2 of leak test infrastructure");
leak(5, 1, sub {push @a,1;}, "basic check 3 of leak test infrastructure");
+# Fatal warnings
+my $f = "use warnings FATAL =>";
+my $all = "$f 'all';";
+eleak(2, 0, "$f 'deprecated'; qq|\\c\{|", 'qq|\c{| with fatal warnings');
+eleak(2, 0, "$f 'syntax'; qq|\\c`|", 'qq|\c`| with fatal warnings');
+eleak(2, 0, "$all /\$\\ /", '/$\ / with fatal warnings');
+eleak(2, 0, "$all s//\\1/", 's//\1/ with fatal warnings');
+eleak(2, 0, "$all qq|\\i|", 'qq|\i| with fatal warnings');
+eleak(2, 0, "$f 'digit'; qq|\\o{9}|", 'qq|\o{9}| with fatal warnings');
+eleak(2, 0, "$f 'misc'; sub foo{} sub foo:lvalue",
+ 'ignored :lvalue with fatal warnings');
+eleak(2, 0, "no warnings; use feature ':all'; $f 'misc';
+ my sub foo{} sub foo:lvalue",
+ 'ignored mysub :lvalue with fatal warnings');
+eleak(2, 0, "no warnings; use feature ':all'; $all
+ my sub foo{} sub foo:lvalue{}",
+ 'fatal mysub redef warning');
+eleak(2, 0, "$all sub foo{} sub foo{}", 'fatal sub redef warning');
+eleak(2, 0, "$all *x=sub {}",
+ 'fatal sub redef warning with sub-to-glob assignment');
+eleak(2, 0, "$all *x=sub() {1}",
+ 'fatal const sub redef warning with sub-to-glob assignment');
+eleak(2, 0, "$all XS::APItest::newCONSTSUB(\\%main::=>name=>0=>1)",
+ 'newCONSTSUB sub redefinition with fatal warnings');
+eleak(2, 0, "$f 'misc'; my\$a,my\$a", 'double my with fatal warnings');
+eleak(2, 0, "$f 'misc'; our\$a,our\$a", 'double our with fatal warnings');
+eleak(2, 0, "$f 'closure';
+ sub foo { my \$x; format=\n\@\n\$x\n.\n} write; ",
+ 'format closing over unavailable var with fatal warnings');
+eleak(2, 0, "$all /(?{})?/ ", '(?{})? with fatal warnings');
+eleak(2, 0, "$all /(?{})+/ ", '(?{})+ with fatal warnings');
+eleak(2, 0, "$all /[\\i]/ ", 'invalid charclass escape with fatal warns');
+eleak(2, 0, "$all /[:foo:]/ ", '/[:foo:]/ with fatal warnings');
+eleak(2, 0, "$all /[a-\\d]/ ", '[a-\d] char class with fatal warnings');
+eleak(2, 0, "$all v111111111111111111111111111111111111111111111111",
+ 'vstring num overflow with fatal warnings');
+
+eleak(2, 0, 'sub{<*>}');
+# Use a random number of ops, so that the glob op does not reuse the same
+# address each time, giving us false passes.
+leak(2, 0, sub { eval '$x+'x(1 + rand() * 100) . '<*>'; },
+ 'freeing partly iterated glob');
+
+eleak(2, 0, 'goto sub {}', 'goto &sub in eval');
+eleak(2, 0, '() = sort { goto sub {} } 1,2', 'goto &sub in sort');
+eleak(2, 0, '/(?{ goto sub {} })/', 'goto &sub in regexp');
+
sub TIEARRAY { bless [], $_[0] }
sub FETCH { $_[0]->[$_[1]] }
sub STORE { $_[0]->[$_[1]] = $_[2] }
@@ -68,6 +126,19 @@
leak(5, 0, sub {local $a[0]}, "local \$tied[0]");
}
+# Overloading
+require overload;
+eleak(2, 0, "BEGIN{overload::constant integer=>sub{}} 1,1,1,1,1,1,1,1,1,1",
+ '"too many errors" from constant overloading returning undef');
+# getting this one to leak was complicated; we have to unset LOCALIZE_HH:
+eleak(2, 0, 'BEGIN{overload::constant integer=>sub{}; $^H &= ~ 0x00020000}
+ 1,1,1,1,1,1,1,1,1,1',
+ '"too many errors" from constant overloading with $^H sabotaged');
+eleak(2, 0, "BEGIN{overload::constant integer=>sub{}; undef %^H}
+ 1,1,1,1,1,1,1,1,1,1",
+ '"too many errors" from constant overloading with %^H undefined');
+
+
# [perl #74484] repeated tries leaked SVs on the tmps stack
leak_expr(5, 0, q{"YYYYYa" =~ /.+?(a(.+?)|b)/ }, "trie leak");
@@ -129,6 +200,9 @@
ok(!$weak, "hash referenced weakened SV released");
}
+# prototype() errors
+leak(2,0, sub { eval { prototype "CORE::fu" } }, 'prototype errors');
+
# RT #72246: rcatline memory leak on bad $/
leak(2, 0,
@@ -141,3 +215,238 @@
},
"rcatline leak"
);
+
+{
+ my $RE = qr/
+ (?:
+ <(?<tag>
+ \s*
+ [^>\s]+
+ )>
+ )??
+ /xis;
+
+ "<html><body></body></html>" =~ m/$RE/gcs;
+
+ leak(5, 0, sub {
+ my $tag = $+{tag};
+ }, "named regexp captures");
+}
+
+eleak(2,0,'/[:]/');
+eleak(2,0,'/[\xdf]/i');
+eleak(2,0,'s![^/]!!');
+eleak(2,0,'/[pp]/');
+eleak(2,0,'/[[:ascii:]]/');
+eleak(2,0,'/[[.zog.]]/');
+eleak(2,0,'/[.zog.]/');
+eleak(2,0,'no warnings; /(?[])/');
+eleak(2,0,'no warnings; /(?[[a]+[b]])/');
+eleak(2,0,'no warnings; /(?[[a]-[b]])/');
+eleak(2,0,'no warnings; /(?[[a]&[b]])/');
+eleak(2,0,'no warnings; /(?[[a]|[b]])/');
+eleak(2,0,'no warnings; /(?[[a]^[b]])/');
+eleak(2,0,'no warnings; /(?[![a]])/');
+eleak(2,0,'no warnings; /(?[\p{Word}])/');
+eleak(2,0,'no warnings; /(?[[a]+)])/');
+eleak(2,0,'no warnings; /(?[\d\d)])/');
+
+# These can generate one ref count, but just once.
+eleak(4,1,'chr(0x100) =~ /[[:punct:]]/');
+eleak(4,1,'chr(0x100) =~ /[[:^punct:]]/');
+eleak(4,1,'chr(0x100) =~ /[[:word:]]/');
+eleak(4,1,'chr(0x100) =~ /[[:^word:]]/');
+
+eleak(2,0,'chr(0x100) =~ /\P{Assigned}/');
+leak(2,0,sub { /(??{})/ }, '/(??{})/');
+
+leak(2,0,sub { !$^V }, '[perl #109762] version object in boolean context');
+
+
+# [perl #114356] run-time rexexp with unchanging pattern got
+# inflated refcounts
+eleak(2, 0, q{ my $x = "x"; "abc" =~ /$x/ for 1..5 }, '#114356');
+
+eleak(2, 0, 'sub', '"sub" with nothing following');
+eleak(2, 0, '+sub:a{}', 'anon subs with invalid attributes');
+eleak(2, 0, 'no warnings; sub a{1 1}', 'sub with syntax error');
+eleak(2, 0, 'no warnings; sub {1 1}', 'anon sub with syntax error');
+eleak(2, 0, 'no warnings; use feature ":all"; my sub a{1 1}',
+ 'my sub with syntax error');
+
+# Reification (or lack thereof)
+leak(2, 0, sub { sub { local $_[0]; shift }->(1) },
+ 'local $_[0] on surreal @_, followed by shift');
+leak(2, 0, sub { sub { local $_[0]; \@_ }->(1) },
+ 'local $_[0] on surreal @_, followed by reification');
+
+# Syntax errors
+eleak(2, 0, '"${<<END}"
+ ', 'unterminated here-doc in quotes in multiline eval');
+eleak(2, 0, '"${<<END
+ }"', 'unterminated here-doc in multiline quotes in eval');
+leak(2, 0, sub { eval { do './op/svleak.pl' } },
+ 'unterminated here-doc in file');
+eleak(2, 0, 'tr/9-0//');
+eleak(2, 0, 'tr/a-z-0//');
+eleak(2, 0, 'no warnings; nonexistent_function 33838',
+ 'bareword followed by number');
+eleak(2, 0, '//dd;'x20, '"too many errors" when parsing m// flags');
+eleak(2, 0, 's///dd;'x20, '"too many errors" when parsing s/// flags');
+eleak(2, 0, 'no warnings; 2 2;BEGIN{}',
+ 'BEGIN block after syntax error');
+{
+ local %INC; # in case Errno is already loaded
+ eleak(2, 0, 'no warnings; 2@!{',
+ 'implicit "use Errno" after syntax error');
+}
+eleak(2, 0, "\"\$\0\356\"", 'qq containing $ <null> something');
+eleak(2, 0, 'END OF TERMS AND CONDITIONS', 'END followed by words');
+eleak(2, 0, "+ + +;qq|\\N{a}|"x10,'qq"\N{a}" after errors');
+eleak(2, 0, "qq|\\N{%}|", 'qq"\N{%}" (invalid charname)');
+eleak(2, 0, "qq|\\N{au}|;", 'qq"\N{invalid}"');
+eleak(2, 0, "qq|\\c|;"x10, '"too many errors" from qq"\c"');
+eleak(2, 0, "qq|\\o|;"x10, '"too many errors" from qq"\o"');
+eleak(2, 0, "qq|\\x{|;"x10, '"too many errors" from qq"\x{"');
+eleak(2, 0, "qq|\\N|;"x10, '"too many errors" from qq"\N"');
+eleak(2, 0, "qq|\\N{|;"x10, '"too many errors" from qq"\N{"');
+eleak(2, 0, "qq|\\N{U+GETG}|;"x10,'"too many errors" from qq"\N{U+JUNK}"');
+
+
+# [perl #114764] Attributes leak scalars
+leak(2, 0, sub { eval 'my $x : shared' }, 'my $x :shared used to leak');
+
+eleak(2, 0, 'ref: 1', 'labels');
+
+# Tied hash iteration was leaking if the hash was freed before itera-
+# tion was over.
+package t {
+ sub TIEHASH { bless [] }
+ sub FIRSTKEY { 0 }
+}
+leak(2, 0, sub {
+ my $h = {};
+ tie %$h, t;
+ each %$h;
+ undef $h;
+}, 'tied hash iteration does not leak');
+
+package explosive_scalar {
+ sub TIESCALAR { my $self = shift; bless [undef, {@_}], $self }
+ sub FETCH { die 'FETCH' if $_[0][1]{FETCH}; $_[0][0] }
+ sub STORE { die 'STORE' if $_[0][1]{STORE}; $_[0][0] = $_[1] }
+}
+tie my $die_on_fetch, 'explosive_scalar', FETCH => 1;
+
+# List assignment was leaking when assigning explosive scalars to
+# aggregates.
+leak(2, 0, sub {
+ eval {%a = ($die_on_fetch, 0)}; # key
+ eval {%a = (0, $die_on_fetch)}; # value
+ eval {%a = ($die_on_fetch, $die_on_fetch)}; # both
+ eval {%a = ($die_on_fetch)}; # key, odd elements
+}, 'hash assignment does not leak');
+leak(2, 0, sub {
+ eval {@a = ($die_on_fetch)};
+ eval {($die_on_fetch, $b) = ($b, $die_on_fetch)};
+ # restore
+ tie $die_on_fetch, 'explosive_scalar', FETCH => 1;
+}, 'array assignment does not leak');
+
+# [perl #107000]
+package hhtie {
+ sub TIEHASH { bless [] }
+ sub STORE { $_[0][0]{$_[1]} = $_[2] }
+ sub FETCH { die if $explosive; $_[0][0]{$_[1]} }
+ sub FIRSTKEY { keys %{$_[0][0]}; each %{$_[0][0]} }
+ sub NEXTKEY { each %{$_[0][0]} }
+}
+leak(2, 0, sub {
+ eval q`
+ BEGIN {
+ $hhtie::explosive = 0;
+ tie %^H, hhtie;
+ $^H{foo} = bar;
+ $hhtie::explosive = 1;
+ }
+ { 1; }
+ `;
+}, 'hint-hash copying does not leak');
+
+package explosive_array {
+ sub TIEARRAY { bless [[], {}], $_[0] }
+ sub FETCH { die if $_[0]->[1]{FETCH}; $_[0]->[0][$_[1]] }
+ sub FETCHSIZE { die if $_[0]->[1]{FETCHSIZE}; scalar @{ $_[0]->[0] } }
+ sub STORE { die if $_[0]->[1]{STORE}; $_[0]->[0][$_[1]] = $_[2] }
+ sub CLEAR { die if $_[0]->[1]{CLEAR}; @{$_[0]->[0]} = () }
+ sub EXTEND { die if $_[0]->[1]{EXTEND}; return }
+ sub explode { my $self = shift; $self->[1] = {@_} }
+}
+
+leak(2, 0, sub {
+ tie my @a, 'explosive_array';
+ tied(@a)->explode( STORE => 1 );
+ my $x = 0;
+ eval { @a = ($x) };
+}, 'explosive array assignment does not leak');
+
+leak(2, 0, sub {
+ my ($a, $b);
+ eval { warn $die_on_fetch };
+}, 'explosive warn argument');
+
+leak(2, 0, sub {
+ my $foo = sub { return $die_on_fetch };
+ my $res = eval { $foo->() };
+ my @res = eval { $foo->() };
+}, 'function returning explosive does not leak');
+
+leak(2, 0, sub {
+ my $res = eval { {$die_on_fetch, 0} };
+ $res = eval { {0, $die_on_fetch} };
+}, 'building anon hash with explosives does not leak');
+
+leak(2, 0, sub {
+ my $res = eval { [$die_on_fetch] };
+}, 'building anon array with explosives does not leak');
+
+leak(2, 0, sub {
+ my @a;
+ eval { push @a, $die_on_fetch };
+}, 'pushing exploding scalar does not leak');
+
+leak(2, 0, sub {
+ eval { push @-, '' };
+}, 'pushing onto read-only array does not leak');
+
+
+# Run-time regexp code blocks
+{
+ use re 'eval';
+ my @tests = ('[(?{})]','(?{})');
+ for my $t (@tests) {
+ leak(2, 0, sub {
+ / $t/;
+ }, "/ \$x/ where \$x is $t does not leak");
+ leak(2, 0, sub {
+ /(?{})$t/;
+ }, "/(?{})\$x/ where \$x is $t does not leak");
+ }
+}
+
+
+{
+ use warnings FATAL => 'all';
+ leak(2, 0, sub {
+ no warnings 'once';
+ eval { printf uNopened 42 };
+ }, 'printfing to bad handle under fatal warnings does not leak');
+ open my $fh, ">", \my $buf;
+ leak(2, 0, sub {
+ eval { printf $fh chr 2455 };
+ }, 'wide fatal warning does not make printf leak');
+ close $fh or die $!;
+}
+
+
+leak(2,0,sub{eval{require untohunothu}}, 'requiring nonexistent module');
Property changes on: trunk/contrib/perl/t/op/svleak.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/switch.t
===================================================================
--- trunk/contrib/perl/t/op/switch.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/switch.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -8,13 +8,22 @@
use strict;
use warnings;
+no warnings 'experimental::smartmatch';
-plan tests => 164;
+plan tests => 201;
-# The behaviour of the feature pragma should be tested by lib/switch.t
-# using the tests in t/lib/switch/*. This file tests the behaviour of
+# The behaviour of the feature pragma should be tested by lib/feature.t
+# using the tests in t/lib/feature/*. This file tests the behaviour of
# the switch ops themselves.
+
+# Before loading feature, test the switch ops with CORE::
+CORE::given(3) {
+ CORE::when(3) { pass "CORE::given and CORE::when"; continue }
+ CORE::default { pass "continue (without feature) and CORE::default" }
+}
+
+
use feature 'switch';
eval { continue };
@@ -44,9 +53,10 @@
$_ = "outside";
given("inside") { check_outside1() }
-sub check_outside1 { is($_, "outside", "\$_ lexically scoped") }
+sub check_outside1 { is($_, "inside", "\$_ is not lexically scoped") }
{
+ no warnings 'experimental::lexical_topic';
my $_ = "outside";
given("inside") { check_outside2() }
sub check_outside2 {
@@ -389,6 +399,7 @@
# Make sure it still works with a lexical $_:
{
+ no warnings 'experimental::lexical_topic';
my $_;
my $test = "explicit comparison with lexical \$_";
my $twenty_five = 25;
@@ -590,7 +601,7 @@
my $f = tie my $v, "FetchCounter";
-{ my $test_name = "Only one FETCH (in given)";
+{ my $test_name = "Multiple FETCHes in given, due to aliasing";
my $ok;
given($v = 23) {
when(undef) {}
@@ -601,7 +612,7 @@
when(/24/) {$ok = 0}
}
is($ok, 1, "precheck: $test_name");
- is($f->count(), 1, $test_name);
+ is($f->count(), 4, $test_name);
}
{ my $test_name = "Only one FETCH (numeric when)";
@@ -689,6 +700,7 @@
{
my $first = 1;
+ no warnings 'experimental::lexical_topic';
my $_;
for (1, "two") {
when ("two") {
@@ -707,6 +719,7 @@
{
my $first = 1;
+ no warnings 'experimental::lexical_topic';
my $_;
for $_ (1, "two") {
when ("two") {
@@ -725,6 +738,7 @@
{
my $first = 1;
+ no warnings 'experimental::lexical_topic';
for my $_ (1, "two") {
when ("two") {
is($first, 0, "Lexical loop: second");
@@ -1200,6 +1214,192 @@
is("@in_slice", "a", "when(hash slice)");
}
+{ # RT#84526 - Handle magical TARG
+ my $x = my $y = "aaa";
+ for ($x, $y) {
+ given ($_) {
+ is(pos, undef, "handle magical TARG");
+ pos = 1;
+ }
+ }
+}
+
+# Test that returned values are correctly propagated through several context
+# levels (see RT #93548).
+{
+ my $tester = sub {
+ my $id = shift;
+
+ package fmurrr;
+
+ our ($when_loc, $given_loc, $ext_loc);
+
+ my $ext_lex = 7;
+ our $ext_glob = 8;
+ local $ext_loc = 9;
+
+ given ($id) {
+ my $given_lex = 4;
+ our $given_glob = 5;
+ local $given_loc = 6;
+
+ when (0) { 0 }
+
+ when (1) { my $when_lex = 1 }
+ when (2) { our $when_glob = 2 }
+ when (3) { local $when_loc = 3 }
+
+ when (4) { $given_lex }
+ when (5) { $given_glob }
+ when (6) { $given_loc }
+
+ when (7) { $ext_lex }
+ when (8) { $ext_glob }
+ when (9) { $ext_loc }
+
+ 'fallback';
+ }
+ };
+
+ my @descriptions = qw<
+ constant
+
+ when-lexical
+ when-global
+ when-local
+
+ given-lexical
+ given-global
+ given-local
+
+ extern-lexical
+ extern-global
+ extern-local
+ >;
+
+ for my $id (0 .. 9) {
+ my $desc = $descriptions[$id];
+
+ my $res = $tester->($id);
+ is $res, $id, "plain call - $desc";
+
+ $res = do {
+ my $id_plus_1 = $id + 1;
+ given ($id_plus_1) {
+ do {
+ when (/\d/) {
+ --$id_plus_1;
+ continue;
+ 456;
+ }
+ };
+ default {
+ $tester->($id_plus_1);
+ }
+ 'XXX';
+ }
+ };
+ is $res, $id, "across continue and default - $desc";
+ }
+}
+
+# Check that values returned from given/when are destroyed at the right time.
+{
+ {
+ package Fmurrr;
+
+ sub new {
+ bless {
+ flag => \($_[1]),
+ id => $_[2],
+ }, $_[0]
+ }
+
+ sub DESTROY {
+ ${$_[0]->{flag}}++;
+ }
+ }
+
+ my @descriptions = qw<
+ when
+ break
+ continue
+ default
+ >;
+
+ for my $id (0 .. 3) {
+ my $desc = $descriptions[$id];
+
+ my $destroyed = 0;
+ my $res_id;
+
+ {
+ my $res = do {
+ given ($id) {
+ my $x;
+ when (0) { Fmurrr->new($destroyed, 0) }
+ when (1) { my $y = Fmurrr->new($destroyed, 1); break }
+ when (2) { $x = Fmurrr->new($destroyed, 2); continue }
+ when (2) { $x }
+ default { Fmurrr->new($destroyed, 3) }
+ }
+ };
+ $res_id = $res->{id};
+ }
+ $res_id = $id if $id == 1; # break doesn't return anything
+
+ is $res_id, $id, "given/when returns the right object - $desc";
+ is $destroyed, 1, "given/when does not leak - $desc";
+ };
+}
+
+# break() must reset the stack
+{
+ my @res = (1, do {
+ given ("x") {
+ 2, 3, do {
+ when (/[a-z]/) {
+ 4, 5, 6, break
+ }
+ }
+ }
+ });
+ is "@res", "1", "break resets the stack";
+}
+
+# RT #94682:
+# must ensure $_ is initialised and cleared at start/end of given block
+
+{
+ sub f1 {
+ no warnings 'experimental::lexical_topic';
+ my $_;
+ given(3) {
+ return sub { $_ } # close over lexical $_
+ }
+ }
+ is(f1()->(), 3, 'closed over $_');
+
+ package RT94682;
+
+ my $d = 0;
+ sub DESTROY { $d++ };
+
+ sub f2 {
+ no warnings 'experimental::lexical_topic';
+ my $_ = 5;
+ given(bless [7]) {
+ ::is($_->[0], 7, "is [7]");
+ }
+ ::is($_, 5, "is 5");
+ ::is($d, 1, "DESTROY called once");
+ }
+ f2();
+}
+
+
+
# Okay, that'll do for now. The intricacies of the smartmatch
-# semantics are tested in t/op/smartmatch.t
+# semantics are tested in t/op/smartmatch.t. Taintedness of
+# returned values is checked in t/op/taint.t.
__END__
Property changes on: trunk/contrib/perl/t/op/switch.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/t/op/symbolcache.t
===================================================================
--- trunk/contrib/perl/t/op/symbolcache.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/symbolcache.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/symbolcache.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/sysio.t
===================================================================
--- trunk/contrib/perl/t/op/sysio.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/sysio.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -14,8 +14,7 @@
$^O eq 'os2' ||
$^O eq 'MSWin32' ||
$^O eq 'NetWare' ||
- $^O eq 'dos' ||
- $^O eq 'mpeix');
+ $^O eq 'dos');
$x = 'abc';
Property changes on: trunk/contrib/perl/t/op/sysio.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/taint.t
===================================================================
--- trunk/contrib/perl/t/op/taint.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/taint.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -17,7 +17,7 @@
use strict;
use Config;
-plan tests => 774;
+plan tests => 797;
$| = 1;
@@ -98,6 +98,7 @@
# How to identify taint when you see it
sub tainted ($) {
+ local $@; # Don't pollute caller's value.
not eval { join("", at _), kill 0; 1 };
}
@@ -137,22 +138,6 @@
{
$ENV{'DCL$PATH'} = '' if $Is_VMS;
- if ($Is_MSWin32 && $Config{ccname} =~ /bcc32/ && ! -f 'cc3250mt.dll') {
- my $bcc_dir;
- foreach my $dir (split /$Config{path_sep}/, $ENV{PATH}) {
- if (-f "$dir/cc3250mt.dll") {
- $bcc_dir = $dir and last;
- }
- }
- if (defined $bcc_dir) {
- require File::Copy;
- File::Copy::copy("$bcc_dir/cc3250mt.dll", '.') or
- die "$0: failed to copy cc3250mt.dll: $!\n";
- eval q{
- END { unlink "cc3250mt.dll" }
- };
- }
- }
$ENV{PATH} = ($Is_Cygwin) ? '/usr/bin' : '';
delete @ENV{@MoreEnv};
$ENV{TERM} = 'dumb';
@@ -167,7 +152,7 @@
while (my $v = $vars[0]) {
local $ENV{$v} = $TAINT;
last if eval { `$echo 1` };
- last unless $@ =~ /^Insecure \$ENV{$v}/;
+ last unless $@ =~ /^Insecure \$ENV\{$v}/;
shift @vars;
}
is("@vars", "");
@@ -178,7 +163,7 @@
is(eval { `$echo 1` }, "1\n");
$ENV{TERM} = 'e=mc2' . $TAINT;
is(eval { `$echo 1` }, undef);
- like($@, qr/^Insecure \$ENV{TERM}/);
+ like($@, qr/^Insecure \$ENV\{TERM}/);
}
my $tmp;
@@ -197,7 +182,7 @@
local $ENV{PATH} = $tmp;
is(eval { `$echo 1` }, undef);
- like($@, qr/^Insecure directory in \$ENV{PATH}/);
+ like($@, qr/^Insecure directory in \$ENV\{PATH}/);
}
SKIP: {
@@ -205,7 +190,7 @@
$ENV{'DCL$PATH'} = $TAINT;
is(eval { `$echo 1` }, undef);
- like($@, qr/^Insecure \$ENV{DCL\$PATH}/);
+ like($@, qr/^Insecure \$ENV\{DCL\$PATH}/);
SKIP: {
skip q[can't find world-writeable directory to test DCL$PATH], 2
unless $tmp;
@@ -212,7 +197,7 @@
$ENV{'DCL$PATH'} = $tmp;
is(eval { `$echo 1` }, undef);
- like($@, qr/^Insecure directory in \$ENV{DCL\$PATH}/);
+ like($@, qr/^Insecure directory in \$ENV\{DCL\$PATH}/);
}
$ENV{'DCL$PATH'} = '';
}
@@ -311,26 +296,44 @@
is($res, 1, "$desc: res value");
is($one, 'a', "$desc: \$1 value");
- $desc = "match with pattern tainted via locale";
+ SKIP: {
+ skip 'No locale testing without d_setlocale', 10 if(!$Config{d_setlocale});
- $s = 'abcd';
- { use locale; $res = $s =~ /(\w+)/; $one = $1; }
- isnt_tainted($s, "$desc: s not tainted");
- isnt_tainted($res, "$desc: res not tainted");
- is_tainted($one, "$desc: \$1 tainted");
- is($res, 1, "$desc: res value");
- is($one, 'abcd', "$desc: \$1 value");
+ $desc = "match with pattern tainted via locale";
- $desc = "match /g with pattern tainted via locale";
+ $s = 'abcd';
+ {
+ BEGIN {
+ if($Config{d_setlocale}) {
+ require locale; import locale;
+ }
+ }
+ $res = $s =~ /(\w+)/; $one = $1;
+ }
+ isnt_tainted($s, "$desc: s not tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ is_tainted($one, "$desc: \$1 tainted");
+ is($res, 1, "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
- $s = 'abcd';
- { use locale; $res = $s =~ /(\w)/g; $one = $1; }
- isnt_tainted($s, "$desc: s not tainted");
- isnt_tainted($res, "$desc: res not tainted");
- is_tainted($one, "$desc: \$1 tainted");
- is($res, 1, "$desc: res value");
- is($one, 'a', "$desc: \$1 value");
+ $desc = "match /g with pattern tainted via locale";
+ $s = 'abcd';
+ {
+ BEGIN {
+ if($Config{d_setlocale}) {
+ require locale; import locale;
+ }
+ }
+ $res = $s =~ /(\w)/g; $one = $1;
+ }
+ isnt_tainted($s, "$desc: s not tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ is_tainted($one, "$desc: \$1 tainted");
+ is($res, 1, "$desc: res value");
+ is($one, 'a', "$desc: \$1 value");
+ }
+
$desc = "match with pattern tainted, list cxt";
$s = 'abcd';
@@ -354,28 +357,46 @@
is($res2,'b', "$desc: res2 value");
is($one, 'd', "$desc: \$1 value");
- $desc = "match with pattern tainted via locale, list cxt";
+ SKIP: {
+ skip 'No locale testing without d_setlocale', 12 if(!$Config{d_setlocale});
- $s = 'abcd';
- { use locale; ($res) = $s =~ /(\w+)/; $one = $1; }
- isnt_tainted($s, "$desc: s not tainted");
- is_tainted($res, "$desc: res tainted");
- is_tainted($one, "$desc: \$1 tainted");
- is($res, 'abcd', "$desc: res value");
- is($one, 'abcd', "$desc: \$1 value");
+ $desc = "match with pattern tainted via locale, list cxt";
- $desc = "match /g with pattern tainted via locale, list cxt";
+ $s = 'abcd';
+ {
+ BEGIN {
+ if($Config{d_setlocale}) {
+ require locale; import locale;
+ }
+ }
+ ($res) = $s =~ /(\w+)/; $one = $1;
+ }
+ isnt_tainted($s, "$desc: s not tainted");
+ is_tainted($res, "$desc: res tainted");
+ is_tainted($one, "$desc: \$1 tainted");
+ is($res, 'abcd', "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
- $s = 'abcd';
- { use locale; ($res, $res2) = $s =~ /(\w)/g; $one = $1; }
- isnt_tainted($s, "$desc: s not tainted");
- is_tainted($res, "$desc: res tainted");
- is_tainted($res2, "$desc: res2 tainted");
- is_tainted($one, "$desc: \$1 tainted");
- is($res, 'a', "$desc: res value");
- is($res2,'b', "$desc: res2 value");
- is($one, 'd', "$desc: \$1 value");
+ $desc = "match /g with pattern tainted via locale, list cxt";
+ $s = 'abcd';
+ {
+ BEGIN {
+ if($Config{d_setlocale}) {
+ require locale; import locale;
+ }
+ }
+ ($res, $res2) = $s =~ /(\w)/g; $one = $1;
+ }
+ isnt_tainted($s, "$desc: s not tainted");
+ is_tainted($res, "$desc: res tainted");
+ is_tainted($res2, "$desc: res2 tainted");
+ is_tainted($one, "$desc: \$1 tainted");
+ is($res, 'a', "$desc: res value");
+ is($res2,'b', "$desc: res2 value");
+ is($one, 'd', "$desc: \$1 value");
+ }
+
$desc = "substitution with string tainted";
$s = 'abcd' . $TAINT;
@@ -496,39 +517,64 @@
is($res, 'xyz', "$desc: res value");
is($one, 'abcd', "$desc: \$1 value");
- $desc = "substitution with pattern tainted via locale";
+ SKIP: {
+ skip 'No locale testing without d_setlocale', 18 if(!$Config{d_setlocale});
- $s = 'abcd';
- { use locale; $res = $s =~ s/(\w+)/xyz/; $one = $1; }
- is_tainted($s, "$desc: s tainted");
- isnt_tainted($res, "$desc: res not tainted");
- is_tainted($one, "$desc: \$1 tainted");
- is($s, 'xyz', "$desc: s value");
- is($res, 1, "$desc: res value");
- is($one, 'abcd', "$desc: \$1 value");
+ $desc = "substitution with pattern tainted via locale";
- $desc = "substitution /g with pattern tainted via locale";
+ $s = 'abcd';
+ {
+ BEGIN {
+ if($Config{d_setlocale}) {
+ require locale; import locale;
+ }
+ }
+ $res = $s =~ s/(\w+)/xyz/; $one = $1;
+ }
+ is_tainted($s, "$desc: s tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ is_tainted($one, "$desc: \$1 tainted");
+ is($s, 'xyz', "$desc: s value");
+ is($res, 1, "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
- $s = 'abcd';
- { use locale; $res = $s =~ s/(\w)/x/g; $one = $1; }
- is_tainted($s, "$desc: s tainted");
- is_tainted($res, "$desc: res tainted");
- is_tainted($one, "$desc: \$1 tainted");
- is($s, 'xxxx', "$desc: s value");
- is($res, 4, "$desc: res value");
- is($one, 'd', "$desc: \$1 value");
+ $desc = "substitution /g with pattern tainted via locale";
- $desc = "substitution /r with pattern tainted via locale";
+ $s = 'abcd';
+ {
+ BEGIN {
+ if($Config{d_setlocale}) {
+ require locale; import locale;
+ }
+ }
+ $res = $s =~ s/(\w)/x/g; $one = $1;
+ }
+ is_tainted($s, "$desc: s tainted");
+ is_tainted($res, "$desc: res tainted");
+ is_tainted($one, "$desc: \$1 tainted");
+ is($s, 'xxxx', "$desc: s value");
+ is($res, 4, "$desc: res value");
+ is($one, 'd', "$desc: \$1 value");
- $s = 'abcd';
- { use locale; $res = $s =~ s/(\w+)/xyz/r; $one = $1; }
- isnt_tainted($s, "$desc: s not tainted");
- is_tainted($res, "$desc: res tainted");
- is_tainted($one, "$desc: \$1 tainted");
- is($s, 'abcd', "$desc: s value");
- is($res, 'xyz', "$desc: res value");
- is($one, 'abcd', "$desc: \$1 value");
+ $desc = "substitution /r with pattern tainted via locale";
+ $s = 'abcd';
+ {
+ BEGIN {
+ if($Config{d_setlocale}) {
+ require locale; import locale;
+ }
+ }
+ $res = $s =~ s/(\w+)/xyz/r; $one = $1;
+ }
+ isnt_tainted($s, "$desc: s not tainted");
+ is_tainted($res, "$desc: res tainted");
+ is_tainted($one, "$desc: \$1 tainted");
+ is($s, 'abcd', "$desc: s value");
+ is($res, 'xyz', "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+ }
+
$desc = "substitution with replacement tainted";
$s = 'abcd';
@@ -576,7 +622,7 @@
$one = $1;
}
is_tainted($s, "$desc: s tainted");
- is_tainted($res, "$desc: res tainted");
+ isnt_tainted($res, "$desc: res tainted");
isnt_tainted($one, "$desc: \$1 not tainted");
is($s, '123', "$desc: s value");
is($res, 3, "$desc: res value");
@@ -667,26 +713,44 @@
is($res, 1, "$desc: res value");
is($one, 'a', "$desc: \$1 value");
- $desc = "use re 'taint': match with pattern tainted via locale";
+ SKIP: {
+ skip 'No locale testing without d_setlocale', 10 if(!$Config{d_setlocale});
- $s = 'abcd';
- { use locale; $res = $s =~ /(\w+)/; $one = $1; }
- isnt_tainted($s, "$desc: s not tainted");
- isnt_tainted($res, "$desc: res not tainted");
- is_tainted($one, "$desc: \$1 tainted");
- is($res, 1, "$desc: res value");
- is($one, 'abcd', "$desc: \$1 value");
+ $desc = "use re 'taint': match with pattern tainted via locale";
- $desc = "use re 'taint': match /g with pattern tainted via locale";
+ $s = 'abcd';
+ {
+ BEGIN {
+ if($Config{d_setlocale}) {
+ require locale; import locale;
+ }
+ }
+ $res = $s =~ /(\w+)/; $one = $1;
+ }
+ isnt_tainted($s, "$desc: s not tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ is_tainted($one, "$desc: \$1 tainted");
+ is($res, 1, "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
- $s = 'abcd';
- { use locale; $res = $s =~ /(\w)/g; $one = $1; }
- isnt_tainted($s, "$desc: s not tainted");
- isnt_tainted($res, "$desc: res not tainted");
- is_tainted($one, "$desc: \$1 tainted");
- is($res, 1, "$desc: res value");
- is($one, 'a', "$desc: \$1 value");
+ $desc = "use re 'taint': match /g with pattern tainted via locale";
+ $s = 'abcd';
+ {
+ BEGIN {
+ if($Config{d_setlocale}) {
+ require locale; import locale;
+ }
+ }
+ $res = $s =~ /(\w)/g; $one = $1;
+ }
+ isnt_tainted($s, "$desc: s not tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ is_tainted($one, "$desc: \$1 tainted");
+ is($res, 1, "$desc: res value");
+ is($one, 'a', "$desc: \$1 value");
+ }
+
$desc = "use re 'taint': match with pattern tainted, list cxt";
$s = 'abcd';
@@ -710,28 +774,46 @@
is($res2,'b', "$desc: res2 value");
is($one, 'd', "$desc: \$1 value");
- $desc = "use re 'taint': match with pattern tainted via locale, list cxt";
+ SKIP: {
+ skip 'No locale testing without d_setlocale', 12 if(!$Config{d_setlocale});
- $s = 'abcd';
- { use locale; ($res) = $s =~ /(\w+)/; $one = $1; }
- isnt_tainted($s, "$desc: s not tainted");
- is_tainted($res, "$desc: res tainted");
- is_tainted($one, "$desc: \$1 tainted");
- is($res, 'abcd', "$desc: res value");
- is($one, 'abcd', "$desc: \$1 value");
+ $desc = "use re 'taint': match with pattern tainted via locale, list cxt";
- $desc = "use re 'taint': match /g with pattern tainted via locale, list cxt";
+ $s = 'abcd';
+ {
+ BEGIN {
+ if($Config{d_setlocale}) {
+ require locale; import locale;
+ }
+ }
+ ($res) = $s =~ /(\w+)/; $one = $1;
+ }
+ isnt_tainted($s, "$desc: s not tainted");
+ is_tainted($res, "$desc: res tainted");
+ is_tainted($one, "$desc: \$1 tainted");
+ is($res, 'abcd', "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
- $s = 'abcd';
- { use locale; ($res, $res2) = $s =~ /(\w)/g; $one = $1; }
- isnt_tainted($s, "$desc: s not tainted");
- is_tainted($res, "$desc: res tainted");
- is_tainted($res2, "$desc: res2 tainted");
- is_tainted($one, "$desc: \$1 tainted");
- is($res, 'a', "$desc: res value");
- is($res2,'b', "$desc: res2 value");
- is($one, 'd', "$desc: \$1 value");
+ $desc = "use re 'taint': match /g with pattern tainted via locale, list cxt";
+ $s = 'abcd';
+ {
+ BEGIN {
+ if($Config{d_setlocale}) {
+ require locale; import locale;
+ }
+ }
+ ($res, $res2) = $s =~ /(\w)/g; $one = $1;
+ }
+ isnt_tainted($s, "$desc: s not tainted");
+ is_tainted($res, "$desc: res tainted");
+ is_tainted($res2, "$desc: res2 tainted");
+ is_tainted($one, "$desc: \$1 tainted");
+ is($res, 'a', "$desc: res value");
+ is($res2,'b', "$desc: res2 value");
+ is($one, 'd', "$desc: \$1 value");
+ }
+
$desc = "use re 'taint': substitution with string tainted";
$s = 'abcd' . $TAINT;
@@ -853,39 +935,64 @@
is($res, 'xyz', "$desc: res value");
is($one, 'abcd', "$desc: \$1 value");
- $desc = "use re 'taint': substitution with pattern tainted via locale";
+ SKIP: {
+ skip 'No locale testing without d_setlocale', 18 if(!$Config{d_setlocale});
- $s = 'abcd';
- { use locale; $res = $s =~ s/(\w+)/xyz/; $one = $1; }
- is_tainted($s, "$desc: s tainted");
- isnt_tainted($res, "$desc: res not tainted");
- is_tainted($one, "$desc: \$1 tainted");
- is($s, 'xyz', "$desc: s value");
- is($res, 1, "$desc: res value");
- is($one, 'abcd', "$desc: \$1 value");
+ $desc = "use re 'taint': substitution with pattern tainted via locale";
- $desc = "use re 'taint': substitution /g with pattern tainted via locale";
+ $s = 'abcd';
+ {
+ BEGIN {
+ if($Config{d_setlocale}) {
+ require locale; import locale;
+ }
+ }
+ $res = $s =~ s/(\w+)/xyz/; $one = $1;
+ }
+ is_tainted($s, "$desc: s tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ is_tainted($one, "$desc: \$1 tainted");
+ is($s, 'xyz', "$desc: s value");
+ is($res, 1, "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
- $s = 'abcd';
- { use locale; $res = $s =~ s/(\w)/x/g; $one = $1; }
- is_tainted($s, "$desc: s tainted");
- is_tainted($res, "$desc: res tainted");
- is_tainted($one, "$desc: \$1 tainted");
- is($s, 'xxxx', "$desc: s value");
- is($res, 4, "$desc: res value");
- is($one, 'd', "$desc: \$1 value");
+ $desc = "use re 'taint': substitution /g with pattern tainted via locale";
- $desc = "use re 'taint': substitution /r with pattern tainted via locale";
+ $s = 'abcd';
+ {
+ BEGIN {
+ if($Config{d_setlocale}) {
+ require locale; import locale;
+ }
+ }
+ $res = $s =~ s/(\w)/x/g; $one = $1;
+ }
+ is_tainted($s, "$desc: s tainted");
+ is_tainted($res, "$desc: res tainted");
+ is_tainted($one, "$desc: \$1 tainted");
+ is($s, 'xxxx', "$desc: s value");
+ is($res, 4, "$desc: res value");
+ is($one, 'd', "$desc: \$1 value");
- $s = 'abcd';
- { use locale; $res = $s =~ s/(\w+)/xyz/r; $one = $1; }
- isnt_tainted($s, "$desc: s not tainted");
- is_tainted($res, "$desc: res tainted");
- is_tainted($one, "$desc: \$1 tainted");
- is($s, 'abcd', "$desc: s value");
- is($res, 'xyz', "$desc: res value");
- is($one, 'abcd', "$desc: \$1 value");
+ $desc = "use re 'taint': substitution /r with pattern tainted via locale";
+ $s = 'abcd';
+ {
+ BEGIN {
+ if($Config{d_setlocale}) {
+ require locale; import locale;
+ }
+ }
+ $res = $s =~ s/(\w+)/xyz/r; $one = $1;
+ }
+ isnt_tainted($s, "$desc: s not tainted");
+ is_tainted($res, "$desc: res tainted");
+ is_tainted($one, "$desc: \$1 tainted");
+ is($s, 'abcd', "$desc: s value");
+ is($res, 'xyz', "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+ }
+
$desc = "use re 'taint': substitution with replacement tainted";
$s = 'abcd';
@@ -933,7 +1040,7 @@
$one = $1;
}
is_tainted($s, "$desc: s tainted");
- is_tainted($res, "$desc: res tainted");
+ isnt_tainted($res, "$desc: res tainted");
isnt_tainted($one, "$desc: \$1 not tainted");
is($s, '123', "$desc: s value");
is($res, 3, "$desc: res value");
@@ -1645,6 +1752,14 @@
($r = $TAINT) =~ /($TAINT)/;
is_tainted($1);
+ {
+ use re 'eval'; # this shouldn't make any difference
+ ($r = $TAINT) =~ /($notaint)/;
+ isnt_tainted($1);
+ ($r = $TAINT) =~ /($TAINT)/;
+ is_tainted($1);
+ }
+
# [perl #24674]
# accessing $^O shoudn't taint it as a side-effect;
# assigning tainted data to it is now an error
@@ -2057,10 +2172,7 @@
formline('@' .('<'*5) . ' | @*', 'hallo', 'welt');
isnt_tainted($^A, "accumulator still untainted");
formline('@' .('<'*(5+$TAINT0)) . ' | @*', 'hallo', 'welt');
- TODO: {
- local $::TODO = "get magic handled too late?";
- is_tainted($^A, "the accumulator should be tainted already");
- }
+ is_tainted($^A, "the accumulator should be tainted already");
is_tainted($^A, "tainted formline picture makes a tainted accumulator");
}
@@ -2127,7 +2239,7 @@
ok("A" =~ /\p{$prop}/, "user-defined property: non-tainted case");
$prop = "IsA$TAINT";
eval { "A" =~ /\p{$prop}/};
- like($@, qr/Insecure user-defined property \\p{main::IsA}/,
+ like($@, qr/Insecure user-defined property \\p\{main::IsA}/,
"user-defined property: tainted case");
}
@@ -2144,6 +2256,101 @@
is_tainted $dest, "ucfirst(tainted) taints its return value";
}
+{
+ # Taintedness of values returned from given()
+ use feature 'switch';
+ no warnings 'experimental::smartmatch';
+
+ my @descriptions = ('when', 'given end', 'default');
+
+ for (qw<x y z>) {
+ my $letter = "$_$TAINT";
+
+ my $desc = "tainted value returned from " . shift(@descriptions);
+
+ my $res = do {
+ given ($_) {
+ when ('x') { $letter }
+ when ('y') { goto leavegiven }
+ default { $letter }
+ leavegiven: $letter
+ }
+ };
+ is $res, $letter, "$desc is correct";
+ is_tainted $res, "$desc stays tainted";
+ }
+}
+
+
+# tainted constants and index()
+# RT 64804; http://bugs.debian.org/291450
+{
+ ok(tainted $old_env_path, "initial taintedness");
+ BEGIN { no strict 'refs'; my $v = $old_env_path; *{"::C"} = sub () { $v }; }
+ ok(tainted C, "constant is tainted properly");
+ ok(!tainted "", "tainting not broken yet");
+ index(undef, C);
+ ok(!tainted "", "tainting still works after index() of the constant");
+}
+
+# Tainted values with smartmatch
+# [perl #93590] S_do_smartmatch stealing its own string buffers
+{
+no warnings 'experimental::smartmatch';
+ok "M$TAINT" ~~ ['m', 'M'], '$tainted ~~ ["whatever", "match"]';
+ok !("M$TAINT" ~~ ['m', undef]), '$tainted ~~ ["whatever", undef]';
+}
+
+# Tainted values and ref()
+for(1,2) {
+ my $x = bless \"M$TAINT", ref(bless[], "main");
+}
+pass("no death when TARG of ref is tainted");
+
+# $$ should not be tainted by being read in a tainted expression.
+{
+ isnt_tainted $$, "PID not tainted initially";
+ my $x = $ENV{PATH}.$$;
+ isnt_tainted $$, "PID not tainted when read in tainted expression";
+}
+
+SKIP: {
+ skip 'No locale testing without d_setlocale', 4 if(!$Config{d_setlocale});
+
+ use feature 'fc';
+ BEGIN {
+ if($Config{d_setlocale}) {
+ require locale; import locale;
+ }
+ }
+ my ($latin1, $utf8) = ("\xDF") x 2;
+ utf8::downgrade($latin1);
+ utf8::upgrade($utf8);
+
+ is_tainted fc($latin1), "under locale, lc(latin1) taints the result";
+ is_tainted fc($utf8), "under locale, lc(utf8) taints the result";
+
+ is_tainted "\F$latin1", "under locale, \\Flatin1 taints the result";
+ is_tainted "\F$utf8", "under locale, \\Futf8 taints the result";
+}
+
+{ # 111654
+ eval {
+ eval { die "Test\n".substr($ENV{PATH}, 0, 0); };
+ die;
+ };
+ like($@, qr/^Test\n\t\.\.\.propagated at /, "error should be propagated");
+}
+
+# tainted run-time (?{}) should die
+
+{
+ my $code = '(?{})' . $TAINT;
+ use re 'eval';
+ eval { "a" =~ /$code/ };
+ like($@, qr/Eval-group in insecure regular expression/, "tainted (?{})");
+}
+
# This may bomb out with the alarm signal so keep it last
SKIP: {
skip "No alarm()" unless $Config{d_alarm};
Property changes on: trunk/contrib/perl/t/op/taint.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/t/op/threads-dirh.t
===================================================================
--- trunk/contrib/perl/t/op/threads-dirh.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/threads-dirh.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/threads-dirh.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/threads.t
===================================================================
--- trunk/contrib/perl/t/op/threads.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/threads.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -9,7 +9,7 @@
skip_all_without_config('useithreads');
skip_all_if_miniperl("no dynamic loading on miniperl, no threads");
- plan(24);
+ plan(26);
}
use strict;
@@ -135,6 +135,7 @@
#
# run-time usage of newCONSTSUB (as done by the IO boot code) wasn't
# thread-safe - got occasional coredumps or malloc corruption
+watchdog(60, "process");
{
local $SIG{__WARN__} = sub {}; # Ignore any thread creation failure warnings
my @t;
@@ -160,7 +161,7 @@
# the seen_evals field of a regexp was getting zeroed on clone, so
# within a thread it didn't know that a regex object contained a 'safe'
-# re_eval expression, so it later died with 'Eval-group not allowed' when
+# code expression, so it later died with 'Eval-group not allowed' when
# you tried to interpolate the object
sub safe_re {
@@ -342,8 +343,40 @@
EOI
+# make sure peephole optimiser doesn't recurse heavily.
+# (We run this inside a thread to get a small stack)
+
+{
+ # lots of constructs that have o->op_other etc
+ my $code = <<'EOF';
+ $r = $x || $y;
+ $x ||= $y;
+ $r = $x // $y;
+ $x //= $y;
+ $r = $x && $y;
+ $x &&= $y;
+ $r = $x ? $y : $z;
+ @a = map $x+1, @a;
+ @a = grep $x+1, @a;
+ $r = /$x/../$y/;
+
+ # this one will fail since we removed tail recursion optimisation
+ # with f11ca51e41e8
+ #while (1) { $x = 0 };
+
+ while (0) { $x = 0 };
+ for ($x=0; $y; $z=0) { $r = 0 };
+ for (1) { $x = 0 };
+ { $x = 0 };
+ $x =~ s/a/$x + 1/e;
+EOF
+ $code = 'my ($r, $x,$y,$z, at a); return 5; ' . ($code x 1000);
+ my $res = threads->create(sub { eval $code})->join;
+ is($res, 5, "avoid peephole recursion");
+}
+
+
# [perl #78494] Pipes shared between threads block when closed
-watchdog 10;
{
my $perl = which_perl;
$perl = qq'"$perl"' if $perl =~ /\s/;
@@ -352,4 +385,10 @@
ok(1, "Pipes shared between threads do not block when closed");
}
+# [perl #105208] Typeglob clones should not be cloned again during a join
+{
+ threads->create(sub { sub { $::hypogamma = 3 } })->join->();
+ is $::hypogamma, 3, 'globs cloned and joined are not recloned';
+}
+
# EOF
Property changes on: trunk/contrib/perl/t/op/threads.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/t/op/threads_create.pl
===================================================================
--- trunk/contrib/perl/t/op/threads_create.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/threads_create.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/threads_create.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/tie.t
===================================================================
--- trunk/contrib/perl/t/op/tie.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/tie.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -273,12 +273,13 @@
0
########
#
-# FETCH freeing tie'd SV
+# FETCH freeing tie'd SV still works
sub TIESCALAR { bless [] }
-sub FETCH { *a = \1; 1 }
+sub FETCH { *a = \1; 2 }
tie $a, 'main';
print $a;
EXPECT
+2
########
# [20020716.007] - nested FETCHES
@@ -925,29 +926,6 @@
EXPECT
Can't locate object method "TIEARRAY" via package "FOO" at - line 5.
########
-
-# Deprecation warnings for tie $handle
-
-use warnings 'deprecated';
-$SIG{__WARN__} = sub { $w = shift };
-$handle = *foo;
-eval { tie $handle, "" };
-print $w =~ /^Use of tie on a handle without \* is deprecated/
- ? "ok tie\n" : "$w\n";
-$handle = *bar;
-tied $handle;
-print $w =~ /^Use of tied on a handle without \* is deprecated/
- ? "ok tied\n" : "$w\n";
-$handle = *baz;
-untie $handle;
-print $w =~ /^Use of untie on a handle without \* is deprecated/
- ? "ok untie\n" : "$w\n";
-
-EXPECT
-ok tie
-ok tied
-ok untie
-########
#
# STORE freeing tie'd AV
sub TIEARRAY { bless [] }
@@ -1030,3 +1008,327 @@
print "ok\n";
EXPECT
ok
+########
+#
+# Nor should it be impossible to tie COW scalars that are already PVMGs.
+
+sub TIESCALAR { bless [] }
+$x = *foo; # PVGV
+undef $x; # downgrade to PVMG
+$x = __PACKAGE__; # PVMG + COW
+tie $x, ""; # bang!
+
+print STDERR "ok\n";
+
+# However, one should not be able to tie read-only glob copies, which look
+# a bit like kine internally (FAKE + READONLY).
+$y = *foo;
+Internals::SvREADONLY($y,1);
+tie $y, "";
+
+EXPECT
+ok
+Modification of a read-only value attempted at - line 16.
+########
+
+# Similarly, read-only regexps cannot be tied.
+sub TIESCALAR { bless [] }
+$y = ${qr//};
+Internals::SvREADONLY($y,1);
+tie $y, "";
+
+EXPECT
+Modification of a read-only value attempted at - line 6.
+########
+
+# tied() should still work on tied scalars after glob assignment
+sub TIESCALAR {bless[]}
+sub FETCH {*foo}
+sub f::TIEHANDLE{bless[],f}
+tie *foo, "f";
+tie $rin, "";
+[$rin]; # call FETCH
+print ref tied $rin, "\n";
+print ref tied *$rin, "\n";
+EXPECT
+main
+f
+########
+
+# (un)tie $glob_copy vs (un)tie *$glob_copy
+sub TIESCALAR { print "TIESCALAR\n"; bless [] }
+sub TIEHANDLE{ print "TIEHANDLE\n"; bless [] }
+sub FETCH { print "never called\n" }
+$f = *foo;
+tie *$f, "";
+tie $f, "";
+untie $f;
+print "ok 1\n" if !tied $f;
+() = $f; # should not call FETCH
+untie *$f;
+print "ok 2\n" if !tied *foo;
+EXPECT
+TIEHANDLE
+TIESCALAR
+ok 1
+ok 2
+########
+
+# RT #8611 mustn't goto outside the magic stack
+sub TIESCALAR { warn "tiescalar\n"; bless [] }
+sub FETCH { warn "fetch()\n"; goto FOO; }
+tie $f, "";
+warn "before fetch\n";
+my $a = "$f";
+warn "before FOO\n";
+FOO:
+warn "after FOO\n";
+EXPECT
+tiescalar
+before fetch
+fetch()
+Can't find label FOO at - line 4.
+########
+
+# RT #8611 mustn't goto outside the magic stack
+sub TIEHANDLE { warn "tiehandle\n"; bless [] }
+sub PRINT { warn "print()\n"; goto FOO; }
+tie *F, "";
+warn "before print\n";
+print F "abc";
+warn "before FOO\n";
+FOO:
+warn "after FOO\n";
+EXPECT
+tiehandle
+before print
+print()
+Can't find label FOO at - line 4.
+########
+
+# \&$tied with $tied holding a reference before the fetch (but not after)
+sub ::72 { 73 };
+sub TIESCALAR {bless[]}
+sub STORE{}
+sub FETCH { 72 }
+tie my $x, "main";
+$x = \$y;
+\&$x;
+print "ok\n";
+EXPECT
+ok
+########
+
+# \&$tied with $tied holding a PVLV glob before the fetch (but not after)
+sub ::72 { 73 };
+sub TIEARRAY {bless[]}
+sub STORE{}
+sub FETCH { 72 }
+tie my @x, "main";
+my $elem = \$x[0];
+$$elem = *bar;
+print &{\&$$elem}, "\n";
+EXPECT
+73
+########
+
+# \&$tied with $tied holding a PVGV glob before the fetch (but not after)
+local *72 = sub { 73 };
+sub TIESCALAR {bless[]}
+sub STORE{}
+sub FETCH { 72 }
+tie my $x, "main";
+$x = *bar;
+print &{\&$x}, "\n";
+EXPECT
+73
+########
+
+# Lexicals should not be visible to magic methods on scope exit
+BEGIN { unless (defined &DynaLoader::boot_DynaLoader) {
+ print "HASH\nHASH\nARRAY\nARRAY\n"; exit;
+}}
+use Scalar::Util 'weaken';
+{ package xoufghd;
+ sub TIEHASH { Scalar::Util::weaken($_[1]); bless \$_[1], xoufghd:: }
+ *TIEARRAY = *TIEHASH;
+ DESTROY {
+ bless ${$_[0]} || return, 0;
+} }
+for my $sub (
+ # hashes: ties before backrefs
+ sub {
+ my %hash;
+ $ref = ref \%hash;
+ tie %hash, xoufghd::, \%hash;
+ 1;
+ },
+ # hashes: backrefs before ties
+ sub {
+ my %hash;
+ $ref = ref \%hash;
+ weaken(my $x = \%hash);
+ tie %hash, xoufghd::, \%hash;
+ 1;
+ },
+ # arrays: ties before backrefs
+ sub {
+ my @array;
+ $ref = ref \@array;
+ tie @array, xoufghd::, \@array;
+ 1;
+ },
+ # arrays: backrefs before ties
+ sub {
+ my @array;
+ $ref = ref \@array;
+ weaken(my $x = \@array);
+ tie @array, xoufghd::, \@array;
+ 1;
+ },
+) {
+ &$sub;
+ &$sub;
+ print $ref, "\n";
+}
+EXPECT
+HASH
+HASH
+ARRAY
+ARRAY
+########
+
+# Localising a tied variable with a typeglob in it should copy magic
+sub TIESCALAR{bless[]}
+sub FETCH{warn "fetching\n"; *foo}
+sub STORE{}
+tie $x, "";
+local $x;
+warn "before";
+"$x";
+warn "after";
+EXPECT
+fetching
+before at - line 8.
+fetching
+after at - line 10.
+########
+
+# tied returns same value as tie
+sub TIESCALAR{bless[]}
+$tyre = \tie $tied, "";
+print "ok\n" if \tied $tied == $tyre;
+EXPECT
+ok
+########
+
+# tied arrays should always be AvREAL
+$^W=1;
+sub TIEARRAY{bless[]}
+sub {
+ tie @_, "";
+ \@_; # used to produce: av_reify called on tied array at - line 7.
+}->(1);
+EXPECT
+########
+
+# [perl #67490] scalar-tying elements of magic hashes
+sub TIESCALAR{bless[]}
+sub STORE{}
+tie $ENV{foo}, '';
+$ENV{foo} = 78;
+delete $ENV{foo};
+tie $^H{foo}, '';
+$^H{foo} = 78;
+delete $^H{foo};
+EXPECT
+########
+
+# [perl #35865, #43011] autovivification should call FETCH after STORE
+# because perl does not know that the FETCH would have returned the same
+# thing that was just stored.
+
+# This package never likes to take ownership of other people’s refs. It
+# always makes its own copies. (For simplicity, it only accepts hashes.)
+package copier {
+ sub TIEHASH { bless {} }
+ sub FETCH { $_[0]{$_[1]} }
+ sub STORE { $_[0]{$_[1]} = { %{ $_[2] } } }
+}
+tie my %h, copier::;
+$h{i}{j} = 'k';
+print $h{i}{j}, "\n";
+EXPECT
+k
+########
+
+# [perl #8931] FETCH for tied $" called an odd number of times.
+use strict;
+my $i = 0;
+sub A::TIESCALAR {bless [] => 'A'}
+sub A::FETCH {print ++ $i, "\n"}
+my @a = ("", "", "");
+
+tie $" => 'A';
+"@a";
+
+$i = 0;
+tie my $a => 'A';
+join $a, 1..10;
+EXPECT
+1
+1
+########
+
+# [perl #9391] return value from 'tied' not discarded soon enough
+use warnings;
+tie @a, 'T';
+if (tied @a) {
+untie @a;
+}
+
+sub T::TIEARRAY { my $s; bless \$s => "T" }
+EXPECT
+########
+
+# NAME Test that tying a hash does not leak a deleted iterator
+# This produced unbalanced string table warnings under
+# PERL_DESTRUCT_LEVEL=2.
+package l {
+ sub TIEHASH{bless[]}
+}
+$h = {foo=>0};
+each %$h;
+delete $$h{foo};
+tie %$h, 'l';
+EXPECT
+########
+
+# NAME EXISTS on arrays
+sub TIEARRAY{bless[]};
+sub FETCHSIZE { 50 }
+sub EXISTS { print "does $_[1] exist?\n" }
+tie @a, "";
+exists $a[1];
+exists $a[-1];
+$NEGATIVE_INDICES=1;
+exists $a[-1];
+EXPECT
+does 1 exist?
+does 49 exist?
+does -1 exist?
+########
+
+# Crash when using negative index on array tied to non-object
+sub TIEARRAY{bless[]};
+${\tie @a, ""} = undef;
+eval { $_ = $a[-1] }; print $@;
+eval { $a[-1] = '' }; print $@;
+eval { delete $a[-1] }; print $@;
+eval { exists $a[-1] }; print $@;
+
+EXPECT
+Can't call method "FETCHSIZE" on an undefined value at - line 5.
+Can't call method "FETCHSIZE" on an undefined value at - line 6.
+Can't call method "FETCHSIZE" on an undefined value at - line 7.
+Can't call method "FETCHSIZE" on an undefined value at - line 8.
Property changes on: trunk/contrib/perl/t/op/tie.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/tie_fetch_count.t
===================================================================
--- trunk/contrib/perl/t/op/tie_fetch_count.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/tie_fetch_count.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -7,7 +7,7 @@
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
- plan (tests => 210);
+ plan (tests => 312);
}
use strict;
@@ -28,6 +28,7 @@
sub check_count {
my $op = shift;
my $expected = shift() // 1;
+ local $::Level = $::Level + 1;
is $count, $expected,
"FETCH called " . (
$expected == 1 ? "just once" :
@@ -43,6 +44,7 @@
# Assignment.
$dummy = $var ; check_count "=";
+*dummy = $var ; check_count '*glob = $tied';
# Unary +/-
$dummy = +$var ; check_count "unary +";
@@ -60,6 +62,11 @@
$dummy = $var x 1 ; check_count 'x';
@dummy = ($var) x 1 ; check_count 'x';
$dummy = $var . 1 ; check_count '.';
+ at dummy = $var .. 1 ; check_count '$tied..1';
+ at dummy = 1 .. $var; check_count '1..$tied';
+tie my $v42 => 'main', "z";
+ at dummy = $v42 .. "a"; check_count '$tied.."a"';
+ at dummy = "a" .. $v42; check_count '"a"..$tied';
# Pre/post in/decrement
$var ++ ; check_count 'post ++';
@@ -114,43 +121,43 @@
# Readline/glob
tie my $var0, "main", \*DATA;
$dummy = <$var0> ; check_count '<readline>';
-$dummy = <${var}> ; check_count '<glob>';
+$var = \1;
+$var .= <DATA> ; check_count '$tiedref .= <rcatline>';
+$var = "tied";
+$var .= <DATA> ; check_count '$tiedstr .= <rcatline>';
+$var = *foo;
+$var .= <DATA> ; check_count '$tiedglob .= <rcatline>';
+{ no warnings "glob";
+ $dummy = <${var}> ; check_count '<glob>';
+}
# File operators
-$dummy = -r $var ; check_count '-r';
-$dummy = -w $var ; check_count '-w';
-$dummy = -x $var ; check_count '-x';
-$dummy = -o $var ; check_count '-o';
-$dummy = -R $var ; check_count '-R';
-$dummy = -W $var ; check_count '-W';
-$dummy = -X $var ; check_count '-X';
-$dummy = -O $var ; check_count '-O';
-$dummy = -e $var ; check_count '-e';
-$dummy = -z $var ; check_count '-z';
-$dummy = -s $var ; check_count '-s';
-$dummy = -f $var ; check_count '-f';
-$dummy = -d $var ; check_count '-d';
+for (split //, 'rwxoRWXOezsfdpSbctugkTBMAC') {
+ no warnings 'unopened';
+ $dummy = eval "-$_ \$var"; check_count "-$_";
+ # Make $var hold a glob:
+ $var = *dummy; $dummy = $var; $count = 0;
+ $dummy = eval "-$_ \$var"; check_count "-$_ \$tied_glob";
+ next if /[guk]/;
+ $var = *dummy; $dummy = $var; $count = 0;
+ eval "\$dummy = -$_ \\\$var";
+ check_count "-$_ \\\$tied_glob";
+}
$dummy = -l $var ; check_count '-l';
-$dummy = -p $var ; check_count '-p';
-$dummy = -S $var ; check_count '-S';
-$dummy = -b $var ; check_count '-b';
-$dummy = -c $var ; check_count '-c';
-$dummy = -t $var ; check_count '-t';
-$dummy = -u $var ; check_count '-u';
-$dummy = -g $var ; check_count '-g';
-$dummy = -k $var ; check_count '-k';
-$dummy = -T $var ; check_count '-T';
-$dummy = -B $var ; check_count '-B';
-$dummy = -M $var ; check_count '-M';
-$dummy = -A $var ; check_count '-A';
-$dummy = -C $var ; check_count '-C';
+$var = "test.pl";
+$dummy = -e -e -e $var ; check_count '-e -e';
# Matching
$_ = "foo";
$dummy = $var =~ m/ / ; check_count 'm//';
$dummy = $var =~ s/ //; check_count 's///';
-$dummy = $var ~~ 1 ; check_count '~~';
+{
+ no warnings 'experimental::smartmatch';
+ $dummy = $var ~~ 1 ; check_count '~~';
+}
$dummy = $var =~ y/ //; check_count 'y///';
+ $var = \1;
+$dummy = $var =~y/ /-/; check_count '$ref =~ y///';
/$var/ ; check_count 'm/pattern/';
/$var foo/ ; check_count 'm/$tied foo/';
s/$var// ; check_count 's/pattern//';
@@ -168,7 +175,7 @@
$dummy = keys $var3 ; check_count 'keys hashref';
{
no strict 'refs';
- tie my $var4 => 'main', **;
+ tie my $var4 => 'main', *];
$dummy = *$var4 ; check_count '*{}';
}
@@ -175,7 +182,104 @@
tie my $var5 => 'main', sub {1};
$dummy = &$var5 ; check_count '&{}';
+{
+ no strict 'refs';
+ tie my $var1 => 'main', 1;
+ $dummy = $$var1 ; check_count 'symbolic ${}';
+ $dummy = @$var1 ; check_count 'symbolic @{}';
+ $dummy = %$var1 ; check_count 'symbolic %{}';
+ $dummy = *$var1 ; check_count 'symbolic *{}';
+ local *1 = sub{};
+ $dummy = &$var1 ; check_count 'symbolic &{}';
+ # This test will not be a complete test if *988 has been created
+ # already. If this dies, change it to use another built-in variable.
+ # In 5.10-14, rv2gv calls get-magic more times for built-in vars, which
+ # is why we need the test this way.
+ if (exists $::{988}) {
+ die "*988 already exists. Please adjust this test"
+ }
+ tie my $var6 => main => 988;
+ no warnings;
+ readdir $var6 ; check_count 'symbolic readdir';
+ if (exists $::{973}) { # Need a different variable here
+ die "*973 already exists. Please adjust this test"
+ }
+ tie my $var7 => main => 973;
+ defined $$var7 ; check_count 'symbolic defined ${}';
+}
+
+tie my $var8 => 'main', 'main';
+sub bolgy {}
+$var8->bolgy ; check_count '->method';
+{
+ no warnings 'once';
+ () = *swibble;
+ # This must be the name of an existing glob to trigger the maximum
+ # number of fetches in 5.14:
+ tie my $var9 => 'main', 'swibble';
+ no strict 'refs';
+ use constant glumscrin => 'shreggleboughet';
+ *$var9 = \&{"glumscrin"}; check_count '*$tied = \&{"name of const"}';
+}
+
+# Functions that operate on filenames or filehandles
+for ([chdir=>''],[chmod=>'0,'],[chown=>'0,0,'],[utime=>'0,0,'],
+ [truncate=>'',',0'],[stat=>''],[lstat=>''],[open=>'my $fh,"<&",'],
+ ['()=sort'=>'',' 1,2,3']) {
+ my($op,$args,$postargs) = @$_; $postargs //= '';
+ # This line makes $var8 hold a glob:
+ $var8 = *dummy; $dummy = $var8; $count = 0;
+ eval "$op $args \$var8 $postargs";
+ check_count "$op $args\$tied_glob$postargs";
+ $var8 = *dummy; $dummy = $var8; $count = 0;
+ my $ref = \$var8;
+ eval "$op $args \$ref $postargs";
+ check_count "$op $args\\\$tied_glob$postargs";
+}
+
+{
+ no warnings;
+ $var = *foo;
+ $dummy = select $var, undef, undef, 0
+ ; check_count 'select $tied_glob, ...';
+ $var = \1;
+ $dummy = select $var, undef, undef, 0
+ ; check_count 'select $tied_ref, ...';
+ $var = undef;
+ $dummy = select $var, undef, undef, 0
+ ; check_count 'select $tied_undef, ...';
+}
+
+chop(my $u = "\xff\x{100}");
+tie $var, "main", $u;
+$dummy = pack "u", $var; check_count 'pack "u", $utf8';
+
+tie $var, "main", "\x{100}";
+pos$var = 0 ; check_count 'lvalue pos $utf8';
+$dummy=sprintf"%1s",$var; check_count 'sprintf "%1s", $utf8';
+$dummy=sprintf"%.1s",$var; check_count 'sprintf "%.1s", $utf8';
+$dummy = substr$var,0,1; check_count 'substr $utf8';
+my $l =\substr$var,0,1;
+$dummy = $$l ; check_count 'reading lvalue substr($utf8)';
+$$l = 0 ; check_count 'setting lvalue substr($utf8)';
+tie $var, "main", "a";
+$$l = "\x{100}" ; check_count 'assigning $utf8 to lvalue substr';
+tie $var1, "main", "a";
+substr$var1,0,0,"\x{100}"; check_count '4-arg substr with utf8 replacement';
+
+{
+ local $SIG{__WARN__} = sub {};
+ $dummy = warn $var ; check_count 'warn $tied';
+ tie $@, => 'main', 1;
+ $dummy = warn ; check_count 'warn() with $@ tied (num)';
+ tie $@, => 'main', \1;
+ $dummy = warn ; check_count 'warn() with $@ tied (ref)';
+ tie $@, => 'main', "foo\n";
+ $dummy = warn ; check_count 'warn() with $@ tied (str)';
+ untie $@;
+}
+
###############################################
# Tests for $foo binop $foo #
###############################################
Property changes on: trunk/contrib/perl/t/op/tie_fetch_count.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/op/tiearray.t
===================================================================
--- trunk/contrib/perl/t/op/tiearray.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/tiearray.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/tiearray.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/t/op/tiehandle.t
===================================================================
--- trunk/contrib/perl/t/op/tiehandle.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/tiehandle.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/tiehandle.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/t/op/time.t
===================================================================
--- trunk/contrib/perl/t/op/time.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/time.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/time.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/t/op/time_loop.t
===================================================================
--- trunk/contrib/perl/t/op/time_loop.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/time_loop.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/time_loop.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/tr.t
===================================================================
--- trunk/contrib/perl/t/op/tr.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/tr.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,5 +1,7 @@
# tr.t
+use utf8;
+
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
@@ -6,7 +8,7 @@
require './test.pl';
}
-plan tests => 128;
+plan tests => 132;
my $Is_EBCDIC = (ord('i') == 0x89 & ord('J') == 0xd1);
@@ -483,11 +485,13 @@
}
($s) = keys %{{pie => 3}};
-my $wasro = Internals::SvREADONLY($s);
-{
- $wasro or local $TODO = "didn't have a COW";
+SKIP: {
+ if (!eval { require XS::APItest }) { skip "no XS::APItest", 2 }
+ my $wasro = XS::APItest::SvIsCOW($s);
+ ok $wasro, "have a COW";
$s =~ tr/i//;
- ok( Internals::SvREADONLY($s), "count-only tr doesn't deCOW COWs" );
+ ok( XS::APItest::SvIsCOW($s),
+ "count-only tr doesn't deCOW COWs" );
}
# [ RT #61520 ]
@@ -504,4 +508,22 @@
is($x,"\x{143}", "utf8 + closure");
}
+# Freeing of trans ops prior to pmtrans() [perl #102858].
+eval q{ $a ~= tr/a/b/; };
+ok 1;
+SKIP: {
+ no warnings "deprecated";
+ skip "no encoding", 1 unless eval { require encoding; 1 };
+ eval q{ use encoding "utf8"; $a ~= tr/a/b/; };
+ ok 1;
+}
+{ # [perl #113584]
+
+ my $x = "Perlα";
+ $x =~ tr/αα/βγ/;
+ note $x;
+ is($x, "Perlβ", "Only first of multiple transliterations is used");
+}
+
+1;
Property changes on: trunk/contrib/perl/t/op/tr.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/t/op/turkish.t
===================================================================
--- trunk/contrib/perl/t/op/turkish.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/turkish.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/turkish.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/undef.t
===================================================================
--- trunk/contrib/perl/t/op/undef.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/undef.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -10,7 +10,7 @@
use vars qw(@ary %ary %hash);
-plan 40;
+plan 85;
ok !defined($a);
@@ -44,14 +44,17 @@
undef $ary{'foo'};
ok !defined($ary{'foo'});
-ok defined(@ary);
{
no warnings 'deprecated';
+ ok defined(@ary);
ok defined(%ary);
}
ok %ary;
undef @ary;
-ok !defined(@ary);
+{
+ no warnings 'deprecated';
+ ok !defined(@ary);
+}
undef %ary;
{
no warnings 'deprecated';
@@ -59,7 +62,10 @@
}
ok !%ary;
@ary = (1);
-ok defined @ary;
+{
+ no warnings 'deprecated';
+ ok defined @ary;
+}
%ary = (1,1);
{
no warnings 'deprecated';
@@ -107,19 +113,59 @@
# bugid 3096
# undefing a hash may free objects with destructors that then try to
-# modify the hash. To them, the hash should appear empty.
+# modify the hash. Ensure that the hash remains consistent
-%hash = (
- key1 => bless({}, 'X'),
- key2 => bless({}, 'X'),
-);
-undef %hash;
-sub X::DESTROY {
- is scalar keys %hash, 0;
- is scalar values %hash, 0;
- my @l = each %hash;
- is @l, 0;
- is delete $hash{'key2'}, undef;
+{
+ my (%hash, %mirror);
+
+ my $iters = 5;
+
+ for (1..$iters) {
+ $hash{"k$_"} = bless ["k$_"], 'X';
+ $mirror{"k$_"} = "k$_";
+ }
+
+
+ my $c = $iters;
+ my $events;
+
+ sub X::DESTROY {
+ my $key = $_[0][0];
+ $events .= 'D';
+ note("----- DELETE($key) ------");
+ delete $mirror{$key};
+
+ is join('-', sort keys %hash), join('-', sort keys %mirror),
+ "$key: keys";
+ is join('-', sort map $_->[0], values %hash),
+ join('-', sort values %mirror), "$key: values";
+
+ # don't know exactly what we'll get from the iterator, but
+ # it must be a sensible value
+ my ($k, $v) = each %hash;
+ ok defined $k ? exists($mirror{$k}) : (keys(%mirror) == 0),
+ "$key: each 1";
+
+ is delete $hash{$key}, undef, "$key: delete";
+ ($k, $v) = each %hash;
+ ok defined $k ? exists($mirror{$k}) : (keys(%mirror) <= 1),
+ "$key: each 2";
+
+ $c++;
+ if ($c <= $iters * 2) {
+ $hash{"k$c"} = bless ["k$c"], 'X';
+ $mirror{"k$c"} = "k$c";
+ }
+ $events .= 'E';
+ }
+
+ each %hash; # set eiter
+ undef %hash;
+
+ is scalar keys %hash, 0, "hash empty at end";
+ is $events, ('DE' x ($iters*2)), "events";
+ my ($k, $v) = each %hash;
+ is $k, undef, 'each undef at end';
}
# this will segfault if it fails
Property changes on: trunk/contrib/perl/t/op/undef.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/universal.t
===================================================================
--- trunk/contrib/perl/t/op/universal.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/universal.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -10,7 +10,7 @@
require "./test.pl";
}
-plan tests => 125;
+plan tests => 139;
$a = {};
bless $a, "Bob";
@@ -59,6 +59,8 @@
ok $a->isa("Female");
+ok ! $a->isa("Female\0NOT REALLY!"), "->isa is nul-clean.";
+
ok $a->isa("Human");
ok ! $a->isa("Male");
@@ -68,6 +70,7 @@
ok $a->isa("HASH");
ok $a->can("eat");
+ok ! $a->can("eat\0Except not!"), "->can is nul-clean.";
ok ! $a->can("sleep");
ok my $ref = $a->can("drink"); # returns a coderef
is $a->$ref("tea"), "drinking tea"; # ... which works
@@ -104,7 +107,10 @@
};
};
-ok ! UNIVERSAL::can(23, "can");
+ok UNIVERSAL::can(23, "can");
+++${"23::foo"};
+ok UNIVERSAL::can("23", "can"), '"23" can can when the pack exists';
+ok UNIVERSAL::can(23, "can"), '23 can can when the pack exists';
ok $a->can("VERSION");
@@ -119,6 +125,13 @@
ok (eval { $a->VERSION(2.718) });
is $@, '';
+ok ! (eval { $a->VERSION("version") });
+like $@, qr/^Invalid version format/;
+
+$aversion::VERSION = "version";
+ok ! (eval { aversion->VERSION(2.719) });
+like $@, qr/^Invalid version format/;
+
my $subs = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::;
## The test for import here is *not* because we want to ensure that UNIVERSAL
## can always import; it is an historical accident that UNIVERSAL can import.
@@ -154,7 +167,7 @@
eval 'sub UNIVERSAL::sleep {}';
ok $a->can("sleep");
-ok ! UNIVERSAL::can($b, "can");
+ok UNIVERSAL::can($b, "can");
ok ! $a->can("export_tags"); # a method in Exporter
@@ -162,6 +175,7 @@
{
package Pickup;
+ no warnings "deprecated";
use UNIVERSAL qw( isa can VERSION );
::ok isa "Pickup", UNIVERSAL;
@@ -220,6 +234,9 @@
ok( Baz->DOES( 'Baz' ), '... even without inheriting any other DOES()' );
ok( ! Baz->DOES( 'Foo' ), '... returning true or false appropriately' );
+ok( ! "T"->DOES( "T\0" ), 'DOES() is nul-clean' );
+ok( ! Baz->DOES( "Baz\0Boy howdy" ), 'DOES() is nul-clean' );
+
package Pig;
package Bodine;
Bodine->isa('Pig');
@@ -315,3 +332,10 @@
@RT66112::T6::ISA = qw/RT66112::E/;
ok(RT66112::T6->isa('RT66112::A'), "modify \@ISA in isa (RT66112::T6 isa RT66112::A)");
}
+
+ok(Undeclared->can("can"));
+sub Undeclared::foo { }
+ok(Undeclared->can("foo"));
+ok(!Undeclared->can("something_else"));
+
+ok(Undeclared->isa("UNIVERSAL"));
Property changes on: trunk/contrib/perl/t/op/universal.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Copied: trunk/contrib/perl/t/op/unlink.t (from rev 6437, vendor/perl/5.18.1/t/op/unlink.t)
===================================================================
--- trunk/contrib/perl/t/op/unlink.t (rev 0)
+++ trunk/contrib/perl/t/op/unlink.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,38 @@
+#!./perl
+
+BEGIN {
+ chdir 't';
+ @INC = '../lib';
+ require './test.pl';
+}
+
+plan 6;
+
+# Need to run this in a quiet private directory as it assumes that it can
+# reliably delete fixed file names.
+my $tempdir = tempfile;
+
+mkdir $tempdir, 0700 or die "Can't mkdir '$tempdir': $!";
+chdir $tempdir or die die "Can't chdir '$tempdir': $!";
+
+sub make_file {
+ my $file = shift;
+ open my $fh, ">", $file or die "Can't open $file: $!";
+ close $fh or die "Can't close $file: $!";
+}
+
+make_file('aaa');
+is unlink('aaa'), 1, 'retval of unlink with one file name';
+ok (!-e 'aaa', 'unlink unlinked it');
+make_file($_) for 'aaa', 'bbb';
+is unlink('aaa','bbb','ccc'), 2,
+ 'retval of unlink with list that includes nonexistent file';
+ok (!-e 'aaa' && !-e 'bbb', 'unlink unlank the files it claims it unlank');
+$_ = 'zzz';
+make_file 'zzz';
+is unlink, 1, 'retval of unlink with no args';
+ok !-e 'zzz', 'unlink with no arg unlinked $_';
+
+
+chdir '..' or die "Couldn't chdir .. for cleanup: $!";
+rmdir $tempdir or die "Couldn't unlink tempdir '$tempdir': $!";
Index: trunk/contrib/perl/t/op/unshift.t
===================================================================
--- trunk/contrib/perl/t/op/unshift.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/unshift.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/unshift.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/t/op/upgrade.t
===================================================================
--- trunk/contrib/perl/t/op/upgrade.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/upgrade.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/upgrade.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/utf8cache.t
===================================================================
--- trunk/contrib/perl/t/op/utf8cache.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/utf8cache.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -5,13 +5,15 @@
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
- skip_all_without_dynamic_extension('Devel::Peek');
}
use strict;
-plan(tests => 1);
+plan(tests => 15);
+SKIP: {
+skip_without_dynamic_extension("Devel::Peek");
+
my $pid = open CHILD, '-|';
die "kablam: $!\n" unless defined $pid;
unless ($pid) {
@@ -35,3 +37,127 @@
\s+ MG_LEN \s = .* \n }xm;
unlike($_, qr{ $utf8magic $utf8magic }x);
+
+} # SKIP
+
+# With bad caching, this code used to go quadratic and take 10s of minutes.
+# The 'test' in this case is simply that it doesn't hang.
+
+{
+ local ${^UTF8CACHE} = 1; # enable cache, disable debugging
+ my $x = "\x{100}" x 1000000;
+ while ($x =~ /./g) {
+ my $p = pos($x);
+ }
+ pass("quadratic pos");
+}
+
+# Get-magic can reallocate the PV. Check that the cache is reset in
+# such cases.
+
+# Regexp vars
+"\x{100}" =~ /(.+)/;
+() = substr $1, 0, 1;
+"a\x{100}" =~ /(.+)/;
+is ord substr($1, 1, 1), 0x100, 'get-magic resets utf8cache on match vars';
+
+# Substr lvalues
+my $x = "a\x{100}";
+my $l = \substr $x, 0;
+() = substr $$l, 1, 1;
+substr $x, 0, 1, = "\x{100}";
+is ord substr($$l, 1, 1), 0x100, 'get-magic resets utf8cache on LVALUEs';
+
+# defelem magic
+my %h;
+sub {
+ $_[0] = "a\x{100}";
+ () = ord substr $_[0], 1, 1;
+ $h{k} = "\x{100}"x2;
+ is ord substr($_[0], 1, 1), 0x100,
+ 'get-magic resets uf8cache on defelems';
+}->($h{k});
+
+
+# Overloading can also reallocate the PV.
+
+package UTF8Toggle {
+ use overload '""' => 'stringify', fallback => 1;
+
+ sub new {
+ my $class = shift;
+ my $value = shift;
+ my $state = shift||0;
+ return bless [$value, $state], $class;
+ }
+
+ sub stringify {
+ my $self = shift;
+ $self->[1] = ! $self->[1];
+ if ($self->[1]) {
+ utf8::downgrade($self->[0]);
+ } else {
+ utf8::upgrade($self->[0]);
+ }
+ $self->[0];
+ }
+}
+my $u = UTF8Toggle->new(" \x{c2}7 ");
+
+pos $u = 2;
+is pos $u, 2, 'pos on overloaded utf8 toggler';
+() = "$u"; # flip flag
+pos $u = 2;
+is pos $u, 2, 'pos on overloaded utf8 toggler (again)';
+
+() = ord ${\substr $u, 1};
+is ord ${\substr($u, 1)}, 0xc2,
+ 'utf8 cache + overloading does not confuse substr lvalues';
+() = "$u"; # flip flag
+() = ord substr $u, 1;
+is ord substr($u, 1), 0xc2,
+ 'utf8 cache + overloading does not confuse substr lvalues (again)';
+
+$u = UTF8Toggle->new(" \x{c2}7 ");
+() = ord ${\substr $u, 2};
+{ no warnings; ${\substr($u, 2, 1)} = 0; }
+is $u, " \x{c2}0 ",
+ 'utf8 cache + overloading does not confuse substr lvalue assignment';
+$u = UTF8Toggle->new(" \x{c2}7 ");
+() = "$u"; # flip flag
+() = ord ${\substr $u, 2};
+{ no warnings; ${\substr($u, 2, 1)} = 0; }
+is $u, " \x{c2}0 ",
+ 'utf8 cache + overload does not confuse substr lv assignment (again)';
+
+
+# Typeglobs and references should not get a cache
+use utf8;
+
+#substr
+my $globref = \*αabcdefg_::_;
+() = substr($$globref, 2, 3);
+*_abcdefgα:: = \%αabcdefg_::;
+undef %αabcdefg_::;
+{ no strict; () = *{"_abcdefgα::_"} }
+is substr($$globref, 2, 3), "abc", 'no utf8 pos cache on globs';
+
+my $ref = bless [], "αabcd_";
+() = substr($ref, 1, 3);
+bless $ref, "_abcdα";
+is substr($ref, 1, 3), "abc", 'no utf8 pos cache on references';
+
+#length
+$globref = \*αabcdefg_::_;
+() = "$$globref"; # turn utf8 flag on
+() = length($$globref);
+*_abcdefgα:: = \%αabcdefg_::;
+undef %αabcdefg_::;
+{ no strict; () = *{"_abcdefgα::_"} }
+is length($$globref), length("$$globref"), 'no utf8 length cache on globs';
+
+$ref = bless [], "αabcd_";
+() = "$ref"; # turn utf8 flag on
+() = length $ref;
+bless $ref, "α";
+is length $ref, length "$ref", 'no utf8 length cache on references';
Property changes on: trunk/contrib/perl/t/op/utf8cache.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/utf8decode.t
===================================================================
--- trunk/contrib/perl/t/op/utf8decode.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/utf8decode.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -135,7 +135,7 @@
3.3.9 n - 4 fb:bf:bf:bf - 4 bytes, need 5
3.3.10 n - 5 fd:bf:bf:bf:bf - 5 bytes, need 6
3.4 Concatenation of incomplete sequences
-3.4.1 N-10 - 30 c0:e0:80:f0:80:80:f8:80:80:80:fc:80:80:80:80:df:ef:bf:f7:bf:bf:fb:bf:bf:bf:fd:bf:bf:bf:bf - unexpected non-continuation byte 0xe0, immediately after start byte 0xc0
+3.4.1 N10 - 30 c0:e0:80:f0:80:80:f8:80:80:80:fc:80:80:80:80:df:ef:bf:f7:bf:bf:fb:bf:bf:bf:fd:bf:bf:bf:bf - unexpected non-continuation byte 0xe0, immediately after start byte 0xc0
3.5 Impossible bytes
3.5.1 n - 1 fe - byte 0xfe
3.5.2 n - 1 ff - byte 0xff
Property changes on: trunk/contrib/perl/t/op/utf8decode.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/utf8magic.t
===================================================================
--- trunk/contrib/perl/t/op/utf8magic.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/utf8magic.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -6,7 +6,7 @@
require './test.pl';
}
-plan tests => 4;
+plan tests => 6;
use strict;
@@ -23,3 +23,16 @@
ok !utf8::is_utf8($1), "is_utf8(bytes)";
scalar "$1"; # invoke SvGETMAGIC
ok !utf8::is_utf8($1), "is_utf8(bytes)";
+
+sub TIESCALAR { bless [pop] }
+sub FETCH { $_[0][0] }
+sub STORE { $::stored = pop }
+
+tie my $str2, "", "a";
+$str2 = "b";
+utf8::encode $str2;
+is $::stored, "a", 'utf8::encode respects get-magic on POK scalars';
+
+tie $str2, "", "\xc4\x80";
+utf8::decode $str2;
+is $::stored, "\x{100}", 'utf8::decode respects set-magic';
Property changes on: trunk/contrib/perl/t/op/utf8magic.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/op/utfhash.t
===================================================================
--- trunk/contrib/perl/t/op/utfhash.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/utfhash.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/utfhash.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/t/op/utftaint.t
===================================================================
--- trunk/contrib/perl/t/op/utftaint.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/utftaint.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/utftaint.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/op/vec.t
===================================================================
--- trunk/contrib/perl/t/op/vec.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/vec.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/vec.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/ver.t
===================================================================
--- trunk/contrib/perl/t/op/ver.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/ver.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -4,6 +4,7 @@
chdir 't' if -d 't';
@INC = qw(. ../lib);
$SIG{'__WARN__'} = sub { warn $_[0] if $DOWARN };
+ require "test.pl";
}
$DOWARN = 1; # enable run-time warnings now
@@ -10,8 +11,7 @@
use Config;
-require "test.pl";
-plan( tests => 54 );
+plan( tests => 57 );
eval 'use v5.5.640';
is( $@, '', "use v5.5.640; $@");
@@ -262,7 +262,20 @@
%h = (65.66.67 => 42);
ok( exists $h{chr(65).chr(66).chr(67)}, "v-stringness is engaged for X.Y.Z" );
+{
+ local $|;
+ $| = v0;
+ $| = 1;
+ --$|; --$|;
+ is $|, 1, 'clobbering vstrings does not clobber all magic';
+}
+$a = v102; $a =~ s/f/f/;
+is ref \$a, 'SCALAR',
+ 's/// flattens vstrings even when the subst results in the same value';
+$a = v102; $a =~ y/f/g/;
+is ref \$a, 'SCALAR', 'y/// flattens vstrings';
+
# The following tests whether v-strings are correctly
# interpreted by the tokeniser when it's in a XTERMORDORDOR
# state (fittingly, the only tokeniser state to contain the
Property changes on: trunk/contrib/perl/t/op/ver.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/op/wantarray.t
===================================================================
--- trunk/contrib/perl/t/op/wantarray.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/wantarray.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/wantarray.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/warn.t
===================================================================
--- trunk/contrib/perl/t/op/warn.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/warn.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -7,7 +7,7 @@
require './test.pl';
}
-plan 22;
+plan 30;
my @warnings;
my $wa = []; my $ea = [];
@@ -148,4 +148,48 @@
'warn stringifies in the absence of $SIG{__WARN__}'
);
+use Tie::Scalar;
+tie $@, "Tie::StdScalar";
+
+$@ = "foo\n";
+ at warnings = ();
+warn;
+is @warnings, 1;
+like $warnings[0], qr/^foo\n\t\.\.\.caught at warn\.t /,
+ '...caught is appended to tied $@';
+
+$@ = \$_;
+ at warnings = ();
+{
+ local *{ref(tied $@) . "::STORE"} = sub {};
+ undef $@;
+}
+warn;
+is @warnings, 1;
+is $warnings[0], \$_, '!SvOK tied $@ that returns ref is used';
+
+untie $@;
+
+ at warnings = ();
+{
+ package o;
+ use overload '""' => sub { "" };
+}
+tie $t, Tie::StdScalar;
+$t = bless [], o;
+{
+ local *{ref(tied $t) . "::STORE"} = sub {};
+ undef $t;
+}
+warn $t;
+is @warnings, 1;
+object_ok $warnings[0], 'o',
+ 'warn $tie_returning_object_that_stringifes_emptily';
+
+ at warnings = ();
+eval "#line 42 Cholmondeley\n \$\@ = '3'; warn";
+eval "#line 42 Cholmondeley\n \$\@ = 3; warn";
+is @warnings, 2;
+is $warnings[1], $warnings[0], 'warn treats $@=3 and $@="3" the same way';
+
1;
Property changes on: trunk/contrib/perl/t/op/warn.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/op/while.t (from rev 6437, vendor/perl/5.18.1/t/op/while.t)
===================================================================
--- trunk/contrib/perl/t/op/while.t (rev 0)
+++ trunk/contrib/perl/t/op/while.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,215 @@
+#!./perl
+
+BEGIN {
+ chdir 't';
+ require "test.pl";
+}
+
+plan(25);
+
+my $tmpfile = tempfile();
+open (tmp,'>', $tmpfile) || die "Can't create Cmd_while.tmp.";
+print tmp "tvi925\n";
+print tmp "tvi920\n";
+print tmp "vt100\n";
+print tmp "Amiga\n";
+print tmp "paper\n";
+close tmp or die "Could not close: $!";
+
+# test "last" command
+
+open(fh, $tmpfile) || die "Can't open Cmd_while.tmp.";
+while (<fh>) {
+ last if /vt100/;
+}
+ok(!eof && /vt100/);
+
+# test "next" command
+
+$bad = '';
+open(fh, $tmpfile) || die "Can't open Cmd_while.tmp.";
+while (<fh>) {
+ next if /vt100/;
+ $bad = 1 if /vt100/;
+}
+ok(eof && !/vt100/ && !$bad);
+
+# test "redo" command
+
+$bad = '';
+open(fh,$tmpfile) || die "Can't open Cmd_while.tmp.";
+while (<fh>) {
+ if (s/vt100/VT100/g) {
+ s/VT100/Vt100/g;
+ redo;
+ }
+ $bad = 1 if /vt100/;
+ $bad = 1 if /VT100/;
+}
+ok(eof && !$bad);
+
+# now do the same with a label and a continue block
+
+# test "last" command
+
+$badcont = '';
+open(fh,$tmpfile) || die "Can't open Cmd_while.tmp.";
+line: while (<fh>) {
+ if (/vt100/) {last line;}
+} continue {
+ $badcont = 1 if /vt100/;
+}
+ok(!eof && /vt100/);
+ok(!$badcont);
+
+# test "next" command
+
+$bad = '';
+$badcont = 1;
+open(fh,$tmpfile) || die "Can't open Cmd_while.tmp.";
+entry: while (<fh>) {
+ next entry if /vt100/;
+ $bad = 1 if /vt100/;
+} continue {
+ $badcont = '' if /vt100/;
+}
+ok(eof && !/vt100/ && !$bad);
+ok(!$badcont);
+
+# test "redo" command
+
+$bad = '';
+$badcont = '';
+open(fh,$tmpfile) || die "Can't open Cmd_while.tmp.";
+loop: while (<fh>) {
+ if (s/vt100/VT100/g) {
+ s/VT100/Vt100/g;
+ redo loop;
+ }
+ $bad = 1 if /vt100/;
+ $bad = 1 if /VT100/;
+} continue {
+ $badcont = 1 if /vt100/;
+}
+ok(eof && !$bad);
+ok(!$badcont);
+
+close(fh) || die "Can't close Cmd_while.tmp.";
+
+$i = 9;
+{
+ $i++;
+}
+is($i, 10);
+
+# Check curpm is reset when jumping out of a scope
+$i = 0;
+'abc' =~ /b/;
+WHILE:
+while (1) {
+ $i++;
+ is($` . $& . $', "abc");
+ { # Localize changes to $` and friends
+ 'end' =~ /end/;
+ redo WHILE if $i == 1;
+ next WHILE if $i == 2;
+ # 3 do a normal loop
+ last WHILE if $i == 4;
+ }
+}
+is($` . $& . $', "abc");
+
+# check that scope cleanup happens right when there's a continue block
+{
+ my $var = 16;
+ my (@got_var, @got_i);
+ while (my $i = ++$var) {
+ next if $i == 17;
+ last if $i > 17;
+ my $i = 0;
+ }
+ continue {
+ ($got_var, $got_i) = ($var, $i);
+ }
+ is($got_var, 17);
+ is($got_i, 17);
+}
+
+{
+ my $got_l;
+ local $l = 18;
+ {
+ local $l = 0
+ }
+ continue {
+ $got_l = $l;
+ }
+ is($got_l, 18);
+}
+
+{
+ my $got_l;
+ local $l = 19;
+ my $x = 0;
+ while (!$x++) {
+ local $l = 0
+ }
+ continue {
+ $got_l = $l;
+ }
+ is($got_l, $l);
+}
+
+{
+ my $ok = 1;
+ $i = 20;
+ while (1) {
+ my $x;
+ $ok = 0 if defined $x;
+ if ($i == 21) {
+ next;
+ }
+ last;
+ }
+ continue {
+ ++$i;
+ }
+ ok($ok);
+}
+
+sub save_context { $_[0] = wantarray; $_[1] }
+
+{
+ my $context = -1;
+ my $p = sub {
+ my $x = 1;
+ while ($x--) {
+ save_context($context, "foo");
+ }
+ };
+ is(scalar($p->()), 0);
+ is($context, undef, "last statement in while block has 'void' context");
+}
+
+{
+ my $context = -1;
+ my $p = sub {
+ my $x = 1;
+ {
+ save_context($context, "foo");
+ }
+ };
+ is(scalar($p->()), "foo");
+ is($context, "", "last statement in block has 'scalar' context");
+}
+
+{
+ # test scope is cleaned
+ my $i = 0;
+ my @a;
+ while ($i++ < 2) {
+ my $x;
+ push @a, \$x;
+ }
+ ok($a[0] ne $a[1]);
+}
Index: trunk/contrib/perl/t/op/while_readdir.t
===================================================================
--- trunk/contrib/perl/t/op/while_readdir.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/while_readdir.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/while_readdir.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/op/write.t
===================================================================
--- trunk/contrib/perl/t/op/write.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/write.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -58,10 +58,10 @@
#---------------------------------------------------------
# number of tests in section 1
-my $bas_tests = 20;
+my $bas_tests = 21;
# number of tests in section 3
-my $bug_tests = 4 + 3 * 3 * 5 * 2 * 3 + 2 + 2 + 1;
+my $bug_tests = 8 + 3 * 3 * 5 * 2 * 3 + 2 + 66 + 4 + 2 + 3 + 96 + 11;
# number of tests in section 4
my $hmb_tests = 35;
@@ -278,6 +278,18 @@
close OUT4 or die "Could not close: $!";
is cat('Op_write.tmp'), "1\n" and unlink_all "Op_write.tmp";
+# More LEX_INTERPNORMAL
+format OUT4a=
+@<<<<<<<<<<<<<<<
+"${; use
+ strict; \'Nasdaq dropping like flies'}"
+.
+open OUT4a, ">Op_write.tmp" or die "Can't create Op_write.tmp";
+write (OUT4a);
+close OUT4a or die "Could not close: $!";
+is cat('Op_write.tmp'), "Nasdaq dropping\n", 'skipspace inside "${...}"'
+ and unlink_all "Op_write.tmp";
+
eval <<'EOFORMAT';
format OUT10 =
@####.## @0###.##
@@ -504,13 +516,50 @@
{
local $~ = '';
eval { write };
- like $@, qr/Not a format reference/, 'format reference';
+ like $@, qr/Undefined format ""/, 'format with 0-length name';
+ $~ = "\0foo";
+ eval { write };
+ like $@, qr/Undefined format "\0foo"/,
+ 'no such format beginning with null';
+
$~ = "NOSUCHFORMAT";
eval { write };
- like $@, qr/Undefined format/, 'no such format';
+ like $@, qr/Undefined format "NOSUCHFORMAT"/, 'no such format';
}
+select +(select(OUT21), do {
+ open(OUT21, '>Op_write.tmp') || die "Can't create Op_write.tmp";
+
+ format OUT21 =
+@<<
+$_
+.
+
+ local $^ = '';
+ local $= = 1;
+ $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) };
+ like $@, qr/Undefined top format ""/, 'top format with 0-length name';
+
+ $^ = "\0foo";
+ # For some reason, we have to do this twice to get the error again.
+ $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) };
+ $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) };
+ like $@, qr/Undefined top format "\0foo"/,
+ 'no such top format beginning with null';
+
+ $^ = "NOSUCHFORMAT";
+ $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) };
+ $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) };
+ like $@, qr/Undefined top format "NOSUCHFORMAT"/, 'no such top format';
+
+ # reset things;
+ eval { write(OUT21) };
+ undef $^A;
+
+ close OUT21 or die "Could not close: $!";
+})[0];
+
{
package Count;
@@ -542,9 +591,13 @@
"$base\nMoo!\n",) {
foreach (['^*', qr/(.+)/], ['@*', qr/(.*?)$/s]) {
my ($format, $re) = @$_;
+ $format = "1^*2 3${format}4";
foreach my $class ('', 'Count') {
- my $name = "$first, $second $format $class";
+ my $name = qq{swrite("$format", "$first", "$second") class="$class"};
$name =~ s/\n/\\n/g;
+ $name =~ s{(.)}{
+ ord($1) > 126 ? sprintf("\\x{%x}",ord($1)) : $1
+ }ge;
$first =~ /(.+)/ or die $first;
my $expect = "1${1}2";
@@ -555,12 +608,12 @@
my $copy1 = $first;
my $copy2;
tie $copy2, $class, $second;
- is swrite("1^*2 3${format}4", $copy1, $copy2), $expect, $name;
+ is swrite("$format", $copy1, $copy2), $expect, $name;
my $obj = tied $copy2;
is $obj->[1], 1, 'value read exactly once';
} else {
my ($copy1, $copy2) = ($first, $second);
- is swrite("1^*2 3${format}4", $copy1, $copy2), $expect, $name;
+ is swrite("$format", $copy1, $copy2), $expect, $name;
}
}
}
@@ -589,7 +642,7 @@
.
-# [ID 20020227.005] format bug with undefined _TOP
+# RT #8698 format bug with undefined _TOP
open STDOUT_DUP, ">&STDOUT";
my $oldfh = select STDOUT_DUP;
@@ -598,10 +651,7 @@
local $~ = "Comment";
write;
curr_test($test + 1);
- {
- local $::TODO = '[ID 20020227.005] format bug with undefined _TOP';
- is $-, 9;
- }
+ is $-, 9;
is $^, "STDOUT_DUP_TOP";
}
select $oldfh;
@@ -610,6 +660,115 @@
*CmT = *{$::{Comment}}{FORMAT};
ok defined *{$::{CmT}}{FORMAT}, "glob assign";
+
+# RT #91032: Check that "non-real" strings like tie and overload work,
+# especially that they re-compile the pattern on each FETCH, and that
+# they don't overrun the buffer
+
+
+{
+ package RT91032;
+
+ sub TIESCALAR { bless [] }
+ my $i = 0;
+ sub FETCH { $i++; "A$i @> Z\n" }
+
+ use overload '""' => \&FETCH;
+
+ tie my $f, 'RT91032';
+
+ formline $f, "a";
+ formline $f, "bc";
+ ::is $^A, "A1 a Z\nA2 bc Z\n", "RT 91032: tied";
+ $^A = '';
+
+ my $g = bless []; # has overloaded stringify
+ formline $g, "de";
+ formline $g, "f";
+ ::is $^A, "A3 de Z\nA4 f Z\n", "RT 91032: overloaded";
+ $^A = '';
+
+ my $h = [];
+ formline $h, "junk1";
+ formline $h, "junk2";
+ ::is ref($h), 'ARRAY', "RT 91032: array ref still a ref";
+ ::like "$h", qr/^ARRAY\(0x[0-9a-f]+\)$/, "RT 91032: array stringifies ok";
+ ::is $^A, "$h$h","RT 91032: stringified array";
+ $^A = '';
+
+ # used to overwrite the ~~ in the *original SV with spaces. Naughty!
+
+ my $orig = my $format = "^<<<<< ~~\n";
+ my $abc = "abc";
+ formline $format, $abc;
+ $^A ='';
+ ::is $format, $orig, "RT91032: don't overwrite orig format string";
+
+ # check that ~ and ~~ are displayed correctly as whitespace,
+ # under the influence of various different types of border
+
+ for my $n (1,2) {
+ for my $lhs (' ', 'Y', '^<<<', '^|||', '^>>>') {
+ for my $rhs ('', ' ', 'Z', '^<<<', '^|||', '^>>>') {
+ my $fmt = "^<B$lhs" . ('~' x $n) . "$rhs\n";
+ my $sfmt = ($fmt =~ s/~/ /gr);
+ my ($a, $bc, $stop);
+ ($a, $bc, $stop) = ('a', 'bc', 's');
+ # $stop is to stop '~~' deleting the whole line
+ formline $sfmt, $stop, $a, $bc;
+ my $exp = $^A;
+ $^A = '';
+ ($a, $bc, $stop) = ('a', 'bc', 's');
+ formline $fmt, $stop, $a, $bc;
+ my $got = $^A;
+ $^A = '';
+ $fmt =~ s/\n/\\n/;
+ ::is($got, $exp, "chop munging: [$fmt]");
+ }
+ }
+ }
+}
+
+# check that '~ (delete current line if empty) works when
+# the target gets upgraded to uft8 (and re-allocated) midstream.
+
+{
+ my $format = "\x{100}@~\n"; # format is utf8
+ # this target is not utf8, but will expand (and get reallocated)
+ # when upgraded to utf8.
+ my $orig = "\x80\x81\x82";
+ local $^A = $orig;
+ my $empty = "";
+ formline $format, $empty;
+ is $^A , $orig, "~ and realloc";
+
+ # check similarly that trailing blank removal works ok
+
+ $format = "@<\n\x{100}"; # format is utf8
+ chop $format;
+ $orig = " ";
+ $^A = $orig;
+ formline $format, " ";
+ is $^A, "$orig\n", "end-of-line blanks and realloc";
+
+ # and check this doesn't overflow the buffer
+
+ local $^A = '';
+ $format = "@* @####\n";
+ $orig = "x" x 100 . "\n";
+ formline $format, $orig, 12345;
+ is $^A, ("x" x 100) . " 12345\n", "\@* doesn't overflow";
+
+ # make sure it can cope with formats > 64k
+
+ $format = 'x' x 65537;
+ $^A = '';
+ formline $format;
+ # don't use 'is' here, as the diag output will be too long!
+ ok $^A eq $format, ">64K";
+}
+
+
SKIP: {
skip_if_miniperl('miniperl does not support scalario');
my $buf = "";
@@ -622,6 +781,33 @@
is $buf, "ok $test\n", "write to duplicated format";
}
+format caret_A_test_TOP =
+T
+.
+
+format caret_A_test =
+L1
+L2
+L3
+L4
+.
+
+SKIP: {
+ skip_if_miniperl('miniperl does not support scalario');
+ my $buf = "";
+ open my $fh, ">", \$buf;
+ my $old_fh = select $fh;
+ local $^ = "caret_A_test_TOP";
+ local $~ = "caret_A_test";
+ local $= = 3;
+ local $^A = "A1\nA2\nA3\nA4\n";
+ write;
+ select $old_fh;
+ close $fh;
+ is $buf, "T\nA1\nA2\n\fT\nA3\nA4\n\fT\nL1\nL2\n\fT\nL3\nL4\n",
+ "assign to ^A sets FmLINES";
+}
+
fresh_perl_like(<<'EOP', qr/^Format STDOUT redefined at/, {stderr => 1}, '#64562 - Segmentation fault with redefined formats and warnings');
#!./perl
@@ -639,6 +825,295 @@
write;
EOP
+fresh_perl_is(<<'EOP', ">ARRAY<\ncrunch_eth\n", {stderr => 1}, '#79532 - formline coerces its arguments');
+use strict;
+use warnings;
+my $zamm = ['crunch_eth'];
+formline $zamm;
+printf ">%s<\n", ref $zamm;
+print "$zamm->[0]\n";
+EOP
+
+# [perl #73690]
+
+select +(select(RT73690), do {
+ open(RT73690, '>Op_write.tmp') || die "Can't create Op_write.tmp";
+ format RT73690 =
+@<< @<<
+11, 22
+.
+
+ my @ret;
+
+ @ret = write;
+ is(scalar(@ret), 1);
+ ok($ret[0]);
+ @ret = scalar(write);
+ is(scalar(@ret), 1);
+ ok($ret[0]);
+ @ret = write(RT73690);
+ is(scalar(@ret), 1);
+ ok($ret[0]);
+ @ret = scalar(write(RT73690));
+ is(scalar(@ret), 1);
+ ok($ret[0]);
+
+ @ret = ('a', write, 'z');
+ is(scalar(@ret), 3);
+ is($ret[0], 'a');
+ ok($ret[1]);
+ is($ret[2], 'z');
+ @ret = ('b', scalar(write), 'y');
+ is(scalar(@ret), 3);
+ is($ret[0], 'b');
+ ok($ret[1]);
+ is($ret[2], 'y');
+ @ret = ('c', write(RT73690), 'x');
+ is(scalar(@ret), 3);
+ is($ret[0], 'c');
+ ok($ret[1]);
+ is($ret[2], 'x');
+ @ret = ('d', scalar(write(RT73690)), 'w');
+ is(scalar(@ret), 3);
+ is($ret[0], 'd');
+ ok($ret[1]);
+ is($ret[2], 'w');
+
+ @ret = do { write; 'foo' };
+ is(scalar(@ret), 1);
+ is($ret[0], 'foo');
+ @ret = do { scalar(write); 'bar' };
+ is(scalar(@ret), 1);
+ is($ret[0], 'bar');
+ @ret = do { write(RT73690); 'baz' };
+ is(scalar(@ret), 1);
+ is($ret[0], 'baz');
+ @ret = do { scalar(write(RT73690)); 'quux' };
+ is(scalar(@ret), 1);
+ is($ret[0], 'quux');
+
+ @ret = ('a', do { write; 'foo' }, 'z');
+ is(scalar(@ret), 3);
+ is($ret[0], 'a');
+ is($ret[1], 'foo');
+ is($ret[2], 'z');
+ @ret = ('b', do { scalar(write); 'bar' }, 'y');
+ is(scalar(@ret), 3);
+ is($ret[0], 'b');
+ is($ret[1], 'bar');
+ is($ret[2], 'y');
+ @ret = ('c', do { write(RT73690); 'baz' }, 'x');
+ is(scalar(@ret), 3);
+ is($ret[0], 'c');
+ is($ret[1], 'baz');
+ is($ret[2], 'x');
+ @ret = ('d', do { scalar(write(RT73690)); 'quux' }, 'w');
+ is(scalar(@ret), 3);
+ is($ret[0], 'd');
+ is($ret[1], 'quux');
+ is($ret[2], 'w');
+
+ close RT73690 or die "Could not close: $!";
+})[0];
+
+select +(select(RT73690_2), do {
+ open(RT73690_2, '>Op_write.tmp') || die "Can't create Op_write.tmp";
+ format RT73690_2 =
+@<< @<<
+return
+.
+
+ my @ret;
+
+ @ret = write;
+ is(scalar(@ret), 1);
+ ok(!$ret[0]);
+ @ret = scalar(write);
+ is(scalar(@ret), 1);
+ ok(!$ret[0]);
+ @ret = write(RT73690_2);
+ is(scalar(@ret), 1);
+ ok(!$ret[0]);
+ @ret = scalar(write(RT73690_2));
+ is(scalar(@ret), 1);
+ ok(!$ret[0]);
+
+ @ret = ('a', write, 'z');
+ is(scalar(@ret), 3);
+ is($ret[0], 'a');
+ ok(!$ret[1]);
+ is($ret[2], 'z');
+ @ret = ('b', scalar(write), 'y');
+ is(scalar(@ret), 3);
+ is($ret[0], 'b');
+ ok(!$ret[1]);
+ is($ret[2], 'y');
+ @ret = ('c', write(RT73690_2), 'x');
+ is(scalar(@ret), 3);
+ is($ret[0], 'c');
+ ok(!$ret[1]);
+ is($ret[2], 'x');
+ @ret = ('d', scalar(write(RT73690_2)), 'w');
+ is(scalar(@ret), 3);
+ is($ret[0], 'd');
+ ok(!$ret[1]);
+ is($ret[2], 'w');
+
+ @ret = do { write; 'foo' };
+ is(scalar(@ret), 1);
+ is($ret[0], 'foo');
+ @ret = do { scalar(write); 'bar' };
+ is(scalar(@ret), 1);
+ is($ret[0], 'bar');
+ @ret = do { write(RT73690_2); 'baz' };
+ is(scalar(@ret), 1);
+ is($ret[0], 'baz');
+ @ret = do { scalar(write(RT73690_2)); 'quux' };
+ is(scalar(@ret), 1);
+ is($ret[0], 'quux');
+
+ @ret = ('a', do { write; 'foo' }, 'z');
+ is(scalar(@ret), 3);
+ is($ret[0], 'a');
+ is($ret[1], 'foo');
+ is($ret[2], 'z');
+ @ret = ('b', do { scalar(write); 'bar' }, 'y');
+ is(scalar(@ret), 3);
+ is($ret[0], 'b');
+ is($ret[1], 'bar');
+ is($ret[2], 'y');
+ @ret = ('c', do { write(RT73690_2); 'baz' }, 'x');
+ is(scalar(@ret), 3);
+ is($ret[0], 'c');
+ is($ret[1], 'baz');
+ is($ret[2], 'x');
+ @ret = ('d', do { scalar(write(RT73690_2)); 'quux' }, 'w');
+ is(scalar(@ret), 3);
+ is($ret[0], 'd');
+ is($ret[1], 'quux');
+ is($ret[2], 'w');
+
+ close RT73690_2 or die "Could not close: $!";
+})[0];
+
+open(UNDEF, '>Op_write.tmp') || die "Can't create Op_write.tmp";
+select +(select(UNDEF), $~ = "UNDEFFORMAT")[0];
+format UNDEFFORMAT =
+@
+undef *UNDEFFORMAT
+.
+write UNDEF;
+pass "active format cannot be freed";
+
+select +(select(UNDEF), $~ = "UNDEFFORMAT2")[0];
+format UNDEFFORMAT2 =
+@
+close UNDEF or die "Could not close: $!"; undef *UNDEF
+.
+write UNDEF;
+pass "freeing current handle in format";
+undef $^A;
+
+ok !eval q|
+format foo {
+@<<<
+$a
+}
+;1
+|, 'format foo { ... } is not allowed';
+
+ok !eval q|
+format =
+@<<<
+}
+;1
+|, 'format = ... } is not allowed';
+
+open(NEST, '>Op_write.tmp') || die "Can't create Op_write.tmp";
+format NEST =
+@<<<
+{
+ my $birds = "birds";
+ local *NEST = *BIRDS{FORMAT};
+ write NEST;
+ format BIRDS =
+@<<<<<
+$birds;
+.
+ "nest"
+}
+.
+write NEST;
+close NEST or die "Could not close: $!";
+is cat('Op_write.tmp'), "birds\nnest\n", 'nested formats';
+
+# A compilation error should not create a format
+eval q|
+format ERROR =
+@
+ at _ =~ s///
+.
+|;
+eval { write ERROR };
+like $@, qr'Undefined format',
+ 'formats with compilation errors are not created';
+
+# This syntax error used to cause a crash, double free, or a least
+# a bad read.
+# See the long-winded explanation at:
+# https://rt.perl.org/rt3/Ticket/Display.html?id=43425#txn-1144500
+eval q|
+format =
+@
+use;format
+strict
+.
+|;
+pass('no crash with invalid use/format inside format');
+
+
+# Low-precedence operators on argument line
+format AND =
+@
+0 and die
+.
+$- = $=;
+ok eval { local $~ = "AND"; print "# "; write; 1 },
+ "low-prec ops on arg line" or diag $@;
+
+# Anonymous hashes
+open(HASH, '>Op_write.tmp') || die "Can't create Op_write.tmp";
+format HASH =
+@<<<
+${{qw[ Sun 0 Mon 1 Tue 2 Wed 3 Thu 4 Fri 5 Sat 6 ]}}{"Wed"}
+.
+write HASH;
+close HASH or die "Could not close: $!";
+is cat('Op_write.tmp'), "3\n", 'anonymous hashes';
+
+# pragmata inside argument line
+open(STRICT, '>Op_write.tmp') || die "Can't create Op_write.tmp";
+format STRICT =
+@<<<
+no strict; $foo
+.
+$::foo = 'oof::$';
+write STRICT;
+close STRICT or die "Could not close: $!";
+is cat('Op_write.tmp'), "oof:\n", 'pragmata on format line';
+
+SKIP: {
+ skip "no weak refs" unless eval { require Scalar::Util };
+ sub Potshriggley {
+format Potshriggley =
+.
+ }
+ Scalar::Util::weaken(my $x = *Potshriggley{FORMAT});
+ undef *Potshriggley;
+ is $x, undef, 'formats in subs do not leak';
+}
+
+
#############################
## Section 4
## Add new tests *above* here
Property changes on: trunk/contrib/perl/t/op/write.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/t/op/yadayada.t
===================================================================
--- trunk/contrib/perl/t/op/yadayada.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/op/yadayada.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/op/yadayada.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/perl.supp
===================================================================
--- trunk/contrib/perl/t/perl.supp 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/perl.supp 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/perl.supp
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/porting/FindExt.t
===================================================================
--- trunk/contrib/perl/t/porting/FindExt.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/porting/FindExt.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/porting/FindExt.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/porting/args_assert.t
===================================================================
--- trunk/contrib/perl/t/porting/args_assert.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/porting/args_assert.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -39,6 +39,8 @@
# *.c or */*.c
push @ARGV, $prefix . $1 if m!^((?:[^/]+/)?[^/]+\.c)\t!;
}
+ push @ARGV, $prefix . 'inline.h'; # Special case this '.h' which acts like
+ # a '.c'
}
while (<>) {
Property changes on: trunk/contrib/perl/t/porting/args_assert.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/porting/authors.t
===================================================================
--- trunk/contrib/perl/t/porting/authors.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/porting/authors.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,20 +1,17 @@
#!./perl -w
+# Test that there are no missing authors in AUTHORS
-# Test that there are no missing authors in AUTHORS
BEGIN {
- chdir '..' unless -d 't';
- unshift @INC, 'lib';
+ @INC = '..' if -f '../TestInit.pm';
}
-
+use TestInit qw(T); # T is chdir to the top level
use strict;
-use warnings;
-if (! -d '.git' ) {
- print "1..0 # SKIP: not being run from a git checkout\n";
- exit 0;
-}
+require 't/test.pl';
+find_git_or_skip('all');
-my $dotslash = $^O eq "MSWin32" ? ".\\" : "./";
-system("git log --pretty=fuller | ${dotslash}perl -Ilib Porting/checkAUTHORS.pl --tap -");
+# This is the subset of "pretty=fuller" that checkAUTHORS.pl actually needs:
+my $quote = $^O =~ /^mswin/i ? q(") : q(');
+system("git log --pretty=format:${quote}Author: %an <%ae>%n${quote} | $^X Porting/checkAUTHORS.pl --tap -");
# EOF
Property changes on: trunk/contrib/perl/t/porting/authors.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/porting/bincompat.t
===================================================================
--- trunk/contrib/perl/t/porting/bincompat.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/porting/bincompat.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/porting/bincompat.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/porting/buildtoc.t
===================================================================
--- trunk/contrib/perl/t/porting/buildtoc.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/porting/buildtoc.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/porting/buildtoc.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/porting/checkcase.t
===================================================================
--- trunk/contrib/perl/t/porting/checkcase.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/porting/checkcase.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,7 +1,12 @@
#!/usr/bin/perl
-# Finds the files that have the same name, case insensitively,
-# in the current directory and its subdirectories
+# Finds the files that have the same name, case insensitively in the build tree
+BEGIN {
+ @INC = '..' if -f '../TestInit.pm';
+ require './test.pl';
+}
+use TestInit qw(T); # T is chdir to the top level
+
use warnings;
use strict;
use File::Find;
@@ -9,29 +14,31 @@
my %files;
my $test_count = 0;
-find(sub {
- # We only care about directories to the extent they
- # result in an actual file collision, so skip dirs
- return if -d $File::Find::name;
+find({no_chdir => 1, wanted => sub {
+ my $name = $File::Find::name;
+ # Assumes that the path separator is exactly one character.
+ $name =~ s/^\..//;
- my $name = $File::Find::name;
- # Assumes that the path separator is exactly one character.
- $name =~ s/^\.\..//;
+ # Special exemption for Makefile, makefile
+ return if $name =~ m!\A(?:x2p/)?[Mm]akefile\z!;
- # Special exemption for Makefile, makefile
- return if $name =~ m!\A(?:x2p/)?[Mm]akefile\z!;
+ if ($name eq '.git') {
+ # Don't scan the .git directory, as its contents are outside
+ # our control. In particular, as fetch doesn't default to
+ # --prune, # someone pushing a branch upstream with a name
+ # which case-conflicts with a previously deleted branch will
+ # cause action-at-a-distance failures, because locally
+ # .git/logs/refs/remotes will contain both.
+ ++$File::Find::prune;
+ return;
+ }
- push @{$files{lc $name}}, $name;
- }, '..');
+ push @{$files{lc $name}}, $name;
+ }}, '.');
foreach (sort values %files) {
- if (@$_ > 1) {
- print "not ok ".++$test_count. " - ". join(", ", @$_), "\n";
- print STDERR "# $_\n" foreach @$_;
- } else {
- print "ok ".++$test_count. " - ". join(", ", @$_), "\n";
- }
+ is( @$_, 1, join(", ", @$_) ) or
+ do{ note($_) foreach @$_; };
}
-print "1..".$test_count."\n";
-# vim: ts=4 sts=4 sw=4 et:
+done_testing();
Property changes on: trunk/contrib/perl/t/porting/checkcase.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/porting/checkcfgvar.t (from rev 6437, vendor/perl/5.18.1/t/porting/checkcfgvar.t)
===================================================================
--- trunk/contrib/perl/t/porting/checkcfgvar.t (rev 0)
+++ trunk/contrib/perl/t/porting/checkcfgvar.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,29 @@
+#!./perl -w
+
+# What does this test?
+# This uses Porting/checkcfgvar.pl to check that none of the config.sh-like
+# files are missing any entries.
+#
+# Why do we test this?
+# We need them to be complete when we ship a release, and this way we catch
+# problems as early as possible. (Instead of creating the potential for yet
+# another last-minute job for the release manager). If a config file for a
+# platform is incomplete, it can't be used to correctly regenerate config.h,
+# because missing values result in invalid C code. We keep the files sorted
+# as it makes it easy to automate adding defaults.
+#
+# It's broken - how do I fix it?
+# The most likely reason that the test failed is because you've just added
+# a new entry to Configure, config.sh and config_h.SH but nowhere else.
+# Run something like:
+# perl Porting/checkcfgvar.pl --regen --default=undef
+# (the correct default might not always be undef) to do most of the work, and
+# then hand-edit configure.com (as that's not automated).
+# If this changes uconfig.sh, you'll also need to run perl regen/uconfig_h.pl
+
+BEGIN {
+ @INC = '..' if -f '../TestInit.pm';
+}
+use TestInit qw(T A); # T is chdir to the top level, A makes paths absolute
+
+system "$^X Porting/checkcfgvar.pl --tap";
Modified: trunk/contrib/perl/t/porting/cmp_version.t
===================================================================
--- trunk/contrib/perl/t/porting/cmp_version.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/porting/cmp_version.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,153 +1,18 @@
#!./perl -w
-#
-# Compare the current Perl source tree against the version at the most
-# recent tag, for modules that have identical version numbers but
-# different contents. Skips cpan/.
-#
# Original by slaven at rezic.de, modified by jhi and matt.w.johnson at gmail.com
#
# Adapted from Porting/cmpVERSION.pl by Abigail
-#
+# Changes folded back into that by Nicholas
BEGIN {
- chdir '..' unless -d 't';
- unshift @INC, 'lib', 'Porting';
+ @INC = '..' if -f '../TestInit.pm';
}
-
+use TestInit qw(T A); # T is chdir to the top level, A makes paths absolute
use strict;
-use warnings;
-use version;
-use ExtUtils::MakeMaker;
-use File::Compare;
-use File::Find;
-use File::Spec::Functions qw(rel2abs abs2rel catfile catdir curdir);
-use Getopt::Std;
-use Maintainers;
-if (! -d '.git' ) {
- print "1..0 # SKIP: not being run from a git checkout\n";
- exit 0;
-}
+require 't/test.pl';
+my $source = find_git_or_skip('all');
+chdir $source or die "Can't chdir to $source: $!";
-#
-# Thanks to David Golden for this suggestion.
-#
-my $tag_to_compare = `git describe --abbrev=0`;
-chomp $tag_to_compare;
-my $source_dir = '.';
-
-my $null = $^O eq 'MSWin32' ? 'nul' : '/dev/null';
-
-my $tag_exists = `git --no-pager tag -l $tag_to_compare 2>$null`;
-chomp $tag_exists;
-
-
-if ($tag_exists ne $tag_to_compare) {
- print "1..0 # SKIP: '$tag_to_compare' is not a known Git tag\n";
- exit 0;
-}
-
-
-my %dual_files;
-for my $m (grep $Maintainers::Modules {$_} {CPAN}, keys %Maintainers::Modules) {
- $dual_files{$_} = 1 for Maintainers::get_module_files ($m);
-}
-
-
-# Files to skip from the check for one reason or another,
-# usually because they pull in their version from some other file.
-my %skip;
- at skip{
- 'lib/Carp/Heavy.pm',
- 'lib/Config.pm', # no version number but contents will vary
- 'lib/Exporter/Heavy.pm',
- 'win32/FindExt.pm',
-} = ();
-
-# Files to skip just for particular version(s),
-# usually due to some # mix-up
-
-my %skip_versions = (
- # 'some/sample/file.pm' => [ '1.23', '1.24' ],
- 'dist/threads/lib/threads.pm' => [ '1.83' ],
-);
-
-my $skip_dirs = qr{^(?:t/lib|cpan)};
-
-my @all_diffs = `git --no-pager diff --name-only $tag_to_compare`;
-chomp @all_diffs;
-
-my @tmp_diffs = grep {
- my $this_dir;
- $this_dir = $1 if m/^(.*)\//;
- /\.pm$/ &&
- (!defined($this_dir) || ($this_dir !~ $skip_dirs)) &&
- !exists $skip{$_};
-} @all_diffs;
-my @module_diffs = grep {!exists $dual_files {$_}} @tmp_diffs;
-push @module_diffs => grep { exists $dual_files {$_}} @tmp_diffs;
-
-unless (@module_diffs) {
- print "1..1\n";
- print "ok 1 - No difference found\n";
- exit;
-}
-
-my (@output_files, @output_diffs);
-
-printf "1..%d\n" => scalar @module_diffs;
-
-my $count = 0;
-my @diff;
-foreach my $pm_file (@module_diffs) {
- @diff = ();
- (my $xs_file = $pm_file) =~ s/\.pm$/.xs/;
- my $pm_eq = compare_git_file($pm_file, $tag_to_compare);
- next unless defined $pm_eq;
- my $xs_eq = 1;
- if (-e $xs_file) {
- $xs_eq = compare_git_file($xs_file, $tag_to_compare);
- next unless defined $xs_eq;
- }
- next if ($pm_eq && $xs_eq);
- my $pm_version = eval {MM->parse_version($pm_file)};
- my $orig_pm_content = get_file_from_git($pm_file, $tag_to_compare);
- my $orig_pm_version = eval {MM->parse_version(\$orig_pm_content)};
- next if ( ! defined $pm_version || ! defined $orig_pm_version );
- next if ( $pm_version eq 'undef' || $orig_pm_version eq 'undef' ); # sigh
- next if $pm_version ne $orig_pm_version;
- next if exists $skip_versions{$pm_file}
- and grep $pm_version eq $_, @{$skip_versions{$pm_file}};
- push @diff => $pm_file unless $pm_eq;
- push @diff => $xs_file unless $xs_eq;
-}
-continue {
- if (@diff) {
- foreach my $diff (@diff) {
- print "# $_" for `git --no-pager diff $tag_to_compare '$diff'`;
- }
- printf "not ok %d - %s\n" => ++ $count, $pm_file;
- }
- else {
- printf "ok %d - %s\n" => ++ $count, $pm_file;
- }
-}
-
-exit;
-
-sub compare_git_file {
- my ($file, $tag) = @_;
- open(my $orig_fh, "-|", "git --no-pager show $tag:$file 2>$null");
- return undef if eof($orig_fh);
- my $is_eq = compare($file, $orig_fh) == 0;
- close($orig_fh);
- return $is_eq;
-}
-
-sub get_file_from_git {
- my ($file, $tag) = @_;
- local $/ = undef;
- my $file_content = `git --no-pager show $tag:$file 2>$null`;
- return $file_content;
-}
+system "$^X Porting/cmpVERSION.pl --exclude --tap";
Property changes on: trunk/contrib/perl/t/porting/cmp_version.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/porting/customized.dat (from rev 6437, vendor/perl/5.18.1/t/porting/customized.dat)
===================================================================
--- trunk/contrib/perl/t/porting/customized.dat (rev 0)
+++ trunk/contrib/perl/t/porting/customized.dat 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,16 @@
+Text::Balanced cpan/Text-Balanced/t/01_compile.t 1598cf491a48fa546260a2ec41142abe84da533d
+Text::Balanced cpan/Text-Balanced/t/02_extbrk.t 6ba1b64a4604e822dc2260b8ffcea6b406339ee8
+Text::Balanced cpan/Text-Balanced/t/03_extcbk.t 3307c980af28963414cab799c427b359ef3b8657
+Text::Balanced cpan/Text-Balanced/t/04_extdel.t be993c5c295b125b4be0ed55f866a249599f5835
+Text::Balanced cpan/Text-Balanced/t/05_extmul.t 4d1bc60add35ac203873f5371d8c6fcc9c8b6d80
+Text::Balanced cpan/Text-Balanced/t/06_extqlk.t 81a5804d392013393a338325b197cea52c4c44e0
+Text::Balanced cpan/Text-Balanced/t/07_exttag.t 5a209ed156387d4614d3003292e5fc412b8541e5
+Text::Balanced cpan/Text-Balanced/t/08_extvar.t 0776ef2cbdad5b1fbefb300541d079212cc24d92
+Text::Balanced cpan/Text-Balanced/t/09_gentag.t 42361b5dfb3bb728bce20f4fb0d92ccfb27c2ba7
+Module::Build cpan/Module-Build/lib/Module/Build/ConfigData.pm 2f3f07fd889077ebd51791ad6e195d9164b4baf3
+Test::Harness cpan/Test-Harness/t/source.t 884890970fb850874213159df263ba483bac62e9
+CPANPLUS cpan/CPANPLUS/Makefile.PL 5d533f6722af6aae73204755beb8d6c008fc0d4a
+libnet cpan/libnet/Makefile.PL 5554b71464b45f5cc002e55f2464f7ff4abd05b6
+podlators cpan/podlators/scripts/pod2man.PL f81acf53f3ff46cdcc5ebdd661c5d13eb35d20d6
+podlators cpan/podlators/scripts/pod2text.PL b4693fcfe4a0a1b38a215cfb8985a65d5d025d69
+Module::Pluggable cpan/Module-Pluggable/Makefile.PL 72062c1a01ed7c62d16c55122c163b2d89f0d739
Copied: trunk/contrib/perl/t/porting/customized.t (from rev 6437, vendor/perl/5.18.1/t/porting/customized.t)
===================================================================
--- trunk/contrib/perl/t/porting/customized.t (rev 0)
+++ trunk/contrib/perl/t/porting/customized.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,140 @@
+#!./perl -w
+
+# Test that CUSTOMIZED files in Maintainers.pl have not been overwritten.
+
+BEGIN {
+ # This test script uses a slightly atypical invocation of the 'standard'
+ # core testing setup stanza.
+ # The existing porting tools which manage the Maintainers file all
+ # expect to be run from the root
+ # XXX that should be fixed
+
+ chdir '..' unless -d 't';
+ @INC = qw(lib Porting t);
+ require 'test.pl';
+}
+
+use strict;
+use warnings;
+use Digest;
+use File::Spec;
+use Maintainers qw[%Modules get_module_files get_module_pat];
+
+sub filter_customized {
+ my ($m, @files) = @_;
+
+ return @files
+ unless my $customized = $Modules{$m}{CUSTOMIZED};
+
+ my ($pat) = map { qr/$_/ } join '|' => map {
+ ref $_ ? $_ : qr/\b\Q$_\E$/
+ } @{ $customized };
+
+ return grep { $_ =~ $pat } @files;
+}
+
+sub my_get_module_files {
+ my $m = shift;
+ return filter_customized $m => map { Maintainers::expand_glob($_) } get_module_pat($m);
+}
+
+my $TestCounter = 0;
+
+my $digest_type = 'SHA-1';
+
+my $original_dir = File::Spec->rel2abs(File::Spec->curdir);
+my $data_dir = File::Spec->catdir('t', 'porting');
+my $customised = File::Spec->catfile($data_dir, 'customized.dat');
+
+my %customised;
+
+my $regen = 0;
+
+while (@ARGV && substr($ARGV[0], 0, 1) eq '-') {
+ my $arg = shift @ARGV;
+
+ $arg =~ s/^--/-/; # Treat '--' the same as a single '-'
+ if ($arg eq '-regen') {
+ $regen = 1;
+ }
+ else {
+ die <<EOF;
+Unknown option '$arg'
+
+Usage: $0 [ --regen ]\n"
+ --regen -> Regenerate the data file for $0
+
+EOF
+ }
+}
+
+my $data_fh;
+
+if ( $regen ) {
+ open $data_fh, '>:bytes', $customised or die "Can't open $customised";
+}
+else {
+ open $data_fh, '<:bytes', $customised or die "Can't open $customised";
+ while (<$data_fh>) {
+ chomp;
+ my ($module,$file,$sha) = split ' ';
+ $customised{ $module }->{ $file } = $sha;
+ }
+ close $data_fh;
+}
+
+foreach my $module ( keys %Modules ) {
+ next unless my $files = $Modules{ $module }{CUSTOMIZED};
+ my @perl_files = my_get_module_files( $module );
+ foreach my $file ( @perl_files ) {
+ my $digest = Digest->new( $digest_type );
+ {
+ open my $fh, '<', $file or die "Can't open $file";
+ binmode $fh;
+ $digest->addfile( $fh );
+ close $fh;
+ }
+ my $id = $digest->hexdigest;
+ if ( $regen ) {
+ print $data_fh join(' ', $module, $file, $id), "\n";
+ next;
+ }
+ my $should_be = $customised{ $module }->{ $file };
+ is( $id, $should_be, "SHA for $file matches stashed SHA" );
+ }
+}
+
+if ( $regen ) {
+ pass( "regenerated data file" );
+ close $data_fh;
+}
+
+done_testing();
+
+=pod
+
+=head1 NAME
+
+customized.t - Test that CUSTOMIZED files in Maintainers.pl have not been overwritten
+
+=head1 SYNOPSIS
+
+ cd t
+ ./perl -I../lib porting/customized.t --regen
+
+=head1 DESCRIPTION
+
+customized.t checks that files listed in C<Maintainers.pl> that have been C<CUSTOMIZED>
+are not accidently overwritten by CPAN module updates.
+
+=head1 OPTIONS
+
+=over
+
+=item C<--regen>
+
+Use this command line option to regenerate the C<customized.dat> file.
+
+=back
+
+=cut
Modified: trunk/contrib/perl/t/porting/diag.t
===================================================================
--- trunk/contrib/perl/t/porting/diag.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/porting/diag.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -2,7 +2,10 @@
use warnings;
use strict;
-require './test.pl';
+BEGIN {
+ chdir 't';
+ require './test.pl';
+}
plan('no_plan');
@@ -48,21 +51,28 @@
close $func_fh;
+my $regcomp_re = "(?<routine>(?:ckWARN(?:\\d+)?reg\\w*|vWARN\\d+))";
my $function_re = join '|', @functions;
-my $source_msg_re = qr/(?<routine>\bDIE\b|$function_re)/;
-my $text_re = qr/"(?<text>(?:\\"|[^"])*?)"/;
+my $regcomp_fail_re = '\b(?:(?:Simple_)?v)?FAIL[2-4]?\b';
+my $source_msg_re =
+ "(?<routine>\\bDIE\\b|$function_re|$regcomp_fail_re)";
+my $text_re = '"(?<text>(?:\\\\"|[^"]|"\s*[A-Z_]+\s*")*)"';
my $source_msg_call_re = qr/$source_msg_re(?:_nocontext)? \s*
\(aTHX_ \s*
(?:packWARN\d*\((?<category>.*?)\),)? \s*
$text_re /x;
my $bad_version_re = qr{BADVERSION\([^"]*$text_re};
+ $regcomp_fail_re = qr/$regcomp_fail_re\([^"]*$text_re/;
+my $regcomp_call_re = qr/$regcomp_re.*?$text_re/;
my %entries;
# Get the ignores that are compiled into this file
+my $reading_categorical_exceptions;
while (<DATA>) {
chomp;
- $entries{$_}{todo}=1;
+ $entries{$_}{$reading_categorical_exceptions ? 'cattodo' : 'todo'}=1;
+ /__CATEGORIES__/ and ++$reading_categorical_exceptions;
}
my $pod = "pod/perldiag.pod";
@@ -70,14 +80,27 @@
open my $diagfh, "<", $pod
or die "Can't open $pod: $!";
-my $category_re = qr/ [a-z0-9_]+?/; # Note: requires an initial space
+my $category_re = qr/ [a-z0-9_:]+?/; # Note: requires an initial space
my $severity_re = qr/ . (?: \| . )* /x; # A severity is a single char, but can
# be of the form 'S|P|W'
+my @same_descr;
while (<$diagfh>) {
if (m/^=item (.*)/) {
$cur_entry = $1;
- if (exists $entries{$cur_entry}) {
+ # Allow multi-line headers
+ while (<$diagfh>) {
+ if (/^\s*$/) {
+ last;
+ }
+
+ $cur_entry .= $_;
+ }
+
+ $cur_entry =~ s/\n/ /gs; # Fix multi-line headers if they have \n's
+ $cur_entry =~ s/\s+\z//;
+
+ if (exists $entries{$cur_entry} && $entries{$cur_entry}{todo}) {
TODO: {
local $::TODO = "Remove the TODO entry \"$cur_entry\" from DATA as it is already in $pod near line $.";
ok($cur_entry);
@@ -87,7 +110,6 @@
# overwrites one in DATA.
$entries{$cur_entry}{todo} = 0;
$entries{$cur_entry}{line_number} = $.;
- next;
}
next if ! defined $cur_entry;
@@ -96,10 +118,16 @@
if (/^ \( ( $severity_re )
# Can have multiple categories separated by commas
- (?: ( $category_re ) (?: , $category_re)* )? \) /x)
+ ( $category_re (?: , $category_re)* )? \) /x)
{
$entries{$cur_entry}{severity} = $1;
- $entries{$cur_entry}{category} = $2;
+ $entries{$cur_entry}{category} =
+ $2 && join ", ", sort split " ", $2 =~ y/,//dr;
+
+ # Record it also for other messages sharing the same description
+ @$_{qw<severity category>} =
+ @{$entries{$cur_entry}}{qw<severity category>}
+ for @same_descr;
}
elsif (! $entries{$cur_entry}{first_line} && $_ =~ /\S/) {
@@ -107,6 +135,12 @@
# that can later examine it to determine if that is ok or not
$entries{$cur_entry}{first_line} = $_;
}
+ if (/\S/) {
+ @same_descr = ();
+ }
+ else {
+ push @same_descr, $entries{$cur_entry};
+ }
}
}
@@ -142,6 +176,10 @@
NVef => 'f',
NVff => 'f',
NVgf => 'f',
+ HEKf256=>'s',
+ HEKf => 's',
+ SVf256=>'s',
+ SVf32=> 's',
SVf => 's');
my $format_modifiers = qr/ [#0\ +-]* # optional flags
(?: [1-9][0-9]* | \* )? # optional field width
@@ -149,22 +187,21 @@
(?: h|l )? # optional length modifier
/x;
-my $specialformats = join '|', sort keys %specialformats;
+my $specialformats =
+ join '|', sort { length $b cmp length $a } keys %specialformats;
my $specialformats_re = qr/%$format_modifiers"\s*($specialformats)(\s*")?/;
-# Recursively descend looking for source files.
-my @todo = sort <*>;
-while (@todo) {
- my $todo = shift @todo;
- next if $todo ~~ ['t', 'lib', 'ext', 'dist', 'cpan'];
- # opmini.c is just a copy of op.c, so there's no need to check again.
- next if $todo eq 'opmini.c';
- if (-d $todo) {
- unshift @todo, sort glob "$todo/*";
- } elsif ($todo =~ m/\.[ch]$/) {
- check_file($todo);
- }
+open my $fh, '<', 'MANIFEST' or die "Can't open MANIFEST: $!";
+while (my $file = <$fh>) {
+ chomp $file;
+ $file =~ s/\s+.*//;
+ next unless $file =~ /\.(?:c|cpp|h|xs|y)\z/ or $file =~ /^perly\./;
+ # OS/2 extensions have never been migrated to ext/, hence the special case:
+ next if $file =~ m!\A(?:ext|dist|cpan|lib|t|os2/OS2)/!
+ && $file !~ m!\Aext/DynaLoader/!;
+ check_file($file);
}
+close $fh or die $!;
# Standardize messages with variants into the form that appears
# in perldiag.pod -- useful for things without a diag_listed_as annotation
@@ -204,16 +241,15 @@
$sub = $_;
}
next if $sub =~ m/^XS/;
- if (m</\* diag_listed_as: (.*) \*/>) {
+ if (m</\*\s*diag_listed_as: (.*?)\s*\*/>) {
$listed_as = $1;
$listed_as_line = $.+1;
}
next if /^#/;
- next if /^ +/;
my $multiline = 0;
# Loop to accumulate the message text all on one line.
- if (m/$source_msg_re/) {
+ if (m/(?:$source_msg_re(?:_nocontext)?|$regcomp_re)\s*\(/) {
while (not m/\);$/) {
my $nextline = <$codefh>;
# Means we fell off the end of the file. Not terribly surprising;
@@ -244,24 +280,55 @@
# The %"foo" thing needs to happen *before* this regex.
# diag($_);
# DIE is just return Perl_die
- my ($name, $category);
+ my ($name, $category, $routine);
if (/$source_msg_call_re/) {
- ($name, $category) = ($+{'text'}, $+{'category'});
+ ($name, $category, $routine) = ($+{'text'}, $+{'category'}, $+{'routine'});
+ # Sometimes the regexp will pick up too much for the category
+ # e.g., WARN_UNINITIALIZED), PL_warn_uninit_sv ... up to the next )
+ $category && $category =~ s/\).*//s;
}
elsif (/$bad_version_re/) {
($name, $category) = ($+{'text'}, undef);
}
+ elsif (/$regcomp_fail_re/) {
+ # FAIL("foo") -> "foo in regex m/%s/"
+ # vFAIL("foo") -> "foo in regex; marked by <-- HERE in m/%s/"
+ ($name, $category) = ($+{'text'}, undef);
+ $name .=
+ " in regex" . ("; marked by <-- HERE in" x /vFAIL/) . " m/%s/";
+ }
+ elsif (/$regcomp_call_re/) {
+ # vWARN/ckWARNreg("foo") -> "foo in regex; marked by <-- HERE in m/%s/
+ ($name, $category, $routine) = ($+{'text'}, undef, $+{'routine'});
+ $name .= " in regex; marked by <-- HERE in m/%s/";
+ $category = 'WARN_REGEXP';
+ if ($routine =~ /dep/) {
+ $category .= ',WARN_DEPRECATED';
+ }
+ }
else {
next;
}
- my $severity = {croak => [qw/P F/],
- die => [qw/P F/],
- warn => [qw/W D S/],
- }->{$+{'routine'}||'die'};
- my @categories;
+ # Try to guess what the severity should be. In the case of
+ # Perl_ck_warner and other _ck_ functions, we can tell whether it is
+ # a severe/default warning or no by the _d suffix. In the case of
+ # other warn functions we cannot tell, because Perl_warner may be pre-
+ # ceded by if(ckWARN) or if(ckWARN_d).
+ my $severity = !$routine ? '[PFX]'
+ : $routine =~ /warn.*_d\z/ ? '[DS]'
+ : $routine =~ /ck_warn/ ? 'W'
+ : $routine =~ /warn/ ? '[WDS]'
+ : $routine =~ /ckWARN.*dep/ ? 'D'
+ : $routine =~ /ckWARN\d*reg/ ? 'W'
+ : $routine =~ /vWARN\d/ ? '[WDS]'
+ : '[PFX]';
+ my $categories;
if (defined $category) {
- @categories = map {s/^WARN_//; lc $_} split /\s*[|,]\s*/, $category;
+ $category =~ s/__/::/g;
+ $categories =
+ join ", ",
+ sort map {s/^WARN_//; lc $_} split /\s*[|,]\s*/, $category;
}
if ($listed_as and $listed_as_line == $. - $multiline) {
$name = $listed_as;
@@ -268,12 +335,13 @@
} else {
# The form listed in perldiag ignores most sorts of fancy printf
# formatting, or makes it more perlish.
- $name =~ s/%%/\\%/g;
+ $name =~ s/%%/%/g;
$name =~ s/%l[ud]/%d/g;
$name =~ s/%\.(\d+|\*)s/\%s/g;
- $name =~ s/\\"/"/g;
+ $name =~ s/(?:%s){2,}/%s/g;
+ $name =~ s/(\\")|("\s*[A-Z_]+\s*")/$1 ? '"' : '%s'/egg;
$name =~ s/\\t/\t/g;
- $name =~ s/\\n/ /g;
+ $name =~ s/\\n/\n/g;
$name =~ s/\s+$//;
$name =~ s/(\\)\\/$1/g;
}
@@ -291,17 +359,39 @@
# inside an #if 0 block.
next if $name eq 'SKIPME';
- $name = standardize($name);
+ next if $name=~/\[TESTING\]/; # ignore these as they are works in progress
- if (exists $entries{$name}) {
- if ( $entries{$name}{seen}++ ) {
+ check_message(standardize($name),$codefn,$severity,$categories);
+ }
+}
+
+sub check_message {
+ my($name,$codefn,$severity,$categories,$partial) = @_;
+ my $key = $name =~ y/\n/ /r;
+ my $ret;
+
+ # Try to reduce printf() formats to simplest forms
+ # Really this should be matching %s, etc like diagnostics.pm does
+
+ # Kill flags
+ $key =~ s/%[#0\-+]/%/g;
+
+ # Kill width
+ $key =~ s/\%(\d+|\*)/%/g;
+
+ # Kill precision
+ $key =~ s/\%\.(\d+|\*)/%/g;
+
+ if (exists $entries{$key}) {
+ $ret = 1;
+ if ( $entries{$key}{seen}++ ) {
# no need to repeat entries we've tested
- } elsif ($entries{$name}{todo}) {
+ } elsif ($entries{$key}{todo}) {
TODO: {
no warnings 'once';
local $::TODO = 'in DATA';
# There is no listing, but it is in the list of exceptions. TODO FAIL.
- fail($name);
+ fail($key);
diag(
" Message '$name'\n from $codefn line $. is not listed in $pod\n".
" (but it wasn't documented in 5.10 either, so marking it TODO)."
@@ -309,17 +399,46 @@
}
} else {
# We found an actual valid entry in perldiag.pod for this error.
- pass($name);
+ pass($key);
+
+ # Now check the category and severity
+
+ # Cache our severity qr thingies
+ use 5.01;
+ state %qrs;
+ my $qr = $qrs{$severity} ||= qr/$severity/;
+
+ return $ret
+ if $entries{$key}{cattodo};
+
+ like $entries{$key}{severity}, $qr,
+ $severity =~ /\[/
+ ? "severity is one of $severity for $key"
+ : "severity is $severity for $key";
+
+ is $entries{$key}{category}, $categories,
+ ($categories ? "categories are [$categories]" : "no category")
+ . " for $key";
}
# Later, should start checking that the severity is correct, too.
+ } elsif ($partial) {
+ # noop
} else {
- if ($make_exceptions_list) {
+ my $ok;
+ if ($name =~ /\n/) {
+ $ok = 1;
+ check_message($_,$codefn,$severity,$categories,1) or $ok = 0, last
+ for split /\n/, $name;
+ }
+ if ($ok) {
+ # noop
+ } elsif ($make_exceptions_list) {
# We're making an updated version of the exception list, to
# stick in the __DATA__ section. I honestly can't think of
# a situation where this is the right thing to do, but I'm
# leaving it here, just in case one of my descendents thinks
# it's a good idea.
- print STDERR "$name\n";
+ print STDERR "$key\n";
} else {
# No listing found, and no excuse either.
# Find the correct place in perldiag.pod, and add a stanza beginning =item $name.
@@ -331,7 +450,7 @@
}
die if $name =~ /%$/;
- }
+ return $ret;
}
# Lists all missing things as of the inauguration of this script, so we
@@ -340,91 +459,72 @@
# PLEASE DO NOT ADD TO THIS LIST. Instead, write an entry in
# pod/perldiag.pod for your new (warning|error).
+# Entries after __CATEGORIES__ are those that are in perldiag but fail the
+# severity/category test.
+
# Also FIXME this test, as the first entry in TODO *is* covered by the
# description: Malformed UTF-8 character (%s)
__DATA__
Malformed UTF-8 character (unexpected non-continuation byte 0x%x, immediately after start byte 0x%x)
-%s (%d) does not match %s (%d),
-%s (%d) smaller than %s (%d),
-Argument "%s" isn't numeric
-Argument "%s" isn't numeric in %s
-Attempt to clear deleted array
-Attempt to free non-existent shared string '%s'%s
-Attempt to free temp prematurely: SV 0x%x
-Attempt to free unreferenced scalar: SV 0x%x
-Attempt to reload %s aborted. Compilation failed in require
-av_reify called on tied array
-Bad name after %s%s
-Bad symbol for %s
+'%c' allowed only after types %s in %s
bad top format reference
-Bizarre copy of %s
-Bizarre SvTYPE [%d]
-Cannot copy to %s
-Can't call method "%s" %s
+Cannot apply "%s" in non-PerlIO perl
+Can't %s big-endian %ss on this
+Can't call mro_isa_changed_in() on anonymous symbol table
+Can't call mro_method_changed_in() on anonymous symbol table
Can't coerce readonly %s to string
Can't coerce readonly %s to string in %s
+Can't find string terminator %c%s%c anywhere before EOF
Can't fix broken locale name "%s"
Can't get short module name from a handle
-Can't goto subroutine from an eval-block
-Can't goto subroutine from an eval-string
Can't locate object method "%s" via package "%s" (perhaps you forgot to load "%s"?)
-Can't modify non-existent substring
-Can't open
-Can't open perl script "%s": %s
-Can't open %s
-Can't reset \%ENV on this system
-Can't return array to lvalue scalar context
-Can't return a %s from lvalue subroutine
-Can't return hash to lvalue scalar context
+Can't pipe "%s": %s
+Can't spawn: %s
Can't spawn "%s": %s
Can't %s script `%s' with ARGV[0] being `%s'
Can't %s "%s": %s
-Can't %s %s%s%s
Can't %s `%s' with ARGV[0] being `%s' (looking for executables only, not found)
-Can't take %s of %f
-Can't use '%c' after -mname
Can't use string ("%s"%s) as a subroutine ref while "strict refs" in use
-Can't use when() outside a topicalizer
\%c better written as $%c
Character(s) in '%c' format wrapped in %s
-$%c is no longer supported
-Cloning substitution context is unimplemented
+chown not implemented!
+clear %s
Code missing after '/' in pack
Code missing after '/' in unpack
-Corrupted regexp opcode %d > %d
'%c' outside of string in pack
-Debug leaking scalars child failed%s%s with errno %d: %s
-Deep recursion on anonymous subroutine
-defined(\%hash) is deprecated
+Debug leaking scalars child failed%s with errno %d: %s
+'/' does not take a repeat count in %s
+Don't know how to get file name
Don't know how to handle magic of type \%o
-Dp not implemented on this platform
-entering effective gid failed
-entering effective uid failed
Error reading "%s": %s
-Exiting %s via %s
+execl not implemented!
+EVAL without pos change exceeded limit in regex
Filehandle opened only for %sput
Filehandle %s opened only for %sput
Filehandle STD%s reopened as %s only for input
+filter_del can only delete in reverse order (currently)
YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET! FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!
-Format STDOUT redefined
+fork() not implemented!
+free %s
Free to wrong pool %p not %p
get %s %p %p %p
+gethostent not implemented!
+getpwnam returned invalid UIC %o for user "%s"
glob failed (can't start child: %s)
glob failed (child exited with status %d%s)
Goto undefined subroutine
Goto undefined subroutine &%s
-Hash \%%s missing the \% in argument %d of %s()
+Got signal %d
+()-group starts with a count in %s
+Illegal binary digit '%c' ignored
Illegal character %sin prototype for %s : %s
-Integer overflow in binary number
-Integer overflow in decimal number
-Integer overflow in hexadecimal number
-Integer overflow in octal number
-Integer overflow in version %d
-internal \%<num>p might conflict with future printf extensions
-invalid control request: '\%o'
-Invalid module name %s with -%c option: contains single ':'
-invalid option -D%c, use -D'' to see choices
+Illegal hexadecimal digit '%c' ignored
+Illegal octal digit '%c' ignored
+Infinite recursion in regex
+internal %<num>p might conflict with future printf extensions
+Invalid argument to sv_cat_decode
Invalid range "%c-%c" in transliteration operator
Invalid separator character %c%c%c in PerlIO layer specification %s
Invalid TOKEN object ignored
@@ -432,99 +532,117 @@
Invalid type '%c' in %s
Invalid type '%c' in unpack
Invalid type ',' in %s
+ioctlsocket not implemented!
'j' not supported on this platform
'J' not supported on this platform
-leaving effective gid failed
-leaving effective uid failed
-List form of piped open not implemented
-Lost precision when decrementing %f by 1
-Lost precision when incrementing %f by 1
-%lx
+killpg not implemented!
+length() used on %s (did you mean "scalar(%s)"?)
+length() used on %hash (did you mean "scalar(keys %hash)"?)
+length() used on @array (did you mean "scalar(@array)"?)
+List form of pipe open not implemented
+Malformed integer in [] in %s
Malformed UTF-8 character (fatal)
-'\%' may not be used in pack
Missing (suid) fd script name
More than one argument to open
More than one argument to open(,':%s')
mprotect for %p %u failed with %d
mprotect RW for %p %u failed with %d
-No code specified for -%c
-No directory specified for -I
+No %s allowed while running setgid
+No %s allowed with (suid) fdscript
No such class field "%s"
Not an XSUB reference
-Not %s reference
Operator or semicolon missing before %c%s
-Perl %s required (did you mean %s?)--this is only %s, stopped
+Pattern subroutine nesting without pos change exceeded limit in regex
Perl %s required--this is only %s, stopped
-Perls since %s too modern--this is %s, stopped
+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
Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)
-Recursive call to Perl_load_module in PerlIO_find_layer
+Regexp modifier "%c" may appear a maximum of twice in regex; marked by <-- HERE in m/%s/
+Regexp modifier "%c" may not appear twice in regex; marked by <-- HERE in m/%s/
+Regexp modifiers "%c" and "%c" are mutually exclusive in regex; marked by <-- HERE in m/%s/
+Regexp *+ operand could be empty in regex; marked by <-- HERE in m/%s/
+Repeated format line will never terminate (~~ and @#)
Reversed %c= operator
-Runaway prototype
-%s(%.0
%s(%f) failed
-%s(%f) too large
-%s(%f) too small
-Scalar value %s better written as $%s
-%sCompilation failed in regexp
%sCompilation failed in require
+Sequence (?%c...) not implemented in regex; marked by <-- HERE in m/%s/
+Sequence (%s...) not recognized in regex; marked by <-- HERE in m/%s/
+Sequence %s... not terminated in regex; marked by <-- HERE in m/%s/
+Sequence (?%c... not terminated in regex; marked by <-- HERE in m/%s/
+Sequence (?(%c... not terminated in regex; marked by <-- HERE in m/%s/
+Sequence (?R) not terminated in regex m/%s/
set %s %p %p %p
%s free() ignored (RMAGIC, PERL_CORE)
%s has too many errors.
SIG%s handler "%s" not defined.
-%s: illegal mapping '%s'
%s in %s
Size magic not implemented
-%s limit (%d) exceeded
-%s method "%s" overloading "%s" in package "%s"
%s number > %s non-portable
-%s object version %s does not match %s%s%s%s %s
%srealloc() %signored
-%s returned from lvalue subroutine in scalar context
-%s%s has too many errors.
-%s%s on %s %s
-%s%s on %s %s %s
+%s in regex m/%s/
+%s on %s %s
+socketpair not implemented!
Starting Full Screen process with flag=%d, mytype=%d
Starting PM process with flag=%d, mytype=%d
-strxfrm() gets absurd
+sv_2iv assumed (U_V(fabs((double)SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%f U_V is 0x%x, IV_MAX is 0x%x
SWASHNEW didn't return an HV ref
+switching effective gid is not implemented
+switching effective uid is not implemented
+System V IPC is not implemented on this machine
-T and -B not implemented on filehandles
+Terminating on signal SIG%s(%d)
+The crypt() function is not implemented on NetWare
The flock() function is not implemented on NetWare
The rewinddir() function is not implemented on NetWare
The seekdir() function is not implemented on NetWare
-The stat preceding lstat() wasn't an lstat
The telldir() function is not implemented on NetWare
Too deeply nested ()-groups in %s
-Too late to run CHECK block
-Too late to run INIT block
Too many args on %s line of "%s"
U0 mode on a byte string
-Unbalanced string table refcount: (%d) for "%s"
-Undefined top format called
-Unexpected constant lvalue entersub entry via type/targ %d:%d
-Unicode non-character 0x%X
-Unknown PerlIO layer "scalar"
+unable to find VMSPIPE.COM for i/o piping
+Unknown Unicode option value %d
+Unrecognized character %s; marked by <-- HERE after %s<-- HERE near column %d
Unstable directory path, current directory changed unexpectedly
-Unsupported script encoding UTF-16BE
-Unsupported script encoding UTF-16LE
-Unsupported script encoding UTF-32BE
-Unsupported script encoding UTF-32LE
Unterminated compressed integer in unpack
+Unterminated \g... pattern in regex; marked by <-- HERE in m/%s/
Usage: CODE(0x%x)(%s)
Usage: %s(%s)
Usage: %s::%s(%s)
+Usage: File::Copy::rmscopy(from,to[,date_flag])
+Usage: VMS::Filespec::candelete(spec)
+Usage: VMS::Filespec::fileify(spec)
+Usage: VMS::Filespec::pathify(spec)
+Usage: VMS::Filespec::rmsexpand(spec[,defspec])
+Usage: VMS::Filespec::unixify(spec)
+Usage: VMS::Filespec::unixpath(spec)
Usage: VMS::Filespec::unixrealpath(spec)
+Usage: VMS::Filespec::vmsify(spec)
+Usage: VMS::Filespec::vmspath(spec)
Usage: VMS::Filespec::vmsrealpath(spec)
Use of inherited AUTOLOAD for non-method %s::%s() is deprecated
utf8 "\x%X" does not map to Unicode
Value of logical "%s" too long. Truncating to %i bytes
-value of node is %d in Offset macro
-Value of %s%s can be "0"; test with defined()
-Variable "%c%s" is not imported
-vector argument not supported with alpha versions
+waitpid: process %x is not a child of process %x
Wide character
Wide character in $/
-Wide character in print
+Within []-length '*' not allowed in %s
Within []-length '%c' not allowed in %s
Wrong syntax (suid) fd script name "%s"
+'X' outside of string in %s
'X' outside of string in unpack
+
+__CATEGORIES__
+Code point 0x%X is not Unicode, all \p{} matches fail; all \P{} matches succeed
+Code point 0x%X is not Unicode, may not be portable
+Illegal character \%o (carriage return)
+Missing argument in %s
+Unicode non-character U+%X is illegal for open interchange
+Operation "%s" returns its argument for non-Unicode code point 0x%X
+Operation "%s" returns its argument for UTF-16 surrogate U+%X
+Unicode surrogate U+%X is illegal in UTF-8
+UTF-16 surrogate U+%X
+False [] range "%s" in regex; marked by <-- HERE in m/%s/
+\N{} in character class restricted to one character in regex; marked by <-- HERE in m/%s/
+Zero length \N{} in regex; marked by <-- HERE in m/%s/
+Expecting '(?flags:(?[...' in regex; marked by <-- HERE in m/%s/
Property changes on: trunk/contrib/perl/t/porting/diag.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/porting/dual-life.t
===================================================================
--- trunk/contrib/perl/t/porting/dual-life.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/porting/dual-life.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -6,6 +6,7 @@
#
# * Are all dual-life programs being generated in utils/?
+chdir 't';
require './test.pl';
plan('no_plan');
@@ -14,20 +15,20 @@
use File::Find;
use File::Spec::Functions;
-# Exceptions are found in dual-life bin dirs but aren't
-# installed by default
-my @not_installed = qw(
- ../cpan/Encode/bin/ucm2table
- ../cpan/Encode/bin/ucmlint
- ../cpan/Encode/bin/ucmsort
- ../cpan/Encode/bin/unidump
-);
+# Exceptions that are found in dual-life bin dirs but aren't
+# installed by default; some occur only during testing:
+my $not_installed = qr{^(?:
+ \.\./cpan/Encode/bin/u(?:cm(?:2table|lint|sort)|nidump)
+ |
+ \.\./cpan/Module-Build/MB-[\w\d]+/Simple/(?:test_install/)?bin/.*
+)\z}ix;
my %dist_dir_exe;
-foreach (qw (podchecker podselect pod2usage)) {
- $dist_dir_exe{lc "$_.PL"} = "../cpan/Pod-Parser/$_";
-};
+$dist_dir_exe{lc "podselect.PL"} = "../cpan/Pod-Parser/podselect";
+$dist_dir_exe{lc "podchecker.PL"} = "../cpan/Pod-Checker/podchecker";
+$dist_dir_exe{lc "pod2usage.PL"} = "../cpan/Pod-Usage/pod2usage";
+
foreach (qw (pod2man pod2text)) {
$dist_dir_exe{lc "$_.PL"} = "../cpan/podlators/$_";
};
@@ -36,13 +37,13 @@
my @programs;
find(
- sub {
+ { no_chidr => 1, wanted => sub {
my $name = $File::Find::name;
return if $name =~ /blib/;
- return unless $name =~ m{/(?:bin|scripts?)/\S+\z};
+ return unless $name =~ m{/(?:bin|scripts?)/\S+\z} && $name !~ m{/t/};
push @programs, $name;
- },
+ }},
qw( ../cpan ../dist ../ext ),
);
@@ -50,12 +51,12 @@
for my $f ( @programs ) {
$f =~ s/\.\z// if $^O eq 'VMS';
- next if qr/(?i:$f)/ ~~ @not_installed;
- $f = basename($f);
- if(qr/\A(?i:$f)\z/ ~~ %dist_dir_exe) {
- ok( -f "$dist_dir_exe{lc $f}$ext", "$f$ext");
+ next if $f =~ $not_installed;
+ my $bn = basename($f);
+ if(grep { /\A(?i:$bn)\z/ } keys %dist_dir_exe) {
+ ok( -f "$dist_dir_exe{lc $bn}$ext", "$f$ext");
} else {
- ok( -f catfile('..', 'utils', "$f$ext"), "$f$ext" );
+ ok( -f catfile('..', 'utils', "$bn$ext"), "$f$ext" );
}
}
Property changes on: trunk/contrib/perl/t/porting/dual-life.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/porting/exec-bit.t
===================================================================
--- trunk/contrib/perl/t/porting/exec-bit.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/porting/exec-bit.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -5,7 +5,17 @@
# This test checks that anything with an executable bit is
# identified in Porting/exec-bit.txt to makerel will set
# the exe bit in the release tarball
+# and that anything with an executable bit also has a shebang
+sub has_shebang {
+ my $fname = shift;
+ open my $fh, '<', $fname or die "Can't open '$fname': $!";
+ my $line = <$fh>;
+ close $fh;
+
+ return $line =~ /^\#!\s*([A-Za-z0-9_\-\/\.])+\s?/ ? 1 : 0;
+}
+
require './test.pl';
if ( $^O eq "MSWin32" ) {
skip_all( "-x on MSWin32 only indicates file has executable suffix. Try Cygwin?" );
@@ -15,12 +25,13 @@
skip_all( "Filename case may not be preserved and other porting issues." );
}
+if ( $^O eq "vos" ) {
+ skip_all( "VOS combines the read and execute permission bits." );
+}
+
plan('no_plan');
use ExtUtils::Manifest qw(maniread);
-use File::Basename;
-use File::Find;
-use File::Spec::Functions;
# Copied from Porting/makerel - these will get +x in the tarball
# XXX refactor? -- dagolden, 2010-07-23
@@ -39,6 +50,8 @@
for my $f ( map { "../$_" } @manifest ) {
next unless -x $f;
+ ok( has_shebang($f), "File $f has shebang" );
+
ok( $exe_list{$f}, "tarball will chmod +x $f" )
or diag( "Remove the exec bit or add '$f' to Porting/exec-bit.txt" );
@@ -47,4 +60,3 @@
ok( ! %exe_list, "Everything in Porting/exec-bit.txt has +x in repo" )
or diag( "Files missing exec bit:\n " . join("\n ", sort keys %exe_list) . "\n");
-
Property changes on: trunk/contrib/perl/t/porting/exec-bit.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/porting/extrefs.t (from rev 6437, vendor/perl/5.18.1/t/porting/extrefs.t)
===================================================================
--- trunk/contrib/perl/t/porting/extrefs.t (rev 0)
+++ trunk/contrib/perl/t/porting/extrefs.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,128 @@
+#!./perl -w
+
+# What does this test?
+# Test that changes to perl header files don't cause external
+# references by simplying #including them. This breaks library probe
+# code on CPAN, and can break cflags.SH.
+#
+# Why do we test this?
+# See https://rt.perl.org/rt3/Ticket/Display.html?id=116989
+#
+# It's broken - how do I fix it?
+# You added an initializer or static function to a header file that
+# references some symbol you didn't define, you need to remove it.
+
+BEGIN {
+ require "./test.pl";
+ unshift @INC, ".." if -f "../TestInit.pm";
+}
+
+use TestInit qw(T A); # T is chdir to the top level, A makes paths absolute
+use strict;
+use warnings;
+use Config;
+use File::Path 'rmtree';
+use Cwd;
+
+plan(tests => 1);
+
+my $VERBOSE = grep {$_ eq '-v'} @ARGV;
+
+ok(try_compile_and_link(<<'CODE'));
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+int main(int argc, char **argv) {
+ return 0;
+}
+CODE
+
+
+# from Time::HiRes's Makefile.PL with minor modifications
+sub try_compile_and_link {
+ my ($c, %args) = @_;
+
+ my $ld_exeext = ($^O eq 'cygwin' || $^O eq 'MSWin32' ||
+ $^O eq 'os2' && $Config{ldflags} =~ /-Zexe\b/) ? '.exe' :
+ (($^O eq 'vos') ? $Config{exe_ext} : '');
+
+ my ($ok) = 0;
+ my $tempdir = tempfile();
+ my $cwd = getcwd();
+ mkdir $tempdir;
+ chdir $tempdir;
+ my ($tmp) = "temp";
+
+ my $obj_ext = $Config{obj_ext} || ".o";
+
+ if (open(my $tmpc, ">$tmp.c")) {
+ print $tmpc $c;
+ unless (close($tmpc)) {
+ chdir($cwd);
+ rmtree($tempdir);
+ warn "Failing closing code file: $!\n" if $VERBOSE;
+ return 0;
+ }
+
+ my $COREincdir = File::Spec->catdir(File::Spec->updir);
+
+ my $ccflags = $Config{'ccflags'} . ' ' . "-I$COREincdir"
+ . ' -DPERL_NO_INLINE_FUNCTIONS';
+
+ if ($^O eq "MSWin32") {
+ $ccflags .= " -I../win32 -I../win32/include";
+ }
+
+ my $libs = '';
+
+ # Include libs to be sure of linking against bufferoverflowU.lib for
+ # the SDK2003 compiler on Windows. See win32/Makefile for more details.
+ if ($^O eq "MSWin32" && $Config{cc} =~ /\bcl\b/i) {
+ $libs = " /link $Config{'libs'}";
+ }
+
+ my $null = File::Spec->devnull;
+
+ my $errornull = $VERBOSE ? '' : ">$null 2>$null";
+
+ # Darwin g++ 4.2.1 is fussy and demands a space.
+ # FreeBSD g++ 4.2.1 does not.
+ # We do not know the reaction of either to the presence of brown M&Ms.
+ my $out_opt = "-o ";
+ if ($^O eq "MSWin32" && $Config{cc} =~ /\bcl\b/i) {
+ $out_opt = "/Fe";
+ }
+
+ my $tmp_exe = "$tmp$ld_exeext";
+
+ my $cccmd = "$Config{'cc'} $out_opt$tmp_exe $ccflags $tmp.c $libs $errornull";
+
+ if ($^O eq 'VMS') {
+ $cccmd = "$Config{'cc'} /include=($COREincdir) $tmp.c";
+ }
+
+ if ($^O eq 'VMS') {
+ open( my $cmdfile, ">$tmp.com" );
+ print $cmdfile "\$ SET MESSAGE/NOFACILITY/NOSEVERITY/NOIDENT/NOTEXT\n";
+ print $cmdfile "\$ $cccmd\n";
+ print $cmdfile "\$ IF \$SEVERITY .NE. 1 THEN EXIT 44\n"; # escalate
+ close $cmdfile;
+ system("\@ $tmp.com");
+ $ok = $?==0;
+ chdir($cwd);
+ rmtree($tempdir);
+ }
+ else
+ {
+ printf "cccmd = $cccmd\n" if $VERBOSE;
+ my $res = system($cccmd);
+ $ok = defined($res) && $res == 0 && -s $tmp_exe && -x _;
+
+ chdir($cwd);
+ rmtree($tempdir);
+ }
+ }
+
+ return $ok;
+}
Modified: trunk/contrib/perl/t/porting/filenames.t
===================================================================
--- trunk/contrib/perl/t/porting/filenames.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/porting/filenames.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -27,12 +27,11 @@
}
use strict;
-use File::Spec;
use File::Basename;
require './test.pl';
-my $manifest = File::Spec->catfile(File::Spec->updir(), 'MANIFEST');
+my $manifest = '../MANIFEST';
open my $m, '<', $manifest or die "Can't open '$manifest': $!";
my @files;
@@ -46,59 +45,38 @@
plan(scalar @files);
-for my $file (@files) {
- validate_file_name($file);
-}
-exit 0;
-
-
-sub validate_file_name {
- my $path = shift;
- my $filename = basename $path;
-
- note("testing $path");
-
- my @path_components = split('/',$path);
- pop @path_components; # throw away the filename
+PATHNAME: for my $pathname (@files) {
+ my @path_components = split('/',$pathname);
+ my $filename = pop @path_components;
for my $component (@path_components) {
- if ($component =~ /\..*?\./) {
- fail("no directory components containing more than one '.'");
- return;
- }
- if (length $component > 32) {
- fail("no directory with a name over 32 characters (VOS requirement)");
- return;
- }
+ if ($component =~ /\./) {
+ fail("$pathname has directory components containing '.'");
+ next PATHNAME;
+ }
+ if (length $component > 32) {
+ fail("$pathname has a name over 32 characters (VOS requirement)");
+ next PATHNAME;
+ }
}
if ($filename =~ /^\-/) {
- fail("filename does not start with -");
- return;
+ fail("$pathname starts with -");
+ next PATHNAME;
}
my($before, $after) = split /\./, $filename;
if (length $before > 39) {
- fail("filename has 39 or fewer characters before the dot");
- return;
+ fail("$pathname has more than 39 characters before the dot");
+ } elsif ($after && length $after > 39) {
+ fail("$pathname has more than 39 characters after the dot");
+ } elsif ($filename =~ /^(?:CON|PRN|AUX|NUL|COM[1-9]|LPT[1-9])\./i) {
+ fail("$pathname has a reserved name");
+ } elsif ($filename =~ /\s|\(|\&/) {
+ fail("$pathname has a reserved character");
+ } else {
+ pass("$pathname ok");
}
- if ($after) {
- if (length $after > 39) {
- fail("filename has 39 or fewer characters after the dot");
- return;
- }
- }
-
- if ($filename =~ /^(?:CON|PRN|AUX|NUL|COM[1-9]|LPT[1-9])\./i) {
- fail("filename has a reserved name");
- return;
- }
-
- if ($filename =~ /\s|\(|\&/) {
- fail("filename has a reserved character");
- return;
- }
- pass("filename ok");
}
# EOF
Property changes on: trunk/contrib/perl/t/porting/filenames.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/porting/globvar.t (from rev 6437, vendor/perl/5.18.1/t/porting/globvar.t)
===================================================================
--- trunk/contrib/perl/t/porting/globvar.t (rev 0)
+++ trunk/contrib/perl/t/porting/globvar.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,77 @@
+#!perl -w
+
+use TestInit qw(T);
+use strict;
+use Config;
+
+require 't/test.pl';
+
+skip_all("Code to read symbols not ported to $^O")
+ if $^O eq 'VMS' or $^O eq 'MSWin32';
+
+# Not investigated *why* we don't export these, but we don't, and we've not
+# received any bug reports about it causing problems:
+my %skip = map { ("PL_$_", 1) }
+ qw(
+ DBcv bitcount cshname force_link_funcs generation lastgotoprobe
+ mod_latin1_uc modcount no_symref_sv timesbuf uudmap
+ watchaddr watchok warn_uninit_sv
+ );
+
+$skip{PL_hash_rand_bits}= $skip{PL_hash_rand_bits_enabled}= 1; # we can be compiled without these, so skip testing them
+
+
+my $trial = "nm globals$Config{_o} 2>&1";
+my $yes = `$trial`;
+
+skip_all("Could not run `$trial`") if $?;
+
+my $defined = qr/^[0-9a-fA-F]{8,16}\s+[^Uu]\s+_?/m;
+
+skip_all("Could not spot definition of PL_Yes in output of `$trial`")
+ unless $yes =~ /${defined}PL_Yes/m;
+
+my %exported;
+open my $fh, '-|', $^X, '-Ilib', './makedef.pl', 'PLATFORM=test'
+ or die "Can't run makedef.pl";
+
+while (<$fh>) {
+ next unless /^PL_/;
+ chomp;
+ ++$exported{$_};
+}
+
+close $fh or die "Problem running makedef.pl";
+
+my %unexported;
+
+foreach my $file (map {$_ . $Config{_o}} qw(globals regcomp)) {
+ open $fh, '-|', 'nm', $file
+ or die "Can't run nm $file";
+
+ while (<$fh>) {
+ next unless /$defined(PL_\S+)/;
+ if (delete $exported{$1}) {
+ note("Seen definition of $1");
+ next;
+ }
+ ++$unexported{$1};
+ }
+ close $fh or die "Problem running nm $file";
+}
+
+foreach (sort keys %exported) {
+ SKIP: {
+ skip("We dont't export '$_' (Perl not built with this enabled?)",1) if $skip{$_};
+ fail("Attempting to export '$_' which is never defined");
+ }
+}
+
+foreach (sort keys %unexported) {
+ SKIP: {
+ skip("We don't export '$_'", 1) if $skip{$_};
+ fail("'$_' is defined, but we do not export it");
+ }
+}
+
+done_testing();
Copied: trunk/contrib/perl/t/porting/known_pod_issues.dat (from rev 6437, vendor/perl/5.18.1/t/porting/known_pod_issues.dat)
===================================================================
--- trunk/contrib/perl/t/porting/known_pod_issues.dat (rev 0)
+++ trunk/contrib/perl/t/porting/known_pod_issues.dat 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,326 @@
+# 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
+# regen'd.
+# Lines without tab characters are simply NAMES of pods that the program knows
+# will have links to them and the program does not check if those links are
+# valid.
+# All other lines should have three fields, each separated by a tab. The
+# first field is the name of a pod; the second field is an error message
+# generated by this program; and the third field is a count of how many
+# known instances of that message there are in the pod. -1 means that the
+# program can expect any number of this type of message.
+_control87(3)
+Algorithm::C3
+AnyEvent
+Apache::MP3
+Array::Base
+Attribute::Constant
+basename(1)
+Benchmark::Perl::Formance
+ByteLoader
+bzip2(1)
+Carp::Always
+Carp::Assert
+Carp::Clan
+chcp(1)
+Class::Accessor
+Class::C3
+Class::ISA
+Class::PseudoHash
+Classic::Perl
+Clone
+Crypt::Random
+curl(1)
+Data::Entropy
+Data::Float
+Data::Types
+Date::Pcalc
+DateTime
+DB_File(3)
+DBIx::Profile
+Devel::Callsite
+Devel::DProf
+Devel::DTrace::Provider
+Devel::NYTProf
+Devel::PPPort
+Devel::SawAmpersand
+dirname(1)
+Encode::Locale
+Exporter::Easy
+ExtUtils::Constant::ProxySubs
+fetch(1)
+File::chdir
+File::Copy::Recursive
+File::Findgrep
+File::MMagic
+File::ShareDir
+flock(3)
+fsync(3c)
+gcc(1)
+getpriority(2)
+HTTP::Lite
+inetd(8)
+IPC::Run
+IPC::Signal
+kill(3)
+langinfo(3)
+Lingua::KO::Hangul::Util
+local::lib
+Mail::Send
+man(5)
+man(7)
+Math::Big
+Math::BigInt::Constant
+Math::BigInt::GMP
+Math::BigInt::Pari
+Math::Random::MT::Perl
+Math::Random::Secure
+Math::TrulyRandom
+md5sum(1)
+Module::CPANTS::Analyse
+Module::Find
+Module::Info
+Module::Starter
+Moo
+Moose
+MRO::Compat
+nl_langinfo(3)
+Number::Format
+Object::InsideOut
+Object::Tiny
+open(2)
+OS2::Proc
+OS2::WinObject
+PadWalker
+passwd(1)
+perl(1)
+Perl4::CoreLibs
+Perl::Unsafe::Signals
+perlbug(1)
+PerlIO::locale
+PerlIO::Util
+PerlIO::via::Base64
+PerlIO::via::StripHTML
+perllexwarn(1)
+perlthanks
+pod/perldiag.pod Verbatim line length including indents exceeds 79 by 1
+pod/perlrun.pod Verbatim line length including indents exceeds 79 by 3
+POD2::FR
+POD2::IT
+pod2ipf(1)
+pod2man(1)
+Pod::HTML2Pod
+Pod::Plainer
+Pod::PXML
+poll(2)
+prctl(2)
+printf(3)
+pstruct
+ptar(1)
+ptargrep(1)
+pwd_mkdb(8)
+Readonly
+recvmsg(3)
+Role::Tiny
+s2p
+Scalar::Readonly
+Semi::Semicolons
+sendmail(1)
+sendmsg(3)
+sha1sum(1)
+Shell
+Shell::Command
+sock_init(3)
+Socket
+socketpair(3)
+SOM
+splain
+sprintf(3)
+stat(2)
+String::Base
+String::Scanf
+Switch
+tar(1)
+Test::Harness::TAP
+Test::Inline
+Test::MockObject
+Text::Autoformat
+Text::Template
+Text::Unidecode
+Time::Object
+Tk
+Tk::Pod
+tty(1)
+Unicode::Casing
+Unicode::Regex::Set
+Unicode::Semantics
+Unicode::Unihan
+unzip(1)
+Version::Requirements
+wait(2)
+waitpid(3)
+wget(1)
+Win32::Locale
+YAML
+YAML::Syck
+YAML::Tiny
+dist/cwd/lib/file/spec/vms.pm Verbatim line length including indents exceeds 79 by 1
+dist/cwd/lib/file/spec/win32.pm Verbatim line length including indents exceeds 79 by 1
+dist/data-dumper/dumper.pm ? Should you be using L<...> instead of 1
+dist/extutils-parsexs/lib/perlxs.pod Verbatim line length including indents exceeds 79 by 1
+dist/extutils-parsexs/lib/perlxstut.pod Verbatim line length including indents exceeds 79 by 10
+dist/filter-simple/lib/filter/simple.pm Verbatim paragraph in NAME section 1
+dist/locale-maketext/lib/locale/maketext/tpj13.pod No items in =over / =back list 3
+dist/math-bigint/lib/math/bigint.pm Verbatim line length including indents exceeds 79 by 77
+dist/math-bigint/lib/math/bigint/calcemu.pm empty section in previous paragraph 3
+dist/math-bigrat/lib/math/bigrat.pm Verbatim line length including indents exceeds 79 by 7
+dist/math-bigrat/lib/math/bigrat.pm unresolved internal link 1
+dist/module-corelist/lib/module/corelist.pod Verbatim line length including indents exceeds 79 by 4
+dist/module-corelist/lib/module/corelist/utils.pm Verbatim line length including indents exceeds 79 by 2
+dist/net-ping/lib/net/ping.pm Verbatim line length including indents exceeds 79 by 2
+dist/safe/safe.pm Verbatim line length including indents exceeds 79 by 1
+dist/safe/safe.pm empty section in previous paragraph 1
+dist/selfloader/lib/selfloader.pm Verbatim line length including indents exceeds 79 by 13
+dist/storable/storable.pm Verbatim line length including indents exceeds 79 by 4
+dist/thread-queue/lib/thread/queue.pm Verbatim line length including indents exceeds 79 by 4
+dist/threads/lib/threads.pm Verbatim line length including indents exceeds 79 by 3
+dist/tie-file/lib/tie/file.pm Verbatim line length including indents exceeds 79 by 3
+ext/b/b/concise.pm Verbatim line length including indents exceeds 79 by 1
+ext/devel-peek/peek.pm ? Should you be using L<...> instead of 2
+ext/devel-peek/peek.pm Verbatim line length including indents exceeds 79 by 2
+ext/dynaloader/dynaloader.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 Verbatim line length including indents exceeds 79 by 2
+ext/i18n-langinfo/langinfo.pm Verbatim line length including indents exceeds 79 by 1
+ext/pod-html/bin/pod2html Pod NAME already used 1
+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
+ext/pod-html/testdir/perlvar-copy.pod Verbatim line length including indents exceeds 79 by 6
+ext/posix/lib/posix.pod Verbatim line length including indents exceeds 79 by 13
+ext/vms-dclsym/dclsym.pm ? Should you be using L<...> instead of 1
+ext/vms-dclsym/dclsym.pm Verbatim line length including indents exceeds 79 by 1
+ext/vms-stdio/stdio.pm Verbatim line length including indents exceeds 79 by 1
+ext/xs-apitest/apitest.pm Verbatim line length including indents exceeds 79 by 1
+install ? Should you be using F<...> or maybe L<...> instead of 1
+installhtml Verbatim line length including indents exceeds 79 by 3
+os2/os2/os2-extattr/extattr.pm ? Should you be using F<...> or maybe L<...> instead of 1
+os2/os2/os2-process/process.pm Verbatim line length including indents exceeds 79 by 27
+os2/os2/os2-rexx/dll/dll.pm Verbatim line length including indents exceeds 79 by 2
+os2/os2/os2-rexx/rexx.pm Verbatim line length including indents exceeds 79 by 1
+pod/perl.pod Verbatim line length including indents exceeds 79 by 8
+pod/perlaix.pod Verbatim line length including indents exceeds 79 by 11
+pod/perlapi.pod ? Should you be using L<...> instead of 76
+pod/perlapi.pod Verbatim line length including indents exceeds 79 by 6
+pod/perlapi.pod unresolved internal link 3
+pod/perlapio.pod Verbatim line length including indents exceeds 79 by 5
+pod/perlbook.pod Verbatim line length including indents exceeds 79 by 1
+pod/perlcall.pod Verbatim line length including indents exceeds 79 by 2
+pod/perlce.pod Verbatim line length including indents exceeds 79 by 2
+pod/perlclib.pod Verbatim line length including indents exceeds 79 by 3
+pod/perlcygwin.pod Verbatim line length including indents exceeds 79 by 25
+pod/perldbmfilter.pod Verbatim line length including indents exceeds 79 by 1
+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/perldiag.pod =item type mismatch 1
+pod/perldiag.pod Verbatim line length including indents exceeds 79 by 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/perlebcdic.pod Verbatim line length including indents exceeds 79 by 13
+pod/perlembed.pod Verbatim line length including indents exceeds 79 by 27
+pod/perlfunc.pod There is more than one target 1
+pod/perlgit.pod Verbatim line length including indents exceeds 79 by 12
+pod/perlgpl.pod Verbatim line length including indents exceeds 79 by 50
+pod/perlguts.pod ? Should you be using F<...> or maybe L<...> instead of 2
+pod/perlguts.pod ? Should you be using L<...> instead of 1
+pod/perlhack.pod ? Should you be using L<...> instead of 1
+pod/perlhack.pod Verbatim line length including indents exceeds 79 by 1
+pod/perlhist.pod Verbatim line length including indents exceeds 79 by 1
+pod/perlhpux.pod Verbatim line length including indents exceeds 79 by 5
+pod/perlhurd.pod Verbatim line length including indents exceeds 79 by 2
+pod/perlintern.pod ? Should you be using L<...> instead of 5
+pod/perlinterp.pod ? Should you be using L<...> instead of 1
+pod/perliol.pod Verbatim line length including indents exceeds 79 by 8
+pod/perlipc.pod Verbatim line length including indents exceeds 79 by 19
+pod/perlirix.pod Verbatim line length including indents exceeds 79 by 4
+pod/perllol.pod Verbatim line length including indents exceeds 79 by 4
+pod/perlmacosx.pod Verbatim line length including indents exceeds 79 by 4
+pod/perlmod.pod Verbatim line length including indents exceeds 79 by 2
+pod/perlmodlib.pod Verbatim line length including indents exceeds 79 by 3
+pod/perlmodstyle.pod Verbatim line length including indents exceeds 79 by 2
+pod/perlmroapi.pod ? Should you be using L<...> instead of 1
+pod/perlnetware.pod Verbatim line length including indents exceeds 79 by 4
+pod/perlnewmod.pod Verbatim line length including indents exceeds 79 by 1
+pod/perlootut.pod ? Should you be using F<...> or maybe L<...> instead of 1
+pod/perlos2.pod ? Should you be using L<...> instead of 2
+pod/perlos2.pod Verbatim line length including indents exceeds 79 by 22
+pod/perlos390.pod Verbatim line length including indents exceeds 79 by 11
+pod/perlpacktut.pod Verbatim line length including indents exceeds 79 by 6
+pod/perlperf.pod Verbatim line length including indents exceeds 79 by 154
+pod/perlpodspec.pod Verbatim line length including indents exceeds 79 by 9
+pod/perlpodstyle.pod Verbatim line length including indents exceeds 79 by 1
+pod/perlref.pod Verbatim line length including indents exceeds 79 by 1
+pod/perlrequick.pod Verbatim line length including indents exceeds 79 by 3
+pod/perlretut.pod Verbatim line length including indents exceeds 79 by 13
+pod/perlrun.pod Verbatim line length including indents exceeds 79 by 3
+pod/perlsolaris.pod Verbatim line length including indents exceeds 79 by 14
+pod/perlsource.pod ? Should you be using F<...> or maybe L<...> instead of 1
+pod/perlsub.pod ? Should you be using F<...> or maybe L<...> instead of 3
+pod/perlsub.pod Verbatim line length including indents exceeds 79 by 4
+pod/perlsymbian.pod Verbatim line length including indents exceeds 79 by 20
+pod/perlthrtut.pod Verbatim line length including indents exceeds 79 by 5
+pod/perltie.pod Verbatim line length including indents exceeds 79 by 13
+pod/perltrap.pod ? Should you be using F<...> or maybe L<...> instead of 1
+pod/perltru64.pod ? Should you be using F<...> or maybe L<...> instead of 1
+pod/perltru64.pod Verbatim line length including indents exceeds 79 by 4
+pod/perlunifaq.pod empty section in previous paragraph 1
+pod/perluniprops.pod =item type mismatch 6
+pod/perlvms.pod ? Should you be using F<...> or maybe L<...> instead of 1
+pod/perlvms.pod Verbatim line length including indents exceeds 79 by 2
+pod/perlwin32.pod Verbatim line length including indents exceeds 79 by 12
+porting/epigraphs.pod Verbatim line length including indents exceeds 79 by 3
+porting/expand-macro.pl Verbatim line length including indents exceeds 79 by 2
+porting/how_to_write_a_perldelta.pod There is no NAME 1
+porting/how_to_write_a_perldelta.pod Verbatim line length including indents exceeds 79 by 3
+porting/pumpkin.pod Verbatim line length including indents exceeds 79 by 9
+porting/release_managers_guide.pod Verbatim line length including indents exceeds 79 by 7
+porting/release_schedule.pod There is no NAME 1
+porting/todo.pod Verbatim line length including indents exceeds 79 by 7
+symbian/perlutil.pod Verbatim line length including indents exceeds 79 by 4
+utils/c2ph Verbatim line length including indents exceeds 79 by 44
+utils/pod2html Pod NAME already used 1
+vms/ext/filespec.pm Verbatim line length including indents exceeds 79 by 1
+x2p/a2p.pod empty section in previous paragraph 2
+lib/benchmark.pm Verbatim line length including indents exceeds 79 by 4
+lib/class/struct.pm Verbatim line length including indents exceeds 79 by 7
+lib/config.pod ? Should you be using L<...> instead of -1
+lib/config.pod nested commands F<...F<...>...> 3
+lib/db.pm Verbatim line length including indents exceeds 79 by 2
+lib/dbm_filter.pm Verbatim line length including indents exceeds 79 by 1
+lib/dbm_filter/compress.pm Verbatim line length including indents exceeds 79 by 1
+lib/dbm_filter/encode.pm Verbatim line length including indents exceeds 79 by 1
+lib/dbm_filter/int32.pm Verbatim line length including indents exceeds 79 by 1
+lib/dbm_filter/null.pm Verbatim line length including indents exceeds 79 by 1
+lib/dbm_filter/utf8.pm Verbatim line length including indents exceeds 79 by 1
+lib/deprecate.pm Verbatim line length including indents exceeds 79 by 2
+lib/english.pm Verbatim line length including indents exceeds 79 by 1
+lib/extutils/embed.pm Verbatim line length including indents exceeds 79 by 2
+lib/extutils/xssymset.pm Verbatim line length including indents exceeds 79 by 1
+lib/file/basename.pm Verbatim line length including indents exceeds 79 by 2
+lib/file/find.pm Verbatim line length including indents exceeds 79 by 1
+lib/getopt/std.pm Verbatim line length including indents exceeds 79 by 1
+lib/integer.pm Verbatim line length including indents exceeds 79 by 1
+lib/perl5db.pl ? Should you be using L<...> instead of 1
+lib/perl5db.pl Verbatim line length including indents exceeds 79 by 1
+lib/perlio.pm Verbatim line length including indents exceeds 79 by 2
+lib/pod/text/overstrike.pm Verbatim line length including indents exceeds 79 by 1
+lib/strict.pm Verbatim line length including indents exceeds 79 by 1
+lib/tie/array.pm Verbatim line length including indents exceeds 79 by 1
+lib/tie/hash.pm Verbatim line length including indents exceeds 79 by 3
+lib/tie/scalar.pm Verbatim line length including indents exceeds 79 by 1
+lib/utf8.pm Verbatim line length including indents exceeds 79 by 4
+lib/version.pod Verbatim line length including indents exceeds 79 by 1
+lib/version/internals.pod Verbatim line length including indents exceeds 79 by 2
+lib/vmsish.pm Verbatim line length including indents exceeds 79 by 1
Modified: trunk/contrib/perl/t/porting/maintainers.t
===================================================================
--- trunk/contrib/perl/t/porting/maintainers.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/porting/maintainers.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -11,6 +11,7 @@
chdir '..' unless -d 't';
@INC = qw(lib Porting);
+ require './t/test.pl';
}
use strict;
@@ -18,17 +19,16 @@
use Maintainers qw(show_results process_options finish_tap_output);
if ($^O eq 'VMS') {
- print "1..0 # Skip: home-grown glob doesn't handle fancy patterns\n";
- exit 0;
+ skip_all "home-grown glob doesn't handle fancy patterns";
}
{
- local @ARGV = qw|--tap-output --checkmani|;
+ local @ARGV = qw|--checkmani|;
show_results(process_options());
}
{
- local @ARGV = qw|--tap-output --checkmani lib/ ext/|;
+ local @ARGV = qw|--checkmani lib/ ext/|;
show_results(process_options());
}
Property changes on: trunk/contrib/perl/t/porting/maintainers.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/porting/manifest.t
===================================================================
--- trunk/contrib/perl/t/porting/manifest.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/porting/manifest.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -3,17 +3,15 @@
# Test the well-formed-ness of the MANIFEST file.
BEGIN {
- chdir 't';
- @INC = '../lib';
+ @INC = '..' if -f '../TestInit.pm';
}
+use TestInit qw(T); # T is chdir to the top level
-use strict;
-use File::Spec;
-require './test.pl';
+require 't/test.pl';
plan('no_plan');
-my $manifest = File::Spec->catfile(File::Spec->updir(), 'MANIFEST');
+my $manifest = 'MANIFEST';
open my $m, '<', $manifest or die "Can't open '$manifest': $!";
my @files;
@@ -29,8 +27,7 @@
push @files, $file;
isnt($file, undef, "Line $. doesn't start with a blank") or next;
- # Remember, we're running from t/
- ok(-f "../$file", "File $file exists");
+ ok(-f $file, "File $file exists");
if ($separator !~ tr/\t//c) {
# It's all tabs
next;
@@ -48,10 +45,10 @@
# Test that MANIFEST is properly sorted
SKIP: {
- skip("'Porting/manisort' not found", 1) if (! -f '../Porting/manisort');
+ skip("'Porting/manisort' not found", 1) if (! -f 'Porting/manisort');
- my $result = runperl('progfile' => '../Porting/manisort',
- 'args' => [ '-c', '../MANIFEST' ],
+ my $result = runperl('progfile' => 'Porting/manisort',
+ 'args' => [ '-c', $manifest ],
'stderr' => 1);
like($result, qr/is sorted properly/, 'MANIFEST sorted properly');
@@ -58,12 +55,11 @@
}
SKIP: {
- chdir "..";
- skip("not under git control", 3) unless -d '.git';
+ find_git_or_skip(6);
chomp(my @repo= grep { !/\.gitignore$/ } `git ls-files`);
skip("git ls-files didnt work",3)
if !@repo;
- is( 0+ at repo, 0+ at files, "git ls-files has a corresponding number of files as does MANIFEST");
+ is( 0+ at repo, 0+ at files, "git ls-files gives the same number of files as MANIFEST lists");
my %repo= map { $_ => 1 } @repo;
my %mani= map { $_ => 1 } @files;
is( 0+keys %mani, 0+ at files, "no duplicate files in MANIFEST");
Property changes on: trunk/contrib/perl/t/porting/manifest.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/porting/pending-author.t (from rev 6437, vendor/perl/5.18.1/t/porting/pending-author.t)
===================================================================
--- trunk/contrib/perl/t/porting/pending-author.t (rev 0)
+++ trunk/contrib/perl/t/porting/pending-author.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,58 @@
+#!./perl -w
+
+# What does this test?
+# This uses Porting/checkAUTHORS.pl to check that any pending commit isn't
+# about to break t/porting/authors.t
+#
+# Why do we test this?
+# t/porting/authors.t checks that the AUTHORS file is up to date, accounting
+# for the "Author:" of every commit. However, any pending changes can't be
+# tested, which leaves a gotcha - "make test" can pass, one then commits
+# the passing code, pushes it uptream, and tests fail. So this test attempts
+# to spot that problem before it happens, where it can.
+#
+# It's broken - how do I fix it?
+# It will fail if you're in a git checkout, have uncommitted changes, and the
+# e-mail address that your commit will default to is in AUTHORS, or the list
+# of author aliases in Porting/checkAUTHORS.pl. So one of
+# a) reset your pending changes
+# b) change your git config user.email to the previously-known e-mail address
+# c) add yourself to AUTHORS
+# d) add an alias to Porting/checkAUTHORS.pl
+
+BEGIN {
+ @INC = '..' if -f '../TestInit.pm';
+}
+use TestInit qw(T); # T is chdir to the top level
+use strict;
+
+require 't/test.pl';
+find_git_or_skip('all');
+
+my $changes;
+foreach (`git status --porcelain 2>/dev/null`) {
+ next if /^\?\?/;
+ ++$changes;
+ last;
+}
+
+skip_all("No pending changes (or git status --porcelain doesn't work here)")
+ unless $changes;
+
+sub get {
+ my $key = shift;
+ my $value = `git config --get user.$key`;
+ unless (defined $value && $value =~ /\S/) {
+ skip_all("git config --get user.$key returned nought");
+ }
+ chomp $value;
+ return $value;
+}
+
+my $email = get('email');
+my $name = get('name');
+
+open my $fh, '|-', "$^X Porting/checkAUTHORS.pl --tap -"
+ or die $!;
+print $fh "Author: $name <$email>\n";
+close $fh or die $!;
Copied: trunk/contrib/perl/t/porting/perlfunc.t (from rev 6437, vendor/perl/5.18.1/t/porting/perlfunc.t)
===================================================================
--- trunk/contrib/perl/t/porting/perlfunc.t (rev 0)
+++ trunk/contrib/perl/t/porting/perlfunc.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,30 @@
+#!./perl -w
+
+# What does this test?
+# This checks that changes to pod/perlfunc.pod don't accidentally break the
+# build by causing ext/Pod-Functions/Functions_pm.PL to abort.
+#
+# Why do we test this?
+# Pod::Functions is generated from pod/perlfunc.pod by
+# ext/Pod-Functions/Functions_pm.PL
+# If it can't parse pod/perlfunc.pod, it will abort, which will cause the
+# build to break. It's really not possible for it to carry on, hence aborting
+# is the only option. However, innocent-seeming changes to documentation
+# shouldn't break the build, and we expect everyone to run (at least)
+# the porting tests, hence this test, to catch such problems before it's too
+# late. To avoid duplicating the parsing logic, we make Functions_pm.PL take
+# a --tap option, to test that all is well.
+#
+# It's broken - how do I fix it?
+# Likely it's because you changed something in pod/perlfunc.pod
+# If you added a new function, it needs to be added to one or more groups in
+# "Perl Functions by Category", and to have a one line summary for
+# Pod::Functions provided by a =for directive.
+
+BEGIN {
+ @INC = '..' if -f '../TestInit.pm';
+}
+
+use TestInit qw(T A); # T is chdir to the top level, A makes paths absolute
+
+system "$^X ext/Pod-Functions/Functions_pm.PL --tap pod/perlfunc.pod";
Copied: trunk/contrib/perl/t/porting/pod_rules.t (from rev 6437, vendor/perl/5.18.1/t/porting/pod_rules.t)
===================================================================
--- trunk/contrib/perl/t/porting/pod_rules.t (rev 0)
+++ trunk/contrib/perl/t/porting/pod_rules.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,15 @@
+#!./perl
+
+BEGIN {
+ chdir '..' unless -d 't';
+ unshift @INC, 'lib';
+}
+
+use strict;
+require 't/test.pl';
+
+my $result = runperl(switches => ['-f', '-Ilib'],
+ progfile => 'Porting/pod_rules.pl',
+ args => ['--tap']);
+
+print $result;
Modified: trunk/contrib/perl/t/porting/podcheck.t
===================================================================
--- trunk/contrib/perl/t/porting/podcheck.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/porting/podcheck.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,67 +1,1926 @@
#!/usr/bin/perl -w
-require './test.pl';
+BEGIN {
+ chdir 't';
+ unshift @INC, "../lib";
+}
use strict;
+use warnings;
+use feature 'unicode_strings';
+use Carp;
+use Config;
+use Digest;
+use File::Find;
+use File::Spec;
+use Scalar::Util;
+use Text::Tabs;
+
+BEGIN {
+ require '../regen/regen_lib.pl';
+}
+
+sub DEBUG { 0 };
+
+=pod
+
+=head1 NAME
+
+podcheck.t - Look for possible problems in the Perl pods
+
+=head1 SYNOPSIS
+
+ cd t
+ ./perl -I../lib porting/podcheck.t [--show_all] [--cpan] [--deltas]
+ [--counts] [ FILE ...]
+ ./perl -I../lib porting/podcheck.t --add_link MODULE ...
+
+ ./perl -I../lib porting/podcheck.t --regen
+
+=head1 DESCRIPTION
+
+podcheck.t is an extension of Pod::Checker. It looks for pod errors and
+potential errors in the files given as arguments, or if none specified, in all
+pods in the distribution workspace, except certain known special ones
+(specified below). It does additional checking beyond that done by
+Pod::Checker, and keeps a database of known potential problems, and will
+fail a pod only if the number of such problems differs from that given in the
+database. It also suppresses the C<(section) deprecated> message from
+Pod::Checker, since specifying the man page section number is quite proper to do.
+
+The additional checks it makes are:
+
+=over
+
+=item Cross-pod link checking
+
+Pod::Checker verifies that links to an internal target in a pod are not
+broken. podcheck.t extends that (when called without FILE arguments) to
+external links. It does this by gathering up all the possible targets in the
+workspace, and cross-checking them. It also checks that a non-broken link
+points to just one target. (The destination pod could have two targets with
+the same name.)
+
+The way that the C<LE<lt>E<gt>> pod command works (for links outside the pod)
+is to actually create a link to C<search.cpan.org> with an embedded query for
+the desired pod or man page. That means that links outside the distribution
+are valid. podcheck.t doesn't verify the validity of such links, but instead
+keeps a data base of those known to be valid. This means that if a link to a
+target not on the list is created, the target needs to be added to the data
+base. This is accomplished via the L<--add_link|/--add_link MODULE ...>
+option to podcheck.t, described below.
+
+=item An internal link that isn't so specified
+
+If a link is broken, but there is an existing internal target of the same
+name, it is likely that the internal target was meant, and the C<"/"> is
+missing from the C<LE<lt>E<gt>> pod command.
+
+=item Verbatim paragraphs that wrap in an 80 (including 1 spare) column window
+
+It's annoying to have lines wrap when displaying pod documentation in a
+terminal window. This checks that all verbatim lines fit in a standard 80
+column window, even when using a pager that reserves a column for its own use.
+(Thus the check is for a net of 79 columns.)
+For those lines that don't fit, it tells you how much needs to be cut in
+order to fit.
+
+Often, the easiest thing to do to gain space for these is to lower the indent
+to just one space.
+
+=item Missing or duplicate NAME or missing NAME short description
+
+A pod can't be linked to unless it has a unique name.
+And a NAME should have a dash and short description after it.
+
+=item =encoding statement issues
+
+This indicates if an C<=encoding> statement should be present, or moved to the
+front of the pod.
+
+=item Items that perhaps should be links
+
+There are mentions of apparent files in the pods that perhaps should be links
+instead, using C<LE<lt>...E<gt>>
+
+=item Items that perhaps should be C<FE<lt>...E<gt>>
+
+What look like path names enclosed in C<CE<lt>...E<gt>> should perhaps have
+C<FE<lt>...E<gt>> mark-up instead.
+
+=back
+
+A number of issues raised by podcheck.t and by the base Pod::Checker are not
+really problems, but merely potential problems, that is, false positives.
+After inspecting them and
+deciding that they aren't real problems, it is possible to shut up this program
+about them, unlike base Pod::Checker. For a valid link to an outside module
+or man page, call podcheck.t with the C<--add_link> option to add it to the
+the database of known links; for other causes, call podcheck.t with the C<--regen>
+option to regenerate the entire database. This tells it that all existing
+issues are to not be mentioned again.
+
+C<--regen> isn't fool-proof. The database merely keeps track of the number of these
+potential problems of each type for each pod. If a new problem of a given
+type is introduced into the pod, podcheck.t will spit out all of them. You
+then have to figure out which is the new one, and should it be changed or not.
+But doing it this way insulates the database from having to keep track of line
+numbers of problems, which may change, or the exact wording of each problem
+which might also change without affecting whether it is a problem or not.
+
+Also, if the count of potential problems of a given type for a pod decreases,
+the database must be regenerated so that it knows the new number. The program
+gives instructions when this happens.
+
+Some pods will have varying numbers of problems of a given type. This can
+be handled by manually editing the database file (see L</FILES>), and setting
+the number of those problems for that pod to a negative number. This will
+cause the corresponding error to always be suppressed no matter how many there
+actually are.
+
+Another problem is that there is currently no check that modules listed as
+valid in the data base
+actually are. Thus any errors introduced there will remain there.
+
+=head2 Specially handled pods
+
+=over
+
+=item perltoc
+
+This pod is generated by pasting bits from other pods. Errors in those bits
+will show up as errors here, as well as for those other pods. Therefore
+errors here are suppressed, and the pod is checked only to verify that nodes
+within it actually exist that are externally linked to.
+
+=item perldelta
+
+The current perldelta pod is initialized from a template that contains
+placeholder text. Some of this text is in the form of links that don't really
+exist. Any such links that are listed in C<@perldelta_ignore_links> will not
+generate messages. It is presumed that these links will be cleaned up when
+the perldelta is cleaned up for release since they should be marked with
+C<XXX>.
+
+=item Porting/perldelta_template.pod
+
+This is not a pod, but a template for C<perldelta>. Any errors introduced
+here will show up when C<perldelta> is created from it.
+
+=item cpan-upstream pods
+
+See the L</--cpan> option documentation
+
+=item old perldeltas
+
+See the L</--deltas> option documentation
+
+=back
+
+=head1 OPTIONS
+
+=over
+
+=item --add_link MODULE ...
+
+Use this option to teach podcheck.t that the C<MODULE>s or man pages actually
+exist, and to silence any messages that links to them are broken.
+
+podcheck.t checks that links within the Perl core distribution are valid, but
+it doesn't check links to man pages or external modules. When it finds
+a broken link, it checks its data base of external modules and man pages,
+and only if not found there does it raise a message. This option just adds
+the list of modules and man page references that follow it on the command line
+to that data base.
+
+For example,
+
+ cd t
+ ./perl -I../lib porting/podcheck.t --add_link Unicode::Casing
+
+causes the external module "Unicode::Casing" to be added to the data base, so
+C<LE<lt>Unicode::CasingE<gt>> will be considered valid.
+
+=item --regen
+
+Regenerate the data base used by podcheck.t to include all the existing
+potential problems. Future runs of the program will not then flag any of
+these.
+
+=item --cpan
+
+Normally, all pods in the cpan directory are skipped, except to make sure that
+any blead-upstream links to such pods are valid.
+This option will cause cpan upstream pods to be fully checked.
+
+=item --deltas
+
+Normally, all old perldelta pods are skipped, except to make sure that
+any links to such pods are valid. This is because they are considered
+stable, and perhaps trying to fix them will cause changes that will
+misrepresent Perl's history. But, this option will cause them to be fully
+checked.
+
+=item --show_all
+
+Normally, if the number of potential problems of a given type found for a
+pod matches the expected value in the database, they will not be displayed.
+This option forces the database to be ignored during the run, so all potential
+problems are displayed and will fail their respective pod test. Specifying
+any particular FILES to operate on automatically selects this option.
+
+=item --counts
+
+Instead of testing, this just dumps the counts of the occurrences of the
+various types of potential problems in the data base.
+
+=back
+
+=head1 FILES
+
+The database is stored in F<t/porting/known_pod_issues.dat>
+
+=head1 SEE ALSO
+
+L<Pod::Checker>
+
+=cut
+
+# VMS builds have a '.com' appended to utility and script names, and it adds a
+# trailing dot for any other file name that doesn't have a dot in it. The db
+# is stored without those things. This regex allows for these special file
+# names to be dealt with. It needs to be interpolated into a larger regex
+# that furnishes the closing boundary.
+my $vms_re = qr/ \. (?: com )? /x;
+
+# Some filenames in the MANIFEST match $vms_re, and so must not be handled the
+# same way that that the special vms ones are. This hash lists those.
+my %special_vms_files;
+
+# This is to get this to work across multiple file systems, including those
+# that are not case sensitive. The db is stored in lower case, Un*x style,
+# and all file name comparisons are done that way.
+sub canonicalize($) {
+ my $input = shift;
+ my ($volume, $directories, $file)
+ = File::Spec->splitpath(File::Spec->canonpath($input));
+ # Assumes $volume is constant for everything in this directory structure
+ $directories = "" if ! $directories;
+ $file = "" if ! $file;
+ $file = lc join '/', File::Spec->splitdir($directories), $file;
+ $file =~ s! / /+ !/!gx; # Multiple slashes => single slash
+
+ # The db is stored without the special suffixes that are there in VMS, so
+ # strip them off to get the comparable name. But some files on all
+ # platforms have these suffixes, so this shouldn't happen for them, as any
+ # of their db entries will have the suffixes in them. The hash has been
+ # populated with these files.
+ if ($^O eq 'VMS'
+ && $file =~ / ( $vms_re ) $ /x
+ && ! exists $special_vms_files{$file})
+ {
+ $file =~ s/ $1 $ //x;
+ }
+ return $file;
+}
+
+#####################################################
+# HOW IT WORKS (in general)
+#
+# If not called with specific files to check, the directory structure is
+# examined for files that have pods in them. Files that might not have to be
+# fully parsed (e.g. in cpan) are parsed enough at this time to find their
+# pod's NAME, and to get a checksum.
+#
+# Those kinds of files are sorted last, but otherwise the pods are parsed with
+# the package coded here, My::Pod::Checker, which is an extension to
+# Pod::Checker that adds some tests and suppresses others that aren't
+# appropriate. The latter module has no provision for capturing diagnostics,
+# so a package, Tie_Array_to_FH, is used to force them to be placed into an
+# array instead of printed.
+#
+# Parsing the files builds up a list of links. The files are gone through
+# again, doing cross-link checking and outputting all saved-up problems with
+# each pod.
+#
+# Sorting the files last that potentially don't need to be fully parsed allows
+# us to not parse them unless there is a link to an internal anchor in them
+# from something that we have already parsed. Keeping checksums allows us to
+# not parse copies of other pods.
+#
+#####################################################
+
+# 1 => Exclude low priority messages that aren't likely to be problems, and
+# has many false positives; higher numbers give more messages.
+my $Warnings_Level = 200;
+
+# perldelta during construction may have place holder links. N.B. This
+# variable is referred to by name in release_managers_guide.pod
+our @perldelta_ignore_links = ( "XXX", "perl5YYYdelta", "perldiag/message" );
+
+# To see if two pods with the same NAME are actually copies of the same pod,
+# which is not an error, it uses a checksum to save work.
+my $digest_type = "SHA-1";
+
+my $original_dir = File::Spec->rel2abs(File::Spec->curdir);
+my $data_dir = File::Spec->catdir($original_dir, 'porting');
+my $known_issues = File::Spec->catfile($data_dir, 'known_pod_issues.dat');
+my $MANIFEST = File::Spec->catfile(File::Spec->updir($original_dir), 'MANIFEST');
+my $copy_fh;
+
+my $MAX_LINE_LENGTH = 79; # 79 columns
+my $INDENT = 7; # default nroff indent
+
+# Our warning messages. Better not have [('"] in them, as those are used as
+# delimiters for variable parts of the messages by poderror.
+my $line_length = "Verbatim line length including indents exceeds $MAX_LINE_LENGTH by";
+my $broken_link = "Apparent broken link";
+my $broken_internal_link = "Apparent internal link is missing its forward slash";
+my $see_not_linked = "? Should you be using L<...> instead of";
+my $C_with_slash = "? Should you be using F<...> or maybe L<...> instead of";
+my $multiple_targets = "There is more than one target";
+my $duplicate_name = "Pod NAME already used";
+my $need_encoding = "Should have =encoding statement because have non-ASCII";
+my $encoding_first = "=encoding must be first command (if present)";
+my $no_name = "There is no NAME";
+my $missing_name_description = "The NAME should have a dash and short description after it";
+
+# objects, tests, etc can't be pods, so don't look for them. Also skip
+# files output by the patch program. Could also ignore most of .gitignore
+# files, but not all, so don't.
+
+my $obj_ext = $Config{'obj_ext'}; $obj_ext =~ tr/.//d; # dot will be added back
+my $lib_ext = $Config{'lib_ext'}; $lib_ext =~ tr/.//d;
+my $lib_so = $Config{'so'}; $lib_so =~ tr/.//d;
+my $dl_ext = $Config{'dlext'}; $dl_ext =~ tr/.//d;
+
+# Not really pods, but can look like them.
+my %excluded_files = (
+ canonicalize("lib/unicore/mktables") => 1,
+ canonicalize("Porting/make-rmg-checklist") => 1,
+ canonicalize("Porting/perldelta_template.pod") => 1,
+ canonicalize("regen/feature.pl") => 1,
+ canonicalize("autodoc.pl") => 1,
+ canonicalize("configpm") => 1,
+ canonicalize("miniperl") => 1,
+ canonicalize("perl") => 1,
+ canonicalize('cpan/Pod-Perldoc/corpus/no-head.pod') => 1,
+ canonicalize('cpan/Pod-Perldoc/corpus/perlfunc.pod') => 1,
+ canonicalize('cpan/Pod-Perldoc/corpus/utf8.pod') => 1,
+ canonicalize("lib/unicore/mktables") => 1,
+ );
+
+# This list should not include anything for which case sensitivity is
+# important, as it won't work on VMS, and won't show up until tested on VMS.
+# All or almost all such files should be listed in the MANIFEST, so that can
+# be examined for them, and each such file explicitly excluded, as is done for
+# .PL files in the loop just below this. For files not catchable this way,
+# is_pod_file() can be used to exclude these at a finer grained level.
+my $non_pods = qr/ (?: \.
+ (?: [achot] | zip | gz | bz2 | jar | tar | tgz
+ | orig | rej | patch # Patch program output
+ | sw[op] | \#.* # Editor droppings
+ | old # buildtoc output
+ | xs # pod should be in the .pm file
+ | al # autosplit files
+ | bs # bootstrap files
+ | (?i:sh) # shell scripts, hints, templates
+ | lst # assorted listing files
+ | bat # Windows,Netware,OS2 batch files
+ | cmd # Windows,Netware,OS2 command files
+ | lis # VMS compiler listings
+ | map # VMS linker maps
+ | opt # VMS linker options files
+ | mms # MM(K|S) description files
+ | ts # timestamp files generated during build
+ | $obj_ext # object files
+ | exe # $Config{'exe_ext'} might be empty string
+ | $lib_ext # object libraries
+ | $lib_so # shared libraries
+ | $dl_ext # dynamic libraries
+ | gif # GIF images (example files from CGI.pm)
+ | eg # examples from libnet
+ )
+ $
+ ) | ~$ | \ \(Autosaved\)\.txt$ # Other editor droppings
+ | ^cxx\$demangler_db\.$ # VMS name mangler database
+ | ^typemap\.?$ # typemap files
+ | ^(?i:Makefile\.PL)$
+ /x;
+
+# '.PL' files should be excluded, as they aren't final pods, but often contain
+# material used in generating pods, and so can look like a pod. We can't use
+# the regexp above because case sensisitivity is important for these, as some
+# '.pl' files should be examined for pods. Instead look through the MANIFEST
+# for .PL files and get their full path names, so we can exclude each such
+# file explicitly. This works because other porting tests prohibit having two
+# files with the same names except for case.
+open my $manifest_fh, '<:bytes', $MANIFEST or die "Can't open $MANIFEST";
+while (<$manifest_fh>) {
+
+ # While we have MANIFEST open, on VMS platforms, look for files that match
+ # the magic VMS file names that have to be handled specially. Add these
+ # to the list of them.
+ if ($^O eq 'VMS' && / ^ ( [^\t]* $vms_re ) \t /x) {
+ $special_vms_files{$1} = 1;
+ }
+ if (/ ^ ( [^\t]* \. PL ) \t /x) {
+ $excluded_files{canonicalize($1)} = 1;
+ }
+}
+close $manifest_fh, or die "Can't close $MANIFEST";
+
+
+# Pod::Checker messages to suppress
+my @suppressed_messages = (
+ "(section) in", # Checker is wrong to flag this
+ "multiple occurrence of link target", # We catch independently the ones
+ # that are real problems.
+ "unescaped <>",
+ "Entity number out of range", # Checker outputs this for anything above
+ # 255, but in fact all Unicode is valid
+);
+
+sub suppressed {
+ # Returns bool as to if input message is one that is to be suppressed
+
+ my $message = shift;
+ return grep { $message =~ /^\Q$_/i } @suppressed_messages;
+}
+
+{ # Closure to contain a simple subset of test.pl. This is to get rid of the
+ # unnecessary 'failed at' messages that would otherwise be output pointing
+ # to a particular line in this file.
+
+ my $current_test = 0;
+ my $planned;
+
+ sub plan {
+ my %plan = @_;
+ $planned = $plan{tests} + 1; # +1 for final test that files haven't
+ # been removed
+ print "1..$planned\n";
+ return;
+ }
+
+ sub ok {
+ my $success = shift;
+ my $message = shift;
+
+ chomp $message;
+
+ $current_test++;
+ print "not " unless $success;
+ print "ok $current_test - $message\n";
+ return $success;
+ }
+
+ sub skip {
+ my $why = shift;
+ my $n = @_ ? shift : 1;
+ for (1..$n) {
+ $current_test++;
+ print "ok $current_test # skip $why\n";
+ }
+ no warnings 'exiting';
+ last SKIP;
+ }
+
+ sub note {
+ my $message = shift;
+
+ chomp $message;
+
+ print $message =~ s/^/# /mgr;
+ print "\n";
+ return;
+ }
+
+ END {
+ if ($planned && $planned != $current_test) {
+ print STDERR
+ "# Looks like you planned $planned tests but ran $current_test.\n";
+ }
+ }
+}
+
+# List of known potential problems by pod and type.
+my %known_problems;
+
+# Pods given by the keys contain an interior node that is referred to from
+# outside it.
+my %has_referred_to_node;
+
+my $show_counts = 0;
+my $regen = 0;
+my $add_link = 0;
+my $show_all = 0;
+
+my $do_upstream_cpan = 0; # Assume that are to skip anything in /cpan
+my $do_deltas = 0; # And stable perldeltas
+
+while (@ARGV && substr($ARGV[0], 0, 1) eq '-') {
+ my $arg = shift @ARGV;
+
+ $arg =~ s/^--/-/; # Treat '--' the same as a single '-'
+ if ($arg eq '-regen') {
+ $regen = 1;
+ }
+ elsif ($arg eq '-add_link') {
+ $add_link = 1;
+ }
+ elsif ($arg eq '-cpan') {
+ $do_upstream_cpan = 1;
+ }
+ elsif ($arg eq '-deltas') {
+ $do_deltas = 1;
+ }
+ elsif ($arg eq '-show_all') {
+ $show_all = 1;
+ }
+ elsif ($arg eq '-counts') {
+ $show_counts = 1;
+ }
+ else {
+ die <<EOF;
+Unknown option '$arg'
+
+Usage: $0 [ --regen | --cpan | --show_all | FILE ... | --add_link MODULE ... ]\n"
+ --add_link -> Add the MODULE and man page references to the data base
+ --regen -> Regenerate the data file for $0
+ --cpan -> Include files in the cpan subdirectory.
+ --deltas -> Include stable perldeltas
+ --show_all -> Show all known potential problems
+ --counts -> Don't test, but give summary counts of the currently
+ existing database
+EOF
+ }
+}
+
+my @files = @ARGV;
+
+my $cpan_or_deltas = $do_upstream_cpan || $do_deltas;
+if (($regen + $show_all + $show_counts + $add_link + $cpan_or_deltas ) > 1) {
+ croak "--regen, --show_all, --counts, and --add_link are mutually exclusive\n and none can be run with --cpan nor --deltas";
+}
+
+my $has_input_files = @files;
+
+if ($has_input_files
+ && ($regen || $show_counts || $do_upstream_cpan || $do_deltas))
{
- package My::Pod::Checker;
- use strict;
+ croak "--regen, --counts, --deltas, and --cpan can't be used since using specific files";
+}
+
+if ($add_link && ! $has_input_files) {
+ croak "--add_link requires at least one module or man page reference";
+}
+
+our %problems; # potential problems found in this run
+
+package My::Pod::Checker { # Extend Pod::Checker
use parent 'Pod::Checker';
- use vars '@errors'; # a bad, bad hack!
+ # Uses inside out hash to protect from typos
+ # For new fields, remember to add to destructor DESTROY()
+ my %indents; # Stack of indents from =over's in effect for
+ # current line
+ my %current_indent; # Current line's indent
+ my %filename; # The pod is store in this file
+ my %skip; # is SKIP set for this pod
+ my %in_NAME; # true if within NAME section
+ my %in_begin; # true if within =begin section
+ my %linkable_item; # Bool: if the latest =item is linkable. It isn't
+ # for bullet and number lists
+ my %linkable_nodes; # Pod::Checker adds all =items to its node list,
+ # but not all =items are linkable to
+ my %seen_encoding_cmd; # true if have =encoding earlier
+ my %command_count; # Number of commands seen
+ my %seen_pod_cmd; # true if have =pod earlier
+ my %warned_encoding; # true if already have warned about =encoding
+ # problems
- sub poderror {
+ sub DESTROY {
+ my $addr = Scalar::Util::refaddr $_[0];
+ delete $command_count{$addr};
+ delete $current_indent{$addr};
+ delete $filename{$addr};
+ delete $in_begin{$addr};
+ delete $indents{$addr};
+ delete $in_NAME{$addr};
+ delete $linkable_item{$addr};
+ delete $linkable_nodes{$addr};
+ delete $seen_encoding_cmd{$addr};
+ delete $seen_pod_cmd{$addr};
+ delete $skip{$addr};
+ delete $warned_encoding{$addr};
+ return;
+ }
+
+ sub new {
+ my $class = shift;
+ my $filename = shift;
+
+ my $self = $class->SUPER::new(-quiet => 1,
+ -warnings => $Warnings_Level);
+ my $addr = Scalar::Util::refaddr $self;
+ $command_count{$addr} = 0;
+ $current_indent{$addr} = 0;
+ $filename{$addr} = $filename;
+ $in_begin{$addr} = 0;
+ $in_NAME{$addr} = 0;
+ $linkable_item{$addr} = 0;
+ $seen_encoding_cmd{$addr} = 0;
+ $seen_pod_cmd{$addr} = 0;
+ $warned_encoding{$addr} = 0;
+ return $self;
+ }
+
+ # re's for messages that Pod::Checker outputs
+ my $location = qr/ \b (?:in|at|on|near) \s+ /xi;
+ my $optional_location = qr/ (?: $location )? /xi;
+ my $line_reference = qr/ [('"]? $optional_location \b line \s+
+ (?: \d+ | EOF | \Q???\E | - )
+ [)'"]? /xi;
+
+ sub poderror { # Called to register a potential problem
+
+ # This adds an extra field to the parent hash, 'parameter'. It is
+ # used to extract the variable parts of a message leaving just the
+ # constant skeleton. This in turn allows the message to be
+ # categorized better, so that it shows up as a single type in our
+ # database, with the specifics of each occurrence not being stored with
+ # it.
+
my $self = shift;
- my $opts;
- if (ref $_[0]) {
- $opts = shift;
- };
- ++($self->{_NUM_ERRORS})
- if(!$opts || ($opts->{-severity} && $opts->{-severity} eq 'ERROR'));
- ++($self->{_NUM_WARNINGS})
- if(!$opts || ($opts->{-severity} && $opts->{-severity} eq 'WARNING'));
- push @errors, $opts;
- };
+ my $opts = shift;
+
+ my $addr = Scalar::Util::refaddr $self;
+ return if $skip{$addr};
+
+ # Input can be a string or hash. If a string, parse it to separate
+ # out the line number and convert to a hash for easier further
+ # processing
+ my $message;
+ if (ref $opts ne 'HASH') {
+ $message = join "", $opts, @_;
+ my $line_number;
+ if ($message =~ s/\s*($line_reference)//) {
+ ($line_number = $1) =~ s/\s*$optional_location//;
+ }
+ else {
+ $line_number = '???';
+ }
+ $opts = { -msg => $message, -line => $line_number };
+ } else {
+ $message = $opts->{'-msg'};
+
+ }
+
+ $message =~ s/^\d+\s+//;
+ return if main::suppressed($message);
+
+ $self->SUPER::poderror($opts, @_);
+
+ $opts->{parameter} = "" unless $opts->{parameter};
+
+ # The variable parts of the message tend to be enclosed in '...',
+ # "....", or (...). Extract them and put them in an extra field,
+ # 'parameter'. This is trickier because the matching delimiter to a
+ # '(' is its mirror, and not itself. Text::Balanced could be used
+ # instead.
+ while ($message =~ m/ \s* $optional_location ( [('"] )/xg) {
+ my $delimiter = $1;
+ my $start = $-[0];
+ $delimiter = ')' if $delimiter eq '(';
+
+ # If there is no ending delimiter, don't consider it to be a
+ # variable part. Most likely it is a contraction like "Don't"
+ last unless $message =~ m/\G .+? \Q$delimiter/xg;
+
+ my $length = $+[0] - $start;
+
+ # Get the part up through the closing delimiter
+ my $special = substr($message, $start, $length);
+ $special =~ s/^\s+//; # No leading whitespace
+
+ # And add that variable part to the parameter, while removing it
+ # from the message. This isn't a foolproof way of finding the
+ # variable part. For example '(s)' can occur in e.g.,
+ # 'paragraph(s)'
+ if ($special ne '(s)') {
+ substr($message, $start, $length) = "";
+ pos $message = $start;
+ $opts->{-msg} = $message;
+ $opts->{parameter} .= " " if $opts->{parameter};
+ $opts->{parameter} .= $special;
+ }
+ }
+
+ # Extract any additional line number given. This is often the
+ # beginning location of something whereas the main line number gives
+ # the ending one.
+ if ($message =~ /( $line_reference )/xi) {
+ my $line_ref = $1;
+ while ($message =~ s/\s*\Q$line_ref//) {
+ $opts->{-msg} = $message;
+ $opts->{parameter} .= " " if $opts->{parameter};
+ $opts->{parameter} .= $line_ref;
+ }
+ }
+
+ Carp::carp("Couldn't extract line number from '$message'") if $message =~ /line \d+/;
+ push @{$problems{$filename{$addr}}{$message}}, $opts;
+ #push @{$problems{$self->get_filename}{$message}}, $opts;
+ }
+
+ sub check_encoding { # Does it need an =encoding statement?
+ my ($self, $paragraph, $line_num, $pod_para) = @_;
+
+ # Do nothing if there is an =encoding in the file, or if the line
+ # doesn't require an =encoding, or have already warned.
+ my $addr = Scalar::Util::refaddr $self;
+ return if $seen_encoding_cmd{$addr}
+ || $warned_encoding{$addr}
+ || $paragraph !~ /\P{ASCII}/;
+
+ $warned_encoding{$addr} = 1;
+ my ($file, $line) = $pod_para->file_line;
+ $self->poderror({ -line => $line, -file => $file,
+ -msg => $need_encoding
+ });
+ return;
+ }
+
+ sub verbatim {
+ my ($self, $paragraph, $line_num, $pod_para) = @_;
+ $self->check_encoding($paragraph, $line_num, $pod_para);
+
+ $self->SUPER::verbatim($paragraph, $line_num, $pod_para);
+
+ my $addr = Scalar::Util::refaddr $self;
+
+ # Pick up the name, since the parent class doesn't in verbatim
+ # NAMEs; so treat as non-verbatim. The parent class only allows one
+ # paragraph in a NAME section, so if there is an extra blank line, it
+ # will trigger a message, but such a blank line is harmless, so skip
+ # in that case.
+ if ($in_NAME{$addr} && $paragraph =~ /\S/) {
+ $self->textblock($paragraph, $line_num, $pod_para);
+ }
+
+ my @lines = split /^/, $paragraph;
+ for my $i (0 .. @lines - 1) {
+ if ( my $encoding = $seen_encoding_cmd{$addr} ) {
+ require Encode;
+ $lines[$i] = Encode::decode($encoding, $lines[$i]);
+ }
+ $lines[$i] =~ s/\s+$//;
+ my $indent = $self->get_current_indent;
+ my $exceeds = length(Text::Tabs::expand($lines[$i]))
+ + $indent - $MAX_LINE_LENGTH;
+ next unless $exceeds > 0;
+ my ($file, $line) = $pod_para->file_line;
+ $self->poderror({ -line => $line + $i, -file => $file,
+ -msg => $line_length,
+ parameter => "+$exceeds (including " . ($indent - $INDENT) . " from =over's)",
+ });
+ }
+ }
+
+ sub textblock {
+ my ($self, $paragraph, $line_num, $pod_para) = @_;
+ $self->check_encoding($paragraph, $line_num, $pod_para);
+
+ $self->SUPER::textblock($paragraph, $line_num, $pod_para);
+
+ my ($file, $line) = $pod_para->file_line;
+ my $addr = Scalar::Util::refaddr $self;
+ if ($in_NAME{$addr}) {
+ if (! $self->name) {
+ my $text = $self->interpolate($paragraph, $line_num);
+ if ($text =~ /^\s*(\S+?)\s*$/) {
+ $self->name($1);
+ $self->poderror({ -line => $line, -file => $file,
+ -msg => $missing_name_description,
+ parameter => $1});
+ }
+ }
+ }
+ $paragraph = join " ", split /^/, $paragraph;
+
+ # Matches something that looks like a file name, but is enclosed in
+ # C<...>
+ my $C_path_re = qr{ \b ( C<
+ # exclude various things that have slashes
+ # in them but aren't paths
+ (?!
+ (?: (?: s | qr | m) / ) # regexes
+ | \d+/\d+> # probable fractions
+ | OS/2>
+ | Perl/Tk>
+ | origin/blead>
+ | origin/maint
+ | - # File names don't begin with "-"
+ )
+ [-\w]+ (?: / [-\w]+ )+ (?: \. \w+ )? > )
+ }x;
+
+ # If looks like a reference to other documentation by containing the
+ # word 'See' and then a likely pod directive, warn.
+ while ($paragraph =~ m{
+ ( (?: \w+ \s+ )* ) # The phrase before, if any
+ \b [Ss]ee \s+
+ ( ( [^L] )
+ <
+ ( [^<]*? ) # The not < excludes nested C<L<...
+ >
+ )
+ ( \s+ (?: under | in ) \s+ L< )?
+ }xg) {
+ my $prefix = $1 // "";
+ my $construct = $2; # The whole thing, like C<...>
+ my $type = $3;
+ my $interior = $4;
+ my $trailing = $5; # After the whole thing ending in "L<"
+
+ # If the full phrase is something like, "you might see C<", or
+ # similar, it really isn't a reference to a link. The ones I saw
+ # all had the word "you" in them; and the "you" wasn't the
+ # beginning of a sentence.
+ if ($prefix !~ / \b you \b /x) {
+
+ # Now, find what the module or man page name within the
+ # construct would be if it actually has L<> syntax. If it
+ # doesn't have that syntax, will set the module to the entire
+ # interior.
+ $interior =~ m/ ^
+ (?: [^|]+ \| )? # Optional arbitrary text ending
+ # in "|"
+ ( .+? ) # module, etc. name
+ (?: \/ .+ )? # target within module
+ $
+ /xs;
+ my $module = $1;
+ if (! defined $trailing # not referring to something in another
+ # section
+ && $interior !~ /$non_pods/
+
+ # C<> that look like files have their own message below, so
+ # exclude them
+ && $construct !~ /$C_path_re/g
+
+ # There can't be spaces (I think) in module names or man
+ # pages
+ && $module !~ / \s /x
+
+ # F<> that end in eg \.pl are almost certainly ok, as are
+ # those that look like a path with multiple "/" chars
+ && ($type ne "F"
+ || (! -e $interior
+ && $interior !~ /\.\w+$/
+ && $interior !~ /\/.+\//)
+ )
+ ) {
+ $self->poderror({ -line => $line, -file => $file,
+ -msg => $see_not_linked,
+ parameter => $construct
+ });
+ }
+ }
+ }
+ while ($paragraph =~ m/$C_path_re/g) {
+ my $construct = $1;
+ $self->poderror({ -line => $line, -file => $file,
+ -msg => $C_with_slash,
+ parameter => $construct
+ });
+ }
+ return;
+ }
+
+ sub command {
+ my ($self, $cmd, $paragraph, $line_num, $pod_para) = @_;
+ my $addr = Scalar::Util::refaddr $self;
+ if ($cmd eq "pod") {
+ $seen_pod_cmd{$addr}++;
+ }
+ elsif ($cmd eq "encoding") {
+ my ($file, $line) = $pod_para->file_line;
+ $seen_encoding_cmd{$addr} = $paragraph; # for later decoding
+ if ($command_count{$addr} != 1 && $seen_pod_cmd{$addr}) {
+ $self->poderror({ -line => $line, -file => $file,
+ -msg => $encoding_first
+ });
+ }
+ }
+ $self->check_encoding($paragraph, $line_num, $pod_para);
+
+ # Pod::Check treats all =items as linkable, but the bullet and
+ # numbered lists really aren't. So keep our own list. This has to be
+ # processed before SUPER is called so that the list is started before
+ # the rest of it gets parsed.
+ if ($cmd eq 'item') { # Not linkable if item begins with * or a digit
+ $linkable_item{$addr} = ($paragraph !~ / ^ \s*
+ (?: [*]
+ | \d+ \.? (?: \$ | \s+ )
+ )/x)
+ ? 1
+ : 0;
+
+ }
+ $self->SUPER::command($cmd, $paragraph, $line_num, $pod_para);
+
+ $command_count{$addr}++;
+
+ $in_NAME{$addr} = 0; # Will change to 1 below if necessary
+ $in_begin{$addr} = 0; # ibid
+ if ($cmd eq 'over') {
+ my $text = $self->interpolate($paragraph, $line_num);
+ my $indent = 4; # default
+ $indent = $1 if $text && $text =~ /^\s*(\d+)\s*$/;
+ push @{$indents{$addr}}, $indent;
+ $current_indent{$addr} += $indent;
+ }
+ elsif ($cmd eq 'back') {
+ if (@{$indents{$addr}}) {
+ $current_indent{$addr} -= pop @{$indents{$addr}};
+ }
+ else {
+ # =back without corresponding =over, but should have
+ # warned already
+ $current_indent{$addr} = 0;
+ }
+ }
+ elsif ($cmd =~ /^head/) {
+ if (! $in_begin{$addr}) {
+
+ # If a particular formatter, then this command doesn't really
+ # apply
+ $current_indent{$addr} = 0;
+ undef @{$indents{$addr}};
+ }
+
+ my $text = $self->interpolate($paragraph, $line_num);
+ $in_NAME{$addr} = 1 if $cmd eq 'head1'
+ && $text && $text =~ /^NAME\b/;
+ }
+ elsif ($cmd eq 'begin') {
+ $in_begin{$addr} = 1;
+ }
+
+ return;
+ }
+
+ sub hyperlink {
+ my $self = shift;
+
+ my $page;
+ if ($_[0] && ($page = $_[0][1]{'-page'})) {
+ my $node = $_[0][1]{'-node'};
+
+ # If the hyperlink is to an interior node of another page, save it
+ # so that we can see if we need to parse normally skipped files.
+ $has_referred_to_node{$page} = 1 if $node;
+
+ # Ignore certain placeholder links in perldelta. Check if the
+ # link is page-level, and also check if to a node within the page
+ if ($self->name && $self->name eq "perldelta"
+ && ((grep { $page eq $_ } @perldelta_ignore_links)
+ || ($node
+ && (grep { "$page/$node" eq $_ } @perldelta_ignore_links)
+ ))) {
+ return;
+ }
+ }
+ return $self->SUPER::hyperlink($_[0]);
+ }
+
+ sub node {
+ my $self = shift;
+ my $text = $_[0];
+ if($text) {
+ $text =~ s/\s+$//s; # strip trailing whitespace
+ $text =~ s/\s+/ /gs; # collapse whitespace
+ my $addr = Scalar::Util::refaddr $self;
+ push(@{$linkable_nodes{$addr}}, $text) if
+ ! $current_indent{$addr}
+ || $linkable_item{$addr};
+ }
+ return $self->SUPER::node($_[0]);
+ }
+
+ sub get_current_indent {
+ return $INDENT + $current_indent{Scalar::Util::refaddr $_[0]};
+ }
+
+ sub get_filename {
+ return $filename{Scalar::Util::refaddr $_[0]};
+ }
+
+ sub linkable_nodes {
+ my $linkables = $linkable_nodes{Scalar::Util::refaddr $_[0]};
+ return undef unless $linkables;
+ return @$linkables;
+ }
+
+ sub get_skip {
+ return $skip{Scalar::Util::refaddr $_[0]} // 0;
+ }
+
+ sub set_skip {
+ my $self = shift;
+ $skip{Scalar::Util::refaddr $self} = shift;
+
+ # If skipping, no need to keep the problems for it
+ delete $problems{$self->get_filename};
+ return;
+ }
+
+ sub parse_from_file {
+ # This overrides the super class method so that if an open fails on a
+ # transitory file, it doesn't croak. It returns 1 if it did find the
+ # file, 0 if it didn't
+
+ my $self = shift;
+ my $filename = shift;
+ # ignores 2nd param, which is output file. Always uses undef
+
+ if (open my $in_fh, '<:bytes', $filename) {
+ $self->SUPER::parse_from_filehandle($in_fh, undef);
+ close $in_fh;
+ return 1;
+ }
+
+ # If couldn't open file, perhaps it was transitory, and hence not an error
+ return 0 unless -e $filename;
+
+ die "Can't open '$filename': $!\n";
+ }
}
+package Tie_Array_to_FH { # So printing actually goes to an array
-use strict;
-use File::Spec;
-s{^\.\./lib$}{lib} for @INC;
-chdir '..';
-my @files;
-my $manifest = 'MANIFEST';
+ my %array;
-open my $m, '<', $manifest or die "Can't open '$manifest': $!";
+ sub TIEHANDLE {
+ my $class = shift;
+ my $array_ref = shift;
-while (<$m>) {
+ my $self = bless \do{ my $anonymous_scalar }, $class;
+ $array{Scalar::Util::refaddr $self} = $array_ref;
+
+ return $self;
+ }
+
+ sub PRINT {
+ my $self = shift;
+ push @{$array{Scalar::Util::refaddr $self}}, @_;
+ return 1;
+ }
+}
+
+
+my %filename_to_checker; # Map a filename to it's pod checker object
+my %id_to_checker; # Map a checksum to it's pod checker object
+my %nodes; # key is filename, values are nodes in that file.
+my %nodes_first_word; # same, but value is first word of each node
+my %valid_modules; # List of modules known to exist outside us.
+my %digests; # checksums of files, whose names are the keys
+my %filename_to_pod; # Map a filename to its pod NAME
+my %files_with_unknown_issues;
+my %files_with_fixes;
+
+my $data_fh;
+open $data_fh, '<:bytes', $known_issues or die "Can't open $known_issues";
+
+my %counts; # For --counts param, count of each issue type
+my %suppressed_files; # Files with at least one issue type to suppress
+my $HEADER = <<END;
+# This file is the data file for $0.
+# 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
+# regen'd.
+# Lines without tab characters are simply NAMES of pods that the program knows
+# will have links to them and the program does not check if those links are
+# valid.
+# All other lines should have three fields, each separated by a tab. The
+# first field is the name of a pod; the second field is an error message
+# generated by this program; and the third field is a count of how many
+# known instances of that message there are in the pod. -1 means that the
+# program can expect any number of this type of message.
+END
+
+my @existing_issues;
+
+
+while (<$data_fh>) { # Read the data base
chomp;
- next unless /\s/; # Ignore lines without whitespace (i.e., filename only)
- my ($file, $separator) = /^(\S+)(\s+)/;
- next if $file =~ /^cpan\//;
- next unless ($file =~ /\.(?:pm|pod|pl)$/);
- next if $file eq 'autodoc.pl';
- push @files, $file;
-};
- at files = sort @files; # so we get consistent results
+ next if /^\s*(?:#|$)/; # Skip comment and empty lines
+ if (/\t/) {
+ next if $show_all;
+ if ($add_link) { # The issues are saved and later output unchanged
+ push @existing_issues, $_;
+ next;
+ }
-sub pod_ok {
- my ($filename) = @_;
- local @My::Pod::Checker::errors;
- my $checker = My::Pod::Checker->new(-quiet => 1);
- $checker->parse_from_file($filename, undef);
- my $error_count = $checker->num_errors();
+ # Keep track of counts of each issue type for each file
+ my ($filename, $message, $count) = split /\t/;
+ $known_problems{$filename}{$message} = $count;
- if(! ok($error_count <= 0, "POD of $filename")) {
- diag( "'$filename' contains POD errors" );
- diag(sprintf "%s %s: %s at line %s",
- $_->{-severity}, $_->{-file}, $_->{-msg}, $_->{-line})
- for @My::Pod::Checker::errors;
+ if ($show_counts) {
+ if ($count < 0) { # -1 means to suppress this issue type
+ $suppressed_files{$filename} = $filename;
+ }
+ else {
+ $counts{$message} += $count;
+ }
+ }
+ }
+ else { # Lines without a tab are modules known to be valid
+ $valid_modules{$_} = 1
+ }
+}
+close $data_fh;
+
+if ($add_link) {
+ $copy_fh = open_new($known_issues);
+
+ # Check for basic sanity, and add each command line argument
+ foreach my $module (@files) {
+ die "\"$module\" does not look like a module or man page"
+ # Must look like (A or A::B or A::B::C ..., or foo(3C)
+ if $module !~ /^ (?: \w+ (?: :: \w+ )* | \w+ \( \d \w* \) ) $/x;
+ $valid_modules{$module} = 1
+ }
+ my_safer_print($copy_fh, $HEADER);
+ foreach (sort { lc $a cmp lc $b } keys %valid_modules) {
+ my_safer_print($copy_fh, $_, "\n");
+ }
+
+ # The rest of the db file is output unchanged.
+ my_safer_print($copy_fh, join "\n", @existing_issues, "");
+
+ close_and_rename($copy_fh);
+ exit;
+}
+
+if ($show_counts) {
+ my $total = 0;
+ foreach my $message (sort keys %counts) {
+ $total += $counts{$message};
+ note(Text::Tabs::expand("$counts{$message}\t$message"));
+ }
+ note("-----\n" . Text::Tabs::expand("$total\tknown potential issues"));
+ if (%suppressed_files) {
+ note("\nFiles that have all messages of at least one type suppressed:");
+ note(join ",", keys %suppressed_files);
+ }
+ exit 0;
+}
+
+# re to match files that are to be parsed only if there is an internal link
+# to them. It does not include cpan, as whether those are parsed depends
+# on a switch. Currently, only perltoc and the stable perldelta.pod's
+# are included. The latter all have characters between 'perl' and
+# 'delta'. (Actually the currently developed one matches as well, but
+# is a duplicate of perldelta.pod, so can be skipped, so fine for it to
+# match this.
+my $only_for_interior_links_re = qr/ ^ pod\/perltoc.pod $
+ /x;
+unless ($do_deltas) {
+ $only_for_interior_links_re = qr/$only_for_interior_links_re |
+ \b perl \d+ delta \. pod \b
+ /x;
+}
+
+{ # Closure
+ my $first_time = 1;
+
+ sub output_thanks ($$$$) { # Called when an issue has been fixed
+ my $filename = shift;
+ my $original_count = shift;
+ my $current_count = shift;
+ my $message = shift;
+
+ $files_with_fixes{$filename} = 1;
+ my $return;
+ my $fixed_count = $original_count - $current_count;
+ my $a_problem = ($fixed_count == 1) ? "a problem" : "multiple problems";
+ my $another_problem = ($fixed_count == 1) ? "another problem" : "another set of problems";
+ my $diff;
+ if ($message) {
+ $diff = <<EOF;
+There were $original_count occurrences (now $current_count) in this pod of type
+"$message",
+EOF
+ } else {
+ $diff = <<EOF;
+There are no longer any problems found in this pod!
+EOF
+ }
+
+ if ($first_time) {
+ $first_time = 0;
+ $return = <<EOF;
+Thanks for fixing $a_problem!
+$diff
+Now you must teach $0 that this was fixed.
+EOF
+ }
+ else {
+ $return = <<EOF
+Thanks for fixing $another_problem.
+$diff
+EOF
+ }
+
+ return $return;
+ }
+}
+
+sub my_safer_print { # print, with error checking for outputting to db
+ my ($fh, @lines) = @_;
+
+ if (! print $fh @lines) {
+ my $save_error = $!;
+ close($fh);
+ die "Write failure: $save_error";
+ }
+}
+
+sub extract_pod { # Extracts just the pod from a file; returns undef if file
+ # doesn't exist
+ my $filename = shift;
+
+ my @pod;
+
+ # Arrange for the output of Pod::Parser to be collected in an array we can
+ # look at instead of being printed
+ tie *ALREADY_FH, 'Tie_Array_to_FH', \@pod;
+ if (open my $in_fh, '<:bytes', $filename) {
+ my $parser = Pod::Parser->new();
+ $parser->parse_from_filehandle($in_fh, *ALREADY_FH);
+ close $in_fh;
+
+ return join "", @pod
+ }
+
+ # The file should already have been opened once to get here, so if that
+ # fails, something is wrong. It's possible that a transitory file
+ # containing a pod would get here, so if the file no longer exists just
+ # return undef.
+ return unless -e $filename;
+ die "Can't open '$filename': $!\n";
+}
+
+my $digest = Digest->new($digest_type);
+
+# This is used as a callback from File::Find::find(), which always constructs
+# pathnames using Unix separators
+sub is_pod_file {
+ # If $_ is a pod file, add it to the lists and do other prep work.
+
+ if (-d) {
+ # Don't look at files in directories that are for tests, nor those
+ # beginning with a dot
+ if (m!/t\z! || m!/\.!) {
+ $File::Find::prune = 1;
+ }
+ return;
+ }
+
+ return unless -r && -s; # Can't check it if can't read it; no need to
+ # check if 0 length
+ return unless -f || -l; # Weird file types won't be pods
+
+ my ($leaf) = m!([^/]+)\z!;
+ if (m!/\.! # No hidden Unix files
+ || $leaf =~ $non_pods) {
+ note("Not considering $_") if DEBUG;
+ return;
+ }
+
+ my $filename = $File::Find::name;
+
+ # $filename is relative, like './path'. Strip that initial part away.
+ $filename =~ s!^\./!! or die 'Unexpected pathname "$filename"';
+
+ return if $excluded_files{canonicalize($filename)};
+
+ my $contents = do {
+ local $/;
+ my $candidate;
+ if (! open $candidate, '<:bytes', $_) {
+
+ # If a transitory file was found earlier, the open could fail
+ # legitimately and we just skip the file; also skip it if it is a
+ # broken symbolic link, as it is probably just a build problem;
+ # certainly not a file that we would want to check the pod of.
+ # Otherwise fail it here and no reason to process it further.
+ # (But the test count will be off too)
+ ok(0, "Can't open '$filename': $!")
+ if -r $filename && ! -l $filename;
+ return;
+ }
+ <$candidate>;
};
-};
-plan (tests => scalar @files);
+ # If the file is a .pm or .pod, having any initial '=' on a line is
+ # grounds for testing it. Otherwise, require a head1 NAME line to
+ # consider it as a potential pod
+ if ($filename =~ /\.(?:pm|pod)/) {
+ return unless $contents =~ /^=/m;
+ } else {
+ return unless $contents =~ /^=head1 +NAME/m;
+ }
-pod_ok $_
- for @files;
+ # Here, we know that the file is a pod. Add it to the list of files
+ # to check and create a checker object for it.
+
+ push @files, $filename;
+ my $checker = My::Pod::Checker->new($filename);
+ $filename_to_checker{$filename} = $checker;
+
+ # In order to detect duplicate pods and only analyze them once, we
+ # compute checksums for the file, so don't have to do an exact
+ # compare. Note that if the pod is just part of the file, the
+ # checksums can differ for the same pod. That special case is handled
+ # later, since if the checksums of the whole file are the same, that
+ # case won't even come up. We don't need the checksums for files that
+ # we parse only if there is a link to its interior, but we do need its
+ # NAME, which is also retrieved in the code below.
+
+ if ($filename =~ / (?: ^(cpan|lib|ext|dist)\/ )
+ | $only_for_interior_links_re
+ /x) {
+ $digest->add($contents);
+ $digests{$filename} = $digest->digest;
+
+ # lib files aren't analyzed if they are duplicates of files copied
+ # there from some other directory. But to determine this, we need
+ # to know their NAMEs. We might as well find the NAME now while
+ # the file is open. Similarly, cpan files aren't analyzed unless
+ # we're analyzing all of them, or this particular file is linked
+ # to by a file we are analyzing, and thus we will want to verify
+ # that the target exists in it. We need to know at least the NAME
+ # to see if it's worth analyzing, or so we can determine if a lib
+ # file is a copy of a cpan one.
+ if ($filename =~ m{ (?: ^ (?: cpan | lib ) / )
+ | $only_for_interior_links_re
+ }x) {
+ if ($contents =~ /^=head1 +NAME.*/mg) {
+ # The NAME is the first non-spaces on the line up to a
+ # comma, dash or end of line. Otherwise, it's invalid and
+ # this pod doesn't have a legal name that we're smart
+ # enough to find currently. But the parser will later
+ # find it if it thinks there is a legal name, and set the
+ # name
+ if ($contents =~ /\G # continue from the line after =head1
+ \s* # ignore any empty lines
+ ^ \s* ( \S+?) \s* (?: [,-] | $ )/mx) {
+ my $name = $1;
+ $checker->name($name);
+ $id_to_checker{$name} = $checker
+ if $filename =~ m{^cpan/};
+ }
+ }
+ elsif ($filename =~ m{^cpan/}) {
+ $id_to_checker{$digests{$filename}} = $checker;
+ }
+ }
+ }
+
+ return;
+} # End of is_pod_file()
+
+# Start of real code that isn't processing the command line (except the
+# db is read in above, as is processing of the --add_link option).
+# Here, @files contains list of files on the command line. If have any of
+# these, unconditionally test them, and show all the errors, even the known
+# ones, and, since not testing other pods, don't do cross-pod link tests.
+# (Could add extra code to do cross-pod tests for the ones in the list.)
+
+if ($has_input_files) {
+ undef %known_problems;
+ $do_upstream_cpan = $do_deltas = 1; # In case one of the inputs is one
+ # of these types
+}
+else { # No input files -- go find all the possibilities.
+ if ($regen) {
+ $copy_fh = open_new($known_issues);
+ note("Regenerating $known_issues, please be patient...");
+ print $copy_fh $HEADER;
+ }
+
+ # Move to the directory above us, but have to adjust @INC to account for
+ # that.
+ s{^\.\./lib$}{lib} for @INC;
+ chdir File::Spec->updir;
+
+ # And look in this directory and all its subdirectories
+ find( {wanted => \&is_pod_file, no_chdir => 1}, '.');
+
+ # Add ourselves to the test
+ push @files, "t/porting/podcheck.t";
+}
+
+# Now we know how many tests there will be.
+plan (tests => scalar @files) if ! $regen;
+
+
+ # Sort file names so we get consistent results, and to put cpan last,
+ # preceeded by the ones that we don't generally parse. This is because both
+ # these classes are generally parsed only if there is a link to the interior
+ # of them, and we have to parse all others first to guarantee that they don't
+ # have such a link. 'lib' files come just before these, as some of these are
+ # duplicates of others. We already have figured this out when gathering the
+ # data as a special case for all such files, but this, while unnecessary,
+ # puts the derived file last in the output. 'readme' files come before those,
+ # as those also could be duplicates of others, which are considered the
+ # primary ones. These currently aren't figured out when gathering data, so
+ # are done here.
+ @files = sort { if ($a =~ /^cpan/) {
+ return 1 if $b !~ /^cpan/;
+ return lc $a cmp lc $b;
+ }
+ elsif ($b =~ /^cpan/) {
+ return -1;
+ }
+ elsif ($a =~ /$only_for_interior_links_re/) {
+ return 1 if $b !~ /$only_for_interior_links_re/;
+ return lc $a cmp lc $b;
+ }
+ elsif ($b =~ /$only_for_interior_links_re/) {
+ return -1;
+ }
+ elsif ($a =~ /^lib/) {
+ return 1 if $b !~ /^lib/;
+ return lc $a cmp lc $b;
+ }
+ elsif ($b =~ /^lib/) {
+ return -1;
+ } elsif ($a =~ /\breadme\b/i) {
+ return 1 if $b !~ /\breadme\b/i;
+ return lc $a cmp lc $b;
+ }
+ elsif ($b =~ /\breadme\b/i) {
+ return -1;
+ }
+ else {
+ return lc $a cmp lc $b;
+ }
+ }
+ @files;
+
+# Now go through all the files and parse them
+FILE:
+foreach my $filename (@files) {
+ my $parsed = 0;
+ note("parsing $filename") if DEBUG;
+
+ # We may have already figured out some things in the process of generating
+ # the file list. If so, we have a $checker object already. But if not,
+ # generate one now.
+ my $checker = $filename_to_checker{$filename};
+ if (! $checker) {
+ $checker = My::Pod::Checker->new($filename);
+ $filename_to_checker{$filename} = $checker;
+ }
+
+ # We have set the name in the checker object if there is a possibility
+ # that no further parsing is necessary, but otherwise do the parsing now.
+ if (! $checker->name) {
+ if (! $checker->parse_from_file($filename, undef)) {
+ $checker->set_skip("$filename is transitory");
+ next FILE;
+ }
+ $parsed = 1;
+
+ }
+
+ if ($checker->num_errors() < 0) { # Returns negative if not a pod
+ $checker->set_skip("$filename is not a pod");
+ }
+ else {
+
+ # Here, is a pod. See if it is one that has already been tested,
+ # or should be tested under another directory. Use either its NAME
+ # if it has one, or a checksum if not.
+ my $name = $checker->name;
+ my $id;
+
+ if ($name) {
+ $id = $name;
+ }
+ else {
+ my $digest = Digest->new($digest_type);
+ my $contents = extract_pod($filename);
+
+ # If the return is undef, it means that $filename was a transitory
+ # file; skip it.
+ next FILE unless defined $contents;
+ $digest->add($contents);
+ $id = $digest->digest;
+ }
+
+ # If there is a match for this pod with something that we've already
+ # processed, don't process it, and output why.
+ my $prior_checker;
+ if (defined ($prior_checker = $id_to_checker{$id})
+ && $prior_checker != $checker) # Could have defined the checker
+ # earlier without pursuing it
+ {
+
+ # If the pods are identical, then it's just a copy, and isn't an
+ # error. First use the checksums we have already computed to see
+ # if the entire files are identical, which means that the pods are
+ # identical too.
+ my $prior_filename = $prior_checker->get_filename;
+ my $same = (! $name
+ || ($digests{$prior_filename}
+ && $digests{$filename}
+ && $digests{$prior_filename} eq $digests{$filename}));
+
+ # If they differ, it could be that the files differ for some
+ # reason, but the pods they contain are identical. Extract the
+ # pods and do the comparisons on just those.
+ if (! $same && $name) {
+ my $contents = extract_pod($filename);
+
+ # If return is <undef>, it means that $filename no longer
+ # exists. This means it was a transitory file, and should not
+ # be tested.
+ next FILE unless defined $contents;
+
+ my $prior_contents = extract_pod($prior_filename);
+
+ # If return is <undef>, it means that $prior_filename no
+ # longer exists. This means it was a transitory file, and
+ # should not have been tested, but we already did process it.
+ # What we should do now is to back-out its records, and
+ # process $filename in its stead. But backing out is not so
+ # simple, and so I'm (khw) skipping that unless and until
+ # experience shows that it is needed. We do go process
+ # $filename, and there are potential false positive conflicts
+ # with the transitory $prior_contents, and rerunning the test
+ # should cause it to succeed.
+ goto process_this_pod unless defined $prior_contents;
+
+ $same = $prior_contents eq $contents;
+ }
+
+ if ($same) {
+ $checker->set_skip("The pod of $filename is a duplicate of "
+ . "the pod for $prior_filename");
+ } elsif ($prior_filename =~ /\breadme\b/i) {
+ $checker->set_skip("$prior_filename is a README apparently for $filename");
+ } elsif ($filename =~ /\breadme\b/i) {
+ $checker->set_skip("$filename is a README apparently for $prior_filename");
+ } elsif (! $do_upstream_cpan
+ && $filename =~ /^cpan/
+ && $prior_filename =~ /^cpan/)
+ {
+ $checker->set_skip("CPAN is upstream for $filename");
+ } else { # Here have two pods with identical names that differ
+ $prior_checker->poderror(
+ { -msg => $duplicate_name,
+ -line => "???",
+ parameter => "'$filename' also has NAME '$name'"
+ });
+ $checker->poderror(
+ { -msg => $duplicate_name,
+ -line => "???",
+ parameter => "'$prior_filename' also has NAME '$name'"
+ });
+
+ # Changing the names helps later.
+ $prior_checker->name("$name version arbitrarily numbered 1");
+ $checker->name("$name version arbitrarily numbered 2");
+ }
+
+ # In any event, don't process this pod that has the same name as
+ # another.
+ next FILE;
+ }
+
+ process_this_pod:
+
+ # A unique pod.
+ $id_to_checker{$id} = $checker;
+
+ my $parsed_for_links = ", but parsed for its interior links";
+ if ((! $do_upstream_cpan && $filename =~ /^cpan/)
+ || $filename =~ $only_for_interior_links_re)
+ {
+ if ($filename =~ /^cpan/) {
+ $checker->set_skip("CPAN is upstream for $filename");
+ }
+ elsif ($filename =~ /perl\d+delta/) {
+ if (! $do_deltas) {
+ $checker->set_skip("$filename is a stable perldelta");
+ }
+ }
+ elsif ($filename =~ /perltoc/) {
+ $checker->set_skip("$filename dependent on component pods");
+ }
+ else {
+ croak("Unexpected file '$filename' encountered that has parsing for interior-linking only");
+ }
+
+ if ($name && $has_referred_to_node{$name}) {
+ $checker->set_skip($checker->get_skip() . $parsed_for_links);
+ }
+ }
+
+ # Need a name in order to process it, because not meaningful
+ # otherwise, and also can't test links to this without a name.
+ if (!defined $name) {
+ $checker->poderror( { -msg => $no_name,
+ -line => '???'
+ });
+ next FILE;
+ }
+
+ # For skipped files, just get its NAME
+ my $skip;
+ if (($skip = $checker->get_skip()) && $skip !~ /$parsed_for_links/)
+ {
+ $checker->node($name) if $name;
+ }
+ elsif (! $parsed) {
+ if (! $checker->parse_from_file($filename, undef)) {
+ $checker->set_skip("$filename is transitory");
+ next FILE;
+ }
+ }
+
+ # Go through everything in the file that could be an anchor that
+ # could be a link target. Count how many there are of the same name.
+ foreach my $node ($checker->linkable_nodes) {
+ next FILE if ! $node; # Can be empty is like '=item *'
+ if (exists $nodes{$name}{$node}) {
+ $nodes{$name}{$node}++;
+ }
+ else {
+ $nodes{$name}{$node} = 1;
+ }
+
+ # Experiments have shown that cpan search can figure out the
+ # target of a link even if the exact wording is incorrect, as long
+ # as the first word is. This happens frequently in perlfunc.pod,
+ # where the link will be just to the function, but the target
+ # entry also includes parameters to the function.
+ my $first_word = $node;
+ if ($first_word =~ s/^(\S+)\s+\S.*/$1/) {
+ $nodes_first_word{$name}{$first_word} = $node;
+ }
+ }
+ $filename_to_pod{$filename} = $name;
+ }
+}
+
+# Here, all files have been parsed, and all links and link targets are stored.
+# Now go through the files again and see which don't have matches.
+if (! $has_input_files) {
+ foreach my $filename (@files) {
+ next if $filename_to_checker{$filename}->get_skip;
+ my $checker = $filename_to_checker{$filename};
+ foreach my $link ($checker->hyperlink) {
+ my $linked_to_page = $link->[1]->page;
+ next unless $linked_to_page; # intra-file checks are handled by std
+ # Pod::Checker
+
+ # Initialize the potential message.
+ my %problem = ( -msg => $broken_link,
+ -line => $link->[0],
+ parameter => "to \"$linked_to_page\"",
+ );
+
+ # See if we have found the linked-to_file in our parse
+ if (exists $nodes{$linked_to_page}) {
+ my $node = $link->[1]->node;
+
+ # If link is only to the page-level, already have it
+ next if ! $node;
+
+ # Transform pod language to what we are expecting
+ $node =~ s,E<sol>,/,g;
+ $node =~ s/E<verbar>/|/g;
+
+ # If link is to a node that exists in the file, is ok
+ if ($nodes{$linked_to_page}{$node}) {
+
+ # But if the page has multiple targets with the same name,
+ # it's ambiguous which one this should be to.
+ if ($nodes{$linked_to_page}{$node} > 1) {
+ $problem{-msg} = $multiple_targets;
+ $problem{parameter} = "in $linked_to_page that $node could be pointing to";
+ $checker->poderror(\%problem);
+ }
+ } elsif (! $nodes_first_word{$linked_to_page}{$node}) {
+
+ # Here the link target was not found, either exactly or to
+ # the first word. Is an error.
+ $problem{parameter} =~ s,"$,/$node",;
+ $checker->poderror(\%problem);
+ }
+
+ } # Linked-to-file not in parse; maybe is in exception list
+ elsif (! exists $valid_modules{$link->[1]->page}) {
+
+ # Here, is a link to a target that we can't find. Check if
+ # there is an internal link on the page with the target name.
+ # If so, it could be that they just forgot the initial '/'
+ # But perldelta is handled specially: only do this if the
+ # broken link isn't one of the known bad ones (that are
+ # placemarkers and should be removed for the final)
+ my $NAME = $filename_to_pod{$filename};
+ if (! defined $NAME) {
+ $checker->poderror(\%problem);
+ }
+ else {
+ if ($nodes{$NAME}{$linked_to_page}) {
+ $problem{-msg} = $broken_internal_link;
+ }
+ $checker->poderror(\%problem);
+ }
+ }
+ }
+ }
+}
+
+# If regenerating the data file, start with the modules for which we don't
+# check targets. If you change the sort order, you need to run --regen before
+# committing so that future commits that do run regen don't show irrelevant
+# changes.
+if ($regen) {
+ foreach (sort { lc $a cmp lc $b } keys %valid_modules) {
+ my_safer_print($copy_fh, $_, "\n");
+ }
+}
+
+# Now ready to output the messages.
+foreach my $filename (@files) {
+ my $canonical = canonicalize($filename);
+ SKIP: {
+ my $skip = $filename_to_checker{$filename}->get_skip // "";
+
+ if ($regen) {
+ foreach my $message ( sort keys %{$problems{$filename}}) {
+ my $count;
+
+ # Preserve a negative setting.
+ if ($known_problems{$canonical}{$message}
+ && $known_problems{$canonical}{$message} < 0)
+ {
+ $count = $known_problems{$canonical}{$message};
+ }
+ else {
+ $count = @{$problems{$filename}{$message}};
+ }
+ my_safer_print($copy_fh, $canonical . "\t$message\t$count\n");
+ }
+ next;
+ }
+
+ skip($skip, 1) if $skip;
+ my @diagnostics;
+ my $indent = ' ';
+
+ my $total_known = 0;
+ foreach my $message ( sort keys %{$problems{$filename}}) {
+ $known_problems{$canonical}{$message} = 0
+ if ! $known_problems{$canonical}{$message};
+ my $diagnostic = "";
+ my $problem_count = scalar @{$problems{$filename}{$message}};
+ $total_known += $problem_count;
+ next if $known_problems{$canonical}{$message} < 0;
+ if ($problem_count > $known_problems{$canonical}{$message}) {
+
+ # Here we are about to output all the messages for this type,
+ # subtract back this number we previously added in.
+ $total_known -= $problem_count;
+
+ $diagnostic .= $indent . qq{"$message"};
+ if ($problem_count > 2) {
+ $diagnostic .= " ($problem_count occurrences,"
+ . " expected $known_problems{$canonical}{$message})";
+ }
+ foreach my $problem (@{$problems{$filename}{$message}}) {
+ $diagnostic .= " " if $problem_count == 1;
+ $diagnostic .= "\n$indent$indent";
+ $diagnostic .= "$problem->{parameter}" if $problem->{parameter};
+ $diagnostic .= " near line $problem->{-line}";
+ $diagnostic .= " $problem->{comment}" if $problem->{comment};
+ }
+ $diagnostic .= "\n";
+ $files_with_unknown_issues{$filename} = 1;
+ } elsif ($problem_count < $known_problems{$canonical}{$message}) {
+ $diagnostic = output_thanks($filename, $known_problems{$canonical}{$message}, $problem_count, $message);
+ }
+ push @diagnostics, $diagnostic if $diagnostic;
+ }
+
+ # The above loop has output messages where there are current potential
+ # issues. But it misses where there were some that have been entirely
+ # fixed. For those, we need to look through the old issues
+ foreach my $message ( sort keys %{$known_problems{$canonical}}) {
+ next if $problems{$filename}{$message};
+ next if ! $known_problems{$canonical}{$message};
+ next if $known_problems{$canonical}{$message} < 0; # Preserve negs
+ my $diagnostic = output_thanks($filename, $known_problems{$canonical}{$message}, 0, $message);
+ push @diagnostics, $diagnostic if $diagnostic;
+ }
+
+ my $output = "POD of $filename";
+ $output .= ", excluding $total_known not shown known potential problems"
+ if $total_known;
+ ok(@diagnostics == 0, $output);
+ if (@diagnostics) {
+ note(join "", @diagnostics,
+ "See end of this test output for your options on silencing this");
+ }
+
+ delete $known_problems{$canonical};
+ }
+}
+
+if (! $regen
+ && ! ok (keys %known_problems == 0, "The known problems data base includes no references to non-existent files"))
+{
+ note("The following files were not found: "
+ . join ", ", keys %known_problems);
+ note("They will automatically be removed from the db the next time");
+ note(" cd t; ./perl -I../lib porting/podcheck.t --regen");
+ note("is run");
+}
+
+my $how_to = <<EOF;
+ run this test script by hand, using the following formula (on
+ Un*x-like machines):
+ cd t
+ ./perl -I../lib porting/podcheck.t --regen
+EOF
+
+if (%files_with_unknown_issues) {
+ my $were_count_files = scalar keys %files_with_unknown_issues;
+ $were_count_files = ($were_count_files == 1)
+ ? "was $were_count_files file"
+ : "were $were_count_files files";
+ my $message = <<EOF;
+
+HOW TO GET THIS .t TO PASS
+
+There $were_count_files that had new potential problems identified.
+Some of them may be real, and some of them may be false positives because
+this program isn't as smart as it likes to think it is. You can teach this
+program to ignore the issues it has identified, and hence pass, by doing the
+following:
+
+1) If a problem is about a link to an unknown module or man page that
+ you know exists, re-run the command something like:
+ ./perl -I../lib porting/podcheck.t --add_link MODULE man_page ...
+ (MODULEs should look like Foo::Bar, and man_pages should look like
+ bar(3c); don't do this for a module or man page that you aren't sure
+ about; instead treat as another type of issue and follow the
+ instructions below.)
+
+2) For other issues, decide if each should be fixed now or not. Fix the
+ ones you decided to, and rerun this test to verify that the fixes
+ worked.
+
+3) If there remain false positive or problems that you don't plan to fix right
+ now,
+$how_to
+ That should cause all current potential problems to be accepted by
+ the program, so that the next time it runs, they won't be flagged.
+EOF
+ if (%files_with_fixes) {
+ $message .= " This step will also take care of the files that have fixes in them\n";
+ }
+
+ $message .= <<EOF;
+ For a few files, such as perltoc, certain issues will always be
+ expected, and more of the same will be added over time. For those,
+ before you do the regen, you can edit
+ $known_issues
+ and find the entry for the module's file and specific error message,
+ and change the count of known potential problems to -1.
+EOF
+
+ note($message);
+} elsif (%files_with_fixes) {
+ note(<<EOF
+To teach this test script that the potential problems have been fixed,
+$how_to
+EOF
+ );
+}
+
+if ($regen) {
+ chdir $original_dir || die "Can't change directories to $original_dir";
+ close_and_rename($copy_fh);
+}
Property changes on: trunk/contrib/perl/t/porting/podcheck.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/porting/regen.t
===================================================================
--- trunk/contrib/perl/t/porting/regen.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/porting/regen.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -2,23 +2,12 @@
# Verify that all files generated by perl scripts are up to date.
-my ($in_t, $lib);
-
BEGIN {
- $in_t = -f 'TEST' && -f '../regen.pl';
- $lib = $in_t ? '../lib' : 'lib';
- unshift @INC, $lib;
+ @INC = '..' if -f '../TestInit.pm';
}
-
+use TestInit qw(T A); # T is chdir to the top level, A makes paths absolute
use strict;
-use File::Spec::Functions 'rel2abs';
-$^X = rel2abs($^X);
-$ENV{PERL5LIB} = rel2abs($lib);
-
-chdir '..' if $in_t;
-
-$INC[0] = 'lib';
require 'regen/regen_lib.pl';
require 't/test.pl';
$::NO_ENDING = $::NO_ENDING = 1;
@@ -27,11 +16,11 @@
skip_all( "- regen.pl needs porting." );
}
-my $in_regen_pl = 17; # I can't see a clean way to calculate this automatically.
+my $in_regen_pl = 23; # I can't see a clean way to calculate this automatically.
my @files = qw(perly.act perly.h perly.tab keywords.c keywords.h uconfig.h);
-my @progs = qw(Porting/makemeta regen/regcharclass.pl regen/mk_PL_charclass.pl);
+my @progs = qw(regen/regcharclass.pl regen/mk_PL_charclass.pl);
-plan (tests => $in_regen_pl + @files + @progs);
+plan (tests => $in_regen_pl + @files + @progs + 2);
OUTER: foreach my $file (@files) {
open my $fh, '<', $file or die "Can't open $file: $!";
@@ -58,3 +47,7 @@
foreach (@progs, 'regen.pl') {
system "$^X $_ --tap";
}
+
+foreach ( '-y', '-j' ) {
+ system "$^X Porting/makemeta --tap $_";
+}
Property changes on: trunk/contrib/perl/t/porting/regen.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/porting/test_bootstrap.t
===================================================================
--- trunk/contrib/perl/t/porting/test_bootstrap.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/porting/test_bootstrap.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -7,7 +7,10 @@
# This regression tests ensures that the rules aren't accidentally overlooked.
-require './test.pl';
+BEGIN {
+ chdir 't';
+ require './test.pl';
+}
plan('no_plan');
@@ -46,8 +49,18 @@
unless $file eq 'comp/require.t'
}
-# There are regression tests using test.pl that don't want PL_sawampersand set
+# There are regression tests using test.pl that don't want PL_sawampersand
+# set. Or at least that was the case until PL_sawampersand was disabled
+# and replaced with copy-on-write.
+# We still allow PL_sawampersand to be enabled with
+# -Accflags=-DPERL_SAWAMPERSAND, so when that is defined we can still run
+# these tests. When it is not enabled, PL_sawampersand makes no observable
+# difference so the tests fail.
+
+require Config;
+exit unless "@{[Config::bincompat_options()]}" =~ /\bPERL_SAWAMPERSAND\b/;
+
# This very much relies on a bug in the regexp implementation, but for now it's
# the best way to work out whether PL_sawampersand is true.
# Then again, PL_sawampersand *is* a bug, for precisely the reason that this
Property changes on: trunk/contrib/perl/t/porting/test_bootstrap.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/porting/utils.t (from rev 6437, vendor/perl/5.18.1/t/porting/utils.t)
===================================================================
--- trunk/contrib/perl/t/porting/utils.t (rev 0)
+++ trunk/contrib/perl/t/porting/utils.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,98 @@
+#!./perl -w
+
+# What does this test?
+# This checks that all the perl "utils" don't have embarrassing syntax errors
+#
+# Why do we test this?
+# Right now, without this, it's possible to pass the all the regression tests
+# even if one has introduced syntax errors into scripts such as installperl
+# or installman. No tests fail, so it's fair game to push the commit.
+# Obviously this breaks installing perl, but we won't spot this.
+# Whilst we can't easily test that the various scripts *work*, we can at least
+# check that we've not made any trivial screw ups.
+#
+# It's broken - how do I fix it?
+# Presumably it's failed because some (other) code that you changed was (also)
+# used by one of the utility scripts. So you'll have to manually test that
+# script.
+
+BEGIN {
+ @INC = '..' if -f '../TestInit.pm';
+}
+use TestInit qw(T); # T is chdir to the top level
+use strict;
+
+require 't/test.pl';
+
+# It turns out that, since the default @INC will include your old 5.x libs, if
+# you have them, the Porting utils might load a library that no longer compiles
+# clean. This actually happened, with Local::Maketext::Lexicon from a 5.10.0
+# preventing 5.16.0-RC0 from testing successfully. This test is really only
+# needed for porters, anyway. -- rjbs, 2012-05-10
+find_git_or_skip('all');
+
+my @maybe;
+
+open my $fh, '<', 'MANIFEST' or die "Can't open MANIFEST: $!";
+while (<$fh>) {
+ push @maybe, $1 if m!^(Porting/\S+)!;
+}
+close $fh or die $!;
+
+open $fh, '<', 'utils.lst' or die "Can't open utils.lst: $!";
+while (<$fh>) {
+ die unless m!^(\S+)!;
+ push @maybe, $1;
+ $maybe[$#maybe] .= '.com' if $^O eq 'VMS';
+}
+close $fh or die $!;
+
+my @victims = (qw(installman installperl regen_perly.pl));
+my %excuses = (
+ 'Porting/git-deltatool' => 'Git::Wrapper',
+ 'Porting/podtidy' => 'Pod::Tidy',
+ 'Porting/leakfinder.pl' => 'XS::APItest',
+ );
+
+foreach (@maybe) {
+ if (/\.p[lm]$/) {
+ push @victims, $_;
+ } elsif ($_ !~ m{^x2p/a2p}) {
+ # test_prep doesn't (yet) have a dependency on a2p, so it seems a bit
+ # silly adding one (and forcing it to be built) just so that we can open
+ # it and determine that it's *not* a perl program, and hence of no
+ # further interest to us.
+ open $fh, '<', $_ or die "Can't open '$_': $!";
+ my $line = <$fh>;
+ if ($line =~ m{^#!(?:\S*|/usr/bin/env\s+)perl}
+ || $^O eq 'VMS' && $line =~ m{^\$ perl}) {
+ push @victims, $_;
+ } else {
+ print "# $_ isn't a Perl script\n";
+ }
+ }
+}
+
+printf "1..%d\n", scalar @victims;
+
+foreach my $victim (@victims) {
+ SKIP: {
+ # Not clear to me *why* it needs the BEGIN block, given what it
+ # does, but not in an easy position to change it.
+ skip("$victim executes code in a BEGIN block which fails for empty \@ARGV")
+ if $victim =~ m{^utils/cpanp-run-perl};
+
+ skip ("$victim uses $excuses{$victim}, so can't test with just core modules")
+ if $excuses{$victim};
+
+ my $got = runperl(switches => ['-c'], progfile => $victim, stderr => 1);
+ is($got, "$victim syntax OK\n", "$victim compiles");
+ }
+}
+
+# Local variables:
+# cperl-indent-level: 4
+# indent-tabs-mode: nil
+# End:
+#
+# ex: set ts=8 sts=4 sw=4 et:
Modified: trunk/contrib/perl/t/re/charset.t
===================================================================
--- trunk/contrib/perl/t/re/charset.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/charset.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -8,6 +8,7 @@
use strict;
use warnings;
+use Config;
plan('no_plan');
@@ -35,19 +36,24 @@
$testcases{'[:word:]'} = $testcases{'\w'};
my @charsets = qw(a d u aa);
-if (! is_miniperl()) {
+if (! is_miniperl() && $Config{d_setlocale}) {
require POSIX;
my $current_locale = POSIX::setlocale( &POSIX::LC_ALL, "C") // "";
if ($current_locale eq 'C') {
- use locale;
- # Some locale implementations don't have the 128-255 characters all
- # mean nothing. Skip the locale tests in that situation
+ # test for d_setlocale is repeated here because this one is compile
+ # time, and the one above is run time
+ use if $Config{d_setlocale}, 'locale';
+
+ # Some implementations don't have the 128-255 range characters all
+ # mean nothing under the C locale (an example being VMS). This is
+ # legal, but since we don't know what the right answers should be,
+ # skip the locale tests in that situation.
for my $i (128 .. 255) {
- goto bad_locale if chr($i) =~ /[[:print:]]/;
+ goto untestable_locale if chr($i) =~ /[[:print:]]/;
}
push @charsets, 'l';
- bad_locale:
+ untestable_locale:
}
}
Property changes on: trunk/contrib/perl/t/re/charset.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/re/fold_grind.t
===================================================================
--- trunk/contrib/perl/t/re/fold_grind.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/fold_grind.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -6,6 +6,7 @@
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
+ require Config; import Config;
skip_all_if_miniperl("no dynamic loading on miniperl, no Encode nor POSIX");
}
@@ -18,6 +19,17 @@
use Encode;
use POSIX;
+# Special-cased characters in the .c's that we want to make sure get tested.
+my %be_sure_to_test = (
+ "\xDF" => 1, # LATIN_SMALL_LETTER_SHARP_S
+ "\x{1E9E}" => 1, # LATIN_CAPITAL_LETTER_SHARP_S
+ "\x{390}" => 1, # GREEK_SMALL_LETTER_IOTA_WITH_DIALYTIKA_AND_TONOS
+ "\x{3B0}" => 1, # GREEK_SMALL_LETTER_UPSILON_WITH_DIALYTIKA_AND_TONOS
+ "\x{1FD3}" => 1, # GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA
+ "\x{1FE3}" => 1, # GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA
+ );
+
+
# Tests both unicode and not, so make sure not implicitly testing unicode
no feature 'unicode_strings';
@@ -52,7 +64,7 @@
# output for debugging purposes.
sub range_type {
- my $ord = shift;
+ my $ord = ord shift;
return $ASCII if $ord < 128;
return $Latin1 if $ord < 256;
@@ -63,136 +75,308 @@
return $a <=> $b
}
-sub run_test($$$$) {
- my ($test, $count, $todo, $debug) = @_;
+my $list_all_tests = $ENV{PERL_DEBUG_FULL_TEST} || $DEBUG;
+$| = 1 if $list_all_tests;
+# Significant time is saved by not outputting each test but grouping the
+# output into subtests
+my $okays; # Number of ok's in current subtest
+my $this_iteration; # Number of possible tests in current subtest
+my $count=0; # Number of subtests = number of total tests
+
+sub run_test($$$) {
+ my ($test, $todo, $debug) = @_;
+
$debug = "" unless $DEBUG;
- ok(eval $test, "$test; $debug");
+ my $res = eval $test;
+
+ if (!$res || $list_all_tests) {
+ # Failed or debug; output the result
+ $count++;
+ ok($res, "$test; $debug");
+ } else {
+ # Just count the test as passed
+ $okays++;
+ }
+ $this_iteration++;
}
-my %tests; # The final set of tests. keys are the code points to test
-my %simple_folds;
-my %multi_folds;
+my %has_test_by_participants; # Makes sure has tests for each range and each
+ # number of characters that fold to the same
+ # thing
+my %has_test_by_byte_count; # Makes sure has tests for each combination of
+ # n bytes folds to m bytes
-# First, analyze the current Unicode's folding rules
-my %folded_from;
-my $file="../lib/unicore/CaseFolding.txt";
-open my $fh, "<", $file or die "Failed to read '$file': $!";
-while (<$fh>) {
- chomp;
+my %tests; # The set of tests.
+# Each key is a code point that folds to something else.
+# Each value is a list of things that the key folds to. If the 'thing' is a
+# single code point, it is that ordinal. If it is a multi-char fold, it is an
+# ordered list of the code points in that fold. Here's an example for 'S':
+# '83' => [ 115, 383 ]
+#
+# And one for a multi-char fold: \xDF
+# 223 => [
+# [ # 'ss'
+# 83,
+# 83
+# ],
+# [ # 'SS'
+# 115,
+# 115
+# ],
+# [ # LATIN SMALL LETTER LONG S
+# 383,
+# 383
+# ],
+# 7838 # LATIN_CAPITAL_LETTER_SHARP_S
+# ],
- # Lines look like (though without the initial '#')
- #0130; F; 0069 0307; # LATIN CAPITAL LETTER I WITH DOT ABOVE
+my %inverse_folds; # keys are strings of the folded-to;
+ # values are lists of characters that fold to them
- my ($line, $comment) = split / \s+ \# \s+ /x, $_;
- next if $line eq "" || substr($line, 0, 1) eq '#';
- my ($hex_from, $fold_type, @folded) = split /[\s;]+/, $line;
+sub add_test($@) {
+ my ($to, @from) = @_;
- my $from = hex $hex_from;
+ # Called to cause the input to be tested by adding to %tests. @from is
+ # the list of characters that fold to the string $to. @from should be
+ # sorted so the lowest code point is first....
+ # The input is in string form; %tests uses code points, so have to
+ # convert.
- if ($fold_type eq 'F') {
- my $from_range_type = range_type($from);
+ my $to_chars = length $to;
+ my @test_to; # List of tests for $to
- # If we were testing comprehensively, we would try every combination
- # of upper and lower case in the fold, but it is quite likely that if
- # the code can handle all combinations if it can handle the cases
- # where everything is upper and when everything is lower. Because of
- # complement matching, we need to do both. And we use the
- # reverse-fold instead of uppercase.
- @folded = map { hex $_ } @folded;
- # XXX better to use reverse fold of these instead of uc
- my @uc_folded = map { ord uc chr $_ } @folded;
+ if ($to_chars == 1) {
+ @test_to = ord $to;
+ }
+ else {
+ push @test_to, [ map { ord $_ } split "", $to ];
- # Include three code points that are handled internally by the regex
- # engine specially, plus all non-above-255 multi folds (which actually
- # the only one is already included in the three, but this makes sure)
- # And if any member of the fold is not the same range type as the
- # source, add it directly to the tests. It needs to be an array of an
- # array, so that it is distinguished from multiple single folds
- if ($from == 0xDF || $from == 0x390 || $from == 0x3B0
- || $from_range_type != $Unicode
- || grep { range_type($_) != $from_range_type } @folded)
- {
- $tests{$from} = [ [ @folded ], [ @uc_folded ] ];
+ # For multi-char folds, we also test that things that can fold to each
+ # individual character in the fold also work. If we were testing
+ # comprehensively, we would try every combination of upper and lower
+ # case in the fold, but it will have to suffice to avoid running
+ # forever to make sure that each thing that folds to these is tested
+ # at least once. Because of complement matching ([^...]), we need to
+ # do both the folded, and the folded-from.
+ # We first look at each character in the multi-char fold, and save how
+ # many characters fold to it; and also the maximum number of such
+ # folds
+ my @folds_to_count; # 0th char in fold is index 0 ...
+ my $max_folds_to = 0;
+
+ for (my $i = 0; $i < $to_chars; $i++) {
+ my $to_char = substr($to, $i, 1);
+ if (exists $inverse_folds{$to_char}) {
+ $folds_to_count[$i] = scalar @{$inverse_folds{$to_char}};
+ $max_folds_to = $folds_to_count[$i] if $max_folds_to < $folds_to_count[$i];
+ }
+ else {
+ $folds_to_count[$i] = 0;
+ }
}
- else {
- # The only multi-char non-utf8 fold is DF, which is handled above,
- # so here chr() must be utf8. Get the number of bytes in each.
- # This is because the optimizer cares about length differences.
- my $from_length = length encode('UTF-8', chr($from));
- my $to_length = length encode('UTF-8', pack 'U*', @folded);
- push @{$multi_folds{$from_length}{$to_length}}, { $from => [ [ @folded ], [ @uc_folded ] ] };
+ # We will need to generate as many tests as the maximum number of
+ # folds, so that each fold will have at least one test.
+ # For example, consider character X which folds to the three character
+ # string 'xyz'. If 2 things fold to x (X and x), 4 to y (Y, Y'
+ # (Y-prime), Y'' (Y-prime-prime), and y), and 1 thing to z (itself), 4
+ # tests will be generated:
+ # xyz
+ # XYz
+ # xY'z
+ # xY''z
+ for (my $i = 0; $i < $max_folds_to; $i++) {
+ my @this_test_to; # Assemble a single test
+
+ # For each character in the multi-char fold ...
+ for (my $j = 0; $j < $to_chars; $j++) {
+ my $this_char = substr($to, $j, 1);
+
+ # Use its corresponding inverse fold, if available.
+ if ($i < $folds_to_count[$j]) {
+ push @this_test_to, ord $inverse_folds{$this_char}[$i];
+ }
+ else { # Or else itself.
+ push @this_test_to, ord $this_char;
+ }
+ }
+
+ # Add this test to the list
+ push @test_to, [ @this_test_to ];
}
+
+ # Here, have assembled all the tests for the multi-char fold. Sort so
+ # lowest code points are first for consistency and aesthetics in
+ # output. We know there are at least two characters in the fold, but
+ # I haven't bothered to worry about sorting on an optional third
+ # character if the first two are identical.
+ @test_to = sort { ($a->[0] == $b->[0])
+ ? $a->[1] <=> $b->[1]
+ : $a->[0] <=> $b->[0]
+ } @test_to;
}
- # Perl only deals with C and F folds
- next if $fold_type ne 'C';
- # C folds are single-char $from to single-char $folded, in chr terms
- # folded_from{'s'} = [ 'S', \N{LATIN SMALL LETTER LONG S} ]
- push @{$folded_from{hex $folded[0]}}, $from;
+ # This test is from n bytes to m bytes. Record that so won't try to add
+ # another test that does the same.
+ use bytes;
+ my $to_bytes = length $to;
+ foreach my $from_map (@from) {
+ $has_test_by_byte_count{length $from_map}{$to_bytes} = $to;
+ }
+ no bytes;
+
+ my $ord_smallest_from = ord shift @from;
+ if (exists $tests{$ord_smallest_from}) {
+ die "There are already tests for $ord_smallest_from"
+ };
+
+ # Add in the fold tests,
+ push @{$tests{$ord_smallest_from}}, @test_to;
+
+ # Then any remaining froms in the equivalence class.
+ push @{$tests{$ord_smallest_from}}, map { ord $_ } @from;
}
-# Now try to sort the single char folds into equivalence classes that are
-# likely to have identical successes and failures. Any fold that crosses
-# range types is suspect, and is automatically tested. Otherwise, store by
-# the number of characters that participate in a fold. Likely all folds in a
-# range type that fold to each other like B->b->B will have identical success
-# and failure; similarly all folds that have three characters participating
-# are likely to have the same successes and failures, etc.
-foreach my $folded (sort numerically keys %folded_from) {
- my $target_range_type = range_type($folded);
- my $count = @{$folded_from{$folded}};
+# Get the Unicode rules and construct inverse mappings from them
- # Automatically test any fold that crosses range types
- if (grep { range_type($_) != $target_range_type } @{$folded_from{$folded}})
- {
- $tests{$folded} = $folded_from{$folded};
+use Unicode::UCD;
+my $file="../lib/unicore/CaseFolding.txt";
+
+# Use the Unicode data file if we are on an ASCII platform (which its data is
+# for), and it is in the modern format (starting in Unicode 3.1.0) and it is
+# available. This avoids being affected by potential bugs introduced by other
+# layers of Perl
+if (ord('A') == 65
+ && pack("C*", split /\./, Unicode::UCD::UnicodeVersion()) ge v3.1.0
+ && open my $fh, "<", $file)
+{
+ while (<$fh>) {
+ chomp;
+
+ # Lines look like (though without the initial '#')
+ #0130; F; 0069 0307; # LATIN CAPITAL LETTER I WITH DOT ABOVE
+
+ # Get rid of comments, ignore blank or comment-only lines
+ my $line = $_ =~ s/ (?: \s* \# .* )? $ //rx;
+ next unless length $line;
+ my ($hex_from, $fold_type, @hex_folded) = split /[\s;]+/, $line;
+
+ next if $fold_type =~ / ^ [IT] $/x; # Perl doesn't do Turkish folding
+ next if $fold_type eq 'S'; # If Unicode's tables are correct, the F
+ # should be a superset of S
+
+ my $folded_str = pack ("U0U*", map { hex $_ } @hex_folded);
+ push @{$inverse_folds{$folded_str}}, chr hex $hex_from;
}
- else {
- push @{$simple_folds{$target_range_type}{$count}},
- { $folded => $folded_from{$folded} };
- }
}
+else { # Here, can't use the .txt file: read the Unicode rules file and
+ # construct inverse mappings from it
-foreach my $from_length (keys %multi_folds) {
- foreach my $fold_length (keys %{$multi_folds{$from_length}}) {
- #print __LINE__, ref $multi_folds{$from_length}{$fold_length}, Dumper $multi_folds{$from_length}{$fold_length};
- foreach my $test (@{$multi_folds{$from_length}{$fold_length}}) {
- #print __LINE__, ": $from_length, $fold_length, $test:\n";
- my ($target, $pattern) = each %$test;
- #print __LINE__, ": $target: $pattern\n";
- $tests{$target} = $pattern;
- last if $skip_apparently_redundant;
+ my ($invlist_ref, $invmap_ref, undef, $default)
+ = Unicode::UCD::prop_invmap('Case_Folding');
+ for my $i (0 .. @$invlist_ref - 1 - 1) {
+ next if $invmap_ref->[$i] == $default;
+
+ # Make into an array if not so already, so can treat uniformly below
+ $invmap_ref->[$i] = [ $invmap_ref->[$i] ] if ! ref $invmap_ref->[$i];
+
+ # Each subsequent element of the range requires adjustment of +1 from
+ # the previous element
+ my $adjust = -1;
+ for my $j ($invlist_ref->[$i] .. $invlist_ref->[$i+1] -1) {
+ $adjust++;
+ my $folded_str
+ = pack "U0U*", map { $_ + $adjust } @{$invmap_ref->[$i]};
+ #note (sprintf "%d: %04X: %s", __LINE__, $j, join " ",
+ # map { sprintf "%04X", $_ + $adjust } @{$invmap_ref->[$i]});
+ push @{$inverse_folds{$folded_str}}, chr $j;
}
}
}
-# Add in tests for single character folds. Add tests for each range type,
-# and within those tests for each number of characters participating in a
-# fold. Thus B->b has two characters participating. But K->k and Kelvin
-# Sign->k has three characters participating. So we would make sure that
-# there is a test for 3 chars, 4 chars, ... . (Note that the 'k' example is a
-# bad one because it crosses range types, so is automatically tested. In the
-# Unicode range there are various of these 3 and 4 char classes, but aren't as
-# easily described as the 'k' one.)
-foreach my $type (keys %simple_folds) {
- foreach my $count (keys %{$simple_folds{$type}}) {
- foreach my $test (@{$simple_folds{$type}{$count}}) {
- my ($target, $pattern) = each %$test;
- $tests{$target} = $pattern;
- last if $skip_apparently_redundant;
+# Analyze the data and generate tests to get adequate test coverage. We sort
+# things so that smallest code points are done first.
+TO:
+foreach my $to (sort { (length $a == length $b)
+ ? $a cmp $b
+ : length $a <=> length $b
+ } keys %inverse_folds)
+{
+
+ # Within each fold, sort so that the smallest code points are done first
+ @{$inverse_folds{$to}} = sort { $a cmp $b } @{$inverse_folds{$to}};
+ my @from = @{$inverse_folds{$to}};
+
+ # Just add it to the tests if doing complete coverage
+ if (! $skip_apparently_redundant) {
+ add_test($to, @from);
+ next TO;
+ }
+
+ my $to_chars = length $to;
+ my $to_range_type = range_type(substr($to, 0, 1));
+
+ # If this is required to be tested, do so. We check for these first, as
+ # they will take up slots of byte-to-byte combinations that we otherwise
+ # would have to have other tests to get.
+ foreach my $from_map (@from) {
+ if (exists $be_sure_to_test{$from_map}) {
+ add_test($to, @from);
+ next TO;
}
}
+
+ # If the fold contains heterogeneous range types, is suspect and should be
+ # tested.
+ if ($to_chars > 1) {
+ foreach my $char (split "", $to) {
+ if (range_type($char) != $to_range_type) {
+ add_test($to, @from);
+ next TO;
+ }
+ }
+ }
+
+ # If the mapping crosses range types, is suspect and should be tested
+ foreach my $from_map (@from) {
+ if (range_type($from_map) != $to_range_type) {
+ add_test($to, @from);
+ next TO;
+ }
+ }
+
+ # Here, all components of the mapping are in the same range type. For
+ # single character folds, we test one case in each range type that has 2
+ # particpants, 3 particpants, etc.
+ if ($to_chars == 1) {
+ if (! exists $has_test_by_participants{scalar @from}{$to_range_type}) {
+ add_test($to, @from);
+ $has_test_by_participants{scalar @from}{$to_range_type} = $to;
+ next TO;
+ }
+ }
+
+ # We also test all combinations of mappings from m to n bytes. This is
+ # because the regex optimizer cares. (Don't bother worrying about that
+ # Latin1 chars will occupy a different number of bytes under utf8, as
+ # there are plenty of other cases that catch these byte numbers.)
+ use bytes;
+ my $to_bytes = length $to;
+ foreach my $from_map (@from) {
+ if (! exists $has_test_by_byte_count{length $from_map}{$to_bytes}) {
+ add_test($to, @from);
+ next TO;
+ }
+ }
}
# For each range type, test additionally a character that folds to itself
-$tests{0x3A} = [ 0x3A ];
-$tests{0xF7} = [ 0xF7 ];
-$tests{0x2C7} = [ 0x2C7 ];
+add_test(chr 0x3A, chr 0x3A);
+add_test(chr 0xF7, chr 0xF7);
+add_test(chr 0x2C7, chr 0x2C7);
-
# To cut down on the number of tests
my $has_tested_aa_above_latin1;
my $has_tested_latin1_aa;
@@ -217,16 +401,30 @@
# It doesn't return pairs like (a, a), (b, b). Change the slice to an array
# to do that. This was just to have fewer tests.
sub pairs (@) {
- #print __LINE__, ": ", join(" XXX ", @_), "\n";
+ #print __LINE__, ": ", join(" XXX ", map { sprintf "%04X", $_ } @_), "\n";
map { prefix $_[$_], @_[0..$_-1, $_+1..$#_] } 0..$#_
}
my @charsets = qw(d u a aa);
-my $current_locale = POSIX::setlocale( &POSIX::LC_ALL, "C") // "";
-push @charsets, 'l' if $current_locale eq 'C';
+if($Config{d_setlocale}) {
+ my $current_locale = POSIX::setlocale( &POSIX::LC_ALL, "C") // "";
+ if ($current_locale eq 'C') {
+ require locale; import locale;
+ # Some implementations don't have the 128-255 range characters all
+ # mean nothing under the C locale (an example being VMS). This is
+ # legal, but since we don't know what the right answers should be,
+ # skip the locale tests in that situation.
+ for my $i (128 .. 255) {
+ my $char = chr($i);
+ goto untestable_locale if uc($char) ne $char || lc($char) ne $char;
+ }
+ push @charsets, 'l';
+ untestable_locale:
+ }
+}
+
# Finally ready to do the tests
-my $count=0;
foreach my $test (sort { numerically } keys %tests) {
my $previous_target;
@@ -254,6 +452,10 @@
@target = (ref $target) ? @$target : $target;
@pattern = (ref $pattern) ? @$pattern : $pattern;
+ # We are testing just folds to/from a single character. If our pairs
+ # happens to generate multi/multi, skip.
+ next if @target > 1 && @pattern > 1;
+
# Have to convert non-utf8 chars to native char set
@target = map { $_ > 255 ? $_ : ord latin1_to_native(chr($_)) } @target;
@pattern = map { $_ > 255 ? $_ : ord latin1_to_native(chr($_)) } @pattern;
@@ -283,11 +485,12 @@
$test,
join("", @x_target),
join("", @x_pattern);
- #print $progress, "\n";
- #diag $progress;
+ #note $progress;
# Now grind out tests, using various combinations.
foreach my $charset (@charsets) {
+ $okays = 0;
+ $this_iteration = 0;
# To cut down somewhat on the enormous quantity of tests this currently
# runs, skip some for some of the character sets whose results aren't
@@ -420,40 +623,51 @@
my $op = '=~';
$op = '!~' if $should_fail;
- # I'm afraid this was derived from trial and error.
- my $todo = ($test == 0xdf
- && $lhs =~ /DF/
- && $uni_semantics
- && ($charset eq 'u' || $charset eq 'a' || $charset eq 'd')
- && ! (($charset eq 'u' || $charset eq 'a')
- && (($upgrade_target eq "") != ($upgrade_pattern eq "")))
- && ! ($charset eq 'd' && (! $upgrade_target || ! $upgrade_pattern))
- );
+ my $todo = 0; # No longer any todo's
my $eval = "my \$c = \"$lhs$rhs\"; my \$p = qr/(?$charset:^($rhs)\\1\$)/i;$upgrade_target$upgrade_pattern \$c $op \$p";
- run_test($eval, ++$count, $todo, "");
+ run_test($eval, $todo, "");
$eval = "my \$c = \"$lhs$rhs\"; my \$p = qr/(?$charset:^(?<grind>$rhs)\\k<grind>\$)/i;$upgrade_target$upgrade_pattern \$c $op \$p";
- run_test($eval, ++$count, $todo, "");
+ run_test($eval, $todo, "");
if ($lhs ne $rhs) {
$eval = "my \$c = \"$rhs$lhs\"; my \$p = qr/(?$charset:^($rhs)\\1\$)/i;$upgrade_target$upgrade_pattern \$c $op \$p";
- run_test($eval, ++$count, "", "");
+ run_test($eval, "", "");
$eval = "my \$c = \"$rhs$lhs\"; my \$p = qr/(?$charset:^(?<grind>$rhs)\\k<grind>\$)/i;$upgrade_target$upgrade_pattern \$c $op \$p";
- run_test($eval, ++$count, "", "");
+ run_test($eval, "", "");
}
- # XXX Doesn't currently test multi-char folds in pattern
- next if @pattern != 1;
-
# See if works on what could be a simple trie.
$eval = "my \$c = \"$lhs\"; my \$p = qr/$rhs|xyz/i$charset;$upgrade_target$upgrade_pattern \$c $op \$p";
- run_test($eval, ++$count, "", "");
+ run_test($eval, "", "");
- my $okays = 0;
- my $this_iteration = 0;
+ # Check that works when the folded character follows something that
+ # is quantified. This test knows the regex code internals to the
+ # extent that it knows this is a potential problem, and that there
+ # are three different types of quantifiers generated: 1) The thing
+ # being quantified matches a single character; 2) it matches more
+ # than one character, but is fixed width; 3) it can match a variable
+ # number of characters. (It doesn't know that case 3 shouldn't
+ # matter, since it doesn't do anything special for the character
+ # following the quantifier; nor that some of the different
+ # quantifiers execute the same underlying code, as these tests are
+ # quick, and this insulates these tests from changes in the
+ # implementation.)
+ for my $quantifier ('?', '??', '*', '*?', '+', '+?', '{1,2}', '{1,2}?') {
+ $eval = "my \$c = \"_$lhs\"; my \$p = qr/(?$charset:.$quantifier$rhs)/i;$upgrade_target$upgrade_pattern \$c $op \$p";
+ run_test($eval, "", "");
+ $eval = "my \$c = \"__$lhs\"; my \$p = qr/(?$charset:(?:..)$quantifier$rhs)/i;$upgrade_target$upgrade_pattern \$c $op \$p";
+ run_test($eval, "", "");
+ $eval = "my \$c = \"__$lhs\"; my \$p = qr/(?$charset:(?:.|\\R)$quantifier$rhs)/i;$upgrade_target$upgrade_pattern \$c $op \$p";
+ run_test($eval, "", "");
+ }
foreach my $bracketed (0, 1) { # Put rhs in [...], or not
+ next if $bracketed && @pattern != 1; # bracketed makes these
+ # or's instead of a sequence
+ foreach my $optimize_bracketed (0, 1) {
+ next if $optimize_bracketed && ! $bracketed;
foreach my $inverted (0,1) {
next if $inverted && ! $bracketed; # inversion only valid in [^...]
next if $inverted && @target != 1; # [perl #89750] multi-char
@@ -475,8 +689,9 @@
$rhs .= $rhs_char;
# Add a character to the class, so class doesn't get
- # optimized out
- $rhs .= '_]' if $bracketed;
+ # optimized out, unless we are testing that optimization
+ $rhs .= '_' if $optimize_bracketed;
+ $rhs .= ']' if $bracketed;
}
# Add one of: no capturing parens
@@ -492,6 +707,10 @@
: "((${rhs})+,?)";
foreach my $quantifier ("", '?', '*', '+', '{1,3}') {
+ # Perhaps should be TODOs, as are unimplemented, but
+ # maybe will never be implemented
+ next if @pattern != 1 && $quantifier;
+
# A ? or * quantifier normally causes the thing to be
# able to match a null string
my $quantifier_can_match_null = $quantifier eq '?' || $quantifier eq '*';
@@ -579,10 +798,10 @@
utf8::upgrade($p) if length($upgrade_pattern);
my $res = $op ? ($c =~ $p): ($c !~ $p);
- if (!$res || $ENV{PERL_DEBUG_FULL_TEST}) {
+ if (!$res || $list_all_tests) {
# Failed or debug; output the result
$count++;
- ok($res, $desc);
+ ok($res, "test $count - $desc");
} else {
# Just count the test as passed
$okays++;
@@ -596,14 +815,16 @@
}
}
}
-
- unless($ENV{PERL_DEBUG_FULL_TEST}) {
- $count++;
- is $okays, $this_iteration, "Subtests okay for "
- . "charset=$charset, utf8_pattern=$utf8_pattern";
}
}
}
+ unless($list_all_tests) {
+ $count++;
+ is $okays, $this_iteration, "$okays subtests ok for"
+ . " /$charset,"
+ . ' target="' . join("", @x_target) . '",'
+ . ' pat="' . join("", @x_pattern) . '"';
+ }
}
}
}
Property changes on: trunk/contrib/perl/t/re/fold_grind.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/re/no_utf8_pm.t
===================================================================
--- trunk/contrib/perl/t/re/no_utf8_pm.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/no_utf8_pm.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,7 +1,13 @@
#!./perl
-print "1..1\n";
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require './test.pl';
+}
+plan tests => 1;
+
# Make sure that case-insensitive matching of any Latin1 chars don't load
# utf8.pm. We assume that NULL won't force loading utf8.pm, and since it
# doesn't match any of the other chars, the regexec.c code would try to load
@@ -8,5 +14,4 @@
# a swash if it thought there was one.
"\0" =~ /[\001-\xFF]/i;
-print "not" if exists $INC{"utf8.pm"};
-print "ok 1\n";
+ok(! exists $INC{"utf8.pm"}, 'case insensitive matching of any Latin1 chars does not load utf8.pm');
Property changes on: trunk/contrib/perl/t/re/no_utf8_pm.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/re/overload.t
===================================================================
--- trunk/contrib/perl/t/re/overload.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/overload.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -33,4 +33,192 @@
is $1, $TAG, "void context //g against overloaded object";
}
+{
+ # an overloaded stringify returning itself shouldn't loop indefinitely
+
+
+ {
+ package Self;
+ use overload q{""} => sub {
+ return shift;
+ },
+ fallback => 1;
+ }
+
+ my $obj = bless [], 'Self';
+ my $r = qr/$obj/;
+ pass("self object, 1 arg");
+ $r = qr/foo$obj/;
+ pass("self object, 2 args");
+}
+
+{
+ # [perl #116823]
+ # when overloading regex string constants, a different code path
+ # was taken if the regex was compile-time, leading to overloaded
+ # regex constant string segments not being handled correctly.
+ # They were just treated as OP_CONST strings to be concatted together.
+ # In particular, if the overload returned a regex object, it would
+ # just be stringified rather than having any code blocks processed.
+
+ BEGIN {
+ overload::constant qr => sub {
+ my ($raw, $cooked, $type) = @_;
+ return $cooked unless defined $::CONST_QR_CLASS;
+ if ($type =~ /qq?/) {
+ return bless \$cooked, $::CONST_QR_CLASS;
+ } else {
+ return $cooked;
+ }
+ };
+ }
+
+ {
+ # returns a qr// object
+
+ package OL_QR;
+ use overload q{""} => sub {
+ my $re = shift;
+ return qr/(?{ $OL_QR::count++ })$$re/;
+ },
+ fallback => 1;
+
+ }
+
+ {
+ # returns a string
+
+ package OL_STR;
+ use overload q{""} => sub {
+ my $re = shift;
+ return qq/(?{ \$OL_STR::count++ })$$re/;
+ },
+ fallback => 1;
+
+ }
+
+ {
+ # returns chr(str)
+
+ package OL_CHR;
+ use overload q{""} => sub {
+ my $chr = shift;
+ return chr($$chr);
+ },
+ fallback => 1;
+
+ }
+
+
+ my $qr;
+
+ $::CONST_QR_CLASS = 'OL_QR';
+
+ $OL_QR::count = 0;
+ $qr = eval q{ qr/^foo$/; };
+ ok("foo" =~ $qr, "compile-time, OL_QR, single constant segment");
+ is($OL_QR::count, 1, "flag");
+
+ $OL_QR::count = 0;
+ $qr = eval q{ qr/^foo$(?{ $OL_QR::count++ })/; };
+ ok("foo" =~ $qr, "compile-time, OL_QR, multiple constant segments");
+ is($OL_QR::count, 2, "qr2 flag");
+
+
+ # test /foo.../ when foo is given string overloading,
+ # for various permutations of '...'
+
+ $::CONST_QR_CLASS = 'OL_STR';
+
+ for my $has_re_eval (0, 1) {
+ for my $has_qr (0, 1) {
+ for my $has_code (0, 1) {
+ for my $has_runtime (0, 1) {
+ for my $has_runtime_code (0, 1) {
+ if ($has_runtime_code) {
+ next unless $has_runtime;
+ }
+ note( "re_eval=$has_re_eval "
+ . "qr=$has_qr "
+ . "code=$has_code "
+ . "runtime=$has_runtime "
+ . "runtime_code=$has_runtime_code");
+ my $eval = '';
+ $eval .= q{use re 'eval'; } if $has_re_eval;
+ $eval .= q{$match = $str =~ };
+ $eval .= q{qr} if $has_qr;
+ $eval .= q{/^abc};
+ $eval .= q{(?{$blocks++})} if $has_code;
+ $eval .= q{$runtime} if $has_runtime;
+ $eval .= q{/; 1;};
+
+ my $runtime = q{def};
+ $runtime .= q{(?{$run_blocks++})} if $has_runtime_code;
+
+ my $blocks = 0;
+ my $run_blocks = 0;
+ my $match;
+ my $str = "abc";
+ $str .= "def" if $runtime;
+
+ my $result = eval $eval;
+ my $err = $@;
+ $result = $result ? 1 : 0;
+
+ if (!$has_re_eval) {
+ is($result, 0, "EVAL: $eval");
+ like($err, qr/Eval-group not allowed at runtime/,
+ "\$\@: $eval");
+ next;
+ }
+
+ is($result, 1, "EVAL: $eval");
+ diag("\$@=[$err]") unless $result;
+
+ is($match, 1, "MATCH: $eval");
+ is($blocks, $has_code, "blocks");
+ is($run_blocks, $has_runtime_code, "run_blocks");
+
+ }
+ }
+ }
+ }
+ }
+
+ # if the pattern gets (undetectably in advance) upgraded to utf8
+ # while being concatenated, it could mess up the alignment of the code
+ # blocks, giving rise to 'Eval-group not allowed at runtime' errs.
+
+ $::CONST_QR_CLASS = 'OL_CHR';
+
+ {
+ my $count = 0;
+ is(eval q{ "\x80\x{100}" =~ /128(?{ $count++ })256/ }, 1,
+ "OL_CHR eval + match");
+ is($count, 1, "OL_CHR count");
+ }
+
+ undef $::CONST_QR_CLASS;
+}
+
+
+{
+ # [perl #115004]
+ # array interpolation within patterns should handle qr overloading
+ # (like it does for scalar vars)
+
+ {
+ package P115004;
+ use overload 'qr' => sub { return qr/a/ };
+ }
+
+ my $o = bless [], 'P115004';
+ my @a = ($o);
+
+ ok("a" =~ /^$o$/, "qr overloading with scalar var interpolation");
+ ok("a" =~ /^@a$/, "qr overloading with array var interpolation");
+
+}
+
+
done_testing();
Property changes on: trunk/contrib/perl/t/re/overload.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/re/pat.t
===================================================================
--- trunk/contrib/perl/t/re/pat.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/pat.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -2,9 +2,7 @@
#
# This is a home for regular expression tests that don't fit into
# the format supported by re/regexp.t. If you want to add a test
-# that does fit that format, add it to re/re_tests, not here. Tests for \N
-# should be added here because they are treated as single quoted strings
-# there, which means they avoid the lexer which otherwise would look at them.
+# that does fit that format, add it to re/re_tests, not here.
use strict;
use warnings;
@@ -18,10 +16,11 @@
BEGIN {
chdir 't' if -d 't';
@INC = ('../lib','.');
+ require Config; import Config;
require './test.pl';
}
-plan tests => 451; # Update this when adding/deleting tests.
+plan tests => 472; # Update this when adding/deleting tests.
run_tests() unless caller;
@@ -154,7 +153,7 @@
{
$_ = 'now is the {time for all} good men to come to.';
- / {([^}]*)}/;
+ / \{([^}]*)}/;
is($1, 'time for all', "Match braces");
}
@@ -518,24 +517,52 @@
is(qr/(?u)\b\v$/, '(?^:(?u)\b\v$)', 'Verify (?u) compiles');
my $dual = qr/\b\v$/;
- use locale;
- my $locale = qr/\b\v$/;
- is($locale, '(?^l:\b\v$)', 'Verify has l modifier when compiled under use locale');
- no locale;
+ my $locale;
+ SKIP: {
+ skip 'No locale testing without d_setlocale', 1 if(!$Config{d_setlocale});
+
+ BEGIN {
+ if($Config{d_setlocale}) {
+ require locale; import locale;
+ }
+ }
+ $locale = qr/\b\v$/;
+ is($locale, '(?^l:\b\v$)', 'Verify has l modifier when compiled under use locale');
+ no locale;
+ }
+
use feature 'unicode_strings';
my $unicode = qr/\b\v$/;
is($unicode, '(?^u:\b\v$)', 'Verify has u modifier when compiled under unicode_strings');
is(qr/abc$dual/, '(?^u:abc(?^:\b\v$))', 'Verify retains d meaning when interpolated under locale');
- is(qr/abc$locale/, '(?^u:abc(?^l:\b\v$))', 'Verify retains l when interpolated under unicode_strings');
+ SKIP: {
+ skip 'No locale testing without d_setlocale', 1 if(!$Config{d_setlocale});
+
+ is(qr/abc$locale/, '(?^u:abc(?^l:\b\v$))', 'Verify retains l when interpolated under unicode_strings');
+ }
+
no feature 'unicode_strings';
- is(qr/abc$locale/, '(?^:abc(?^l:\b\v$))', 'Verify retains l when interpolated outside locale and unicode strings');
+ SKIP: {
+ skip 'No locale testing without d_setlocale', 1 if(!$Config{d_setlocale});
+
+ is(qr/abc$locale/, '(?^:abc(?^l:\b\v$))', 'Verify retains l when interpolated outside locale and unicode strings');
+ }
+
is(qr/def$unicode/, '(?^:def(?^u:\b\v$))', 'Verify retains u when interpolated outside locale and unicode strings');
- use locale;
- is(qr/abc$dual/, '(?^l:abc(?^:\b\v$))', 'Verify retains d meaning when interpolated under locale');
- is(qr/abc$unicode/, '(?^l:abc(?^u:\b\v$))', 'Verify retains u when interpolated under locale');
+ SKIP: {
+ skip 'No locale testing without d_setlocale', 2 if(!$Config{d_setlocale});
+
+ BEGIN {
+ if($Config{d_setlocale}) {
+ require locale; import locale;
+ }
+ }
+ is(qr/abc$dual/, '(?^l:abc(?^:\b\v$))', 'Verify retains d meaning when interpolated under locale');
+ is(qr/abc$unicode/, '(?^l:abc(?^u:\b\v$))', 'Verify retains u when interpolated under locale');
+ }
}
{
@@ -678,10 +705,11 @@
is($#-, 1, $message);
}
- foreach ('$+[0] = 13', '$-[0] = 13', '@+ = (7, 6, 5)', '@- = qw (foo bar)') {
+ foreach ('$+[0] = 13', '$-[0] = 13', '@+ = (7, 6, 5)',
+ '@- = qw (foo bar)', '$^N = 42') {
is(eval $_, undef);
like($@, qr/^Modification of a read-only value attempted/,
- 'Elements of @- and @+ are read-only');
+ '$^N, @- and @+ are read-only');
}
{
@@ -986,7 +1014,7 @@
my @space1 = sort grep {$space {$_} =~ /[[:space:]]/} keys %space;
my @space2 = sort grep {$space {$_} =~ /[[:blank:]]/} keys %space;
- is("@space0", "cr ff lf spc tab", $message);
+ is("@space0", "cr ff lf spc tab vt", $message);
is("@space1", "cr ff lf spc tab vt", $message);
is("@space2", "spc tab", $message);
}
@@ -1070,51 +1098,6 @@
}
{
- # Test that a regex followed by an operator and/or a statement modifier work
- # These tests use string-eval so that it reports a clean error when it fails
- # (without the string eval the test script might be unparseable)
-
- # Note: these test check the behaviour that currently is valid syntax
- # If a new regex modifier is added and a test fails then there is a backwards-compatibility issue
- # Note-2: a new deprecate warning was added for this with commit e6897b1a5db0410e387ccbf677e89fc4a1d8c97a
- # which indicate that this syntax will be removed in 5.16.
- # When this happens the tests can be removed
-
- foreach (['my $r = "a" =~ m/a/lt 2', 'm', 'lt'],
- ['my $r = "a" =~ m/a/le 1', 'm', 'le'],
- ['my $r = "a" =~ m/a/eq 1', 'm', 'eq'],
- ['my $r = "a" =~ m/a/ne 0', 'm', 'ne'],
- ['my $r = "a" =~ m/a/and 1', 'm', 'and'],
- ['my $r = "a" =~ m/a/unless 0', 'm', 'unless'],
- ['my $c = 1; my $r; $r = "a" =~ m/a/while $c--', 'm', 'while'],
- ['my $c = 0; my $r; $r = "a" =~ m/a/until $c++', 'm', 'until'],
- ['my $r; $r = "a" =~ m/a/for 1', 'm', 'for'],
- ['my $r; $r = "a" =~ m/a/foreach 1', 'm', 'foreach'],
-
- ['my $t = "a"; my $r = $t =~ s/a//lt 2', 's', 'lt'],
- ['my $t = "a"; my $r = $t =~ s/a//le 1', 's', 'le'],
- ['my $t = "a"; my $r = $t =~ s/a//ne 0', 's', 'ne'],
- ['my $t = "a"; my $r = $t =~ s/a//and 1', 's', 'and'],
- ['my $t = "a"; my $r = $t =~ s/a//unless 0', 's', 'unless'],
-
- ['my $c = 1; my $r; my $t = "a"; $r = $t =~ s/a//while $c--', 's', 'while'],
- ['my $c = 0; my $r; my $t = "a"; $r = $t =~ s/a//until $c++', 's', 'until'],
- ['my $r; my $t = "a"; $r = $t =~ s/a//for 1', 's', 'for'],
- ['my $r; my $t = "a"; $r = $t =~ s/a//for 1', 's', 'foreach'],
- ) {
- my $message = sprintf 'regex (%s) followed by $_->[2]',
- $_->[1] eq 'm' ? 'm//' : 's///';
- my $code = "$_->[0]; 'eval_ok ' . \$r";
- my $result = do {
- no warnings 'syntax';
- eval $code;
- };
- is($@, '', $message);
- is($result, 'eval_ok 1', $message);
- }
- }
-
- {
my $str= "\x{100}";
chop $str;
my $qr= qr/$str/;
@@ -1167,6 +1150,236 @@
is($got,$want,'RT #84294: check that "ab" =~ /((\w+)(?{ push @got, $2 })){2}/ leaves @got in the correct state');
}
+ {
+ # Suppress warnings, as the non-unicode one comes out even if turn off
+ # warnings here (because the execution is done in another scope).
+ local $SIG{__WARN__} = sub {};
+ my $str = "\x{110000}";
+
+ # No non-unicode code points match any Unicode property, even inverse
+ # ones
+ unlike($str, qr/\p{ASCII_Hex_Digit=True}/, "Non-Unicode doesn't match \\p{}");
+ unlike($str, qr/\p{ASCII_Hex_Digit=False}/, "Non-Unicode doesn't match \\p{}");
+ like($str, qr/\P{ASCII_Hex_Digit=True}/, "Non-Unicode matches \\P{}");
+ like($str, qr/\P{ASCII_Hex_Digit=False}/, "Non-Unicode matches \\P{}");
+ }
+
+ {
+ # Test that IDstart works, but because the author (khw) knows
+ # regexes much better than the rest of the core, it is being done here
+ # in the context of a regex which relies on buffer names beginng with
+ # IDStarts.
+ use utf8;
+ my $str = "abc";
+ like($str, qr/(?<a>abc)/, "'a' is legal IDStart");
+ like($str, qr/(?<_>abc)/, "'_' is legal IDStart");
+ like($str, qr/(?<ß>abc)/, "U+00DF is legal IDStart");
+ like($str, qr/(?<ℕ>abc)/, "U+2115' is legal IDStart");
+
+ # This test works on Unicode 6.0 in which U+2118 and U+212E are legal
+ # IDStarts there, but are not Word characters, and therefore Perl
+ # doesn't allow them to be IDStarts. But there is no guarantee that
+ # Unicode won't change things around in the future so that at some
+ # future Unicode revision these tests would need to be revised.
+ foreach my $char ("%", "×", chr(0x2118), chr(0x212E)) {
+ my $prog = <<"EOP";
+use utf8;;
+"abc" =~ qr/(?<$char>abc)/;
+EOP
+ utf8::encode($prog);
+ fresh_perl_like($prog, qr!Group name must start with a non-digit word character!, "",
+ sprintf("'U+%04X not legal IDFirst'", ord($char)));
+ }
+ }
+
+ { # [perl #101710]
+ my $pat = "b";
+ utf8::upgrade($pat);
+ like("\xffb", qr/$pat/i, "/i: utf8 pattern, non-utf8 string, latin1-char preceding matching char in string");
+ }
+
+ { # Crash with @a =~ // warning
+ local $SIG{__WARN__} = sub {
+ pass 'no crash for @a =~ // warning'
+ };
+ eval ' sub { my @a =~ // } ';
+ }
+
+ { # Concat overloading and qr// thingies
+ my @refs;
+ my $qr = qr//;
+ package Cat {
+ require overload;
+ overload->import(
+ '""' => sub { ${$_[0]} },
+ '.' => sub {
+ push @refs, ref $_[1] if ref $_[1];
+ bless $_[2] ? \"$_[1]${$_[0]}" : \"${$_[0]}$_[1]"
+ }
+ );
+ }
+ my $s = "foo";
+ my $o = bless \$s, Cat::;
+ /$o$qr/;
+ is "@refs", "Regexp", '/$o$qr/ passes qr ref to cat overload meth';
+ }
+
+ {
+ my $count=0;
+ my $str="\n";
+ $count++ while $str=~/.*/g;
+ is $count, 2, 'test that ANCH_MBOL works properly. We should get 2 from $count++ while "\n"=~/.*/g';
+ my $class_count= 0;
+ $class_count++ while $str=~/[^\n]*/g;
+ is $class_count, $count, 'while "\n"=~/.*/g and while "\n"=~/[^\n]*/g should behave the same';
+ my $anch_count= 0;
+ $anch_count++ while $str=~/^.*/mg;
+ is $anch_count, 1, 'while "\n"=~/^.*/mg should match only once';
+ }
+
+ { # [perl #111174]
+ use re '/u';
+ like "\xe0", qr/(?i:\xc0)/, "(?i: shouldn't lose the passed in /u";
+ use re '/a';
+ unlike "\x{100}", qr/(?i:\w)/, "(?i: shouldn't lose the passed in /a";
+ use re '/aa';
+ unlike 'k', qr/(?i:\N{KELVIN SIGN})/, "(?i: shouldn't lose the passed in /aa";
+ }
+
+ {
+ # the test for whether the pattern should be re-compiled should
+ # consider the UTF8ness of the previous and current pattern
+ # string, as well as the physical bytes of the pattern string
+
+ for my $s ("\xc4\x80", "\x{100}") {
+ ok($s =~ /^$s$/, "re-compile check is UTF8-aware");
+ }
+ }
+
+ # #113682 more overloading and qr//
+ # when doing /foo$overloaded/, if $overloaded returns
+ # a qr/(?{})/ via qr or "" overloading, then 'use re 'eval'
+ # shouldn't be required. Via '.', it still is.
+ {
+ package Qr0;
+ use overload 'qr' => sub { qr/(??{50})/ };
+
+ package Qr1;
+ use overload '""' => sub { qr/(??{51})/ };
+
+ package Qr2;
+ use overload '.' => sub { $_[1] . qr/(??{52})/ };
+
+ package Qr3;
+ use overload '""' => sub { qr/(??{7})/ },
+ '.' => sub { $_[1] . qr/(??{53})/ };
+
+ package Qr_indirect;
+ use overload '""' => sub { $_[0][0] };
+
+ package main;
+
+ for my $i (0..3) {
+ my $o = bless [], "Qr$i";
+ if ((0,0,1,1)[$i]) {
+ eval { "A5$i" =~ /^A$o$/ };
+ like($@, qr/Eval-group not allowed/, "Qr$i");
+ eval { "5$i" =~ /$o/ };
+ like($@, ($i == 3 ? qr/^$/ : qr/no method found,/),
+ "Qr$i bare");
+ {
+ use re 'eval';
+ ok("A5$i" =~ /^A$o$/, "Qr$i - with use re eval");
+ eval { "5$i" =~ /$o/ };
+ like($@, ($i == 3 ? qr/^$/ : qr/no method found,/),
+ "Qr$i bare - with use re eval");
+ }
+ }
+ else {
+ ok("A5$i" =~ /^A$o$/, "Qr$i");
+ ok("5$i" =~ /$o/, "Qr$i bare");
+ }
+ }
+
+ my $o = bless [ bless [], "Qr1" ], 'Qr_indirect';
+ ok("A51" =~ /^A$o/, "Qr_indirect");
+ ok("51" =~ /$o/, "Qr_indirect bare");
+ }
+
+ { # Various flags weren't being set when a [] is optimized into an
+ # EXACTish node
+ ;
+ ;
+ ok("\x{017F}\x{017F}" =~ qr/^[\x{00DF}]?$/i, "[] to EXACTish optimization");
+ }
+
+ {
+ for my $char (":", "\x{f7}", "\x{2010}") {
+ my $utf8_char = $char;
+ utf8::upgrade($utf8_char);
+ my $display = $char;
+ $display = display($display);
+ my $utf8_display = "utf8::upgrade(\"$display\")";
+
+ like($char, qr/^$char?$/, "\"$display\" =~ /^$display?\$/");
+ like($char, qr/^$utf8_char?$/, "my \$p = \"$display\"; utf8::upgrade(\$p); \"$display\" =~ /^\$p?\$/");
+ like($utf8_char, qr/^$char?$/, "my \$c = \"$display\"; utf8::upgrade(\$c); \"\$c\" =~ /^$display?\$/");
+ like($utf8_char, qr/^$utf8_char?$/, "my \$c = \"$display\"; utf8::upgrade(\$c); my \$p = \"$display\"; utf8::upgrade(\$p); \"\$c\" =~ /^\$p?\$/");
+ }
+ }
+
+ {
+ # #116148: Pattern utf8ness sticks around globally
+ # the utf8 in the first match was sticking around for the second
+ # match
+
+ use feature 'unicode_strings';
+
+ my $x = "\x{263a}";
+ $x =~ /$x/;
+
+ my $text = "Perl";
+ ok("Perl" =~ /P.*$/i, '#116148');
+ }
+
+ { # 117327: Sequence (?#...) not recognized in regex
+ # The space between the '(' and '?' is now deprecated; this test should
+ # be removed when the deprecation is made fatal.
+ no warnings;
+ like("ab", qr/a( ?#foo)b/x);
+ }
+
+ { # 118297: Mixing up- and down-graded strings in regex
+ utf8::upgrade(my $u = "\x{e5}");
+ utf8::downgrade(my $d = "\x{e5}");
+ my $warned;
+ local $SIG{__WARN__} = sub { $warned++ if $_[0] =~ /\AMalformed UTF-8/ };
+ my $re = qr/$u$d/;
+ ok(!$warned, "no warnings when interpolating mixed up-/downgraded strings in pattern");
+ my $c = "\x{e5}\x{e5}";
+ utf8::downgrade($c);
+ like($c, $re, "mixed up-/downgraded pattern matches downgraded string");
+ utf8::upgrade($c);
+ like($c, $re, "mixed up-/downgraded pattern matches upgraded string");
+ }
+
+ {
+ # RT #119125
+ # the earlier fix for /[#](?{})/x, although correct, as a
+ # side-effect fixed another long-standing bug where /[#$x]/x
+ # didn't interpolate the var $x. Although fixing that is good,
+ # it's too big a change for maint, so keep the old buggy behaviour
+ # for now.
+
+ my $b = 'cd';
+ my $s = 'abcd$%#&';
+ $s =~ s/[a#$b%]/X/g;
+ is ($s, 'XbXX$XX&', 'RT #119125 without /x');
+ $s = 'abcd$%#&';
+ $s =~ s/[a#$b%]/X/gx;
+ is ($s, 'XXcdXXX&', 'RT #119125 with /x');
+ }
+
} # End of sub run_tests
1;
Property changes on: trunk/contrib/perl/t/re/pat.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/re/pat_advanced.t
===================================================================
--- trunk/contrib/perl/t/re/pat_advanced.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/pat_advanced.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -789,6 +789,12 @@
}
{
+ # The second half of RT #114808
+ warning_is(sub {'aa' =~ /.+\x{100}/}, undef,
+ 'utf8-only floating substr, non-utf8 target, no warning');
+ }
+
+ {
my $message = "qr /.../x";
my $R = qr / A B C # D E/x;
ok("ABCDE" =~ $R && $& eq "ABC", $message);
@@ -829,15 +835,6 @@
}
{
- # XXX DAPM 13-Apr-06. Recursive split is still broken. It's only luck it
- # hasn't been crashing. Disable this test until it is fixed properly.
- # XXX also check what it returns rather than just doing ok(1,...)
- # split /(?{ split "" })/, "abc";
- local $::TODO = "Recursive split is still broken";
- ok 0, 'cache_re & "(?{": it dumps core in 5.6.1 & 5.8.0';
- }
-
- {
ok "\x{100}\n" =~ /\x{100}\n$/, "UTF-8 length cache and fbm_compile";
}
@@ -882,16 +879,16 @@
}
{
- for (120 .. 130) {
+ for (120 .. 130, 240 .. 260) {
my $head = 'x' x $_;
my $message = q [Don't misparse \x{...} in regexp ] .
- q [near 127 char EXACT limit];
+ q [near EXACT char count limit];
for my $tail ('\x{0061}', '\x{1234}', '\x61') {
eval qq{like("$head$tail", qr/$head$tail/, \$message)};
is($@, '', $message);
}
$message = q [Don't misparse \N{...} in regexp ] .
- q [near 127 char EXACT limit];
+ q [near EXACT char count limit];
for my $tail ('\N{SNOWFLAKE}') {
eval qq {use charnames ':full';
like("$head$tail", qr/$head$tail/, \$message)};
@@ -980,6 +977,9 @@
use Cname;
ok 'fooB' =~ /\N{foo}[\N{B}\N{b}]/, "Passthrough charname";
+ my $name = "foo\xDF";
+ my $result = eval "'A${name}B' =~ /^A\\N{$name}B\$/";
+ ok !$@ && $result, "Passthrough charname of non-ASCII, Latin1";
#
# Why doesn't must_warn work here?
#
@@ -986,7 +986,7 @@
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/,
+ ok $w && $w =~ /Using just the first character returned by \\N\{} in character class/,
"single character in [\\N{}] warning";
undef $w;
@@ -994,6 +994,16 @@
"Zerolength charname in charclass doesn't match \\\\0"];
ok $w && $w =~ /Ignoring zero length/,
'Ignoring zero length \N{} in character class warning';
+ undef $w;
+ eval q [ok 'xy' =~ /x[\N{EMPTY-STR} y]/x,
+ 'Empty string charname in [] is ignored; finds a following character'];
+ ok $w && $w =~ /Ignoring zero length/,
+ 'Ignoring zero length \N{} in character class warning';
+ undef $w;
+ eval q [ok 'x ' =~ /x[\N{EMPTY-STR} y]/,
+ 'Empty string charname in [] is ignored; finds a following blank under /x'];
+ ok $w && $w =~ /Ignoring zero length/,
+ 'Ignoring zero length \N{} in character class warning';
ok 'AB' =~ /(\N{EVIL})/ && $1 eq 'A', 'Charname caching $1';
ok 'ABC' =~ /(\N{EVIL})/, 'Charname caching $1';
@@ -1004,6 +1014,37 @@
ok "\N{LONG-STR}" =~ /^\N{LONG-STR}$/, 'Verify that long string works';
ok "\N{LONG-STR}" =~ /^\N{LONG-STR}$/i, 'Verify under folding that long string works';
+ eval '/(?[[\N{EMPTY-STR}]])/';
+ ok $@ && $@ =~ /Zero length \\N\{}/;
+
+ undef $w;
+ eval q [is("\N{TOO MANY SPACES}", "TOO MANY SPACES", "Multiple spaces in character name works")];
+ like ($w, qr/A sequence of multiple spaces in a charnames alias definition is deprecated/, "... but returns a deprecation warning");
+ eval q [use utf8; is("\N{TOO MANY SPACES}", "TOO MANY SPACES", "Same under 'use utf8': they work")];
+ like ($w, qr/A sequence of multiple spaces in a charnames alias definition is deprecated/, "... but return a deprecation warning");
+ {
+ no warnings 'deprecated';
+ undef $w;
+ eval q ["\N{TOO MANY SPACES}"];
+ ok (! defined $w, "... and no warning if warnings are off");
+ eval q [use utf8; "\N{TOO MANY SPACES}"];
+ ok (! defined $w, "... same under 'use utf8'");
+ }
+
+ undef $w;
+ eval q [is("\N{TRAILING SPACE }", "TRAILING SPACE ", "Trailing space in character name works")];
+ like ($w, qr/Trailing white-space in a charnames alias definition is deprecated/, "... but returns a deprecation warning");
+ eval q [use utf8; is("\N{TRAILING SPACE }", "TRAILING SPACE ", "Same under 'use utf8': they work")];
+ like ($w, qr/Trailing white-space in a charnames alias definition is deprecated/, "... but returns a deprecation warning");
+ {
+ no warnings 'deprecated';
+ undef $w;
+ eval q ["\N{TRAILING SPACE }"];
+ ok (! defined $w, "... and no warning if warnings are off");
+ eval q [use utf8; "\N{TRAILING SPACE }"];
+ ok (! defined $w, "... same under 'use utf8'");
+ }
+
# If remove the limitation in regcomp code these should work
# differently
undef $w;
@@ -1010,21 +1051,45 @@
eval q [ok "\N{TOO-LONG-STR}" =~ /^\N{TOO-LONG-STR}$/, 'Verify that what once was too long a string works'];
eval 'q(syntax error) =~ /\N{MALFORMED}/';
ok $@ && $@ =~ /Malformed/, 'Verify that malformed utf8 gives an error';
- undef $w;
eval 'q() =~ /\N{4F}/';
- ok $w && $w =~ /Deprecated/, 'Verify that leading digit in name gives warning';
- undef $w;
+ ok $@ && $@ =~ /Invalid character/, 'Verify that leading digit in name gives error';
eval 'q() =~ /\N{COM,MA}/';
- ok $w && $w =~ /Deprecated/, 'Verify that comma in name gives warning';
- undef $w;
- my $name = "A\x{D7}O";
+ ok $@ && $@ =~ /Invalid character/, 'Verify that comma in name gives error';
+ $name = "A\x{D7}O";
eval "q(W) =~ /\\N{$name}/";
- ok $w && $w =~ /Deprecated/, 'Verify that latin1 symbol in name gives warning';
+ ok $@ && $@ =~ /Invalid character/, 'Verify that latin1 symbol in name gives error';
+ my $utf8_name = "7 CITIES OF GOLD";
+ utf8::upgrade($utf8_name);
+ eval "use utf8; q(W) =~ /\\N{$utf8_name}/";
+ ok $@ && $@ =~ /Invalid character/, 'Verify that leading digit in utf8 name gives error';
+ $utf8_name = "SHARP #";
+ utf8::upgrade($utf8_name);
+ eval "use utf8; q(W) =~ /\\N{$utf8_name}/";
+ ok $@ && $@ =~ /Invalid character/, 'Verify that ASCII symbol in utf8 name gives error';
+ $utf8_name = "A HOUSE \xF7 AGAINST ITSELF";
+ utf8::upgrade($utf8_name);
+ eval "use utf8; q(W) =~ /\\N{$utf8_name}/";
+ ok $@ && $@ =~ /Invalid character/, 'Verify that latin1 symbol in utf8 name gives error';
+ $utf8_name = "\x{664} HORSEMEN}";
+ eval "use utf8; q(W) =~ /\\N{$utf8_name}/";
+ ok $@ && $@ =~ /Invalid character/, 'Verify that leading above Latin1 digit in utf8 name gives error';
+ $utf8_name = "A \x{1F4A9} WOULD SMELL AS SWEET}";
+ eval "use utf8; q(W) =~ /\\N{$utf8_name}/";
+ ok $@ && $@ =~ /Invalid character/, 'Verify that above Latin1 symbol in utf8 name gives error';
+
undef $w;
$name = "A\x{D1}O";
eval "q(W) =~ /\\N{$name}/";
ok ! $w, 'Verify that latin1 letter in name doesnt give warning';
+ # This tests the code path that restarts the parse when the recursive
+ # call to S_reg() from within S_grok_bslash_N() discovers that the
+ # pattern needs to be recalculated as UTF-8. use eval to avoid
+ # needing literal Unicode in this source file:
+ my $r = eval "qr/\\N{\x{100}\x{100}}/";
+ isnt $r, undef, "Generated regex for multi-char UTF-8 charname"
+ or diag($@);
+ ok "\x{100}\x{100}" =~ $r, "which matches";
}
{
@@ -1521,11 +1586,14 @@
my $ary = shift @$t;
foreach my $pat (@$t) {
foreach my $str (@$ary) {
- ok $str =~ /($pat)/, $pat;
- is($1, $str, $pat);
+ my $temp_str = $str;
+ $temp_str = display($temp_str);
+ ok $str =~ /($pat)/, $temp_str . " =~ /($pat)";
+ my $temp_1 = $1;
+ is($1, $str, "\$1='" . display($temp_1) . "' eq '" . $temp_str . "' after ($pat)");
utf8::upgrade ($str);
- ok $str =~ /($pat)/, "Upgraded string - $pat";
- is($1, $str, "Upgraded string - $pat");
+ ok $str =~ /($pat)/, "Upgraded " . $temp_str . " =~ /($pat)/";
+ is($1, $str, "\$1='" . display($temp_1) . "' eq '" . $temp_str . "'(upgraded) after ($pat)");
}
}
}
@@ -1585,7 +1653,7 @@
{
# Test for keys in %+ and %-
my $message = 'Test keys in %+ and %-';
- no warnings 'uninitialized';
+ no warnings 'uninitialized', 'deprecated', 'experimental::lexical_topic';
my $_ = "abcdef";
/(?<foo>a)|(?<foo>b)/;
is((join ",", sort keys %+), "foo", $message);
@@ -1606,6 +1674,7 @@
{
# length() on captures, the numbered ones end up in Perl_magic_len
+ no warnings 'deprecated', 'experimental::lexical_topic';
my $_ = "aoeu \xe6var ook";
/^ \w+ \s (?<eek>\S+)/x;
@@ -1655,7 +1724,6 @@
print ">$1<\n";
EOP
- local $::TODO = 'RT #86042';
fresh_perl_is(<<'EOP', ">abc<\n", {}, 'no mention of $&');
my $x;
($x='abc')=~/(abc)/g;
@@ -1740,10 +1808,11 @@
my @isPunct = grep {/[[:punct:]]/ != /\p{IsPunct}/}
map {chr} 0x80 .. 0xff;
- is(join ('', @isPunct), "\xa1\xab\xb7\xbb\xbf", # ¡ « · » ¿
+ is(join ('', @isPunct), "\xa1\xa7\xab\xb6\xb7\xbb\xbf", # ¡ « · » ¿
'IsPunct disagrees with [:punct:] outside ASCII');
my @isPunctLatin1 = eval q {
+ no warnings 'deprecated';
use encoding 'latin1';
grep {/[[:punct:]]/ != /\p{IsPunct}/} map {chr} 0x80 .. 0xff;
};
@@ -2054,7 +2123,7 @@
(?<=[=&]) (?=.)
)}iox';
is($@, '', $message);
- isa_ok($r, 'Regexp', $message);
+ object_ok($r, 'Regexp', $message);
}
# RT #82610
@@ -2066,6 +2135,58 @@
like("\xC0", $p, "Verify \"\\xC0\" =~ /[\\xE0_]/i; pattern in utf8");
}
+ ok "x" =~ /\A(?>(?:(?:)A|B|C?x))\z/,
+ "Check TRIE does not overwrite EXACT following NOTHING at start - RT #111842";
+
+ {
+ my $single = ":";
+ my $upper = "\x{390}"; # Fold is 3 chars.
+ my $multi = CORE::fc($upper);
+
+ my $failed = 0;
+
+ # Try forcing a node to be split, with a multi-char fold at the
+ # boundary
+ for my $repeat (1 .. 300) {
+ my $string = $single x $repeat;
+ my $lhs = $string . $upper;
+ if ($lhs !~ m/$string$multi/i) {
+ $failed = $repeat;
+ last;
+ }
+ }
+ ok(! $failed, "Matched multi-char fold across EXACTFish node boundaries; if failed, was at count $failed");
+
+ $failed = 0;
+ for my $repeat (1 .. 300) {
+ my $string = $single x $repeat;
+ my $lhs = $string . "\N{LATIN SMALL LIGATURE FFI}";
+ if ($lhs !~ m/${string}ff\N{LATIN SMALL LETTER I}/i) {
+ $failed = $repeat;
+ last;
+ }
+ }
+ ok(! $failed, "Matched multi-char fold across EXACTFish node boundaries; if failed, was at count $failed");
+
+ $failed = 0;
+ for my $repeat (1 .. 300) {
+ my $string = $single x $repeat;
+ my $lhs = $string . "\N{LATIN SMALL LIGATURE FFL}";
+ if ($lhs !~ m/${string}ff\N{U+6c}/i) {
+ $failed = $repeat;
+ last;
+ }
+ }
+ ok(! $failed, "Matched multi-char fold across EXACTFish node boundaries; if failed, was at count $failed");
+ }
+
+ {
+ fresh_perl_is('print eval "\"\x{101}\" =~ /[[:lower:]]/", "\n"; print eval "\"\x{100}\" =~ /[[:lower:]]/i", "\n";',
+ "1\n1", # Both re's should match
+ "",
+ "get [:lower:] swash in first eval; test under /i in second");
+ }
+
#
# Keep the following tests last -- they may crash perl
#
@@ -2112,6 +2233,62 @@
unlike("s\N{U+DF}", qr/^\x{00DF}/i, "\"s\\N{U+DF}\", qr/^\\x{00DF}/i");
}
+ # User-defined Unicode properties to match above-Unicode code points
+ sub Is_32_Bit_Super { return "110000\tFFFFFFFF\n" }
+ sub Is_Portable_Super { return '!utf8::Any' } # Matches beyond 32 bits
+
+ { # Assertion was failing on on 64-bit platforms; just didn't work on 32.
+ no warnings qw(non_unicode portable);
+ use Config;
+
+ # We use 'ok' instead of 'like' because the warnings are lexically
+ # scoped, and want to turn them off, so have to do the match in this
+ # scope
+ if ($Config{uvsize} < 8) {
+ ok(chr(0xFFFF_FFFE) =~ /\p{Is_32_Bit_Super}/,
+ "chr(0xFFFF_FFFE) can match a Unicode property");
+ ok(chr(0xFFFF_FFFF) =~ /\p{Is_32_Bit_Super}/,
+ "chr(0xFFFF_FFFF) can match a Unicode property");
+ my $p = qr/^[\x{FFFF_FFFF}]$/;
+ ok(chr(0xFFFF_FFFF) =~ $p,
+ "chr(0xFFFF_FFFF) can match itself in a [class]");
+ ok(chr(0xFFFF_FFFF) =~ $p, # Tests any caching
+ "chr(0xFFFF_FFFF) can match itself in a [class] subsequently");
+ }
+ else {
+ no warnings 'overflow';
+ ok(chr(0xFFFF_FFFF_FFFF_FFFE) =~ qr/\p{Is_Portable_Super}/,
+ "chr(0xFFFF_FFFF_FFFF_FFFE) can match a Unicode property");
+ ok(chr(0xFFFF_FFFF_FFFF_FFFF) =~ qr/^\p{Is_Portable_Super}$/,
+ "chr(0xFFFF_FFFF_FFFF_FFFF) can match a Unicode property");
+
+ my $p = qr/^[\x{FFFF_FFFF_FFFF_FFFF}]$/;
+ ok(chr(0xFFFF_FFFF_FFFF_FFFF) =~ $p,
+ "chr(0xFFFF_FFFF_FFFF_FFFF) can match itself in a [class]");
+ ok(chr(0xFFFF_FFFF_FFFF_FFFF) =~ $p, # Tests any caching
+ "chr(0xFFFF_FFFF_FFFF_FFFF) can match itself in a [class] subsequently");
+
+ # This test is because something was declared as 32 bits, but
+ # should have been cast to 64; only a problem where
+ # sizeof(STRLEN) != sizeof(UV)
+ ok(chr(0xFFFF_FFFF_FFFF_FFFE) !~ qr/\p{Is_32_Bit_Super}/, "chr(0xFFFF_FFFF_FFFF_FFFE) shouldn't match a range ending in 0xFFFF_FFFF");
+ }
+ }
+
+ { # [perl #112530], the code below caused a panic
+ sub InFoo { "a\tb\n9\ta\n" }
+ like("\n", qr/\p{InFoo}/,
+ "Overlapping ranges in user-defined properties");
+ }
+
+ { # Regexp:Grammars was broken:
+ # http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2013-06/msg01290.html
+ fresh_perl_like('use warnings; "abc" =~ qr{(?&foo){0}abc(?<foo>)}',
+ 'Quantifier unexpected on zero-length expression',
+ "",
+ 'No segfault on qr{(?&foo){0}abc(?<foo>)}');
+ }
+
# !!! NOTE that tests that aren't at all likely to crash perl should go
# a ways above, above these last ones.
Property changes on: trunk/contrib/perl/t/re/pat_advanced.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/t/re/pat_advanced_thr.t
===================================================================
--- trunk/contrib/perl/t/re/pat_advanced_thr.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/pat_advanced_thr.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/re/pat_advanced_thr.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/re/pat_psycho.t
===================================================================
--- trunk/contrib/perl/t/re/pat_psycho.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/pat_psycho.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -3,6 +3,9 @@
# This is a home for regular expression tests that don't fit into
# the format supported by re/regexp.t. If you want to add a test
# that does fit that format, add it to re/re_tests, not here.
+#
+# this file includes test that my burn a lot of CPU or otherwise be heavy
+# on resources. Set env var $PERL_SKIP_PSYCHO_TEST to skip this file
use strict;
use warnings;
@@ -21,7 +24,8 @@
}
-plan tests => 11; # Update this when adding/deleting tests.
+skip_all('$PERL_SKIP_PSYCHO_TEST set') if $ENV{PERL_SKIP_PSYCHO_TEST};
+plan tests => 15; # Update this when adding/deleting tests.
run_tests() unless caller;
@@ -29,16 +33,17 @@
# Tests start here.
#
sub run_tests {
+ print "# Set PERL_SKIP_PSYCHO_TEST to skip these tests\n";
- SKIP:
{
- print "# Set PERL_SKIP_PSYCHO_TEST to skip this test\n";
+
+ # stress test tries
+
my @normal = qw [the are some normal words];
- skip "Skipped Psycho", 2 * @normal if $ENV {PERL_SKIP_PSYCHO_TEST};
-
local $" = "|";
+ note "setting up trie psycho vars ...";
my @psycho = (@normal, map chr $_, 255 .. 20000);
my $psycho1 = "@psycho";
for (my $i = @psycho; -- $i;) {
@@ -48,13 +53,12 @@
my $psycho2 = "@psycho";
foreach my $word (@normal) {
- ok $word =~ /($psycho1)/ && $1 eq $word, 'Psycho';
- ok $word =~ /($psycho2)/ && $1 eq $word, 'Psycho';
+ ok $word =~ /($psycho1)/ && $1 eq $word, qq{"$word" =~ /\$psycho1/};
+ ok $word =~ /($psycho2)/ && $1 eq $word, qq{"$word" =~ /\$psycho1/};
}
}
- SKIP:
{
# stress test CURLYX/WHILEM.
#
@@ -63,8 +67,6 @@
# CURLYX and WHILEM blocks, except those related to LONGJMP, the
# super-linear cache and warnings. It executes about 0.5M regexes
- skip "No psycho tests" if $ENV {PERL_SKIP_PSYCHO_TEST};
- print "# Set PERL_SKIP_PSYCHO_TEST to skip this test\n";
my $r = qr/^
(?:
( (?:a|z+)+ )
@@ -158,6 +160,49 @@
}
ok($ok, $msg);
}
+
+
+ {
+ # these bits of test code used to run quadratically. If we break
+ # anything, they'll start to take minutes to run, rather than
+ # seconds. We don't actually measure times or set alarms, since
+ # that tends to be very fragile and prone to false positives.
+ # Instead, just hope that if someone is messing with
+ # performance-related code, they'll re-run the test suite and
+ # notice it suddenly takes a lot longer.
+
+ my $x;
+
+ $x = 'x' x 1_000_000;
+ 1 while $x =~ /(.)/g;
+ pass "ascii =~ /(.)/";
+
+ {
+ local ${^UTF8CACHE} = 1; # defeat debugging
+ $x = "\x{100}" x 1_000_000;
+ 1 while $x =~ /(.)/g;
+ pass "utf8 =~ /(.)/";
+ }
+
+ # run these in separate processes, since they set $&
+
+ fresh_perl_is(<<'EOF', "ok\n", {}, 'ascii =~ /(.)/, mention $&');
+$&;
+$x = 'x' x 1_000_000;
+1 while $x =~ /(.)/g;
+print "ok\n";
+EOF
+
+ fresh_perl_is(<<'EOF', "ok\n", {}, 'utf8 =~ /(.)/, mention $&');
+$&;
+local ${^UTF8CACHE} = 1; # defeat debugging
+$x = "\x{100}" x 1_000_000;
+1 while $x =~ /(.)/g;
+print "ok\n";
+EOF
+
+
+ }
} # End of sub run_tests
1;
Property changes on: trunk/contrib/perl/t/re/pat_psycho.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/re/pat_psycho_thr.t
===================================================================
--- trunk/contrib/perl/t/re/pat_psycho_thr.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/pat_psycho_thr.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/re/pat_psycho_thr.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/re/pat_re_eval.t
===================================================================
--- trunk/contrib/perl/t/re/pat_re_eval.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/pat_re_eval.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -6,6 +6,7 @@
use strict;
use warnings;
+use Config;
use 5.010;
@@ -22,10 +23,16 @@
}
-plan tests => 123; # Update this when adding/deleting tests.
+plan tests => 519; # Update this when adding/deleting tests.
run_tests() unless caller;
+# test that runtime code without 'use re eval' is trapped
+
+sub norun {
+ like($@, qr/Eval-group not allowed at runtime/, @_);
+}
+
#
# Tests start here.
#
@@ -42,12 +49,17 @@
undef $@;
eval {/$c/};
- like($@, qr/not allowed at runtime/, $message);
+ norun("$message norun 1");
- use re "eval";
- /$a$c$a/;
- is($b, '14', $message);
+ {
+ eval {/$a$c$a/};
+ norun("$message norun 2");
+ use re "eval";
+ /$a$c$a/;
+ is($b, '14', $message);
+ }
+
our $lex_a = 43;
our $lex_b = 17;
our $lex_c = 27;
@@ -57,9 +69,9 @@
is($lex_a, 44, $message);
is($lex_c, 43, $message);
- no re "eval";
undef $@;
- my $match = eval { /$a$c$a/ };
+ my $d = '(?{1})';
+ my $match = eval { /$a$c$a$d/ };
ok($@ && $@ =~ /Eval-group not allowed/ && !$match, $message);
is($b, '14', $message);
@@ -92,7 +104,6 @@
is(length qr /##/x, 9, "## in qr // doesn't corrupt memory; Bug 17776");
{
- use re 'eval';
ok "$x$x" =~ /^$x(??{$x})\z/,
"Postponed UTF-8 string in UTF-8 re matches UTF-8";
ok "$y$x" =~ /^$y(??{$x})\z/,
@@ -116,8 +127,7 @@
{
- use re 'eval';
- # Test if $^N and $+ work in (?{{})
+ # Test if $^N and $+ work in (?{})
our @ctl_n = ();
our @plus = ();
our $nested_tags;
@@ -170,9 +180,6 @@
}
{
- use re 'eval';
-
-
our $f;
local $f;
$f = sub {
@@ -312,11 +319,8 @@
is("@plus", $test->[3], "plus $c; Bug 56194");
is($str, $test->[4], "str $c; Bug 56194");
}
- SKIP: {
- if ($] le '5.010') {
- skip "test segfaults on perl < 5.10", 4;
- }
+ {
@ctl_n = ();
@plus = ();
@@ -342,6 +346,837 @@
}
}
+ {
+ # re evals within \U, \Q etc shouldn't be seen by the lexer
+ local our $a = "i";
+ local our $B = "J";
+ ok('(?{1})' =~ /^\Q(?{1})\E$/, '\Q(?{1})\E');
+ ok('(?{1})' =~ /^\Q(?{\E1\}\)$/, '\Q(?{\E1\}\)');
+ eval {/^\U(??{"$a\Ea"})$/ }; norun('^\U(??{"$a\Ea"})$ norun');
+ eval {/^\L(??{"$B\Ea"})$/ }; norun('^\L(??{"$B\Ea"})$ norun');
+ use re 'eval';
+ ok('Ia' =~ /^\U(??{"$a\Ea"})$/, '^\U(??{"$a\Ea"})$');
+ ok('ja' =~ /^\L(??{"$B\Ea"})$/, '^\L(??{"$B\Ea"})$');
+ }
+
+ {
+ # Comprehensive (hopefully) tests of closure behaviour:
+ # i.e. when do (?{}) blocks get (re)compiled, and what instances
+ # of lexical vars do they close over?
+
+ # if the pattern string gets utf8 upgraded while concatenating,
+ # make sure a literal code block is still detected (by still
+ # compiling in the absence of use re 'eval')
+
+ {
+ my $s1 = "\x{80}";
+ my $s2 = "\x{100}";
+ ok("\x{80}\x{100}" =~ /^$s1(?{1})$s2$/, "utf8 upgrade");
+ }
+
+ my ($cr1, $cr2, $cr3, $cr4);
+
+ for my $x (qw(a b c)) {
+ my $bc = ($x ne 'a');
+ my $c80 = chr(0x80);
+
+ # the most basic: literal code should be in same scope
+ # as the parent
+
+ ok("A$x" =~ /^A(??{$x})$/, "[$x] literal code");
+ ok("\x{100}$x" =~ /^\x{100}(??{$x})$/, "[$x] literal code UTF8");
+
+ # the "don't recompile if pattern unchanged" mechanism
+ # shouldn't apply to code blocks - recompile every time
+ # to pick up new instances of variables
+
+ my $code1 = 'B(??{$x})';
+ my $code1u = $c80 . "\x{100}" . '(??{$x})';
+
+ eval {/^A$code1$/};
+ norun("[$x] unvarying runtime code AA norun");
+ eval {/^A$code1u$/};
+ norun("[$x] unvarying runtime code AU norun");
+ eval {/^$c80\x{100}$code1$/};
+ norun("[$x] unvarying runtime code UA norun");
+ eval {/^$c80\x{101}$code1u$/};
+ norun("[$x] unvarying runtime code UU norun");
+
+ {
+ use re 'eval';
+ ok("AB$x" =~ /^A$code1$/, "[$x] unvarying runtime code AA");
+ ok("A$c80\x{100}$x" =~ /^A$code1u$/,
+ "[$x] unvarying runtime code AU");
+ ok("$c80\x{100}B$x" =~ /^$c80\x{100}$code1$/,
+ "[$x] unvarying runtime code UA");
+ ok("$c80\x{101}$c80\x{100}$x" =~ /^$c80\x{101}$code1u$/,
+ "[$x] unvarying runtime code UU");
+ }
+
+ # mixed literal and run-time code blocks
+
+ my $code2 = 'B(??{$x})';
+ my $code2u = $c80 . "\x{100}" . '(??{$x})';
+
+ eval {/^A(??{$x})-$code2$/};
+ norun("[$x] literal+runtime AA norun");
+ eval {/^A(??{$x})-$code2u$/};
+ norun("[$x] literal+runtime AU norun");
+ eval {/^$c80\x{100}(??{$x})-$code2$/};
+ norun("[$x] literal+runtime UA norun");
+ eval {/^$c80\x{101}(??{$x})-$code2u$/};
+ norun("[$x] literal+runtime UU norun");
+
+ {
+ use re 'eval';
+ ok("A$x-B$x" =~ /^A(??{$x})-$code2$/,
+ "[$x] literal+runtime AA");
+ ok("A$x-$c80\x{100}$x" =~ /^A(??{$x})-$code2u$/,
+ "[$x] literal+runtime AU");
+ ok("$c80\x{100}$x-B$x" =~ /^$c80\x{100}(??{$x})-$code2$/,
+ "[$x] literal+runtime UA");
+ ok("$c80\x{101}$x-$c80\x{100}$x"
+ =~ /^$c80\x{101}(??{$x})-$code2u$/,
+ "[$x] literal+runtime UU");
+ }
+
+ # literal qr code only created once, naked
+
+ $cr1 //= qr/^A(??{$x})$/;
+ ok("Aa" =~ $cr1, "[$x] literal qr once naked");
+
+ # literal qr code only created once, embedded with text
+
+ $cr2 //= qr/B(??{$x})$/;
+ ok("ABa" =~ /^A$cr2/, "[$x] literal qr once embedded text");
+
+ # literal qr code only created once, embedded with text + lit code
+
+ $cr3 //= qr/C(??{$x})$/;
+ ok("A$x-BCa" =~ /^A(??{$x})-B$cr3/,
+ "[$x] literal qr once embedded text + lit code");
+
+ # literal qr code only created once, embedded with text + run code
+
+ $cr4 //= qr/C(??{$x})$/;
+ my $code3 = 'A(??{$x})';
+
+ eval {/^$code3-B$cr4/};
+ norun("[$x] literal qr once embedded text + run code norun");
+ {
+ use re 'eval';
+ ok("A$x-BCa" =~ /^$code3-B$cr4/,
+ "[$x] literal qr once embedded text + run code");
+ }
+
+ # literal qr code, naked
+
+ my $r1 = qr/^A(??{$x})$/;
+ ok("A$x" =~ $r1, "[$x] literal qr naked");
+
+ # literal qr code, embedded with text
+
+ my $r2 = qr/B(??{$x})$/;
+ ok("AB$x" =~ /^A$r2/, "[$x] literal qr embedded text");
+
+ # literal qr code, embedded with text + lit code
+
+ my $r3 = qr/C(??{$x})$/;
+ ok("A$x-BC$x" =~ /^A(??{$x})-B$r3/,
+ "[$x] literal qr embedded text + lit code");
+
+ # literal qr code, embedded with text + run code
+
+ my $r4 = qr/C(??{$x})$/;
+ my $code4 = '(??{$x})';
+
+ eval {/^A$code4-B$r4/};
+ norun("[$x] literal qr embedded text + run code");
+ {
+ use re 'eval';
+ ok("A$x-BC$x" =~ /^A$code4-B$r4/,
+ "[$x] literal qr embedded text + run code");
+ }
+
+ # nested qr in different scopes
+
+ my $code5 = '(??{$x})';
+ my $r5 = qr/C(??{$x})/;
+
+ my $r6;
+ eval {qr/$code5-C(??{$x})/}; norun("r6 norun");
+ {
+ use re 'eval';
+ $r6 = qr/$code5-C(??{$x})/;
+ }
+
+ my @rr5;
+ my @rr6;
+
+ for my $y (qw(d e f)) {
+
+ my $rr5 = qr/^A(??{"$x$y"})-$r5/;
+ push @rr5, $rr5;
+ ok("A$x$y-C$x" =~ $rr5,
+ "[$x-$y] literal qr + r5");
+
+ my $rr6 = qr/^A(??{"$x$y"})-$r6/;
+ push @rr6, $rr6;
+ ok("A$x$y-$x-C$x" =~ $rr6,
+ "[$x-$y] literal qr + r6");
+ }
+
+ for my $i (0,1,2) {
+ my $y = 'Y';
+ my $yy = (qw(d e f))[$i];
+ my $rr5 = $rr5[$i];
+ ok("A$x$yy-C$x" =~ $rr5, "[$x-$yy] literal qr + r5, outside");
+ ok("A$x$yy-C$x-D$x" =~ /$rr5-D(??{$x})$/,
+ "[$x-$yy] literal qr + r5 + lit, outside");
+
+
+ my $rr6 = $rr6[$i];
+ push @rr6, $rr6;
+ ok("A$x$yy-$x-C$x" =~ $rr6,
+ "[$x-$yy] literal qr + r6, outside");
+ ok("A$x$yy-$x-C$x-D$x" =~ /$rr6-D(??{$x})/,
+ "[$x-$yy] literal qr + r6 +lit, outside");
+ }
+ }
+
+ # recursive subs should get lexical from the correct pad depth
+
+ sub recurse {
+ my ($n) = @_;
+ return if $n > 2;
+ ok("A$n" =~ /^A(??{$n})$/, "recurse($n)");
+ recurse($n+1);
+ }
+ recurse(0);
+
+ # for qr// containing run-time elements but with a compile-time
+ # code block, make sure the run-time bits are executed in the same
+ # pad they were compiled in
+ {
+ my $a = 'a'; # ensure outer and inner pads don't align
+ my $b = 'b';
+ my $c = 'c';
+ my $d = 'd';
+ my $r = qr/^$b(??{$c})$d$/;
+ ok("bcd" =~ $r, "qr with run-time elements and code block");
+ }
+
+ # check that cascaded embedded regexes all see their own lexical
+ # environment
+
+ {
+ my ($r1, $r2, $r3, $r4);
+ my ($x1, $x2, $x3, $x4) = (5,6,7,8);
+ { my $x1 = 1; $r1 = qr/A(??{$x1})/; }
+ { my $x2 = 2; $r2 = qr/$r1(??{$x2})/; }
+ { my $x3 = 3; $r3 = qr/$r2(??{$x3})/; }
+ { my $x4 = 4; $r4 = qr/$r3(??{$x4})/; }
+ ok("A1234" =~ /^$r4$/, "cascaded qr");
+ }
+
+ # and again, but in a loop, with no external references
+ # being maintained to the qr's
+
+ {
+ my $r = 'A';
+ for my $x (1..4) {
+ $r = qr/$r(??{$x})/;
+ }
+ my $x = 5;
+ ok("A1234" =~ /^$r$/, "cascaded qr loop");
+ }
+
+
+ # and again, but compiling the qrs in an eval so there
+ # aren't even refs to the qrs from any ops
+
+ {
+ my $r = 'A';
+ for my $x (1..4) {
+ $r = eval q[ qr/$r(??{$x})/; ];
+ }
+ my $x = 5;
+ ok("A1234" =~ /^$r$/, "cascaded qr loop");
+ }
+
+ # have qrs with either literal code blocks or only embedded
+ # code blocks, but not both
+
+ {
+ my ($r1, $r2, $r3, $r4);
+ my ($x1, $x3) = (7,8);
+ { my $x1 = 1; $r1 = qr/A(??{$x1})/; }
+ { $r2 = qr/${r1}2/; }
+ { my $x3 = 3; $r3 = qr/$r2(??{$x3})/; }
+ { $r4 = qr/${r3}4/; }
+ ok("A1234" =~ /^$r4$/, "cascaded qr mix 1");
+ ok("A12345" =~ /^${r4}5$/, "cascaded qr mix 2");
+ ok("A1234" =~ qr/^$r4$/ , "cascaded qr mix 3");
+ ok("A12345" =~ qr/^${r4}5$/, "cascaded qr mix 4");
+ }
+
+ # and make sure things are freed at the right time
+
+ SKIP: {
+ if ($Config{mad}) {
+ skip "MAD doesn't free eval CVs", 3;
+ }
+
+ {
+ sub Foo99::DESTROY { $Foo99::d++ }
+ $Foo99::d = 0;
+ my $r1;
+ {
+ my $x = bless [1], 'Foo99';
+ $r1 = eval 'qr/(??{$x->[0]})/';
+ }
+ my $r2 = eval 'qr/a$r1/';
+ my $x = 2;
+ ok(eval '"a1" =~ qr/^$r2$/', "match while in scope");
+ # make sure PL_reg_curpm isn't holding on to anything
+ "a" =~ /a(?{1})/;
+ is($Foo99::d, 0, "before scope exit");
+ }
+ ::is($Foo99::d, 1, "after scope exit");
+ }
+
+ # forward declared subs should Do The Right Thing with any anon CVs
+ # within them (i.e. pad_fixup_inner_anons() should work)
+
+ sub forward;
+ sub forward {
+ my $x = "a";
+ my $A = "A";
+ ok("Aa" =~ qr/^A(??{$x})$/, "forward qr compiletime");
+ ok("Aa" =~ qr/^$A(??{$x})$/, "forward qr runtime");
+ }
+ forward;
+ }
+
+ # test that run-time embedded code, when re-fed into toker,
+ # does all the right escapes
+
+ {
+ my $enc = eval 'use Encode; find_encoding("ascii")';
+
+ my $x = 0;
+ my $y = 'bad';
+
+ # note that most of the strings below are single-quoted, and the
+ # things within them, like '$y', *aren't* intended to interpolate
+
+ my $s1 =
+ 'a\\$y(?# (??{BEGIN{$x=1} "X1"})b(?# \Ux2\E)c\'d\\\\e\\\\Uf\\\\E';
+
+ ok(q{a$ybc'd\e\Uf\E} =~ /^$s1$/, "reparse");
+ is($x, 0, "reparse no BEGIN");
+
+ my $s2 = 'g\\$y# (??{{BEGIN{$x=2} "X3"}) \Ux3\E' . "\nh";
+
+ ok(q{a$ybc'd\\e\\Uf\\Eg$yh} =~ /^$s1$s2$/x, "reparse /x");
+ is($x, 0, "reparse /x no BEGIN");
+
+ my $b = '\\';
+ my $q = '\'';
+
+ # non-ascii in string as "<0xNNN>"
+ sub esc_str {
+ my $s = shift;
+ $s =~ s{(.)}{
+ my $c = ord($1);
+ ($c< 32 || $c > 127) ? sprintf("<0x%x>", $c) : $1;
+ }ge;
+ $s;
+ }
+ sub fmt { sprintf "hairy backslashes %s [%s] =~ /^%s/",
+ $_[0], esc_str($_[1]), esc_str($_[2]);
+ }
+
+
+ for my $u (
+ [ '', '', 'blank ' ],
+ [ "\x{100}", '\x{100}', 'single' ],
+ [ "\x{100}", "\x{100}", 'double' ])
+ {
+ for my $pair (
+ [ "$b", "$b$b" ],
+ [ "$q", "$q" ],
+ [ "$b$q", "$b$b$b$q" ],
+ [ "$b$b$q", "$b$b$b$b$q" ],
+ [ "$b$b$b$q", "$b$b$b$b$b$b$q" ],
+ [ "$b$b$b$b$q","$b$b$b$b$b$b$b$b$q" ],
+ ) {
+ my ($s, $r) = @$pair;
+ $s = "9$s";
+ my $ss = "$u->[0]$s";
+
+ my $c = '9' . $r;
+ my $cc = "$u->[1]$c";
+
+ ok($ss =~ /^$cc/, fmt("plain $u->[2]", $ss, $cc));
+
+ no strict;
+ my $chr41 = "\x41";
+ $ss = "$u->[0]\t${q}$chr41${b}x42$s";
+ $nine = $nine = "bad";
+ for my $use_qr ('', 'qr') {
+ $c = qq[(??{my \$z='{';]
+ . qq[$use_qr"$b${b}t$b$q$b${b}x41$b$b$b${b}x42"]
+ . qq[. \$nine})];
+ # (??{ qr/str/ }) goes through one less interpolation
+ # stage than (??{ qq/str/ })
+ $c =~ s{\\\\}{\\}g if ($use_qr eq 'qr');
+ $c .= $r;
+ $cc = "$u->[1]$c";
+ my $nine = 9;
+
+ eval {/^$cc/}; norun(fmt("code norun $u->[2]", $ss, $cc));
+ {
+ use re 'eval';
+ ok($ss =~ /^$cc/, fmt("code $u->[2]", $ss, $cc));
+ }
+
+ {
+ # Poor man's "use encoding 'ascii'".
+ # This causes a different code path in S_const_str()
+ # to be used
+ local ${^ENCODING} = $enc;
+ use re 'eval';
+ ok($ss =~ /^$cc/, fmt("encode $u->[2]", $ss, $cc));
+ }
+ }
+ }
+ }
+
+ my $code1u = "(??{qw(\x{100})})";
+ eval {/^$code1u$/}; norun("reparse embeded unicode norun");
+ {
+ use re 'eval';
+ ok("\x{100}" =~ /^$code1u$/, "reparse embeded unicode");
+ }
+ }
+
+ # a non-pattern literal won't get code blocks parsed at compile time;
+ # but they must get parsed later on if 'use re eval' is in scope
+ # also check that unbalanced {}'s are parsed ok
+
+ {
+ eval q["a{" =~ '^(??{"a{"})$'];
+ norun("non-pattern literal code norun");
+ eval {/^${\'(??{"a{"})'}$/};
+ norun("runtime code with unbalanced {} norun");
+
+ use re 'eval';
+ ok("a{" =~ '^a(??{"{"})$', "non-pattern literal code");
+ ok("a{" =~ /^a${\'(??{"{"})'}$/, "runtime code with unbalanced {}");
+ }
+
+ # make sure warnings come from the right place
+
+ {
+ use warnings;
+ my ($s, $t, $w);
+ local $SIG{__WARN__} = sub { $w .= "@_" };
+
+ $w = ''; $s = 's';
+ my $r = qr/(?{$t=$s+1})/;
+ "a" =~ /a$r/;
+ like($w, qr/pat_re_eval/, "warning main file");
+
+ # do it in an eval to get predictable line numbers
+ eval q[
+
+ $r = qr/(?{$t=$s+1})/;
+ ];
+ $w = ''; $s = 's';
+ "a" =~ /a$r/;
+ like($w, qr/ at \(eval \d+\) line 3/, "warning eval A");
+
+ $w = ''; $s = 's';
+ eval q[
+ use re 'eval';
+ my $c = '(?{$t=$s+1})';
+ "a" =~ /a$c/;
+ 1;
+ ];
+ like($w, qr/ at \(eval \d+\) line 1/, "warning eval B");
+ }
+
+ # jumbo test for:
+ # * recursion;
+ # * mixing all the different types of blocks (literal, qr/literal/,
+ # runtime);
+ # * backtracking (the Z+ alternation ensures CURLYX and full
+ # scope popping on backtracking)
+
+ {
+ sub recurse2 {
+ my ($depth)= @_;
+ return unless $depth;
+ my $s1 = '3-LMN';
+ my $r1 = qr/(??{"$s1-$depth"})/;
+
+ my $s2 = '4-PQR';
+ my $c1 = '(??{"$s2-$depth"})';
+ use re 'eval';
+ ok( "<12345-ABC-$depth-123-LMN-$depth-1234-PQR-$depth>"
+ . "<12345-ABC-$depth-123-LMN-$depth-1234-PQR-$depth>"
+ =~
+ /^<(\d|Z+)+(??{"45-ABC-$depth-"})(\d|Z+)+$r1-\d+$c1>
+ <(\d|Z+)+(??{"45-ABC-$depth-"})(\d|Z+)+$r1-\d+$c1>$/x,
+ "recurse2($depth)");
+ recurse2($depth-1);
+ }
+ recurse2(5);
+ }
+
+ # nested (??{}) called from various levels of a recursive function
+
+ {
+ sub recurse3 {
+ my ($n) = @_;
+ return if $n > 3;
+ ok("A$n" =~ m{^A(??{ "0123" =~ /((??{$n}))/; $1 })$},
+ "recurse3($n)");
+ ok("A$n" !~ m{^A(??{ "0123" =~ /((??{$n}))/; "X" })$},
+ "recurse3($n) nomatch");
+ recurse3($n+1);
+ }
+ recurse3(0);
+ }
+
+ # nested (??{}) being invoked recursively via a function
+
+ {
+ my $s = '';
+ our $recurse4;
+ my @alpha = qw(A B C D E);
+ $recurse4 = sub {
+ my ($n) = @_;
+ $s .= "(n=$n:";
+ if ($n < 4) {
+ my $m = ("$alpha[$n]" . substr("0123", 0, $n+1)) =~
+ m{^([A-Z])
+ (??{
+ $s .= "1=$1:";
+ "$n-0123" =~ m{^(\d)-(((??{$recurse4->($n+1)})))};
+ $s .= "i1=$1:<=[$2]";
+ $3; # NB - not stringified
+ })
+ $
+ }x;
+ $s .= "1a=$1:";
+ $s .= $m ? 'M' : '!M';
+ }
+ my $ret = '.*?' . ($n-1);
+ $s .= "<=[$ret])";
+ return $ret;
+ };
+ $recurse4->(0);
+ my $exp = '(n=0:1=A:(n=1:1=B:(n=2:1=C:(n=3:1=D:(n=4:<=[.*?3])'
+ . 'i1=3:<=[0123]1a=D:M<=[.*?2])i1=2:<=[012]1a=C:M<=[.*?1])'
+ . 'i1=1:<=[01]1a=B:M<=[.*?0])i1=0:<=[0]1a=A:M<=[.*?-1])';
+ is($s, $exp, 'recurse4');
+ }
+
+ # single (??{}) being invoked recursively via a function
+
+ {
+ my $s = '';
+ our $recurse5;
+ my @alpha = qw(A B C D E);
+ $recurse5 = sub {
+ my ($n) = @_;
+ $s .= "(n=$n:";
+ if ($n < 4) {
+ my $m = ("$alpha[$n]" . substr("0123", 0, $n+1)) =~
+ m{^([A-Z])
+ ((??{
+ $s .= "1=$1:";
+ $recurse5->($n+1);
+ }))
+ $
+ }x;
+ $s .= "1a=$1:2=$2:";
+ $s .= $m ? 'M' : '!M';
+ }
+ my $ret = '.*?' . ($n-1);
+ $s .= "<=[$ret])";
+ return $ret;
+ };
+ $recurse5->(0);
+ my $exp = '(n=0:1=A:(n=1:1=B:(n=2:1=C:(n=3:1=D:(n=4:<=[.*?3])'
+ . '1a=D:2=0123:M<=[.*?2])1a=C:2=012:M<=[.*?1])'
+ . '1a=B:2=01:M<=[.*?0])1a=A:2=0:M<=[.*?-1])';
+ is($s, $exp, 'recurse5');
+ }
+
+
+ # make sure that errors during compiling run-time code get trapped
+
+ {
+ use re 'eval';
+
+ my $code = '(?{$x=})';
+ eval { "a" =~ /^a$code/ };
+ like($@, qr/syntax error at \(eval \d+\) line \d+/, 'syntax error');
+
+ $code = '(?{BEGIN{die})';
+ eval { "a" =~ /^a$code/ };
+ like($@,
+ qr/BEGIN failed--compilation aborted at \(eval \d+\) line \d+/,
+ 'syntax error');
+ }
+
+ # make sure that 'use re eval' is propagated into compiling the
+ # pattern returned by (??{})
+
+ {
+ use re 'eval';
+ my $pat = 'B(??{1})C';
+ my $A = 'A';
+ # compile-time outer code-block
+ ok("AB1CD" =~ /^A(??{$pat})D$/, "re eval propagated compile-time");
+ # run-time outer code-block
+ ok("AB1CD" =~ /^$A(??{$pat})D$/, "re eval propagated run-time");
+ }
+
+ # returning a ref to something that had set magic but wasn't
+ # PERL_MAGIC_qr triggered a false positive assertion failure
+ # The test is not so much concerned with it not matching,
+ # as with not failing the assertion
+
+ {
+ ok("a" !~ /^(a)(??{ \$1 })/, '(??{ ref })');
+ }
+
+ # make sure the uninit warning from returning an undef var
+ # sees the right var
+
+ {
+ my ($u1, $u2);
+ my $warn = '';
+ local $SIG{__WARN__} = sub { $warn .= $_[0] };
+ $u1 =~ /(??{$u2})/ or die;
+ like($warn, qr/value \$u1 in pattern match.*\n.*value at/, 'uninit');
+ }
+
+ # test that code blocks are called in scalar context
+
+ {
+ my @a = (0);
+ ok("" =~ /^(?{@a})$/, '(?{}) in scalar context');
+ is($^R, 1, '(?{}) in scalar context: $^R');
+ ok("1" =~ /^(??{@a})$/, '(??{}) in scalar context');
+ ok("foo" =~ /^(?(?{@a})foo|bar)$/, '(?(?{})|) in scalar context');
+ }
+
+ # BEGIN in compiled blocks shouldn't mess with $1 et al
+
+ {
+ use re 'eval';
+ my $code1 = '(B)(??{ BEGIN { "X" =~ /X/ } $1})(C)';
+ ok("ABBCA" =~ /^(.)(??{$code1})\1$/, '(?{}) BEGIN and $1');
+ my $code2 = '(B)(??{ BEGIN { "X" =~ /X/ } $1 =~ /(.)/ ? $1 : ""})(C)';
+ ok("ABBCA" =~ /^(.)(??{$code2})\1$/, '(?{}) BEGIN and $1 mark 2');
+ }
+
+ # check that the optimiser is applied to code blocks: see if aelem has
+ # been converted to aelemfast
+
+ {
+ my $out;
+ for my $prog (
+ '/(?{$a[0]})/',
+ 'q() =~ qr/(?{$a[0]})/',
+ 'use re q(eval); q() =~ q{(?{$a[0]})}',
+ 'use re q(eval); $c = q{(?{$a[0]})}; /$c/',
+ 'use re q(eval); $c = q{(?{$a[0]})}; /(?{1;})$c/',
+ ) {
+ $out = runperl(switches => ["-Dt"], prog => $prog, stderr => 1);
+ like($out, qr/aelemfast|Recompile perl with -DDEBUGGING/,
+ "optimise: '$prog'");
+ }
+ }
+
+ # [perl #115080]
+ # Ensure that ?pat? matches exactly once, even when the run-time
+ # pattern changes, and even when the presence of run-time (?{}) affects
+ # how and when patterns are recompiled
+
+ {
+ my $m;
+
+ $m = '';
+ for (qw(a a a)) {
+ $m .= $_ if m?$_?;
+ }
+ is($m, 'a', '?pat? with a,a,a');
+
+ $m = '';
+ for (qw(a b c)) {
+ $m .= $_ if m?$_?;
+ }
+ is($m, 'a', '?pat? with a,b,c');
+
+ use re 'eval';
+
+ $m = '';
+ for (qw(a a a)) {
+ my $e = qq[(??{"$_"})];
+ $m .= $_ if m?$e?;
+ }
+ is($m, 'a', '?pat? with (??{a,a,a})');
+
+ $m = '';
+ for (qw(a b c)) {
+ my $e = qq[(??{"$_"})];
+ $m .= $_ if m?$e?;
+ }
+ is($m, 'a', '?pat? with (??{a,b,c})');
+ }
+
+ {
+ # this code won't actually fail, but it used to fail valgrind,
+ # so its here just to make sure valgrind doesn't fail again
+ # While examining the ops of the secret anon sub wrapped around
+ # the qr//, the pad of the sub was in scope, so cSVOPo_sv
+ # got the const from the wrong pad. By having lots of $s's
+ # (aka gvsv(*s), this forces the targs of the consts which have
+ # been moved to the pad, to have high indices.
+
+ sub {
+ local our $s = "abc";
+ my $qr = qr/^(?{1})$s$s$s$s$s$s$s$s$s$s$s$s$s$s$s$s$s$s$s$s$s$s$s/;
+ }->();
+ pass("cSVOPo_sv");
+ }
+
+ # [perl #115004]
+ # code blocks in qr objects that are interpolated in arrays need
+ # handling the same as if they were interpolated from scalar vars
+ # (before this code would need 'use re "eval"')
+
+ {
+ use Tie::Array;
+
+ use vars '@global';
+ local @global;
+ my @array;
+ my @refs = (0, \@array, 2);
+ my @tied;
+ tie @tied, 'Tie::StdArray';
+ {
+ my $bb = 'B';
+ my $dd = 'D';
+ @array = ('A', qr/(??{$bb})/, 'C', qr/(??{$dd})/, 'E');
+ @tied = @array;
+ @global = @array;
+ }
+ my $bb = 'X';
+ my $dd = 'Y';
+ ok("A B C D E=" =~ /@array/, 'bare interpolated array match');
+ ok("A B C D E=" =~ qr/@array/, 'qr bare interpolated array match');
+ ok("A B C D E=" =~ /@global/, 'bare interpolated global array match');
+ ok("A B C D E=" =~ qr/@global/,
+ 'qr bare interpolated global array match');
+ ok("A B C D E=" =~ /@{$refs[1]}/, 'bare interpolated ref array match');
+ ok("A B C D E=" =~ qr/@{$refs[1]}/,
+ 'qr bare interpolated ref array match');
+ ok("A B C D E=" =~ /@tied/, 'bare interpolated tied array match');
+ ok("A B C D E=" =~ qr/@tied/, 'qr bare interpolated tied array match');
+ ok("aA B C D E=" =~ /^a at array=$/, 'interpolated array match');
+ ok("aA B C D E=" =~ qr/^a at array=$/, 'qr interpolated array match');
+ ok("aA B C D E=" =~ /^a at global=$/, 'interpolated global array match');
+ ok("aA B C D E=" =~ qr/^a at global=$/,
+ 'qr interpolated global array match');
+ ok("aA B C D E=" =~ /^a@{$refs[1]}=$/, 'interpolated ref array match');
+ ok("aA B C D E=" =~ qr/^a@{$refs[1]}=$/,
+ 'qr interpolated ref array match');
+ ok("aA B C D E=" =~ /^a at tied=$/, 'interpolated tied array match');
+ ok("aA B C D E=" =~ qr/^a at tied=$/, 'qr interpolated tied array match');
+
+ {
+ local $" = '-';
+ ok("aA-B-C-D-E=" =~ /^a@{array}=$/,
+ 'interpolated array match with local sep');
+ ok("aA-B-C-D-E=" =~ qr/^a@{array}=$/,
+ 'qr interpolated array match with local sep');
+ ok("aA-B-C-D-E=" =~ /^a@{global}=$/,
+ 'interpolated global array match with local sep');
+ ok("aA-B-C-D-E=" =~ qr/^a@{global}=$/,
+ 'qr interpolated global array match with local sep');
+ ok("aA-B-C-D-E=" =~ /^a@{tied}=$/,
+ 'interpolated tied array match with local sep');
+ ok("aA-B-C-D-E=" =~ qr/^a@{tied}=$/,
+ 'qr interpolated tied array match with local sep');
+ }
+
+ # but don't handle the array ourselves in the presence of \Q etc
+
+ @array = ('A', '(?{})');
+ @global = @array;
+ @tied = @array;
+ ok("aA (?{})=" =~ /^a\Q@{array}\E=$/,
+ 'interpolated array match with \Q');
+ ok("aA (?{})=" =~ qr/^a\Q@{array}\E=$/,
+ 'qr interpolated array match with \Q');
+ ok("aA (?{})=" =~ /^a\Q@{global}\E=$/,
+ 'interpolated global array match with \Q');
+ ok("aA (?{})=" =~ qr/^a\Q@{global}\E=$/,
+ 'qr interpolated global array match with \Q');
+ ok("aA (?{})=" =~ /^a\Q@{$refs[1]}\E=$/,
+ 'interpolated ref array match with \Q');
+ ok("aA (?{})=" =~ qr/^a\Q@{$refs[1]}\E=$/,
+ 'qr interpolated ref array match with \Q');
+ ok("aA (?{})=" =~ /^a\Q@{tied}\E=$/,
+ 'interpolated tied array match with \Q');
+ ok("aA (?{})=" =~ qr/^a\Q@{tied}\E=$/,
+ 'qr interpolated tied array match with \Q');
+
+ # and check it works with an empty array
+
+ @array = ();
+ @global = ();
+ @tied = ();
+ ok("a=" =~ /^a at array=$/, 'empty array match');
+ ok("a=" =~ qr/^a at array=$/, 'qr empty array match');
+ ok("a=" =~ /^a at global=$/, 'empty global array match');
+ ok("a=" =~ qr/^a at global=$/, 'qr empty global array match');
+ ok("a=" =~ /^a at tied=$/, 'empty tied array match');
+ ok("a=" =~ qr/^a at tied=$/, 'qr empty tied array match');
+ ok("a=" =~ /^a\Q@{array}\E=$/, 'empty array match with \Q');
+ ok("a=" =~ /^a\Q@{array}\E=$/, 'empty array match with \Q');
+ ok("a=" =~ qr/^a\Q@{global}\E=$/,
+ 'qr empty global array match with \Q');
+ ok("a=" =~ /^a\Q@{tied}\E=$/, 'empty tied array match with \Q');
+ ok("a=" =~ qr/^a\Q@{tied}\E=$/, 'qr empty tied array match with \Q');
+
+ # NB: these below are empty patterns, so they happen to use the
+ # successful match from the line above
+
+ ok("a=" =~ /@array/, 'empty array pattern');
+ ok("a=" =~ qr/@array/, 'qr empty array pattern');
+ ok("a=" =~ /@global/, 'empty global array pattern');
+ ok("a=" =~ qr/@global/, 'qr empty global array pattern');
+ ok("a=" =~ /@tied/, 'empty tied pattern');
+ ok("a=" =~ qr/@tied/, 'qr empty tied pattern');
+ ok("a=" =~ /\Q at array\E/, 'empty array pattern with \Q');
+ ok("a=" =~ qr/\Q at array\E/, 'qr empty array pattern with \Q');
+ ok("a=" =~ /\Q at global\E/, 'empty global array pattern with \Q');
+ ok("a=" =~ qr/\Q at global\E/, 'qr empty global array pattern with \Q');
+ ok("a=" =~ /\Q at tied\E/, 'empty tied pattern with \Q');
+ ok("a=" =~ qr/\Q at tied\E/, 'qr empty tied pattern with \Q');
+ ok("a=" =~ //, 'completely empty pattern');
+ ok("a=" =~ qr//, 'qr completely empty pattern');
+ }
+
+
} # End of sub run_tests
1;
Property changes on: trunk/contrib/perl/t/re/pat_re_eval.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/re/pat_re_eval_thr.t
===================================================================
--- trunk/contrib/perl/t/re/pat_re_eval_thr.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/pat_re_eval_thr.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/re/pat_re_eval_thr.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/re/pat_rt_report.t
===================================================================
--- trunk/contrib/perl/t/re/pat_rt_report.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/pat_rt_report.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -22,7 +22,7 @@
}
-plan tests => 2521; # Update this when adding/deleting tests.
+plan tests => 2532; # Update this when adding/deleting tests.
run_tests() unless caller;
@@ -384,14 +384,7 @@
is("@_", "a|b|c", $message);
}
- {
- # XXX DAPM 13-Apr-06. Recursive split is still broken. It's only luck it
- # hasn't been crashing. Disable this test until it is fixed properly.
- # XXX also check what it returns rather than just doing ok(1,...)
- # split /(?{ split "" })/, "abc";
- local $::TODO = "Recursive split is still broken";
- ok 0, 'cache_re & "(?{": it dumps core in 5.6.1 & 5.8.0';
- }
+ is(join('-', split /(?{ split "" })/, "abc"), 'a-b-c', 'nested split');
{
$_ = "code: 'x' { '...' }\n"; study;
@@ -534,7 +527,8 @@
}
{
- local $::TODO = "See changes 26925-26928, which reverted change 26410";
+ # [perl #78680]
+ # See changes 26925-26928, which reverted change 26410
{
package lv;
our $var = "abc";
@@ -552,7 +546,6 @@
is($f, "ab", "pos() retained between calls");
}
else {
- local $::TODO;
ok 0, "Code failed: $@";
}
@@ -569,7 +562,6 @@
is($g, "ab", "pos() retained between calls");
}
else {
- local $::TODO;
ok 0, "Code failed: $@";
}
}
@@ -923,6 +915,7 @@
{
my $message = '$REGMARK in replacement; Bug 49190';
our $REGMARK;
+ no warnings 'experimental::lexical_topic';
my $_ = "A";
ok(s/(*:B)A/$REGMARK/, $message);
is($_, "B", $message);
@@ -929,6 +922,10 @@
$_ = "CCCCBAA";
ok(s/(*:X)A+|(*:Y)B+|(*:Z)C+/$REGMARK/g, $message);
is($_, "ZYX", $message);
+ # Use a longer name to force reallocation of $REGMARK.
+ $_ = "CCCCBAA";
+ ok(s/(*:X)A+|(*:YYYYYYYYYYYYYYYY)B+|(*:Z)C+/$REGMARK/g, $message);
+ is($_, "ZYYYYYYYYYYYYYYYYX", $message);
}
{
@@ -1136,6 +1133,46 @@
EOP
}
+ {
+ # pattern must be compiled late or we can break the test file
+ my $message = '[perl #115050] repeated nothings in a trie can cause panic';
+ my $pattern;
+ $pattern = '[xyz]|||';
+ ok("blah blah" =~ /$pattern/, $message);
+ ok("blah blah" =~ /(?:$pattern)h/, $message);
+ $pattern = '|||[xyz]';
+ ok("blah blah" =~ /$pattern/, $message);
+ ok("blah blah" =~ /(?:$pattern)h/, $message);
+ }
+
+ {
+ # [perl #4289] First mention $& after a match
+ local $::TODO = "these tests fail without Copy-on-Write enabled";
+ fresh_perl_is(
+ '$_ = "abc"; /b/g; $_ = "hello"; print eval q|$&|, "\n"',
+ "b\n", {}, '$& first mentioned after match');
+ fresh_perl_is(
+ '$_ = "abc"; /b/g; $_ = "hello"; print eval q|$`|, "\n"',
+ "a\n", {}, '$` first mentioned after match');
+ fresh_perl_is(
+ '$_ = "abc"; /b/g; $_ = "hello"; print eval q|$\'|,"\n"',
+ "c\n", {}, '$\' first mentioned after match');
+ }
+
+ {
+ # [perl #118175] threaded perl-5.18.0 fails pat_rt_report_thr.t
+ # this tests some related failures
+ #
+ # The tests in the block *only* fail when run on 32-bit systems
+ # with a malloc that allocates above the 2GB line. On the system
+ # in the report above that only happened in a thread.
+ my $s = "\x{1ff}" . "f" x 32;
+ ok($s =~ /\x{1ff}[[:alpha:]]+/gca, "POSIXA pointer wrap");
+
+ # this one segfaulted under the conditions above
+ # of course, CANY is evil, maybe it should crash
+ ok($s =~ /.\C+/, "CANY pointer wrap");
+ }
} # End of sub run_tests
1;
Property changes on: trunk/contrib/perl/t/re/pat_rt_report.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/re/pat_rt_report_thr.t
===================================================================
--- trunk/contrib/perl/t/re/pat_rt_report_thr.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/pat_rt_report_thr.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/re/pat_rt_report_thr.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/re/pat_special_cc.t
===================================================================
--- trunk/contrib/perl/t/re/pat_special_cc.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/pat_special_cc.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/re/pat_special_cc.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/re/pat_special_cc_thr.t
===================================================================
--- trunk/contrib/perl/t/re/pat_special_cc_thr.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/pat_special_cc_thr.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/re/pat_special_cc_thr.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/re/pat_thr.t
===================================================================
--- trunk/contrib/perl/t/re/pat_thr.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/pat_thr.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/re/pat_thr.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/re/pos.t (from rev 6437, vendor/perl/5.18.1/t/re/pos.t)
===================================================================
--- trunk/contrib/perl/t/re/pos.t (rev 0)
+++ trunk/contrib/perl/t/re/pos.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,68 @@
+#!./perl
+
+# Make sure pos / resetting pos on failed match works
+
+use strict;
+use warnings;
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require './test.pl';
+}
+
+plan tests => 8;
+
+## Early bailout of pp_match because matchlen > stringlen
+
+# With a var
+{
+ my $str = "bird";
+
+ $str =~ /i/g;
+
+ is(pos($str), 2, 'pos correct');
+
+ $str =~ /toolongtomatch/g;
+
+ is(pos($str), undef, 'pos undef after failed match');
+}
+
+# With $_
+{
+ $_ = "bird";
+
+ m/i/g;
+
+ is(pos, 2, 'pos correct');
+
+ m/toolongtomatch/g;
+
+ is(pos, undef, 'pos undef after failed match');
+}
+
+## Early bail out of pp_match because ?? already matched
+
+# With a var
+{
+ my $str = "bird";
+
+ for (1..2) {
+ if ($str =~ m?bird?g) {
+ is(pos($str), 4, 'pos correct');
+ } else {
+ is(pos($str), undef, 'pos undef after failed match');
+ }
+ }
+}
+
+# With $_
+{
+ for (1..2) {
+ if (m?\d?g) {
+ is(pos, 1, 'pos correct');
+ } else {
+ is(pos, undef, 'pos undef after failed match');
+ }
+ }
+}
Index: trunk/contrib/perl/t/re/qr-72922.t
===================================================================
--- trunk/contrib/perl/t/re/qr-72922.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/qr-72922.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/re/qr-72922.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/re/qr.t
===================================================================
--- trunk/contrib/perl/t/re/qr.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/qr.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -10,7 +10,7 @@
my $rx = qr//;
-is(ref $rx, "Regexp", "qr// blessed into `Regexp' by default");
+is(ref $rx, "Regexp", "qr// blessed into 'Regexp' by default");
# Make sure /$qr/ doesn’t clobber match vars before the match (bug 70764).
@@ -33,6 +33,7 @@
is $output, "5\n1: 5\n2: 5\n", '$a_match_var =~ /$qr/';
}
+no warnings 'experimental::lexical_topic';
for my $_($'){
my $output = '';
my $rx = qr/o/;
Property changes on: trunk/contrib/perl/t/re/qr.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/re/qr_gc.t
===================================================================
--- trunk/contrib/perl/t/re/qr_gc.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/qr_gc.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/re/qr_gc.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/re/qrstack.t
===================================================================
--- trunk/contrib/perl/t/re/qrstack.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/qrstack.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/re/qrstack.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/re/re_tests
===================================================================
--- trunk/contrib/perl/t/re/re_tests 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/re_tests 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,7 +1,11 @@
# This stops me getting screenfulls of syntax errors every time I accidentally
-# run this file via a shell glob. Format of this file is given in regexp.t
-# Can't use \N{VALID NAME TEST} here because need 'use charnames'; but can use
-# \N{U+valid} here.
+# run this file via a shell glob. The full format of this file is given
+# in regexp.t
+# Prior to the implementation of autoloading of \N{}, tests that used \N{name}
+# could not go in this file, and were farmed out to other .t's, where they
+# remain
+#
+# pat string y/n/etc expr expected-expr skip-reason
__END__
abc abc y $& abc
abc abc y $-[0] 0
@@ -104,7 +108,7 @@
a[b-d] aac y $& ac
a[-b] a- y $& a-
a[b-] a- y $& a-
-a[b-a] - c - Invalid [] range \"b-a\"
+a[b-a] - c - Invalid [] range
a[]b - c - Unmatched [
a[ - c - Unmatched [
a] a] y $& a]
@@ -159,6 +163,7 @@
()ef def y $&-$1 ef-
()ef def y $-[0] 1
()ef def y $+[0] 3
+()\x{100}\x{1000} d\x{100}\x{1000} y $+[0] 3
()ef def y $-[1] 1
()ef def y $+[1] 1
*a - c - Quantifier follows nothing
@@ -347,7 +352,7 @@
'a[b-d]'i AAC y $& AC
'a[-b]'i A- y $& A-
'a[b-]'i A- y $& A-
-'a[b-a]'i - c - Invalid [] range \"b-a\"
+'a[b-a]'i - c - Invalid [] range
'a[]b'i - c - Unmatched [
'a['i - c - Unmatched [
'a]'i A] y $& A]
@@ -477,7 +482,7 @@
(?<!c)b cb n - -
(?<!c)b b y - -
(?<!c)b b y $& b
-(?<%)b - c - Sequence (?<%...) not recognized
+(?<%)b - c - Group name must start with a non-digit word character
(?:..)*a aba y $& aba
(?:..)*?a aba y $& a
^(?:b|a(?=(.)))*\1 abc y $& ab
@@ -531,12 +536,12 @@
'(ab)\d\1'i ab4Ab y $1 ab
foo\w*\d{4}baz foobar1234baz y $& foobar1234baz
a(?{})b cabd y $& ab
-a(?{)b - c - Sequence (?{...}) not terminated or not {}-balanced
-a(?{{})b - c - Sequence (?{...}) not terminated or not {}-balanced
+a(?{f()+ - c - Missing right curly or square bracket
+a(?{{1}+ - c - Missing right curly or square bracket
a(?{}})b - c -
-a(?{"{"})b - c - Sequence (?{...}) not terminated or not {}-balanced
+a(?{"{"})b ab y - -
a(?{"\{"})b cabd y $& ab
-a(?{"{"}})b - c - Unmatched right curly bracket
+a(?{"{"}})b - c - Sequence (?{...}) not terminated with ')'
a(?{$::bl="\{"}).b caxbd y $::bl {
x(~~)*(?:(?:F)?)? x~~ y - -
^a(?#xxx){3}c aaac y $& aaac
@@ -577,8 +582,8 @@
^(\(+)?blah(?(1)(\)))$ blah y ($2) ()
^(\(+)?blah(?(1)(\)))$ blah) n - -
^(\(+)?blah(?(1)(\)))$ (blah n - -
-(?(1?)a|b) a c - Switch condition not recognized
-(?(1)a|b|c) a c - Switch (?(condition)... contains too many branches
+(?(1?)a|b) - c - Switch condition not recognized
+(?(1)a|b|c) - c - Switch (?(condition)... contains too many branches
(?(?{0})a|b) a n - -
(?(?{0})b|a) a y $& a
(?(?{1})b|a) a n - -
@@ -587,6 +592,10 @@
(?(?!a)b|a) a y $& a
(?(?=a)b|a) a n - -
(?(?=a)a|b) a y $& a
+(?(?!\x{100})\x{100}|b) \x{100} n - -
+(?(?!\x{100})b|\x{100}) \x{100} y $& \x{100}
+(?(?=\x{100})b|\x{100}) \x{100} n - -
+(?(?=\x{100})\x{100}|b) \x{100} y $& \x{100}
(?=(a+?))(\1ab) aaab y $2 aab
^(?=(a+?))\1ab aaab n - -
(\w+:)+ one: y $1 one:
@@ -612,8 +621,7 @@
[a[:xyz: - c - Unmatched [
[a[:xyz:] - c - POSIX class [:xyz:] unknown
[a[:]b[:c] abc y $& abc
-([a[:xyz:]b]+) pbaq c - POSIX class [:xyz:] unknown
-[a[:]b[:c] abc y $& abc
+([a[:xyz:]b]+) - c - POSIX class [:xyz:] unknown
([[:alpha:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd
([[:alnum:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy
([[:ascii:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy__-- ${nulnul}
@@ -645,8 +653,7 @@
(?>(a+))b aaab y $1 aaa
((?>[^()]+)|\([^()]*\))+ ((abc(ade)ufh()()x y $& abc(ade)ufh()()x
(?<=x+)y - c - Variable length lookbehind not implemented
-a{37,17} - c - Can't do {n,m} with n > m
-a{37,0} - c - Can't do {n,m} with n > m
+((def){37,17})?ABC ABC y $& ABC
\Z a\nb\n y $-[0] 3
\z a\nb\n y $-[0] 4
$ a\nb\n y $-[0] 3
@@ -845,6 +852,7 @@
'abb\Z'm b\nca n - -
'abb\z'm b\nca n - -
'abb$'m b\nca n - -
+'\Aa$'m a\n\n y $& a
(^|x)(c) ca y $2 c
a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz x n - -
a(?{$a=2;$b=3;($b)=$a})b yabz y $b 2
@@ -872,12 +880,18 @@
.[X](.+)+[X][X] bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - -
.[X][X](.+)+[X] bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - -
tt+$ xxxtt y - -
-([a-\d]+) za-9z y $1 a-9
-([\d-z]+) a0-za y $1 0-z
-([\d-\s]+) a0- z y $1 0-
-([a-[:digit:]]+) za-9z y $1 a-9
-([[:digit:]-z]+) =0-z= y $1 0-z
-([[:digit:]-[:alpha:]]+) =0-z= y $1 0-z
+([a-\d]+) za-9z Sy $1 a-9
+([a-\d]+) - sc - False [] range
+([\d-z]+) a0-za Sy $1 0-z
+([\d-z]+) - sc $1 False [] range
+([\d-\s]+) a0- z Sy $1 0-
+([\d-\s]+) - sc $1 False [] range
+([a-[:digit:]]+) za-9z Sy $1 a-9
+([a-[:digit:]]+) - sc - False [] range
+([[:digit:]-z]+) =0-z= Sy $1 0-z
+([[:digit:]-z]+) - sc c False [] range
+([[:digit:]-[:alpha:]]+) =0-z= Sy $1 0-z
+([[:digit:]-[:alpha:]]+) - sc - False [] range
\GX.*X aaaXbX n - -
(\d+\.\d+) 3.1415926 y $1 3.1415926
(\ba.{0,10}br) have a web browser y $1 a web br
@@ -992,8 +1006,8 @@
^.{2,3}?((?:b|a|r)+?)\1\z foobarbar y $1 bar
^(?:f|o|b){2,3}?((?:b|a|r)+?)\1\z foobarbar y $1 bar
.*a(?!(b|cd)*e).*f ......abef n - - # [perl #23030]
-x(?# x c - Sequence (?#... not terminated
-:x(?#: x c - Sequence (?#... not terminated
+x(?# - c - Sequence (?#... not terminated
+:x(?#: - c - Sequence (?#... not terminated
(WORDS|WORD)S WORDS y $1 WORD
(X.|WORDS|X.|WORD)S WORDS y $1 WORD
(WORDS|WORLD|WORD)S WORDS y $1 WORD
@@ -1078,9 +1092,9 @@
(?P<n>foo|bar|baz)(?P<m>[ew]+) snofooewa yM $+{m} ew miniperl cannot load Tie::Hash::NamedCapture
(?P<n>foo)|(?P<n>bar)|(?P<n>baz) snofooewa yM $+{n} foo miniperl cannot load Tie::Hash::NamedCapture
(?P<n>foo)(??{ $+{n} }) snofooefoofoowaa yM $+{n} foo miniperl cannot load Tie::Hash::NamedCapture
-(?P<=n>foo|bar|baz) snofooewa c - Sequence (?P<=...) not recognized
-(?P<!n>foo|bar|baz) snofooewa c - Sequence (?P<!...) not recognized
-(?PX<n>foo|bar|baz) snofooewa c - Sequence (?PX<...) not recognized
+(?P<=n>foo|bar|baz) - c - Group name must start with a non-digit word character
+(?P<!n>foo|bar|baz) - c - Group name must start with a non-digit word character
+(?PX<n>foo|bar|baz) - c - Sequence (?PX<...) not recognized
/(?'n'foo|bar|baz)/ snofooewa y $1 foo
/(?'n'foo|bar|baz)/ snofooewa yM $+{n} foo miniperl cannot load Tie::Hash::NamedCapture
/(?'n'foo|bar|baz)(?'m'[ew]+)/ snofooewa yM $+{n} foo miniperl cannot load Tie::Hash::NamedCapture
@@ -1258,30 +1272,30 @@
/(?<_>foo) \k<_>/ ..foo foo.. yM $+{_} foo miniperl cannot load Tie::Hash::NamedCapture
/(?'_0_'foo) \k'_0_'/ ..foo foo.. yM $+{_0_} foo miniperl cannot load Tie::Hash::NamedCapture
/(?<_0_>foo) \k<_0_>/ ..foo foo.. yM $+{_0_} foo miniperl cannot load Tie::Hash::NamedCapture
-/(?'0'foo) bar/ ..foo bar.. c - Sequence (?'
-/(?<0>foo) bar/ ..foo bar.. c - Sequence (?<
-/(?'12'foo) bar/ ..foo bar.. c - Sequence (?'
-/(?<12>foo) bar/ ..foo bar.. c - Sequence (?<
-/(?'1a'foo) bar/ ..foo bar.. c - Sequence (?'
-/(?<1a>foo) bar/ ..foo bar.. c - Sequence (?<
-/(?''foo) bar/ ..foo bar.. c - Sequence (?''
-/(?<>foo) bar/ ..foo bar.. c - Sequence (?<>
-/foo \k'n'/ foo foo c - Reference to nonexistent named group
-/foo \k<n>/ foo foo c - Reference to nonexistent named group
-/foo \k'a1'/ foo foo c - Reference to nonexistent named group
-/foo \k<a1>/ foo foo c - Reference to nonexistent named group
-/foo \k'_'/ foo foo c - Reference to nonexistent named group
-/foo \k<_>/ foo foo c - Reference to nonexistent named group
-/foo \k'_0_'/ foo foo c - Reference to nonexistent named group
-/foo \k<_0_>/ foo foo c - Reference to nonexistent named group
-/foo \k'0'/ foo foo c - Sequence \\k'
-/foo \k<0>/ foo foo c - Sequence \\k<
-/foo \k'12'/ foo foo c - Sequence \\k'
-/foo \k<12>/ foo foo c - Sequence \\k<
-/foo \k'1a'/ foo foo c - Sequence \\k'
-/foo \k<1a>/ foo foo c - Sequence \\k<
-/foo \k''/ foo foo c - Sequence \\k'
-/foo \k<>/ foo foo c - Sequence \\k<
+/(?'0'foo) bar/ - c - Group name must start with a non-digit word character
+/(?<0>foo) bar/ - c - Group name must start with a non-digit word character
+/(?'12'foo) bar/ - c - Group name must start with a non-digit word character
+/(?<12>foo) bar/ - c - Group name must start with a non-digit word character
+/(?'1a'foo) bar/ - c - Group name must start with a non-digit word character
+/(?<1a>foo) bar/ - c - Group name must start with a non-digit word character
+/(?''foo) bar/ - c - Group name must start with a non-digit word character
+/(?<>foo) bar/ - c - Group name must start with a non-digit word character
+/foo \k'n'/ - c - Reference to nonexistent named group
+/foo \k<n>/ - c - Reference to nonexistent named group
+/foo \k'a1'/ - c - Reference to nonexistent named group
+/foo \k<a1>/ - c - Reference to nonexistent named group
+/foo \k'_'/ - c - Reference to nonexistent named group
+/foo \k<_>/ - c - Reference to nonexistent named group
+/foo \k'_0_'/ - c - Reference to nonexistent named group
+/foo \k<_0_>/ - c - Reference to nonexistent named group
+/foo \k'0'/ - c - Group name must start with a non-digit word character
+/foo \k<0>/ - c - Group name must start with a non-digit word character
+/foo \k'12'/ - c - Group name must start with a non-digit word character
+/foo \k<12>/ - c - Group name must start with a non-digit word character
+/foo \k'1a'/ - c - Group name must start with a non-digit word character
+/foo \k<1a>/ - c - Group name must start with a non-digit word character
+/foo \k''/ - c - Group name must start with a non-digit word character
+/foo \k<>/ - c - Group name must start with a non-digit word character
/(?<as>as) (\w+) \k<as> (\w+)/ as easy as pie y $1-$2-$3 as-easy-pie
# \g{...} with a name as the argument
@@ -1430,7 +1444,8 @@
# and bypasses the lexer.
/\N{U+}/ - c - Invalid hexadecimal number
# Below currently gives a misleading message
-/[\N{U+}]/ - c - Unmatched
+/[\N{U+}]/ - Sc - Unmatched
+/[\N{U+}]/ - sc - Syntax error in (?[...])
/abc\N{def/ - c - Missing right brace
/\N{U+4AG3}/ - c - Illegal hexadecimal digit
/[\N{U+4AG3}]/ - c - Illegal hexadecimal digit
@@ -1439,7 +1454,7 @@
# figures it out.
\N{U+} - c - Invalid hexadecimal number
[\N{U+}] - c - Invalid hexadecimal number
-\N{U+4AG3} - c - Illegal hexadecimal digit
+\N{U+4AG3} - c - Invalid hexadecimal number
[\N{U+4AG3}] - c - Invalid hexadecimal number
abc\N{def - c - \\N{NAME} must be resolved by the lexer
@@ -1453,7 +1468,7 @@
# Verify works in single quotish context; regex compiler delivers slightly different msg
# \N{U+BEEF.BEAD} succeeds here, because can't completely hide it from the outside.
-\N{U+0xBEEF} - c - Illegal hexadecimal digit
+\N{U+0xBEEF} - c - Invalid hexadecimal number
\c` - c - \"\\c`\" is more clearly written simply as \"\\ \"
\c1 - c - \"\\c1\" is more clearly written simply as \"q\"
\cA \001 y $& \1
@@ -1471,15 +1486,25 @@
[a\o{400}] \x{100} y $& \x{100}
[a\o{1000}] \x{200} y $& \x{200}
+# The below were inserting a NULL
+\87 87 y $& 87
+a\87 a87 y $& a87
+a\97 a97 y $& a97
+
+
# The below was inserting a NULL into the character class.
-[\8\9] \000 n - -
-[\8\9] 8 y $& 8
-[\8\9] 9 y $& 9
+[\8\9] \000 Sn - -
+[\8\9] - sc $& Unrecognized escape \\8 in character class
+[\8\9] 8 Sy $& 8
+[\8\9] 9 Sy $& 9
# Verify that reads 1-3 octal digits, and that \_ works in char class
-[\0] \000 y $& \000
-[\07] \007 y $& \007
-[\07] 7\000 n - -
+[\0] \000 Sy $& \000
+[\0] - sc - Need exactly 3 octal digits
+[\07] \007 Sy $& \007
+[\07] - sc - Need exactly 3 octal digits
+[\07] 7\000 Sn - -
+[\07] - sc - Need exactly 3 octal digits
[\006] \006 y $& \006
[\006] 6\000 n - -
[\0005] \0005 y $& \000
@@ -1521,5 +1546,206 @@
# Normally 1E9E generates a multi-char fold, but not in inverted class;
# See [perl #89750]. This makes sure that the simple fold gets generated
# in that case, to DF.
-/[^\x{1E9E}]/i \x{DF} n - -
+/[^\x{1E9E}]/i \x{DF} Sn - -
+
+# RT #96354
+/^.*\d\H/ X1 n - -
+/^.*\d\V/ X1 n - -
+
+# \p{L_} was being misinterpreted as \p{L}. L_ matches cased letters, which
+# the ideograph below isn't, whereas it does match L
+/^\p{L_}/ \x{3400} n - -
+/^\p{L}/ \x{3400} y $& \x{3400}
+
+# RT #89774
+/[s\xDF]a/ui ssa Sy $& ssa
+/[s\xDF]a/ui sa y $& sa
+
+# RT #99928
+/^\R\x0A$/ \x0D\x0A n - -
+
+/ff/i \x{FB00}\x{FB01} y $& \x{FB00}
+/ff/i \x{FB01}\x{FB00} y $& \x{FB00}
+/fi/i \x{FB01}\x{FB00} y $& \x{FB01}
+/fi/i \x{FB00}\x{FB01} y $& \x{FB01}
+#
+# Make sure we don't see code blocks where there aren't, and vice-versa
+(?#( (?{1+)a a y - -
+'a# (?{1+'x a y - -
+ab[(?{1] ab1 y - -
+ab[(?{1\](?{2] ab2 y - -
+ab(?{"["})cd abcd y - -
+ab(??{"[x]"})cd abxcd y - -
+ab\[(??{1})c ab[1c y - -
+ab\\[(??{1;})]c ab\\;c y - -
+ab\\\[(??{1})c ab\\[1c y - -
+ab[c\](??{"]d abcd y - -
+ab[c\\](??{"[x]"})d ab\\xd y - -
+ab[c\\\](??{"x"})]{3}d ab\\](d y - -
+
+# These test that doesn't cut-off matching too soon in the string for
+# multi-char folds
+/ffiffl/i abcdef\x{FB03}\x{FB04} y $& \x{FB03}\x{FB04}
+/\xdf\xdf/ui abcdefssss y $& ssss
+
+/st/i \x{DF}\x{FB05} y $& \x{FB05}
+/ssst/i \x{DF}\x{FB05} y $& \x{DF}\x{FB05}
+
+# [perl #101970]
+/[[:lower:]]/i \x{100} y $& \x{100}
+/[[:upper:]]/i \x{101} y $& \x{101}
+
+# Was matching 'ss' only and failing the entire match, not seeing the
+# alternative that would succeed
+/s\xDF/ui \xDFs y $& \xDFs
+/sst/ui s\N{LATIN SMALL LIGATURE ST} y $& s\N{LATIN SMALL LIGATURE ST}
+/sst/ui s\N{LATIN SMALL LIGATURE LONG S T} y $& s\N{LATIN SMALL LIGATURE LONG S T}
+
+# /i properties shouldn't match more than the property itself
+/[[:ascii:]]/i \N{KELVIN SIGN} n - -
+
+# [[:lower:]]/i and [[:upper:]]/i should match what \p{Lower} and \p{Upper} do.
+# which is \p{Cased}, not \p{Alpha},
+/[[:lower:]]/i \N{U+3400} n - -
+/[[:upper:]]/i \N{U+01BB} n - -
+
+# [perl #110648]
+[^\p{Alphabetic}] \x{100} n - -
+
+# [perl #111400]. Tests the first Y/N boundary above 255 for each of these.
+/[[:alnum:]]/ \x{2c1} y - -
+/[[:alnum:]]/ \x{2c2} n - -
+/[[:alpha:]]/ \x{2c1} y - -
+/[[:alpha:]]/ \x{2c2} n - -
+/[[:graph:]]/ \x{377} y - -
+/[[:graph:]]/ \x{378} n - -
+/[[:lower:]]/ \x{100} n - -
+/[[:lower:]]/ \x{101} y - -
+/[[:lower:]]/ \x{102} n - -
+/[[:print:]]/ \x{377} y - -
+/[[:print:]]/ \x{378} n - -
+/[[:punct:]]/ \x{37D} n - -
+/[[:punct:]]/ \x{37E} y - -
+/[[:punct:]]/ \x{388} n - -
+/[[:upper:]]/ \x{100} y - -
+/[[:upper:]]/ \x{101} n - -
+/[[:word:]]/ \x{2c1} y - -
+/[[:word:]]/ \x{2c2} n - -
+
+# [perl #113400]
+/syntax OK\s+\z/si t/bin/good.pl syntax OK\n y - -
+
+/^(.*?)\s*\|\s*(?:\/\s*|)'(.+)'$/ text|'sec' y <$1><$2> <text><sec>
+/^(foo|)bar$/ bar y <$&> <bar>
+/^(foo||baz)bar$/ bar y <$&> <bar>
+/^(foo||baz)bar$/ bazbar y <$1> <baz>
+/^(foo||baz)bar$/ foobar y <$1> <foo>
+
+/^(?:foo|)bar$/ bar y <$&> <bar>
+/^(?:foo||baz)bar$/ bar y <$&> <bar>
+/^(?:foo||baz)bar$/ bazbar y <$&> <bazbar>
+/^(?:foo||baz)bar$/ foobar y <$&> <foobar>
+
+/^(?i:foo|)bar$/ bar y <$&> <bar>
+/^(?i:foo||baz)bar$/ bar y <$&> <bar>
+/^(?i:foo||baz)bar$/ bazbar y <$&> <bazbar>
+/^(?i:foo||baz)bar$/ foobar y <$&> <foobar>
+
+# $^N, $+ on backtrackracking
+# BRANCH
+^(.)(?:(..)|B)[CX] ABCDE y $^N-$+ A-A -
+# TRIE
+^(.)(?:BC(.)|B)[CX] ABCDE y $^N-$+ A-A -
+# CURLYX
+^(.)(?:(.)+)*[BX] ABCDE y $^N-$+ A-A -
+# CURLYM
+^(.)(BC)* ABCDE y $^N-$+ BC-BC -
+^(.)(BC)*[BX] ABCDE y $^N-$+ A-A -
+# CURLYN
+^(.)(B)*.[DX] ABCDE y $^N-$+ B-B -
+^(.)(B)*.[CX] ABCDE y $^N-$+ A-A -
+
+# using 'return' in code blocks
+^(A)(?{"xyz"})B$ AB y $1-$^R A-xyz -
+^(A)(?{return "xyz"})B$ AB y $1-$^R A-xyz -
+^(A)((??{"xyz"}))$ Axyz y $1-$2 A-xyz -
+^(A)((??{return "xyz"}))$ Axyz y $1-$2 A-xyz -
+^(A)((?(?{1})abc|xyz))$ Aabc y $1-$2 A-abc -
+^(A)((?(?{0})abc|xyz))$ Axyz y $1-$2 A-xyz -
+^(A)((?(?{return 1})abc|xyz))$ Aabc y $1-$2 A-abc -
+^(A)((?(?{return 0})abc|xyz))$ Axyz y $1-$2 A-xyz -
+
+# pattern modifier flags should propagate into returned (??{}) pattern
+# p,d,l not tested
+
+/^(a)((??{"b"}))$/i AB y $1-$2 A-B -
+/^(A)((??{'B$'}))(\nC)$/m AB\nC y $1-$2-$3 A-B-\nC -
+/^(A)((??{'.'}))(B)$/s A\nB y $1-$2-$3 A-\n-B -
+/^(A) ((??{' .'}))(B)$/x A B y $1-$2-$3 A- -B -
+/^((??{'\d'}))$/a \x{660} n - -
+/^(??{"s"})$/i \x{17F} y - -
+/^(??{"s"})$/ia \x{17F} y - -
+/^(??{"s"})$/iaa \x{17F} n - -
+/^(??{'\w'})$/u \x{AA} y - -
+
+# #113670 ensure any captures to the right are invalidated when CURLY
+# and CURLYM backtrack
+
+^(?:(X)?(\d)|(X)?(\d\d))$ X12 y $1-$2-$3-$4 --X-12
+^(?:(XX)?(\d)|(XX)?(\d\d))$ XX12 y $1-$2-$3-$4 --XX-12
+
+# rt 113770
+\A(?>\[(?:(?:)(?:R){1}|T|V?|A)\])\z [A] y $& [A]
+# rt 114068
+/( [^z] $ [^z]+)/xm aa\nbb\ncc\n y $1 a\nbb\ncc\n
+
+# [perl #114220]
+/[\h]/ \x{A0} y $& \xA0
+/[\H]/ \x{BF} y $& \xBF
+/[\H]/ \x{A0} n - -
+/[\H]/ \x{A1} y $& \xA1
+
+[^\n]+ \nb y $& b
+[^\n]+ a\n y $& a
+
+# /a has no effect on properties
+(?a:\p{Any}) \x{100} y $& \x{100}
+(?aa:\p{Any}) \x{100} y $& \x{100}
+
+\w \x{200C} y $& \x{200C}
+\W \x{200C} n - -
+\w \x{200D} y $& \x{200D}
+\W \x{200D} n - -
+
+/^(?d:\xdf|_)*_/i \x{17f}\x{17f}_ y $& \x{17f}\x{17f}_
+#
+# check that @-, @+ count chars, not bytes; especially if beginning of
+# string is not copied
+
+(\x{100}) \x{2000}\x{2000}\x{2000}\x{100} y $-[0]:$-[1]:$+[0]:$+[1] 3:3:4:4
+
+^\R{2}$ \r\n\r\n y $& \r\n\r\n
+
+/^\D{11}/a \x{10FFFF}\x{10FFFF}\x{10FFFF}\x{10FFFF}\x{10FFFF}\x{10FFFF}\x{10FFFF}\x{10FFFF}\x{10FFFF}\x{10FFFF} n - -
+/^\S{11}/a \x{10FFFF}\x{10FFFF}\x{10FFFF}\x{10FFFF}\x{10FFFF}\x{10FFFF}\x{10FFFF}\x{10FFFF}\x{10FFFF}\x{10FFFF} n - -
+/^\W{11}/a \x{10FFFF}\x{10FFFF}\x{10FFFF}\x{10FFFF}\x{10FFFF}\x{10FFFF}\x{10FFFF}\x{10FFFF}\x{10FFFF}\x{10FFFF} n - -
+
+# [ perl #114272]
+\Vn \xFFn/ y $& \xFFn
+
+/(?l:a?\w)/ b y $& b
+m?^xy\?$? xy? y $& xy?
+
# vim: softtabstop=0 noexpandtab
+/[#]/ a#b y $& #
+/[#]b/ a#b y $& #b
+/[#]/x a#b y $& #
+/[#]b/x a#b y $& #b
+/[#](?{})/x a#b y $& #
+/[#](??{'b'})/x a#b y $& #b
+/(?#)(?{})b/ a#b y $& b
+/(?#)(??{'b'})/ a#b y $& b
+/[(?#](?{})b/ a#b y $& #b
+/[(?#](??{'b'})/ a#b y $& #b
+/(?#)(?{})b/x a#b y $& b
+/(?#)(??{'b'})/x a#b y $& b
Property changes on: trunk/contrib/perl/t/re/re_tests
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/re/recompile.t (from rev 6437, vendor/perl/5.18.1/t/re/recompile.t)
===================================================================
--- trunk/contrib/perl/t/re/recompile.t (rev 0)
+++ trunk/contrib/perl/t/re/recompile.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,195 @@
+#!./perl
+
+# Check that we don't recompile runtime patterns when the pattern hasn't
+# changed
+#
+# Works by checking the debugging output of 'use re debug' and, if
+# available, -Dr. We use both to check that the different code paths
+# with Perl_foo() verses the my_foo() under ext/re/ don't cause any
+# changes.
+
+use strict;
+use warnings;
+
+$| = 1;
+
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = ('../lib','.');
+ require './test.pl';
+ skip_all_if_miniperl("no dynamic loading on miniperl, no re");
+}
+
+
+plan tests => 38;
+
+my $results = runperl(
+ switches => [ '-Dr' ],
+ prog => '1',
+ stderr => 1,
+ );
+my $has_Dr = $results !~ /Recompile perl with -DDEBUGGING/;
+
+my $tmpfile = tempfile();
+
+
+# Check that a pattern triggers a regex compilation exactly N times,
+# using either -Dr or 'use re debug'
+# This is partially based on _fresh_perl() in test.pl
+
+sub _comp_n {
+ my ($use_Dr, $n, $prog, $desc) = @_;
+ open my $tf, ">$tmpfile" or die "Cannot open $tmpfile: $!";
+
+ my $switches = [];
+ if ($use_Dr) {
+ push @$switches, '-Dr';
+ }
+ else {
+ $prog = qq{use re qw(debug);\n$prog};
+ }
+
+ print $tf $prog;
+ close $tf or die "Cannot close $tmpfile: $!";
+ my $results = runperl(
+ switches => $switches,
+ progfile => $tmpfile,
+ stderr => 1,
+ );
+
+ my $status = $?;
+
+ my $count = () = $results =~ /Final program:/g;
+ if ($count == $n && !$status) {
+ pass($desc);
+ }
+ else {
+ fail($desc);
+ _diag "# COUNT: $count EXPECTED $n\n";
+ _diag "# STATUS: $status\n";
+ _diag "# SWITCHES: @$switches\n";
+ _diag "# PROG: \n$prog\n";
+ # this is verbose; uncomment for debugging
+ #_diag "# OUTPUT:\n------------------\n $results-------------------\n";
+ }
+}
+
+# Check that a pattern triggers a regex compilation exactly N times,
+
+sub comp_n {
+ my ($n, $prog, $desc) = @_;
+ if ($has_Dr) {
+ _comp_n(1, $n, $prog, "$desc -Dr");
+ }
+ else {
+ SKIP: {
+ skip("-Dr not compiled in");
+ }
+ }
+ _comp_n(0, @_);
+}
+
+# Check that a pattern triggers a regex compilation exactly once.
+
+sub comp_1 {
+ comp_n(1, @_);
+}
+
+
+comp_1(<<'CODE', 'simple');
+"a" =~ /$_/ for qw(a a a);
+CODE
+
+comp_1(<<'CODE', 'simple qr');
+"a" =~ qr/$_/ for qw(a a a);
+CODE
+
+comp_1(<<'CODE', 'literal utf8');
+"a" =~ /$_/ for "\x{100}", "\x{100}", "\x{100}";
+CODE
+
+comp_1(<<'CODE', 'literal utf8 qr');
+"a" =~ qr/$_/ for "\x{100}", "\x{100}", "\x{100}";
+CODE
+
+comp_1(<<'CODE', 'longjmp literal utf8');
+my $x = chr(0x80);
+"a" =~ /$x$_/ for "\x{100}", "\x{100}", "\x{100}";
+CODE
+
+comp_1(<<'CODE', 'longjmp literal utf8 qr');
+my $x = chr(0x80);
+"a" =~ qr/$x$_/ for "\x{100}", "\x{100}", "\x{100}";
+CODE
+
+comp_1(<<'CODE', 'utf8');
+"a" =~ /$_/ for '\x{100}', '\x{100}', '\x{100}';
+CODE
+
+comp_1(<<'CODE', 'utf8 qr');
+"a" =~ qr/$_/ for '\x{100}', '\x{100}', '\x{100}';
+CODE
+
+comp_1(<<'CODE', 'longjmp utf8');
+my $x = chr(0x80);
+"a" =~ /$x$_/ for '\x{100}', '\x{100}', '\x{100}';
+CODE
+
+comp_1(<<'CODE', 'longjmp utf8');
+my $x = chr(0x80);
+"a" =~ qr/$x$_/ for '\x{100}', '\x{100}', '\x{100}';
+CODE
+
+comp_n(3, <<'CODE', 'mixed utf8');
+"a" =~ /$_/ for "\x{c4}\x{80}", "\x{100}", "\x{c4}\x{80}";
+CODE
+
+comp_n(3, <<'CODE', 'mixed utf8 qr');
+"a" =~ qr/$_/ for "\x{c4}\x{80}", "\x{100}", "\x{c4}\x{80}";
+CODE
+
+# note that that for runtime code, each pattern is compiled twice; the
+# second time to allow the parser to see the code.
+
+comp_n(6, <<'CODE', 'runtime code');
+my $x = '(?{1})';
+BEGIN { $^H |= 0x00200000 } # lightweight "use re 'eval'"
+"a" =~ /a$_/ for $x, $x, $x;
+CODE
+
+comp_n(6, <<'CODE', 'runtime code qr');
+my $x = '(?{1})';
+BEGIN { $^H |= 0x00200000 } # lightweight "use re 'eval'"
+"a" =~ qr/a$_/ for $x, $x, $x;
+CODE
+
+comp_n(4, <<'CODE', 'embedded code');
+my $x = qr/(?{1})/;
+"a" =~ /a$_/ for $x, $x, $x;
+CODE
+
+comp_n(4, <<'CODE', 'embedded code qr');
+my $x = qr/(?{1})/;
+"a" =~ qr/a$_/ for $x, $x, $x;
+CODE
+
+comp_n(7, <<'CODE', 'mixed code');
+my $x = qr/(?{1})/;
+my $y = '(?{1})';
+BEGIN { $^H |= 0x00200000 } # lightweight "use re 'eval'"
+"a" =~ /a$x$_/ for $y, $y, $y;
+CODE
+
+comp_n(7, <<'CODE', 'mixed code qr');
+my $x = qr/(?{1})/;
+my $y = '(?{1})';
+BEGIN { $^H |= 0x00200000 } # lightweight "use re 'eval'"
+"a" =~ qr/a$x$_/ for $y, $y, $y;
+CODE
+
+comp_n(6, <<'CODE', 'embedded code qr');
+my $x = qr/a/i;
+my $y = qr/a/;
+"a" =~ qr/a$_/ for $x, $y, $x, $y;
+CODE
Index: trunk/contrib/perl/t/re/reg_60508.t
===================================================================
--- trunk/contrib/perl/t/re/reg_60508.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/reg_60508.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/re/reg_60508.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/re/reg_email.t
===================================================================
--- trunk/contrib/perl/t/re/reg_email.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/reg_email.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -30,7 +30,7 @@
(?<dcontent> (?&dtext) | (?"ed_pair))
(?<dtext> (?&NO_WS_CTL) | [\x21-\x5a\x5e-\x7e])
- (?<atext> (?&ALPHA) | (?&DIGIT) | [!#\$%&'*+-/=?^_`{|}~])
+ (?<atext> (?&ALPHA) | (?&DIGIT) | [-!#\$%&'*+/=?^_`{|}~])
(?<atom> (?&CFWS)? (?&atext)+ (?&CFWS)?)
(?<dot_atom> (?&CFWS)? (?&dot_atom_text) (?&CFWS)?)
(?<dot_atom_text> (?&atext)+ (?: \. (?&atext)+)*)
Property changes on: trunk/contrib/perl/t/re/reg_email.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/re/reg_email_thr.t
===================================================================
--- trunk/contrib/perl/t/re/reg_email_thr.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/reg_email_thr.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/re/reg_email_thr.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/re/reg_eval.t
===================================================================
--- trunk/contrib/perl/t/re/reg_eval.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/reg_eval.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/re/reg_eval.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/re/reg_eval_scope.t
===================================================================
--- trunk/contrib/perl/t/re/reg_eval_scope.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/reg_eval_scope.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -9,15 +9,8 @@
skip_all_if_miniperl("no dynamic loading on miniperl, no re");
}
-plan 17;
+plan 48;
-# Functions for turning to-do-ness on and off (as there are so many
-# to-do tests)
-sub on { $::TODO = "(?{}) implementation is screwy" }
-sub off { undef $::TODO }
-
-on;
-
fresh_perl_is <<'CODE', '781745', {}, '(?{}) has its own lexical scope';
my $x = 7; my $a = 4; my $b = 5;
print "a" =~ /(?{ print $x; my $x = 8; print $x; my $y })a/;
@@ -87,7 +80,7 @@
fresh_perl_is <<'CODE', '123123', {},
for my $x(1..3) {
- push @regexps = qr/(?{ print $x })a/;
+ push @regexps, qr/(?{ print $x })a/;
}
"a" =~ $_ for @regexps;
"ba" =~ /b$_/ for @regexps;
@@ -94,21 +87,17 @@
CODE
'qr/(?{})/ is a closure';
-off;
-
"a" =~ do { package foo; qr/(?{ $::pack = __PACKAGE__ })a/ };
is $pack, 'foo', 'qr// inherits package';
"a" =~ do { use re "/x"; qr/(?{ $::re = qr-- })a/ };
is $re, '(?^x:)', 'qr// inherits pragmata';
-on;
-
+$::pack = '';
"ba" =~ /b${\do { package baz; qr|(?{ $::pack = __PACKAGE__ })a| }}/;
is $pack, 'baz', '/text$qr/ inherits package';
"ba" =~ m+b${\do { use re "/i"; qr|(?{ $::re = qr-- })a| }}+;
is $re, '(?^i:)', '/text$qr/ inherits pragmata';
-off;
{
use re 'eval';
package bar;
@@ -121,32 +110,261 @@
}
is $re, '(?^m:)', '/$text/ containing (?{}) inherits pragmata';
-on;
-
fresh_perl_is <<'CODE', '45', { stderr => 1 }, '(?{die})';
- eval { my $a=4; my $b=5; "a" =~ /(?{die})a/ }; print $a,$b"
+my $a=4; my $b=5; eval { "a" =~ /(?{die})a/ }; print $a,$b;
CODE
-SKIP: {
- # The remaining TODO tests crash, which will display an error dialog
- # on Windows that has to be manually dismissed. We don't want this
- # to happen for release builds: 5.14.x, 5.16.x etc.
- # On UNIX, they produce ugly 'Aborted' shell output mixed in with the
- # test harness output, so skip on all platforms.
- skip "Don't run crashing TODO test on release build", 3
- if $::TODO && (int($]*1000) & 1) == 0;
+fresh_perl_is <<'CODE', 'Y45', { stderr => 1 }, '(?{eval{die}})';
+my $a=4; my $b=5;
+"a" =~ /(?{eval { die; print "X" }; print "Y"; })a/; print $a,$b;
+CODE
- fresh_perl_is <<'CODE', '45', { stderr => 1 }, '(?{last})';
- { my $a=4; my $b=5; "a" =~ /(?{last})a/ }; print $a,$b
+fresh_perl_is <<'CODE',
+ my $a=4; my $b=5;
+ sub f { "a" =~ /(?{print((caller(0))[3], "\n");})a/ };
+ f();
+ print $a,$b;
CODE
- fresh_perl_is <<'CODE', '45', { stderr => 1 }, '(?{next})';
- { my $a=4; my $b=5; "a" =~ /(?{last})a/ }; print $a,$b
+ "main::f\n45",
+ { stderr => 1 }, 'sub f {(?{caller})}';
+
+
+fresh_perl_is <<'CODE',
+ my $a=4; my $b=5;
+ sub f { print ((caller(0))[3], "-", (caller(1))[3], "-\n") };
+ "a" =~ /(?{f()})a/;
+ print $a,$b;
CODE
- fresh_perl_is <<'CODE', '45', { stderr => 1 }, '(?{return})';
- print sub { my $a=4; my $b=5; "a" =~ /(?{return $a.$b})a/ }->();
+ "main::f--\n45",
+ { stderr => 1 }, 'sub f {caller} /(?{f()})/';
+
+
+fresh_perl_is <<'CODE',
+ my $a=4; my $b=5;
+ sub f {
+ "a" =~ /(?{print "X"; return; print "Y"; })a/;
+ print "Z";
+ };
+ f();
+ print $a,$b;
CODE
+ "XZ45",
+ { stderr => 1 }, 'sub f {(?{return})}';
+
+
+fresh_perl_is <<'CODE',
+my $a=4; my $b=5; "a" =~ /(?{last})a/; print $a,$b
+CODE
+ q{Can't "last" outside a loop block at - line 1.},
+ { stderr => 1 }, '(?{last})';
+
+
+fresh_perl_is <<'CODE',
+my $a=4; my $b=5; "a" =~ /(?{for (1..4) {last}})a/; print $a,$b
+CODE
+ '45',
+ { stderr => 1 }, '(?{for {last}})';
+
+
+fresh_perl_is <<'CODE',
+for (1) { my $a=4; my $b=5; "a" =~ /(?{last})a/ }; print $a,$b
+CODE
+ q{Can't "last" outside a loop block at - line 1.},
+ { stderr => 1 }, 'for (1) {(?{last})}';
+
+
+fresh_perl_is <<'CODE',
+my $a=4; my $b=5; eval { "a" =~ /(?{last})a/ }; print $a,$b
+CODE
+ '45',
+ { stderr => 1 }, 'eval {(?{last})}';
+
+
+fresh_perl_is <<'CODE',
+my $a=4; my $b=5; "a" =~ /(?{next})a/; print $a,$b
+CODE
+ q{Can't "next" outside a loop block at - line 1.},
+ { stderr => 1 }, '(?{next})';
+
+
+fresh_perl_is <<'CODE',
+my $a=4; my $b=5; "a" =~ /(?{for (1,2,3) { next} })a/; print $a,$b
+CODE
+ '45',
+ { stderr => 1 }, '(?{for {next}})';
+
+
+fresh_perl_is <<'CODE',
+for (1) { my $a=4; my $b=5; "a" =~ /(?{next})a/ }; print $a,$b
+CODE
+ q{Can't "next" outside a loop block at - line 1.},
+ { stderr => 1 }, 'for (1) {(?{next})}';
+
+
+fresh_perl_is <<'CODE',
+my $a=4; my $b=5; eval { "a" =~ /(?{next})a/ }; print $a,$b
+CODE
+ '45',
+ { stderr => 1 }, 'eval {(?{next})}';
+
+
+fresh_perl_is <<'CODE',
+my $a=4; my $b=5;
+"a" =~ /(?{ goto FOO; print "X"; })a/;
+print "Y";
+FOO:
+print $a,$b
+CODE
+ q{Can't "goto" out of a pseudo block at - line 2.},
+ { stderr => 1 }, '{(?{goto})}';
+
+
+{
+ local $::TODO = "goto doesn't yet work in pseduo blocks";
+fresh_perl_is <<'CODE',
+my $a=4; my $b=5;
+"a" =~ /(?{ goto FOO; print "X"; FOO: print "Y"; })a/;
+print "Z";
+FOO;
+print $a,$b
+CODE
+ "YZ45",
+ { stderr => 1 }, '{(?{goto FOO; FOO:})}';
}
-fresh_perl_is <<'CODE', '45', { stderr => 1 }, '(?{goto})';
- my $a=4; my $b=5; "a" =~ /(?{goto _})a/; die; _: print $a,$b
+# [perl #3590]
+fresh_perl_is <<'CODE', '', { stderr => 1 }, '(?{eval{die}})';
+"$_$_$_"; my $foo; # these consume pad entries and ensure a SEGV on opd perls
+"" =~ m{(?{exit(0)})};
CODE
+
+
+# [perl #92256]
+{ my $y = "a"; $y =~ /a(?{ undef *_ })/ }
+pass "undef *_ in a re-eval does not cause a double free";
+
+# make sure regexp warnings are reported on the right line
+# (we don't care what warning; the 32768 limit is just one
+# that was easy to reproduce) */
+{
+ use warnings;
+ my $w;
+ local $SIG{__WARN__} = sub { $w = "@_" };
+ my $qr = qr/(??{'a'})/;
+ my $filler = 1;
+ ("a" x 40_000) =~ /^$qr(ab*)+/; my $line = __LINE__;
+ like($w, qr/recursion limit.* line $line\b/, "warning on right line");
+}
+
+# on immediate exit from pattern with code blocks, make sure PL_curcop is
+# restored
+
+{
+ use re 'eval';
+
+ my $c = '(?{"1"})';
+ my $w = '';
+ my $l;
+
+ local $SIG{__WARN__} = sub { $w .= "@_" };
+ $l = __LINE__; "1" =~ /^1$c/x and warn "foo";
+ like($w, qr/foo.+line $l/, 'curcop 1');
+
+ $w = '';
+ $l = __LINE__; "4" =~ /^1$c/x or warn "foo";
+ like($w, qr/foo.+line $l/, 'curcop 2');
+
+ $c = '(??{"1"})';
+ $l = __LINE__; "1" =~ /^$c/x and warn "foo";
+ like($w, qr/foo.+line $l/, 'curcop 3');
+
+ $w = '';
+ $l = __LINE__; "4" =~ /^$c/x or warn "foo";
+ like($w, qr/foo.+line $l/, 'curcop 4');
+}
+
+# [perl #113928] caller behaving unexpectedly in re-evals
+#
+# /(?{...})/ should be in the same caller scope as the surrounding code;
+# qr/(?{...})/ should be in an anon sub
+
+{
+
+ my $l;
+
+ sub callers {
+ my @c;
+ my $stack = '';
+ my $i = 1;
+ while (@c = caller($i++)) {
+ $stack .= "($c[3]:" . ($c[2] - $l) . ')';
+ }
+ $stack;
+ }
+
+ $l = __LINE__;
+ my $c;
+ is (callers(), '', 'callers() null');
+ "" =~ /(?{ $c = callers() })/;
+ is ($c, '', 'callers() //');
+
+ $l = __LINE__;
+ sub m1 { "" =~ /(?{ $c = callers() })/; }
+ m1();
+ is ($c, '(main::m1:2)', 'callers() m1');
+
+ $l = __LINE__;
+ my $r1 = qr/(?{ $c = callers() })/;
+ "" =~ /$r1/;
+ is ($c, '(main::__ANON__:2)', 'callers() r1');
+
+ $l = __LINE__;
+ sub r1 { "" =~ /$r1/; }
+ r1();
+ is ($c, '(main::__ANON__:1)(main::r1:2)', 'callers() r1/r1');
+
+ $l = __LINE__;
+ sub c2 { $c = callers() }
+ my $r2 = qr/(?{ c2 })/;
+ "" =~ /$r2/;
+ is ($c, '(main::c2:2)(main::__ANON__:3)', 'callers() r2/c2');
+ sub r2 { "" =~ /$r2/; }
+ r2();
+ is ($c, '(main::c2:2)(main::__ANON__:5)(main::r2:6)', 'callers() r2/r2/c2');
+
+ $l = __LINE__;
+ sub c3 { $c = callers() }
+ my $r3 = qr/(?{ c3 })/;
+ my $c1;
+ "ABC" =~ /A(?{ $c1 = callers() })B${r3}C/;
+ is ($c, '(main::c3:2)(main::__ANON__:4)', 'callers() r3/c3');
+ is ($c1,'', 'callers() r3/c3 part 2');
+ sub r3 { "ABC" =~ /A(?{ $c1 = callers() })B${r3}C/; }
+ r3();
+ is ($c, '(main::c3:2)(main::__ANON__:7)(main::r3:8)', 'callers() r3/r3/c3');
+ is ($c1,'(main::r3:8)', 'callers() r3/r3/c3 part 2');
+
+}
+
+# [perl #113928] caller behaving unexpectedly in re-evals
+#
+# make sure __SUB__ within a code block returns something safe.
+# NB waht it actually returns is subject to change
+
+{
+
+ my $s;
+
+ sub f1 { /(?{ $s = CORE::__SUB__; })/ }
+ f1();
+ is ($s, \&f1, '__SUB__ direct');
+
+ my $r = qr/(?{ $s = CORE::__SUB__; })/;
+ sub f2 { "" =~ $r }
+ f2();
+ is ($s, \&f2, '__SUB__ qr');
+
+ sub f3 { "AB" =~ /A${r}B/ }
+ f3();
+ is ($s, \&f3, '__SUB__ qr multi');
+}
Property changes on: trunk/contrib/perl/t/re/reg_eval_scope.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/re/reg_fold.t
===================================================================
--- trunk/contrib/perl/t/re/reg_fold.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/reg_fold.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -11,17 +11,53 @@
use warnings;
my @tests;
-my %todo_pass = map { $_ => 1 }
- qw(00DF 1E9E FB00 FB01 FB02 FB03 FB04 FB05 FB06);
+my $file="../lib/unicore/CaseFolding.txt";
+my @folds;
+use Unicode::UCD;
-my $file="../lib/unicore/CaseFolding.txt";
-open my $fh,"<",$file or die "Failed to read '$file': $!";
-while (<$fh>) {
+# Use the Unicode data file if we are on an ASCII platform (which its data is
+# for), and it is in the modern format (starting in Unicode 3.1.0) and it is
+# available. This avoids being affected by potential bugs introduced by other
+# layers of Perl
+if (ord('A') == 65
+ && pack("C*", split /\./, Unicode::UCD::UnicodeVersion()) ge v3.1.0
+ && open my $fh, "<", $file)
+{
+ @folds = <$fh>;
+}
+else {
+ my ($invlist_ref, $invmap_ref, undef, $default)
+ = Unicode::UCD::prop_invmap('Case_Folding');
+ for my $i (0 .. @$invlist_ref - 1 - 1) {
+ next if $invmap_ref->[$i] == $default;
+ my $adjust = -1;
+ for my $j ($invlist_ref->[$i] .. $invlist_ref->[$i+1] -1) {
+ $adjust++;
+
+ # Single-code point maps go to a 'C' type
+ if (! ref $invmap_ref->[$i]) {
+ push @folds, sprintf("%04X; C; %04X\n",
+ $j,
+ $invmap_ref->[$i] + $adjust);
+ }
+ else { # Multi-code point maps go to 'F'. prop_invmap()
+ # guarantees that no adjustment is needed for these,
+ # as the range will contain just one element
+ push @folds, sprintf("%04X; F; %s\n",
+ $j,
+ join " ", map { sprintf "%04X", $_ }
+ @{$invmap_ref->[$i]});
+ }
+ }
+ }
+}
+
+for (@folds) {
chomp;
my ($line,$comment)= split/\s+#\s+/, $_;
+ $comment = "" unless defined $comment;
my ($cp,$type, at folded)=split/[\s;]+/,$line||'';
next unless $type and ($type eq 'F' or $type eq 'C');
- next if $type eq 'C'; # 'C' tests now done by fold_grind.t
my $fold_above_latin1 = grep { hex("0x$_") > 255 } @folded;
$_="\\x{$_}" for @folded;
my $cpv=hex("0x$cp");
@@ -28,7 +64,7 @@
my $chr="\\x{$cp}";
my @str;
foreach my $swap (0, 1) { # swap lhs and rhs, or not.
- foreach my $charclass (0) { # Put rhs in [...], or not
+ foreach my $charclass (0, 1) { # Put rhs in [...], or not
my $lhs;
my $rhs;
if ($swap) {
@@ -36,20 +72,26 @@
$rhs = $chr;
$rhs = "[$rhs]" if $charclass;
} else {
+ #next if $charclass && @folded > 1;
$lhs = $chr;
$rhs = "";
foreach my $rhs_char (@folded) {
- $rhs .= '[' if $charclass;
+
+ # The colon is an unrelated character to the rest of the
+ # class, and makes sure no optimization into an EXACTish
+ # node occurs.
+ $rhs .= '[:' if $charclass;
$rhs .= $rhs_char;
$rhs .= ']' if $charclass;
}
}
$lhs = "\"$lhs\"";
- $rhs = "/^$rhs\$/i";
+ $rhs = "/^$rhs\$/iu";
# Try both Latin1 and Unicode for code points below 256
foreach my $upgrade ("", 'utf8::upgrade($c); ') {
- if ($upgrade) {
+ if ($upgrade) { # No need to upgrade if already must be in
+ # utf8
next if $swap && $fold_above_latin1;
next if !$swap && $cpv > 255;
}
@@ -56,15 +98,9 @@
my $eval = "my \$c = $lhs; $upgrade\$c =~ $rhs";
#print __LINE__, ": $eval\n";
push @tests, qq[ok(eval '$eval', '$eval - $comment')];
- if ($charclass && @folded > 1 && $swap && ! $upgrade && ! $fold_above_latin1) {
- $tests[-1]="TODO: { local \$::TODO='Multi-char, non-utf8 folded inside character class [ ] doesnt work';\n$tests[-1] }"
- } elsif (! $upgrade && $cpv >= 128 && $cpv <= 255 && $cpv != 0xb5) {
- $tests[-1]="TODO: { local \$::TODO='Most non-utf8 latin1 doesnt work';\n$tests[-1] }"
- } elsif (! $swap && $charclass && @folded > 1
- && ! $todo_pass{$cp})
+ if (! $swap && $charclass && @folded > 1)
{
- # There are a few of these that pass; most fail.
- $tests[-1]="TODO: { local \$::TODO='Some multi-char, f8 folded inside character class [ ] doesnt work';\n$tests[-1] }"
+ $tests[-1]="TODO: { local \$::TODO='A multi-char fold \"foo\", doesnt work for /[f][o][o]/i';\n$tests[-1] }"
}
}
}
@@ -107,7 +143,7 @@
$fold_ascii[$lower_ord] = $upper_ord;
}
-# Test every latin1 character that the correct values in both /u and /d
+# Test every latin1 character for the correct values in both /u and /d
for my $i (0 .. 255) {
my $chr = sprintf "\\x%02X", $i;
my $hex_fold_ascii = sprintf "0x%02X", $fold_ascii[$i];
@@ -119,11 +155,12 @@
push @tests, qq[like chr(0x0430), qr/[=\x{0410}-\x{0411}]/i, 'Bug #71752 Unicode /i char in a range'];
push @tests, qq[like 'a', qr/\\p{Upper}/i, "'a' =~ /\\\\p{Upper}/i"];
-push @tests, q[my $c = "\x{212A}"; my $p = qr/(?:^[\x{004B}_]+$)/i; utf8::upgrade($p); like $c, $p, 'Bug #78994: my $c = "\x{212A}"; my $p = qr/(?:^[\x{004B}_]+$)/i; utf8::upgrade($p); $c =~ $p'];
+push @tests, q[my $c = "\x{212A}"; my $p = qr/(?:^[K_]+$)/i; utf8::upgrade($p); like $c, $p, 'Bug #78994: my $c = "\x{212A}"; my $p = qr/(?:^[K_]+$)/i; utf8::upgrade($p); $c =~ $p'];
use charnames ":full";
-push @tests, q[my $re1 = "\N{WHITE SMILING FACE}";like "\xE8", qr/[\w$re1]/, 'my $re = "\N{WHITE SMILING FACE}"; "\xE8" =~ qr/[\w$re]/'];
-push @tests, q[my $re2 = "\N{WHITE SMILING FACE}";like "\xE8", qr/\w|$re2/, 'my $re = "\N{WHITE SMILING FACE}"; "\xE8" =~ qr/\w|$re/'];
+my $e_grave = latin1_to_native("\xE8");
+push @tests, q[my $re1 = "\N{WHITE SMILING FACE}";like $e_grave, qr/[\w$re1]/, 'my $re = "\N{WHITE SMILING FACE}"; $e_grave =~ qr/[\w$re]/'];
+push @tests, q[my $re2 = "\N{WHITE SMILING FACE}";like $e_grave, qr/\w|$re2/, 'my $re = "\N{WHITE SMILING FACE}"; $e_grave =~ qr/\w|$re/'];
eval join ";\n","plan tests=>". (scalar @tests), @tests, "1"
or die $@;
Property changes on: trunk/contrib/perl/t/re/reg_fold.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/re/reg_mesg.t
===================================================================
--- trunk/contrib/perl/t/re/reg_mesg.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/reg_mesg.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -15,12 +15,29 @@
## arrays below. The {#} is a meta-marker -- it marks where the marker should
## go.
##
+## Returns empty string if that is what is expected. Otherwise, handles
+## either a scalar, turning it into a single element array; or a ref to an
+## array, adjusting each element. If called in array context, returns an
+## array, otherwise the join of all elements
+
sub fixup_expect {
- my $expect = shift;
- $expect =~ s/{\#}/<-- HERE/;
- $expect =~ s/{\#}/ <-- HERE /;
- $expect .= " at ";
- return $expect;
+ my $expect_ref = shift;
+ return if $expect_ref eq "";
+
+ my @expect;
+ if (ref $expect_ref) {
+ @expect = @$expect_ref;
+ }
+ else {
+ @expect = $expect_ref;
+ }
+
+ foreach my $element (@expect) {
+ $element =~ s/{\#}/in regex; marked by <-- HERE in/;
+ $element =~ s/{\#}/ <-- HERE /;
+ $element .= " at ";
+ }
+ return wantarray ? @expect : join "", @expect;
}
my $inf_m1 = ($Config::Config{reg_infty} || 32767) - 1;
@@ -31,102 +48,224 @@
##
my @death =
(
- '/[[=foo=]]/' => 'POSIX syntax [= =] is reserved for future extensions in regex; marked by {#} in m/[[=foo=]{#}]/',
+ '/[[=foo=]]/' => 'POSIX syntax [= =] is reserved for future extensions {#} m/[[=foo=]{#}]/',
'/(?<= .*)/' => 'Variable length lookbehind not implemented in regex m/(?<= .*)/',
'/(?<= x{1000})/' => 'Lookbehind longer than 255 not implemented in regex m/(?<= x{1000})/',
- '/(?@)/' => 'Sequence (?@...) not implemented in regex; marked by {#} in m/(?@{#})/',
+ '/(?@)/' => 'Sequence (?@...) not implemented {#} m/(?@{#})/',
- '/(?{ 1/' => 'Sequence (?{...}) not terminated or not {}-balanced in regex; marked by {#} in m/(?{{#} 1/',
+ '/(?{ 1/' => 'Missing right curly or square bracket',
- '/(?(1x))/' => 'Switch condition not recognized in regex; marked by {#} in m/(?(1x{#}))/',
+ '/(?(1x))/' => 'Switch condition not recognized {#} m/(?(1x{#}))/',
- '/(?(1)x|y|z)/' => 'Switch (?(condition)... contains too many branches in regex; marked by {#} in m/(?(1)x|y|{#}z)/',
+ '/(?(1)x|y|z)/' => 'Switch (?(condition)... contains too many branches {#} m/(?(1)x|y|{#}z)/',
- '/(?(x)y|x)/' => 'Unknown switch condition (?(x) in regex; marked by {#} in m/(?({#}x)y|x)/',
+ '/(?(x)y|x)/' => 'Unknown switch condition (?(x) {#} m/(?({#}x)y|x)/',
- '/(?/' => 'Sequence (? incomplete in regex; marked by {#} in m/(?{#}/',
+ '/(?/' => 'Sequence (? incomplete {#} m/(?{#}/',
- '/(?;x/' => 'Sequence (?;...) not recognized in regex; marked by {#} in m/(?;{#}x/',
- '/(?<;x/' => 'Sequence (?<;...) not recognized in regex; marked by {#} in m/(?<;{#}x/',
+ '/(?;x/' => 'Sequence (?;...) not recognized {#} m/(?;{#}x/',
+ '/(?<;x/' => 'Group name must start with a non-digit word character {#} m/(?<;{#}x/',
+ '/(?\ix/' => 'Sequence (?\...) not recognized {#} m/(?\{#}ix/',
+ '/(?\mx/' => 'Sequence (?\...) not recognized {#} m/(?\{#}mx/',
+ '/(?\:x/' => 'Sequence (?\...) not recognized {#} m/(?\{#}:x/',
+ '/(?\=x/' => 'Sequence (?\...) not recognized {#} m/(?\{#}=x/',
+ '/(?\!x/' => 'Sequence (?\...) not recognized {#} m/(?\{#}!x/',
+ '/(?\<=x/' => 'Sequence (?\...) not recognized {#} m/(?\{#}<=x/',
+ '/(?\<!x/' => 'Sequence (?\...) not recognized {#} m/(?\{#}<!x/',
+ '/(?\>x/' => 'Sequence (?\...) not recognized {#} m/(?\{#}>x/',
+ '/(?^-i:foo)/' => 'Sequence (?^-...) not recognized {#} m/(?^-{#}i:foo)/',
+ '/(?^-i)foo/' => 'Sequence (?^-...) not recognized {#} m/(?^-{#}i)foo/',
+ '/(?^d:foo)/' => 'Sequence (?^d...) not recognized {#} m/(?^d{#}:foo)/',
+ '/(?^d)foo/' => 'Sequence (?^d...) not recognized {#} m/(?^d{#})foo/',
+ '/(?^lu:foo)/' => 'Regexp modifiers "l" and "u" are mutually exclusive {#} m/(?^lu{#}:foo)/',
+ '/(?^lu)foo/' => 'Regexp modifiers "l" and "u" are mutually exclusive {#} m/(?^lu{#})foo/',
+'/(?da:foo)/' => 'Regexp modifiers "d" and "a" are mutually exclusive {#} m/(?da{#}:foo)/',
+'/(?lil:foo)/' => 'Regexp modifier "l" may not appear twice {#} m/(?lil{#}:foo)/',
+'/(?aaia:foo)/' => 'Regexp modifier "a" may appear a maximum of twice {#} m/(?aaia{#}:foo)/',
+'/(?i-l:foo)/' => 'Regexp modifier "l" may not appear after the "-" {#} m/(?i-l{#}:foo)/',
- '/(?\ix/' => 'Sequence (?\...) not recognized in regex; marked by {#} in m/(?\{#}ix/',
- '/(?\mx/' => 'Sequence (?\...) not recognized in regex; marked by {#} in m/(?\{#}mx/',
- '/(?\:x/' => 'Sequence (?\...) not recognized in regex; marked by {#} in m/(?\{#}:x/',
- '/(?\=x/' => 'Sequence (?\...) not recognized in regex; marked by {#} in m/(?\{#}=x/',
- '/(?\!x/' => 'Sequence (?\...) not recognized in regex; marked by {#} in m/(?\{#}!x/',
- '/(?\<=x/' => 'Sequence (?\...) not recognized in regex; marked by {#} in m/(?\{#}<=x/',
- '/(?\<!x/' => 'Sequence (?\...) not recognized in regex; marked by {#} in m/(?\{#}<!x/',
- '/(?\>x/' => 'Sequence (?\...) not recognized in regex; marked by {#} in m/(?\{#}>x/',
- '/(?^-i:foo)/' => 'Sequence (?^-...) not recognized in regex; marked by {#} in m/(?^-{#}i:foo)/',
- '/(?^-i)foo/' => 'Sequence (?^-...) not recognized in regex; marked by {#} in m/(?^-{#}i)foo/',
- '/(?^d:foo)/' => 'Sequence (?^d...) not recognized in regex; marked by {#} in m/(?^d{#}:foo)/',
- '/(?^d)foo/' => 'Sequence (?^d...) not recognized in regex; marked by {#} in m/(?^d{#})foo/',
- '/(?^lu:foo)/' => 'Regexp modifiers "l" and "u" are mutually exclusive in regex; marked by {#} in m/(?^lu{#}:foo)/',
- '/(?^lu)foo/' => 'Regexp modifiers "l" and "u" are mutually exclusive in regex; marked by {#} in m/(?^lu{#})foo/',
-'/(?da:foo)/' => 'Regexp modifiers "d" and "a" are mutually exclusive in regex; marked by {#} in m/(?da{#}:foo)/',
-'/(?lil:foo)/' => 'Regexp modifier "l" may not appear twice in regex; marked by {#} in m/(?lil{#}:foo)/',
-'/(?aaia:foo)/' => 'Regexp modifier "a" may appear a maximum of twice in regex; marked by {#} in m/(?aaia{#}:foo)/',
-'/(?i-l:foo)/' => 'Regexp modifier "l" may not appear after the "-" in regex; marked by {#} in m/(?i-l{#}:foo)/',
+ '/((x)/' => 'Unmatched ( {#} m/({#}(x)/',
- '/((x)/' => 'Unmatched ( in regex; marked by {#} in m/({#}(x)/',
+ "/x{$inf_p1}/" => "Quantifier in {,} bigger than $inf_m1 {#} m/x{{#}$inf_p1}/",
- "/x{$inf_p1}/" => "Quantifier in {,} bigger than $inf_m1 in regex; marked by {#} in m/x{{#}$inf_p1}/",
- '/x{3,1}/' => 'Can\'t do {n,m} with n > m in regex; marked by {#} in m/x{3,1}{#}/',
+ '/x**/' => 'Nested quantifiers {#} m/x**{#}/',
- '/x**/' => 'Nested quantifiers in regex; marked by {#} in m/x**{#}/',
+ '/x[/' => 'Unmatched [ {#} m/x[{#}/',
- '/x[/' => 'Unmatched [ in regex; marked by {#} in m/x[{#}/',
+ '/*/', => 'Quantifier follows nothing {#} m/*{#}/',
- '/*/', => 'Quantifier follows nothing in regex; marked by {#} in m/*{#}/',
+ '/\p{x/' => 'Missing right brace on \p{} {#} m/\p{{#}x/',
- '/\p{x/' => 'Missing right brace on \p{} in regex; marked by {#} in m/\p{{#}x/',
+ '/[\p{x]/' => 'Missing right brace on \p{} {#} m/[\p{{#}x]/',
- '/[\p{x]/' => 'Missing right brace on \p{} in regex; marked by {#} in m/[\p{{#}x]/',
+ '/(x)\2/' => 'Reference to nonexistent group {#} m/(x)\2{#}/',
- '/(x)\2/' => 'Reference to nonexistent group in regex; marked by {#} in m/(x)\2{#}/',
-
'my $m = "\\\"; $m =~ $m', => 'Trailing \ in regex m/\/',
- '/\x{1/' => 'Missing right brace on \x{} in regex; marked by {#} in m/\x{{#}1/',
+ '/\x{1/' => 'Missing right brace on \x{} {#} m/\x{1{#}/',
+ '/\x{X/' => 'Missing right brace on \x{} {#} m/\x{{#}X/',
- '/[\x{X]/' => 'Missing right brace on \x{} in regex; marked by {#} in m/[\x{{#}X]/',
+ '/[\x{X]/' => 'Missing right brace on \x{} {#} m/[\x{{#}X]/',
+ '/[\x{A]/' => 'Missing right brace on \x{} {#} m/[\x{A{#}]/',
- '/[[:barf:]]/' => 'POSIX class [:barf:] unknown in regex; marked by {#} in m/[[:barf:]{#}]/',
+ '/\o{1/' => 'Missing right brace on \o{ {#} m/\o{1{#}/',
+ '/\o{X/' => 'Missing right brace on \o{ {#} m/\o{{#}X/',
- '/[[=barf=]]/' => 'POSIX syntax [= =] is reserved for future extensions in regex; marked by {#} in m/[[=barf=]{#}]/',
+ '/[\o{X]/' => 'Missing right brace on \o{ {#} m/[\o{{#}X]/',
+ '/[\o{7]/' => 'Missing right brace on \o{ {#} m/[\o{7{#}]/',
- '/[[.barf.]]/' => 'POSIX syntax [. .] is reserved for future extensions in regex; marked by {#} in m/[[.barf.]{#}]/',
-
- '/[z-a]/' => 'Invalid [] range "z-a" in regex; marked by {#} in m/[z-a{#}]/',
+ '/[[:barf:]]/' => 'POSIX class [:barf:] unknown {#} m/[[:barf:]{#}]/',
- '/\p/' => 'Empty \p{} in regex; marked by {#} in m/\p{#}/',
+ '/[[=barf=]]/' => 'POSIX syntax [= =] is reserved for future extensions {#} m/[[=barf=]{#}]/',
- '/\P{}/' => 'Empty \P{} in regex; marked by {#} in m/\P{{#}}/',
+ '/[[.barf.]]/' => 'POSIX syntax [. .] is reserved for future extensions {#} m/[[.barf.]{#}]/',
+
+ '/[z-a]/' => 'Invalid [] range "z-a" {#} m/[z-a{#}]/',
+
+ '/\p/' => 'Empty \p{} {#} m/\p{#}/',
+
+ '/\P{}/' => 'Empty \P{} {#} m/\P{{#}}/',
+ '/(?[[[:word]]])/' => "Unmatched ':' in POSIX class {#} m/(?[[[:word{#}]]])/",
+ '/(?[[:word]])/' => "Unmatched ':' in POSIX class {#} m/(?[[:word{#}]])/",
+ '/(?[[[:digit: ])/' => "Unmatched '[' in POSIX class {#} m/(?[[[:digit:{#} ])/",
+ '/(?[[:digit: ])/' => "Unmatched '[' in POSIX class {#} m/(?[[:digit:{#} ])/",
+ '/(?[[[::]]])/' => "POSIX class [::] unknown {#} m/(?[[[::]{#}]])/",
+ '/(?[[[:w:]]])/' => "POSIX class [:w:] unknown {#} m/(?[[[:w:]{#}]])/",
+ '/(?[[:w:]])/' => "POSIX class [:w:] unknown {#} m/(?[[:w:]{#}])/",
+ '/(?[a])/' => 'Unexpected character {#} m/(?[a{#}])/',
+ '/(?[\t])/l' => '(?[...]) not valid in locale {#} m/(?[{#}\t])/',
+ '/(?[ + \t ])/' => 'Unexpected binary operator \'+\' with no preceding operand {#} m/(?[ +{#} \t ])/',
+ '/(?[ \cK - ( + \t ) ])/' => 'Unexpected binary operator \'+\' with no preceding operand {#} m/(?[ \cK - ( +{#} \t ) ])/',
+ '/(?[ \cK ( \t ) ])/' => 'Unexpected \'(\' with no preceding operator {#} m/(?[ \cK ({#} \t ) ])/',
+ '/(?[ \cK \t ])/' => 'Operand with no preceding operator {#} m/(?[ \cK \t{#} ])/',
+ '/(?[ \0004 ])/' => 'Need exactly 3 octal digits {#} m/(?[ \0004 {#}])/',
+ '/(?[ \05 ])/' => 'Need exactly 3 octal digits {#} m/(?[ \05 {#}])/',
+ '/(?[ \o{1038} ])/' => 'Non-octal character {#} m/(?[ \o{1038{#}} ])/',
+ '/(?[ \o{} ])/' => 'Number with no digits {#} m/(?[ \o{}{#} ])/',
+ '/(?[ \x{defg} ])/' => 'Non-hex character {#} m/(?[ \x{defg{#}} ])/',
+ '/(?[ \xabcdef ])/' => 'Use \\x{...} for more than two hex characters {#} m/(?[ \xabc{#}def ])/',
+ '/(?[ \x{} ])/' => 'Number with no digits {#} m/(?[ \x{}{#} ])/',
+ '/(?[ \cK + ) ])/' => 'Unexpected \')\' {#} m/(?[ \cK + ){#} ])/',
+ '/(?[ \cK + ])/' => 'Incomplete expression within \'(?[ ])\' {#} m/(?[ \cK + {#}])/',
+ '/(?[ \p{foo} ])/' => 'Property \'foo\' is unknown {#} m/(?[ \p{foo}{#} ])/',
+ '/(?[ \p{ foo = bar } ])/' => 'Property \'foo = bar\' is unknown {#} m/(?[ \p{ foo = bar }{#} ])/',
+ '/(?[ \8 ])/' => 'Unrecognized escape \8 in character class {#} m/(?[ \8{#} ])/',
+ '/(?[ \t ]/' => 'Syntax error in (?[...]) in regex m/(?[ \t ]/',
+ '/(?[ [ \t ]/' => 'Syntax error in (?[...]) in regex m/(?[ [ \t ]/',
+ '/(?[ \t ] ]/' => 'Syntax error in (?[...]) in regex m/(?[ \t ] ]/',
+ '/(?[ [ ] ]/' => 'Syntax error in (?[...]) in regex m/(?[ [ ] ]/',
+ '/(?[ \t + \e # This was supposed to be a comment ])/' => 'Syntax error in (?[...]) in regex m/(?[ \t + \e # This was supposed to be a comment ])/',
+ '/(?[ ])/' => 'Incomplete expression within \'(?[ ])\' {#} m/(?[ {#}])/',
+ '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/(?[[\N{LATIN CAPITAL LETTER A WITH MACRON AND GRAVE}]])/' => '\N{} in character class 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{{#}/',
+ 'm/\o/' => 'Missing braces on \o{} {#} m/\o{#}/',
+ 'm/\o{}/' => 'Number with no digits {#} m/\o{}{#}/',
+ 'm/[\o{]/' => 'Missing right brace on \o{ {#} m/[\o{{#}]/',
+ 'm/[\o]/' => 'Missing braces on \o{} {#} m/[\o{#}]/',
+ 'm/[\o{}]/' => 'Number with no digits {#} m/[\o{}{#}]/',
+ 'm/(?^-i:foo)/' => 'Sequence (?^-...) not recognized {#} m/(?^-{#}i:foo)/',
);
+# Tests involving a user-defined charnames translator are in pat_advanced.t
+# 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 warnings.
+## 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 in regex; marked by {#} in m/\b*{#}/',
+ 'm/\b*/' => '\b* matches null string many times {#} m/\b*{#}/',
- 'm/[:blank:]/' => 'POSIX syntax [: :] belongs inside character classes in regex; marked by {#} in m/[:blank:]{#}/',
+ 'm/[:blank:]/' => 'POSIX syntax [: :] belongs inside character classes {#} m/[:blank:]{#}/',
- "m'[\\y]'" => 'Unrecognized escape \y in character class passed through in regex; marked by {#} in m/[\y{#}]/',
+ "m'[\\y]'" => 'Unrecognized escape \y in character class passed through {#} m/[\y{#}]/',
- 'm/[a-\d]/' => 'False [] range "a-\d" in regex; marked by {#} in m/[a-\d{#}]/',
- 'm/[\w-x]/' => 'False [] range "\w-" in regex; marked by {#} in m/[\w-{#}x]/',
- 'm/[a-\pM]/' => 'False [] range "a-\pM" in regex; marked by {#} in m/[a-\pM{#}]/',
- 'm/[\pM-x]/' => 'False [] range "\pM-" in regex; marked by {#} in m/[\pM-{#}x]/',
- "m'\\y'" => 'Unrecognized escape \y passed through in regex; marked by {#} in m/\y{#}/',
+ '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{#}/',
+ '/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{#}/',
+ '/[\08]/' => '\'\08\' resolved to \'\o{0}8\' {#} m/[\08{#}]/',
+ '/[\018]/' => '\'\018\' resolved to \'\o{1}8\' {#} m/[\018{#}]/',
+ '/\87/' => 'Unrecognized escape \8 passed through {#} m/\8{#}7/',
+ '/a\87/' => 'Unrecognized escape \8 passed through {#} m/a\8{#}7/',
+ '/a\97/' => 'Unrecognized escape \9 passed through {#} m/a\9{#}7/',
+ '/(?=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{#}/',
+ '/\q{/' => 'Unrecognized escape \q{ passed through {#} m/\q{{#}/',
+ '/(?=a){1,3}/' => 'Quantifier unexpected on zero-length expression {#} m/(?=a){1,3}{#}/',
+ '/\_/' => "",
+ '/[\_\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{#}]/',
+ ],
+ '/[: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.]{#}/',
+ '/[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{#})/',
+ ],
+ '/(?g-c)/' => [ 'Useless (?g) - use /g modifier {#} m/(?g{#}-c)/',
+ 'Useless (?-c) - don\'t use /gc modifier {#} m/(?g-c{#})/',
+ ],
+ # (?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)/',
+ ],
+ '/(?ogc)/' => [ 'Useless (?o) - use /o modifier {#} m/(?o{#}gc)/',
+ 'Useless (?g) - use /g modifier {#} m/(?og{#}c)/',
+ 'Useless (?c) - use /gc modifier {#} m/(?ogc{#})/',
+ ],
);
+my @experimental_regex_sets = (
+ '/(?[ \t ])/' => 'The regex_sets feature is experimental {#} m/(?[{#} \t ])/',
+);
+
+my @deprecated = (
+ '/a\b{cde/' => '"\b{" is deprecated; use "\b\{" or "\b[{]" instead {#} m/a\{#}b{cde/',
+ '/a\B{cde/' => '"\B{" is deprecated; use "\B\{" or "\B[{]" instead {#} m/a\{#}B{cde/',
+ 'use utf8; /(?x)\
\
/' => 'Escape literal pattern white space under /x {#} m/(?x)\
{#}\
/',
+ '/((?# This is a comment in the middle of a token)?:foo)/' => 'In \'(?...)\', splitting the initial \'(?\' is deprecated {#} m/((?# This is a comment in the middle of a token)?{#}:foo)/',
+ '/((?# This is a comment in the middle of a token)*FAIL)/' => 'In \'(*VERB...)\', splitting the initial \'(*\' is deprecated {#} m/((?# This is a comment in the middle of a token)*{#}FAIL)/',
+);
+
while (my ($regex, $expect) = splice @death, 0, 2) {
my $expect = fixup_expect($expect);
+ no warnings 'experimental::regex_sets';
# skip the utf8 test on EBCDIC since they do not die
next if $::IS_EBCDIC && $regex =~ /utf8/;
@@ -133,17 +272,48 @@
warning_is(sub {
$_ = "x";
eval $regex;
- like($@, qr/\Q$expect/);
- }, undef, "$regex died without any other warnings");
+ like($@, qr/\Q$expect/, $regex);
+ }, undef, "... and died without any other warnings");
}
-while (my ($regex, $expect) = splice @warning, 0, 2) {
- my $expect = fixup_expect($expect);
- warning_like(sub {
- $_ = "x";
- eval $regex;
- is($@, '', "$regex did not die");
- }, qr/\Q$expect/);
+foreach my $ref (\@warning, \@experimental_regex_sets, \@deprecated) {
+ my $warning_type = ($ref == \@warning)
+ ? 'regexp'
+ : ($ref == \@deprecated)
+ ? 'regexp, deprecated'
+ : 'experimental::regex_sets';
+ while (my ($regex, $expect) = splice @$ref, 0, 2) {
+ my @expect = fixup_expect($expect);
+ {
+ $_ = "x";
+ no warnings;
+ eval $regex;
+ }
+ if (is($@, "", "$regex did not die")) {
+ my @got = capture_warnings(sub {
+ $_ = "x";
+ eval $regex });
+ my $count = @expect;
+ if (! is(scalar @got, scalar @expect, "... and gave expected number ($count) of warnings")) {
+ if (@got < @expect) {
+ $count = @got;
+ note "Expected warnings not gotten:\n\t" . join "\n\t", @expect[$count .. $#expect];
+ }
+ else {
+ note "Unexpected warnings gotten:\n\t" . join("\n\t", @got[$count .. $#got]);
+ }
+ }
+ foreach my $i (0 .. $count - 1) {
+ if (like($got[$i], qr/\Q$expect[$i]/, "... and gave expected warning[$i]")) {
+ ok (0 == capture_warnings(sub {
+ $_ = "x";
+ eval "no warnings '$warning_type'; $regex;" }
+ ),
+ "... and turning off '$warning_type' warnings suppressed it");
+ }
+ }
+ }
+ }
}
done_testing();
Property changes on: trunk/contrib/perl/t/re/reg_mesg.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/re/reg_namedcapture.t
===================================================================
--- trunk/contrib/perl/t/re/reg_namedcapture.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/reg_namedcapture.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/re/reg_namedcapture.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/re/reg_nc_tie.t
===================================================================
--- trunk/contrib/perl/t/re/reg_nc_tie.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/reg_nc_tie.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/re/reg_nc_tie.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/re/reg_pmod.t
===================================================================
--- trunk/contrib/perl/t/re/reg_pmod.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/reg_pmod.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -11,39 +11,65 @@
our @tests = (
# /p Pattern PRE MATCH POST
- [ '/p', "456", "123-", "456", "-789"],
- [ '(?p)', "456", "123-", "456", "-789"],
- [ '', "(456)", "123-", "456", "-789"],
- [ '', "456", undef, undef, undef ],
+ [ '/p', "345", "12-", "345", "-6789"],
+ [ '(?p)', "345", "12-", "345", "-6789"],
+ [ '(?p:)',"345", "12-", "345", "-6789"],
+ [ '', "(345)", undef, undef, undef ],
+ [ '', "345", undef, undef, undef ],
);
-plan tests => 4 * @tests + 2;
+plan tests => 14 * @tests + 4;
my $W = "";
$SIG{__WARN__} = sub { $W.=join("", at _); };
sub _u($$) { "$_[0] is ".(defined $_[1] ? "'$_[1]'" : "undef") }
-$_ = '123-456-789';
foreach my $test (@tests) {
my ($p, $pat,$l,$m,$r) = @$test;
- my $test_name = $p eq '/p' ? "/$pat/p"
- : $p eq '(?p)' ? "/(?p)$pat/"
- : "/$pat/";
+ for my $sub (0,1) {
+ my $test_name = $p eq '/p' ? "/$pat/p"
+ : $p eq '(?p)' ? "/(?p)$pat/"
+ : $p eq '(?p:)'? "/(?p:$pat)/"
+ : "/$pat/";
+ $test_name = "s$test_name" if $sub;
- #
- # Cannot use if/else due to the scope invalidating ${^MATCH} and friends.
- #
- my $ok = ok $p eq '/p' ? /$pat/p
- : $p eq '(?p)' ? /(?p)$pat/
- : /$pat/
- => $test_name;
- SKIP: {
- skip "/$pat/$p failed to match", 3
- unless $ok;
- is(${^PREMATCH}, $l,_u "$test_name: ^PREMATCH",$l);
- is(${^MATCH}, $m,_u "$test_name: ^MATCH",$m );
- is(${^POSTMATCH}, $r,_u "$test_name: ^POSTMATCH",$r );
+ #
+ # Cannot use if/else due to the scope invalidating ${^MATCH} and friends.
+ #
+ $_ = '12-345-6789';
+ my $ok =
+ $sub ?
+ ( $p eq '/p' ? s/$pat/abc/p
+ : $p eq '(?p)' ? s/(?p)$pat/abc/
+ : $p eq '(?p:)'? s/(?p:$pat)/abc/
+ : s/$pat/abc/
+ )
+ :
+ ( $p eq '/p' ? /$pat/p
+ : $p eq '(?p)' ? /(?p)$pat/
+ : $p eq '(?p:)'? /(?p:$pat)/
+ : /$pat/
+ );
+ ok $ok, $test_name;
+ SKIP: {
+ skip "/$pat/$p failed to match", 6
+ unless $ok;
+ is(${^PREMATCH}, $l,_u "$test_name: ^PREMATCH",$l);
+ is(${^MATCH}, $m,_u "$test_name: ^MATCH",$m );
+ is(${^POSTMATCH}, $r,_u "$test_name: ^POSTMATCH",$r );
+ is(length ${^PREMATCH}, length $l, "$test_name: ^PREMATCH length");
+ is(length ${^MATCH}, length $m, "$test_name: ^MATCH length");
+ is(length ${^POSTMATCH},length $r, "$test_name: ^POSTMATCH length");
+ }
}
}
is($W,"","No warnings should be produced");
ok(!defined ${^MATCH}, "No /p in scope so ^MATCH is undef");
+
+#RT 117135
+
+{
+ my $m;
+ ok("a"=~ /(?p:a(?{ $m = ${^MATCH} }))/, '(?{})');
+ is($m, 'a', '(?{}) ^MATCH');
+}
Property changes on: trunk/contrib/perl/t/re/reg_pmod.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/re/reg_posixcc.t
===================================================================
--- trunk/contrib/perl/t/re/reg_posixcc.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/reg_posixcc.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -17,6 +17,10 @@
"\\S",
"\\d",
"\\D",
+ "\\h",
+ "\\H",
+ "\\v",
+ "\\V",
"[:alnum:]",
"[:^alnum:]",
"[:alpha:]",
@@ -97,6 +101,20 @@
$got{"[$no]"}{$type} = $str=~/[$no]/ ? 1 : 0;
$got{"[^$yes]"}{$type} = $str=~/[^$yes]/ ? 1 : 0;
$got{"[^$no]"}{$type} = $str=~/[^$no]/ ? 1 : 0;
+
+ # For \w, \s, and \d, \h, \v, also test without being in character
+ # classes.
+ next if $yes =~ /\[/;
+
+ # The rest of this .t was written when there were many test
+ # failures, so it goes to some lengths to summarize things. Now
+ # those are fixed, so these missing tests just do standard
+ # procedures
+
+ my $chr = chr($b);
+ utf8::upgrade $chr if $type eq 'unicode';
+ ok (($chr =~ /$yes/) != ($chr =~ /$no/),
+ "$type: chr($display_b) isn't both $yes and $no");
}
foreach my $which ("[$yes]","[$no]","[^$yes]","[^$no]") {
if ($got{$which}{'unicode'} != $got{$which}{'not-unicode'}){
Property changes on: trunk/contrib/perl/t/re/reg_posixcc.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/re/regex_sets.t (from rev 6437, vendor/perl/5.18.1/t/re/regex_sets.t)
===================================================================
--- trunk/contrib/perl/t/re/regex_sets.t (rev 0)
+++ trunk/contrib/perl/t/re/regex_sets.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,90 @@
+#!./perl
+
+# This tests (?[...]). XXX These are just basic tests, as full ones would be
+# best done with an infrastructure change to allow getting out the inversion
+# list of the constructed set and then comparing it character by character
+# with the expected result.
+
+use strict;
+use warnings;
+
+$| = 1;
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = ('../lib','.');
+ require './test.pl';
+}
+
+use utf8;
+no warnings 'experimental::regex_sets';
+
+like("a", qr/(?[ [a] # This is a comment
+ ])/, 'Can ignore a comment');
+like("a", qr/(?[ [a] # [[:notaclass:]]
+ ])/, 'A comment isn\'t parsed');
+unlike("\x85", qr/(?[ \t
])/, 'NEL is white space');
+unlike("\x85", qr/(?[ [\t
] ])/, '... including within nested []');
+like("\x85", qr/(?[ \t + \
])/, 'can escape NEL to match');
+like("\x85", qr/(?[ [\
] ])/, '... including within nested []');
+like("\t", qr/(?[ \t + \
])/, 'can do basic union');
+like("\cK", qr/(?[ \s ])/, '\s matches \cK');
+unlike("\cK", qr/(?[ \s - \cK ])/, 'can do basic subtraction');
+like(" ", qr/(?[ \s - \cK ])/, 'can do basic subtraction');
+like(":", qr/(?[ [:] ])/, '[:] is not a posix class');
+unlike("\t", qr/(?[ ! \t ])/, 'can do basic complement');
+like("\t", qr/(?[ ! [ ^ \t ] ])/, 'can do basic complement');
+unlike("\r", qr/(?[ \t ])/, '\r doesn\'t match \t ');
+like("\r", qr/(?[ ! \t ])/, 'can do basic complement');
+like("0", qr/(?[ [:word:] & [:digit:] ])/, 'can do basic intersection');
+unlike("A", qr/(?[ [:word:] & [:digit:] ])/, 'can do basic intersection');
+like("0", qr/(?[[:word:]&[:digit:]])/, 'spaces around internal [] aren\'t required');
+
+like("a", qr/(?[ [a] | [b] ])/, '| means union');
+like("b", qr/(?[ [a] | [b] ])/, '| means union');
+unlike("c", qr/(?[ [a] | [b] ])/, '| means union');
+
+like("a", qr/(?[ [ab] ^ [bc] ])/, 'basic symmetric difference works');
+unlike("b", qr/(?[ [ab] ^ [bc] ])/, 'basic symmetric difference works');
+like("c", qr/(?[ [ab] ^ [bc] ])/, 'basic symmetric difference works');
+
+like("2", qr/(?[ ( ( \pN & ( [a] + [2] ) ) ) ])/, 'Nesting parens and grouping');
+unlike("a", qr/(?[ ( ( \pN & ( [a] + [2] ) ) ) ])/, 'Nesting parens and grouping');
+
+unlike("\x{17f}", qr/(?[ [k] + \p{Blk=ASCII} ])/i, '/i doesn\'t affect \p{}');
+like("\N{KELVIN SIGN}", qr/(?[ [k] + \p{Blk=ASCII} ])/i, '/i does affect literals');
+
+my $thai_or_lao = qr/(?[ \p{Thai} + \p{Lao} ])/;
+my $thai_or_lao_digit = qr/(?[ \p{Digit} & $thai_or_lao ])/;
+like("\N{THAI DIGIT ZERO}", $thai_or_lao_digit, 'embedded qr/(?[ ])/ works');
+unlike(chr(ord("\N{THAI DIGIT ZERO}") - 1), $thai_or_lao_digit, 'embedded qr/(?[ ])/ works');
+like("\N{THAI DIGIT NINE}", $thai_or_lao_digit, 'embedded qr/(?[ ])/ works');
+unlike(chr(ord("\N{THAI DIGIT NINE}") + 1), $thai_or_lao_digit, 'embedded qr/(?[ ])/ works');
+like("\N{LAO DIGIT ZERO}", $thai_or_lao_digit, 'embedded qr/(?[ ])/ works');
+unlike(chr(ord("\N{LAO DIGIT ZERO}") - 1), $thai_or_lao_digit, 'embedded qr/(?[ ])/ works');
+like("\N{LAO DIGIT NINE}", $thai_or_lao_digit, 'embedded qr/(?[ ])/ works');
+unlike(chr(ord("\N{LAO DIGIT NINE}") + 1), $thai_or_lao_digit, 'embedded qr/(?[ ])/ works');
+
+my $ascii_word = qr/(?[ \w ])/a;
+my $ascii_digits_plus_all_of_arabic = qr/(?[ \p{Digit} & $ascii_word + \p{Arabic} ])/;
+like("9", $ascii_digits_plus_all_of_arabic, "/a, then interpolating and intersection works for ASCII in the set");
+unlike("A", $ascii_digits_plus_all_of_arabic, "/a, then interpolating and intersection works for ASCII not in the set");
+unlike("\N{BENGALI DIGIT ZERO}", $ascii_digits_plus_all_of_arabic, "/a, then interpolating and intersection works for non-ASCII not in either set");
+unlike("\N{BENGALI LETTER A}", $ascii_digits_plus_all_of_arabic, "/a, then interpolating and intersection works for non-ASCII in one set");
+like("\N{ARABIC LETTER HAMZA}", $ascii_digits_plus_all_of_arabic, "interpolation and intersection is left-associative");
+like("\N{EXTENDED ARABIC-INDIC DIGIT ZERO}", $ascii_digits_plus_all_of_arabic, "interpolation and intersection is left-associative");
+
+my $kelvin = qr/(?[ \N{KELVIN SIGN} ])/;
+my $fold = qr/(?[ $kelvin ])/i;
+like("\N{KELVIN SIGN}", $kelvin, '"\N{KELVIN SIGN}" matches compiled qr/(?[ \N{KELVIN SIGN} ])/');
+unlike("K", $fold, "/i on outer (?[ ]) doesn't leak to interpolated one");
+unlike("k", $fold, "/i on outer (?[ ]) doesn't leak to interpolated one");
+
+my $kelvin_fold = qr/(?[ \N{KELVIN SIGN} ])/i;
+my $still_fold = qr/(?[ $kelvin_fold ])/;
+like("K", $still_fold, "/i on interpolated (?[ ]) is retained in outer without /i");
+like("k", $still_fold, "/i on interpolated (?[ ]) is retained in outer without /i");
+
+done_testing();
+
+1;
Copied: trunk/contrib/perl/t/re/regex_sets_compat.t (from rev 6437, vendor/perl/5.18.1/t/re/regex_sets_compat.t)
===================================================================
--- trunk/contrib/perl/t/re/regex_sets_compat.t (rev 0)
+++ trunk/contrib/perl/t/re/regex_sets_compat.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,15 @@
+#!./perl
+
+# This tests that the (?[...]) feature doesn't introduce unexpected
+# differences from regular bracketed character classes. It just sets a flag
+# and calls regexp.t which will run through its test suite, modifiying the
+# tests to use (?[...]) instead wherever the test uses [].
+
+BEGIN { $regex_sets = 1; }
+for $file ('./re/regexp.t', './t/re/regexp.t', ':re:regexp.t') {
+ if (-r $file) {
+ do $file or die $@;
+ exit;
+ }
+}
+die "Cannot find ./re/regexp.t or ./t/re/regexp.t\n";
Modified: trunk/contrib/perl/t/re/regexp.t
===================================================================
--- trunk/contrib/perl/t/re/regexp.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/regexp.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -18,6 +18,8 @@
# B test exposes a known bug in Perl, should be skipped
# b test exposes a known bug in Perl, should be skipped if noamp
# t test exposes a bug with threading, TODO if qr_embed_thr
+# s test should only be run for regex_sets_compat.t
+# S test should not be run for regex_sets_compat.t
#
# Columns 4 and 5 are used only if column 3 contains C<y> or C<c>.
#
@@ -44,7 +46,7 @@
# Note that columns 2,3 and 5 are all enclosed in double quotes and then
# evalled; so something like a\"\x{100}$1 has length 3+length($1).
-my $file;
+my ($file, $iters);
BEGIN {
$iters = shift || 1; # Poor man performance suite, 10000 is OK.
@@ -59,15 +61,20 @@
}
+sub _comment {
+ return map { /^#/ ? "$_\n" : "# $_\n" }
+ map { split /\n/ } @_;
+}
+
use strict;
use warnings FATAL=>"all";
-use vars qw($iters $numtests $bang $ffff $nulnul $OP);
-use vars qw($qr $skip_amp $qr_embed $qr_embed_thr); # set by our callers
+use vars qw($bang $ffff $nulnul); # used by the tests
+use vars qw($qr $skip_amp $qr_embed $qr_embed_thr $regex_sets); # set by our callers
+
if (!defined $file) {
- open(TESTS,'re/re_tests') || open(TESTS,'t/re/re_tests')
- || open(TESTS,':re:re_tests') || die "Can't open re_tests";
+ open TESTS, 're/re_tests' or die "Can't open re/re_tests: $!";
}
my @tests = <TESTS>;
@@ -77,7 +84,7 @@
$bang = sprintf "\\%03o", ord "!"; # \41 would not be portable.
$ffff = chr(0xff) x 2;
$nulnul = "\0" x 2;
-$OP = $qr ? 'qr' : 'm';
+my $OP = $qr ? 'qr' : 'm';
$| = 1;
printf "1..%d\n# $iters iterations\n", scalar @tests;
@@ -92,7 +99,7 @@
next;
}
chomp;
- s/\\n/\n/g;
+ s/\\n/\n/g unless $regex_sets;
my ($pat, $subject, $result, $repl, $expect, $reason) = split(/\t/,$_,6);
$reason = '' unless defined $reason;
my $input = join(':',$pat,$subject,$result,$repl,$expect);
@@ -99,7 +106,7 @@
# the double '' below keeps simple syntax highlighters from going crazy
$pat = "'$pat'" unless $pat =~ /^[:''\/]/;
$pat =~ s/(\$\{\w+\})/$1/eeg;
- $pat =~ s/\\n/\n/g;
+ $pat =~ s/\\n/\n/g unless $regex_sets;
$subject = eval qq("$subject"); die $@ if $@;
$expect = eval qq("$expect"); die $@ if $@;
$expect = $repl = '-' if $skip_amp and $input =~ /\$[&\`\']/;
@@ -106,11 +113,197 @@
my $todo_qr = $qr_embed_thr && ($result =~ s/t//);
my $skip = ($skip_amp ? ($result =~ s/B//i) : ($result =~ s/B//));
++$skip if $result =~ s/M// && !defined &DynaLoader::boot_DynaLoader;
+ if ($result =~ s/ ( [Ss] ) //x) {
+ if (($1 eq 'S' && $regex_sets) || ($1 eq 's' && ! $regex_sets)) {
+ $skip++;
+ $reason = "Test not valid for $0";
+ }
+ }
$reason = 'skipping $&' if $reason eq '' && $skip_amp;
$result =~ s/B//i unless $skip;
my $todo= $result =~ s/T// ? " # TODO" : "";
-
+ if (! $skip && $regex_sets) {
+ # If testing regex sets, change the [bracketed] classes into
+ # (?[bracketed]).
+
+ if ($pat !~ / \[ /x) {
+
+ $skip++;
+ $reason = "Pattern doesn't contain [brackets]";
+ }
+ else { # Use non-regex features of Perl to accomplish this.
+ my $modified = "";
+ my $in_brackets = 0;
+
+ # Go through the pattern character-by-character. We also add
+ # blanks around each token to test the /x parts of (?[ ])
+ my $pat_len = length($pat);
+ CHAR: for (my $i = 0; $i < $pat_len; $i++) {
+ my $curchar = substr($pat, $i, 1);
+ if ($curchar eq '\\') {
+ $modified .= " " if $in_brackets;
+ $modified .= $curchar;
+ $i++;
+
+ # Get the character the backslash is escaping
+ $curchar = substr($pat, $i, 1);
+ $modified .= $curchar;
+
+ # If the character following that is a '{}', treat the
+ # entire amount as a single token
+ if ($i < $pat_len -1 && substr($pat, $i+1, 1) eq '{') {
+ my $j = index($pat, '}', $i+2);
+ if ($j < 0) {
+ last unless $in_brackets;
+ if ($result eq 'c') {
+ $skip++;
+ $reason = "Can't handle compilation errors with unmatched '{'";
+ }
+ else {
+ print "not ok $test # Problem in $0; original = '$pat'; mod = '$modified'\n";
+ next TEST;
+ }
+ }
+ $modified .= substr($pat, $i+1, $j - $i);
+ $i = $j;
+ }
+ elsif ($curchar eq 'x') {
+
+ # \x without brackets is supposed to be followed by 2
+ # hex digits. Take up to 2, and then add a blank
+ # after the last one. This avoids getting errors from
+ # (?[ ]) for run-ons, like \xabc
+ my $j = $i + 1;
+ for (; $j < $i + 3 && $j < $pat_len; $j++) {
+ my $curord = ord(substr($pat, $j, 1));
+ if (!(($curord >= ord("A") && $curord <= ord("F"))
+ || ($curord >= ord("a") && $curord <= ord("f"))
+ || ($curord >= ord("0") && $curord <= ord("9"))))
+ {
+ $j++;
+ last;
+ }
+ }
+ $j--;
+ $modified .= substr($pat, $i + 1, $j - $i) . " ";
+ $i = $j;
+ }
+ elsif (ord($curchar) >= ord('0')
+ && (ord($curchar) <= ord('7')))
+ {
+ # Similarly, octal constants have up to 3 digits.
+ my $j = $i + 1;
+ for (; $j < $i + 3 && $j < $pat_len; $j++) {
+ my $curord = ord(substr($pat, $j, 1));
+ if (! ($curord >= ord("0") && $curord <= ord("7"))) {
+ $j++;
+ last;
+ }
+ }
+ $j--;
+ $modified .= substr($pat, $i + 1, $j - $i);
+ $i = $j;
+ }
+
+ next;
+ } # End of processing a backslash sequence
+
+ if (! $in_brackets # Skip (?{ })
+ && $curchar eq '('
+ && $i < $pat_len - 2
+ && substr($pat, $i+1, 1) eq '?'
+ && substr($pat, $i+2, 1) eq '{')
+ {
+ $skip++;
+ $reason = "Pattern contains '(?{'";
+ last;
+ }
+
+ # Closing ']'
+ if ($curchar eq ']' && $in_brackets) {
+ $modified .= " ] ])";
+ $in_brackets = 0;
+ next;
+ }
+
+ # A regular character.
+ if ($curchar ne '[') {
+ if (! $in_brackets) {
+ $modified .= $curchar;
+ }
+ else {
+ $modified .= " $curchar ";
+ }
+ next;
+ }
+
+ # Here is a '['; If not in a bracketed class, treat as the
+ # beginning of one.
+ if (! $in_brackets) {
+ $in_brackets = 1;
+ $modified .= "(?[ [ ";
+
+ # An immediately following ']' or '^]' is not the ending
+ # of the class, but is to be treated literally.
+ if ($i < $pat_len - 1
+ && substr($pat, $i+1, 1) eq ']')
+ {
+ $i ++;
+ $modified .= " ] ";
+ }
+ elsif ($i < $pat_len - 2
+ && substr($pat, $i+1, 1) eq '^'
+ && substr($pat, $i+2, 1) eq ']')
+ {
+ $i += 2;
+ $modified .= " ^ ] ";
+ }
+ next;
+ }
+
+ # Here is a plain '[' within [ ]. Could mean wants to
+ # match a '[', or it could be a posix class that has a
+ # corresponding ']'. Absorb either
+
+ $modified .= ' [';
+ last if $i >= $pat_len - 1;
+
+ $i++;
+ $curchar = substr($pat, $i, 1);
+ if ($curchar =~ /[:=.]/) {
+ for (my $j = $i + 1; $j < $pat_len; $j++) {
+ next unless substr($pat, $j, 1) eq ']';
+ last if $j - $i < 2;
+ if (substr($pat, $j - 1, 1) eq $curchar) {
+ # Here, is a posix class
+ $modified .= substr($pat, $i, $j - $i + 1) . " ";
+ $i = $j;
+ next CHAR;
+ }
+ }
+ }
+
+ # Here wasn't a posix class, just process normally
+ $modified .= " $curchar ";
+ }
+
+ if ($in_brackets && ! $skip) {
+ if ($result eq 'c') {
+ $skip++;
+ $reason = "Can't figure out where to put the (?[ and ]) since is a compilation error";
+ }
+ else {
+ print "not ok $test # Problem in $0; original = '$pat'; mod = '$modified'\n";
+ next TEST;
+ }
+ }
+
+ # Use our modified pattern instead of the original
+ $pat = $modified;
+ }
+ }
+
for my $study ('', 'study $subject', 'utf8::upgrade($subject)',
'utf8::upgrade($subject); study $subject') {
# Need to make a copy, else the utf8::upgrade of an already studied
@@ -151,6 +344,7 @@
\$got = "$repl";
EOFCODE
}
+ $code = "no warnings 'experimental::regex_sets';$code" if $regex_sets;
#$code.=qq[\n\$expect="$expect";\n];
#use Devel::Peek;
#die Dump($code) if $pat=~/\\h/ and $subject=~/\x{A0}/;
@@ -162,20 +356,20 @@
eval $code;
}
chomp( my $err = $@ );
- if ($result eq 'c') {
- if ($err !~ m!^\Q$expect!) { print "not ok $test$todo (compile) $input => `$err'\n"; next TEST }
+ if ( $skip ) {
+ print "ok $test # skipped", length($reason) ? ". $reason" : '', "\n";
+ next TEST;
+ }
+ elsif ($result eq 'c') {
+ if ($err !~ m!^\Q$expect!) { print "not ok $test$todo (compile) $input => '$err'\n"; next TEST }
last; # no need to study a syntax error
}
- elsif ( $skip ) {
- print "ok $test # skipped", length($reason) ? " $reason" : '', "\n";
- next TEST;
- }
elsif ( $todo_qr ) {
print "not ok $test # TODO", length($reason) ? " - $reason" : '', "\n";
next TEST;
}
elsif ($@) {
- print "not ok $test$todo $input => error `$err'\n$code\n$@\n"; next TEST;
+ print "not ok $test$todo $input => error '$err'\n", _comment("$code\n$@\n"); next TEST;
}
elsif ($result =~ /^n/) {
if ($match) { print "not ok $test$todo ($study) $input => false positive\n"; next TEST }
@@ -183,13 +377,18 @@
else {
if (!$match || $got ne $expect) {
eval { require Data::Dumper };
- if ($@) {
- print "not ok $test$todo ($study) $input => `$got', match=$match\n$code\n";
+ no warnings "utf8"; # But handle should be utf8
+ if ($@ || !defined &DynaLoader::boot_DynaLoader) {
+ # Data::Dumper will load on miniperl, but fail when used in
+ # anger as it tries to load B. I'd prefer to keep the
+ # regular calls below outside of an eval so that real
+ # (unknown) failures get spotted, not ignored.
+ print "not ok $test$todo ($study) $input => '$got', match=$match\n", _comment("$code\n");
}
else { # better diagnostics
my $s = Data::Dumper->new([$subject],['subject'])->Useqq(1)->Dump;
my $g = Data::Dumper->new([$got],['got'])->Useqq(1)->Dump;
- print "not ok $test$todo ($study) $input => `$got', match=$match\n$s\n$g\n$code\n";
+ print "not ok $test$todo ($study) $input => '$got', match=$match\n", _comment("$s\n$g\n$code\n");
}
next TEST;
}
Property changes on: trunk/contrib/perl/t/re/regexp.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/re/regexp_noamp.t
===================================================================
--- trunk/contrib/perl/t/re/regexp_noamp.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/regexp_noamp.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,5 +1,7 @@
#!./perl
+# Doesn't look at the expect field if it contains $&.
+
$skip_amp = 1;
for $file ('./re/regexp.t', './t/re/regexp.t', ':re:regexp.t') {
if (-r $file) {
Property changes on: trunk/contrib/perl/t/re/regexp_noamp.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/re/regexp_notrie.t
===================================================================
--- trunk/contrib/perl/t/re/regexp_notrie.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/regexp_notrie.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/re/regexp_notrie.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/re/regexp_qr.t
===================================================================
--- trunk/contrib/perl/t/re/regexp_qr.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/regexp_qr.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/re/regexp_qr.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/re/regexp_qr_embed.t
===================================================================
--- trunk/contrib/perl/t/re/regexp_qr_embed.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/regexp_qr_embed.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/re/regexp_qr_embed.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/re/regexp_qr_embed_thr.t
===================================================================
--- trunk/contrib/perl/t/re/regexp_qr_embed_thr.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/regexp_qr_embed_thr.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/re/regexp_qr_embed_thr.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/re/regexp_trielist.t
===================================================================
--- trunk/contrib/perl/t/re/regexp_trielist.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/regexp_trielist.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/re/regexp_trielist.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/re/regexp_unicode_prop.t
===================================================================
--- trunk/contrib/perl/t/re/regexp_unicode_prop.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/regexp_unicode_prop.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -91,6 +91,8 @@
InNotKana => ['\x{3040}', '!\x{3041}'],
InConsonant => ['d', '!e'],
IsSyriac1 => ['\x{0712}', '!\x{072F}'],
+ IsSyriac1KanaMark => ['\x{309A}', '!\x{3090}'],
+ IsSyriac1KanaMark => ['\x{0730}', '!\x{0712}'],
'# User-defined character properties may lack \n at the end',
InGreekSmall => ['\N{GREEK SMALL LETTER PI}',
'\N{GREEK SMALL LETTER FINAL SIGMA}'],
@@ -186,29 +188,29 @@
my ($str, $name);
- given ($char) {
- when (/^\\/) {
- $str = eval qq ["$char"];
- $name = qq ["$char"];
- }
- when (/^0x([0-9A-Fa-f]+)$/) {
- $str = chr hex $1;
- $name = "chr ($char)";
- }
- default {
- $str = $char;
- $name = qq ["$char"];
- }
+ if ($char =~ /^\\/) {
+ $str = eval qq ["$char"];
+ $name = qq ["$char"];
}
+ elsif ($char =~ /^0x([0-9A-Fa-f]+)$/) {
+ $str = chr hex $1;
+ $name = "chr ($char)";
+ }
+ else {
+ $str = $char;
+ $name = qq ["$char"];
+ }
undef $@;
- my $match_pat = eval "qr/$match/$caseless";
- is($@, '', "$name compiled correctly to a regexp");
+ my $pat = "qr/$match/$caseless";
+ my $match_pat = eval $pat;
+ is($@, '', "$pat compiled correctly to a regexp: $@");
like($str, $match_pat, "$name correctly matched");
undef $@;
- my $nomatch_pat = eval "qr/$nomatch/$caseless";
- is($@, '', "$name compiled correctly to a regexp");
+ $pat = "qr/$nomatch/$caseless";
+ my $nomatch_pat = eval $pat;
+ is($@, '', "$pat compiled correctly to a regexp: $@");
unlike($str, $nomatch_pat, "$name correctly did not match");
}
@@ -342,6 +344,13 @@
}
}
+# Verify that can use user-defined properties inside another one
+sub IsSyriac1KanaMark {<<'--'}
++main::IsSyriac1
++main::InKana3
+&utf8::IsMark
+--
+
# fake user-defined properties; these subs shouldn't be called, because
# their names don't start with In or Is
Property changes on: trunk/contrib/perl/t/re/regexp_unicode_prop.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/re/regexp_unicode_prop_thr.t
===================================================================
--- trunk/contrib/perl/t/re/regexp_unicode_prop_thr.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/regexp_unicode_prop_thr.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/re/regexp_unicode_prop_thr.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/re/rxcode.t
===================================================================
--- trunk/contrib/perl/t/re/rxcode.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/rxcode.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -6,7 +6,7 @@
require './test.pl';
}
-plan tests => 38;
+plan tests => 39;
$^R = undef;
like( 'a', qr/^a(?{1})(?:b(?{2}))?/, 'a =~ ab?' );
@@ -84,3 +84,10 @@
ok( 'abbb' =~ /^a(?{36})(?:b(?{37})|c(?{38}))+/, 'abbbb =~ a(?:b|c)+' );
ok( $^R == 37, '$^R == 37' ) or print "# \$^R=$^R\n";
}
+
+# Broken temporarily by the jumbo re-eval rewrite in 5.17.1; fixed in .6
+{
+ use re 'eval';
+ $x = "(?{})";
+ is eval { "a" =~ /a++(?{})+$x/x } || $@, '1', '/a++(?{})+$code_block/'
+}
Property changes on: trunk/contrib/perl/t/re/rxcode.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/re/subst.t
===================================================================
--- trunk/contrib/perl/t/re/subst.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/subst.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -4,10 +4,10 @@
chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
+ require './test.pl';
}
-require './test.pl';
-plan( tests => 176 );
+plan( tests => 206 );
$_ = 'david';
$a = s/david/rules/r;
@@ -746,6 +746,8 @@
# when substituted with a UTF8 replacement string, due to
# magic getting called multiple times, and pointers now pointing
# to stale/freed strings
+ # The original fix for this caused infinite loops for non- or cow-
+ # strings, so we test those, too.
package FOO;
my $fc;
sub TIESCALAR { bless [ "abcdefgh" ] }
@@ -757,4 +759,130 @@
$s =~ s/..../\x{101}/;
::is($fc, 1, "tied UTF8 stuff FETCH count");
::is("$s", "\x{101}efgh", "tied UTF8 stuff");
+
+ ::watchdog(300);
+ $fc = 0;
+ $s = *foo;
+ $s =~ s/..../\x{101}/;
+ ::is($fc, 1, '$tied_glob =~ s/non-utf8/utf8/ fetch count');
+ ::is("$s", "\x{101}::foo", '$tied_glob =~ s/non-utf8/utf8/ result');
+ $fc = 0;
+ $s = *foo;
+ $s =~ s/(....)/\x{101}/g;
+ ::is($fc, 1, '$tied_glob =~ s/(non-utf8)/utf8/g fetch count');
+ ::is("$s", "\x{101}\x{101}o",
+ '$tied_glob =~ s/(non-utf8)/utf8/g result');
+ $fc = 0;
+ $s = "\xff\xff\xff\xff\xff";
+ $s =~ s/..../\x{101}/;
+ ::is($fc, 1, '$tied_latin1 =~ s/non-utf8/utf8/ fetch count');
+ ::is("$s", "\x{101}\xff", '$tied_latin1 =~ s/non-utf8/utf8/ result');
+ $fc = 0;
+ { package package_name; tied($s)->[0] = __PACKAGE__ };
+ $s =~ s/..../\x{101}/;
+ ::is($fc, 1, '$tied_cow =~ s/non-utf8/utf8/ fetch count');
+ ::is("$s", "\x{101}age_name", '$tied_cow =~ s/non-utf8/utf8/ result');
+ $fc = 0;
+ $s = \1;
+ $s =~ s/..../\x{101}/;
+ ::is($fc, 1, '$tied_ref =~ s/non-utf8/utf8/ fetch count');
+ ::like("$s", qr/^\x{101}AR\(0x.*\)\z/,
+ '$tied_ref =~ s/non-utf8/utf8/ result');
}
+
+# RT #97954
+{
+ my $count;
+
+ sub bam::DESTROY {
+ --$count;
+ }
+
+ my $z_zapp = bless [], 'bam';
+ ++$count;
+
+ is($count, 1, '1 object');
+ is($z_zapp =~ s/.*/R/r, 'R', 'substitution happens');
+ is(ref $z_zapp, 'bam', 'still 1 object');
+ is($count, 1, 'still 1 object');
+ undef $z_zapp;
+ is($count, 0, 'now 0 objects');
+
+ $z_zapp = bless [], 'bam';
+ ++$count;
+
+ is($count, 1, '1 object');
+ like($z_zapp =~ s/./R/rg, qr/\AR{8,}\z/, 'substitution happens');
+ is(ref $z_zapp, 'bam', 'still 1 object');
+ is($count, 1, 'still 1 object');
+ undef $z_zapp;
+ is($count, 0, 'now 0 objects');
+}
+
+is(*bam =~ s/\*//r, 'main::bam', 'Can s///r a tyepglob');
+is(*bam =~ s/\*//rg, 'main::bam', 'Can s///rg a tyepglob');
+
+{
+ sub cowBug::TIESCALAR { bless[], 'cowBug' }
+ sub cowBug::FETCH { __PACKAGE__ }
+ sub cowBug::STORE{}
+ tie my $kror, cowBug =>;
+ $kror =~ s/(?:)/""/e;
+}
+pass("s/// on tied var returning a cow");
+
+# a test for 6502e08109cd003b2cdf39bc94ef35e52203240b
+# previously this would segfault
+
+{
+ my $s = "abc";
+ eval { $s =~ s/(.)/die/e; };
+ like($@, qr/Died at/, "s//die/e");
+}
+
+
+# Test problems with constant replacement optimisation
+# [perl #26986] logop in repl resulting in incorrect optimisation
+"g" =~ /(.)/;
+ at l{'a'..'z'} = 'A'..':';
+$_ = "hello";
+{ s/(.)/$l{my $a||$1}/g }
+is $_, "HELLO",
+ 'logop in s/// repl does not result in "constant" repl optimisation';
+# Aliases to match vars
+"g" =~ /(.)/;
+$_ = "hello";
+{
+ local *a = *1;
+ s/(.)\1/$a/g;
+}
+is $_, 'helo', 's/pat/$alias_to_match_var/';
+"g" =~ /(.)/;
+$_ = "hello";
+{
+ local *a = *1;
+ s/e(.)\1/a$a/g;
+}
+is $_, 'halo', 's/pat/$alias_to_match_var/';
+# Last-used pattern containing re-evals that modify "constant" rhs
+{
+ local *a;
+ $x = "hello";
+ $x =~ /(?{*a = \"a"})./;
+ undef *a;
+ $x =~ s//$a/g;
+ is $x, 'aaaaa',
+ 'last-used pattern disables constant repl optimisation';
+}
+
+
+$_ = "\xc4\x80";
+$a = "";
+utf8::upgrade $a;
+$_ =~ s/$/$a/;
+is $_, "\xc4\x80", "empty utf8 repl does not result in mangled utf8";
+
+$@ = "\x{30cb}eval 18";
+$@ =~ s/eval \d+/eval 11/;
+is $@, "\x{30cb}eval 11",
+ 'loading utf8 tables does not interfere with matches against $@';
Property changes on: trunk/contrib/perl/t/re/subst.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/re/substT.t
===================================================================
--- trunk/contrib/perl/t/re/substT.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/substT.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/re/substT.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/re/subst_amp.t
===================================================================
--- trunk/contrib/perl/t/re/subst_amp.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/subst_amp.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/re/subst_amp.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/re/subst_wamp.t
===================================================================
--- trunk/contrib/perl/t/re/subst_wamp.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/subst_wamp.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/re/subst_wamp.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/re/substr.t
===================================================================
--- trunk/contrib/perl/t/re/substr.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/substr.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/re/substr.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/re/substr_thr.t
===================================================================
--- trunk/contrib/perl/t/re/substr_thr.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/substr_thr.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/re/substr_thr.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/re/uniprops.t
===================================================================
--- trunk/contrib/perl/t/re/uniprops.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/re/uniprops.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/re/uniprops.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/run/cloexec.t
===================================================================
--- trunk/contrib/perl/t/run/cloexec.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/run/cloexec.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -43,12 +43,9 @@
$|=1;
-my $Is_VMS = $^O eq 'VMS';
-my $Is_Win32 = $^O eq 'MSWin32';
-
# When in doubt, skip.
-skip_all("VMS") if $Is_VMS;
-skip_all("Win32") if $Is_Win32;
+skip_all($^O)
+ if $^O eq 'VMS' or $^O eq 'MSWin32';
sub make_tmp_file {
my ($fname, $fcontents) = @_;
@@ -59,7 +56,7 @@
}
my $Perl = which_perl();
-my $quote = $Is_VMS || $Is_Win32 ? '"' : "'";
+my $quote = "'";
my $tmperr = tempfile();
my $tmpfile1 = tempfile();
Property changes on: trunk/contrib/perl/t/run/cloexec.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Copied: trunk/contrib/perl/t/run/dtrace.pl (from rev 6437, vendor/perl/5.18.1/t/run/dtrace.pl)
===================================================================
--- trunk/contrib/perl/t/run/dtrace.pl (rev 0)
+++ trunk/contrib/perl/t/run/dtrace.pl 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1 @@
+42
Copied: trunk/contrib/perl/t/run/dtrace.t (from rev 6437, vendor/perl/5.18.1/t/run/dtrace.t)
===================================================================
--- trunk/contrib/perl/t/run/dtrace.t (rev 0)
+++ trunk/contrib/perl/t/run/dtrace.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,196 @@
+#!./perl
+
+my $Perl;
+my $dtrace;
+
+BEGIN {
+ chdir 't';
+ @INC = '../lib';
+ require './test.pl';
+
+ skip_all_without_config("usedtrace");
+
+ $dtrace = $Config::Config{dtrace};
+
+ $Perl = which_perl();
+
+ `$dtrace -V` or skip_all("$dtrace unavailable");
+
+ my $result = `$dtrace -qnBEGIN -c'$Perl -e 1' 2>&1`;
+ $? && skip_all("Apparently can't probe using $dtrace (perhaps you need root?): $result");
+}
+
+use strict;
+use warnings;
+use IPC::Open2;
+
+plan(tests => 9);
+
+dtrace_like(
+ '1',
+ 'BEGIN { trace(42+666) }',
+ qr/708/,
+ 'really running DTrace',
+);
+
+dtrace_like(
+ 'package My;
+ sub outer { Your::inner() }
+ package Your;
+ sub inner { }
+ package Other;
+ My::outer();
+ Your::inner();',
+
+ 'sub-entry { printf("-> %s::%s at %s line %d!\n", copyinstr(arg3), copyinstr(arg0), copyinstr(arg1), arg2) }
+ sub-return { printf("<- %s::%s at %s line %d!\n", copyinstr(arg3), copyinstr(arg0), copyinstr(arg1), arg2) }',
+
+ qr/-> My::outer at - line 2!
+-> Your::inner at - line 4!
+<- Your::inner at - line 4!
+<- My::outer at - line 2!
+-> Your::inner at - line 4!
+<- Your::inner at - line 4!/,
+
+ 'traced multiple function calls',
+);
+
+dtrace_like(
+ '1',
+ 'phase-change { printf("%s -> %s; ", copyinstr(arg1), copyinstr(arg0)) }',
+ qr/START -> RUN; RUN -> DESTRUCT;/,
+ 'phase changes of a simple script',
+);
+
+# this code taken from t/opbasic/magic_phase.t which tests all of the
+# transitions of ${^GLOBAL_PHASE}. instead of printing (which will
+# interact nondeterministically with the DTrace output), we increment
+# an unused variable for side effects
+dtrace_like(<< 'MAGIC_OP',
+ my $x = 0;
+ BEGIN { $x++ }
+ CHECK { $x++ }
+ INIT { $x++ }
+ sub Moo::DESTROY { $x++ }
+
+ my $tiger = bless {}, Moo::;
+
+ sub Kooh::DESTROY { $x++ }
+
+ our $affe = bless {}, Kooh::;
+
+ END { $x++ }
+MAGIC_OP
+
+ 'phase-change { printf("%s -> %s; ", copyinstr(arg1), copyinstr(arg0)) }',
+
+ qr/START -> CHECK; CHECK -> INIT; INIT -> RUN; RUN -> END; END -> DESTRUCT;/,
+
+ 'phase-changes in a script that exercises all of ${^GLOBAL_PHASE}',
+);
+
+dtrace_like(<< 'PHASES',
+ my $x = 0;
+ sub foo { $x++ }
+ sub bar { $x++ }
+ sub baz { $x++ }
+
+ INIT { foo() }
+ bar();
+ END { baz() }
+PHASES
+
+ '
+ BEGIN { starting = 1 }
+
+ phase-change { phase = arg0 }
+ phase-change /copyinstr(arg0) == "RUN"/ { starting = 0 }
+ phase-change /copyinstr(arg0) == "END"/ { ending = 1 }
+
+ sub-entry /copyinstr(arg0) != copyinstr(phase) && (starting || ending)/ {
+ printf("%s during %s; ", copyinstr(arg0), copyinstr(phase));
+ }
+ ',
+
+ qr/foo during INIT; baz during END;/,
+
+ 'make sure sub-entry and phase-change interact well',
+);
+
+dtrace_like(<< 'PERL_SCRIPT',
+ my $tmp = "foo";
+ $tmp =~ s/f/b/;
+ chop $tmp;
+PERL_SCRIPT
+ << 'D_SCRIPT',
+ op-entry { printf("op-entry <%s>\n", copyinstr(arg0)) }
+D_SCRIPT
+ [
+ qr/op-entry <subst>/,
+ qr/op-entry <schop>/,
+ ],
+ 'basic op probe',
+);
+
+dtrace_like(<< 'PERL_SCRIPT',
+ use strict;
+ require HTTP::Tiny;
+ do "run/dtrace.pl";
+PERL_SCRIPT
+ << 'D_SCRIPT',
+ loading-file { printf("loading-file <%s>\n", copyinstr(arg0)) }
+ loaded-file { printf("loaded-file <%s>\n", copyinstr(arg0)) }
+D_SCRIPT
+ [
+ # the original test made sure that each file generated a loading-file then a loaded-file,
+ # but that had a race condition when the kernel would push the perl process onto a different
+ # CPU, so the DTrace output would appear out of order
+ qr{loading-file <strict\.pm>.*loading-file <HTTP/Tiny\.pm>.*loading-file <run/dtrace\.pl>}s,
+ qr{loaded-file <strict\.pm>.*loaded-file <HTTP/Tiny\.pm>.*loaded-file <run/dtrace\.pl>}s,
+ ],
+ 'loading-file, loaded-file probes',
+);
+
+sub dtrace_like {
+ my $perl = shift;
+ my $probes = shift;
+ my $expected = shift;
+ my $name = shift;
+
+ my ($reader, $writer);
+
+ my $pid = open2($reader, $writer,
+ $dtrace,
+ '-q',
+ '-n', 'BEGIN { trace("ready!\n") }', # necessary! see below
+ '-n', $probes,
+ '-c', $Perl,
+ );
+
+ # wait until DTrace tells us that it is initialized
+ # otherwise our probes won't properly fire
+ chomp(my $throwaway = <$reader>);
+ $throwaway eq "ready!" or die "Unexpected 'ready!' result from DTrace: $throwaway";
+
+ # now we can start executing our perl
+ print $writer $perl;
+ close $writer;
+
+ # read all the dtrace results back in
+ local $/;
+ my $result = <$reader>;
+
+ # make sure that dtrace is all done and successful
+ waitpid($pid, 0);
+ my $child_exit_status = $? >> 8;
+ die "Unexpected error from DTrace: $result"
+ if $child_exit_status != 0;
+
+ if (ref($expected) eq 'ARRAY') {
+ like($result, $_, $name) for @$expected;
+ }
+ else {
+ like($result, $expected, $name);
+ }
+}
+
Index: trunk/contrib/perl/t/run/exit.t
===================================================================
--- trunk/contrib/perl/t/run/exit.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/run/exit.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/run/exit.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/run/fresh_perl.t
===================================================================
--- trunk/contrib/perl/t/run/fresh_perl.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/run/fresh_perl.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -81,7 +81,7 @@
########
$x=0x0eabcd; print $x->ref;
EXPECT
-Can't call method "ref" without a package or object reference at - line 1.
+Can't locate object method "ref" via package "961485" (perhaps you forgot to load "961485"?) at - line 1.
########
chop ($str .= <DATA>);
########
@@ -349,15 +349,12 @@
@x = foo(' x y z ');
print "you die joe!\n" unless "@x" eq 'x y z';
########
-/(?{"{"})/ # Check it outside of eval too
+"A" =~ /(?{"{"})/ # Check it outside of eval too
EXPECT
-Sequence (?{...}) not terminated or not {}-balanced in regex; marked by <-- HERE in m/(?{ <-- HERE "{"})/ at - line 1.
########
/(?{"{"}})/ # Check it outside of eval too
EXPECT
-Unmatched right curly bracket at (re_eval 1) line 1, at end of line
-syntax error at (re_eval 1) line 1, near ""{"}"
-Compilation failed in regexp at - line 1.
+Sequence (?{...}) not terminated with ')' at - line 1.
########
BEGIN { @ARGV = qw(a b c d e) }
BEGIN { print "argv <@ARGV>\nbegin <",shift,">\n" }
@@ -761,49 +758,30 @@
foo at - line 1.
######## glob() bug Mon, 01 Sep 2003 02:25:41 -0700 <200309010925.h819Pf0X011457 at smtp3.ActiveState.com>
-lw
-BEGIN {
- if ($^O eq 'os390') {
- require File::Glob;
- import File::Glob ':glob';
- }
+# Make sure the presence of the CORE::GLOBAL::glob typeglob does not affect
+# whether File::Glob::csh_glob is called.
+if ($^O eq 'VMS') {
+ # A pattern with a double quote in it is a syntax error to LIB$FIND_FILE
+ # Should we strip quotes in Perl_vms_start_glob the way csh_glob() does?
+ print "ok1\nok2\n";
}
-BEGIN {
- eval 'require Fcntl';
- if ($@) { print qq[./"TEST"\n./"TEST"\n]; exit 0 } # running minitest?
+else {
+ ++$INC{"File/Glob.pm"}; # prevent it from loading
+ my $called1 =
+ my $called2 = 0;
+ *File::Glob::csh_glob = sub { ++$called1 };
+ my $output1 = eval q{ glob(q(./"TEST")) };
+ undef *CORE::GLOBAL::glob; # but leave the typeglob itself there
+ ++$CORE::GLOBAL::glob if 0; # "used only once"
+ undef *File::Glob::csh_glob; # avoid redefinition warnings
+ *File::Glob::csh_glob = sub { ++$called2 };
+ my $output2 = eval q{ glob(q(./"TEST")) };
+ print "ok1" if $called1 eq $called2;
+ print "ok2" if $output1 eq $output2;
}
-if ($^O eq 'VMS') { # VMS is not *that* kind of a glob.
-print qq[./"TEST"\n./"TEST"\n];
-} else {
-print glob(q(./"TEST"));
-use File::Glob;
-print glob(q(./"TEST"));
-}
EXPECT
-./"TEST"
-./"TEST"
-######## glob() bug Mon, 01 Sep 2003 02:25:41 -0700 <200309010925.h819Pf0X011457 at smtp3.ActiveState.com>
--lw
-BEGIN {
- if ($^O eq 'os390') {
- require File::Glob;
- import File::Glob ':glob';
- }
-}
-BEGIN {
- eval 'require Fcntl';
- if ($@) { print qq[./"TEST"\n./"TEST"\n]; exit 0 } # running minitest?
-}
-if ($^O eq 'VMS') { # VMS is not *that* kind of a glob.
-print qq[./"TEST"\n./"TEST"\n];
-} else {
-use File::Glob;
-print glob(q(./"TEST"));
-use File::Glob;
-print glob(q(./"TEST"));
-}
-EXPECT
-./"TEST"
-./"TEST"
+ok1
+ok2
######## "#75146: 27e904532594b7fb (fix for #23810) introduces a #regression"
use strict;
@@ -844,3 +822,55 @@
print "If you get here, you didn't crash\n";
EXPECT
If you get here, you didn't crash
+######## [perl #112312] crash on syntax error
+# SKIP: !defined &DynaLoader::boot_DynaLoader # miniperl
+#!/usr/bin/perl
+use strict;
+use warnings;
+sub meow (&);
+my %h;
+my $k;
+meow {
+ my $t : need_this;
+ $t = {
+ size => $h{$k}{size};
+ used => $h{$k}(used}
+ };
+};
+EXPECT
+syntax error at - line 12, near "used"
+syntax error at - line 12, near "used}"
+Unmatched right curly bracket at - line 14, at end of line
+Execution of - aborted due to compilation errors.
+######## [perl #112312] crash on syntax error - another test
+# SKIP: !defined &DynaLoader::boot_DynaLoader # miniperl
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+sub meow (&);
+
+my %h;
+my $k;
+
+meow {
+ my $t : need_this;
+ $t = {
+ size => $h{$k}{size};
+ used => $h{$k}(used}
+ };
+};
+
+sub testo {
+ my $value = shift;
+ print;
+ print;
+ print;
+ 1;
+}
+
+EXPECT
+syntax error at - line 15, near "used"
+syntax error at - line 15, near "used}"
+Unmatched right curly bracket at - line 17, at end of line
+Execution of - aborted due to compilation errors.
Property changes on: trunk/contrib/perl/t/run/fresh_perl.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/run/locale.t
===================================================================
--- trunk/contrib/perl/t/run/locale.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/run/locale.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -58,12 +58,17 @@
EOF
"", {}, "LC_NUMERIC without setlocale() has no effect in any locale");
+
# try to find out a locale where LC_NUMERIC makes a difference
my $original_locale = setlocale(LC_NUMERIC);
my ($base, $different, $difference);
for ("C", @locales) { # prefer C for the base if available
- use locale;
+ BEGIN {
+ if($Config{d_setlocale}) {
+ require locale; import locale;
+ }
+ }
setlocale(LC_NUMERIC, $_) or next;
my $in = 4.2; # avoid any constant folding bugs
if ((my $s = sprintf("%g", $in)) eq "4.2") {
@@ -112,7 +117,7 @@
@.#
4.179
.
-{ use locale; write; }
+{ require locale; import locale; write; }
EOF
"too late to look at the locale at write() time");
}
@@ -119,7 +124,8 @@
{
fresh_perl_is(<<'EOF', $difference, {},
-use locale; format STDOUT =
+use locale;
+format STDOUT =
@.#
4.179
.
@@ -129,11 +135,44 @@
}
}
+ {
+ # do not let "use 5.000" affect the locale!
+ # this test is to prevent regression of [rt.perl.org #105784]
+ fresh_perl_is(<<"EOF",
+ BEGIN {
+ if($Config{d_setlocale}) {
+ require locale; import locale;
+ }
+ }
+ use POSIX;
+ my \$i = 0.123;
+ POSIX::setlocale(POSIX::LC_NUMERIC(),"$different");
+ \$a = sprintf("%.2f", \$i);
+ require version;
+ \$b = sprintf("%.2f", \$i);
+ print ".\$a \$b" unless \$a eq \$b
+EOF
+ "", {}, "version does not clobber version");
+
+ fresh_perl_is(<<"EOF",
+ use locale;
+ use POSIX;
+ my \$i = 0.123;
+ POSIX::setlocale(POSIX::LC_NUMERIC(),"$different");
+ \$a = sprintf("%.2f", \$i);
+ eval "use v5.0.0";
+ \$b = sprintf("%.2f", \$i);
+ print "\$a \$b" unless \$a eq \$b
+EOF
+ "", {}, "version does not clobber version (via eval)");
+ }
+
+
for ($different) {
local $ENV{LC_NUMERIC} = $_;
local $ENV{LC_ALL}; # so it never overrides LC_NUMERIC
fresh_perl_is(<<'EOF', "$difference "x4, {},
- use locale;
+ use locale;
use POSIX qw(locale_h);
setlocale(LC_NUMERIC, "");
my $in = 4.2;
@@ -143,4 +182,4 @@
}
} # SKIP
-sub last { 7 }
+sub last { 9 }
Property changes on: trunk/contrib/perl/t/run/locale.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/run/mad.t (from rev 6437, vendor/perl/5.18.1/t/run/mad.t)
===================================================================
--- trunk/contrib/perl/t/run/mad.t (rev 0)
+++ trunk/contrib/perl/t/run/mad.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,46 @@
+#!./perl
+#
+# Tests for Perl mad environment
+#
+# $PERL_XMLDUMP
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ require './test.pl';
+ skip_all_without_config('mad');
+}
+
+use File::Path;
+use File::Spec;
+
+my $tempdir = tempfile;
+
+mkdir $tempdir, 0700 or die "Can't mkdir '$tempdir': $!";
+unshift @INC, '../../lib';
+my $cleanup = 1;
+
+END {
+ if ($cleanup) {
+ rmtree($tempdir);
+ }
+}
+
+plan tests => 4;
+
+{
+ delete local $ENV{$_} for keys %ENV;
+ my $fn = File::Spec->catfile(File::Spec->curdir(), "withoutT.xml");
+ $ENV{PERL_XMLDUMP} = $fn;
+ fresh_perl_is('print q/hello/', '', {}, 'mad without -T');
+ ok(-f $fn, "xml file created without -T as expected");
+}
+
+{
+ delete local $ENV{$_} for keys %ENV;
+ my $fn = File::Spec->catfile(File::Spec->curdir(), "withT.xml");
+ fresh_perl_is('print q/hello/', 'hello', { switches => [ "-T" ] },
+ 'mad with -T');
+ ok(!-e $fn, "no xml file created with -T as expected");
+}
Modified: trunk/contrib/perl/t/run/noswitch.t
===================================================================
--- trunk/contrib/perl/t/run/noswitch.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/run/noswitch.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,12 +1,16 @@
#!./perl
BEGIN {
- print "1..3\n";
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require './test.pl';
*ARGV = *DATA;
+ plan(tests => 3);
}
-print "ok 1\n";
-print <>;
-print "ok 3\n";
+pass("first test");
+is( scalar <>, "ok 2\n", "read from aliased DATA filehandle");
+pass("last test");
+
__DATA__
-ok 2 - read from aliased DATA filehandle
+ok 2
Property changes on: trunk/contrib/perl/t/run/noswitch.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/run/runenv.t
===================================================================
--- trunk/contrib/perl/t/run/runenv.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/run/runenv.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -12,7 +12,7 @@
skip_all_without_config('d_fork');
}
-plan tests => 84;
+plan tests => 104;
my $STDOUT = tempfile();
my $STDERR = tempfile();
@@ -53,7 +53,7 @@
}
open STDOUT, '>', $STDOUT or exit $FAILURE_CODE;
open STDERR, '>', $STDERR and do { exec $PERL, @$args };
- # it didn't_work:
+ # it did not work:
print STDOUT "IWHCWJIHCI\cNHJWCJQWKJQJWCQW\n";
exit $FAILURE_CODE;
}
@@ -63,8 +63,21 @@
my ($env, $args, $stdout, $stderr) = @_;
my ($actual_stdout, $actual_stderr) = runperl_and_capture($env, $args);
local $::Level = $::Level + 1;
- is ($stdout, $actual_stdout);
- is ($stderr, $actual_stderr);
+ my @envpairs = ();
+ for my $k (sort keys %$env) {
+ push @envpairs, "$k => $env->{$k}";
+ }
+ my $label = join(',' => (@envpairs, @$args));
+ if (ref $stdout) {
+ ok ( $actual_stdout =~/$stdout/, $label . ' stdout' );
+ } else {
+ is ( $actual_stdout, $stdout, $label . ' stdout' );
+ }
+ if (ref $stderr) {
+ ok ( $actual_stderr =~/$stderr/, $label . ' stderr' );
+ } else {
+ is ( $actual_stderr, $stderr, $label . ' stderr' );
+ }
}
# PERL5OPT Command-line options (switches). Switches in
@@ -191,6 +204,77 @@
'',
'');
+try({PERL_HASH_SEED_DEBUG => 1},
+ ['-e','1'],
+ '',
+ qr/HASH_FUNCTION =/);
+
+try({PERL_HASH_SEED_DEBUG => 1},
+ ['-e','1'],
+ '',
+ qr/HASH_SEED =/);
+
+# special case, seed "0" implies disabled hash key traversal randomization
+try({PERL_HASH_SEED_DEBUG => 1, PERL_HASH_SEED => "0"},
+ ['-e','1'],
+ '',
+ qr/PERTURB_KEYS = 0/);
+
+# check that setting it to a different value with the same logical value
+# triggers the normal "deterministic mode".
+try({PERL_HASH_SEED_DEBUG => 1, PERL_HASH_SEED => "0x0"},
+ ['-e','1'],
+ '',
+ qr/PERTURB_KEYS = 2/);
+
+try({PERL_HASH_SEED_DEBUG => 1, PERL_PERTURB_KEYS => "0"},
+ ['-e','1'],
+ '',
+ qr/PERTURB_KEYS = 0/);
+
+try({PERL_HASH_SEED_DEBUG => 1, PERL_PERTURB_KEYS => "1"},
+ ['-e','1'],
+ '',
+ qr/PERTURB_KEYS = 1/);
+
+try({PERL_HASH_SEED_DEBUG => 1, PERL_PERTURB_KEYS => "2"},
+ ['-e','1'],
+ '',
+ qr/PERTURB_KEYS = 2/);
+
+try({PERL_HASH_SEED_DEBUG => 1, PERL_HASH_SEED => "12345678"},
+ ['-e','1'],
+ '',
+ qr/HASH_SEED = 0x12345678/);
+
+try({PERL_HASH_SEED_DEBUG => 1, PERL_HASH_SEED => "12"},
+ ['-e','1'],
+ '',
+ qr/HASH_SEED = 0x12000000/);
+
+try({PERL_HASH_SEED_DEBUG => 1, PERL_HASH_SEED => "123456789"},
+ ['-e','1'],
+ '',
+ qr/HASH_SEED = 0x12345678/);
+
+# Test that PERL_PERTURB_KEYS works as expected. We check that we get the same
+# results if we use PERL_PERTURB_KEYS = 0 or 2 and we reuse the seed from previous run.
+my @print_keys = ( '-e', '@_{"A".."Z"}=(); print keys %_');
+for my $mode ( 0,1, 2 ) { # disabled and deterministic respectively
+ my %base_opts = ( PERL_PERTURB_KEYS => $mode, PERL_HASH_SEED_DEBUG => 1 ),
+ my ($out, $err) = runperl_and_capture( { %base_opts }, [ @print_keys ]);
+ if ($err=~/HASH_SEED = (0x[a-f0-9]+)/) {
+ my $seed = $1;
+ my($out2, $err2) = runperl_and_capture( { %base_opts, PERL_HASH_SEED => $seed }, [ @print_keys ]);
+ if ( $mode == 1 ) {
+ isnt ($out,$out2,"PERL_PERTURB_KEYS = $mode results in different key order with the same key");
+ } else {
+ is ($out,$out2,"PERL_PERTURB_KEYS = $mode allows one to recreate a random hash");
+ }
+ is ($err,$err2,"Got the same debug output when we set PERL_HASH_SEED and PERL_PERTURB_KEYS");
+ }
+}
+
# Tests for S_incpush_use_sep():
my @dump_inc = ('-e', 'print "$_\n" foreach @INC');
Property changes on: trunk/contrib/perl/t/run/runenv.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/run/script.t
===================================================================
--- trunk/contrib/perl/t/run/script.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/run/script.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -4,6 +4,7 @@
chdir 't';
@INC = '../lib';
require './test.pl'; # for which_perl() etc
+ plan(3);
}
my $Perl = which_perl();
@@ -10,11 +11,9 @@
my $filename = tempfile();
-print "1..3\n";
-
$x = `$Perl -le "print 'ok';"`;
-if ($x eq "ok\n") {print "ok 1\n";} else {print "not ok 1\n";}
+is($x, "ok\n", "Got expected 'perl -le' output");
open(try,">$filename") || (die "Can't open temp file.");
print try 'print "ok\n";'; print try "\n";
@@ -22,8 +21,8 @@
$x = `$Perl $filename`;
-if ($x eq "ok\n") {print "ok 2\n";} else {print "not ok 2\n";}
+is($x, "ok\n", "Got expected output of command from script");
$x = `$Perl <$filename`;
-if ($x eq "ok\n") {print "ok 3\n";} else {print "not ok 3\n";}
+is($x, "ok\n", "Got expected output of command read from script");
Property changes on: trunk/contrib/perl/t/run/script.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/run/switch0.t
===================================================================
--- trunk/contrib/perl/t/run/switch0.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/run/switch0.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,3 +1,11 @@
#!./perl -0
-print "1..1\n";
-print ord $/ == 0 ? "ok 1\n" : "not ok 1\n";
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require './test.pl';
+}
+
+plan tests => 1;
+
+is(ord $/, 0, '$/ set to 0 via switch');
Property changes on: trunk/contrib/perl/t/run/switch0.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/run/switchC.t
===================================================================
--- trunk/contrib/perl/t/run/switchC.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/run/switchC.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -28,7 +28,7 @@
SKIP: {
if (exists $ENV{PERL_UNICODE} &&
($ENV{PERL_UNICODE} eq "" || $ENV{PERL_UNICODE} =~ /[SO]/)) {
- skip(qq[cannot test with PERL_UNICODE locale "" or /[SO]/], 1);
+ skip(qq[cannot test with PERL_UNICODE "" or /[SO]/], 1);
}
$r = runperl( switches => [ '-CI', '-w' ],
prog => 'print ord(<STDIN>)',
@@ -96,8 +96,13 @@
like( $r, qr/^Too late for "-CS" option at -e line 1\.$/s,
'#!perl -C with different -C on command line' );
-$r = runperl( switches => [ '-w' ],
- progs => [ '#!perl -CS', 'print chr(256)' ],
- stderr => 1, );
-like( $r, qr/^Too late for "-CS" option at -e line 1\.$/s,
- '#!perl -C but not command line' );
+SKIP: {
+ if (exists $ENV{PERL_UNICODE} && $ENV{PERL_UNICODE} =~ /S/) {
+ skip(qq[cannot test with PERL_UNICODE including "S"], 1);
+ }
+ $r = runperl( switches => [ '-w' ],
+ progs => [ '#!perl -CS', 'print chr(256)' ],
+ stderr => 1, );
+ like( $r, qr/^Too late for "-CS" option at -e line 1\.$/s,
+ '#!perl -C but not command line' );
+}
Property changes on: trunk/contrib/perl/t/run/switchC.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/run/switchF.t
===================================================================
--- trunk/contrib/perl/t/run/switchF.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/run/switchF.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,11 +1,16 @@
#!./perl -anFx+
BEGIN {
- print "1..2\n";
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require './test.pl';
*ARGV = *DATA;
+ plan(tests => 2);
}
-print "@F";
+my $index = $F[-1];
+chomp $index;
+is($index, $., "line $.");
__DATA__
okx1
-okxxx2
+okx3xx2
Property changes on: trunk/contrib/perl/t/run/switchF.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/run/switchF1.t
===================================================================
--- trunk/contrib/perl/t/run/switchF1.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/run/switchF1.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,4 +1,8 @@
#!perl -w
+
+# This test file does not use test.pl because of the involved way in which it
+# generates its TAP output.
+
print "1..5\n";
my $file = "Run_switchF1.pl";
@@ -14,10 +18,10 @@
print "@F";
__DATA__
-okx1
-okq2
-ok\3
-ok'4
+okx1x- use of alternate delimiter (lower case letter) in -F
+okq2q- use of alternate delimiter (lower case letter) in -F
+ok\3\- use of alternate delimiter (backslash) in -F
+ok'4'- use of alternate delimiter (apostrophe) in -F
EOT
# 2 of the characters toke.c used to use to quote the split parameter:
@@ -26,6 +30,8 @@
print F $prog;
close F or die "Close $file: $!";
-print system ($^X, $file) ? "not ok 5\n" : "ok 5\n";
+$count = 5;
+$result = "ok $count - complete test of alternate delimiters in -F\n";
+print system ($^X, $file) ? "not $result" : $result;
unlink $file or die "Unlink $file: $!";
Property changes on: trunk/contrib/perl/t/run/switchF1.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/run/switchI.t
===================================================================
--- trunk/contrib/perl/t/run/switchI.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/run/switchI.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -11,11 +11,12 @@
my $lib;
$lib = 'Bla';
-ok(grep { $_ eq $lib } @INC[0..($#INC-1)]);
+ok do { grep { $_ eq $lib } @INC[0..($#INC-1)] }, 'Identified entry in @INC';
SKIP: {
skip 'Double colons not allowed in dir spec', 1 if $Is_VMS;
$lib = 'Foo::Bar';
- ok(grep { $_ eq $lib } @INC[0..($#INC-1)]);
+ ok do { grep { $_ eq $lib } @INC[0..($#INC-1)] },
+ 'Identified entry in @INC with double colons';
}
$lib = 'Bla2';
Property changes on: trunk/contrib/perl/t/run/switchI.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/t/run/switchM.t (from rev 6437, vendor/perl/5.18.1/t/run/switchM.t)
===================================================================
--- trunk/contrib/perl/t/run/switchM.t (rev 0)
+++ trunk/contrib/perl/t/run/switchM.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,19 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+use strict;
+
+require './test.pl';
+
+plan(2);
+
+like(runperl(switches => ['-Irun/flib', '-Mbroken'], stderr => 1),
+ qr/^Global symbol "\$x" requires explicit package name 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\./,
+ "Ensure -Irun/flib/ produces correct filename in warnings");
Copied: trunk/contrib/perl/t/run/switchPx.aux (from rev 6437, vendor/perl/5.18.1/t/run/switchPx.aux)
===================================================================
--- trunk/contrib/perl/t/run/switchPx.aux (rev 0)
+++ trunk/contrib/perl/t/run/switchPx.aux 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,34 @@
+Some stuff that's not Perl
+
+This CPP directive should not be read.
+#define BARMAR 1
+
+#perl
+
+Still not perl.
+
+#!
+
+still not perl
+
+#!/something/else
+
+still not perl
+
+#!/some/path/that/leads/to/perl -l
+
+# The -l switch should be applied from the #! line.
+# Unfortunately, -P has a bug whereby the #! line is ignored.
+# If this test suddenly starts printing blank lines that bug is fixed.
+
+#define FOO "ok 1\n"
+
+#ifdef BARMAR
+# define YAR "not ok 2\n"
+#else
+# define YAR "ok 2\n"
+#endif
+
+print "1..2\n";
+print FOO;
+print YAR;
Copied: trunk/contrib/perl/t/run/switchPx.t (from rev 6437, vendor/perl/5.18.1/t/run/switchPx.t)
===================================================================
--- trunk/contrib/perl/t/run/switchPx.t (rev 0)
+++ trunk/contrib/perl/t/run/switchPx.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,22 @@
+#!./perl
+
+# Ensure that the -P and -x flags work together.
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ $ENV{PERL5LIB} = '../lib';
+
+ use Config;
+ if ( $^O eq 'MacOS' || ($Config{'cppstdin'} =~ /\bcppstdin\b/) &&
+ ! -x $Config{'binexp'} . "/cppstdin" ) {
+ print "1..0 # Skip: \$Config{cppstdin} unavailable\n";
+ exit; # Cannot test till after install, alas.
+ }
+}
+
+require './test.pl';
+
+print runperl( switches => ['-Px'],
+ nolib => 1, # for some reason this is necessary under VMS
+ progfile => 'run/switchPx.aux' );
Modified: trunk/contrib/perl/t/run/switcha.t
===================================================================
--- trunk/contrib/perl/t/run/switcha.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/run/switcha.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,11 +1,14 @@
#!./perl -na
BEGIN {
- print "1..2\n";
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require './test.pl';
*ARGV = *DATA;
- $i = 0;
+ plan(tests => 2);
}
-print "$F[1] ",++$i,"\n";
+chomp;
+is($F[1], 'ok', "testing split of string '$_'");
__DATA__
not ok
Property changes on: trunk/contrib/perl/t/run/switcha.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/run/switchd-78586.t
===================================================================
--- trunk/contrib/perl/t/run/switchd-78586.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/run/switchd-78586.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/run/switchd-78586.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/run/switchd.t
===================================================================
--- trunk/contrib/perl/t/run/switchd.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/run/switchd.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -9,7 +9,7 @@
# This test depends on t/lib/Devel/switchd*.pm.
-plan(tests => 5);
+plan(tests => 10);
my $r;
@@ -35,19 +35,25 @@
progfile => $filename,
args => ['3'],
);
- like($r, qr/^sub<Devel::switchd::import>;import<Devel::switchd>;DB<main,$::tempfile_regexp,9>;sub<Foo::foo>;DB<Foo,$::tempfile_regexp,5>;DB<Foo,$::tempfile_regexp,6>;sub<Bar::bar>;DB<Bar,$::tempfile_regexp,2>;sub<Bar::bar>;DB<Bar,$::tempfile_regexp,2>;sub<Bar::bar>;DB<Bar,$::tempfile_regexp,2>;$/);
+ like($r,
+qr/^sub<Devel::switchd::import>;import<Devel::switchd>;DB<main,$::tempfile_regexp,9>;sub<Foo::foo>;DB<Foo,$::tempfile_regexp,5>;DB<Foo,$::tempfile_regexp,6>;sub<Bar::bar>;DB<Bar,$::tempfile_regexp,2>;sub<Bar::bar>;DB<Bar,$::tempfile_regexp,2>;sub<Bar::bar>;DB<Bar,$::tempfile_regexp,2>;$/,
+ 'Got debugging output: 1');
$r = runperl(
switches => [ '-Ilib', '-f', '-d:switchd=a,42' ],
progfile => $filename,
args => ['4'],
);
- like($r, qr/^sub<Devel::switchd::import>;import<Devel::switchd a 42>;DB<main,$::tempfile_regexp,9>;sub<Foo::foo>;DB<Foo,$::tempfile_regexp,5>;DB<Foo,$::tempfile_regexp,6>;sub<Bar::bar>;DB<Bar,$::tempfile_regexp,2>;sub<Bar::bar>;DB<Bar,$::tempfile_regexp,2>;sub<Bar::bar>;DB<Bar,$::tempfile_regexp,2>;$/);
+ like($r,
+qr/^sub<Devel::switchd::import>;import<Devel::switchd a 42>;DB<main,$::tempfile_regexp,9>;sub<Foo::foo>;DB<Foo,$::tempfile_regexp,5>;DB<Foo,$::tempfile_regexp,6>;sub<Bar::bar>;DB<Bar,$::tempfile_regexp,2>;sub<Bar::bar>;DB<Bar,$::tempfile_regexp,2>;sub<Bar::bar>;DB<Bar,$::tempfile_regexp,2>;$/,
+ 'Got debugging output: 2');
$r = runperl(
switches => [ '-Ilib', '-f', '-d:-switchd=a,42' ],
progfile => $filename,
args => ['4'],
);
- like($r, qr/^sub<Devel::switchd::unimport>;unimport<Devel::switchd a 42>;DB<main,$::tempfile_regexp,9>;sub<Foo::foo>;DB<Foo,$::tempfile_regexp,5>;DB<Foo,$::tempfile_regexp,6>;sub<Bar::bar>;DB<Bar,$::tempfile_regexp,2>;sub<Bar::bar>;DB<Bar,$::tempfile_regexp,2>;sub<Bar::bar>;DB<Bar,$::tempfile_regexp,2>;$/);
+ like($r,
+qr/^sub<Devel::switchd::unimport>;unimport<Devel::switchd a 42>;DB<main,$::tempfile_regexp,9>;sub<Foo::foo>;DB<Foo,$::tempfile_regexp,5>;DB<Foo,$::tempfile_regexp,6>;sub<Bar::bar>;DB<Bar,$::tempfile_regexp,2>;sub<Bar::bar>;DB<Bar,$::tempfile_regexp,2>;sub<Bar::bar>;DB<Bar,$::tempfile_regexp,2>;$/,
+ 'Got debugging output: 3');
}
# [perl #71806]
@@ -78,3 +84,82 @@
qr "1\r?\n2\r?\n",
'Subroutine redefinition works in the debugger [perl #48332]',
);
+
+# [rt.cpan.org #69862]
+like(
+ runperl(
+ switches => [ '-Ilib', '-d:switchd_empty' ],
+ progs => [
+ 'sub DB::sub { goto &$DB::sub }',
+ 'sub foo { print qq _1\n_ }',
+ 'sub bar { print qq _2\n_ }',
+ 'delete $::{foo}; eval { foo() };',
+ 'my $bar = *bar; undef *bar; eval { &$bar };',
+ ],
+ ),
+ qr "1\r?\n2\r?\n",
+ 'Subroutines no longer found under their names can be called',
+);
+
+# [rt.cpan.org #69862]
+like(
+ runperl(
+ switches => [ '-Ilib', '-d:switchd_empty' ],
+ progs => [
+ 'sub DB::sub { goto &$DB::sub }',
+ 'sub foo { goto &bar::baz; }',
+ 'sub bar::baz { print qq _ok\n_ }',
+ 'delete $::{bar::::};',
+ 'foo();',
+ ],
+ ),
+ qr "ok\r?\n",
+ 'No crash when calling orphaned subroutine via goto &',
+);
+
+# test when DB::DB is seen but not defined [perl #114990]
+like(
+ runperl(
+ switches => [ '-Ilib', '-d:nodb' ],
+ prog => [ '1' ],
+ stderr => 1,
+ ),
+ qr/^No DB::DB routine defined/,
+ "No crash when *DB::DB exists but not &DB::DB",
+);
+like(
+ runperl(
+ switches => [ '-Ilib' ],
+ prog => 'sub DB::DB; BEGIN { $^P = 0x22; } for(0..9){ warn }',
+ stderr => 1,
+ ),
+ qr/^No DB::DB routine defined/,
+ "No crash when &DB::DB exists but isn't actually defined",
+);
+
+# [perl #115742] Recursive DB::DB clobbering its own pad
+like(
+ runperl(
+ switches => [ '-Ilib' ],
+ progs => [ split "\n", <<'='
+ BEGIN {
+ $^P = 0x22;
+ }
+ package DB;
+ sub DB {
+ my $x = 42;
+ return if $__++;
+ $^D |= 1 << 30; # allow recursive calls
+ main::foo();
+ print $x//q-u-, qq-\n-;
+ }
+ package main;
+ chop;
+ sub foo { chop; }
+=
+ ],
+ stderr => 1,
+ ),
+ qr/42/,
+ "Recursive DB::DB does not clobber its own pad",
+);
Property changes on: trunk/contrib/perl/t/run/switchd.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/run/switches.t
===================================================================
--- trunk/contrib/perl/t/run/switches.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/run/switches.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -11,9 +11,11 @@
BEGIN { require "./test.pl"; }
-plan(tests => 71);
+plan(tests => 115);
use Config;
+use Errno qw(EACCES EISDIR);
+use POSIX qw(setlocale LC_ALL);
# due to a bug in VMS's piping which makes it impossible for runperl()
# to emulate echo -n (ie. stdin always winds up with a newline), these
@@ -107,6 +109,25 @@
);
}
+{
+ my $tempdir = tempfile;
+ mkdir $tempdir, 0700 or die "Can't mkdir '$tempdir': $!";
+
+ local $ENV{'LC_ALL'} = 'C'; # Keep the test simple: expect English
+ local $ENV{LANGUAGE} = 'C';
+ setlocale(LC_ALL, "C");
+
+ # 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; "$!" };
+ like(
+ runperl( switches => [ '-c' ], args => [ $tempdir ], stderr => 1),
+ qr/Can't open perl script.*$tempdir.*\Q$error/s,
+ "RT \#61362: Cannot syntax-check a directory"
+ );
+ rmdir $tempdir or die "Can't rmdir '$tempdir': $!";
+}
+
# Tests for -l
$r = runperl(
@@ -225,6 +246,10 @@
"-M- not allowed" );
} # disable TODO on VMS
}
+is runperl(stderr => 1, prog => '#!perl -m'),
+ qq 'Too late for "-m" option at -e line 1.\n', '#!perl -m';
+is runperl(stderr => 1, prog => '#!perl -M'),
+ qq 'Too late for "-M" option at -e line 1.\n', '#!perl -M';
# Tests for -V
@@ -297,8 +322,22 @@
qr/\QUnrecognized switch: -$switch (-h will show valid options)./,
"-$switch correctly unknown" );
+ # [perl #104288]
+ like( runperl( stderr => 1, prog => "#!perl -$switch" ),
+ qr/^Unrecognized switch: -$switch \(-h will show valid (?x:
+ )options\) at -e line 1\./,
+ "-$switch unrecognised on #! line" );
}
+# Tests for unshebangable switches
+for (qw( e f x E S V )) {
+ $r = runperl(
+ stderr => 1,
+ prog => "#!perl -$_",
+ );
+ is $r, "Can't emulate -$_ on #! line at -e line 1.\n","-$_ on #! line";
+}
+
# Tests for -i
{
@@ -332,6 +371,26 @@
is(join(":", @bak),
"foo yada dada:bada foo bing:king kong foo",
"-i backup file");
+
+ my $out1 = runperl(
+ switches => ['-i.bak -p'],
+ prog => 'exit',
+ stderr => 1,
+ stdin => "1\n",
+ );
+ is(
+ $out1,
+ "-i used with no filenames on the command line, reading from STDIN.\n",
+ "warning when no files given"
+ );
+ my $out2 = runperl(
+ switches => ['-i.bak -p'],
+ prog => 'exit',
+ stderr => 1,
+ stdin => "1\n",
+ args => ['file'],
+ );
+ is($out2, "", "no warning when files given");
}
# Tests for -E
@@ -345,12 +404,12 @@
$r = runperl(
- switches => [ '-E', '"undef ~~ undef and say q(Hello, world!)"']
+ switches => [ '-E', '"no warnings q{experimental::smartmatch}; undef ~~ undef and say q(Hello, world!)"']
);
is( $r, "Hello, world!\n", "-E ~~" );
$r = runperl(
- switches => [ '-E', '"given(undef) {when(undef) { say q(Hello, world!)"}}']
+ switches => [ '-E', '"no warnings q{experimental::smartmatch}; given(undef) {when(undef) { say q(Hello, world!)"}}']
);
is( $r, "Hello, world!\n", "-E given" );
Property changes on: trunk/contrib/perl/t/run/switches.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/t/run/switchn.t
===================================================================
--- trunk/contrib/perl/t/run/switchn.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/run/switchn.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,11 +1,22 @@
#!./perl -n
BEGIN {
- print "1..2\n";
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require './test.pl';
*ARGV = *DATA;
+ plan(tests => 3);
}
-print;
+END {
+ pass("Final test");
+}
+
+chomp;
+is("ok ".$., $_, "Checking line $.");
+
+s/^/not /;
+
__DATA__
ok 1
ok 2
Property changes on: trunk/contrib/perl/t/run/switchn.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/run/switchp.t
===================================================================
--- trunk/contrib/perl/t/run/switchp.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/run/switchp.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,10 +1,19 @@
#!./perl -p
+# This test file does not use test.pl because of the involved way in which it
+# generates its TAP output.
+
BEGIN {
- print "1..2\n";
+ print "1..3\n";
*ARGV = *DATA;
}
+END {
+ print "ok 3 - -p switch tested\n";
+}
+
+s/^not //;
+
__DATA__
-ok 1
-ok 2
+not ok 1 - -p switch first iteration
+not ok 2 - -p switch second iteration
Property changes on: trunk/contrib/perl/t/run/switchp.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/run/switcht.t
===================================================================
--- trunk/contrib/perl/t/run/switcht.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/run/switcht.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/run/switcht.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/run/switchx.aux
===================================================================
--- trunk/contrib/perl/t/run/switchx.aux 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/run/switchx.aux 2013-12-02 21:26:09 UTC (rev 6439)
@@ -17,11 +17,11 @@
#!/some/path/that/leads/to/perl -l
-print "1..4";
+print "1..7";
if (-f 'run/switchx.aux') {
- print "ok 1";
+ print "ok 1 - Test file exists";
}
-print "ok 2";
+print "ok 2 - Test file utilized";
# other tests are in switchx2.aux
__END__
Property changes on: trunk/contrib/perl/t/run/switchx.aux
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/run/switchx.t
===================================================================
--- trunk/contrib/perl/t/run/switchx.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/run/switchx.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -4,6 +4,7 @@
chdir 't' if -d 't';
@INC = '../lib';
}
+use strict;
require './test.pl';
@@ -16,4 +17,20 @@
progfile => 'run/switchx2.aux',
args => [ 3 ] );
-# EOF
+curr_test(5);
+
+# Test the error message for not found
+like(runperl(switches => ['-x'], progfile => 'run/switchx3.aux', stderr => 1),
+ qr/^No Perl script found in input\r?\n\z/,
+ "Test the error message when -x can't find a #!perl line");
+
+SKIP: {
+ skip("These tests embed newlines in command line arguments, which isn't portable to $^O", 2)
+ if $^O eq 'MSWin32' or $^O eq 'VMS';
+ my @progs = ("die;\n", "#!perl\n", "warn;\n");
+ is(runperl(progs => \@progs, stderr => 1, non_portable => 1),
+ "Died at -e line 1.\n", 'Test program dies');
+ is(runperl(progs => \@progs, stderr => 1, non_portable => 1,
+ switches => ['-x']),
+ "No Perl script found in input\n", '-x and -e gives expected error');
+}
Property changes on: trunk/contrib/perl/t/run/switchx.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/run/switchx2.aux
===================================================================
--- trunk/contrib/perl/t/run/switchx2.aux 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/run/switchx2.aux 2013-12-02 21:26:09 UTC (rev 6439)
@@ -21,10 +21,10 @@
# These lines get executed
my $test = $ARGV[0];
if (-f 'switchx.t') {
- print("ok $test");
+ print("ok $test - perl -l option tested");
}
$test++;
-print "ok $test";
+print "ok $test - Second test file utilized";
__END__
Property changes on: trunk/contrib/perl/t/run/switchx2.aux
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/run/switchx3.aux (from rev 6437, vendor/perl/5.18.1/t/run/switchx3.aux)
===================================================================
--- trunk/contrib/perl/t/run/switchx3.aux (rev 0)
+++ trunk/contrib/perl/t/run/switchx3.aux 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,2 @@
+print "not ok 5\n";
+die "You shouldn't get here";
Modified: trunk/contrib/perl/t/test.pl
===================================================================
--- trunk/contrib/perl/t/test.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/test.pl 2013-12-02 21:26:09 UTC (rev 6439)
@@ -109,6 +109,16 @@
map { split /\n/ } @_;
}
+sub _have_dynamic_extension {
+ my $extension = shift;
+ unless (eval {require Config; 1}) {
+ warn "test.pl had problems loading Config: $@";
+ return 1;
+ }
+ $extension =~ s!::!/!g;
+ return 1 if ($Config::Config{extensions} =~ /\b$extension\b/);
+}
+
sub skip_all {
if (@_) {
_print "1..0 # Skip @_\n";
@@ -123,14 +133,9 @@
}
sub skip_all_without_dynamic_extension {
- my $extension = shift;
+ my ($extension) = @_;
skip_all("no dynamic loading on miniperl, no $extension") if is_miniperl();
- unless (eval {require Config; 1}) {
- warn "test.pl had problems loading Config: $@";
- return;
- }
- $extension =~ s!::!/!g;
- return if ($Config::Config{extensions} =~ /\b$extension\b/);
+ return if &_have_dynamic_extension;
skip_all("$extension was not built");
}
@@ -152,6 +157,49 @@
}
}
+sub find_git_or_skip {
+ my ($source_dir, $reason);
+ if (-d '.git') {
+ $source_dir = '.';
+ } elsif (-l 'MANIFEST' && -l 'AUTHORS') {
+ my $where = readlink 'MANIFEST';
+ die "Can't readling MANIFEST: $!" unless defined $where;
+ die "Confusing symlink target for MANIFEST, '$where'"
+ unless $where =~ s!/MANIFEST\z!!;
+ if (-d "$where/.git") {
+ # Looks like we are in a symlink tree
+ if (exists $ENV{GIT_DIR}) {
+ diag("Found source tree at $where, but \$ENV{GIT_DIR} is $ENV{GIT_DIR}. Not changing it");
+ } else {
+ note("Found source tree at $where, setting \$ENV{GIT_DIR}");
+ $ENV{GIT_DIR} = "$where/.git";
+ }
+ $source_dir = $where;
+ }
+ }
+ if ($source_dir) {
+ my $version_string = `git --version`;
+ if (defined $version_string
+ && $version_string =~ /\Agit version (\d+\.\d+\.\d+)(.*)/) {
+ return $source_dir if eval "v$1 ge v1.5.0";
+ # If you have earlier than 1.5.0 and it works, change this test
+ $reason = "in git checkout, but git version '$1$2' too old";
+ } else {
+ $reason = "in git checkout, but cannot run git";
+ }
+ } else {
+ $reason = 'not being run from a git checkout';
+ }
+ skip_all($reason) if $_[0] && $_[0] eq 'all';
+ skip($reason, @_);
+}
+
+sub BAIL_OUT {
+ my ($reason) = @_;
+ _print("Bail out! $reason\n");
+ exit 255;
+}
+
sub _ok {
my ($pass, $where, $name, @mess) = @_;
# Do not try to microoptimize by factoring out the "not ".
@@ -177,7 +225,10 @@
note @mess; # Ensure that the message is properly escaped.
}
else {
- _diag "# Failed $where\n";
+ my $msg = "# Failed test $test - ";
+ $msg.= "$name " if $name;
+ $msg .= "$where\n";
+ _diag $msg;
_diag @mess;
}
@@ -408,6 +459,13 @@
skip(@_) if is_miniperl();
}
+sub skip_without_dynamic_extension {
+ my ($extension) = @_;
+ skip("no dynamic loading on miniperl, no $extension") if is_miniperl();
+ return if &_have_dynamic_extension;
+ skip("$extension was not built");
+}
+
sub todo_skip {
my $why = shift;
my $n = @_ ? shift : 1;
@@ -439,7 +497,10 @@
# Force a hash recompute if this perl's internals can cache the hash key.
$key = "" . $key;
if (exists $orig->{$key}) {
- if ($orig->{$key} ne $value) {
+ if (
+ defined $orig->{$key} != defined $value
+ || (defined $value && $orig->{$key} ne $value)
+ ) {
_print "# key ", _qq($key), " was ", _qq($orig->{$key}),
" now ", _qq($value), "\n";
$fail = 1;
@@ -704,6 +765,44 @@
$count;
}
+# _num_to_alpha - Returns a string of letters representing a positive integer.
+# Arguments :
+# number to convert
+# maximum number of letters
+
+# returns undef if the number is negative
+# returns undef if the number of letters is greater than the maximum wanted
+
+# _num_to_alpha( 0) eq 'A';
+# _num_to_alpha( 1) eq 'B';
+# _num_to_alpha(25) eq 'Z';
+# _num_to_alpha(26) eq 'AA';
+# _num_to_alpha(27) eq 'AB';
+
+my @letters = qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z);
+
+# Avoid ++ -- ranges split negative numbers
+sub _num_to_alpha{
+ my($num,$max_char) = @_;
+ return unless $num >= 0;
+ my $alpha = '';
+ my $char_count = 0;
+ $max_char = 0 if $max_char < 0;
+
+ while( 1 ){
+ $alpha = $letters[ $num % 26 ] . $alpha;
+ $num = int( $num / 26 );
+ last if $num == 0;
+ $num = $num - 1;
+
+ # char limit
+ next unless $max_char;
+ $char_count = $char_count + 1;
+ return if $char_count == $max_char;
+ }
+ return $alpha;
+}
+
my %tmpfiles;
END { unlink_all keys %tmpfiles }
@@ -711,25 +810,23 @@
$::tempfile_regexp = 'tmp\d+[A-Z][A-Z]?';
# Avoid ++, avoid ranges, avoid split //
-my @letters = qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z);
+my $tempfile_count = 0;
sub tempfile {
- my $count = 0;
- do {
- my $temp = $count;
+ while(1){
my $try = "tmp$$";
- do {
- $try = $try . $letters[$temp % 26];
- $temp = int ($temp / 26);
- } while $temp;
+ my $alpha = _num_to_alpha($tempfile_count,2);
+ last unless defined $alpha;
+ $try = $try . $alpha;
+ $tempfile_count = $tempfile_count + 1;
+
# Need to note all the file names we allocated, as a second request may
# come before the first is created.
- if (!-e $try && !$tmpfiles{$try}) {
+ if (!$tmpfiles{$try} && !-e $try) {
# We have a winner
$tmpfiles{$try} = 1;
return $try;
}
- $count = $count + 1;
- } while $count < 26 * 26;
+ }
die "Can't find temporary file name starting 'tmp$$'";
}
@@ -747,8 +844,8 @@
# it feels like the least-worse thing is to assume that auto-vivification
# works. At least, this is only going to be a run-time failure, so won't
# affect tests using this file but not this function.
- $runperl_args->{progfile} = $tmpfile;
- $runperl_args->{stderr} = 1;
+ $runperl_args->{progfile} ||= $tmpfile;
+ $runperl_args->{stderr} = 1 unless exists $runperl_args->{stderr};
open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!";
@@ -843,6 +940,34 @@
# Many tests use the same format in __DATA__ or external files to specify a
# sequence of (fresh) tests to run, extra files they may temporarily need, and
# what the expected output is. So have excatly one copy of the code to run that
+#
+# Each program is source code to run followed by an "EXPECT" line, followed
+# by the expected output.
+#
+# The code to run may begin with a command line switch such as -w or -0777
+# (alphanumerics only), and may contain (note the '# ' on each):
+# # TODO reason for todo
+# # SKIP reason for skip
+# # SKIP ?code to test if this should be skipped
+# # NAME name of the test (as with ok($ok, $name))
+#
+# The expected output may contain:
+# OPTION list of options
+# OPTIONS list of options
+#
+# The possible options for OPTION may be:
+# regex - the expected output is a regular expression
+# random - all lines match but in any order
+# fatal - the code will fail fatally (croak, die)
+#
+# If the actual output contains a line "SKIPPED" the test will be
+# skipped.
+#
+# If the actual output contains a line "PREFIX", any output starting with that
+# line will be ignored when comparing with the expected output
+#
+# If the global variable $FATAL is true then OPTION fatal is the
+# default.
sub run_multiple_progs {
my $up = shift;
@@ -860,6 +985,7 @@
my $tmpfile = tempfile();
+ PROGRAM:
for (@prgs){
unless (/\n/) {
print "# From $_\n";
@@ -887,8 +1013,21 @@
}
}
+ my $name = '';
+ if ($prog =~ s/^#\s*NAME\s+(.+)\n//m) {
+ $name = $1;
+ }
+
+ if ($reason{skip}) {
+ SKIP:
+ {
+ skip($name ? "$name - $reason{skip}" : $reason{skip}, 1);
+ }
+ next PROGRAM;
+ }
+
if ($prog =~ /--FILE--/) {
- my @files = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ;
+ my @files = split(/\n?--FILE--\s*([^\s\n]*)\s*\n/, $prog) ;
shift @files ;
die "Internal error: test $_ didn't split into pairs, got " .
scalar(@files) . "[" . join("%%%%", @files) ."]\n"
@@ -946,6 +1085,7 @@
# any special options? (OPTIONS foo bar zap)
my $option_regex = 0;
my $option_random = 0;
+ my $fatal = $FATAL;
if ($expected =~ s/^OPTIONS? (.+)\n//) {
foreach my $option (split(' ', $1)) {
if ($option eq 'regex') { # allow regular expressions
@@ -954,6 +1094,9 @@
elsif ($option eq 'random') { # all lines match, but in any order
$option_random = 1;
}
+ elsif ($option eq 'fatal') { # perl should fail
+ $fatal = 1;
+ }
else {
die "$0: Unknown OPTION '$option'\n";
}
@@ -966,28 +1109,36 @@
print "$results\n" ;
$ok = 1;
}
- elsif ($option_random) {
- my @got = sort split "\n", $results;
- my @expected = sort split "\n", $expected;
+ else {
+ if ($option_random) {
+ my @got = sort split "\n", $results;
+ my @expected = sort split "\n", $expected;
- $ok = "@got" eq "@expected";
+ $ok = "@got" eq "@expected";
+ }
+ elsif ($option_regex) {
+ $ok = $results =~ /^$expected/;
+ }
+ elsif ($prefix) {
+ $ok = $results =~ /^\Q$expected/;
+ }
+ else {
+ $ok = $results eq $expected;
+ }
+
+ if ($ok && $fatal && !($status >> 8)) {
+ $ok = 0;
+ }
}
- elsif ($option_regex) {
- $ok = $results =~ /^$expected/;
- }
- elsif ($prefix) {
- $ok = $results =~ /^\Q$expected/;
- }
- else {
- $ok = $results eq $expected;
- }
local $::TODO = $reason{todo};
unless ($ok) {
my $err_line = "PROG: $switch\n$prog\n" .
- "EXPECTED:\n$expected\n" .
- "GOT:\n$results\n";
+ "EXPECTED:\n$expected\n";
+ $err_line .= "EXIT STATUS: != 0\n" if $fatal;
+ $err_line .= "GOT:\n$results\n";
+ $err_line .= "EXIT STATUS: " . ($status >> 8) . "\n" if $fatal;
if ($::TODO) {
$err_line =~ s/^/# /mg;
print $err_line; # Harness can't filter it out from STDERR.
@@ -997,7 +1148,7 @@
}
}
- ok($ok);
+ ok($ok, $name);
foreach (@temps) {
unlink $_ if $_;
@@ -1031,7 +1182,7 @@
}
-# Call $class->new( @$args ); and run the result through isa_ok.
+# Call $class->new( @$args ); and run the result through object_ok.
# See Test::More::new_ok
sub new_ok {
my($class, $args, $obj_name) = @_;
@@ -1045,7 +1196,7 @@
my $error = $@;
if($ok) {
- isa_ok($obj, $class, $object_name);
+ object_ok($obj, $class, $object_name);
}
else {
ok( 0, "new() died" );
@@ -1066,20 +1217,29 @@
if( !defined $object ) {
$diag = "$obj_name isn't defined";
}
- elsif( !ref $object ) {
- $diag = "$obj_name isn't a reference";
- }
else {
+ my $whatami = ref $object ? 'object' : 'class';
+
# We can't use UNIVERSAL::isa because we want to honor isa() overrides
local($@, $!); # eval sometimes resets $!
my $rslt = eval { $object->isa($class) };
- if( $@ ) {
- if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) {
+ my $error = $@; # in case something else blows away $@
+
+ if( $error ) {
+ if( $error =~ /^Can't call method "isa" on unblessed reference/ ) {
+ # It's an unblessed reference
+ $obj_name = 'The reference' unless defined $obj_name;
if( !UNIVERSAL::isa($object, $class) ) {
my $ref = ref $object;
$diag = "$obj_name isn't a '$class' it's a '$ref'";
}
- } else {
+ }
+ elsif( $error =~ /Can't call method "isa" without a package/ ) {
+ # It's something that can't even be a class
+ $obj_name = 'The thing' unless defined $obj_name;
+ $diag = "$obj_name isn't a class or reference";
+ }
+ else {
die <<WHOA;
WHOA! I tried to call ->isa on your object and got some weird error.
This should never happen. Please contact the author immediately.
@@ -1089,6 +1249,7 @@
}
}
elsif( !$rslt ) {
+ $obj_name = "The $whatami" unless defined $obj_name;
my $ref = ref $object;
$diag = "$obj_name isn't a '$class' it's a '$ref'";
}
@@ -1097,6 +1258,34 @@
_ok( !$diag, _where(), $name );
}
+
+sub class_ok {
+ my($class, $isa, $class_name) = @_;
+
+ # Written so as to count as one test
+ local $Level = $Level + 1;
+ if( ref $class ) {
+ ok( 0, "$class is a refrence, not a class name" );
+ }
+ else {
+ isa_ok($class, $isa, $class_name);
+ }
+}
+
+
+sub object_ok {
+ my($obj, $isa, $obj_name) = @_;
+
+ local $Level = $Level + 1;
+ if( !ref $obj ) {
+ ok( 0, "$obj is not a reference" );
+ }
+ else {
+ isa_ok($obj, $isa, $obj_name);
+ }
+}
+
+
# Purposefully avoiding a closure.
sub __capture {
push @::__capture, join "", @_;
@@ -1191,7 +1380,7 @@
# Don't use a watchdog process if 'threads' is loaded -
# use a watchdog thread instead
- if (!$threads_on) {
+ if (!$threads_on || $method eq "process") {
# On Windows and VMS, try launching a watchdog process
# using system(1, ...) (see perlport.pod)
@@ -1258,6 +1447,11 @@
if (kill(0, $pid_to_kill)) {
_diag($timeout_msg);
kill('KILL', $pid_to_kill);
+ if ($is_cygwin) {
+ # sometimes the above isn't enough on cygwin
+ sleep 1; # wait a little, it might have worked after all
+ system("/bin/kill -f $pid_to_kill");
+ }
}
# Don't execute END block (added at beginning of this file)
Property changes on: trunk/contrib/perl/t/test.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/t/thread_it.pl
===================================================================
--- trunk/contrib/perl/t/thread_it.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/thread_it.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/thread_it.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/t/uni/attrs.t (from rev 6437, vendor/perl/5.18.1/t/uni/attrs.t)
===================================================================
--- trunk/contrib/perl/t/uni/attrs.t (rev 0)
+++ trunk/contrib/perl/t/uni/attrs.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,195 @@
+#!./perl
+
+# Regression tests for attributes.pm and the C< : attrs> syntax.
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require './test.pl';
+ skip_all_if_miniperl("miniperl can't load attributes");
+}
+
+use utf8;
+use open qw( :utf8 :std );
+use warnings;
+use feature 'unicode_strings';
+
+$SIG{__WARN__} = sub { die @_ };
+
+sub eval_ok ($;$) {
+ eval shift;
+ is( $@, '', @_);
+}
+
+fresh_perl_is 'use attributes; print "ok"', 'ok',
+ 'attributes.pm can load without warnings.pm already loaded';
+
+eval 'sub è1 ($) : plùgh ;';
+like $@, qr/^Invalid CODE attributes?: ["']?plùgh["']? at/;
+
+eval 'sub ɛ2 ($) : plǖgh(0,0) xyzzy ;';
+like $@, qr/^Invalid CODE attributes: ["']?plǖgh\(0,0\)["']? /;
+
+eval 'my ($x,$y) : plǖgh;';
+like $@, qr/^Invalid SCALAR attribute: ["']?plǖgh["']? at/;
+
+# bug #16080
+eval '{my $x : plǖgh}';
+like $@, qr/^Invalid SCALAR attribute: ["']?plǖgh["']? at/;
+eval '{my ($x,$y) : plǖgh(})}';
+like $@, qr/^Invalid SCALAR attribute: ["']?plǖgh\(}\)["']? at/;
+
+# More syntax tests from the attributes manpage
+eval 'my $x : Şʨᚻ(10,ᕘ(7,3)) : 에ㄒ펜ሲ;';
+like $@, qr/^Invalid SCALAR attributes: ["']?Şʨᚻ\(10,ᕘ\(7,3\)\) : 에ㄒ펜ሲ["']? at/;
+eval q/my $x : Ugļᑈ('\(") :받;/;
+like $@, qr/^Invalid SCALAR attributes: ["']?Ugļᑈ\('\\\("\) : 받["']? at/;
+eval 'my $x : Şʨᚻ(10,ᕘ();';
+like $@, qr/^Unterminated attribute parameter in attribute list at/;
+eval q/my $x : Ugļᑈ('(');/;
+like $@, qr/^Unterminated attribute parameter in attribute list at/;
+
+sub A::MODIFY_SCALAR_ATTRIBUTES { return }
+eval 'my A $x : plǖgh;';
+like $@, qr/^SCALAR package attribute may clash with future reserved word: ["']?plǖgh["']? at/;
+
+eval 'my A $x : plǖgh plover;';
+like $@, qr/^SCALAR package attributes may clash with future reserved words: ["']?plǖgh["']? /;
+
+no warnings 'reserved';
+eval 'my A $x : plǖgh;';
+is $@, '';
+
+eval 'package Càt; my Càt @socks;';
+like $@, '';
+
+eval 'my Càt %nap;';
+like $@, '';
+
+sub X::MODIFY_CODE_ATTRIBUTES { die "$_[0]" }
+sub X::ᕘ { 1 }
+*Y::bar = \&X::ᕘ;
+*Y::bar = \&X::ᕘ; # second time for -w
+eval 'package Z; sub Y::bar : ᕘ';
+like $@, qr/^X at /;
+
+# Begin testing attributes that tie
+
+{
+ package Ttìè;
+ sub DESTROY {}
+ sub TIESCALAR { my $x = $_[1]; bless \$x, $_[0]; }
+ sub FETCH { ${$_[0]} }
+ sub STORE {
+ ::pass;
+ ${$_[0]} = $_[1]*2;
+ }
+ package Tlòòp;
+ sub MODIFY_SCALAR_ATTRIBUTES { tie ${$_[1]}, 'Ttìè', -1; (); }
+}
+
+eval_ok '
+ package Tlòòp;
+ for my $i (0..2) {
+ my $x : TìèLòòp = $i;
+ $x != $i*2 and ::is $x, $i*2;
+ }
+';
+
+# bug #15898
+eval 'our ${""} : ᕘ = 1';
+like $@, qr/Can't declare scalar dereference in "our"/;
+eval 'my $$ᕘ : bar = 1';
+like $@, qr/Can't declare scalar dereference in "my"/;
+
+
+# this will segfault if it fails
+sub PVBM () { 'ᕘ' }
+{ my $dummy = index 'ᕘ', PVBM }
+
+ok !defined(eval 'attributes::get(\PVBM)'),
+ 'PVBMs don\'t segfault attributes::get';
+
+{
+ # [perl #49472] Attributes + Unknown Error
+ eval '
+ use strict;
+ sub MODIFY_CODE_ATTRIBUTE{}
+ sub f:Blah {$nosuchvar};
+ ';
+
+ my $err = $@;
+ like ($err, qr/Global symbol "\$nosuchvar" requires /, 'perl #49472');
+}
+
+# Test that code attributes always get applied to the same CV that
+# we're left with at the end (bug#66970).
+{
+ package bug66970;
+ our $c;
+ sub MODIFY_CODE_ATTRIBUTES { $c = $_[1]; () }
+ $c=undef; eval 'sub t0 :ᕘ';
+ main::ok $c == \&{"t0"};
+ $c=undef; eval 'sub t1 :ᕘ { }';
+ main::ok $c == \&{"t1"};
+ $c=undef; eval 'sub t2';
+ our $t2a = \&{"t2"};
+ $c=undef; eval 'sub t2 :ᕘ';
+ main::ok $c == \&{"t2"} && $c == $t2a;
+ $c=undef; eval 'sub t3';
+ our $t3a = \&{"t3"};
+ $c=undef; eval 'sub t3 :ᕘ { }';
+ main::ok $c == \&{"t3"} && $c == $t3a;
+ $c=undef; eval 'sub t4 :ᕘ';
+ our $t4a = \&{"t4"};
+ our $t4b = $c;
+ $c=undef; eval 'sub t4 :ᕘ';
+ main::ok $c == \&{"t4"} && $c == $t4b && $c == $t4a;
+ $c=undef; eval 'sub t5 :ᕘ';
+ our $t5a = \&{"t5"};
+ our $t5b = $c;
+ $c=undef; eval 'sub t5 :ᕘ { }';
+ main::ok $c == \&{"t5"} && $c == $t5b && $c == $t5a;
+}
+
+# [perl #68560] Calling closure prototypes (only accessible via :attr)
+{
+ package brength;
+ my $proto;
+ sub MODIFY_CODE_ATTRIBUTES { $proto = $_[1]; _: }
+ eval q{
+ my $x;
+ () = sub :a0 { $x };
+ };
+ package main;
+ eval { $proto->() }; # used to crash in pp_entersub
+ like $@, qr/^Closure prototype called/,
+ "Calling closure proto with (no) args";
+ eval { () = &$proto }; # used to crash in pp_leavesub
+ like $@, qr/^Closure prototype called/,
+ 'Calling closure proto with no @_ that returns a lexical';
+}
+
+# [perl #68658] Attributes on stately variables
+{
+ package thwext;
+ sub MODIFY_SCALAR_ATTRIBUTES { () }
+ my $i = 0;
+ my $x_values = '';
+ eval 'sub ᕘ { use 5.01; state $x :A0 = $i++; $x_values .= $x }';
+ ᕘ(); ᕘ();
+ package main;
+ is $x_values, '00', 'state with attributes';
+}
+
+{
+ package 닌g난ㄬ;
+ sub MODIFY_SCALAR_ATTRIBUTES{}
+ sub MODIFY_ARRAY_ATTRIBUTES{ }
+ sub MODIFY_HASH_ATTRIBUTES{ }
+ my ($cows, @go, %bong) : テa퐅Š = qw[ jibber jabber joo ];
+ ::is $cows, 'jibber', 'list assignment to scalar with attrs';
+ ::is "@go", 'jabber joo', 'list assignment to array with attrs';
+}
+
+done_testing();
Copied: trunk/contrib/perl/t/uni/bless.t (from rev 6437, vendor/perl/5.18.1/t/uni/bless.t)
===================================================================
--- trunk/contrib/perl/t/uni/bless.t (rev 0)
+++ trunk/contrib/perl/t/uni/bless.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,124 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require './test.pl';
+}
+
+use utf8;
+use open qw( :utf8 :std );
+plan (84);
+
+sub expected {
+ my($object, $package, $type) = @_;
+ print "# $object $package $type\n";
+ is(ref($object), $package);
+ my $r = qr/^\Q$package\E=(\w+)\(0x([0-9a-f]+)\)$/u;
+ like("$object", $r);
+ if ("$object" =~ $r) {
+ is($1, $type);
+ # in 64-bit platforms hex warns for 32+ -bit values
+ cmp_ok(do {no warnings 'portable'; hex($2)}, '==', $object);
+ }
+ else {
+ fail(); fail();
+ }
+}
+
+# test blessing simple types
+
+$a1 = bless {}, "ዐ";
+expected($a1, "ዐ", "HASH");
+$b1 = bless [], "Ｂ";
+expected($b1, "Ｂ", "ARRAY");
+$c1 = bless \(map "$_", "test"), "ᶜ";
+expected($c1, "ᶜ", "SCALAR");
+$tèst = "foo"; $d1 = bless \*tèst, "ɖ";
+expected($d1, "ɖ", "GLOB");
+$e1 = bless sub { 1 }, "ಎ";
+expected($e1, "ಎ", "CODE");
+$f1 = bless \[], "ḟ";
+expected($f1, "ḟ", "REF");
+$g1 = bless \substr("test", 1, 2), "ㄍ";
+expected($g1, "ㄍ", "LVALUE");
+
+# blessing ref to object doesn't modify object
+
+expected(bless(\$a1, "ḟ"), "ḟ", "REF");
+expected($a1, "ዐ", "HASH");
+
+# reblessing does modify object
+
+bless $a1, "ዐ2";
+expected($a1, "ዐ2", "HASH");
+
+# local and my
+{
+ local $a1 = bless $a1, "ዐ3"; # should rebless outer $a1
+ local $b1 = bless [], "Ｂ3";
+ my $c1 = bless $c1, "ᶜ3"; # should rebless outer $c1
+ our $test2 = ""; my $d1 = bless \*test2, "ɖ3";
+ expected($a1, "ዐ3", "HASH");
+ expected($b1, "Ｂ3", "ARRAY");
+ expected($c1, "ᶜ3", "SCALAR");
+ expected($d1, "ɖ3", "GLOB");
+}
+expected($a1, "ዐ3", "HASH");
+expected($b1, "Ｂ", "ARRAY");
+expected($c1, "ᶜ3", "SCALAR");
+expected($d1, "ɖ", "GLOB");
+
+# class is magic
+"ಎ" =~ /(.)/;
+expected(bless({}, $1), "ಎ", "HASH");
+{
+ local $! = 1;
+ my $string = "$!";
+ $! = 2; # attempt to avoid cached string
+ $! = 1;
+ expected(bless({}, $!), $string, "HASH");
+
+# ref is ref to magic
+ {
+ {
+ package ḟ;
+ sub test { main::is(${$_[0]}, $string) }
+ }
+ $! = 2;
+ $f1 = bless \$!, "ḟ";
+ $! = 1;
+ $f1->test;
+ }
+}
+
+# ref is magic
+
+# class is a ref
+$a1 = bless {}, "ዐ4";
+$b1 = eval { bless {}, $a1 };
+isnt ($@, '', "class is a ref");
+
+# class is an overloaded ref
+=begin
+$TODO = "Package not yet clean";
+{
+ package ᚺ4;
+ use overload '""' => sub { "ᶜ4" };
+}
+$h1 = bless {}, "ᚺ4";
+$c4 = eval { bless \$test, $h1 };
+is ($@, '', "class is an overloaded ref");
+expected($c4, 'ᶜ4', "SCALAR");
+=cut
+
+{
+ my %h = 1..2;
+ my($k) = keys %h;
+ my $x=\$k;
+ bless $x, 'pàm';
+ is(ref $x, 'pàm');
+
+ my $a = bless \(keys %h), 'zàp';
+ is(ref $a, 'zàp');
+}
Modified: trunk/contrib/perl/t/uni/cache.t
===================================================================
--- trunk/contrib/perl/t/uni/cache.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/uni/cache.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -6,17 +6,28 @@
plan tests => 1;
-my $count = 0;
-unshift @INC, sub {
- # XXX Kludge requires exact path, which might change
- $count++ if $_[1] eq 'unicore/lib/Sc/Hira.pl';
-};
+# Looks to see if a "do 'unicore/lib/Sc/Hira.pl'" is called more than once, by
+# putting a compile sub first on the libary path;
+# XXX Kludge: requires exact path, which might change, and has deep knowledge
+# of how utf8_heavy.pl works, which might also change.
+BEGIN { # Make sure catches compile time references
+ $::count = 0;
+ unshift @INC, sub {
+ $::count++ if $_[1] eq 'unicore/lib/Sc/Hira.pl';
+ };
+}
+
my $s = 'foo';
-$s =~ m/[\p{Hiragana}]/;
-$s =~ m/[\p{Hiragana}]/;
-$s =~ m/[\p{Hiragana}]/;
-$s =~ m/[\p{Hiragana}]/;
+# The second value is to prevent an optimization that exists at the time this
+# is written to re-use a property without trying to look it up if it is the
+# only thing in a character class. They differ in order to make sure that any
+# future optimizations that don't re-use identical character classes don't come
+# into play
+$s =~ m/[\p{Hiragana}\x{101}]/;
+$s =~ m/[\p{Hiragana}\x{102}]/;
+$s =~ m/[\p{Hiragana}\x{103}]/;
+$s =~ m/[\p{Hiragana}\x{104}]/;
-is($count, 1, "Swatch hash caching kept us from reloading swatch hash.");
+is($::count, 1, "Swatch hash caching kept us from reloading swatch hash.");
Property changes on: trunk/contrib/perl/t/uni/cache.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/t/uni/caller.t (from rev 6437, vendor/perl/5.18.1/t/uni/caller.t)
===================================================================
--- trunk/contrib/perl/t/uni/caller.t (rev 0)
+++ trunk/contrib/perl/t/uni/caller.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,71 @@
+#!./perl
+# Tests for caller()
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require './test.pl';
+ plan( tests => 18 );
+}
+
+use utf8;
+use open qw( :utf8 :std );
+
+package ｍａｉｎ;
+
+{
+ local $@;
+ eval 'ok(1);';
+ ::like $@, qr/Undefined subroutine &ｍａｉｎ::ok called at/u;
+}
+my @c;
+
+sub { @c = caller(0) } -> ();
+::is( $c[3], "ｍａｉｎ::__ANON__", "anonymous subroutine name" );
+::ok( $c[4], "hasargs true with anon sub" );
+
+# Bug 20020517.003, used to dump core
+sub ｆｏｏ { @c = caller(0) }
+my $fooref = delete $ｍａｉｎ::{ｆｏｏ};
+$fooref -> ();
+::is( $c[3], "ｍａｉｎ::__ANON__", "deleted subroutine name" );
+::ok( $c[4], "hasargs true with deleted sub" );
+
+print "# Tests with caller(1)\n";
+
+sub ｆ { @c = caller(1) }
+
+sub ｃａｌｌｆ { ｆ(); }
+ｃａｌｌｆ();
+::is( $c[3], "ｍａｉｎ::ｃａｌｌｆ", "subroutine name" );
+::ok( $c[4], "hasargs true with ｃａｌｌｆ()" );
+&ｃａｌｌｆ;
+::ok( !$c[4], "hasargs false with &ｃａｌｌｆ" );
+
+eval { ｆ() };
+::is( $c[3], "(eval)", "subroutine name in an eval {}" );
+::ok( !$c[4], "hasargs false in an eval {}" );
+
+eval q{ ｆ() };
+::is( $c[3], "(eval)", "subroutine name in an eval ''" );
+::ok( !$c[4], "hasargs false in an eval ''" );
+
+sub { ｆ() } -> ();
+::is( $c[3], "ｍａｉｎ::__ANON__", "anonymous subroutine name" );
+::ok( $c[4], "hasargs true with anon sub" );
+
+sub ｆｏｏ2 { ｆ() }
+my $fooref2 = delete $ｍａｉｎ::{ｆｏｏ2};
+$fooref2 -> ();
+::is( $c[3], "ｍａｉｎ::__ANON__", "deleted subroutine name" );
+::ok( $c[4], "hasargs true with deleted sub" );
+
+sub ｐｂ { return (caller(0))[3] }
+
+::is( eval 'ｐｂ()', 'ｍａｉｎ::ｐｂ', "actually return the right function name" );
+
+my $saved_perldb = $^P;
+$^P = 16;
+$^P = $saved_perldb;
+
+::is( eval 'ｐｂ()', 'ｍａｉｎ::ｐｂ', 'actually return the right function name even if $^P had been on at some point' );
Modified: trunk/contrib/perl/t/uni/case.pl
===================================================================
--- trunk/contrib/perl/t/uni/case.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/uni/case.pl 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,4 +1,6 @@
require "test.pl";
+use strict;
+use warnings;
sub unidump {
join " ", map { sprintf "%04X", $_ } unpack "U*", $_[0];
@@ -5,7 +7,10 @@
}
sub casetest {
- my ($already_run, $base, $spec, @funcs) = @_;
+ my ($already_run, $base, @funcs) = @_;
+
+ my %spec;
+
# For each provided function run it, and run a version with some extra
# characters afterwards. Use a recycling symbol, as it doesn't change case.
# $already_run is the number of extra tests the caller has run before this
@@ -20,13 +25,33 @@
},
)} @funcs;
- my $file = "../lib/unicore/To/$base.pl";
- my $simple = do $file or die $@;
+ use Unicode::UCD 'prop_invmap';
+
+ # Get the case mappings
+ my ($invlist_ref, $invmap_ref, undef, $default) = prop_invmap($base);
my %simple;
- for my $i (split(/\n/, $simple)) {
- my ($k, $v) = split(' ', $i);
- $simple{$k} = $v;
+
+ for my $i (0 .. @$invlist_ref - 1 - 1) {
+ next if $invmap_ref->[$i] == $default;
+
+ # Add simple mappings to the simples test list
+ if (! ref $invmap_ref->[$i]) {
+
+ # The returned map needs to have adjustments made. Each
+ # subsequent element of the range requires adjustment of +1 from
+ # the previous element
+ my $adjust = 0;
+ for my $k ($invlist_ref->[$i] .. $invlist_ref->[$i+1] - 1) {
+ $simple{$k} = $invmap_ref->[$i] + $adjust++;
+ }
+ }
+ else { # The return is a list of the characters mapped-to.
+ # prop_invmap() guarantees a single element in the range in
+ # this case, so no adjustments are needed.
+ $spec{$invlist_ref->[$i]} = pack "U0U*" , @{$invmap_ref->[$i]};
+ }
}
+
my %seen;
for my $i (sort keys %simple) {
@@ -34,18 +59,13 @@
}
print "# ", scalar keys %simple, " simple mappings\n";
- my $both;
-
- for my $i (sort keys %$spec) {
+ for my $i (sort keys %spec) {
if (++$seen{$i} == 2) {
warn sprintf "$base: $i seen twice\n";
- $both++;
}
}
- print "# ", scalar keys %$spec, " special mappings\n";
+ print "# ", scalar keys %spec, " special mappings\n";
- exit(1) if $both;
-
my %none;
for my $i (map { ord } split //,
"\e !\"#\$%&'()+,-./0123456789:;<=>?\@[\\]^_{|}~\b") {
@@ -57,7 +77,7 @@
my $tests =
$already_run +
((scalar keys %simple) +
- (scalar keys %$spec) +
+ (scalar keys %spec) +
(scalar keys %none)) * @funcs;
my $test = $already_run + 1;
@@ -64,94 +84,36 @@
for my $i (sort keys %simple) {
my $w = $simple{$i};
- my $c = pack "U0U", hex $i;
+ my $c = pack "U0U", $i;
foreach my $func (@funcs) {
my $d = $func->($c);
my $e = unidump($d);
- print $d eq pack("U0U", hex $simple{$i}) ?
- "ok $test # $i -> $w\n" : "not ok $test # $i -> $e ($w)\n";
- $test++;
+ is( $d, pack("U0U", $simple{$i}), "$i -> $e ($w)" );
}
}
- for my $i (sort keys %$spec) {
- my $w = unidump($spec->{$i});
- if (ord('A') == 193 && $i eq "\x8A\x73") {
- $w = '0178'; # It's a Latin small Y with diaeresis and not a Latin small letter sharp 's'.
- }
- my $u = unpack "C0U", $i;
- my $h = sprintf "%04X", $u;
- my $c = chr($u); $c .= chr(0x100); chop $c;
+ for my $i (sort keys %spec) {
+ my $w = unidump($spec{$i});
+ my $h = sprintf "%04X", $i;
+ my $c = chr($i); $c .= chr(0x100); chop $c;
foreach my $func (@funcs) {
my $d = $func->($c);
my $e = unidump($d);
- if (ord "A" == 193) { # EBCDIC
- # We need to a little bit of remapping.
- #
- # For example, in titlecase (ucfirst) mapping
- # of U+0149 the Unicode mapping is U+02BC U+004E.
- # The 4E is N, which in EBCDIC is 2B--
- # and the ucfirst() does that right.
- # The problem is that our reference
- # data is in Unicode code points.
- #
- # The Right Way here would be to use, say,
- # Encode, to remap the less-than 0x100 code points,
- # but let's try to be Encode-independent here.
- #
- # These are the titlecase exceptions:
- #
- # Unicode Unicode+EBCDIC
- #
- # 0149 -> 02BC 004E (02BC 002B)
- # 01F0 -> 004A 030C (00A2 030C)
- # 1E96 -> 0048 0331 (00E7 0331)
- # 1E97 -> 0054 0308 (00E8 0308)
- # 1E98 -> 0057 030A (00EF 030A)
- # 1E99 -> 0059 030A (00DF 030A)
- # 1E9A -> 0041 02BE (00A0 02BE)
- #
- # The uppercase exceptions are identical.
- #
- # The lowercase has one more:
- #
- # Unicode Unicode+EBCDIC
- #
- # 0130 -> 0069 0307 (00D1 0307)
- #
- if ($h =~ /^(0130|0149|01F0|1E96|1E97|1E98|1E99|1E9A)$/) {
- $e =~ s/004E/002B/; # N
- $e =~ s/004A/00A2/; # J
- $e =~ s/0048/00E7/; # H
- $e =~ s/0054/00E8/; # T
- $e =~ s/0057/00EF/; # W
- $e =~ s/0059/00DF/; # Y
- $e =~ s/0041/00A0/; # A
- $e =~ s/0069/00D1/; # i
- }
- # We have to map the output, not the input, because
- # pack/unpack U has been EBCDICified, too, it would
- # just undo our remapping.
- }
- print $w eq $e ?
- "ok $test # $i -> $w\n" : "not ok $test # $h -> $e ($w)\n";
- $test++;
+ is( $w, $e, "$h -> $e ($w)" );
}
}
for my $i (sort { $a <=> $b } keys %none) {
+ my $c = pack "U0U", $i;
my $w = $i = sprintf "%04X", $i;
- my $c = pack "U0U", hex $i;
foreach my $func (@funcs) {
my $d = $func->($c);
my $e = unidump($d);
- print $d eq $c ?
- "ok $test # $i -> $w\n" : "not ok $test # $i -> $e ($w)\n";
- $test++;
+ is( $d, $c, "$i -> $e ($w)" );
}
}
- print "1..$tests\n";
+ done_testing();
}
1;
Property changes on: trunk/contrib/perl/t/uni/case.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/t/uni/chomp.t
===================================================================
--- trunk/contrib/perl/t/uni/chomp.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/uni/chomp.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/uni/chomp.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/uni/chr.t
===================================================================
--- trunk/contrib/perl/t/uni/chr.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/uni/chr.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -8,7 +8,8 @@
}
use strict;
-plan (tests => 6);
+plan (tests => 8);
+no warnings 'deprecated';
use encoding 'johab';
ok(chr(0x7f) eq "\x7f");
@@ -19,4 +20,13 @@
ok(chr($i) eq pack('C', $i));
}
+# [perl #83048]
+{
+ my $w;
+ local $SIG{__WARN__} = sub { $w .= $_[0] };
+ my $chr = chr(-1);
+ is($chr, "\x{fffd}", "invalid values become REPLACEMENT CHARACTER");
+ like($w, qr/^Invalid negative number \(-1\) in chr at /, "with a warning");
+}
+
__END__
Property changes on: trunk/contrib/perl/t/uni/chr.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/uni/class.t
===================================================================
--- trunk/contrib/perl/t/uni/class.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/uni/class.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -4,8 +4,13 @@
require "test.pl";
}
-plan tests => 10;
+plan tests => 11;
+my $str = join "", map latin1_to_native(chr($_)), 0x20 .. 0x6F;
+
+is(($str =~ /(\p{IsMyUniClass}+)/)[0], '0123456789:;<=>?@ABCDEFGHIJKLMNO',
+ 'user-defined class compiled before defined');
+
sub IsMyUniClass {
<<END;
0030 004F
@@ -50,8 +55,6 @@
use strict;
-my $str = join "", map latin1_to_native(chr($_)), 0x20 .. 0x6F;
-
# make sure it finds built-in class
is(($str =~ /(\p{Letter}+)/)[0], 'ABCDEFGHIJKLMNOPQRSTUVWXYZ');
is(($str =~ /(\p{l}+)/)[0], 'ABCDEFGHIJKLMNOPQRSTUVWXYZ');
Property changes on: trunk/contrib/perl/t/uni/class.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Copied: trunk/contrib/perl/t/uni/eval.t (from rev 6437, vendor/perl/5.18.1/t/uni/eval.t)
===================================================================
--- trunk/contrib/perl/t/uni/eval.t (rev 0)
+++ trunk/contrib/perl/t/uni/eval.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,42 @@
+#!./perl
+
+# Check if eval correctly ignores the UTF-8 hint.
+
+BEGIN {
+ require './test.pl';
+}
+
+plan (tests => 5);
+
+use open qw( :utf8 :std );
+use feature 'unicode_eval';
+
+{
+ my $w;
+ $SIG{__WARN__} = sub { $w = shift };
+ use utf8;
+ my $prog = "qq!\x{f9}!";
+
+ eval $prog;
+ ok !$w;
+
+ $w = "";
+ utf8::upgrade($prog);
+ eval $prog;
+ is $w, '';
+}
+
+{
+ use utf8;
+ isnt eval "q!\360\237\220\252!", eval "q!\x{1f42a}!";
+}
+
+{
+ no utf8; #Let's make real sure.
+ my $not_utf8 = "q!\343\203\213!";
+ isnt eval $not_utf8, eval "q!\x{30cb}!";
+ {
+ use utf8;
+ isnt eval $not_utf8, eval "q!\x{30cb}!";
+ }
+}
Modified: trunk/contrib/perl/t/uni/fold.t
===================================================================
--- trunk/contrib/perl/t/uni/fold.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/uni/fold.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -2,47 +2,66 @@
use warnings;
# re/fold_grind.t has more complex tests, but doesn't test every fold
+# This file also tests the fc() keyword.
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
+ require Config; import Config;
require './test.pl';
}
+use feature 'unicode_strings';
+use Unicode::UCD qw(all_casefolds);
+
binmode *STDOUT, ":utf8";
our $TODO;
+
plan("no_plan");
-
# Read in the official case folding definitions.
-my $CF = '../lib/unicore/CaseFolding.txt';
-
-die qq[$0: failed to open "$CF": $!\n] if ! open(my $fh, "<", $CF);
-
+my $casefolds = all_casefolds();
+my @folds;
my @CF;
+my @simple_folds;
my %reverse_fold;
-while (<$fh>) {
- # Skip S since we are going for 'F'ull case folding. I is obsolete starting
- # with Unicode 3.2, but leaving it in does no harm, and allows backward
- # compatibility
- next unless my ($code, $type, $mapping, $name) = $_ =~
- /^([0-9A-F]+); ([CFI]); ((?:[0-9A-F]+)(?: [0-9A-F]+)*); \# (.+)/;
+use Unicode::UCD;
+use charnames();
- # Convert any 0-255 range chars to native.
- $code = sprintf("%04X", ord_latin1_to_native(hex $code)) if hex $code < 0x100;
- $mapping = join " ", map { $_ =
- sprintf("%04X", ord_latin1_to_native(hex $_)) }
- split / /, $mapping;
+foreach my $decimal_code_point (sort { $a <=> $b } keys %$casefolds) {
+ # We only use simple folds in fc(), since the regex engine uses full case
+ # folding.
- push @CF, [$code, $mapping, $type, $name];
+ my $name = charnames::viacode($decimal_code_point);
+ my $type = $casefolds->{$decimal_code_point}{'status'};
+ my $code = $casefolds->{$decimal_code_point}{'code'};
+ my $simple = $casefolds->{$decimal_code_point}{'simple'};
+ my $full = $casefolds->{$decimal_code_point}{'full'};
+ if ($simple && $simple ne $full) { # If there is a distinction
+ push @simple_folds, [ $code, $simple, $type, $name ];
+ }
+
+ push @CF, [ $code, $full, $type, $name ];
+
# Get the inverse fold for single-char mappings.
- $reverse_fold{pack "U0U*", hex $mapping} = pack "U0U*", hex $code if $type ne 'F';
+ $reverse_fold{pack "U0U*", hex $simple} = pack "U0U*", $decimal_code_point if $simple;
}
-close($fh) or die "$0 Couldn't close $CF";
+foreach my $test_ref ( @simple_folds ) {
+ use feature 'fc';
+ my ($code, $mapping, $type, $name) = @$test_ref;
+ my $c = pack("U0U*", hex $code);
+ my $f = pack("U0U*", map { hex } split " ", $mapping);
+ my $against = join "", "qq{", map("\\x{$_}", split " ", $mapping), "}";
+ {
+ isnt(fc($c), $f, "$code - $name - $mapping - $type - Full casefolding, fc(\\x{$code}) ne $against");
+ isnt("\F$c", $f, "$code - $name - $mapping - $type - Full casefolding, qq{\\F\\x{$code}} ne $against");
+ }
+}
+
foreach my $test_ref (@CF) {
my ($code, $mapping, $type, $name) = @$test_ref;
my $c = pack("U0U*", hex $code);
@@ -60,6 +79,24 @@
ok eval $test, "$code - $name - $mapping - $type - $test";
}
+ {
+ # fc() tests
+ my $against = join "", "qq{", map("\\x{$_}", split " ", $mapping), "}";
+ is(CORE::fc($c), $f,
+ "$code - $name - $mapping - $type - fc(\\x{$code}) eq $against");
+ is("\F$c", $f, "$code - $name - $mapping - $type - qq{\\F\\x{$code}} eq $against");
+
+ # And here we test bytes. For [A-Za-z0-9], the fold is the same as lc under
+ # bytes. For everything else, it's the bytes that formed the original string.
+ if ( $c =~ /[A-Za-z0-9]/ ) {
+ use bytes;
+ is(CORE::fc($c), lc($c), "$code - $name - fc and use bytes, ascii");
+ } else {
+ my $copy = "" . $c;
+ utf8::encode($copy);
+ is($copy, do { use bytes; CORE::fc($c) }, "$code - $name - fc and use bytes");
+ }
+ }
# Certain tests weren't convenient to put in the list above since they are
# TODO's in multi-character folds.
if ($f_length == 1) {
@@ -115,8 +152,298 @@
}
}
+{
+ use utf8;
+ use feature qw(fc);
+ # These three come from the ICU project's test suite, more especifically
+ # http://icu.sourcearchive.com/documentation/4.4~rc1-1/strcase_8cpp-source.html
+
+ my $s = "A\N{U+00df}\N{U+00b5}\N{U+fb03}\N{U+1040C}\N{U+0130}\N{U+0131}";
+ #\N{LATIN CAPITAL LETTER A}\N{LATIN SMALL LETTER SHARP S}\N{MICRO SIGN}\N{LATIN SMALL LIGATURE FFI}\N{DESERET CAPITAL LETTER AY}\N{LATIN CAPITAL LETTER I WITH DOT ABOVE}\N{LATIN SMALL LETTER DOTLESS I}
+
+ my $f = "ass\N{U+03bc}ffi\N{U+10434}i\N{U+0307}\N{U+0131}";
+ #\N{LATIN SMALL LETTER A}\N{LATIN SMALL LETTER S}\N{LATIN SMALL LETTER S}\N{GREEK SMALL LETTER MU}\N{LATIN SMALL LETTER F}\N{LATIN SMALL LETTER F}\N{LATIN SMALL LETTER I}\N{DESERET SMALL LETTER AY}\N{LATIN SMALL LETTER I}\N{COMBINING DOT ABOVE}\N{LATIN SMALL LETTER DOTLESS I}
+
+ is(fc($s), $f, "ICU's casefold test passes");
+ is("\F$s", $f, "ICU's casefold test passes");
+
+ is( fc("aBİIıϐßffi\x{5FFFF}"), "abi̇iıβssffi\x{5FFFF}" );
+ is( "\FaBİIıϐßffi\x{5FFFF}", "abi̇iıβssffi\x{5FFFF}" );
+# TODO: {
+# local $::TODO = "turkic special cases";
+# is( fc "aBİIıϐßffi\x{5FFFF}", "abiııβssffi\x{5FFFF}" );
+# }
+
+ # The next batch come from http://www.devdaily.com/java/jwarehouse/lucene/contrib/icu/src/test/org/apache/lucene/analysis/icu/TestICUFoldingFilter.java.shtml
+ # Except the article got most casings wrong. Or maybe Lucene does.
+
+ is( fc("This is a test"), "this is a test" );
+ is( fc("Ruß"), "russ" );
+ is( fc("ΜΆΪΟΣ"), "μάϊοσ" );
+ is( fc("Μάϊος"), "μάϊοσ" );
+ is( fc("𐐖"), "𐐾" );
+ is( fc("r\xe9sum\xe9"), "r\xe9sum\xe9" );
+ is( fc("re\x{0301}sume\x{0301}"), "re\x{301}sume\x{301}" );
+ is( fc("ELİF"), "eli\x{307}f" );
+ is( fc("eli\x{307}f"), "eli\x{307}f");
+
+ # This batch comes from
+ # http://www.java2s.com/Open-Source/Java-Document/Internationalization-Localization/icu4j/com/ibm/icu/dev/test/lang/UCharacterCaseTest.java.htm
+ # Which uses ICU as the backend.
+
+ my @folding_mixed = (
+ "\x{61}\x{42}\x{130}\x{49}\x{131}\x{3d0}\x{df}\x{fb03}",
+ "A\x{df}\x{b5}\x{fb03}\x{1040C}\x{130}\x{131}",
+ );
+
+ my @folding_default = (
+ "\x{61}\x{62}\x{69}\x{307}\x{69}\x{131}\x{3b2}\x{73}\x{73}\x{66}\x{66}\x{69}",
+ "ass\x{3bc}ffi\x{10434}i\x{307}\x{131}",
+ );
+
+ my @folding_exclude_turkic = (
+ "\x{61}\x{62}\x{69}\x{131}\x{131}\x{3b2}\x{73}\x{73}\x{66}\x{66}\x{69}",
+ "ass\x{3bc}ffi\x{10434}i\x{131}",
+ );
+
+ is( fc($folding_mixed[1]), $folding_default[1] );
+
+ is( fc($folding_mixed[0]), $folding_default[0] );
+
+}
+
+{
+ use utf8;
+ # Table stolen from tchrist's mail in
+ # http://bugs.python.org/file23051/casing-tests.py
+ # and http://98.245.80.27/tcpc/OSCON2011/case-test.python3
+ # For reference, it's a longer version of what he posted here:
+ # http://stackoverflow.com/questions/6991038/case-insensitive-storage-and-unicode-compatibility
+
+ #Couple of repeats because I'm lazy, not tchrist's fault.
+
+ #This should probably go in t/op/lc.t
+
+ my @test_table = (
+# ORIG LC_SIMPLE TC_SIMPLE UC_SIMPLE LC_FULL TC_FULL UC_FULL FC_SIMPLE FC_TURKIC FC_FULL
+[ 'þǽr rihtes', 'þǽr rihtes', 'Þǽr Rihtes', 'ÞǼR RIHTES', 'þǽr rihtes', 'Þǽr Rihtes', 'ÞǼR RIHTES', 'þǽr rihtes', 'þǽr rihtes', 'þǽr rihtes', ],
+[ 'duȝeðlice', 'duȝeðlice', 'Duȝeðlice', 'DUȜEÐLICE', 'duȝeðlice', 'Duȝeðlice', 'DUȜEÐLICE', 'duȝeðlice', 'duȝeðlice', 'duȝeðlice', ],
+[ 'Ævar Arnfjörð Bjarmason', 'ævar arnfjörð bjarmason', 'Ævar Arnfjörð Bjarmason', 'ÆVAR ARNFJÖRÐ BJARMASON', 'ævar arnfjörð bjarmason', 'Ævar Arnfjörð Bjarmason', 'ÆVAR ARNFJÖRÐ BJARMASON', 'ævar arnfjörð bjarmason', 'ævar arnfjörð bjarmason', 'ævar arnfjörð bjarmason', ],
+[ 'Кириллица', 'кириллица', 'Кириллица', 'КИРИЛЛИЦА', 'кириллица', 'Кириллица', 'КИРИЛЛИЦА', 'кириллица', 'кириллица', 'кириллица', ],
+[ 'ij', 'ij', 'IJ', 'IJ', 'ij', 'IJ', 'IJ', 'ij', 'ij', 'ij', ],
+[ 'Van Dijke', 'van dijke', 'Van Dijke', 'VAN DIJKE', 'van dijke', 'Van Dijke', 'VAN DIJKE', 'van dijke', 'van dijke', 'van dijke', ],
+[ 'VAN DIJKE', 'van dijke', 'Van Dijke', 'VAN DIJKE', 'van dijke', 'Van Dijke', 'VAN DIJKE', 'van dijke', 'van dijke', 'van dijke', ],
+[ 'efficient', 'efficient', 'Efficient', 'EffiCIENT', 'efficient', 'Efficient', 'EFFICIENT', 'efficient', 'efficient', 'efficient', ],
+[ 'flour', 'flour', 'flour', 'flOUR', 'flour', 'Flour', 'FLOUR', 'flour', 'flour', 'flour', ],
+[ 'flour and water', 'flour and water', 'flour And Water', 'flOUR AND WATER', 'flour and water', 'Flour And Water', 'FLOUR AND WATER', 'flour and water', 'flour and water', 'flour and water', ],
+[ 'dzur', 'dzur', 'Dzur', 'DZUR', 'dzur', 'Dzur', 'DZUR', 'dzur', 'dzur', 'dzur', ],
+[ 'Dzur', 'dzur', 'Dzur', 'DZUR', 'dzur', 'Dzur', 'DZUR', 'dzur', 'dzur', 'dzur', ],
+[ 'DZUR', 'dzur', 'Dzur', 'DZUR', 'dzur', 'Dzur', 'DZUR', 'dzur', 'dzur', 'dzur', ],
+[ 'dzur mountain', 'dzur mountain', 'Dzur Mountain', 'DZUR MOUNTAIN', 'dzur mountain', 'Dzur Mountain', 'DZUR MOUNTAIN', 'dzur mountain', 'dzur mountain', 'dzur mountain', ],
+[ 'Dzur Mountain', 'dzur mountain', 'Dzur Mountain', 'DZUR MOUNTAIN', 'dzur mountain', 'Dzur Mountain', 'DZUR MOUNTAIN', 'dzur mountain', 'dzur mountain', 'dzur mountain', ],
+[ 'DZUR MOUNTAIN', 'dzur mountain', 'Dzur Mountain', 'DZUR MOUNTAIN', 'dzur mountain', 'Dzur Mountain', 'DZUR MOUNTAIN', 'dzur mountain', 'dzur mountaın', 'dzur mountain', ],
+[ 'poſt', 'poſt', 'Poſt', 'POST', 'poſt', 'Poſt', 'POST', 'post', 'post', 'post', ],
+[ 'poſt', 'poſt', 'Poſt', 'POſt', 'poſt', 'Poſt', 'POST', 'poſt', 'post', 'post', ],
+[ 'ſtop', 'ſtop', 'ſtop', 'ſtOP', 'ſtop', 'Stop', 'STOP', 'ſtop', 'stop', 'stop', ],
+[ 'tschüß', 'tschüß', 'Tschüß', 'TSCHÜß', 'tschüß', 'Tschüß', 'TSCHÜSS', 'tschüß', 'tschüss', 'tschüss', ],
+[ 'TSCHÜẞ', 'tschüß', 'Tschüß', 'TSCHÜẞ', 'tschüß', 'Tschüß', 'TSCHÜẞ', 'tschüß', 'tschüss', 'tschüss', ],
+[ 'weiß', 'weiß', 'Weiß', 'WEIß', 'weiß', 'Weiß', 'WEISS', 'weiß', 'weiss', 'weiss', ],
+[ 'WEIẞ', 'weiß', 'Weiß', 'WEIẞ', 'weiß', 'Weiß', 'WEIẞ', 'weiß', 'weıss', 'weiss', ],
+[ 'ẞIEW', 'ßiew', 'ẞiew', 'ẞIEW', 'ßiew', 'ẞiew', 'ẞIEW', 'ßiew', 'ssıew', 'ssiew', ],
+[ 'ᾲ', 'ᾲ', 'Ὰͅ', 'ᾺΙ', 'ᾲ', 'Ὰͅ', 'ᾺΙ', 'ὰι', 'ὰι', 'ὰι', ],
+[ 'Ὰι', 'ὰι', 'Ὰι', 'ᾺΙ', 'ὰι', 'Ὰι', 'ᾺΙ', 'ὰι', 'ὰι', 'ὰι', ],
+[ 'ᾺΙ', 'ὰι', 'Ὰι', 'ᾺΙ', 'ὰι', 'Ὰι', 'ᾺΙ', 'ὰι', 'ὰι', 'ὰι', ],
+[ 'ᾲ', 'ᾲ', 'ᾲ', 'ᾲ', 'ᾲ', 'Ὰͅ', 'ᾺΙ', 'ᾲ', 'ὰι', 'ὰι', ],
+[ 'Ὰͅ', 'ᾲ', 'Ὰͅ', 'ᾺΙ', 'ᾲ', 'Ὰͅ', 'ᾺΙ', 'ὰι', 'ὰι', 'ὰι', ],
+[ 'ᾺΙ', 'ὰι', 'Ὰι', 'ᾺΙ', 'ὰι', 'Ὰι', 'ᾺΙ', 'ὰι', 'ὰι', 'ὰι', ],
+[ 'ᾲ στο διάολο', 'ᾲ στο διάολο', 'ᾲ Στο Διάολο', 'ᾲ ΣΤΟ ΔΙΆΟΛΟ', 'ᾲ στο διάολο', 'Ὰͅ Στο Διάολο', 'ᾺΙ ΣΤΟ ΔΙΆΟΛΟ', 'ᾲ στο διάολο', 'ὰι στο διάολο', 'ὰι στο διάολο', ],
+[ 'ᾲ στο διάολο', 'ᾲ στο διάολο', 'Ὰͅ Στο Διάολο', 'ᾺΙ ΣΤΟ ΔΙΆΟΛΟ', 'ᾲ στο διάολο', 'Ὰͅ Στο Διάολο', 'ᾺΙ ΣΤΟ ΔΙΆΟΛΟ', 'ὰι στο διάολο', 'ὰι στο διάολο', 'ὰι στο διάολο', ],
+[ '𐐼𐐯𐑅𐐨𐑉𐐯𐐻', '𐐼𐐯𐑅𐐨𐑉𐐯𐐻', '𐐔𐐯𐑅𐐨𐑉𐐯𐐻', '𐐔𐐇𐐝𐐀𐐡𐐇𐐓', '𐐼𐐯𐑅𐐨𐑉𐐯𐐻', '𐐔𐐯𐑅𐐨𐑉𐐯𐐻', '𐐔𐐇𐐝𐐀𐐡𐐇𐐓', '𐐼𐐯𐑅𐐨𐑉𐐯𐐻', '𐐼𐐯𐑅𐐨𐑉𐐯𐐻', '𐐼𐐯𐑅𐐨𐑉𐐯𐐻', ],
+[ '𐐔𐐯𐑅𐐨𐑉𐐯𐐻', '𐐼𐐯𐑅𐐨𐑉𐐯𐐻', '𐐔𐐯𐑅𐐨𐑉𐐯𐐻', '𐐔𐐇𐐝𐐀𐐡𐐇𐐓', '𐐼𐐯𐑅𐐨𐑉𐐯𐐻', '𐐔𐐯𐑅𐐨𐑉𐐯𐐻', '𐐔𐐇𐐝𐐀𐐡𐐇𐐓', '𐐼𐐯𐑅𐐨𐑉𐐯𐐻', '𐐼𐐯𐑅𐐨𐑉𐐯𐐻', '𐐼𐐯𐑅𐐨𐑉𐐯𐐻', ],
+[ '𐐔𐐇𐐝𐐀𐐡𐐇𐐓', '𐐼𐐯𐑅𐐨𐑉𐐯𐐻', '𐐔𐐯𐑅𐐨𐑉𐐯𐐻', '𐐔𐐇𐐝𐐀𐐡𐐇𐐓', '𐐼𐐯𐑅𐐨𐑉𐐯𐐻', '𐐔𐐯𐑅𐐨𐑉𐐯𐐻', '𐐔𐐇𐐝𐐀𐐡𐐇𐐓', '𐐼𐐯𐑅𐐨𐑉𐐯𐐻', '𐐼𐐯𐑅𐐨𐑉𐐯𐐻', '𐐼𐐯𐑅𐐨𐑉𐐯𐐻', ],
+[ 'henry ⅷ', 'henry ⅷ', 'Henry Ⅷ', 'HENRY Ⅷ', 'henry ⅷ', 'Henry Ⅷ', 'HENRY Ⅷ', 'henry ⅷ', 'henry ⅷ', 'henry ⅷ', ],
+[ 'Henry Ⅷ', 'henry ⅷ', 'Henry Ⅷ', 'HENRY Ⅷ', 'henry ⅷ', 'Henry Ⅷ', 'HENRY Ⅷ', 'henry ⅷ', 'henry ⅷ', 'henry ⅷ', ],
+[ 'HENRY Ⅷ', 'henry ⅷ', 'Henry Ⅷ', 'HENRY Ⅷ', 'henry ⅷ', 'Henry Ⅷ', 'HENRY Ⅷ', 'henry ⅷ', 'henry ⅷ', 'henry ⅷ', ],
+[ 'i work at ⓚ', 'i work at ⓚ', 'I Work At Ⓚ', 'I WORK AT Ⓚ', 'i work at ⓚ', 'I Work At Ⓚ', 'I WORK AT Ⓚ', 'i work at ⓚ', 'i work at ⓚ', 'i work at ⓚ', ],
+[ 'I Work At Ⓚ', 'i work at ⓚ', 'I Work At Ⓚ', 'I WORK AT Ⓚ', 'i work at ⓚ', 'I Work At Ⓚ', 'I WORK AT Ⓚ', 'i work at ⓚ', 'ı work at ⓚ', 'i work at ⓚ', ],
+[ 'I WORK AT Ⓚ', 'i work at ⓚ', 'I Work At Ⓚ', 'I WORK AT Ⓚ', 'i work at ⓚ', 'I Work At Ⓚ', 'I WORK AT Ⓚ', 'i work at ⓚ', 'ı work at ⓚ', 'i work at ⓚ', ],
+[ 'istambul', 'istambul', 'Istambul', 'ISTAMBUL', 'istambul', 'Istambul', 'ISTAMBUL', 'istambul', 'istambul', 'istambul', ],
+[ 'i̇stanbul', 'i̇stanbul', 'İstanbul', 'İSTANBUL', 'i̇stanbul', 'İstanbul', 'İSTANBUL', 'i̇stanbul', 'i̇stanbul', 'i̇stanbul', ],
+[ 'İstanbul', 'i̇stanbul', 'İstanbul', 'İSTANBUL', 'i̇stanbul', 'İstanbul', 'İSTANBUL', 'i̇stanbul', 'ı̇stanbul', 'i̇stanbul', ],
+[ 'İSTANBUL', 'istanbul', 'İstanbul', 'İSTANBUL', 'i̇stanbul', 'İstanbul', 'İSTANBUL', 'İstanbul', 'istanbul', 'i̇stanbul', ],
+[ 'στιγμας', 'στιγμας', 'Στιγμας', 'ΣΤΙΓΜΑΣ', 'στιγμας', 'Στιγμας', 'ΣΤΙΓΜΑΣ', 'στιγμασ', 'στιγμασ', 'στιγμασ', ],
+[ 'στιγμασ', 'στιγμασ', 'Στιγμασ', 'ΣΤΙΓΜΑΣ', 'στιγμασ', 'Στιγμασ', 'ΣΤΙΓΜΑΣ', 'στιγμασ', 'στιγμασ', 'στιγμασ', ],
+[ 'ΣΤΙΓΜΑΣ', 'στιγμασ', 'Στιγμασ', 'ΣΤΙΓΜΑΣ', 'στιγμασ', 'Στιγμασ', 'ΣΤΙΓΜΑΣ', 'στιγμασ', 'στιγμασ', 'στιγμασ', ],
+[ 'ʀᴀʀᴇ', 'ʀᴀʀᴇ', 'Ʀᴀʀᴇ', 'ƦᴀƦᴇ', 'ʀᴀʀᴇ', 'Ʀᴀʀᴇ', 'ƦᴀƦᴇ', 'ʀᴀʀᴇ', 'ʀᴀʀᴇ', 'ʀᴀʀᴇ', ],
+[ 'Ʀᴀʀᴇ', 'ʀᴀʀᴇ', 'Ʀᴀʀᴇ', 'ƦᴀƦᴇ', 'ʀᴀʀᴇ', 'Ʀᴀʀᴇ', 'ƦᴀƦᴇ', 'ʀᴀʀᴇ', 'ʀᴀʀᴇ', 'ʀᴀʀᴇ', ],
+[ 'ƦᴀƦᴇ', 'ʀᴀʀᴇ', 'Ʀᴀʀᴇ', 'ƦᴀƦᴇ', 'ʀᴀʀᴇ', 'Ʀᴀʀᴇ', 'ƦᴀƦᴇ', 'ʀᴀʀᴇ', 'ʀᴀʀᴇ', 'ʀᴀʀᴇ', ],
+[ 'Ԧԧ', 'ԧԧ', 'Ԧԧ', 'ԦԦ', 'ԧԧ', 'Ԧԧ', 'ԦԦ', 'ԧԧ', 'ԧԧ', 'ԧԧ', ],
+[ 'ԧԧ', 'ԧԧ', 'Ԧԧ', 'ԦԦ', 'ԧԧ', 'Ԧԧ', 'ԦԦ', 'ԧԧ', 'ԧԧ', 'ԧԧ', ],
+[ 'Ԧԧ', 'ԧԧ', 'Ԧԧ', 'ԦԦ', 'ԧԧ', 'Ԧԧ', 'ԦԦ', 'ԧԧ', 'ԧԧ', 'ԧԧ', ],
+[ 'ԦԦ', 'ԧԧ', 'Ԧԧ', 'ԦԦ', 'ԧԧ', 'Ԧԧ', 'ԦԦ', 'ԧԧ', 'ԧԧ', 'ԧԧ', ],
+[ "þǽr rihtes", "þǽr rihtes", "Þǽr Rihtes", "ÞǼR RIHTES", "þǽr rihtes", "Þǽr Rihtes", "ÞǼR RIHTES", "þǽr rihtes", "þǽr rihtes", "þǽr rihtes", ],
+[ "duȝeðlice", "duȝeðlice", "Duȝeðlice", "DUȜEÐLICE", "duȝeðlice", "Duȝeðlice", "DUȜEÐLICE", "duȝeðlice", "duȝeðlice", "duȝeðlice", ],
+[ "Van Dijke", "van dijke", "Van Dijke", "VAN DIJKE", "van dijke", "Van Dijke", "VAN DIJKE", "van dijke", "van dijke", "van dijke", ],
+[ "fi", "fi", "fi", "fi", "fi", "Fi", "FI", "fi", "fi", "fi", ],
+[ "filesystem", "filesystem", "filesystem", "fiLESYSTEM", "filesystem", "Filesystem", "FILESYSTEM", "filesystem", "filesystem", "filesystem", ],
+[ "efficient", "efficient", "Efficient", "EffiCIENT", "efficient", "Efficient", "EFFICIENT", "efficient", "efficient", "efficient", ],
+[ "flour and water", "flour and water", "flour And Water", "flOUR AND WATER", "flour and water", "Flour And Water", "FLOUR AND WATER", "flour and water", "flour and water", "flour and water", ],
+[ "dz", "dz", "Dz", "DZ", "dz", "Dz", "DZ", "dz", "dz", "dz", ],
+[ "dzur mountain", "dzur mountain", "Dzur Mountain", "DZUR MOUNTAIN", "dzur mountain", "Dzur Mountain", "DZUR MOUNTAIN", "dzur mountain", "dzur mountain", "dzur mountain", ],
+[ "poſt", "poſt", "Poſt", "POST", "poſt", "Poſt", "POST", "post", "post", "post", ],
+[ "poſt", "poſt", "Poſt", "POſt", "poſt", "Poſt", "POST", "poſt", "post", "post", ],
+[ "ſtop", "ſtop", "ſtop", "ſtOP", "ſtop", "Stop", "STOP", "ſtop", "stop", "stop", ],
+[ "tschüß", "tschüß", "Tschüß", "TSCHÜß", "tschüß", "Tschüß", "TSCHÜSS", "tschüß", "tschüss", "tschüss", ],
+[ "TSCHÜẞ", "tschüß", "Tschüß", "TSCHÜẞ", "tschüß", "Tschüß", "TSCHÜẞ", "tschüß", "tschüss", "tschüss", ],
+[ "rußland", "rußland", "Rußland", "RUßLAND", "rußland", "Rußland", "RUSSLAND", "rußland", "russland", "russland", ],
+[ "RUẞLAND", "rußland", "Rußland", "RUẞLAND", "rußland", "Rußland", "RUẞLAND", "rußland", "russland", "russland", ],
+[ "weiß", "weiß", "Weiß", "WEIß", "weiß", "Weiß", "WEISS", "weiß", "weiss", "weiss", ],
+[ "WEIẞ", "weiß", "Weiß", "WEIẞ", "weiß", "Weiß", "WEIẞ", "weiß", "weıss", "weiss", ],
+[ "ẞIEW", "ßiew", "ẞiew", "ẞIEW", "ßiew", "ẞiew", "ẞIEW", "ßiew", "ssıew", "ssiew", ],
+[ "ͅ", "ͅ", "Ι", "Ι", "ͅ", "Ι", "Ι", "ι", "ι", "ι", ],
+[ "ᾲ", "ᾲ", "Ὰͅ", "ᾺΙ", "ᾲ", "Ὰͅ", "ᾺΙ", "ὰι", "ὰι", "ὰι", ],
+[ "Ὰι", "ὰι", "Ὰι", "ᾺΙ", "ὰι", "Ὰι", "ᾺΙ", "ὰι", "ὰι", "ὰι", ],
+[ "ᾺΙ", "ὰι", "Ὰι", "ᾺΙ", "ὰι", "Ὰι", "ᾺΙ", "ὰι", "ὰι", "ὰι", ],
+[ "ᾲ", "ᾲ", "ᾲ", "ᾲ", "ᾲ", "Ὰͅ", "ᾺΙ", "ᾲ", "ὰι", "ὰι", ],
+[ "Ὰͅ", "ᾲ", "Ὰͅ", "ᾺΙ", "ᾲ", "Ὰͅ", "ᾺΙ", "ὰι", "ὰι", "ὰι", ],
+[ "ᾺΙ", "ὰι", "Ὰι", "ᾺΙ", "ὰι", "Ὰι", "ᾺΙ", "ὰι", "ὰι", "ὰι", ],
+[ "ᾲ στο διάολο", "ᾲ στο διάολο", "ᾲ Στο Διάολο", "ᾲ ΣΤΟ ΔΙΆΟΛΟ", "ᾲ στο διάολο", "Ὰͅ Στο Διάολο", "ᾺΙ ΣΤΟ ΔΙΆΟΛΟ", "ᾲ στο διάολο", "ὰι στο διάολο", "ὰι στο διάολο", ],
+[ "ᾲ στο διάολο", "ᾲ στο διάολο", "Ὰͅ Στο Διάολο", "ᾺΙ ΣΤΟ ΔΙΆΟΛΟ", "ᾲ στο διάολο", "Ὰͅ Στο Διάολο", "ᾺΙ ΣΤΟ ΔΙΆΟΛΟ", "ὰι στο διάολο", "ὰι στο διάολο", "ὰι στο διάολο", ],
+[ "ⅷ", "ⅷ", "Ⅷ", "Ⅷ", "ⅷ", "Ⅷ", "Ⅷ", "ⅷ", "ⅷ", "ⅷ", ],
+[ "henry ⅷ", "henry ⅷ", "Henry Ⅷ", "HENRY Ⅷ", "henry ⅷ", "Henry Ⅷ", "HENRY Ⅷ", "henry ⅷ", "henry ⅷ", "henry ⅷ", ],
+[ "ⓚ", "ⓚ", "Ⓚ", "Ⓚ", "ⓚ", "Ⓚ", "Ⓚ", "ⓚ", "ⓚ", "ⓚ", ],
+[ "i work at ⓚ", "i work at ⓚ", "I Work At Ⓚ", "I WORK AT Ⓚ", "i work at ⓚ", "I Work At Ⓚ", "I WORK AT Ⓚ", "i work at ⓚ", "i work at ⓚ", "i work at ⓚ", ],
+[ "istambul", "istambul", "Istambul", "ISTAMBUL", "istambul", "Istambul", "ISTAMBUL", "istambul", "istambul", "istambul", ],
+[ "i̇stanbul", "i̇stanbul", "İstanbul", "İSTANBUL", "i̇stanbul", "İstanbul", "İSTANBUL", "i̇stanbul", "i̇stanbul", "i̇stanbul", ],
+[ "İstanbul", "i̇stanbul", "İstanbul", "İSTANBUL", "i̇stanbul", "İstanbul", "İSTANBUL", "i̇stanbul", "ı̇stanbul", "i̇stanbul", ],
+[ "İSTANBUL", "istanbul", "İstanbul", "İSTANBUL", "i̇stanbul", "İstanbul", "İSTANBUL", "İstanbul", "istanbul", "i̇stanbul", ],
+[ "στιγμας", "στιγμας", "Στιγμας", "ΣΤΙΓΜΑΣ", "στιγμας", "Στιγμας", "ΣΤΙΓΜΑΣ", "στιγμασ", "στιγμασ", "στιγμασ", ],
+[ "στιγμασ", "στιγμασ", "Στιγμασ", "ΣΤΙΓΜΑΣ", "στιγμασ", "Στιγμασ", "ΣΤΙΓΜΑΣ", "στιγμασ", "στιγμασ", "στιγμασ", ],
+[ "ΣΤΙΓΜΑΣ", "στιγμασ", "Στιγμασ", "ΣΤΙΓΜΑΣ", "στιγμασ", "Στιγμασ", "ΣΤΙΓΜΑΣ", "στιγμασ", "στιγμασ", "στιγμασ", ],
+[ "ʀᴀʀᴇ", "ʀᴀʀᴇ", "Ʀᴀʀᴇ", "ƦᴀƦᴇ", "ʀᴀʀᴇ", "Ʀᴀʀᴇ", "ƦᴀƦᴇ", "ʀᴀʀᴇ", "ʀᴀʀᴇ", "ʀᴀʀᴇ", ],
+[ "𐐼𐐯𐑅𐐨𐑉𐐯𐐻", "𐐼𐐯𐑅𐐨𐑉𐐯𐐻", "𐐔𐐯𐑅𐐨𐑉𐐯𐐻", "𐐔𐐇𐐝𐐀𐐡𐐇𐐓", "𐐼𐐯𐑅𐐨𐑉𐐯𐐻", "𐐔𐐯𐑅𐐨𐑉𐐯𐐻", "𐐔𐐇𐐝𐐀𐐡𐐇𐐓", "𐐼𐐯𐑅𐐨𐑉𐐯𐐻", "𐐼𐐯𐑅𐐨𐑉𐐯𐐻", "𐐼𐐯𐑅𐐨𐑉𐐯𐐻", ],
+[ "Ԧԧ", "ԧԧ", "Ԧԧ", "ԦԦ", "ԧԧ", "Ԧԧ", "ԦԦ", "ԧԧ", "ԧԧ", "ԧԧ", ],
+[ "ﬓﬔﬕﬖﬗ", "ﬓﬔﬕﬖﬗ", "ﬓﬔﬕﬖﬗ", "ﬓﬔﬕﬖﬗ", "ﬓﬔﬕﬖﬗ", "Մնﬔﬕﬖﬗ", "ՄՆՄԵՄԻՎՆՄԽ", "ﬓﬔﬕﬖﬗ", "մնմեմիվնմխ", "մնմեմիվնմխ", ],
+[ "ʼn groot", "ʼn groot", "ʼn Groot", "ʼn GROOT", "ʼn groot", "ʼN Groot", "ʼN GROOT", "ʼn groot", "ʼn groot", "ʼn groot", ],
+[ "ẚ", "ẚ", "ẚ", "ẚ", "ẚ", "Aʾ", "Aʾ", "ẚ", "aʾ", "aʾ", ],
+[ "ff", "ff", "ff", "ff", "ff", "Ff", "FF", "ff", "ff", "ff", ],
+[ "ǰ", "ǰ", "ǰ", "ǰ", "ǰ", "J̌", "J̌", "ǰ", "ǰ", "ǰ", ],
+[ "550 nm or Å", "550 nm or å", "550 Nm Or Å", "550 NM OR Å", "550 nm or å", "550 Nm Or Å", "550 NM OR Å", "550 nm or å", "550 nm or å", "550 nm or å", ],
+);
+
+ use feature qw(fc);
+
+ for (@test_table) {
+ my ($simple_lc, $simple_tc, $simple_uc, $simple_fc) = @{$_}[1, 2, 3, 7];
+ my ($orig, $lower, $titlecase, $upper, $fc_turkic, $fc_full) = @{$_}[0,4,5,6,8,9];
+
+ if ($orig =~ /(\P{Assigned})/) { # So can fail gracefully in earlier
+ # Unicode versions
+ fail(sprintf "because U+%04X is unassigned", ord($1));
+ next;
+ }
+ is( fc($orig), $fc_full, "fc('$orig') returns '$fc_full'" );
+ is( "\F$orig", $fc_full, '\F works' );
+ is( lc($orig), $lower, "lc('$orig') returns '$lower'" );
+ is( "\L$orig", $lower, '\L works' );
+ is( uc($orig), $upper, "uc('$orig') returns '$upper'" );
+ is( "\U$orig", $upper, '\U works' );
+ }
+}
+
+{
+ use feature qw(fc);
+ package Eeyup { use overload q{""} => sub { "\x{df}" }, fallback => 1 }
+ package Uunope { use overload q{""} => sub { "\x{30cb}" }, fallback => 1 }
+ package Undef { use overload q{""} => sub { undef }, fallback => 1 }
+
+ my $obj = bless {}, "Eeyup";
+ is(fc($obj), "ss", "fc() works on overloaded objects returning latin-1");
+ $obj = bless {}, "Eeyup";
+ is("\F$obj", "ss", '\F works on overloaded objects returning latin-1');
+
+ $obj = bless {}, "Uunope";
+ is(fc($obj), "\x{30cb}", "fc() works on overloaded objects returning UTF-8");
+ $obj = bless {}, "Uunope";
+ is("\F$obj", "\x{30cb}", '\F works on overloaded objects returning UTF-8');
+
+ $obj = bless {}, "Undef";
+ my $warnings;
+ {
+ no warnings;
+ use warnings "uninitialized";
+ local $SIG{__WARN__} = sub { $warnings++; like(shift, qr/Use of uninitialized value (?:\$obj )?in fc/) };
+ fc(undef);
+ fc($obj);
+ }
+ is( $warnings, 2, "correct number of warnings" );
+
+ my $fetched = 0;
+ package Derpy { sub TIESCALAR { bless {}, shift } sub FETCH { $fetched++; "\x{df}" } }
+
+ tie my $x, "Derpy";
+
+ is( fc($x), "ss", "fc() works on tied values" );
+ is( $fetched, 1, "and only calls the magic once" );
+
+}
+
+{
+ use feature qw( fc );
+ my $troublesome1 = "\xdf" x 11; #SvLEN should be 12, SvCUR should be 11
+ #So this should force fc() to grow the string.
+
+ is( fc($troublesome1), "ss" x 11, "fc() grows the string" );
+
+ my $troublesome2 = "abcdef:\x{df}:fjksjs"; #SvLEN should be 16, SvCUR should be 15
+ is( fc($troublesome2), "abcdef:ss:fjksjs", "fc() expands \\x{DF} in the middle of a string that needs to grow" );
+
+ my $troublesome3 = ":\x{df}:";
+ is( fc($troublesome3), ":ss:", "fc() expands \\x{DF} in the middle of a string" );
+
+
+ my $troublesome4 = "\x{B5}"; #\N{MICRON SIGN} is latin-1, but its foldcase is in UTF-8
+
+ is( fc($troublesome4), "\x{3BC}", "fc() for a latin-1 \x{B5} returns UTF-8" );
+ ok( !utf8::is_utf8($troublesome4), "fc() doesn't upgrade the original string" );
+
+
+ my $troublesome5 = "\x{C9}abda\x{B5}aaf\x{C8}"; # Up until foldcasing \x{B5}, the string
+ # was in Latin-1. This tests that the
+ # results don't have illegal UTF-8
+ # (i.e. leftover latin-1) in them
+
+ is( fc($troublesome5), "\x{E9}abda\x{3BC}aaf\x{E8}" );
+}
+
+{
+ use feature qw( fc unicode_strings );
+
+ # This tests both code paths in pp_fc
+
+ for (0..0xff) {
+ my $latin1 = chr;
+ my $utf8 = $latin1;
+ utf8::downgrade($latin1); #No-op, but doesn't hurt
+ utf8::upgrade($utf8);
+ is(fc($latin1), fc($utf8), "fc() gives the same results for \\x{$_} in Latin-1 and UTF-8 under unicode_strings");
+ SKIP: {
+ skip 'No locale testing without d_setlocale', 2 if(!$Config{d_setlocale});
+ BEGIN {
+ if($Config{d_setlocale}) {
+ require locale; import locale;
+ }
+ }
+ is(fc($latin1), lc($latin1), "use locale; fc(qq{\\x{$_}}), lc(qq{\\x{$_}}) when qq{\\x{$_}} is in latin-1");
+ is(fc($utf8), lc($utf8), "use locale; fc(qq{\\x{$_}}), lc(qq{\\x{$_}}) when qq{\\x{$_}} is in latin-1");
+ }
+ {
+ no feature 'unicode_strings';
+ is(fc($latin1), lc($latin1), "under nothing, fc() for <256 is the same as lc");
+ }
+ }
+}
+
my $num_tests = curr_test() - 1;
-die qq[$0: failed to find casefoldings from "$CF"\n] unless $num_tests > 0;
-
plan($num_tests);
Property changes on: trunk/contrib/perl/t/uni/fold.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Copied: trunk/contrib/perl/t/uni/goto.t (from rev 6437, vendor/perl/5.18.1/t/uni/goto.t)
===================================================================
--- trunk/contrib/perl/t/uni/goto.t (rev 0)
+++ trunk/contrib/perl/t/uni/goto.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,41 @@
+#!./perl -w
+
+BEGIN {
+ require './test.pl';
+}
+
+plan tests => 4;
+
+use utf8;
+use open qw( :utf8 :std );
+
+sub goto_baresub {
+ goto &問題の原因;
+}
+
+sub goto_softref {
+ goto &{"問題の原因"};
+}
+
+sub goto_softref_octal {
+ goto &{"\345\225\217\351\241\214\343\201\256\345\216\237\345\233\240"};
+}
+
+sub 問題の原因 {
+ 1;
+}
+
+ok goto_baresub(), "Magical goto works on an UTF-8 sub,";
+ok goto_softref(), "..and an UTF-8 softref sub,";
+
+{
+ local $@;
+ eval { goto_softref_octal() };
+ like $@, qr/Goto undefined subroutine &main::\345\225\217\351\241\214\343\201\256\345\216\237\345\233\240/, "But does NOT find the softref sub when it's lacking the UTF-8 flag";
+}
+
+{
+ local $@;
+ eval { goto &因 };
+ like $@, qr/Goto undefined subroutine &main::因/, "goto undefined sub gets the right error message";
+}
Modified: trunk/contrib/perl/t/uni/greek.t
===================================================================
--- trunk/contrib/perl/t/uni/greek.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/uni/greek.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -9,6 +9,7 @@
plan tests => 72;
+no warnings 'deprecated';
use encoding "greek"; # iso 8859-7
# U+0391, \xC1, \301, GREEK CAPITAL LETTER ALPHA
Property changes on: trunk/contrib/perl/t/uni/greek.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/t/uni/gv.t (from rev 6437, vendor/perl/5.18.1/t/uni/gv.t)
===================================================================
--- trunk/contrib/perl/t/uni/gv.t (rev 0)
+++ trunk/contrib/perl/t/uni/gv.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,843 @@
+#!./perl
+
+#
+# various typeglob tests
+#
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require './test.pl';
+}
+
+use utf8;
+use open qw( :utf8 :std );
+use warnings;
+
+plan( tests => 212 );
+
+# type coersion on assignment
+$ᕘ = 'ᕘ';
+$ᴮᛅ = *main::ᕘ;
+$ᴮᛅ = $ᕘ;
+is(ref(\$ᴮᛅ), 'SCALAR');
+$ᕘ = *main::ᴮᛅ;
+
+# type coersion (not) on misc ops
+
+ok($ᕘ);
+is(ref(\$ᕘ), 'GLOB');
+
+unlike ($ᕘ, qr/abcd/);
+is(ref(\$ᕘ), 'GLOB');
+
+is($ᕘ, '*main::ᴮᛅ');
+is(ref(\$ᕘ), 'GLOB');
+
+{
+ no warnings;
+ ${\*$ᕘ} = undef;
+ is(ref(\$ᕘ), 'GLOB', 'no type coersion when assigning to *{} retval');
+ $::{ఫｹ} = *ᴮᛅ;
+ is(
+ \$::{ఫｹ}, \*{"ఫｹ"},
+ 'symbolic *{} returns symtab entry when FAKE'
+ );
+ ${\*{"ఫｹ"}} = undef;
+ is(
+ ref(\$::{ఫｹ}), 'GLOB',
+ 'no type coersion when assigning to retval of symbolic *{}'
+ );
+ $::{pɥአＱuઍ} = *ᴮᛅ;
+ eval '
+ is(
+ \$::{pɥአＱuઍ}, \*pɥአＱuઍ,
+ "compile-time *{} returns symtab entry when FAKE"
+ );
+ ${\*pɥአＱuઍ} = undef;
+ ';
+ is(
+ ref(\$::{pɥአＱuઍ}), 'GLOB',
+ 'no type coersion when assigning to retval of compile-time *{}'
+ );
+}
+
+# type coersion on substitutions that match
+$a = *main::ᕘ;
+$b = $a;
+$a =~ s/^X//;
+is(ref(\$a), 'GLOB');
+$a =~ s/^\*//;
+is($a, 'main::ᕘ');
+is(ref(\$b), 'GLOB');
+
+# typeglobs as lvalues
+substr($ᕘ, 0, 1) = "XXX";
+is(ref(\$ᕘ), 'SCALAR');
+is($ᕘ, 'XXXmain::ᴮᛅ');
+
+# returning glob values
+sub ᕘ {
+ local($ᴮᛅ) = *main::ᕘ;
+ $ᕘ = *main::ᴮᛅ;
+ return ($ᕘ, $ᴮᛅ);
+}
+
+($ፉṶ, $ባ) = ᕘ();
+ok(defined $ፉṶ);
+is(ref(\$ፉṶ), 'GLOB');
+
+
+ok(defined $ባ);
+is(ref(\$ባ), 'GLOB');
+
+# nested package globs
+# NOTE: It's probably OK if these semantics change, because the
+# fact that %X::Y:: is stored in %X:: isn't documented.
+# (I hope.)
+
+{ package ฝ오::ʉ; no warnings 'once'; $test=1; }
+ok(exists $ฝ오::{'ʉ::'});
+is($ฝ오::{'ʉ::'}, '*ฝ오::ʉ::');
+
+
+# test undef operator clearing out entire glob
+$ᕘ = 'stuff';
+@ᕘ = qw(more stuff);
+%ᕘ = qw(even more random stuff);
+undef *ᕘ;
+is ($ᕘ, undef);
+is (scalar @ᕘ, 0);
+is (scalar %ᕘ, 0);
+
+{
+ # test warnings from assignment of undef to glob
+ my $msg = '';
+ local $SIG{__WARN__} = sub { $msg = $_[0] };
+ use warnings;
+ *ᕘ = 'ᴮᛅ';
+ is($msg, '');
+ *ᕘ = undef;
+ like($msg, qr/Undefined value assigned to typeglob/);
+
+ no warnings 'once';
+ # test warnings for converting globs to other forms
+ my $copy = *PWÒMPF;
+ foreach ($copy, *SKRÈÈÈ) {
+ $msg = '';
+ my $victim = sprintf "%d", $_;
+ like($msg, qr/Argument "\*main::(\p{ASCII}|\Q\x{\E\p{ASCII_Hex_Digit}{2}\}){3}\Q...\E" isn't numeric in sprintf/,
+ "Warning on conversion to IV");
+ is($victim, 0);
+
+ $msg = '';
+ $victim = sprintf "%u", $_;
+ like($msg, qr/Argument "\*main::(\p{ASCII}|\Q\x{\E\p{ASCII_Hex_Digit}{2}\}){3}\Q...\E" isn't numeric in sprintf/,
+ "Warning on conversion to UV");
+ is($victim, 0);
+
+ $msg = '';
+ $victim = sprintf "%e", $_;
+ like($msg, qr/Argument "\*main::(\p{ASCII}|\Q\x{\E\p{ASCII_Hex_Digit}{2}\}){3}\Q...\E" isn't numeric in sprintf/,
+ "Warning on conversion to NV");
+ like($victim, qr/^0\.0+E\+?00/i, "Expect floating point zero");
+
+ $msg = '';
+ $victim = sprintf "%s", $_;
+ is($msg, '', "No warning on stringification");
+ is($victim, '' . $_);
+ }
+}
+
+my $test = curr_test();
+# test *glob{THING} syntax
+$Ẋ = "ok $test\n";
+++$test;
+@Ẋ = ("ok $test\n");
+++$test;
+%Ẋ = ("ok $test" => "\n");
+++$test;
+sub Ẋ { "ok $test\n" }
+print ${*Ẋ{SCALAR}}, @{*Ẋ{ARRAY}}, %{*Ẋ{HASH}}, &{*Ẋ{CODE}};
+# This needs to go here, after the print, as sub Ẋ will return the current
+# value of test
+++$test;
+format Ẋ =
+XXX This text isn't used. Should it be?
+.
+curr_test($test);
+
+is (ref *Ẋ{FORMAT}, "FORMAT");
+*Ẋ = *STDOUT;
+is (*{*Ẋ{GLOB}}, "*main::STDOUT");
+
+{
+ my $test = curr_test();
+
+ print {*Ẋ{IO}} "ok $test\n";
+ ++$test;
+
+ my $warn;
+ local $SIG{__WARN__} = sub {
+ $warn .= $_[0];
+ };
+ my $val = *Ẋ{FILEHANDLE};
+ print {*Ẋ{IO}} ($warn =~ /is deprecated/
+ ? "ok $test\n" : "not ok $test\n");
+ curr_test(++$test);
+}
+
+
+{
+ # test if defined() doesn't create any new symbols
+
+ my $a = "Sʎｍ000";
+ ok(!defined *{$a});
+
+ {
+ no warnings 'deprecated';
+ ok(!defined @{$a});
+ }
+ ok(!defined *{$a});
+
+ {
+ no warnings 'deprecated';
+ ok(!defined %{$a});
+ }
+ ok(!defined *{$a});
+
+ ok(!defined ${$a});
+ ok(!defined *{$a});
+
+ ok(!defined &{$a});
+ ok(!defined *{$a});
+
+ my $state = "not";
+ *{$a} = sub { $state = "ok" };
+ ok(defined &{$a});
+ ok(defined *{$a});
+ &{$a};
+ is ($state, 'ok');
+}
+
+# [ID 20010526.001] localized glob loses value when assigned to
+
+$Ｊ=1; %Ｊ=(a=>1); @Ｊ=(1); local *Ｊ=*Ｊ; *Ｊ = sub{};
+
+is($Ｊ, 1);
+is($Ｊ{a}, 1);
+is($Ｊ[0], 1);
+
+{
+ # does pp_readline() handle glob-ness correctly?
+ my $g = *ᕘ;
+ $g = <DATA>;
+ is ($g, "Perl\n");
+}
+
+{
+ my $w = '';
+ local $SIG{__WARN__} = sub { $w = $_[0] };
+ sub aʙȼ1 ();
+ local *aʙȼ1 = sub { };
+ is ($w, '');
+ sub aʙȼ2 ();
+ local *aʙȼ2;
+ *aʙȼ2 = sub { };
+ is ($w, '');
+ sub aʙȼ3 ();
+ *aʙȼ3 = sub { };
+ like ($w, qr/Prototype mismatch/);
+}
+
+{
+ # [17375] rcatline to formerly-defined undef was broken. Fixed in
+ # do_readline by checking SvOK. AMS, 20020918
+ my $x = "not ";
+ $x = undef;
+ $x .= <DATA>;
+ is ($x, "Rules\n");
+}
+
+{
+ # test the assignment of a GLOB to an LVALUE
+ my $e = '';
+ local $SIG{__DIE__} = sub { $e = $_[0] };
+ my %Ｖ;
+ sub ƒ { $_[0] = 0; $_[0] = "a"; $_[0] = *DATA }
+ ƒ($Ｖ{Ｖ});
+ is ($Ｖ{Ｖ}, '*main::DATA');
+ is (ref\$Ｖ{Ｖ}, 'GLOB', 'lvalue assignment preserves globs');
+ my $x = readline $Ｖ{Ｖ};
+ is ($x, "perl\n");
+ is ($e, '', '__DIE__ handler never called');
+}
+
+{
+
+ my $e = '';
+ # GLOB assignment to tied element
+ local $SIG{__DIE__} = sub { $e = $_[0] };
+ sub Ʈ::TIEARRAY { bless [] => "Ʈ" }
+ sub Ʈ::STORE { $_[0]->[ $_[1] ] = $_[2] }
+ sub Ʈ::FETCH { $_[0]->[ $_[1] ] }
+ sub Ʈ::FETCHSIZE { @{$_[0]} }
+ tie my @ary => "Ʈ";
+ $ary[0] = *DATA;
+ is ($ary[0], '*main::DATA');
+ is (
+ ref\tied(@ary)->[0], 'GLOB',
+ 'tied elem assignment preserves globs'
+ );
+ is ($e, '', '__DIE__ handler not called');
+ my $x = readline $ary[0];
+ is($x, "rocks\n");
+ is ($e, '', '__DIE__ handler never called');
+}
+
+{
+ SKIP: {
+ skip_if_miniperl('no dynamic loading on miniperl, no Encode', 2);
+ # Need some sort of die or warn to get the global destruction text if the
+ # bug is still present
+ my $prog = <<'EOPROG';
+ use utf8;
+ use open qw( :utf8 :std );
+ package ᴹ;
+ $| = 1;
+ sub DESTROY {eval {die qq{Farewell $_[0]}}; print $@}
+ package main;
+
+ bless \$Ⱥ::ㄅ, q{ᴹ};
+ *Ⱥ:: = \*ㄅ::;
+EOPROG
+
+ utf8::decode($prog);
+ my $output = runperl(prog => $prog);
+
+ require Encode;
+ $output = Encode::decode("UTF-8", $output);
+ like($output, qr/^Farewell ᴹ=SCALAR/, "DESTROY was called");
+ unlike($output, qr/global destruction/,
+ "unreferenced symbol tables should be cleaned up immediately");
+ }
+}
+
+{
+ # Possibly not the correct test file for these tests.
+ # There are certain space optimisations implemented via promotion rules to
+ # GVs
+
+ foreach (qw (оઓnḲ ga_ㄕƚo잎)) {
+ ok(!exists $::{$_}, "no symbols of any sort to start with for $_");
+ }
+
+ # A string in place of the typeglob is promoted to the function prototype
+ $::{оઓnḲ} = "pìè";
+ my $proto = eval 'prototype \&оઓnḲ';
+ die if $@;
+ is ($proto, "pìè", "String is promoted to prototype");
+
+
+ # A reference to a value is used to generate a constant subroutine
+ foreach my $value (3, "Perl rules", \42, qr/whatever/, [1,2,3], {1=>2},
+ \*STDIN, \&ok, \undef, *STDOUT) {
+ delete $::{оઓnḲ};
+ $::{оઓnḲ} = \$value;
+ $proto = eval 'prototype \&оઓnḲ';
+ die if $@;
+ is ($proto, '', "Prototype for a constant subroutine is empty");
+
+ my $got = eval 'оઓnḲ';
+ die if $@;
+ is (ref $got, ref $value, "Correct type of value (" . ref($value) . ")");
+ is ($got, $value, "Value is correctly set");
+ }
+}
+
+delete $::{оઓnḲ};
+$::{оઓnḲ} = \"Value";
+
+*{"ga_ㄕƚo잎"} = \&{"оઓnḲ"};
+
+is (ref $::{ga_ㄕƚo잎}, 'SCALAR', "Export of proxy constant as is");
+is (ref $::{оઓnḲ}, 'SCALAR', "Export doesn't affect original");
+is (eval 'ga_ㄕƚo잎', "Value", "Constant has correct value");
+is (ref $::{ga_ㄕƚo잎}, 'SCALAR',
+ "Inlining of constant doesn't change representation");
+
+delete $::{ga_ㄕƚo잎};
+
+eval 'sub ga_ㄕƚo잎 (); 1' or die $@;
+is ($::{ga_ㄕƚo잎}, '', "Prototype is stored as an empty string");
+
+# Check that a prototype expands.
+*{"ga_ㄕƚo잎"} = \&{"оઓnḲ"};
+
+is (ref $::{оઓnḲ}, 'SCALAR', "Export doesn't affect original");
+is (eval 'ga_ㄕƚo잎', "Value", "Constant has correct value");
+is (ref \$::{ga_ㄕƚo잎}, 'GLOB', "Symbol table has full typeglob");
+
+
+@::zᐓｔ = ('Zᐓｔ!');
+
+# Check that assignment to an existing typeglob works
+{
+ my $w = '';
+ local $SIG{__WARN__} = sub { $w = $_[0] };
+ *{"zᐓｔ"} = \&{"оઓnḲ"};
+ is($w, '', "Should be no warning");
+}
+
+is (ref $::{оઓnḲ}, 'SCALAR', "Export doesn't affect original");
+is (eval 'zᐓｔ', "Value", "Constant has correct value");
+is (ref \$::{zᐓｔ}, 'GLOB', "Symbol table has full typeglob");
+is (join ('!', @::zᐓｔ), 'Zᐓｔ!', "Existing array still in typeglob");
+
+sub Ṩp맅싵Ş () {
+ "Traditional";
+}
+
+# Check that assignment to an existing subroutine works
+{
+ my $w = '';
+ local $SIG{__WARN__} = sub { $w = $_[0] };
+ *{"Ṩp맅싵Ş"} = \&{"оઓnḲ"};
+ like($w, qr/^Constant subroutine main::Ṩp맅싵Ş redefined/,
+ "Redefining a constant sub should warn");
+}
+
+is (ref $::{оઓnḲ}, 'SCALAR', "Export doesn't affect original");
+is (eval 'Ṩp맅싵Ş', "Value", "Constant has correct value");
+is (ref \$::{Ṩp맅싵Ş}, 'GLOB', "Symbol table has full typeglob");
+
+# Check that assignment to an existing typeglob works
+{
+ my $w = '';
+ local $SIG{__WARN__} = sub { $w = $_[0] };
+ *{"plუᒃ"} = [];
+ *{"plუᒃ"} = \&{"оઓnḲ"};
+ is($w, '', "Should be no warning");
+}
+
+is (ref $::{оઓnḲ}, 'SCALAR', "Export doesn't affect original");
+is (eval 'plუᒃ', "Value", "Constant has correct value");
+is (ref \$::{plუᒃ}, 'GLOB', "Symbol table has full typeglob");
+
+my $gr = eval '\*plუᒃ' or die;
+
+{
+ my $w = '';
+ local $SIG{__WARN__} = sub { $w = $_[0] };
+ *{$gr} = \&{"оઓnḲ"};
+ is($w, '', "Redefining a constant sub to another constant sub with the same underlying value should not warn (It's just re-exporting, and that was always legal)");
+}
+
+is (ref $::{оઓnḲ}, 'SCALAR', "Export doesn't affect original");
+is (eval 'plუᒃ', "Value", "Constant has correct value");
+is (ref \$::{plუᒃ}, 'GLOB', "Symbol table has full typeglob");
+
+# Non-void context should defeat the optimisation, and will cause the original
+# to be promoted (what change 26482 intended)
+my $result;
+{
+ my $w = '';
+ local $SIG{__WARN__} = sub { $w = $_[0] };
+ $result = *{"aẈʞƙʞƙʞƙ"} = \&{"оઓnḲ"};
+ is($w, '', "Should be no warning");
+}
+
+is (ref \$result, 'GLOB',
+ "Non void assignment should still return a typeglob");
+
+is (ref \$::{оઓnḲ}, 'GLOB', "This export does affect original");
+is (eval 'plუᒃ', "Value", "Constant has correct value");
+is (ref \$::{plუᒃ}, 'GLOB', "Symbol table has full typeglob");
+
+delete $::{оઓnḲ};
+$::{оઓnḲ} = \"Value";
+
+sub non_dangling {
+ my $w = '';
+ local $SIG{__WARN__} = sub { $w = $_[0] };
+ *{"z앞"} = \&{"оઓnḲ"};
+ is($w, '', "Should be no warning");
+}
+
+non_dangling();
+is (ref $::{оઓnḲ}, 'SCALAR', "Export doesn't affect original");
+is (eval 'z앞', "Value", "Constant has correct value");
+is (ref $::{z앞}, 'SCALAR', "Exported target is also a PCS");
+
+sub dangling {
+ local $SIG{__WARN__} = sub { die $_[0] };
+ *{"ビfᶠ"} = \&{"оઓnḲ"};
+}
+
+dangling();
+is (ref \$::{оઓnḲ}, 'GLOB', "This export does affect original");
+is (eval 'ビfᶠ', "Value", "Constant has correct value");
+is (ref \$::{ビfᶠ}, 'GLOB', "Symbol table has full typeglob");
+
+{
+ use vars qw($gᓙʞ $sምḲ $ᕘf);
+ # Check reference assignment isn't affected by the SV type (bug #38439)
+ $gᓙʞ = 3;
+ $sምḲ = 4;
+ $ᕘf = "halt and cool down";
+
+ my $rv = \*sምḲ;
+ is($gᓙʞ, 3);
+ *gᓙʞ = $rv;
+ is($gᓙʞ, 4);
+
+ my $pv = "";
+ $pv = \*sምḲ;
+ is($ᕘf, "halt and cool down");
+ *ᕘf = $pv;
+ is($ᕘf, 4);
+}
+
+{
+no warnings 'once';
+format =
+.
+
+ foreach my $value ([1,2,3], {1=>2}, *STDOUT{IO}, \&ok, *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;
+ $type =~ s/.*=//;
+ $type =~ s/\(.*//;
+ delete $::{оઓnḲ};
+ $::{оઓnḲ} = $value;
+ $proto = eval 'prototype \&оઓnḲ';
+ like ($@, qr/^Cannot convert a reference to $type to typeglob/,
+ "Cannot upgrade ref-to-$type to typeglob");
+ }
+}
+
+{
+ no warnings qw(once uninitialized);
+ my $g = \*ȼલᑧɹ;
+ my $r = eval {no strict; ${*{$g}{SCALAR}}};
+ is ($@, '', "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax");
+
+ $g = \*vȍwɯ;
+ $r = eval {use strict; ${*{$g}{SCALAR}}};
+ is ($@, '',
+ "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax under strict");
+}
+
+{
+ # Bug reported by broquaint on IRC
+ *ᔅᓗsḨ::{HASH}->{ISA}=[];
+ ᔅᓗsḨ->import;
+ pass("gv_fetchmeth coped with the unexpected");
+
+ # An audit found these:
+ {
+ package ᔅᓗsḨ;
+ sub 맆 {
+ my $s = shift;
+ $s->SUPER::맆;
+ }
+ }
+ {
+ eval {ᔅᓗsḨ->맆;};
+ like ($@, qr/^Can't locate object method "맆"/, "Even with SUPER");
+ }
+ is(ᔅᓗsḨ->isa('swoosh'), '');
+}
+
+{
+ die if exists $::{본ㄎ};
+ $::{본ㄎ} = \"포ヰｅ";
+ *{"본ㄎ"} = \&{"본ㄎ"};
+ eval 'is(본ㄎ(), "포ヰｅ",
+ "Assignment works when glob created midway (bug 45607)"); 1'
+ or die $@;
+}
+
+
+# [perl #72740] - indirect object syntax, heuristically imputed due to
+# the non-existence of a function, should not cause a stash entry to be
+# created for the non-existent function.
+{
+ {
+ package RƬ72740a;
+ my $f = bless({}, RƬ72740b);
+ sub s1 { s2 $f; }
+ our $s4;
+ sub s3 { s4 $f; }
+ }
+ {
+ package RƬ72740b;
+ sub s2 { "RƬ72740b::s2" }
+ sub s4 { "RƬ72740b::s4" }
+ }
+ ok(exists($RƬ72740a::{s1}), "RƬ72740a::s1 exists");
+ ok(!exists($RƬ72740a::{s2}), "RƬ72740a::s2 does not exist");
+ ok(exists($RƬ72740a::{s3}), "RƬ72740a::s3 exists");
+ ok(exists($RƬ72740a::{s4}), "RƬ72740a::s4 exists");
+ is(RƬ72740a::s1(), "RƬ72740b::s2", "RƬ72740::s1 parsed correctly");
+ is(RƬ72740a::s3(), "RƬ72740b::s4", "RƬ72740::s3 parsed correctly");
+}
+
+# [perl #71686] Globs that are in symbol table can be un-globbed
+$ŚyṀ = undef;
+$::{Ḟ앜ɞ} = *ŚyṀ;
+is (eval 'local *::Ḟ앜ɞ = \"chuck"; $Ḟ앜ɞ', 'chuck',
+ "Localized glob didn't coerce into a RV");
+is ($@, '', "Can localize FAKE glob that's present in stash");
+{
+ is (scalar $::{Ḟ앜ɞ}, "*main::ŚyṀ",
+ "Localized FAKE glob's value was correctly restored");
+}
+
+# [perl #1804] *$x assignment when $x is a copy of another glob
+# And [perl #77508] (same thing with list assignment)
+ {
+ no warnings 'once';
+ my $x = *_ràndom::glob_that_is_not_used_elsewhere;
+ *$x = sub{};
+ is(
+ "$x", '*_ràndom::glob_that_is_not_used_elsewhere',
+ '[perl #1804] *$x assignment when $x is FAKE',
+ );
+ $x = *_ràndom::glob_that_is_not_used_elsewhere;
+ (my $dummy, *$x) = (undef,[]);
+ is(
+ "$x", '*_ràndom::glob_that_is_not_used_elsewhere',
+ '[perl #77508] *$x list assignment when $x is FAKE',
+ ) or require Devel::Peek, Devel::Peek::Dump($x);
+}
+
+# [perl #76540]
+# this caused panics or 'Attempt to free unreferenced scalar'
+# (its a compile-time issue, so the die lets us skip the prints)
+{
+ my @warnings;
+ local $SIG{__WARN__} = sub { push @warnings, @_ };
+
+ eval <<'EOF';
+BEGIN { $::{FÒÒ} = \'ᴮᛅ' }
+die "made it";
+print FÒÒ, "\n";
+print FÒÒ, "\n";
+EOF
+
+ like($@, qr/made it/, "#76540 - no panic");
+ ok(!@warnings, "#76540 - no 'Attempt to free unreferenced scalar'");
+}
+
+# [perl #77362] various bugs related to globs as PVLVs
+{
+ no warnings qw 'once void';
+ my %h; # We pass a key of this hash to the subroutine to get a PVLV.
+ sub { for(shift) {
+ # Set up our glob-as-PVLV
+ $_ = *hòn;
+ is $_, "*main::hòn";
+
+ # Bad symbol for array
+ ok eval{ @$_; 1 }, 'PVLV glob slots can be autovivified' or diag $@;
+
+ {
+ # This should call TIEHANDLE, not TIESCALAR
+ *thèxt::TIEHANDLE = sub{};
+ ok eval{ tie *$_, 'thèxt'; 1 }, 'PVLV globs can be tied as handles'
+ or diag $@;
+ }
+ # Assigning undef to the glob should not overwrite it...
+ {
+ my $w;
+ local $SIG{__WARN__} = sub { $w = shift };
+ *$_ = undef;
+ is $_, "*main::hòn", 'PVLV: assigning undef to the glob does nothing';
+ like $w, qr\Undefined value assigned to typeglob\,
+ 'PVLV: assigning undef to the glob warns';
+ }
+
+ # Neither should reference assignment.
+ *$_ = [];
+ is $_, "*main::hòn", "PVLV: arrayref assignment assigns to the AV slot";
+
+ # Concatenation should still work.
+ ok eval { $_ .= 'thlèw' }, 'PVLV concatenation does not die' or diag $@;
+ is $_, '*main::hònthlèw', 'PVLV concatenation works';
+
+ # And we should be able to overwrite it with a string, number, or refer-
+ # ence, too, if we omit the *.
+ $_ = *hòn; $_ = 'tzòr';
+ is $_, 'tzòr', 'PVLV: assigning a string over a glob';
+ $_ = *hòn; $_ = 23;
+ is $_, 23, 'PVLV: assigning an integer over a glob';
+ $_ = *hòn; $_ = 23.23;
+ is $_, 23.23, 'PVLV: assigning a float over a glob';
+ $_ = *hòn; $_ = \my $sthat;
+ is $_, \$sthat, 'PVLV: assigning a reference over a glob';
+
+ # This bug was found by code inspection. Could this ever happen in
+ # real life? :-)
+ # This duplicates a file handle, accessing it through a PVLV glob, the
+ # glob having been removed from the symbol table, so a stringified form
+ # of it does not work. This checks that sv_2io does not stringify a PVLV.
+ $_ = *quìn;
+ open *quìn, "test.pl"; # test.pl is as good a file as any
+ delete $::{quìn};
+ ok eval { open my $zow, "<&", $_ }, 'PVLV: sv_2io stringifieth not'
+ or diag $@;
+
+ # Similar tests to make sure sv_2cv etc. do not stringify.
+ *$_ = sub { 1 };
+ ok eval { &$_ }, "PVLV glob can be called as a sub" or diag $@;
+ *flèlp = sub { 2 };
+ $_ = 'flèlp';
+ is eval { &$_ }, 2, 'PVLV holding a string can be called as a sub'
+ or diag $@;
+
+ # Coderef-to-glob assignment when the glob is no longer accessible
+ # under its name: These tests are to make sure the OPpASSIGN_CV_TO_GV
+ # optimisation takes PVLVs into account, which is why the RHSs have to be
+ # named subs.
+ use constant ghèèn => 'quàrè';
+ $_ = *mìng;
+ delete $::{mìng};
+ *$_ = \&ghèèn;
+ is eval { &$_ }, 'quàrè',
+ 'PVLV: constant assignment when the glob is detached from the symtab'
+ or diag $@;
+ $_ = *bèngth;
+ delete $::{bèngth};
+ *ghèck = sub { 'lon' };
+ *$_ = \&ghèck;
+ is eval { &$_ }, 'lon',
+ 'PVLV: coderef assignment when the glob is detached from the symtab'
+ or diag $@;
+
+SKIP: {
+ skip_if_miniperl("no dynamic loading on miniperl, so can't load PerlIO::scalar", 1);
+ # open should accept a PVLV as its first argument
+ $_ = *hòn;
+ ok eval { open $_,'<', \my $thlext }, 'PVLV can be the first arg to open'
+ or diag $@;
+ }
+
+ # -t should not stringify
+ $_ = *thlìt; delete $::{thlìt};
+ *$_ = *STDOUT{IO};
+ ok defined -t $_, 'PVLV: -t does not stringify';
+
+ # neither should -T
+ # but some systems don’t support this on file handles
+ my $pass;
+ ok
+ eval {
+ open my $quìle, "<", 'test.pl';
+ $_ = *$quìle;
+ $pass = -T $_;
+ 1
+ } ? $pass : $@ =~ /not implemented on filehandles/,
+ "PVLV: -T does not stringify";
+ # Unopened file handle
+ {
+ my $w;
+ local $SIG{__WARN__} = sub { $w .= shift };
+ $_ = *vòr;
+ close $_;
+ like $w, qr\unopened filehandle vòr\,
+ 'PVLV globs get their names reported in unopened error messages';
+ }
+
+ }}->($h{k});
+}
+
+*àieee = 4;
+pass('Can assign integers to typeglobs');
+*àieee = 3.14;
+pass('Can assign floats to typeglobs');
+*àieee = 'pi';
+pass('Can assign strings to typeglobs');
+
+
+{
+ package thrèxt;
+ sub TIESCALAR{bless[]}
+ sub STORE{ die "No!"}
+ sub FETCH{ no warnings 'once'; *thrìt }
+ tie my $a, "thrèxt";
+ () = "$a"; # do a fetch; now $a holds a glob
+ eval { *$a = sub{} };
+ untie $a;
+ eval { $a = "ᴮᛅ" };
+ ::is $a, "ᴮᛅ",
+ "[perl #77812] Globs in tied scalars can be reified if STORE dies"
+}
+
+# These two crashed prior to 5.13.6. In 5.13.6 they were fatal errors. They
+# were fixed in 5.13.7.
+ok eval {
+ my $glob = \*hèèn::ISA;
+ delete $::{"hèèn::"};
+ *$glob = *ᴮᛅ;
+}, "glob-to-*ISA assignment works when *ISA has lost its stash";
+ok eval {
+ my $glob = \*slàre::ISA;
+ delete $::{"slàre::"};
+ *$glob = [];
+}, "array-to-*ISA assignment works when *ISA has lost its stash";
+# These two crashed in 5.13.6. They were likewise fixed in 5.13.7.
+ok eval {
+ sub grèck;
+ my $glob = do { no warnings "once"; \*phìng::ᕘ};
+ delete $::{"phìng::"};
+ *$glob = *grèck;
+}, "Assigning a glob-with-sub to a glob that has lost its stash warks";
+ok eval {
+ sub pòn::ᕘ;
+ my $glob = \*pòn::ᕘ;
+ delete $::{"pòn::"};
+ *$glob = *ᕘ;
+}, "Assigning a glob to a glob-with-sub that has lost its stash warks";
+
+{
+ package Tie::Alias;
+ sub TIESCALAR{ bless \\pop }
+ sub FETCH { $${$_[0]} }
+ sub STORE { $${$_[0]} = $_[1] }
+ package main;
+ tie my $alias, 'Tie::Alias', my $var;
+ no warnings 'once';
+ $var = *gàlobbe;
+ {
+ local *$alias = [];
+ $var = 3;
+ is $alias, 3, "[perl #77926] Glob reification during localisation";
+ }
+}
+
+# This code causes gp_free to call a destructor when a glob is being
+# restored on scope exit. The destructor used to see SVs with a refcount of
+# zero inside the glob, which could result in crashes (though not in this
+# test case, which just panics).
+{
+ no warnings 'once';
+ my $survived;
+ *Trìt::DESTROY = sub {
+ $thwèxt = 42; # panic
+ $survived = 1;
+ };
+ {
+ local *thwèxt = bless [],'Trìt';
+ ();
+ }
+ ok $survived,
+ 'no error when gp_free calls a destructor that assigns to the gv';
+}
+
+__END__
+Perl
+Rules
+perl
+rocks
Copied: trunk/contrib/perl/t/uni/labels.t (from rev 6437, vendor/perl/5.18.1/t/uni/labels.t)
===================================================================
--- trunk/contrib/perl/t/uni/labels.t (rev 0)
+++ trunk/contrib/perl/t/uni/labels.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,85 @@
+#!./perl
+
+# Tests for labels in UTF-8
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require './test.pl';
+}
+
+use utf8;
+use open qw( :utf8 :std );
+use warnings;
+use feature qw 'unicode_strings evalbytes';
+
+use charnames qw( :full );
+
+plan(10);
+
+ＬＡＢＥＬ: {
+ pass("Sanity check, UTF-8 labels don't throw a syntax error.");
+}
+
+
+SKIP: {
+ skip_if_miniperl("no dynamic loading, no Encode", 2);
+ no warnings 'exiting';
+ require Encode;
+
+ my $prog = 'last ＬＯＯＰ;';
+
+ ＬＯＯＰ: {
+ eval $prog;
+ }
+ is $@, '', "last with a UTF-8 label works,";
+
+ ＬＯＯＰ: {
+ Encode::_utf8_off($prog);
+ evalbytes $prog;
+ like $@, qr/^Unrecognized character/, "..but turn off the UTF-8 flag and it explodes";
+ }
+}
+
+{
+ no warnings 'exiting';
+
+ eval "last Ｅ";
+ like $@, qr/Label not found for "last Ｅ" at/u, "last's error is UTF-8 clean";
+
+ eval "redo Ｅ";
+ like $@, qr/Label not found for "redo Ｅ" at/u, "redo's error is UTF-8 clean";
+
+ eval "next Ｅ";
+ like $@, qr/Label not found for "next Ｅ" at/u, "next's error is UTF-8 clean";
+}
+
+my $d = 2;
+LÁBEL: {
+ my $e = $@;
+ my $prog = "redo L\N{LATIN CAPITAL LETTER A WITH ACUTE}BEL";
+
+ if ($d == 1) {
+ is $e, '', "redo UTF8 works";
+ utf8::downgrade($prog);
+ }
+ if ($d--) {
+ use feature 'unicode_eval';
+ no warnings 'exiting';
+ eval $prog;
+ }
+}
+
+like $@, qr/Unrecognized character/, "redo to downgradeable labels";
+is $d, 0, "Latin-1 labels are reachable";
+
+{
+ no warnings;
+ goto ここ;
+
+ if (undef) {
+ ここ: {
+ pass("goto UTF-8 LABEL works.");
+ }
+ }
+}
Modified: trunk/contrib/perl/t/uni/latin2.t
===================================================================
--- trunk/contrib/perl/t/uni/latin2.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/uni/latin2.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -9,6 +9,7 @@
plan tests => 94;
+no warnings 'deprecated';
use encoding "latin2"; # iso 8859-2
# U+00C1, \xC1, \301, LATIN CAPITAL LETTER A WITH ACUTE
Property changes on: trunk/contrib/perl/t/uni/latin2.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/uni/lex_utf8.t
===================================================================
--- trunk/contrib/perl/t/uni/lex_utf8.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/uni/lex_utf8.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -12,7 +12,7 @@
use strict;
-plan (tests => 10);
+plan (tests => 11);
use charnames ':full';
use utf8;
@@ -40,6 +40,13 @@
is((join "", unpack("C*", $uname_last)), "98" . "198" . "129" . "194" . "181", 'b . char above 0x100 . \N{U+00B5}');
is((join "", unpack("C*", $octal_first)), "99" . "195" . "191" . "196" . "134", 'c . \377 . char above 0x100');
is((join "", unpack("C*", $octal_last)), "99" . "196" . "134" . "195" . "191", 'c . char above 0x100 . \377');
+};
+
+{
+ local $SIG{__WARN__} = sub {};
+ eval "our $::\xe9; $\xe9";
+ unlike $@, qr/utf8_heavy/,
+ 'No utf8_heavy errors with our() syntax errors';
}
__END__
Property changes on: trunk/contrib/perl/t/uni/lex_utf8.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/uni/lower.t
===================================================================
--- trunk/contrib/perl/t/uni/lower.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/uni/lower.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -5,6 +5,6 @@
}
casetest(0, # No extra tests run here,
- "Lower", \%utf8::ToSpecLower,
+ "Lowercase_Mapping",
sub { lc $_[0] }, sub { my $a = ""; lc ($_[0] . $a) },
sub { lcfirst $_[0] }, sub { my $a = ""; lcfirst ($_[0] . $a) });
Property changes on: trunk/contrib/perl/t/uni/lower.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/t/uni/method.t (from rev 6437, vendor/perl/5.18.1/t/uni/method.t)
===================================================================
--- trunk/contrib/perl/t/uni/method.t (rev 0)
+++ trunk/contrib/perl/t/uni/method.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,205 @@
+#!./perl -w
+
+#
+# test method calls and autoloading.
+#
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = qw(. ../lib);
+ require "test.pl";
+}
+
+use strict;
+use utf8;
+use open qw( :utf8 :std );
+no warnings 'once';
+
+plan(tests => 62);
+
+#Can't use bless yet, as it might not be clean
+
+sub F::ｂ { ::is shift, "F"; "UTF8 meth" }
+sub Ｆ::b { ::is shift, "Ｆ"; "UTF8 Stash" }
+sub Ｆ::ｂ { ::is shift, "Ｆ"; "UTF8 Stash&meth" }
+
+is(F->ｂ, "UTF8 meth", "If the method is in UTF-8, lookup works through explicitly named methods");
+is(F->${\"ｂ"}, "UTF8 meth", '..as does for ->${\""}');
+eval { F->${\"ｂ\0nul"} };
+ok $@, "If the method is in UTF-8, lookup is nul-clean";
+
+is(Ｆ->b, "UTF8 Stash", "If the stash is in UTF-8, lookup works through explicitly named methods");
+is(Ｆ->${\"b"}, "UTF8 Stash", '..as does for ->${\""}');
+eval { Ｆ->${\"b\0nul"} };
+ok $@, "If the stash is in UTF-8, lookup is nul-clean";
+
+is(Ｆ->ｂ, "UTF8 Stash&meth", "If both stash and method are in UTF-8, lookup works through explicitly named methods");
+is(Ｆ->${\"ｂ"}, "UTF8 Stash&meth", '..as does for ->${\""}');
+eval { Ｆ->${\"ｂ\0nul"} };
+ok $@, "Even if both stash and method are in UTF-8, lookup is nul-clean";
+
+eval { my $ref = \my $var; $ref->ｍｅｔｈｏｄ };
+like $@, qr/Can't call method "ｍｅｔｈｏｄ" on unblessed reference /u;
+
+{
+ use utf8;
+ use open qw( :utf8 :std );
+
+ my $e;
+
+ eval '$e = bless {}, "Ｅ::Ａ"; Ｅ::Ａ->ｆｏｏ()';
+ like ($@, qr/^\QCan't locate object method "ｆｏｏ" via package "Ｅ::Ａ" at/u);
+ eval '$e = bless {}, "Ｅ::Ｂ"; $e->ｆｏｏ()';
+ like ($@, qr/^\QCan't locate object method "ｆｏｏ" via package "Ｅ::Ｂ" at/u);
+ eval 'Ｅ::Ｃ->ｆｏｏ()';
+ like ($@, qr/^\QCan't locate object method "ｆｏｏ" via package "Ｅ::Ｃ" (perhaps /u);
+
+ eval 'UNIVERSAL->Ｅ::Ｄ::ｆｏｏ()';
+ like ($@, qr/^\QCan't locate object method "ｆｏｏ" via package "Ｅ::Ｄ" (perhaps /u);
+ eval 'my $e = bless {}, "UNIVERSAL"; $e->Ｅ::Ｅ::ｆｏｏ()';
+ like ($@, qr/^\QCan't locate object method "ｆｏｏ" via package "Ｅ::Ｅ" (perhaps /u);
+
+ $e = bless {}, "Ｅ::Ｆ"; # force package to exist
+ eval 'UNIVERSAL->Ｅ::Ｆ::ｆｏｏ()';
+ like ($@, qr/^\QCan't locate object method "ｆｏｏ" via package "Ｅ::Ｆ" at/u);
+ eval '$e = bless {}, "UNIVERSAL"; $e->Ｅ::Ｆ::ｆｏｏ()';
+ like ($@, qr/^\QCan't locate object method "ｆｏｏ" via package "Ｅ::Ｆ" at/u);
+}
+
+is(do { use utf8; use open qw( :utf8 :std ); eval 'Ｆｏｏ->ｂｏｏｇｉｅ()';
+ $@ =~ /^\QCan't locate object method "ｂｏｏｇｉｅ" via package "Ｆｏｏ" (perhaps /u ? 1 : $@}, 1);
+
+#This reimplements a bit of _fresh_perl() from test.pl, as we want to decode
+#the output of that program before using it.
+SKIP: {
+ skip_if_miniperl('no dynamic loading on miniperl, no Encode');
+
+ my $prog = q!use utf8; use open qw( :utf8 :std ); sub Ｔ::DESTROY { $x = $_[0]; } bless [], "Ｔ";!;
+ utf8::decode($prog);
+
+ my $tmpfile = tempfile();
+ my $runperl_args = {};
+ $runperl_args->{progfile} = $tmpfile;
+ $runperl_args->{stderr} = 1;
+
+ open TEST, '>', $tmpfile or die "Cannot open $tmpfile: $!";
+
+ print TEST $prog;
+ close TEST or die "Cannot close $tmpfile: $!";
+
+ my $results = runperl(%$runperl_args);
+
+ require Encode;
+ $results = Encode::decode("UTF-8", $results);
+
+ like($results,
+ qr/DESTROY created new reference to dead object 'Ｔ' during global destruction./u,
+ "DESTROY creating a new reference to the object generates a warning in UTF-8.");
+}
+
+package Føø::Bær {
+ sub new { bless {}, shift }
+ sub nèw { bless {}, shift }
+}
+
+like( Føø::Bær::new("Føø::Bær"), qr/Føø::Bær=HASH/u, 'Can access new directly through a UTF-8 package.' );
+like( Føø::Bær->new, qr/Føø::Bær=HASH/u, 'Can access new as a method through a UTF-8 package.' );
+like( Føø::Bær::nèw("Føø::Bær"), qr/Føø::Bær=HASH/u, 'Can access nèw directly through a UTF-8 package.' );
+like( Føø::Bær->nèw, qr/Føø::Bær=HASH/u, 'Can access nèw as a method through a UTF-8 package.' );
+
+is( ref Føø::Bær->new, 'Føø::Bær');
+
+my $new_ascii = "new";
+my $new_latin = "nèw";
+my $new_utf8 = "n\303\250w";
+my $newoct = "n\303\250w";
+utf8::decode($new_utf8);
+
+like( Føø::Bær->$new_ascii, qr/Føø::Bær=HASH/u, "Can access \$new_ascii, [$new_ascii], stored in a scalar, as a method, through a UTF-8 package." );
+like( Føø::Bær->$new_latin, qr/Føø::Bær=HASH/u, "Can access \$new_latin, [$new_latin], stored in a scalar, as a method, through a UTF-8 package." );
+like( Føø::Bær->$new_utf8, qr/Føø::Bær=HASH/u, "Can access \$new_utf8, [$new_utf8], stored in a scalar, as a method, through a UTF-8 package." );
+{
+ local $@;
+ eval { Føø::Bær->$newoct };
+ like($@, qr/Can't locate object method "n\303\250w" via package "Føø::Bær"/u, "Can't access [$newoct], stored in a scalar, as a method through a UTF-8 package." );
+}
+
+
+like( nèw Føø::Bær, qr/Føø::Bær=HASH/u, "Can access [nèw] as a method through a UTF-8 indirect object package.");
+
+my $pkg_latin_1 = 'Føø::Bær';
+
+like( $pkg_latin_1->new, qr/Føø::Bær=HASH/u, 'Can access new as a method when the UTF-8 package name is in a scalar.');
+like( $pkg_latin_1->nèw, qr/Føø::Bær=HASH/u, 'Can access nèw as a method when the UTF-8 package name is in a scalar.');
+
+like( $pkg_latin_1->$new_ascii, qr/Føø::Bær=HASH/u, "Can access \$new_ascii, [$new_ascii], stored in a scalar, as a method, when the UTF-8 package name is also in a scalar.");
+like( $pkg_latin_1->$new_latin, qr/Føø::Bær=HASH/u, "Can access \$new_latin, [$new_latin], stored in a scalar, as a method, when the UTF-8 package name is also in a scalar.");
+like( $pkg_latin_1->$new_utf8, qr/Føø::Bær=HASH/u, "Can access \$new_utf8, [$new_utf8], stored in a scalar, as a method, when the UTF-8 package name is also in a scalar." );
+{
+ local $@;
+ eval { $pkg_latin_1->$newoct };
+ like($@, qr/Can't locate object method "n\303\250w" via package "Føø::Bær"/u, "Can't access [$newoct], stored in a scalar, as a method, when the UTF-8 package name is also in a scalar.");
+}
+
+ok !!Føø::Bær->can($new_ascii), "->can works for [$new_ascii]";
+ok !!Føø::Bær->can($new_latin), "->can works for [$new_latin]";
+ok((not !!Føø::Bær->can($newoct)), "->can doesn't work for [$newoct]");
+
+package クラス {
+ sub new { bless {}, shift }
+ sub ニュー { bless {}, shift }
+}
+
+like( クラス::new("クラス"), qr/クラス=HASH/u);
+like( クラス->new, qr/クラス=HASH/u);
+
+like( クラス::ニュー("クラス"), qr/クラス=HASH/u);
+like( クラス->ニュー, qr/クラス=HASH/u);
+
+like( ニュー クラス, qr/クラス=HASH/u, "Indirect object is UTF-8, as is the class.");
+
+is( ref クラス->new, 'クラス');
+is( ref クラス->ニュー, 'クラス');
+
+package Foo::Bar {
+ our @ISA = qw( Føø::Bær );
+}
+
+package Foo::Bàz {
+ use parent qw( -norequire Føø::Bær );
+}
+
+package ฟọ::バッズ {
+ use parent qw( -norequire Føø::Bær クラス );
+}
+
+ok(Foo::Bar->new, 'Simple inheritance works by pushing into @ISA,');
+ok(Foo::Bar->nèw, 'Even with UTF-8 methods');
+
+ok(Foo::Bàz->new, 'Simple inheritance works with parent using -norequire,');
+ok(Foo::Bàz->nèw, 'Even with UTF-8 methods');
+
+ok(ฟọ::バッズ->new, 'parent using -norequire, in a UTF-8 package.');
+ok(ฟọ::バッズ->nèw, 'Also works with UTF-8 methods');
+ok(ฟọ::バッズ->ニュー, 'Even methods from an UTF-8 parent');
+
+BEGIN {no strict 'refs'; ++${"\xff::foo"} } # autovivify the package
+package ÿ { # without UTF8
+ sub AUTOLOAD {
+ ::is our $AUTOLOAD,
+ "\xff::\x{100}", '$AUTOLOAD made from Latin1 package + UTF8 sub';
+ }
+}
+ÿ->${\"\x{100}"};
+
+#This test should go somewhere else.
+#DATA was being generated in the wrong package.
+package ʑ;
+no strict 'refs';
+
+::ok( *{"ʑ::DATA"}{IO}, "DATA is generated in the right glob");
+::ok !defined(*{"main::DATA"}{IO});
+::is scalar <DATA>, "Some data\n";
+
+__DATA__
+Some data
Copied: trunk/contrib/perl/t/uni/opcroak.t (from rev 6437, vendor/perl/5.18.1/t/uni/opcroak.t)
===================================================================
--- trunk/contrib/perl/t/uni/opcroak.t (rev 0)
+++ trunk/contrib/perl/t/uni/opcroak.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,44 @@
+#!./perl
+
+#
+# tests for op.c generated croaks
+#
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require './test.pl';
+}
+
+use utf8;
+use open qw( :utf8 :std );
+use warnings;
+
+plan( tests => 5 );
+
+eval qq!sub \x{30cb} (\$) {} \x{30cb}()!;
+like $@, qr/Not enough arguments for main::\x{30cb}/u, "Not enough arguments croak is UTF-8 clean";
+
+eval qq!sub \x{30cc} (\$) {} \x{30cc}(1, 2)!;
+like $@, qr/Too many arguments for main::\x{30cc}/u, "Too many arguments croak is UTF-8 clean";
+
+eval qq!sub \x{30cd} (\Q\%\E) { 1 } \x{30cd}(1);!;
+like $@, qr/Type of arg 1 to main::\x{30cd} must be/u, "bad type croak is UTF-8 clean";
+
+ eval <<'END_FIELDS';
+ {
+ package ＦŌŌ {
+ use fields qw( a b );
+ sub new { bless {}, shift }
+ }
+ }
+END_FIELDS
+
+for (
+ [ element => 'my ＦŌŌ $bàr = ＦŌŌ->new; $bàr->{クラス};' ],
+ [ slice => 'my ＦŌŌ $bàr = ＦŌŌ->new; @{$bàr}{ qw( a クラス ) };' ]
+ ) {
+ eval $_->[1];
+
+ like $@, qr/No such class field "クラス" in variable \$bàr of type ＦŌŌ/, "$_->[0]: no such field error is UTF-8 clean";
+}
Modified: trunk/contrib/perl/t/uni/overload.t
===================================================================
--- trunk/contrib/perl/t/uni/overload.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/uni/overload.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -3,6 +3,7 @@
BEGIN {
chdir 't';
@INC = '../lib';
+ require Config; import Config;
require './test.pl';
}
@@ -95,8 +96,10 @@
my $have_setlocale = 0;
eval {
require POSIX;
- import POSIX ':locale_h';
- $have_setlocale++;
+ if($Config{d_setlocale}) {
+ import POSIX ':locale_h';
+ $have_setlocale++;
+ }
};
SKIP: {
@@ -107,7 +110,11 @@
} elsif ($^O eq 'dec_osf' || $^O eq 'VMS') {
skip "$^O has broken en_GB.ISO8859-1 locale", 24;
} else {
- use locale;
+ BEGIN {
+ if($Config{d_setlocale}) {
+ require locale; import locale;
+ }
+ }
my $u = UTF8Toggle->new("\311");
my $lc = lc $u;
is (length $lc, 1);
Property changes on: trunk/contrib/perl/t/uni/overload.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/t/uni/package.t (from rev 6437, vendor/perl/5.18.1/t/uni/package.t)
===================================================================
--- trunk/contrib/perl/t/uni/package.t (rev 0)
+++ trunk/contrib/perl/t/uni/package.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,111 @@
+#!./perl
+
+# Checks if 'package' work as intended.
+
+BEGIN {
+ require './test.pl';
+}
+
+plan (tests => 18);
+
+use utf8;
+use open qw( :utf8 :std );
+
+package Føø::Bær { }
+
+package クラス { }
+
+package ฟọ::バッズ { }
+
+ok 1, "sanity check. If we got this far, UTF-8 in package names is legal.";
+
+#The next few come from comp/package.t
+{
+
+ $ㄅĽuṞfⳐ = 123;
+
+ package ꑭʑ;
+
+ sub ニュー {bless [];}
+ $bar = 4;
+ {
+ package 압Ƈ;
+ $ㄅĽuṞfⳐ = 5;
+ }
+
+ $압Ƈ'd읯ⱪ = 6; #'
+
+ $ꑭʑ = 2;
+
+ $ꑭʑ = join(':', sort(keys %ꑭʑ::));
+ $압Ƈ = join(':', sort(keys %압Ƈ::));
+
+ ::is $ꑭʑ, 'bar:ニュー:ꑭʑ:압Ƈ', "comp/stash.t test 1";
+ ::is $압Ƈ, "d읯ⱪ:ㄅĽuṞfⳐ", "comp/stash.t test 2";
+ ::is $main'ㄅĽuṞfⳐ, 123, "comp/stash.t test 3";
+
+ package 압Ƈ;
+
+ ::is $ㄅĽuṞfⳐ, 5, "comp/stash.t test 4";
+ eval '::is $ㄅĽuṞfⳐ, 5, "comp/stash.t test 5";';
+ eval 'package main; is $ㄅĽuṞfⳐ, 123, "comp/stash.t test 6";';
+ ::is $ㄅĽuṞfⳐ, 5, "comp/stash.t test 7";
+
+ #This is actually pretty bad, as caller() wasn't clean to begin with.
+ package main;
+ sub ㄘ { caller(0) }
+
+ sub ƒஓ {
+ my $s = shift;
+ if ($s) {
+ package ᛔQR;
+ main::ㄘ();
+ }
+ }
+
+ is((ƒஓ(1))[0], 'ᛔQR', "comp/stash.t test 8");
+
+ my $Q = ꑭʑ->ニュー();
+ undef %ꑭʑ::;
+ eval { $a = *ꑭʑ::ニュー{PACKAGE}; };
+ is $a, "__ANON__", "comp/stash.t test 9";
+
+ {
+ local $@;
+ eval { $Q->param; };
+ like $@, qr/^Can't use anonymous symbol table for method lookup/, "comp/stash.t test 10";
+ }
+
+ like "$Q", qr/^__ANON__=/, "comp/stash.t test 11";
+
+ is ref $Q, "__ANON__", "comp/stash.t test 12";
+
+ package bugⅲⅱⅴⅵⅱ { #not really latin, but bear with me, I'm not Damian.
+ ::is( __PACKAGE__, 'bugⅲⅱⅴⅵⅱ', "comp/stash.t test 13");
+ ::is( eval('__PACKAGE__'), 'bugⅲⅱⅴⅵⅱ', "comp/stash.t test 14");
+ }
+}
+
+#This comes from comp/package_block.t
+{
+ local $@;
+ eval q[package ᕘ {];
+ like $@, qr/\AMissing right curly /, "comp/package_block.t test";
+}
+
+# perl #105922
+
+{
+ my $latin_1 = "þackage";
+ my $utf8 = "þackage";
+ utf8::downgrade($latin_1);
+ utf8::upgrade($utf8);
+
+ local $@;
+ eval { $latin_1->can("yadda") };
+ ok(!$@, "latin1->meth works");
+
+ local $@;
+ eval { $utf8->can("yadda") };
+ ok(!$@, "utf8->meth works");
+}
Copied: trunk/contrib/perl/t/uni/parser.t (from rev 6437, vendor/perl/5.18.1/t/uni/parser.t)
===================================================================
--- trunk/contrib/perl/t/uni/parser.t (rev 0)
+++ trunk/contrib/perl/t/uni/parser.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,154 @@
+#!./perl
+
+# Checks if the parser behaves correctly in edge cases
+# (including weird syntax errors)
+
+BEGIN {
+ require './test.pl';
+}
+
+plan (tests => 48);
+
+use utf8;
+use open qw( :utf8 :std );
+
+ok *tèst, "*main::tèst", "sanity check.";
+ok $::{"tèst"}, "gets the right glob in the stash.";
+
+my $glob_by_sub = sub { *ｍａｉｎ::method }->();
+
+is *ｍａｉｎ::method, "*ｍａｉｎ::method", "glob stringy works";
+is "" . *ｍａｉｎ::method, "*ｍａｉｎ::method", "glob stringify-through-concat works";
+is $glob_by_sub, "*ｍａｉｎ::method", "glob stringy works";
+is "" . $glob_by_sub, "*ｍａｉｎ::method", "";
+
+sub gimme_glob {
+ no strict 'refs';
+ is *{$_[0]}, "*main::$_[0]";
+ *{$_[0]};
+}
+
+is "" . gimme_glob("下郎"), "*main::下郎";
+$a = *下郎;
+is "" . $a, "*main::下郎";
+
+*{gimme_glob("下郎")} = sub {};
+
+{
+ ok defined *{"下郎"}{CODE};
+ ok !defined *{"\344\270\213\351\203\216"}{CODE};
+}
+
+$Lèon = 1;
+is ${*Lèon{SCALAR}}, 1, "scalar define in the right glob,";
+ok !${*{"L\303\250on"}{SCALAR}}, "..and nothing in the wrong one.";
+
+my $a = "foo" . chr(190);
+my $b = $a . chr(256);
+chop $b; # $b is $a with utf8 on
+
+is $a, $b, '$a equals $b';
+
+*$b = sub { 5 };
+
+is eval { main->$a }, 5, q!$a can call $b's sub!;
+ok !$@, "..and there's no error.";
+
+my $c = $b;
+utf8::encode($c);
+ok $b ne $c, '$b unequal $c';
+eval { main->$c };
+ok $@, q!$c can't call $b's sub.!;
+
+# Now define another sub under the downgraded name:
+*$a = sub { 6 };
+# Call it:
+is eval { main->$a }, 6, "Adding a new sub to *a and calling it works,";
+ok !$@, "..without errors.";
+eval { main->$c };
+ok $@, "but it's still unreachable through *c";
+
+*$b = \10;
+is ${*$a{SCALAR}}, 10;
+is ${*$b{SCALAR}}, 10;
+is ${*$c{SCALAR}}, undef;
+
+opendir FÒÒ, ".";
+closedir FÒÒ;
+::ok($::{"FÒÒ"}, "Bareword generates the right glob.");
+::ok(!$::{"F\303\222\303\222"});
+
+sub участники { 1 }
+
+ok $::{"участники"}, "non-const sub declarations generate the right glob";
+ok *{$::{"участники"}}{CODE};
+is *{$::{"участники"}}{CODE}->(), 1;
+
+sub 原 () { 1 }
+
+is grep({ $_ eq "\x{539f}" } keys %::), 1, "Constant subs generate the right glob.";
+is grep({ $_ eq "\345\216\237" } keys %::), 0;
+
+#These should probably go elsewhere.
+eval q{ sub wròng1 (_$); wròng1(1,2) };
+like( $@, qr/Malformed prototype for main::wròng1/, 'Malformed prototype croak is clean.' );
+
+eval q{ sub ча::ики ($__); ча::ики(1,2) };
+like( $@, qr/Malformed prototype for ча::ики/ );
+
+our $問 = 10;
+is $問, 10, "our works";
+is $main::問, 10, "...as does getting the same variable through the fully qualified name";
+is ${"main::\345\225\217"}, undef, "..and using the encoded form doesn't";
+
+{
+ use charnames qw( :full );
+
+ eval qq! my \$\x{30cb} \N{DROMEDARY CAMEL} !;
+ $@ =~ s/eval \d+/eval 11/;
+ is $@, 'Unrecognized character \x{1f42a}; marked by <-- HERE after my $ニ <-- HERE near column 8 at (eval 11) line 1.
+', "'Unrecognized character' croak is UTF-8 clean";
+}
+
+{
+ use feature 'state';
+ for ( qw( my state our ) ) {
+ local $@;
+ eval "$_ Ｆｏｏ $x = 1;";
+ like $@, qr/No such class Ｆｏｏ/u, "'No such class' warning for $_ is UTF-8 clean";
+ }
+}
+
+{
+ local $@;
+ eval "our \$main::\x{30cb};";
+ like $@, qr!No package name allowed for variable \$main::\x{30cb} in "our"!, "'No such package name allowed for variable' is UTF-8 clean";
+}
+
+{
+ use feature 'state';
+ local $@;
+ for ( qw( my state ) ) {
+ eval "$_ \$::\x{30cb};";
+ like $@, qr!"$_" variable \$::\x{30cb} can't be in a package!, qq!'"$_" variable %s can't be in a package' is UTF-8 clean!;
+ }
+}
+
+{
+ local $@;
+ eval qq!print \x{30cb}, "comma""!;
+ like $@, qr/No comma allowed after filehandle/, "No comma allowed after filehandle triggers correctly for UTF-8 filehandles.";
+}
+
+# tests for "Bad name"
+eval q{ Ｆｏｏ::$bar };
+like( $@, qr/Bad name after Ｆｏｏ::/, 'Bad name after Ｆｏｏ::' );
+eval q{ Ｆｏｏ''bar };
+like( $@, qr/Bad name after Ｆｏｏ'/, 'Bad name after Ｆｏｏ\'' );
+
+{
+ no warnings 'utf8';
+ my $malformed_to_be = "\x{c0}\x{a0}"; # Overlong sequence
+ CORE::evalbytes "use charnames ':full'; use utf8; my \$x = \"\\N{abc$malformed_to_be}\"";
+ like( $@, qr/Malformed UTF-8 character immediately after '\\N\{abc' at .* within string/, 'Malformed UTF-8 input to \N{}');
+}
Copied: trunk/contrib/perl/t/uni/readline.t (from rev 6437, vendor/perl/5.18.1/t/uni/readline.t)
===================================================================
--- trunk/contrib/perl/t/uni/readline.t (rev 0)
+++ trunk/contrib/perl/t/uni/readline.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,66 @@
+#!./perl
+
+BEGIN {
+ chdir 't';
+ @INC = '../lib';
+ require './test.pl';
+}
+
+plan tests => 7;
+
+use utf8;
+use open qw( :utf8 :std );
+
+# [perl #19566]: sv_gets writes directly to its argument via
+# TARG. Test that we respect SvREADONLY.
+eval { for (\2) { $_ = <Fʜ> } };
+like($@, 'Modification of a read-only value attempted', '[perl #19566]');
+
+# [perl #21628]
+{
+ my $file = tempfile();
+ open Ạ,'+>',$file; $a = 3;
+ is($a .= <Ạ>, 3, '#21628 - $a .= <A> , A eof');
+ close Ạ; $a = 4;
+ is($a .= <Ạ>, 4, '#21628 - $a .= <A> , A closed');
+}
+
+use strict;
+
+open ᕝ, '.' and sysread ᕝ, $_, 1;
+my $err = $! + 0;
+close ᕝ;
+
+SKIP: {
+ skip "you can read directories as plain files", 2 unless( $err );
+
+ $!=0;
+ open ᕝ, '.' and $_=<ᕝ>;
+ ok( $!==$err && !defined($_) => 'readline( DIRECTORY )' );
+ close ᕝ;
+
+ $!=0;
+ { local $/;
+ open ᕝ, '.' and $_=<ᕝ>;
+ ok( $!==$err && !defined($_) => 'readline( DIRECTORY ) slurp mode' );
+ close ᕝ;
+ }
+}
+
+my $obj = bless [], "Ȼლᔆ";
+$obj .= <DATA>;
+like($obj, qr/Ȼლᔆ=ARRAY.*world/u, 'rcatline and refs');
+
+{
+ my $file = tempfile();
+ open my $out_fh, ">", $file;
+ print { $out_fh } "Data\n";
+ close $out_fh;
+
+ open hòฟ, "<", $file;
+ is( scalar(<hòฟ>), "Data\n", "readline() works correctly on UTF-8 filehandles" );
+ close hòฟ;
+}
+
+__DATA__
+world
Copied: trunk/contrib/perl/t/uni/select.t (from rev 6437, vendor/perl/5.18.1/t/uni/select.t)
===================================================================
--- trunk/contrib/perl/t/uni/select.t (rev 0)
+++ trunk/contrib/perl/t/uni/select.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,35 @@
+#!./perl
+
+#
+# Tests whenever the return value of select(FH) is correctly encoded.
+#
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require './test.pl';
+}
+
+use utf8;
+use open qw( :utf8 :std );
+
+plan( tests => 5 );
+
+open DÙP, ">&", *STDERR;
+open $dùp, ">&", *STDOUT;
+open 둪, ">&", *STDERR;
+open $ᛞ웊, ">&", *STDOUT;
+
+is select(DÙP), "main::STDOUT";
+is select($dùp), "main::DÙP";
+
+TODO: {
+ local $TODO = "Scalar filehandles not yet clean";
+ is select(둪), "main::dùp";
+}
+
+is select($ᛞ웊), "main::둪";
+TODO: {
+ local $TODO = "Scalar filehandles not yet clean";
+ is select(STDOUT), "main::ᛞ웊";
+}
Index: trunk/contrib/perl/t/uni/sprintf.t
===================================================================
--- trunk/contrib/perl/t/uni/sprintf.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/uni/sprintf.t 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/uni/sprintf.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/t/uni/stash.t (from rev 6437, vendor/perl/5.18.1/t/uni/stash.t)
===================================================================
--- trunk/contrib/perl/t/uni/stash.t (rev 0)
+++ trunk/contrib/perl/t/uni/stash.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,310 @@
+#!./perl
+
+#
+# various stash tests
+#
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require './test.pl';
+}
+
+use utf8;
+use open qw( :utf8 :std );
+
+plan( tests => 58 );
+
+#These come from op/my_stash.t
+{
+ use constant Myクラス => 'ꕽ::Ʉ::ꔬz::ꢨᙇ';
+
+ {
+ package ꕽ::Ʉ::ꔬz::ꢨᙇ;
+ 1;
+ }
+
+ for (qw(ꕽ ꕽ:: Myクラス __PACKAGE__)) {
+ eval "sub { my $_ \$obj = shift; }";
+ ok ! $@, "op/my_stash.t test, $_";
+ }
+
+ use constant NòClàss => '노pӬ::ꕽ::Ꜻ::BӢz::ʙࡆ';
+
+ for (qw(노pӬ 노pӬ:: NòClàss)) {
+ eval "sub { my $_ \$obj = shift; }";
+ ok $@, "op/my_stash.t test";
+ }
+}
+
+#op/stash.t
+{
+ {
+ no warnings 'deprecated';
+ ok( defined %왿ퟀⲺa::ᒫṡ::, q(stashes happen to be defined if not used) );
+ ok( defined %{"왿ퟀⲺa::ᒫṡ::"}, q(- work with hard refs too) );
+
+ ok( defined %ᛐⲞɲe::Šꇇᚽṙᆂṗ::, q(stashes are defined if seen at compile time) );
+ ok( defined %{"ᛐⲞɲe::Šꇇᚽṙᆂṗ::"}, q(- work with hard refs too) );
+
+ ok( defined %본go::ଶfʦbᚒƴ::, q(stashes are defined if a var is seen at compile time) );
+ ok( defined %{"본go::ଶfʦbᚒƴ::"}, q(- work with hard refs too) );
+ }
+
+
+ package ᛐⲞɲe::Šꇇᚽṙᆂṗ;
+ $본go::ଶfʦbᚒƴ::scalar = 1;
+
+ package main;
+
+ # now tests in eval
+
+ ok( eval { no warnings 'deprecated'; defined %앛hȚꟻࡃҥ:: }, 'works in eval{}' );
+ ok( eval q{ no warnings 'deprecated'; defined %Ṧㄘㇹen맠ㄦ:: }, 'works in eval("")' );
+
+ # now tests with strictures
+
+ {
+ use strict;
+ no warnings 'deprecated';
+ ok( defined %piƓ::, q(referencing a non-existent stash doesn't produce stricture errors) );
+ ok( !exists $piƓ::{bodine}, q(referencing a non-existent stash element doesn't produce stricture errors) );
+ }
+
+ SKIP: {
+ eval { require B; 1 } or skip "no B", 28;
+
+ *b = \&B::svref_2object;
+ my $CVf_ANON = B::CVf_ANON();
+
+ my $sub = do {
+ package 온ꪵ;
+ \&{"온ꪵ"};
+ };
+ delete $온ꪵ::{온ꪵ};
+ my $gv = b($sub)->GV;
+
+ object_ok( $gv, "B::GV", "deleted stash entry leaves CV with valid GV");
+ is( b($sub)->CvFLAGS & $CVf_ANON, $CVf_ANON, "...and CVf_ANON set");
+ is( eval { $gv->NAME }, "__ANON__", "...and an __ANON__ name");
+ is( eval { $gv->STASH->NAME }, "온ꪵ", "...but leaves stash intact");
+
+ $sub = do {
+ package tꖿ;
+ \&{"tꖿ"};
+ };
+ %tꖿ:: = ();
+ $gv = b($sub)->GV;
+
+ object_ok( $gv, "B::GV", "cleared stash leaves CV with valid GV");
+ is( b($sub)->CvFLAGS & $CVf_ANON, $CVf_ANON, "...and CVf_ANON set");
+ is( eval { $gv->NAME }, "__ANON__", "...and an __ANON__ name");
+ is( eval { $gv->STASH->NAME }, "tꖿ", "...but leaves stash intact");
+
+ $sub = do {
+ package ᖟ레ￇ;
+ \&{"ᖟ레ￇ"};
+ };
+ undef %ᖟ레ￇ::;
+ $gv = b($sub)->GV;
+
+ object_ok( $gv, "B::GV", "undefed stash leaves CV with valid GV");
+ is( b($sub)->CvFLAGS & $CVf_ANON, $CVf_ANON, "...and CVf_ANON set");
+ is( eval { $gv->NAME }, "__ANON__", "...and an __ANON__ name");
+ is( eval { $gv->STASH->NAME }, "__ANON__", "...and an __ANON__ stash");
+
+ my $sub = do {
+ package ꃖᚢ;
+ sub { 1 };
+ };
+ %ꃖᚢ:: = ();
+
+ my $gv = B::svref_2object($sub)->GV;
+ ok($gv->isa(q/B::GV/), "cleared stash leaves anon CV with valid GV");
+
+ my $st = eval { $gv->STASH->NAME };
+ is($st, q/ꃖᚢ/, "...but leaves the stash intact");
+
+ $sub = do {
+ package fꢄᶹᵌ;
+ sub { 1 };
+ };
+ undef %fꢄᶹᵌ::;
+
+ $gv = B::svref_2object($sub)->GV;
+ ok($gv->isa(q/B::GV/), "undefed stash leaves anon CV with valid GV");
+
+ $st = eval { $gv->STASH->NAME };
+
+ { local $TODO = 'STASHES not anonymized';
+ is($st, q/__ANON__/, "...and an __ANON__ stash");
+ }
+
+ $sub = do {
+ package sӥㄒ;
+ \&{"sӥㄒ"}
+ };
+ my $stash_glob = delete $::{"sӥㄒ::"};
+ # Now free the GV while the stash still exists (though detached)
+ delete $$stash_glob{"sӥㄒ"};
+ $gv = B::svref_2object($sub)->GV;
+ ok($gv->isa(q/B::GV/),
+ 'anonymised CV whose stash is detached still has a GV');
+ #fails because mro_gather_and_rename isn't clean
+ is $gv->STASH->NAME, '__ANON__',
+ 'CV anonymised when its stash is detached becomes __ANON__::__ANON__';
+
+ # CvSTASH should be null on a named sub if the stash has been deleted
+ {
+ package ＦŌŌ;
+ sub Ƒಓ {}
+ my $rfoo = \&Ƒಓ;
+ package main;
+ delete $::{'ＦŌŌ::'};
+ my $cv = B::svref_2object($rfoo);
+ # (is there a better way of testing for NULL ?)
+ my $stash = $cv->STASH;
+ like($stash, qr/B::SPECIAL/, "NULL CvSTASH on named sub");
+ }
+
+ # on glob reassignment, orphaned CV should have anon CvGV
+
+ {
+ my $r;
+ eval q[
+ package ＦŌŌ௨;
+ sub Ƒ{};
+ $r = \&Ƒ;
+ *Ƒ = sub {};
+ ];
+ delete $ＦŌŌ௨::{Ƒ};
+ my $cv = B::svref_2object($r);
+ my $gv = $cv->GV;
+ ok($gv->isa(q/B::GV/), "orphaned CV has valid GV");
+ is($gv->NAME, '__ANON__', "orphaned CV has anon GV");
+ }
+
+ # deleting __ANON__ glob shouldn't break things
+
+ {
+ package ＦŌŌ３;
+ sub 남えㄉ {};
+ my $anon = sub {};
+ my $남えㄉ = eval q[\&남えㄉ];
+ package main;
+ delete $ＦŌŌ３::{남えㄉ}; # make named anonymous
+
+ delete $ＦŌŌ３::{__ANON__}; # whoops!
+ my ($cv,$gv);
+ $cv = B::svref_2object($남えㄉ);
+ $gv = $cv->GV;
+ ok($gv->isa(q/B::GV/), "ex-named CV has valid GV");
+ is($gv->NAME, '__ANON__', "ex-named CV has anon GV");
+
+ $cv = B::svref_2object($anon);
+ $gv = $cv->GV;
+ ok($gv->isa(q/B::GV/), "anon CV has valid GV");
+ is($gv->NAME, '__ANON__', "anon CV has anon GV");
+ }
+
+ {
+ my $r;
+ {
+ package bᓙṗ;
+
+ BEGIN {
+ $r = \&main::Ẃⱒcᴷ;
+ }
+ }
+
+ my $br = B::svref_2object($r);
+ is ($br->STASH->NAME, 'bᓙṗ',
+ 'stub records the package it was compiled in');
+
+ # We need to take this reference "late", after the subroutine is
+ # defined.
+ $br = B::svref_2object(eval 'sub Ẃⱒcᴷ {}; \&Ẃⱒcᴷ');
+ die $@ if $@;
+
+ is ($br->STASH->NAME, 'main',
+ 'definition overrides the package it was compiled in');
+ like ($br->FILE, qr/eval/,
+ 'definition overrides the file it was compiled in');
+ }
+ }
+
+ # make sure having a sub called __ANON__ doesn't confuse perl.
+
+ {
+ package クラス;
+ my $c;
+ sub __ANON__ { $c = (caller(0))[3]; }
+ {
+ local $@;
+ eval { ok(1); };
+ ::like($@, qr/^Undefined subroutine &クラス::ok/);
+ }
+ __ANON__();
+ ::is ($c, 'クラス::__ANON__', '__ANON__ sub called ok');
+ }
+
+ # Stashes that are effectively renamed
+ {
+ package rìle;
+
+ use Config;
+
+ my $obj = bless [];
+ my $globref = \*tàt;
+
+ # effectively rename a stash
+ *slìn:: = *rìle::; *rìle:: = *zòr::;
+
+ ::is *$globref, "*rìle::tàt",
+ 'globs stringify the same way when stashes are moved';
+ ::is ref $obj, "rìle",
+ 'ref() returns the same thing when an object’s stash is moved';
+ ::like "$obj", qr "^rìle=ARRAY\(0x[\da-f]+\)\z",
+ 'objects stringify the same way when their stashes are moved';
+ ::is eval '__PACKAGE__', 'rìle',
+ '__PACKAGE__ returns the same when the current stash is moved';
+
+ # Now detach it completely from the symtab, making it effect-
+ # ively anonymous
+ my $life_raft = \%slìn::;
+ *slìn:: = *zòr::;
+
+ ::is *$globref, "*rìle::tàt",
+ 'globs stringify the same way when stashes are detached';
+ ::is ref $obj, "rìle",
+ 'ref() returns the same thing when an object’s stash is detached';
+ ::like "$obj", qr "^rìle=ARRAY\(0x[\da-f]+\)\z",
+ 'objects stringify the same way when their stashes are detached';
+ ::is eval '__PACKAGE__', 'rìle',
+ '__PACKAGE__ returns the same when the current stash is detached';
+ }
+
+ # Setting the name during undef %stash:: should have no effect.
+ {
+ my $glob = \*Phòò::glòb;
+ sub ò::DESTROY { eval '++$Phòò::bòr' }
+ no strict 'refs';
+ ${"Phòò::thòng1"} = bless [], "ò";
+ undef %Phòò::;
+ is "$$glob", "*__ANON__::glòb",
+ "setting stash name during undef has no effect";
+ }
+
+ # [perl #88134] incorrect package structure
+ {
+ package Bèàr::;
+ sub bàz{1}
+ package main;
+ ok eval { Bèàr::::bàz() },
+ 'packages ending with :: are self-consistent';
+ }
+
+ # [perl #88138] ' not equivalent to :: before a null
+ ${"à'\0b"} = "c";
+ is ${"à::\0b"}, "c", "' is equivalent to :: before a null";
+}
\ No newline at end of file
Modified: trunk/contrib/perl/t/uni/tie.t
===================================================================
--- trunk/contrib/perl/t/uni/tie.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/uni/tie.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -4,7 +4,7 @@
require './test.pl';
}
-plan (tests => 9);
+plan (tests => 10);
use strict;
{
@@ -41,6 +41,19 @@
}
{
+ use utf8;
+ use open qw( :utf8 :std );
+ package Tìè::UTF8 {
+ sub TIESCALAR {
+ return bless {}, shift;
+ }
+ }
+
+ my $t;
+ tie $t, 'Tìè::UTF8';
+ is ref(tied($t)), 'Tìè::UTF8', "Tie'ing to a UTF8 package works.";
+}
+{
local $::TODO = "Need more tests!";
fail();
}
Property changes on: trunk/contrib/perl/t/uni/tie.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/uni/title.t
===================================================================
--- trunk/contrib/perl/t/uni/title.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/uni/title.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -5,5 +5,5 @@
}
casetest(0, # No extra tests run here,
- "Title", \%utf8::ToSpecTitle, sub { ucfirst $_[0] },
+ "Titlecase_Mapping", sub { ucfirst $_[0] },
sub { my $a = ""; ucfirst ($_[0] . $a) });
Property changes on: trunk/contrib/perl/t/uni/title.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/uni/tr_7jis.t
===================================================================
--- trunk/contrib/perl/t/uni/tr_7jis.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/uni/tr_7jis.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -13,6 +13,7 @@
use strict;
plan(tests => 6);
+no warnings 'deprecated';
use encoding 'iso-2022-jp';
my @hiragana = map {chr} ord("$B$!(B")..ord("$B$s(B");
Property changes on: trunk/contrib/perl/t/uni/tr_7jis.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/uni/tr_eucjp.t
===================================================================
--- trunk/contrib/perl/t/uni/tr_eucjp.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/uni/tr_eucjp.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -12,6 +12,7 @@
use strict;
plan(tests => 6);
+no warnings 'deprecated';
use encoding 'euc-jp';
my @hiragana = map {chr} ord("\xA4\xA1")..ord("\xA4\xF3");
Property changes on: trunk/contrib/perl/t/uni/tr_eucjp.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/uni/tr_sjis.t
===================================================================
--- trunk/contrib/perl/t/uni/tr_sjis.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/uni/tr_sjis.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -12,6 +12,7 @@
use strict;
plan(tests => 6);
+no warnings 'deprecated';
use encoding 'shiftjis';
my @hiragana = map {chr} ord("\x82\x9F")..ord("\x82\xF1");
Property changes on: trunk/contrib/perl/t/uni/tr_sjis.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/t/uni/tr_utf8.t
===================================================================
--- trunk/contrib/perl/t/uni/tr_utf8.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/uni/tr_utf8.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -13,6 +13,7 @@
use strict;
plan(tests => 8);
+no warnings 'deprecated';
use encoding 'utf8';
my @hiragana = map {chr} ord("ぁ")..ord("ん");
Property changes on: trunk/contrib/perl/t/uni/tr_utf8.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/t/uni/universal.t (from rev 6437, vendor/perl/5.18.1/t/uni/universal.t)
===================================================================
--- trunk/contrib/perl/t/uni/universal.t (rev 0)
+++ trunk/contrib/perl/t/uni/universal.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,172 @@
+#!./perl
+#
+# check UNIVERSAL
+#
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ $| = 1;
+ require "./test.pl";
+}
+
+use utf8;
+use open qw( :utf8 :std );
+
+plan tests => 93;
+
+$a = {};
+bless $a, "Bòb";
+ok $a->isa("Bòb");
+
+package Hùmàn;
+sub èàt {}
+
+package Fèmàlè;
+ at ISA=qw(Hùmàn);
+
+package Àlìcè;
+ at ISA=qw(Bòb Fèmàlè);
+sub sìng;
+sub drìnk { return "drinking " . $_[1] }
+sub nèw { bless {} }
+
+$Àlìcè::VERSION = 2.718;
+
+{
+ package Cèdrìc;
+ our @ISA;
+ use base qw(Hùmàn);
+}
+
+{
+ package Prògràmmèr;
+ our $VERSION = 1.667;
+
+ sub wrìtè_perl { 1 }
+}
+
+package main;
+
+$a = nèw Àlìcè;
+
+ok $a->isa("Àlìcè");
+ok $a->isa("main::Àlìcè"); # check that alternate class names work
+ok(("main::Àlìcè"->nèw)->isa("Àlìcè"));
+
+ok $a->isa("Bòb");
+ok $a->isa("main::Bòb");
+
+ok $a->isa("Fèmàlè");
+
+ok $a->isa("Hùmàn");
+
+ok ! $a->isa("Màlè");
+
+ok ! $a->isa('Prògràmmèr');
+
+ok $a->isa("HASH");
+
+ok $a->can("èàt");
+ok ! $a->can("sleep");
+ok my $ref = $a->can("drìnk"); # returns a coderef
+is $a->$ref("tèà"), "drinking tèà"; # ... which works
+ok $ref = $a->can("sìng");
+eval { $a->$ref() };
+ok $@; # ... but not if no actual subroutine
+
+ok $a->can("VERSION");
+cmp_ok eval { $a->VERSION }, '==', 2.718;
+ok ! (eval { $a->VERSION(2.719) });
+like $@, qr/^Àlìcè version 2.719 required--this is only version 2.718 at /u;
+
+ok (!Cèdrìc->isa('Prògràmmèr'));
+
+ok (Cèdrìc->isa('Hùmàn'));
+
+push(@Cèdrìc::ISA,'Prògràmmèr');
+
+ok (Cèdrìc->isa('Prògràmmèr'));
+
+{
+ package Àlìcè;
+ base::->import('Prògràmmèr');
+}
+
+ok $a->isa('Prògràmmèr');
+ok $a->isa("Fèmàlè");
+
+ at Cèdrìc::ISA = qw(Bòb);
+
+ok (!Cèdrìc->isa('Prògràmmèr'));
+
+my $b = 'abc';
+my @refs = qw(SCALAR SCALAR LVALUE GLOB ARRAY HASH CODE);
+my @vals = ( \$b, \3.14, \substr($b,1,1), \*b, [], {}, sub {} );
+for ($p=0; $p < @refs; $p++) {
+ for ($q=0; $q < @vals; $q++) {
+ is UNIVERSAL::isa($vals[$p], $refs[$q]), ($p==$q or $p+$q==1);
+ };
+};
+
+
+ok UNIVERSAL::isa(Àlìcè => "UNIVERSAL");
+
+cmp_ok UNIVERSAL::can(Àlìcè => "can"), '==', \&UNIVERSAL::can;
+
+eval 'sub UNIVERSAL::slèèp {}';
+ok $a->can("slèèp");
+
+{
+ package Pìckùp;
+ no warnings "deprecated";
+ use UNIVERSAL qw( isa can VERSION );
+
+ ::ok isa "Pìckùp", UNIVERSAL;
+ ::cmp_ok can( "Pìckùp", "can" ), '==', \&UNIVERSAL::can;
+ ::ok VERSION "UNIVERSAL" ;
+}
+
+package Fòò;
+
+sub DOES { 1 }
+
+package Bàr;
+
+ at Bàr::ISA = 'Fòò';
+
+package Bàz;
+
+package main;
+ok( Fòò->DOES( 'bàr' ), 'DOES() should call DOES() on class' );
+ok( Bàr->DOES( 'Bàr' ), '... and should fall back to isa()' );
+ok( Bàr->DOES( 'Fòò' ), '... even when inherited' );
+ok( Bàz->DOES( 'Bàz' ), '... even without inheriting any other DOES()' );
+ok( ! Bàz->DOES( 'Fòò' ), '... returning true or false appropriately' );
+
+package Pìg;
+package Bòdìnè;
+Bòdìnè->isa('Pìg');
+
+package main;
+eval { UNIVERSAL::DOES([], "fòò") };
+like( $@, qr/Can't call method "DOES" on unblessed reference/,
+ 'DOES call error message says DOES, not isa' );
+
+# Tests for can seem to be split between here and method.t
+# Add the verbatim perl code mentioned in the comments of
+# http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2001-05/msg01710.html
+# but never actually tested.
+is(UNIVERSAL->can("NòSùchPàckàgè::fòò"), undef);
+
+ at splàtt::ISA = 'zlòpp';
+ok (splàtt->isa('zlòpp'));
+ok (!splàtt->isa('plòp'));
+
+# This should reset the ->isa lookup cache
+ at splàtt::ISA = 'plòp';
+# And here is the new truth.
+ok (!splàtt->isa('zlòpp'));
+ok (splàtt->isa('plòp'));
+
+
Modified: trunk/contrib/perl/t/uni/upper.t
===================================================================
--- trunk/contrib/perl/t/uni/upper.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/uni/upper.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -7,6 +7,6 @@
is(uc("\x{3B1}\x{345}\x{301}"), "\x{391}\x{301}\x{399}", 'Verify moves YPOGEGRAMMENI');
casetest( 1, # extra tests already run
- "Upper", \%utf8::ToSpecUpper,
+ "Uppercase_Mapping",
sub { uc $_[0] },
sub { my $a = ""; uc ($_[0] . $a) });
Property changes on: trunk/contrib/perl/t/uni/upper.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/t/uni/variables.t (from rev 6437, vendor/perl/5.18.1/t/uni/variables.t)
===================================================================
--- trunk/contrib/perl/t/uni/variables.t (rev 0)
+++ trunk/contrib/perl/t/uni/variables.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,229 @@
+#!./perl
+
+# Checks if the parser behaves correctly in edge case
+# (including weird syntax errors)
+
+BEGIN {
+ require './test.pl';
+}
+
+use 5.016;
+use utf8;
+use open qw( :utf8 :std );
+no warnings qw(misc reserved);
+
+plan (tests => 65869);
+
+# ${single:colon} should not be valid syntax
+{
+ no strict;
+
+ local $@;
+ eval "\${\x{30cd}single:\x{30cd}colon} = 1";
+ like($@,
+ qr/syntax error .* near "\x{30cd}single:/,
+ '${\x{30cd}single:\x{30cd}colon} should not be valid syntax'
+ );
+
+ local $@;
+ no utf8;
+ evalbytes '${single:colon} = 1';
+ like($@,
+ qr/syntax error .* near "single:/,
+ '...same with ${single:colon}'
+ );
+}
+
+# ${yadda'etc} and ${yadda::etc} should both work under strict
+{
+ local $@;
+ eval q<use strict; ${flark::fleem}>;
+ is($@, '', q<${package::var} works>);
+
+ local $@;
+ eval q<use strict; ${fleem'flark}>;
+ is($@, '', q<...as does ${package'var}>);
+}
+
+# The first character in ${...} should respect the rules
+{
+ local $@;
+ use utf8;
+ eval '${☭asd} = 1';
+ like($@, qr/\QUnrecognized character/, q(the first character in ${...} isn't special))
+}
+
+# Checking that at least some of the special variables work
+for my $v (qw( ^V ; < > ( ) {^GLOBAL_PHASE} ^W _ 1 4 0 [ ] ! @ / \ = )) {
+ local $@;
+ evalbytes "\$$v;";
+ is $@, '', "No syntax error for \$$v";
+
+ local $@;
+ eval "use utf8; \$$v;";
+ is $@, '', "No syntax error for \$$v under use utf8";
+}
+
+# Checking if the Latin-1 range behaves as expected, and that the behavior is the
+# same whenever under strict or not.
+for ( 0x80..0xff ) {
+ no warnings 'closure';
+ my $chr = chr;
+ my $esc = sprintf("%X", ord $chr);
+ utf8::downgrade($chr);
+ if ($chr !~ /\p{XIDS}/u) {
+ is evalbytes "no strict; \$$chr = 10",
+ 10,
+ sprintf("\\x%02x, part of the latin-1 range, is legal as a length-1 variable", $_);
+
+ utf8::upgrade($chr);
+ local $@;
+ eval "no strict; use utf8; \$$chr = 1";
+ like $@,
+ qr/\QUnrecognized character \x{\E\L$esc/,
+ sprintf("..but is illegal as a length-1 variable under use utf8", $_);
+ }
+ else {
+ {
+ no utf8;
+ local $@;
+ evalbytes "no strict; \$$chr = 1";
+ is($@, '', sprintf("\\x%02x, =~ \\p{XIDS}, latin-1, no utf8, no strict, is a valid length-1 variable", $_));
+
+ local $@;
+ evalbytes "use strict; \$$chr = 1";
+ is($@,
+ '',
+ sprintf("\\x%02x under no utf8 does not have to be required under strict, even though it matches XIDS", $_)
+ );
+
+ local $@;
+ evalbytes "\$a$chr = 1";
+ like($@,
+ qr/Unrecognized character /,
+ sprintf("...but under no utf8, it's not allowed in two-or-more character variables")
+ );
+
+ local $@;
+ evalbytes "\$a$chr = 1";
+ like($@,
+ qr/Unrecognized character /,
+ sprintf("...but under no utf8, it's not allowed in two-or-more character variables")
+ );
+ }
+ {
+ use utf8;
+ my $u = $chr;
+ utf8::upgrade($u);
+ local $@;
+ eval "no strict; \$$u = 1";
+ is($@, '', sprintf("\\x%02x, =~ \\p{XIDS}, UTF-8, use utf8, no strict, is a valid length-1 variable", $_));
+
+ local $@;
+ eval "use strict; \$$u = 1";
+ like($@,
+ qr/Global symbol "\$$u" requires explicit package name/,
+ sprintf("\\x%02x under utf8 has to be required under strict", $_)
+ );
+ }
+ }
+}
+
+{
+ use utf8;
+ my $ret = eval "my \$c\x{327} = 100; \$c\x{327}"; # c + cedilla
+ is($@, '', "ASCII character + combining character works as a variable name");
+ is($ret, 100, "...and returns the correct value");
+}
+
+# From Tom Christiansen's 'highly illegal variable names are now accidentally legal' mail
+for my $chr (
+ "\N{EM DASH}", "\x{F8FF}", "\N{POUND SIGN}", "\N{SOFT HYPHEN}",
+ "\N{THIN SPACE}", "\x{11_1111}", "\x{DC00}", "\N{COMBINING DIAERESIS}",
+ "\N{COMBINING ENCLOSING CIRCLE BACKSLASH}",
+ )
+{
+ no warnings 'non_unicode';
+ my $esc = sprintf("%x", ord $chr);
+ local $@;
+ eval "\$$chr = 1; \$$chr";
+ like($@,
+ qr/\QUnrecognized character \x{$esc};/,
+ "\\x{$esc} is illegal for a length-one identifier"
+ );
+}
+
+for my $i (0x100..0xffff) {
+ my $chr = chr($i);
+ my $esc = sprintf("%x", $i);
+ local $@;
+ eval "my \$$chr = q<test>; \$$chr;";
+ if ( $chr =~ /^\p{_Perl_IDStart}$/ ) {
+ is($@, '', sprintf("\\x{%04x} is XIDS, works as a length-1 variable", $i));
+ }
+ else {
+ like($@,
+ qr/\QUnrecognized character \x{$esc};/,
+ "\\x{$esc} isn't XIDS, illegal as a length-1 variable",
+ )
+ }
+}
+
+{
+ # Bleadperl v5.17.9-109-g3283393 breaks ZEFRAM/Module-Runtime-0.013.tar.gz
+ # https://rt.perl.org/rt3/Public/Bug/Display.html?id=117101
+ no strict;
+
+ local $@;
+ eval <<'EOP';
+ q{$} =~ /(.)/;
+ is($$1, $$, q{$$1 parses as ${$1}});
+
+ $doof = "test";
+ $test = "Got here";
+ $::{+$$} = *doof;
+
+ is( $$$$1, $test, q{$$$$1 parses as ${${${$1}}}} );
+EOP
+ is($@, '', q{$$1 parses correctly});
+
+ for my $chr ( q{@}, "\N{U+FF10}", "\N{U+0300}" ) {
+ my $esc = sprintf("\\x{%x}", ord $chr);
+ local $@;
+ eval <<" EOP";
+ \$$chr = q{\$};
+ \$\$$chr;
+ EOP
+
+ like($@,
+ qr/syntax error|Unrecognized character/,
+ qq{\$\$$esc is a syntax error}
+ );
+ }
+}
+
+{
+ # bleadperl v5.17.9-109-g3283393 breaks JEREMY/File-Signature-1.009.tar.gz
+ # https://rt.perl.org/rt3/Ticket/Display.html?id=117145
+ local $@;
+ my $var = 10;
+ eval ' ${ var }';
+
+ is(
+ $@,
+ '',
+ '${ var } works under strict'
+ );
+
+ {
+ no strict;
+ for my $var ( '$', "\7LOBAL_PHASE", "^GLOBAL_PHASE", "^V" ) {
+ eval "\${ $var}";
+ is($@, '', "\${ $var} works" );
+ eval "\${$var }";
+ is($@, '', "\${$var } works" );
+ eval "\${ $var }";
+ is($@, '', "\${ $var } works" );
+ }
+ }
+}
Modified: trunk/contrib/perl/t/uni/write.t
===================================================================
--- trunk/contrib/perl/t/uni/write.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/uni/write.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -7,7 +7,7 @@
skip_all_without_perlio();
}
-plan tests => 6;
+plan tests => 8;
# Some tests for UTF8 and format/write
@@ -93,4 +93,31 @@
$bmulti$blite2
EOEXPECT
-unlink_all 'Uni_write.tmp';
+{
+ use utf8;
+ use open qw( :utf8 :std );
+
+ local $~ = "놋웇ʱＦᚖṀŦ";
+ eval { write };
+ like $@, qr/Undefined format "놋웇ʱＦᚖṀŦ/u, 'no such format, with format name in UTF-8.';
+}
+
+{
+
+format OUT =
+
+
+.
+ use utf8;
+ use open qw( :utf8 :std );
+ open OUT, '>', 'Uni_write2.tmp';
+
+ my $oldfh = select OUT;
+ local $^ = "უデfiᕣネḓ_ＦᚖṀŦɐȾ";#"UNDEFINED_FORMAT";
+ eval { write };
+ like $@, qr/Undefined top format "უデfiᕣネḓ_ＦᚖṀŦɐȾ/u, 'no such top format';
+ select $oldfh;
+ close OUT;
+}
+
+unlink_all qw( Uni_write.tmp Uni_write2.tmp );
Property changes on: trunk/contrib/perl/t/uni/write.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Added: trunk/contrib/perl/t/win32/runenv.t
===================================================================
--- trunk/contrib/perl/t/win32/runenv.t (rev 0)
+++ trunk/contrib/perl/t/win32/runenv.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -0,0 +1,253 @@
+#!./perl
+#
+# Tests for Perl run-time environment variable settings
+# Clone of t/run/runenv.t but without the forking, and with cmd.exe-friendly -e syntax.
+#
+# $PERL5OPT, $PERL5LIB, etc.
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ require File::Temp; import File::Temp qw/:POSIX/;
+
+ require Win32;
+ ($::os_id, $::os_major) = ( Win32::GetOSVersion() )[ 4, 1 ];
+ if ($::os_id == 2 and $::os_major == 6) { # Vista, Server 2008 (incl R2), 7
+ $::tests = 43;
+ }
+ else {
+ $::tests = 40;
+ }
+
+ require './test.pl';
+}
+
+skip_all "requires compilation with PERL_IMPLICIT_SYS"
+ unless $Config{ccflags} =~/(?:\A|\s)-DPERL_IMPLICIT_SYS\b/;
+
+plan tests => $::tests;
+
+my $PERL = $ENV{PERL} || '.\perl';
+my $NL = $/;
+
+delete $ENV{PERLLIB};
+delete $ENV{PERL5LIB};
+delete $ENV{PERL5OPT};
+
+
+# Run perl with specified environment and arguments, return (STDOUT, STDERR)
+sub runperl_and_capture {
+ my ($env, $args) = @_;
+
+ # Clear out old env
+ local %ENV = %ENV;
+ delete $ENV{PERLLIB};
+ delete $ENV{PERL5LIB};
+ delete $ENV{PERL5OPT};
+
+ # Populate with our desired env
+ for my $k (keys %$env) {
+ $ENV{$k} = $env->{$k};
+ }
+
+ # This is slightly expensive, but this is more reliable than
+ # trying to emulate fork(), and we still get STDERR and STDOUT individually.
+ my $stderr_cache = tmpnam();
+ my $stdout = `$PERL @$args 2>$stderr_cache`;
+ my $stderr = '';
+ if (-s $stderr_cache) {
+ open(my $stderr_cache_fh, "<", $stderr_cache)
+ or die "Could not retrieve STDERR output: $!";
+ while ( defined(my $s_line = <$stderr_cache_fh>) ) {
+ $stderr .= $s_line;
+ }
+ close $stderr_cache_fh;
+ unlink $stderr_cache;
+ }
+
+ return ($stdout, $stderr);
+}
+
+sub try {
+ my ($env, $args, $stdout, $stderr) = @_;
+ my ($actual_stdout, $actual_stderr) = runperl_and_capture($env, $args);
+ local $::Level = $::Level + 1;
+ is $actual_stdout, $stdout;
+ is $actual_stderr, $stderr;
+}
+
+# PERL5OPT Command-line options (switches). Switches in
+# this variable are taken as if they were on
+# every Perl command line. Only the -[DIMUdmtw]
+# switches are allowed. When running taint
+# checks (because the program was running setuid
+# or setgid, or the -T switch was used), this
+# variable is ignored. If PERL5OPT begins with
+# -T, tainting will be enabled, and any
+# subsequent options ignored.
+
+try({PERL5OPT => '-w'}, ['-e', '"print $::x"'],
+ "",
+ qq(Name "main::x" used only once: possible typo at -e line 1.${NL}Use of uninitialized value \$x in print at -e line 1.${NL}));
+
+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}));
+
+# 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}));
+
+# Fails in 5.6.0
+try({PERL5OPT => '-w -Mstrict'}, ['-I..\lib', '-e', '"print $::x"'],
+ "",
+ <<ERROR
+Name "main::x" used only once: possible typo at -e line 1.
+Use of uninitialized value \$x in print at -e line 1.
+ERROR
+ );
+
+# Fails in 5.6.0
+try({PERL5OPT => '-w -Mstrict'}, ['-I..\lib', '-e', '"print $::x"'],
+ "",
+ <<ERROR
+Name "main::x" used only once: possible typo at -e line 1.
+Use of uninitialized value \$x in print at -e line 1.
+ERROR
+ );
+
+try({PERL5OPT => '-MExporter'}, ['-I..\lib', '-e0'],
+ "",
+ "");
+
+# Fails in 5.6.0
+try({PERL5OPT => '-MExporter -MExporter'}, ['-I..\lib', '-e0'],
+ "",
+ "");
+
+try({PERL5OPT => '-Mstrict -Mwarnings'},
+ ['-I..\lib', '-e', '"print \"ok\" if $INC{\"strict.pm\"} and $INC{\"warnings.pm\"}"'],
+ "ok",
+ "");
+
+open my $fh, ">", "Oooof.pm" or die "Can't write Oooof.pm: $!";
+print $fh "package Oooof; 1;\n";
+close $fh;
+END { 1 while unlink "Oooof.pm" }
+
+try({PERL5OPT => '-I. -MOooof'},
+ ['-e', '"print \"ok\" if $INC{\"Oooof.pm\"} eq \"Oooof.pm\""'],
+ "ok",
+ "");
+
+try({PERL5OPT => '-w -w'},
+ ['-e', '"print $ENV{PERL5OPT}"'],
+ '-w -w',
+ '');
+
+try({PERL5OPT => '-t'},
+ ['-e', '"print ${^TAINT}"'],
+ '-1',
+ '');
+
+try({PERL5OPT => '-W'},
+ ['-I..\lib','-e', '"local $^W = 0; no warnings; print $x"'],
+ '',
+ <<ERROR
+Name "main::x" used only once: possible typo at -e line 1.
+Use of uninitialized value \$x in print at -e line 1.
+ERROR
+);
+
+try({PERLLIB => "foobar$Config{path_sep}42"},
+ ['-e', '"print grep { $_ eq \"foobar\" } @INC"'],
+ 'foobar',
+ '');
+
+try({PERLLIB => "foobar$Config{path_sep}42"},
+ ['-e', '"print grep { $_ eq \"42\" } @INC"'],
+ '42',
+ '');
+
+try({PERL5LIB => "foobar$Config{path_sep}42"},
+ ['-e', '"print grep { $_ eq \"foobar\" } @INC"'],
+ 'foobar',
+ '');
+
+try({PERL5LIB => "foobar$Config{path_sep}42"},
+ ['-e', '"print grep { $_ eq \"42\" } @INC"'],
+ '42',
+ '');
+
+try({PERL5LIB => "foo",
+ PERLLIB => "bar"},
+ ['-e', '"print grep { $_ eq \"foo\" } @INC"'],
+ 'foo',
+ '');
+
+try({PERL5LIB => "foo",
+ PERLLIB => "bar"},
+ ['-e', '"print grep { $_ eq \"bar\" } @INC"'],
+ '',
+ '');
+
+# Tests for S_incpush_use_sep():
+
+my @dump_inc = ('-e', '"print \"$_\n\" foreach @INC"');
+
+my ($out, $err) = runperl_and_capture({}, [@dump_inc]);
+
+is ($err, '', 'No errors when determining @INC');
+
+my @default_inc = split /\n/, $out;
+
+is ($default_inc[-1], '.', '. is last in @INC');
+
+my $sep = $Config{path_sep};
+my @test_cases = (
+ ['nothing', ''],
+ ['something', 'zwapp', 'zwapp'],
+ ['two things', "zwapp${sep}bam", 'zwapp', 'bam'],
+ ['two things, ::', "zwapp${sep}${sep}bam", 'zwapp', 'bam'],
+ [': at start', "${sep}zwapp", 'zwapp'],
+ [': at end', "zwapp${sep}", 'zwapp'],
+ [':: sandwich ::', "${sep}${sep}zwapp${sep}${sep}", 'zwapp'],
+ [':', "${sep}"],
+ ['::', "${sep}${sep}"],
+ [':::', "${sep}${sep}${sep}"],
+ ['two things and :', "zwapp${sep}bam${sep}", 'zwapp', 'bam'],
+ [': and two things', "${sep}zwapp${sep}bam", 'zwapp', 'bam'],
+ [': two things :', "${sep}zwapp${sep}bam${sep}", 'zwapp', 'bam'],
+ ['three things', "zwapp${sep}bam${sep}${sep}owww",
+ 'zwapp', 'bam', 'owww'],
+);
+
+# This block added to verify fix for RT #87322
+if ($::os_id == 2 and $::os_major == 6) { # Vista, Server 2008 (incl R2), 7
+ my @big_perl5lib = ('z' x 16) x 2049;
+ push @testcases, [
+ 'enough items so PERL5LIB val is longer than 32k',
+ join($sep, @big_perl5lib), @big_perl5lib,
+ ];
+}
+
+foreach ( @testcases ) {
+ my ($name, $lib, @expect) = @$_;
+ push @expect, @default_inc;
+
+ ($out, $err) = runperl_and_capture({PERL5LIB => $lib}, [@dump_inc]);
+
+ is ($err, '', "No errors when determining \@INC for $name");
+
+ my @inc = split /\n/, $out;
+
+ is (scalar @inc, scalar @expect,
+ "expected number of elements in \@INC for $name");
+
+ is ("@inc", "@expect", "expected elements in \@INC for $name");
+}
Modified: trunk/contrib/perl/t/win32/system.t
===================================================================
--- trunk/contrib/perl/t/win32/system.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/win32/system.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -34,28 +34,10 @@
or die "Can't create $testdir/$exename.c: $!";
print $F <<'EOT';
#include <stdio.h>
-#ifdef __BORLANDC__
-#include <windows.h>
-#endif
int
main(int ac, char **av)
{
int i;
-#ifdef __BORLANDC__
- char *s = GetCommandLine();
- int j=0;
- av[0] = s;
- if (s[0]=='"') {
- for(;s[++j]!='"';)
- ;
- av[0]++;
- }
- else {
- for(;s[++j]!=' ';)
- ;
- }
- s[j]=0;
-#endif
for (i = 0; i < ac; i++)
printf("[%s]", av[i]);
printf("\n");
Property changes on: trunk/contrib/perl/t/win32/system.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/t/win32/system_tests
===================================================================
--- trunk/contrib/perl/t/win32/system_tests 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/win32/system_tests 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/t/win32/system_tests
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/t/x2p/s2p.t
===================================================================
--- trunk/contrib/perl/t/x2p/s2p.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/t/x2p/s2p.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -582,7 +582,7 @@
### s ###
's' => {
script => <<'[TheEnd]',
-# enclose any `(a)'.. `(c)' in `-'
+# enclose any '(a)'.. '(c)' in '-'
s/([a-z])/-\1-/g
s/\([abc]\)/-\1-/g
@@ -627,6 +627,19 @@
[TheEnd]
},
+### s2 ### RT #115156
+'s2' => {
+ todo => 'RT #115156',
+ script => 's/1*$/x/g',
+ input => 'bins',
+ expect => <<'[TheEnd]',
+0x
+x
+1000x
+1000x
+[TheEnd]
+},
+
### t ###
't' => {
script => join( "\n",
@@ -815,6 +828,8 @@
for my $tc ( sort keys %testcase ){
my( $psedres, $s2pres );
+ local $TODO = $testcase{$tc}{todo};
+
# 1st test: run psed
# prepare the script
open( SED, ">$script" ) || goto FAIL_BOTH;
Property changes on: trunk/contrib/perl/t/x2p/s2p.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/vms/descrip_mms.template
===================================================================
--- trunk/contrib/perl/vms/descrip_mms.template 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/vms/descrip_mms.template 2013-12-02 21:26:09 UTC (rev 6439)
@@ -13,9 +13,9 @@
# tidy -- purge files generated by executing this file
# clean -- remove all intermediate (e.g. object files, C files generated
# during build) files generated by executing this file,
-# but leave `installable' files (images, library) intact
+# but leave 'installable' files (images, library) intact
# realclean -- remove all files generated by executing this file
-# cleansrc -- `realclean' + purge *.c,*.h,descrip.mms
+# cleansrc -- 'realclean' + purge *.c,*.h,descrip.mms
# crtl.opt -- compiler-specific linker options file (made automatically)
#
@@ -79,36 +79,15 @@
SOCKET=1
.endif
-.ifdef SOCKETSHR_SOCKETS
-SOCKET=1
-.endif
-
-# If they defined SOCKET but didn't choose a stack, default to SOCKETSHR
-.ifdef DECC_SOCKETS
-.else
-.ifdef SOCKETSHR_SOCKETS
-.else
-.ifdef SOCKET
-SOCKETSHR_SOCKETS=1
-.endif
-.endif
-.endif
-
ARCHDIR = [.lib.$(ARCHNAME).$(PERL_VERSION)]
ARCHCORE = [.lib.$(ARCHNAME).$(PERL_VERSION).CORE]
ARCHAUTO = [.lib.$(ARCHNAME).$(PERL_VERSION).auto]
-#: Backwards compatibility
-.ifdef DECC_PIPES_BROKEN
-PIPES_BROKEN = 1
-.endif
-
#: >>>>>Compiler-specific options <<<<<
.ifdef GNUC
.first
@ If F$TrnLnm("Sys").eqs."" Then Define/NoLog SYS GNU_CC_Include:[VMS]
CC = gcc
-PIPES_BROKEN = 1
# -fno-builtin avoids bug in gcc up to version 2.6.2 which can destroy
# data when memcpy() is called on large (>64 kB) blocks of memory
# (fixed in gcc 2.6.3)
@@ -158,35 +137,6 @@
DBG =
.endif
-#: SOCKET: build in support for TCP/IP sockets
-#: By default, used SOCKETSHR library; see ReadMe.VMS
-#: for information on changing socket support
-.ifdef SOCKET
-.ifdef DECC_SOCKETS
-SOCKDEF =
-SOCKLIB =
-.else
-SOCKDEF =
-SOCKLIB = SocketShr/Share
-.endif
-# N.B. the targets for $(SOCKC) and $(SOCKH) assume that the permanent
-# copies live in [.vms], and the `clean' target will delete copies of
-# these files in the current default directory.
-SOCKC = sockadapt.c
-SOCKH = sockadapt.h
-SOCKARCH = $(ARCHCORE)$(SOCKH)
-SOCKO = sockadapt$(O)
-SOCKPM = [.lib]Socket.pm
-.else
-SOCKDEF =
-SOCKLIB =
-SOCKC =
-SOCKH =
-SOCKARCH =
-SOCKO =
-SOCKPM =
-.endif
-
.ifdef THREADED
THREADDEF =
THREAD = THREAD
@@ -284,7 +234,7 @@
#### End of system configuration section. ####
-c0 = $(MALLOC_C) $(SOCKC) av.c deb.c doio.c doop.c dump.c globals.c gv.c hv.c mro.c
+c0 = $(MALLOC_C) av.c deb.c doio.c doop.c dump.c globals.c gv.c hv.c mro.c
c1 = mg.c locale.c mathoms.c miniperlmain.c numeric.c op.c pad.c perl.c perlapi.c perlio.c
c2 = perly.c pp.c pp_ctl.c pp_hot.c pp_pack.c pp_sort.c pp_sys.c regcomp.c regexec.c reentr.c
c3 = run.c scope.c sv.c taint.c toke.c universal.c utf8.c util.c vms.c keywords.c
@@ -291,7 +241,7 @@
c = $(c0) $(c1) $(c2) $(c3)
obj0 = perl$(O)
-obj1 = $(MALLOC_O) $(SOCKO) av$(O) deb$(O) doio$(O) doop$(O) dump$(O) mro$(O) globals$(O) gv$(O) hv$(O)
+obj1 = $(MALLOC_O) av$(O) deb$(O) doio$(O) doop$(O) dump$(O) mro$(O) globals$(O) gv$(O) hv$(O)
obj2 = keywords$(O) locale$(O) mathoms$(O) mg$(O) miniperlmain$(O) numeric$(O) op$(O) pad$(O) perlapi$(O) perlio$(O)
obj3 = perly$(O) pp$(O) pp_ctl$(O) pp_hot$(O) reentr$(O) pp_pack$(O) pp_sort$(O) pp_sys$(O) regcomp$(O)
obj4 = regexec$(O) run$(O) scope$(O) sv$(O) taint$(O) toke$(O) universal$(O) utf8$(O) util$(O) vms$(O)
@@ -301,40 +251,19 @@
h0 = av.h config.h cop.h cv.h embed.h embedvar.h
h1 = EXTERN.h form.h gv.h handy.h hv.h l1_char_class_tab.h INTERN.h intrpvar.h
-h2 = iperlsys.h keywords.h mydtrace.h mg.h nostdio.h op.h op_reg_common.h
-h3 = opcode.h opnames.h overload.h pad.h parser.h patchlevel.h perl.h
-h4 = perlapi.h perlio.h perlsdio.h perlvars.h perly.h
+h2 = iperlsys.h keywords.h mydtrace.h mg.h mg_vtable.h nostdio.h op.h
+h3 = op_reg_common.h opcode.h opnames.h overload.h pad.h parser.h patchlevel.h
+h4 = perl.h perlapi.h perlio.h perlsdio.h perlvars.h perly.h
h5 = pp.h pp_proto.h proto.h regcomp.h regexp.h regnodes.h scope.h
-h5 = sv.h thread.h utf8.h util.h vmsish.h warnings.h
-h7 = xsub.h $(SOCKH) $(THREADH)
+h6 = sv.h thread.h utf8.h util.h vmsish.h warnings.h
+h7 = xsub.h $(THREADH)
h = $(h0) $(h1) $(h2) $(h3) $(h4) $(h5) $(h6) $(h7)
-ac0 = $(ARCHCORE)$(sockh) $(ARCHCORE)av.h
-ac1 = $(ARCHCORE)config.h $(ARCHCORE)cop.h $(ARCHCORE)cv.h $(ARCHCORE)embed.h
-ac2 = $(ARCHCORE)embedvar.h $(ARCHCORE)EXTERN.h $(ARCHCORE)fakethr.h
-ac3 = $(ARCHCORE)form.h $(ARCHCORE)git_version.h $(ARCHCORE)gv.h $(ARCHCORE)handy.h $(ARCHCORE)hv.h
-ac4 = $(ARCHCORE)l1_char_class_tab.h $(ARCHCORE)INTERN.h $(ARCHCORE)intrpvar.h $(ARCHCORE)iperlsys.h
-ac5 = $(ARCHCORE)keywords.h $(ARCHCORE)mydtrace.h $(ARCHCORE)mg.h $(ARCHCORE)nostdio.h
-ac6 = $(ARCHCORE)op_reg_common.h $(ARCHCORE)op.h $(ARCHCORE)opcode.h $(ARCHCORE)opnames.h
-ac7 = $(ARCHCORE)overload.h $(ARCHCORE)pad.h $(ARCHCORE)parser.h $(ARCHCORE)patchlevel.h
-ac8 = $(ARCHCORE)perl.h $(ARCHCORE)perlapi.h $(ARCHCORE)perlio.h $(ARCHCORE)perlsdio.h
-ac9 = $(ARCHCORE)perlsfio.h $(ARCHCORE)perlvars.h $(ARCHCORE)perly.h $(ARCHCORE)pp.h
-.ifdef THREADED
-ac10 = $(ARCHCORE)pp_proto.h $(ARCHCORE)proto.h $(ARCHCORE)reentr.h $(ARCHCORE)regcomp.h
-.else
-ac10 = $(ARCHCORE)pp_proto.h $(ARCHCORE)proto.h $(ARCHCORE)regcomp.h
-.endif
-ac11 = $(ARCHCORE)regexp.h $(ARCHCORE)regnodes.h $(ARCHCORE)scope.h
-.ifdef SOCKARCH
-ac12 = $(ARCHCORE)sv.h $(SOCKARCH)
-.else
-ac12 = $(ARCHCORE)sv.h
-.endif
-ac13 = $(ARCHCORE)thread.h $(ARCHCORE)utf8.h $(ARCHCORE)util.h
-ac14 = $(ARCHCORE)vmsish.h $(ARCHCORE)warnings.h $(ARCHCORE)xsub.h
acopt = $(ARCHCORE)perlshr_attr.opt $(ARCHCORE)$(DBG)perlshr_bld.opt
-ac = $(ac0) $(ac1) $(ac2) $(ac3) $(ac4) $(ac5) $(ac6) $(ac7) $(ac8) $(ac9) $(ac10) $(ac11) $(ac12) $(ac13) $(ac14) $(acopt)
+ac = archcore_includes.ts $(acopt)
+generated_headers = uudmap.h bitcount.h mg_data.h
+
CRTL = []crtl.opt
CRTLOPTS =,$(CRTL)/Options
@@ -361,11 +290,11 @@
# Modules which must be installed before we can build extensions
LIBPREREQ = $(ARCHDIR)Config.pm $(ARCHDIR)Config_heavy.pl [.lib.VMS]Filespec.pm $(ARCHDIR)vmspipe.com [.lib]buildcustomize.pl
-utils1 = [.lib.pods]perldoc.com [.lib.ExtUtils]Miniperl.pm [.utils]c2ph.com [.utils]h2ph.com
-utils2 = [.utils]h2xs.com [.utils]libnetcfg.com [.lib]perlbug.com [.utils]dprofpp.com [.utils]json_pp.com
-utils3 = [.utils]perlivp.com [.lib]splain.com [.utils]pl2pm.com [.utils]xsubpp.com [.utils]instmodsh.com
+utils1 = [.utils]perldoc.com [.lib.ExtUtils]Miniperl.pm [.utils]c2ph.com [.utils]h2ph.com
+utils2 = [.utils]h2xs.com [.utils]libnetcfg.com [.lib]perlbug.com [.utils]json_pp.com
+utils3 = [.utils]perlivp.com [.lib]splain.com [.utils]pl2pm.com [.utils]xsubpp.com [.utils]pod2html.com [.utils]instmodsh.com
utils4 = [.utils]enc2xs.com [.utils]piconv.com [.utils]cpan.com [.utils]prove.com [.utils]ptar.com [.utils]ptardiff.com [.utils]shasum.com
-utils5 = [.utils]corelist.com [.utils]config_data.com [.utils]cpanp.com [.utils]cpan2dist.com [.utils]cpanp-run-perl.com [.utils]ptargrep.com
+utils5 = [.utils]corelist.com [.utils]config_data.com [.utils]cpanp.com [.utils]cpan2dist.com [.utils]cpanp-run-perl.com [.utils]ptargrep.com [.utils]zipdetails.com
.ifdef NOX2P
all : base extras archcorefiles preplibrary [.pod]perltoc.pod
@@ -397,48 +326,10 @@
extra.pods : miniperl
@ @extra_pods.com
-pod0 = [.lib.pods]perl.pod [.lib.pods]perl5004delta.pod [.lib.pods]perl5005delta.pod [.lib.pods]perl5100delta.pod [.lib.pods]perl5101delta.pod
-pod1 = [.lib.pods]perl5110delta.pod [.lib.pods]perl5111delta.pod [.lib.pods]perl5112delta.pod [.lib.pods]perl5113delta.pod [.lib.pods]perl5114delta.pod
-pod2 = [.lib.pods]perl5115delta.pod [.lib.pods]perl5120delta.pod [.lib.pods]perl5121delta.pod [.lib.pods]perl5122delta.pod [.lib.pods]perl5123delta.pod
-pod3 = [.lib.pods]perl5130delta.pod [.lib.pods]perl51310delta.pod [.lib.pods]perl51311delta.pod [.lib.pods]perl5131delta.pod [.lib.pods]perl5132delta.pod
-pod4 = [.lib.pods]perl5133delta.pod [.lib.pods]perl5134delta.pod [.lib.pods]perl5135delta.pod [.lib.pods]perl5136delta.pod [.lib.pods]perl5137delta.pod
-pod5 = [.lib.pods]perl5138delta.pod [.lib.pods]perl5139delta.pod [.lib.pods]perl5140delta.pod [.lib.pods]perl561delta.pod [.lib.pods]perl56delta.pod
-pod6 = [.lib.pods]perl570delta.pod [.lib.pods]perl571delta.pod [.lib.pods]perl572delta.pod [.lib.pods]perl573delta.pod [.lib.pods]perl581delta.pod
-pod7 = [.lib.pods]perl582delta.pod [.lib.pods]perl583delta.pod [.lib.pods]perl584delta.pod [.lib.pods]perl585delta.pod [.lib.pods]perl586delta.pod
-pod8 = [.lib.pods]perl587delta.pod [.lib.pods]perl588delta.pod [.lib.pods]perl589delta.pod [.lib.pods]perl58delta.pod [.lib.pods]perl590delta.pod
-pod9 = [.lib.pods]perl591delta.pod [.lib.pods]perl592delta.pod [.lib.pods]perl593delta.pod [.lib.pods]perl594delta.pod [.lib.pods]perl595delta.pod
-pod10 = [.lib.pods]perlaix.pod [.lib.pods]perlamiga.pod [.lib.pods]perlapi.pod [.lib.pods]perlapio.pod [.lib.pods]perlartistic.pod [.lib.pods]perlbeos.pod
-pod11 = [.lib.pods]perlbook.pod [.lib.pods]perlboot.pod [.lib.pods]perlbot.pod [.lib.pods]perlbs2000.pod [.lib.pods]perlcall.pod [.lib.pods]perlce.pod
-pod12 = [.lib.pods]perlcheat.pod [.lib.pods]perlclib.pod [.lib.pods]perlcn.pod [.lib.pods]perlcommunity.pod [.lib.pods]perlcompile.pod
-pod13 = [.lib.pods]perlcygwin.pod [.lib.pods]perldata.pod [.lib.pods]perldbmfilter.pod [.lib.pods]perldebguts.pod [.lib.pods]perldebtut.pod
-pod14 = [.lib.pods]perldebug.pod [.lib.pods]perldelta.pod [.lib.pods]perldgux.pod [.lib.pods]perldiag.pod [.lib.pods]perldoc.pod [.lib.pods]perldos.pod
-pod15 = [.lib.pods]perldsc.pod [.lib.pods]perlebcdic.pod [.lib.pods]perlembed.pod [.lib.pods]perlepoc.pod [.lib.pods]perlfaq.pod [.lib.pods]perlfaq1.pod
-pod16 = [.lib.pods]perlfaq2.pod [.lib.pods]perlfaq3.pod [.lib.pods]perlfaq4.pod [.lib.pods]perlfaq5.pod [.lib.pods]perlfaq6.pod [.lib.pods]perlfaq7.pod
-pod17 = [.lib.pods]perlfaq8.pod [.lib.pods]perlfaq9.pod [.lib.pods]perlfilter.pod [.lib.pods]perlfork.pod [.lib.pods]perlform.pod [.lib.pods]perlfreebsd.pod
-pod18 = [.lib.pods]perlfunc.pod [.lib.pods]perlgit.pod [.lib.pods]perlglossary.pod [.lib.pods]perlgpl.pod [.lib.pods]perlguts.pod [.lib.pods]perlhack.pod
-pod19 = [.lib.pods]perlhacktips.pod [.lib.pods]perlhacktut.pod [.lib.pods]perlhaiku.pod [.lib.pods]perlhist.pod [.lib.pods]perlhpux.pod
-pod20 = [.lib.pods]perlhurd.pod [.lib.pods]perlintern.pod [.lib.pods]perlinterp.pod [.lib.pods]perlintro.pod [.lib.pods]perliol.pod [.lib.pods]perlipc.pod
-pod21 = [.lib.pods]perlirix.pod [.lib.pods]perljp.pod [.lib.pods]perlko.pod [.lib.pods]perllexwarn.pod [.lib.pods]perllinux.pod [.lib.pods]perllocale.pod
-pod22 = [.lib.pods]perllol.pod [.lib.pods]perlmacos.pod [.lib.pods]perlmacosx.pod [.lib.pods]perlmod.pod [.lib.pods]perlmodinstall.pod
-pod23 = [.lib.pods]perlmodlib.pod [.lib.pods]perlmodstyle.pod [.lib.pods]perlmpeix.pod [.lib.pods]perlmroapi.pod [.lib.pods]perlnetware.pod
-pod24 = [.lib.pods]perlnewmod.pod [.lib.pods]perlnumber.pod [.lib.pods]perlobj.pod [.lib.pods]perlop.pod [.lib.pods]perlopenbsd.pod
-pod25 = [.lib.pods]perlopentut.pod [.lib.pods]perlos2.pod [.lib.pods]perlos390.pod [.lib.pods]perlos400.pod [.lib.pods]perlpacktut.pod
-pod26 = [.lib.pods]perlperf.pod [.lib.pods]perlplan9.pod [.lib.pods]perlpod.pod [.lib.pods]perlpodspec.pod [.lib.pods]perlpodstyle.pod
-pod27 = [.lib.pods]perlpolicy.pod [.lib.pods]perlport.pod [.lib.pods]perlpragma.pod [.lib.pods]perlqnx.pod [.lib.pods]perlre.pod [.lib.pods]perlreapi.pod
-pod28 = [.lib.pods]perlrebackslash.pod [.lib.pods]perlrecharclass.pod [.lib.pods]perlref.pod [.lib.pods]perlreftut.pod [.lib.pods]perlreguts.pod
-pod29 = [.lib.pods]perlrequick.pod [.lib.pods]perlreref.pod [.lib.pods]perlretut.pod [.lib.pods]perlriscos.pod [.lib.pods]perlrun.pod [.lib.pods]perlsec.pod
-pod30 = [.lib.pods]perlsolaris.pod [.lib.pods]perlsource.pod [.lib.pods]perlstyle.pod [.lib.pods]perlsub.pod [.lib.pods]perlsymbian.pod
-pod31 = [.lib.pods]perlsyn.pod [.lib.pods]perlthrtut.pod [.lib.pods]perltie.pod [.lib.pods]perltoc.pod [.lib.pods]perltodo.pod [.lib.pods]perltooc.pod
-pod32 = [.lib.pods]perltoot.pod [.lib.pods]perltrap.pod [.lib.pods]perltru64.pod [.lib.pods]perltw.pod [.lib.pods]perlunicode.pod [.lib.pods]perlunifaq.pod
-pod33 = [.lib.pods]perluniintro.pod [.lib.pods]perluniprops.pod [.lib.pods]perlunitut.pod [.lib.pods]perlutil.pod [.lib.pods]perluts.pod
-pod34 = [.lib.pods]perlvar.pod [.lib.pods]perlvmesa.pod [.lib.pods]perlvms.pod [.lib.pods]perlvos.pod [.lib.pods]perlwin32.pod [.lib.pods]perlxs.pod
-pod35 = [.lib.pods]perlxstut.pod
-pod = $(pod0) $(pod1) $(pod2) $(pod3) $(pod4) $(pod5) $(pod6) $(pod7) $(pod8) $(pod9) $(pod10) $(pod11) $(pod12) $(pod13) $(pod14) $(pod15) $(pod16) $(pod17) $(pod18) $(pod19) $(pod20) $(pod21) $(pod22) $(pod23) $(pod24) $(pod25) $(pod26) $(pod27) $(pod28) $(pod29) $(pod30) $(pod31) $(pod32) $(pod33) $(pod34) $(pod35)
+PERLDELTA_CURRENT = [.pod]perl5181delta.pod
-PERLDELTA_CURRENT = [.pod]perl5140delta.pod
-
$(PERLDELTA_CURRENT) : [.pod]perldelta.pod
- Copy/NoConfirm/Log $(MMS$SOURCE) $(MMS$TARGET)
+ Copy/NoConfirm/Log $(MMS$SOURCE) $(PERLDELTA_CURRENT)
[.pod]perlapi.pod : embed.fnc autodoc.pl $(MINIPERL_EXE)
$(MINIPERL) autodoc.pl
@@ -451,7 +342,7 @@
[.pod]perltoc.pod : $(PERLDELTA_CURRENT) [.pod]perlapi.pod [.pod]perlintern.pod [.pod]perlmodlib.pod extra.pods $(PERL_EXE)
@ define/user_mode $(DBG)PERLSHR SYS$DISK:[]$(DBG)perlshr$(E)
- $(PERL) "-f" [.pod]buildtoc "-q" "--build-toc"
+ $(PERL) "-f" [.pod]buildtoc "-q"
archcorefiles : $(ac) $(ARCHAUTO)time.stamp
@ $(NOOP)
@@ -508,43 +399,30 @@
perlmini$(O) : perlmini.c
$(CC) $(CORECFLAGS) $(MMS$SOURCE)
-bitcount.h : uudmap.h
+bitcount.h mg_data.h : uudmap.h
@ $(NOOP)
uudmap.h : generate_uudmap$(E)
- MCR SYS$DISK:[]generate_uudmap$(E) uudmap.h bitcount.h
+ MCR SYS$DISK:[]generate_uudmap$(E) $(generated_headers)
generate_uudmap$(E) : generate_uudmap$(O) $(CRTL)
Link $(LINKFLAGS)/NoDebug/Trace/NoMap/NoFull/NoCross/Exe=$(MMS$TARGET) generate_uudmap$(O) $(CRTLOPTS)
-generate_uudmap$(O) : generate_uudmap.c
+generate_uudmap$(O) : generate_uudmap.c mg_raw.h
$(CC) $(CORECFLAGS) $(MMS$SOURCE)
# The following files are built in one go by gen_shrfls.pl:
# perlshr_attr.opt, $(DBG)perlshr_bld.opt - VAX and AXP
# perlshr_gbl*.mar, perlshr_gbl*$(O) - VAX only
-# The song and dance with gen_shrfls.opt accommodates DCL's 255 character
-# line length limit.
-.ifdef PIPES_BROKEN
-# This is a backup target used only with older versions of the DECCRTL which
-# can't deal with pipes properly. See ReadMe.VMS for details.
+# The song and dance with gen_shrfls.opt accommodates DCL's line length limit.
$(DBG)perlshr_xtras.ts : perl.h config.h vmsish.h proto.h [.vms]gen_shrfls.pl $(MINIPERL_EXE) $(MAKEFILE) $(CRTL)
- $(CC) $(CFLAGS)/NoObject/NoList/PreProcess=perl.i perl.h
- @ $(MINIPERL) -e "print join('|', at ARGV),'|';" "~~NOCC~~perl.i~~$(CC)$(CFLAGS)" >gen_shrfls.opt
- @ $(MINIPERL) -e "print join('|', at ARGV);" "$(O)" "$(DBG)" "$(OLB)" "$(EXT)" "$(CRTL)" >>gen_shrfls.opt
+ @ $(MINIPERL) makedef.pl "PLATFORM=vms" > makedef.lis
+ @ $(MINIPERLQ) -e "print join('|', at ARGV),'|';" "$(CC)$(CFLAGS)" >gen_shrfls.opt
+ @ $(MINIPERLQ) -e "print join('|', at ARGV);" "$(O)" "$(DBG)" "$(OLB)" "$(EXT)" "$(CRTL)" >>gen_shrfls.opt
$(MINIPERL) [.vms]gen_shrfls.pl -f gen_shrfls.opt
- @ Delete/NoLog/NoConfirm perl.i;, gen_shrfls.opt;
- @ If F$Search("$(DBG)perlshr_xtras.ts").nes."" Then Delete/NoLog/NoConfirm $(DBG)perlshr_xtras.ts;*
- @ Copy _NLA0: $(DBG)perlshr_xtras.ts
-.else
-$(DBG)perlshr_xtras.ts : perl.h config.h vmsish.h proto.h [.vms]gen_shrfls.pl $(MINIPERL_EXE) $(MAKEFILE) $(CRTL)
- @ $(MINIPERL) -e "print join('|', at ARGV),'|';" "$(CC)$(CFLAGS)" >gen_shrfls.opt
- @ $(MINIPERL) -e "print join('|', at ARGV);" "$(O)" "$(DBG)" "$(OLB)" "$(EXT)" "$(CRTL)" >>gen_shrfls.opt
- $(MINIPERL) [.vms]gen_shrfls.pl -f gen_shrfls.opt
@ Delete/NoLog/NoConfirm gen_shrfls.opt;
@ If F$Search("$(DBG)perlshr_xtras.ts").nes."" Then Delete/NoLog/NoConfirm $(DBG)perlshr_xtras.ts;*
@ Copy _NLA0: $(DBG)perlshr_xtras.ts
-.endif
$(ARCHDIR)Config.pm : [.lib]Config.pm
Create/Directory $(ARCHDIR)
@@ -571,7 +449,7 @@
dynext : $(LIBPREREQ) $(DBG)perlshr$(E) unidatafiles.ts DynaLoader$(O) preplibrary makeppport $(MINIPERL_EXE)
$(MINIPERL) make_ext.pl "MAKE=$(MMS)" "--dynamic" "--static"
-nonxsext : $(LIBPREREQ) preplibrary $(MINIPERL_EXE)
+nonxsext : $(LIBPREREQ) preplibrary $(MINIPERL_EXE) [.pod]perlfunc.pod
$(MINIPERL) make_ext.pl "MAKE=$(MMS)" "--nonxs"
[.lib.VMS]Filespec.pm : [.vms.ext]Filespec.pm
@@ -578,10 +456,8 @@
@ If F$Search("[.lib]VMS.Dir").eqs."" Then Create/Directory [.lib.VMS]
Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.VMS]
-[.lib.pods]perldoc.com : [.utils]perldoc.PL $(ARCHDIR)Config.pm
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
+[.utils]perldoc.com : [.utils]perldoc.PL $(ARCHDIR)Config.pm
$(MINIPERL) -"I[-.lib]" $(MMS$SOURCE)
- Copy/NoConfirm/Log [.utils]perldoc.com [.lib.pods]
[.lib.ExtUtils]Miniperl.pm : Minimod.PL miniperlmain.c $(ARCHDIR)Config.pm
$(MINIPERL) -"I[-.lib]" $(MMS$SOURCE) >$(MMS$TARGET)
@@ -625,9 +501,6 @@
[.utils]c2ph.com : [.utils]c2ph.PL $(ARCHDIR)Config.pm
$(MINIPERL) -"I[-.lib]" $(MMS$SOURCE)
-[.utils]dprofpp.com : [.utils]dprofpp.PL $(ARCHDIR)Config.pm
- $(MINIPERL) -"I[-.lib]" $(MMS$SOURCE)
-
[.utils]json_pp.com : [.utils]json_pp.PL $(ARCHDIR)Config.pm
$(MINIPERL) -"I[-.lib]" $(MMS$SOURCE)
@@ -669,6 +542,12 @@
[.utils]xsubpp.com : [.utils]xsubpp.PL $(ARCHDIR)Config.pm nonxsext
$(MINIPERL) -"I[-.lib]" $(MMS$SOURCE)
+[.utils]zipdetails.com : [.utils]zipdetails.PL $(ARCHDIR)Config.pm nonxsext
+ $(MINIPERL) -"I[-.lib]" $(MMS$SOURCE)
+
+[.utils]pod2html.com : [.utils]pod2html.PL $(ARCHDIR)Config.pm nonxsext
+ $(MINIPERL) -"I[-.lib]" $(MMS$SOURCE)
+
# Rename catches problem with some DECC versions in which object file is
# placed in current default dir, not same one as source file.
[.x2p]$(DBG)a2p$(E) : [.x2p]a2p$(O), [.x2p]hash$(O), [.x2p]str$(O), [.x2p]util$(O), [.x2p]walk$(O)
@@ -678,9 +557,9 @@
# Accommodate buggy cpp in some version of DECC, which chokes on illegal
# filespec "y.tab.c", and broken gcc cpp, which doesn't start #include ""
# search in same dir as source file
-[.x2p]a2p$(O) : [.x2p]a2p.c [.x2p]a2py.c [.x2p]INTERN.h [.x2p]a2p.h [.x2p]hash.h [.x2p]str.h config.h handy.h vmsish.h $(SOCKH) $(MINIPERL_EXE)
+[.x2p]a2p$(O) : [.x2p]a2p.c [.x2p]a2py.c [.x2p]INTERN.h [.x2p]a2p.h [.x2p]hash.h [.x2p]str.h config.h handy.h vmsish.h $(MINIPERL_EXE)
$(MINIPERL) -pe "s/^#line\s+(\d+)\s+\Q""y.tab.c""/#line $1 ""y_tab.c""/;" $(MMS$SOURCE) >$(MMS$TARGET_NAME)_vms.c
- $(CC) $(X2PCFLAGS) /Object=$(MMS$TARGET)/Include=([.x2p],[]) $(MMS$TARGET_NAME)_vms.c
+ $(CC) $(X2PCFLAGS) /Object=$(MMS$TARGET)/Include=([.x2p],[],"./x2p") $(MMS$TARGET_NAME)_vms.c
Delete/Log/NoConfirm $(MMS$TARGET_NAME)_vms.c;
# gcc cpp broken -- doesn't look in directory of source file for #include ""
@@ -699,770 +578,11 @@
.endif
preplibrary : $(MINIPERL_EXE) $(LIBPREREQ)
+ @ $(NOOP)
makeppport : $(MINIPERL_EXE) $(ARCHDIR)Config.pm nonxsext
$(MINIPERL) mkppport
-[.lib.pods]perl.pod : [.pod]perl.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl5004delta.pod : [.pod]perl5004delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl5005delta.pod : [.pod]perl5005delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl5100delta.pod : [.pod]perl5100delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl5101delta.pod : [.pod]perl5101delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl5110delta.pod : [.pod]perl5110delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl5111delta.pod : [.pod]perl5111delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl5112delta.pod : [.pod]perl5112delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl5113delta.pod : [.pod]perl5113delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl5114delta.pod : [.pod]perl5114delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl5115delta.pod : [.pod]perl5115delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl5120delta.pod : [.pod]perl5120delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl5121delta.pod : [.pod]perl5121delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl5122delta.pod : [.pod]perl5122delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl5123delta.pod : [.pod]perl5123delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl5130delta.pod : [.pod]perl5130delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl51310delta.pod : [.pod]perl51310delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl51311delta.pod : [.pod]perl51311delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl5131delta.pod : [.pod]perl5131delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl5132delta.pod : [.pod]perl5132delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl5133delta.pod : [.pod]perl5133delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl5134delta.pod : [.pod]perl5134delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl5135delta.pod : [.pod]perl5135delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl5136delta.pod : [.pod]perl5136delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl5137delta.pod : [.pod]perl5137delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl5138delta.pod : [.pod]perl5138delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl5139delta.pod : [.pod]perl5139delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl5140delta.pod : [.pod]perl5140delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl561delta.pod : [.pod]perl561delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl56delta.pod : [.pod]perl56delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl570delta.pod : [.pod]perl570delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl571delta.pod : [.pod]perl571delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl572delta.pod : [.pod]perl572delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl573delta.pod : [.pod]perl573delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl581delta.pod : [.pod]perl581delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl582delta.pod : [.pod]perl582delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl583delta.pod : [.pod]perl583delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl584delta.pod : [.pod]perl584delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl585delta.pod : [.pod]perl585delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl586delta.pod : [.pod]perl586delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl587delta.pod : [.pod]perl587delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl588delta.pod : [.pod]perl588delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl589delta.pod : [.pod]perl589delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl58delta.pod : [.pod]perl58delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl590delta.pod : [.pod]perl590delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl591delta.pod : [.pod]perl591delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl592delta.pod : [.pod]perl592delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl593delta.pod : [.pod]perl593delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl594delta.pod : [.pod]perl594delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perl595delta.pod : [.pod]perl595delta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlaix.pod : [.pod]perlaix.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlamiga.pod : [.pod]perlamiga.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlapi.pod : [.pod]perlapi.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlapio.pod : [.pod]perlapio.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlartistic.pod : [.pod]perlartistic.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlbeos.pod : [.pod]perlbeos.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlbook.pod : [.pod]perlbook.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlboot.pod : [.pod]perlboot.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlbot.pod : [.pod]perlbot.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlbs2000.pod : [.pod]perlbs2000.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlcall.pod : [.pod]perlcall.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlce.pod : [.pod]perlce.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlcheat.pod : [.pod]perlcheat.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlclib.pod : [.pod]perlclib.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlcn.pod : [.pod]perlcn.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlcommunity.pod : [.pod]perlcommunity.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlcompile.pod : [.pod]perlcompile.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlcygwin.pod : [.pod]perlcygwin.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perldata.pod : [.pod]perldata.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perldbmfilter.pod : [.pod]perldbmfilter.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perldebguts.pod : [.pod]perldebguts.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perldebtut.pod : [.pod]perldebtut.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perldebug.pod : [.pod]perldebug.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perldelta.pod : [.pod]perldelta.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perldgux.pod : [.pod]perldgux.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perldiag.pod : [.pod]perldiag.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perldoc.pod : [.pod]perldoc.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perldos.pod : [.pod]perldos.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perldsc.pod : [.pod]perldsc.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlebcdic.pod : [.pod]perlebcdic.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlembed.pod : [.pod]perlembed.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlepoc.pod : [.pod]perlepoc.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlfaq.pod : [.pod]perlfaq.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlfaq1.pod : [.pod]perlfaq1.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlfaq2.pod : [.pod]perlfaq2.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlfaq3.pod : [.pod]perlfaq3.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlfaq4.pod : [.pod]perlfaq4.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlfaq5.pod : [.pod]perlfaq5.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlfaq6.pod : [.pod]perlfaq6.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlfaq7.pod : [.pod]perlfaq7.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlfaq8.pod : [.pod]perlfaq8.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlfaq9.pod : [.pod]perlfaq9.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlfilter.pod : [.pod]perlfilter.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlfork.pod : [.pod]perlfork.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlform.pod : [.pod]perlform.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlfreebsd.pod : [.pod]perlfreebsd.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlfunc.pod : [.pod]perlfunc.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlgit.pod : [.pod]perlgit.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlglossary.pod : [.pod]perlglossary.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlgpl.pod : [.pod]perlgpl.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlguts.pod : [.pod]perlguts.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlhack.pod : [.pod]perlhack.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlhacktips.pod : [.pod]perlhacktips.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlhacktut.pod : [.pod]perlhacktut.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlhaiku.pod : [.pod]perlhaiku.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlhist.pod : [.pod]perlhist.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlhpux.pod : [.pod]perlhpux.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlhurd.pod : [.pod]perlhurd.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlintern.pod : [.pod]perlintern.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlinterp.pod : [.pod]perlinterp.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlintro.pod : [.pod]perlintro.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perliol.pod : [.pod]perliol.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlipc.pod : [.pod]perlipc.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlirix.pod : [.pod]perlirix.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perljp.pod : [.pod]perljp.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlko.pod : [.pod]perlko.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perllexwarn.pod : [.pod]perllexwarn.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perllinux.pod : [.pod]perllinux.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perllocale.pod : [.pod]perllocale.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perllol.pod : [.pod]perllol.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlmacos.pod : [.pod]perlmacos.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlmacosx.pod : [.pod]perlmacosx.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlmod.pod : [.pod]perlmod.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlmodinstall.pod : [.pod]perlmodinstall.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlmodlib.pod : [.pod]perlmodlib.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlmodstyle.pod : [.pod]perlmodstyle.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlmpeix.pod : [.pod]perlmpeix.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlmroapi.pod : [.pod]perlmroapi.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlnetware.pod : [.pod]perlnetware.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlnewmod.pod : [.pod]perlnewmod.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlnumber.pod : [.pod]perlnumber.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlobj.pod : [.pod]perlobj.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlop.pod : [.pod]perlop.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlopenbsd.pod : [.pod]perlopenbsd.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlopentut.pod : [.pod]perlopentut.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlos2.pod : [.pod]perlos2.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlos390.pod : [.pod]perlos390.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlos400.pod : [.pod]perlos400.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlpacktut.pod : [.pod]perlpacktut.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlperf.pod : [.pod]perlperf.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlplan9.pod : [.pod]perlplan9.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlpod.pod : [.pod]perlpod.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlpodspec.pod : [.pod]perlpodspec.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlpodstyle.pod : [.pod]perlpodstyle.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlpolicy.pod : [.pod]perlpolicy.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlport.pod : [.pod]perlport.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlpragma.pod : [.pod]perlpragma.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlqnx.pod : [.pod]perlqnx.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlre.pod : [.pod]perlre.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlreapi.pod : [.pod]perlreapi.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlrebackslash.pod : [.pod]perlrebackslash.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlrecharclass.pod : [.pod]perlrecharclass.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlref.pod : [.pod]perlref.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlreftut.pod : [.pod]perlreftut.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlreguts.pod : [.pod]perlreguts.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlrequick.pod : [.pod]perlrequick.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlreref.pod : [.pod]perlreref.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlretut.pod : [.pod]perlretut.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlriscos.pod : [.pod]perlriscos.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlrun.pod : [.pod]perlrun.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlsec.pod : [.pod]perlsec.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlsolaris.pod : [.pod]perlsolaris.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlsource.pod : [.pod]perlsource.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlstyle.pod : [.pod]perlstyle.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlsub.pod : [.pod]perlsub.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlsymbian.pod : [.pod]perlsymbian.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlsyn.pod : [.pod]perlsyn.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlthrtut.pod : [.pod]perlthrtut.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perltie.pod : [.pod]perltie.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perltoc.pod : [.pod]perltoc.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perltodo.pod : [.pod]perltodo.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perltooc.pod : [.pod]perltooc.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perltoot.pod : [.pod]perltoot.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perltrap.pod : [.pod]perltrap.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perltru64.pod : [.pod]perltru64.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perltw.pod : [.pod]perltw.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlunicode.pod : [.pod]perlunicode.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlunifaq.pod : [.pod]perlunifaq.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perluniintro.pod : [.pod]perluniintro.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perluniprops.pod : [.pod]perluniprops.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlunitut.pod : [.pod]perlunitut.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlutil.pod : [.pod]perlutil.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perluts.pod : [.pod]perluts.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlvar.pod : [.pod]perlvar.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlvmesa.pod : [.pod]perlvmesa.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlvms.pod : [.pod]perlvms.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlvos.pod : [.pod]perlvos.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlwin32.pod : [.pod]perlwin32.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlxs.pod : [.pod]perlxs.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
-[.lib.pods]perlxstut.pod : [.pod]perlxstut.pod
- @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
- Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
-
install.html : [.pod]perltoc.pod
@ @perl_setup.com
@ If F$Search("perl_root:[lib]html.dir").eqs."" Then Create/Directory perl_root:[lib.html]
@@ -1470,25 +590,10 @@
printconfig :
@ @[.vms]make_command $(MMS) $(MMSQUALIFIERS) $(MMSTARGETS)
- @ @[.vms]myconfig "$(CC)" "$(CFLAGS)" "$(LINKFLAGS)" "$(LIBS1)" "$(FULLLIBS2)" "$(SOCKLIB)" "$(EXT)" "$(DBG)"
+ @ @[.vms]myconfig "$(CC)" "$(CFLAGS)" "$(LINKFLAGS)" "$(LIBS1)" "$(FULLLIBS2)" "$(EXT)" "$(DBG)"
-.ifdef SOCKET
-
-vmsish.h : $(SOCKH)
-
-$(SOCKO) : $(SOCKC) $(h)
-
-$(SOCKC) : [.vms]$(SOCKC)
- Copy/NoConfirm/Log $(MMS$SOURCE) []
-
-$(SOCKH) : [.vms]$(SOCKH)
- Copy/NoConfirm/Log $(MMS$SOURCE) []
-
-.endif
-
# The following files are generated automatically
-# embed.pl: proto.h embed.h embedvar.h global.sym
-# perlapi.h perlapi.c
+# embed.pl: proto.h embed.h embedvar.h perlapi.h perlapi.c
# opcode.pl: opcode.h opnames.h pp_proto.h
# regcomp.pl: regnodes.h
# warnings.pl: warnings.h lib/warnings.pm
@@ -1510,9 +615,11 @@
perly$(O) : perly.c, perly.h, $(h)
.endif
-[.t.lib]vmsfspec.t : [.vms.ext]filespec.t
- Copy/NoConfirm/Log $(MMS$SOURCE) $(MMS$TARGET)
+VMSFSPEC_T = [.t.lib]vmsfspec.t
+$(VMSFSPEC_T) : [.vms.ext]filespec.t
+ Copy/NoConfirm/Log $(MMS$SOURCE) $(VMSFSPEC_T)
+
check : test
@ Continue
@@ -1532,10 +639,11 @@
# install ought not need a source, but it doesn't work if one's not
# there. Go figure...
-install : $(MINIPERL_EXE)
+install : $(PERL_EXE)
@ @perl_setup.com
If F$TrnLnm("Sys") .nes. "" Then Deass SYS
- $(MINIPERL) installperl
+ @ define/user_mode $(DBG)PERLSHR SYS$DISK:[]$(DBG)perlshr$(E)
+ $(PERL) installperl
archify : all
@ Write Sys$Output "Moving files to architecture-specific locations for $(ARCHNAME)"
@@ -1554,167 +662,11 @@
@ Write Sys$Output " 2. Delete Miniperl$(E)"
# CORE subset for MakeMaker, so we can build Perl without sources
-# Should move to VMS installperl when we get one
-.ifdef SOCKET
-$(SOCKARCH) : $(SOCKH)
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-.endif
-$(ARCHCORE)av.h : av.h
+
+archcore_includes.ts :
@ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)config.h : config.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)cop.h : cop.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)cv.h : cv.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)embed.h : embed.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)embedvar.h : embedvar.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)EXTERN.h : EXTERN.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)fakethr.h : fakethr.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)form.h : form.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)git_version.h : git_version.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)gv.h : gv.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)handy.h : handy.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)hv.h : hv.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)l1_char_class_tab.h : l1_char_class_tab.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)INTERN.h : INTERN.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)intrpvar.h : intrpvar.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)iperlsys.h : iperlsys.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)keywords.h : keywords.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)mydtrace.h : mydtrace.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)mg.h : mg.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)nostdio.h : nostdio.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)op_reg_common.h : op_reg_common.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)op.h : op.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)opcode.h : opcode.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)opnames.h : opnames.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)overload.h : overload.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)pad.h : pad.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)parser.h : parser.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)patchlevel.h : patchlevel.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)perl.h : perl.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)perlapi.h : perlapi.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)perlio.h : perlio.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)perlsdio.h : perlsdio.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)perlsfio.h : perlsfio.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)perlvars.h : perlvars.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)perly.h : perly.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)pp.h : pp.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)pp_proto.h : pp_proto.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)proto.h : proto.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-.ifdef THREADED
-$(ARCHCORE)reentr.h : reentr.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-.endif
-$(ARCHCORE)regcomp.h : regcomp.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)regexp.h : regexp.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)regnodes.h : regnodes.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)scope.h : scope.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)sv.h : sv.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)thread.h : thread.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)utf8.h : utf8.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)util.h : util.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)vmsish.h : vmsish.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)warnings.h : warnings.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
-$(ARCHCORE)xsub.h : xsub.h
- @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
+ Copy/NoConfirm/Log *.h $(ARCHCORE)
+ @ Copy _NLA0: $(MMS$TARGET)
$(ARCHCORE)$(DBG)libperl$(OLB) : $(DBG)libperl$(OLB) $(DBG)perlshr_xtras.ts
@ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
@@ -1735,10 +687,6 @@
#util$(O) : util.c
# $(CC) $(CORECFLAGS) $(MMS$SOURCE)
# AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE
-.ifdef SOCKET
-$(SOCKO) : $(SOCKC) $(h)
- $(CC) $(CORECFLAGS) $(MMS$SOURCE)
-.endif
av$(O) : av.c $(h)
$(CC) $(CORECFLAGS) $(MMS$SOURCE)
deb$(O) : deb.c $(h)
@@ -1749,7 +697,7 @@
$(CC) $(CORECFLAGS) $(MMS$SOURCE)
dump$(O) : dump.c $(h)
$(CC) $(CORECFLAGS) $(MMS$SOURCE)
-globals$(O) : globals.c uudmap.h bitcount.h $(h)
+globals$(O) : globals.c $(generated_headers) $(h)
$(CC) $(CORECFLAGS) $(MMS$SOURCE)
gv$(O) : gv.c $(h)
$(CC) $(CORECFLAGS) $(MMS$SOURCE)
@@ -1822,16 +770,16 @@
vms$(O) : vms.c $(h)
$(CC) $(CORECFLAGS) $(MMS$SOURCE)
-[.x2p]hash$(O) : [.x2p]hash.c [.x2p]EXTERN.h [.x2p]a2p.h [.x2p]hash.h [.x2p]str.h [.x2p]util.h config.h handy.h vmsish.h $(SOCKH)
+[.x2p]hash$(O) : [.x2p]hash.c [.x2p]EXTERN.h [.x2p]a2p.h [.x2p]hash.h [.x2p]str.h [.x2p]util.h config.h handy.h vmsish.h
$(CC) $(X2PCFLAGS) $(MMS$SOURCE)
-[.x2p]str$(O) : [.x2p]str.c [.x2p]EXTERN.h [.x2p]a2p.h [.x2p]hash.h [.x2p]str.h [.x2p]util.h config.h handy.h vmsish.h $(SOCKH)
+[.x2p]str$(O) : [.x2p]str.c [.x2p]EXTERN.h [.x2p]a2p.h [.x2p]hash.h [.x2p]str.h [.x2p]util.h config.h handy.h vmsish.h
$(CC) $(X2PCFLAGS) $(MMS$SOURCE)
-[.x2p]util$(O) : [.x2p]util.c [.x2p]EXTERN.h [.x2p]INTERN.h [.x2p]a2p.h [.x2p]hash.h [.x2p]str.h [.x2p]util.h config.h handy.h vmsish.h $(SOCKH)
+[.x2p]util$(O) : [.x2p]util.c [.x2p]EXTERN.h [.x2p]INTERN.h [.x2p]a2p.h [.x2p]hash.h [.x2p]str.h [.x2p]util.h config.h handy.h vmsish.h
$(CC) $(X2PCFLAGS) $(MMS$SOURCE)
-[.x2p]walk$(O) : [.x2p]walk.c [.x2p]EXTERN.h [.x2p]a2p.h [.x2p]hash.h [.x2p]str.h [.x2p]util.h config.h handy.h vmsish.h $(SOCKH)
+[.x2p]walk$(O) : [.x2p]walk.c [.x2p]EXTERN.h [.x2p]a2p.h [.x2p]hash.h [.x2p]str.h [.x2p]util.h config.h handy.h vmsish.h
$(CC) $(X2PCFLAGS) $(MMS$SOURCE)
# End of automatically generated make dependencies
@@ -1844,7 +792,7 @@
Copy/Log/Noconfirm [.vms]vms.c []
$(CRTL) : $(MAKEFILE)
- @ @[.vms]genopt "$(CRTL)/Write" "|" "$(LIBS1)|$(FULLLIBS2)|$(SOCKLIB)"
+ @ @[.vms]genopt "$(CRTL)/Write" "|" "$(LIBS1)|$(FULLLIBS2)"
ok : $(utils)
$(MINIPERL) lib/perlbug.com -ok -s "(UNINSTALLED)"
@@ -1884,6 +832,7 @@
- If F$Search("perlmain.c;-1") .nes."" Then Purge/NoConfirm/Log perlmain.c
- If F$Search("uudmap.h;-1") .nes."" Then Purge/NoConfirm/Log uudmap.h
- If F$Search("bitcount.h;-1") .nes."" Then Purge/NoConfirm/Log bitcount.h
+ - If F$Search("mg_data.h;-1") .nes."" Then Purge/NoConfirm/Log mg_data.h
- If F$Search("Perlshr_Gbl*.Mar;-1") .nes."" Then Purge/NoConfirm/Log Perlshr_Gbl*.Mar
- If F$Search("[.ext.Opcode...];-1").nes."" Then Purge/NoConfirm/Log [.ext.Opcode]
- If F$Search("[.vms.ext...]*.C;-1").nes."" Then Purge/NoConfirm/Log [.vms.ext...]*.C
@@ -1896,13 +845,11 @@
- If F$Search("$(ARCHDIR)Config_heavy.pl;-1").nes."" Then Purge/NoConfirm/Log $(ARCHDIR)Config_heavy.pl
- If F$Search("[.lib.ExtUtils]Miniperl.pm").nes."" Then Purge/NoConfirm/Log [.lib.ExtUtils]Miniperl.pm
- If F$Search("[.lib.VMS]*.*;-1").nes."" Then Purge/NoConfirm/Log [.lib.VMS]*.*
- - If F$Search("[.lib.pods]*.Pod;-1").nes."" Then Purge/NoConfirm/Log [.lib.pods]*.Pod
- If F$Search("$(ARCHCORE)*.*").nes."" Then Purge/NoConfirm/Log $(ARCHCORE)*.*
- If F$Search("[.lib]*.com;-1").nes."" Then Purge/NoConfirm/Log [.lib]*.com
- If F$Search("[.pod]*.com;-1").nes."" Then Purge/NoConfirm/Log [.pod]*.com
- If F$Search("[.utils]*.com;-1").nes."" Then Purge/NoConfirm/Log [.utils]*.com
- If F$Search("[.x2p]*.com;-1").nes."" Then Purge/NoConfirm/Log [.x2p]*.com
- - If F$Search("[.lib.pods]*.com;-1").nes."" Then Purge/NoConfirm/Log [.lib.pods]*.com
- If F$Search("[.lib]buildcustomize.pl;-1").nes."" Then Purge/NoConfirm/Log [.lib]buildcustomize.pl
clean : tidy cleantest
@@ -1909,8 +856,6 @@
- $(MINIPERL) make_ext.pl "MAKE=$(MMS)" "--all" "--target=clean"
- If F$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;*/Exclude=PerlShr_*.Opt
- If F$Search("[...]*$(O);*") .nes."" Then Delete/NoConfirm/Log [...]*$(O);*
- - If F$Search(F$Parse("Sys$Disk:[]","$(SOCKH)")).nes."" Then Delete/NoConfirm/Log $(SOCKH);*
- - If F$Search(F$Parse("Sys$Disk:[]","$(SOCKC)")).nes."" Then Delete/NoConfirm/Log $(SOCKC);*
- If F$Search("vmsish.h").nes."" Then Delete/NoConfirm/Log vmsish.h;*
- If F$Search("vms.c") .nes."" Then Delete/NoConfirm/Log vms.c;*
- If F$Search("perlmain.c") .nes."" Then Delete/NoConfirm/Log perlmain.c;*
@@ -1917,11 +862,13 @@
- If F$Search("perlmini.c") .nes."" Then Delete/NoConfirm/Log perlmini.c;*
- If F$Search("uudmap.h") .nes."" Then Delete/NoConfirm/Log uudmap.h;*
- If F$Search("bitcount.h") .nes."" Then Delete/NoConfirm/Log bitcount.h;*
+ - If F$Search("mg_data.h") .nes."" Then Delete/NoConfirm/Log mg_data.h;*
- If F$Search("Perlshr_Gbl*.Mar") .nes."" Then Delete/NoConfirm/Log Perlshr_Gbl*.Mar;*
- If F$Search("*.TS").nes."" Then Delete/NoConfirm/Log *.TS;*
- If F$Search("[.vms.ext...]*.C").nes."" Then Delete/NoConfirm/Log [.vms.ext...]*.C;*
- If F$Search("[.vms.ext...]*$(O)").nes."" Then Delete/NoConfirm/Log [.vms.ext...]*$(O);*
- If F$Search("[.pod]*.com").nes."" Then Delete/NoConfirm/Log [.pod]*.com;*
+ - If F$Search("[.pod]roffitall").nes."" Then Delete/NoConfirm/Log [.pod]roffitall;*
- If F$Search("$(PERLDELTA_CURRENT)").nes."" Then Delete/NoConfirm/Log $(PERLDELTA_CURRENT);*
- If F$Search("[.pod]perlapi.pod").nes."" Then Delete/NoConfirm/Log [.pod]perlapi.pod;*
- If F$Search("[.pod]perlintern.pod").nes."" Then Delete/NoConfirm/Log [.pod]perlintern.pod;*
@@ -1929,7 +876,6 @@
- If F$Search("[.pod]perltoc.pod").nes."" Then Delete/NoConfirm/Log [.pod]perltoc.pod;*
- If F$Search("[.pod]perluniprops.pod").nes."" Then Delete/NoConfirm/Log [.pod]perluniprops.pod;*
- @extra_pods CLEAN
- - If F$Search("unpushed.h").nes."" Then Delete/NoConfirm/Log unpushed.h;*
- If F$Search("[.lib]Config_git.pl").nes."" Then Delete/NoConfirm/Log [.lib]Config_git.pl;*
- If F$Search("git_version.h").nes."" Then Delete/NoConfirm/Log git_version.h;*
@@ -1947,7 +893,7 @@
- If F$Search("Descrip.MMS").nes."" Then Delete/NoConfirm/Log Descrip.MMS;*
- If F$Search("extra_pods.Com").nes."" Then Delete/NoConfirm/Log extra_pods.Com;*
- If F$Search("extra.pods").nes."" Then Delete/NoConfirm/Log extra.pods;*
- - $(MINIPERL) -e "use File::Path; rmtree(['lib/auto','lib/VMS','lib/$(ARCHNAME)'],1,0);"
+ - $(MINIPERL) -e "use File::Path; rmtree(['[.CXX_REPOSITORY]', 'lib/auto','lib/VMS','lib/$(ARCHNAME)'],1,0);"
- If F$Search("*.TS").nes."" Then Delete/NoConfirm/Log *.TS;*
- If F$Search("[.lib]Config.pm").nes."" Then Delete/NoConfirm/Log [.lib]Config.pm;*
- If F$Search("[.lib]Config_heavy.pl").nes."" Then Delete/NoConfirm/Log [.lib]Config_heavy.pl;*
@@ -1959,13 +905,11 @@
- If F$Search("$(ARCHDIR)Config.pm").nes."" Then Delete/NoConfirm/Log $(ARCHDIR)Config.pm;*
- If F$Search("$(ARCHDIR)Config_heavy.pl").nes."" Then Delete/NoConfirm/Log $(ARCHDIR)Config_heavy.pl;*
- If F$Search("[.lib.ExtUtils]Miniperl.pm").nes."" Then Delete/NoConfirm/Log [.lib.ExtUtils]Miniperl.pm;*
- - If F$Search("[.lib.pods]*.pod").nes."" Then Delete/NoConfirm/Log [.lib.pods]*.pod;*
- - If F$Search("[.lib.pods]perldoc.com").nes."" Then Delete/NoConfirm/Log [.lib.pods]perldoc.com;*
+ - If F$Search("[.utils]perldoc.com").nes."" Then Delete/NoConfirm/Log [.utils]perldoc.com;*
- If F$Search("[.utils]perlivp.com").nes."" Then Delete/NoConfirm/Log [.utils]perlivp.com;*
- - If F$Search("[.lib.pods]pod2*.com").nes."" Then Delete/NoConfirm/Log [.lib.pods]pod2*.com;*
- If F$Search("[.t.lib]vms*.t").nes."" Then Delete/NoConfirm/Log [.t.lib]vms*.t;*
- If F$Search("[...]*$(E)").nes."" Then Delete/NoConfirm/Log [...]*$(E);*
- - If F$Search("[.vms]Perl_Setup.Com").nes."" Then Delete/NoConfirm/Log [.vms]Perl_Setup.Com;*
+ - If F$Search("Perl_Setup.Com").nes."" Then Delete/NoConfirm/Log Perl_Setup.Com;*
- If F$Search("[.t]rantests.").nes."" Then Delete/NoConfirm/Log [.t]rantests.;*
- If F$Search("[.t]test_state.").nes."" Then Delete/NoConfirm/Log [.t]test_state.;*
- If F$Search("[.t.lib]vmsfspec.t").nes."" Then Delete/NoConfirm/Log [.t.lib]vmsfspec.t;*
@@ -1972,6 +916,7 @@
- If F$Search("[.t.lib]vmsish.t").nes."" Then Delete/NoConfirm/Log [.t.lib]vmsish.t;*
- If F$Search("vmspipe.com").nes."" Then Delete/NoConfirm/Log vmspipe.com;*
- If F$Search("[.lib]buildcustomize.pl").nes."" Then Delete/NoConfirm/Log [.lib]buildcustomize.pl;*
+ - If F$Search("[.lib]config.pod").nes."" Then Delete/NoConfirm/Log [.lib]config.pod;*
cleansrc : clean
- If F$Search("*.c;-1").nes."" Then Purge/NoConfirm/Log *.c
Property changes on: trunk/contrib/perl/vms/descrip_mms.template
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/vms/ext/Filespec.pm
===================================================================
--- trunk/contrib/perl/vms/ext/Filespec.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/vms/ext/Filespec.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/vms/ext/Filespec.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/vms/ext/filespec.t
===================================================================
--- trunk/contrib/perl/vms/ext/filespec.t 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/vms/ext/filespec.t 2013-12-02 21:26:09 UTC (rev 6439)
@@ -79,6 +79,15 @@
__DATA__
+# Column definitions:
+#
+# Column 1: Argument (path spec to be transformed)
+# Column 2: Function that is to do the transformation
+# Column 3: Expected result when DECC$EFS_CHARSET is not in effect
+# Column 4: Expected result when DECC$EFS_CHARSET is in effect
+# ^ means expect same result for EFS as for non-EFS
+# ^* means TODO when EFS is in effect
+
# lots of underscores used to minimize collision with existing logical names
# Basic VMS to Unix filespecs
@@ -87,15 +96,16 @@
[.__some_.__where_.__over_]__the_.__rainbow_ unixify __some_/__where_/__over_/__the_.__rainbow_ ^
[-.__some_.__where_.__over_]__the_.__rainbow_ unixify ../__some_/__where_/__over_/__the_.__rainbow_ ^
[.__some_.--.__where_.__over_]__the_.__rainbow_ unixify __some_/../../__where_/__over_/__the_.__rainbow_ ^
-[.__some_...__where_.__over_]__the_.__rainbow_ unixify __some_/.../__where_/__over_/__the_.__rainbow_ ^*
-[...__some_.__where_.__over_]__the_.__rainbow_ unixify .../__some_/__where_/__over_/__the_.__rainbow_ ^*
-[.__some_.__where_.__over_...]__the_.__rainbow_ unixify __some_/__where_/__over_/.../__the_.__rainbow_ ^*
-[.__some_.__where_.__over_...] unixify __some_/__where_/__over_/.../ ^*
+[.__some_...__where_.__over_]__the_.__rainbow_ unixify __some_/.../__where_/__over_/__the_.__rainbow_ ^
+[...__some_.__where_.__over_]__the_.__rainbow_ unixify .../__some_/__where_/__over_/__the_.__rainbow_ ^
+[.__some_.__where_.__over_...]__the_.__rainbow_ unixify __some_/__where_/__over_/.../__the_.__rainbow_ ^
+[.__some_.__where_.__over_...] unixify __some_/__where_/__over_/.../ ^
[.__some_.__where_.__over_.-] unixify __some_/__where_/__over_/../ ^
[] unixify ./ ^
[-] unixify ../ ^
[--] unixify ../../ ^
-[...] unixify .../ ^*
+[...] unixify .../ ^
+__lyrics_:[__are_.__very_^.__sappy_]__but_^.__rhymes_^.__are_.__true_ unixify /__lyrics_/__are_/__very_.__sappy_/__but_.__rhymes_.__are_.__true_ ^
[.$(macro)] unixify $(macro)/ ^
# and back again
@@ -102,33 +112,32 @@
/__some_/__where_/__over_/__the_.__rainbow_ vmsify __some_:[__where_.__over_]__the_.__rainbow_ ^
__some_/__where_/__over_/__the_.__rainbow_ vmsify [.__some_.__where_.__over_]__the_.__rainbow_ ^
../__some_/__where_/__over_/__the_.__rainbow_ vmsify [-.__some_.__where_.__over_]__the_.__rainbow_ ^
-__some_/../../__where_/__over_/__the_.__rainbow_ vmsify [-.__where_.__over_]__the_.__rainbow_ [.__some_.--.__where_.__over_]__the_.__rainbow_
-.../__some_/__where_/__over_/__the_.__rainbow_ vmsify [...__some_.__where_.__over_]__the_.__rainbow_ [.^.^.^..__some_.__where_.__over_]__the_.__rainbow_
-__some_/.../__where_/__over_/__the_.__rainbow_ vmsify [.__some_...__where_.__over_]__the_.__rainbow_ [.__some_.^.^.^..__where_.__over_]__the_.__rainbow_
-/__some_/.../__where_/__over_/__the_.__rainbow_ vmsify __some_:[...__where_.__over_]__the_.__rainbow_ __some_:[^.^.^..__where_.__over_]__the_.__rainbow_
-__some_/__where_/... vmsify [.__some_.__where_...] [.__some_.__where_]^.^.^..
-/__where_/... vmsify __where_:[...] __where_:[]^.^.^..
+__some_/../../__where_/__over_/__the_.__rainbow_ vmsify [.__some_.--.__where_.__over_]__the_.__rainbow_ ^
+.../__some_/__where_/__over_/__the_.__rainbow_ vmsify [...__some_.__where_.__over_]__the_.__rainbow_ ^
+__some_/.../__where_/__over_/__the_.__rainbow_ vmsify [.__some_...__where_.__over_]__the_.__rainbow_ ^
+/__some_/.../__where_/__over_/__the_.__rainbow_ vmsify __some_:[...__where_.__over_]__the_.__rainbow_ ^
+__some_/__where_/... vmsify [.__some_.__where_...] ^
+/__where_/... vmsify __where_:[...] ^
. vmsify [] ^
.. vmsify [-] ^
../.. vmsify [--] ^
-.../ vmsify [...] [.^.^.^.]
-# Can not predict what / will translate to.
-/ vmsify sys$disk:[000000] ^*
+.../ vmsify [...] ^
+/ vmsify sys$disk:[000000] ^
./$(macro)/ vmsify [.$(macro)] ^
./$(macro) vmsify []$(macro) ^
-./$(m+ vmsify []$^(m^+ []$^(m^+.
-
+./$(m+ vmsify []$^(m^+ ^
+foo-bar-0^.01/ vmsify [.foo-bar-0_01] [.foo-bar-0^.01]
# Fileifying directory specs
__down_:[__the_.__garden_.__path_] fileify __down_:[__the_.__garden_]__path_.dir;1 ^
[.__down_.__the_.__garden_.__path_] fileify [.__down_.__the_.__garden_]__path_.dir;1 ^
-/__down_/__the_/__garden_/__path_ fileify /__down_/__the_/__garden_/__path_.dir;1 /__down_/__the_/__garden_/__path_
-/__down_/__the_/__garden_/__path_/ fileify /__down_/__the_/__garden_/__path_.dir;1 /__down_/__the_/__garden_/__path_
-__down_/__the_/__garden_/__path_ fileify __down_/__the_/__garden_/__path_.dir;1 __down_/__the_/__garden_/__path_
+/__down_/__the_/__garden_/__path_ fileify /__down_/__the_/__garden_/__path_.dir;1 ^
+/__down_/__the_/__garden_/__path_/ fileify /__down_/__the_/__garden_/__path_.dir;1 ^
+__down_/__the_/__garden_/__path_ fileify __down_/__the_/__garden_/__path_.dir;1 ^
__down_:[__the_.__garden_]__path_ fileify __down_:[__the_.__garden_]__path_.dir;1 ^
__down_:[__the_.__garden_]__path_. fileify ^ __down_:[__the_.__garden_]__path_^..dir;1 # N.B. trailing . ==> null type
__down_:[__the_]__garden_.__path_ fileify ^ __down_:[__the_]__garden_^.__path_.dir;1 #undef
-/__down_/__the_/__garden_/__path_. fileify ^ /__down_/__the_/__garden_/__path_. # N.B. trailing . ==> null type
-/__down_/__the_/__garden_.__path_ fileify ^ /__down_/__the_/__garden_.__path_
+/__down_/__the_/__garden_/__path_. fileify ^ /__down_/__the_/__garden_/__path_..dir;1 # N.B. trailing . ==> null type
+/__down_/__the_/__garden_.__path_ fileify ^ /__down_/__the_/__garden_.__path_.dir;1
# and pathifying them
__down_:[__the_.__garden_]__path_.dir;1 pathify __down_:[__the_.__garden_.__path_] ^
@@ -136,7 +145,7 @@
/__down_/__the_/__garden_/__path_.dir pathify /__down_/__the_/__garden_/__path_/ ^
__down_/__the_/__garden_/__path_.dir pathify __down_/__the_/__garden_/__path_/ ^
__down_:[__the_.__garden_]__path_ pathify __down_:[__the_.__garden_.__path_] ^
-__down_:[__the_.__garden_]__path_. pathify ^ __down_:[__the.__garden_.__path_^.] # N.B. trailing . ==> null type
+__down_:[__the_.__garden_]__path_. pathify ^ __down_:[__the_.__garden_.__path_^.] # N.B. trailing . ==> null type
__down_:[__the_]__garden_.__path_ pathify ^ __down_:[__the_.__garden_^.__path_] # undef
/__down_/__the_/__garden_/__path_. pathify /__down_/__the_/__garden_/__path__/ /__down_/__the_/__garden_/__path_./ # N.B. trailing . ==> null type
/__down_/__the_/__garden_.__path_ pathify /__down_/__the_/__garden____path_/ /__down_/__the_/__garden_.__path_/
@@ -151,16 +160,16 @@
__down_:[__the_.__garden_]__path_.dir;1 unixpath /__down_/__the_/__garden_/__path_/ ^
/__down_/__the_/__garden_/__path_ vmspath __down_:[__the_.__garden_.__path_] ^
__down_:[__the_.__garden_.__path_] unixpath /__down_/__the_/__garden_/__path_/ ^
-__down_:[__the_.__garden_.__path_...] unixpath /__down_/__the_/__garden_/__path_/.../ # Not translatable
+__down_:[__the_.__garden_.__path_...] unixpath /__down_/__the_/__garden_/__path_/.../ ^
/__down_/__the_/__garden_/__path_.dir vmspath __down_:[__the_.__garden_.__path_] ^
[.__down_.__the_.__garden_]__path_.dir unixpath __down_/__the_/__garden_/__path_/ ^
__down_/__the_/__garden_/__path_ vmspath [.__down_.__the_.__garden_.__path_] ^
__path_ vmspath [.__path_] ^
-/ vmspath sys$disk:[000000] ^*
+/ vmspath sys$disk:[000000] ^
/sys$scratch vmspath sys$scratch: ^
# Redundant characters in Unix paths
-//__some_/__where_//__over_/../__the_.__rainbow_ vmsify __some_:[__where_]__the_.__rainbow_ __some_:[__where_.__over_.-]__the_.__rainbow_
+//__some_/__where_//__over_/../__the_.__rainbow_ vmsify __some_:[__where_.__over_.-]__the_.__rainbow_ ^
/__some_/__where_//__over_/./__the_.__rainbow_ vmsify __some_:[__where_.__over_]__the_.__rainbow_ ^
..//../ vmspath [--] ^
./././ vmspath [] ^
Property changes on: trunk/contrib/perl/vms/ext/filespec.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/vms/gen_shrfls.pl
===================================================================
--- trunk/contrib/perl/vms/gen_shrfls.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/vms/gen_shrfls.pl 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,10 +1,10 @@
# Create global symbol declarations, transfer vector, and
# linker options files for PerlShr.
#
+# Processes the output of makedef.pl.
+#
# Input:
-# $cflags - command line qualifiers passed to cc when preprocesing perl.h
-# Note: A rather simple-minded attempt is made to restore quotes to
-# a /Define clause - use with care.
+# $cc_cmd - compiler command
# $objsuffix - file type (including '.') used for object files.
# $libperl - Perl object library.
# $extnames - package names for static extensions (used to generate
@@ -40,7 +40,7 @@
my $debug = $ENV{'GEN_SHRFLS_DEBUG'};
-print "gen_shrfls.pl Rev. 30-Sep-2010\n" if $debug;
+print "gen_shrfls.pl Rev. 8-Jul-2011\n" if $debug;
if ($ARGV[0] eq '-f') {
open(INP,$ARGV[1]) or die "Can't read input file $ARGV[1]: $!\n";
@@ -54,8 +54,7 @@
print "Read input data | ",join(' | ', at ARGV)," |\n" if $debug > 1;
}
-my $cc_cmd = shift @ARGV;
-my $cpp_file;
+my $cc_cmd = shift @ARGV; # no longer used to run the preprocessor
# Someday, we'll have $GetSyI built into perl . . .
my $isvax = `\$ Write Sys\$Output \(F\$GetSyI(\"HW_MODEL\") .LE. 1024 .AND. F\$GetSyI(\"HW_MODEL\") .GT. 0\)`;
@@ -74,15 +73,14 @@
$debugging_enabled, $hide_mymalloc, $isgcc, $use_perlio, $dir )
= ( 0, 0, 0, 0, 0, 0, 0, 0 );
-if ($docc) {
- if (-f 'perl.h') { $dir = '[]'; }
- elsif (-f '[-]perl.h') { $dir = '[-]'; }
- else { die "$0: Can't find perl.h\n"; }
+if (-f 'perl.h') { $dir = '[]'; }
+elsif (-f '[-]perl.h') { $dir = '[-]'; }
+else { die "$0: Can't find perl.h\n"; }
- # Go see what is enabled in config.sh
- my $config = $dir . "config.sh";
- open CONFIG, '<', $config;
- while(<CONFIG>) {
+# Go see what is enabled in config.sh
+my $config = $dir . "config.sh";
+open CONFIG, '<', $config;
+while(<CONFIG>) {
$use_threads++ if /usethreads='(define|yes|true|t|y|1)'/i;
$use_mymalloc++ if /usemymalloc='(define|yes|true|t|y|1)'/i;
$care_about_case++ if /d_vms_case_sensitive_symbols='(define|yes|true|t|y|1)'/i;
@@ -91,37 +89,26 @@
$hide_mymalloc++ if /embedmymalloc='(define|yes|true|t|y|1)'/i;
$isgcc++ if /gccversion='[^']/;
$use_perlio++ if /useperlio='(define|yes|true|t|y|1)'/i;
- }
- close CONFIG;
+}
+close CONFIG;
- # put quotes back onto defines - they were removed by DCL on the way in
- if (my ($prefix,$defines,$suffix) =
+# put quotes back onto defines - they were removed by DCL on the way in
+if (my ($prefix,$defines,$suffix) =
($cc_cmd =~ m#(.*)/Define=(.*?)([/\s].*)#i)) {
- $defines =~ s/^\((.*)\)$/$1/;
- $debugging_enabled ||= $defines =~ /\bDEBUGGING\b/;
- my @defines = split(/,/,$defines);
- $cc_cmd = "$prefix/Define=(" . join(',',grep($_ = "\"$_\"", at defines))
+ $defines =~ s/^\((.*)\)$/$1/;
+ $debugging_enabled ||= $defines =~ /\bDEBUGGING\b/;
+ my @defines = split(/,/,$defines);
+ $cc_cmd = "$prefix/Define=(" . join(',',grep($_ = "\"$_\"", at defines))
. ')' . $suffix;
- }
- print "Filtered \$cc_cmd: \\$cc_cmd\\\n" if $debug;
+}
+print "Filtered \$cc_cmd: \\$cc_cmd\\\n" if $debug;
- # check for gcc - if present, we'll need to use MACRO hack to
- # define global symbols for shared variables
+# check for gcc - if present, we'll need to use MACRO hack to
+# define global symbols for shared variables
- print "\$isgcc: $isgcc\n" if $debug;
- print "\$debugging_enabled: $debugging_enabled\n" if $debug;
+print "\$isgcc: $isgcc\n" if $debug;
+print "\$debugging_enabled: $debugging_enabled\n" if $debug;
-}
-else {
- (undef,undef,$cpp_file,$cc_cmd) = split(/~~/,$cc_cmd,4);
- $isgcc = $cc_cmd =~ /case_hack/i
- or 0; # for nice debug output
- $debugging_enabled = $cc_cmd =~ /\bdebugging\b/i;
- print "\$isgcc: \\$isgcc\\\n" if $debug;
- print "\$debugging_enabled: \\$debugging_enabled\\\n" if $debug;
- print "Not running cc, preprocesor output in \\$cpp_file\\\n" if $debug;
-}
-
my $objsuffix = shift @ARGV;
print "\$objsuffix: \\$objsuffix\\\n" if $debug;
my $dbgprefix = shift @ARGV;
@@ -134,143 +121,26 @@
my $rtlopt = shift @ARGV;
print "\$rtlopt: \\$rtlopt\\\n" if $debug;
-my (%vars, %cvars, %fcns);
+my (%vars, %fcns);
-# These are symbols that we should not export. They may merely
-# look like exportable symbols but aren't, or they may be declared
-# as exportable symbols but there is no function implementing them
-# (possibly due to an alias).
+open my $makedefs, '<', $dir . 'makedef.lis' or die "Unable to open makedef.lis: $!";
-my %symbols_to_exclude = (
- '__attribute__format__' => 1,
- 'main' => 1,
- 'Perl_pp_avalues' => 1,
- 'Perl_pp_reach' => 1,
- 'Perl_pp_rvalues' => 1,
- 'Perl_pp_say' => 1,
- 'Perl_pp_transr' => 1,
- 'sizeof' => 1,
-);
-
-sub scan_var {
- my($line) = @_;
- my($const) = $line =~ /^EXTCONST/;
-
- print "\tchecking for global variable\n" if $debug > 1;
- $line =~ s/\s*EXT/EXT/;
- $line =~ s/INIT\s*\(.*\)//;
- $line =~ s/\[.*//;
- $line =~ s/=.*//;
- $line =~ s/\W*;?\s*$//;
- $line =~ s/\W*\)\s*\(.*$//; # closing paren for args stripped in previous stmt
- print "\tfiltered to \\$line\\\n" if $debug > 1;
- if ($line =~ /(\w+)$/) {
- print "\tvar name is \\$1\\" . ($const ? ' (const)' : '') . "\n" if $debug > 1;
- if ($const) { $cvars{$1}++; }
- else { $vars{$1}++; }
+while (my $line = <$makedefs>) {
+ chomp $line;
+ $line = shorten_symbol($line, $care_about_case) if $shorten_symbols;
+ # makedef.pl loses distinction between vars and funcs, so
+ # use the start of the name to guess and add specific
+ # exceptions when we know about them.
+ if ($line =~ m/^(PL_|MallocCfg)/
+ || $line eq 'PerlIO_perlio'
+ || $line eq 'PerlIO_pending') {
+ $vars{$line}++;
}
-}
-
-sub scan_func {
- my @lines = split /;/, $_[0];
-
- for my $line (@lines) {
- print "\tchecking for global routine\n" if $debug > 1;
- $line =~ s/\b(IV|Off_t|Size_t|SSize_t|void|int)\b//i;
- if ( $line =~ /(\w+)\s*\(/ ) {
- print "\troutine name is \\$1\\\n" if $debug > 1;
- if (exists($symbols_to_exclude{$1})
- || ($1 eq 'Perl_stashpv_hvname_match' && ! $use_threads)) {
- print "\tskipped\n" if $debug > 1;
- }
- else { $fcns{$1}++ }
- }
- }
-}
-
-# Go add some right up front if we need 'em
-if ($use_mymalloc) {
- $fcns{'Perl_malloc'}++;
- $fcns{'Perl_calloc'}++;
- $fcns{'Perl_realloc'}++;
- $fcns{'Perl_mfree'}++;
-}
-
-my ($used_expectation_enum, $used_opcode_enum) = (0, 0); # avoid warnings
-if ($docc) {
- 1 while unlink 'perlincludes.tmp';
- END { 1 while unlink 'perlincludes.tmp'; } # and clean up after
-
- open(PERLINC, '>', 'perlincludes.tmp') or die "Couldn't open 'perlincludes.tmp' $!";
-
- print PERLINC qq/#include "${dir}perl.h"\n/;
- print PERLINC qq/#include "${dir}perlapi.h"\n/;
- print PERLINC qq/#include "${dir}perliol.h"\n/ if $use_perlio;
- print PERLINC qq/#include "${dir}regcomp.h"\n/;
-
- close PERLINC;
- my $preprocess_list = 'perlincludes.tmp';
-
- open(CPP,"${cc_cmd}/NoObj/PreProc=Sys\$Output $preprocess_list|")
- or die "$0: Can't preprocess $preprocess_list: $!\n";
-}
-else {
- open(CPP,"$cpp_file") or die "$0: Can't read preprocessed file $cpp_file: $!\n";
-}
-my %checkh = map { $_,1 } qw( bytecode byterun intrpvar perlapi perlio perliol
- perlvars proto regcomp thrdvar thread );
-my $ckfunc = 0;
-LINE: while (<CPP>) {
- while (/^#.*vmsish\.h/i .. /^#.*perl\.h/i) {
- while (/__VMS_PROTOTYPES__/i .. /__VMS_SEPYTOTORP__/i) {
- print "vms_proto>> $_" if $debug > 2;
- if (/^\s*EXT(CONST|\s+)/) { &scan_var($_); }
- else { &scan_func($_); }
- last LINE unless defined($_ = <CPP>);
- }
- print "vmsish.h>> $_" if $debug > 2;
- if (/^\s*EXT(CONST|\s+)/) { &scan_var($_); }
- last LINE unless defined($_ = <CPP>);
- }
- while (/^#.*opcode\.h/i .. /^#.*perl\.h/i) {
- print "opcode.h>> $_" if $debug > 2;
- if (/^OP \*\s/) { &scan_func($_); }
- if (/^\s*EXT(CONST|\s+)/) { &scan_var($_); }
- last LINE unless defined($_ = <CPP>);
- }
- # Check for transition to new header file
- my $scanname;
- if (/^# \d+ "(\S+)"/) {
- my $spec = $1;
- # Pull name from library module or header filespec
- $spec =~ /^(\w+)$/ or $spec =~ /(\w+)\.h/i;
- my $name = lc $1;
- $ckfunc = exists $checkh{$name} ? 1 : 0;
- $scanname = $name if $ckfunc;
- print "Header file transition: ckfunc = $ckfunc for $name.h\n" if $debug > 1;
- }
- if ($ckfunc) {
- print "$scanname>> $_" if $debug > 2;
- if (/^\s*EXT(CONST|\s+)/) { &scan_var($_); }
- else { &scan_func($_); }
- }
else {
- print $_ if $debug > 3 && ($debug > 5 || length($_));
- if (/^\s*EXT(CONST|\s+)/) { &scan_var($_); }
+ $fcns{$line}++;
}
}
-close CPP;
-while (<DATA>) {
- next if /^#/;
- s/\s+#.*\n//;
- next if /^\s*$/;
- my ($key,$array) = split('=',$_);
- if ($array eq 'vars') { $key = "PL_$key"; }
- else { $key = "Perl_$key"; }
- print "Adding $key to \%$array list\n" if $debug > 1;
- ${$array}{$key}++;
-}
if ($debugging_enabled and $isgcc) { $vars{'colors'}++ }
foreach (split /\s+/, $extnames) {
my($pkgname) = $_;
@@ -279,25 +149,6 @@
print "Adding boot_$pkgname to \%fcns (for extension $_)\n" if $debug;
}
-# For symbols over 31 characters, export the shortened name.
-# TODO: Make this general purpose so we can predict the shortened name the
-# compiler will generate for any symbol over 31 characters in length. The
-# docs to CC/NAMES=SHORTENED describe the CRC used to shorten the name, but
-# don't describe its use fully enough to actually mimic what the compiler
-# does.
-
-if ($shorten_symbols) {
- if (exists $fcns{'Perl_ck_entersub_args_proto_or_list'}) {
- delete $fcns{'Perl_ck_entersub_args_proto_or_list'};
- if ($care_about_case) {
- $fcns{'Perl_ck_entersub_args_p11c2bjj$'}++;
- }
- else {
- $fcns{'PERL_CK_ENTERSUB_ARGS_P3IAT616$'}++;
- }
- }
-}
-
# Eventually, we'll check against existing copies here, so we can add new
# symbols to an existing options file in an upwardly-compatible manner.
@@ -319,10 +170,11 @@
print OPTBLD "PSECT_ATTR=\$GLOBAL_RO_VARS,PIC,NOEXE,RD,NOWRT,SHR\n";
print OPTBLD "PSECT_ATTR=\$GLOBAL_RW_VARS,PIC,NOEXE,RD,WRT,NOSHR\n";
}
+ print OPTBLD "PSECT_ATTR=LIB\$INITIALIZE,GBL,NOEXE,NOWRT,NOSHR,LONG\n";
}
print OPTBLD "case_sensitive=yes\n" if $care_about_case;
my $count = 0;
-foreach my $var (sort (keys %vars,keys %cvars)) {
+foreach my $var (sort (keys %vars)) {
if ($isvax) { print OPTBLD "UNIVERSAL=$var\n"; }
else { print OPTBLD "SYMBOL_VECTOR=($var=DATA)\n"; }
# This hack brought to you by the lack of a globaldef in gcc.
@@ -358,9 +210,11 @@
open(OPTATTR, '>', "${dir}perlshr_attr.opt")
or die "$0: Can't write to ${dir}perlshr_attr.opt: $!\n";
if ($isgcc) {
- foreach my $var (sort keys %cvars) {
- print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,NOWRT,SHR\n";
- }
+# TODO -- lost ability to distinguish constant vars from others when
+# we switched to using makedef.pl for input.
+# foreach my $var (sort keys %cvars) {
+# print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,NOWRT,SHR\n";
+# }
foreach my $var (sort keys %vars) {
print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,WRT,NOSHR\n";
}
@@ -402,19 +256,19 @@
# given version of Perl.
if ($ENV{PERLSHR_USE_GSMATCH}) {
if ($ENV{PERLSHR_USE_GSMATCH} eq 'INCLUDE_COMPILE_OPTIONS') {
- # Build up a major ID. Since it can only be 8 bits, we encode the version
- # number in the top four bits and use the bottom four for build options
- # that'll cause incompatibilities
- my ($ver, $sub) = $] =~ /\.(\d\d\d)(\d\d)/;
+ # Build up a major ID. Since on Alpha it can only be 8 bits, we encode
+ # the version number in the top 5 bits and use the bottom 3 for build
+ # options most likely to cause incompatibilities. Breaks at Perl 5.32.
+ my ($ver, $sub) = $] =~ /\.(\d\d\d)(\d\d\d)/;
$ver += 0; $sub += 0;
- my $gsmatch = ($sub >= 50) ? "equal" : "lequal"; # Force an equal match for
+ my $gsmatch = ($ver % 2 == 1) ? "EQUAL" : "LEQUAL"; # Force an equal match for
# dev, but be more forgiving
# for releases
- $ver *=16;
- $ver += 8 if $debugging_enabled; # If DEBUGGING is set
- $ver += 4 if $use_threads; # if we're threaded
- $ver += 2 if $use_mymalloc; # if we're using perl's malloc
+ $ver <<= 3;
+ $ver += 1 if $debugging_enabled; # If DEBUGGING is set
+ $ver += 2 if $use_threads; # if we're threaded
+ $ver += 4 if $use_mymalloc; # if we're using perl's malloc
print OPTBLD "GSMATCH=$gsmatch,$ver,$sub\n";
}
else {
@@ -423,7 +277,7 @@
print OPTBLD "GSMATCH=LEQUAL,$major,$minor\n";
}
print OPTBLD 'CLUSTER=$$TRANSFER_VECTOR,,',
- map(",$_$objsuffix", at symfiles), "\n";
+ map(",$_$objsuffix", at symfiles), "\n" if $isvax;
}
elsif (@symfiles) { $incstr .= ',' . join(',', at symfiles); }
# Include object modules and RTLs in options file
@@ -438,8 +292,111 @@
exec "\$ \@$drvrname" if $isvax;
+# Symbol shortening Copyright (c) 2012 Craig A. Berry
+#
+# Released under the same terms as Perl itself.
+#
+# This code provides shortening of long symbols (> 31 characters) using the
+# same mechanism as the OpenVMS C compiler. The basic procedure is to compute
+# an AUTODIN II checksum of the entire symbol, encode the checksum in base32,
+# and glue together a shortened symbol from the first 23 characters of the
+# original symbol plus the encoded checksum appended. The output format is
+# the same used in the name mangler database, stored by default in
+# [.CXX_REPOSITORY]CXX$DEMANGLER_DB.
+
+sub crc32 {
+ use constant autodin_ii_table => [
+ 0x00000000, 0x77073096, 0xee0e612c, 0x990951ba, 0x076dc419, 0x706af48f,
+ 0xe963a535, 0x9e6495a3, 0x0edb8832, 0x79dcb8a4, 0xe0d5e91e, 0x97d2d988,
+ 0x09b64c2b, 0x7eb17cbd, 0xe7b82d07, 0x90bf1d91, 0x1db71064, 0x6ab020f2,
+ 0xf3b97148, 0x84be41de, 0x1adad47d, 0x6ddde4eb, 0xf4d4b551, 0x83d385c7,
+ 0x136c9856, 0x646ba8c0, 0xfd62f97a, 0x8a65c9ec, 0x14015c4f, 0x63066cd9,
+ 0xfa0f3d63, 0x8d080df5, 0x3b6e20c8, 0x4c69105e, 0xd56041e4, 0xa2677172,
+ 0x3c03e4d1, 0x4b04d447, 0xd20d85fd, 0xa50ab56b, 0x35b5a8fa, 0x42b2986c,
+ 0xdbbbc9d6, 0xacbcf940, 0x32d86ce3, 0x45df5c75, 0xdcd60dcf, 0xabd13d59,
+ 0x26d930ac, 0x51de003a, 0xc8d75180, 0xbfd06116, 0x21b4f4b5, 0x56b3c423,
+ 0xcfba9599, 0xb8bda50f, 0x2802b89e, 0x5f058808, 0xc60cd9b2, 0xb10be924,
+ 0x2f6f7c87, 0x58684c11, 0xc1611dab, 0xb6662d3d, 0x76dc4190, 0x01db7106,
+ 0x98d220bc, 0xefd5102a, 0x71b18589, 0x06b6b51f, 0x9fbfe4a5, 0xe8b8d433,
+ 0x7807c9a2, 0x0f00f934, 0x9609a88e, 0xe10e9818, 0x7f6a0dbb, 0x086d3d2d,
+ 0x91646c97, 0xe6635c01, 0x6b6b51f4, 0x1c6c6162, 0x856530d8, 0xf262004e,
+ 0x6c0695ed, 0x1b01a57b, 0x8208f4c1, 0xf50fc457, 0x65b0d9c6, 0x12b7e950,
+ 0x8bbeb8ea, 0xfcb9887c, 0x62dd1ddf, 0x15da2d49, 0x8cd37cf3, 0xfbd44c65,
+ 0x4db26158, 0x3ab551ce, 0xa3bc0074, 0xd4bb30e2, 0x4adfa541, 0x3dd895d7,
+ 0xa4d1c46d, 0xd3d6f4fb, 0x4369e96a, 0x346ed9fc, 0xad678846, 0xda60b8d0,
+ 0x44042d73, 0x33031de5, 0xaa0a4c5f, 0xdd0d7cc9, 0x5005713c, 0x270241aa,
+ 0xbe0b1010, 0xc90c2086, 0x5768b525, 0x206f85b3, 0xb966d409, 0xce61e49f,
+ 0x5edef90e, 0x29d9c998, 0xb0d09822, 0xc7d7a8b4, 0x59b33d17, 0x2eb40d81,
+ 0xb7bd5c3b, 0xc0ba6cad, 0xedb88320, 0x9abfb3b6, 0x03b6e20c, 0x74b1d29a,
+ 0xead54739, 0x9dd277af, 0x04db2615, 0x73dc1683, 0xe3630b12, 0x94643b84,
+ 0x0d6d6a3e, 0x7a6a5aa8, 0xe40ecf0b, 0x9309ff9d, 0x0a00ae27, 0x7d079eb1,
+ 0xf00f9344, 0x8708a3d2, 0x1e01f268, 0x6906c2fe, 0xf762575d, 0x806567cb,
+ 0x196c3671, 0x6e6b06e7, 0xfed41b76, 0x89d32be0, 0x10da7a5a, 0x67dd4acc,
+ 0xf9b9df6f, 0x8ebeeff9, 0x17b7be43, 0x60b08ed5, 0xd6d6a3e8, 0xa1d1937e,
+ 0x38d8c2c4, 0x4fdff252, 0xd1bb67f1, 0xa6bc5767, 0x3fb506dd, 0x48b2364b,
+ 0xd80d2bda, 0xaf0a1b4c, 0x36034af6, 0x41047a60, 0xdf60efc3, 0xa867df55,
+ 0x316e8eef, 0x4669be79, 0xcb61b38c, 0xbc66831a, 0x256fd2a0, 0x5268e236,
+ 0xcc0c7795, 0xbb0b4703, 0x220216b9, 0x5505262f, 0xc5ba3bbe, 0xb2bd0b28,
+ 0x2bb45a92, 0x5cb36a04, 0xc2d7ffa7, 0xb5d0cf31, 0x2cd99e8b, 0x5bdeae1d,
+ 0x9b64c2b0, 0xec63f226, 0x756aa39c, 0x026d930a, 0x9c0906a9, 0xeb0e363f,
+ 0x72076785, 0x05005713, 0x95bf4a82, 0xe2b87a14, 0x7bb12bae, 0x0cb61b38,
+ 0x92d28e9b, 0xe5d5be0d, 0x7cdcefb7, 0x0bdbdf21, 0x86d3d2d4, 0xf1d4e242,
+ 0x68ddb3f8, 0x1fda836e, 0x81be16cd, 0xf6b9265b, 0x6fb077e1, 0x18b74777,
+ 0x88085ae6, 0xff0f6a70, 0x66063bca, 0x11010b5c, 0x8f659eff, 0xf862ae69,
+ 0x616bffd3, 0x166ccf45, 0xa00ae278, 0xd70dd2ee, 0x4e048354, 0x3903b3c2,
+ 0xa7672661, 0xd06016f7, 0x4969474d, 0x3e6e77db, 0xaed16a4a, 0xd9d65adc,
+ 0x40df0b66, 0x37d83bf0, 0xa9bcae53, 0xdebb9ec5, 0x47b2cf7f, 0x30b5ffe9,
+ 0xbdbdf21c, 0xcabac28a, 0x53b39330, 0x24b4a3a6, 0xbad03605, 0xcdd70693,
+ 0x54de5729, 0x23d967bf, 0xb3667a2e, 0xc4614ab8, 0x5d681b02, 0x2a6f2b94,
+ 0xb40bbe37, 0xc30c8ea1, 0x5a05df1b, 0x2d02ef8d,
+ ];
+
+ my $input_string = shift;
+ my $crc = 0xFFFFFFFF;
+
+ for my $byte (unpack 'C*', $input_string) {
+ $crc = ($crc >> 8) ^ autodin_ii_table->[($crc ^ $byte) & 0xff];
+ }
+ return ~$crc;
+}
+
+sub base32 {
+ my $input = shift;
+ my $output = '';
+ use constant base32hex_table => [
+ '0', '1', '2', '3', '4', '5', '6', '7', '8', '9',
+ 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j',
+ 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't',
+ 'u', 'v'
+ ];
+
+ # Grab lowest 5 bits and look up conversion in table. Lather, rinse,
+ # repeat for a total of 7, 5-bit chunks to accommodate 32 bits of input.
+
+ for (0..6) {
+ $output = base32hex_table->[$input & 0x1f] . $output;
+ $input >>= 5; # position to look at next 5
+ }
+ $output .= '$'; # It's DEC, so use '$' not '=' to pad.
+
+ return $output;
+}
+
+sub shorten_symbol {
+ my $input_symbol = shift;
+ my $as_is_flag = shift;
+ my $symbol = $input_symbol;
+
+ return $symbol unless length($input_symbol) > 31;
+
+ $symbol = uc($symbol) unless $as_is_flag;
+ my $crc = crc32($symbol);
+ $crc = ~$crc; # Compiler uses non-inverted form.
+ my $b32 = base32($crc);
+ $b32 = uc($b32) unless $as_is_flag;
+
+ return substr($symbol, 0, 23) . $b32;
+}
+
__END__
-# Oddball cases, so we can keep the perl.h scan above simple
-#Foo=vars # uncommented becomes PL_Foo
-#Bar=funcs # uncommented becomes Perl_Bar
Property changes on: trunk/contrib/perl/vms/gen_shrfls.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/vms/genopt.com
===================================================================
--- trunk/contrib/perl/vms/genopt.com 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/vms/genopt.com 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/vms/genopt.com
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/vms/make_command.com
===================================================================
--- trunk/contrib/perl/vms/make_command.com 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/vms/make_command.com 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/vms/make_command.com
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/vms/mms2make.pl
===================================================================
--- trunk/contrib/perl/vms/mms2make.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/vms/mms2make.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/vms/mms2make.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/vms/munchconfig.c
===================================================================
--- trunk/contrib/perl/vms/munchconfig.c 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/vms/munchconfig.c 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/vms/munchconfig.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/vms/myconfig.com
===================================================================
--- trunk/contrib/perl/vms/myconfig.com 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/vms/myconfig.com 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/vms/myconfig.com
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/vms/sockadapt.c
===================================================================
--- trunk/contrib/perl/vms/sockadapt.c 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/vms/sockadapt.c 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/vms/sockadapt.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/vms/sockadapt.h
===================================================================
--- trunk/contrib/perl/vms/sockadapt.h 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/vms/sockadapt.h 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/vms/sockadapt.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/vms/test.com
===================================================================
--- trunk/contrib/perl/vms/test.com 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/vms/test.com 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/vms/test.com
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/vms/vms.c
===================================================================
--- trunk/contrib/perl/vms/vms.c 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/vms/vms.c 2013-12-02 21:26:09 UTC (rev 6439)
@@ -2,13 +2,10 @@
*
* VMS-specific routines for perl5
*
- * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
- * 2002, 2003, 2004, 2005, 2006, 2007 by Charles Bailey and others.
+ * Copyright (C) 1993-2013 by Charles Bailey 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.
- *
- * Please see Changes*.* or the Perl Repository Browser for revision history.
*/
/*
@@ -26,7 +23,11 @@
#include <acedef.h>
#include <acldef.h>
#include <armdef.h>
+#if __CRTL_VER < 70300000
+/* needed for home-rolled utime() */
#include <atrdef.h>
+#include <fibdef.h>
+#endif
#include <chpdef.h>
#include <clidef.h>
#include <climsgdef.h>
@@ -34,7 +35,6 @@
#include <descrip.h>
#include <devdef.h>
#include <dvidef.h>
-#include <fibdef.h>
#include <float.h>
#include <fscndef.h>
#include <iodef.h>
@@ -44,7 +44,6 @@
#include <libdef.h>
#include <lib$routines.h>
#include <lnmdef.h>
-#include <msgdef.h>
#include <ossdef.h>
#if __CRTL_VER >= 70301000 && !defined(__VAX)
#include <ppropdef.h>
@@ -61,13 +60,8 @@
#include <uaidef.h>
#include <uicdef.h>
#include <stsdef.h>
-#include <rmsdef.h>
-#if __CRTL_VER >= 70000000 /* FIXME to earliest version */
#include <efndef.h>
#define NO_EFN EFN$C_ENF
-#else
-#define NO_EFN 0;
-#endif
#if __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
int decc$feature_get_index(const char *name);
@@ -88,29 +82,6 @@
};
#pragma member_alignment restore
-#if __CRTL_VER >= 70300000 && !defined(__VAX)
-
-static int set_feature_default(const char *name, int value)
-{
- int status;
- int index;
-
- index = decc$feature_get_index(name);
-
- status = decc$feature_set_value(index, 1, value);
- if (index == -1 || (status == -1)) {
- return -1;
- }
-
- status = decc$feature_get_value(index, 1);
- if (status != value) {
- return -1;
- }
-
-return 0;
-}
-#endif
-
/* Older versions of ssdef.h don't have these */
#ifndef SS$_INVFILFOROP
# define SS$_INVFILFOROP 3930
@@ -137,10 +108,6 @@
#include <libfildef.h>
#endif
-#if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
-# define RTL_USES_UTC 1
-#endif
-
#if !defined(__VAX) && __CRTL_VER >= 80200000
#ifdef lstat
#undef lstat
@@ -181,8 +148,7 @@
dEXT int h_errno;
#endif
-#ifdef __DECC
-#pragma message disable pragma
+#if defined(__DECC) || defined(__DECCXX)
#pragma member_alignment save
#pragma nomember_alignment longword
#pragma message save
@@ -203,10 +169,11 @@
struct vs_str_st {
unsigned short length;
- char str[65536];
+ char str[VMS_MAXRSS];
+ unsigned short pad; /* for longword struct alignment */
};
-#ifdef __DECC
+#if defined(__DECC) || defined(__DECCXX)
#pragma message restore
#pragma member_alignment restore
#endif
@@ -276,10 +243,6 @@
/* munching */
static int no_translate_barewords;
-#ifndef RTL_USES_UTC
-static int tz_updated = 1;
-#endif
-
/* DECC Features that may need to affect how Perl interprets
* displays filename information
*/
@@ -301,7 +264,6 @@
/* bug workarounds if needed */
int decc_bug_devnull = 1;
-int decc_dir_barename = 0;
int vms_bug_stat_filename = 0;
static int vms_debug_on_exception = 0;
@@ -473,8 +435,8 @@
/* High bit set, but not a Unicode character! */
/* Non printing DECMCS or ISO Latin-1 character? */
- if (*inspec <= 0x9F) {
- int hex;
+ if ((unsigned char)*inspec <= 0x9F) {
+ int hex;
outspec[0] = '^';
outspec++;
hex = (*inspec >> 4) & 0xF;
@@ -491,13 +453,13 @@
}
*output_cnt = 3;
return 1;
- } else if (*inspec == 0xA0) {
+ } else if ((unsigned char)*inspec == 0xA0) {
outspec[0] = '^';
outspec[1] = 'A';
outspec[2] = '0';
*output_cnt = 3;
return 1;
- } else if (*inspec == 0xFF) {
+ } else if ((unsigned char)*inspec == 0xFF) {
outspec[0] = '^';
outspec[1] = 'F';
outspec[2] = 'F';
@@ -603,6 +565,7 @@
return 1;
break;
}
+ return 0;
}
@@ -1082,7 +1045,7 @@
if (aTHX != NULL)
#endif
#ifdef SECURE_INTERNAL_GETENV
- flags = (PL_curinterp ? PL_tainting : will_taint) ?
+ flags = (PL_curinterp ? TAINTING_get : will_taint) ?
PERL__TRNENV_SECURE : 0;
#endif
@@ -1155,7 +1118,7 @@
/* Impose security constraints only if tainting */
if (sys) {
/* Impose security constraints only if tainting */
- secure = PL_curinterp ? PL_tainting : will_taint;
+ secure = PL_curinterp ? TAINTING_get : will_taint;
saverr = errno; savvmserr = vaxc$errno;
}
else {
@@ -1180,8 +1143,7 @@
* off and make sure we only retrieve the equivalence name for
* that index. */
if ((cp2 = strchr(lnm,';')) != NULL) {
- strcpy(uplnm,lnm);
- uplnm[cp2-lnm] = '\0';
+ my_strlcpy(uplnm, lnm, cp2 - lnm + 1);
idx = strtoul(cp2+1,NULL,0);
lnm = uplnm;
flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
@@ -1255,7 +1217,7 @@
else {
if (sys) {
/* Impose security constraints only if tainting */
- secure = PL_curinterp ? PL_tainting : will_taint;
+ secure = PL_curinterp ? TAINTING_get : will_taint;
saverr = errno; savvmserr = vaxc$errno;
}
else {
@@ -1273,8 +1235,7 @@
flags |= PERL__TRNENV_JOIN_SEARCHLIST;
if ((cp2 = strchr(lnm,';')) != NULL) {
- strcpy(buf,lnm);
- buf[cp2-lnm] = '\0';
+ my_strlcpy(buf, lnm, cp2 - lnm + 1);
idx = strtoul(cp2+1,NULL,0);
lnm = buf;
flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
@@ -1399,19 +1360,18 @@
}
else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
!str$case_blind_compare(&tmpdsc,&clisym)) {
- strcpy(cmd,"Show Symbol/Global *");
+ my_strlcpy(cmd, "Show Symbol/Global *", sizeof(cmd));
cmddsc.dsc$w_length = 20;
if (env_tables[i]->dsc$w_length == 12 &&
(tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
- !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
+ !str$case_blind_compare(&tmpdsc,&local)) my_strlcpy(cmd+12, "Local *", sizeof(cmd)-12);
flags = defflags | CLI$M_NOLOGNAM;
}
else {
- strcpy(cmd,"Show Logical *");
+ my_strlcpy(cmd, "Show Logical *", sizeof(cmd));
if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
- strcat(cmd," /Table=");
- strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
- cmddsc.dsc$w_length = strlen(cmd);
+ my_strlcat(cmd," /Table=", sizeof(cmd));
+ cmddsc.dsc$w_length = my_strlcat(cmd, env_tables[i]->dsc$a_pointer, env_tables[i]->dsc$w_length + 1);
}
else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
flags = defflags | CLI$M_NOCLISYM;
@@ -1434,7 +1394,7 @@
while (1) {
char *cp1, *cp2, *key;
unsigned long int sts, iosb[2], retlen, keylen;
- register U32 hash;
+ U32 hash;
sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
if (sts & 1) sts = iosb[0] & 0xffff;
@@ -1720,16 +1680,6 @@
return;
}
}
-#ifndef RTL_USES_UTC
- if (len == 6 || len == 2) {
- char uplnm[7];
- int i;
- for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
- uplnm[len] = '\0';
- if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
- if (!strcmp(uplnm,"TZ")) tz_updated = 1;
- }
-#endif
}
(void) vmssetenv(lnm,eqv,NULL);
}
@@ -1739,14 +1689,9 @@
/* vmssetuserlnm
* sets a user-mode logical in the process logical name table
* used for redirection of sys$error
- *
- * Fix-me: The pTHX is not needed for this routine, however doio.c
- * is calling it with one instead of using a macro.
- * A macro needs to be added to vmsish.h and doio.c updated to use it.
- *
*/
void
-Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
+Perl_vmssetuserlnm(const char *name, const char *eqv)
{
$DESCRIPTOR(d_tab, "LNM$PROCESS");
struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
@@ -1869,7 +1814,8 @@
char *vmsname;
char *rslt;
unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
- unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
+ unsigned long int cxt = 0, aclsts, fndsts;
+ int rmsts = -1;
struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
struct myacedef {
unsigned char myace$b_length;
@@ -1891,7 +1837,7 @@
/* Expand the input spec using RMS, since the CRTL remove() and
* system services won't do this by themselves, so we may miss
* a file "hiding" behind a logical name or search list. */
- vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
+ vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1);
if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
rslt = int_rmsexpand_tovms(name, vmsname, PERL_RMSEXPAND_M_SYMLINK);
@@ -2153,16 +2099,18 @@
Perl_my_chdir(pTHX_ const char *dir)
{
STRLEN dirlen = strlen(dir);
+ const char *dir1 = dir;
/* zero length string sometimes gives ACCVIO */
- if (dirlen == 0) return -1;
- const char *dir1;
+ if (dirlen == 0) {
+ SETERRNO(EINVAL, SS$_BADPARAM);
+ return -1;
+ }
/* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
* This does not work if DECC$EFS_CHARSET is active. Hack it here
* so that existing scripts do not need to be changed.
*/
- dir1 = dir;
while ((dirlen > 0) && (*dir1 == ' ')) {
dir1++;
dirlen--;
@@ -2178,10 +2126,10 @@
if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
char *newdir;
int ret;
- newdir = PerlMem_malloc(dirlen);
+ newdir = (char *)PerlMem_malloc(dirlen);
if (newdir ==NULL)
_ckvmssts_noperl(SS$_INSFMEM);
- strncpy(newdir, dir1, dirlen-1);
+ memcpy(newdir, dir1, dirlen-1);
newdir[dirlen-1] = '\0';
ret = chdir(newdir);
PerlMem_free(newdir);
@@ -2244,7 +2192,7 @@
if ((fp = tmpfile())) return fp;
- cp = PerlMem_malloc(L_tmpnam+24);
+ cp = (char *)PerlMem_malloc(L_tmpnam+24);
if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
if (decc_filename_unix_only == 0)
@@ -2260,7 +2208,6 @@
/*}}}*/
-#ifndef HOMEGROWN_POSIX_SIGNALS
/*
* The C RTL's sigaction fails to check for invalid signal numbers so we
* help it out a bit. The docs are correct, but the actual routine doesn't
@@ -2278,7 +2225,6 @@
return sigaction(sig, act, oact);
}
/*}}}*/
-#endif
#ifdef KILL_BY_SIGPRC
#include <errnodef.h>
@@ -2357,20 +2303,16 @@
0 /* 28 SIGWINCH */
};
-#if __VMS_VER >= 60200000
static int initted = 0;
if (!initted) {
initted = 1;
sig_code[16] = C$_SIGUSR1;
sig_code[17] = C$_SIGUSR2;
-#if __CRTL_VER >= 70000000
sig_code[20] = C$_SIGCHLD;
-#endif
#if __CRTL_VER >= 70300000
sig_code[28] = C$_SIGWINCH;
#endif
}
-#endif
if (sig < _SIG_MIN) return 0;
if (sig > _MY_SIG_MAX) return 0;
@@ -2388,15 +2330,22 @@
}
+#define sys$sigprc SYS$SIGPRC
+#ifdef __cplusplus
+extern "C" {
+#endif
+int sys$sigprc(unsigned int *pidadr,
+ struct dsc$descriptor_s *prcname,
+ unsigned int code);
+#ifdef __cplusplus
+}
+#endif
+
int
Perl_my_kill(int pid, int sig)
{
int iss;
unsigned int code;
-#define sys$sigprc SYS$SIGPRC
- int sys$sigprc(unsigned int *pidadr,
- struct dsc$descriptor_s *prcname,
- unsigned int code);
/* sig 0 means validate the PID */
/*------------------------------*/
@@ -2923,7 +2872,7 @@
struct exit_control_block
{
struct exit_control_block *flink;
- unsigned long int (*exit_routine)();
+ unsigned long int (*exit_routine)(void);
unsigned long int arg_count;
unsigned long int *status_address;
unsigned long int exit_status;
@@ -2956,7 +2905,7 @@
static unsigned long int
-pipe_exit_routine()
+pipe_exit_routine(void)
{
pInfo info;
unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
@@ -3633,7 +3582,7 @@
/* get the directory from $^X */
- unixdir = PerlMem_malloc(VMS_MAXRSS);
+ unixdir = (char *)PerlMem_malloc(VMS_MAXRSS);
if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
#ifdef PERL_IMPLICIT_CONTEXT
@@ -3641,7 +3590,7 @@
#else
if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
#endif
- strcpy(temp, PL_origargv[0]);
+ my_strlcpy(temp, PL_origargv[0], sizeof(temp));
x = strrchr(temp,']');
if (x == NULL) {
x = strrchr(temp,'>');
@@ -3663,8 +3612,7 @@
if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
p->next = head_PLOC;
head_PLOC = p;
- strncpy(p->dir,unixdir,sizeof(p->dir)-1);
- p->dir[NAM$C_MAXRSS] = '\0';
+ my_strlcpy(p->dir, unixdir, sizeof(p->dir));
}
}
@@ -3687,8 +3635,7 @@
p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
p->next = head_PLOC;
head_PLOC = p;
- strncpy(p->dir,unixdir,sizeof(p->dir)-1);
- p->dir[NAM$C_MAXRSS] = '\0';
+ my_strlcpy(p->dir, unixdir, sizeof(p->dir));
}
/* most likely spot (ARCHLIB) put first in the list */
@@ -3699,8 +3646,7 @@
if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
p->next = head_PLOC;
head_PLOC = p;
- strncpy(p->dir,unixdir,sizeof(p->dir)-1);
- p->dir[NAM$C_MAXRSS] = '\0';
+ my_strlcpy(p->dir, unixdir, sizeof(p->dir));
}
#endif
PerlMem_free(unixdir);
@@ -3741,10 +3687,8 @@
while (p) {
char * exp_res;
int dirlen;
- strcpy(file, p->dir);
- dirlen = strlen(file);
- strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
- file[NAM$C_MAXRSS] = '\0';
+ dirlen = my_strlcpy(file, p->dir, sizeof(file));
+ my_strlcat(file, "vmspipe.com", sizeof(file));
p = p->next;
exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
@@ -4200,7 +4144,7 @@
tfilebuf[0] = '@';
vmspipe = find_vmspipe(aTHX);
if (vmspipe) {
- strcpy(tfilebuf+1,vmspipe);
+ vmspipedsc.dsc$w_length = my_strlcpy(tfilebuf+1, vmspipe, sizeof(tfilebuf)-1) + 1;
} else { /* uh, oh...we're in tempfile hell */
tpipe = vmspipe_tempfile(aTHX);
if (!tpipe) { /* a fish popular in Boston */
@@ -4210,9 +4154,9 @@
return NULL;
}
fgetname(tpipe,tfilebuf+1,1);
+ vmspipedsc.dsc$w_length = strlen(tfilebuf);
}
vmspipedsc.dsc$a_pointer = tfilebuf;
- vmspipedsc.dsc$w_length = strlen(tfilebuf);
sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
if (!(sts & 1)) {
@@ -4244,7 +4188,7 @@
n = sizeof(Info);
_ckvmssts_noperl(lib$get_vm(&n, &info));
- strcpy(mode,in_mode);
+ my_strlcpy(mode, in_mode, sizeof(mode));
info->mode = *mode;
info->done = FALSE;
info->completion = 0;
@@ -4261,11 +4205,11 @@
info->xchan = 0;
info->xchan_valid = 0;
- in = PerlMem_malloc(VMS_MAXRSS);
+ in = (char *)PerlMem_malloc(VMS_MAXRSS);
if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
- out = PerlMem_malloc(VMS_MAXRSS);
+ out = (char *)PerlMem_malloc(VMS_MAXRSS);
if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
- err = PerlMem_malloc(VMS_MAXRSS);
+ err = (char *)PerlMem_malloc(VMS_MAXRSS);
if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
in[0] = out[0] = err[0] = '\0';
@@ -4291,7 +4235,7 @@
info->fp = PerlIO_open(mbx, mode);
} else {
info->fp = (PerlIO *) freopen(mbx, mode, stdin);
- Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
+ vmssetuserlnm("SYS$INPUT", mbx);
}
if (!info->fp && info->out) {
@@ -4346,7 +4290,7 @@
info->fp = PerlIO_open(mbx, mode);
} else {
info->fp = (PerlIO *) freopen(mbx, mode, stdout);
- Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
+ vmssetuserlnm("SYS$OUTPUT", mbx);
}
if (info->in) {
@@ -4399,18 +4343,13 @@
}
}
- symbol[MAX_DCL_SYMBOL] = '\0';
-
- strncpy(symbol, in, MAX_DCL_SYMBOL);
- d_symbol.dsc$w_length = strlen(symbol);
+ d_symbol.dsc$w_length = my_strlcpy(symbol, in, sizeof(symbol));
_ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
- strncpy(symbol, err, MAX_DCL_SYMBOL);
- d_symbol.dsc$w_length = strlen(symbol);
+ d_symbol.dsc$w_length = my_strlcpy(symbol, err, sizeof(symbol));
_ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
- strncpy(symbol, out, MAX_DCL_SYMBOL);
- d_symbol.dsc$w_length = strlen(symbol);
+ d_symbol.dsc$w_length = my_strlcpy(symbol, out, sizeof(symbol));
_ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
/* Done with the names for the pipes */
@@ -4427,8 +4366,7 @@
sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
- strncpy(symbol, p, MAX_DCL_SYMBOL);
- d_symbol.dsc$w_length = strlen(symbol);
+ d_symbol.dsc$w_length = my_strlcpy(symbol, p, sizeof(symbol));
_ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
if (strlen(p) > MAX_DCL_SYMBOL) {
@@ -4662,8 +4600,16 @@
/* Roll our own prototype because we want this regardless of whether
* _VMS_WAIT is defined.
*/
+
+#ifdef __cplusplus
+extern "C" {
+#endif
__pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
+#ifdef __cplusplus
+}
#endif
+
+#endif
/* sort-of waitpid; special handling of pipe clean-up for subprocesses
created with popen(); otherwise partially emulate waitpid() unless
we have a suitable one from the CRTL that came with VMS 7.2 and later.
@@ -4804,13 +4750,6 @@
loc = buf ? buf : __gcvtbuf;
-#ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
- if (val < 1) {
- sprintf(loc,"%.*g",ndig,val);
- return loc;
- }
-#endif
-
if (val) {
if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
return gcvt(val,ndig,loc);
@@ -4998,7 +4937,7 @@
/* Expand the input spec using RMS, since we do not want to put
* ACLs on the target of a symbolic link */
- vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
+ vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1);
if (vmsname == NULL)
return SS$_INSFMEM;
@@ -5241,7 +5180,7 @@
* on if one or more of them are directories.
*/
- vms_dst = PerlMem_malloc(VMS_MAXRSS);
+ vms_dst = (char *)PerlMem_malloc(VMS_MAXRSS);
if (vms_dst == NULL)
_ckvmssts_noperl(SS$_INSFMEM);
@@ -5249,11 +5188,11 @@
char * ret_str;
char * vms_dir_file;
- vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
+ vms_dir_file = (char *)PerlMem_malloc(VMS_MAXRSS);
if (vms_dir_file == NULL)
_ckvmssts_noperl(SS$_INSFMEM);
- /* If the dest is a directory, we must remove it
+ /* If the dest is a directory, we must remove it */
if (dst_sts == 0) {
int d_sts;
d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 1);
@@ -5260,7 +5199,7 @@
if (d_sts != 0) {
PerlMem_free(vms_dst);
errno = EIO;
- return sts;
+ return d_sts;
}
pre_delete = 1;
@@ -5467,7 +5406,7 @@
isunix = 1;
char * ret_spec;
- vmsfspec = PerlMem_malloc(VMS_MAXRSS);
+ vmsfspec = (char *)PerlMem_malloc(VMS_MAXRSS);
if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
ret_spec = int_tovmsspec(filespec, vmsfspec, 0, fs_utf8);
if (ret_spec == NULL) {
@@ -5500,7 +5439,7 @@
int t_isunix;
t_isunix = is_unix_filespec(defspec);
if (t_isunix) {
- vmsdefspec = PerlMem_malloc(VMS_MAXRSS);
+ vmsdefspec = (char *)PerlMem_malloc(VMS_MAXRSS);
if (vmsdefspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
ret_spec = int_tovmsspec(defspec, vmsdefspec, 0, dfs_utf8);
@@ -5518,10 +5457,10 @@
}
/* Now we need the expansion buffers */
- esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
+ esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
#if !defined(__VAX) && defined(NAML$C_MAXRSS)
- esal = PerlMem_malloc(VMS_MAXRSS);
+ esal = (char *)PerlMem_malloc(VMS_MAXRSS);
if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
#endif
rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
@@ -5530,7 +5469,7 @@
* addresses unless you suppress the short name.
*/
#if !defined(__VAX) && defined(NAML$C_MAXRSS)
- outbufl = PerlMem_malloc(VMS_MAXRSS);
+ outbufl = (char *)PerlMem_malloc(VMS_MAXRSS);
if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
#endif
rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
@@ -5652,11 +5591,11 @@
if (defspec && *defspec) {
char *defesal = NULL;
char *defesa = NULL;
- defesa = PerlMem_malloc(VMS_MAXRSS + 1);
+ defesa = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
if (defesa != NULL) {
struct FAB deffab = cc$rms_fab;
#if !defined(__VAX) && defined(NAML$C_MAXRSS)
- defesal = PerlMem_malloc(VMS_MAXRSS + 1);
+ defesal = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
#endif
rms_setup_nam(defnam);
@@ -5786,7 +5725,7 @@
/* VMS file specs are not in UTF-8 */
if (fs_utf8 != NULL)
*fs_utf8 = 0;
- strcpy(outbuf, spec_buf);
+ my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
ret_spec = outbuf;
}
}
@@ -5799,8 +5738,8 @@
char * src;
char * new_src = NULL;
if (spec_buf == outbuf) {
- new_src = PerlMem_malloc(VMS_MAXRSS);
- strcpy(new_src, spec_buf);
+ new_src = (char *)PerlMem_malloc(VMS_MAXRSS);
+ my_strlcpy(new_src, spec_buf, VMS_MAXRSS);
} else {
src = spec_buf;
}
@@ -5815,7 +5754,7 @@
/* Copy the buffer if needed */
if (outbuf != spec_buf)
- strcpy(outbuf, spec_buf);
+ my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
ret_spec = outbuf;
}
}
@@ -5949,8 +5888,6 @@
char *cp1, *cp2, *lastdir;
char *trndir, *vmsdir;
unsigned short int trnlnm_iter_count;
- int is_vms = 0;
- int is_unix = 0;
int sts;
if (utf8_fl != NULL)
*utf8_fl = 0;
@@ -5972,7 +5909,7 @@
set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
return NULL;
}
- trndir = PerlMem_malloc(VMS_MAXRSS + 1);
+ trndir = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
if (!strpbrk(dir+1,"/]>:") &&
(!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
@@ -5985,7 +5922,7 @@
dirlen = strlen(trndir);
}
else {
- strncpy(trndir,dir,dirlen);
+ memcpy(trndir, dir, dirlen);
trndir[dirlen] = '\0';
}
@@ -6028,35 +5965,11 @@
}
}
- vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
+ vmsdir = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
cp1 = strpbrk(trndir,"]:>");
if (hasfilename || !cp1) { /* filename present or not VMS */
- if (decc_efs_charset && !cp1) {
-
- /* EFS handling for UNIX mode */
-
- /* Just remove the trailing '/' and we should be done */
- STRLEN trndir_len;
- trndir_len = strlen(trndir);
-
- if (trndir_len > 1) {
- trndir_len--;
- if (trndir[trndir_len] == '/') {
- trndir[trndir_len] = '\0';
- }
- }
- strcpy(buf, trndir);
- PerlMem_free(trndir);
- PerlMem_free(vmsdir);
- return buf;
- }
-
- /* For non-EFS mode, this is left for backwards compatibility */
- /* For EFS mode, this is only done for VMS format filespecs as */
- /* Perl programs generally have problems when a UNIX format spec */
- /* returns a VMS format spec */
if (trndir[0] == '.') {
if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
PerlMem_free(trndir);
@@ -6174,6 +6087,20 @@
/* The .dir for now, and fix this better later */
dirlen = cp2 - trndir;
}
+ if (decc_efs_charset && !strchr(trndir,'/')) {
+ /* Dots are allowed in dir names, so escape them if input not in Unix syntax. */
+ char *cp4 = is_dir ? (cp2 - 1) : cp2;
+
+ for (; cp4 > cp1; cp4--) {
+ if (*cp4 == '.') {
+ if ((cp4 - 1 > trndir) && (*(cp4 - 1) != '^')) {
+ memmove(cp4 + 1, cp4, trndir + dirlen - cp4 + 1);
+ *cp4 = '^';
+ dirlen++;
+ }
+ }
+ }
+ }
}
}
@@ -6184,52 +6111,10 @@
/* We've picked up everything up to the directory file name.
Now just add the type and version, and we're set. */
-
- /* We should only add type for VMS syntax, but historically Perl
- has added it for UNIX style also */
-
- /* Fix me - we should not be using the same routine for VMS and
- UNIX format files. Things are too tangled so we need to lookup
- what syntax the output is */
-
- is_unix = 0;
- is_vms = 0;
- lastdir = strrchr(trndir,'/');
- if (lastdir) {
- is_unix = 1;
- } else {
- lastdir = strpbrk(trndir,"]:>");
- if (lastdir) {
- is_vms = 1;
- }
- }
-
- if ((is_vms == 0) && (is_unix == 0)) {
- /* We still do not know? */
- is_unix = decc_filename_unix_report;
- if (is_unix == 0)
- is_vms = 1;
- }
-
- if ((is_unix && !decc_efs_charset) || is_vms) {
-
- /* It is a bug to add a .dir to a UNIX format directory spec */
- /* However Perl on VMS may have programs that expect this so */
- /* If not using EFS character specifications allow it. */
-
- if ((!decc_efs_case_preserve) && vms_process_case_tolerant) {
- /* Traditionally Perl expects filenames in lower case */
- strcat(buf, ".dir");
- } else {
- /* VMS expects the .DIR to be in upper case */
- strcat(buf, ".DIR");
- }
-
- /* It is also a bug to put a VMS format version on a UNIX file */
- /* specification. Perl self tests are looking for this */
- if (is_vms || !(decc_efs_charset || decc_filename_unix_report))
- strcat(buf, ";1");
- }
+ if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
+ strcat(buf,".dir;1");
+ else
+ strcat(buf,".DIR;1");
PerlMem_free(trndir);
PerlMem_free(vmsdir);
return buf;
@@ -6244,11 +6129,11 @@
rms_setup_nam(savnam);
rms_setup_nam(dirnam);
- esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
+ esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
esal = NULL;
#if !defined(__VAX) && defined(NAML$C_MAXRSS)
- esal = PerlMem_malloc(VMS_MAXRSS);
+ esal = (char *)PerlMem_malloc(VMS_MAXRSS);
if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
#endif
rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
@@ -6344,7 +6229,7 @@
if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
/* They provided at least the name; we added the type, if necessary, */
- strcpy(buf, my_esa);
+ my_strlcpy(buf, my_esa, VMS_MAXRSS);
sts = rms_free_search_context(&dirfab);
PerlMem_free(trndir);
PerlMem_free(esa);
@@ -6389,7 +6274,7 @@
if ((cp1) != NULL) {
/* There's more than one directory in the path. Just roll back. */
*cp1 = term;
- strcpy(buf, my_esa);
+ my_strlcpy(buf, my_esa, VMS_MAXRSS);
}
else {
if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
@@ -6556,10 +6441,10 @@
int len;
len = v_len + r_len + d_len - 1;
char dclose = d_spec[d_len - 1];
- strncpy(buf, dir, len);
+ memcpy(buf, dir, len);
buf[len] = '.';
len++;
- strncpy(&buf[len], n_spec, n_len);
+ memcpy(&buf[len], n_spec, n_len);
len += n_len;
buf[len] = dclose;
buf[len + 1] = '\0';
@@ -6574,20 +6459,33 @@
int len;
len = v_len + r_len + d_len - 1;
char dclose = d_spec[d_len - 1];
- strncpy(buf, dir, len);
+ memcpy(buf, dir, len);
buf[len] = '.';
len++;
- strncpy(&buf[len], n_spec, n_len);
+ memcpy(&buf[len], n_spec, n_len);
len += n_len;
if (e_len > 0) {
if (decc_efs_charset) {
- buf[len] = '^';
- len++;
- strncpy(&buf[len], e_spec, e_len);
- len += e_len;
- } else {
- set_vaxc_errno(RMS$_DIR);
- set_errno(ENOTDIR);
+ if (e_len == 4
+ && (toupper(e_spec[1]) == 'D')
+ && (toupper(e_spec[2]) == 'I')
+ && (toupper(e_spec[3]) == 'R')) {
+
+ /* Corner case: directory spec with invalid version.
+ * Valid would have followed is_dir path above.
+ */
+ SETERRNO(ENOTDIR, RMS$_DIR);
+ return NULL;
+ }
+ else {
+ buf[len] = '^';
+ len++;
+ memcpy(&buf[len], e_spec, e_len);
+ len += e_len;
+ }
+ }
+ else {
+ SETERRNO(ENOTDIR, RMS$_DIR);
return NULL;
}
}
@@ -6638,13 +6536,13 @@
return NULL;
}
- trndir = PerlMem_malloc(VMS_MAXRSS);
+ trndir = (char *)PerlMem_malloc(VMS_MAXRSS);
if (trndir == NULL)
_ckvmssts_noperl(SS$_INSFMEM);
/* If no directory specified use the current default */
if (*dir)
- strcpy(trndir, dir);
+ my_strlcpy(trndir, dir, VMS_MAXRSS);
else {
getcwd(trndir, VMS_MAXRSS - 1);
need_to_lower = 1;
@@ -6662,7 +6560,7 @@
/* Trap simple rooted lnms, and return lnm:[000000] */
if (!strcmp(trndir+trnlen-2,".]")) {
- strcpy(buf, dir);
+ my_strlcpy(buf, dir, VMS_MAXRSS);
strcat(buf, ":[000000]");
PerlMem_free(trndir);
@@ -6716,7 +6614,7 @@
/* Traditional mode, assume .DIR is directory */
buf[0] = '[';
buf[1] = '.';
- strncpy(&buf[2], n_spec, n_len);
+ memcpy(&buf[2], n_spec, n_len);
buf[n_len + 2] = ']';
buf[n_len + 3] = '\0';
PerlMem_free(trndir);
@@ -6749,7 +6647,7 @@
/* Simple way did not work, which means that a logical name */
/* was present for the directory specification. */
/* Need to use an rmsexpand variant to decode it completely */
- exp_spec = PerlMem_malloc(VMS_MAXRSS);
+ exp_spec = (char *)PerlMem_malloc(VMS_MAXRSS);
if (exp_spec == NULL)
_ckvmssts_noperl(SS$_INSFMEM);
@@ -6787,65 +6685,55 @@
return ret_spec;
} else {
- /* Unix specification, Could be trivial conversion */
- STRLEN dir_len;
- dir_len = strlen(trndir);
+ /* Unix specification, Could be trivial conversion, */
+ /* but have to deal with trailing '.dir' or extra '.' */
- /* If the extended file character set is in effect */
- /* then pathify is simple */
+ char * lastdot;
+ char * lastslash;
+ int is_dir;
+ STRLEN dir_len = strlen(trndir);
- if (!decc_efs_charset) {
- /* Have to deal with trailing '.dir' or extra '.' */
- /* that should not be there in legacy mode, but is */
+ lastslash = strrchr(trndir, '/');
+ if (lastslash == NULL)
+ lastslash = trndir;
+ else
+ lastslash++;
- char * lastdot;
- char * lastslash;
- int is_dir;
+ lastdot = NULL;
- lastslash = strrchr(trndir, '/');
- if (lastslash == NULL)
- lastslash = trndir;
- else
- lastslash++;
-
- lastdot = NULL;
-
- /* '..' or '.' are valid directory components */
- is_dir = 0;
- if (lastslash[0] == '.') {
- if (lastslash[1] == '\0') {
- is_dir = 1;
- } else if (lastslash[1] == '.') {
- if (lastslash[2] == '\0') {
+ /* '..' or '.' are valid directory components */
+ is_dir = 0;
+ if (lastslash[0] == '.') {
+ if (lastslash[1] == '\0') {
+ is_dir = 1;
+ } else if (lastslash[1] == '.') {
+ if (lastslash[2] == '\0') {
+ is_dir = 1;
+ } else {
+ /* And finally allow '...' */
+ if ((lastslash[2] == '.') && (lastslash[3] == '\0')) {
is_dir = 1;
- } else {
- /* And finally allow '...' */
- if ((lastslash[2] == '.') && (lastslash[3] == '\0')) {
- is_dir = 1;
- }
}
}
}
+ }
- if (!is_dir) {
- lastdot = strrchr(lastslash, '.');
- }
- if (lastdot != NULL) {
- STRLEN e_len;
+ if (!is_dir) {
+ lastdot = strrchr(lastslash, '.');
+ }
+ if (lastdot != NULL) {
+ STRLEN e_len;
+ /* '.dir' is discarded, and any other '.' is invalid */
+ e_len = strlen(lastdot);
- /* '.dir' is discarded, and any other '.' is invalid */
- e_len = strlen(lastdot);
+ is_dir = is_dir_ext(lastdot, e_len, NULL, 0);
- is_dir = is_dir_ext(lastdot, e_len, NULL, 0);
-
- if (is_dir) {
- dir_len = dir_len - 4;
-
- }
+ if (is_dir) {
+ dir_len = dir_len - 4;
}
}
- strcpy(buf, trndir);
+ my_strlcpy(buf, trndir, VMS_MAXRSS);
if (buf[dir_len - 1] != '/') {
buf[dir_len] = '/';
buf[dir_len + 1] = '\0';
@@ -6962,7 +6850,7 @@
const char *cp2;
int dirlen;
unsigned short int trnlnm_iter_count;
- int cmp_rslt;
+ int cmp_rslt, outchars_added;
if (utf8_fl != NULL)
*utf8_fl = 0;
@@ -6995,10 +6883,9 @@
int tunix_len;
int nl_flag;
- tunix = PerlMem_malloc(VMS_MAXRSS);
+ tunix = (char *)PerlMem_malloc(VMS_MAXRSS);
if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
- strcpy(tunix, spec);
- tunix_len = strlen(tunix);
+ tunix_len = my_strlcpy(tunix, spec, VMS_MAXRSS);
nl_flag = 0;
if (tunix[tunix_len - 1] == '\n') {
tunix[tunix_len - 1] = '\"';
@@ -7009,13 +6896,13 @@
uspec = decc$translate_vms(tunix);
PerlMem_free(tunix);
if ((int)uspec > 0) {
- strcpy(rslt,uspec);
+ my_strlcpy(rslt, uspec, VMS_MAXRSS);
if (nl_flag) {
strcat(rslt,"\n");
}
else {
/* If we can not translate it, makemaker wants as-is */
- strcpy(rslt, spec);
+ my_strlcpy(rslt, spec, VMS_MAXRSS);
}
return rslt;
}
@@ -7054,9 +6941,19 @@
}
}
}
- /* This is already UNIX or at least nothing VMS understands */
+
+ cp1 = rslt;
+ cp2 = spec;
+
+ /* This is already UNIX or at least nothing VMS understands,
+ * so all we can reasonably do is unescape extended chars.
+ */
if (cmp_rslt) {
- strcpy(rslt,spec);
+ while (*cp2) {
+ cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
+ cp1 += outchars_added;
+ }
+ *cp1 = '\0';
if (vms_debug_fileify) {
fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
}
@@ -7063,13 +6960,15 @@
return rslt;
}
- cp1 = rslt;
- cp2 = spec;
dirend = strrchr(spec,']');
if (dirend == NULL) dirend = strrchr(spec,'>');
if (dirend == NULL) dirend = strchr(spec,':');
if (dirend == NULL) {
- strcpy(rslt,spec);
+ while (*cp2) {
+ cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
+ cp1 += outchars_added;
+ }
+ *cp1 = '\0';
if (vms_debug_fileify) {
fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
}
@@ -7077,7 +6976,6 @@
}
/* Special case 1 - sys$posix_root = / */
-#if __CRTL_VER >= 70000000
if (!decc_disable_posix_root) {
if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
*cp1 = '/';
@@ -7085,16 +6983,9 @@
cp2 = cp2 + 15;
}
}
-#endif
/* Special case 2 - Convert NLA0: to /dev/null */
-#if __CRTL_VER < 70000000
- cmp_rslt = strncmp(spec,"NLA0:", 5);
- if (cmp_rslt != 0)
- cmp_rslt = strncmp(spec,"nla0:", 5);
-#else
cmp_rslt = strncasecmp(spec,"NLA0:", 5);
-#endif
if (cmp_rslt == 0) {
strcpy(rslt, "/dev/null");
cp1 = cp1 + 9;
@@ -7107,14 +6998,8 @@
}
/* Also handle special case "SYS$SCRATCH:" */
-#if __CRTL_VER < 70000000
- cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
- if (cmp_rslt != 0)
- cmp_rslt = strncmp(spec,"sys$scratch:", 12);
-#else
cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
-#endif
- tmp = PerlMem_malloc(VMS_MAXRSS);
+ tmp = (char *)PerlMem_malloc(VMS_MAXRSS);
if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
if (cmp_rslt == 0) {
int islnm;
@@ -7177,9 +7062,8 @@
*(cp1++) = '/';
}
if ((*cp2 == '^')) {
- /* EFS file escape, pass the next character as is */
- /* Fix me: HEX encoding for Unicode not implemented */
- cp2++;
+ cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
+ cp1 += outchars_added;
}
else if ( *cp2 == '.') {
if (*(cp2+1) == '.' && *(cp2+2) == '.') {
@@ -7239,8 +7123,7 @@
}
/* Translate the rest of the filename. */
while (*cp2) {
- int dot_seen;
- dot_seen = 0;
+ int dot_seen = 0;
switch(*cp2) {
/* Fixme - for compatibility with the CRTL we should be removing */
/* spaces from the file specifications, but this may show that */
@@ -7250,16 +7133,8 @@
*(cp1++) = '?';
break;
case '^':
- /* Fix me hex expansions not implemented */
- cp2++; /* '^.' --> '.' and other. */
- if (*cp2) {
- if (*cp2 == '_') {
- cp2++;
- *(cp1++) = ' ';
- } else {
- *(cp1++) = *(cp2++);
- }
- }
+ cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
+ cp1 += outchars_added;
break;
case ';':
if (decc_filename_unix_no_version) {
@@ -7429,7 +7304,7 @@
else {
/* This is already a VMS specification, no conversion */
unixlen--;
- strncpy(vmspath,unixpath, vmspath_len);
+ my_strlcpy(vmspath, unixpath, vmspath_len + 1);
}
}
else
@@ -7484,13 +7359,13 @@
vmspath[vmspath_len] = 0;
if (unixpath[unixlen - 1] == '/')
dir_flag = 1;
- esal = PerlMem_malloc(VMS_MAXRSS);
+ esal = (char *)PerlMem_malloc(VMS_MAXRSS);
if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
- esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
+ esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
- rsal = PerlMem_malloc(VMS_MAXRSS);
+ rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
- rsa = PerlMem_malloc(NAM$C_MAXRSS + 1);
+ rsa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
rms_bind_fab_nam(myfab, mynam);
@@ -7541,7 +7416,7 @@
if (strncmp(unixpath,"\"^UP^",5) != 0)
sprintf(vmspath,"\"^UP^%s\"",unixpath);
else
- strcpy(vmspath, unixpath);
+ my_strlcpy(vmspath, unixpath, vmspath_len + 1);
}
else {
vmspath[specdsc.dsc$w_length] = 0;
@@ -7742,21 +7617,20 @@
/* Find the next slash */
nextslash = strchr(unixptr,'/');
- esa = PerlMem_malloc(vmspath_len);
+ esa = (char *)PerlMem_malloc(vmspath_len);
if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
- trn = PerlMem_malloc(VMS_MAXRSS);
+ trn = (char *)PerlMem_malloc(VMS_MAXRSS);
if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
if (nextslash != NULL) {
seg_len = nextslash - unixptr;
- strncpy(esa, unixptr, seg_len);
+ memcpy(esa, unixptr, seg_len);
esa[seg_len] = 0;
}
else {
- strcpy(esa, unixptr);
- seg_len = strlen(unixptr);
+ seg_len = my_strlcpy(esa, unixptr, sizeof(esa));
}
/* trnlnm(section) */
islnm = vmstrnenv(esa, trn, 0, fildev, 0);
@@ -7799,8 +7673,7 @@
if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
/* This must be a directory */
if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
- strcpy(vmsptr, esa);
- vmslen=strlen(vmsptr);
+ vmslen = my_strlcpy(vmsptr, esa, vmspath_len - 1);
vmsptr[vmslen] = ':';
vmslen++;
vmsptr[vmslen] = '\0';
@@ -7817,7 +7690,7 @@
/* transfer the volume */
if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
- strncpy(vmsptr, v_spec, v_len);
+ memcpy(vmsptr, v_spec, v_len);
vmsptr += v_len;
vmsptr[0] = '\0';
vmslen += v_len;
@@ -7840,7 +7713,7 @@
}
}
if (r_len > 0) {
- strncpy(vmsptr, r_spec, r_len);
+ memcpy(vmsptr, r_spec, r_len);
vmsptr += r_len;
vmslen += r_len;
vmsptr[0] = '\0';
@@ -7871,7 +7744,7 @@
d_spec++;
d_len--;
}
- strncpy(vmsptr, d_spec, d_len);
+ memcpy(vmsptr, d_spec, d_len);
vmsptr += d_len;
vmslen += d_len;
vmsptr[0] = '\0';
@@ -7954,7 +7827,7 @@
* here that are a VMS device name or concealed logical name instead.
* So to make things work, this procedure must be tolerant.
*/
- esa = PerlMem_malloc(vmspath_len);
+ esa = (char *)PerlMem_malloc(vmspath_len);
if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
sts = SS$_NORMAL;
@@ -7961,10 +7834,9 @@
nextslash = strchr(&unixptr[1],'/');
seg_len = 0;
if (nextslash != NULL) {
- int cmp;
+ int cmp;
seg_len = nextslash - &unixptr[1];
- strncpy(vmspath, unixptr, seg_len + 1);
- vmspath[seg_len+1] = 0;
+ my_strlcpy(vmspath, unixptr, seg_len + 2);
cmp = 1;
if (seg_len == 3) {
cmp = strncmp(vmspath, "dev", 4);
@@ -7982,8 +7854,7 @@
sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
if ($VMS_STATUS_SUCCESS(sts)) {
- strcpy(vmspath, esa);
- vmslen = strlen(vmspath);
+ vmslen = my_strlcpy(vmspath, esa, vmspath_len + 1);
vmsptr = vmspath + vmslen;
unixptr++;
if (unixptr < lastslash) {
@@ -8028,9 +7899,8 @@
*/
/* Posix to VMS destroyed this, so copy it again */
- strncpy(vmspath, &unixptr[1], seg_len);
- vmspath[seg_len] = 0;
- vmslen = seg_len;
+ my_strlcpy(vmspath, &unixptr[1], seg_len + 1);
+ vmslen = strlen(vmspath); /* We know we're truncating. */
vmsptr = &vmsptr[vmslen];
islnm = 0;
@@ -8379,14 +8249,28 @@
return result;
}
+/* A convenience macro for copying dots in filenames and escaping
+ * them when they haven't already been escaped, with guards to
+ * avoid checking before the start of the buffer or advancing
+ * beyond the end of it (allowing room for the NUL terminator).
+ */
+#define VMSEFS_DOT_WITH_ESCAPE(vmsefsdot,vmsefsbuf,vmsefsbufsiz) STMT_START { \
+ if ( ((vmsefsdot) > (vmsefsbuf) && *((vmsefsdot) - 1) != '^' \
+ || ((vmsefsdot) == (vmsefsbuf))) \
+ && (vmsefsdot) < (vmsefsbuf) + (vmsefsbufsiz) - 3 \
+ ) { \
+ *((vmsefsdot)++) = '^'; \
+ } \
+ if ((vmsefsdot) < (vmsefsbuf) + (vmsefsbufsiz) - 2) \
+ *((vmsefsdot)++) = '.'; \
+} STMT_END
-
/*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
static char *int_tovmsspec
(const char *path, char *rslt, int dir_flag, int * utf8_flag) {
char *dirend;
char *lastdot;
- register char *cp1;
+ char *cp1;
const char *cp2;
unsigned long int infront = 0, hasdir = 1;
int rslt_len;
@@ -8468,7 +8352,7 @@
if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
if (utf8_flag != NULL)
*utf8_flag = 0;
- strcpy(rslt, path);
+ my_strlcpy(rslt, path, VMS_MAXRSS);
if (vms_debug_fileify) {
fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
}
@@ -8489,7 +8373,7 @@
*/
if (utf8_flag != NULL)
*utf8_flag = 0;
- strcpy(rslt, path);
+ my_strlcpy(rslt, path, VMS_MAXRSS);
if (vms_debug_fileify) {
fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
}
@@ -8499,52 +8383,25 @@
dirend = strrchr(path,'/');
if (dirend == NULL) {
- char *macro_start;
- int has_macro;
-
- /* If we get here with no UNIX directory delimiters, then this is
- not a complete file specification, either garbage a UNIX glob
- specification that can not be converted to a VMS wildcard, or
- it a UNIX shell macro. MakeMaker wants shell macros passed
- through AS-IS,
-
- utf8 flag setting needs to be preserved.
+ /* If we get here with no Unix directory delimiters, then this is an
+ * ambiguous file specification, such as a Unix glob specification, a
+ * shell or make macro, or a filespec that would be valid except for
+ * unescaped extended characters. The safest thing if it's a macro
+ * is to pass it through as-is.
*/
- hasdir = 0;
-
- has_macro = 0;
- macro_start = strchr(path,'$');
- if (macro_start != NULL) {
- if (macro_start[1] == '(') {
- has_macro = 1;
- }
- }
- if ((decc_efs_charset == 0) || (has_macro)) {
- strcpy(rslt, path);
+ if (strstr(path, "$(")) {
+ my_strlcpy(rslt, path, VMS_MAXRSS);
if (vms_debug_fileify) {
fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
}
return rslt;
}
+ hasdir = 0;
}
-
-/* If EFS charset mode active, handle the conversion */
-#if __CRTL_VER >= 80200000 && !defined(__VAX)
- if (decc_efs_charset) {
- posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
- if (vms_debug_fileify) {
- fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
- }
- return rslt;
- }
-#endif
-
- if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
+ else if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
if (!*(dirend+2)) dirend +=2;
if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
- if (decc_efs_charset == 0) {
- if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
- }
+ if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
}
cp1 = rslt;
@@ -8572,7 +8429,7 @@
}
while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
*cp1 = '\0';
- trndev = PerlMem_malloc(VMS_MAXRSS);
+ trndev = (char *)PerlMem_malloc(VMS_MAXRSS);
if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
@@ -8624,7 +8481,7 @@
}
else {
if (cp2 != dirend) {
- strcpy(rslt,trndev);
+ my_strlcpy(rslt, trndev, VMS_MAXRSS);
cp1 = rslt + trnend;
if (*cp2 != 0) {
*(cp1++) = '.';
@@ -8640,7 +8497,7 @@
}
PerlMem_free(trndev);
}
- else {
+ else if (hasdir) {
*(cp1++) = '[';
if (*cp2 == '.') {
if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
@@ -8665,10 +8522,13 @@
}
else *(cp1++) = '.';
}
+ else {
+ *(cp1++) = *cp2;
+ }
for (; cp2 < dirend; cp2++) {
if (*cp2 == '/') {
if (*(cp2-1) == '/') continue;
- if (*(cp1-1) != '.') *(cp1++) = '.';
+ if (cp1 > rslt && *(cp1-1) != '.') *(cp1++) = '.';
infront = 0;
}
else if (!infront && *cp2 == '.') {
@@ -8675,15 +8535,10 @@
if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
- if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
- else if (*(cp1-2) == '[') *(cp1-1) = '-';
- else { /* back up over previous directory name */
- cp1--;
- while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
- if (*(cp1-1) == '[') {
- memcpy(cp1,"000000.",7);
- cp1 += 7;
- }
+ if (cp1 > rslt && (*(cp1-1) == '-' || *(cp1-1) == '[')) *(cp1++) = '-'; /* handle "../" */
+ else if (cp1 > rslt + 1 && *(cp1-2) == '[') *(cp1-1) = '-';
+ else {
+ *(cp1++) = '-';
}
cp2 += 2;
if (cp2 == dirend) break;
@@ -8690,7 +8545,7 @@
}
else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
(*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
- if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
+ if (cp1 > rslt && *(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
*(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
if (!*(cp2+3)) {
*(cp1++) = '.'; /* Simulate trailing '/' */
@@ -8699,22 +8554,26 @@
else cp2 += 3; /* Trailing '/' was there, so skip it, too */
}
else {
- if (decc_efs_charset == 0)
+ if (decc_efs_charset == 0) {
+ if (cp1 > rslt && *(cp1-1) == '^')
+ cp1--; /* remove the escape, if any */
*(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
+ }
else {
- *(cp1++) = '^'; /* fix up syntax - '.' in name is allowed */
- *(cp1++) = '.';
+ VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
}
}
}
else {
- if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
+ if (!infront && cp1 > rslt && *(cp1-1) == '-') *(cp1++) = '.';
if (*cp2 == '.') {
- if (decc_efs_charset == 0)
+ if (decc_efs_charset == 0) {
+ if (cp1 > rslt && *(cp1-1) == '^')
+ cp1--; /* remove the escape, if any */
*(cp1++) = '_';
+ }
else {
- *(cp1++) = '^';
- *(cp1++) = '.';
+ VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
}
}
else *(cp1++) = *cp2;
@@ -8721,7 +8580,7 @@
infront = 1;
}
}
- if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
+ if (cp1 > rslt && *(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
if (hasdir) *(cp1++) = ']';
if (*cp2) cp2++; /* check in case we ended with trailing '..' */
/* fixme for ODS5 */
@@ -8737,7 +8596,8 @@
*(cp1++) = '?';
cp2++;
case ' ':
- *(cp1)++ = '^';
+ if (cp2 > path && *(cp2-1) != '^') /* not previously escaped */
+ *(cp1)++ = '^';
*(cp1)++ = '_';
cp2++;
break;
@@ -8744,8 +8604,7 @@
case '.':
if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
decc_readdir_dropdotnotype) {
- *(cp1)++ = '^';
- *(cp1)++ = '.';
+ VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
cp2++;
/* trailing dot ==> '^..' on VMS */
@@ -8822,7 +8681,8 @@
case '|':
case '<':
case '>':
- *(cp1++) = '^';
+ if (cp2 > path && *(cp2-1) != '^') /* not previously escaped */
+ *(cp1++) = '^';
*(cp1++) = *(cp2++);
break;
case ';':
@@ -8914,7 +8774,7 @@
if (path == NULL)
return NULL;
- pathified = PerlMem_malloc(VMS_MAXRSS);
+ pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
if (pathified == NULL)
_ckvmssts_noperl(SS$_INSFMEM);
@@ -8939,7 +8799,7 @@
char *pathified, *vmsified, *cp;
if (path == NULL) return NULL;
- pathified = PerlMem_malloc(VMS_MAXRSS);
+ pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
if (int_pathify_dirspec(path, pathified) == NULL) {
PerlMem_free(pathified);
@@ -8967,7 +8827,7 @@
return cp;
}
else {
- strcpy(__tovmspath_retbuf,vmsified);
+ my_strlcpy(__tovmspath_retbuf, vmsified, sizeof(__tovmspath_retbuf));
Safefree(vmsified);
return __tovmspath_retbuf;
}
@@ -8992,7 +8852,7 @@
char *pathified, *unixified, *cp;
if (path == NULL) return NULL;
- pathified = PerlMem_malloc(VMS_MAXRSS);
+ pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
if (int_pathify_dirspec(path, pathified) == NULL) {
PerlMem_free(pathified);
@@ -9021,7 +8881,7 @@
return cp;
}
else {
- strcpy(__tounixpath_retbuf,unixified);
+ my_strlcpy(__tounixpath_retbuf, unixified, sizeof(__tounixpath_retbuf));
Safefree(unixified);
return __tounixpath_retbuf;
}
@@ -9297,12 +9157,12 @@
fprintf(stderr,"Can't open output file %s as stdout",out);
exit(vaxc$errno);
}
- if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
+ if (out != NULL) vmssetuserlnm("SYS$OUTPUT", out);
if (err != NULL) {
if (strcmp(err,"&1") == 0) {
dup2(fileno(stdout), fileno(stderr));
- Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
+ vmssetuserlnm("SYS$ERROR", "SYS$OUTPUT");
} else {
FILE *tmperr;
if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
@@ -9315,7 +9175,7 @@
{
exit(vaxc$errno);
}
- Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
+ vmssetuserlnm("SYS$ERROR", err);
}
}
#ifdef ARGPROC_DEBUG
@@ -9400,7 +9260,7 @@
resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
resultspec.dsc$b_class = DSC$K_CLASS_D;
resultspec.dsc$a_pointer = NULL;
- vmsspec = PerlMem_malloc(VMS_MAXRSS);
+ vmsspec = (char *)PerlMem_malloc(VMS_MAXRSS);
if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
if ((isunix = (int) strchr(item,'/')) != (int) NULL)
filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
@@ -9424,10 +9284,9 @@
char *string;
char *c;
- string = PerlMem_malloc(resultspec.dsc$w_length+1);
+ string = (char *)PerlMem_malloc(resultspec.dsc$w_length+1);
if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
- strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
- string[resultspec.dsc$w_length] = '\0';
+ my_strlcpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length+1);
if (NULL == had_version)
*(strrchr(string, ';')) = '\0';
if ((!had_directory) && (had_device == NULL))
@@ -9434,7 +9293,7 @@
{
if (NULL == (devdir = strrchr(string, ']')))
devdir = strrchr(string, '>');
- strcpy(string, devdir + 1);
+ my_strlcpy(string, devdir + 1, resultspec.dsc$w_length+1);
}
/*
* Be consistent with what the C RTL has already done to the rest of
@@ -9479,7 +9338,7 @@
static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
-static unsigned long int exit_handler(int *status)
+static unsigned long int exit_handler(void)
{
short iosb[4];
@@ -9580,14 +9439,12 @@
unsigned long int flags = 17, one = 1, retsts;
int len;
- strcat(command, argv[0]);
- len = strlen(command);
+ len = my_strlcat(command, argv[0], sizeof(command));
while (--argc && (len < MAX_DCL_SYMBOL))
{
- strcat(command, " \"");
- strcat(command, *(++argv));
- strcat(command, "\"");
- len = strlen(command);
+ my_strlcat(command, " \"", sizeof(command));
+ my_strlcat(command, *(++argv), sizeof(command));
+ len = my_strlcat(command, "\"", sizeof(command));
}
value.dsc$a_pointer = command;
value.dsc$w_length = strlen(value.dsc$a_pointer);
@@ -9712,7 +9569,7 @@
_ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
_ckvmssts_noperl(iosb[0]);
}
- mask = jpilist[1].bufadr;
+ mask = (unsigned long int *)jpilist[1].bufadr;
/* Check attribute flags for each identifier (2nd longword); protected
* subsystem identifiers trigger tainting.
*/
@@ -9761,7 +9618,7 @@
newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
newargv[0] = oldargv[0];
- newargv[1] = PerlMem_malloc(3 * sizeof(char));
+ newargv[1] = (char *)PerlMem_malloc(3 * sizeof(char));
if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
strcpy(newargv[1], "-T");
Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
@@ -9840,15 +9697,14 @@
int
Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
{
- char *unixified, *unixwild,
- *template, *base, *end, *cp1, *cp2;
- register int tmplen, reslen = 0, dirs = 0;
+ char *unixified, *unixwild, *tplate, *base, *end, *cp1, *cp2;
+ int tmplen, reslen = 0, dirs = 0;
if (!wildspec || !fspec) return 0;
- unixwild = PerlMem_malloc(VMS_MAXRSS);
+ unixwild = (char *)PerlMem_malloc(VMS_MAXRSS);
if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
- template = unixwild;
+ tplate = unixwild;
if (strpbrk(wildspec,"]>:") != NULL) {
if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
PerlMem_free(unixwild);
@@ -9856,10 +9712,9 @@
}
}
else {
- strncpy(unixwild, wildspec, VMS_MAXRSS-1);
- unixwild[VMS_MAXRSS-1] = 0;
+ my_strlcpy(unixwild, wildspec, VMS_MAXRSS);
}
- unixified = PerlMem_malloc(VMS_MAXRSS);
+ unixified = (char *)PerlMem_malloc(VMS_MAXRSS);
if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
if (strpbrk(fspec,"]>:") != NULL) {
if (int_tounixspec(fspec, unixified, NULL) == NULL) {
@@ -9875,7 +9730,7 @@
else base = fspec;
/* No prefix or absolute path on wildcard, so nothing to remove */
- if (!*template || *template == '/') {
+ if (!*tplate || *tplate == '/') {
PerlMem_free(unixwild);
if (base == fspec) {
PerlMem_free(unixified);
@@ -9893,8 +9748,8 @@
}
for (end = base; *end; end++) ; /* Find end of resultant filespec */
- if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
- for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
+ if ((cp1 = strstr(tplate,".../")) == NULL) { /* No ...; just count elts */
+ for (cp1 = tplate; *cp1; cp1++) if (*cp1 == '/') dirs++;
for (cp1 = end ;cp1 >= base; cp1--)
if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
{ cp1++; break; }
@@ -9913,9 +9768,9 @@
while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
totells = ells;
for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
- tpl = PerlMem_malloc(VMS_MAXRSS);
+ tpl = (char *)PerlMem_malloc(VMS_MAXRSS);
if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
- if (ellipsis == template && opts & 1) {
+ if (ellipsis == tplate && opts & 1) {
/* Template begins with an ellipsis. Since we can't tell how many
* directory names at the front of the resultant to keep for an
* arbitrary starting point, we arbitrarily choose the current
@@ -9949,9 +9804,9 @@
for (front = end ; front >= base; front--)
if (*front == '/' && !dirs--) { front++; break; }
}
- lcres = PerlMem_malloc(VMS_MAXRSS);
+ lcres = (char *)PerlMem_malloc(VMS_MAXRSS);
if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
- for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
+ for (cp1=tplate,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
cp1++,cp2++) {
if (!decc_efs_case_preserve) {
*cp2 = _tolower(*cp1); /* Make lc copy for match */
@@ -9972,10 +9827,10 @@
lcfront = lcres + (front - base);
/* Now skip over each ellipsis and try to match the path in front of it. */
while (ells--) {
- for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
+ for (cp1 = ellipsis - 2; cp1 >= tplate; cp1--)
if (*(cp1) == '.' && *(cp1+1) == '.' &&
*(cp1+2) == '.' && *(cp1+3) == '/' ) break;
- if (cp1 < template) break; /* template started with an ellipsis */
+ if (cp1 < tplate) break; /* template started with an ellipsis */
if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
ellipsis = cp1; continue;
}
@@ -10131,12 +9986,12 @@
dd->context = 0;
dd->count = 0;
dd->flags = 0;
- /* By saying we always want the result of readdir() in unix format, we
- * are really saying we want all the escapes removed. Otherwise the caller,
- * having no way to know whether it's already in VMS format, might send it
- * through tovmsspec again, thus double escaping.
+ /* By saying we want the result of readdir() in unix format, we are really
+ * saying we want all the escapes removed, translating characters that
+ * must be escaped in a VMS-format name to their unescaped form, which is
+ * presumably allowed in a Unix-format name.
*/
- dd->flags = PERL_VMSDIR_M_UNIXSPECS;
+ dd->flags = decc_filename_unix_report ? PERL_VMSDIR_M_UNIXSPECS : 0;
dd->pat.dsc$a_pointer = dd->pattern;
dd->pat.dsc$w_length = strlen(dd->pattern);
dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
@@ -10204,7 +10059,7 @@
/* Add the version wildcard, ignoring the "*.*" put on before */
i = strlen(dd->pattern);
Newx(text,i + e->d_namlen + 3,char);
- strcpy(text, dd->pattern);
+ my_strlcpy(text, dd->pattern, i + 1);
sprintf(&text[i - 3], "%s;*", e->d_name);
/* Set up the pattern descriptor. */
@@ -10274,20 +10129,23 @@
tmpsts = lib$find_file
(&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
- if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
+ if (dd->context == 0)
+ tmpsts = RMS$_NMF; /* None left. (should be set, but make sure) */
+
if (!(tmpsts & 1)) {
- set_vaxc_errno(tmpsts);
switch (tmpsts) {
+ case RMS$_NMF:
+ break; /* no more files considered success */
case RMS$_PRV:
- set_errno(EACCES); break;
+ SETERRNO(EACCES, tmpsts); break;
case RMS$_DEV:
- set_errno(ENODEV); break;
+ SETERRNO(ENODEV, tmpsts); break;
case RMS$_DIR:
- set_errno(ENOTDIR); break;
+ SETERRNO(ENOTDIR, tmpsts); break;
case RMS$_FNF: case RMS$_DNF:
- set_errno(ENOENT); break;
+ SETERRNO(ENOENT, tmpsts); break;
default:
- set_errno(EVMSERR);
+ SETERRNO(EVMSERR, tmpsts);
}
Safefree(buff);
return NULL;
@@ -10322,7 +10180,7 @@
/* In Unix report mode, remove the ".dir;1" from the name */
/* if it is a real directory. */
- if (decc_filename_unix_report || decc_efs_charset) {
+ if (decc_filename_unix_report && decc_efs_charset) {
if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
Stat_t statbuf;
int ret_sts;
@@ -10342,9 +10200,9 @@
}
}
- strncpy(dd->entry.d_name, n_spec, n_len + e_len);
+ memcpy(dd->entry.d_name, n_spec, n_len + e_len);
dd->entry.d_name[n_len + e_len] = '\0';
- dd->entry.d_namlen = strlen(dd->entry.d_name);
+ dd->entry.d_namlen = n_len + e_len;
/* Convert the filename to UNIX format if needed */
if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
@@ -10367,8 +10225,7 @@
/* counted strings apparently with a Unicode flag */
}
*q = 0;
- strcpy(dd->entry.d_name, new_name);
- dd->entry.d_namlen = strlen(dd->entry.d_name);
+ dd->entry.d_namlen = my_strlcpy(dd->entry.d_name, new_name, sizeof(dd->entry.d_name));
}
}
@@ -10473,9 +10330,9 @@
static int vfork_called;
-/*{{{int my_vfork()*/
+/*{{{int my_vfork(void)*/
int
-my_vfork()
+my_vfork(void)
{
vfork_called++;
return vfork();
@@ -10498,9 +10355,9 @@
setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
{
char *junk, *tmps = NULL;
- register size_t cmdlen = 0;
+ size_t cmdlen = 0;
size_t rlen;
- register SV **idx;
+ SV **idx;
STRLEN n_a;
idx = mark;
@@ -10521,7 +10378,7 @@
Newx(PL_Cmd, cmdlen+1, char);
if (tmps && *tmps) {
- strcpy(PL_Cmd,tmps);
+ my_strlcpy(PL_Cmd, tmps, cmdlen + 1);
mark++;
}
else *PL_Cmd = '\0';
@@ -10529,8 +10386,8 @@
if (*mark) {
char *s = SvPVx(*mark,n_a);
if (!*s) continue;
- if (*PL_Cmd) strcat(PL_Cmd," ");
- strcat(PL_Cmd,s);
+ if (*PL_Cmd) my_strlcat(PL_Cmd, " ", cmdlen+1);
+ my_strlcat(PL_Cmd, s, cmdlen+1);
}
}
return PL_Cmd;
@@ -10552,29 +10409,28 @@
struct dsc$descriptor_s *vmscmd;
struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
- register char *s, *rest, *cp, *wordbreak;
+ char *s, *rest, *cp, *wordbreak;
char * cmd;
int cmdlen;
- register int isdcl;
+ int isdcl;
- vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
+ vmscmd = (struct dsc$descriptor_s *)PerlMem_malloc(sizeof(struct dsc$descriptor_s));
if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
/* vmsspec is a DCL command buffer, not just a filename */
- vmsspec = PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
+ vmsspec = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
if (vmsspec == NULL)
_ckvmssts_noperl(SS$_INSFMEM);
- resspec = PerlMem_malloc(VMS_MAXRSS);
+ resspec = (char *)PerlMem_malloc(VMS_MAXRSS);
if (resspec == NULL)
_ckvmssts_noperl(SS$_INSFMEM);
/* Make a copy for modification */
cmdlen = strlen(incmd);
- cmd = PerlMem_malloc(cmdlen+1);
+ cmd = (char *)PerlMem_malloc(cmdlen+1);
if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
- strncpy(cmd, incmd, cmdlen);
- cmd[cmdlen] = 0;
+ my_strlcpy(cmd, incmd, cmdlen + 1);
image_name[0] = 0;
image_argv[0] = 0;
@@ -10607,6 +10463,68 @@
for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
}
else { cp = vmsspec; rest = s; }
+
+ /* If the first word is quoted, then we need to unquote it and
+ * escape spaces within it. We'll expand into the resspec buffer,
+ * then copy back into the cmd buffer, expanding the latter if
+ * necessary.
+ */
+ if (*rest == '"') {
+ char *cp2;
+ char *r = rest;
+ bool in_quote = 0;
+ int clen = cmdlen;
+ int soff = s - cmd;
+
+ for (cp2 = resspec;
+ *rest && cp2 - resspec < (VMS_MAXRSS - 1);
+ rest++) {
+
+ if (*rest == ' ') { /* Escape ' ' to '^_'. */
+ *cp2 = '^';
+ *(++cp2) = '_';
+ cp2++;
+ clen++;
+ }
+ else if (*rest == '"') {
+ clen--;
+ if (in_quote) { /* Must be closing quote. */
+ rest++;
+ break;
+ }
+ in_quote = 1;
+ }
+ else {
+ *cp2 = *rest;
+ cp2++;
+ }
+ }
+ *cp2 = '\0';
+
+ /* Expand the command buffer if necessary. */
+ if (clen > cmdlen) {
+ cmd = (char *)PerlMem_realloc(cmd, clen);
+ if (cmd == NULL)
+ _ckvmssts_noperl(SS$_INSFMEM);
+ /* Where we are may have changed, so recompute offsets */
+ r = cmd + (r - s - soff);
+ rest = cmd + (rest - s - soff);
+ s = cmd + soff;
+ }
+
+ /* Shift the non-verb portion of the command (if any) up or
+ * down as necessary.
+ */
+ if (*rest)
+ memmove(rest + clen - cmdlen, rest, s - soff + cmdlen - rest);
+
+ /* Copy the unquoted and escaped command verb into place. */
+ memcpy(r, resspec, cp2 - resspec);
+ cmd[clen] = '\0';
+ cmdlen = clen;
+ rest = r; /* Rewind for subsequent operations. */
+ }
+
if (*rest == '.' || *rest == '/') {
char *cp2;
for (cp2 = resspec;
@@ -10647,7 +10565,7 @@
isdcl = 1;
if (suggest_quote) *suggest_quote = 1;
} else {
- register char *filespec = strpbrk(s,":<[.;");
+ char *filespec = strpbrk(s,":<[.;");
rest = wordbreak = strpbrk(s," \"\t/");
if (!wordbreak) wordbreak = s + strlen(s);
if (*s == '$') check_img = 0;
@@ -10783,7 +10701,7 @@
else {
tchr = tmpspec;
}
- strcpy(image_name, tchr);
+ my_strlcpy(image_name, tchr, sizeof(image_name));
}
}
}
@@ -10799,25 +10717,25 @@
}
if (cando_by_name(S_IXUSR,0,resspec)) {
- vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
+ vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH);
if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
if (!isdcl) {
- strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
+ my_strlcpy(vmscmd->dsc$a_pointer,"$ MCR ", MAX_DCL_LINE_LENGTH);
if (image_name[0] != 0) {
- strcat(vmscmd->dsc$a_pointer, image_name);
- strcat(vmscmd->dsc$a_pointer, " ");
+ my_strlcat(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
+ my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
}
} else if (image_name[0] != 0) {
- strcpy(vmscmd->dsc$a_pointer, image_name);
- strcat(vmscmd->dsc$a_pointer, " ");
+ my_strlcpy(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
+ my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
} else {
- strcpy(vmscmd->dsc$a_pointer,"@");
+ my_strlcpy(vmscmd->dsc$a_pointer, "@", MAX_DCL_LINE_LENGTH);
}
if (suggest_quote) *suggest_quote = 1;
/* If there is an image name, use original command */
if (image_name[0] == 0)
- strcat(vmscmd->dsc$a_pointer,resspec);
+ my_strlcat(vmscmd->dsc$a_pointer, resspec, MAX_DCL_LINE_LENGTH);
else {
rest = cmd;
while (*rest && isspace(*rest)) rest++;
@@ -10824,8 +10742,8 @@
}
if (image_argv[0] != 0) {
- strcat(vmscmd->dsc$a_pointer,image_argv);
- strcat(vmscmd->dsc$a_pointer, " ");
+ my_strlcat(vmscmd->dsc$a_pointer, image_argv, MAX_DCL_LINE_LENGTH);
+ my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
}
if (rest) {
int rest_len;
@@ -10834,7 +10752,7 @@
rest_len = strlen(rest);
vmscmd_len = strlen(vmscmd->dsc$a_pointer);
if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
- strcat(vmscmd->dsc$a_pointer,rest);
+ my_strlcat(vmscmd->dsc$a_pointer, rest, MAX_DCL_LINE_LENGTH);
else
retsts = CLI$_BUFOVF;
}
@@ -10851,9 +10769,8 @@
/* It's either a DCL command or we couldn't find a suitable image */
vmscmd->dsc$w_length = strlen(cmd);
- vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
- strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
- vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
+ vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(vmscmd->dsc$w_length + 1);
+ my_strlcpy(vmscmd->dsc$a_pointer, cmd, vmscmd->dsc$w_length + 1);
PerlMem_free(cmd);
PerlMem_free(resspec);
@@ -11139,10 +11056,10 @@
int
my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
{
- register char *cp, *end, *cpd;
+ char *cp, *end, *cpd;
char *data;
- register unsigned int fd = fileno(dest);
- register unsigned int fdoff = fd / sizeof(unsigned int);
+ unsigned int fd = fileno(dest);
+ unsigned int fdoff = fd / sizeof(unsigned int);
int retval;
int bufsize = itmsz * nitm + 1;
@@ -11216,8 +11133,8 @@
}
/* Convert this to Unix format */
- vms_name = PerlMem_malloc(VMS_MAXRSS + 1);
- strcpy(vms_name, retname);
+ vms_name = (char *)PerlMem_malloc(VMS_MAXRSS);
+ my_strlcpy(vms_name, retname, VMS_MAXRSS);
retname = int_tounixspec(vms_name, buf, NULL);
PerlMem_free(vms_name);
@@ -11357,7 +11274,7 @@
if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
}
else
- strcpy(pwd->pw_unixdir, pwd->pw_dir);
+ my_strlcpy(pwd->pw_unixdir, pwd->pw_dir, sizeof(pwd->pw_unixdir));
if (!decc_efs_case_preserve)
__mystrtolower(pwd->pw_unixdir);
return 1;
@@ -11393,8 +11310,7 @@
else { _ckvmssts(sts); }
}
}
- strncpy(__pw_namecache, name, sizeof(__pw_namecache));
- __pw_namecache[sizeof __pw_namecache - 1] = '\0';
+ my_strlcpy(__pw_namecache, name, sizeof(__pw_namecache));
__pwdcache.pw_name= __pw_namecache;
return &__pwdcache;
} /* end of my_getpwnam() */
@@ -11479,105 +11395,6 @@
}
/*}}}*/
-#ifdef HOMEGROWN_POSIX_SIGNALS
- /* Signal handling routines, pulled into the core from POSIX.xs.
- *
- * We need these for threads, so they've been rolled into the core,
- * rather than left in POSIX.xs.
- *
- * (DRS, Oct 23, 1997)
- */
-
- /* sigset_t is atomic under VMS, so these routines are easy */
-/*{{{int my_sigemptyset(sigset_t *) */
-int my_sigemptyset(sigset_t *set) {
- if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
- *set = 0; return 0;
-}
-/*}}}*/
-
-
-/*{{{int my_sigfillset(sigset_t *)*/
-int my_sigfillset(sigset_t *set) {
- int i;
- if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
- for (i = 0; i < NSIG; i++) *set |= (1 << i);
- return 0;
-}
-/*}}}*/
-
-
-/*{{{int my_sigaddset(sigset_t *set, int sig)*/
-int my_sigaddset(sigset_t *set, int sig) {
- if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
- if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
- *set |= (1 << (sig - 1));
- return 0;
-}
-/*}}}*/
-
-
-/*{{{int my_sigdelset(sigset_t *set, int sig)*/
-int my_sigdelset(sigset_t *set, int sig) {
- if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
- if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
- *set &= ~(1 << (sig - 1));
- return 0;
-}
-/*}}}*/
-
-
-/*{{{int my_sigismember(sigset_t *set, int sig)*/
-int my_sigismember(sigset_t *set, int sig) {
- if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
- if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
- return *set & (1 << (sig - 1));
-}
-/*}}}*/
-
-
-/*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
-int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
- sigset_t tempmask;
-
- /* If set and oset are both null, then things are badly wrong. Bail out. */
- if ((oset == NULL) && (set == NULL)) {
- set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
- return -1;
- }
-
- /* If set's null, then we're just handling a fetch. */
- if (set == NULL) {
- tempmask = sigblock(0);
- }
- else {
- switch (how) {
- case SIG_SETMASK:
- tempmask = sigsetmask(*set);
- break;
- case SIG_BLOCK:
- tempmask = sigblock(*set);
- break;
- case SIG_UNBLOCK:
- tempmask = sigblock(0);
- sigsetmask(*oset & ~tempmask);
- break;
- default:
- set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
- return -1;
- }
- }
-
- /* Did they pass us an oset? If so, stick our holding mask into it */
- if (oset)
- *oset = tempmask;
-
- return 0;
-}
-/*}}}*/
-#endif /* HOMEGROWN_POSIX_SIGNALS */
-
-
/* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
* my_utime(), and flex_stat(), all of which operate on UTC unless
* VMSISH_TIMES is true.
@@ -11598,31 +11415,10 @@
#undef time
-/*
- * DEC C previous to 6.0 corrupts the behavior of the /prefix
- * qualifier with the extern prefix pragma. This provisional
- * hack circumvents this prefix pragma problem in previous
- * precompilers.
- */
-#if defined(__VMS_VER) && __VMS_VER >= 70000000
-# if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
-# pragma __extern_prefix save
-# pragma __extern_prefix "" /* set to empty to prevent prefixing */
-# define gmtime decc$__utctz_gmtime
-# define localtime decc$__utctz_localtime
-# define time decc$__utc_time
-# pragma __extern_prefix restore
-
- struct tm *gmtime(), *localtime();
-
-# endif
-#endif
-
-
static time_t toutc_dst(time_t loc) {
struct tm *rsltmp;
- if ((rsltmp = localtime(&loc)) == NULL) return -1;
+ if ((rsltmp = localtime(&loc)) == NULL) return -1u;
loc -= utc_offset_secs;
if (rsltmp->tm_isdst) loc -= 3600;
return loc;
@@ -11636,7 +11432,7 @@
struct tm *rsltmp;
utc += utc_offset_secs;
- if ((rsltmp = localtime(&utc)) == NULL) return -1;
+ if ((rsltmp = localtime(&utc)) == NULL) return -1u;
if (rsltmp->tm_isdst) utc += 3600;
return utc;
}
@@ -11645,290 +11441,6 @@
(gmtime_emulation_type == 1 ? toloc_dst(secs) : \
((secs) + utc_offset_secs))))
-#ifndef RTL_USES_UTC
-/*
-
- ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
- DST starts on 1st sun of april at 02:00 std time
- ends on last sun of october at 02:00 dst time
- see the UCX management command reference, SET CONFIG TIMEZONE
- for formatting info.
-
- No, it's not as general as it should be, but then again, NOTHING
- will handle UK times in a sensible way.
-*/
-
-
-/*
- parse the DST start/end info:
- (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
-*/
-
-static char *
-tz_parse_startend(char *s, struct tm *w, int *past)
-{
- int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
- int ly, dozjd, d, m, n, hour, min, sec, j, k;
- time_t g;
-
- if (!s) return 0;
- if (!w) return 0;
- if (!past) return 0;
-
- ly = 0;
- if (w->tm_year % 4 == 0) ly = 1;
- if (w->tm_year % 100 == 0) ly = 0;
- if (w->tm_year+1900 % 400 == 0) ly = 1;
- if (ly) dinm[1]++;
-
- dozjd = isdigit(*s);
- if (*s == 'J' || *s == 'j' || dozjd) {
- if (!dozjd && !isdigit(*++s)) return 0;
- d = *s++ - '0';
- if (isdigit(*s)) {
- d = d*10 + *s++ - '0';
- if (isdigit(*s)) {
- d = d*10 + *s++ - '0';
- }
- }
- if (d == 0) return 0;
- if (d > 366) return 0;
- d--;
- if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
- g = d * 86400;
- dozjd = 1;
- } else if (*s == 'M' || *s == 'm') {
- if (!isdigit(*++s)) return 0;
- m = *s++ - '0';
- if (isdigit(*s)) m = 10*m + *s++ - '0';
- if (*s != '.') return 0;
- if (!isdigit(*++s)) return 0;
- n = *s++ - '0';
- if (n < 1 || n > 5) return 0;
- if (*s != '.') return 0;
- if (!isdigit(*++s)) return 0;
- d = *s++ - '0';
- if (d > 6) return 0;
- }
-
- if (*s == '/') {
- if (!isdigit(*++s)) return 0;
- hour = *s++ - '0';
- if (isdigit(*s)) hour = 10*hour + *s++ - '0';
- if (*s == ':') {
- if (!isdigit(*++s)) return 0;
- min = *s++ - '0';
- if (isdigit(*s)) min = 10*min + *s++ - '0';
- if (*s == ':') {
- if (!isdigit(*++s)) return 0;
- sec = *s++ - '0';
- if (isdigit(*s)) sec = 10*sec + *s++ - '0';
- }
- }
- } else {
- hour = 2;
- min = 0;
- sec = 0;
- }
-
- if (dozjd) {
- if (w->tm_yday < d) goto before;
- if (w->tm_yday > d) goto after;
- } else {
- if (w->tm_mon+1 < m) goto before;
- if (w->tm_mon+1 > m) goto after;
-
- j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
- k = d - j; /* mday of first d */
- if (k <= 0) k += 7;
- k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
- if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
- if (w->tm_mday < k) goto before;
- if (w->tm_mday > k) goto after;
- }
-
- if (w->tm_hour < hour) goto before;
- if (w->tm_hour > hour) goto after;
- if (w->tm_min < min) goto before;
- if (w->tm_min > min) goto after;
- if (w->tm_sec < sec) goto before;
- goto after;
-
-before:
- *past = 0;
- return s;
-after:
- *past = 1;
- return s;
-}
-
-
-
-
-/* parse the offset: (+|-)hh[:mm[:ss]] */
-
-static char *
-tz_parse_offset(char *s, int *offset)
-{
- int hour = 0, min = 0, sec = 0;
- int neg = 0;
- if (!s) return 0;
- if (!offset) return 0;
-
- if (*s == '-') {neg++; s++;}
- if (*s == '+') s++;
- if (!isdigit(*s)) return 0;
- hour = *s++ - '0';
- if (isdigit(*s)) hour = hour*10+(*s++ - '0');
- if (hour > 24) return 0;
- if (*s == ':') {
- if (!isdigit(*++s)) return 0;
- min = *s++ - '0';
- if (isdigit(*s)) min = min*10 + (*s++ - '0');
- if (min > 59) return 0;
- if (*s == ':') {
- if (!isdigit(*++s)) return 0;
- sec = *s++ - '0';
- if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
- if (sec > 59) return 0;
- }
- }
-
- *offset = (hour*60+min)*60 + sec;
- if (neg) *offset = -*offset;
- return s;
-}
-
-/*
- input time is w, whatever type of time the CRTL localtime() uses.
- sets dst, the zone, and the gmtoff (seconds)
-
- caches the value of TZ and UCX$TZ env variables; note that
- my_setenv looks for these and sets a flag if they're changed
- for efficiency.
-
- We have to watch out for the "australian" case (dst starts in
- october, ends in april)...flagged by "reverse" and checked by
- scanning through the months of the previous year.
-
-*/
-
-static int
-tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
-{
- time_t when;
- struct tm *w2;
- char *s,*s2;
- char *dstzone, *tz, *s_start, *s_end;
- int std_off, dst_off, isdst;
- int y, dststart, dstend;
- static char envtz[1025]; /* longer than any logical, symbol, ... */
- static char ucxtz[1025];
- static char reversed = 0;
-
- if (!w) return 0;
-
- if (tz_updated) {
- tz_updated = 0;
- reversed = -1; /* flag need to check */
- envtz[0] = ucxtz[0] = '\0';
- tz = my_getenv("TZ",0);
- if (tz) strcpy(envtz, tz);
- tz = my_getenv("UCX$TZ",0);
- if (tz) strcpy(ucxtz, tz);
- if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
- }
- tz = envtz;
- if (!*tz) tz = ucxtz;
-
- s = tz;
- while (isalpha(*s)) s++;
- s = tz_parse_offset(s, &std_off);
- if (!s) return 0;
- if (!*s) { /* no DST, hurray we're done! */
- isdst = 0;
- goto done;
- }
-
- dstzone = s;
- while (isalpha(*s)) s++;
- s2 = tz_parse_offset(s, &dst_off);
- if (s2) {
- s = s2;
- } else {
- dst_off = std_off - 3600;
- }
-
- if (!*s) { /* default dst start/end?? */
- if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
- s = strchr(ucxtz,',');
- }
- if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
- }
- if (*s != ',') return 0;
-
- when = *w;
- when = _toutc(when); /* convert to utc */
- when = when - std_off; /* convert to pseudolocal time*/
-
- w2 = localtime(&when);
- y = w2->tm_year;
- s_start = s+1;
- s = tz_parse_startend(s_start,w2,&dststart);
- if (!s) return 0;
- if (*s != ',') return 0;
-
- when = *w;
- when = _toutc(when); /* convert to utc */
- when = when - dst_off; /* convert to pseudolocal time*/
- w2 = localtime(&when);
- if (w2->tm_year != y) { /* spans a year, just check one time */
- when += dst_off - std_off;
- w2 = localtime(&when);
- }
- s_end = s+1;
- s = tz_parse_startend(s_end,w2,&dstend);
- if (!s) return 0;
-
- if (reversed == -1) { /* need to check if start later than end */
- int j, ds, de;
-
- when = *w;
- if (when < 2*365*86400) {
- when += 2*365*86400;
- } else {
- when -= 365*86400;
- }
- w2 =localtime(&when);
- when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
-
- for (j = 0; j < 12; j++) {
- w2 =localtime(&when);
- tz_parse_startend(s_start,w2,&ds);
- tz_parse_startend(s_end,w2,&de);
- if (ds != de) break;
- when += 30*86400;
- }
- reversed = 0;
- if (de && !ds) reversed = 1;
- }
-
- isdst = dststart && !dstend;
- if (reversed) isdst = dststart || !dstend;
-
-done:
- if (dst) *dst = isdst;
- if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
- if (isdst) tz = dstzone;
- if (zone) {
- while(isalpha(*tz)) *zone++ = *tz++;
- *zone = '\0';
- }
- return 1;
-}
-
-#endif /* !RTL_USES_UTC */
-
/* my_time(), my_localtime(), my_gmtime()
* By default traffic in UTC time values, using CRTL gmtime() or
* SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
@@ -11977,12 +11489,8 @@
when = time(NULL);
# ifdef VMSISH_TIME
-# ifdef RTL_USES_UTC
if (VMSISH_TIME) when = _toloc(when);
-# else
- if (!VMSISH_TIME) when = _toutc(when);
# endif
-# endif
if (timep != NULL) *timep = when;
return when;
@@ -12007,14 +11515,7 @@
# ifdef VMSISH_TIME
if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
# endif
-# ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
return gmtime(&when);
-# else
- /* CRTL localtime() wants local time as input, so does no tz correction */
- rsltmp = localtime(&when);
- if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
- return rsltmp;
-#endif
} /* end of my_gmtime() */
/*}}}*/
@@ -12023,9 +11524,7 @@
struct tm *
Perl_my_localtime(pTHX_ const time_t *timep)
{
- time_t when, whenutc;
- struct tm *rsltmp;
- int dst, offset;
+ time_t when;
if (timep == NULL) {
set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
@@ -12035,31 +11534,11 @@
if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
when = *timep;
-# ifdef RTL_USES_UTC
# ifdef VMSISH_TIME
if (VMSISH_TIME) when = _toutc(when);
# endif
/* CRTL localtime() wants UTC as input, does tz correction itself */
return localtime(&when);
-
-# else /* !RTL_USES_UTC */
- whenutc = when;
-# ifdef VMSISH_TIME
- if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
- if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
-# endif
- dst = -1;
-#ifndef RTL_USES_UTC
- if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
- when = whenutc - offset; /* pseudolocal time*/
- }
-# endif
- /* CRTL localtime() wants local time as input, so does no tz correction */
- rsltmp = localtime(&when);
- if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
- return rsltmp;
-# endif
-
} /* end of my_localtime() */
/*}}}*/
@@ -12120,7 +11599,7 @@
#else /* __CRTL_VER < 70300000 */
- register int i;
+ int i;
int sts;
long int bintime[2], len = 2, lowbit, unixtime,
secscale = 10000000; /* seconds --> 100 ns intervals */
@@ -12427,10 +11906,10 @@
if (!fname || !*fname) return FALSE;
/* Make sure we expand logical names, since sys$check_access doesn't */
- fileified = PerlMem_malloc(VMS_MAXRSS);
+ fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
if (!strpbrk(fname,"/]>:")) {
- strcpy(fileified,fname);
+ my_strlcpy(fileified, fname, VMS_MAXRSS);
trnlnm_iter_count = 0;
while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
trnlnm_iter_count++;
@@ -12439,7 +11918,7 @@
fname = fileified;
}
- vmsname = PerlMem_malloc(VMS_MAXRSS);
+ vmsname = (char *)PerlMem_malloc(VMS_MAXRSS);
if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
/* Don't know if already in VMS format, so make sure */
@@ -12450,7 +11929,7 @@
}
}
else {
- strcpy(vmsname,fname);
+ my_strlcpy(vmsname, fname, VMS_MAXRSS);
}
/* sys$check_access needs a file spec, not a directory spec.
@@ -12514,14 +11993,12 @@
_ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
_ckvmssts_noperl(iosb[0]);
-#if defined(__VMS_VER) && __VMS_VER >= 60000000
-
/* find out the space required for the profile */
_ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
&usrprodsc.dsc$w_length,&profile_context));
/* allocate space for the profile and get it filled in */
- usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
+ usrprodsc.dsc$a_pointer = (char *)PerlMem_malloc(usrprodsc.dsc$w_length);
if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
_ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
&usrprodsc.dsc$w_length,&profile_context));
@@ -12531,12 +12008,6 @@
PerlMem_free(usrprodsc.dsc$a_pointer);
if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
-#else
-
- retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
-
-#endif
-
if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
@@ -12594,10 +12065,11 @@
int
Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
{
+ dSAVE_ERRNO; /* fstat may set this even on success */
if (!fstat(fd, &statbufp->crtl_stat)) {
char *cptr;
char *vms_filename;
- vms_filename = PerlMem_malloc(VMS_MAXRSS);
+ vms_filename = (char *)PerlMem_malloc(VMS_MAXRSS);
if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
/* Save name for cando by name in VMS format */
@@ -12622,7 +12094,6 @@
VMS_DEVICE_ENCODE
(statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
-# ifdef RTL_USES_UTC
# ifdef VMSISH_TIME
if (VMSISH_TIME) {
statbufp->st_mtime = _toloc(statbufp->st_mtime);
@@ -12630,17 +12101,7 @@
statbufp->st_ctime = _toloc(statbufp->st_ctime);
}
# endif
-# else
-# ifdef VMSISH_TIME
- if (!VMSISH_TIME) { /* Return UTC instead of local time */
-# else
- if (1) {
-# endif
- statbufp->st_mtime = _toutc(statbufp->st_mtime);
- statbufp->st_atime = _toutc(statbufp->st_atime);
- statbufp->st_ctime = _toutc(statbufp->st_ctime);
- }
-#endif
+ RESTORE_ERRNO;
return 0;
}
return -1;
@@ -12651,12 +12112,13 @@
static int
Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
{
- char *fileified;
- char *temp_fspec;
+ char *temp_fspec = NULL;
+ char *fileified = NULL;
const char *save_spec;
char *ret_spec;
int retval = -1;
- int efs_hack = 0;
+ char efs_hack = 0;
+ char already_fileified = 0;
dSAVEDERRNO;
if (!fspec) {
@@ -12677,44 +12139,41 @@
}
}
- /* Try for a directory name first. If fspec contains a filename without
+ SAVE_ERRNO;
+
+#if __CRTL_VER >= 80200000 && !defined(__VAX)
+ /*
+ * If we are in POSIX filespec mode, accept the filename as is.
+ */
+ if (decc_posix_compliant_pathnames == 0) {
+#endif
+
+ /* Try for a simple stat first. If fspec contains a filename without
* a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
- * and sea:[wine.dark]water. exist, we prefer the directory here.
+ * and sea:[wine.dark]water. exist, the CRTL prefers the directory here.
* Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
* not sea:[wine.dark]., if the latter exists. If the intended target is
* the file with null type, specify this by calling flex_stat() with
* a '.' at the end of fspec.
- *
- * If we are in Posix filespec mode, accept the filename as is.
*/
+ if (lstat_flag == 0)
+ retval = stat(fspec, &statbufp->crtl_stat);
+ else
+ retval = lstat(fspec, &statbufp->crtl_stat);
- fileified = PerlMem_malloc(VMS_MAXRSS);
- if (fileified == NULL)
- _ckvmssts_noperl(SS$_INSFMEM);
-
- temp_fspec = PerlMem_malloc(VMS_MAXRSS);
- if (temp_fspec == NULL)
- _ckvmssts_noperl(SS$_INSFMEM);
+ if (!retval) {
+ save_spec = fspec;
+ }
+ else {
+ /* In the odd case where we have write but not read access
+ * to a directory, stat('foo.DIR') works but stat('foo') doesn't.
+ */
+ fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
+ if (fileified == NULL)
+ _ckvmssts_noperl(SS$_INSFMEM);
- strcpy(temp_fspec, fspec);
-
- SAVE_ERRNO;
-
-#if __CRTL_VER >= 80200000 && !defined(__VAX)
- if (decc_posix_compliant_pathnames == 0) {
-#endif
-
- /* We may be able to optimize this, but in order for fileify_dirspec to
- * always return a usuable answer, we have to call vmspath first to
- * make sure that it is in VMS directory format, as stat/lstat on 8.3
- * can not handle directories in unix format that it does not have read
- * access to. Vmspath handles the case where a bare name which could be
- * a logical name gets passed.
- */
- ret_spec = int_tovmspath(fspec, temp_fspec, NULL);
- if (ret_spec != NULL) {
- ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
+ ret_spec = int_fileify_dirspec(fspec, fileified, NULL);
if (ret_spec != NULL) {
if (lstat_flag == 0)
retval = stat(fileified, &statbufp->crtl_stat);
@@ -12721,15 +12180,18 @@
else
retval = lstat(fileified, &statbufp->crtl_stat);
save_spec = fileified;
+ already_fileified = 1;
}
}
if (retval && vms_bug_stat_filename) {
- /* We should try again as a vmsified file specification */
- /* However Perl traditionally has not done this, which */
- /* causes problems with existing tests */
+ temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
+ if (temp_fspec == NULL)
+ _ckvmssts_noperl(SS$_INSFMEM);
+ /* We should try again as a vmsified file specification. */
+
ret_spec = int_tovmsspec(fspec, temp_fspec, 0, NULL);
if (ret_spec != NULL) {
if (lstat_flag == 0)
@@ -12741,7 +12203,7 @@
}
if (retval) {
- /* Last chance - allow multiple dots with out EFS CHARSET */
+ /* Last chance - allow multiple dots without EFS CHARSET */
/* The CRTL stat() falls down hard on multi-dot filenames in unix
* format unless * DECC$EFS_CHARSET is in effect, so temporarily
* enable it if it isn't already.
@@ -12780,8 +12242,8 @@
#endif
if (!retval) {
- char * cptr;
- int rmsex_flags = PERL_RMSEXPAND_M_VMS;
+ char *cptr;
+ int rmsex_flags = PERL_RMSEXPAND_M_VMS;
/* If this is an lstat, do not follow the link */
if (lstat_flag)
@@ -12794,7 +12256,27 @@
decc$feature_set_value(decc_efs_charset_index, 1, 1);
}
#endif
- cptr = int_rmsexpand_tovms(save_spec, statbufp->st_devnam, rmsex_flags);
+
+ /* If we've got a directory, save a fileified, expanded version of it
+ * in st_devnam. If not a directory, just an expanded version.
+ */
+ if (S_ISDIR(statbufp->st_mode) && !already_fileified) {
+ fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
+ if (fileified == NULL)
+ _ckvmssts_noperl(SS$_INSFMEM);
+
+ cptr = do_fileify_dirspec(save_spec, fileified, 0, NULL);
+ if (cptr != NULL)
+ save_spec = fileified;
+ }
+
+ cptr = int_rmsexpand(save_spec,
+ statbufp->st_devnam,
+ NULL,
+ rmsex_flags,
+ 0,
+ 0);
+
#if __CRTL_VER >= 70300000 && !defined(__VAX)
if (efs_hack && (decc_efs_charset_index > 0)) {
decc$feature_set_value(decc_efs_charset, 1, 0);
@@ -12809,7 +12291,6 @@
VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
VMS_DEVICE_ENCODE
(statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
-# ifdef RTL_USES_UTC
# ifdef VMSISH_TIME
if (VMSISH_TIME) {
statbufp->st_mtime = _toloc(statbufp->st_mtime);
@@ -12817,22 +12298,13 @@
statbufp->st_ctime = _toloc(statbufp->st_ctime);
}
# endif
-# else
-# ifdef VMSISH_TIME
- if (!VMSISH_TIME) { /* Return UTC instead of local time */
-# else
- if (1) {
-# endif
- statbufp->st_mtime = _toutc(statbufp->st_mtime);
- statbufp->st_atime = _toutc(statbufp->st_atime);
- statbufp->st_ctime = _toutc(statbufp->st_ctime);
- }
-# endif
}
/* If we were successful, leave errno where we found it */
if (retval == 0) RESTORE_ERRNO;
- PerlMem_free(temp_fspec);
- PerlMem_free(fileified);
+ if (temp_fspec)
+ PerlMem_free(temp_fspec);
+ if (fileified)
+ PerlMem_free(fileified);
return retval;
} /* end of flex_stat_int() */
@@ -12907,9 +12379,9 @@
struct XABRDT xabrdt;
struct XABSUM xabsum;
- vmsin = PerlMem_malloc(VMS_MAXRSS);
+ vmsin = (char *)PerlMem_malloc(VMS_MAXRSS);
if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
- vmsout = PerlMem_malloc(VMS_MAXRSS);
+ vmsout = (char *)PerlMem_malloc(VMS_MAXRSS);
if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
if (!spec_in || !*spec_in || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
!spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
@@ -12919,11 +12391,11 @@
return 0;
}
- esa = PerlMem_malloc(VMS_MAXRSS);
+ esa = (char *)PerlMem_malloc(VMS_MAXRSS);
if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
esal = NULL;
#if !defined(__VAX) && defined(NAML$C_MAXRSS)
- esal = PerlMem_malloc(VMS_MAXRSS);
+ esal = (char *)PerlMem_malloc(VMS_MAXRSS);
if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
#endif
fab_in = cc$rms_fab;
@@ -12934,11 +12406,11 @@
rms_bind_fab_nam(fab_in, nam);
fab_in.fab$l_xab = (void *) &xabdat;
- rsa = PerlMem_malloc(VMS_MAXRSS);
+ rsa = (char *)PerlMem_malloc(VMS_MAXRSS);
if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
rsal = NULL;
#if !defined(__VAX) && defined(NAML$C_MAXRSS)
- rsal = PerlMem_malloc(VMS_MAXRSS);
+ rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
#endif
rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
@@ -12997,16 +12469,16 @@
rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
- esa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
+ esa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
- rsa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
+ rsa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
esal_out = NULL;
rsal_out = NULL;
#if !defined(__VAX) && defined(NAML$C_MAXRSS)
- esal_out = PerlMem_malloc(VMS_MAXRSS);
+ esal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
- rsal_out = PerlMem_malloc(VMS_MAXRSS);
+ rsal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
#endif
rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
@@ -13088,7 +12560,7 @@
fab_out.fab$l_xab = (void *) &xabrdt;
}
- ubf = PerlMem_malloc(32256);
+ ubf = (char *)PerlMem_malloc(32256);
if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
rab_in = cc$rms_rab;
rab_in.rab$l_fab = &fab_in;
@@ -13486,14 +12958,14 @@
for(counter = 0; counter <= num_entries; counter++) {
/* If it's not the first name then tack on a __ */
if (counter) {
- strcat(work_name, "__");
+ my_strlcat(work_name, "__", sizeof(work_name));
}
- strcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)));
+ my_strlcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)), sizeof(work_name));
}
/* Check to see if we actually have to bother...*/
if (strlen(work_name) + 3 <= max_name_len) {
- strcat(ultimate_name, work_name);
+ my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
} else {
/* It's too darned big, so we need to go strip. We use the same */
/* algorithm as xsubpp does. First, strip out doubled __ */
@@ -13508,7 +12980,7 @@
last = *source;
}
/* Go put it back */
- strcpy(work_name, workbuff);
+ my_strlcpy(work_name, workbuff, sizeof(work_name));
/* Is it still too big? */
if (strlen(work_name) + 3 > max_name_len) {
/* Strip duplicate letters */
@@ -13521,7 +12993,7 @@
*dest++ = *source;
last = toupper(*source);
}
- strcpy(work_name, workbuff);
+ my_strlcpy(work_name, workbuff, sizeof(work_name));
}
/* Is it *still* too big? */
@@ -13529,7 +13001,7 @@
/* Too bad, we truncate */
work_name[max_name_len - 2] = 0;
}
- strcat(ultimate_name, work_name);
+ my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
}
/* Okay, return it */
@@ -13676,7 +13148,7 @@
for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) {
if (*cp == '?') {
wildquery = 1;
- if (!decc_efs_case_preserve)
+ if (!decc_efs_charset)
*cp = '%';
} else if (*cp == '%') {
wildquery = 1;
@@ -13738,7 +13210,7 @@
/* In Unix report mode, remove the ".dir;1" from the name */
/* if it is a real directory */
- if (decc_filename_unix_report || decc_efs_charset) {
+ if (decc_filename_unix_report && decc_efs_charset) {
if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
Stat_t statbuf;
int ret_sts;
@@ -13807,7 +13279,7 @@
if (!found) {
/* Be POSIXish: return the input pattern when no matches */
- strcpy(rstr,SvPVX(tmpglob));
+ my_strlcpy(rstr, SvPVX(tmpglob), VMS_MAXRSS);
strcat(rstr,"\n");
ok = (PerlIO_puts(tmpfp,rstr) != EOF);
}
@@ -13893,42 +13365,28 @@
#ifdef HAS_SYMLINK
/*
* A thin wrapper around decc$symlink to make sure we follow the
- * standard and do not create a symlink with a zero-length name.
- *
- * Also in ODS-2 mode, existing tests assume that the link target
- * will be converted to UNIX format.
+ * standard and do not create a symlink with a zero-length name,
+ * and convert the target to Unix format, as the CRTL can't handle
+ * targets in VMS format.
*/
/*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
-int Perl_my_symlink(pTHX_ const char *contents, const char *link_name) {
- if (!link_name || !*link_name) {
- SETERRNO(ENOENT, SS$_NOSUCHFILE);
- return -1;
- }
+int
+Perl_my_symlink(pTHX_ const char *contents, const char *link_name)
+{
+ int sts;
+ char * utarget;
- if (decc_efs_charset) {
- return symlink(contents, link_name);
- } else {
- int sts;
- char * utarget;
+ if (!link_name || !*link_name) {
+ SETERRNO(ENOENT, SS$_NOSUCHFILE);
+ return -1;
+ }
- /* Unless we are in ODS-5 mode, convert the symlink target to UNIX */
- /* because in order to work, the symlink target must be in UNIX format */
-
- /* As symbolic links can hold things other than files, we will only do */
- /* the conversion in in ODS-2 mode */
-
- utarget = PerlMem_malloc(VMS_MAXRSS + 1);
- if (int_tounixspec(contents, utarget, NULL) == NULL) {
-
- /* This should not fail, as an untranslatable filename */
- /* should be passed through */
- utarget = (char *)contents;
- }
- sts = symlink(utarget, link_name);
- PerlMem_free(utarget);
- return sts;
- }
-
+ utarget = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
+ /* An untranslatable filename should be passed through. */
+ (void) int_tounixspec(contents, utarget, NULL);
+ sts = symlink(utarget, link_name);
+ PerlMem_free(utarget);
+ return sts;
}
/*}}}*/
@@ -14019,6 +13477,10 @@
* on OpenVMS.
*/
+#ifdef __cplusplus
+extern "C" {
+#endif
+
/* Hack, use old stat() as fastest way of getting ino_t and device */
int decc$stat(const char *name, void * statbuf);
#if !defined(__VAX) && __CRTL_VER >= 80200000
@@ -14027,7 +13489,11 @@
#define decc$lstat decc$stat
#endif
+#ifdef __cplusplus
+}
+#endif
+
/* Realpath is fragile. In 8.3 it does not work if the feature
* DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
* links are implemented in RMS, not the CRTL. It also can fail if the
@@ -14064,11 +13530,11 @@
* unexpected answers
*/
- fileified = PerlMem_malloc(VMS_MAXRSS);
+ fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
if (fileified == NULL)
_ckvmssts_noperl(SS$_INSFMEM);
- temp_fspec = PerlMem_malloc(VMS_MAXRSS);
+ temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
if (temp_fspec == NULL)
_ckvmssts_noperl(SS$_INSFMEM);
@@ -14259,7 +13725,7 @@
/* 2. ODS-5 / UNIX report mode should return a failure */
/* if the parent directory also does not exist */
/* Otherwise, get the real path for the parent */
- /* and add the child to it.
+ /* and add the child to it. */
/* basename / dirname only available for VMS 7.0+ */
/* So we may need to implement them as common routines */
@@ -14290,7 +13756,7 @@
int dir_len = v_len + r_len + d_len + n_len;
if (dir_len > 0) {
- strncpy(dir_name, filespec, dir_len);
+ memcpy(dir_name, filespec, dir_len);
dir_name[dir_len] = '\0';
file_name = (char *)&filespec[dir_len + 1];
}
@@ -14302,7 +13768,7 @@
if (tchar != NULL) {
int dir_len = tchar - filespec;
- strncpy(dir_name, filespec, dir_len);
+ memcpy(dir_name, filespec, dir_len);
dir_name[dir_len] = '\0';
file_name = (char *) &filespec[dir_len + 1];
}
@@ -14320,13 +13786,13 @@
dir_name, 0, NULL);
if (sts == 0) {
- /* Now need to pathify it.
+ /* Now need to pathify it. */
char *tdir = int_pathify_dirspec(vms_dir_name,
outbuf);
/* And now add the original filespec to it */
if (file_name != NULL) {
- strcat(outbuf, file_name);
+ my_strlcat(outbuf, file_name, VMS_MAXRSS);
}
return outbuf;
}
@@ -14427,13 +13893,59 @@
/* Start of DECC RTL Feature handling */
+#if __CRTL_VER >= 70300000 && !defined(__VAX)
+static int
+set_feature_default(const char *name, int value)
+{
+ int status;
+ int index;
+ char val_str[10];
+
+ /* If the feature has been explicitly disabled in the environment,
+ * then don't enable it here.
+ */
+ if (value > 0) {
+ status = simple_trnlnm(name, val_str, sizeof(val_str));
+ if ($VMS_STATUS_SUCCESS(status)) {
+ val_str[0] = _toupper(val_str[0]);
+ if (val_str[0] == 'D' || val_str[0] == '0' || val_str[0] == 'F')
+ return 0;
+ }
+ }
+
+ index = decc$feature_get_index(name);
+
+ status = decc$feature_set_value(index, 1, value);
+ if (index == -1 || (status == -1)) {
+ return -1;
+ }
+
+ status = decc$feature_get_value(index, 1);
+ if (status != value) {
+ return -1;
+ }
+
+ /* Various things may check for an environment setting
+ * rather than the feature directly, so set that too.
+ */
+ vmssetuserlnm(name, value ? "ENABLE" : "DISABLE");
+
+ return 0;
+}
+#endif
+
+
/* C RTL Feature settings */
-static int set_features
- (int (* init_coroutine)(int *, int *, void *), /* Needs casts if used */
- int (* cli_routine)(void), /* Not documented */
- void *image_info) /* Not documented */
+#if defined(__DECC) || defined(__DECCXX)
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+extern void
+vmsperl_set_features(void)
{
int status;
int s;
@@ -14511,14 +14023,12 @@
vms_unlink_all_versions = 0;
}
- /* Dectect running under GNV Bash or other UNIX like shell */
#if __CRTL_VER >= 70300000 && !defined(__VAX)
+ /* Detect running under GNV Bash or other UNIX like shell */
gnv_unix_shell = 0;
status = simple_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
if ($VMS_STATUS_SUCCESS(status)) {
gnv_unix_shell = 1;
- set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
- set_feature_default("DECC$EFS_CHARSET", 1);
set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
@@ -14526,6 +14036,10 @@
vms_unlink_all_versions = 1;
vms_posix_exit = 1;
}
+ /* Some reasonable defaults that are not CRTL defaults */
+ set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
+ set_feature_default("DECC$ARGV_PARSE_STYLE", 1); /* Requires extended parse. */
+ set_feature_default("DECC$EFS_CHARSET", 1);
#endif
/* hacks to see if known bugs are still present for testing */
@@ -14541,17 +14055,6 @@
decc_bug_devnull = 0;
}
- /* UNIX directory names with no paths are broken in a lot of places */
- decc_dir_barename = 1;
- status = simple_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
- if ($VMS_STATUS_SUCCESS(status)) {
- val_str[0] = _toupper(val_str[0]);
- if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
- decc_dir_barename = 1;
- else
- decc_dir_barename = 0;
- }
-
#if __CRTL_VER >= 70300000 && !defined(__VAX)
s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
if (s >= 0) {
@@ -14700,44 +14203,38 @@
else
vms_posix_exit = 0;
}
-
-
- /* CRTL can be initialized past this point, but not before. */
-/* DECC$CRTL_INIT(); */
-
- return SS$_NORMAL;
}
-#ifdef __DECC
-#pragma nostandard
-#pragma extern_model save
-#pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
- const __align (LONGWORD) int spare[8] = {0};
-
-/* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
-#if __DECC_VER >= 60560002
-#pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
-#else
-#pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
+/* Use 32-bit pointers because that's what the image activator
+ * assumes for the LIB$INITIALZE psect.
+ */
+#if __INITIAL_POINTER_SIZE
+#pragma pointer_size save
+#pragma pointer_size 32
+#endif
+
+/* Create a reference to the LIB$INITIALIZE function. */
+extern void LIB$INITIALIZE(void);
+extern void (*vmsperl_unused_global_1)(void) = LIB$INITIALIZE;
+
+/* Create an array of pointers to the init functions in the special
+ * LIB$INITIALIZE section. In our case, the array only has one entry.
+ */
+#pragma extern_model save
+#pragma extern_model strict_refdef "LIB$INITIALIZE" nopic,gbl,nowrt,noshr,long
+extern void (* const vmsperl_unused_global_2[])() =
+{
+ vmsperl_set_features,
+};
+#pragma extern_model restore
+
+#if __INITIAL_POINTER_SIZE
+#pragma pointer_size restore
+#endif
+
+#ifdef __cplusplus
+}
#endif
-#endif /* __DECC */
-const long vms_cc_features = (const long)set_features;
-
-/*
-** Force a reference to LIB$INITIALIZE to ensure it
-** exists in the image.
-*/
-#define lib$initialize LIB$INITIALIZE
-int lib$initialize(void);
-#ifdef __DECC
-#pragma extern_model strict_refdef
-#endif
- int lib_init_ref = (int) lib$initialize;
-
-#ifdef __DECC
-#pragma extern_model restore
-#pragma standard
-#endif
-
+#endif /* defined(__DECC) || defined(__DECCXX) */
/* End of vms.c */
Property changes on: trunk/contrib/perl/vms/vms.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/vms/vmsish.h
===================================================================
--- trunk/contrib/perl/vms/vmsish.h 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/vms/vmsish.h 2013-12-02 21:26:09 UTC (rev 6439)
@@ -24,9 +24,12 @@
* ADDRCONSTEXT,NEEDCONSTEXT: initialization of data with non-constant values
* (e.g. pointer fields of descriptors)
*/
-#if defined(__DECC) || defined(__DECCXX)
+#ifdef __DECC
# pragma message disable (ADDRCONSTEXT,NEEDCONSTEXT)
#endif
+#ifdef __DECCXX
+# pragma message informational (INTSIGNCHANGE,CASTQUALTYP,ASSCOMMEA,NOCTOBUTCONREFM)
+#endif
/* DEC's C compilers and gcc use incompatible definitions of _to(upp|low)er() */
#ifdef _toupper
@@ -37,14 +40,6 @@
# undef _tolower
#endif
#define _tolower(c) (((c) < 'A' || (c) > 'Z') ? (c) : (c) | 040)
-/* DECC 1.3 has a funny definition of abs; it's fixed in DECC 4.0, so this
- * can go away once DECC 1.3 isn't in use any more. */
-#if defined(__ALPHA) && (defined(__DECC) || defined(__DECCXX))
-#undef abs
-#define abs(__x) __ABS(__x)
-#undef labs
-#define labs(__x) __LABS(__x)
-#endif /* __ALPHA && __DECC */
/* Assorted things to look like Unix */
#ifdef __GNUC__
@@ -93,19 +88,9 @@
#define HAS_GETENV_SV
#define HAS_GETENV_LEN
-/* All this stiff is for the x2P programs. Hopefully they'll still work */
-#if defined(PERL_FOR_X2P)
-#ifndef aTHX_
-#define aTHX_
-#endif
-#ifndef pTHX_
-#define pTHX_
-#endif
-#ifndef pTHX
-#define pTHX
-#endif
-#endif
+#ifndef PERL_FOR_X2P
+
#ifndef DONT_MASK_RTL_CALLS
# ifdef getenv
# undef getenv
@@ -229,6 +214,7 @@
#define vms_realpath(a,b,c) Perl_vms_realpath(aTHX_ a,b,c)
#define vmssetenv(a,b,c) Perl_vmssetenv(aTHX_ a,b,c)
#define vmstrnenv(a,b,c,d,e) Perl_vmstrnenv(a,b,c,d,e)
+#define vmssetuserlnm(a,b) Perl_vmssetuserlnm(a,b)
/* Delete if at all possible, changing protections if necessary. */
#define unlink(a) kill_file(a)
@@ -253,6 +239,7 @@
#ifndef DONT_MASK_RTL_CALLS
# define tmpfile Perl_my_tmpfile
#endif
+#endif
/* BIG_TIME:
@@ -279,16 +266,6 @@
*/
#define ALTERNATE_SHEBANG "$"
-/* Lower case entry points for these are missing in some earlier RTLs
- * so we borrow the defines and declares from errno.h and upcase them.
- */
-#if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 50500000)
-# define errno (*CMA$TIS_ERRNO_GET_ADDR())
-# define vaxc$errno (*CMA$TIS_VMSERRNO_GET_ADDR())
- int *CMA$TIS_ERRNO_GET_ADDR (void); /* UNIX style error code */
- int *CMA$TIS_VMSERRNO_GET_ADDR (void); /* VMS error (errno == EVMSERR) */
-#endif
-
/* Macros to set errno using the VAX thread-safe calls, if present */
#if (defined(__DECC) || defined(__DECCXX)) && !defined(__ALPHA)
# define set_errno(v) (cma$tis_errno_set_value(v))
@@ -333,7 +310,7 @@
#define PERL__TRNENV_JOIN_SEARCHLIST 0x02
/* Handy way to vet calls to VMS system services and RTL routines. */
-#define _ckvmssts(call) STMT_START { register unsigned long int __ckvms_sts; \
+#define _ckvmssts(call) STMT_START { unsigned long int __ckvms_sts; \
if (!((__ckvms_sts=(call))&1)) { \
set_errno(EVMSERR); set_vaxc_errno(__ckvms_sts); \
Perl_croak(aTHX_ "Fatal VMS error (status=%d) at %s, line %d", \
@@ -341,23 +318,18 @@
/* Same thing, but don't call back to Perl's croak(); useful for errors
* occurring during startup, before Perl's state is initialized */
-#define _ckvmssts_noperl(call) STMT_START { register unsigned long int __ckvms_sts; \
+#define _ckvmssts_noperl(call) STMT_START { unsigned long int __ckvms_sts; \
if (!((__ckvms_sts=(call))&1)) { \
set_errno(EVMSERR); set_vaxc_errno(__ckvms_sts); \
- fprintf(stderr,"Fatal VMS error (status=%d) at %s, line %d", \
- __ckvms_sts,__FILE__,__LINE__); lib$signal(__ckvms_sts); } } STMT_END
+ (void)fprintf(stderr,"Fatal VMS error (status=%d) at %s, line %d", \
+ __ckvms_sts,__FILE__,__LINE__); (void)lib$signal(__ckvms_sts); } } STMT_END
#ifdef VMS_DO_SOCKETS
-#include "sockadapt.h"
#define PERL_SOCK_SYSREAD_IS_RECV
#define PERL_SOCK_SYSWRITE_IS_SEND
#endif
-#if __CRTL_VER < 70000000
-#define BIT_BUCKET "_NLA0:"
-#else
#define BIT_BUCKET "/dev/null"
-#endif
#define PERL_SYS_INIT_BODY(c,v) MALLOC_CHECK_TAINT2(*c,*v) vms_image_init((c),(v)); PERLIO_INIT; MALLOC_INIT
#define PERL_SYS_TERM_BODY() HINTS_REFCNT_TERM; OP_REFCNT_TERM; PERLIO_TERM; MALLOC_TERM
#define dXSUB_SYS
@@ -388,11 +360,7 @@
* This symbol, if defined, indicates that the ioctl() routine is
* available to set I/O characteristics
*/
-#if defined(__CRTL_VER) && __CRTL_VER >= 70000000
#define HAS_IOCTL /**/
-#else
-#undef HAS_IOCTL /**/
-#endif
/* HAS_UTIME:
* This symbol, if defined, indicates that the routine utime() is
@@ -530,46 +498,12 @@
#define localtime(t) my_localtime(t)
#define time(t) my_time(t)
-/* If we're using an older version of VMS whose Unix signal emulation
- * isn't very POSIXish, then roll our own.
- */
-#if __VMS_VER < 70000000 || __DECC_VER < 50200000
-# define HOMEGROWN_POSIX_SIGNALS
-#endif
-#ifdef HOMEGROWN_POSIX_SIGNALS
-# define sigemptyset(t) my_sigemptyset(t)
-# define sigfillset(t) my_sigfillset(t)
-# define sigaddset(t, u) my_sigaddset(t, u)
-# define sigdelset(t, u) my_sigdelset(t, u)
-# define sigismember(t, u) my_sigismember(t, u)
-# define sigprocmask(t, u, v) my_sigprocmask(t, u, v)
-# ifndef _SIGSET_T
- typedef int sigset_t;
-# endif
- /* The tools for sigprocmask() are there, just not the routine itself */
-# ifndef SIG_UNBLOCK
-# define SIG_UNBLOCK 1
-# endif
-# ifndef SIG_BLOCK
-# define SIG_BLOCK 2
-# endif
-# ifndef SIG_SETMASK
-# define SIG_SETMASK 3
-# endif
-# define sigaction sigvec
-# define sa_flags sv_onstack
-# define sa_handler sv_handler
-# define sa_mask sv_mask
-# define sigsuspend(set) sigpause(*set)
-# define sigpending(a) (not_here("sigpending"),0)
-#else
/*
* The C RTL's sigaction fails to check for invalid signal numbers so we
* help it out a bit.
*/
-# ifndef DONT_MASK_RTL_CALLS
+#ifndef DONT_MASK_RTL_CALLS
# define sigaction(a,b,c) Perl_my_sigaction(aTHX_ a,b,c)
-# endif
#endif
#ifdef KILL_BY_SIGPRC
# define kill Perl_my_kill
@@ -732,24 +666,6 @@
# pragma __member_alignment __restore
#endif
-/*
- * DEC C previous to 6.0 corrupts the behavior of the /prefix
- * qualifier with the extern prefix pragma. This provisional
- * hack circumvents this prefix pragma problem in previous
- * precompilers.
- */
-#if defined(__VMS_VER) && __VMS_VER >= 70000000
-# if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
-# pragma __extern_prefix save
-# pragma __extern_prefix "" /* set to empty to prevent prefixing */
-# define geteuid decc$__unix_geteuid
-# define getuid decc$__unix_getuid
-# define stat(__p1,__p2) decc$__utc_stat(__p1,__p2)
-# define fstat(__p1,__p2) decc$__utc_fstat(__p1,__p2)
-# pragma __extern_prefix restore
-# endif
-#endif
-
#ifndef DONT_MASK_RTL_CALLS /* defined for vms.c so we can see RTL calls */
# ifdef stat
# undef stat
@@ -764,33 +680,14 @@
#define S_IDOTH (S_IWOTH | S_IXOTH)
+#ifndef PERL_FOR_X2P
/* Prototypes for functions unique to vms.c. Don't include replacements
* for routines in the mainline source files excluded by #ifndef VMS;
* their prototypes are already in proto.h.
- *
- * In order to keep Gen_ShrFls.Pl happy, functions which are to be made
- * available to images linked to PerlShr.Exe must be declared between the
- * __VMS_PROTOTYPES__ and __VMS_SEPYTOTORP__ lines, and must be in the form
- * <data type><TAB>name<WHITESPACE>(<prototype args>);
*/
-#ifdef NO_PERL_TYPEDEFS
- /* We don't have Perl typedefs available (e.g. when building a2p), so
- we fake them here. N.B. There is *no* guarantee that the faked
- prototypes will actually match the real routines. If you want to
- call Perl routines, include perl.h to get the real typedefs. */
-# ifndef bool
-# define bool int
-# define __MY_BOOL_TYPE_FAKE
-# endif
-# ifndef I32
-# define I32 int
-# define __MY_I32_TYPE_FAKE
-# endif
-# ifndef SV
-# define SV void /* Since we only see SV * in prototypes */
-# define __MY_SV_TYPE_FAKE
-# endif
+#ifdef __cplusplus
+extern "C" {
#endif
void prime_env_iter (void);
@@ -797,8 +694,6 @@
void init_os_extras (void);
int Perl_vms_status_to_unix(int vms_status, int child_flag);
int Perl_unix_status_to_vms(int unix_status);
-/* prototype section start marker; `typedef' passes through cpp */
-typedef char __VMS_PROTOTYPES__;
int Perl_vmstrnenv (const char *, char *, unsigned long int, struct dsc$descriptor_s **, unsigned long int);
char * Perl_vms_realpath (pTHX_ const char *, char *, int *);
char * Perl_my_getenv (pTHX_ const char *, bool);
@@ -841,7 +736,7 @@
int Perl_vms_case_tolerant(void);
char * Perl_my_getenv_len (pTHX_ const char *, unsigned long *, bool);
int Perl_vmssetenv (pTHX_ const char *, const char *, struct dsc$descriptor_s **);
-void Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv);
+void Perl_vmssetuserlnm(const char *name, const char *eqv);
char * Perl_my_crypt (pTHX_ const char *, const char *);
Pid_t Perl_my_waitpid (pTHX_ Pid_t, int *, int);
char * my_gconvert (double, int, int, char *);
@@ -849,9 +744,7 @@
int Perl_my_chdir (pTHX_ const char *);
int Perl_my_chmod(pTHX_ const char *, mode_t);
FILE * Perl_my_tmpfile (void);
-#ifndef HOMEGROWN_POSIX_SIGNALS
int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);
-#endif
#ifdef KILL_BY_SIGPRC
unsigned int Perl_sig_to_vmscondition (int);
int Perl_my_kill (int, int);
@@ -868,14 +761,6 @@
struct tm * Perl_my_gmtime (pTHX_ const time_t *);
struct tm * Perl_my_localtime (pTHX_ const time_t *);
time_t Perl_my_time (pTHX_ time_t *);
-#ifdef HOMEGROWN_POSIX_SIGNALS
-int my_sigemptyset (sigset_t *);
-int my_sigfillset (sigset_t *);
-int my_sigaddset (sigset_t *, int);
-int my_sigdelset (sigset_t *, int);
-int my_sigismember (sigset_t *, int);
-int my_sigprocmask (int, sigset_t *, sigset_t *);
-#endif
I32 Perl_cando_by_name (pTHX_ I32, bool, const char *);
int Perl_flex_fstat (pTHX_ int, Stat_t *);
int Perl_flex_lstat (pTHX_ const char *, Stat_t *);
@@ -894,24 +779,13 @@
struct passwd * Perl_my_getpwuid (pTHX_ Uid_t uid);
void Perl_my_endpwent (pTHX);
char * my_getlogin (void);
-typedef char __VMS_SEPYTOTORP__;
-/* prototype section end marker; `typedef' passes through cpp */
-#ifdef NO_PERL_TYPEDEFS /* We'll try not to scramble later files */
-# ifdef __MY_BOOL_TYPE_FAKE
-# undef bool
-# undef __MY_BOOL_TYPE_FAKE
-# endif
-# ifdef __MY_I32_TYPE_FAKE
-# undef I32
-# undef __MY_I32_TYPE_FAKE
-# endif
-# ifdef __MY_SV_TYPE_FAKE
-# undef SV
-# undef __MY_SV_TYPE_FAKE
-# endif
+#ifdef __cplusplus
+}
#endif
+#endif
+
#ifndef VMS_DO_SOCKETS
/* This relies on tricks in perl.h to pick up that these manifest constants
* are undefined and set up conversion routines. It will then redefine
Property changes on: trunk/contrib/perl/vms/vmsish.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/vms/vmspipe.com
===================================================================
--- trunk/contrib/perl/vms/vmspipe.com 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/vms/vmspipe.com 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/vms/vmspipe.com
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/vos/Changes
===================================================================
--- trunk/contrib/perl/vos/Changes 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/vos/Changes 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/vos/Changes
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/vos/compile_full_perl.cm
===================================================================
--- trunk/contrib/perl/vos/compile_full_perl.cm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/vos/compile_full_perl.cm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/vos/compile_full_perl.cm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/vos/configure_full_perl.sh
===================================================================
--- trunk/contrib/perl/vos/configure_full_perl.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/vos/configure_full_perl.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/vos/configure_full_perl.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/vos/make_full_perl.sh
===================================================================
--- trunk/contrib/perl/vos/make_full_perl.sh 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/vos/make_full_perl.sh 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/vos/make_full_perl.sh
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/vos/syslog.h
===================================================================
--- trunk/contrib/perl/vos/syslog.h 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/vos/syslog.h 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/vos/syslog.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/vos/vos.c
===================================================================
--- trunk/contrib/perl/vos/vos.c 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/vos/vos.c 2013-12-02 21:26:09 UTC (rev 6439)
@@ -8,6 +8,8 @@
add syslog entries. */
/* Modified 08-02-04 by Paul Green (Paul.Green at stratus.com) to
open the syslog file in the working dir. */
+/* Modified 11-10-17 by Paul Green to remove the dummy copies
+ of socketpair() and the syslog functions. */
/* End of modification history */
#include <errno.h>
@@ -18,8 +20,6 @@
#include <sys/types.h>
#include <unistd.h>
-#include "vos/syslog.h"
-
/* VOS doesn't supply a truncate function, so we build one up
from the available POSIX functions. */
@@ -35,18 +35,6 @@
return code;
}
-/* VOS doesn't implement AF_UNIX (AF_LOCAL) style sockets, and
- the perl emulation of them hangs on VOS (due to stcp-1257),
- so we supply this version that always fails. */
-
-int
-socketpair (int family, int type, int protocol, int fd[2]) {
- fd[0] = 0;
- fd[1] = 0;
- errno = ENOSYS;
- return -1;
-}
-
/* Supply a private version of the power function that returns 1
for x**0. This avoids c-1471. Abigail's Japh tests depend
on this fix. We leave all the other cases to the VOS C
@@ -65,228 +53,3 @@
return(s_crt_pow(&x,&y));
}
-
-/* entries */
-
-extern void s$log_system_message (
-/* char_varying (256) *message_text,
- char_varying (66) *module_name,
- short int *error_code */ );
-
-/* constants */
-
-#define ALL_PRIORITIES 255 /* 8 priorities, all enabled */
-#define BUFFER_LEN 256
-#define IDENT_LEN 64
-#define MSG_LEN 256
-#define PATH_LEN 257
-
-/* static */
-
-int vos_syslog_facility = LOG_USER>>3;
-int vos_syslog_fd = -1;
-int vos_syslog_logopt = 0;
-char vos_syslog_ident[IDENT_LEN] = "";
-int vos_syslog_ident_len = 0;
-int vos_syslog_mask = ALL_PRIORITIES;
-char vos_syslog_path[PATH_LEN] = "syslog";
-
-char vos_syslog_facility_name [17][10] = {
- "[KERN] ", /* LOG_KERN */
- "[USER] ", /* LOG_USER */
- "[MAIL] ", /* LOG_MAIL */
- "[NEWS] ", /* LOG_NEWS */
- "[UUCP] ", /* LOG_UUCP */
- "[DAEMON] ", /* LOG_DAEMON */
- "[AUTH] ", /* LOG_AUTH */
- "[CRON] ", /* LOG_CRON */
- "[LPR] ", /* LOG_LPR */
- "[LOCAL0] ", /* LOG_LOCAL0 */
- "[LOCAL1] ", /* LOG_LOCAL1 */
- "[LOCAL2] ", /* LOG_LOCAL2 */
- "[LOCAL3] ", /* LOG_LOCAL3 */
- "[LOCAL4] ", /* LOG_LOCAL4 */
- "[LOCAL5] ", /* LOG_LOCAL5 */
- "[LOCAL6] ", /* LOG_LOCAL6 */
- "[LOCAL7] "}; /* LOG_LOCAL7 */
-
-/* syslog functions */
-
-static void open_syslog (void)
-{
- if (vos_syslog_fd >= 0)
- return;
-
- vos_syslog_fd = open (vos_syslog_path, O_RDWR | O_CREAT | O_APPEND, 0777);
- if (vos_syslog_fd < 0)
- fprintf (stderr, "Unable to open %s (errno=%d, os_errno=%d)\n",
- vos_syslog_path, errno, os_errno);
-}
-
-void closelog (void)
-{
- if (vos_syslog_fd >= 0)
- close (vos_syslog_fd);
-
- vos_syslog_facility = LOG_USER>>3;
- vos_syslog_fd = -1;
- vos_syslog_logopt = 0;
- vos_syslog_ident[0] = '\0';
- vos_syslog_ident_len = 0;
- vos_syslog_mask = ALL_PRIORITIES;
- return;
-}
-
-void openlog (const char *ident, int logopt, int facility)
-{
-int n;
-
- if (ident != NULL)
- {
- strncpy (vos_syslog_ident, ident, sizeof (vos_syslog_ident));
- n = IDENT_LEN -
- strnlen (vos_syslog_ident, sizeof (vos_syslog_ident));
- strncat (vos_syslog_ident, ": ", n);
- vos_syslog_ident_len = strnlen (vos_syslog_ident,
- sizeof (vos_syslog_ident));
- }
-
- vos_syslog_logopt = logopt;
- vos_syslog_facility = facility>>3;
-
- if ((logopt & LOG_NDELAY) == LOG_NDELAY)
- open_syslog ();
-
- return;
-}
-
-int setlogmask (int maskpri)
-{
-int old_mask;
-
- old_mask = vos_syslog_mask;
-
- if (maskpri > 0)
- vos_syslog_mask = maskpri;
-
- return old_mask;
-}
-
-void syslog (int priority, const char *format, ...)
-{
-va_list ap;
-int bare_facility;
-int bare_priority;
-int buffer_n;
-char buffer[BUFFER_LEN];
-short int code;
-char_varying(MSG_LEN) message;
-char_varying(66) module_name;
-int n;
-int pid_n;
-char pid_string[32];
-int r;
-int user_n;
-char user_string[256];
-
- /* Calculate priority and facility value. */
-
- bare_priority = priority & 3;
- bare_facility = priority >> 3;
-
- /* If the priority is not set in the mask, do not log the
- message. */
-
- if ((vos_syslog_mask & LOG_MASK(bare_priority)) == 0)
- return;
-
- /* Output facility name. */
-
- if (bare_facility == 0)
- bare_facility = vos_syslog_facility;
-
- strcpy (buffer, vos_syslog_facility_name[bare_facility]);
-
- /* Output priority value. */
-
- /* TBD */
-
- /* Output identity string. */
-
- buffer_n = BUFFER_LEN - strlen (buffer);
- strncat (buffer, vos_syslog_ident, buffer_n);
-
- /* Output process ID. */
-
- if ((vos_syslog_logopt & LOG_PID) == LOG_PID)
- {
- pid_n = snprintf (pid_string, sizeof (pid_string),
- "PID=0x%x ", getpid ());
- if (pid_n)
- {
- buffer_n = BUFFER_LEN - strlen (buffer);
- strncat (buffer, pid_string, buffer_n);
- }
- }
-
- /* Output formatted message. */
-
- va_start (ap, format);
- user_n = vsnprintf (user_string, sizeof (user_string), format, ap);
- va_end (ap);
-
- /* Ensure string ends in a newline. */
-
- if (user_n > 0)
- {
- if (user_n >= sizeof (user_string))
- user_n = sizeof (user_string) - 1;
-
- /* arrays are zero-origin.... */
-
- if (user_string [user_n-1] != '\n')
- {
- user_string [user_n-1] = '\n';
- user_string [user_n++] = '\0';
- }
- }
- else
- {
- user_string [0] = '\n';
- user_string [1] = '\0';
- user_n = 1;
- }
-
- buffer_n = BUFFER_LEN - strnlen (buffer, sizeof (buffer));
- strncat (buffer, user_string, buffer_n);
-
- /* If the log is not open, try to open it now. */
-
- if (vos_syslog_fd < 0)
- open_syslog ();
-
- /* Try to write the message to the syslog file. */
-
- if (vos_syslog_fd < 0)
- r = -1;
- else
- {
- buffer_n = strnlen (buffer, sizeof (buffer));
- r = write (vos_syslog_fd, buffer, buffer_n);
- }
-
- /* If we were unable to write to the log and if LOG_CONS is
- set, send it to the console. */
-
- if (r < 0)
- if ((vos_syslog_logopt & LOG_CONS) == LOG_CONS)
- {
- strcpy_vstr_nstr (&message, "syslog: ");
- n = MSG_LEN - sizeof ("syslog: ");
- strncat_vstr_nstr (&message, buffer, n);
- strcpy_vstr_nstr (&module_name, "");
- s$log_system_message (&message, &module_name, &code);
- }
-
- return;
-}
Property changes on: trunk/contrib/perl/vos/vos.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/vos/vosish.h
===================================================================
--- trunk/contrib/perl/vos/vosish.h 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/vos/vosish.h 2013-12-02 21:26:09 UTC (rev 6439)
@@ -8,11 +8,5 @@
is a work-around for posix-1302. */
#undef SA_SIGINFO
-/* The following declaration is an avoidance for posix-950. */
-extern int ioctl (int fd, int request, ...);
-
/* Specify a prototype for truncate() since we are supplying one. */
extern int truncate (const char *path, off_t len);
-
-/* Specify a prototype for socketpair() since we supplying one. */
-extern int socketpair (int family, int type, int protocol, int fd[2]);
Property changes on: trunk/contrib/perl/vos/vosish.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/win32/FindExt.pm
===================================================================
--- trunk/contrib/perl/win32/FindExt.pm 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/FindExt.pm 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/win32/FindExt.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/win32/Makefile
===================================================================
--- trunk/contrib/perl/win32/Makefile 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/Makefile 2013-12-02 21:26:09 UTC (rev 6439)
@@ -5,7 +5,7 @@
# Windows SDK 64-bit compiler and tools
#
# This is set up to build a perl.exe that runs off a shared library
-# (perl514.dll). Also makes individual DLLs for the XS extensions.
+# (perl518.dll). Also makes individual DLLs for the XS extensions.
#
##
@@ -37,7 +37,7 @@
# versioned installation can be obtained by setting INST_TOP above to a
# path that includes an arbitrary version string.
#
-#INST_VER = \5.14.0
+#INST_VER = \5.18.1
#
# Comment this out if you DON'T want your perl installation to have
@@ -93,28 +93,38 @@
USE_LARGE_FILES = define
#
+# Uncomment this if you're building a 32-bit perl and want 64-bit integers.
+# (If you're building a 64-bit perl then you will have 64-bit integers whether
+# or not this is uncommented.)
+#USE_64_BIT_INT = define
+
+#
# uncomment exactly one of the following
#
# Visual C++ 6.x (aka Visual C++ 98)
CCTYPE = MSVC60
+# Visual C++ .NET 2002/2003 (aka Visual C++ 7.x) (full version)
+#CCTYPE = MSVC70
# Visual C++ Toolkit 2003 (aka Visual C++ 7.x) (free command-line tools)
#CCTYPE = MSVC70FREE
-# Visual C++ .NET 2003 (aka Visual C++ 7.x) (full version)
-#CCTYPE = MSVC70
# Windows Server 2003 SP1 Platform SDK (April 2005)
#CCTYPE = SDK2003SP1
+# Visual C++ 2005 (aka Visual C++ 8.x) (full version)
+#CCTYPE = MSVC80
# Visual C++ 2005 Express Edition (aka Visual C++ 8.x) (free version)
#CCTYPE = MSVC80FREE
-# Visual C++ 2005 (aka Visual C++ 8.x) (full version)
-#CCTYPE = MSVC80
+# Visual C++ 2008 (aka Visual C++ 9.x) (full version)
+#CCTYPE = MSVC90
# Visual C++ 2008 Express Edition (aka Visual C++ 9.x) (free version)
#CCTYPE = MSVC90FREE
-# Visual C++ 2008 (aka Visual C++ 9.x) (full version)
-#CCTYPE = MSVC90
+# Visual C++ 2010 (aka Visual C++ 10.x) (full version)
+#CCTYPE = MSVC100
# Visual C++ 2010 Express Edition (aka Visual C++ 10.x) (free version)
#CCTYPE = MSVC100FREE
-# Visual C++ 2010 (aka Visual C++ 10.x) (full version)
-#CCTYPE = MSVC100
+# Visual C++ 2012 (aka Visual C++ 11.x) (full version)
+#CCTYPE = MSVC110
+# Visual C++ 2012 Express Edition (aka Visual C++ 11.x) (free version)
+#CCTYPE = MSVC110FREE
#
# uncomment next line if you want debug version of perl (big,slow)
@@ -152,7 +162,7 @@
# set this to additionally provide a statically linked perl-static.exe.
# Note that dynamic loading will not work with this perl, so you must
# include required modules statically using the STATIC_EXT or ALL_STATIC
-# variables below. A static library perl514s.lib will also be created.
+# variables below. A static library perl518s.lib will also be created.
# Ordinary perl.exe is not affected by this option.
#
#BUILD_STATIC = define
@@ -261,6 +271,10 @@
USE_LARGE_FILES = undef
!ENDIF
+!IF "$(USE_64_BIT_INT)" == ""
+USE_64_BIT_INT = undef
+!ENDIF
+
!IF "$(USE_IMP_SYS)$(USE_MULTI)" == "defineundef"
USE_MULTI = define
!ENDIF
@@ -301,6 +315,10 @@
!ENDIF
!ENDIF
+!IF "$(WIN64)" == "define"
+USE_64_BIT_INT = define
+!ENDIF
+
# Treat 64-bit MSVC60 (doesn't really exist) as SDK2003SP1 because
# both link against MSVCRT.dll (which is part of Windows itself) and
# not against a compiler specific versioned runtime.
@@ -308,6 +326,15 @@
CCTYPE = SDK2003SP1
!ENDIF
+# Most relevant compiler-specific options fall into two groups:
+# either pre-MSVC80 or MSVC80 onwards, so define a macro for this.
+!IF "$(CCTYPE)" == "MSVC60" || \
+ "$(CCTYPE)" == "MSVC70" || "$(CCTYPE)" == "MSVC70FREE"
+PREMSVC80 = define
+!ELSE
+PREMSVC80 = undef
+!ENDIF
+
ARCHITECTURE = $(PROCESSOR_ARCHITECTURE)
!IF "$(ARCHITECTURE)" == "AMD64"
ARCHITECTURE = x64
@@ -334,14 +361,15 @@
ARCHNAME = $(ARCHNAME)-thread
!ENDIF
-# Visual C++ 98, .NET 2003, 2005/2008/2010 specific.
-# VC++ 6/7/8/9/10.x can load DLLs on demand. Makes the test suite run
-# in about 10% less time. (The free version of 7.x can't do this, but the free
-# versions of 8/9/10.x can.)
-!IF "$(CCTYPE)" == "MSVC60" || "$(CCTYPE)" == "MSVC70" || \
- "$(CCTYPE)" == "MSVC80" || "$(CCTYPE)" == "MSVC80FREE" || \
- "$(CCTYPE)" == "MSVC90" || "$(CCTYPE)" == "MSVC90FREE" || \
- "$(CCTYPE)" == "MSVC100" || "$(CCTYPE)" == "MSVC100FREE"
+!IF "$(WIN64)" != "define"
+!IF "$(USE_64_BIT_INT)" == "define"
+ARCHNAME = $(ARCHNAME)-64int
+!ENDIF
+!ENDIF
+
+# All but the free version of VC++ 7.x can load DLLs on demand. Makes the test
+# suite run in about 10% less time.
+!IF "$(CCTYPE)" != "MSVC70FREE"
DELAYLOAD = -DELAYLOAD:ws2_32.dll delayimp.lib
!ENDIF
@@ -400,7 +428,8 @@
OPTIMIZE = -Od -MD -Zi -DDEBUGGING
LINK_DBG = -debug
!ELSE
-OPTIMIZE = -MD -Zi -DNDEBUG
+# -O1 yields smaller code, which turns out to be faster than -O2 on x86 and x64
+OPTIMIZE = -O1 -MD -Zi -DNDEBUG
# we enable debug symbols in release builds also
LINK_DBG = -debug -opt:ref,icf
# you may want to enable this if you want COFF symbols in the executables
@@ -411,12 +440,8 @@
#LINK_DBG = $(LINK_DBG) -debugtype:both
! IF "$(WIN64)" == "define"
# enable Whole Program Optimizations (WPO) and Link Time Code Generation (LTCG)
-OPTIMIZE = $(OPTIMIZE) -Ox -GL
+OPTIMIZE = $(OPTIMIZE) -GL
LINK_DBG = $(LINK_DBG) -ltcg
-! ELSE
-# -O1 yields smaller code, which turns out to be faster than -O2 on x86
-OPTIMIZE = $(OPTIMIZE) -O1
-#OPTIMIZE = $(OPTIMIZE) -O2
! ENDIF
!ENDIF
@@ -425,11 +450,9 @@
OPTIMIZE = $(OPTIMIZE) -fp:precise
!ENDIF
-# For now, silence VC++ 8/9/10.x's warnings about "unsafe" CRT functions
+# For now, silence warnings from VC++ 8.x onwards about "unsafe" CRT functions
# and POSIX CRT function names being deprecated.
-!IF "$(CCTYPE)" == "MSVC80" || "$(CCTYPE)" == "MSVC80FREE" || \
- "$(CCTYPE)" == "MSVC90" || "$(CCTYPE)" == "MSVC90FREE" || \
- "$(CCTYPE)" == "MSVC100" || "$(CCTYPE)" == "MSVC100FREE"
+!IF "$(PREMSVC80)" == "undef"
DEFINES = $(DEFINES) -D_CRT_SECURE_NO_DEPRECATE -D_CRT_NONSTDC_NO_DEPRECATE
!ENDIF
@@ -442,8 +465,7 @@
# Perl itself with e.g. VC6 but later installs an XS module using VC8
# the time_t types will still be compatible.
!IF "$(WIN64)" == "undef"
-! IF "$(CCTYPE)" == "MSVC60" || \
- "$(CCTYPE)" == "MSVC70" || "$(CCTYPE)" == "MSVC70FREE"
+! IF "$(PREMSVC80)" == "define"
BUILDOPT = $(BUILDOPT) -D_USE_32BIT_TIME_T
! ENDIF
!ENDIF
@@ -477,9 +499,7 @@
CFLAGS_O = $(CFLAGS) $(BUILDOPT)
-!IF "$(CCTYPE)" == "MSVC80" || "$(CCTYPE)" == "MSVC80FREE" || \
- "$(CCTYPE)" == "MSVC90" || "$(CCTYPE)" == "MSVC90FREE" || \
- "$(CCTYPE)" == "MSVC100" || "$(CCTYPE)" == "MSVC100FREE"
+!IF "$(PREMSVC80)" == "undef"
LINK_FLAGS = $(LINK_FLAGS) "/manifestdependency:type='Win32' name='Microsoft.Windows.Common-Controls' version='6.0.0.0' processorArchitecture='*' publicKeyToken='6595b64144ccf1df' language='*'"
!ELSE
RSC_FLAGS = -DINCLUDE_MANIFEST
@@ -500,6 +520,9 @@
.c$(o):
$(CC) -c -I$(<D) $(CFLAGS_O) $(OBJOUT_FLAG)$@ $<
+.c.i:
+ $(CC) -c -I$(<D) $(CFLAGS_O) -P $(OBJOUT_FLAG)$@ $<
+
.y.c:
$(NOOP)
@@ -516,9 +539,9 @@
# makedef.pl must be updated if this changes, and this should normally
# only change when there is an incompatible revision of the public API.
-PERLIMPLIB = ..\perl514.lib
-PERLSTATICLIB = ..\perl514s.lib
-PERLDLL = ..\perl514.dll
+PERLIMPLIB = ..\perl518.lib
+PERLSTATICLIB = ..\perl518s.lib
+PERLDLL = ..\perl518.dll
MINIPERL = ..\miniperl.exe
MINIDIR = .\mini
@@ -540,7 +563,8 @@
FIRSTUNIFILE = ..\lib\unicore\Decomposition.pl
UNIDATAFILES = ..\lib\unicore\Decomposition.pl \
..\lib\unicore\CombiningClass.pl ..\lib\unicore\Name.pl \
- ..\lib\unicore\Heavy.pl ..\lib\unicore\mktables.lst \
+ ..\lib\unicore\Heavy.pl ..\lib\unicore\mktables.lst \
+ ..\lib\unicore\UCD.pl ..\lib\unicore\Name.pm \
..\lib\unicore\TestProp.pl
# Directories of Unicode data files generated by mktables
@@ -564,7 +588,6 @@
UTILS = \
..\utils\h2ph \
..\utils\splain \
- ..\utils\dprofpp \
..\utils\perlbug \
..\utils\pl2pm \
..\utils\c2ph \
@@ -583,6 +606,7 @@
..\utils\ptar \
..\utils\ptardiff \
..\utils\ptargrep \
+ ..\utils\zipdetails \
..\utils\cpanp-run-perl \
..\utils\cpanp \
..\utils\cpan2dist \
@@ -589,6 +613,7 @@
..\utils\shasum \
..\utils\instmodsh \
..\utils\json_pp \
+ ..\utils\pod2html \
..\x2p\find2perl \
..\x2p\psed \
..\x2p\s2p \
@@ -601,13 +626,8 @@
MAKE = nmake -nologo
MAKE_BARE = nmake
-!IF "$(WIN64)" == "define"
-CFGSH_TMPL = config.vc64
-CFGH_TMPL = config_H.vc64
-!ELSE
CFGSH_TMPL = config.vc
CFGH_TMPL = config_H.vc
-!ENDIF
XCOPY = xcopy /f /r /i /d /y
RCOPY = xcopy /f /r /i /e /d /y
@@ -692,6 +712,7 @@
..\gv.h \
..\handy.h \
..\hv.h \
+ ..\hv_func.h \
..\iperlsys.h \
..\mg.h \
..\nostdio.h \
@@ -726,6 +747,8 @@
UUDMAP_H = ..\uudmap.h
BITCOUNT_H = ..\bitcount.h
+MG_DATA_H = ..\mg_data.h
+GENERATED_HEADERS = $(UUDMAP_H) $(BITCOUNT_H) $(MG_DATA_H)
MICROCORE_OBJ = $(MICROCORE_SRC:.c=.obj)
CORE_OBJ = $(MICROCORE_OBJ) $(EXTRACORE_SRC:.c=.obj)
@@ -764,7 +787,6 @@
DYNALOADER = ..\DynaLoader$(o)
CFG_VARS = \
- "INST_DRV=$(INST_DRV)" \
"INST_TOP=$(INST_TOP)" \
"INST_VER=$(INST_VER)" \
"INST_ARCH=$(INST_ARCH)" \
@@ -785,10 +807,12 @@
"useithreads=$(USE_ITHREADS)" \
"usemultiplicity=$(USE_MULTI)" \
"useperlio=$(USE_PERLIO)" \
+ "use64bitint=$(USE_64_BIT_INT)" \
"uselargefiles=$(USE_LARGE_FILES)" \
"usesitecustomize=$(USE_SITECUST)" \
"LINK_FLAGS=$(LINK_FLAGS:"=\")" \
- "optimize=$(OPTIMIZE:"=\")"
+ "optimize=$(OPTIMIZE:"=\")" \
+ "WIN64=$(WIN64)"
ICWD = -I..\dist\Cwd -I..\dist\Cwd\lib
@@ -824,9 +848,82 @@
config.w32 : $(CFGSH_TMPL)
copy $(CFGSH_TMPL) config.w32
+#
+# Copy the template config.h and set configurables at the end of it
+# as per the options chosen and compiler used.
+# Note: This config.h is only used to build miniperl.exe anyway, but
+# it's as well to have its options correct to be sure that it builds
+# and so that it's "-V" options are correct for use by makedef.pl. The
+# real config.h used to build perl.exe is generated from the top-level
+# config_h.SH by config_h.PL (run by miniperl.exe).
+#
.\config.h : $(CFGH_TMPL)
-del /f config.h
copy $(CFGH_TMPL) config.h
+ @echo.>>$@
+ @echo #ifndef _config_h_footer_>>$@
+ @echo #define _config_h_footer_>>$@
+ @echo #undef PTRSIZE>>$@
+ @echo #undef SSize_t>>$@
+ @echo #undef HAS_ATOLL>>$@
+ @echo #undef HAS_STRTOLL>>$@
+ @echo #undef HAS_STRTOULL>>$@
+ @echo #undef IVTYPE>>$@
+ @echo #undef UVTYPE>>$@
+ @echo #undef IVSIZE>>$@
+ @echo #undef UVSIZE>>$@
+ @echo #undef NV_PRESERVES_UV>>$@
+ @echo #undef NV_PRESERVES_UV_BITS>>$@
+ @echo #undef IVdf>>$@
+ @echo #undef UVuf>>$@
+ @echo #undef UVof>>$@
+ @echo #undef UVxf>>$@
+ @echo #undef UVXf>>$@
+ @echo #undef USE_64_BIT_INT>>$@
+ @echo #undef Size_t_size>>$@
+!IF "$(WIN64)"=="define"
+ @echo #define PTRSIZE ^8>>$@
+ @echo #define SSize_t __int64>>$@
+ @echo #define HAS_ATOLL>>$@
+ @echo #define HAS_STRTOLL>>$@
+ @echo #define HAS_STRTOULL>>$@
+ @echo #define Size_t_size ^8>>$@
+!ELSE
+ @echo #define PTRSIZE ^4>>$@
+ @echo #define SSize_t int>>$@
+ @echo #undef HAS_ATOLL>>$@
+ @echo #undef HAS_STRTOLL>>$@
+ @echo #undef HAS_STRTOULL>>$@
+ @echo #define Size_t_size ^4>>$@
+!ENDIF
+!IF "$(USE_64_BIT_INT)"=="define"
+ @echo #define IVTYPE __int64>>$@
+ @echo #define UVTYPE unsigned __int64>>$@
+ @echo #define IVSIZE ^8>>$@
+ @echo #define UVSIZE ^8>>$@
+ @echo #undef NV_PRESERVES_UV>>$@
+ @echo #define NV_PRESERVES_UV_BITS 53>>$@
+ @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>>$@
+ @echo #define UVTYPE unsigned long>>$@
+ @echo #define IVSIZE ^4>>$@
+ @echo #define UVSIZE ^4>>$@
+ @echo #define NV_PRESERVES_UV>>$@
+ @echo #define NV_PRESERVES_UV_BITS 32>>$@
+ @echo #define IVdf "ld">>$@
+ @echo #define UVuf "lu">>$@
+ @echo #define UVof "lo">>$@
+ @echo #define UVxf "lx">>$@
+ @echo #define UVXf "lX">>$@
+ @echo #undef USE_64_BIT_INT>>$@
+!ENDIF
+ @echo #endif>>$@
..\git_version.h : $(MINIPERL) ..\make_patchnum.pl
cd ..
@@ -839,20 +936,15 @@
..\config.sh : config.w32 $(MINIPERL) config_sh.PL FindExt.pm
$(MINIPERL) -I..\lib config_sh.PL $(CFG_VARS) config.w32 > ..\config.sh
-# this target is for when changes to the main config.sh happen.
-# edit config.vc, then make perl in a minimal configuration (i.e. with MULTI,
-# ITHREADS, IMP_SYS, LARGE_FILES, PERLIO and CRYPT off), then make this target
+# This target is for when changes to the main config.sh happen.
+# Edit config.vc, then make perl in a minimal configuration (i.e. with MULTI,
+# ITHREADS, IMP_SYS, LARGE_FILES and PERLIO off), then make this target
# to regenerate config_H.vc.
-# repeat for config.vc64 and config_H.vc64 if you have a suitable build
-# environment, otherwise hand-edit them to maintain the same differences with
-# config.vc and config_H.vc as before.
-# unfortunately, some further manual editing is also then required to restore all
-# the special __GNUC__ handling that is otherwise lost.
regen_config_h:
$(MINIPERL) -I..\lib config_sh.PL $(CFG_VARS) $(CFGSH_TMPL) > ..\config.sh
$(MINIPERL) -I..\lib ..\configpm --chdir=..
-del /f $(CFGH_TMPL)
- -$(MINIPERL) -I..\lib $(ICWD) config_h.PL "INST_VER=$(INST_VER)"
+ -$(MINIPERL) -I..\lib $(ICWD) config_h.PL
rename config.h $(CFGH_TMPL)
$(CONFIGPM) : $(MINIPERL) ..\config.sh config_h.PL ..\minimod.pl
@@ -861,7 +953,7 @@
$(XCOPY) ..\*.h $(COREDIR)\*.*
$(XCOPY) *.h $(COREDIR)\*.*
$(RCOPY) include $(COREDIR)\*.*
- -$(MINIPERL) -I..\lib $(ICWD) config_h.PL "INST_VER=$(INST_VER)"
+ -$(MINIPERL) -I..\lib $(ICWD) config_h.PL
if errorlevel 1 $(MAKE) /$(MAKEFLAGS) $(CONFIGPM)
..\lib\buildcustomize.pl: $(MINIPERL) ..\write_buildcustomize.pl
@@ -869,7 +961,7 @@
$(MINIPERL) : $(MINIDIR) $(MINI_OBJ)
$(LINK32) -subsystem:console -out:$@ @<<
- $(LINK_FLAGS) $(LIBFILES) $(MINI_OBJ)
+ $(LINK_FLAGS) $(DELAYLOAD) $(LIBFILES) $(MINI_OBJ)
<<
$(EMBED_EXE_MANI)
@@ -880,7 +972,7 @@
$(CC) -c $(CFLAGS) -DPERL_EXTERNAL_GLOB -DPERL_IS_MINIPERL $(OBJOUT_FLAG)$@ ..\$(*F).c
$(MINIWIN32_OBJ) : $(CORE_NOCFG_H)
- $(CC) -c $(CFLAGS) $(OBJOUT_FLAG)$@ $(*F).c
+ $(CC) -c $(CFLAGS) -DPERL_IS_MINIPERL $(OBJOUT_FLAG)$@ $(*F).c
# -DPERL_IMPLICIT_SYS needs C++ for perllib.c
# This is the only file that depends on perlhost.h, vmem.h, and vdir.h
@@ -899,10 +991,10 @@
$(DLL_OBJ) : $(CORE_H)
$(X2P_OBJ) : $(CORE_H)
-perldll.def : $(MINIPERL) $(CONFIGPM) ..\global.sym ..\makedef.pl create_perllibst_h.pl
+perldll.def : $(MINIPERL) $(CONFIGPM) ..\embed.fnc ..\makedef.pl create_perllibst_h.pl
$(MINIPERL) -I..\lib create_perllibst_h.pl
$(MINIPERL) -I..\lib -w ..\makedef.pl PLATFORM=win32 $(OPTIMIZE) $(DEFINES) $(BUILDOPT) \
- CCTYPE=$(CCTYPE) > perldll.def
+ CCTYPE=$(CCTYPE) TARG_DIR=..\ > perldll.def
$(PERLDLL): perldll.def $(PERLDLL_OBJ) $(PERLDLL_RES) Extensions_static
$(LINK32) -dll -def:perldll.def -base:0x28000000 -out:$@ @Extensions_static @<<
@@ -947,13 +1039,15 @@
<<
$(EMBED_EXE_MANI)
-$(MINIDIR)\globals$(o) : $(UUDMAP_H) $(BITCOUNT_H)
+$(MINIDIR)\globals$(o) : $(GENERATED_HEADERS)
-$(UUDMAP_H) : $(BITCOUNT_H)
+$(UUDMAP_H) $(MG_DATA_H) : $(BITCOUNT_H)
$(BITCOUNT_H) : $(GENUUDMAP)
- $(GENUUDMAP) $(UUDMAP_H) $(BITCOUNT_H)
+ $(GENUUDMAP) $(GENERATED_HEADERS)
+$(GENUUDMAP_OBJ) : ..\mg_raw.h
+
$(GENUUDMAP) : $(GENUUDMAP_OBJ)
$(LINK32) -subsystem:console -out:$@ @<<
$(LINK_FLAGS) $(LIBFILES) $(GENUUDMAP_OBJ)
@@ -1004,7 +1098,7 @@
$(MINIPERL) -I..\lib ..\make_ext.pl "MAKE=$(MAKE)" --dir=$(CPANDIR) --dir=$(DISTDIR) --dir=$(EXTDIR) --static
$(MINIPERL) -I..\lib list_static_libs.pl > Extensions_static
-Extensions_nonxs: ..\make_ext.pl ..\lib\buildcustomize.pl $(PERLDEP) $(CONFIGPM)
+Extensions_nonxs: ..\make_ext.pl ..\lib\buildcustomize.pl $(PERLDEP) $(CONFIGPM) ..\pod\perlfunc.pod
$(XCOPY) ..\*.h $(COREDIR)\*.*
$(MINIPERL) -I..\lib ..\make_ext.pl "MAKE=$(MAKE)" --dir=$(CPANDIR) --dir=$(DISTDIR) --dir=$(EXTDIR) --nonxs
@@ -1022,8 +1116,8 @@
doc: $(PERLEXE) ..\pod\perltoc.pod
$(PERLEXE) -I..\lib ..\installhtml --podroot=.. --htmldir=$(HTMLDIR) \
- --podpath=pod:lib:ext:utils --htmlroot="file://$(INST_HTML::=|)" \
- --libpod=perlfunc:perlguts:perlvar:perlrun:perlop --recurse
+ --podpath=pod:lib:utils --htmlroot="file://$(INST_HTML::=|)" \
+ --recurse
# Note that this next section is parsed (and regenerated) by pod/buildtoc
# so please check that script before making structural changes here
@@ -1034,7 +1128,6 @@
cd ..\pod
copy ..\README.aix ..\pod\perlaix.pod
copy ..\README.amiga ..\pod\perlamiga.pod
- copy ..\README.beos ..\pod\perlbeos.pod
copy ..\README.bs2000 ..\pod\perlbs2000.pod
copy ..\README.ce ..\pod\perlce.pod
copy ..\README.cn ..\pod\perlcn.pod
@@ -1041,7 +1134,6 @@
copy ..\README.cygwin ..\pod\perlcygwin.pod
copy ..\README.dgux ..\pod\perldgux.pod
copy ..\README.dos ..\pod\perldos.pod
- copy ..\README.epoc ..\pod\perlepoc.pod
copy ..\README.freebsd ..\pod\perlfreebsd.pod
copy ..\README.haiku ..\pod\perlhaiku.pod
copy ..\README.hpux ..\pod\perlhpux.pod
@@ -1052,7 +1144,6 @@
copy ..\README.linux ..\pod\perllinux.pod
copy ..\README.macos ..\pod\perlmacos.pod
copy ..\README.macosx ..\pod\perlmacosx.pod
- copy ..\README.mpeix ..\pod\perlmpeix.pod
copy ..\README.netware ..\pod\perlnetware.pod
copy ..\README.openbsd ..\pod\perlopenbsd.pod
copy ..\README.os2 ..\pod\perlos2.pod
@@ -1065,11 +1156,9 @@
copy ..\README.symbian ..\pod\perlsymbian.pod
copy ..\README.tru64 ..\pod\perltru64.pod
copy ..\README.tw ..\pod\perltw.pod
- copy ..\README.uts ..\pod\perluts.pod
- copy ..\README.vmesa ..\pod\perlvmesa.pod
copy ..\README.vos ..\pod\perlvos.pod
copy ..\README.win32 ..\pod\perlwin32.pod
- copy ..\pod\perldelta.pod ..\pod\perl5140delta.pod
+ copy ..\pod\perldelta.pod ..\pod\perl5181delta.pod
cd ..\win32
$(PERLEXE) $(PL2BAT) $(UTILS)
$(PERLEXE) $(ICWD) ..\autodoc.pl ..
@@ -1076,7 +1165,7 @@
$(PERLEXE) $(ICWD) ..\pod\perlmodlib.pl -q
..\pod\perltoc.pod: $(PERLEXE) Extensions Extensions_nonxs
- $(PERLEXE) -f ..\pod\buildtoc --build-toc -q
+ $(PERLEXE) -f ..\pod\buildtoc -q
# Note that the pod cleanup in this next section is parsed (and regenerated
# by pod/buildtoc so please check that script before making changes here
@@ -1161,21 +1250,20 @@
-if exist $(LIBDIR)\Unicode\Collate rmdir /s /q $(LIBDIR)\Unicode\Collate
-if exist $(LIBDIR)\XS rmdir /s /q $(LIBDIR)\XS
-if exist $(LIBDIR)\Win32API rmdir /s /q $(LIBDIR)\Win32API
- -cd $(PODDIR) && del /f *.html *.bat \
- perl5140delta.pod perlaix.pod perlamiga.pod perlapi.pod \
- perlbeos.pod perlbs2000.pod perlce.pod perlcn.pod \
- perlcygwin.pod perldgux.pod perldos.pod perlepoc.pod \
- perlfreebsd.pod perlhaiku.pod perlhpux.pod perlhurd.pod \
- perlintern.pod perlirix.pod perljp.pod perlko.pod perllinux.pod \
- perlmacos.pod perlmacosx.pod perlmodlib.pod perlmpeix.pod \
- perlnetware.pod perlopenbsd.pod perlos2.pod perlos390.pod \
- perlos400.pod perlplan9.pod perlqnx.pod perlriscos.pod \
- perlsolaris.pod perlsymbian.pod perltoc.pod perltru64.pod \
- perltw.pod perluniprops.pod perluts.pod perlvmesa.pod \
+ -cd $(PODDIR) && del /f *.html *.bat roffitall \
+ perl5181delta.pod perlaix.pod perlamiga.pod perlapi.pod \
+ perlbs2000.pod perlce.pod perlcn.pod perlcygwin.pod \
+ perldgux.pod perldos.pod perlfreebsd.pod perlhaiku.pod \
+ perlhpux.pod perlhurd.pod perlintern.pod perlirix.pod \
+ perljp.pod perlko.pod perllinux.pod perlmacos.pod \
+ perlmacosx.pod perlmodlib.pod perlnetware.pod perlopenbsd.pod \
+ perlos2.pod perlos390.pod perlos400.pod perlplan9.pod \
+ perlqnx.pod perlriscos.pod perlsolaris.pod perlsymbian.pod \
+ perltoc.pod perltru64.pod perltw.pod perluniprops.pod \
perlvos.pod perlwin32.pod
-cd ..\utils && del /f h2ph splain perlbug pl2pm c2ph pstruct h2xs \
- perldoc perlivp dprofpp libnetcfg enc2xs piconv cpan *.bat \
- xsubpp instmodsh json_pp prove ptar ptardiff ptargrep cpanp-run-perl cpanp cpan2dist shasum corelist config_data
+ perldoc perlivp libnetcfg enc2xs piconv cpan *.bat \
+ xsubpp pod2html instmodsh json_pp prove ptar ptardiff ptargrep cpanp-run-perl cpanp cpan2dist shasum corelist config_data zipdetails
-cd ..\x2p && del /f find2perl s2p psed *.bat
-del /f ..\config.sh perlmain.c dlutils.c config.h.new \
perlmainst.c
@@ -1191,7 +1279,6 @@
-if exist $(AUTODIR) rmdir /s /q $(AUTODIR)
-if exist $(COREDIR) rmdir /s /q $(COREDIR)
-if exist pod2htmd.tmp del pod2htmd.tmp
- -if exist pod2htmi.tmp del pod2htmi.tmp
-if exist $(HTMLDIR) rmdir /s /q $(HTMLDIR)
-del /f ..\t\test_state
@@ -1223,7 +1310,7 @@
$(XCOPY) $(GLOBEXE) ..\t\$(NULL)
attrib -r ..\t\*.*
cd ..\t && \
- $(MINIPERL) -I..\lib harness base/*.t comp/*.t cmd/*.t io/*.t op/*.t pragma/*.t
+ $(MINIPERL) -I..\lib harness base/*.t comp/*.t cmd/*.t io/*.t opbasic/*.t op/*.t pragma/*.t
test-prep : all utils ../pod/perltoc.pod
$(XCOPY) $(PERLEXE) ..\t\$(NULL)
@@ -1236,6 +1323,11 @@
$(PERLEXE) -I..\lib harness $(TEST_SWITCHES) $(TEST_FILES)
cd ..\win32
+test_porting : test-prep
+ cd ..\t
+ $(PERLEXE) -I..\lib harness $(TEST_SWITCHES) porting\*.t ..\lib\diagnostics.t
+ cd ..\win32
+
test-reonly : reonly utils
$(XCOPY) $(PERLEXE) ..\t\$(NULL)
$(XCOPY) $(PERLDLL) ..\t\$(NULL)
@@ -1279,7 +1371,7 @@
-@$(DEL) $(PERLSTATICLIB)
-@$(DEL) $(PERLDLL)
-@$(DEL) $(CORE_OBJ)
- -@$(DEL) $(GENUUDMAP) $(GENUUDMAP_OBJ) $(UUDMAP_H) $(BITCOUNT_H)
+ -@$(DEL) $(GENUUDMAP) $(GENUUDMAP_OBJ) $(GENERATED_HEADERS)
-if exist $(MINIDIR) rmdir /s /q $(MINIDIR)
-if exist $(UNIDATADIR1) rmdir /s /q $(UNIDATADIR1)
-if exist $(UNIDATADIR2) rmdir /s /q $(UNIDATADIR2)
Property changes on: trunk/contrib/perl/win32/Makefile
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/win32/Makefile.ce
===================================================================
--- trunk/contrib/perl/win32/Makefile.ce 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/Makefile.ce 2013-12-02 21:26:09 UTC (rev 6439)
@@ -5,8 +5,7 @@
#
SRCDIR = ..
-PV = 59
-INST_VER = 5.14.0
+PV = 517
# INSTALL_ROOT specifies a path where this perl will be installed on CE device
INSTALL_ROOT=/netzwerk/sprache/perl
@@ -82,6 +81,7 @@
#MACHINE=wince-mips-palm-wce211
#MACHINE=wince-sh3-palm-wce211
#MACHINE=wince-x86em-palm-wce211
+#MACHINE=wince-x86-hpc-wce300
!endif
# set this to your email address
@@ -336,6 +336,24 @@
$(CECONSOLEDIR)/$(MACHINE)/w32console.obj
!endif
+!if "$(MACHINE)" == "wince-x86-hpc-wce300"
+CC = cl.exe
+ARCH = X86EM
+CPU = X86
+TARGETCPU = X86
+CEVersion = 400
+OSVERSION = WCE400
+PLATFORM = MS Pocket PC
+MCFLAGS = -DX86 -D_X86_ -Dx86 -DPROCESSOR_X86 -D _MT -D _DLL \
+ -DPALM_SIZE -DPOCKET_SIZE -I $(CELIBDLLDIR)\inc
+MACH = -machine:IX86
+SUBSYS = -subsystem:windowsce,2.0
+CELIBPATH = $(CELIBDLLDIR)\wince-x86-hpc-wce300-release
+LDLIBPATH = -libpath:$(CELIBPATH)
+STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \
+ $(CECONSOLEDIR)/$(MACHINE)/w32console.obj
+!endif
+
######################################################################
# common section
@@ -363,6 +381,9 @@
PATH=$(CEPATH);$(PATH)
+# attention, for eVC 4, these paths are not generated correctly since the
+# WinCE SDK is organized differently from eVC 3, replace the next 2 macros
+# with absolute paths to the correct directories on your system
INCLUDE=$(WCEROOT)\$(OSVERSION)\$(PLATFORM)\include
LIB=$(WCEROOT)\$(OSVERSION)\$(PLATFORM)\lib\$(ARCH)
@@ -472,8 +493,9 @@
CELIB = celib.lib
!endif
+#use ws2.lib instead of winsock.lib for WSAGetLastError
CELIBS = -nodefaultlib \
- winsock.lib $(CELIB) coredll.lib
+ ws2.lib $(CELIB) coredll.lib
!if $(CEVersion) > 200
CELIBS = $(CELIBS) corelibc.lib
@@ -488,10 +510,10 @@
CFLAGS = -nologo -Gf -W3 $(INCLUDES) $(DEFINES) $(LOCDEFS) \
$(PCHFLAGS) $(OPTIMIZE)
-LINK_FLAGS = -nologo -machine:$(PROCESSOR_ARCHITECTURE)
+LINK_FLAGS = -nologo -opt:ref,icf -machine:$(PROCESSOR_ARCHITECTURE)
!if "$(CFG)" == "DEBUG"
-LINK_FLAGS = $(LINK_FLAGS) -debug:full -pdb:none
+LINK_FLAGS = $(LINK_FLAGS) -debug
!else
LINK_FLAGS = $(LINK_FLAGS) -release
!endif
@@ -512,6 +534,9 @@
.c$(o):
$(CC) -c -I$(<D) $(CFLAGS_O) $(OBJOUT_FLAG)$@ $<
+.c.i:
+ $(CC) -c -I$(<D) $(CFLAGS_O) -P $(OBJOUT_FLAG)$@ $<
+
.y.c:
$(NOOP)
@@ -535,11 +560,18 @@
MINIMOD = ..\lib\ExtUtils\Miniperl.pm
# Unicode data files generated by mktables
+FIRSTUNIFILE = ..\lib\unicore\Decomposition.pl
UNIDATAFILES = ..\lib\unicore\Decomposition.pl \
..\lib\unicore\CombiningClass.pl ..\lib\unicore\Name.pl \
..\lib\unicore\Heavy.pl ..\lib\unicore\mktables.lst \
+ ..\lib\unicore\UCD.pl ..\lib\unicore\Name.pm \
..\lib\unicore\TestProp.pl
+PERLEXE_MANIFEST= .\perlexe.manifest
+PERLEXE_ICO = .\perlexe.ico
+PERLEXE_RES = .\perlexe.res
+PERLDLL_RES =
+
# Directories of Unicode data files generated by mktables
UNIDATADIR1 = ..\lib\unicore\To
UNIDATADIR2 = ..\lib\unicore\lib
@@ -555,12 +587,6 @@
CFGSH_TMPL = config.ce
CFGH_TMPL = config_H.ce
-#
-# filenames given to xsubpp must have forward slashes (since it puts
-# full pathnames in #line strings)
-XSUBPP = $(HPERL) -I..\..\lib -MCross=$(CROSS_NAME) ..\$(EXTUTILSDIR)\xsubpp \
- -C++ -prototypes
-
MICROCORE_SRC = \
..\av.c \
..\deb.c \
@@ -571,8 +597,11 @@
..\gv.c \
..\mro.c \
..\hv.c \
+ ..\locale.c \
..\keywords.c \
+ ..\mathoms.c \
..\mg.c \
+ ..\numeric.c \
..\op.c \
..\pad.c \
..\perl.c \
@@ -613,8 +642,6 @@
WIN32_SRC = $(WIN32_SRC) .\$(CRYPT_SRC)
!ENDIF
-DLL_SRC = $(DYNALOADER).c
-
CORE_NOCFG_H = \
..\av.h \
..\cop.h \
@@ -625,6 +652,7 @@
..\gv.h \
..\handy.h \
..\hv.h \
+ ..\hv_func.h \
..\iperlsys.h \
..\mg.h \
..\nostdio.h \
@@ -669,7 +697,6 @@
$(ERRNO_PM)
CFG_VARS = \
- "INST_DRV=$(INST_DRV)" \
"INST_TOP=$(INST_TOP)" \
"INST_VER=$(INST_VER)" \
"INST_ARCH=$(INST_ARCH)" \
@@ -695,7 +722,17 @@
"LINK_FLAGS=$(LDLIBPATH) $(LINK_FLAGS) $(SUBSYS)" \
"optimize=$(OPTIMIZE)"
+ICWD = -I..\dist\Cwd -I..\dist\Cwd\lib
+ICWD1 = -I..\..\dist\Cwd -I..\..\dist\Cwd\lib
+
#
+# filenames given to xsubpp must have forward slashes (since it puts
+# full pathnames in #line strings)
+XSUBPP = $(HPERL) -I..\..\lib $(ICWD1) -MCross=$(CROSS_NAME) ..\$(EXTUTILSDIR)\xsubpp \
+ -C++ -prototypes
+
+
+#
# Top targets
#
@@ -703,8 +740,8 @@
$(DYNALOADER)$(o) : $(DYNALOADER).c xconfig.h $(EXTDIR)\DynaLoader\dlutils.c
-$(CONFIGPM) : $(HPERL) ..\config.sh .\xconfig.h config_h.PL ..\minimod.pl
- cd .. && $(HPERL) configpm --cross=$(CROSS_NAME) --no-glossary
+$(CONFIGPM) : $(HPERL) ..\Cross\config-$(MACHINE).sh config_h.PL ..\minimod.pl
+ cd .. && $(HPERL) -Ilib configpm --cross=$(CROSS_NAME) --no-glossary
-mkdir $(XCOREDIR)
$(XCOPY) ..\*.h $(XCOREDIR)\*.*
$(XCOPY) ..\*.inc $(XCOREDIR)\*.*
@@ -715,30 +752,15 @@
.\xconfig.h:
-del /f xconfig.h
-mkdir $(XCOREDIR)
- -$(HPERL) -I..\lib -MCross=$(CROSS_NAME) config_h.PL "INST_VER=$(INST_VER)" "CORE_DIR=$(XCOREDIR)" "CONFIG_H=xconfig.h"
+ -$(HPERL) -I..\lib $(ICWD) -MCross=$(CROSS_NAME) config_h.PL "INST_VER=$(INST_VER)" "CORE_DIR=$(XCOREDIR)" "CONFIG_H=xconfig.h"
$(XCOPY) xconfig.h $(XCOREDIR)\config.h
-..\config.sh: config.ce config_sh.PL
- $(HPERL) -I..\lib -I. config_sh.PL $(CFG_VARS) config.ce > ..\config.sh
+..\Cross\config-$(MACHINE).sh: config.ce config_sh.PL
+ $(HPERL) -I..\lib -I. config_sh.PL $(CFG_VARS) config.ce > ..\Cross\config-$(MACHINE).sh
$(MINIMOD) : ..\minimod.pl
cd .. && $(HPERL) minimod.pl > lib\ExtUtils\Miniperl.pm
-$(DYNALOADER).c: $(EXTDIR)\DynaLoader\dl_win32.xs $(CONFIGPM)
- if not exist $(AUTODIR) mkdir $(AUTODIR)
- cd $(EXTDIR)\$(*B)
- $(HPERL) -I..\..\lib -MCross=$(CROSS_NAME) $(*B)_pm.PL
- $(HPERL) -I..\..\lib -MCross=$(CROSS_NAME) XSLoader_pm.PL
- cd ..\..\win32
- $(XCOPY) $(EXTDIR)\$(*B)\$(*B).pm $(LIBDIR)\$(NULL)
- $(XCOPY) $(EXTDIR)\$(*B)\XSLoader.pm $(LIBDIR)\$(NULL)
- cd $(EXTDIR)\$(*B)
- $(XSUBPP) dl_win32.xs > $(*B).c
- cd ..\..\win32
-
-$(EXTDIR)\DynaLoader\dl_win32.xs: dl_win32.xs
- $(COPY) dl_win32.xs $(EXTDIR)\DynaLoader\dl_win32.xs
-
MakePPPort: $(MINIPERL) $(CONFIGPM)
$(HPERL) -I..\lib -MCross=$(CROSS_NAME) ..\mkppport
@@ -763,8 +785,8 @@
#----------------------------------------------------------------------------------
-$(PERLEXE_RES): perl.rc perl.ico
- rc $(RCDEFS) perl.rc
+$(PERLEXE_RES): perlexe.rc perl.rc $(PERLEXE_MANIFEST) $(PERLEXE_ICO)
+ rc $(RCDEFS) perlexe.rc
clean:
-rm -f $(MACHINE)/dll/*
@@ -772,7 +794,7 @@
-rm -f $(MACHINE)/*.exe
-rm -f $(MACHINE)/*.dll
-rm -f $(MACHINE)/*.lib
- -rm -f ../config.sh ../lib/Config.pm
+ -rm -f ..\Cross\config-$(MACHINE).sh ../lib/Config.pm
-rm -f config.h xconfig.h perl.res
-rm -f ../t/test_state
@@ -787,6 +809,7 @@
$(DLLDIR)\mro.obj \
$(DLLDIR)\hv.obj \
$(DLLDIR)\locale.obj \
+$(DLLDIR)\keywords.obj \
$(DLLDIR)\mathoms.obj \
$(DLLDIR)\mg.obj \
$(DLLDIR)\numeric.obj \
@@ -845,13 +868,13 @@
rem (frustrated) mv perllib.obj $(DLLDIR)
!ENDIF
-perldll.def : $(HPERL) $(CONFIGPM) ..\global.sym ..\makedef.pl create_perllibst_h.pl
- $(HPERL) -MCross -I..\lib create_perllibst_h.pl
- $(HPERL) -w ..\makedef.pl PLATFORM=wince $(OPTIMIZE) $(DEFINES) $(BUILDOPT) \
- CCTYPE=$(CCTYPE) -DPERL_DLL=$(PERLDLL) > perldll.def
+perldll.def : $(HPERL) $(CONFIGPM) ..\embed.fnc ..\makedef.pl create_perllibst_h.pl .\xconfig.h
+ $(HPERL) -I..\lib -MCross create_perllibst_h.pl
+ $(HPERL) -I..\lib -MCross -w ..\makedef.pl PLATFORM=wince $(OPTIMIZE) $(DEFINES) $(BUILDOPT) \
+ CCTYPE=$(CCTYPE) -DPERL_DLL=$(PERLDLL) TARG_DIR=..\ > perldll.def
$(PERLDLL) : $(DLLDIR) perldll.def $(XDLLOBJS) $(PERLDLL_RES)
- $(LINK32) -dll -def:perldll.def -out:$@ \
+ $(LINK32) -dll -def:perldll.def -base:0x28000000 -out:$@ \
$(SUBSYS) $(LDLIBPATH) \
$(LINK_FLAGS) $(LIBFILES) \
$(XDLLOBJS) $(PERLDLL_RES)
@@ -914,7 +937,7 @@
$(UNIDATAFILES) : $(HPERL) $(CONFIGPM) ..\lib\unicore\mktables
cd ..\lib\unicore && \
- $(HPERL) -I.. mktables -P ..\..\pod -maketest -makelist -p
+ $(HPERL) -I.. -I..\..\lib $(ICWD1) -MCross=$(CROSS_NAME) mktables -P ..\..\pod -maketest -makelist -p -check $@ $(FIRSTUNIFILE)
dist: all
$(HPERL) -I..\lib -MCross=$(CROSS_NAME) ce-helpers\makedist.pl --distdir=dist-$(CROSS_NAME) --cross-name=$(CROSS_NAME)
Property changes on: trunk/contrib/perl/win32/Makefile.ce
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/win32/bin/exetype.pl
===================================================================
--- trunk/contrib/perl/win32/bin/exetype.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/bin/exetype.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/win32/bin/exetype.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/win32/bin/perlglob.pl
===================================================================
--- trunk/contrib/perl/win32/bin/perlglob.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/bin/perlglob.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/win32/bin/perlglob.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/win32/bin/pl2bat.pl
===================================================================
--- trunk/contrib/perl/win32/bin/pl2bat.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/bin/pl2bat.pl 2013-12-02 21:26:09 UTC (rev 6439)
@@ -26,7 +26,7 @@
a /^#!.*perl/ line was already present).
-s stripsuffix strip this suffix from file before appending ".bat"
Not case-sensitive
- Can be a regex if it begins with `/'
+ Can be a regex if it begins with '/'
Defaults to "/\.plx?/"
-h show this help
EOT
@@ -335,7 +335,7 @@
Strip a suffix string from file name before appending a ".bat"
suffix. The suffix is not case-sensitive. It can be a regex if
-it begins with `/' (the trailing '/' is optional and a trailing
+it begins with '/' (the trailing '/' is optional and a trailing
C<$> is always assumed). Defaults to C</.plx?/>.
=item B<-w>
@@ -363,21 +363,21 @@
C:\> pl2bat foo.pl bar.PM
[..creates foo.bat, bar.PM.bat..]
-
+
C:\> pl2bat -s "/\.pl|\.pm/" foo.pl bar.PM
[..creates foo.bat, bar.bat..]
-
+
C:\> pl2bat < somefile > another.bat
-
+
C:\> pl2bat > another.bat
print scalar reverse "rekcah lrep rehtona tsuj\n";
^Z
[..another.bat is now a certified japh application..]
-
+
C:\> ren *.bat *.pl
C:\> pl2bat -u *.pl
[..updates the wrapping of some previously wrapped scripts..]
-
+
C:\> pl2bat -u -s .bat *.bat
[..same as previous example except more dangerous..]
Property changes on: trunk/contrib/perl/win32/bin/pl2bat.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/win32/bin/runperl.pl
===================================================================
--- trunk/contrib/perl/win32/bin/runperl.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/bin/runperl.pl 2013-12-02 21:26:09 UTC (rev 6439)
@@ -6,10 +6,10 @@
$_ = "." if $_ eq "";
$0 = "$_/$0" , goto doit if -f "$_/$0";
}
- die "`$0' not found.\n";
+ die "'$0' not found.\n";
}
doit: exec "perl", "-x", $0, @ARGV;
-die "Failed to exec `$0': $!";
+die "Failed to exec '$0': $!";
__END__
=head1 NAME
@@ -20,12 +20,12 @@
C:\> copy runperl.bat foo.bat
C:\> foo
- [..runs the perl script `foo'..]
-
+ [..runs the perl script 'foo'..]
+
C:\> foo.bat
- [..runs the perl script `foo'..]
-
+ [..runs the perl script 'foo'..]
+
=head1 DESCRIPTION
This file can be copied to any file name ending in the ".bat" suffix.
Property changes on: trunk/contrib/perl/win32/bin/runperl.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/win32/bin/search.pl
===================================================================
--- trunk/contrib/perl/win32/bin/search.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/bin/search.pl 2013-12-02 21:26:09 UTC (rev 6439)
@@ -464,7 +464,7 @@
##
if ($underlineOK) {
if ($regex =~ m/[?*+{}()\\.|^\$[]/) {
- warn "$0: warning, can't underline-safe ``$regex''.\n";
+ warn "$0: warning, can't underline-safe '$regex'.\n";
} else {
$regex = join($underline_glue, split(//, $regex));
}
Property changes on: trunk/contrib/perl/win32/bin/search.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/win32/ce-helpers/cecopy-lib.pl
===================================================================
--- trunk/contrib/perl/win32/ce-helpers/cecopy-lib.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/ce-helpers/cecopy-lib.pl 2013-12-02 21:26:09 UTC (rev 6439)
@@ -40,6 +40,7 @@
bytes.pm
Carp.pm
charnames.pm
+ _charnames.pm
Config.pm
constant.pm
Cwd.pm
Property changes on: trunk/contrib/perl/win32/ce-helpers/cecopy-lib.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/win32/ce-helpers/comp.pl
===================================================================
--- trunk/contrib/perl/win32/ce-helpers/comp.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/ce-helpers/comp.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/win32/ce-helpers/comp.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/win32/ce-helpers/compile-all.bat
===================================================================
--- trunk/contrib/perl/win32/ce-helpers/compile-all.bat 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/ce-helpers/compile-all.bat 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/win32/ce-helpers/compile-all.bat
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/win32/ce-helpers/compile.bat
===================================================================
--- trunk/contrib/perl/win32/ce-helpers/compile.bat 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/ce-helpers/compile.bat 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/win32/ce-helpers/compile.bat
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/win32/ce-helpers/makedist.pl
===================================================================
--- trunk/contrib/perl/win32/ce-helpers/makedist.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/ce-helpers/makedist.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/win32/ce-helpers/makedist.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/win32/ce-helpers/registry.bat
===================================================================
--- trunk/contrib/perl/win32/ce-helpers/registry.bat 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/ce-helpers/registry.bat 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/win32/ce-helpers/registry.bat
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/win32/config.bc
===================================================================
--- trunk/contrib/perl/win32/config.bc 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/config.bc 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/win32/config.bc
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/win32/config.ce
===================================================================
--- trunk/contrib/perl/win32/config.ce 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/config.ce 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,8 +1,6 @@
## Configured by: ~cf_email~
## Target system: WINCE
Author=''
-PERL_CONFIG_SH='true'
-CONFIGDOTSH='true'
Date='$Date'
Header=''
Id='$Id'
@@ -13,8 +11,7 @@
Revision='$Revision'
Source=''
State=''
-# keep this for WinCE, as it is used by some mods...
-_a='.lib'
+_a='.lib' # keep this for WinCE, as it is used by some mods...
_exe='.exe'
_o='.obj'
afs='false'
@@ -38,6 +35,7 @@
bin='~INST_TOP~~INST_VER~\bin~INST_ARCH~'
binexp='~INST_TOP~~INST_VER~\bin~INST_ARCH~'
bison=''
+bootstrap_charset='undef'
byacc='byacc'
byteorder='1234'
c=''
@@ -130,11 +128,11 @@
d_const='define'
d_copysignl='undef'
d_cplusplus='undef'
+d_crypt='undef'
d_crypt_r='undef'
-d_crypt='undef'
d_csh='undef'
+d_ctermid='undef'
d_ctermid_r='undef'
-d_ctermid='undef'
d_ctime64='undef'
d_ctime_r='undef'
d_cuserid='undef'
@@ -149,12 +147,12 @@
d_dlopen='define'
d_dlsymun='undef'
d_dosuid='undef'
+d_drand48_r='undef'
d_drand48proto='undef'
-d_drand48_r='undef'
d_dup2='define'
d_eaccess='undef'
+d_endgrent='undef'
d_endgrent_r='undef'
-d_endgrent='undef'
d_endhent='undef'
d_endhostent_r='undef'
d_endnent='undef'
@@ -161,8 +159,8 @@
d_endnetent_r='undef'
d_endpent='undef'
d_endprotoent_r='undef'
+d_endpwent='undef'
d_endpwent_r='undef'
-d_endpwent='undef'
d_endsent='undef'
d_endservent_r='undef'
d_endspent='undef'
@@ -172,23 +170,23 @@
d_fchdir='undef'
d_fchmod='undef'
d_fchown='undef'
+d_fcntl='undef'
d_fcntl_can_lock='undef'
-d_fcntl='undef'
d_fd_macros='define'
+d_fd_set='define'
d_fds_bits='define'
-d_fd_set='define'
d_fgetpos='define'
+d_finite='undef'
d_finitel='undef'
-d_finite='undef'
d_flexfnam='define'
+d_flock='undef'
d_flockproto='undef'
-d_flock='undef'
d_fork='undef'
+d_fp_class='undef'
d_fpathconf='undef'
+d_fpclass='undef'
d_fpclassify='undef'
d_fpclassl='undef'
-d_fp_class='undef'
-d_fpclass='undef'
d_fpos64_t='undef'
d_frexpl='undef'
d_fs_data_s='undef'
@@ -206,8 +204,8 @@
d_getcwd='define'
d_getespwnam='undef'
d_getfsstat='undef'
+d_getgrent='undef'
d_getgrent_r='undef'
-d_getgrent='undef'
d_getgrgid_r='undef'
d_getgrnam_r='undef'
d_getgrps='undef'
@@ -222,8 +220,8 @@
d_getitimer='undef'
d_getlogin='define'
d_getlogin_r='undef'
+d_getmnt='undef'
d_getmntent='undef'
-d_getmnt='undef'
d_getnameinfo='undef'
d_getnbyaddr='undef'
d_getnbyname='undef'
@@ -246,8 +244,8 @@
d_getprotoent_r='undef'
d_getprotoprotos='define'
d_getprpwnam='undef'
+d_getpwent='undef'
d_getpwent_r='undef'
-d_getpwent='undef'
d_getpwnam_r='undef'
d_getpwuid_r='undef'
d_getsbyname='define'
@@ -258,8 +256,8 @@
d_getservent_r='undef'
d_getservprotos='define'
d_getspent='undef'
+d_getspnam='undef'
d_getspnam_r='undef'
-d_getspnam='undef'
d_gettimeod='undef'
d_gmtime64='undef'
d_gmtime_r='undef'
@@ -274,7 +272,12 @@
d_inetntop='undef'
d_inetpton='undef'
d_int64_t='undef'
+d_ip_mreq='undef'
+d_ip_mreq_source='undef'
+d_ipv6_mreq='undef'
+d_ipv6_mreq_source='undef'
d_isascii='define'
+d_isblank='undef'
d_isfinite='undef'
d_isinf='undef'
d_isnan='define'
@@ -285,8 +288,8 @@
d_libm_lib_version='undef'
d_link='define'
d_localtime64='undef'
+d_localtime_r='undef'
d_localtime_r_needs_tzset='undef'
-d_localtime_r='undef'
d_locconv='define'
d_lockf='undef'
d_longdbl='undef'
@@ -307,26 +310,26 @@
d_mkdir='define'
d_mkdtemp='undef'
d_mkfifo='undef'
+d_mkstemp='undef'
d_mkstemps='undef'
-d_mkstemp='undef'
d_mktime64='undef'
d_mktime='define'
d_mmap='undef'
+d_modfl='undef'
d_modfl_pow32_bug='undef'
d_modflproto='undef'
-d_modfl='undef'
d_mprotect='undef'
-d_msgctl='undef'
+d_msg='undef'
d_msg_ctrunc='undef'
d_msg_dontroute='undef'
-d_msgget='undef'
-d_msghdr_s='undef'
d_msg_oob='undef'
d_msg_peek='undef'
d_msg_proxy='undef'
+d_msgctl='undef'
+d_msgget='undef'
+d_msghdr_s='undef'
d_msgrcv='undef'
d_msgsnd='undef'
-d_msg='undef'
d_msync='undef'
d_munmap='undef'
d_mymalloc='~PERL_MALLOC~'
@@ -438,6 +441,7 @@
d_sin6_scope_id='undef'
d_sitearch='define'
d_snprintf='undef'
+d_sockaddr_in6='undef'
d_sockaddr_sa_len='undef'
d_sockatmark='undef'
d_sockatmarkproto='undef'
@@ -452,9 +456,9 @@
d_sresgproto='undef'
d_sresuproto='undef'
d_statblks='undef'
-d_static_inline='undef'
d_statfs_f_flags='undef'
d_statfs_s='undef'
+d_static_inline='undef'
d_statvfs='undef'
d_stdio_cnt_lval='undef'
d_stdio_ptr_lval='undef'
@@ -657,6 +661,7 @@
i_shadow='undef'
i_socks='undef'
i_stdarg='define'
+i_stdbool='undef'
i_stddef='define'
i_stdlib='define'
i_string='define'
@@ -799,8 +804,8 @@
nm_so_opt=''
nonxs_ext='Errno'
nroff=''
+nv_overflows_integers_at='256.0*256.0*256.0*256.0*256.0*256.0*2.0*2.0*2.0*2.0*2.0'
nv_preserves_uv_bits='32'
-nv_overflows_integers_at='256.0*256.0*256.0*256.0*256.0*256.0*2.0*2.0*2.0*2.0*2.0'
nveformat='"e"'
nvfformat='"f"'
nvgformat='"g"'
@@ -822,9 +827,9 @@
perl5=''
perl='perl'
perl_patchlevel='~PERL_PATCHLEVEL~'
+perl_static_inline='static'
perladmin=''
perlpath='~INST_TOP~~INST_VER~\bin~INST_ARCH~\perl.exe'
-perl_static_inline='static'
pg=''
phostname='hostname'
pidtype='int'
@@ -832,7 +837,7 @@
pmake=''
pr=''
prefix='~INST_TOP~'
-prefixexp='~INST_DRV~'
+prefixexp='~INST_TOP~'
privlib='~INST_TOP~~INST_VER~\lib'
privlibexp='~INST_TOP~~INST_VER~\lib'
procselfexe=''
@@ -924,6 +929,8 @@
srandom_r_proto='0'
src=''
ssizetype='int'
+st_ino_sign='1'
+st_ino_size='4'
startperl='#!perl'
startsh='#!/bin/sh'
static_ext='DynaLoader'
@@ -937,7 +944,7 @@
strerror_r_proto='0'
strings='/usr/include/string.h'
submit=''
-subversion='~SUBVERSION~'
+subversion='~PERL_SUBVERSION~'
sysman='/usr/man/man1'
tail=''
tar=''
@@ -977,6 +984,7 @@
usedtrace='undef'
usefaststdio='undef'
useithreads='~USE_ITHREADS~'
+usekernprocpathname='undef'
uselargefiles='undef'
uselongdouble='undef'
usemallocwrap='define'
@@ -984,6 +992,7 @@
usemultiplicity='undef'
usemymalloc='n'
usenm='false'
+usensgetexecutablepath='undef'
useopcode='true'
useperlio='~USE_PERLIO~'
useposix='true'
@@ -1014,7 +1023,7 @@
vendorlibexp=''
vendorprefix=''
vendorprefixexp=''
-version='~VERSION~'
+version=''
versiononly='undef'
vi=''
voidflags='15'
@@ -1030,3 +1039,4 @@
PATCHLEVEL='~PERL_VERSION~'
PERL_PATCHLEVEL='~PERL_PATCHLEVEL~'
PERL_CONFIG_SH='true'
+CONFIGDOTSH='true'
Property changes on: trunk/contrib/perl/win32/config.ce
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/win32/config.gc
===================================================================
--- trunk/contrib/perl/win32/config.gc 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/config.gc 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,5 +1,5 @@
## Configured by: ~cf_email~
-## Target system: WIN32
+## Target system: WIN32
Author=''
Date='$Date'
Header=''
@@ -22,7 +22,7 @@
api_subversion='~PERL_API_SUBVERSION~'
api_version='~PERL_API_VERSION~'
api_versionstring='~PERL_API_REVISION~.~PERL_API_VERSION~.~PERL_API_SUBVERSION~'
-ar='ar'
+ar='~ARCHPREFIX~ar'
archlib='~INST_TOP~~INST_VER~\lib~INST_ARCH~'
archlibexp='~INST_TOP~~INST_VER~\lib~INST_ARCH~'
archname64=''
@@ -35,12 +35,13 @@
bin='~INST_TOP~~INST_VER~\bin~INST_ARCH~'
binexp='~INST_TOP~~INST_VER~\bin~INST_ARCH~'
bison=''
+bootstrap_charset='undef'
byacc='byacc'
byteorder='1234'
c=''
castflags='0'
cat='type'
-cc='gcc'
+cc='~ARCHPREFIX~gcc'
cccdlflags=' '
ccdlflags=' '
ccflags='-MD -DWIN32'
@@ -170,14 +171,14 @@
d_fchdir='undef'
d_fchmod='undef'
d_fchown='undef'
+d_fcntl='undef'
d_fcntl_can_lock='undef'
-d_fcntl='undef'
d_fd_macros='define'
d_fd_set='define'
d_fds_bits='define'
d_fgetpos='define'
+d_finite='undef'
d_finitel='undef'
-d_finite='undef'
d_flexfnam='define'
d_flock='define'
d_flockproto='define'
@@ -271,7 +272,12 @@
d_inetntop='undef'
d_inetpton='undef'
d_int64_t='undef'
+d_ip_mreq='undef'
+d_ip_mreq_source='undef'
+d_ipv6_mreq='undef'
+d_ipv6_mreq_source='undef'
d_isascii='define'
+d_isblank='undef'
d_isfinite='undef'
d_isinf='undef'
d_isnan='define'
@@ -287,7 +293,7 @@
d_locconv='define'
d_lockf='undef'
d_longdbl='define'
-d_longlong='undef'
+d_longlong='define'
d_lseekproto='define'
d_lstat='undef'
d_madvise='undef'
@@ -313,17 +319,17 @@
d_modfl_pow32_bug='undef'
d_modflproto='undef'
d_mprotect='undef'
-d_msgctl='undef'
+d_msg='undef'
d_msg_ctrunc='undef'
d_msg_dontroute='undef'
-d_msgget='undef'
-d_msghdr_s='undef'
d_msg_oob='undef'
d_msg_peek='undef'
d_msg_proxy='undef'
+d_msgctl='undef'
+d_msgget='undef'
+d_msghdr_s='undef'
d_msgrcv='undef'
d_msgsnd='undef'
-d_msg='undef'
d_msync='undef'
d_munmap='undef'
d_mymalloc='undef'
@@ -435,6 +441,7 @@
d_sin6_scope_id='define'
d_sitearch='define'
d_snprintf='define'
+d_sockaddr_in6='undef'
d_sockaddr_sa_len='undef'
d_sockatmark='undef'
d_sockatmarkproto='undef'
@@ -449,9 +456,9 @@
d_sresgproto='undef'
d_sresuproto='undef'
d_statblks='undef'
-d_static_inline='define'
d_statfs_f_flags='undef'
d_statfs_s='undef'
+d_static_inline='define'
d_statvfs='undef'
d_stdio_cnt_lval='define'
d_stdio_ptr_lval='define'
@@ -535,6 +542,7 @@
defvoidused='15'
direntrytype='struct direct'
dlext='dll'
+dlltool='~ARCHPREFIX~dlltool'
dlsrc='dl_win32.xs'
doublesize='8'
drand01='(rand()/(double)((unsigned)1<<RANDBITS))'
@@ -665,6 +673,7 @@
i_shadow='undef'
i_socks='undef'
i_stdarg='define'
+i_stdbool='undef'
i_stddef='define'
i_stdlib='define'
i_string='define'
@@ -751,7 +760,7 @@
ivtype='long'
known_extensions='~static_ext~ ~dynamic_ext~ ~nonxs_ext~'
ksh=''
-ld='g++'
+ld='~ARCHPREFIX~g++'
lddlflags='-mdll ~LINK_FLAGS~'
ldflags='~LINK_FLAGS~'
ldflags_uselargefiles=''
@@ -819,7 +828,7 @@
netdb_host_type='char *'
netdb_name_type='char *'
netdb_net_type='long'
-nm='nm'
+nm='~ARCHPREFIX~nm'
nm_opt=''
nm_so_opt=''
nonxs_ext='Errno'
@@ -850,10 +859,10 @@
perl5=''
perl='perl'
perl_patchlevel='~PERL_PATCHLEVEL~'
+perl_static_inline='static __inline__'
perladmin=''
perllibs='~libs~'
perlpath='~INST_TOP~~INST_VER~\bin~INST_ARCH~\perl.exe'
-perl_static_inline='static __inline__'
pg=''
phostname='hostname'
pidtype='int'
@@ -963,6 +972,8 @@
srandom_r_proto='0'
src=''
ssizetype='int'
+st_ino_sign='1'
+st_ino_size='4'
startperl='#!perl'
startsh='#!/bin/sh'
static_ext=' '
@@ -976,7 +987,7 @@
strerror_r_proto='0'
strings='/usr/include/string.h'
submit=''
-subversion='~SUBVERSION~'
+subversion='~PERL_SUBVERSION~'
sysman='/usr/man/man1'
tail=''
tar=''
@@ -1017,6 +1028,7 @@
usedtrace='undef'
usefaststdio='undef'
useithreads='undef'
+usekernprocpathname='undef'
uselargefiles='undef'
uselongdouble='undef'
usemallocwrap='define'
@@ -1024,6 +1036,7 @@
usemultiplicity='undef'
usemymalloc='n'
usenm='false'
+usensgetexecutablepath='undef'
useopcode='true'
useperlio='undef'
useposix='true'
@@ -1064,7 +1077,7 @@
vendorprefixexp=''
vendorscript=''
vendorscriptexp=''
-version='~VERSION~'
+version=''
version_patchlevel_string=''
versiononly='undef'
vi=''
Property changes on: trunk/contrib/perl/win32/config.gc
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/win32/config.gc64
===================================================================
--- trunk/contrib/perl/win32/config.gc64 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/config.gc64 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/win32/config.gc64
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/win32/config.gc64nox
===================================================================
--- trunk/contrib/perl/win32/config.gc64nox 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/config.gc64nox 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/win32/config.gc64nox
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/win32/config.vc
===================================================================
--- trunk/contrib/perl/win32/config.vc 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/config.vc 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,5 +1,5 @@
## Configured by: ~cf_email~
-## Target system: WIN32
+## Target system: WIN32
Author=''
Date='$Date'
Header=''
@@ -35,6 +35,7 @@
bin='~INST_TOP~~INST_VER~\bin~INST_ARCH~'
binexp='~INST_TOP~~INST_VER~\bin~INST_ARCH~'
bison=''
+bootstrap_charset='undef'
byacc='byacc'
byteorder='1234'
c=''
@@ -170,14 +171,14 @@
d_fchdir='undef'
d_fchmod='undef'
d_fchown='undef'
+d_fcntl='undef'
d_fcntl_can_lock='undef'
-d_fcntl='undef'
d_fd_macros='define'
d_fd_set='define'
d_fds_bits='define'
d_fgetpos='define'
+d_finite='undef'
d_finitel='undef'
-d_finite='undef'
d_flexfnam='define'
d_flock='define'
d_flockproto='define'
@@ -271,7 +272,12 @@
d_inetntop='undef'
d_inetpton='undef'
d_int64_t='undef'
+d_ip_mreq='undef'
+d_ip_mreq_source='undef'
+d_ipv6_mreq='undef'
+d_ipv6_mreq_source='undef'
d_isascii='define'
+d_isblank='undef'
d_isfinite='undef'
d_isinf='undef'
d_isnan='define'
@@ -313,17 +319,17 @@
d_modfl_pow32_bug='undef'
d_modflproto='undef'
d_mprotect='undef'
-d_msgctl='undef'
+d_msg='undef'
d_msg_ctrunc='undef'
d_msg_dontroute='undef'
-d_msgget='undef'
-d_msghdr_s='undef'
d_msg_oob='undef'
d_msg_peek='undef'
d_msg_proxy='undef'
+d_msgctl='undef'
+d_msgget='undef'
+d_msghdr_s='undef'
d_msgrcv='undef'
d_msgsnd='undef'
-d_msg='undef'
d_msync='undef'
d_munmap='undef'
d_mymalloc='undef'
@@ -435,6 +441,7 @@
d_sin6_scope_id='define'
d_sitearch='define'
d_snprintf='define'
+d_sockaddr_in6='undef'
d_sockaddr_sa_len='undef'
d_sockatmark='undef'
d_sockatmarkproto='undef'
@@ -449,9 +456,9 @@
d_sresgproto='undef'
d_sresuproto='undef'
d_statblks='undef'
-d_static_inline='define'
d_statfs_f_flags='undef'
d_statfs_s='undef'
+d_static_inline='define'
d_statvfs='undef'
d_stdio_cnt_lval='define'
d_stdio_ptr_lval='define'
@@ -665,6 +672,7 @@
i_shadow='undef'
i_socks='undef'
i_stdarg='define'
+i_stdbool='undef'
i_stddef='define'
i_stdlib='define'
i_string='define'
@@ -850,10 +858,10 @@
perl5=''
perl='perl'
perl_patchlevel='~PERL_PATCHLEVEL~'
+perl_static_inline='static __inline'
perladmin=''
perllibs='~libs~'
perlpath='~INST_TOP~~INST_VER~\bin~INST_ARCH~\perl.exe'
-perl_static_inline='static __inline'
pg=''
phostname='hostname'
pidtype='int'
@@ -963,6 +971,8 @@
srandom_r_proto='0'
src=''
ssizetype='int'
+st_ino_sign='1'
+st_ino_size='4'
startperl='#!perl'
startsh='#!/bin/sh'
static_ext=' '
@@ -976,7 +986,7 @@
strerror_r_proto='0'
strings='/usr/include/string.h'
submit=''
-subversion='~SUBVERSION~'
+subversion='~PERL_SUBVERSION~'
sysman='/usr/man/man1'
tail=''
tar=''
@@ -1017,6 +1027,7 @@
usedtrace='undef'
usefaststdio='undef'
useithreads='undef'
+usekernprocpathname='undef'
uselargefiles='undef'
uselongdouble='undef'
usemallocwrap='define'
@@ -1024,6 +1035,7 @@
usemultiplicity='undef'
usemymalloc='n'
usenm='false'
+usensgetexecutablepath='undef'
useopcode='true'
useperlio='undef'
useposix='true'
@@ -1064,7 +1076,7 @@
vendorprefixexp=''
vendorscript=''
vendorscriptexp=''
-version='~VERSION~'
+version=''
version_patchlevel_string=''
versiononly='undef'
vi=''
Property changes on: trunk/contrib/perl/win32/config.vc
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/win32/config.vc64
===================================================================
--- trunk/contrib/perl/win32/config.vc64 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/config.vc64 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/win32/config.vc64
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/win32/config_H.bc
===================================================================
--- trunk/contrib/perl/win32/config_H.bc 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/config_H.bc 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/win32/config_H.bc
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/win32/config_H.ce
===================================================================
--- trunk/contrib/perl/win32/config_H.ce 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/config_H.ce 2013-12-02 21:26:09 UTC (rev 6439)
@@ -7,7 +7,7 @@
* that running config_h.SH again will wipe out any changes you've made.
* For a more permanent change edit undef and rerun config_h.SH.
*
- * $Id: config_H.ce,v 1.1.1.1 2011-05-19 23:03:36 laffer1 Exp $
+ * $Id: Config_h.U,v 3.0.1.5 1997/02/28 14:57:43 ram Exp $
*/
/*
@@ -1050,6 +1050,12 @@
#define BYTEORDER 0x1234 /* large digits for MSB */
#endif /* NeXT */
+/* CHARBITS:
+ * This symbol contains the size of a char, so that the C preprocessor
+ * can make decisions based on it.
+ */
+#define CHARBITS 8 /**/
+
/* CAT2:
* This macro concatenates 2 tokens together.
*/
@@ -1889,9 +1895,16 @@
/* LOCALTIME_R_NEEDS_TZSET:
* Many libc's localtime_r implementations do not call tzset,
* making them differ from localtime(), and making timezone
- * changes using $ENV{TZ} without explicitly calling tzset
+ * changes using \undef{TZ} without explicitly calling tzset
* impossible. This symbol makes us call tzset before localtime_r
*/
+/*#define LOCALTIME_R_NEEDS_TZSET /**/
+#ifdef LOCALTIME_R_NEEDS_TZSET
+#define L_R_TZSET tzset(),
+#else
+#define L_R_TZSET
+#endif
+
/* LOCALTIME_R_PROTO:
* This symbol encodes the prototype of localtime_r.
* It is zero if d_localtime_r is undef, and one of the
@@ -1899,7 +1912,6 @@
* is defined.
*/
/*#define HAS_LOCALTIME_R /**/
-/*#define LOCALTIME_R_NEEDS_TZSET /**/
#define LOCALTIME_R_PROTO 0 /**/
/* HAS_LONG_DOUBLE:
@@ -4420,5 +4432,25 @@
*/
/*#define HAS_TTYNAME_R /**/
#define TTYNAME_R_PROTO 0 /**/
+/* GMTIME_MAX:
+ * This symbol contains the maximum value for the time_t offset that
+ * the system function gmtime () accepts, and defaults to 0
+ */
+/* GMTIME_MIN:
+ * This symbol contains the minimum value for the time_t offset that
+ * the system function gmtime () accepts, and defaults to 0
+ */
+/* LOCALTIME_MAX:
+ * This symbol contains the maximum value for the time_t offset that
+ * the system function localtime () accepts, and defaults to 0
+ */
+/* LOCALTIME_MIN:
+ * This symbol contains the minimum value for the time_t offset that
+ * the system function localtime () accepts, and defaults to 0
+ */
+#define GMTIME_MAX 2147483647 /**/
+#define GMTIME_MIN 0 /**/
+#define LOCALTIME_MAX 2147483647 /**/
+#define LOCALTIME_MIN 0 /**/
#endif
Property changes on: trunk/contrib/perl/win32/config_H.ce
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/win32/config_H.gc
===================================================================
--- trunk/contrib/perl/win32/config_H.gc 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/config_H.gc 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,5 +1,4 @@
-/*
- * This file was produced by running the config_h.SH script, which
+/* This file was produced by running the config_h.SH script, which
* gets its values from undef, which is generally produced by
* running Configure.
*
@@ -6,14 +5,11 @@
* Feel free to modify any of this as the need arises. Note, however,
* that running config_h.SH again will wipe out any changes you've made.
* For a more permanent change edit undef and rerun config_h.SH.
- *
- * $Id: config_H.gc,v 1.1.1.1 2011-05-19 23:03:36 laffer1 Exp $
*/
-/*
- * Package name : perl5
+/* Package name : perl5
* Source directory :
- * Configuration time: Sun Jan 10 19:53:56 2010
+ * Configuration time: Sun Aug 5 17:25:40 2012
* Configured by : Steve
* Target system :
*/
@@ -72,7 +68,7 @@
* This symbol, if defined, indicates that the crypt routine is available
* to encrypt passwords and the like.
*/
-/*#define HAS_CRYPT / **/
+#define HAS_CRYPT /**/
/* HAS_CTERMID:
* This symbol, if defined, indicates that the ctermid routine is
@@ -883,21 +879,30 @@
#define _V(args) ()
#endif
-/* INTSIZE:
- * This symbol contains the value of sizeof(int) so that the C
- * preprocessor can make decisions based on it.
+/* OSNAME:
+ * This symbol contains the name of the operating system, as determined
+ * by Configure. You shouldn't rely on it too much; the specific
+ * feature tests from Configure are generally more reliable.
*/
-/* LONGSIZE:
- * This symbol contains the value of sizeof(long) so that the C
- * preprocessor can make decisions based on it.
+/* OSVERS:
+ * This symbol contains the version of the operating system, as determined
+ * by Configure. You shouldn't rely on it too much; the specific
+ * feature tests from Configure are generally more reliable.
*/
-/* SHORTSIZE:
- * This symbol contains the value of sizeof(short) so that the C
- * preprocessor can make decisions based on it.
+#define OSNAME "MSWin32" /**/
+#define OSVERS "6.1" /**/
+
+/* USE_CROSS_COMPILE:
+ * This symbol, if defined, indicates that Perl is being cross-compiled.
*/
-#define INTSIZE 4 /**/
-#define LONGSIZE 4 /**/
-#define SHORTSIZE 2 /**/
+/* 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
/* MULTIARCH:
* This symbol, if defined, signifies that the build
@@ -908,43 +913,17 @@
*/
/*#define MULTIARCH / **/
-/* HAS_QUAD:
- * This symbol, if defined, tells that there's a 64-bit integer type,
- * Quad_t, and its unsigned counterpar, Uquad_t. QUADKIND will be one
- * of QUAD_IS_INT, QUAD_IS_LONG, QUAD_IS_LONG_LONG, QUAD_IS_INT64_T,
- * or QUAD_IS___INT64.
+/* MEM_ALIGNBYTES:
+ * This symbol contains the number of bytes required to align a
+ * double, or a long double when applicable. Usual values are 2,
+ * 4 and 8. The default is eight, for safety.
*/
-#define HAS_QUAD /**/
-#ifdef HAS_QUAD
-# ifndef _MSC_VER
-# define Quad_t long long /**/
-# define Uquad_t unsigned long long /**/
-# define QUADKIND 3 /**/
-# else
-# define Quad_t __int64 /**/
-# define Uquad_t unsigned __int64 /**/
-# define QUADKIND 5 /**/
-# endif
-# define QUAD_IS_INT 1
-# define QUAD_IS_LONG 2
-# define QUAD_IS_LONG_LONG 3
-# define QUAD_IS_INT64_T 4
-# define QUAD_IS___INT64 5
+#if defined(USE_CROSS_COMPILE) || defined(MULTIARCH)
+# define MEM_ALIGNBYTES 8
+#else
+#define MEM_ALIGNBYTES 8
#endif
-/* OSNAME:
- * This symbol contains the name of the operating system, as determined
- * by Configure. You shouldn't rely on it too much; the specific
- * feature tests from Configure are generally more reliable.
- */
-/* OSVERS:
- * This symbol contains the version of the operating system, as determined
- * by Configure. You shouldn't rely on it too much; the specific
- * feature tests from Configure are generally more reliable.
- */
-#define OSNAME "MSWin32" /**/
-#define OSVERS "5.1" /**/
-
/* ARCHLIB:
* This variable, if defined, holds the name of the directory in
* which the user wants to put architecture-dependent public
@@ -985,6 +964,71 @@
#define BIN_EXP "c:\\perl\\bin" /**/
#define PERL_RELOCATABLE_INC "undef" /**/
+/* INTSIZE:
+ * This symbol contains the value of sizeof(int) so that the C
+ * preprocessor can make decisions based on it.
+ */
+/* LONGSIZE:
+ * This symbol contains the value of sizeof(long) so that the C
+ * preprocessor can make decisions based on it.
+ */
+/* SHORTSIZE:
+ * This symbol contains the value of sizeof(short) so that the C
+ * preprocessor can make decisions based on it.
+ */
+#define INTSIZE 4 /**/
+#define LONGSIZE 4 /**/
+#define SHORTSIZE 2 /**/
+
+/* BYTEORDER:
+ * 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 (eg. on NeXT systems), 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(USE_CROSS_COMPILE) || defined(MULTIARCH)
+# ifdef __LITTLE_ENDIAN__
+# if LONGSIZE == 4
+# define BYTEORDER 0x1234
+# else
+# if LONGSIZE == 8
+# define BYTEORDER 0x12345678
+# endif
+# endif
+# else
+# ifdef __BIG_ENDIAN__
+# if LONGSIZE == 4
+# define BYTEORDER 0x4321
+# else
+# if LONGSIZE == 8
+# define BYTEORDER 0x87654321
+# endif
+# endif
+# endif
+# endif
+# if !defined(BYTEORDER) && (defined(NeXT) || defined(__NeXT__))
+# define BYTEORDER 0x4321
+# endif
+#else
+#define BYTEORDER 0x1234 /* large digits for MSB */
+#endif /* NeXT */
+
+/* CHARBITS:
+ * This symbol contains the size of a char, so that the C preprocessor
+ * can make decisions based on it.
+ */
+#define CHARBITS 8 /**/
+
/* CAT2:
* This macro concatenates 2 tokens together.
*/
@@ -1033,15 +1077,9 @@
* This symbol is intended to be used along with CPPRUN in the same manner
* symbol CPPMINUS is used with CPPSTDIN. It contains either "-" or "".
*/
-#ifndef _MSC_VER
-# define CPPSTDIN "gcc -E"
-# define CPPMINUS "-"
-# define CPPRUN "gcc -E"
-#else
-# define CPPSTDIN "cppstdin"
-# define CPPMINUS ""
-# define CPPRUN "cl -nologo -E"
-#endif
+#define CPPSTDIN "gcc -E"
+#define CPPMINUS "-"
+#define CPPRUN "gcc -E"
#define CPPLAST ""
/* HAS_ACCESS:
@@ -1111,6 +1149,33 @@
/*#define HASATTRIBUTE_UNUSED / **/
/*#define HASATTRIBUTE_WARN_UNUSED_RESULT / **/
+/* CASTI32:
+ * This symbol is defined if the C compiler can cast negative
+ * or large floating point numbers to 32-bit ints.
+ */
+#define CASTI32 /**/
+
+/* CASTNEGFLOAT:
+ * This symbol is defined if the C compiler can cast negative
+ * numbers to unsigned longs, ints and shorts.
+ */
+/* CASTFLAGS:
+ * This symbol contains flags that say what difficulties the compiler
+ * has casting odd floating values to unsigned long:
+ * 0 = ok
+ * 1 = couldn't cast < 0
+ * 2 = couldn't cast >= 0x80000000
+ * 4 = couldn't cast in argument expression list
+ */
+#define CASTNEGFLOAT /**/
+#define CASTFLAGS 0 /**/
+
+/* VOID_CLOSEDIR:
+ * This symbol, if defined, indicates that the closedir() routine
+ * does not return a value.
+ */
+/*#define VOID_CLOSEDIR / **/
+
/* HASCONST:
* This symbol, if defined, indicates that this C compiler knows about
* the const type. There is no need to actually test for that symbol
@@ -1172,6 +1237,26 @@
/*#define HAS_CTIME_R / **/
#define CTIME_R_PROTO 0 /**/
+/* 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.
+ */
+/* DOSUID:
+ * This symbol, if defined, indicates that the C program should
+ * check the script that it is executing for setuid/setgid bits, and
+ * attempt to emulate setuid/setgid on systems that have disabled
+ * setuid #! scripts because the kernel can't do it securely.
+ * It is up to the package designer to make sure that this emulation
+ * is done securely. Among other things, it should do an fstat on
+ * the script it just opened to make sure it really is a setuid/setgid
+ * script, it should make sure the arguments passed correspond exactly
+ * to the argument on the #! line, and it should not trust any
+ * subprocesses to which it must pass the filename rather than the
+ * file descriptor of the script to be executed.
+ */
+/*#define SETUID_SCRIPTS_ARE_SECURE_NOW / **/
+/*#define DOSUID / **/
+
/* HAS_DRAND48_R:
* This symbol, if defined, indicates that the drand48_r routine
* is available to drand48 re-entrantly.
@@ -1313,6 +1398,12 @@
/*#define HAS_ENDSERVENT_R / **/
#define ENDSERVENT_R_PROTO 0 /**/
+/* HAS_FD_SET:
+ * This symbol, when defined, indicates presence of the fd_set typedef
+ * in <sys/types.h>
+ */
+#define HAS_FD_SET /**/
+
/* FLEXFILENAMES:
* This symbol, if defined, indicates that the system supports filenames
* longer than 14 characters.
@@ -1319,6 +1410,23 @@
*/
#define FLEXFILENAMES /**/
+/* Gconvert:
+ * This preprocessor macro is defined to convert a floating point
+ * number to a string without a trailing decimal point. This
+ * emulates the behavior of sprintf("%g"), but is sometimes much more
+ * efficient. If gconvert() is not available, but gcvt() drops the
+ * trailing decimal point, then gcvt() is used. If all else fails,
+ * a macro using sprintf("%g") is used. Arguments for the Gconvert
+ * macro are: value, number of digits, whether trailing zeros should
+ * be retained, and the output buffer.
+ * The usual values are:
+ * d_Gconvert='gconvert((x),(n),(t),(b))'
+ * d_Gconvert='gcvt((x),(n),(b))'
+ * d_Gconvert='sprintf((b),"%.*g",(n),(x))'
+ * The last two assume trailing zeros should not be kept.
+ */
+#define Gconvert(x,n,t,b) sprintf((b),"%.*g",(n),(x))
+
/* HAS_GETGRENT:
* This symbol, if defined, indicates that the getgrent routine is
* available for sequential access of the group database.
@@ -1536,6 +1644,13 @@
*/
/*#define HAS_GETNET_PROTOS / **/
+/* HAS_GETPAGESIZE:
+ * This symbol, if defined, indicates that the getpagesize system call
+ * is available to get system page size, which is the granularity of
+ * many memory management calls.
+ */
+/*#define HAS_GETPAGESIZE / **/
+
/* HAS_GETPROTOENT:
* This symbol, if defined, indicates that the getprotoent() routine is
* available to look up protocols in some data base or another.
@@ -1747,6 +1862,16 @@
/*#define HAS_GMTIME_R / **/
#define GMTIME_R_PROTO 0 /**/
+/* HAS_GNULIBC:
+ * This symbol, if defined, indicates to the C program that
+ * the GNU C library is being used. A better check is to use
+ * the __GLIBC__ and __GLIBC_MINOR__ symbols supplied with glibc.
+ */
+/*#define HAS_GNULIBC / **/
+#if defined(HAS_GNULIBC) && !defined(_GNU_SOURCE)
+# define _GNU_SOURCE
+#endif
+
/* HAS_HTONL:
* This symbol, if defined, indicates that the htonl() routine (and
* friends htons() ntohl() ntohs()) are available to do network
@@ -1772,6 +1897,19 @@
#define HAS_NTOHL /**/
#define HAS_NTOHS /**/
+/* HAS_ISASCII:
+ * This manifest constant lets the C program know that isascii
+ * is available.
+ */
+#define HAS_ISASCII /**/
+
+/* HAS_LCHOWN:
+ * This symbol, if defined, indicates that the lchown routine is
+ * available to operate on a symbolic link (instead of following the
+ * link).
+ */
+/*#define HAS_LCHOWN / **/
+
/* HAS_LOCALTIME_R:
* This symbol, if defined, indicates that the localtime_r routine
* is available to localtime re-entrantly.
@@ -1809,11 +1947,7 @@
*/
#define HAS_LONG_DOUBLE /**/
#ifdef HAS_LONG_DOUBLE
-# ifndef _MSC_VER
-# define LONG_DOUBLESIZE 12 /**/
-# else
-# define LONG_DOUBLESIZE 8 /**/
-# endif
+#define LONG_DOUBLESIZE 12 /**/
#endif
/* HAS_LONG_LONG:
@@ -1824,7 +1958,7 @@
* C preprocessor can make decisions based on it. It is only
* defined if the system supports long long.
*/
-/*#define HAS_LONG_LONG / **/
+#define HAS_LONG_LONG /**/
#ifdef HAS_LONG_LONG
#define LONGLONGSIZE 8 /**/
#endif
@@ -1868,6 +2002,12 @@
*/
/*#define HAS_MSG / **/
+/* HAS_OPEN3:
+ * This manifest constant lets the C program know that the three
+ * argument form of open(2) is available.
+ */
+/*#define HAS_OPEN3 / **/
+
/* OLD_PTHREAD_CREATE_JOINABLE:
* This symbol, if defined, indicates how to create pthread
* in joinable (aka undetached) state. NOTE: not defined
@@ -1942,6 +2082,29 @@
/*#define HAS_READDIR_R / **/
#define READDIR_R_PROTO 0 /**/
+/* HAS_SAFE_BCOPY:
+ * This symbol, if defined, indicates that the bcopy routine is available
+ * to copy potentially overlapping memory blocks. Normally, you should
+ * probably use memmove() or memcpy(). If neither is defined, roll your
+ * own version.
+ */
+/*#define HAS_SAFE_BCOPY / **/
+
+/* HAS_SAFE_MEMCPY:
+ * This symbol, if defined, indicates that the memcpy routine is available
+ * to copy potentially overlapping memory blocks. If you need to
+ * copy overlapping memory blocks, you should check HAS_MEMMOVE and
+ * use memmove() instead, if available.
+ */
+/*#define HAS_SAFE_MEMCPY / **/
+
+/* HAS_SANE_MEMCMP:
+ * This symbol, if defined, indicates that the memcmp routine is available
+ * and can be used to compare relative magnitudes of chars with their high
+ * bits set. If it is not defined, roll your own version.
+ */
+#define HAS_SANE_MEMCMP /**/
+
/* HAS_SEM:
* This symbol, if defined, indicates that the entire sem*(2) library is
* supported.
@@ -2114,6 +2277,43 @@
#define Shmat_t void * /**/
/*#define HAS_SHMAT_PROTOTYPE / **/
+/* HAS_SIGACTION:
+ * This symbol, if defined, indicates that Vr4's sigaction() routine
+ * is available.
+ */
+/*#define HAS_SIGACTION / **/
+
+/* HAS_SIGSETJMP:
+ * This variable indicates to the C program that the sigsetjmp()
+ * routine is available to save the calling process's registers
+ * and stack environment for later use by siglongjmp(), and
+ * to optionally save the process's signal mask. See
+ * Sigjmp_buf, Sigsetjmp, and Siglongjmp.
+ */
+/* Sigjmp_buf:
+ * This is the buffer type to be used with Sigsetjmp and Siglongjmp.
+ */
+/* Sigsetjmp:
+ * This macro is used in the same way as sigsetjmp(), but will invoke
+ * traditional setjmp() if sigsetjmp isn't available.
+ * See HAS_SIGSETJMP.
+ */
+/* Siglongjmp:
+ * This macro is used in the same way as siglongjmp(), but will invoke
+ * traditional longjmp() if siglongjmp isn't available.
+ * See HAS_SIGSETJMP.
+ */
+/*#define HAS_SIGSETJMP / **/
+#ifdef HAS_SIGSETJMP
+#define Sigjmp_buf sigjmp_buf
+#define Sigsetjmp(buf,save_mask) sigsetjmp((buf),(save_mask))
+#define Siglongjmp(buf,retval) siglongjmp((buf),(retval))
+#else
+#define Sigjmp_buf jmp_buf
+#define Sigsetjmp(buf,save_mask) setjmp((buf))
+#define Siglongjmp(buf,retval) longjmp((buf),(retval))
+#endif
+
/* HAS_SOCKET:
* This symbol, if defined, indicates that the BSD socket interface is
* supported.
@@ -2152,8 +2352,30 @@
* Checking just with #ifdef might not be enough because this symbol
* has been known to be an enum.
*/
+/* HAS_SOCKADDR_SA_LEN:
+ * This symbol, if defined, indicates that the struct sockaddr
+ * structure has a member called sa_len, indicating the length of
+ * the structure.
+ */
+/* HAS_SOCKADDR_IN6:
+ * This symbol, if defined, indicates the availability of
+ * struct sockaddr_in6;
+ */
+/* HAS_SIN6_SCOPE_ID:
+ * This symbol, if defined, indicates that the struct sockaddr_in6
+ * structure has a member called sin6_scope_id.
+ */
+/* HAS_IP_MREQ:
+ * This symbol, if defined, indicates the availability of
+ * struct ip_mreq;
+ */
+/* HAS_IPV6_MREQ:
+ * This symbol, if defined, indicates the availability of
+ * struct ipv6_mreq;
+ */
#define HAS_SOCKET /**/
/*#define HAS_SOCKETPAIR / **/
+/*#define HAS_SOCKADDR_SA_LEN / **/
/*#define HAS_MSG_CTRUNC / **/
/*#define HAS_MSG_DONTROUTE / **/
/*#define HAS_MSG_OOB / **/
@@ -2160,6 +2382,10 @@
/*#define HAS_MSG_PEEK / **/
/*#define HAS_MSG_PROXY / **/
/*#define HAS_SCM_RIGHTS / **/
+/*#define HAS_SOCKADDR_IN6 / **/
+#define HAS_SIN6_SCOPE_ID /**/
+/*#define HAS_IP_MREQ / **/
+/*#define HAS_IPV6_MREQ / **/
/* HAS_SRAND48_R:
* This symbol, if defined, indicates that the srand48_r routine
@@ -2195,6 +2421,97 @@
/*#define USE_STAT_BLOCKS / **/
#endif
+/* HAS_STATIC_INLINE:
+ * This symbol, if defined, indicates that the C compiler supports
+ * C99-style static inline. That is, the function can't be called
+ * from another translation unit.
+ */
+/* PERL_STATIC_INLINE:
+ * This symbol gives the best-guess incantation to use for static
+ * inline functions. If HAS_STATIC_INLINE is defined, this will
+ * give C99-style inline. If HAS_STATIC_INLINE is not defined,
+ * this will give a plain 'static'. It will always be defined
+ * to something that gives static linkage.
+ * Possibilities include
+ * static inline (c99)
+ * static __inline__ (gcc -ansi)
+ * static __inline (MSVC)
+ * static _inline (older MSVC)
+ * static (c89 compilers)
+ */
+#define HAS_STATIC_INLINE /**/
+#define PERL_STATIC_INLINE static __inline__ /**/
+
+/* USE_STDIO_PTR:
+ * This symbol is defined if the _ptr and _cnt fields (or similar)
+ * of the stdio FILE structure can be used to access the stdio buffer
+ * for a file handle. If this is defined, then the FILE_ptr(fp)
+ * and FILE_cnt(fp) macros will also be defined and should be used
+ * to access these fields.
+ */
+/* FILE_ptr:
+ * This macro is used to access the _ptr field (or equivalent) of the
+ * FILE structure pointed to by its argument. This macro will always be
+ * defined if USE_STDIO_PTR is defined.
+ */
+/* STDIO_PTR_LVALUE:
+ * This symbol is defined if the FILE_ptr macro can be used as an
+ * lvalue.
+ */
+/* FILE_cnt:
+ * This macro is used to access the _cnt field (or equivalent) of the
+ * FILE structure pointed to by its argument. This macro will always be
+ * defined if USE_STDIO_PTR is defined.
+ */
+/* STDIO_CNT_LVALUE:
+ * This symbol is defined if the FILE_cnt macro can be used as an
+ * lvalue.
+ */
+/* STDIO_PTR_LVAL_SETS_CNT:
+ * This symbol is defined if using the FILE_ptr macro as an lvalue
+ * to increase the pointer by n has the side effect of decreasing the
+ * value of File_cnt(fp) by n.
+ */
+/* STDIO_PTR_LVAL_NOCHANGE_CNT:
+ * This symbol is defined if using the FILE_ptr macro as an lvalue
+ * to increase the pointer by n leaves File_cnt(fp) unchanged.
+ */
+#define USE_STDIO_PTR /**/
+#ifdef USE_STDIO_PTR
+#define FILE_ptr(fp) ((fp)->_ptr)
+#define STDIO_PTR_LVALUE /**/
+#define FILE_cnt(fp) ((fp)->_cnt)
+#define STDIO_CNT_LVALUE /**/
+/*#define STDIO_PTR_LVAL_SETS_CNT / **/
+#define STDIO_PTR_LVAL_NOCHANGE_CNT /**/
+#endif
+
+/* USE_STDIO_BASE:
+ * This symbol is defined if the _base field (or similar) of the
+ * stdio FILE structure can be used to access the stdio buffer for
+ * a file handle. If this is defined, then the FILE_base(fp) macro
+ * will also be defined and should be used to access this field.
+ * Also, the FILE_bufsiz(fp) macro will be defined and should be used
+ * to determine the number of bytes in the buffer. USE_STDIO_BASE
+ * will never be defined unless USE_STDIO_PTR is.
+ */
+/* FILE_base:
+ * This macro is used to access the _base field (or equivalent) of the
+ * FILE structure pointed to by its argument. This macro will always be
+ * defined if USE_STDIO_BASE is defined.
+ */
+/* FILE_bufsiz:
+ * This macro is used to determine the number of bytes in the I/O
+ * buffer pointed to by _base field (or equivalent) of the FILE
+ * structure pointed to its argument. This macro will always be defined
+ * if USE_STDIO_BASE is defined.
+ */
+#define USE_STDIO_BASE /**/
+#ifdef USE_STDIO_BASE
+#define FILE_base(fp) ((fp)->_base)
+#define FILE_bufsiz(fp) ((fp)->_cnt + (fp)->_ptr - (fp)->_base)
+#endif
+
/* USE_STRUCT_COPY:
* This symbol, if defined, indicates that this C compiler knows how
* to copy structures. If undefined, you'll need to use a block copy
@@ -2334,6 +2651,32 @@
#define volatile
#endif
+/* HAS_VPRINTF:
+ * This symbol, if defined, indicates that the vprintf routine is available
+ * to printf with a pointer to an argument list. If unavailable, you
+ * may need to write your own, probably in terms of _doprnt().
+ */
+/* USE_CHAR_VSPRINTF:
+ * This symbol is defined if this system has vsprintf() returning type
+ * (char*). The trend seems to be to declare it as "int vsprintf()". It
+ * is up to the package author to declare vsprintf correctly based on the
+ * symbol.
+ */
+#define HAS_VPRINTF /**/
+/*#define USE_CHAR_VSPRINTF / **/
+
+/* DOUBLESIZE:
+ * This symbol contains the size of a double, so that the C preprocessor
+ * can make decisions based on it.
+ */
+#define DOUBLESIZE 8 /**/
+
+/* EBCDIC:
+ * This symbol, if defined, indicates that this system uses
+ * EBCDIC encoding.
+ */
+/*#define EBCDIC / **/
+
/* Fpos_t:
* This symbol holds the type used to declare file positions in libc.
* It can be fpos_t, long, uint, etc... It may be necessary to include
@@ -2524,6 +2867,32 @@
*/
/*#define I_SYSUIO / **/
+/* I_TIME:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <time.h>.
+ */
+/* I_SYS_TIME:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/time.h>.
+ */
+/* I_SYS_TIME_KERNEL:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/time.h> with KERNEL defined.
+ */
+/* HAS_TM_TM_ZONE:
+ * This symbol, if defined, indicates to the C program that
+ * the struct tm has a tm_zone field.
+ */
+/* HAS_TM_TM_GMTOFF:
+ * This symbol, if defined, indicates to the C program that
+ * the struct tm has a tm_gmtoff field.
+ */
+#define I_TIME /**/
+/*#define I_SYS_TIME / **/
+/*#define I_SYS_TIME_KERNEL / **/
+/*#define HAS_TM_TM_ZONE / **/
+/*#define HAS_TM_TM_GMTOFF / **/
+
/* I_STDARG:
* This symbol, if defined, indicates that <stdarg.h> exists and should
* be included.
@@ -2593,6 +2962,33 @@
*/
#define Mode_t mode_t /* file mode parameter for system calls */
+/* VAL_O_NONBLOCK:
+ * This symbol is to be used during open() or fcntl(F_SETFL) to turn on
+ * non-blocking I/O for the file descriptor. Note that there is no way
+ * back, i.e. you cannot turn it blocking again this way. If you wish to
+ * alternatively switch between blocking and non-blocking, use the
+ * ioctl(FIOSNBIO) call instead, but that is not supported by all devices.
+ */
+/* VAL_EAGAIN:
+ * This symbol holds the errno error code set by read() when no data was
+ * present on the non-blocking file descriptor.
+ */
+/* RD_NODATA:
+ * This symbol holds the return code from read() when no data is present
+ * on the non-blocking file descriptor. Be careful! If EOF_NONBLOCK is
+ * not defined, then you can't distinguish between no data and EOF by
+ * issuing a read(). You'll have to find another way to tell for sure!
+ */
+/* EOF_NONBLOCK:
+ * This symbol, if defined, indicates to the C program that a read() on
+ * a non-blocking file descriptor will return 0 on EOF, and not the value
+ * held in RD_NODATA (-1 usually, in that case!).
+ */
+#define VAL_O_NONBLOCK O_NONBLOCK
+#define VAL_EAGAIN EAGAIN
+#define RD_NODATA -1
+#define EOF_NONBLOCK
+
/* Netdb_host_t:
* This symbol holds the type used for the 1st argument
* to gethostbyaddr().
@@ -2662,6 +3058,57 @@
#define _(args) ()
#endif
+/* PTRSIZE:
+ * This symbol contains the size of a pointer, so that the C preprocessor
+ * can make decisions based on it. It will be sizeof(void *) if
+ * the compiler supports (void *); otherwise it will be
+ * sizeof(char *).
+ */
+#define PTRSIZE 4 /**/
+
+/* HAS_QUAD:
+ * This symbol, if defined, tells that there's a 64-bit integer type,
+ * Quad_t, and its unsigned counterpart, Uquad_t. QUADKIND will be one
+ * of QUAD_IS_INT, QUAD_IS_LONG, QUAD_IS_LONG_LONG, QUAD_IS_INT64_T,
+ * or QUAD_IS___INT64.
+ */
+#define HAS_QUAD /**/
+#ifdef HAS_QUAD
+# define Quad_t long long /**/
+# define Uquad_t unsigned long long /**/
+# define QUADKIND 3 /**/
+# define QUAD_IS_INT 1
+# define QUAD_IS_LONG 2
+# define QUAD_IS_LONG_LONG 3
+# define QUAD_IS_INT64_T 4
+# define QUAD_IS___INT64 5
+#endif
+
+/* Drand01:
+ * This macro is to be used to generate uniformly distributed
+ * random numbers over the range [0., 1.[. You may have to supply
+ * an 'extern double drand48();' in your program since SunOS 4.1.3
+ * doesn't provide you with anything relevant in its headers.
+ * See HAS_DRAND48_PROTO.
+ */
+/* Rand_seed_t:
+ * This symbol defines the type of the argument of the
+ * random seed function.
+ */
+/* seedDrand01:
+ * This symbol defines the macro to be used in seeding the
+ * random number generator (see Drand01).
+ */
+/* RANDBITS:
+ * This symbol indicates how many bits are produced by the
+ * function used to generate normalized random numbers.
+ * Values include 15, 16, 31, and 48.
+ */
+#define Drand01() (rand()/(double)((unsigned)1<<RANDBITS)) /**/
+#define Rand_seed_t unsigned /**/
+#define seedDrand01(x) srand((Rand_seed_t)x) /**/
+#define RANDBITS 15 /**/
+
/* Select_fd_set_t:
* This symbol holds the type used for the 2nd, 3rd, and 4th
* arguments to select. Usually, this is 'fd_set *', if HAS_FD_SET
@@ -2772,7 +3219,7 @@
* unsigned long, int, etc. It may be necessary to include
* <sys/types.h> to get any typedef'ed information.
*/
-#define Size_t size_t /* length paramater for string functions */
+#define Size_t size_t /* length parameter for string functions */
/* Sock_size_t:
* This symbol holds the type used for the size argument of
@@ -2780,6 +3227,16 @@
*/
#define Sock_size_t int /**/
+/* SSize_t:
+ * This symbol holds the type used by functions that return
+ * a count of bytes or an error condition. It must be a signed type.
+ * It is usually ssize_t, but may be long or int, etc.
+ * It may be necessary to include <sys/types.h> or <unistd.h>
+ * to get any typedef'ed information.
+ * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t).
+ */
+#define SSize_t int /* signed count of bytes */
+
/* STDCHAR:
* This symbol is defined to be the type of char used in stdio.h.
* It has the values "unsigned char" or "char".
@@ -2873,7 +3330,7 @@
* 2 = supports arrays of pointers to functions returning void
* 4 = supports comparisons between pointers to void functions and
* addresses of void functions
- * 8 = suports declaration of generic void pointers
+ * 8 = supports declaration of generic void pointers
*
* The package designer should define VOIDUSED to indicate the requirements
* of the package. This can be done either by #defining VOIDUSED before
@@ -2890,464 +3347,6 @@
#define M_VOID /* Xenix strikes again */
#endif
-/* 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,
- * 4 and 8. The default is eight, for safety.
- */
-#if defined(USE_CROSS_COMPILE) || defined(MULTIARCH)
-# define MEM_ALIGNBYTES 8
-#else
-#define MEM_ALIGNBYTES 8
-#endif
-
-/* BYTEORDER:
- * 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 (eg. on NeXT systems), 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(USE_CROSS_COMPILE) || defined(MULTIARCH)
-# ifdef __LITTLE_ENDIAN__
-# if LONGSIZE == 4
-# define BYTEORDER 0x1234
-# else
-# if LONGSIZE == 8
-# define BYTEORDER 0x12345678
-# endif
-# endif
-# else
-# ifdef __BIG_ENDIAN__
-# if LONGSIZE == 4
-# define BYTEORDER 0x4321
-# else
-# if LONGSIZE == 8
-# define BYTEORDER 0x87654321
-# endif
-# endif
-# endif
-# endif
-# if !defined(BYTEORDER) && (defined(NeXT) || defined(__NeXT__))
-# define BYTEORDER 0x4321
-# endif
-#else
-#define BYTEORDER 0x1234 /* large digits for MSB */
-#endif /* NeXT */
-
-/* CHARBITS:
- * This symbol contains the size of a char, so that the C preprocessor
- * can make decisions based on it.
- */
-#define CHARBITS 8 /**/
-
-/* CASTI32:
- * This symbol is defined if the C compiler can cast negative
- * or large floating point numbers to 32-bit ints.
- */
-#ifndef _MSC_VER
-# define CASTI32 /**/
-#endif
-
-/* CASTNEGFLOAT:
- * This symbol is defined if the C compiler can cast negative
- * numbers to unsigned longs, ints and shorts.
- */
-/* CASTFLAGS:
- * This symbol contains flags that say what difficulties the compiler
- * has casting odd floating values to unsigned long:
- * 0 = ok
- * 1 = couldn't cast < 0
- * 2 = couldn't cast >= 0x80000000
- * 4 = couldn't cast in argument expression list
- */
-#define CASTNEGFLOAT /**/
-#define CASTFLAGS 0 /**/
-
-/* VOID_CLOSEDIR:
- * This symbol, if defined, indicates that the closedir() routine
- * does not return a value.
- */
-/*#define VOID_CLOSEDIR / **/
-
-/* HAS_FD_SET:
- * This symbol, when defined, indicates presence of the fd_set typedef
- * in <sys/types.h>
- */
-#define HAS_FD_SET /**/
-
-/* Gconvert:
- * This preprocessor macro is defined to convert a floating point
- * number to a string without a trailing decimal point. This
- * emulates the behavior of sprintf("%g"), but is sometimes much more
- * efficient. If gconvert() is not available, but gcvt() drops the
- * trailing decimal point, then gcvt() is used. If all else fails,
- * a macro using sprintf("%g") is used. Arguments for the Gconvert
- * macro are: value, number of digits, whether trailing zeros should
- * be retained, and the output buffer.
- * The usual values are:
- * d_Gconvert='gconvert((x),(n),(t),(b))'
- * d_Gconvert='gcvt((x),(n),(b))'
- * d_Gconvert='sprintf((b),"%.*g",(n),(x))'
- * The last two assume trailing zeros should not be kept.
- */
-#define Gconvert(x,n,t,b) sprintf((b),"%.*g",(n),(x))
-
-/* HAS_GETPAGESIZE:
- * This symbol, if defined, indicates that the getpagesize system call
- * is available to get system page size, which is the granularity of
- * many memory management calls.
- */
-/*#define HAS_GETPAGESIZE / **/
-
-/* HAS_GNULIBC:
- * This symbol, if defined, indicates to the C program that
- * the GNU C library is being used. A better check is to use
- * the __GLIBC__ and __GLIBC_MINOR__ symbols supplied with glibc.
- */
-/*#define HAS_GNULIBC / **/
-#if defined(HAS_GNULIBC) && !defined(_GNU_SOURCE)
-# define _GNU_SOURCE
-#endif
-
-/* HAS_ISASCII:
- * This manifest constant lets the C program know that isascii
- * is available.
- */
-#define HAS_ISASCII /**/
-
-/* HAS_LCHOWN:
- * This symbol, if defined, indicates that the lchown routine is
- * available to operate on a symbolic link (instead of following the
- * link).
- */
-/*#define HAS_LCHOWN / **/
-
-/* HAS_OPEN3:
- * This manifest constant lets the C program know that the three
- * argument form of open(2) is available.
- */
-/*#define HAS_OPEN3 / **/
-
-/* HAS_SAFE_BCOPY:
- * This symbol, if defined, indicates that the bcopy routine is available
- * to copy potentially overlapping memory blocks. Normally, you should
- * probably use memmove() or memcpy(). If neither is defined, roll your
- * own version.
- */
-/*#define HAS_SAFE_BCOPY / **/
-
-/* HAS_SAFE_MEMCPY:
- * This symbol, if defined, indicates that the memcpy routine is available
- * to copy potentially overlapping memory blocks. If you need to
- * copy overlapping memory blocks, you should check HAS_MEMMOVE and
- * use memmove() instead, if available.
- */
-/*#define HAS_SAFE_MEMCPY / **/
-
-/* HAS_SANE_MEMCMP:
- * This symbol, if defined, indicates that the memcmp routine is available
- * and can be used to compare relative magnitudes of chars with their high
- * bits set. If it is not defined, roll your own version.
- */
-#define HAS_SANE_MEMCMP /**/
-
-/* HAS_SIGACTION:
- * This symbol, if defined, indicates that Vr4's sigaction() routine
- * is available.
- */
-/*#define HAS_SIGACTION / **/
-
-/* HAS_SIGSETJMP:
- * This variable indicates to the C program that the sigsetjmp()
- * routine is available to save the calling process's registers
- * and stack environment for later use by siglongjmp(), and
- * to optionally save the process's signal mask. See
- * Sigjmp_buf, Sigsetjmp, and Siglongjmp.
- */
-/* Sigjmp_buf:
- * This is the buffer type to be used with Sigsetjmp and Siglongjmp.
- */
-/* Sigsetjmp:
- * This macro is used in the same way as sigsetjmp(), but will invoke
- * traditional setjmp() if sigsetjmp isn't available.
- * See HAS_SIGSETJMP.
- */
-/* Siglongjmp:
- * This macro is used in the same way as siglongjmp(), but will invoke
- * traditional longjmp() if siglongjmp isn't available.
- * See HAS_SIGSETJMP.
- */
-/*#define HAS_SIGSETJMP / **/
-#ifdef HAS_SIGSETJMP
-#define Sigjmp_buf sigjmp_buf
-#define Sigsetjmp(buf,save_mask) sigsetjmp((buf),(save_mask))
-#define Siglongjmp(buf,retval) siglongjmp((buf),(retval))
-#else
-#define Sigjmp_buf jmp_buf
-#define Sigsetjmp(buf,save_mask) setjmp((buf))
-#define Siglongjmp(buf,retval) longjmp((buf),(retval))
-#endif
-
-/* HAS_STATIC_INLINE:
- * This symbol, if defined, indicates that the C compiler supports
- * C99-style static inline. That is, the function can't be called
- * from another translation unit.
- */
-/* PERL_STATIC_INLINE:
- * This symbol gives the best-guess incantation to use for static
- * inline functions. If HAS_STATIC_INLINE is defined, this will
- * give C99-style inline. If HAS_STATIC_INLINE is not defined,
- * this will give a plain 'static'. It will always be defined
- * to something that gives static linkage.
- * Possibilities include
- * static inline (c99)
- * static __inline__ (gcc -ansi)
- * static __inline (MSVC)
- * static _inline (older MSVC)
- * static (c89 compilers)
- */
-#ifdef _MSC_VER
-# define HAS_STATIC_INLINE /**/
-# define PERL_STATIC_INLINE static __inline /**/
-#else /* gcc presumably */
-# define HAS_STATIC_INLINE /**/
-# define PERL_STATIC_INLINE static __inline__ /**/
-#endif
-
-/* USE_STDIO_PTR:
- * This symbol is defined if the _ptr and _cnt fields (or similar)
- * of the stdio FILE structure can be used to access the stdio buffer
- * for a file handle. If this is defined, then the FILE_ptr(fp)
- * and FILE_cnt(fp) macros will also be defined and should be used
- * to access these fields.
- */
-/* FILE_ptr:
- * This macro is used to access the _ptr field (or equivalent) of the
- * FILE structure pointed to by its argument. This macro will always be
- * defined if USE_STDIO_PTR is defined.
- */
-/* STDIO_PTR_LVALUE:
- * This symbol is defined if the FILE_ptr macro can be used as an
- * lvalue.
- */
-/* FILE_cnt:
- * This macro is used to access the _cnt field (or equivalent) of the
- * FILE structure pointed to by its argument. This macro will always be
- * defined if USE_STDIO_PTR is defined.
- */
-/* STDIO_CNT_LVALUE:
- * This symbol is defined if the FILE_cnt macro can be used as an
- * lvalue.
- */
-/* STDIO_PTR_LVAL_SETS_CNT:
- * This symbol is defined if using the FILE_ptr macro as an lvalue
- * to increase the pointer by n has the side effect of decreasing the
- * value of File_cnt(fp) by n.
- */
-/* STDIO_PTR_LVAL_NOCHANGE_CNT:
- * This symbol is defined if using the FILE_ptr macro as an lvalue
- * to increase the pointer by n leaves File_cnt(fp) unchanged.
- */
-#define USE_STDIO_PTR /**/
-#ifdef USE_STDIO_PTR
-#define FILE_ptr(fp) ((fp)->_ptr)
-#define STDIO_PTR_LVALUE /**/
-#define FILE_cnt(fp) ((fp)->_cnt)
-#define STDIO_CNT_LVALUE /**/
-/*#define STDIO_PTR_LVAL_SETS_CNT / **/
-#define STDIO_PTR_LVAL_NOCHANGE_CNT /**/
-#endif
-
-/* USE_STDIO_BASE:
- * This symbol is defined if the _base field (or similar) of the
- * stdio FILE structure can be used to access the stdio buffer for
- * a file handle. If this is defined, then the FILE_base(fp) macro
- * will also be defined and should be used to access this field.
- * Also, the FILE_bufsiz(fp) macro will be defined and should be used
- * to determine the number of bytes in the buffer. USE_STDIO_BASE
- * will never be defined unless USE_STDIO_PTR is.
- */
-/* FILE_base:
- * This macro is used to access the _base field (or equivalent) of the
- * FILE structure pointed to by its argument. This macro will always be
- * defined if USE_STDIO_BASE is defined.
- */
-/* FILE_bufsiz:
- * This macro is used to determine the number of bytes in the I/O
- * buffer pointed to by _base field (or equivalent) of the FILE
- * structure pointed to its argument. This macro will always be defined
- * if USE_STDIO_BASE is defined.
- */
-#define USE_STDIO_BASE /**/
-#ifdef USE_STDIO_BASE
-#define FILE_base(fp) ((fp)->_base)
-#define FILE_bufsiz(fp) ((fp)->_cnt + (fp)->_ptr - (fp)->_base)
-#endif
-
-/* HAS_VPRINTF:
- * This symbol, if defined, indicates that the vprintf routine is available
- * to printf with a pointer to an argument list. If unavailable, you
- * may need to write your own, probably in terms of _doprnt().
- */
-/* USE_CHAR_VSPRINTF:
- * This symbol is defined if this system has vsprintf() returning type
- * (char*). The trend seems to be to declare it as "int vsprintf()". It
- * is up to the package author to declare vsprintf correctly based on the
- * symbol.
- */
-#define HAS_VPRINTF /**/
-/*#define USE_CHAR_VSPRINTF / **/
-
-/* DOUBLESIZE:
- * This symbol contains the size of a double, so that the C preprocessor
- * can make decisions based on it.
- */
-#define DOUBLESIZE 8 /**/
-
-/* I_TIME:
- * This symbol, if defined, indicates to the C program that it should
- * include <time.h>.
- */
-/* I_SYS_TIME:
- * This symbol, if defined, indicates to the C program that it should
- * include <sys/time.h>.
- */
-/* I_SYS_TIME_KERNEL:
- * This symbol, if defined, indicates to the C program that it should
- * include <sys/time.h> with KERNEL defined.
- */
-/* HAS_TM_TM_ZONE:
- * This symbol, if defined, indicates to the C program that
- * the struct tm has a tm_zone field.
- */
-/* HAS_TM_TM_GMTOFF:
- * This symbol, if defined, indicates to the C program that
- * the struct tm has a tm_gmtoff field.
- */
-#define I_TIME /**/
-/*#define I_SYS_TIME / **/
-/*#define I_SYS_TIME_KERNEL / **/
-/*#define HAS_TM_TM_ZONE / **/
-/*#define HAS_TM_TM_GMTOFF / **/
-
-/* VAL_O_NONBLOCK:
- * This symbol is to be used during open() or fcntl(F_SETFL) to turn on
- * non-blocking I/O for the file descriptor. Note that there is no way
- * back, i.e. you cannot turn it blocking again this way. If you wish to
- * alternatively switch between blocking and non-blocking, use the
- * ioctl(FIOSNBIO) call instead, but that is not supported by all devices.
- */
-/* VAL_EAGAIN:
- * This symbol holds the errno error code set by read() when no data was
- * present on the non-blocking file descriptor.
- */
-/* RD_NODATA:
- * This symbol holds the return code from read() when no data is present
- * on the non-blocking file descriptor. Be careful! If EOF_NONBLOCK is
- * not defined, then you can't distinguish between no data and EOF by
- * issuing a read(). You'll have to find another way to tell for sure!
- */
-/* EOF_NONBLOCK:
- * This symbol, if defined, indicates to the C program that a read() on
- * a non-blocking file descriptor will return 0 on EOF, and not the value
- * held in RD_NODATA (-1 usually, in that case!).
- */
-#define VAL_O_NONBLOCK O_NONBLOCK
-#define VAL_EAGAIN EAGAIN
-#define RD_NODATA -1
-#define EOF_NONBLOCK
-
-/* PTRSIZE:
- * This symbol contains the size of a pointer, so that the C preprocessor
- * can make decisions based on it. It will be sizeof(void *) if
- * the compiler supports (void *); otherwise it will be
- * sizeof(char *).
- */
-#define PTRSIZE 4 /**/
-
-/* Drand01:
- * This macro is to be used to generate uniformly distributed
- * random numbers over the range [0., 1.[. You may have to supply
- * an 'extern double drand48();' in your program since SunOS 4.1.3
- * doesn't provide you with anything relevant in its headers.
- * See HAS_DRAND48_PROTO.
- */
-/* Rand_seed_t:
- * This symbol defines the type of the argument of the
- * random seed function.
- */
-/* seedDrand01:
- * This symbol defines the macro to be used in seeding the
- * random number generator (see Drand01).
- */
-/* RANDBITS:
- * This symbol indicates how many bits are produced by the
- * function used to generate normalized random numbers.
- * Values include 15, 16, 31, and 48.
- */
-#define Drand01() (rand()/(double)((unsigned)1<<RANDBITS)) /**/
-#define Rand_seed_t unsigned /**/
-#define seedDrand01(x) srand((Rand_seed_t)x) /**/
-#define RANDBITS 15 /**/
-
-/* SSize_t:
- * This symbol holds the type used by functions that return
- * a count of bytes or an error condition. It must be a signed type.
- * It is usually ssize_t, but may be long or int, etc.
- * It may be necessary to include <sys/types.h> or <unistd.h>
- * to get any typedef'ed information.
- * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t).
- */
-#define SSize_t int /* signed count of bytes */
-
-/* EBCDIC:
- * This symbol, if defined, indicates that this system uses
- * EBCDIC encoding.
- */
-/*#define EBCDIC / **/
-
-/* 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.
- */
-/* DOSUID:
- * This symbol, if defined, indicates that the C program should
- * check the script that it is executing for setuid/setgid bits, and
- * attempt to emulate setuid/setgid on systems that have disabled
- * setuid #! scripts because the kernel can't do it securely.
- * It is up to the package designer to make sure that this emulation
- * is done securely. Among other things, it should do an fstat on
- * the script it just opened to make sure it really is a setuid/setgid
- * script, it should make sure the arguments passed correspond exactly
- * to the argument on the #! line, and it should not trust any
- * subprocesses to which it must pass the filename rather than the
- * file descriptor of the script to be executed.
- */
-/*#define SETUID_SCRIPTS_ARE_SECURE_NOW / **/
-/*#define DOSUID / **/
-
/* PERL_USE_DEVEL:
* This symbol, if defined, indicates that Perl was configured with
* -Dusedevel, to enable development features. This should not be
@@ -3635,7 +3634,7 @@
/* HAS_GETESPWNAM:
* This symbol, if defined, indicates that the getespwnam system call is
- * available to retrieve enchanced (shadow) password entries by name.
+ * available to retrieve enhanced (shadow) password entries by name.
*/
/*#define HAS_GETESPWNAM / **/
@@ -3712,6 +3711,12 @@
*/
/*#define HAS_INT64_T / **/
+/* HAS_ISBLANK:
+ * This manifest constant lets the C program know that isblank
+ * is available.
+ */
+/*#define HAS_ISBLANK / **/
+
/* HAS_ISFINITE:
* This symbol, if defined, indicates that the isfinite routine is
* available to check whether a double is finite (non-infinity non-NaN).
@@ -3776,7 +3781,7 @@
/* HAS_MKSTEMPS:
* This symbol, if defined, indicates that the mkstemps routine is
- * available to excluslvely create and open a uniquely named
+ * available to exclusively create and open a uniquely named
* (with a suffix) temporary file.
*/
/*#define HAS_MKSTEMPS / **/
@@ -3826,6 +3831,17 @@
*/
/*#define HAS_OFF64_T / **/
+/* HAS_PRCTL:
+ * This symbol, if defined, indicates that the prctl routine is
+ * available to set process title.
+ */
+/* HAS_PRCTL_SET_NAME:
+ * This symbol, if defined, indicates that the prctl routine is
+ * available to set process title and supports PR_SET_NAME.
+ */
+/*#define HAS_PRCTL / **/
+/*#define HAS_PRCTL_SET_NAME / **/
+
/* HAS_PROCSELFEXE:
* This symbol is defined if PROCSELFEXE_PATH is a symlink
* to the absolute pathname of the executing program.
@@ -4297,6 +4313,12 @@
*/
/*#define I_SOCKS / **/
+/* I_STDBOOL:
+ * This symbol, if defined, indicates that <stdbool.h> exists and
+ * can be included.
+ */
+/*#define I_STDBOOL / **/
+
/* I_SUNMATH:
* This symbol, if defined, indicates that <sunmath.h> exists and
* should be included.
@@ -4465,7 +4487,7 @@
/* NV_OVERFLOWS_INTEGERS_AT:
* This symbol gives the largest integer value that NVs can hold. This
* value + 1.0 cannot be stored accurately. It is expressed as constant
- * floating point expression to reduce the chance of decimale/binary
+ * floating point expression to reduce the chance of decimal/binary
* conversion issues. If it can not be determined, the value 0 is given.
*/
/* NV_ZERO_IS_ALLBITS_ZERO:
@@ -4481,13 +4503,8 @@
#define I32TYPE long /**/
#define U32TYPE unsigned long /**/
#ifdef HAS_QUAD
-# ifndef _MSC_VER
-# define I64TYPE long long /**/
-# define U64TYPE unsigned long long /**/
-# else
-# define I64TYPE __int64 /**/
-# define U64TYPE unsigned __int64 /**/
-# endif
+#define I64TYPE long long /**/
+#define U64TYPE unsigned long long /**/
#endif
#define NVTYPE double /**/
#define IVSIZE 4 /**/
@@ -4571,6 +4588,16 @@
*/
#define SELECT_MIN_BITS 32 /**/
+/* ST_INO_SIZE:
+ * This variable contains the size of struct stat's st_ino in bytes.
+ */
+/* ST_INO_SIGN:
+ * This symbol holds the signedess of struct stat's st_ino.
+ * 1 for unsigned, -1 for signed.
+ */
+#define ST_INO_SIGN 1 /* st_ino sign */
+#define ST_INO_SIZE 4 /* st_ino size */
+
/* STARTPERL:
* This variable contains the string to put in front of a perl
* script to make sure (one hopes) that it runs with perl and not
@@ -4607,8 +4634,8 @@
* This symbol contains the minimum value for the time_t offset that
* the system function localtime () accepts, and defaults to 0
*/
-#define GMTIME_MAX 2147483647 /**/
-#define GMTIME_MIN 0 /**/
+#define GMTIME_MAX 2147483647 /**/
+#define GMTIME_MIN 0 /**/
#define LOCALTIME_MAX 2147483647 /**/
#define LOCALTIME_MIN 0 /**/
@@ -4652,6 +4679,13 @@
/*#define USE_FAST_STDIO / **/
#endif
+/* USE_KERN_PROC_PATHNAME:
+ * This symbol, if defined, indicates that we can use sysctl with
+ * KERN_PROC_PATHNAME to get a full path for the executable, and hence
+ * convert $^X to an absolute path.
+ */
+/*#define USE_KERN_PROC_PATHNAME / **/
+
/* USE_LARGE_FILES:
* This symbol, if defined, indicates that large file support
* should be used when available.
@@ -4684,6 +4718,13 @@
/*#define MULTIPLICITY / **/
#endif
+/* USE_NSGETEXECUTABLEPATH:
+ * This symbol, if defined, indicates that we can use _NSGetExecutablePath
+ * and realpath to get a full path for the executable, and hence convert
+ * $^X to an absolute path.
+ */
+/*#define USE_NSGETEXECUTABLEPATH / **/
+
/* USE_PERLIO:
* This symbol, if defined, indicates that the PerlIO abstraction should
* be used throughout. If not defined, stdio should be
Property changes on: trunk/contrib/perl/win32/config_H.gc
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/win32/config_H.gc64
===================================================================
--- trunk/contrib/perl/win32/config_H.gc64 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/config_H.gc64 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/win32/config_H.gc64
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/win32/config_H.gc64nox
===================================================================
--- trunk/contrib/perl/win32/config_H.gc64nox 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/config_H.gc64nox 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/win32/config_H.gc64nox
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/win32/config_H.vc
===================================================================
--- trunk/contrib/perl/win32/config_H.vc 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/config_H.vc 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,5 +1,4 @@
-/*
- * This file was produced by running the config_h.SH script, which
+/* This file was produced by running the config_h.SH script, which
* gets its values from undef, which is generally produced by
* running Configure.
*
@@ -6,14 +5,11 @@
* Feel free to modify any of this as the need arises. Note, however,
* that running config_h.SH again will wipe out any changes you've made.
* For a more permanent change edit undef and rerun config_h.SH.
- *
- * $Id: config_H.vc,v 1.1.1.1 2011-05-19 23:03:36 laffer1 Exp $
*/
-/*
- * Package name : perl5
+/* Package name : perl5
* Source directory :
- * Configuration time: Sat Jan 9 17:22:03 2010
+ * Configuration time: Sun Aug 5 17:04:42 2012
* Configured by : Steve
* Target system :
*/
@@ -72,7 +68,7 @@
* This symbol, if defined, indicates that the crypt routine is available
* to encrypt passwords and the like.
*/
-/*#define HAS_CRYPT / **/
+#define HAS_CRYPT /**/
/* HAS_CTERMID:
* This symbol, if defined, indicates that the ctermid routine is
@@ -883,21 +879,30 @@
#define _V(args) ()
#endif
-/* INTSIZE:
- * This symbol contains the value of sizeof(int) so that the C
- * preprocessor can make decisions based on it.
+/* OSNAME:
+ * This symbol contains the name of the operating system, as determined
+ * by Configure. You shouldn't rely on it too much; the specific
+ * feature tests from Configure are generally more reliable.
*/
-/* LONGSIZE:
- * This symbol contains the value of sizeof(long) so that the C
- * preprocessor can make decisions based on it.
+/* OSVERS:
+ * This symbol contains the version of the operating system, as determined
+ * by Configure. You shouldn't rely on it too much; the specific
+ * feature tests from Configure are generally more reliable.
*/
-/* SHORTSIZE:
- * This symbol contains the value of sizeof(short) so that the C
- * preprocessor can make decisions based on it.
+#define OSNAME "MSWin32" /**/
+#define OSVERS "6.1" /**/
+
+/* USE_CROSS_COMPILE:
+ * This symbol, if defined, indicates that Perl is being cross-compiled.
*/
-#define INTSIZE 4 /**/
-#define LONGSIZE 4 /**/
-#define SHORTSIZE 2 /**/
+/* 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
/* MULTIARCH:
* This symbol, if defined, signifies that the build
@@ -908,43 +913,17 @@
*/
/*#define MULTIARCH / **/
-/* HAS_QUAD:
- * This symbol, if defined, tells that there's a 64-bit integer type,
- * Quad_t, and its unsigned counterpar, Uquad_t. QUADKIND will be one
- * of QUAD_IS_INT, QUAD_IS_LONG, QUAD_IS_LONG_LONG, QUAD_IS_INT64_T
- * or QUAD_IS___INT64.
+/* MEM_ALIGNBYTES:
+ * This symbol contains the number of bytes required to align a
+ * double, or a long double when applicable. Usual values are 2,
+ * 4 and 8. The default is eight, for safety.
*/
-#define HAS_QUAD /**/
-#ifdef HAS_QUAD
-# ifndef __GNUC__
-# define Quad_t __int64 /**/
-# define Uquad_t unsigned __int64 /**/
-# define QUADKIND 5 /**/
-# else
-# define Quad_t long long /**/
-# define Uquad_t unsigned long long /**/
-# define QUADKIND 3 /**/
-# endif
-# define QUAD_IS_INT 1
-# define QUAD_IS_LONG 2
-# define QUAD_IS_LONG_LONG 3
-# define QUAD_IS_INT64_T 4
-# define QUAD_IS___INT64 5
+#if defined(USE_CROSS_COMPILE) || defined(MULTIARCH)
+# define MEM_ALIGNBYTES 8
+#else
+#define MEM_ALIGNBYTES 8
#endif
-/* OSNAME:
- * This symbol contains the name of the operating system, as determined
- * by Configure. You shouldn't rely on it too much; the specific
- * feature tests from Configure are generally more reliable.
- */
-/* OSVERS:
- * This symbol contains the version of the operating system, as determined
- * by Configure. You shouldn't rely on it too much; the specific
- * feature tests from Configure are generally more reliable.
- */
-#define OSNAME "MSWin32" /**/
-#define OSVERS "5.1" /**/
-
/* ARCHLIB:
* This variable, if defined, holds the name of the directory in
* which the user wants to put architecture-dependent public
@@ -985,6 +964,71 @@
#define BIN_EXP "c:\\perl\\bin" /**/
#define PERL_RELOCATABLE_INC "undef" /**/
+/* INTSIZE:
+ * This symbol contains the value of sizeof(int) so that the C
+ * preprocessor can make decisions based on it.
+ */
+/* LONGSIZE:
+ * This symbol contains the value of sizeof(long) so that the C
+ * preprocessor can make decisions based on it.
+ */
+/* SHORTSIZE:
+ * This symbol contains the value of sizeof(short) so that the C
+ * preprocessor can make decisions based on it.
+ */
+#define INTSIZE 4 /**/
+#define LONGSIZE 4 /**/
+#define SHORTSIZE 2 /**/
+
+/* BYTEORDER:
+ * 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 (eg. on NeXT systems), 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(USE_CROSS_COMPILE) || defined(MULTIARCH)
+# ifdef __LITTLE_ENDIAN__
+# if LONGSIZE == 4
+# define BYTEORDER 0x1234
+# else
+# if LONGSIZE == 8
+# define BYTEORDER 0x12345678
+# endif
+# endif
+# else
+# ifdef __BIG_ENDIAN__
+# if LONGSIZE == 4
+# define BYTEORDER 0x4321
+# else
+# if LONGSIZE == 8
+# define BYTEORDER 0x87654321
+# endif
+# endif
+# endif
+# endif
+# if !defined(BYTEORDER) && (defined(NeXT) || defined(__NeXT__))
+# define BYTEORDER 0x4321
+# endif
+#else
+#define BYTEORDER 0x1234 /* large digits for MSB */
+#endif /* NeXT */
+
+/* CHARBITS:
+ * This symbol contains the size of a char, so that the C preprocessor
+ * can make decisions based on it.
+ */
+#define CHARBITS 8 /**/
+
/* CAT2:
* This macro concatenates 2 tokens together.
*/
@@ -1031,15 +1075,9 @@
* This symbol is intended to be used along with CPPRUN in the same manner
* symbol CPPMINUS is used with CPPSTDIN. It contains either "-" or "".
*/
-#ifndef __GNUC__
-# define CPPSTDIN "cppstdin"
-# define CPPMINUS ""
-# define CPPRUN "cl -nologo -E"
-#else
-# define CPPSTDIN "gcc -E"
-# define CPPMINUS "-"
-# define CPPRUN "gcc -E"
-#endif
+#define CPPSTDIN "cppstdin"
+#define CPPMINUS ""
+#define CPPRUN "cl -nologo -E"
#define CPPLAST ""
/* HAS_ACCESS:
@@ -1105,6 +1143,33 @@
/*#define HASATTRIBUTE_UNUSED / **/
/*#define HASATTRIBUTE_WARN_UNUSED_RESULT / **/
+/* CASTI32:
+ * This symbol is defined if the C compiler can cast negative
+ * or large floating point numbers to 32-bit ints.
+ */
+/*#define CASTI32 / **/
+
+/* CASTNEGFLOAT:
+ * This symbol is defined if the C compiler can cast negative
+ * numbers to unsigned longs, ints and shorts.
+ */
+/* CASTFLAGS:
+ * This symbol contains flags that say what difficulties the compiler
+ * has casting odd floating values to unsigned long:
+ * 0 = ok
+ * 1 = couldn't cast < 0
+ * 2 = couldn't cast >= 0x80000000
+ * 4 = couldn't cast in argument expression list
+ */
+#define CASTNEGFLOAT /**/
+#define CASTFLAGS 0 /**/
+
+/* VOID_CLOSEDIR:
+ * This symbol, if defined, indicates that the closedir() routine
+ * does not return a value.
+ */
+/*#define VOID_CLOSEDIR / **/
+
/* HASCONST:
* This symbol, if defined, indicates that this C compiler knows about
* the const type. There is no need to actually test for that symbol
@@ -1166,6 +1231,26 @@
/*#define HAS_CTIME_R / **/
#define CTIME_R_PROTO 0 /**/
+/* 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.
+ */
+/* DOSUID:
+ * This symbol, if defined, indicates that the C program should
+ * check the script that it is executing for setuid/setgid bits, and
+ * attempt to emulate setuid/setgid on systems that have disabled
+ * setuid #! scripts because the kernel can't do it securely.
+ * It is up to the package designer to make sure that this emulation
+ * is done securely. Among other things, it should do an fstat on
+ * the script it just opened to make sure it really is a setuid/setgid
+ * script, it should make sure the arguments passed correspond exactly
+ * to the argument on the #! line, and it should not trust any
+ * subprocesses to which it must pass the filename rather than the
+ * file descriptor of the script to be executed.
+ */
+/*#define SETUID_SCRIPTS_ARE_SECURE_NOW / **/
+/*#define DOSUID / **/
+
/* HAS_DRAND48_R:
* This symbol, if defined, indicates that the drand48_r routine
* is available to drand48 re-entrantly.
@@ -1307,6 +1392,12 @@
/*#define HAS_ENDSERVENT_R / **/
#define ENDSERVENT_R_PROTO 0 /**/
+/* HAS_FD_SET:
+ * This symbol, when defined, indicates presence of the fd_set typedef
+ * in <sys/types.h>
+ */
+#define HAS_FD_SET /**/
+
/* FLEXFILENAMES:
* This symbol, if defined, indicates that the system supports filenames
* longer than 14 characters.
@@ -1313,6 +1404,23 @@
*/
#define FLEXFILENAMES /**/
+/* Gconvert:
+ * This preprocessor macro is defined to convert a floating point
+ * number to a string without a trailing decimal point. This
+ * emulates the behavior of sprintf("%g"), but is sometimes much more
+ * efficient. If gconvert() is not available, but gcvt() drops the
+ * trailing decimal point, then gcvt() is used. If all else fails,
+ * a macro using sprintf("%g") is used. Arguments for the Gconvert
+ * macro are: value, number of digits, whether trailing zeros should
+ * be retained, and the output buffer.
+ * The usual values are:
+ * d_Gconvert='gconvert((x),(n),(t),(b))'
+ * d_Gconvert='gcvt((x),(n),(b))'
+ * d_Gconvert='sprintf((b),"%.*g",(n),(x))'
+ * The last two assume trailing zeros should not be kept.
+ */
+#define Gconvert(x,n,t,b) sprintf((b),"%.*g",(n),(x))
+
/* HAS_GETGRENT:
* This symbol, if defined, indicates that the getgrent routine is
* available for sequential access of the group database.
@@ -1530,6 +1638,13 @@
*/
/*#define HAS_GETNET_PROTOS / **/
+/* HAS_GETPAGESIZE:
+ * This symbol, if defined, indicates that the getpagesize system call
+ * is available to get system page size, which is the granularity of
+ * many memory management calls.
+ */
+/*#define HAS_GETPAGESIZE / **/
+
/* HAS_GETPROTOENT:
* This symbol, if defined, indicates that the getprotoent() routine is
* available to look up protocols in some data base or another.
@@ -1741,6 +1856,16 @@
/*#define HAS_GMTIME_R / **/
#define GMTIME_R_PROTO 0 /**/
+/* HAS_GNULIBC:
+ * This symbol, if defined, indicates to the C program that
+ * the GNU C library is being used. A better check is to use
+ * the __GLIBC__ and __GLIBC_MINOR__ symbols supplied with glibc.
+ */
+/*#define HAS_GNULIBC / **/
+#if defined(HAS_GNULIBC) && !defined(_GNU_SOURCE)
+# define _GNU_SOURCE
+#endif
+
/* HAS_HTONL:
* This symbol, if defined, indicates that the htonl() routine (and
* friends htons() ntohl() ntohs()) are available to do network
@@ -1766,6 +1891,19 @@
#define HAS_NTOHL /**/
#define HAS_NTOHS /**/
+/* HAS_ISASCII:
+ * This manifest constant lets the C program know that isascii
+ * is available.
+ */
+#define HAS_ISASCII /**/
+
+/* HAS_LCHOWN:
+ * This symbol, if defined, indicates that the lchown routine is
+ * available to operate on a symbolic link (instead of following the
+ * link).
+ */
+/*#define HAS_LCHOWN / **/
+
/* HAS_LOCALTIME_R:
* This symbol, if defined, indicates that the localtime_r routine
* is available to localtime re-entrantly.
@@ -1803,11 +1941,7 @@
*/
#define HAS_LONG_DOUBLE /**/
#ifdef HAS_LONG_DOUBLE
-# ifndef __GNUC__
-# define LONG_DOUBLESIZE 8 /**/
-# else
-# define LONG_DOUBLESIZE 12 /**/
-# endif
+#define LONG_DOUBLESIZE 8 /**/
#endif
/* HAS_LONG_LONG:
@@ -1862,6 +1996,12 @@
*/
/*#define HAS_MSG / **/
+/* HAS_OPEN3:
+ * This manifest constant lets the C program know that the three
+ * argument form of open(2) is available.
+ */
+/*#define HAS_OPEN3 / **/
+
/* OLD_PTHREAD_CREATE_JOINABLE:
* This symbol, if defined, indicates how to create pthread
* in joinable (aka undetached) state. NOTE: not defined
@@ -1936,6 +2076,29 @@
/*#define HAS_READDIR_R / **/
#define READDIR_R_PROTO 0 /**/
+/* HAS_SAFE_BCOPY:
+ * This symbol, if defined, indicates that the bcopy routine is available
+ * to copy potentially overlapping memory blocks. Normally, you should
+ * probably use memmove() or memcpy(). If neither is defined, roll your
+ * own version.
+ */
+/*#define HAS_SAFE_BCOPY / **/
+
+/* HAS_SAFE_MEMCPY:
+ * This symbol, if defined, indicates that the memcpy routine is available
+ * to copy potentially overlapping memory blocks. If you need to
+ * copy overlapping memory blocks, you should check HAS_MEMMOVE and
+ * use memmove() instead, if available.
+ */
+/*#define HAS_SAFE_MEMCPY / **/
+
+/* HAS_SANE_MEMCMP:
+ * This symbol, if defined, indicates that the memcmp routine is available
+ * and can be used to compare relative magnitudes of chars with their high
+ * bits set. If it is not defined, roll your own version.
+ */
+#define HAS_SANE_MEMCMP /**/
+
/* HAS_SEM:
* This symbol, if defined, indicates that the entire sem*(2) library is
* supported.
@@ -2108,6 +2271,43 @@
#define Shmat_t void * /**/
/*#define HAS_SHMAT_PROTOTYPE / **/
+/* HAS_SIGACTION:
+ * This symbol, if defined, indicates that Vr4's sigaction() routine
+ * is available.
+ */
+/*#define HAS_SIGACTION / **/
+
+/* HAS_SIGSETJMP:
+ * This variable indicates to the C program that the sigsetjmp()
+ * routine is available to save the calling process's registers
+ * and stack environment for later use by siglongjmp(), and
+ * to optionally save the process's signal mask. See
+ * Sigjmp_buf, Sigsetjmp, and Siglongjmp.
+ */
+/* Sigjmp_buf:
+ * This is the buffer type to be used with Sigsetjmp and Siglongjmp.
+ */
+/* Sigsetjmp:
+ * This macro is used in the same way as sigsetjmp(), but will invoke
+ * traditional setjmp() if sigsetjmp isn't available.
+ * See HAS_SIGSETJMP.
+ */
+/* Siglongjmp:
+ * This macro is used in the same way as siglongjmp(), but will invoke
+ * traditional longjmp() if siglongjmp isn't available.
+ * See HAS_SIGSETJMP.
+ */
+/*#define HAS_SIGSETJMP / **/
+#ifdef HAS_SIGSETJMP
+#define Sigjmp_buf sigjmp_buf
+#define Sigsetjmp(buf,save_mask) sigsetjmp((buf),(save_mask))
+#define Siglongjmp(buf,retval) siglongjmp((buf),(retval))
+#else
+#define Sigjmp_buf jmp_buf
+#define Sigsetjmp(buf,save_mask) setjmp((buf))
+#define Siglongjmp(buf,retval) longjmp((buf),(retval))
+#endif
+
/* HAS_SOCKET:
* This symbol, if defined, indicates that the BSD socket interface is
* supported.
@@ -2146,8 +2346,30 @@
* Checking just with #ifdef might not be enough because this symbol
* has been known to be an enum.
*/
+/* HAS_SOCKADDR_SA_LEN:
+ * This symbol, if defined, indicates that the struct sockaddr
+ * structure has a member called sa_len, indicating the length of
+ * the structure.
+ */
+/* HAS_SOCKADDR_IN6:
+ * This symbol, if defined, indicates the availability of
+ * struct sockaddr_in6;
+ */
+/* HAS_SIN6_SCOPE_ID:
+ * This symbol, if defined, indicates that the struct sockaddr_in6
+ * structure has a member called sin6_scope_id.
+ */
+/* HAS_IP_MREQ:
+ * This symbol, if defined, indicates the availability of
+ * struct ip_mreq;
+ */
+/* HAS_IPV6_MREQ:
+ * This symbol, if defined, indicates the availability of
+ * struct ipv6_mreq;
+ */
#define HAS_SOCKET /**/
/*#define HAS_SOCKETPAIR / **/
+/*#define HAS_SOCKADDR_SA_LEN / **/
/*#define HAS_MSG_CTRUNC / **/
/*#define HAS_MSG_DONTROUTE / **/
/*#define HAS_MSG_OOB / **/
@@ -2154,6 +2376,10 @@
/*#define HAS_MSG_PEEK / **/
/*#define HAS_MSG_PROXY / **/
/*#define HAS_SCM_RIGHTS / **/
+/*#define HAS_SOCKADDR_IN6 / **/
+#define HAS_SIN6_SCOPE_ID /**/
+/*#define HAS_IP_MREQ / **/
+/*#define HAS_IPV6_MREQ / **/
/* HAS_SRAND48_R:
* This symbol, if defined, indicates that the srand48_r routine
@@ -2189,6 +2415,97 @@
/*#define USE_STAT_BLOCKS / **/
#endif
+/* HAS_STATIC_INLINE:
+ * This symbol, if defined, indicates that the C compiler supports
+ * C99-style static inline. That is, the function can't be called
+ * from another translation unit.
+ */
+/* PERL_STATIC_INLINE:
+ * This symbol gives the best-guess incantation to use for static
+ * inline functions. If HAS_STATIC_INLINE is defined, this will
+ * give C99-style inline. If HAS_STATIC_INLINE is not defined,
+ * this will give a plain 'static'. It will always be defined
+ * to something that gives static linkage.
+ * Possibilities include
+ * static inline (c99)
+ * static __inline__ (gcc -ansi)
+ * static __inline (MSVC)
+ * static _inline (older MSVC)
+ * static (c89 compilers)
+ */
+#define HAS_STATIC_INLINE /**/
+#define PERL_STATIC_INLINE static __inline /**/
+
+/* USE_STDIO_PTR:
+ * This symbol is defined if the _ptr and _cnt fields (or similar)
+ * of the stdio FILE structure can be used to access the stdio buffer
+ * for a file handle. If this is defined, then the FILE_ptr(fp)
+ * and FILE_cnt(fp) macros will also be defined and should be used
+ * to access these fields.
+ */
+/* FILE_ptr:
+ * This macro is used to access the _ptr field (or equivalent) of the
+ * FILE structure pointed to by its argument. This macro will always be
+ * defined if USE_STDIO_PTR is defined.
+ */
+/* STDIO_PTR_LVALUE:
+ * This symbol is defined if the FILE_ptr macro can be used as an
+ * lvalue.
+ */
+/* FILE_cnt:
+ * This macro is used to access the _cnt field (or equivalent) of the
+ * FILE structure pointed to by its argument. This macro will always be
+ * defined if USE_STDIO_PTR is defined.
+ */
+/* STDIO_CNT_LVALUE:
+ * This symbol is defined if the FILE_cnt macro can be used as an
+ * lvalue.
+ */
+/* STDIO_PTR_LVAL_SETS_CNT:
+ * This symbol is defined if using the FILE_ptr macro as an lvalue
+ * to increase the pointer by n has the side effect of decreasing the
+ * value of File_cnt(fp) by n.
+ */
+/* STDIO_PTR_LVAL_NOCHANGE_CNT:
+ * This symbol is defined if using the FILE_ptr macro as an lvalue
+ * to increase the pointer by n leaves File_cnt(fp) unchanged.
+ */
+#define USE_STDIO_PTR /**/
+#ifdef USE_STDIO_PTR
+#define FILE_ptr(fp) ((fp)->_ptr)
+#define STDIO_PTR_LVALUE /**/
+#define FILE_cnt(fp) ((fp)->_cnt)
+#define STDIO_CNT_LVALUE /**/
+/*#define STDIO_PTR_LVAL_SETS_CNT / **/
+#define STDIO_PTR_LVAL_NOCHANGE_CNT /**/
+#endif
+
+/* USE_STDIO_BASE:
+ * This symbol is defined if the _base field (or similar) of the
+ * stdio FILE structure can be used to access the stdio buffer for
+ * a file handle. If this is defined, then the FILE_base(fp) macro
+ * will also be defined and should be used to access this field.
+ * Also, the FILE_bufsiz(fp) macro will be defined and should be used
+ * to determine the number of bytes in the buffer. USE_STDIO_BASE
+ * will never be defined unless USE_STDIO_PTR is.
+ */
+/* FILE_base:
+ * This macro is used to access the _base field (or equivalent) of the
+ * FILE structure pointed to by its argument. This macro will always be
+ * defined if USE_STDIO_BASE is defined.
+ */
+/* FILE_bufsiz:
+ * This macro is used to determine the number of bytes in the I/O
+ * buffer pointed to by _base field (or equivalent) of the FILE
+ * structure pointed to its argument. This macro will always be defined
+ * if USE_STDIO_BASE is defined.
+ */
+#define USE_STDIO_BASE /**/
+#ifdef USE_STDIO_BASE
+#define FILE_base(fp) ((fp)->_base)
+#define FILE_bufsiz(fp) ((fp)->_cnt + (fp)->_ptr - (fp)->_base)
+#endif
+
/* USE_STRUCT_COPY:
* This symbol, if defined, indicates that this C compiler knows how
* to copy structures. If undefined, you'll need to use a block copy
@@ -2328,6 +2645,32 @@
#define volatile
#endif
+/* HAS_VPRINTF:
+ * This symbol, if defined, indicates that the vprintf routine is available
+ * to printf with a pointer to an argument list. If unavailable, you
+ * may need to write your own, probably in terms of _doprnt().
+ */
+/* USE_CHAR_VSPRINTF:
+ * This symbol is defined if this system has vsprintf() returning type
+ * (char*). The trend seems to be to declare it as "int vsprintf()". It
+ * is up to the package author to declare vsprintf correctly based on the
+ * symbol.
+ */
+#define HAS_VPRINTF /**/
+/*#define USE_CHAR_VSPRINTF / **/
+
+/* DOUBLESIZE:
+ * This symbol contains the size of a double, so that the C preprocessor
+ * can make decisions based on it.
+ */
+#define DOUBLESIZE 8 /**/
+
+/* EBCDIC:
+ * This symbol, if defined, indicates that this system uses
+ * EBCDIC encoding.
+ */
+/*#define EBCDIC / **/
+
/* Fpos_t:
* This symbol holds the type used to declare file positions in libc.
* It can be fpos_t, long, uint, etc... It may be necessary to include
@@ -2518,6 +2861,32 @@
*/
/*#define I_SYSUIO / **/
+/* I_TIME:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <time.h>.
+ */
+/* I_SYS_TIME:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/time.h>.
+ */
+/* I_SYS_TIME_KERNEL:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/time.h> with KERNEL defined.
+ */
+/* HAS_TM_TM_ZONE:
+ * This symbol, if defined, indicates to the C program that
+ * the struct tm has a tm_zone field.
+ */
+/* HAS_TM_TM_GMTOFF:
+ * This symbol, if defined, indicates to the C program that
+ * the struct tm has a tm_gmtoff field.
+ */
+#define I_TIME /**/
+/*#define I_SYS_TIME / **/
+/*#define I_SYS_TIME_KERNEL / **/
+/*#define HAS_TM_TM_ZONE / **/
+/*#define HAS_TM_TM_GMTOFF / **/
+
/* I_STDARG:
* This symbol, if defined, indicates that <stdarg.h> exists and should
* be included.
@@ -2587,6 +2956,33 @@
*/
#define Mode_t mode_t /* file mode parameter for system calls */
+/* VAL_O_NONBLOCK:
+ * This symbol is to be used during open() or fcntl(F_SETFL) to turn on
+ * non-blocking I/O for the file descriptor. Note that there is no way
+ * back, i.e. you cannot turn it blocking again this way. If you wish to
+ * alternatively switch between blocking and non-blocking, use the
+ * ioctl(FIOSNBIO) call instead, but that is not supported by all devices.
+ */
+/* VAL_EAGAIN:
+ * This symbol holds the errno error code set by read() when no data was
+ * present on the non-blocking file descriptor.
+ */
+/* RD_NODATA:
+ * This symbol holds the return code from read() when no data is present
+ * on the non-blocking file descriptor. Be careful! If EOF_NONBLOCK is
+ * not defined, then you can't distinguish between no data and EOF by
+ * issuing a read(). You'll have to find another way to tell for sure!
+ */
+/* EOF_NONBLOCK:
+ * This symbol, if defined, indicates to the C program that a read() on
+ * a non-blocking file descriptor will return 0 on EOF, and not the value
+ * held in RD_NODATA (-1 usually, in that case!).
+ */
+#define VAL_O_NONBLOCK O_NONBLOCK
+#define VAL_EAGAIN EAGAIN
+#define RD_NODATA -1
+#define EOF_NONBLOCK
+
/* Netdb_host_t:
* This symbol holds the type used for the 1st argument
* to gethostbyaddr().
@@ -2656,6 +3052,57 @@
#define _(args) ()
#endif
+/* PTRSIZE:
+ * This symbol contains the size of a pointer, so that the C preprocessor
+ * can make decisions based on it. It will be sizeof(void *) if
+ * the compiler supports (void *); otherwise it will be
+ * sizeof(char *).
+ */
+#define PTRSIZE 4 /**/
+
+/* HAS_QUAD:
+ * This symbol, if defined, tells that there's a 64-bit integer type,
+ * Quad_t, and its unsigned counterpart, Uquad_t. QUADKIND will be one
+ * of QUAD_IS_INT, QUAD_IS_LONG, QUAD_IS_LONG_LONG, QUAD_IS_INT64_T,
+ * or QUAD_IS___INT64.
+ */
+#define HAS_QUAD /**/
+#ifdef HAS_QUAD
+# define Quad_t __int64 /**/
+# define Uquad_t unsigned __int64 /**/
+# define QUADKIND 5 /**/
+# define QUAD_IS_INT 1
+# define QUAD_IS_LONG 2
+# define QUAD_IS_LONG_LONG 3
+# define QUAD_IS_INT64_T 4
+# define QUAD_IS___INT64 5
+#endif
+
+/* Drand01:
+ * This macro is to be used to generate uniformly distributed
+ * random numbers over the range [0., 1.[. You may have to supply
+ * an 'extern double drand48();' in your program since SunOS 4.1.3
+ * doesn't provide you with anything relevant in its headers.
+ * See HAS_DRAND48_PROTO.
+ */
+/* Rand_seed_t:
+ * This symbol defines the type of the argument of the
+ * random seed function.
+ */
+/* seedDrand01:
+ * This symbol defines the macro to be used in seeding the
+ * random number generator (see Drand01).
+ */
+/* RANDBITS:
+ * This symbol indicates how many bits are produced by the
+ * function used to generate normalized random numbers.
+ * Values include 15, 16, 31, and 48.
+ */
+#define Drand01() (rand()/(double)((unsigned)1<<RANDBITS)) /**/
+#define Rand_seed_t unsigned /**/
+#define seedDrand01(x) srand((Rand_seed_t)x) /**/
+#define RANDBITS 15 /**/
+
/* Select_fd_set_t:
* This symbol holds the type used for the 2nd, 3rd, and 4th
* arguments to select. Usually, this is 'fd_set *', if HAS_FD_SET
@@ -2766,7 +3213,7 @@
* unsigned long, int, etc. It may be necessary to include
* <sys/types.h> to get any typedef'ed information.
*/
-#define Size_t size_t /* length paramater for string functions */
+#define Size_t size_t /* length parameter for string functions */
/* Sock_size_t:
* This symbol holds the type used for the size argument of
@@ -2774,6 +3221,16 @@
*/
#define Sock_size_t int /**/
+/* SSize_t:
+ * This symbol holds the type used by functions that return
+ * a count of bytes or an error condition. It must be a signed type.
+ * It is usually ssize_t, but may be long or int, etc.
+ * It may be necessary to include <sys/types.h> or <unistd.h>
+ * to get any typedef'ed information.
+ * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t).
+ */
+#define SSize_t int /* signed count of bytes */
+
/* STDCHAR:
* This symbol is defined to be the type of char used in stdio.h.
* It has the values "unsigned char" or "char".
@@ -2867,7 +3324,7 @@
* 2 = supports arrays of pointers to functions returning void
* 4 = supports comparisons between pointers to void functions and
* addresses of void functions
- * 8 = suports declaration of generic void pointers
+ * 8 = supports declaration of generic void pointers
*
* The package designer should define VOIDUSED to indicate the requirements
* of the package. This can be done either by #defining VOIDUSED before
@@ -2884,464 +3341,6 @@
#define M_VOID /* Xenix strikes again */
#endif
-/* 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,
- * 4 and 8. The default is eight, for safety.
- */
-#if defined(USE_CROSS_COMPILE) || defined(MULTIARCH)
-# define MEM_ALIGNBYTES 8
-#else
-#define MEM_ALIGNBYTES 8
-#endif
-
-/* BYTEORDER:
- * 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 (eg. on NeXT systems), 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(USE_CROSS_COMPILE) || defined(MULTIARCH)
-# ifdef __LITTLE_ENDIAN__
-# if LONGSIZE == 4
-# define BYTEORDER 0x1234
-# else
-# if LONGSIZE == 8
-# define BYTEORDER 0x12345678
-# endif
-# endif
-# else
-# ifdef __BIG_ENDIAN__
-# if LONGSIZE == 4
-# define BYTEORDER 0x4321
-# else
-# if LONGSIZE == 8
-# define BYTEORDER 0x87654321
-# endif
-# endif
-# endif
-# endif
-# if !defined(BYTEORDER) && (defined(NeXT) || defined(__NeXT__))
-# define BYTEORDER 0x4321
-# endif
-#else
-#define BYTEORDER 0x1234 /* large digits for MSB */
-#endif /* NeXT */
-
-/* CHARBITS:
- * This symbol contains the size of a char, so that the C preprocessor
- * can make decisions based on it.
- */
-#define CHARBITS 8 /**/
-
-/* CASTI32:
- * This symbol is defined if the C compiler can cast negative
- * or large floating point numbers to 32-bit ints.
- */
-#ifdef __GNUC__
-# define CASTI32 /**/
-#endif
-
-/* CASTNEGFLOAT:
- * This symbol is defined if the C compiler can cast negative
- * numbers to unsigned longs, ints and shorts.
- */
-/* CASTFLAGS:
- * This symbol contains flags that say what difficulties the compiler
- * has casting odd floating values to unsigned long:
- * 0 = ok
- * 1 = couldn't cast < 0
- * 2 = couldn't cast >= 0x80000000
- * 4 = couldn't cast in argument expression list
- */
-#define CASTNEGFLOAT /**/
-#define CASTFLAGS 0 /**/
-
-/* VOID_CLOSEDIR:
- * This symbol, if defined, indicates that the closedir() routine
- * does not return a value.
- */
-/*#define VOID_CLOSEDIR / **/
-
-/* HAS_FD_SET:
- * This symbol, when defined, indicates presence of the fd_set typedef
- * in <sys/types.h>
- */
-#define HAS_FD_SET /**/
-
-/* Gconvert:
- * This preprocessor macro is defined to convert a floating point
- * number to a string without a trailing decimal point. This
- * emulates the behavior of sprintf("%g"), but is sometimes much more
- * efficient. If gconvert() is not available, but gcvt() drops the
- * trailing decimal point, then gcvt() is used. If all else fails,
- * a macro using sprintf("%g") is used. Arguments for the Gconvert
- * macro are: value, number of digits, whether trailing zeros should
- * be retained, and the output buffer.
- * The usual values are:
- * d_Gconvert='gconvert((x),(n),(t),(b))'
- * d_Gconvert='gcvt((x),(n),(b))'
- * d_Gconvert='sprintf((b),"%.*g",(n),(x))'
- * The last two assume trailing zeros should not be kept.
- */
-#define Gconvert(x,n,t,b) sprintf((b),"%.*g",(n),(x))
-
-/* HAS_GETPAGESIZE:
- * This symbol, if defined, indicates that the getpagesize system call
- * is available to get system page size, which is the granularity of
- * many memory management calls.
- */
-/*#define HAS_GETPAGESIZE / **/
-
-/* HAS_GNULIBC:
- * This symbol, if defined, indicates to the C program that
- * the GNU C library is being used. A better check is to use
- * the __GLIBC__ and __GLIBC_MINOR__ symbols supplied with glibc.
- */
-/*#define HAS_GNULIBC / **/
-#if defined(HAS_GNULIBC) && !defined(_GNU_SOURCE)
-# define _GNU_SOURCE
-#endif
-
-/* HAS_ISASCII:
- * This manifest constant lets the C program know that isascii
- * is available.
- */
-#define HAS_ISASCII /**/
-
-/* HAS_LCHOWN:
- * This symbol, if defined, indicates that the lchown routine is
- * available to operate on a symbolic link (instead of following the
- * link).
- */
-/*#define HAS_LCHOWN / **/
-
-/* HAS_OPEN3:
- * This manifest constant lets the C program know that the three
- * argument form of open(2) is available.
- */
-/*#define HAS_OPEN3 / **/
-
-/* HAS_SAFE_BCOPY:
- * This symbol, if defined, indicates that the bcopy routine is available
- * to copy potentially overlapping memory blocks. Normally, you should
- * probably use memmove() or memcpy(). If neither is defined, roll your
- * own version.
- */
-/*#define HAS_SAFE_BCOPY / **/
-
-/* HAS_SAFE_MEMCPY:
- * This symbol, if defined, indicates that the memcpy routine is available
- * to copy potentially overlapping memory blocks. If you need to
- * copy overlapping memory blocks, you should check HAS_MEMMOVE and
- * use memmove() instead, if available.
- */
-/*#define HAS_SAFE_MEMCPY / **/
-
-/* HAS_SANE_MEMCMP:
- * This symbol, if defined, indicates that the memcmp routine is available
- * and can be used to compare relative magnitudes of chars with their high
- * bits set. If it is not defined, roll your own version.
- */
-#define HAS_SANE_MEMCMP /**/
-
-/* HAS_SIGACTION:
- * This symbol, if defined, indicates that Vr4's sigaction() routine
- * is available.
- */
-/*#define HAS_SIGACTION / **/
-
-/* HAS_SIGSETJMP:
- * This variable indicates to the C program that the sigsetjmp()
- * routine is available to save the calling process's registers
- * and stack environment for later use by siglongjmp(), and
- * to optionally save the process's signal mask. See
- * Sigjmp_buf, Sigsetjmp, and Siglongjmp.
- */
-/* Sigjmp_buf:
- * This is the buffer type to be used with Sigsetjmp and Siglongjmp.
- */
-/* Sigsetjmp:
- * This macro is used in the same way as sigsetjmp(), but will invoke
- * traditional setjmp() if sigsetjmp isn't available.
- * See HAS_SIGSETJMP.
- */
-/* Siglongjmp:
- * This macro is used in the same way as siglongjmp(), but will invoke
- * traditional longjmp() if siglongjmp isn't available.
- * See HAS_SIGSETJMP.
- */
-/*#define HAS_SIGSETJMP / **/
-#ifdef HAS_SIGSETJMP
-#define Sigjmp_buf sigjmp_buf
-#define Sigsetjmp(buf,save_mask) sigsetjmp((buf),(save_mask))
-#define Siglongjmp(buf,retval) siglongjmp((buf),(retval))
-#else
-#define Sigjmp_buf jmp_buf
-#define Sigsetjmp(buf,save_mask) setjmp((buf))
-#define Siglongjmp(buf,retval) longjmp((buf),(retval))
-#endif
-
-/* HAS_STATIC_INLINE:
- * This symbol, if defined, indicates that the C compiler supports
- * C99-style static inline. That is, the function can't be called
- * from another translation unit.
- */
-/* PERL_STATIC_INLINE:
- * This symbol gives the best-guess incantation to use for static
- * inline functions. If HAS_STATIC_INLINE is defined, this will
- * give C99-style inline. If HAS_STATIC_INLINE is not defined,
- * this will give a plain 'static'. It will always be defined
- * to something that gives static linkage.
- * Possibilities include
- * static inline (c99)
- * static __inline__ (gcc -ansi)
- * static __inline (MSVC)
- * static _inline (older MSVC)
- * static (c89 compilers)
- */
-#ifdef _MSC_VER
-# define HAS_STATIC_INLINE /**/
-# define PERL_STATIC_INLINE static __inline /**/
-#else /* gcc presumably */
-# define HAS_STATIC_INLINE /**/
-# define PERL_STATIC_INLINE static __inline__ /**/
-#endif
-
-/* USE_STDIO_PTR:
- * This symbol is defined if the _ptr and _cnt fields (or similar)
- * of the stdio FILE structure can be used to access the stdio buffer
- * for a file handle. If this is defined, then the FILE_ptr(fp)
- * and FILE_cnt(fp) macros will also be defined and should be used
- * to access these fields.
- */
-/* FILE_ptr:
- * This macro is used to access the _ptr field (or equivalent) of the
- * FILE structure pointed to by its argument. This macro will always be
- * defined if USE_STDIO_PTR is defined.
- */
-/* STDIO_PTR_LVALUE:
- * This symbol is defined if the FILE_ptr macro can be used as an
- * lvalue.
- */
-/* FILE_cnt:
- * This macro is used to access the _cnt field (or equivalent) of the
- * FILE structure pointed to by its argument. This macro will always be
- * defined if USE_STDIO_PTR is defined.
- */
-/* STDIO_CNT_LVALUE:
- * This symbol is defined if the FILE_cnt macro can be used as an
- * lvalue.
- */
-/* STDIO_PTR_LVAL_SETS_CNT:
- * This symbol is defined if using the FILE_ptr macro as an lvalue
- * to increase the pointer by n has the side effect of decreasing the
- * value of File_cnt(fp) by n.
- */
-/* STDIO_PTR_LVAL_NOCHANGE_CNT:
- * This symbol is defined if using the FILE_ptr macro as an lvalue
- * to increase the pointer by n leaves File_cnt(fp) unchanged.
- */
-#define USE_STDIO_PTR /**/
-#ifdef USE_STDIO_PTR
-#define FILE_ptr(fp) ((fp)->_ptr)
-#define STDIO_PTR_LVALUE /**/
-#define FILE_cnt(fp) ((fp)->_cnt)
-#define STDIO_CNT_LVALUE /**/
-/*#define STDIO_PTR_LVAL_SETS_CNT / **/
-#define STDIO_PTR_LVAL_NOCHANGE_CNT /**/
-#endif
-
-/* USE_STDIO_BASE:
- * This symbol is defined if the _base field (or similar) of the
- * stdio FILE structure can be used to access the stdio buffer for
- * a file handle. If this is defined, then the FILE_base(fp) macro
- * will also be defined and should be used to access this field.
- * Also, the FILE_bufsiz(fp) macro will be defined and should be used
- * to determine the number of bytes in the buffer. USE_STDIO_BASE
- * will never be defined unless USE_STDIO_PTR is.
- */
-/* FILE_base:
- * This macro is used to access the _base field (or equivalent) of the
- * FILE structure pointed to by its argument. This macro will always be
- * defined if USE_STDIO_BASE is defined.
- */
-/* FILE_bufsiz:
- * This macro is used to determine the number of bytes in the I/O
- * buffer pointed to by _base field (or equivalent) of the FILE
- * structure pointed to its argument. This macro will always be defined
- * if USE_STDIO_BASE is defined.
- */
-#define USE_STDIO_BASE /**/
-#ifdef USE_STDIO_BASE
-#define FILE_base(fp) ((fp)->_base)
-#define FILE_bufsiz(fp) ((fp)->_cnt + (fp)->_ptr - (fp)->_base)
-#endif
-
-/* HAS_VPRINTF:
- * This symbol, if defined, indicates that the vprintf routine is available
- * to printf with a pointer to an argument list. If unavailable, you
- * may need to write your own, probably in terms of _doprnt().
- */
-/* USE_CHAR_VSPRINTF:
- * This symbol is defined if this system has vsprintf() returning type
- * (char*). The trend seems to be to declare it as "int vsprintf()". It
- * is up to the package author to declare vsprintf correctly based on the
- * symbol.
- */
-#define HAS_VPRINTF /**/
-/*#define USE_CHAR_VSPRINTF / **/
-
-/* DOUBLESIZE:
- * This symbol contains the size of a double, so that the C preprocessor
- * can make decisions based on it.
- */
-#define DOUBLESIZE 8 /**/
-
-/* I_TIME:
- * This symbol, if defined, indicates to the C program that it should
- * include <time.h>.
- */
-/* I_SYS_TIME:
- * This symbol, if defined, indicates to the C program that it should
- * include <sys/time.h>.
- */
-/* I_SYS_TIME_KERNEL:
- * This symbol, if defined, indicates to the C program that it should
- * include <sys/time.h> with KERNEL defined.
- */
-/* HAS_TM_TM_ZONE:
- * This symbol, if defined, indicates to the C program that
- * the struct tm has a tm_zone field.
- */
-/* HAS_TM_TM_GMTOFF:
- * This symbol, if defined, indicates to the C program that
- * the struct tm has a tm_gmtoff field.
- */
-#define I_TIME /**/
-/*#define I_SYS_TIME / **/
-/*#define I_SYS_TIME_KERNEL / **/
-/*#define HAS_TM_TM_ZONE / **/
-/*#define HAS_TM_TM_GMTOFF / **/
-
-/* VAL_O_NONBLOCK:
- * This symbol is to be used during open() or fcntl(F_SETFL) to turn on
- * non-blocking I/O for the file descriptor. Note that there is no way
- * back, i.e. you cannot turn it blocking again this way. If you wish to
- * alternatively switch between blocking and non-blocking, use the
- * ioctl(FIOSNBIO) call instead, but that is not supported by all devices.
- */
-/* VAL_EAGAIN:
- * This symbol holds the errno error code set by read() when no data was
- * present on the non-blocking file descriptor.
- */
-/* RD_NODATA:
- * This symbol holds the return code from read() when no data is present
- * on the non-blocking file descriptor. Be careful! If EOF_NONBLOCK is
- * not defined, then you can't distinguish between no data and EOF by
- * issuing a read(). You'll have to find another way to tell for sure!
- */
-/* EOF_NONBLOCK:
- * This symbol, if defined, indicates to the C program that a read() on
- * a non-blocking file descriptor will return 0 on EOF, and not the value
- * held in RD_NODATA (-1 usually, in that case!).
- */
-#define VAL_O_NONBLOCK O_NONBLOCK
-#define VAL_EAGAIN EAGAIN
-#define RD_NODATA -1
-#define EOF_NONBLOCK
-
-/* PTRSIZE:
- * This symbol contains the size of a pointer, so that the C preprocessor
- * can make decisions based on it. It will be sizeof(void *) if
- * the compiler supports (void *); otherwise it will be
- * sizeof(char *).
- */
-#define PTRSIZE 4 /**/
-
-/* Drand01:
- * This macro is to be used to generate uniformly distributed
- * random numbers over the range [0., 1.[. You may have to supply
- * an 'extern double drand48();' in your program since SunOS 4.1.3
- * doesn't provide you with anything relevant in its headers.
- * See HAS_DRAND48_PROTO.
- */
-/* Rand_seed_t:
- * This symbol defines the type of the argument of the
- * random seed function.
- */
-/* seedDrand01:
- * This symbol defines the macro to be used in seeding the
- * random number generator (see Drand01).
- */
-/* RANDBITS:
- * This symbol indicates how many bits are produced by the
- * function used to generate normalized random numbers.
- * Values include 15, 16, 31, and 48.
- */
-#define Drand01() (rand()/(double)((unsigned)1<<RANDBITS)) /**/
-#define Rand_seed_t unsigned /**/
-#define seedDrand01(x) srand((Rand_seed_t)x) /**/
-#define RANDBITS 15 /**/
-
-/* SSize_t:
- * This symbol holds the type used by functions that return
- * a count of bytes or an error condition. It must be a signed type.
- * It is usually ssize_t, but may be long or int, etc.
- * It may be necessary to include <sys/types.h> or <unistd.h>
- * to get any typedef'ed information.
- * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t).
- */
-#define SSize_t int /* signed count of bytes */
-
-/* EBCDIC:
- * This symbol, if defined, indicates that this system uses
- * EBCDIC encoding.
- */
-/*#define EBCDIC / **/
-
-/* 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.
- */
-/* DOSUID:
- * This symbol, if defined, indicates that the C program should
- * check the script that it is executing for setuid/setgid bits, and
- * attempt to emulate setuid/setgid on systems that have disabled
- * setuid #! scripts because the kernel can't do it securely.
- * It is up to the package designer to make sure that this emulation
- * is done securely. Among other things, it should do an fstat on
- * the script it just opened to make sure it really is a setuid/setgid
- * script, it should make sure the arguments passed correspond exactly
- * to the argument on the #! line, and it should not trust any
- * subprocesses to which it must pass the filename rather than the
- * file descriptor of the script to be executed.
- */
-/*#define SETUID_SCRIPTS_ARE_SECURE_NOW / **/
-/*#define DOSUID / **/
-
/* PERL_USE_DEVEL:
* This symbol, if defined, indicates that Perl was configured with
* -Dusedevel, to enable development features. This should not be
@@ -3629,7 +3628,7 @@
/* HAS_GETESPWNAM:
* This symbol, if defined, indicates that the getespwnam system call is
- * available to retrieve enchanced (shadow) password entries by name.
+ * available to retrieve enhanced (shadow) password entries by name.
*/
/*#define HAS_GETESPWNAM / **/
@@ -3706,6 +3705,12 @@
*/
/*#define HAS_INT64_T / **/
+/* HAS_ISBLANK:
+ * This manifest constant lets the C program know that isblank
+ * is available.
+ */
+/*#define HAS_ISBLANK / **/
+
/* HAS_ISFINITE:
* This symbol, if defined, indicates that the isfinite routine is
* available to check whether a double is finite (non-infinity non-NaN).
@@ -3770,7 +3775,7 @@
/* HAS_MKSTEMPS:
* This symbol, if defined, indicates that the mkstemps routine is
- * available to excluslvely create and open a uniquely named
+ * available to exclusively create and open a uniquely named
* (with a suffix) temporary file.
*/
/*#define HAS_MKSTEMPS / **/
@@ -3820,6 +3825,17 @@
*/
/*#define HAS_OFF64_T / **/
+/* HAS_PRCTL:
+ * This symbol, if defined, indicates that the prctl routine is
+ * available to set process title.
+ */
+/* HAS_PRCTL_SET_NAME:
+ * This symbol, if defined, indicates that the prctl routine is
+ * available to set process title and supports PR_SET_NAME.
+ */
+/*#define HAS_PRCTL / **/
+/*#define HAS_PRCTL_SET_NAME / **/
+
/* HAS_PROCSELFEXE:
* This symbol is defined if PROCSELFEXE_PATH is a symlink
* to the absolute pathname of the executing program.
@@ -4291,6 +4307,12 @@
*/
/*#define I_SOCKS / **/
+/* I_STDBOOL:
+ * This symbol, if defined, indicates that <stdbool.h> exists and
+ * can be included.
+ */
+/*#define I_STDBOOL / **/
+
/* I_SUNMATH:
* This symbol, if defined, indicates that <sunmath.h> exists and
* should be included.
@@ -4459,7 +4481,7 @@
/* NV_OVERFLOWS_INTEGERS_AT:
* This symbol gives the largest integer value that NVs can hold. This
* value + 1.0 cannot be stored accurately. It is expressed as constant
- * floating point expression to reduce the chance of decimale/binary
+ * floating point expression to reduce the chance of decimal/binary
* conversion issues. If it can not be determined, the value 0 is given.
*/
/* NV_ZERO_IS_ALLBITS_ZERO:
@@ -4475,13 +4497,8 @@
#define I32TYPE long /**/
#define U32TYPE unsigned long /**/
#ifdef HAS_QUAD
-# ifndef __GNUC__
-# define I64TYPE __int64 /**/
-# define U64TYPE unsigned __int64 /**/
-# else
-# define I64TYPE long long /**/
-# define U64TYPE unsigned long long /**/
-# endif
+#define I64TYPE __int64 /**/
+#define U64TYPE unsigned __int64 /**/
#endif
#define NVTYPE double /**/
#define IVSIZE 4 /**/
@@ -4565,6 +4582,16 @@
*/
#define SELECT_MIN_BITS 32 /**/
+/* ST_INO_SIZE:
+ * This variable contains the size of struct stat's st_ino in bytes.
+ */
+/* ST_INO_SIGN:
+ * This symbol holds the signedess of struct stat's st_ino.
+ * 1 for unsigned, -1 for signed.
+ */
+#define ST_INO_SIGN 1 /* st_ino sign */
+#define ST_INO_SIZE 4 /* st_ino size */
+
/* STARTPERL:
* This variable contains the string to put in front of a perl
* script to make sure (one hopes) that it runs with perl and not
@@ -4601,8 +4628,8 @@
* This symbol contains the minimum value for the time_t offset that
* the system function localtime () accepts, and defaults to 0
*/
-#define GMTIME_MAX 2147483647 /**/
-#define GMTIME_MIN 0 /**/
+#define GMTIME_MAX 2147483647 /**/
+#define GMTIME_MIN 0 /**/
#define LOCALTIME_MAX 2147483647 /**/
#define LOCALTIME_MIN 0 /**/
@@ -4646,6 +4673,13 @@
/*#define USE_FAST_STDIO / **/
#endif
+/* USE_KERN_PROC_PATHNAME:
+ * This symbol, if defined, indicates that we can use sysctl with
+ * KERN_PROC_PATHNAME to get a full path for the executable, and hence
+ * convert $^X to an absolute path.
+ */
+/*#define USE_KERN_PROC_PATHNAME / **/
+
/* USE_LARGE_FILES:
* This symbol, if defined, indicates that large file support
* should be used when available.
@@ -4678,6 +4712,13 @@
/*#define MULTIPLICITY / **/
#endif
+/* USE_NSGETEXECUTABLEPATH:
+ * This symbol, if defined, indicates that we can use _NSGetExecutablePath
+ * and realpath to get a full path for the executable, and hence convert
+ * $^X to an absolute path.
+ */
+/*#define USE_NSGETEXECUTABLEPATH / **/
+
/* USE_PERLIO:
* This symbol, if defined, indicates that the PerlIO abstraction should
* be used throughout. If not defined, stdio should be
Property changes on: trunk/contrib/perl/win32/config_H.vc
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/win32/config_H.vc64
===================================================================
--- trunk/contrib/perl/win32/config_H.vc64 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/config_H.vc64 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/win32/config_H.vc64
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/win32/config_h.PL
===================================================================
--- trunk/contrib/perl/win32/config_h.PL 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/config_h.PL 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,14 +1,17 @@
-#
+#!perl -w
+use strict;
+
BEGIN { warn "Running ".__FILE__."\n" };
BEGIN
{
require "Config.pm";
die "Config.pm:$@" if $@;
- Config::->import;
+ Config->import;
}
use File::Compare qw(compare);
use File::Copy qw(copy);
use File::Basename qw(fileparse);
+
my ($name, $dir) = fileparse($0);
$name =~ s#^(.*)\.PL$#../$1.SH#;
my %opt;
@@ -23,18 +26,12 @@
warn "Writing $opt{CONFIG_H}\n";
-my $patchlevel = $opt{INST_VER};
-$patchlevel =~ s|^[\\/]||;
-$patchlevel =~ s|~VERSION~|$Config{version}|g;
-$patchlevel ||= $Config{version};
-$patchlevel = qq["$patchlevel"];
-
open(SH,"<$name") || die "Cannot open $name:$!";
while (<SH>)
{
last if /^\s*sed/;
}
-($term,$file,$pat) = /^\s*sed\s+<<(\S+)\s+>(\S+)\s+(.*)$/;
+my($term,$file,$pat) = /^\s*sed\s+<<(\S+)\s+>(\S+)\s+(.*)$/;
$file =~ s/^\$(\w+)$/$opt{$1}/g;
@@ -54,7 +51,6 @@
die "$str:$@" if $@;
open(H,">$file.new") || die "Cannot open $file.new:$!";
-#binmode H; # no CRs (which cause a spurious rebuild)
while (<SH>)
{
last if /^$term$/o;
@@ -73,6 +69,10 @@
{
$_ = "/*#define ". $1 . "_EXP \"\"\t/ **/\n";
}
+ elsif (/^\s*#define\s+CPP(STDIN|RUN)\s+"gcc(.*)"\s*$/)
+ {
+ $_ = "#define CPP" . $1 . " \"" . $opt{ARCHPREFIX} . "gcc" . $2 . "\"\n";
+ }
print H;
}
close(H);
@@ -89,7 +89,6 @@
chmod(0666,$file);
unlink($file);
rename("$file.new",$file);
- #chmod(0444,$file);
exit(1);
}
else
@@ -112,7 +111,7 @@
my $cmd = shift;
if ($cmd =~ /^echo\s+(.*?)\s*\|\s+sed\s+'(.*)'\s*$/)
{
- local ($data,$pat) = ($1,$2);
+ my($data,$pat) = ($1,$2);
$data =~ s/\s+/ /g;
eval "\$data =~ $pat";
return $data;
Property changes on: trunk/contrib/perl/win32/config_h.PL
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/win32/config_sh.PL
===================================================================
--- trunk/contrib/perl/win32/config_sh.PL 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/config_sh.PL 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,4 +1,7 @@
+#!perl -w
+use strict;
use FindExt;
+
# take a semicolon separated path list and turn it into a quoted
# list of paths that Text::Parsewords will grok
sub mungepath {
@@ -18,7 +21,7 @@
if ($ARGV[0] =~ /--cfgsh-option-file/) {
shift @ARGV;
my $optfile = shift @ARGV;
- local (*F);
+ local (*OPTF);
open OPTF, $optfile or die "Can't open $optfile: $!\n";
my @opts;
chomp(my $line = <OPTF>);
@@ -45,13 +48,13 @@
FindExt::scan_ext("../cpan");
FindExt::scan_ext("../dist");
FindExt::scan_ext("../ext");
-FindExt::set_static_extensions(split ' ', $opt{'static_ext'});
+FindExt::set_static_extensions(split ' ', $opt{static_ext});
-$opt{'nonxs_ext'} = join(' ',FindExt::nonxs_ext()) || ' ';
-$opt{'static_ext'} = join(' ',FindExt::static_ext()) || ' ';
-$opt{'dynamic_ext'} = join(' ',FindExt::dynamic_ext()) || ' ';
-$opt{'extensions'} = join(' ',FindExt::extensions()) || ' ';
-$opt{'known_extensions'} = join(' ',FindExt::known_extensions()) || ' ';
+$opt{nonxs_ext} = join(' ',FindExt::nonxs_ext()) || ' ';
+$opt{static_ext} = join(' ',FindExt::static_ext()) || ' ';
+$opt{dynamic_ext} = join(' ',FindExt::dynamic_ext()) || ' ';
+$opt{extensions} = join(' ',FindExt::extensions()) || ' ';
+$opt{known_extensions} = join(' ',FindExt::known_extensions()) || ' ';
my $pl_h = '../patchlevel.h';
@@ -76,62 +79,119 @@
close $fh;
}
-$opt{VERSION} = "$opt{PERL_REVISION}.$opt{PERL_VERSION}.$opt{PERL_SUBVERSION}";
-$opt{INST_VER} =~ s|~VERSION~|$opt{VERSION}|g;
-$opt{'version_patchlevel_string'} = "version $opt{PERL_VERSION} subversion $opt{PERL_SUBVERSION}";
-$opt{'version_patchlevel_string'} .= " patch $opt{PERL_PATCHLEVEL}" if exists $opt{PERL_PATCHLEVEL};
+$opt{version} = "$opt{PERL_REVISION}.$opt{PERL_VERSION}.$opt{PERL_SUBVERSION}";
+$opt{version_patchlevel_string} = "version $opt{PERL_VERSION} subversion $opt{PERL_SUBVERSION}";
+$opt{version_patchlevel_string} .= " patch $opt{PERL_PATCHLEVEL}" if exists $opt{PERL_PATCHLEVEL};
my $ver = `ver 2>nul`;
if ($ver =~ /Version (\d+\.\d+)/) {
- $opt{'osvers'} = $1;
+ $opt{osvers} = $1;
}
else {
- $opt{'osvers'} = '4.0';
+ $opt{osvers} = '4.0';
}
if (exists $opt{cc}) {
- # cl and bcc32 version detection borrowed from Test::Smoke's configsmoke.pl
+ # cl version detection borrowed from Test::Smoke's configsmoke.pl
if ($opt{cc} eq 'cl') {
my $output = `cl --version 2>&1`;
$opt{ccversion} = $output =~ /^.*Version\s+([\d.]+)/ ? $1 : '?';
}
- elsif ($opt{cc} eq 'bcc32') {
- my $output = `bcc32 --version 2>&1`;
- $opt{ccversion} = $output =~ /([\d.]+)/ ? $1 : '?';
- }
elsif ($opt{cc} =~ /\bgcc\b/) {
chomp($opt{gccversion} = `$opt{cc} -dumpversion`);
}
}
-$opt{'cf_by'} = $ENV{USERNAME} unless $opt{'cf_by'};
-$opt{'cf_email'} = $opt{'cf_by'} . '@' . (gethostbyname('localhost'))[0]
- unless $opt{'cf_email'};
-$opt{'usemymalloc'} = 'y' if $opt{'d_mymalloc'} eq 'define';
+$opt{cf_by} = $ENV{USERNAME} unless $opt{cf_by};
+if (!$opt{cf_email}) {
+ my $computername = eval{(gethostbyname('localhost'))[0]};
+# gethostbyname might not be implemented in miniperl
+ $computername = $ENV{COMPUTERNAME} if $@;
+ $opt{cf_email} = $opt{cf_by} . '@' . $computername;
+}
+$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};
-# some functions are not available on Win9x
-unless (defined $ENV{SYSTEMROOT}) { # SystemRoot has been introduced by WinNT
- $opt{d_flock} = 'undef';
- $opt{d_link} = 'undef';
+my($int64, $int64f);
+if ($opt{cc} eq 'cl') {
+ $int64 = '__int64';
+ $int64f = 'I64';
}
+elsif ($opt{cc} =~ /\bgcc\b/) {
+ $int64 = 'long long';
+ $int64f = 'll';
+}
-# change the lseeksize and lseektype from their canned default values (which
-# are set-up for a non-uselargefiles build) if we are building with
-# uselargefiles. don't do this for bcc32: the code contains special handling
-# for bcc32 and the lseeksize and lseektype should not be changed.
-if ($opt{uselargefiles} eq 'define' and $opt{cc} ne 'bcc32') {
+# set large files options
+if ($opt{uselargefiles} eq 'define') {
$opt{lseeksize} = 8;
- if ($opt{cc} eq 'cl') {
- $opt{lseektype} = '__int64';
- }
- elsif ($opt{cc} =~ /\bgcc\b/) {
- $opt{lseektype} = 'long long';
- }
+ $opt{lseektype} = $int64;
}
+else {
+ $opt{lseeksize} = 4;
+ $opt{lseektype} = 'long';
+}
+# set 64-bit options
+if ($opt{WIN64} eq 'define') {
+ $opt{d_atoll} = 'define';
+ $opt{d_strtoll} = 'define';
+ $opt{d_strtoull} = 'define';
+ $opt{ptrsize} = 8;
+ $opt{sizesize} = 8;
+ $opt{ssizetype} = $int64;
+ $opt{st_ino_size} = 8;
+}
+else {
+ $opt{d_atoll} = 'undef';
+ $opt{d_strtoll} = 'undef';
+ $opt{d_strtoull} = 'undef';
+ $opt{ptrsize} = 4;
+ $opt{sizesize} = 4;
+ $opt{ssizetype} = 'int';
+ $opt{st_ino_size} = 4;
+}
+if ($opt{use64bitint} eq 'define') {
+ $opt{d_nv_preserves_uv} = 'undef';
+ $opt{ivdformat} = qq{"${int64f}d"};
+ $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{uvsize} = 8;
+ $opt{uvtype} = qq{unsigned $int64};
+ $opt{uvuformat} = qq{"${int64f}u"};
+ $opt{uvxformat} = qq{"${int64f}x"};
+}
+else {
+ $opt{d_nv_preserves_uv} = 'define';
+ $opt{ivdformat} = '"ld"';
+ $opt{ivsize} = 4;
+ $opt{ivtype} = 'long';
+ $opt{nv_preserves_uv_bits} = 32;
+ $opt{sPRIXU64} = '"lX"';
+ $opt{sPRId64} = '"ld"';
+ $opt{sPRIi64} = '"li"';
+ $opt{sPRIo64} = '"lo"';
+ $opt{sPRIu64} = '"lu"';
+ $opt{sPRIx64} = '"lx"';
+ $opt{uvXUformat} = '"lX"';
+ $opt{uvoformat} = '"lo"';
+ $opt{uvsize} = 4;
+ $opt{uvtype} = 'unsigned long';
+ $opt{uvuformat} = '"lu"';
+ $opt{uvxformat} = '"lx"';
+}
+
# change the s{GM|LOCAL}TIME_{min|max} for VS2005 (aka VC 8) and
# VS2008 (aka VC 9) or higher (presuming that later versions will have
# at least the range of that).
@@ -148,7 +208,7 @@
}
while (<>) {
- s/~([\w_]+)~/$opt{$1}/g;
+ s/~([\w_]+)~/exists $opt{$1} ? $opt{$1} : ''/eg;
if (/^([\w_]+)=(.*)$/) {
my($k,$v) = ($1,$2);
# this depends on cf_time being empty in the template (or we'll
Property changes on: trunk/contrib/perl/win32/config_sh.PL
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/win32/create_perllibst_h.pl
===================================================================
--- trunk/contrib/perl/win32/create_perllibst_h.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/create_perllibst_h.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/win32/create_perllibst_h.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/win32/distclean.bat
===================================================================
--- trunk/contrib/perl/win32/distclean.bat 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/distclean.bat 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/win32/distclean.bat
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/win32/fcrypt.c
===================================================================
--- trunk/contrib/perl/win32/fcrypt.c 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/fcrypt.c 2013-12-02 21:26:09 UTC (rev 6439)
@@ -9,10 +9,6 @@
* eay at psych.psy.uq.oz.au
*/
-#if defined(__BORLANDC__)
-#pragma warn -8004 /* "'foo' is assigned a value that is never used" */
-#endif
-
typedef unsigned char des_cblock[8];
typedef struct des_ks_struct
@@ -340,10 +336,10 @@
static int
des_set_key(des_cblock *key, des_key_schedule schedule)
{
- register unsigned long c,d,t,s;
- register unsigned char *in;
- register unsigned long *k;
- register int i;
+ unsigned long c,d,t,s;
+ unsigned char *in;
+ unsigned long *k;
+ int i;
k=(unsigned long *)schedule;
in=(unsigned char *)key;
@@ -537,13 +533,13 @@
unsigned long Eswap0,
unsigned long Eswap1)
{
- register unsigned long l,r,t,u,v;
+ unsigned long l,r,t,u,v;
#ifdef ALT_ECB
- register unsigned char *des_SP=(unsigned char *)SPtrans;
+ unsigned char *des_SP=(unsigned char *)SPtrans;
#endif
- register unsigned long *s;
- register int i,j;
- register unsigned long E0,E1;
+ unsigned long *s;
+ int i,j;
+ unsigned long E0,E1;
l=0;
r=0;
Property changes on: trunk/contrib/perl/win32/fcrypt.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/win32/genmk95.pl
===================================================================
--- trunk/contrib/perl/win32/genmk95.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/genmk95.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/win32/genmk95.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/win32/include/arpa/inet.h
===================================================================
--- trunk/contrib/perl/win32/include/arpa/inet.h 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/include/arpa/inet.h 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/win32/include/arpa/inet.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/win32/include/dirent.h
===================================================================
--- trunk/contrib/perl/win32/include/dirent.h 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/include/dirent.h 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/win32/include/dirent.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/win32/include/netdb.h
===================================================================
--- trunk/contrib/perl/win32/include/netdb.h 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/include/netdb.h 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/win32/include/netdb.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/win32/include/sys/socket.h
===================================================================
--- trunk/contrib/perl/win32/include/sys/socket.h 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/include/sys/socket.h 2013-12-02 21:26:09 UTC (rev 6439)
@@ -30,11 +30,17 @@
# include <ws2tcpip.h>
# ifndef SIO_GET_INTERFACE_LIST_EX
+
+# ifndef MSG_WAITALL
+# define MSG_WAITALL 0x8
+# endif
+
/* The ws2tcpip.h header included in VC6 doesn't define the
* sin6_scope_id member of sockaddr_in6. We define our own
* version and redefine sockaddr_in6 to point to this one
* instead for compiling e.g. Socket.xs.
*/
+
struct my_sockaddr_in6 {
short sin6_family; /* AF_INET6 */
u_short sin6_port; /* Transport level port number */
@@ -71,11 +77,106 @@
(x)->sin6_scope_id = 0; \
}
+# ifndef IPV6_HDRINCL
+# define IPV6_HDRINCL 2
+# endif
+# ifndef IPV6_UNICAST_HOPS
+# define IPV6_UNICAST_HOPS 4
+# endif
+# ifndef IPV6_MULTICAST_IF
+# define IPV6_MULTICAST_IF 9
+# endif
+# ifndef IPV6_MULTICAST_HOPS
+# define IPV6_MULTICAST_HOPS 10
+# endif
+# ifndef IPV6_MULTICAST_LOOP
+# define IPV6_MULTICAST_LOOP 11
+# endif
+# ifndef IPV6_ADD_MEMBERSHIP
+# define IPV6_ADD_MEMBERSHIP 12
+# endif
+# ifndef IPV6_DROP_MEMBERSHIP
+# define IPV6_DROP_MEMBERSHIP 13
+# endif
+# ifndef IPV6_JOIN_GROUP
+# define IPV6_JOIN_GROUP IPV6_ADD_MEMBERSHIP
+# endif
+# ifndef IPV6_LEAVE_GROUP
+# define IPV6_LEAVE_GROUP IPV6_DROP_MEMBERSHIP
+# endif
+# ifndef IPV6_PKTINFO
+# define IPV6_PKTINFO 19
+# endif
+# ifndef IPV6_HOPLIMIT
+# define IPV6_HOPLIMIT 21
+# endif
+# ifndef IPV6_PROTECTION_LEVEL
+# define IPV6_PROTECTION_LEVEL 23
+# endif
+
+ /* The ws2tcpip.h header included in MinGW includes ipv6_mreq already */
+# ifndef __GNUC__
+ typedef struct ipv6_mreq {
+ struct in_addr6 ipv6mr_multiaddr;
+ unsigned int ipv6mr_interface;
+ } IPV6_MREQ;
+# endif
+
+# ifndef EAI_AGAIN
+# define EAI_AGAIN WSATRY_AGAIN
+# endif
+# ifndef EAI_BADFLAGS
+# define EAI_BADFLAGS WSAEINVAL
+# endif
+# ifndef EAI_FAIL
+# define EAI_FAIL WSANO_RECOVERY
+# endif
+# ifndef EAI_FAMILY
+# define EAI_FAMILY WSAEAFNOSUPPORT
+# endif
+# ifndef EAI_MEMORY
+# define EAI_MEMORY WSA_NOT_ENOUGH_MEMORY
+# endif
+# ifndef EAI_NODATA
+# define EAI_NODATA WSANO_DATA
+# endif
+# ifndef EAI_NONAME
+# define EAI_NONAME WSAHOST_NOT_FOUND
+# endif
+# ifndef EAI_SERVICE
+# define EAI_SERVICE WSATYPE_NOT_FOUND
+# endif
+# ifndef EAI_SOCKTYPE
+# define EAI_SOCKTYPE WSAESOCKTNOSUPPORT
+# endif
+
+# ifndef NI_NOFQDN
+# define NI_NOFQDN 0x01
+# endif
+# ifndef NI_NUMERICHOST
+# define NI_NUMERICHOST 0x02
+# endif
+# ifndef NI_NAMEREQD
+# define NI_NAMEREQD 0x04
+# endif
+# ifndef NI_NUMERICSERV
+# define NI_NUMERICSERV 0x08
+# endif
+# ifndef NI_DGRAM
+# define NI_DGRAM 0x10
+# endif
+
# endif
# endif
#endif
+/* Early Platform SDKs have an incorrect definition of EAI_NODATA */
+#if (EAI_NODATA == EAI_NONAME)
+# undef EAI_NODATA
+# define EAI_NODATA WSANO_DATA
+#endif
+
#include "win32.h"
#ifdef __cplusplus
@@ -94,8 +195,6 @@
#undef EAFNOSUPPORT
#define EAFNOSUPPORT WSAEAFNOSUPPORT
-#ifdef USE_SOCKETS_AS_HANDLES
-
#ifndef PERL_FD_SETSIZE
#define PERL_FD_SETSIZE 64
#endif
@@ -120,16 +219,6 @@
#define PERL_FD_ISSET(n,p) \
((p)->bits[(n)/PERL_NFDBITS] & ((unsigned)1 << ((n)%PERL_NFDBITS)))
-#else /* USE_SOCKETS_AS_HANDLES */
-
-#define Perl_fd_set fd_set
-#define PERL_FD_SET(n,p) FD_SET(n,p)
-#define PERL_FD_CLR(n,p) FD_CLR(n,p)
-#define PERL_FD_ISSET(n,p) FD_ISSET(n,p)
-#define PERL_FD_ZERO(p) FD_ZERO(p)
-
-#endif /* USE_SOCKETS_AS_HANDLES */
-
SOCKET win32_accept (SOCKET s, struct sockaddr *addr, int *addrlen);
int win32_bind (SOCKET s, const struct sockaddr *addr, int namelen);
int win32_closesocket (SOCKET s);
@@ -230,7 +319,6 @@
#define setprotoent win32_setprotoent
#define setservent win32_setservent
-#ifdef USE_SOCKETS_AS_HANDLES
#undef fd_set
#undef FD_SET
#undef FD_CLR
@@ -241,7 +329,6 @@
#define FD_CLR(n,p) PERL_FD_CLR(n,p)
#define FD_ISSET(n,p) PERL_FD_ISSET(n,p)
#define FD_ZERO(p) PERL_FD_ZERO(p)
-#endif /* USE_SOCKETS_AS_HANDLES */
#endif /* WIN32SCK_IS_STDSCK */
Property changes on: trunk/contrib/perl/win32/include/sys/socket.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/win32/list_static_libs.pl
===================================================================
--- trunk/contrib/perl/win32/list_static_libs.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/list_static_libs.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/win32/list_static_libs.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/win32/makefile.mk
===================================================================
--- trunk/contrib/perl/win32/makefile.mk 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/makefile.mk 2013-12-02 21:26:09 UTC (rev 6439)
@@ -2,12 +2,11 @@
# Makefile to build perl on Windows using DMAKE.
# Supported compilers:
# Microsoft Visual C++ 6.0 or later
-# Borland C++ 5.02 or later
# MinGW with gcc-3.2 or later
# Windows SDK 64-bit compiler and tools
#
# This is set up to build a perl.exe that runs off a shared library
-# (perl514.dll). Also makes individual DLLs for the XS extensions.
+# (perl518.dll). Also makes individual DLLs for the XS extensions.
#
##
@@ -39,7 +38,7 @@
# versioned installation can be obtained by setting INST_TOP above to a
# path that includes an arbitrary version string.
#
-#INST_VER *= \5.14.0
+#INST_VER *= \5.18.1
#
# Comment this out if you DON'T want your perl installation to have
@@ -95,46 +94,42 @@
USE_LARGE_FILES *= define
#
+# Uncomment this if you're building a 32-bit perl and want 64-bit integers.
+# (If you're building a 64-bit perl then you will have 64-bit integers whether
+# or not this is uncommented.)
+#USE_64_BIT_INT *= define
+
+#
# uncomment exactly one of the following
#
# Visual C++ 6.x (aka Visual C++ 98)
#CCTYPE *= MSVC60
+# Visual C++ .NET 2002/2003 (aka Visual C++ 7.x) (full version)
+#CCTYPE *= MSVC70
# Visual C++ Toolkit 2003 (aka Visual C++ 7.x) (free command-line tools)
#CCTYPE *= MSVC70FREE
-# Visual C++ .NET 2003 (aka Visual C++ 7.x) (full version)
-#CCTYPE *= MSVC70
# Windows Server 2003 SP1 Platform SDK (April 2005)
#CCTYPE = SDK2003SP1
+# Visual C++ 2005 (aka Visual C++ 8.x) (full version)
+#CCTYPE *= MSVC80
# Visual C++ 2005 Express Edition (aka Visual C++ 8.x) (free version)
#CCTYPE *= MSVC80FREE
-# Visual C++ 2005 (aka Visual C++ 8.x) (full version)
-#CCTYPE *= MSVC80
+# Visual C++ 2008 (aka Visual C++ 9.x) (full version)
+#CCTYPE *= MSVC90
# Visual C++ 2008 Express Edition (aka Visual C++ 9.x) (free version)
#CCTYPE *= MSVC90FREE
-# Visual C++ 2008 (aka Visual C++ 9.x) (full version)
-#CCTYPE *= MSVC90
+# Visual C++ 2010 (aka Visual C++ 10.x) (full version)
+#CCTYPE = MSVC100
# Visual C++ 2010 Express Edition (aka Visual C++ 10.x) (free version)
#CCTYPE = MSVC100FREE
-# Visual C++ 2010 (aka Visual C++ 10.x) (full version)
-#CCTYPE = MSVC100
-# Borland 5.02 or later
-#CCTYPE *= BORLAND
+# Visual C++ 2012 (aka Visual C++ 11.x) (full version)
+#CCTYPE = MSVC110
+# Visual C++ 2012 Express Edition (aka Visual C++ 11.x) (free version)
+#CCTYPE = MSVC110FREE
# MinGW or mingw-w64 with gcc-3.2 or later
CCTYPE *= GCC
#
-# uncomment this if your Borland compiler is older than v5.4.
-#BCCOLD *= define
-#
-# uncomment this if you want to use Borland's VCL as your CRT
-#BCCVCL *= define
-
-#
-# uncomment this if you are compiling under Windows 95/98 and command.com
-# (not needed if you're running under 4DOS/NT 6.01 or later)
-#IS_WIN95 *= define
-
-#
# uncomment next line if you want debug version of perl (big,slow)
# If not enabled, we automatically try to use maximum optimization
# with all compilers that are known to have a working optimizer.
@@ -170,7 +165,7 @@
# set this to additionally provide a statically linked perl-static.exe.
# Note that dynamic loading will not work with this perl, so you must
# include required modules statically using the STATIC_EXT or ALL_STATIC
-# variables below. A static library perl514s.lib will also be created.
+# variables below. A static library perl518s.lib will also be created.
# Ordinary perl.exe is not affected by this option.
#
#BUILD_STATIC *= define
@@ -191,9 +186,7 @@
# so you may have to set CCHOME explicitly (spaces in the path name should
# not be quoted)
#
-.IF "$(CCTYPE)" == "BORLAND"
-CCHOME *= C:\Borland\BCC55
-.ELIF "$(CCTYPE)" == "GCC"
+.IF "$(CCTYPE)" == "GCC"
CCHOME *= C:\MinGW
.ELSE
CCHOME *= $(MSVCDIR)
@@ -200,22 +193,6 @@
.ENDIF
#
-# If building with gcc-4.x.x (or x86_64-w64-mingw32-gcc-4.x.x), then
-# uncomment the following assignment to GCC_4XX, make sure that CCHOME
-# has been set correctly above, and uncomment the appropriate
-# GCCHELPERDLL line.
-# The name of the dll can change, depending upon which vendor has supplied
-# your 4.x.x compiler, and upon the values of "x".
-# (The dll will be in your mingw/bin folder, so check there if you're
-# unsure about the correct name.)
-# Without these corrections, the op/taint.t test script will fail.
-#
-#GCC_4XX *= define
-#GCCHELPERDLL *= $(CCHOME)\bin\libgcc_s_sjlj-1.dll
-#GCCHELPERDLL *= $(CCHOME)\bin\libgcc_s_dw2-1.dll
-#GCCHELPERDLL *= $(CCHOME)\bin\libgcc_s_1.dll
-
-#
# uncomment this if you are using x86_64-w64-mingw32 cross-compiler
# ie if your gcc executable is called 'x86_64-w64-mingw32-gcc'
# instead of the usual 'gcc'.
@@ -227,11 +204,13 @@
#
.IF "$(GCCCROSS)" == "define"
-CCINCDIR *= $(CCHOME)\mingw\include
-CCLIBDIR *= $(CCHOME)\mingw\lib
+CCINCDIR *= $(CCHOME)\x86_64-w64-mingw32\include
+CCLIBDIR *= $(CCHOME)\x86_64-w64-mingw32\lib
+CCDLLDIR *= $(CCLIBDIR)
.ELSE
CCINCDIR *= $(CCHOME)\include
CCLIBDIR *= $(CCHOME)\lib
+CCDLLDIR *= $(CCHOME)\bin
.ENDIF
#
@@ -290,6 +269,7 @@
USE_IMP_SYS *= undef
USE_PERLIO *= undef
USE_LARGE_FILES *= undef
+USE_64_BIT_INT *= undef
.IF "$(USE_IMP_SYS)" == "define"
PERL_MALLOC = undef
@@ -323,7 +303,7 @@
BUILDOPT += -DPERL_IMPLICIT_SYS
.ENDIF
-.IMPORT .IGNORE : PROCESSOR_ARCHITECTURE PROCESSOR_ARCHITEW6432 WIN64
+.IMPORT .IGNORE : PROCESSOR_ARCHITECTURE PROCESSOR_ARCHITEW6432 WIN64 CCHOME
PROCESSOR_ARCHITECTURE *= x86
@@ -341,6 +321,10 @@
.ENDIF
.ENDIF
+.IF "$(WIN64)" == "define"
+USE_64_BIT_INT = define
+.ENDIF
+
# Treat 64-bit MSVC60 (doesn't really exist) as SDK2003SP1 because
# both link against MSVCRT.dll (which is part of Windows itself) and
# not against a compiler specific versioned runtime.
@@ -366,31 +350,20 @@
.ENDIF
.ENDIF
+.IF "$(USE_PERLIO)" == "define"
+BUILDOPT += -DUSE_PERLIO
+.ENDIF
+
.IF "$(USE_ITHREADS)" == "define"
ARCHNAME !:= $(ARCHNAME)-thread
.ENDIF
-# Visual C++ 98, .NET 2003, 2005/2008/2010 specific.
-# VC++ 6/7/8/9/10.x can load DLLs on demand. Makes the test suite run
-# in about 10% less time. (The free version of 7.x can't do this, but the free
-# versions of 8/9/10.x can.)
-.IF "$(CCTYPE)" == "MSVC60" || "$(CCTYPE)" == "MSVC70" || \
- "$(CCTYPE)" == "MSVC80" || "$(CCTYPE)" == "MSVC80FREE" || \
- "$(CCTYPE)" == "MSVC90" || "$(CCTYPE)" == "MSVC90FREE" || \
- "$(CCTYPE)" == "MSVC100" || "$(CCTYPE)" == "MSVC100FREE"
-DELAYLOAD *= -DELAYLOAD:ws2_32.dll delayimp.lib
+.IF "$(WIN64)" != "define"
+.IF "$(USE_64_BIT_INT)" == "define"
+ARCHNAME !:= $(ARCHNAME)-64int
.ENDIF
+.ENDIF
-# Visual C++ 2005 and 2008 (VC++ 8.x and 9.x) create manifest files for EXEs and
-# DLLs. These either need copying everywhere with the binaries, or else need
-# embedding in them otherwise MSVCR80.dll or MSVCR90.dll won't be found. For
-# simplicity, embed them if they exist (and delete them afterwards so that they
-# don't get installed too).
-EMBED_EXE_MANI = if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;1 && \
- if exist $@.manifest del $@.manifest
-EMBED_DLL_MANI = if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;2 && \
- if exist $@.manifest del $@.manifest
-
ARCHDIR = ..\lib\$(ARCHNAME)
COREDIR = ..\lib\CORE
AUTODIR = ..\lib\auto
@@ -416,66 +389,8 @@
.USESHELL :
-.IF "$(CCTYPE)" == "BORLAND"
+.IF "$(CCTYPE)" == "GCC"
-CC = bcc32
-.IF "$(BCCOLD)" != "define"
-LINK32 = ilink32
-.ELSE
-LINK32 = tlink32
-.ENDIF
-LIB32 = tlib /a /P128
-IMPLIB = implib -c
-RSC = brcc32
-
-#
-# Options
-#
-INCLUDES = -I$(COREDIR) -I.\include -I. -I.. -I"$(CCINCDIR)"
-#PCHFLAGS = -H -Hc -H=c:\temp\bcmoduls.pch
-DEFINES = -DWIN32
-LOCDEFS = -DPERLDLL -DPERL_CORE
-SUBSYS = console
-CXX_FLAG = -P
-
-LIBC = cw32mti.lib
-
-# same libs as MSVC, except Borland doesn't have oldnames.lib
-LIBFILES = \
- kernel32.lib user32.lib gdi32.lib winspool.lib \
- comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib \
- netapi32.lib uuid.lib ws2_32.lib mpr.lib winmm.lib \
- version.lib odbc32.lib odbccp32.lib comctl32.lib \
- import32.lib $(LIBC)
-
-.IF "$(CFG)" == "Debug"
-OPTIMIZE = -v -D_RTLDLL -DDEBUGGING
-LINK_DBG = -v
-.ELSE
-OPTIMIZE = -O2 -D_RTLDLL
-LINK_DBG =
-.ENDIF
-
-EXTRACFLAGS =
-CFLAGS = -w -g0 -tWM -tWD $(INCLUDES) $(DEFINES) $(LOCDEFS) \
- $(PCHFLAGS) $(OPTIMIZE)
-LINK_FLAGS = $(LINK_DBG) -x -L"$(INST_COREDIR)" -L"$(CCLIBDIR)" \
- -L"$(CCLIBDIR)\PSDK"
-OBJOUT_FLAG = -o
-EXEOUT_FLAG = -e
-LIBOUT_FLAG =
-.IF "$(BCCOLD)" != "define"
-LINK_FLAGS += -Gn
-DEFINES += -D_MT -D__USELOCALES__ -D_WIN32_WINNT=0x0410
-.END
-.IF "$(BCCVCL)" == "define"
-LIBC = cp32mti.lib vcl.lib vcl50.lib vclx50.lib vcle50.lib
-LINK_FLAGS += -L"$(CCLIBDIR)\Release"
-.END
-
-
-.ELIF "$(CCTYPE)" == "GCC"
-
.IF "$(GCCCROSS)" == "define"
ARCHPREFIX = x86_64-w64-mingw32-
.ENDIF
@@ -524,7 +439,7 @@
.ENDIF
EXTRACFLAGS =
-CFLAGS = $(INCLUDES) $(DEFINES) $(LOCDEFS) $(OPTIMIZE)
+CFLAGS = $(EXTRACFLAGS) $(INCLUDES) $(DEFINES) $(LOCDEFS) $(OPTIMIZE)
LINK_FLAGS = $(LINK_DBG) -L"$(INST_COREDIR)" -L"$(CCLIBDIR)"
OBJOUT_FLAG = -o
EXEOUT_FLAG = -o
@@ -534,6 +449,31 @@
.ELSE
+# All but the free version of VC++ 7.x can load DLLs on demand. Makes the test
+# suite run in about 10% less time.
+.IF "$(CCTYPE)" != "MSVC70FREE"
+DELAYLOAD = -DELAYLOAD:ws2_32.dll delayimp.lib
+.ENDIF
+
+# Visual C++ 2005 and 2008 (VC++ 8.x and 9.x) create manifest files for EXEs and
+# DLLs. These either need copying everywhere with the binaries, or else need
+# embedding in them otherwise MSVCR80.dll or MSVCR90.dll won't be found. For
+# simplicity, embed them if they exist (and delete them afterwards so that they
+# don't get installed too).
+EMBED_EXE_MANI = if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;1 && \
+ if exist $@.manifest del $@.manifest
+EMBED_DLL_MANI = if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;2 && \
+ if exist $@.manifest del $@.manifest
+
+# Most relevant compiler-specific options fall into two groups:
+# either pre-MSVC80 or MSVC80 onwards, so define a macro for this.
+.IF "$(CCTYPE)" == "MSVC60" || \
+ "$(CCTYPE)" == "MSVC70" || "$(CCTYPE)" == "MSVC70FREE"
+PREMSVC80 = define
+.ELSE
+PREMSVC80 = undef
+.ENDIF
+
CC = cl
LINK32 = link
LIB32 = $(LINK32) -lib
@@ -556,7 +496,8 @@
OPTIMIZE = -Od -MD -Zi -DDEBUGGING
LINK_DBG = -debug
.ELSE
-OPTIMIZE = -MD -Zi -DNDEBUG
+# -O1 yields smaller code, which turns out to be faster than -O2 on x86 and x64
+OPTIMIZE = -O1 -MD -Zi -DNDEBUG
# we enable debug symbols in release builds also
LINK_DBG = -debug -opt:ref,icf
# you may want to enable this if you want COFF symbols in the executables
@@ -567,12 +508,8 @@
#LINK_DBG = $(LINK_DBG) -debugtype:both
.IF "$(WIN64)" == "define"
# enable Whole Program Optimizations (WPO) and Link Time Code Generation (LTCG)
-OPTIMIZE += -Ox -GL
+OPTIMIZE += -GL
LINK_DBG += -ltcg
-.ELSE
-# -O1 yields smaller code, which turns out to be faster than -O2 on x86
-OPTIMIZE += -O1
-#OPTIMIZE += -O2
.ENDIF
.ENDIF
@@ -581,11 +518,9 @@
OPTIMIZE += -fp:precise
.ENDIF
-# For now, silence VC++ 8/9/10.x's warnings about "unsafe" CRT functions
+# For now, silence warnings from VC++ 8.x onwards about "unsafe" CRT functions
# and POSIX CRT function names being deprecated.
-.IF "$(CCTYPE)" == "MSVC80" || "$(CCTYPE)" == "MSVC80FREE" || \
- "$(CCTYPE)" == "MSVC90" || "$(CCTYPE)" == "MSVC90FREE" || \
- "$(CCTYPE)" == "MSVC100" || "$(CCTYPE)" == "MSVC100FREE"
+.IF "$(PREMSVC80)" == "undef"
DEFINES += -D_CRT_SECURE_NO_DEPRECATE -D_CRT_NONSTDC_NO_DEPRECATE
.ENDIF
@@ -598,8 +533,7 @@
# Perl itself with e.g. VC6 but later installs an XS module using VC8
# the time_t types will still be compatible.
.IF "$(WIN64)" == "undef"
-.IF "$(CCTYPE)" == "MSVC60" || \
- "$(CCTYPE)" == "MSVC70" || "$(CCTYPE)" == "MSVC70FREE"
+.IF "$(PREMSVC80)" == "define"
BUILDOPT += -D_USE_32BIT_TIME_T
.ENDIF
.ENDIF
@@ -635,9 +569,7 @@
CFLAGS_O = $(CFLAGS) $(BUILDOPT)
-.IF "$(CCTYPE)" == "MSVC80" || "$(CCTYPE)" == "MSVC80FREE" || \
- "$(CCTYPE)" == "MSVC90" || "$(CCTYPE)" == "MSVC90FREE" || \
- "$(CCTYPE)" == "MSVC100" || "$(CCTYPE)" == "MSVC100FREE"
+.IF "$(PREMSVC80)" == "undef"
LINK_FLAGS += "/manifestdependency:type='Win32' name='Microsoft.Windows.Common-Controls' version='6.0.0.0' processorArchitecture='*' publicKeyToken='6595b64144ccf1df' language='*'"
.ELSE
RSC_FLAGS = -DINCLUDE_MANIFEST
@@ -686,10 +618,7 @@
$(NOOP)
$(o).dll:
-.IF "$(CCTYPE)" == "BORLAND"
- $(LINK32) -Tpd -ap $(BLINK_FLAGS) c0d32$(o) $<,$@,,$(LIBFILES),$(*B).def
- $(IMPLIB) $(*B).lib $@
-.ELIF "$(CCTYPE)" == "GCC"
+.IF "$(CCTYPE)" == "GCC"
$(LINK32) -o $@ $(BLINK_FLAGS) $< $(LIBFILES)
$(IMPLIB) --input-def $(*B).def --output-lib $(*B).a $@
.ELSE
@@ -726,6 +655,7 @@
# Unicode data files generated by mktables
UNIDATAFILES = ..\lib\unicore\Decomposition.pl ..\lib\unicore\TestProp.pl \
..\lib\unicore\CombiningClass.pl ..\lib\unicore\Name.pl \
+ ..\lib\unicore\UCD.pl ..\lib\unicore\Name.pm \
..\lib\unicore\Heavy.pl ..\lib\unicore\mktables.lst
# Directories of Unicode data files generated by mktables
@@ -745,12 +675,10 @@
PL2BAT = bin\pl2bat.pl
-GLOBBAT = bin\perlglob.bat
UTILS = \
..\utils\h2ph \
..\utils\splain \
- ..\utils\dprofpp \
..\utils\perlbug \
..\utils\pl2pm \
..\utils\c2ph \
@@ -765,10 +693,12 @@
..\utils\corelist \
..\utils\cpan \
..\utils\xsubpp \
+ ..\utils\pod2html \
..\utils\prove \
..\utils\ptar \
..\utils\ptardiff \
..\utils\ptargrep \
+ ..\utils\zipdetails \
..\utils\cpanp-run-perl \
..\utils\cpanp \
..\utils\cpan2dist \
@@ -784,45 +714,29 @@
bin\perlglob.pl \
bin\search.pl
-.IF "$(CCTYPE)" == "BORLAND"
+.IF "$(CCTYPE)" == "GCC"
-CFGSH_TMPL = config.bc
-CFGH_TMPL = config_H.bc
-
-.ELIF "$(CCTYPE)" == "GCC"
-
-.IF "$(WIN64)" == "define"
-.IF "$(GCCCROSS)" == "define"
-CFGSH_TMPL = config.gc64
-CFGH_TMPL = config_H.gc64
-.ELSE
-CFGSH_TMPL = config.gc64nox
-CFGH_TMPL = config_H.gc64nox
-.ENDIF
-.ELSE
CFGSH_TMPL = config.gc
CFGH_TMPL = config_H.gc
-.ENDIF
-PERLIMPLIB = ..\libperl514$(a)
-PERLSTATICLIB = ..\libperl514s$(a)
+PERLIMPLIB = ..\libperl518$(a)
+PERLSTATICLIB = ..\libperl518s$(a)
+INT64 = long long
+INT64f = ll
.ELSE
-.IF "$(WIN64)" == "define"
-CFGSH_TMPL = config.vc64
-CFGH_TMPL = config_H.vc64
-.ELSE
CFGSH_TMPL = config.vc
CFGH_TMPL = config_H.vc
-.ENDIF
+INT64 = __int64
+INT64f = I64
.ENDIF
# makedef.pl must be updated if this changes, and this should normally
# only change when there is an incompatible revision of the public API.
-PERLIMPLIB *= ..\perl514$(a)
-PERLSTATICLIB *= ..\perl514s$(a)
-PERLDLL = ..\perl514.dll
+PERLIMPLIB *= ..\perl518$(a)
+PERLSTATICLIB *= ..\perl518s$(a)
+PERLDLL = ..\perl518.dll
XCOPY = xcopy /f /r /i /d /y
RCOPY = xcopy /f /r /i /e /d /y
@@ -937,6 +851,8 @@
UUDMAP_H = ..\uudmap.h
BITCOUNT_H = ..\bitcount.h
+MG_DATA_H = ..\mg_data.h
+GENERATED_HEADERS = $(UUDMAP_H) $(BITCOUNT_H) $(MG_DATA_H)
MICROCORE_OBJ = $(MICROCORE_SRC:db:+$(o))
CORE_OBJ = $(MICROCORE_OBJ) $(EXTRACORE_SRC:db:+$(o))
@@ -977,7 +893,6 @@
# trying to fit them all on the command line)
# -- BKS 10-17-1999
CFG_VARS = \
- INST_DRV=$(INST_DRV) ~ \
INST_TOP=$(INST_TOP) ~ \
INST_VER=$(INST_VER) ~ \
INST_ARCH=$(INST_ARCH) ~ \
@@ -1002,34 +917,14 @@
useithreads=$(USE_ITHREADS) ~ \
usemultiplicity=$(USE_MULTI) ~ \
useperlio=$(USE_PERLIO) ~ \
+ use64bitint=$(USE_64_BIT_INT) ~ \
uselargefiles=$(USE_LARGE_FILES) ~ \
usesitecustomize=$(USE_SITECUST) ~ \
LINK_FLAGS=$(LINK_FLAGS) ~ \
- optimize=$(OPTIMIZE)
+ optimize=$(OPTIMIZE) ~ \
+ ARCHPREFIX=$(ARCHPREFIX) ~ \
+ WIN64=$(WIN64)
-#
-# set up targets varying between Win95 and WinNT builds
-#
-
-.IF "$(IS_WIN95)" == "define"
-MK2 = .\makefile.95
-RIGHTMAKE = __switch_makefiles
-.ELSE
-MK2 = __not_needed
-RIGHTMAKE =
-.ENDIF
-
-.IMPORT .IGNORE : SystemRoot windir
-
-# Don't just .IMPORT OS from the environment because dmake sets OS itself.
-ENV_OS=$(subst,OS=, $(shell @set OS))
-
-.IF "$(ENV_OS)" == "Windows_NT"
-ODBCCP32_DLL = $(SystemRoot)\system32\odbccp32.dll
-.ELSE
-ODBCCP32_DLL = $(windir)\system\odbccp32.dll
-.ENDIF
-
ICWD = -I..\dist\Cwd -I..\dist\Cwd\lib
#
@@ -1036,8 +931,8 @@
# Top targets
#
-all : CHECKDMAKE .\config.h ..\git_version.h $(GLOBEXE) $(MINIPERL) $(MK2) \
- $(RIGHTMAKE) $(MINIMOD) $(CONFIGPM) $(UNIDATAFILES) MakePPPort \
+all : CHECKDMAKE .\config.h ..\git_version.h $(GLOBEXE) $(MINIPERL) \
+ $(MINIMOD) $(CONFIGPM) $(UNIDATAFILES) MakePPPort \
$(PERLEXE) $(X2P) Extensions Extensions_nonxs $(PERLSTATIC)
regnodes : ..\regnodes.h
@@ -1046,8 +941,8 @@
..\regexec$(o) : ..\regnodes.h ..\regcharclass.h
-reonly : regnodes .\config.h ..\git_version.h $(GLOBEXE) $(MINIPERL) $(MK2) \
- $(RIGHTMAKE) $(MINIMOD) $(CONFIGPM) $(UNIDATAFILES) $(PERLEXE) \
+reonly : regnodes .\config.h ..\git_version.h $(GLOBEXE) $(MINIPERL) \
+ $(MINIMOD) $(CONFIGPM) $(UNIDATAFILES) $(PERLEXE) \
$(X2P) Extensions_reonly
static: $(PERLEXESTATIC)
@@ -1054,52 +949,6 @@
#----------------------------------------------------------------
-#-------------------- BEGIN Win95 SPECIFIC ----------------------
-
-# this target is a jump-off point for Win95
-# 1. it switches to the Win95-specific makefile if it exists
-# (__do_switch_makefiles)
-# 2. it prints a message when the Win95-specific one finishes (__done)
-# 3. it then kills this makefile by trying to make __no_such_target
-
-__switch_makefiles: __do_switch_makefiles __done __no_such_target
-
-__do_switch_makefiles:
-.IF "$(NOTFIRST)" != "true"
- if exist $(MK2) $(MAKE:s/-S//) -f $(MK2) $(MAKETARGETS) NOTFIRST=true
-.ELSE
- $(NOOP)
-.ENDIF
-
-.IF "$(NOTFIRST)" != "true"
-__done:
- @echo Build process complete. Ignore any errors after this message.
- @echo Run "dmake test" to test and "dmake install" to install
-
-.ELSE
-# dummy targets for Win95-specific makefile
-
-__done:
- $(NOOP)
-
-__no_such_target:
- $(NOOP)
-
-.ENDIF
-
-# This target is used to generate the new makefile (.\makefile.95) for Win95
-
-.\makefile.95: .\makefile.mk
- $(MINIPERL) genmk95.pl makefile.mk $(MK2)
-
-#--------------------- END Win95 SPECIFIC ---------------------
-
-# a blank target for when builds don't need to do certain things
-# this target added for Win95 port but used to keep the WinNT port able to
-# use this file
-__not_needed:
- $(NOOP)
-
CHECKDMAKE :
.IF "$(NEWDMAKE)" == "define"
$(NOOP)
@@ -1110,11 +959,7 @@
.ENDIF
$(GLOBEXE) : perlglob$(o)
-.IF "$(CCTYPE)" == "BORLAND"
- $(CC) -c -w -v -tWM -I"$(CCINCDIR)" perlglob.c
- $(LINK32) -Tpe -ap $(BLINK_FLAGS) c0x32$(o) perlglob$(o) \
- "$(CCLIBDIR)\32BIT\wildargs$(o)",$@,,import32.lib cw32mt.lib,
-.ELIF "$(CCTYPE)" == "GCC"
+.IF "$(CCTYPE)" == "GCC"
$(LINK32) $(BLINK_FLAGS) -mconsole -o $@ perlglob$(o) $(LIBFILES)
.ELSE
$(LINK32) $(BLINK_FLAGS) $(LIBFILES) -out:$@ -subsystem:$(SUBSYS) \
@@ -1127,9 +972,82 @@
config.w32 : $(CFGSH_TMPL)
copy $(CFGSH_TMPL) config.w32
+#
+# Copy the template config.h and set configurables at the end of it
+# as per the options chosen and compiler used.
+# Note: This config.h is only used to build miniperl.exe anyway, but
+# it's as well to have its options correct to be sure that it builds
+# and so that it's "-V" options are correct for use by makedef.pl. The
+# real config.h used to build perl.exe is generated from the top-level
+# config_h.SH by config_h.PL (run by miniperl.exe).
+#
.\config.h : $(CFGH_TMPL) $(CORE_NOCFG_H)
-del /f config.h
copy $(CFGH_TMPL) config.h
+ @echo.>>$@
+ @echo #ifndef _config_h_footer_>>$@
+ @echo #define _config_h_footer_>>$@
+ @echo #undef PTRSIZE>>$@
+ @echo #undef SSize_t>>$@
+ @echo #undef HAS_ATOLL>>$@
+ @echo #undef HAS_STRTOLL>>$@
+ @echo #undef HAS_STRTOULL>>$@
+ @echo #undef IVTYPE>>$@
+ @echo #undef UVTYPE>>$@
+ @echo #undef IVSIZE>>$@
+ @echo #undef UVSIZE>>$@
+ @echo #undef NV_PRESERVES_UV>>$@
+ @echo #undef NV_PRESERVES_UV_BITS>>$@
+ @echo #undef IVdf>>$@
+ @echo #undef UVuf>>$@
+ @echo #undef UVof>>$@
+ @echo #undef UVxf>>$@
+ @echo #undef UVXf>>$@
+ @echo #undef USE_64_BIT_INT>>$@
+ @echo #undef Size_t_size>>$@
+.IF "$(WIN64)"=="define"
+ @echo #define PTRSIZE ^8>>$@
+ @echo #define SSize_t $(INT64)>>$@
+ @echo #define HAS_ATOLL>>$@
+ @echo #define HAS_STRTOLL>>$@
+ @echo #define HAS_STRTOULL>>$@
+ @echo #define Size_t_size ^8>>$@
+.ELSE
+ @echo #define PTRSIZE ^4>>$@
+ @echo #define SSize_t int>>$@
+ @echo #undef HAS_ATOLL>>$@
+ @echo #undef HAS_STRTOLL>>$@
+ @echo #undef HAS_STRTOULL>>$@
+ @echo #define Size_t_size ^4>>$@
+.ENDIF
+.IF "$(USE_64_BIT_INT)"=="define"
+ @echo #define IVTYPE $(INT64)>>$@
+ @echo #define UVTYPE unsigned $(INT64)>>$@
+ @echo #define IVSIZE ^8>>$@
+ @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 USE_64_BIT_INT>>$@
+.ELSE
+ @echo #define IVTYPE long>>$@
+ @echo #define UVTYPE unsigned long>>$@
+ @echo #define IVSIZE ^4>>$@
+ @echo #define UVSIZE ^4>>$@
+ @echo #define NV_PRESERVES_UV>>$@
+ @echo #define NV_PRESERVES_UV_BITS 32>>$@
+ @echo #define IVdf "ld">>$@
+ @echo #define UVuf "lu">>$@
+ @echo #define UVof "lo">>$@
+ @echo #define UVxf "lx">>$@
+ @echo #define UVXf "lX">>$@
+ @echo #undef USE_64_BIT_INT>>$@
+.ENDIF
+ @echo #endif>>$@
..\git_version.h : $(MINIPERL) ..\make_patchnum.pl
cd .. && miniperl -Ilib make_patchnum.pl
@@ -1141,20 +1059,16 @@
$(MINIPERL) -I..\lib config_sh.PL --cfgsh-option-file \
$(mktmp $(CFG_VARS)) config.w32 > ..\config.sh
-# this target is for when changes to the main config.sh happen.
-# edit config.gc, then make perl using GCC in a minimal configuration (i.e.
-# with MULTI, ITHREADS, IMP_SYS, LARGE_FILES, PERLIO and CRYPT off), then make
+# This target is for when changes to the main config.sh happen.
+# Edit config.gc, then make perl using GCC in a minimal configuration (i.e.
+# with MULTI, ITHREADS, IMP_SYS, LARGE_FILES and PERLIO off), then make
# this target to regenerate config_H.gc.
-# unfortunately, some further manual editing is also then required to restore all
-# the special _MSC_VER handling that is otherwise lost.
-# repeat for config.bc and config_H.bc (using BORLAND), except that there is no
-# _MSC_VER stuff in that case.
regen_config_h:
$(MINIPERL) -I..\lib config_sh.PL --cfgsh-option-file $(mktmp $(CFG_VARS)) \
$(CFGSH_TMPL) > ..\config.sh
$(MINIPERL) -I..\lib ..\configpm --chdir=..
-del /f $(CFGH_TMPL)
- -$(MINIPERL) -I..\lib $(ICWD) config_h.PL "INST_VER=$(INST_VER)"
+ -$(MINIPERL) -I..\lib $(ICWD) config_h.PL "ARCHPREFIX=$(ARCHPREFIX)"
rename config.h $(CFGH_TMPL)
$(CONFIGPM) : $(MINIPERL) ..\config.sh config_h.PL ..\minimod.pl
@@ -1163,7 +1077,7 @@
$(XCOPY) ..\*.h $(COREDIR)\*.*
$(XCOPY) *.h $(COREDIR)\*.*
$(RCOPY) include $(COREDIR)\*.*
- $(MINIPERL) -I..\lib $(ICWD) config_h.PL "INST_VER=$(INST_VER)" \
+ $(MINIPERL) -I..\lib $(ICWD) config_h.PL "ARCHPREFIX=$(ARCHPREFIX)" \
|| $(MAKE) $(MAKEMACROS) $(CONFIGPM) $(MAKEFILE)
..\lib\buildcustomize.pl: $(MINIPERL) ..\write_buildcustomize.pl
@@ -1171,17 +1085,12 @@
$(MINIPERL) : $(MINIDIR) $(MINI_OBJ) $(CRTIPMLIBS)
-.IF "$(CCTYPE)" == "BORLAND"
- if not exist $(CCLIBDIR)\PSDK\odbccp32.lib \
- cd $(CCLIBDIR)\PSDK && implib odbccp32.lib $(ODBCCP32_DLL)
- $(LINK32) -Tpe -ap $(BLINK_FLAGS) \
- @$(mktmp c0x32$(o) $(MINI_OBJ),$@,,$(LIBFILES),)
-.ELIF "$(CCTYPE)" == "GCC"
+.IF "$(CCTYPE)" == "GCC"
$(LINK32) -v -mconsole -o $@ $(BLINK_FLAGS) \
$(mktmp $(LKPRE) $(MINI_OBJ) $(LIBFILES) $(LKPOST))
.ELSE
$(LINK32) -subsystem:console -out:$@ $(BLINK_FLAGS) \
- @$(mktmp $(LIBFILES) $(MINI_OBJ))
+ @$(mktmp $(DELAYLOAD) $(LIBFILES) $(MINI_OBJ))
$(EMBED_EXE_MANI)
.ENDIF
@@ -1192,7 +1101,7 @@
$(CC) -c $(CFLAGS) -DPERL_EXTERNAL_GLOB -DPERL_IS_MINIPERL $(OBJOUT_FLAG)$@ ..\$(*B).c
$(MINIWIN32_OBJ) : $(CORE_NOCFG_H)
- $(CC) -c $(CFLAGS) $(OBJOUT_FLAG)$@ $(*B).c
+ $(CC) -c $(CFLAGS) -DPERL_IS_MINIPERL $(OBJOUT_FLAG)$@ $(*B).c
# -DPERL_IMPLICIT_SYS needs C++ for perllib.c
# rules wrapped in .IFs break Win9X build (we end up with unbalanced []s unless
@@ -1219,18 +1128,13 @@
$(X2P_OBJ) : $(CORE_H)
-perldll.def : $(MINIPERL) $(CONFIGPM) ..\global.sym ..\makedef.pl create_perllibst_h.pl
+perldll.def : $(MINIPERL) $(CONFIGPM) ..\embed.fnc ..\makedef.pl create_perllibst_h.pl
$(MINIPERL) -I..\lib create_perllibst_h.pl
$(MINIPERL) -I..\lib -w ..\makedef.pl PLATFORM=win32 $(OPTIMIZE) $(DEFINES) \
- $(BUILDOPT) CCTYPE=$(CCTYPE) > perldll.def
+ $(BUILDOPT) CCTYPE=$(CCTYPE) TARG_DIR=..\ > perldll.def
$(PERLDLL): perldll.def $(PERLDLL_OBJ) $(PERLDLL_RES) Extensions_static
-.IF "$(CCTYPE)" == "BORLAND"
- $(LINK32) -Tpd -ap $(BLINK_FLAGS) \
- @$(mktmp c0d32$(o) $(PERLDLL_OBJ),$@,, \
- $(shell @type Extensions_static) $(LIBFILES),perldll.def)
- $(IMPLIB) $*.lib $@
-.ELIF "$(CCTYPE)" == "GCC"
+.IF "$(CCTYPE)" == "GCC"
$(LINK32) -mdll -o $@ -Wl,--base-file -Wl,perl.base $(BLINK_FLAGS) \
$(mktmp $(LKPRE) $(PERLDLL_OBJ) \
$(shell @type Extensions_static) \
@@ -1254,11 +1158,7 @@
$(XCOPY) $(PERLIMPLIB) $(COREDIR)
$(PERLSTATICLIB): Extensions_static
-.IF "$(CCTYPE)" == "BORLAND"
- $(LIB32) $(LIB_FLAGS) $@ \
- @$(mktmp $(shell @type Extensions_static) \
- $(PERLDLL_OBJ))
-.ELIF "$(CCTYPE)" == "GCC"
+.IF "$(CCTYPE)" == "GCC"
# XXX: It would be nice if MinGW's ar accepted a temporary file, but this
# doesn't seem to work:
# $(LIB32) $(LIB_FLAGS) $@ \
@@ -1296,10 +1196,7 @@
$(X2P) : $(MINIPERL) $(X2P_OBJ) Extensions
$(MINIPERL) -I..\lib ..\x2p\find2perl.PL
$(MINIPERL) -I..\lib ..\x2p\s2p.PL
-.IF "$(CCTYPE)" == "BORLAND"
- $(LINK32) -Tpe -ap $(BLINK_FLAGS) \
- @$(mktmp c0x32$(o) $(X2P_OBJ),$@,,$(LIBFILES),)
-.ELIF "$(CCTYPE)" == "GCC"
+.IF "$(CCTYPE)" == "GCC"
$(LINK32) -v -o $@ $(BLINK_FLAGS) \
$(mktmp $(LKPRE) $(X2P_OBJ) $(LIBFILES) $(LKPOST))
.ELSE
@@ -1308,18 +1205,17 @@
$(EMBED_EXE_MANI)
.ENDIF
-$(MINIDIR)\globals$(o) : $(UUDMAP_H) $(BITCOUNT_H)
+$(MINIDIR)\globals$(o) : $(GENERATED_HEADERS)
-$(UUDMAP_H) : $(BITCOUNT_H)
+$(UUDMAP_H) $(MG_DATA_H) : $(BITCOUNT_H)
$(BITCOUNT_H) : $(GENUUDMAP)
- $(GENUUDMAP) $(UUDMAP_H) $(BITCOUNT_H)
+ $(GENUUDMAP) $(GENERATED_HEADERS)
+$(GENUUDMAP_OBJ) : ..\mg_raw.h
+
$(GENUUDMAP) : $(GENUUDMAP_OBJ)
-.IF "$(CCTYPE)" == "BORLAND"
- $(LINK32) -Tpe -ap $(BLINK_FLAGS) \
- @$(mktmp c0x32$(o) $(GENUUDMAP_OBJ),$@,,$(LIBFILES),)
-.ELIF "$(CCTYPE)" == "GCC"
+.IF "$(CCTYPE)" == "GCC"
$(LINK32) -v -o $@ $(BLINK_FLAGS) \
$(mktmp $(LKPRE) $(GENUUDMAP_OBJ) $(LIBFILES) $(LKPOST))
.ELSE
@@ -1341,11 +1237,7 @@
$(CC) $(CFLAGS_O) $(OBJOUT_FLAG)$@ -c perlmainst.c
$(PERLEXE): $(PERLDLL) $(CONFIGPM) $(PERLEXE_OBJ) $(PERLEXE_RES)
-.IF "$(CCTYPE)" == "BORLAND"
- $(LINK32) -Tpe -ap $(BLINK_FLAGS) \
- @$(mktmp c0x32$(o) $(PERLEXE_OBJ),$@,, \
- $(PERLIMPLIB) $(LIBFILES),,$(PERLEXE_RES))
-.ELIF "$(CCTYPE)" == "GCC"
+.IF "$(CCTYPE)" == "GCC"
$(LINK32) -mconsole -o $@ $(BLINK_FLAGS) \
$(PERLEXE_OBJ) $(PERLEXE_RES) $(PERLIMPLIB) $(LIBFILES)
.ELSE
@@ -1357,12 +1249,7 @@
$(MINIPERL) -I..\lib bin\exetype.pl $(WPERLEXE) WINDOWS
$(PERLEXESTATIC): $(PERLSTATICLIB) $(CONFIGPM) $(PERLEXEST_OBJ) $(PERLEXE_RES)
-.IF "$(CCTYPE)" == "BORLAND"
- $(LINK32) -Tpe -ap $(BLINK_FLAGS) \
- @$(mktmp c0x32$(o) $(PERLEXEST_OBJ),$@,, \
- $(shell @type Extensions_static) $(PERLSTATICLIB) $(LIBFILES),, \
- $(PERLEXE_RES))
-.ELIF "$(CCTYPE)" == "GCC"
+.IF "$(CCTYPE)" == "GCC"
$(LINK32) -mconsole -o $@ $(BLINK_FLAGS) \
$(mktmp $(LKPRE) $(shell @type Extensions_static) \
$(PERLSTATICLIB) $(LIBFILES) $(PERLEXEST_OBJ) \
@@ -1393,7 +1280,7 @@
$(MINIPERL) -I..\lib ..\make_ext.pl "MAKE=$(MAKE)" --dir=$(CPANDIR) --dir=$(DISTDIR) --dir=$(EXTDIR) --static
$(MINIPERL) -I..\lib list_static_libs.pl > Extensions_static
-Extensions_nonxs : ..\make_ext.pl ..\lib\buildcustomize.pl $(PERLDEP) $(CONFIGPM)
+Extensions_nonxs : ..\make_ext.pl ..\lib\buildcustomize.pl $(PERLDEP) $(CONFIGPM) ..\pod\perlfunc.pod
$(XCOPY) ..\*.h $(COREDIR)\*.*
$(MINIPERL) -I..\lib ..\make_ext.pl "MAKE=$(MAKE)" --dir=$(CPANDIR) --dir=$(DISTDIR) --dir=$(EXTDIR) --nonxs
@@ -1412,8 +1299,8 @@
doc: $(PERLEXE) ..\pod\perltoc.pod
$(PERLEXE) -I..\lib ..\installhtml --podroot=.. --htmldir=$(HTMLDIR) \
- --podpath=pod:lib:ext:utils --htmlroot="file://$(INST_HTML:s,:,|,)"\
- --libpod=perlfunc:perlguts:perlvar:perlrun:perlop --recurse
+ --podpath=pod:lib:utils --htmlroot="file://$(INST_HTML:s,:,|,)"\
+ --recurse
# Note that this next section is parsed (and regenerated) by pod/buildtoc
# so please check that script before making structural changes here
@@ -1421,7 +1308,6 @@
cd ..\utils && $(MAKE) PERL=$(MINIPERL)
copy ..\README.aix ..\pod\perlaix.pod
copy ..\README.amiga ..\pod\perlamiga.pod
- copy ..\README.beos ..\pod\perlbeos.pod
copy ..\README.bs2000 ..\pod\perlbs2000.pod
copy ..\README.ce ..\pod\perlce.pod
copy ..\README.cn ..\pod\perlcn.pod
@@ -1428,7 +1314,6 @@
copy ..\README.cygwin ..\pod\perlcygwin.pod
copy ..\README.dgux ..\pod\perldgux.pod
copy ..\README.dos ..\pod\perldos.pod
- copy ..\README.epoc ..\pod\perlepoc.pod
copy ..\README.freebsd ..\pod\perlfreebsd.pod
copy ..\README.haiku ..\pod\perlhaiku.pod
copy ..\README.hpux ..\pod\perlhpux.pod
@@ -1439,7 +1324,6 @@
copy ..\README.linux ..\pod\perllinux.pod
copy ..\README.macos ..\pod\perlmacos.pod
copy ..\README.macosx ..\pod\perlmacosx.pod
- copy ..\README.mpeix ..\pod\perlmpeix.pod
copy ..\README.netware ..\pod\perlnetware.pod
copy ..\README.openbsd ..\pod\perlopenbsd.pod
copy ..\README.os2 ..\pod\perlos2.pod
@@ -1452,17 +1336,15 @@
copy ..\README.symbian ..\pod\perlsymbian.pod
copy ..\README.tru64 ..\pod\perltru64.pod
copy ..\README.tw ..\pod\perltw.pod
- copy ..\README.uts ..\pod\perluts.pod
- copy ..\README.vmesa ..\pod\perlvmesa.pod
copy ..\README.vos ..\pod\perlvos.pod
copy ..\README.win32 ..\pod\perlwin32.pod
- copy ..\pod\perldelta.pod ..\pod\perl5140delta.pod
+ copy ..\pod\perldelta.pod ..\pod\perl5181delta.pod
$(PERLEXE) $(PL2BAT) $(UTILS)
$(PERLEXE) $(ICWD) ..\autodoc.pl ..
$(PERLEXE) $(ICWD) ..\pod\perlmodlib.pl -q
..\pod\perltoc.pod: $(PERLEXE) Extensions Extensions_nonxs
- $(PERLEXE) -f ..\pod\buildtoc --build-toc -q
+ $(PERLEXE) -f ..\pod\buildtoc -q
# Note that the pod cleanup in this next section is parsed (and regenerated
# by pod/buildtoc so please check that script before making changes here
@@ -1547,21 +1429,20 @@
-if exist $(LIBDIR)\Unicode\Collate rmdir /s /q $(LIBDIR)\Unicode\Collate
-if exist $(LIBDIR)\XS rmdir /s /q $(LIBDIR)\XS
-if exist $(LIBDIR)\Win32API rmdir /s /q $(LIBDIR)\Win32API
- -cd $(PODDIR) && del /f *.html *.bat \
- perl5140delta.pod perlaix.pod perlamiga.pod perlapi.pod \
- perlbeos.pod perlbs2000.pod perlce.pod perlcn.pod \
- perlcygwin.pod perldgux.pod perldos.pod perlepoc.pod \
- perlfreebsd.pod perlhaiku.pod perlhpux.pod perlhurd.pod \
- perlintern.pod perlirix.pod perljp.pod perlko.pod perllinux.pod \
- perlmacos.pod perlmacosx.pod perlmodlib.pod perlmpeix.pod \
- perlnetware.pod perlopenbsd.pod perlos2.pod perlos390.pod \
- perlos400.pod perlplan9.pod perlqnx.pod perlriscos.pod \
- perlsolaris.pod perlsymbian.pod perltoc.pod perltru64.pod \
- perltw.pod perluniprops.pod perluts.pod perlvmesa.pod \
+ -cd $(PODDIR) && del /f *.html *.bat roffitall \
+ perl5181delta.pod perlaix.pod perlamiga.pod perlapi.pod \
+ perlbs2000.pod perlce.pod perlcn.pod perlcygwin.pod \
+ perldgux.pod perldos.pod perlfreebsd.pod perlhaiku.pod \
+ perlhpux.pod perlhurd.pod perlintern.pod perlirix.pod \
+ perljp.pod perlko.pod perllinux.pod perlmacos.pod \
+ perlmacosx.pod perlmodlib.pod perlnetware.pod perlopenbsd.pod \
+ perlos2.pod perlos390.pod perlos400.pod perlplan9.pod \
+ perlqnx.pod perlriscos.pod perlsolaris.pod perlsymbian.pod \
+ perltoc.pod perltru64.pod perltw.pod perluniprops.pod \
perlvos.pod perlwin32.pod
-cd ..\utils && del /f h2ph splain perlbug pl2pm c2ph pstruct h2xs \
- perldoc perlivp dprofpp libnetcfg enc2xs piconv cpan *.bat \
- xsubpp instmodsh json_pp prove ptar ptardiff ptargrep cpanp-run-perl cpanp cpan2dist shasum corelist config_data
+ perldoc perlivp libnetcfg enc2xs piconv cpan *.bat \
+ xsubpp pod2html instmodsh json_pp prove ptar ptardiff ptargrep cpanp-run-perl cpanp cpan2dist shasum corelist config_data zipdetails
-cd ..\x2p && del /f find2perl s2p psed *.bat
-del /f ..\config.sh perlmain.c dlutils.c config.h.new \
perlmainst.c
@@ -1577,13 +1458,12 @@
-if exist $(AUTODIR) rmdir /s /q $(AUTODIR)
-if exist $(COREDIR) rmdir /s /q $(COREDIR)
-if exist pod2htmd.tmp del pod2htmd.tmp
- -if exist pod2htmi.tmp del pod2htmi.tmp
-if exist $(HTMLDIR) rmdir /s /q $(HTMLDIR)
-del /f ..\t\test_state
install : all installbare installhtml
-installbare : $(RIGHTMAKE) utils ..\pod\perltoc.pod
+installbare : utils ..\pod\perltoc.pod
$(PERLEXE) ..\installperl
if exist $(WPERLEXE) $(XCOPY) $(WPERLEXE) $(INST_BIN)\*.*
if exist $(PERLEXESTATIC) $(XCOPY) $(PERLEXESTATIC) $(INST_BIN)\*.*
@@ -1606,33 +1486,35 @@
$(XCOPY) $(MINIPERL) ..\t\$(NULL)
if exist ..\t\perl.exe del /f ..\t\perl.exe
rename ..\t\miniperl.exe perl.exe
-.IF "$(CCTYPE)" == "BORLAND"
- $(XCOPY) $(GLOBBAT) ..\t\$(NULL)
-.ELSE
$(XCOPY) $(GLOBEXE) ..\t\$(NULL)
-.ENDIF
attrib -r ..\t\*.*
cd ..\t && \
- $(MINIPERL) -I..\lib harness base/*.t comp/*.t cmd/*.t io/*.t op/*.t pragma/*.t
+ $(MINIPERL) -I..\lib harness base/*.t comp/*.t cmd/*.t io/*.t opbasic/*.t op/*.t pragma/*.t
test-prep : all utils ..\pod\perltoc.pod
$(XCOPY) $(PERLEXE) ..\t\$(NULL)
$(XCOPY) $(PERLDLL) ..\t\$(NULL)
-.IF "$(CCTYPE)" == "BORLAND"
- $(XCOPY) $(GLOBBAT) ..\t\$(NULL)
-.ELSE
$(XCOPY) $(GLOBEXE) ..\t\$(NULL)
-.ENDIF
.IF "$(CCTYPE)" == "GCC"
-.IF "$(GCC_4XX)" == "define"
- $(XCOPY) $(GCCHELPERDLL) ..\t\$(NULL)
+# If building with gcc versions 4.x.x or greater, then
+# the GCC helper DLL will also need copied to the test directory.
+# The name of the dll can change, depending upon which vendor has supplied
+# your compiler, and upon the values of "x".
+# libstdc++-6.dll is copied if it exists as it, too, may then be needed.
+# Without this copying, the op/taint.t test script will fail.
+ if exist $(CCDLLDIR)\libgcc_s_sjlj-1.dll $(XCOPY) $(CCDLLDIR)\libgcc_s_sjlj-1.dll ..\t\$(NULL)
+ if exist $(CCDLLDIR)\libgcc_s_dw2-1.dll $(XCOPY) $(CCDLLDIR)\libgcc_s_dw2-1.dll ..\t\$(NULL)
+ if exist $(CCDLLDIR)\libstdc++-6.dll $(XCOPY) $(CCDLLDIR)\libstdc++-6.dll ..\t\$(NULL)
.ENDIF
-.ENDIF
-test : $(RIGHTMAKE) test-prep
+test : test-prep
set PERL_STATIC_EXT=$(STATIC_EXT) && \
cd ..\t && $(PERLEXE) -I..\lib harness $(TEST_SWITCHES) $(TEST_FILES)
+test_porting : test-prep
+ set PERL_STATIC_EXT=$(STATIC_EXT) && \
+ cd ..\t && $(PERLEXE) -I..\lib harness $(TEST_SWITCHES) porting\*.t ..\lib\diagnostics.t
+
test-reonly : reonly utils
$(XCOPY) $(PERLEXE) ..\t\$(NULL)
$(XCOPY) $(PERLDLL) ..\t\$(NULL)
@@ -1649,14 +1531,10 @@
set PERL_SKIP_TTY_TEST=1 && \
cd ..\t && $(PERLEXE) -I.\lib harness $(TEST_SWITCHES) $(TEST_FILES)
-_test : $(RIGHTMAKE)
+_test :
$(XCOPY) $(PERLEXE) ..\t\$(NULL)
$(XCOPY) $(PERLDLL) ..\t\$(NULL)
-.IF "$(CCTYPE)" == "BORLAND"
- $(XCOPY) $(GLOBBAT) ..\t\$(NULL)
-.ELSE
$(XCOPY) $(GLOBEXE) ..\t\$(NULL)
-.ENDIF
set PERL_STATIC_EXT=$(STATIC_EXT) && \
cd ..\t && $(PERLEXE) -I..\lib harness $(TEST_SWITCHES) $(TEST_FILES)
@@ -1676,7 +1554,7 @@
- at erase $(PERLSTATICLIB)
- at erase $(PERLDLL)
- at erase $(CORE_OBJ)
- - at erase $(GENUUDMAP) $(GENUUDMAP_OBJ) $(UUDMAP_H) $(BITCOUNT_H)
+ - at erase $(GENUUDMAP) $(GENUUDMAP_OBJ) $(GENERATED_HEADERS)
-if exist $(MINIDIR) rmdir /s /q $(MINIDIR)
-if exist $(UNIDATADIR1) rmdir /s /q $(UNIDATADIR1)
-if exist $(UNIDATADIR2) rmdir /s /q $(UNIDATADIR2)
Property changes on: trunk/contrib/perl/win32/makefile.mk
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/win32/mdelete.bat
===================================================================
--- trunk/contrib/perl/win32/mdelete.bat 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/mdelete.bat 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/win32/mdelete.bat
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/win32/perl.rc
===================================================================
--- trunk/contrib/perl/win32/perl.rc 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/perl.rc 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/win32/perl.rc
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/win32/perlexe.ico
===================================================================
--- trunk/contrib/perl/win32/perlexe.ico 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/perlexe.ico 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/win32/perlexe.ico
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/win32/perlexe.manifest
===================================================================
--- trunk/contrib/perl/win32/perlexe.manifest 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/perlexe.manifest 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/win32/perlexe.manifest
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/win32/perlexe.rc
===================================================================
--- trunk/contrib/perl/win32/perlexe.rc 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/perlexe.rc 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/win32/perlexe.rc
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/win32/perlglob.c
===================================================================
--- trunk/contrib/perl/win32/perlglob.c 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/perlglob.c 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,8 +1,22 @@
/*
* Globbing for NT. Relies on the expansion done by the library
- * startup code.
+ * startup code (provided by Visual C++ by linking in setargv.obj).
*/
+/* Enable wildcard expansion for gcc's C-runtime library if not enabled by
+ * default (currently necessary with the automated build of the mingw-w64
+ * cross-compiler, but there's no harm in making sure for others too). */
+#ifdef __MINGW32__
+#include <_mingw.h>
+#if defined(__MINGW64_VERSION_MAJOR) && defined(__MINGW64_VERSION_MINOR)
+ // MinGW-w64
+ int _dowildcard = -1;
+#else
+ // MinGW
+ int _CRT_glob = -1;
+#endif
+#endif
+
#include <stdio.h>
#include <io.h>
#include <fcntl.h>
Property changes on: trunk/contrib/perl/win32/perlglob.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/win32/perlhost.h
===================================================================
--- trunk/contrib/perl/win32/perlhost.h 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/perlhost.h 2013-12-02 21:26:09 UTC (rev 6439)
@@ -26,11 +26,10 @@
#endif
START_EXTERN_C
-extern char * g_win32_get_privlib(const char *pl, STRLEN *const len);
-extern char * g_win32_get_sitelib(const char *pl, STRLEN *const len);
-extern char * g_win32_get_vendorlib(const char *pl,
- STRLEN *const len);
-extern char * g_getlogin(void);
+extern char * g_win32_get_privlib(const char *pl, STRLEN *const len);
+extern char * g_win32_get_sitelib(const char *pl, STRLEN *const len);
+extern char * g_win32_get_vendorlib(const char *pl, STRLEN *const len);
+extern char * g_getlogin(void);
END_EXTERN_C
class CPerlHost
@@ -840,21 +839,6 @@
int fileno = win32_dup(win32_fileno(pf));
/* open the file in the same mode */
-#ifdef __BORLANDC__
- if((pf)->flags & _F_READ) {
- mode[0] = 'r';
- mode[1] = 0;
- }
- else if((pf)->flags & _F_WRIT) {
- mode[0] = 'a';
- mode[1] = 0;
- }
- else if((pf)->flags & _F_RDWR) {
- mode[0] = 'r';
- mode[1] = '+';
- mode[2] = 0;
- }
-#else
if((pf)->_flag & _IOREAD) {
mode[0] = 'r';
mode[1] = 0;
@@ -868,7 +852,6 @@
mode[1] = '+';
mode[2] = 0;
}
-#endif
/* it appears that the binmode is attached to the
* file descriptor so binmode files will be handled
@@ -1295,8 +1278,7 @@
struct hostent*
PerlSockGethostent(struct IPerlSock* piPerl)
{
- dTHX;
- Perl_croak(aTHX_ "gethostent not implemented!\n");
+ win32_croak_not_implemented("gethostent");
return NULL;
}
@@ -1551,13 +1533,13 @@
return win32_crypt(clear, salt);
}
-void
+PERL_CALLCONV_NO_RET void
PerlProcExit(struct IPerlProc* piPerl, int status)
{
exit(status);
}
-void
+PERL_CALLCONV_NO_RET void
PerlProc_Exit(struct IPerlProc* piPerl, int status)
{
_exit(status);
@@ -1710,7 +1692,6 @@
win32_start_child(LPVOID arg)
{
PerlInterpreter *my_perl = (PerlInterpreter*)arg;
- GV *tmpgv;
int status;
HWND parent_message_hwnd;
#ifdef PERL_SYNC_FORK
@@ -1722,18 +1703,11 @@
PERL_SET_THX(my_perl);
win32_checkTLS(my_perl);
- /* set $$ to pseudo id */
#ifdef PERL_SYNC_FORK
w32_pseudo_id = id;
#else
w32_pseudo_id = GetCurrentThreadId();
#endif
- if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV)) {
- SV *sv = GvSV(tmpgv);
- SvREADONLY_off(sv);
- sv_setiv(sv, -(IV)w32_pseudo_id);
- SvREADONLY_on(sv);
- }
#ifdef PERL_USES_PL_PIDSTATUS
hv_clear(PL_pidstatus);
#endif
@@ -1781,6 +1755,10 @@
LEAVE;
FREETMPS;
PL_curstash = PL_defstash;
+ if (PL_curstash != PL_defstash) {
+ SvREFCNT_dec(PL_curstash);
+ PL_curstash = (HV *)SvREFCNT_inc(PL_defstash);
+ }
if (PL_endav && !PL_minus_c)
call_list(oldscope, PL_endav);
status = STATUS_EXIT;
@@ -1829,8 +1807,8 @@
int
PerlProcFork(struct IPerlProc* piPerl)
{
+#ifdef USE_ITHREADS
dTHX;
-#ifdef USE_ITHREADS
DWORD id;
HANDLE handle;
CPerlHost *h;
@@ -1882,7 +1860,7 @@
# endif
return -(int)id;
#else
- Perl_croak(aTHX_ "fork() not implemented!\n");
+ win32_croak_not_implemented("fork()");
return -1;
#endif /* USE_ITHREADS */
}
@@ -1914,6 +1892,8 @@
int
PerlProcLastHost(struct IPerlProc* piPerl)
{
+ /* this dTHX is unused in an optimized build since CPerlHost::num_hosts
+ is a static */
dTHX;
CPerlHost *h = (CPerlHost*)w32_internal_host;
return h->LastHost();
@@ -2198,7 +2178,6 @@
void
CPerlHost::Add(LPCSTR lpStr)
{
- dTHX;
char szBuffer[1024];
LPSTR *lpPtr;
int index, length = strlen(lpStr)+1;
@@ -2245,7 +2224,6 @@
void
CPerlHost::FreeLocalEnvironmentStrings(LPSTR lpStr)
{
- dTHX;
Safefree(lpStr);
}
@@ -2252,7 +2230,6 @@
char*
CPerlHost::GetChildDir(void)
{
- dTHX;
char* ptr;
size_t length;
@@ -2269,7 +2246,6 @@
void
CPerlHost::FreeChildDir(char* pStr)
{
- dTHX;
Safefree(pStr);
}
@@ -2276,13 +2252,12 @@
LPSTR
CPerlHost::CreateLocalEnvironmentStrings(VDir &vDir)
{
- dTHX;
LPSTR lpStr, lpPtr, lpEnvPtr, lpTmp, lpLocalEnv, lpAllocPtr;
DWORD dwSize, dwEnvIndex;
int nLength, compVal;
// get the process environment strings
- lpAllocPtr = lpTmp = (LPSTR)GetEnvironmentStrings();
+ lpAllocPtr = lpTmp = (LPSTR)win32_getenvironmentstrings();
// step over current directory stuff
while(*lpTmp == '=')
@@ -2358,7 +2333,7 @@
}
// release the process environment strings
- FreeEnvironmentStrings(lpAllocPtr);
+ win32_freeenvironmentstrings(lpAllocPtr);
return lpPtr;
}
@@ -2366,7 +2341,6 @@
void
CPerlHost::Reset(void)
{
- dTHX;
if(m_lppEnvList != NULL) {
for(DWORD index = 0; index < m_dwEnvCount; ++index) {
Free(m_lppEnvList[index]);
@@ -2381,7 +2355,6 @@
void
CPerlHost::Clearenv(void)
{
- dTHX;
char ch;
LPSTR lpPtr, lpStr, lpEnvPtr;
if (m_lppEnvList != NULL) {
@@ -2395,7 +2368,7 @@
}
/* get the process environment strings */
- lpStr = lpEnvPtr = (LPSTR)GetEnvironmentStrings();
+ lpStr = lpEnvPtr = (LPSTR)win32_getenvironmentstrings();
/* step over current directory stuff */
while(*lpStr == '=')
@@ -2414,7 +2387,7 @@
lpStr += strlen(lpStr) + 1;
}
- FreeEnvironmentStrings(lpEnvPtr);
+ win32_freeenvironmentstrings(lpEnvPtr);
}
@@ -2421,7 +2394,6 @@
char*
CPerlHost::Getenv(const char *varname)
{
- dTHX;
if (!m_bTopLevel) {
char *pEnv = Find(varname);
if (pEnv && *pEnv)
@@ -2433,7 +2405,6 @@
int
CPerlHost::Putenv(const char *envstring)
{
- dTHX;
Add(envstring);
if (m_bTopLevel)
return win32_putenv(envstring);
@@ -2444,7 +2415,6 @@
int
CPerlHost::Chdir(const char *dirname)
{
- dTHX;
int ret;
if (!dirname) {
errno = ENOENT;
Property changes on: trunk/contrib/perl/win32/perlhost.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/win32/perllib.c
===================================================================
--- trunk/contrib/perl/win32/perllib.c 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/perllib.c 2013-12-02 21:26:09 UTC (rev 6439)
@@ -18,7 +18,7 @@
/* Register any extra external extensions */
-char *staticlinkmodules[] = {
+const char * const staticlinkmodules[] = {
"DynaLoader",
/* other similar records will be included from "perllibst.h" */
#define STATIC1
@@ -232,10 +232,10 @@
}
#ifdef PERL_GLOBAL_STRUCT
-#define PERLVAR(var,type) /**/
-#define PERLVARA(var,type) /**/
-#define PERLVARI(var,type,init) PL_Vars.var = init;
-#define PERLVARIC(var,type,init) PL_Vars.var = init;
+#define PERLVAR(prefix,var,type) /**/
+#define PERLVARA(prefix,var,type) /**/
+#define PERLVARI(prefix,var,type,init) PL_Vars.prefix##var = init;
+#define PERLVARIC(prefix,var,type,init) PL_Vars.prefix##var = init;
#include "perlvars.h"
#undef PERLVAR
#undef PERLVARA
@@ -281,7 +281,7 @@
}
#endif
- /* At least the Borland RTL wants to free argv[] after main() returns. */
+ /* Some RTLs may want to free argv[] after main() returns. */
argv[0] = arg0;
if (ansi)
win32_free(ansi);
Property changes on: trunk/contrib/perl/win32/perllib.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/win32/perlmaince.c
===================================================================
--- trunk/contrib/perl/win32/perlmaince.c 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/perlmaince.c 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/win32/perlmaince.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/win32/pod.mak
===================================================================
--- trunk/contrib/perl/win32/pod.mak 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/pod.mak 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,7 +1,5 @@
HTMLROOT = / # Change this to fix cross-references in HTML
-POD2HTML_ARGS = --htmlroot=$(HTMLROOT) \
- --podroot=.. --podpath=pod:lib:ext:vms \
- --libpods=perlfunc:perlguts:perlvar:perlrun:perlop
+POD2HTML_ARGS = --htmlroot=$(HTMLROOT) --podroot=.. --podpath=pod:lib:ext:vms
POD2HTML = ../ext/Pod-Html/pod2html
POD2MAN = ../cpan/podlators/pod2man
POD2TEXT = ../cpan/podlators/pod2text
@@ -15,41 +13,30 @@
ICWD = -I..\dist\Cwd
-POD = \
- perl.pod \
+POD = perl.pod \
perl5004delta.pod \
perl5005delta.pod \
perl5100delta.pod \
perl5101delta.pod \
- perl5110delta.pod \
- perl5111delta.pod \
- perl5112delta.pod \
- perl5113delta.pod \
- perl5114delta.pod \
- perl5115delta.pod \
perl5120delta.pod \
perl5121delta.pod \
perl5122delta.pod \
perl5123delta.pod \
- perl5130delta.pod \
- perl51310delta.pod \
- perl51311delta.pod \
- perl5131delta.pod \
- perl5132delta.pod \
- perl5133delta.pod \
- perl5134delta.pod \
- perl5135delta.pod \
- perl5136delta.pod \
- perl5137delta.pod \
- perl5138delta.pod \
- perl5139delta.pod \
+ perl5124delta.pod \
+ perl5125delta.pod \
perl5140delta.pod \
+ perl5141delta.pod \
+ perl5142delta.pod \
+ perl5143delta.pod \
+ perl5144delta.pod \
+ perl5160delta.pod \
+ perl5161delta.pod \
+ perl5162delta.pod \
+ perl5163delta.pod \
+ perl5180delta.pod \
+ perl5181delta.pod \
perl561delta.pod \
perl56delta.pod \
- perl570delta.pod \
- perl571delta.pod \
- perl572delta.pod \
- perl573delta.pod \
perl581delta.pod \
perl582delta.pod \
perl583delta.pod \
@@ -60,12 +47,6 @@
perl588delta.pod \
perl589delta.pod \
perl58delta.pod \
- perl590delta.pod \
- perl591delta.pod \
- perl592delta.pod \
- perl593delta.pod \
- perl594delta.pod \
- perl595delta.pod \
perlapi.pod \
perlapio.pod \
perlartistic.pod \
@@ -76,7 +57,6 @@
perlcheat.pod \
perlclib.pod \
perlcommunity.pod \
- perlcompile.pod \
perldata.pod \
perldbmfilter.pod \
perldebguts.pod \
@@ -84,26 +64,16 @@
perldebug.pod \
perldelta.pod \
perldiag.pod \
- perldoc.pod \
perldsc.pod \
+ perldtrace.pod \
perlebcdic.pod \
perlembed.pod \
- perlfaq.pod \
- perlfaq1.pod \
- perlfaq2.pod \
- perlfaq3.pod \
- perlfaq4.pod \
- perlfaq5.pod \
- perlfaq6.pod \
- perlfaq7.pod \
- perlfaq8.pod \
- perlfaq9.pod \
+ perlexperiment.pod \
perlfilter.pod \
perlfork.pod \
perlform.pod \
perlfunc.pod \
perlgit.pod \
- perlglossary.pod \
perlgpl.pod \
perlguts.pod \
perlhack.pod \
@@ -126,6 +96,7 @@
perlnewmod.pod \
perlnumber.pod \
perlobj.pod \
+ perlootut.pod \
perlop.pod \
perlopentut.pod \
perlpacktut.pod \
@@ -166,45 +137,32 @@
perlunitut.pod \
perlutil.pod \
perlvar.pod \
- perlvms.pod \
- perlxs.pod \
- perlxstut.pod
+ perlvms.pod
-MAN = \
- perl.man \
+MAN = perl.man \
perl5004delta.man \
perl5005delta.man \
perl5100delta.man \
perl5101delta.man \
- perl5110delta.man \
- perl5111delta.man \
- perl5112delta.man \
- perl5113delta.man \
- perl5114delta.man \
- perl5115delta.man \
perl5120delta.man \
perl5121delta.man \
perl5122delta.man \
perl5123delta.man \
- perl5130delta.man \
- perl51310delta.man \
- perl51311delta.man \
- perl5131delta.man \
- perl5132delta.man \
- perl5133delta.man \
- perl5134delta.man \
- perl5135delta.man \
- perl5136delta.man \
- perl5137delta.man \
- perl5138delta.man \
- perl5139delta.man \
+ perl5124delta.man \
+ perl5125delta.man \
perl5140delta.man \
+ perl5141delta.man \
+ perl5142delta.man \
+ perl5143delta.man \
+ perl5144delta.man \
+ perl5160delta.man \
+ perl5161delta.man \
+ perl5162delta.man \
+ perl5163delta.man \
+ perl5180delta.man \
+ perl5181delta.man \
perl561delta.man \
perl56delta.man \
- perl570delta.man \
- perl571delta.man \
- perl572delta.man \
- perl573delta.man \
perl581delta.man \
perl582delta.man \
perl583delta.man \
@@ -215,12 +173,6 @@
perl588delta.man \
perl589delta.man \
perl58delta.man \
- perl590delta.man \
- perl591delta.man \
- perl592delta.man \
- perl593delta.man \
- perl594delta.man \
- perl595delta.man \
perlapi.man \
perlapio.man \
perlartistic.man \
@@ -231,7 +183,6 @@
perlcheat.man \
perlclib.man \
perlcommunity.man \
- perlcompile.man \
perldata.man \
perldbmfilter.man \
perldebguts.man \
@@ -239,26 +190,16 @@
perldebug.man \
perldelta.man \
perldiag.man \
- perldoc.man \
perldsc.man \
+ perldtrace.man \
perlebcdic.man \
perlembed.man \
- perlfaq.man \
- perlfaq1.man \
- perlfaq2.man \
- perlfaq3.man \
- perlfaq4.man \
- perlfaq5.man \
- perlfaq6.man \
- perlfaq7.man \
- perlfaq8.man \
- perlfaq9.man \
+ perlexperiment.man \
perlfilter.man \
perlfork.man \
perlform.man \
perlfunc.man \
perlgit.man \
- perlglossary.man \
perlgpl.man \
perlguts.man \
perlhack.man \
@@ -281,6 +222,7 @@
perlnewmod.man \
perlnumber.man \
perlobj.man \
+ perlootut.man \
perlop.man \
perlopentut.man \
perlpacktut.man \
@@ -321,45 +263,32 @@
perlunitut.man \
perlutil.man \
perlvar.man \
- perlvms.man \
- perlxs.man \
- perlxstut.man
+ perlvms.man
-HTML = \
- perl.html \
+HTML = perl.html \
perl5004delta.html \
perl5005delta.html \
perl5100delta.html \
perl5101delta.html \
- perl5110delta.html \
- perl5111delta.html \
- perl5112delta.html \
- perl5113delta.html \
- perl5114delta.html \
- perl5115delta.html \
perl5120delta.html \
perl5121delta.html \
perl5122delta.html \
perl5123delta.html \
- perl5130delta.html \
- perl51310delta.html \
- perl51311delta.html \
- perl5131delta.html \
- perl5132delta.html \
- perl5133delta.html \
- perl5134delta.html \
- perl5135delta.html \
- perl5136delta.html \
- perl5137delta.html \
- perl5138delta.html \
- perl5139delta.html \
+ perl5124delta.html \
+ perl5125delta.html \
perl5140delta.html \
+ perl5141delta.html \
+ perl5142delta.html \
+ perl5143delta.html \
+ perl5144delta.html \
+ perl5160delta.html \
+ perl5161delta.html \
+ perl5162delta.html \
+ perl5163delta.html \
+ perl5180delta.html \
+ perl5181delta.html \
perl561delta.html \
perl56delta.html \
- perl570delta.html \
- perl571delta.html \
- perl572delta.html \
- perl573delta.html \
perl581delta.html \
perl582delta.html \
perl583delta.html \
@@ -370,12 +299,6 @@
perl588delta.html \
perl589delta.html \
perl58delta.html \
- perl590delta.html \
- perl591delta.html \
- perl592delta.html \
- perl593delta.html \
- perl594delta.html \
- perl595delta.html \
perlapi.html \
perlapio.html \
perlartistic.html \
@@ -386,7 +309,6 @@
perlcheat.html \
perlclib.html \
perlcommunity.html \
- perlcompile.html \
perldata.html \
perldbmfilter.html \
perldebguts.html \
@@ -394,26 +316,16 @@
perldebug.html \
perldelta.html \
perldiag.html \
- perldoc.html \
perldsc.html \
+ perldtrace.html \
perlebcdic.html \
perlembed.html \
- perlfaq.html \
- perlfaq1.html \
- perlfaq2.html \
- perlfaq3.html \
- perlfaq4.html \
- perlfaq5.html \
- perlfaq6.html \
- perlfaq7.html \
- perlfaq8.html \
- perlfaq9.html \
+ perlexperiment.html \
perlfilter.html \
perlfork.html \
perlform.html \
perlfunc.html \
perlgit.html \
- perlglossary.html \
perlgpl.html \
perlguts.html \
perlhack.html \
@@ -436,6 +348,7 @@
perlnewmod.html \
perlnumber.html \
perlobj.html \
+ perlootut.html \
perlop.html \
perlopentut.html \
perlpacktut.html \
@@ -475,46 +388,33 @@
perlunitut.html \
perlutil.html \
perlvar.html \
- perlvms.html \
- perlxs.html \
- perlxstut.html
+ perlvms.html
# not perltoc.html
-TEX = \
- perl.tex \
+TEX = perl.tex \
perl5004delta.tex \
perl5005delta.tex \
perl5100delta.tex \
perl5101delta.tex \
- perl5110delta.tex \
- perl5111delta.tex \
- perl5112delta.tex \
- perl5113delta.tex \
- perl5114delta.tex \
- perl5115delta.tex \
perl5120delta.tex \
perl5121delta.tex \
perl5122delta.tex \
perl5123delta.tex \
- perl5130delta.tex \
- perl51310delta.tex \
- perl51311delta.tex \
- perl5131delta.tex \
- perl5132delta.tex \
- perl5133delta.tex \
- perl5134delta.tex \
- perl5135delta.tex \
- perl5136delta.tex \
- perl5137delta.tex \
- perl5138delta.tex \
- perl5139delta.tex \
+ perl5124delta.tex \
+ perl5125delta.tex \
perl5140delta.tex \
+ perl5141delta.tex \
+ perl5142delta.tex \
+ perl5143delta.tex \
+ perl5144delta.tex \
+ perl5160delta.tex \
+ perl5161delta.tex \
+ perl5162delta.tex \
+ perl5163delta.tex \
+ perl5180delta.tex \
+ perl5181delta.tex \
perl561delta.tex \
perl56delta.tex \
- perl570delta.tex \
- perl571delta.tex \
- perl572delta.tex \
- perl573delta.tex \
perl581delta.tex \
perl582delta.tex \
perl583delta.tex \
@@ -525,12 +425,6 @@
perl588delta.tex \
perl589delta.tex \
perl58delta.tex \
- perl590delta.tex \
- perl591delta.tex \
- perl592delta.tex \
- perl593delta.tex \
- perl594delta.tex \
- perl595delta.tex \
perlapi.tex \
perlapio.tex \
perlartistic.tex \
@@ -541,7 +435,6 @@
perlcheat.tex \
perlclib.tex \
perlcommunity.tex \
- perlcompile.tex \
perldata.tex \
perldbmfilter.tex \
perldebguts.tex \
@@ -549,26 +442,16 @@
perldebug.tex \
perldelta.tex \
perldiag.tex \
- perldoc.tex \
perldsc.tex \
+ perldtrace.tex \
perlebcdic.tex \
perlembed.tex \
- perlfaq.tex \
- perlfaq1.tex \
- perlfaq2.tex \
- perlfaq3.tex \
- perlfaq4.tex \
- perlfaq5.tex \
- perlfaq6.tex \
- perlfaq7.tex \
- perlfaq8.tex \
- perlfaq9.tex \
+ perlexperiment.tex \
perlfilter.tex \
perlfork.tex \
perlform.tex \
perlfunc.tex \
perlgit.tex \
- perlglossary.tex \
perlgpl.tex \
perlguts.tex \
perlhack.tex \
@@ -591,6 +474,7 @@
perlnewmod.tex \
perlnumber.tex \
perlobj.tex \
+ perlootut.tex \
perlop.tex \
perlopentut.tex \
perlpacktut.tex \
@@ -631,9 +515,7 @@
perlunitut.tex \
perlutil.tex \
perlvar.tex \
- perlvms.tex \
- perlxs.tex \
- perlxstut.tex
+ perlvms.tex
man: $(POD2MAN) $(MAN)
Property changes on: trunk/contrib/perl/win32/pod.mak
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/win32/runperl.c
===================================================================
--- trunk/contrib/perl/win32/runperl.c 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/runperl.c 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/win32/runperl.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/win32/sync_ext.pl
===================================================================
--- trunk/contrib/perl/win32/sync_ext.pl 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/sync_ext.pl 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/win32/sync_ext.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/win32/vdir.h
===================================================================
--- trunk/contrib/perl/win32/vdir.h 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/vdir.h 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/win32/vdir.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/win32/vmem.h
===================================================================
--- trunk/contrib/perl/win32/vmem.h 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/vmem.h 2013-12-02 21:26:09 UTC (rev 6439)
@@ -9,8 +9,8 @@
* Options:
*
* Defining _USE_MSVCRT_MEM_ALLOC will cause all memory allocations
- * to be forwarded to MSVCRT.DLL. Defining _USE_LINKED_LIST as well will
- * track all allocations in a doubly linked list, so that the host can
+ * to be forwarded to the compiler's MSVCR*.DLL. Defining _USE_LINKED_LIST as
+ * well will track all allocations in a doubly linked list, so that the host can
* free all memory allocated when it goes away.
* If _USE_MSVCRT_MEM_ALLOC is not defined then Knuth's boundary tag algorithm
* is used; defining _USE_BUDDY_BLOCKS will use Knuth's algorithm R
@@ -65,13 +65,10 @@
#endif
/*
- * Pass all memory requests throught to msvcrt.dll
- * optionaly track by using a doubly linked header
+ * Pass all memory requests through to the compiler's msvcr*.dll.
+ * Optionaly track by using a doubly linked header.
*/
-typedef void (*LPFREE)(void *block);
-typedef void* (*LPMALLOC)(size_t size);
-typedef void* (*LPREALLOC)(void *block, size_t size);
#ifdef _USE_LINKED_LIST
class VMem;
typedef struct _MemoryBlockHeader* PMEMORY_BLOCK_HEADER;
@@ -87,14 +84,14 @@
public:
VMem();
~VMem();
- virtual void* Malloc(size_t size);
- virtual void* Realloc(void* pMem, size_t size);
- virtual void Free(void* pMem);
- virtual void GetLock(void);
- virtual void FreeLock(void);
- virtual int IsLocked(void);
- virtual long Release(void);
- virtual long AddRef(void);
+ void* Malloc(size_t size);
+ void* Realloc(void* pMem, size_t size);
+ void Free(void* pMem);
+ void GetLock(void);
+ void FreeLock(void);
+ int IsLocked(void);
+ long Release(void);
+ long AddRef(void);
inline BOOL CreateOk(void)
{
@@ -121,30 +118,20 @@
}
MEMORY_BLOCK_HEADER m_Dummy;
+ CRITICAL_SECTION m_cs; // access lock
#endif
long m_lRefCount; // number of current users
- CRITICAL_SECTION m_cs; // access lock
- HINSTANCE m_hLib;
- LPFREE m_pfree;
- LPMALLOC m_pmalloc;
- LPREALLOC m_prealloc;
};
VMem::VMem()
{
m_lRefCount = 1;
+#ifdef _USE_LINKED_LIST
InitializeCriticalSection(&m_cs);
-#ifdef _USE_LINKED_LIST
m_Dummy.pNext = m_Dummy.pPrev = &m_Dummy;
m_Dummy.owner = this;
#endif
- m_hLib = LoadLibrary("msvcrt.dll");
- if (m_hLib) {
- m_pfree = (LPFREE)GetProcAddress(m_hLib, "free");
- m_pmalloc = (LPMALLOC)GetProcAddress(m_hLib, "malloc");
- m_prealloc = (LPREALLOC)GetProcAddress(m_hLib, "realloc");
- }
}
VMem::~VMem(void)
@@ -153,10 +140,8 @@
while (m_Dummy.pNext != &m_Dummy) {
Free(m_Dummy.pNext+1);
}
+ DeleteCriticalSection(&m_cs);
#endif
- if (m_hLib)
- FreeLibrary(m_hLib);
- DeleteCriticalSection(&m_cs);
}
void* VMem::Malloc(size_t size)
@@ -163,7 +148,7 @@
{
#ifdef _USE_LINKED_LIST
GetLock();
- PMEMORY_BLOCK_HEADER ptr = (PMEMORY_BLOCK_HEADER)m_pmalloc(size+sizeof(MEMORY_BLOCK_HEADER));
+ PMEMORY_BLOCK_HEADER ptr = (PMEMORY_BLOCK_HEADER)malloc(size+sizeof(MEMORY_BLOCK_HEADER));
if (!ptr) {
FreeLock();
return NULL;
@@ -172,7 +157,7 @@
FreeLock();
return (ptr+1);
#else
- return m_pmalloc(size);
+ return malloc(size);
#endif
}
@@ -190,7 +175,7 @@
GetLock();
PMEMORY_BLOCK_HEADER ptr = (PMEMORY_BLOCK_HEADER)(((char*)pMem)-sizeof(MEMORY_BLOCK_HEADER));
UnlinkBlock(ptr);
- ptr = (PMEMORY_BLOCK_HEADER)m_prealloc(ptr, size+sizeof(MEMORY_BLOCK_HEADER));
+ ptr = (PMEMORY_BLOCK_HEADER)realloc(ptr, size+sizeof(MEMORY_BLOCK_HEADER));
if (!ptr) {
FreeLock();
return NULL;
@@ -200,7 +185,7 @@
return (ptr+1);
#else
- return m_prealloc(pMem, size);
+ return realloc(pMem, size);
#endif
}
@@ -212,9 +197,8 @@
if (ptr->owner != this) {
if (ptr->owner) {
#if 1
- dTHX;
int *nowhere = NULL;
- Perl_warn(aTHX_ "Free to wrong pool %p not %p",this,ptr->owner);
+ Perl_warn_nocontext("Free to wrong pool %p not %p",this,ptr->owner);
*nowhere = 0; /* this segfault is deliberate,
so you can see the stack trace */
#else
@@ -226,22 +210,26 @@
GetLock();
UnlinkBlock(ptr);
ptr->owner = NULL;
- m_pfree(ptr);
+ free(ptr);
FreeLock();
}
-#else
- m_pfree(pMem);
+#else /*_USE_LINKED_LIST*/
+ free(pMem);
#endif
}
void VMem::GetLock(void)
{
+#ifdef _USE_LINKED_LIST
EnterCriticalSection(&m_cs);
+#endif
}
void VMem::FreeLock(void)
{
+#ifdef _USE_LINKED_LIST
LeaveCriticalSection(&m_cs);
+#endif
}
int VMem::IsLocked(void)
@@ -413,14 +401,14 @@
public:
VMem();
~VMem();
- virtual void* Malloc(size_t size);
- virtual void* Realloc(void* pMem, size_t size);
- virtual void Free(void* pMem);
- virtual void GetLock(void);
- virtual void FreeLock(void);
- virtual int IsLocked(void);
- virtual long Release(void);
- virtual long AddRef(void);
+ void* Malloc(size_t size);
+ void* Realloc(void* pMem, size_t size);
+ void Free(void* pMem);
+ void GetLock(void);
+ void FreeLock(void);
+ int IsLocked(void);
+ long Release(void);
+ long AddRef(void);
inline BOOL CreateOk(void)
{
Property changes on: trunk/contrib/perl/win32/vmem.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/win32/win32.c
===================================================================
--- trunk/contrib/perl/win32/win32.c 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/win32.c 2013-12-02 21:26:09 UTC (rev 6439)
@@ -64,13 +64,8 @@
#include <stdarg.h>
#include <float.h>
#include <time.h>
+#include <sys/utime.h>
-#if defined(_MSC_VER) || defined(__MINGW32__)
-# include <sys/utime.h>
-#else
-# include <utime.h>
-#endif
-
#ifdef __GNUC__
/* Mingw32 defaults to globing command line
* So we turn it off like this:
@@ -89,11 +84,6 @@
END_EXTERN_C
#endif
-#if defined(__BORLANDC__)
-# define _stat stat
-# define _utimbuf utimbuf
-#endif
-
#define EXECF_EXEC 1
#define EXECF_SPAWN 2
#define EXECF_SPAWN_NOWAIT 3
@@ -109,44 +99,6 @@
# define getlogin g_getlogin
#endif
-static void get_shell(void);
-static long tokenize(const char *str, char **dest, char ***destv);
-static int do_spawn2(pTHX_ const char *cmd, int exectype);
-static BOOL has_shell_metachars(const char *ptr);
-static long filetime_to_clock(PFILETIME ft);
-static BOOL filetime_from_time(PFILETIME ft, time_t t);
-static char * get_emd_part(SV **leading, STRLEN *const len,
- char *trailing, ...);
-static void remove_dead_process(long deceased);
-static long find_pid(int pid);
-static char * qualified_path(const char *cmd);
-static char * win32_get_xlib(const char *pl, const char *xlib,
- const char *libname, STRLEN *const len);
-static LRESULT win32_process_message(HWND hwnd, UINT msg,
- WPARAM wParam, LPARAM lParam);
-
-#ifdef USE_ITHREADS
-static void remove_dead_pseudo_process(long child);
-static long find_pseudo_pid(int pid);
-#endif
-
-START_EXTERN_C
-HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE;
-char w32_module_name[MAX_PATH+1];
-END_EXTERN_C
-
-static OSVERSIONINFO g_osver = {0, 0, 0, 0, 0, ""};
-
-#ifdef __BORLANDC__
-/* Silence STDERR grumblings from Borland's math library. */
-DllExport int
-_matherr(struct _exception *a)
-{
- PERL_UNUSED_VAR(a);
- return 1;
-}
-#endif
-
/* VS2005 (MSC version 14) provides a mechanism to set an invalid
* parameter handler. This functionality is not available in the
* 64-bit compiler from the Platform SDK, which unfortunately also
@@ -163,7 +115,70 @@
#endif
#ifdef SET_INVALID_PARAMETER_HANDLER
-void my_invalid_parameter_handler(const wchar_t* expression,
+static BOOL set_silent_invalid_parameter_handler(BOOL newvalue);
+static void my_invalid_parameter_handler(const wchar_t* expression,
+ const wchar_t* function, const wchar_t* file,
+ unsigned int line, uintptr_t pReserved);
+#endif
+
+static char* get_regstr_from(HKEY hkey, const char *valuename, SV **svp);
+static char* get_regstr(const char *valuename, SV **svp);
+static char* get_emd_part(SV **prev_pathp, STRLEN *const len,
+ char *trailing, ...);
+static char* win32_get_xlib(const char *pl, const char *xlib,
+ const char *libname, STRLEN *const len);
+static BOOL has_shell_metachars(const char *ptr);
+static long tokenize(const char *str, char **dest, char ***destv);
+static void get_shell(void);
+static char* find_next_space(const char *s);
+static int do_spawn2(pTHX_ const char *cmd, int exectype);
+static long find_pid(pTHX_ int pid);
+static void remove_dead_process(long child);
+static int terminate_process(DWORD pid, HANDLE process_handle, int sig);
+static int my_kill(int pid, int sig);
+static void out_of_memory(void);
+static char* wstr_to_str(const wchar_t* wstr);
+static long filetime_to_clock(PFILETIME ft);
+static BOOL filetime_from_time(PFILETIME ft, time_t t);
+static char* create_command_line(char *cname, STRLEN clen,
+ const char * const *args);
+static char* qualified_path(const char *cmd);
+static void ansify_path(void);
+static LRESULT win32_process_message(HWND hwnd, UINT msg,
+ WPARAM wParam, LPARAM lParam);
+
+#ifdef USE_ITHREADS
+static long find_pseudo_pid(pTHX_ int pid);
+static void remove_dead_pseudo_process(long child);
+static HWND get_hwnd_delay(pTHX, long child, DWORD tries);
+#endif
+
+#ifdef HAVE_INTERP_INTERN
+static void win32_csighandler(int sig);
+#endif
+
+START_EXTERN_C
+HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE;
+char w32_module_name[MAX_PATH+1];
+END_EXTERN_C
+
+static OSVERSIONINFO g_osver = {0, 0, 0, 0, 0, ""};
+
+#ifdef SET_INVALID_PARAMETER_HANDLER
+static BOOL silent_invalid_parameter_handler = FALSE;
+
+static BOOL
+set_silent_invalid_parameter_handler(BOOL newvalue)
+{
+ BOOL oldvalue = silent_invalid_parameter_handler;
+# ifdef _DEBUG
+ silent_invalid_parameter_handler = newvalue;
+# endif
+ return oldvalue;
+}
+
+static void
+my_invalid_parameter_handler(const wchar_t* expression,
const wchar_t* function,
const wchar_t* file,
unsigned int line,
@@ -170,9 +185,20 @@
uintptr_t pReserved)
{
# ifdef _DEBUG
- wprintf(L"Invalid parameter detected in function %s."
- L" File: %s Line: %d\n", function, file, line);
- wprintf(L"Expression: %s\n", expression);
+ char* ansi_expression;
+ char* ansi_function;
+ char* ansi_file;
+ if (silent_invalid_parameter_handler)
+ return;
+ ansi_expression = wstr_to_str(expression);
+ ansi_function = wstr_to_str(function);
+ ansi_file = wstr_to_str(file);
+ fprintf(stderr, "Invalid parameter detected in function %s. "
+ "File: %s, line: %d\n", ansi_function, ansi_file, line);
+ fprintf(stderr, "Expression: %s\n", ansi_expression);
+ free(ansi_expression);
+ free(ansi_function);
+ free(ansi_file);
# endif
}
#endif
@@ -355,10 +381,9 @@
return NULL;
}
-char *
+EXTERN_C char *
win32_get_privlib(const char *pl, STRLEN *const len)
{
- dTHX;
char *stdlib = "lib";
char buffer[MAX_PATH+1];
SV *sv = NULL;
@@ -376,7 +401,6 @@
win32_get_xlib(const char *pl, const char *xlib, const char *libname,
STRLEN *const len)
{
- dTHX;
char regstr[40];
char pathstr[MAX_PATH+1];
SV *sv1 = NULL;
@@ -404,6 +428,7 @@
if (!sv1) {
sv1 = sv2;
} else if (sv2) {
+ dTHX;
sv_catpvn(sv1, ";", 1);
sv_catsv(sv1, sv2);
}
@@ -413,7 +438,7 @@
return SvPVX(sv1);
}
-char *
+EXTERN_C char *
win32_get_sitelib(const char *pl, STRLEN *const len)
{
return win32_get_xlib(pl, "sitelib", "site", len);
@@ -423,7 +448,7 @@
# define PERL_VENDORLIB_NAME "vendor"
#endif
-char *
+EXTERN_C char *
win32_get_vendorlib(const char *pl, STRLEN *const len)
{
return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME, len);
@@ -518,10 +543,9 @@
char **retvstart = 0;
int items = -1;
if (str) {
- dTHX;
int slen = strlen(str);
- register char *ret;
- register char **retv;
+ char *ret;
+ char **retv;
Newx(ret, slen+2, char);
Newx(retv, (slen+3)/2, char*);
@@ -789,7 +813,7 @@
DllExport DIR *
win32_opendir(const char *filename)
{
- dTHX;
+ dTHXa(NULL);
DIR *dirp;
long len;
long idx;
@@ -828,6 +852,7 @@
/* do the FindFirstFile call */
MultiByteToWideChar(CP_ACP, 0, scanname, -1, wscanname, sizeof(wscanname)/sizeof(WCHAR));
+ aTHXa(PERL_GET_THX);
dirp->handle = FindFirstFileW(PerlDir_mapW(wscanname), &wFindData);
if (dirp->handle == INVALID_HANDLE_VALUE) {
@@ -898,7 +923,6 @@
/* Now set up for the next call to readdir */
dirp->curr += len + 1;
if (dirp->curr >= dirp->end) {
- dTHX;
BOOL res;
char buffer[MAX_PATH*2];
@@ -980,7 +1004,6 @@
DllExport int
win32_closedir(DIR *dirp)
{
- dTHX;
if (dirp->handle != INVALID_HANDLE_VALUE)
FindClose(dirp->handle);
Safefree(dirp->start);
@@ -994,7 +1017,7 @@
{
dVAR;
PerlInterpreter *const from = param->proto_perl;
- PerlInterpreter *const to = PERL_GET_THX;
+ PerlInterpreter *const to = (PerlInterpreter *)PERL_GET_THX;
long pos;
DIR *dup;
@@ -1083,7 +1106,7 @@
return (agid == ROOT_GID ? 0 : -1);
}
-char *
+EXTERN_C char *
getlogin(void)
{
dTHX;
@@ -1127,9 +1150,8 @@
}
static long
-find_pid(int pid)
+find_pid(pTHX_ int pid)
{
- dTHX;
long child = w32_num_children;
while (--child >= 0) {
if ((int)w32_child_pids[child] == pid)
@@ -1154,9 +1176,8 @@
#ifdef USE_ITHREADS
static long
-find_pseudo_pid(int pid)
+find_pseudo_pid(pTHX_ int pid)
{
- dTHX;
long child = w32_num_pseudo_children;
while (--child >= 0) {
if ((int)w32_pseudo_child_pids[child] == pid)
@@ -1286,6 +1307,50 @@
return retval;
}
+#ifdef USE_ITHREADS
+/* Get a child pseudo-process HWND, with retrying and delaying/yielding.
+ * The "tries" parameter is the number of retries to make, with a Sleep(1)
+ * (waiting and yielding the time slot) between each try. Specifying 0 causes
+ * only Sleep(0) (no waiting and potentially no yielding) to be used, so is not
+ * recommended
+ * Returns an hwnd != INVALID_HANDLE_VALUE (so be aware that NULL can be
+ * returned) or croaks if the child pseudo-process doesn't schedule and deliver
+ * a HWND in the time period allowed.
+ */
+static HWND
+get_hwnd_delay(pTHX, long child, DWORD tries)
+{
+ HWND hwnd = w32_pseudo_child_message_hwnds[child];
+ if (hwnd != INVALID_HANDLE_VALUE) return hwnd;
+
+ /* Pseudo-process has not yet properly initialized since hwnd isn't set.
+ * Fast sleep: On some NT kernels/systems, a Sleep(0) won't deschedule a
+ * thread 100% of the time since threads are attached to a CPU for NUMA and
+ * caching reasons, and the child thread was attached to a different CPU
+ * therefore there is no workload on that CPU and Sleep(0) returns control
+ * without yielding the time slot.
+ * https://rt.perl.org/rt3/Ticket/Display.html?id=88840
+ */
+ Sleep(0);
+ win32_async_check(aTHX);
+ hwnd = w32_pseudo_child_message_hwnds[child];
+ if (hwnd != INVALID_HANDLE_VALUE) return hwnd;
+
+ {
+ unsigned int count = 0;
+ /* No Sleep(1) if tries==0, just fail instead if we get this far. */
+ while (count++ < tries) {
+ Sleep(1);
+ win32_async_check(aTHX);
+ hwnd = w32_pseudo_child_message_hwnds[child];
+ if (hwnd != INVALID_HANDLE_VALUE) return hwnd;
+ }
+ }
+
+ Perl_croak(aTHX_ "panic: child pseudo-process was never scheduled");
+}
+#endif
+
DllExport int
win32_kill(int pid, int sig)
{
@@ -1294,68 +1359,62 @@
#ifdef USE_ITHREADS
if (pid < 0) {
/* it is a pseudo-forked child */
- child = find_pseudo_pid(-pid);
+ child = find_pseudo_pid(aTHX_ -pid);
if (child >= 0) {
- HWND hwnd = w32_pseudo_child_message_hwnds[child];
HANDLE hProcess = w32_pseudo_child_handles[child];
switch (sig) {
- case 0:
- /* "Does process exist?" use of kill */
- return 0;
-
- case 9:
- /* kill -9 style un-graceful exit */
- if (TerminateThread(hProcess, sig)) {
- /* Allow the scheduler to finish cleaning up the other thread.
- * Otherwise, if we ExitProcess() before another context switch
- * happens we will end up with a process exit code of "sig" instead
- * of our own exit status.
- * See also: https://rt.cpan.org/Ticket/Display.html?id=66016#txn-908976
- */
- Sleep(0);
- remove_dead_pseudo_process(child);
+ case 0:
+ /* "Does process exist?" use of kill */
return 0;
- }
- break;
- default: {
- int count = 0;
- /* pseudo-process has not yet properly initialized if hwnd isn't set */
- while (hwnd == INVALID_HANDLE_VALUE && count < 5) {
- /* Yield and wait for the other thread to send us its message_hwnd */
- Sleep(0);
- win32_async_check(aTHX);
- hwnd = w32_pseudo_child_message_hwnds[child];
- ++count;
- }
- if (hwnd != INVALID_HANDLE_VALUE) {
- /* We fake signals to pseudo-processes using Win32
- * message queue. In Win9X the pids are negative already. */
- if ((hwnd != NULL && PostMessage(hwnd, WM_USER_KILL, sig, 0)) ||
- PostThreadMessage(-pid, WM_USER_KILL, sig, 0))
- {
- /* Don't wait for child process to terminate after we send a SIGTERM
- * because the child may be blocked in a system call and never receive
- * the signal.
- */
- if (sig == SIGTERM) {
- Sleep(0);
- w32_pseudo_child_sigterm[child] = 1;
- }
- /* It might be us ... */
- PERL_ASYNC_CHECK();
- return 0;
- }
- }
- break;
- }
- } /* switch */
+ case 9: {
+ /* kill -9 style un-graceful exit */
+ /* Do a wait to make sure child starts and isn't in DLL
+ * Loader Lock */
+ HWND hwnd = get_hwnd_delay(aTHX, child, 5);
+ if (TerminateThread(hProcess, sig)) {
+ /* Allow the scheduler to finish cleaning up the other
+ * thread.
+ * Otherwise, if we ExitProcess() before another context
+ * switch happens we will end up with a process exit
+ * code of "sig" instead of our own exit status.
+ * https://rt.cpan.org/Ticket/Display.html?id=66016#txn-908976
+ */
+ Sleep(0);
+ remove_dead_pseudo_process(child);
+ return 0;
+ }
+ break;
+ }
+
+ default: {
+ HWND hwnd = get_hwnd_delay(aTHX, child, 5);
+ /* We fake signals to pseudo-processes using Win32
+ * message queue. */
+ if ((hwnd != NULL && PostMessage(hwnd, WM_USER_KILL, sig, 0)) ||
+ PostThreadMessage(-pid, WM_USER_KILL, sig, 0))
+ {
+ /* Don't wait for child process to terminate after we send a
+ * SIGTERM because the child may be blocked in a system call
+ * and never receive the signal.
+ */
+ if (sig == SIGTERM) {
+ Sleep(0);
+ w32_pseudo_child_sigterm[child] = 1;
+ }
+ /* It might be us ... */
+ PERL_ASYNC_CHECK();
+ return 0;
+ }
+ break;
+ }
+ } /* switch */
}
}
else
#endif
{
- child = find_pid(pid);
+ child = find_pid(aTHX_ pid);
if (child >= 0) {
if (my_kill(pid, sig)) {
DWORD exitcode = 0;
@@ -1379,9 +1438,9 @@
DllExport int
win32_stat(const char *path, Stat_t *sbuf)
{
- dTHX;
char buffer[MAX_PATH+1];
int l = strlen(path);
+ dTHX;
int res;
int nlink = 1;
BOOL expect_dir = FALSE;
@@ -1483,8 +1542,8 @@
}
if (S_ISDIR(sbuf->st_mode)) {
/* Ensure the "write" bit is switched off in the mode for
- * directories with the read-only attribute set. Borland (at least)
- * switches it on for directories, which is technically correct
+ * directories with the read-only attribute set. Some compilers
+ * switch it on for directories, which is technically correct
* (directories are indeed always writable unless denied by DACLs),
* but we want stat() and -w to reflect the state of the read-only
* attribute for symmetry with chmod(). */
@@ -1493,29 +1552,6 @@
sbuf->st_mode &= ~S_IWRITE;
}
}
-#ifdef __BORLANDC__
- if (S_ISDIR(sbuf->st_mode)) {
- sbuf->st_mode |= S_IEXEC;
- }
- else if (S_ISREG(sbuf->st_mode)) {
- int perms;
- if (l >= 4 && path[l-4] == '.') {
- const char *e = path + l - 3;
- if (strnicmp(e,"exe",3)
- && strnicmp(e,"bat",3)
- && strnicmp(e,"com",3)
- && strnicmp(e,"cmd",3))
- sbuf->st_mode &= ~S_IEXEC;
- else
- sbuf->st_mode |= S_IEXEC;
- }
- else
- sbuf->st_mode &= ~S_IEXEC;
- /* Propagate permissions to _group_ and _others_ */
- perms = sbuf->st_mode & (S_IREAD|S_IWRITE|S_IEXEC);
- sbuf->st_mode |= (perms>>3) | (perms>>6);
- }
-#endif
}
return res;
}
@@ -1625,16 +1661,37 @@
static void
out_of_memory(void)
{
- if (PL_curinterp) {
- dTHX;
- /* Can't use PerlIO to write as it allocates memory */
- PerlLIO_write(PerlIO_fileno(Perl_error_log),
- PL_no_mem, strlen(PL_no_mem));
- my_exit(1);
- }
+ if (PL_curinterp)
+ croak_no_mem();
exit(1);
}
+void
+win32_croak_not_implemented(const char * fname)
+{
+ PERL_ARGS_ASSERT_WIN32_CROAK_NOT_IMPLEMENTED;
+
+ Perl_croak_nocontext("%s not implemented!\n", fname);
+}
+
+/* Converts a wide character (UTF-16) string to the Windows ANSI code page,
+ * potentially using the system's default replacement character for any
+ * unrepresentable characters. The caller must free() the returned string. */
+static char*
+wstr_to_str(const wchar_t* wstr)
+{
+ BOOL used_default = FALSE;
+ size_t wlen = wcslen(wstr) + 1;
+ int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wstr, wlen,
+ NULL, 0, NULL, NULL);
+ char* str = (char*)malloc(len);
+ if (!str)
+ out_of_memory();
+ WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wstr, wlen,
+ str, len, NULL, &used_default);
+ return str;
+}
+
/* The win32_ansipath() function takes a Unicode filename and converts it
* into the current Windows codepage. If some characters cannot be mapped,
* then it will convert the short name instead.
@@ -1660,7 +1717,7 @@
size_t widelen = wcslen(widename)+1;
int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
NULL, 0, NULL, NULL);
- name = win32_malloc(len);
+ name = (char*)win32_malloc(len);
if (!name)
out_of_memory();
@@ -1669,7 +1726,7 @@
if (use_default) {
DWORD shortlen = GetShortPathNameW(widename, NULL, 0);
if (shortlen) {
- WCHAR *shortname = win32_malloc(shortlen*sizeof(WCHAR));
+ WCHAR *shortname = (WCHAR*)win32_malloc(shortlen*sizeof(WCHAR));
if (!shortname)
out_of_memory();
shortlen = GetShortPathNameW(widename, shortname, shortlen)+1;
@@ -1676,7 +1733,7 @@
len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
NULL, 0, NULL, NULL);
- name = win32_realloc(name, len);
+ name = (char*)win32_realloc(name, len);
if (!name)
out_of_memory();
WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
@@ -1687,12 +1744,46 @@
return name;
}
+/* the returned string must be freed with win32_freeenvironmentstrings which is
+ * implemented as a macro
+ * void win32_freeenvironmentstrings(void* block)
+ */
DllExport char *
+win32_getenvironmentstrings(void)
+{
+ LPWSTR lpWStr, lpWTmp;
+ LPSTR lpStr, lpTmp;
+ DWORD env_len, wenvstrings_len = 0, aenvstrings_len = 0;
+
+ /* Get the process environment strings */
+ lpWTmp = lpWStr = (LPWSTR) GetEnvironmentStringsW();
+ for (wenvstrings_len = 1; *lpWTmp != '\0'; lpWTmp += env_len + 1) {
+ env_len = wcslen(lpWTmp);
+ /* calculate the size of the environment strings */
+ wenvstrings_len += env_len + 1;
+ }
+
+ /* Get the number of bytes required to store the ACP encoded string */
+ aenvstrings_len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
+ lpWStr, wenvstrings_len, NULL, 0, NULL, NULL);
+ lpTmp = lpStr = (char *)win32_calloc(aenvstrings_len, sizeof(char));
+ if(!lpTmp)
+ out_of_memory();
+
+ /* Convert the string from UTF-16 encoding to ACP encoding */
+ WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, lpWStr, wenvstrings_len, lpStr,
+ aenvstrings_len, NULL, NULL);
+
+ return(lpStr);
+}
+
+DllExport char *
win32_getenv(const char *name)
{
dTHX;
DWORD needlen;
SV *curitem = NULL;
+ DWORD last_err;
needlen = GetEnvironmentVariableA(name,NULL,0);
if (needlen != 0) {
@@ -1705,10 +1796,37 @@
SvCUR_set(curitem, needlen);
}
else {
- /* allow any environment variables that begin with 'PERL'
- to be stored in the registry */
- if (strncmp(name, "PERL", 4) == 0)
- (void)get_regstr(name, &curitem);
+ last_err = GetLastError();
+ if (last_err == ERROR_NOT_ENOUGH_MEMORY) {
+ /* It appears the variable is in the env, but the Win32 API
+ doesn't have a canned way of getting it. So we fall back to
+ grabbing the whole env and pulling this value out if possible */
+ char *envv = GetEnvironmentStrings();
+ char *cur = envv;
+ STRLEN len;
+ while (*cur) {
+ char *end = strchr(cur,'=');
+ if (end && end != cur) {
+ *end = '\0';
+ if (!strcmp(cur,name)) {
+ curitem = sv_2mortal(newSVpv(end+1,0));
+ *end = '=';
+ break;
+ }
+ *end = '=';
+ cur = end + strlen(end+1)+2;
+ }
+ else if ((len = strlen(cur)))
+ cur += len+1;
+ }
+ FreeEnvironmentStrings(envv);
+ }
+ else {
+ /* last ditch: allow any environment variables that begin with 'PERL'
+ to be obtained from the registry, if found there */
+ if (strncmp(name, "PERL", 4) == 0)
+ (void)get_regstr(name, &curitem);
+ }
}
if (curitem && SvCUR(curitem))
return SvPVX(curitem);
@@ -1719,13 +1837,12 @@
DllExport int
win32_putenv(const char *name)
{
- dTHX;
char* curitem;
char* val;
int relval = -1;
if (name) {
- Newx(curitem,strlen(name)+1,char);
+ curitem = (char *) win32_malloc(strlen(name)+1);
strcpy(curitem, name);
val = strchr(curitem, '=');
if (val) {
@@ -1749,7 +1866,7 @@
if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
relval = 0;
}
- Safefree(curitem);
+ win32_free(curitem);
}
return relval;
}
@@ -1969,8 +2086,7 @@
char *arch;
GetSystemInfo(&info);
-#if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \
- || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION) && !defined(__MINGW_EXTENSION))
+#if (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION) && !defined(__MINGW_EXTENSION))
procarch = info.u.s.wProcessorArchitecture;
#else
procarch = info.wProcessorArchitecture;
@@ -2096,13 +2212,33 @@
win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
{
/* We may need several goes at this - so compute when we stop */
- DWORD ticks = 0;
+ FT_t ticks = {0};
+ unsigned __int64 endtime = timeout;
if (timeout != INFINITE) {
- ticks = GetTickCount();
- timeout += ticks;
+ GetSystemTimeAsFileTime(&ticks.ft_val);
+ ticks.ft_i64 /= 10000;
+ endtime += ticks.ft_i64;
}
- while (1) {
- DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_POSTMESSAGE|QS_TIMER|QS_SENDMESSAGE);
+ /* This was a race condition. Do not let a non INFINITE timeout to
+ * MsgWaitForMultipleObjects roll under 0 creating a near
+ * infinity/~(UINT32)0 timeout which will appear as a deadlock to the
+ * user who did a CORE perl function with a non infinity timeout,
+ * sleep for example. This is 64 to 32 truncation minefield.
+ *
+ * This scenario can only be created if the timespan from the return of
+ * MsgWaitForMultipleObjects to GetSystemTimeAsFileTime exceeds 1 ms. To
+ * generate the scenario, manual breakpoints in a C debugger are required,
+ * or a context switch occured in win32_async_check in PeekMessage, or random
+ * messages are delivered to the *thread* message queue of the Perl thread
+ * from another process (msctf.dll doing IPC among its instances, VS debugger
+ * causes msctf.dll to be loaded into Perl by kernel), see [perl #33096].
+ */
+ while (ticks.ft_i64 <= endtime) {
+ /* if timeout's type is lengthened, remember to split 64b timeout
+ * into multiple non-infinity runs of MWFMO */
+ DWORD result = MsgWaitForMultipleObjects(count, handles, FALSE,
+ (DWORD)(endtime - ticks.ft_i64),
+ QS_POSTMESSAGE|QS_TIMER|QS_SENDMESSAGE);
if (resultp)
*resultp = result;
if (result == WAIT_TIMEOUT) {
@@ -2112,8 +2248,9 @@
return 0;
}
if (timeout != INFINITE) {
- ticks = GetTickCount();
- }
+ GetSystemTimeAsFileTime(&ticks.ft_val);
+ ticks.ft_i64 /= 10000;
+ }
if (result == WAIT_OBJECT_0 + count) {
/* Message has arrived - check it */
(void)win32_async_check(aTHX);
@@ -2123,19 +2260,21 @@
break;
}
}
+ /* If we are past the end say zero */
+ if (!ticks.ft_i64 || ticks.ft_i64 > endtime)
+ return 0;
/* compute time left to wait */
- ticks = timeout - ticks;
- /* If we are past the end say zero */
- return (ticks > 0) ? ticks : 0;
+ ticks.ft_i64 = endtime - ticks.ft_i64;
+ /* if more ms than DWORD, then return max DWORD */
+ return ticks.ft_i64 <= UINT_MAX ? (DWORD)ticks.ft_i64 : UINT_MAX;
}
int
-win32_internal_wait(int *status, DWORD timeout)
+win32_internal_wait(pTHX_ int *status, DWORD timeout)
{
/* XXX this wait emulation only knows about processes
* spawned via win32_spawnvp(P_NOWAIT, ...).
*/
- dTHX;
int i, retval;
DWORD exitcode, waitcode;
@@ -2201,10 +2340,10 @@
int retval = -1;
long child;
if (pid == -1) /* XXX threadid == 1 ? */
- return win32_internal_wait(status, timeout);
+ return win32_internal_wait(aTHX_ status, timeout);
#ifdef USE_ITHREADS
else if (pid < 0) {
- child = find_pseudo_pid(-pid);
+ child = find_pseudo_pid(aTHX_ -pid);
if (child >= 0) {
HANDLE hThread = w32_pseudo_child_handles[child];
DWORD waitcode;
@@ -2228,7 +2367,7 @@
else {
HANDLE hProcess;
DWORD waitcode;
- child = find_pid(pid);
+ child = find_pid(aTHX_ pid);
if (child >= 0) {
hProcess = w32_child_handles[child];
win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
@@ -2273,7 +2412,8 @@
DllExport int
win32_wait(int *status)
{
- return win32_internal_wait(status, INFINITE);
+ dTHX;
+ return win32_internal_wait(aTHX_ status, INFINITE);
}
DllExport unsigned int
@@ -2281,7 +2421,11 @@
{
dTHX;
/* Win32 times are in ms so *1000 in and /1000 out */
- return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
+ if (t > UINT_MAX / 1000) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
+ "sleep(%lu) too large", t);
+ }
+ return win32_msgwait(aTHX_ 0, NULL, t * 1000, NULL) / 1000;
}
DllExport unsigned int
@@ -2436,15 +2580,16 @@
DllExport char *
win32_strerror(int e)
{
-#if !defined __BORLANDC__ && !defined __MINGW32__ /* compiler intolerance */
+#if !defined __MINGW32__ /* compiler intolerance */
extern int sys_nerr;
#endif
if (e < 0 || e > sys_nerr) {
- dTHX;
+ dTHXa(NULL);
if (e < 0)
e = GetLastError();
+ aTHXa(PERL_GET_THX);
if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM
|FORMAT_MESSAGE_IGNORE_INSERTS, NULL, e, 0,
w32_strerror_buffer, sizeof(w32_strerror_buffer),
@@ -2538,7 +2683,7 @@
DllExport FILE *
win32_fopen(const char *filename, const char *mode)
{
- dTHX;
+ dTHXa(NULL);
FILE *f;
if (!*filename)
@@ -2547,6 +2692,7 @@
if (stricmp(filename, "/dev/null")==0)
filename = "NUL";
+ aTHXa(PERL_GET_THX);
f = fopen(PerlDir_mapA(filename), mode);
/* avoid buffering headaches for child processes */
if (f && *mode == 'a')
@@ -2554,15 +2700,9 @@
return f;
}
-#ifndef USE_SOCKETS_AS_HANDLES
-#undef fdopen
-#define fdopen my_fdopen
-#endif
-
DllExport FILE *
win32_fdopen(int handle, const char *mode)
{
- dTHX;
FILE *f;
f = fdopen(handle, (char *) mode);
/* avoid buffering headaches for child processes */
@@ -2574,10 +2714,11 @@
DllExport FILE *
win32_freopen(const char *path, const char *mode, FILE *stream)
{
- dTHX;
+ dTHXa(NULL);
if (stricmp(path, "/dev/null")==0)
path = "NUL";
+ aTHXa(PERL_GET_THX);
return freopen(PerlDir_mapA(path), mode, stream);
}
@@ -2584,7 +2725,11 @@
DllExport int
win32_fclose(FILE *pf)
{
+#ifdef WIN32_NO_SOCKETS
+ return fclose(pf);
+#else
return my_fclose(pf); /* defined in win32sck.c */
+#endif
}
DllExport int
@@ -2634,14 +2779,10 @@
win32_ftell(FILE *pf)
{
#if defined(WIN64) || defined(USE_LARGE_FILES)
-#if defined(__BORLANDC__) /* buk */
- return win32_tell( fileno( pf ) );
-#else
fpos_t pos;
if (fgetpos(pf, &pos))
return -1;
return (Off_t)pos;
-#endif
#else
return ftell(pf);
#endif
@@ -2651,13 +2792,6 @@
win32_fseek(FILE *pf, Off_t offset,int origin)
{
#if defined(WIN64) || defined(USE_LARGE_FILES)
-#if defined(__BORLANDC__) /* buk */
- return win32_lseek(
- fileno(pf),
- offset,
- origin
- );
-#else
fpos_t pos;
switch (origin) {
case SEEK_CUR:
@@ -2677,7 +2811,6 @@
return -1;
}
return fsetpos(pf, &offset);
-#endif
#else
return fseek(pf, (long)offset, origin);
#endif
@@ -2686,25 +2819,13 @@
DllExport int
win32_fgetpos(FILE *pf,fpos_t *p)
{
-#if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
- if( win32_tell(fileno(pf)) == -1L ) {
- errno = EBADF;
- return -1;
- }
- return 0;
-#else
return fgetpos(pf, p);
-#endif
}
DllExport int
win32_fsetpos(FILE *pf,const fpos_t *p)
{
-#if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
- return win32_lseek(fileno(pf), *p, SEEK_CUR);
-#else
return fsetpos(pf, p);
-#endif
}
DllExport void
@@ -2717,7 +2838,6 @@
DllExport int
win32_tmpfd(void)
{
- dTHX;
char prefix[MAX_PATH+1];
char filename[MAX_PATH+1];
DWORD len = GetTempPath(MAX_PATH, prefix);
@@ -2734,9 +2854,7 @@
if (fh != INVALID_HANDLE_VALUE) {
int fd = win32_open_osfhandle((intptr_t)fh, 0);
if (fd >= 0) {
-#if defined(__BORLANDC__)
- setmode(fd,O_BINARY);
-#endif
+ PERL_DEB(dTHX;)
DEBUG_p(PerlIO_printf(Perl_debug_log,
"Created tmpfile=%s\n",filename));
return fd;
@@ -2766,50 +2884,10 @@
DllExport int
win32_fstat(int fd, Stat_t *sbufptr)
{
-#ifdef __BORLANDC__
- /* A file designated by filehandle is not shown as accessible
- * for write operations, probably because it is opened for reading.
- * --Vadim Konovalov
- */
- BY_HANDLE_FILE_INFORMATION bhfi;
-# if defined(WIN64) || defined(USE_LARGE_FILES)
- /* Borland 5.5.1 has a 64-bit stat, but only a 32-bit fstat */
- struct stat tmp;
- int rc = fstat(fd,&tmp);
-
- sbufptr->st_dev = tmp.st_dev;
- sbufptr->st_ino = tmp.st_ino;
- sbufptr->st_mode = tmp.st_mode;
- sbufptr->st_nlink = tmp.st_nlink;
- sbufptr->st_uid = tmp.st_uid;
- sbufptr->st_gid = tmp.st_gid;
- sbufptr->st_rdev = tmp.st_rdev;
- sbufptr->st_size = tmp.st_size;
- sbufptr->st_atime = tmp.st_atime;
- sbufptr->st_mtime = tmp.st_mtime;
- sbufptr->st_ctime = tmp.st_ctime;
-# else
- int rc = fstat(fd,sbufptr);
-# endif
-
- if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
-# if defined(WIN64) || defined(USE_LARGE_FILES)
- sbufptr->st_size = ((__int64)bhfi.nFileSizeHigh << 32) | bhfi.nFileSizeLow ;
-# endif
- sbufptr->st_mode &= 0xFE00;
- if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
- sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
- else
- sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
- + ((S_IREAD|S_IWRITE) >> 6));
- }
- return rc;
+#if defined(WIN64) || defined(USE_LARGE_FILES)
+ return _fstati64(fd, sbufptr);
#else
-# if defined(WIN64) || defined(USE_LARGE_FILES)
- return _fstati64(fd, sbufptr);
-# else
return fstat(fd, sbufptr);
-# endif
#endif
}
@@ -2822,8 +2900,7 @@
DllExport PerlIO*
win32_popenlist(const char *mode, IV narg, SV **args)
{
- dTHX;
- Perl_croak(aTHX_ "List form of pipe open not implemented");
+ Perl_croak_nocontext("List form of pipe open not implemented");
return NULL;
}
@@ -2839,7 +2916,6 @@
#ifdef USE_RTL_POPEN
return _popen(command, mode);
#else
- dTHX;
int p[2];
int parent, child;
int stdfd, oldfd;
@@ -2992,18 +3068,48 @@
DllExport int
win32_link(const char *oldname, const char *newname)
{
- dTHX;
+ dTHXa(NULL);
WCHAR wOldName[MAX_PATH+1];
WCHAR wNewName[MAX_PATH+1];
if (MultiByteToWideChar(CP_ACP, 0, oldname, -1, wOldName, MAX_PATH+1) &&
MultiByteToWideChar(CP_ACP, 0, newname, -1, wNewName, MAX_PATH+1) &&
- (wcscpy(wOldName, PerlDir_mapW(wOldName)),
+ ((aTHXa(PERL_GET_THX)), wcscpy(wOldName, PerlDir_mapW(wOldName)),
CreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
{
return 0;
}
- errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
+ /* This isn't perfect, eg. Win32 returns ERROR_ACCESS_DENIED for
+ both permissions errors and if the source is a directory, while
+ POSIX wants EACCES and EPERM respectively.
+
+ Determined by experimentation on Windows 7 x64 SP1, since MS
+ don't document what error codes are returned.
+ */
+ switch (GetLastError()) {
+ case ERROR_BAD_NET_NAME:
+ case ERROR_BAD_NETPATH:
+ case ERROR_BAD_PATHNAME:
+ case ERROR_FILE_NOT_FOUND:
+ case ERROR_FILENAME_EXCED_RANGE:
+ case ERROR_INVALID_DRIVE:
+ case ERROR_PATH_NOT_FOUND:
+ errno = ENOENT;
+ break;
+ case ERROR_ALREADY_EXISTS:
+ errno = EEXIST;
+ break;
+ case ERROR_ACCESS_DENIED:
+ errno = EACCES;
+ break;
+ case ERROR_NOT_SAME_DEVICE:
+ errno = EXDEV;
+ break;
+ default:
+ /* ERROR_INVALID_FUNCTION - eg. on a FAT volume */
+ errno = EINVAL;
+ break;
+ }
return -1;
}
@@ -3101,23 +3207,7 @@
win32_lseek(int fd, Off_t offset, int origin)
{
#if defined(WIN64) || defined(USE_LARGE_FILES)
-#if defined(__BORLANDC__) /* buk */
- LARGE_INTEGER pos;
- pos.QuadPart = offset;
- pos.LowPart = SetFilePointer(
- (HANDLE)_get_osfhandle(fd),
- pos.LowPart,
- &pos.HighPart,
- origin
- );
- if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
- pos.QuadPart = -1;
- }
-
- return pos.QuadPart;
-#else
return _lseeki64(fd, offset, origin);
-#endif
#else
return lseek(fd, (long)offset, origin);
#endif
@@ -3127,24 +3217,7 @@
win32_tell(int fd)
{
#if defined(WIN64) || defined(USE_LARGE_FILES)
-#if defined(__BORLANDC__) /* buk */
- LARGE_INTEGER pos;
- pos.QuadPart = 0;
- pos.LowPart = SetFilePointer(
- (HANDLE)_get_osfhandle(fd),
- pos.LowPart,
- &pos.HighPart,
- FILE_CURRENT
- );
- if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
- pos.QuadPart = -1;
- }
-
- return pos.QuadPart;
- /* return tell(fd); */
-#else
return _telli64(fd);
-#endif
#else
return tell(fd);
#endif
@@ -3153,7 +3226,7 @@
DllExport int
win32_open(const char *path, int flag, ...)
{
- dTHX;
+ dTHXa(NULL);
va_list ap;
int pmode;
@@ -3164,6 +3237,7 @@
if (stricmp(path, "/dev/null")==0)
path = "NUL";
+ aTHXa(PERL_GET_THX);
return open(PerlDir_mapA(path), flag, pmode);
}
@@ -3173,7 +3247,11 @@
DllExport int
win32_close(int fd)
{
+#ifdef WIN32_NO_SOCKETS
+ return close(fd);
+#else
return my_close(fd);
+#endif
}
DllExport int
@@ -3244,7 +3322,6 @@
DllExport int
win32_chdir(const char *dir)
{
- dTHX;
if (!dir) {
errno = ENOENT;
return -1;
@@ -3270,7 +3347,7 @@
static char *
create_command_line(char *cname, STRLEN clen, const char * const *args)
{
- dTHX;
+ PERL_DEB(dTHX;)
int index, argc;
char *cmd, *ptr;
const char *arg;
@@ -3425,7 +3502,6 @@
static char *
qualified_path(const char *cmd)
{
- dTHX;
char *pathstr;
char *fullcmd, *curfullcmd;
STRLEN cmdlen = 0;
@@ -3442,8 +3518,10 @@
}
/* look in PATH */
- pathstr = PerlEnv_getenv("PATH");
-
+ {
+ dTHX;
+ pathstr = PerlEnv_getenv("PATH");
+ }
/* worst case: PATH is a single directory; we need additional space
* to append "/", ".exe" and trailing "\0" */
Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
@@ -3549,7 +3627,6 @@
DllExport char*
win32_get_childdir(void)
{
- dTHX;
char* ptr;
char szfilename[MAX_PATH+1];
@@ -3562,7 +3639,6 @@
DllExport void
win32_free_childdir(char* d)
{
- dTHX;
Safefree(d);
}
@@ -3584,7 +3660,7 @@
#ifdef USE_RTL_SPAWNVP
return spawnvp(mode, cmdname, (char * const *)argv);
#else
- dTHX;
+ dTHXa(NULL);
int ret;
void* env;
char* dir;
@@ -3617,6 +3693,7 @@
cmd = create_command_line(cname, clen, argv);
+ aTHXa(PERL_GET_THX);
env = PerlEnv_get_childenv();
dir = PerlEnv_get_childdir();
@@ -3746,17 +3823,9 @@
/* if this is a pseudo-forked child, we just want to spawn
* the new program, and return */
if (w32_pseudo_id)
-# ifdef __BORLANDC__
- return spawnv(P_WAIT, cmdname, (char *const *)argv);
-# else
return spawnv(P_WAIT, cmdname, argv);
-# endif
#endif
-#ifdef __BORLANDC__
- return execv(cmdname, (char *const *)argv);
-#else
return execv(cmdname, argv);
-#endif
}
DllExport int
@@ -3776,11 +3845,7 @@
return status;
}
#endif
-#ifdef __BORLANDC__
- return execvp(cmdname, (char *const *)argv);
-#else
return execvp(cmdname, argv);
-#endif
}
DllExport void
@@ -3999,21 +4064,6 @@
int fileno = win32_dup(win32_fileno(pf));
/* open the file in the same mode */
-#ifdef __BORLANDC__
- if((pf)->flags & _F_READ) {
- mode[0] = 'r';
- mode[1] = 0;
- }
- else if((pf)->flags & _F_WRIT) {
- mode[0] = 'a';
- mode[1] = 0;
- }
- else if((pf)->flags & _F_RDWR) {
- mode[0] = 'r';
- mode[1] = '+';
- mode[2] = 0;
- }
-#else
if((pf)->_flag & _IOREAD) {
mode[0] = 'r';
mode[1] = 0;
@@ -4027,7 +4077,6 @@
mode[1] = '+';
mode[2] = 0;
}
-#endif
/* it appears that the binmode is attached to the
* file descriptor so binmode files will be handled
@@ -4045,9 +4094,9 @@
DllExport void*
win32_dynaload(const char* filename)
{
- dTHX;
+ dTHXa(NULL);
char buf[MAX_PATH+1];
- char *first;
+ const char *first;
/* LoadLibrary() doesn't recognize forward slashes correctly,
* so turn 'em back. */
@@ -4065,6 +4114,7 @@
filename = buf;
}
}
+ aTHXa(PERL_GET_THX);
return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
}
@@ -4096,19 +4146,19 @@
void
Perl_init_os_extras(void)
{
- dTHX;
+ dTHXa(NULL);
char *file = __FILE__;
/* Initialize Win32CORE if it has been statically linked. */
+#ifndef PERL_IS_MINIPERL
void (*pfn_init)(pTHX);
-#if defined(__BORLANDC__)
- /* makedef.pl seems to have given up on fixing this issue in the .def file */
- pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "_init_Win32CORE");
-#else
pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "init_Win32CORE");
-#endif
+ aTHXa(PERL_GET_THX);
if (pfn_init)
pfn_init(aTHX);
+#else
+ aTHXa(PERL_GET_THX);
+#endif
newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
}
@@ -4196,13 +4246,17 @@
/* fetch Unicode version of PATH */
len = 2000;
- wide_path = win32_malloc(len*sizeof(WCHAR));
+ wide_path = (WCHAR*)win32_malloc(len*sizeof(WCHAR));
while (wide_path) {
size_t newlen = GetEnvironmentVariableW(L"PATH", wide_path, len);
+ if (newlen == 0) {
+ win32_free(wide_path);
+ return;
+ }
if (newlen < len)
break;
len = newlen;
- wide_path = win32_realloc(wide_path, len*sizeof(WCHAR));
+ wide_path = (WCHAR*)win32_realloc(wide_path, len*sizeof(WCHAR));
}
if (!wide_path)
return;
@@ -4231,7 +4285,7 @@
ansi_len = strlen(ansi_dir);
if (ansi_path) {
size_t newlen = len + 1 + ansi_len;
- ansi_path = win32_realloc(ansi_path, newlen+1);
+ ansi_path = (char*)win32_realloc(ansi_path, newlen+1);
if (!ansi_path)
break;
ansi_path[len] = ';';
@@ -4240,7 +4294,7 @@
}
else {
len = ansi_len;
- ansi_path = win32_malloc(5+len+1);
+ ansi_path = (char*)win32_malloc(5+len+1);
if (!ansi_path)
break;
memcpy(ansi_path, "PATH=", 5);
@@ -4270,7 +4324,7 @@
*/
SetEnvironmentVariableA("PATH", ansi_path+5);
/* We are intentionally leaking the ansi_path string here because
- * the Borland runtime library puts it directly into the environ
+ * the some runtime libraries puts it directly into the environ
* array. The Microsoft runtime library seems to make a copy,
* but will leak the copy should it be replaced again later.
* Since this code is only called once during PERL_SYS_INIT this
@@ -4291,7 +4345,7 @@
#endif
/* Disable floating point errors, Perl will trap the ones we
* care about. VC++ RTL defaults to switching these off
- * already, but the Borland RTL doesn't. Since we don't
+ * already, but some RTLs don't. Since we don't
* want to be at the vendor's whim on the default, we set
* it explicitly here.
*/
@@ -4319,7 +4373,6 @@
void
Perl_win32_term(void)
{
- dTHX;
HINTS_REFCNT_TERM;
OP_REFCNT_TERM;
PERLIO_TERM;
@@ -4337,10 +4390,20 @@
Sighandler_t
win32_signal(int sig, Sighandler_t subcode)
{
- dTHX;
+ dTHXa(NULL);
if (sig < SIG_SIZE) {
int save_errno = errno;
- Sighandler_t result = signal(sig, subcode);
+ Sighandler_t result;
+#ifdef SET_INVALID_PARAMETER_HANDLER
+ /* Silence our invalid parameter handler since we expect to make some
+ * calls with invalid signal numbers giving a SIG_ERR result. */
+ BOOL oldvalue = set_silent_invalid_parameter_handler(TRUE);
+#endif
+ result = signal(sig, subcode);
+#ifdef SET_INVALID_PARAMETER_HANDLER
+ set_silent_invalid_parameter_handler(oldvalue);
+#endif
+ aTHXa(PERL_GET_THX);
if (result == SIG_ERR) {
result = w32_sighandler[sig];
errno = save_errno;
@@ -4380,14 +4443,14 @@
* are relativley infrequent code-paths, is better than the added
* complexity of getting the correct context passed into
* win32_create_message_window() */
+ dTHX;
switch(msg) {
#ifdef USE_ITHREADS
case WM_USER_MESSAGE: {
- long child = find_pseudo_pid((int)wParam);
+ long child = find_pseudo_pid(aTHX_ (int)wParam);
if (child >= 0) {
- dTHX;
w32_pseudo_child_message_hwnds[child] = (HWND)lParam;
return 1;
}
@@ -4396,7 +4459,6 @@
#endif
case WM_USER_KILL: {
- dTHX;
/* We use WM_USER_KILL to fake kill() with other signals */
int sig = (int)wParam;
if (do_raise(aTHX_ sig))
@@ -4406,7 +4468,6 @@
}
case WM_TIMER: {
- dTHX;
/* alarm() is a one-shot but SetTimer() repeats so kill it */
if (w32_timerid && w32_timerid==(UINT)wParam) {
KillTimer(w32_message_hwnd, w32_timerid);
Property changes on: trunk/contrib/perl/win32/win32.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/win32/win32.h
===================================================================
--- trunk/contrib/perl/win32/win32.h 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/win32.h 2013-12-02 21:26:09 UTC (rev 6439)
@@ -13,6 +13,38 @@
# define _WIN32_WINNT 0x0500 /* needed for CreateHardlink() etc. */
#endif
+#ifdef PERL_IS_MINIPERL
+/* this macro will remove Winsock only on miniperl, PERL_IMPLICIT_SYS and
+ * makedef.pl create dependencies that will keep Winsock linked in even with
+ * this macro defined, even though sockets will be umimplemented from a script
+ * level in full perl
+ */
+# define WIN32_NO_SOCKETS
+#endif
+
+#ifdef WIN32_NO_SOCKETS
+# undef HAS_SOCKET
+# undef HAS_GETPROTOBYNAME
+# undef HAS_GETPROTOBYNUMBER
+# undef HAS_GETPROTOENT
+# undef HAS_GETNETBYNAME
+# undef HAS_GETNETBYADDR
+# undef HAS_GETNETENT
+# undef HAS_GETSERVBYNAME
+# undef HAS_GETSERVBYPORT
+# undef HAS_GETSERVENT
+# undef HAS_GETHOSTBYNAME
+# undef HAS_GETHOSTBYADDR
+# undef HAS_GETHOSTENT
+# undef HAS_SELECT
+# undef HAS_IOCTL
+# undef HAS_NTOHL
+# undef HAS_HTONL
+# undef HAS_HTONS
+# undef HAS_NTOHS
+# define WIN32SCK_IS_STDSCK
+#endif
+
#if defined(PERL_IMPLICIT_SYS)
# define DYNAMIC_ENV_FETCH
# define HAS_GETENV_LEN
@@ -46,12 +78,15 @@
*/
/* now even GCC supports __declspec() */
-
-#if defined(PERLDLL)
-#define DllExport
-/*#define DllExport __declspec(dllexport)*/ /* noises with VC5+sp3 */
+/* miniperl has no reason to export anything */
+#if defined(PERL_IS_MINIPERL) && !defined(UNDER_CE) && defined(_MSC_VER)
+# define DllExport
#else
-#define DllExport __declspec(dllimport)
+# if defined(PERLDLL)
+# define DllExport __declspec(dllexport)
+# else
+# define DllExport __declspec(dllimport)
+# endif
#endif
/* The Perl APIs can only be called directly inside the perl5xx.dll.
@@ -66,11 +101,26 @@
#if !defined(PERLDLL) && !defined(PERL_EXT_RE_BUILD)
# ifdef __cplusplus
# define PERL_CALLCONV extern "C" __declspec(dllimport)
+# ifdef _MSC_VER
+# define PERL_CALLCONV_NO_RET extern "C" __declspec(dllimport) __declspec(noreturn)
+# endif
# else
# define PERL_CALLCONV __declspec(dllimport)
+# ifdef _MSC_VER
+# define PERL_CALLCONV_NO_RET __declspec(dllimport) __declspec(noreturn)
+# endif
# endif
+#else /* MSVC noreturn support inside the interp */
+# ifdef _MSC_VER
+# define PERL_CALLCONV_NO_RET __declspec(noreturn)
+# endif
#endif
+#ifdef _MSC_VER
+# define PERL_STATIC_NO_RET __declspec(noreturn) static
+# define PERL_STATIC_INLINE_NO_RET __declspec(noreturn) PERL_STATIC_INLINE
+#endif
+
#define WIN32_LEAN_AND_MEAN
#include <windows.h>
@@ -147,34 +197,18 @@
#define DOSISH 1 /* no escaping our roots */
#define OP_BINARY O_BINARY /* mistake in in pp_sys.c? */
-/* Define USE_SOCKETS_AS_HANDLES to enable emulation of windows sockets as
- * real filehandles. XXX Should always be defined (the other version is untested) */
-#define USE_SOCKETS_AS_HANDLES
-
/* read() and write() aren't transparent for socket handles */
-#define PERL_SOCK_SYSREAD_IS_RECV
-#define PERL_SOCK_SYSWRITE_IS_SEND
+#ifndef WIN32_NO_SOCKETS
+# define PERL_SOCK_SYSREAD_IS_RECV
+# define PERL_SOCK_SYSWRITE_IS_SEND
+#endif
#define PERL_NO_FORCE_LINK /* no need for PL_force_link_funcs */
-/* Define PERL_WIN32_SOCK_DLOAD to have Perl dynamically load the winsock
- DLL when needed. Don't use if your compiler supports delayloading (ie, VC++ 6.0)
- -- BKS 5-29-2000 */
-#if !(defined(_M_IX86) && _MSC_VER >= 1200)
-#define PERL_WIN32_SOCK_DLOAD
-#endif
#define ENV_IS_CASELESS
#define PIPESOCK_MODE "b" /* pipes, sockets default to binmode */
-#ifndef VER_PLATFORM_WIN32_WINDOWS /* VC-2.0 headers don't have this */
-#define VER_PLATFORM_WIN32_WINDOWS 1
-#endif
-
-#ifndef FILE_SHARE_DELETE /* VC-4.0 headers don't have this */
-#define FILE_SHARE_DELETE 0x00000004
-#endif
-
/* access() mode bits */
#ifndef R_OK
# define R_OK 4
@@ -192,46 +226,12 @@
/* Compiler-specific stuff. */
-#if defined(_MSC_VER) || defined(__MINGW32__)
/* VC uses non-standard way to determine the size and alignment if bit-fields */
-/* MinGW will compiler with -mms-bitfields, so should use the same types */
-# define PERL_BITFIELD8 unsigned char
-# define PERL_BITFIELD16 unsigned short
-# define PERL_BITFIELD32 unsigned int
-#endif
+/* MinGW will compile with -mms-bitfields, so should use the same types */
+#define PERL_BITFIELD8 unsigned char
+#define PERL_BITFIELD16 unsigned short
+#define PERL_BITFIELD32 unsigned int
-#ifdef __BORLANDC__ /* Borland C++ */
-
-#if (__BORLANDC__ <= 0x520)
-#define _access access
-#define _chdir chdir
-#endif
-
-#define _getpid getpid
-#define wcsicmp _wcsicmp
-#include <sys/types.h>
-
-#ifndef DllMain
-#define DllMain DllEntryPoint
-#endif
-
-#pragma warn -8004 /* "'foo' is assigned a value that is never used" */
-#pragma warn -8008 /* "condition is always true/false" */
-#pragma warn -8012 /* "comparing signed and unsigned values" */
-#pragma warn -8027 /* "functions containing %s are not expanded inline" */
-#pragma warn -8057 /* "parameter 'foo' is never used" */
-#pragma warn -8060 /* "possibly incorrect assignment" */
-#pragma warn -8066 /* "unreachable code" */
-#pragma warn -8071 /* "conversion may lose significant digits" */
-#pragma warn -8080 /* "'foo' is declared but never used" */
-
-/* Borland C thinks that a pointer to a member variable is 12 bytes in size. */
-#define PERL_MEMBER_PTR_SIZE 12
-
-#define isnan _isnan
-
-#endif
-
#ifdef _MSC_VER /* Microsoft Visual C++ */
#ifndef UNDER_CE
@@ -242,9 +242,6 @@
#pragma warning(disable: 4102) /* "unreferenced label" */
-/* Visual C thinks that a pointer to a member variable is 16 bytes in size. */
-#define PERL_MEMBER_PTR_SIZE 16
-
#define isnan _isnan
#define snprintf _snprintf
#define vsnprintf _vsnprintf
@@ -287,14 +284,11 @@
# endif
#endif
-#endif /* __MINGW32__ */
-
-/* both GCC/Mingw32 and MSVC++ 4.0 are missing this, so we put it here */
#ifndef CP_UTF8
# define CP_UTF8 65001
#endif
-/* compatibility stuff for other compilers goes here */
+#endif /* __MINGW32__ */
#ifndef _INTPTR_T_DEFINED
typedef int intptr_t;
@@ -310,6 +304,7 @@
/* For UNIX compatibility. */
+#ifdef PERL_CORE
extern uid_t getuid(void);
extern gid_t getgid(void);
extern uid_t geteuid(void);
@@ -325,6 +320,7 @@
extern char * getlogin(void);
extern int chown(const char *p, uid_t o, gid_t g);
extern int mkstemp(const char *path);
+#endif
#undef Stat
#define Stat win32_stat
@@ -364,9 +360,6 @@
DllExport void win32_get_child_IO(child_IO_table* ptr);
DllExport HWND win32_create_message_window(void);
-#ifndef USE_SOCKETS_AS_HANDLES
-extern FILE * my_fdopen(int, char *);
-#endif
extern int my_fclose(FILE *);
extern char * win32_get_privlib(const char *pl, STRLEN *const len);
extern char * win32_get_sitelib(const char *pl, STRLEN *const len);
@@ -376,7 +369,7 @@
extern void win32_delete_internal_host(void *h);
#endif
-extern char * staticlinkmodules[];
+extern const char * const staticlinkmodules[];
END_EXTERN_C
@@ -419,9 +412,7 @@
char Wstrerror_buffer[512];
struct servent Wservent;
char Wgetlogin_buffer[128];
-# ifdef USE_SOCKETS_AS_HANDLES
int Winit_socktype;
-# endif
char Wcrypt_buffer[30];
# ifdef USE_RTL_THREAD_API
void * retv; /* slot for thread return value */
Property changes on: trunk/contrib/perl/win32/win32.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/win32/win32ceio.c
===================================================================
--- trunk/contrib/perl/win32/win32ceio.c 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/win32ceio.c 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/win32/win32ceio.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/win32/win32io.c
===================================================================
--- trunk/contrib/perl/win32/win32io.c 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/win32io.c 2013-12-02 21:26:09 UTC (rev 6439)
@@ -317,11 +317,11 @@
{
PerlIOWin32 *os = PerlIOSelf(f,PerlIOWin32);
HANDLE proc = GetCurrentProcess();
- HANDLE new;
- if (DuplicateHandle(proc, os->h, proc, &new, 0, FALSE, DUPLICATE_SAME_ACCESS))
+ HANDLE new_h;
+ if (DuplicateHandle(proc, os->h, proc, &new_h, 0, FALSE, DUPLICATE_SAME_ACCESS))
{
char mode[8];
- int fd = win32_open_osfhandle((intptr_t) new, PerlIOUnix_oflags(PerlIO_modestr(o,mode)));
+ int fd = win32_open_osfhandle((intptr_t) new_h, PerlIOUnix_oflags(PerlIO_modestr(o,mode)));
if (fd >= 0)
{
f = PerlIOBase_dup(aTHX_ f, o, params, flags);
@@ -328,7 +328,7 @@
if (f)
{
PerlIOWin32 *fs = PerlIOSelf(f,PerlIOWin32);
- fs->h = new;
+ fs->h = new_h;
fs->fd = fd;
fs->refcnt = 1;
fdtable[fd] = fs;
@@ -342,7 +342,7 @@
}
else
{
- CloseHandle(new);
+ CloseHandle(new_h);
}
}
return f;
Property changes on: trunk/contrib/perl/win32/win32io.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/win32/win32iop-o.h
===================================================================
--- trunk/contrib/perl/win32/win32iop-o.h 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/win32iop-o.h 2013-12-02 21:26:09 UTC (rev 6439)
@@ -16,12 +16,8 @@
#endif
#ifndef UNDER_CE
-#if defined(_MSC_VER) || defined(__MINGW32__)
-# include <sys/utime.h>
-#else
-# include <utime.h>
+#include <sys/utime.h>
#endif
-#endif
/*
* defines for flock emulation
@@ -178,15 +174,6 @@
#undef uname
#undef wait
-#ifdef __BORLANDC__
-#undef ungetc
-#undef getc
-#undef putc
-#undef getchar
-#undef putchar
-#undef fileno
-#endif
-
#define stderr win32_stderr()
#define stdout win32_stdout()
#define stdin win32_stdin()
Property changes on: trunk/contrib/perl/win32/win32iop-o.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/win32/win32iop.h
===================================================================
--- trunk/contrib/perl/win32/win32iop.h 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/win32iop.h 2013-12-02 21:26:09 UTC (rev 6439)
@@ -13,11 +13,7 @@
#endif
#endif
-#if defined(_MSC_VER) || defined(__MINGW32__)
-# include <sys/utime.h>
-#else
-# include <utime.h>
-#endif
+#include <sys/utime.h>
/*
* defines for flock emulation
@@ -126,6 +122,8 @@
DllExport int win32_closedir(DIR *dirp);
DllExport DIR* win32_dirp_dup(DIR *const dirp, CLONE_PARAMS *const param);
+DllExport char* win32_getenvironmentstrings(void);
+/* also see win32_freeenvironmentstrings macro */
DllExport char* win32_getenv(const char *name);
DllExport int win32_putenv(const char *name);
@@ -162,6 +160,8 @@
END_EXTERN_C
+/* see comment in win32_getenvironmentstrings */
+#define win32_freeenvironmentstrings(x) win32_free(x)
#undef alarm
#define alarm win32_alarm
#undef strerror
@@ -190,15 +190,7 @@
#undef uname
#undef wait
-#ifdef __BORLANDC__
-#undef ungetc
-#undef getc
-#undef putc
-#undef getchar
-#undef putchar
-#endif
-
-#if defined(__MINGW32__) || defined(__BORLANDC__)
+#if defined(__MINGW32__)
#undef fileno
#endif
Property changes on: trunk/contrib/perl/win32/win32iop.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/win32/win32sck.c
===================================================================
--- trunk/contrib/perl/win32/win32sck.c 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/win32sck.c 2013-12-02 21:26:09 UTC (rev 6439)
@@ -29,13 +29,8 @@
#include <io.h>
/* thanks to Beverly Brown (beverly at datacube.com) */
-#ifdef USE_SOCKETS_AS_HANDLES
-# define OPEN_SOCKET(x) win32_open_osfhandle(x,O_RDWR|O_BINARY)
-# define TO_SOCKET(x) _get_osfhandle(x)
-#else
-# define OPEN_SOCKET(x) (x)
-# define TO_SOCKET(x) (x)
-#endif /* USE_SOCKETS_AS_HANDLES */
+#define OPEN_SOCKET(x) win32_open_osfhandle(x,O_RDWR|O_BINARY)
+#define TO_SOCKET(x) _get_osfhandle(x)
#define StartSockets() \
STMT_START { \
@@ -68,7 +63,6 @@
void
start_sockets(void)
{
- dTHX;
unsigned short version;
WSADATA retdata;
int ret;
@@ -87,48 +81,17 @@
wsock_started = 1;
}
-#ifndef USE_SOCKETS_AS_HANDLES
-#undef fdopen
-FILE *
-my_fdopen(int fd, char *mode)
-{
- FILE *fp;
- char sockbuf[256];
- int optlen = sizeof(sockbuf);
- int retval;
-
- if (!wsock_started)
- return(fdopen(fd, mode));
-
- retval = getsockopt((SOCKET)fd, SOL_SOCKET, SO_TYPE, sockbuf, &optlen);
- if(retval == SOCKET_ERROR && WSAGetLastError() == WSAENOTSOCK) {
- return(fdopen(fd, mode));
- }
-
- /*
- * If we get here, then fd is actually a socket.
- */
- Newxz(fp, 1, FILE); /* XXX leak, good thing this code isn't used */
- if(fp == NULL) {
- errno = ENOMEM;
- return NULL;
- }
-
- fp->_file = fd;
- if(*mode == 'r')
- fp->_flag = _IOREAD;
- else
- fp->_flag = _IOWRT;
-
- return fp;
-}
-#endif /* USE_SOCKETS_AS_HANDLES */
-
-
+/* in no sockets Win32 builds, this fowards to replacements in util.c, dTHX
+ * is required
+ */
u_long
win32_htonl(u_long hostlong)
{
+#ifdef MYSWAP
+ dTHX;
+#else
StartSockets();
+#endif
return htonl(hostlong);
}
@@ -135,7 +98,11 @@
u_short
win32_htons(u_short hostshort)
{
+#ifdef MYSWAP
+ dTHX;
+#else
StartSockets();
+#endif
return htons(hostshort);
}
@@ -142,7 +109,11 @@
u_long
win32_ntohl(u_long netlong)
{
+#ifdef MYSWAP
+ dTHX;
+#else
StartSockets();
+#endif
return ntohl(netlong);
}
@@ -149,7 +120,11 @@
u_short
win32_ntohs(u_short netshort)
{
+#ifdef MYSWAP
+ dTHX;
+#else
StartSockets();
+#endif
return ntohs(netshort);
}
@@ -258,7 +233,6 @@
win32_select(int nfds, Perl_fd_set* rd, Perl_fd_set* wr, Perl_fd_set* ex, const struct timeval* timeout)
{
int r;
-#ifdef USE_SOCKETS_AS_HANDLES
int i, fd, save_errno = errno;
FD_SET nrd, nwr, nex;
bool just_sleep = TRUE;
@@ -320,9 +294,6 @@
}
}
errno = save_errno;
-#else
- SOCKET_TEST_ERROR(r = select(nfds, rd, wr, ex, timeout));
-#endif
return r;
}
@@ -372,9 +343,6 @@
return r;
}
-#ifdef USE_SOCKETS_AS_HANDLES
-#define WIN32_OPEN_SOCKET(af, type, protocol) open_ifs_socket(af, type, protocol)
-
void
convert_proto_info_w2a(WSAPROTOCOL_INFOW *in, WSAPROTOCOL_INFOA *out)
{
@@ -433,25 +401,17 @@
return out;
}
-#else
-#define WIN32_OPEN_SOCKET(af, type, protocol) socket(af, type, protocol)
-#endif
-
SOCKET
win32_socket(int af, int type, int protocol)
{
SOCKET s;
-#ifndef USE_SOCKETS_AS_HANDLES
- SOCKET_TEST(s = socket(af, type, protocol), INVALID_SOCKET);
-#else
StartSockets();
- if((s = WIN32_OPEN_SOCKET(af, type, protocol)) == INVALID_SOCKET)
+ if((s = open_ifs_socket(af, type, protocol)) == INVALID_SOCKET)
errno = WSAGetLastError();
else
s = OPEN_SOCKET(s);
-#endif /* USE_SOCKETS_AS_HANDLES */
return s;
}
@@ -564,11 +524,12 @@
struct servent *
win32_getservbyname(const char *name, const char *proto)
{
- dTHX;
+ dTHXa(NULL);
struct servent *r;
SOCKET_TEST(r = getservbyname(name, proto), NULL);
if (r) {
+ aTHXa(PERL_GET_THX);
r = win32_savecopyservent(&w32_servent, r, proto);
}
return r;
@@ -577,11 +538,12 @@
struct servent *
win32_getservbyport(int port, const char *proto)
{
- dTHX;
+ dTHXa(NULL);
struct servent *r;
SOCKET_TEST(r = getservbyport(port, proto), NULL);
if (r) {
+ aTHXa(PERL_GET_THX);
r = win32_savecopyservent(&w32_servent, r, proto);
}
return r;
@@ -590,7 +552,6 @@
int
win32_ioctl(int i, unsigned int u, char *data)
{
- dTHX;
u_long u_long_arg;
int retval;
@@ -635,29 +596,25 @@
void
win32_endhostent()
{
- dTHX;
- Perl_croak_nocontext("endhostent not implemented!\n");
+ win32_croak_not_implemented("endhostent");
}
void
win32_endnetent()
{
- dTHX;
- Perl_croak_nocontext("endnetent not implemented!\n");
+ win32_croak_not_implemented("endnetent");
}
void
win32_endprotoent()
{
- dTHX;
- Perl_croak_nocontext("endprotoent not implemented!\n");
+ win32_croak_not_implemented("endprotoent");
}
void
win32_endservent()
{
- dTHX;
- Perl_croak_nocontext("endservent not implemented!\n");
+ win32_croak_not_implemented("endservent");
}
@@ -664,8 +621,7 @@
struct netent *
win32_getnetent(void)
{
- dTHX;
- Perl_croak_nocontext("getnetent not implemented!\n");
+ win32_croak_not_implemented("getnetent");
return (struct netent *) NULL;
}
@@ -672,8 +628,7 @@
struct netent *
win32_getnetbyname(char *name)
{
- dTHX;
- Perl_croak_nocontext("getnetbyname not implemented!\n");
+ win32_croak_not_implemented("getnetbyname");
return (struct netent *)NULL;
}
@@ -680,8 +635,7 @@
struct netent *
win32_getnetbyaddr(long net, int type)
{
- dTHX;
- Perl_croak_nocontext("getnetbyaddr not implemented!\n");
+ win32_croak_not_implemented("getnetbyaddr");
return (struct netent *)NULL;
}
@@ -688,8 +642,7 @@
struct protoent *
win32_getprotoent(void)
{
- dTHX;
- Perl_croak_nocontext("getprotoent not implemented!\n");
+ win32_croak_not_implemented("getprotoent");
return (struct protoent *) NULL;
}
@@ -696,8 +649,7 @@
struct servent *
win32_getservent(void)
{
- dTHX;
- Perl_croak_nocontext("getservent not implemented!\n");
+ win32_croak_not_implemented("getservent");
return (struct servent *) NULL;
}
@@ -704,8 +656,7 @@
void
win32_sethostent(int stayopen)
{
- dTHX;
- Perl_croak_nocontext("sethostent not implemented!\n");
+ win32_croak_not_implemented("sethostent");
}
@@ -712,8 +663,7 @@
void
win32_setnetent(int stayopen)
{
- dTHX;
- Perl_croak_nocontext("setnetent not implemented!\n");
+ win32_croak_not_implemented("setnetent");
}
@@ -720,8 +670,7 @@
void
win32_setprotoent(int stayopen)
{
- dTHX;
- Perl_croak_nocontext("setprotoent not implemented!\n");
+ win32_croak_not_implemented("setprotoent");
}
@@ -728,8 +677,7 @@
void
win32_setservent(int stayopen)
{
- dTHX;
- Perl_croak_nocontext("setservent not implemented!\n");
+ win32_croak_not_implemented("setservent");
}
static struct servent*
@@ -738,11 +686,9 @@
d->s_name = s->s_name;
d->s_aliases = s->s_aliases;
d->s_port = s->s_port;
-#ifndef __BORLANDC__ /* Buggy on WinNT-with-Borland-WSOCK */
if (s->s_proto && strlen(s->s_proto))
d->s_proto = s->s_proto;
else
-#endif
if (proto && strlen(proto))
d->s_proto = (char *)proto;
else
Property changes on: trunk/contrib/perl/win32/win32sck.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/win32/win32thread.c
===================================================================
--- trunk/contrib/perl/win32/win32thread.c 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/win32thread.c 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/win32/win32thread.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/win32/win32thread.h
===================================================================
--- trunk/contrib/perl/win32/win32thread.h 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/win32thread.h 2013-12-02 21:26:09 UTC (rev 6439)
@@ -109,10 +109,9 @@
/* XXX Docs mention that the RTL versions of thread creation routines
* should be used, but that advice only seems applicable when the RTL
- * is not in a DLL. RTL DLLs in both Borland and VC seem to do all of
- * the init/deinit required upon DLL_THREAD_ATTACH/DETACH. So we seem
- * to be completely safe using straight Win32 API calls, rather than
- * the much braindamaged RTL calls.
+ * is not in a DLL. RTL DLLs seem to do all of the init/deinit required
+ * upon DLL_THREAD_ATTACH/DETACH. So we seem to be completely safe using
+ * straight Win32 API calls, rather than the much braindamaged RTL calls.
*
* _beginthread() in the RTLs call CloseHandle() just after the thread
* function returns, which means: 1) we have a race on our hands
@@ -123,11 +122,7 @@
*/
#ifdef USE_RTL_THREAD_API
# include <process.h>
-# if defined(__BORLANDC__)
- /* Borland RTL doesn't allow a return value from thread function! */
-# define THREAD_RET_TYPE void _USERENTRY
-# define THREAD_RET_CAST(p) ((void)(thr->i.retv = (void *)(p)))
-# elif defined (_MSC_VER)
+# if defined (_MSC_VER)
# define THREAD_RET_TYPE unsigned __stdcall
# define THREAD_RET_CAST(p) ((unsigned)(p))
# else
@@ -145,7 +140,7 @@
START_EXTERN_C
-#if defined(PERLDLL) && defined(USE_DECLSPEC_THREAD) && (!defined(__BORLANDC__) || defined(_DLL))
+#if defined(PERLDLL) && defined(USE_DECLSPEC_THREAD)
extern __declspec(thread) void *PL_current_context;
#define PERL_SET_CONTEXT(t) (PL_current_context = t)
#define PERL_GET_CONTEXT PL_current_context
Property changes on: trunk/contrib/perl/win32/win32thread.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/win32/wince.c
===================================================================
--- trunk/contrib/perl/win32/wince.c 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/wince.c 2013-12-02 21:26:09 UTC (rev 6439)
@@ -73,7 +73,7 @@
static char * get_emd_part(SV **leading, STRLEN *const len,
char *trailing, ...);
static void remove_dead_process(long deceased);
-static long find_pid(int pid);
+static long find_pid(pTHX_ int pid);
static char * qualified_path(const char *cmd);
static char * win32_get_xlib(const char *pl, const char *xlib,
const char *libname, STRLEN *const len);
@@ -80,7 +80,7 @@
#ifdef USE_ITHREADS
static void remove_dead_pseudo_process(long child);
-static long find_pseudo_pid(int pid);
+static long find_pseudo_pid(pTHX_ int pid);
#endif
int _fmode = O_TEXT; /* celib do not provide _fmode, so we define it here */
@@ -261,8 +261,6 @@
dTHX;
char regstr[40];
char pathstr[MAX_PATH+1];
- DWORD datalen;
- int len, newsize;
SV *sv1 = NULL;
SV *sv2 = NULL;
@@ -417,8 +415,8 @@
if (str) {
dTHX;
int slen = strlen(str);
- register char *ret;
- register char **retv;
+ char *ret;
+ char **retv;
Newx(ret, slen+2, char);
Newx(retv, (slen+3)/2, char*);
@@ -893,7 +891,53 @@
return path;
}
+static void
+out_of_memory(void)
+{
+ if (PL_curinterp) {
+ dTHX;
+ /* Can't use PerlIO to write as it allocates memory */
+ PerlLIO_write(PerlIO_fileno(Perl_error_log),
+ PL_no_mem, strlen(PL_no_mem));
+ my_exit(1);
+ }
+ exit(1);
+}
+
+/* The win32_ansipath() function takes a Unicode filename and converts it
+ * into the current Windows codepage. If some characters cannot be mapped,
+ * then it will convert the short name instead.
+ *
+ * The buffer to the ansi pathname must be freed with win32_free() when it
+ * it no longer needed.
+ *
+ * The argument to win32_ansipath() must exist before this function is
+ * called; otherwise there is no way to determine the short path name.
+ *
+ * Ideas for future refinement:
+ * - Only convert those segments of the path that are not in the current
+ * codepage, but leave the other segments in their long form.
+ * - If the resulting name is longer than MAX_PATH, start converting
+ * additional path segments into short names until the full name
+ * is shorter than MAX_PATH. Shorten the filename part last!
+ */
DllExport char *
+win32_ansipath(const WCHAR *widename)
+{
+ char *name;
+ size_t widelen = wcslen(widename)+1;
+ int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
+ NULL, 0, NULL, NULL);
+ name = win32_malloc(len);
+ if (!name)
+ out_of_memory();
+
+ WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
+ name, len, NULL, NULL);
+ return name;
+}
+
+DllExport char *
win32_getenv(const char *name)
{
return xcegetenv(name);
@@ -1498,9 +1542,6 @@
if (fh != INVALID_HANDLE_VALUE) {
int fd = win32_open_osfhandle((intptr_t)fh, 0);
if (fd >= 0) {
-#if defined(__BORLANDC__)
- setmode(fd,O_BINARY);
-#endif
DEBUG_p(PerlIO_printf(Perl_debug_log,
"Created tmpfile=%s\n",filename));
return fd;
@@ -2737,13 +2778,7 @@
return xcegetcwd(buf, size);
}
-int
-isnan(double d)
-{
- return _isnan(d);
-}
-
DllExport PerlIO*
win32_popenlist(const char *mode, IV narg, SV **args)
{
Property changes on: trunk/contrib/perl/win32/wince.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/win32/wince.h
===================================================================
--- trunk/contrib/perl/win32/wince.h 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/wince.h 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/win32/wince.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/win32/wincesck.c
===================================================================
--- trunk/contrib/perl/win32/wincesck.c 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/win32/wincesck.c 2013-12-02 21:26:09 UTC (rev 6439)
@@ -483,11 +483,9 @@
d->s_name = s->s_name;
d->s_aliases = s->s_aliases;
d->s_port = s->s_port;
-#ifndef __BORLANDC__ /* Buggy on Win95 and WinNT-with-Borland-WSOCK */
if (!IsWin95() && s->s_proto && strlen(s->s_proto))
d->s_proto = s->s_proto;
else
-#endif
if (proto && strlen(proto))
d->s_proto = (char *)proto;
else
Property changes on: trunk/contrib/perl/win32/wincesck.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/x2p/EXTERN.h
===================================================================
--- trunk/contrib/perl/x2p/EXTERN.h 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/x2p/EXTERN.h 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/x2p/EXTERN.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/x2p/INTERN.h
===================================================================
--- trunk/contrib/perl/x2p/INTERN.h 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/x2p/INTERN.h 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/x2p/INTERN.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/x2p/Makefile.SH
===================================================================
--- trunk/contrib/perl/x2p/Makefile.SH 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/x2p/Makefile.SH 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,3 +1,5 @@
+#!/bin/sh
+
case $PERL_CONFIG_SH in
'')
if test -f config.sh; then TOP=.;
@@ -35,16 +37,13 @@
esac
cat >Makefile <<!GROK!THIS!
-# $RCSfile: Makefile.SH,v $$Revision: 1.1.1.3 $$Date: 2011-05-18 13:33:34 $
+# $RCSfile: Makefile.SH,v $$Revision: 4.1 $$Date: 92/08/07 18:29:07 $
#
-# $Log: not supported by cvs2svn $
+# $Log: Makefile.SH,v $
CC = $cc
BYACC = $byacc
LDFLAGS = $ldflags
-# XXX Perl malloc temporarily unusable (declaration collisions with stdlib.h)
-#mallocsrc = $mallocsrc
-#mallocobj = $mallocobj
shellflags = $shellflags
libs = $perllibs
@@ -101,9 +100,9 @@
h = EXTERN.h INTERN.h ../config.h ../handy.h hash.h a2p.h str.h util.h
-c = hash.c $(mallocsrc) str.c util.c walk.c
+c = hash.c str.c util.c walk.c
-obj = hash$(OBJ_EXT) $(mallocobj) str$(OBJ_EXT) util$(OBJ_EXT) walk$(OBJ_EXT)
+obj = hash$(OBJ_EXT) str$(OBJ_EXT) util$(OBJ_EXT) walk$(OBJ_EXT)
lintflags = -phbvxac
@@ -156,7 +155,7 @@
realclean: clean
-rmdir .depending
- rm -f core $(addedbyconf) all malloc.c
+ rm -f core $(addedbyconf) all
rm -f $(FIRSTMAKEFILE) $(FIRSTMAKEFILE).old makefile.old
veryclean: realclean
@@ -170,7 +169,7 @@
lint:
lint $(lintflags) $(defs) $(c) > a2p.fuzz
-depend: $(mallocsrc) ../makedepend
+depend: ../makedepend
sh ../makedepend MAKE=$(MAKE)
clist:
@@ -185,18 +184,10 @@
$(plextract):
$(RUN) $(PERL) -I../lib $@.PL
-find2perl: find2perl.PL
+find2perl: find2perl.PL ../config.sh
-s2p: s2p.PL
+s2p: s2p.PL ../config.sh
-malloc.c: ../malloc.c
- rm -f malloc.c
- sed <../malloc.c >malloc.c \
- -e 's/"EXTERN.h"/"..\/EXTERN.h"/' \
- -e 's/"perl.h"/"..\/perl.h"/' \
- -e 's/my_exit/exit/' \
- -e 's/MUTEX_[A-Z_]*(&PL_malloc_mutex);//'
-
# AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE
$(obj):
@ echo "You haven't done a "'"make depend" yet!'; exit 1
Property changes on: trunk/contrib/perl/x2p/Makefile.SH
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/x2p/a2p.c
===================================================================
--- trunk/contrib/perl/x2p/a2p.c 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/x2p/a2p.c 2013-12-02 21:26:09 UTC (rev 6439)
@@ -10,7 +10,7 @@
extern int yyparse(void);
#define YYPREFIX "yy"
#line 2 "a2p.y"
-/* $RCSfile: a2p.c,v $$Revision: 1.1.1.2 $$Date: 2011-02-17 12:49:38 $
+/* $RCSfile: a2p.y,v $$Revision: 4.1 $$Date: 92/08/07 18:29:12 $
*
* Copyright (C) 1991, 1992, 1993, 1994, 1996, 1997, 1999, 2000,
* by Larry Wall and others
@@ -18,7 +18,7 @@
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*
- * $Log: not supported by cvs2svn $
+ * $Log: a2p.y,v $
*/
#include "INTERN.h"
@@ -2181,7 +2181,7 @@
#define YYERROR goto yyerrlab
#if YYDEBUG
-# if defined(WIN32) && !defined(__BORLANDC__)
+# if defined(WIN32)
EXTERN_C _CRTIMP char *getenv(const char *);
# else
EXTERN_C char *getenv(const char *);
@@ -2191,9 +2191,9 @@
int
yyparse(void)
{
- register int yym, yyn, yystate;
+ int yym, yyn, yystate;
#if YYDEBUG
- register const char *yys;
+ const char *yys;
if ((yys = getenv("YYDEBUG")))
{
Property changes on: trunk/contrib/perl/x2p/a2p.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/x2p/a2p.h
===================================================================
--- trunk/contrib/perl/x2p/a2p.h 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/x2p/a2p.h 2013-12-02 21:26:09 UTC (rev 6439)
@@ -13,7 +13,7 @@
#define _INC_WIN32_PERL5 /* kludge around win32 stdio layer */
#endif
-#ifdef VMS
+#ifdef __VMS
# include "config.h"
#elif defined(NETWARE)
# include "../NetWare/config.h"
@@ -30,19 +30,6 @@
# ifndef STANDARD_C
# define STANDARD_C
# endif
-# if defined(__BORLANDC__)
-# pragma warn -ccc
-# pragma warn -rch
-# pragma warn -sig
-# pragma warn -pia
-# pragma warn -par
-# pragma warn -aus
-# pragma warn -use
-# pragma warn -csu
-# pragma warn -pro
-# elif defined(_MSC_VER)
-# elif defined(__MINGW32__)
-# endif
#endif
/* Use all the "standard" definitions? */
@@ -74,14 +61,6 @@
#define MEM_SIZE Size_t
#ifdef PERL_MEM_LOG
-/* Blindly copied from ../perl.h. -- AD 2/2006. */
-/* Configure gets this right but the UTS compiler gets it wrong.
- -- Hal Morris <hom00 at utsglobal.com> */
-# ifdef UTS
-# undef UVTYPE
-# define UVTYPE unsigned
-# endif
-
typedef IVTYPE IV;
typedef UVTYPE UV;
#endif
@@ -142,7 +121,7 @@
/* All of these are in stdlib.h or time.h for ANSI C */
Time_t time();
struct tm *gmtime(), *localtime();
-#if defined(OEMVS) || defined(__OPEN_VM)
+#if defined(OEMVS)
char *(strchr)(), *(strrchr)();
char *(strcpy)(), *(strcat)();
#else
@@ -357,11 +336,7 @@
int ival;
char *cval;
};
-#if defined(iAPX286) || defined(M_I286) || defined(I80286) /* 80286 hack */
-#define OPSMAX (64000/sizeof(union u_ops)) /* approx. max segment size */
-#else
#define OPSMAX 50000
-#endif /* 80286 hack */
EXT union u_ops ops[OPSMAX];
typedef struct string STR;
Property changes on: trunk/contrib/perl/x2p/a2p.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/x2p/a2p.pod
===================================================================
--- trunk/contrib/perl/x2p/a2p.pod 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/x2p/a2p.pod 2013-12-02 21:26:09 UTC (rev 6439)
@@ -164,7 +164,7 @@
=head1 SEE ALSO
perl The perl compiler/interpreter
-
+
s2p sed to perl translator
=head1 DIAGNOSTICS
Property changes on: trunk/contrib/perl/x2p/a2p.pod
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/x2p/a2p.y
===================================================================
--- trunk/contrib/perl/x2p/a2p.y 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/x2p/a2p.y 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,5 +1,5 @@
%{
-/* $RCSfile: a2p.y,v $$Revision: 1.1.1.1 $$Date: 2009-03-15 19:20:10 $
+/* $RCSfile: a2p.y,v $$Revision: 4.1 $$Date: 92/08/07 18:29:12 $
*
* Copyright (C) 1991, 1992, 1993, 1994, 1996, 1997, 1999, 2000,
* by Larry Wall and others
@@ -7,7 +7,7 @@
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*
- * $Log: not supported by cvs2svn $
+ * $Log: a2p.y,v $
*/
#include "INTERN.h"
Property changes on: trunk/contrib/perl/x2p/a2p.y
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/x2p/a2py.c
===================================================================
--- trunk/contrib/perl/x2p/a2py.c 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/x2p/a2py.c 2013-12-02 21:26:09 UTC (rev 6439)
@@ -17,6 +17,8 @@
#include "../patchlevel.h"
#endif
#include "util.h"
+#include "../unicode_constants.h"
+#define DELETE_CHAR DEL_NATIVE
const char *filename;
const char *myname;
@@ -29,10 +31,10 @@
int oper3(int type, int arg1, int arg2, int arg3);
int oper4(int type, int arg1, int arg2, int arg3, int arg4);
int oper5(int type, int arg1, int arg2, int arg3, int arg4, int arg5);
-STR *walk(int useval, int level, register int node, int *numericptr, int minprec);
+STR *walk(int useval, int level, int node, int *numericptr, int minprec);
#ifdef NETWARE
char *savestr(char *str);
-char *cpy2(register char *to, register char *from, register int delim);
+char *cpy2(char *to, char *from, int delim);
#endif
#if defined(OS2) || defined(WIN32) || defined(NETWARE)
@@ -59,9 +61,9 @@
#endif
int
-main(register int argc, register const char **argv, register const char **env)
+main(int argc, const char **argv, const char **env)
{
- register STR *str;
+ STR *str;
int i;
STR *tmpstr;
/* char *namelist; */
@@ -221,9 +223,9 @@
int
yylex(void)
{
- register char *s = bufptr;
- register char *d;
- register int tmp;
+ char *s = bufptr;
+ char *d;
+ int tmp;
retry:
#if YYDEBUG
@@ -289,11 +291,7 @@
case ':':
tmp = *s++;
XOP(tmp);
-#ifdef EBCDIC
- case 7:
-#else
- case 127:
-#endif
+ case DELETE_CHAR:
s++;
XTERM('}');
case '}':
@@ -399,7 +397,7 @@
#define SNARFWORD \
d = tokenbuf; \
- while (isALPHA(*s) || isDIGIT(*s) || *s == '_') \
+ while (isWORDCHAR(*s)) \
*d++ = *s++; \
*d = '\0'; \
d = tokenbuf; \
@@ -426,7 +424,7 @@
maxfld = tmp;
XOP(FIELD);
}
- for (d = s; isALPHA(*s) || isDIGIT(*s) || *s == '_'; )
+ for (d = s; isWORDCHAR(*s); )
s++;
split_to_array = TRUE;
if (d != s)
@@ -826,9 +824,9 @@
}
char *
-scanpat(register char *s)
+scanpat(char *s)
{
- register char *d;
+ char *d;
switch (*s++) {
case '/':
@@ -878,9 +876,9 @@
}
char *
-scannum(register char *s)
+scannum(char *s)
{
- register char *d;
+ char *d;
switch (*s) {
case '1': case '2': case '3': case '4': case '5':
@@ -1027,9 +1025,9 @@
void
dump(int branch)
{
- register int type;
- register int len;
- register int i;
+ int type;
+ int len;
+ int i;
type = ops[branch].ival;
len = type >> 8;
@@ -1067,8 +1065,8 @@
void
fixup(STR *str)
{
- register char *s;
- register char *t;
+ char *s;
+ char *t;
for (s = str->str_ptr; *s; s++) {
if (*s == ';' && s[1] == ' ' && s[2] == '\n') {
@@ -1092,8 +1090,8 @@
void
putlines(STR *str)
{
- register char *d, *s, *t, *e;
- register int pos, newpos;
+ char *d, *s, *t, *e;
+ int pos, newpos;
d = tokenbuf;
pos = 0;
@@ -1168,7 +1166,7 @@
void
putone(void)
{
- register char *t;
+ char *t;
for (t = tokenbuf; *t; t++) {
*t &= 127;
Property changes on: trunk/contrib/perl/x2p/a2py.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/x2p/cflags.SH
===================================================================
--- trunk/contrib/perl/x2p/cflags.SH 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/x2p/cflags.SH 2013-12-02 21:26:09 UTC (rev 6439)
@@ -1,3 +1,5 @@
+#!/bin/sh
+
case $PERL_CONFIG_SH in
'')
if test -f config.sh; then TOP=.;
Property changes on: trunk/contrib/perl/x2p/cflags.SH
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/x2p/find2perl.PL
===================================================================
--- trunk/contrib/perl/x2p/find2perl.PL 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/x2p/find2perl.PL 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/x2p/find2perl.PL
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/x2p/hash.c
===================================================================
--- trunk/contrib/perl/x2p/hash.c 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/x2p/hash.c 2013-12-02 21:26:09 UTC (rev 6439)
@@ -17,12 +17,12 @@
#endif
STR *
-hfetch(register HASH *tb, char *key)
+hfetch(HASH *tb, char *key)
{
- register char *s;
- register int i;
- register int hash;
- register HENT *entry;
+ char *s;
+ int i;
+ int hash;
+ HENT *entry;
if (!tb)
return NULL;
@@ -43,13 +43,13 @@
}
bool
-hstore(register HASH *tb, char *key, STR *val)
+hstore(HASH *tb, char *key, STR *val)
{
- register char *s;
- register int i;
- register int hash;
- register HENT *entry;
- register HENT **oentry;
+ char *s;
+ int i;
+ int hash;
+ HENT *entry;
+ HENT **oentry;
if (!tb)
return FALSE;
@@ -94,12 +94,12 @@
hsplit(HASH *tb)
{
const int oldsize = tb->tbl_max + 1;
- register int newsize = oldsize * 2;
- register int i;
- register HENT **a;
- register HENT **b;
- register HENT *entry;
- register HENT **oentry;
+ int newsize = oldsize * 2;
+ int i;
+ HENT **a;
+ HENT **b;
+ HENT *entry;
+ HENT **oentry;
a = (HENT**) saferealloc((char*)tb->tbl_array, newsize * sizeof(HENT*));
memset(&a[oldsize], 0, oldsize * sizeof(HENT*)); /* zero second half */
@@ -130,7 +130,7 @@
HASH *
hnew(void)
{
- register HASH *tb = (HASH*)safemalloc(sizeof(HASH));
+ HASH *tb = (HASH*)safemalloc(sizeof(HASH));
tb->tbl_array = (HENT**) safemalloc(8 * sizeof(HENT*));
tb->tbl_fill = 0;
@@ -141,7 +141,7 @@
}
int
-hiterinit(register HASH *tb)
+hiterinit(HASH *tb)
{
tb->tbl_riter = -1;
tb->tbl_eiter = (HENT*)NULL;
Property changes on: trunk/contrib/perl/x2p/hash.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/x2p/hash.h
===================================================================
--- trunk/contrib/perl/x2p/hash.h 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/x2p/hash.h 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/x2p/hash.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/x2p/s2p.PL
===================================================================
--- trunk/contrib/perl/x2p/s2p.PL 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/x2p/s2p.PL 2013-12-02 21:26:09 UTC (rev 6439)
@@ -91,7 +91,7 @@
A stream editor reads the input stream consisting of the specified files
(or standard input, if none are given), processes is line by line by
applying a script consisting of edit commands, and writes resulting lines
-to standard output. The filename `C<->' may be used to read standard input.
+to standard output. The filename 'C<->' may be used to read standard input.
The edit script is composed from arguments of B<-e> options and
script-files, in the given order. A single script argument may be specified
@@ -98,7 +98,7 @@
as the first parameter.
If this program is invoked with the name F<s2p>, it will act as a
-sed-to-Perl translator. See L<"sed Script Translation">.
+sed-to-Perl translator. See L<"SED SCRIPT TRANSLATION">.
B<sed> returns an exit code of 0 on success or >0 if an error occurred.
@@ -155,7 +155,7 @@
A sed address is either a line number or a pattern, which may be combined
arbitrarily to construct ranges. Lines are numbered across all input files.
-Any address may be followed by an exclamation mark (`C<!>'), selecting
+Any address may be followed by an exclamation mark ('C<!>'), selecting
all lines not matching that address.
=over 4
@@ -171,10 +171,10 @@
=item B</>I<regular expression>B</>
A pattern address is a basic regular expression (see
-L<"Basic Regular Expressions">), between the delimiting character C</>.
+L<"BASIC REGULAR EXPRESSIONS">), between the delimiting character C</>.
Any other character except C<\> or newline may be used to delimit a
pattern address when the initial delimiter is prefixed with a
-backslash (`C<\>').
+backslash ('C<\>').
=back
@@ -329,9 +329,9 @@
Print the contents of the pattern space: non-printable characters are
shown in C-style escaped form; long lines are split and have a trailing
-`C<\>' at the point of the split; the true end of a line is marked with
-a `C<$>'. Escapes are: `\a', `\t', `\n', `\f', `\r', `\e' for
-BEL, HT, LF, FF, CR, ESC, respectively, and `\' followed by a three-digit
+^'C<\>' at the point of the split; the true end of a line is marked with
+a 'C<$>'. Escapes are: '\a', '\t', '\n', '\f', '\r', '\e' for
+BEL, HT, LF, FF, CR, ESC, respectively, and '\' followed by a three-digit
octal number for all other non-printable characters.
=cut
@@ -427,15 +427,15 @@
Any character other than backslash or newline can be used instead of a
slash to delimit the regular expression and the replacement.
To use the delimiter as a literal character within the regular expression
-and the replacement, precede the character by a backslash (`C<\>').
+and the replacement, precede the character by a backslash ('C<\>').
Literal newlines may be embedded in the replacement string by
preceding a newline with a backslash.
-Within the replacement, an ampersand (`C<&>') is replaced by the string
-matching the regular expression. The strings `C<\1>' through `C<\9>' are
-replaced by the corresponding subpattern (see L<"Basic Regular Expressions">).
-To get a literal `C<&>' or `C<\>' in the replacement text, precede it
+Within the replacement, an ampersand ('C<&>') is replaced by the string
+matching the regular expression. The strings 'C<\1>' through 'C<\9>' are
+replaced by the corresponding subpattern (see L<"BASIC REGULAR EXPRESSIONS">).
+To get a literal 'C<&>' or 'C<\>' in the replacement text, precede it
by a backslash.
The following I<flags> modify the behaviour of the B<s> command:
@@ -497,6 +497,7 @@
#--------------------------------------------------------------------------
$ComTab{'y'}=[ 2, 'tra', \&Emit, '' ]; #ok
+
=item [2addr]B<y>B</>I<string1>B</>I<string2>B</>
In the pattern space, replace all characters occurring in I<string1> by the
@@ -504,7 +505,7 @@
to use any character (other than a backslash or newline) instead of a
slash to delimit the strings. Within I<string1> and I<string2>, a
backslash followed by any character other than a newline is that literal
-character, and a backslash followed by an `n' is replaced by a newline
+character, and a backslash followed by an 'n' is replaced by a newline
character.
=cut
@@ -520,7 +521,7 @@
#--------------------------------------------------------------------------
$ComTab{':'}=[ 0, 'str', \&Label, '' ]; #ok
-
+
=item [0addr]B<:> [I<label>]
The command specifies the position of the I<label>. It has no other effect.
@@ -549,7 +550,7 @@
=item [0addr]B<#> [I<comment>]
The entire line is ignored (treated as a comment). If, however, the first
-two characters in the script are `C<#n>', automatic printing of output is
+two characters in the script are 'C<#n>', automatic printing of output is
suppressed, as if the B<-n> option were given on the command line.
=back
@@ -689,7 +690,7 @@
if( defined( $jcom ) ){
$rc = Emit( $addr1, $addr2, $negated, $opcode, $arg, $fl );
} else {
- Warn( "unexpected `}'", $fl );
+ Warn( "unexpected '}'", $fl );
$rc = 1;
}
$rc;
@@ -799,7 +800,7 @@
my $fc = substr($fr,$i,1);
my $tc = substr($to,$i,1);
if( exists( $tr{$fc} ) && $tr{$fc} ne $tc ){
- Warn( "ambiguous translation for character `$fc' in `y' command",
+ Warn( "ambiguous translation for character '$fc' in 'y' command",
$fl );
$error++;
}
@@ -924,15 +925,15 @@
If the first character after B<[> is B<^>, the sense of matching is
inverted.
-To include a literal `C<^>', place it anywhere else but first. To
+To include a literal 'C<^>', place it anywhere else but first. To
include a literal 'C<]>' place it first or immediately after an
-initial B<^>. To include a literal `C<->' make it the first (or
+initial B<^>. To include a literal 'C<->' make it the first (or
second after B<^>) or last character, or the second endpoint of
a range.
The special bracket expression constructs C<[[:E<lt>:]]> and C<[[:E<gt>:]]>
match the null string at the beginning and end of a word respectively.
-(Note that neither is identical to Perl's `\b' atom.)
+(Note that neither is identical to Perl's '\b' atom.)
=head2 Additional Atoms
@@ -987,7 +988,7 @@
### backslash escapes
my $nc = peek($pat,$ic);
if( $nc eq '' ){
- Warn( "`\\' cannot be last in pattern", $fl );
+ Warn( "'\\' cannot be last in pattern", $fl );
return undef();
}
$ic++;
@@ -1007,7 +1008,7 @@
$parlev--;
$backref++;
if( $parlev < 0 ){
- Warn( "unmatched `\\)'", $fl );
+ Warn( "unmatched '\\)'", $fl );
return undef();
}
$res .= ')';
@@ -1015,7 +1016,7 @@
} elsif( $nc eq '{' ){ ## repetition factor \{<i>[,[<j>]]\}
my $endpos = index( $pat, '\\}', $ic );
if( $endpos < 0 ){
- Warn( "unmatched `\\{'", $fl );
+ Warn( "unmatched '\\{'", $fl );
return undef();
}
my $rep = substr( $pat, $ic+1, $endpos-($ic+1) );
@@ -1029,7 +1030,7 @@
my $max = $3;
if( length( $max ) ){
if( $max < $min ){
- Warn( "maximum less than minimum in `\\{$rep\\}'",
+ Warn( "maximum less than minimum in '\\{$rep\\}'",
$fl );
return undef();
}
@@ -1047,7 +1048,7 @@
$res .= "{$min$com$max}";
}
} else {
- Warn( "invalid repeat clause `\\{$rep\\}'", $fl );
+ Warn( "invalid repeat clause '\\{$rep\\}'", $fl );
return undef();
}
@@ -1077,7 +1078,7 @@
## \<closing bracketing-delimiter> - keep '\'
$res .= "\\$nc";
- } else { ## \ <char> => <char> ("as if `\' were not present")
+ } else { ## \ <char> => <char> ("as if '\' were not present")
$res .= $nc;
}
@@ -1105,7 +1106,7 @@
}
# check that [ is not trailing
if( $ic >= length( $pat ) - 1 ){
- Warn( "unmatched `['", $fl );
+ Warn( "unmatched '['", $fl );
return undef();
}
# look for [:...:] and x-y
@@ -1113,7 +1114,7 @@
if( $rstr =~ /^((?:\[:\(\w+|[><]\):\]|[^]-](?:-[^]])?)*)/ ){
my $cnt = $1;
$ic += length( $cnt );
- $cnt =~ s/([\\\$])/\\$1/g; # `\', `$' are magic in Perl []
+ $cnt =~ s/([\\\$])/\\$1/g; # '\', '$' are magic in Perl []
# try some simplifications
my $red = $cnt;
if( $red =~ s/0-9// ){
@@ -1130,7 +1131,7 @@
}
- ## may have a trailing `-' before `]'
+ ## may have a trailing '-' before ']'
if( $ic < length($pat) - 1 &&
substr( $pat, $ic+1 ) =~ /^(-?])/ ){
$ic += length( $1 );
@@ -1139,7 +1140,7 @@
$add =~ s/^\[(\^?)(\\[dw])]$/ $1 eq '^' ? uc($2) : $2 /e;
$res .= $add;
} else {
- Warn( "unmatched `['", $fl );
+ Warn( "unmatched '['", $fl );
return undef();
}
@@ -1164,7 +1165,7 @@
}
if( $parlev ){
- Warn( "unmatched `\\('", $fl );
+ Warn( "unmatched '\\('", $fl );
return undef();
}
@@ -1192,7 +1193,7 @@
### backslash escapes
my $nc = peek($subst,$ic);
if( $nc eq '' ){
- Warn( "`\\' cannot be last in substitution", $fl );
+ Warn( "'\\' cannot be last in substitution", $fl );
return undef();
}
$ic++;
@@ -1282,13 +1283,13 @@
next;
}
} else {
- Warn( "invalid address after `,'", $fl );
+ Warn( "invalid address after ','", $fl );
$error++;
next;
}
}
- # address modifier `!'
+ # address modifier '!'
#
$negated = $cmd =~ s/^!\s*//;
if( defined( $addr1 ) ){
@@ -1307,7 +1308,7 @@
#
if( $cmd !~ s/^([:#={}abcdDgGhHilnNpPqrstwxy])\s*// ){
my $h = substr( $cmd, 0, 1 );
- Warn( "unknown command `$h'", $fl );
+ Warn( "unknown command '$h'", $fl );
$error++;
next;
}
@@ -1354,7 +1355,7 @@
} elsif( $tabref->[1] eq 'sub' ){
# s///
if( ! length( $cmd ) ){
- Warn( "`s' command requires argument", $fl );
+ Warn( "'s' command requires argument", $fl );
$error++;
next;
}
@@ -1398,7 +1399,7 @@
$write = $1 if $cmd =~ s/w\s*(.*)$//;
### $nmatch =~ s/^(\d)\1*$/$1/; ### may be dangerous?
if( $global && length( $nmatch ) || length( $nmatch ) > 1 ){
- Warn( "conflicting flags `$global$nmatch'", $fl );
+ Warn( "conflicting flags '$global$nmatch'", $fl );
$error++;
next;
}
@@ -1430,30 +1431,30 @@
$Code .= "# $Commands[$icom]\n" if $doGenerate;
}
if( ! length( $cmd ) ){
- Warn( "`y' command requires argument", $fl );
+ Warn( "'y' command requires argument", $fl );
$error++;
next;
}
my $d = substr( $cmd, 0, 1 ); $cmd = substr( $cmd, 1 );
if( $d eq '\\' ){
- Warn( "`\\' not valid as delimiter in `y' command", $fl );
+ Warn( "'\\' not valid as delimiter in 'y' command", $fl );
$error++;
next;
}
my $fr = stripTrans( $d, \$cmd );
if( ! defined( $fr ) || ! length( $cmd ) ){
- Warn( "malformed `y' command argument", $fl );
+ Warn( "malformed 'y' command argument", $fl );
$error++;
next;
}
my $to = stripTrans( $d, \$cmd );
if( ! defined( $to ) ){
- Warn( "malformed `y' command argument", $fl );
+ Warn( "malformed 'y' command argument", $fl );
$error++;
next;
}
if( length($fr) != length($to) ){
- Warn( "string lengths in `y' command differ", $fl );
+ Warn( "string lengths in 'y' command differ", $fl );
$error++;
next;
}
@@ -1486,7 +1487,7 @@
while( @BlockStack ){
my $bl = pop( @BlockStack );
- Warn( "start of unterminated `{'", $bl );
+ Warn( "start of unterminated '{'", $bl );
$error++;
}
@@ -1493,7 +1494,7 @@
for my $lab ( keys( %Label ) ){
if( ! exists( $Label{$lab}{defined} ) ){
for my $used ( @{$Label{$lab}{used}} ){
- Warn( "undefined label `$lab'", $used );
+ Warn( "undefined label '$lab'", $used );
$error++;
}
}
@@ -1570,7 +1571,7 @@
} elsif( $opt eq 'a' ){
$doOpenWrite = 0;
} else {
- Warn( "illegal option `$opt'" );
+ Warn( "illegal option '$opt'" );
usage();
exit( 1 );
}
@@ -1873,27 +1874,27 @@
=over 4
-=item ambiguous translation for character `%s' in `y' command
+=item ambiguous translation for character '%s' in 'y' command
The indicated character appears twice, with different translations.
-=item `[' cannot be last in pattern
+=item '[' cannot be last in pattern
-A `[' in a BRE indicates the beginning of a I<bracket expression>.
+A '[' in a BRE indicates the beginning of a I<bracket expression>.
-=item `\' cannot be last in pattern
+=item '\' cannot be last in pattern
-A `\' in a BRE is used to make the subsequent character literal.
+A '\' in a BRE is used to make the subsequent character literal.
-=item `\' cannot be last in substitution
+=item '\' cannot be last in substitution
-A `\' in a substitution string is used to make the subsequent character literal.
+A '\' in a substitution string is used to make the subsequent character literal.
-=item conflicting flags `%s'
+=item conflicting flags '%s'
-In an B<s> command, either the `g' flag and an n-th occurrence flag, or
+In an B<s> command, either the 'g' flag and an n-th occurrence flag, or
multiple n-th occurrence flags are specified. Note that only the digits
-`1' through `9' are permitted.
+^'1' through '9' are permitted.
=item duplicate label %s (first defined at %s)
@@ -1903,13 +1904,13 @@
=item extra characters after command (%s)
-=item illegal option `%s'
+=item illegal option '%s'
=item improper delimiter in s command
-The BRE and substitution may not be delimited with `\' or newline.
+The BRE and substitution may not be delimited with '\' or newline.
-=item invalid address after `,'
+=item invalid address after ','
=item invalid backreference (%s)
@@ -1916,7 +1917,7 @@
The specified backreference number exceeds the number of backreferences
in the BRE.
-=item invalid repeat clause `\{%s\}'
+=item invalid repeat clause '\{%s\}'
The repeat clause does not contain a valid integer value, or pair of
values.
@@ -1929,11 +1930,11 @@
=item malformed substitution expression
-=item malformed `y' command argument
+=item malformed 'y' command argument
The first or second string of a B<y> command is syntactically incorrect.
-=item maximum less than minimum in `\{%s\}'
+=item maximum less than minimum in '\{%s\}'
=item no script command given
@@ -1940,23 +1941,23 @@
There must be at least one B<-e> or one B<-f> option specifying a
script or script file.
-=item `\' not valid as delimiter in `y' command
+=item '\' not valid as delimiter in 'y' command
=item option -e requires an argument
=item option -f requires an argument
-=item `s' command requires argument
+=item 's' command requires argument
-=item start of unterminated `{'
+=item start of unterminated '{'
-=item string lengths in `y' command differ
+=item string lengths in 'y' command differ
The translation table strings in a B<y> command must have equal lengths.
-=item undefined label `%s'
+=item undefined label '%s'
-=item unexpected `}'
+=item unexpected '}'
A B<}> command without a preceding B<{> command was encountered.
@@ -1965,23 +1966,23 @@
The end of the script was reached although a text line after a
B<a>, B<c> or B<i> command indicated another line.
-=item unknown command `%s'
+=item unknown command '%s'
-=item unterminated `['
+=item unterminated '['
A BRE contains an unterminated bracket expression.
-=item unterminated `\('
+=item unterminated '\('
A BRE contains an unterminated backreference.
-=item `\{' without closing `\}'
+=item '\{' without closing '\}'
A BRE contains an unterminated bounds specification.
-=item `\)' without preceding `\('
+=item '\)' without preceding '\('
-=item `y' command requires argument
+=item 'y' command requires argument
=back
@@ -2019,12 +2020,12 @@
=head1 BUGS
-The B<l> command will show escape characters (ESC) as `C<\e>', but
+The B<l> command will show escape characters (ESC) as 'C<\e>', but
a vertical tab (VT) in octal.
Trailing spaces are truncated from labels in B<:>, B<t> and B<b> commands.
-The meaning of an empty regular expression (`C<//>'), as defined by B<sed>,
+The meaning of an empty regular expression ('C<//>'), as defined by B<sed>,
is "the last pattern used, at run time". This deviates from the Perl
interpretation, which will re-use the "last last successfully executed
regular expression". Since keeping track of pattern usage would create
Property changes on: trunk/contrib/perl/x2p/s2p.PL
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/x2p/str.c
===================================================================
--- trunk/contrib/perl/x2p/str.c 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/x2p/str.c 2013-12-02 21:26:09 UTC (rev 6439)
@@ -12,7 +12,7 @@
#include "util.h"
void
-str_numset(register STR *str, double num)
+str_numset(STR *str, double num)
{
str->str_nval = num;
str->str_pok = 0; /* invalidate pointer */
@@ -20,9 +20,9 @@
}
char *
-str_2ptr(register STR *str)
+str_2ptr(STR *str)
{
- register char *s;
+ char *s;
if (!str)
return (char *)""; /* probably safe - won't be written to */
@@ -43,7 +43,7 @@
}
void
-str_sset(STR *dstr, register STR *sstr)
+str_sset(STR *dstr, STR *sstr)
{
if (!sstr)
str_nset(dstr,No,0);
@@ -56,7 +56,7 @@
}
void
-str_nset(register STR *str, register const char *ptr, register int len)
+str_nset(STR *str, const char *ptr, int len)
{
GROWSTR(&(str->str_ptr), &(str->str_len), len + 1);
memcpy(str->str_ptr,ptr,len);
@@ -67,9 +67,9 @@
}
void
-str_set(register STR *str, register const char *ptr)
+str_set(STR *str, const char *ptr)
{
- register int len;
+ int len;
if (!ptr)
ptr = "";
@@ -82,7 +82,7 @@
}
void
-str_ncat(register STR *str, register const char *ptr, register int len)
+str_ncat(STR *str, const char *ptr, int len)
{
if (!(str->str_pok))
str_2ptr(str);
@@ -95,7 +95,7 @@
}
void
-str_scat(STR *dstr, register STR *sstr)
+str_scat(STR *dstr, STR *sstr)
{
if (!(sstr->str_pok))
str_2ptr(sstr);
@@ -104,9 +104,9 @@
}
void
-str_cat(register STR *str, register const char *ptr)
+str_cat(STR *str, const char *ptr)
{
- register int len;
+ int len;
if (!ptr)
return;
@@ -123,7 +123,7 @@
STR *
str_new(int len)
{
- register STR *str;
+ STR *str;
if (freestrroot) {
str = freestrroot;
@@ -141,7 +141,7 @@
/* make str point to what nstr did */
void
-str_free(register STR *str)
+str_free(STR *str)
{
if (!str)
return;
@@ -155,7 +155,7 @@
}
int
-str_len(register STR *str)
+str_len(STR *str)
{
if (!str)
return 0;
@@ -168,15 +168,15 @@
}
char *
-str_gets(register STR *str, register FILE *fp)
+str_gets(STR *str, FILE *fp)
{
#if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
/* Here is some breathtakingly efficient cheating */
- register char *bp; /* we're going to steal some values */
- register int cnt; /* from the stdio struct and put EVERYTHING */
- register STDCHAR *ptr; /* in the innermost loop into registers */
- register char newline = '\n'; /* (assuming at least 6 registers) */
+ char *bp; /* we're going to steal some values */
+ int cnt; /* from the stdio struct and put EVERYTHING */
+ STDCHAR *ptr; /* in the innermost loop into registers */
+ char newline = '\n'; /* (assuming at least 6 registers) */
int i;
int bpx;
@@ -210,7 +210,7 @@
}
FILE_cnt(fp) = cnt; /* deregisterize cnt and ptr */
- FILE_ptr(fp) = (void*)ptr; /* LHS STDCHAR* cast non-portable */
+ FILE_ptr(fp) = ptr;
i = getc(fp); /* get more characters */
cnt = FILE_cnt(fp);
ptr = (STDCHAR*)FILE_ptr(fp); /* reregisterize cnt and ptr */
@@ -230,7 +230,7 @@
thats_all_folks:
FILE_cnt(fp) = cnt; /* put these back or we're in trouble */
- FILE_ptr(fp) = (void*)ptr; /* LHS STDCHAR* cast non-portable */
+ FILE_ptr(fp) = ptr;
*bp = '\0';
str->str_cur = bp - str->str_ptr; /* set length */
@@ -252,7 +252,7 @@
STR *
str_make(const char *s)
{
- register STR *str = str_new(0);
+ STR *str = str_new(0);
str_set(str,s);
return str;
Property changes on: trunk/contrib/perl/x2p/str.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/x2p/str.h
===================================================================
--- trunk/contrib/perl/x2p/str.h 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/x2p/str.h 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/x2p/str.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/x2p/util.c
===================================================================
--- trunk/contrib/perl/x2p/util.c 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/x2p/util.c 2013-12-02 21:26:09 UTC (rev 6439)
@@ -82,7 +82,7 @@
/* copy a string up to some (non-backslashed) delimiter, if any */
char *
-cpytill(register char *to, register char *from, register int delim)
+cpytill(char *to, char *from, int delim)
{
for (; *from; from++,to++) {
if (*from == '\\') {
@@ -101,7 +101,7 @@
char *
-cpy2(register char *to, register char *from, register int delim)
+cpy2(char *to, char *from, int delim)
{
for (; *from; from++,to++) {
if (*from == '\\')
@@ -121,8 +121,8 @@
char *
instr(char *big, const char *little)
{
- register char *t, *x;
- register const char *s;
+ char *t, *x;
+ const char *s;
for (t = big; *t; t++) {
for (x=t,s=little; *s; x++,s++) {
@@ -142,7 +142,7 @@
char *
savestr(const char *str)
{
- register char * const newaddr = (char *) safemalloc((MEM_SIZE)(strlen(str)+1));
+ char * const newaddr = (char *) safemalloc((MEM_SIZE)(strlen(str)+1));
(void)strcpy(newaddr,str);
return newaddr;
Property changes on: trunk/contrib/perl/x2p/util.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/x2p/util.h
===================================================================
--- trunk/contrib/perl/x2p/util.h 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/x2p/util.h 2013-12-02 21:26:09 UTC (rev 6439)
Property changes on: trunk/contrib/perl/x2p/util.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/x2p/walk.c
===================================================================
--- trunk/contrib/perl/x2p/walk.c 2013-12-02 21:18:17 UTC (rev 6438)
+++ trunk/contrib/perl/x2p/walk.c 2013-12-02 21:26:09 UTC (rev 6439)
@@ -35,18 +35,18 @@
STR * walk ( int useval, int level, int node, int *numericptr, int minprec );
#ifdef NETWARE
char *savestr(char *str);
-char *cpytill(register char *to, register char *from, register int delim);
+char *cpytill(char *to, char *from, int delim);
char *instr(char *big, const char *little);
#endif
STR *
-walk(int useval, int level, register int node, int *numericptr, int minprec)
+walk(int useval, int level, int node, int *numericptr, int minprec)
{
- register int len;
- register STR *str;
- register int type;
- register int i;
- register STR *tmpstr;
+ int len;
+ STR *str;
+ int type;
+ int i;
+ STR *tmpstr;
STR *tmp2str;
STR *tmp3str;
char *t;
@@ -69,7 +69,7 @@
if (namelist) {
while (isALPHA(*namelist)) {
for (d = tokenbuf,s=namelist;
- isALPHA(*s) || isDIGIT(*s) || *s == '_';
+ isWORDCHAR(*s);
*d++ = *s++) ;
*d = '\0';
while (*s && !isALPHA(*s)) s++;
@@ -584,7 +584,7 @@
*t &= 127;
if (isLOWER(*t))
*t = toUPPER(*t);
- if (!isALPHA(*t) && !isDIGIT(*t))
+ if (!isALPHANUMERIC(*t))
*t = '_';
}
if (!strchr(tokenbuf,'_'))
@@ -1112,7 +1112,7 @@
*t &= 127;
if (isLOWER(*t))
*t = toUPPER(*t);
- if (!isALPHA(*t) && !isDIGIT(*t))
+ if (!isALPHANUMERIC(*t))
*t = '_';
}
if (!strchr(tokenbuf,'_'))
@@ -1149,7 +1149,7 @@
*t &= 127;
if (isLOWER(*t))
*t = toUPPER(*t);
- if (!isALPHA(*t) && !isDIGIT(*t))
+ if (!isALPHANUMERIC(*t))
*t = '_';
}
if (!strchr(tokenbuf,'_'))
@@ -1420,7 +1420,7 @@
i = numarg;
if (i) {
t = s = tmpstr->str_ptr;
- while (isALPHA(*t) || isDIGIT(*t) || *t == '$' || *t == '_')
+ while (isWORDCHAR(*t) || *t == '$')
t++;
i = t - s;
if (i < 2)
@@ -1546,7 +1546,7 @@
}
static void
-tab(register STR *str, register int lvl)
+tab(STR *str, int lvl)
{
while (lvl > 1) {
str_cat(str,"\t");
@@ -1557,9 +1557,9 @@
}
static void
-fixtab(register STR *str, register int lvl)
+fixtab(STR *str, int lvl)
{
- register char *s;
+ char *s;
/* strip trailing white space */
@@ -1575,9 +1575,9 @@
}
static void
-addsemi(register STR *str)
+addsemi(STR *str)
{
- register char *s;
+ char *s;
s = str->str_ptr+str->str_cur - 1;
while (s >= str->str_ptr && (*s == ' ' || *s == '\t' || *s == '\n'))
@@ -1587,9 +1587,9 @@
}
static void
-emit_split(register STR *str, int level)
+emit_split(STR *str, int level)
{
- register int i;
+ int i;
if (split_to_array)
str_cat(str,"@Fld");
@@ -1620,11 +1620,11 @@
}
int
-prewalk(int numit, int level, register int node, int *numericptr)
+prewalk(int numit, int level, int node, int *numericptr)
{
- register int len;
- register int type;
- register int i;
+ int len;
+ int type;
+ int i;
int numarg;
int numeric = FALSE;
STR *tmpstr;
@@ -2037,10 +2037,10 @@
}
static void
-numericize(register int node)
+numericize(int node)
{
- register int len;
- register int type;
+ int len;
+ int type;
STR *tmpstr;
STR *tmp2str;
int numarg;
Property changes on: trunk/contrib/perl/x2p/walk.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
More information about the Midnightbsd-cvs
mailing list